Re: [Haskell-cafe] [BUG] Criterion is tied to x86 architecture

24 Sep 2021

      Thanks, it works now:
bmaxa@Branimirs-Air sort % ghc -O2 ms.hs
Loaded package environment from /Users/bmaxa/.ghc/aarch64-darwin-8.10.7/environments/default
[1 of 1] Compiling Main             ( ms.hs, ms.o )

ms.hs:23:44: warning: [-Wdeprecations]
    In the use of ‘bitSize’ (imported from Data.Bits):
    Deprecated: "Use 'bitSizeMaybe' or 'finiteBitSize' instead"
   |
23 | positiveLsdSort list = foldl step list [0..bitSize (head list)] where
   |                                            ^^^^^^^

ms.hs:27:29: warning: [-Wdeprecations]
    In the use of ‘bitSize’ (imported from Data.Bits):
    Deprecated: "Use 'bitSizeMaybe' or 'finiteBitSize' instead"
   |
27 | positiveMsdSort list = aux (bitSize (head list) - 1) list where
   |                             ^^^^^^^
Linking ms ...
bmaxa@Branimirs-Air sort % ./ms
list size 65536
+++ OK, passed 100 tests.
benchmarking msdSort/random
time                 109.4 ms   (108.4 ms .. 110.6 ms)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 107.2 ms   (106.2 ms .. 108.0 ms)
std dev              1.456 ms   (966.8 μs .. 2.248 ms)

benchmarking msdSort/sorted
time                 101.1 ms   (100.4 ms .. 102.3 ms)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 100.9 ms   (100.5 ms .. 101.2 ms)
std dev              550.8 μs   (418.0 μs .. 801.1 μs)

benchmarking msdSort/reverse sorted
time                 104.6 ms   (103.8 ms .. 106.2 ms)
                     1.000 R²   (0.999 R² .. 1.000 R²)
mean                 103.6 ms   (102.8 ms .. 104.2 ms)
std dev              1.134 ms   (861.7 μs .. 1.447 ms)

benchmarking lsdSort/random
time                 107.9 ms   (106.9 ms .. 109.0 ms)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 107.6 ms   (107.1 ms .. 108.1 ms)
std dev              765.3 μs   (406.2 μs .. 983.7 μs)

benchmarking lsdSort/sorted
time                 89.28 ms   (88.80 ms .. 89.99 ms)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 88.48 ms   (88.19 ms .. 88.79 ms)
std dev              513.3 μs   (427.9 μs .. 624.1 μs)

benchmarking lsdSort/reverse sorted
time                 89.04 ms   (88.02 ms .. 89.83 ms)
                     1.000 R²   (0.999 R² .. 1.000 R²)
mean                 89.26 ms   (88.85 ms .. 89.68 ms)
std dev              684.2 μs   (536.5 μs .. 851.6 μs)

benchmarking qsort/random
time                 18.90 ms   (18.76 ms .. 19.02 ms)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 18.91 ms   (18.83 ms .. 19.02 ms)
std dev              221.3 μs   (168.4 μs .. 321.8 μs)

benchmarking qsort/sorted
time                 13.27 ms   (13.15 ms .. 13.41 ms)
                     0.999 R²   (0.998 R² .. 1.000 R²)
mean                 13.33 ms   (13.23 ms .. 13.45 ms)
std dev              274.2 μs   (218.5 μs .. 358.7 μs)

benchmarking qsort/reverse sorted
time                 13.04 ms   (12.95 ms .. 13.13 ms)
                     1.000 R²   (0.999 R² .. 1.000 R²)
mean                 13.00 ms   (12.88 ms .. 13.08 ms)
std dev              274.5 μs   (188.5 μs .. 439.5 μs)

benchmarking sort/random
time                 46.24 ms   (45.99 ms .. 46.49 ms)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 46.08 ms   (45.76 ms .. 46.27 ms)
std dev              496.2 μs   (263.1 μs .. 851.3 μs)

benchmarking sort/sorted
time                 1.886 ms   (1.862 ms .. 1.907 ms)
                     0.998 R²   (0.997 R² .. 0.999 R²)
mean                 2.073 ms   (2.035 ms .. 2.115 ms)
std dev              139.7 μs   (122.6 μs .. 167.1 μs)
variance introduced by outliers: 49% (moderately inflated)

benchmarking sort/reverse sorted
time                 776.4 μs   (771.2 μs .. 781.4 μs)
                     0.999 R²   (0.999 R² .. 1.000 R²)
mean                 805.7 μs   (797.3 μs .. 817.1 μs)
std dev              33.20 μs   (26.90 μs .. 40.92 μs)
variance introduced by outliers: 32% (moderately inflated)

benchmarking msort/random
time                 59.61 ms   (58.73 ms .. 60.14 ms)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 58.98 ms   (58.16 ms .. 59.34 ms)
std dev              917.6 μs   (386.7 μs .. 1.670 ms)

benchmarking msort/sorted
time                 27.21 ms   (27.01 ms .. 27.45 ms)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 27.11 ms   (26.92 ms .. 27.24 ms)
std dev              325.1 μs   (225.9 μs .. 491.0 μs)

benchmarking msort/reverse sorted
time                 27.44 ms   (27.35 ms .. 27.60 ms)
                     1.000 R²   (1.000 R² .. 1.000 R²)
mean                 27.36 ms   (27.21 ms .. 27.42 ms)
std dev              200.6 μs   (72.91 μs .. 378.0 μs)

benchmarking rsort/random
time                 24.63 ms   (24.36 ms .. 24.95 ms)
                     1.000 R²   (0.999 R² .. 1.000 R²)
mean                 24.90 ms   (24.72 ms .. 25.33 ms)
std dev              542.9 μs   (274.7 μs .. 912.1 μs)

benchmarking rsort/sorted
time                 24.55 ms   (24.32 ms .. 24.80 ms)
                     1.000 R²   (0.999 R² .. 1.000 R²)
mean                 24.54 ms   (24.41 ms .. 24.82 ms)
std dev              408.0 μs   (206.4 μs .. 727.4 μs)

benchmarking rsort/reverse sorted
time                 24.67 ms   (24.44 ms .. 24.97 ms)
                     1.000 R²   (0.999 R² .. 1.000 R²)
mean                 24.38 ms   (24.27 ms .. 24.52 ms)
std dev              278.1 μs   (197.5 μs .. 388.4 μs)

[2,3,5,6,6,8,8,9,10,11]

bmaxa@Branimirs-Air sort % cat ms.hs
import Data.List
import qualified Test.QuickCheck as QC
import System.Random
import Criterion.Main
import Data.Bits
import qualified Data.Vector.Mutable as VM
import qualified Data.Vector as V
import Data.Word
import System.IO.Unsafe
import Data.Bits

lsdSort :: (Ord a, Bits a, Num a) => [a] -> [a]
lsdSort = fixSort positiveLsdSort

msdSort :: (Ord a, Bits a, Num a) => [a] -> [a]
msdSort = fixSort positiveMsdSort

-- Fix a sort that puts negative numbers at the end, like positiveLsdSort and positiveMsdSort
fixSort :: (Bits a, Ord a, Num a)=>([a]->[a]) -> [a] -> [a]
fixSort sorter list = uncurry (flip (++)) (break (< 0) (sorter list))

positiveLsdSort :: (Bits a) => [a] -> [a]
positiveLsdSort list = foldl step list [0..bitSize (head list)] where
    step list bit = uncurry (++) (partition (not . flip testBit bit) list)

positiveMsdSort :: (Bits a) => [a] -> [a]
positiveMsdSort list = aux (bitSize (head list) - 1) list where
    aux _ [] = []
    aux (-1) list = list
    aux bit list = aux (bit - 1) lower ++ aux (bit - 1) upper where
                  (lower, upper) = partition (not . flip testBit bit) list
msort :: Ord a =>[a] -> [a]
msort xs
  | n < 2 = xs
  | otherwise = merge (msort x1s) (msort x2s)
  where
    n = length xs
    (x1s,x2s) = splitAt (n`quot`2) xs
    merge xs ys = case (xs,ys) of
      ([], ys') -> ys'
      (xs', []) -> xs'
      (x:xs',y:ys') | x < y -> x : merge xs' ys
                    | otherwise -> y : merge xs ys'

isort :: Ord a => [a] -> [a]
isort xs = foldr insert [] xs
    where
        insert x [] = [x]
        insert x (y:ys) = if x [a] -> [a]
qsort [] = []
qsort [x] = [x]
qsort xs =
    let
        pivot = mot
        (x1s,x2s,pivots) = foldl (\(ys,zs,pivots) x->
                            if xpivot
                                 then (ys,x:zs,pivots)
                                 else (ys,zs,x:pivots)) ([],[],[]) xs
    in qsort x1s ++ pivots ++ qsort x2s
    where
          mot =
            let n = length xs
                (a,b,c) = (xs !! 0, (xs !! (n`quot`2)), xs !! (n-1))
            in if a>b
               then if a<c
                    then a
                    else if c>b
                         then c
                         else b
               else if b<c
                    then b
                    else if c>a
                         then c
                         else a

rsort :: [Word32] -> [Word32]
rsort xs = unsafePerformIO $ do
    let base = 16

        add_bucket :: Int -> Word32 -> VM.IOVector [Word32] -> VM.IOVector [Word32]
        add_bucket i n b = unsafePerformIO $ do
                        lst <- VM.read b i
                        VM.write b i (n:lst)
                        return b
        clear b = mapM_ (\i-> VM.write b i []) [0..base-1]
    bucket <- VM.replicate base [] :: IO (VM.IOVector [Word32])
    let loop = return $ foldl body xs [0..7]
            where
                body :: [Word32] -> Word32 -> [Word32]
                body nums n = unsafePerformIO $ do
                        v <- V.freeze (foldl disp bucket nums)
                        clear bucket
                        return $ V.foldr gather [] v
                    where
                        disp :: VM.IOVector [Word32]->Word32->VM.IOVector [Word32]
                        disp b val = add_bucket (fromIntegral ((val`shiftR`fromIntegral (n`shiftL`fromIntegral 2)).&.0xf)) val b
                        gather :: [Word32]->[Word32] -> [Word32]
                        gather b nums = foldl (\xs x->x:xs) nums b
    loop

prop_msort :: [Word32]->Bool
prop_msort xs = msort xs == sort xs && sort xs == isort xs && sort xs == qsort xs && sort xs == rsort xs &&
                lsdSort xs == sort xs && msdSort xs == sort xs

deepCheck p = QC.quickCheckWith (QC.stdArgs { QC.maxSize = 1000}) p

n :: Word32
n = 4096 * 16
tl :: [Word32]->[Word32]
tl = take (fromIntegral n)

main = do
    putStrLn $ "list size " ++ show n
    deepCheck prop_msort
    g <- getStdGen
    let rl = randomRs (0,n) g
    let (s,rs) = ([(0::Word32)..],[(n-1::Word32),n-2..])
    let rnd = tl rl
        srt = tl s
        rsrt = tl rs
    defaultMain [
        bgroup "msdSort" [
            bench "random"  $ nf msdSort rnd,
            bench "sorted"  $ nf msdSort srt,
            bench "reverse sorted"  $ nf msdSort rsrt
            ],
        bgroup "lsdSort" [
            bench "random"  $ nf lsdSort rnd,
            bench "sorted"  $ nf lsdSort srt,
            bench "reverse sorted"  $ nf lsdSort rsrt
            ],
        bgroup "qsort" [
            bench "random"  $ nf qsort rnd,
            bench "sorted"  $ nf qsort srt,
            bench "reverse sorted"  $ nf qsort rsrt
            ],
        bgroup "sort"  [
            bench "random" $ nf sort rnd,
            bench "sorted" $ nf sort srt,
            bench "reverse sorted" $ nf sort rsrt
            ],
        bgroup "msort" [
            bench "random" $ nf msort rnd,
            bench "sorted" $ nf msort srt,
            bench "reverse sorted" $ nf msort rsrt
            ],{-
        bgroup "isort" [
            bench "random" $ nf isort rnd,
            bench "sorted" $ nf isort srt,
            bench "reverse sorted" $ nf isort rsrt
            ],-}
        bgroup "rsort" [
            bench "random" $ nf rsort rnd,
            bench "sorted" $ nf rsort srt,
            bench "reverse sorted" $ nf rsort rsrt
            ]
        ]
    print $ take 10 $ rsort rnd

Greetings, Branimir.
...
On 18.09.2021., at 11:55, Jaro Reinders  wrote:
This issue: https://github.com/haskell/criterion/issues/238, makes it seem like this should be fixed with criterion-measurement-0.1.3.0. If that doesn't work then I suggest placing a comment or opening a new issue there.
Cheers,
Jaro
On 18-09-2021 11:24, Branimir Maksimovic wrote:
...
Problem as I work on Apple M1 processor, can’t compile
Criterion as it use x86 specific features.
Greetings, Branimir.
_______________________________________________
Haskell-Cafe mailing list
To (un)subscribe, modify options or view archives go to:
http://mail.haskell.org/cgi-bin/mailman/listinfo/haskell-cafe
Only members subscribed via the mailman list are allowed to post.

Haskell-Cafe mailing list
To (un)subscribe, modify options or view archives go to:
http://mail.haskell.org/cgi-bin/mailman/listinfo/haskell-cafe
Only members subscribed via the mailman list are allowed to post.