diff --git a/benchmarks/PPoPP2019/build.sh b/benchmarks/PPoPP2019/build.sh
new file mode 100755
index 0000000..e802daf
--- /dev/null
+++ b/benchmarks/PPoPP2019/build.sh
@@ -0,0 +1,141 @@
+#!/bin/bash
+
+set -e
+
+if [[ -z $GHC_COMPILERS ]]; then
+ GHC_COMPILERS=$HOME/ghc-8
+fi
+
+# Figure, Label , benchmark, compiler , code , htm options
+# -------------------------------------------------------------------------------
+# 1(a) , mut-hybrid , rbtree , hybrid , mut , (2,t)
+# 1(a) , tvar-hybrid , rbtree , hybrid , tvar , (2,t)
+# 1(a) , tstruct-hybrid , rbtree , hybrid , tstruct , (2,t)
+# 1(a) , mut-fine-hybrid , rbtree , fine , mut , (t,t)
+# 1(a) , tvar-fine , rbtree , fine , tvar , (t,t)
+# 1(a) , tstruct-fine-hybrid , rbtree , fine , tstruct , (t,t)
+# 1(a) , mut-fine , rbtree , fine , mut , (0,0)
+# 1(a) , tvar-fine , rbtree , fine , tvar , (0,0)
+# 1(a) , tstruct-fine , rbtree , fine , tstruct , (0,0)
+
+# 1(b) , mut-hybrid , hamt , hybrid , mut , (2,t)
+# 1(b) , tvar-hybrid , hamt , hybrid , tvar , (2,t)
+# 1(b) , tstruct-hybrid , hamt , hybrid , tstruct , (2,t)
+# 1(b) , mut-fine-hybrid , hamt , fine , mut , (t,t)
+# 1(b) , tvar-fine , hamt , fine , tvar , (t,t)
+# 1(b) , tstruct-fine-hybrid , hamt , fine , tstruct , (t,t)
+# 1(b) , mut-fine , hamt , fine , mut , (0,0)
+# 1(b) , tvar-fine , hamt , fine , tvar , (0,0)
+# 1(b) , tstruct-fine , hamt , fine , tstruct , (0,0)
+
+# 1(c) , mut-hybrid , treap , hybrid , mut , (2,t)
+# 1(c) , tvar-hybrid , treap , hybrid , tvar , (2,t)
+# 1(c) , mut-fine-hybrid , treap , fine , mut , (t,t)
+# 1(c) , tvar-fine , treap , fine , tvar , (t,t)
+# 1(c) , mut-fine , treap , fine , mut , (0,0)
+# 1(c) , tvar-fine , treap , fine , tvar , (0,0)
+
+# 2(a) , mut-hard , treap , hybrid , mut , (2,t)
+# 2(a) , tvar-hard , treap , hybrid , tvar , (2,t)
+# 2(a) , mut-fall , treap , hybrid , mut , (2,t)
+# 2(a) , tvar-fall , treap , hybrid , tvar , (2,t)
+# 2(a) , mut-lock , treap , hybrid , mut , (2,t)
+# 2(a) , tvar-lock , treap , hybrid , tvar , (2,t)
+
+# 2(b) , hamt-late , hamt , hybrid , mut , (2,t)
+# 2(b) , hamt-early , hamt , hybrid-early , mut , (2,t)
+# 2(b) , rbtree-late , rbtree , hybrid , mut , (2,t)
+# 2(b) , rbtree-early , rbtree , hybrid-early , mut , (2,t)
+# 2(b) , treap-late , treap , hybrid , mut , (2,t)
+# 2(b) , treap-early , treap , hybrid-early , mut , (2,t)
+
+# 2(c) , (2,t) , treap , hybrid , mut , (2,t)
+# 2(c) , (t,t) , treap , hybrid , mut , (t,t)
+# 2(c) , (2,2) , treap , hybrid , mut , (2,2)
+# 2(c) , (2,0) , treap , hybrid , mut , (2,0)
+
+# Compiler versions:
+# hybrid -- supports:
+# - full hybrid (2,t), (t,t), (2,2)
+# - lock-elision on fallback lock (0,t), (0,2)
+# - coarse-grain STM (0,0)
+# - late lock subscription
+# hybrid-lock -- Same as hybrid, but with early lock subscription.
+# fine -- supports:
+# - fine hybrid (t,t) (htm used for the commit of the fine-grain TM)
+# - fine-grain STM (0,0) (equivalant to main branch of GHC when used with TVar code)
+#
+# All versions support mutable-fields extensions.
+
+# Code variations:
+# mut -- Mutable fields.
+# tvar -- TVar-based (equivalant to main branch of GHC).
+# tstruct -- TStruct-based code.
+
+deps="-isrc/focus-0.1.5.2/library"
+deps="$deps -isrc/hashable-1.2.6.1"
+deps="$deps -isrc/base-prelude-1.2.0.1/library"
+deps="$deps -isrc/loch-th-0.2.1"
+deps="$deps -isrc/primitive-0.6.3.0"
+deps="$deps -isrc/transformers-base-0.4.4/src"
+deps="$deps -isrc/transformers-compat-0.5.1.4/src"
+deps="$deps -isrc/entropy-0.4"
+
+flags=""
+flags="$flags -XBangPatterns"
+flags="$flags -XConstraintKinds"
+flags="$flags -XDataKinds"
+flags="$flags -XDefaultSignatures"
+flags="$flags -XDeriveDataTypeable"
+flags="$flags -XDeriveFunctor"
+flags="$flags -XDeriveGeneric"
+flags="$flags -XEmptyDataDecls"
+flags="$flags -XFlexibleContexts"
+flags="$flags -XFlexibleInstances"
+flags="$flags -XFunctionalDependencies"
+flags="$flags -XGADTs"
+flags="$flags -XGeneralizedNewtypeDeriving"
+flags="$flags -XLambdaCase"
+flags="$flags -XMultiParamTypeClasses"
+flags="$flags -XMultiWayIf"
+flags="$flags -XNoMonomorphismRestriction"
+flags="$flags -XPatternGuards"
+flags="$flags -XPolyKinds"
+flags="$flags -XQuasiQuotes"
+flags="$flags -XRankNTypes"
+flags="$flags -XStandaloneDeriving"
+flags="$flags -XTemplateHaskell"
+flags="$flags -XTupleSections"
+flags="$flags -XTypeFamilies"
+flags="$flags -XTypeOperators"
+
+cbits="src/cbits/gettime.c"
+cbits="$cbits src/hashable-1.2.6.1/cbits/fnv.c"
+cbits="$cbits src/entropy-0.4/cbits/rdrand.c"
+cbits="$cbits src/primitive-0.6.3.0/cbits/primitive-memops.c"
+
+for compiler in hybrid hybrid-early fine; do
+ ghc=$GHC_COMPILERS/$compiler/bin/ghc
+ for bench in RBTREE HAMT TREAP; do
+ for code in MUT TVAR TSTRUCT; do
+ if [ "$bench" == "RBTREE" ]; then
+ a=""
+ elif [ "$bench" == "HAMT" ]; then
+ a=""
+ elif [ "$bench" == "TREAP" ]; then
+ if [ "$code" == "TSTRUCT" ]; then
+ continue
+ fi
+ fi
+
+ n=$bench-$code-$compiler
+ opts="-O2 -rtsopts -threaded -fno-omit-yields -msse4.2 $flags"
+ buildopts="-no-user-package-db -outputdir .build-$n -isrc $deps"
+ cppflags="-DBYTECOUNTER -D$bench -D$code"
+ ccflags="--optc='-O2'"
+
+ echo $ghc src/Main.hs -o bin/$n $cppflags
+ $ghc src/Main.hs $cbits $opts $buildopts -o bin/$n $cppflags
+ done
+ done
+done
diff --git a/benchmarks/PPoPP2019/clean.sh b/benchmarks/PPoPP2019/clean.sh
new file mode 100755
index 0000000..6031218
--- /dev/null
+++ b/benchmarks/PPoPP2019/clean.sh
@@ -0,0 +1,5 @@
+#!/bin/bash
+
+set -e
+
+rm -rf .build-*
diff --git a/benchmarks/PPoPP2019/fig-1.sh b/benchmarks/PPoPP2019/fig-1.sh
new file mode 100755
index 0000000..84f15fb
--- /dev/null
+++ b/benchmarks/PPoPP2019/fig-1.sh
@@ -0,0 +1,78 @@
+#!/bin/bash
+
+set -e
+
+if [[ -z $GHC_COMPILERS ]]; then
+ GHC_COMPILERS=$HOME/ghc-8
+fi
+
+run=$GHC_COMPILERS/hybrid/bin/runhaskell
+
+if [[ ! -x $run ]]; then
+ echo "Did not find ghc here: $run"
+ echo "GHC_COMPILERS=$GHC_COMPILERS"
+ echo "Check that GHC_COMPILERS points to the right place."
+ exit 1
+fi
+
+N=`nproc`
+
+n=100000
+m=90
+q=-qatopo-cores-sockets-threads-$N
+s=1000
+
+function threads()
+{
+ if [[ $1 == "t" ]]; then
+ if [[ $2 -le 10 ]]; then
+ count=10
+ else
+ count=$2
+ fi
+ else
+ count=$1
+ fi
+}
+
+# mut-hybrid RBTREE HYBRID MUT 2 t
+function doBenchmark()
+{
+ label=$1
+ bench=$2
+ compiler=$3
+ code=$4
+ htm=$5
+ hle=$6
+
+ name=$bench-$code-$compiler
+ exe=./bin/$name
+ log="logs/$bench-$label.log"
+ logs="$logs $log"
+ echo "Benchmarking $name."
+ rm -f "$log" &> /dev/null
+
+ for t in `seq 1 $N`; do
+ threads $htm $t
+ thtm=$count
+ threads $hle $t
+ thle=$count
+ retry="--htm-retry=$thtm --hle-retry=$thle"
+ cmd="$exe -e $n -t $t -m $m -s $s +RTS --stm-stats $q -N$t -ki4k -kc64k -kb4k -A1m $retry"
+ echo $cmd
+ echo "command: $cmd" &>> $log
+ $cmd &>> $log
+ done
+}
+
+for p in a b c; do
+ logs=""
+ input="fig-1$p.txt"
+ while IFS= read -r var
+ do
+ doBenchmark $var
+ done < "$input"
+
+ $run plot.hs "Figure 1($p)" "output/fig-1$p.html" $logs
+done
+
diff --git a/benchmarks/PPoPP2019/fig-2a.sh b/benchmarks/PPoPP2019/fig-2a.sh
new file mode 100755
index 0000000..f7197c5
--- /dev/null
+++ b/benchmarks/PPoPP2019/fig-2a.sh
@@ -0,0 +1,71 @@
+#!/bin/bash
+
+set -e
+
+if [[ -z $GHC_COMPILERS ]]; then
+ GHC_COMPILERS=$HOME/ghc-8
+fi
+
+run=$GHC_COMPILERS/hybrid/bin/runhaskell
+
+N=`nproc`
+
+n=100000
+m=90
+q=-qatopo-cores-sockets-threads-$N
+s=1000
+
+function threads()
+{
+ if [[ $1 == "t" ]]; then
+ if [[ $2 -le 10 ]]; then
+ count=10
+ else
+ count=$2
+ fi
+ else
+ count=$1
+ fi
+}
+
+# mut-hybrid RBTREE HYBRID MUT 2 t
+function doBenchmark()
+{
+ label=$1
+ bench=$2
+ compiler=$3
+ code=$4
+ htm=$5
+ hle=$6
+
+ name=$bench-$code-$compiler
+ exe=./bin/$name
+ log="logs/$bench-$label.log"
+ logs="$logs $log"
+ echo "Benchmarking $name."
+ rm -f "$log" &> /dev/null
+
+ for t in `seq 1 $N`; do
+ threads $htm $t
+ thtm=$count
+ threads $hle $t
+ thle=$count
+ retry="--htm-retry=$thtm --hle-retry=$thle"
+ cmd="$exe -e $n -t $t -m $m -s $s +RTS --stm-stats $q -N$t -ki4k -kc64k -kb4k -A1m $retry"
+ echo $cmd
+ $cmd &>> $log
+ echo "command: $cmd" &>> $log
+ done
+}
+
+for p in a; do
+ logs=""
+ input="fig-2$p.txt"
+ while IFS= read -r var
+ do
+ doBenchmark $var
+ done < "$input"
+
+ $run plot-stats.hs "Figure 2($p)" "output/fig-2$p.html" $logs
+done
+
diff --git a/benchmarks/PPoPP2019/fig-2bc.sh b/benchmarks/PPoPP2019/fig-2bc.sh
new file mode 100755
index 0000000..8044f15
--- /dev/null
+++ b/benchmarks/PPoPP2019/fig-2bc.sh
@@ -0,0 +1,71 @@
+#!/bin/bash
+
+set -e
+
+if [[ -z $GHC_COMPILERS ]]; then
+ GHC_COMPILERS=$HOME/ghc-8
+fi
+
+run=$GHC_COMPILERS/hybrid/bin/runhaskell
+
+N=`nproc`
+
+n=100000
+m=90
+q=-qatopo-cores-sockets-threads-$N
+s=1000
+
+function threads()
+{
+ if [[ $1 == "t" ]]; then
+ if [[ $2 -le 10 ]]; then
+ count=10
+ else
+ count=$2
+ fi
+ else
+ count=$1
+ fi
+}
+
+# mut-hybrid RBTREE HYBRID MUT 2 t
+function doBenchmark()
+{
+ label=$1
+ bench=$2
+ compiler=$3
+ code=$4
+ htm=$5
+ hle=$6
+
+ name=$bench-$code-$compiler
+ exe=./bin/$name
+ log="logs/$bench-$label.log"
+ logs="$logs $log"
+ echo "Benchmarking $name."
+ rm -f "$log" &> /dev/null
+
+ for t in `seq 1 $N`; do
+ threads $htm $t
+ thtm=$count
+ threads $hle $t
+ thle=$count
+ retry="--htm-retry=$thtm --hle-retry=$thle"
+ cmd="$exe -e $n -t $t -m $m -s $s +RTS --stm-stats $q -N$t -ki4k -kc64k -kb4k -A1m $retry"
+ echo $cmd
+ $cmd &>> $log
+ echo "command: $cmd" &>> $log
+ done
+}
+
+for p in b c; do
+ logs=""
+ input="fig-2$p.txt"
+ while IFS= read -r var
+ do
+ doBenchmark $var
+ done < "$input"
+
+ $run plot.hs "Figure 2($p)" "output/fig-2$p.html" $logs
+done
+
diff --git a/benchmarks/PPoPP2019/mktopo.hs b/benchmarks/PPoPP2019/mktopo.hs
new file mode 100644
index 0000000..bbefe9f
--- /dev/null
+++ b/benchmarks/PPoPP2019/mktopo.hs
@@ -0,0 +1,45 @@
+import System.Environment
+import Data.List
+
+asT vs = "(" ++ intercalate "," vs ++ ")"
+
+tcs nt nc ns = [ s
+ | c <- map transpose ts
+ , t <- c
+ , s <- t
+ ]
+ where
+ n = nt * nc * ns
+ ts = chunksOf nc . chunksOf nt $ [0..n-1]
+
+chunksOf :: Int -> [a] -> [[a]]
+chunksOf n [] = []
+chunksOf n vs = take n vs : chunksOf n (drop n vs)
+
+
+main = do
+ as <- getArgs
+ case as of
+ [a,b,c] | [((t,c,s), [])] <- reads (asT [a,b,c]) -> mapM_ print (tcs t c s)
+ _ -> mapM_ putStrLn $
+ [ "Unknown input: " ++ show as
+ , "Usage: mktopo THREADS CORES SOCKETS"
+ , " Print thread assignment filling cores on each socket first, than"
+ , " hyperthreads on each core."
+ , " The arguments are threads per core, cores per socket, and total sockets."
+ , " This assumes a particular ordering that may not be correct for"
+ , " a particular OS and architecture."
+ ]
+
+-- The existing files are produced with the following arguments:
+-- $GHC_COMPILERS/hybrid/bin/runhaskell mktopo.hs 2 4 1 > topo-cores-sockets-threads-8
+-- $GHC_COMPILERS/hybrid/bin/runhaskell mktopo.hs 2 6 1 > topo-cores-sockets-threads-12
+-- $GHC_COMPILERS/hybrid/bin/runhaskell mktopo.hs 2 10 1 > topo-cores-sockets-threads-20
+-- $GHC_COMPILERS/hybrid/bin/runhaskell mktopo.hs 2 12 1 > topo-cores-sockets-threads-24
+-- $GHC_COMPILERS/hybrid/bin/runhaskell mktopo.hs 2 16 1 > topo-cores-sockets-threads-32
+-- $GHC_COMPILERS/hybrid/bin/runhaskell mktopo.hs 2 18 1 > topo-cores-sockets-threads-34
+-- $GHC_COMPILERS/hybrid/bin/runhaskell mktopo.hs 2 10 2 > topo-cores-sockets-threads-40
+-- $GHC_COMPILERS/hybrid/bin/runhaskell mktopo.hs 2 12 2 > topo-cores-sockets-threads-48
+-- $GHC_COMPILERS/hybrid/bin/runhaskell mktopo.hs 2 16 2 > topo-cores-sockets-threads-64
+-- $GHC_COMPILERS/hybrid/bin/runhaskell mktopo.hs 2 18 2 > topo-cores-sockets-threads-72
+
diff --git a/benchmarks/PPoPP2019/plot-stats.hs b/benchmarks/PPoPP2019/plot-stats.hs
new file mode 100644
index 0000000..2e79755
--- /dev/null
+++ b/benchmarks/PPoPP2019/plot-stats.hs
@@ -0,0 +1,131 @@
+import System.Environment
+import Data.List
+import Control.Monad
+import qualified Data.Map as M
+
+-- In line before "HTM stats:"
+-- Starts, column 0
+-- HTM-commit, column 6
+-- STM-commit, column 5
+--
+-- In line before "Heap stats:"
+-- HTM-fallback, column 0
+-- HLE-fallback, column 5
+
+readLog :: Bool -> FilePath -> IO [[String]]
+readLog threads log = do
+ ss <- findStats . lines <$> readFile log
+ let rs = map rates ss
+ let hs = map (log++) ["-full", "-fall", "-lock"]
+ return $ (if threads then "Threads":hs else hs)
+ : [ if threads then show t:vs else vs
+ | (t, R full fall lock) <- zip [1..] rs
+ , let vs = map show [full, fall, lock]
+ ]
+
+data Stats = S
+ { starts :: Int
+ , stmCommit :: Int
+ , htmCommit :: Int
+ , htmFallback :: Int
+ , hleFallback :: Int
+ } deriving (Show)
+
+read' s = case reads (filter (/= ',') s) of
+ [(v, [])] -> v
+ _ -> error $ "Can't read: " ++ s
+
+findStats :: [String] -> [Stats]
+findStats ls = go ls empty
+ where
+ empty = S 0 0 0 0 0
+ go [] _ = []
+ go (l:"HTM stats:": ls) s =
+ let ws = words l
+ in go ls s { starts = read' (ws !! 0)
+ , stmCommit = read' (ws !! 5)
+ , htmCommit = read' (ws !! 6)
+ }
+ go (l:"Heap stats:":ls) s =
+ let ws = words l
+ in s { htmFallback = read' (ws !! 0)
+ , hleFallback = read' (ws !! 5)
+ } : go ls empty
+ go (_:ls) s = go ls s
+
+data Rates =
+ R { full :: Double
+ , fall :: Double
+ , lock :: Double
+ } deriving (Show)
+
+hwFullCommit s =
+ let a = fromIntegral $ starts s
+ b = fromIntegral $ htmFallback s
+ in a - b
+
+hwFallbackCommit s =
+ let a = fromIntegral $ htmCommit s
+ b = hwFullCommit s
+ in a - b
+
+rates s =
+ let rate a b = if b == 0 then 0 else a / b
+ aFull = hwFullCommit s
+ bFull = fromIntegral $ starts s
+ aFall = hwFallbackCommit s
+ bFall = fromIntegral $ htmFallback s
+ aLock = fromIntegral $ stmCommit s
+ bLock = fromIntegral $ hleFallback s
+ in R { full = rate aFull bFull
+ , fall = rate aFall bFall
+ , lock = rate aLock bLock
+ }
+
+getTicks :: [[String]] -> [Int]
+getTicks (_:rs) = ticks
+ where
+ (ts:_) = transpose rs
+ m = maximum $ map read ts
+
+ ticks
+ | m <= 16 = [1..m]
+ | otherwise = [1, m `div` 4, m `div` 2, 3*(m `div` 4), m]
+
+colPlus :: [[a]] -> [[a]] -> [[a]]
+colPlus as bs = transpose (transpose as ++ transpose bs)
+
+formatColumns :: [[String]] -> String
+formatColumns rs = unlines rs'
+ where
+ cs = transpose rs
+ ls = map (succ . maximum . map length) cs
+
+ pad s l = go s (l - length s)
+
+ go s 0 = s
+ go s l = ' ' : go s (l - 1)
+
+ rs' = map concat . transpose . zipWith (\l c -> map (flip pad l) c) ls $ cs
+
+applyTemplate :: FilePath -> FilePath -> M.Map String String -> IO ()
+applyTemplate input output m = do
+ ls <- lines <$> readFile input
+ let os = map apply ls
+ writeFile output (unlines os)
+ where
+ apply l
+ | "$$$" `isPrefixOf` l
+ , [_, n] <- words l
+ , Just v <- n `M.lookup` m = v
+ | otherwise = l
+
+main :: IO ()
+main = do
+ (t:out:as) <- getArgs
+ cs <- foldl1 colPlus <$> zipWithM readLog (True:repeat False) as
+ let d = formatColumns cs
+ ticks = "var ticks = " ++ show (getTicks cs)
+
+ applyTemplate "plot/plot-stats.html.template" out
+ (M.fromList [("title", t), ("data", d), ("ticks", ticks)])
diff --git a/benchmarks/PPoPP2019/plot.hs b/benchmarks/PPoPP2019/plot.hs
new file mode 100644
index 0000000..3f55628
--- /dev/null
+++ b/benchmarks/PPoPP2019/plot.hs
@@ -0,0 +1,70 @@
+import System.Environment
+import Data.List
+import Control.Monad
+import qualified Data.Map as M
+
+-- benchdata: run-time 1.0047227869945345 no-kill-time 1.0047204369911924 transactions 1727020 prog RBTREE-MUT-hybrid threads 1 entries 100000 code RBTreeMutUSTM
+readLog :: Bool -> FilePath -> IO [[String]]
+readLog threads log = do
+ ls <- map words . filter ("benchdata:" `isPrefixOf`) . lines <$> readFile log
+ return $ (if threads then ["Threads", log] else [log])
+ : [ if threads then [t, show v] else [show v]
+ | [_,_,s,_,_,_,n,_,_,_,t,_,_,_,_] <- ls
+ , let v = read n / read s
+ ]
+
+getMaxY :: [[String]] -> Double
+getMaxY (_:rs) = maximum . map read . concat $ rs
+
+getY0 :: [[String]] -> Double
+getY0 (_:r1:rs) = maximum . map read $ r1
+
+getTicks :: [[String]] -> [Int]
+getTicks (_:rs) = ticks
+ where
+ (ts:_) = transpose rs
+ m = maximum $ map read ts
+
+ ticks
+ | m <= 16 = [1..m]
+ | otherwise = [1, m `div` 4, m `div` 2, 3*(m `div` 4), m]
+
+colPlus :: [[a]] -> [[a]] -> [[a]]
+colPlus as bs = transpose (transpose as ++ transpose bs)
+
+formatColumns :: [[String]] -> String
+formatColumns rs = unlines rs'
+ where
+ cs = transpose rs
+ ls = map (succ . maximum . map length) cs
+
+ pad s l = go s (l - length s)
+
+ go s 0 = s
+ go s l = ' ' : go s (l - 1)
+
+ rs' = map concat . transpose . zipWith (\l c -> map (flip pad l) c) ls $ cs
+
+applyTemplate :: FilePath -> FilePath -> M.Map String String -> IO ()
+applyTemplate input output m = do
+ ls <- lines <$> readFile input
+ let os = map apply ls
+ writeFile output (unlines os)
+ where
+ apply l
+ | "$$$" `isPrefixOf` l
+ , [_, n] <- words l
+ , Just v <- n `M.lookup` m = v
+ | otherwise = l
+
+main :: IO ()
+main = do
+ (t:out:as) <- getArgs
+ cs <- foldl1 colPlus <$> zipWithM readLog (True:repeat False) as
+ let d = formatColumns cs
+ maxY = "var maxY = " ++ show (getMaxY cs)
+ y0 = "var y0 = " ++ show (getY0 cs)
+ ticks = "var ticks = " ++ show (getTicks cs)
+
+ applyTemplate "plot/plot.html.template" out
+ (M.fromList [("title", t), ("data", d), ("maxY", maxY), ("y0", y0), ("ticks", ticks)])
diff --git a/benchmarks/PPoPP2019/plot/plot-stats.html.template b/benchmarks/PPoPP2019/plot/plot-stats.html.template
new file mode 100644
index 0000000..e32643a
--- /dev/null
+++ b/benchmarks/PPoPP2019/plot/plot-stats.html.template
@@ -0,0 +1,303 @@
+
+
+
+
+ Data Explorer
+
+
+
+
+
+
+
+
+
+
+
diff --git a/benchmarks/PPoPP2019/plot/plot.html.template b/benchmarks/PPoPP2019/plot/plot.html.template
new file mode 100644
index 0000000..df9b454
--- /dev/null
+++ b/benchmarks/PPoPP2019/plot/plot.html.template
@@ -0,0 +1,310 @@
+
+
+
+
+ Data Explorer
+
+
+
+
+
+
+
+
+
+
+
diff --git a/benchmarks/PPoPP2019/src/Hamt.hs b/benchmarks/PPoPP2019/src/Hamt.hs
new file mode 100644
index 0000000..464b15d
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/Hamt.hs
@@ -0,0 +1,117 @@
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE CPP #-}
+module Hamt
+ ( Tree
+ , mkTree
+
+ , benchCode
+
+ , insert
+ , delete
+ , update
+ , get
+ , contains
+
+ , insertTest
+ , deleteTest
+ ) where
+
+#ifdef TSTRUCT
+import qualified HamtTStruct as M
+#elif defined(MUT)
+import qualified HamtTRef as M
+#elif defined(TVAR)
+import qualified STMContainers.Map as M
+#else
+#error Unsupported HAMT code variation
+#endif
+import GHC.Conc.Sync
+import Control.Applicative
+import Control.Monad (forM_)
+import Data.Maybe
+import Data.Word
+import Data.List (inits,tails)
+
+#ifdef TSTRUCT
+benchCode :: String
+benchCode = "HAMTTStruct"
+#elif defined(MUT)
+benchCode :: String
+benchCode = "HAMTTRef"
+#else
+benchCode :: String
+benchCode = "STMTrieTVar"
+#endif
+
+type Tree = M.Map Word Word
+----------------------------------
+-- Public API
+--
+mkTree :: STM Tree
+mkTree = M.new
+
+insert :: Tree -> Word -> Word -> STM Bool
+#if defined(TSTRUCT) || defined(MUT)
+insert t k v = M.insert k v t >> return False
+#else
+insert t k v = M.insert v k t >> return False
+#endif
+
+delete :: Tree -> Word -> STM Bool
+delete t k = M.delete k t >> return False
+
+update :: Tree -> Word -> Word -> STM Bool
+update t k v = insert t k v
+
+get :: Tree -> Word -> STM (Maybe Word)
+get t k = M.lookup k t
+
+contains :: Tree -> Word -> STM Bool
+contains t k = isJust <$> get t k
+
+insertTest :: [Word] -> IO ()
+insertTest as = do
+ r <- atomically $ mkTree
+ forM_ (zip3 as (tail (inits as)) (tail (tails as))) $ \(a,is,ts) -> do
+ atomically $ insert r a a
+
+ forM_ is $ \i -> do
+ m <- atomically $ get r i
+ case m of
+ Nothing -> print (i, "not found.")
+ Just i' -> if i == i'
+ then return ()
+ else print (i, i', "Unmatched!")
+
+ forM_ ts $ \i -> do
+ m <- atomically $ get r i
+ case m of
+ Nothing -> return ()
+ Just i' -> print (i, i', "Unexpected!")
+
+
+
+deleteTest :: [Word] -> IO ()
+deleteTest as = do
+ r <- atomically $ mkTree
+ forM_ as $ \a -> do
+ atomically $ insert r a a
+
+ forM_ (zip3 as (tail (inits as)) (tail (tails as))) $ \(a,is,ts) -> do
+ atomically $ delete r a
+ putStrLn $ "Deleting " ++ show a
+ -- putStrLn $ " out " ++ show is ++ " in " ++ show ts
+
+ forM_ is $ \i -> do
+ m <- atomically $ get r i
+ case m of
+ Nothing -> return ()
+ Just i' -> print (i, i', "Unexpected!")
+
+ forM_ ts $ \i -> do
+ m <- atomically $ get r i
+ case m of
+ Nothing -> print (i, "not found.")
+ Just i' -> if i == i'
+ then return ()
+ else print (i, i', "Unmatched!")
diff --git a/benchmarks/PPoPP2019/src/HamtTRef.hs b/benchmarks/PPoPP2019/src/HamtTRef.hs
new file mode 100644
index 0000000..8d923e5
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/HamtTRef.hs
@@ -0,0 +1,540 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE MutableFields #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE UnboxedTuples #-}
+module HamtTRef where
+
+import Prelude hiding (lookup)
+
+import Numeric
+
+import GHC.Num
+import GHC.ST
+import GHC.Base hiding (assert)
+import GHC.Conc
+import GHC.Word
+import GHC.Prim
+
+import System.IO.Unsafe (unsafePerformIO)
+
+import Data.List (nub)
+
+-- import Prelude (Maybe(..), pred, succ, (=<<), ($!), snd, unlines)
+
+import qualified STMContainers.WordArray.Indices as Indices
+import qualified STMContainers.HAMT.Level as Level
+
+import Data.Hashable
+import Control.Monad (forM_, forM)
+import Control.Applicative ((<$>))
+
+-- In original HAMT the Node type has three constructors:
+--
+-- data Node = Nodes (WordArray (Node e))
+-- | Leaf Hash e
+-- | Leaves Hash (SizedArray e)
+--
+-- If we collapse leaf and leaves:
+--
+-- data Node = Nodes (WordArray (Node e))
+-- | Leaves Hash (SizedArray e)
+--
+-- Now represent both of these with an STMMutableArray# version of the following:
+--
+-- data Nodes = Nodes Indices [Nodes e]
+-- data Leaves = Leaves Hash [e]
+--
+-- In the monomorphic unboxed case Leaves stores everything in words while Nodes
+-- always has pointers. We can use a word for the tag bit and represent both with
+-- a STMMutableArray#. The tag bit would be read-only so we can cheat in STM
+-- and do a non-transactional read:
+--
+-- struct Nodes
+-- {
+-- halfword sizeWords;
+-- halfword sizePtrs;
+--
+-- word tag;
+-- word indices;
+-- Nodes* nodes[];
+-- }
+--
+-- struct Leaves
+-- {
+-- halfword sizeWords;
+-- halfword sizePtrs;
+--
+-- word tag;
+-- word Hash;
+-- word words[];
+-- }
+--
+-- We will assume word sized keys and heap object values are being stored (to match the
+-- original).
+--
+
+newtype Map k v = Map { unMap :: TVar (Node (k,v)) }
+
+type Key a = (Eq a, Hashable a)
+type Hash = Int
+
+class (Eq (ElementKey e)) => Element e where
+ type ElementKey e
+ elementKey :: e -> ElementKey e
+
+instance (Eq k) => Element (k, v) where
+ type ElementKey (k, v) = k
+ elementKey (k, v) = k
+
+data Node e where
+-- TODO: fix this. Right now the wrapper gets the type Int# -> Int# -> ...
+ Nodes :: {-# UNPACK #-} !Indices -> mutableArray (Node e) -> STM (Node e)
+ Leaves :: {-# UNPACK #-} !Hash -> mutableArray e -> STM (Node e)
+-- Nodes :: Indices -> mutableArray (Node e) -> STM (Node e)
+-- Leaves :: Hash -> mutableArray e -> STM (Node e)
+ Deleted :: Node e
+
+instance Eq (Node e) where
+ Deleted == Deleted = True
+ _ == Deleted = False
+ Deleted == _ = False
+ a == a' =
+ case sameSTMMutableArray# (unsafeCoerce# a) (unsafeCoerce# a') of
+ 0# -> False
+ _ -> True
+
+type Index = Int
+type Indices = Int
+
+---------------------------------------------------
+-- Array operations
+
+{-# INLINE refArraySize #-}
+refArraySize :: RefArray# RealWorld e -> Int
+refArraySize r =
+ case refArraySize# r of
+ i# -> I# i#
+
+type DataArray e = RefArray# RealWorld e
+type NodeArray e = RefArray# RealWorld (Node e)
+
+{-# INLINE readDataP #-}
+readDataP :: DataArray e -> Int -> STM e
+readDataP arr (I# i#) = STM $ \s1# -> readRefArrayExt# arr i# s1#
+
+{-# INLINE writeDataP #-}
+writeDataP :: DataArray e -> Int -> e -> STM ()
+writeDataP arr (I# i#) e = STM $ \s1# ->
+ case writeRefArrayExt# arr i# e s1# of
+ s2# -> (# s2#, () #)
+
+{-# INLINE writeNodesDataP #-}
+writeNodesDataP :: NodeArray e -> Int -> Node e -> STM ()
+writeNodesDataP arr (I# i#) e = STM $ \s1# ->
+ case writeRefArrayExt# arr i# e s1# of
+ s2# -> (# s2#, () #)
+
+{-# INLINE readNodesData #-}
+readNodesData :: NodeArray e -> Int -> STM (Node e)
+readNodesData arr (I# i#) = STM $ \s1# -> readTRefArray# arr i# s1#
+
+{-# INLINE readData #-}
+readData :: DataArray e -> Int -> STM e
+readData arr (I# i#) = STM $ \s# -> readTRefArray# arr i# s#
+
+{-# INLINE writeData #-}
+writeData :: DataArray e -> Int -> e -> STM ()
+writeData arr (I# i#) e = STM $ \s1# ->
+ case writeTRefArray# arr i# e s1# of
+ s2# -> (# s2#, () #)
+
+{-# INLINE writeNodesData #-}
+writeNodesData :: NodeArray e -> Int -> Node e -> STM ()
+writeNodesData arr (I# i#) e = STM $ \s1# ->
+ case writeTRefArray# arr i# e s1# of
+ s2# -> (# s2#, () #)
+
+{-# INLINE mkNodes #-}
+mkNodes :: Indices -> Int -> STM (Node e)
+mkNodes i (I# sz#) = Nodes i sz#
+
+{-# INLINE mkLeaves #-}
+mkLeaves :: Hash -> Int -> STM (Node e)
+mkLeaves h (I# sz#) = Leaves h sz#
+
+---------------------------------------------------
+-- Operations
+--
+
+lookupLevel :: Element e => Hash -> ElementKey e -> Level.Level -> Node e -> STM (Maybe e)
+lookupLevel h k l (Nodes b ns) = do
+ let i = Level.hashIndex l h
+ if Indices.elem i b
+ then readNodesData ns (Indices.position i b) >>= lookupLevel h k (Level.succ l)
+ else return Nothing
+lookupLevel h k l (Leaves h' vs)
+ | h == h' = do
+ let sz = refArraySize vs
+ find i
+ | i >= sz = return Nothing
+ | otherwise = do
+ e <- readData vs i
+ if elementKey e == k
+ then return $! Just e
+ else find (i+1)
+ find 0
+ | otherwise = return Nothing
+lookupLevel _ _ _ Deleted = return Nothing
+
+{-# INLINE set #-}
+set :: Index -> Node e -> Node e -> STM (Node e)
+set i e a@(Nodes b ns) = do
+ let sparseIndex = Indices.position i b
+ size = Indices.size b
+
+ if Indices.elem i b
+ then writeNodesData ns sparseIndex e >> return a
+ else do
+ a'@(Nodes _ ns') <- mkNodes (Indices.insert i b) (size+1)
+ forM_ [0..sparseIndex-1] $ \i -> readNodesData ns i >>= writeNodesDataP ns' i
+ writeNodesDataP ns' sparseIndex e
+ forM_ [sparseIndex..(size-1)] $ \i -> readNodesData ns i >>= writeNodesDataP ns' (i+1)
+ return a'
+set _ _ _ = error "set on non Nodes"
+
+{-# INLINE unset #-}
+unset :: Index -> Node e -> STM (Node e)
+unset i a@(Nodes b ns) = do
+ -- TODO: handling a Nodes that goes to one element.
+ if Indices.elem i b
+ then do
+ let b' = Indices.invert i b
+ size = Indices.size b
+ sparseIndex = Indices.position i b
+
+ if size == 1
+ then return Deleted
+ else do
+ a'@(Nodes _ ns') <- mkNodes b' (pred size)
+ forM_ [0..pred sparseIndex] $ \i -> readNodesData ns i >>= writeNodesDataP ns' i
+ forM_ [succ sparseIndex..pred size]
+ $ \i -> readNodesData ns i >>= writeNodesDataP ns' (pred i)
+ return a'
+ else return a
+unset _ _ = error "unset on non Nodes"
+
+{-# INLINE unset' #-}
+unset' :: Index -> Node e -> STM (Maybe (Node e))
+unset' i a@(Nodes b ns) = do
+ -- TODO: handling a Nodes that goes to one element.
+ if Indices.elem i b
+ then do
+ let b' = Indices.invert i b
+ size = Indices.size b
+ sparseIndex = Indices.position i b
+
+ if size == 1
+ then return Nothing
+ else do
+ a'@(Nodes _ ns') <- mkNodes b' (pred size)
+ forM_ [0..pred sparseIndex] $ \i -> readNodesData ns i >>= writeNodesDataP ns' i
+ forM_ [succ sparseIndex..pred size]
+ $ \i -> readNodesData ns i >>= writeNodesDataP ns' (pred i)
+ return (Just a')
+ else return (Just a)
+unset' _ _ = error "unset' on non Nodes"
+
+
+{-# INLINE singleton #-}
+singleton :: Index -> Node e -> STM (Node e)
+singleton i e = do
+ a@(Nodes _ ns) <- mkNodes (Indices.singleton i) 1
+ writeNodesDataP ns 0 e
+ return a
+
+{-# INLINE pairNodes #-}
+pairNodes :: Index -> Node e -> Index -> Node e -> STM (Node e)
+pairNodes i e i' e' = do
+ if | i < i' -> do
+ a@(Nodes _ ns) <- mkNodes is 2
+ writeNodesDataP ns 0 e
+ writeNodesDataP ns 1 e'
+ return a
+ | i > i' -> do
+ a@(Nodes _ ns) <- mkNodes is 2
+ writeNodesDataP ns 0 e'
+ writeNodesDataP ns 1 e
+ return a
+ | otherwise -> singleton is e'
+ where
+ is = Indices.fromList [i, i']
+
+pair :: Hash -> Node e -> Hash -> Node e -> Level.Level -> STM (Node e)
+pair h1 n1 h2 n2 l =
+ -- Even if the whole hashes do not match, the next chunk of it might, so check
+ -- if the indexes at this level match. If they do, make a new level and recurse
+ -- until we find the difference.
+
+ if i1 == i2
+ then singleton i1 =<< pair h1 n1 h2 n2 (Level.succ l)
+ else pairNodes i1 n1 i2 n2
+ where
+ hashIndex = Level.hashIndex l
+ i1 = hashIndex h1
+ i2 = hashIndex h2
+
+
+insertLevel :: Element e => Hash -> e -> Level.Level -> Node e -> STM (Node e)
+insertLevel h e l a@(Nodes b ns)
+ | Indices.elem i b = do
+ -- If there is already an entry for the hash at this level, follow
+ -- it down.
+ let !sparseIndex = Indices.position i b
+ a' <- readNodesData ns sparseIndex
+ insertLevel h e (Level.succ l) a' >>= update sparseIndex a'
+ return a
+ | otherwise = do
+ -- There is not an entry for the hash at this level:
+ -- - Make a new leaf entry
+ ls@(Leaves _ vs) <- mkLeaves h 1
+ writeDataP vs 0 e
+ -- - Expand this level to include a new entry
+ -- returning the new nodes level.
+ set i ls a
+ where
+ update i old new
+ | old /= new = writeNodesData ns i new
+ | otherwise = return ()
+ !i = Level.hashIndex l h
+
+insertLevel h e l a@(Leaves h' vs)
+ | h == h' = do
+ -- Hashes match. Check to see if the match is due to a
+ -- matching key, if so, replace the value otherwise, expand to
+ -- include this new entry as a collision.
+ let !sz = refArraySize vs
+ k = elementKey e
+ find i
+ | i >= sz = do
+ -- Expand and add the new value.
+ ls@(Leaves _ vs') <- mkLeaves h (sz+1)
+ forM_ [0..sz-1] $ \j -> do
+ readData vs j >>= writeDataP vs' j
+ writeDataP vs' sz e
+ return ls
+ | otherwise = do
+ e' <- readData vs i
+ if elementKey e' == k
+ then do
+ -- TODO: Do not replace! This is something
+ -- that could be specalized in a monomorphic
+ -- version where value comparisons could happen.
+ -- -- Found entry with same key, replace.
+ -- writeData a i e
+ return a
+ else find (i+1)
+ find 0
+ | otherwise = do
+ -- Hashes do not match, we need to turn this into a nodes level
+ -- with a pair of leaf levels below.
+ -- - Make a new single leaf for the new entry.
+ ls@(Leaves _ vs) <- mkLeaves h 1
+ writeDataP vs 0 e
+
+ -- - Make a new nodes level, Link the new leaf (ls), and the old leaves (a).
+ -- Return this pair to replace the old level (may be a chain of new levels
+ -- down to the difference in the hash).
+ pair h' a h ls l
+
+insertLevel h e _ Deleted = do
+ ls@(Leaves _ vs) <- mkLeaves h 1
+ writeDataP vs 0 e
+ return ls
+
+-- Delete from a level
+--
+-- Cases we must handle.
+--
+-- - Deleting form a collision leaf
+--
+-- Shrink the leaf, updated parent pointer.
+--
+-- - Deleting from a singlton leaf when the parent nodes has multiple entries
+--
+-- Shrink the parent, update grandparent pointer.
+--
+-- - Deleting from a singlton leaf when the parent nodes is also a singlton
+--
+-- Shrink grandparent, update above.
+--
+-- Recursive call can dictate the following actions when it returns:
+--
+-- - Update pointer to new entry
+-- - Shrink removing the entry
+-- - Signal above to shrink
+--
+deleteLevel
+ :: (Element e)
+ => Hash
+ -> ElementKey e
+ -> Level.Level
+ -> Node e
+ -> STM (Node e)
+
+deleteLevel h k l a@(Nodes b ns)
+ | Indices.elem i b = do
+ -- If there is already an entry for the hash at this level, follow
+ -- it down.
+ let !sparseIndex = Indices.position i b
+ a' <- readNodesData ns sparseIndex
+ deleteLevel h k (Level.succ l) a' >>= update i sparseIndex a'
+ | otherwise = return a
+ where
+ !i = Level.hashIndex l h
+ update i _ _ Deleted = unset i a
+ update i sparseIndex old new
+ | old /= new = writeNodesData ns sparseIndex new >> return a
+ | otherwise = return a
+
+deleteLevel h k l a@(Leaves h' vs)
+ | h == h' = do
+ -- Hashes match. Check to see if the match is due to a
+ -- matching key, if so shrink the leaf.
+ let !sz = refArraySize vs
+ find i
+ | i >= sz = return a -- Key not found, do nothing.
+ | otherwise = do
+ e' <- readData vs i
+ if elementKey e' == k
+ then do
+ -- Found entry with same key, shrink.
+ if sz == 1
+ then return Deleted
+ else do
+ ls@(Leaves _ vs') <- mkLeaves h (sz-1)
+ forM_ [0..i-1] $ \j ->
+ readData vs j >>= writeDataP vs' j
+ forM_ [i+1..sz-1] $ \j ->
+ readData vs j >>= writeDataP vs' (j-1)
+ return $ ls
+ else find (i+1)
+ find 0
+ | otherwise = return a -- Hashes do not match, we are done.
+
+deleteLevel _ _ _ Deleted = return Deleted
+
+---------------------------------------------------
+-- API
+--
+
+-- lookup :: (Show k, Show v, Key k) => k -> Map k v -> STM (Maybe v)
+lookup :: (Key k) => k -> Map k v -> STM (Maybe v)
+lookup k (Map m) = do
+ e <- readTVar m >>= lookupLevel (hash k) k 0
+ return $ fmap snd e
+
+-- insert :: (Show k, Show v, Key k) => k -> v -> Map k v -> STM ()
+insert :: (Key k) => k -> v -> Map k v -> STM ()
+insert k v (Map m) = do
+ a <- readTVar m
+ a' <- insertLevel (hash k) (k,v) 0 a
+ if a == a'
+ then return () -- >> validate (Map m)
+ else writeTVar m a' -- >> validate (Map m)
+{-
+ assertM ("VVV Key not present after insert!") $ do
+ lookup k (Map m) >>= \case
+ Just _ -> return True
+ Nothing -> return False
+-}
+
+-- delete :: (Show k, Show v, Key k) => k -> Map k v -> STM ()
+delete :: (Key k) => k -> Map k v -> STM ()
+delete k (Map m) = do
+ a <- readTVar m
+ a' <- deleteLevel (hash k) k 0 a
+
+ if a == a'
+ then return () -- >> validate (Map m)
+ else writeTVar m a' -- >> validate (Map m)
+{-
+ assertM ("VVV Key still present after delete!") $ do
+ lookup k (Map m) >>= \case
+ Just _ -> return False
+ Nothing -> return True
+-}
+
+new :: STM (Map k v)
+new = do
+ v <- newTVar Deleted
+ return (Map v)
+
+
+showLevel :: (Show e, Element e) => Node e -> STM [String]
+showLevel (Nodes b ns) = do
+ let sz = Indices.size b
+ ls <- forM [0..sz-1] $ \i -> readNodesData ns i >>= showLevel
+ return $ ("Nodes " ++ showBin b) : map (" "++) (concat ls)
+showLevel (Leaves h vs) = do
+ let sz = refArraySize vs
+ ls <- forM [0..sz-1] $ \i -> show <$> readData vs i
+ return $ ("Leaf " ++ showBin h) : map (" "++) ls
+showLevel Deleted = return ["Deleted"]
+
+showBin x = showIntAtBase 2 ("01"!!) x ""
+
+assertM :: Show e => e -> STM Bool -> STM ()
+assertM m a = do
+ b <- a
+ if b
+ then return ()
+ else unsafeIOToSTM (print m)
+
+assert :: Show e => e -> Bool -> STM ()
+assert m b = do
+ if b
+ then return ()
+ else unsafeIOToSTM (print m)
+
+-- Find the first hash available.
+findHash :: Node e -> STM Hash
+findHash (Nodes _ ns) = do
+ assert ("VVV Empty non-root nodes") $ refArraySize ns > 0
+ -- Recurse to find the first hash. Really we want all
+ -- hashes to match, but this aproximates.
+ readNodesData ns 0 >>= findHash
+findHash (Leaves h _) = return h
+findHash _ = error "Deleted in findHash"
+
+validateLevel :: (Show e, Element e, Eq (ElementKey e), Key (ElementKey e)) => Level.Level -> Node e -> STM ()
+validateLevel l a@(Nodes b ns) = do
+ let sz = Indices.size b
+ forM_ [0..sz-1] $ \i -> do
+ a' <- readNodesData ns i
+ h <- findHash a'
+
+ let h' = Level.hashIndex l h
+ i' = Indices.position h' b
+
+ assert ("VVV First hash does not match.", i, i', h', h, b, l) $ i == i'
+
+ validateLevel (Level.succ l) a'
+validateLevel l a@(Leaves h vs) = do
+ let sz = refArraySize vs
+ assert ("VVV Empty Leaf!", h) $ sz > 0
+
+ -- check that keys and hashes match, keys do not match.
+ es <- forM [0..sz-1] $ readData vs
+ let ks = map elementKey es
+
+ assert ("VVV Keys to not all hash same", es, map hash ks) $ nub (map hash ks) == [h]
+ assert ("VVV Some keys match!", es) $ nub ks == ks
+
+
+validate :: (Show k, Show v, Key k) => Map k v -> STM ()
+validate (Map m) = readTVar m >>= validateLevel 0
+
+showSTM :: (Show k, Show v, Key k) => Map k v -> STM String
+showSTM (Map m) = do
+ a <- readTVar m
+ unlines <$> showLevel a
diff --git a/benchmarks/PPoPP2019/src/HamtTStruct.hs b/benchmarks/PPoPP2019/src/HamtTStruct.hs
new file mode 100644
index 0000000..c0cfe96
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/HamtTStruct.hs
@@ -0,0 +1,726 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+module HamtTStruct where
+
+import Prelude hiding (lookup)
+
+import Numeric
+
+import GHC.Num
+import GHC.ST
+import GHC.Base hiding (assert)
+import GHC.Conc
+import GHC.Word
+import GHC.Prim
+
+import System.IO.Unsafe (unsafePerformIO)
+
+import Data.List (nub)
+
+-- import Prelude (Maybe(..), pred, succ, (=<<), ($!), snd, unlines)
+
+import qualified STMContainers.WordArray.Indices as Indices
+import qualified STMContainers.HAMT.Level as Level
+
+import Data.Hashable
+import Control.Monad (forM_, forM)
+import Control.Applicative ((<$>))
+
+-- In original HAMT the Node type has three constructors:
+--
+-- data Node = Nodes (WordArray (Node e))
+-- | Leaf Hash e
+-- | Leaves Hash (SizedArray e)
+--
+-- If we collapse leaf and leaves:
+--
+-- data Node = Nodes (WordArray (Node e))
+-- | Leaves Hash (SizedArray e)
+--
+-- Now represent both of these with an STMMutableArray# version of the following:
+--
+-- data Nodes = Nodes Indices [Nodes e]
+-- data Leaves = Leaves Hash [e]
+--
+-- In the monomorphic unboxed case Leaves stores everything in words while Nodes
+-- always has pointers. We can use a word for the tag bit and represent both with
+-- a STMMutableArray#. The tag bit would be read-only so we can cheat in STM
+-- and do a non-transactional read:
+--
+-- struct Nodes
+-- {
+-- halfword sizeWords;
+-- halfword sizePtrs;
+--
+-- word tag;
+-- word indices;
+-- Nodes* nodes[];
+-- }
+--
+-- struct Leaves
+-- {
+-- halfword sizeWords;
+-- halfword sizePtrs;
+--
+-- word tag;
+-- word Hash;
+-- word words[];
+-- }
+--
+-- We will assume word sized keys and heap object values are being stored (to match the
+-- original).
+--
+
+newtype Map k v = Map { unMap :: TVar (WordArray (k,v)) }
+
+type Key a = (Eq a, Hashable a)
+type Hash = Int
+
+class (Eq (ElementKey e)) => Element e where
+ type ElementKey e
+ elementKey :: e -> ElementKey e
+
+instance (Eq k) => Element (k, v) where
+ type ElementKey (k, v) = k
+ elementKey (k, v) = k
+
+data WordArray e = WordArray { unWordArray :: STMMutableArray# RealWorld e }
+
+instance Eq (WordArray e) where
+ (WordArray a) == (WordArray a') =
+ case sameSTMMutableArray# a a' of
+ 0# -> False
+ _ -> True
+
+type Index = Int
+type Indices = Int
+
+-- Private API for building a new private WordArray that we can then use transactionally.
+{-# INLINE newWordArrayP #-}
+newWordArrayP :: Int -> STM (WordArray e)
+newWordArrayP (I# i#) = STM $ \s1# ->
+ case newSTMArray# i# 1# undefined s1# of
+ (# s2#, marr# #) -> (# s2#, WordArray marr# #)
+
+{-# INLINE newWordArrayIO #-}
+newWordArrayIO :: Int -> IO (WordArray e)
+newWordArrayIO (I# i#) = IO $ \s1# ->
+ case newSTMArray# i# 1# undefined s1# of
+ (# s2#, marr# #) -> (# s2#, WordArray marr# #)
+
+{-# INLINE newWordArrayInitP #-}
+newWordArrayInitP :: Int -> e -> STM (WordArray e)
+newWordArrayInitP (I# i#) e = STM $ \s1# ->
+ case newSTMArray# i# 1# e s1# of
+ (# s2#, marr# #) -> (# s2#, WordArray marr# #)
+
+{-# INLINE readTagP #-}
+readTagP :: WordArray e -> STM Word
+readTagP (WordArray arr#) = STM $ \s1# ->
+ case readSTMArrayWord# arr# 0# s1# of
+ (# s2#, w# #) -> (# s2#, W# w# #)
+
+---------------------------------------------------
+-- Nodes
+{-# INLINE roundUp64# #-}
+roundUp64# :: Int# -> Int#
+roundUp64# i# = (i# +# 63#) `andI#` (-64#)
+
+{-# INLINE newNodesInitP #-}
+newNodesInitP :: Int -> WordArray e -> STM (WordArray e)
+newNodesInitP (I# i#) (WordArray e#) = STM $ \s1# ->
+-- case newSTMArray# (roundUp64# i#) 2# (unsafeCoerce# e#) s1# of
+ case newSTMArray# i# 2# (unsafeCoerce# e#) s1# of
+ (# s2#, arr# #) ->
+ case writeSTMArrayWord# arr# 0# 0## s2# of -- Set the tag to zero
+ s3# -> (# s3#, WordArray arr# #)
+
+{-# INLINE newNodesP #-}
+newNodesP :: Int -> STM (WordArray e)
+newNodesP (I# i#) = STM $ \s1# ->
+-- case newSTMArray# (roundUp64# i#) 2# undefined s1# of -- round up pointer count so words are on next cacheline
+ case newSTMArray# i# 2# undefined s1# of -- Minimal allocation
+ (# s2#, arr# #) ->
+ case writeSTMArrayWord# arr# 0# 0## s2# of -- Set the tag to zero
+ s3# -> (# s3#, WordArray arr# #)
+
+{-# INLINE modifyIndicesP #-}
+modifyIndicesP :: WordArray e -> (Int -> Int) -> STM ()
+modifyIndicesP arr f = do
+ i <- readIndicesP arr
+ writeIndicesP arr (f i)
+
+{-# INLINE readIndicesP #-}
+readIndicesP :: WordArray e -> STM Int
+readIndicesP (WordArray arr#) = STM $ \s1# ->
+ case readSTMArrayWord# arr# 1# s1# of
+ (# s2#, w# #) -> (# s2#, I# (word2Int# w#) #)
+
+{-# INLINE writeIndicesP #-}
+writeIndicesP :: WordArray e -> Int -> STM ()
+writeIndicesP (WordArray arr#) (I# i#) = STM $ \s1# ->
+ case writeSTMArrayWord# arr# 1# (int2Word# i#) s1# of
+ s2# -> (# s2#, () #)
+
+---------------------------------------------------
+-- Leaves
+
+{-# INLINE newLeavesP #-}
+newLeavesP :: Int -> STM (WordArray e)
+newLeavesP (I# i#) = STM $ \s1# ->
+ case newSTMArray# i# 2# undefined s1# of
+ (# s2#, arr# #) ->
+ case writeSTMArrayWord# arr# 0# 1## s2# of -- Set the tag to one
+ s3# -> (# s3#, WordArray arr# #)
+
+{-# INLINE modifyHashP #-}
+modifyHashP :: WordArray e -> (Hash -> Hash) -> STM ()
+modifyHashP arr f = do
+ i <- readHashP arr
+ writeHashP arr (f i)
+
+{-# INLINE readHashP #-}
+readHashP :: WordArray e -> STM Hash
+readHashP (WordArray arr#) = STM $ \s1# ->
+ case readSTMArrayWord# arr# 1# s1# of
+ (# s2#, w# #) -> (# s2#, I# (word2Int# w#) #)
+
+{-# INLINE writeHashP #-}
+writeHashP :: WordArray e -> Hash -> STM ()
+writeHashP (WordArray arr#) (I# i#) = STM $ \s1# ->
+ case writeSTMArrayWord# arr# 1# (int2Word# i#) s1# of
+ s2# -> (# s2#, () #)
+
+---------------------------------------------------
+-- Pointers
+--
+
+{-# INLINE dataSize #-}
+dataSize :: WordArray e -> Int
+dataSize (WordArray arr#) =
+ case sizeofSTMMutableArray# arr# of
+ i# -> I# i#
+
+{-# INLINE readDataP #-}
+readDataP :: WordArray e -> Int -> STM e
+readDataP arr (I# i#) = STM $ \s1# -> readSTMArray# (unWordArray arr) i# s1#
+
+{-# INLINE writeDataP #-}
+writeDataP :: WordArray e -> Int -> e -> STM ()
+writeDataP arr (I# i#) e = STM $ \s1# ->
+ case writeSTMArray# (unWordArray arr) i# e s1# of
+ s2# -> (# s2#, () #)
+
+{-# INLINE writeNodesDataP #-}
+writeNodesDataP :: WordArray e -> Int -> WordArray e -> STM ()
+writeNodesDataP arr (I# i#) (WordArray e#) = STM $ \s1# ->
+ case writeSTMArray# (unWordArray arr) i# (unsafeCoerce# e#) s1# of
+ s2# -> (# s2#, () #)
+
+{-# INLINE readNodesData #-}
+readNodesData :: WordArray e -> Int -> STM (WordArray e)
+readNodesData a i = do
+ e <- readData a i
+ return (WordArray (unsafeCoerce# e))
+
+{-# INLINE readData #-}
+readData :: WordArray e -> Int -> STM e
+readData arr (I# i#) = STM $ \s# -> readTArray# (unWordArray arr) (int2Word# i#) s#
+
+{-# INLINE writeData #-}
+writeData :: WordArray e -> Int -> e -> STM ()
+writeData arr (I# i#) e = STM $ \s1# ->
+ case writeTArray# (unWordArray arr) (int2Word# i#) e s1# of
+ s2# -> (# s2#, () #)
+
+{-# INLINE writeNodesData #-}
+writeNodesData :: WordArray e -> Int -> WordArray e -> STM ()
+writeNodesData arr (I# i#) (WordArray e#) = STM $ \s1# ->
+ case writeTArray# (unWordArray arr) (int2Word# i#) (unsafeCoerce# e#) s1# of
+ s2# -> (# s2#, () #)
+
+---------------------------------------------------
+-- Operations
+--
+
+lookupLevel :: Element e => Hash -> ElementKey e -> Level.Level -> WordArray e -> STM (Maybe e)
+lookupLevel h k l arr = do
+ t <- readTagP arr
+ case t of
+ 0 -> do -- A nodes level.
+ let i = Level.hashIndex l h
+ b <- readIndicesP arr -- TODO: if we can grow this must be transactional
+ if Indices.elem i b
+ then readNodesData arr (Indices.position i b) >>= lookupLevel h k (Level.succ l)
+ else return Nothing
+ 1 -> do -- A leaf level.
+ h' <- readHashP arr
+ if h == h'
+ then do
+ let sz = dataSize arr
+ find i
+ | i >= sz = return Nothing
+ | otherwise = do
+ e <- readData arr i
+ if elementKey e == k
+ then return $! Just e
+ else find (i+1)
+ find 0
+ else return Nothing
+
+{-# INLINE set #-}
+set :: Index -> WordArray e -> WordArray e -> STM (WordArray e)
+set i e a = do
+ b <- readIndicesP a
+ let sparseIndex = Indices.position i b
+ size = Indices.size b
+
+ if Indices.elem i b
+ then writeNodesData a sparseIndex e >> return a
+ else do
+ a' <- newNodesP (size+1)
+ forM_ [0..sparseIndex-1] $ \i -> readNodesData a i >>= writeNodesDataP a' i
+ writeNodesDataP a' sparseIndex e
+ forM_ [sparseIndex..(size-1)] $ \i -> readNodesData a i >>= writeNodesDataP a' (i+1)
+ writeIndicesP a' (Indices.insert i b)
+ return a'
+
+{-# NOINLINE deleteMarker #-}
+deleteMarker :: WordArray e
+deleteMarker = unsafePerformIO $ newWordArrayIO 0
+
+{-# INLINE unset #-}
+unset :: Index -> WordArray e -> STM (WordArray e)
+unset i a = do
+ -- TODO: handling a Nodes that goes to one element.
+ b <- readIndicesP a
+ if Indices.elem i b
+ then do
+ let b' = Indices.invert i b
+ size = Indices.size b
+ sparseIndex = Indices.position i b
+
+ if size == 1
+ then return deleteMarker
+ else do
+ a' <- newNodesP (pred size)
+ forM_ [0..pred sparseIndex] $ \i -> readNodesData a i >>= writeNodesDataP a' i
+ forM_ [succ sparseIndex..pred size]
+ $ \i -> readNodesData a i >>= writeNodesDataP a' (pred i)
+ writeIndicesP a' b'
+ return a'
+ else return a
+
+{-# INLINE unset' #-}
+unset' :: Index -> WordArray e -> STM (Maybe (WordArray e))
+unset' i a = do
+ -- TODO: handling a Nodes that goes to one element.
+ b <- readIndicesP a
+ if Indices.elem i b
+ then do
+ let b' = Indices.invert i b
+ size = Indices.size b
+ sparseIndex = Indices.position i b
+
+ if size == 1
+ then return Nothing
+ else do
+ a' <- newNodesP (pred size)
+ forM_ [0..pred sparseIndex] $ \i -> readNodesData a i >>= writeNodesDataP a' i
+ forM_ [succ sparseIndex..pred size]
+ $ \i -> readNodesData a i >>= writeNodesDataP a' (pred i)
+ writeIndicesP a' b'
+ return (Just a')
+ else return (Just a)
+
+{-# INLINE singleton #-}
+singleton :: Index -> WordArray e -> STM (WordArray e)
+singleton i a = do
+ ns <- newNodesInitP 1 a
+ writeIndicesP ns (Indices.singleton i)
+ return ns
+
+{-# INLINE pairNodes #-}
+pairNodes :: Index -> WordArray e -> Index -> WordArray e -> STM (WordArray e)
+pairNodes i e i' e' = do
+ if | i < i' -> do
+ a <- newNodesInitP 2 e
+ writeNodesDataP a 1 e'
+ writeIndicesP a is
+ return a
+ | i > i' -> do
+ a <- newNodesInitP 2 e
+ writeNodesDataP a 0 e'
+ writeIndicesP a is
+ return a
+ | i == i' -> do
+ a <- newNodesInitP 1 e'
+ writeIndicesP a is
+ return a
+ where
+ is = Indices.fromList [i, i']
+
+pair :: Hash -> WordArray e -> Hash -> WordArray e -> Level.Level -> STM (WordArray e)
+pair h1 n1 h2 n2 l =
+ -- Even if the whole hashes do not match, the next chunk of it might, so check
+ -- if the indexes at this level match. If they do, make a new level and recurse
+ -- until we find the difference.
+
+ if i1 == i2
+ then singleton i1 =<< pair h1 n1 h2 n2 (Level.succ l)
+ else pairNodes i1 n1 i2 n2
+ where
+ hashIndex = Level.hashIndex l
+ i1 = hashIndex h1
+ i2 = hashIndex h2
+
+
+insertLevel :: Element e => Hash -> e -> Level.Level -> WordArray e -> STM (WordArray e)
+insertLevel h e l a = do
+ let update i old new
+ | old /= new = writeNodesData a i new
+ | otherwise = return ()
+ k = elementKey e
+ t <- readTagP a
+ case t of
+ 0 -> do
+ -- We have a nodes level
+ let !i = Level.hashIndex l h
+ b <- readIndicesP a
+ if Indices.elem i b
+ then do
+ -- If there is already an entry for the hash at this level, follow
+ -- it down.
+ let !sparseIndex = Indices.position i b
+ a' <- readNodesData a sparseIndex
+ insertLevel h e (Level.succ l) a' >>= update sparseIndex a'
+ return a
+ else do
+ -- There is not an entry for the hash at this level:
+ -- - Make a new leaf entry
+ ls <- newLeavesP 1
+ writeHashP ls h
+ writeDataP ls 0 e
+ -- - Expand this level to include a new entry
+ -- returning the new nodes level.
+ set i ls a
+
+ 1 -> do
+ -- We have a leaf level do the hashes match?
+ h' <- readHashP a
+ if h == h'
+ then do
+ -- Hashes match. Check to see if the match is due to a
+ -- matching key, if so, replace the value otherwise, expand to
+ -- include this new entry as a collision.
+ let !sz = dataSize a
+ find i
+ | i >= sz = do
+ -- Expand and add the new value.
+ ls <- newLeavesP (sz+1)
+ writeHashP ls h
+ forM_ [0..sz-1] $ \j -> do
+ readData a j >>= writeDataP ls j
+ writeDataP ls sz e
+ return ls
+ | otherwise = do
+ e' <- readData a i
+ if elementKey e' == k
+ then do
+ -- TODO: Do not replace! This is something
+ -- that could be specalized in a monomorphic
+ -- version where value comparisons could happen.
+ -- -- Found entry with same key, replace.
+ -- writeData a i e
+ return a
+ else find (i+1)
+ find 0
+ else do
+ -- Hashes do not match, we need to turn this into a nodes level
+ -- with a pair of leaf levels below.
+ -- - Make a new single leaf for the new entry.
+ ls <- newLeavesP 1
+ writeHashP ls h
+ writeDataP ls 0 e
+
+ -- - Make a new nodes level, Link the new leaf (ls), and the old leaves (a).
+ -- Return this pair to replace the old level (may be a chain of new levels
+ -- down to the difference in the hash).
+ pair h' a h ls l
+
+-- Delete from a level
+--
+-- Cases we must handle.
+--
+-- - Deleting form a collision leaf
+--
+-- Shrink the leaf, updated parent pointer.
+--
+-- - Deleting from a singlton leaf when the parent nodes has multiple entries
+--
+-- Shrink the parent, update grandparent pointer.
+--
+-- - Deleting from a singlton leaf when the parent nodes is also a singlton
+--
+-- Shrink grandparent, update above.
+--
+-- Recursive call can dictate the following actions when it returns:
+--
+-- - Update pointer to new entry
+-- - Shrink removing the entry
+-- - Signal above to shrink
+--
+deleteLevel
+ :: (Element e)
+ => Hash
+ -> ElementKey e
+ -> Level.Level
+ -> WordArray e
+ -> STM (WordArray e)
+
+deleteLevel h k l a = do
+ let update i sparseIndex old new
+ | new == deleteMarker = unset i a -- remove entry, shrink
+ | old /= new = writeNodesData a sparseIndex new >> return a
+ | otherwise = return a
+ t <- readTagP a
+ case t of
+ 0 -> do
+ -- We have a nodes level
+ let !i = Level.hashIndex l h
+ b <- readIndicesP a
+ if Indices.elem i b
+ then do
+ -- If there is already an entry for the hash at this level, follow
+ -- it down.
+ let !sparseIndex = Indices.position i b
+ a' <- readNodesData a sparseIndex
+ deleteLevel h k (Level.succ l) a' >>= update i sparseIndex a'
+ else -- There is not an entry for the hash at this level, we are done.
+ return a
+
+ 1 -> do
+ -- We have a leaf level do the hashes match?
+ h' <- readHashP a
+ if h == h'
+ then do
+ -- Hashes match. Check to see if the match is due to a
+ -- matching key, if so shrink the leaf.
+ let !sz = dataSize a
+ find i
+ | i >= sz = return a -- Key not found, do nothing.
+ | otherwise = do
+ e' <- readData a i
+ if elementKey e' == k
+ then do
+ -- Found entry with same key, shrink.
+ if sz == 1
+ then return deleteMarker
+ else do
+ ls <- newLeavesP (sz-1)
+ writeHashP ls h
+ forM_ [0..i-1] $ \j ->
+ readData a j >>= writeDataP ls j
+ forM_ [i+1..sz-1] $ \j ->
+ readData a j >>= writeDataP ls (j-1)
+ return $ ls
+ else find (i+1)
+ find 0
+ else return a -- Hashes do not match, we are done.
+
+deleteLevel'
+ :: (Element e)
+ => Hash
+ -> ElementKey e
+ -> Level.Level
+ -> WordArray e
+ -> STM (Maybe (WordArray e))
+
+deleteLevel' h k l a = do
+ let update i sparseIndex old Nothing = unset' i a -- remove entry, shrink
+ update i sparseIndex old (Just new) -- Update pointer
+ | old /= new = writeNodesData a sparseIndex new >> return (Just a)
+ | otherwise = return (Just a)
+ t <- readTagP a
+ case t of
+ 0 -> do
+ -- We have a nodes level
+ let i = Level.hashIndex l h
+ b <- readIndicesP a
+ if Indices.elem i b
+ then do
+ -- If there is already an entry for the hash at this level, follow
+ -- it down.
+ let sparseIndex = Indices.position i b
+ a' <- readNodesData a sparseIndex
+ deleteLevel' h k (Level.succ l) a' >>= update i sparseIndex a'
+ else -- There is not an entry for the hash at this level, we are done.
+ return (Just a)
+
+ 1 -> do
+ -- We have a leaf level do the hashes match?
+ h' <- readHashP a
+ if h == h'
+ then do
+ -- Hashes match. Check to see if the match is due to a
+ -- matching key, if so shrink the leaf.
+ let sz = dataSize a
+ find i
+ | i >= sz = return (Just a) -- Key not found, do nothing.
+ | otherwise = do
+ e' <- readData a i
+ if elementKey e' == k
+ then do
+ -- Found entry with same key, shrink.
+ if sz == 1
+ then return Nothing
+ else do
+ ls <- newLeavesP (sz-1)
+ writeHashP ls h
+ forM_ [0..i-1] $ \j ->
+ readData a j >>= writeDataP ls j
+ forM_ [i+1..sz-1] $ \j ->
+ readData a j >>= writeDataP ls (j-1)
+ return $ Just ls
+ else find (i+1)
+ find 0
+ else return (Just a) -- Hashes do not match, we are done.
+
+---------------------------------------------------
+-- API
+--
+
+-- lookup :: (Show k, Show v, Key k) => k -> Map k v -> STM (Maybe v)
+lookup :: (Key k) => k -> Map k v -> STM (Maybe v)
+lookup k (Map m) = do
+ e <- readTVar m >>= lookupLevel (hash k) k 0
+ return $ fmap snd e
+
+-- insert :: (Show k, Show v, Key k) => k -> v -> Map k v -> STM ()
+insert :: (Key k) => k -> v -> Map k v -> STM ()
+insert k v (Map m) = do
+ a <- readTVar m
+ a' <- insertLevel (hash k) (k,v) 0 a
+ if a == a'
+ then return () -- validate (Map m)
+ else writeTVar m a' -- >> validate (Map m)
+{-
+ assertM ("VVV Key not present after insert!") $ do
+ lookup k (Map m) >>= \case
+ Just _ -> return True
+ Nothing -> return False
+-}
+-- delete :: (Show k, Show v, Key k) => k -> Map k v -> STM ()
+delete :: (Key k) => k -> Map k v -> STM ()
+delete k (Map m) = do
+ a <- readTVar m
+ a' <- deleteLevel (hash k) k 0 a
+
+ if a' == deleteMarker
+ then (newNodesP 0 >>= writeTVar m) -- >> validate (Map m)
+ else if a == a'
+ then return () -- validate (Map m)
+ else writeTVar m a' -- >> validate (Map m)
+{-
+ assertM ("VVV Key still present after delete!") $ do
+ lookup k (Map m) >>= \case
+ Just _ -> return False
+ Nothing -> return True
+-}
+new :: STM (Map k v)
+new = do
+ n <- newNodesP 0
+ v <- newTVar n
+ return (Map v)
+
+
+showLevel :: (Show e, Element e) => WordArray e -> STM [String]
+showLevel a = do
+ t <- readTagP a
+ case t of
+ 0 -> do
+ -- Nodes
+ b <- readIndicesP a
+ let sz = Indices.size b
+ ls <- forM [0..sz-1] $ \i -> readNodesData a i >>= showLevel
+ return $ ("Nodes " ++ showBin b) : map (" "++) (concat ls)
+ 1 -> do
+ -- Leaf
+ h <- readHashP a
+ let sz = dataSize a
+ ls <- forM [0..sz-1] $ \i -> show <$> readData a i
+ return $ ("Leaf " ++ showBin h) : map (" "++) ls
+ where
+ showBin x = showIntAtBase 2 ("01"!!) x ""
+
+assertM :: Show e => e -> STM Bool -> STM ()
+assertM m a = do
+ b <- a
+ if b
+ then return ()
+ else unsafeIOToSTM (print m)
+
+assert :: Show e => e -> Bool -> STM ()
+assert m b = do
+ if b
+ then return ()
+ else unsafeIOToSTM (print m)
+
+-- Find the first hash available.
+findHash :: WordArray e -> STM Hash
+findHash a = do
+ t <- readTagP a
+ case t of
+ 0 -> do
+ -- Nodes
+ assert ("VVV Empty non-root nodes") $ dataSize a > 0
+ -- Recurse to find the first hash. Really we want all
+ -- hashes to match, but this aproximates.
+ readNodesData a 0 >>= findHash
+ 1 -> readHashP a
+
+validateLevel :: (Show e, Element e, Eq (ElementKey e), Key (ElementKey e)) => Level.Level -> WordArray e -> STM ()
+validateLevel l a = do
+ t <- readTagP a
+ case t of
+ 0 -> do
+ -- Nodes
+ b <- readIndicesP a
+ let sz = Indices.size b
+
+-- We abuse this at the moment by over allocating for cache alignment
+-- assert ("VVV PopCount dataSize mismatch", sz, dataSize a) $ sz == dataSize a
+
+ forM_ [0..sz-1] $ \i -> do
+ a' <- readNodesData a i
+ h <- findHash a'
+
+ let h' = Level.hashIndex l h
+ i' = Indices.position h' b
+
+ assert ("VVV First hash does not match.", i, i', h', h, b, l) $ i == i'
+
+ validateLevel (Level.succ l) a'
+
+ 1 -> do
+ -- leaf
+ h <- readHashP a
+
+ let sz = dataSize a
+ assert ("VVV Empty Leaf!", h) $ sz > 0
+
+ -- check that keys and hashes match, keys do not match.
+ es <- forM [0..sz-1] $ readData a
+ let ks = map elementKey es
+
+ assert ("VVV Keys to not all hash same", es, map hash ks) $ nub (map hash ks) == [h]
+ assert ("VVV Some keys match!", es) $ nub ks == ks
+
+
+validate :: (Show k, Show v, Key k) => Map k v -> STM ()
+validate (Map m) = readTVar m >>= validateLevel 0
+
+showSTM :: (Show k, Show v, Key k) => Map k v -> STM String
+showSTM (Map m) = do
+ a <- readTVar m
+ unlines <$> showLevel a
diff --git a/benchmarks/PPoPP2019/src/Main.hs b/benchmarks/PPoPP2019/src/Main.hs
new file mode 100644
index 0000000..7bc6587
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/Main.hs
@@ -0,0 +1,212 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+module Main where
+
+import Control.Applicative
+import Control.Monad
+
+import GHC.Conc.Sync
+import Control.Concurrent
+
+import Data.Maybe
+import Data.Word
+
+#ifdef RBTREE
+import RBTree
+#elif HAMT
+import Hamt
+#elif TREAP
+import Treap
+#else
+#error Unknown Variant for Import
+#endif
+
+import Throughput
+import System.Random.PCG.Fast.Pure
+
+import System.Console.GetOpt
+import System.Environment
+
+import GHC.Prim (resetSTMStats#)
+import GHC.Types
+
+type RGen = GenIO
+
+initGens :: Int -> IO [RGen]
+initGens threads = mapM initialize (map fromIntegral [1..threads])
+
+samples :: Word -> Word -> RGen -> IO ((Word,Word), RGen)
+samples sampleMax total g = do
+ r <- uniformB sampleMax g
+ v <- uniformB (total - 2) g
+ return ((r, v+1), g)
+
+type BenchTree = Tree
+#define VALUE 0
+#define ATOMIC atomically
+
+data BenchOpts = BenchOpts
+ { _entries :: Word
+ , _threads :: Int
+ , _initOnly :: Bool
+ , _withoutTM :: Bool
+ , _mix :: Double
+ , _throughput :: Int
+ } deriving (Show)
+
+benchDefs :: BenchOpts
+benchDefs = BenchOpts
+ { _entries = 800
+ , _threads = 8
+ , _initOnly = False
+ , _withoutTM = False
+ , _mix = 90
+ , _throughput = 1000
+ }
+
+benchOpts :: [OptDescr (BenchOpts -> BenchOpts)]
+benchOpts =
+ [ Option ['e'] ["entries"]
+ (ReqArg (\v o -> o { _entries = read v}) "ENTRIES") "Number of values in the tree"
+ , Option ['t'] ["threads"]
+ (ReqArg (\v o -> o { _threads = read v}) "THREADS") "Number of threads"
+ , Option ['i'] ["initOnly"]
+ (NoArg (\o -> o { _initOnly = True })) "Initialize only"
+ , Option ['w'] ["withoutTM"]
+ (NoArg (\o -> o { _withoutTM = True })) "No transactions"
+ , Option ['m'] ["mix"]
+ (ReqArg (\v o -> o { _mix = read v}) "MIX") "Read mix percent"
+ , Option ['s'] ["throughput"]
+ (ReqArg (\v o -> o { _throughput = read v}) "TIME")
+ "Throughput runtime in milliseconds"
+ ]
+
+getBenchOpts = do
+ prog <- getProgName
+ let header = "Usage: " ++ prog
+ argv <- getArgs
+ case getOpt Permute benchOpts argv of
+ (o, n, []) -> return (foldl (flip id) benchDefs o)
+ (_, _, es) -> ioError (userError (concat es ++ usageInfo header benchOpts))
+
+runRSTMEmpty :: CountIO -> RGen -> BenchTree -> Word -> Double -> IO ()
+runRSTMEmpty count g t total readRate = go g
+ where
+ insertRate = ((100 - readRate) / 2) + readRate
+ sampleMax = 100000 :: Word
+
+ toPercent :: Word -> Double
+ toPercent r = fromIntegral r * 100 / fromIntegral sampleMax
+
+ go g = do
+ (!(toPercent -> !r,!v),!g') <- samples sampleMax total g
+ case () of
+ () | r <= readRate -> ATOMIC (doNothing t v)
+ | r <= insertRate -> ATOMIC (doNothing t v)
+ | otherwise -> ATOMIC (doNothing t v)
+ incCount count
+ go g'
+ {-# NOINLINE go #-}
+
+ doNothing t 0 = return ()
+ doNothing t _ = return ()
+
+
+runRSTMSingle :: CountIO -> RGen -> BenchTree -> Word -> Double -> IO ()
+runRSTMSingle count g t total readRate = go g
+ where
+ insertRate = ((100 - readRate) / 2) + readRate
+ sampleMax = 100000 :: Word
+
+ readLevel :: Word
+ !readLevel = floor $ readRate / 100.0 * fromIntegral sampleMax
+ insertLevel :: Word
+ !insertLevel = floor $ insertRate / 100.0 * fromIntegral sampleMax
+
+ toPercent :: Word -> Double
+ toPercent r = fromIntegral r * 100 / fromIntegral sampleMax
+
+#ifndef TESTCODE
+ go g = do
+ (!(!r,!v),!g') <- samples sampleMax total g
+ case () of
+ () | r <= readLevel -> ATOMIC (get t v >> return ())
+ | r <= insertLevel -> ATOMIC (insert t v VALUE >> return ())
+ | otherwise -> ATOMIC (delete t v >> return ())
+ incCount count
+ go g'
+ {-# NOINLINE go #-}
+
+#else
+ go g = do
+ (!(!r,!v),!g') <- samples sampleMax total g
+ case () of
+ () | r <= readLevel -> ATOMIC (get t v >> return ())
+ | r <= insertLevel -> ATOMIC (insert t v VALUE >> return ()) >> hasValue t v -- single-threaded sanity check
+ | otherwise -> ATOMIC (delete t v >> return ()) >> noValue t v
+ incCount count
+ go g'
+ {-# NOINLINE go #-}
+
+hasValue t v = do
+ x <- ATOMIC (get t v)
+ case x of
+ Just _ -> return ()
+ Nothing -> print (v, "missing")
+
+noValue t v = do
+ x <- ATOMIC (get t v)
+ case x of
+ Nothing -> return ()
+ _ -> print (v, "found")
+#endif
+
+resetSTMStats :: IO ()
+resetSTMStats = IO $ \s# -> case resetSTMStats# s# of s'# -> (# s'#, () #)
+
+main :: IO ()
+main = do
+ prog <- getProgName
+ opts <- getBenchOpts
+
+ setNumCapabilities (_threads opts)
+
+ let !e = _entries opts
+ !m = _mix opts
+ !s = _throughput opts
+
+ (g':gs) <- initGens (_threads opts + 1)
+
+ ((_,v'), g'') <- samples 100000 e g'
+ ((_,v''),_ ) <- samples 100000 e g''
+
+ when (v' == v'') $ putStrLn $ "v' == v'' (" ++ show v' ++ ")"
+
+ t <- ATOMIC mkTree
+ forM_ [0,2..e] $ \a -> ATOMIC $ insert t a VALUE
+
+ unless (_initOnly opts) $ resetSTMStats
+
+ cs <- replicateM (_threads opts) $ newCount 0
+
+ unless (_initOnly opts) $ do
+ -- loop forever, stopping after s milliseconds.
+ (t,ta) <- case () of
+ () | _withoutTM opts ->
+ throughputMain (s * 1000) (zipWith (\c g -> runRSTMEmpty c g t e m) cs gs)
+ | otherwise ->
+ throughputMain (s * 1000) (zipWith (\c g -> runRSTMSingle c g t e m) cs gs)
+ trans <- sum <$> forM cs readCount
+ putStrLn $ unwords [ "benchdata:"
+ , "run-time" , show t
+ , "no-kill-time", show ta
+ , "transactions", show trans
+ , "prog" , prog
+ , "threads" , show (_threads opts)
+ , "entries" , show e
+ , "code" , benchCode
+ ]
diff --git a/benchmarks/PPoPP2019/src/Opts.hs b/benchmarks/PPoPP2019/src/Opts.hs
new file mode 100644
index 0000000..6a0fddc
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/Opts.hs
@@ -0,0 +1,54 @@
+import System.Console.GetOpt
+import System.Environment
+import Data.Maybe (fromMaybe)
+
+data BenchOpts = BenchOpts
+ { _entries :: Word
+ , _threads :: Int
+ , _initOnly :: Bool
+ , _withoutTM :: Bool
+ , _mix :: Double
+ , _throughput :: Int
+ } deriving (Show)
+
+benchDefs :: BenchOpts
+benchDefs = BenchOpts
+ { _entries = 800
+ , _threads = 8
+ , _initOnly = False
+ , _withoutTM = False
+ , _mix = 90
+ , _throughput = 1000
+ }
+
+benchOpts :: [OptDescr (BenchOpts -> BenchOpts)]
+benchOpts =
+ [ Option ['e'] ["entries"]
+ (ReqArg (\v o -> o { _entries = read v}) "ENTRIES") "Number of values in the tree"
+ , Option ['t'] ["threads"]
+ (ReqArg (\v o -> o { _threads = read v}) "THREADS") "Number of threads"
+ , Option ['i'] ["initOnly"]
+ (NoArg (\o -> o { _initOnly = True })) "Initialize only"
+ , Option ['w'] ["withoutTM"]
+ (NoArg (\o -> o { _withoutTM = True })) "No transactions"
+ , Option ['m'] ["mix"]
+ (ReqArg (\v o -> o { _mix = read v}) "MIX") "Read mix percent"
+ , Option ['s'] ["throughput"]
+ (ReqArg (\v o -> o { _throughput = read v}) "TIME")
+ "Throughput runtime in milliseconds"
+ ]
+
+readOpt f v = read v
+
+getBenchOpts = do
+ prog <- getProgName
+ let header = "Usage: " ++ prog
+ argv <- getArgs
+ case getOpt Permute benchOpts argv of
+ (o, n, []) -> return (foldl (flip id) benchDefs o, n)
+ (_, _, es) -> ioError (userError (concat es ++ usageInfo header benchOpts))
+
+main = do
+ as <- getBenchOpts
+
+ print as
diff --git a/benchmarks/PPoPP2019/src/RBTree.hs b/benchmarks/PPoPP2019/src/RBTree.hs
new file mode 100644
index 0000000..11600d7
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/RBTree.hs
@@ -0,0 +1,33 @@
+{-# LANGUAGE CPP #-}
+module RBTree
+ ( Tree
+ , mkTree
+
+ , insert
+ , delete
+ , update
+ , get
+ , contains
+
+ , benchCode
+ ) where
+
+import GHC.Conc.Sync
+import Data.Word
+
+#if defined(TSTRUCT)
+import RBTreeTStruct
+type Tree = RBTree
+#elif defined(MUT)
+import RBTreeMutUSTM
+type Tree = RBTree Word Word
+#elif defined(TVAR)
+import RBTreeTVar
+type Tree = RBTree Word Word
+#else
+#error Unknown RBTree Variant
+#endif
+
+
+mkTree :: STM Tree
+mkTree = mkRBTree
diff --git a/benchmarks/PPoPP2019/src/RBTreeMutUSTM.hs b/benchmarks/PPoPP2019/src/RBTreeMutUSTM.hs
new file mode 100644
index 0000000..b9d875a
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/RBTreeMutUSTM.hs
@@ -0,0 +1,668 @@
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE MutableFields #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+module RBTreeMutUSTM
+ ( RBTree
+ , mkRBTree
+
+ , insert
+ , delete
+ , update
+ , get
+ , contains
+
+ , benchCode
+#ifdef TESTCODE
+ , testMain
+
+ , verify
+#endif
+ ) where
+
+import Prelude hiding (lookup)
+
+import Control.Applicative
+import Control.Monad
+import Control.Exception
+
+import Data.List (sort,inits)
+import Debug.Trace
+
+import GHC.Types
+import GHC.Prim
+import GHC.IO
+import GHC.Int
+import GHC.Conc
+
+benchCode :: String
+benchCode = "RBTreeMutUSTM"
+
+-- data Node k v where
+-- Node :: { key :: !k
+-- , value :: !v
+-- , parent :: mutable (Node k v)
+-- , left :: mutable (Node k v)
+-- , right :: mutable (Node k v)
+-- , color :: mutable Color
+-- } :: STM (Node k v)
+-- Nil :: Node k v
+-- TODO: record syntax.
+
+type TRef a = Ref# RealWorld a
+type TRefInt = RefU# RealWorld Int#
+
+readTRef :: TRef a -> STM a
+readTRef r = STM (\s# -> readTRef# r s#)
+
+writeTRef :: TRef a -> a -> STM ()
+writeTRef r l = STM (\s1# -> case writeTRef# r l s1# of
+ s2# -> (# s2#, () #))
+
+readTRefInt :: TRefInt -> STM Int
+readTRefInt r = STM (\s# -> case readTRefInt# r s# of
+ (# s2#, i# #) -> (# s2#, I# i# #))
+
+writeTRefInt :: TRefInt -> Int -> STM ()
+writeTRefInt r (I# i#) = STM (\s1# -> case writeTRefInt# r i# s1# of
+ s2# -> (# s2#, () #))
+
+
+data Node k v where
+ Node :: !k
+ -> !v
+ -> mutable (Node k v)
+ -> mutable (Node k v)
+ -> mutable (Node k v)
+ -> mutable Int#
+ -> STM (Node k v)
+ Nil :: Node k v
+
+
+key :: Node k v -> k
+key (Node k _ _ _ _ _) = k
+
+value :: Node k v -> v
+value (Node _ v _ _ _ _) = v
+
+parent :: Node k v -> TRef (Node k v)
+parent (Node _ _ p _ _ _) = p
+
+left :: Node k v -> TRef (Node k v)
+left (Node _ _ _ l _ _) = l
+
+right :: Node k v -> TRef (Node k v)
+right (Node _ _ _ _ r _) = r
+
+color :: Node k v -> TRefInt
+color (Node _ _ _ _ _ c) = c
+
+rED :: Int
+rED = 0
+
+bLACK :: Int
+bLACK = 1
+
+instance (Show k, Show v) => Show (Node k v) where
+ show Nil = "Nil"
+ show (Node k v _ _ _ _) = show ("Node " ++ show k ++ " " ++ show v)
+
+instance Eq k => Eq (Node k v) where
+ Nil == Nil = True
+ Nil == _ = False
+ _ == Nil = False
+
+-- x == y = case reallyUnsafePtrEquality# x y of
+-- 0# -> False
+-- _ -> True
+-- TODO: This caused a problem in unarize where it found a mutable
+-- UnaryRep in the alt.
+ (Node k _ _ _ _ _) == (Node k' _ _ _ _ _) = k == k'
+
+isNil :: Node k v -> Bool
+isNil Nil = True
+isNil _ = False
+
+isNode = not . isNil
+
+-- data RBTree k v where
+-- { root :: mutable (Node k v) } :: STM (RBTree k v)
+
+data RBTree k v where
+ RBTree :: mutable (Node k v) -> STM (RBTree k v)
+
+root :: RBTree k v -> TRef (Node k v)
+root (RBTree n) = n
+
+lookupNode :: Ord k => k -> Node k v -> STM (Node k v)
+lookupNode _ Nil = return Nil
+lookupNode s n@(Node k v _ tl tr _)
+ = case compare s k of
+ EQ -> return n
+ LT -> readTRef tl >>= lookupNode s
+ GT -> readTRef tr >>= lookupNode s
+
+lookup :: Ord k => k -> RBTree k v -> STM (Node k v)
+lookup k t = readTRef (root t) >>= lookupNode k
+
+rotateLeft :: (Eq v, Eq k) => RBTree k v -> Node k v -> STM ()
+rotateLeft s x = do
+ r <- readTRef (right x)
+ rl <- readTRef (left r)
+ writeTRef (right x) rl
+ when (isNode rl) $ writeTRef (parent rl) x
+
+ xp <- readTRef (parent x)
+ writeTRef (parent r) xp
+
+ if isNil xp
+ then writeTRef (root s) r
+ else do
+ xpl <- readTRef (left xp)
+ if xpl == x
+ then writeTRef (left xp) r
+ else writeTRef (right xp) r
+
+ writeTRef (left r) x
+ writeTRef (parent x) r
+
+
+rotateRight :: (Eq v, Eq k) => RBTree k v -> Node k v -> STM ()
+rotateRight s x = do
+ l <- readTRef (left x)
+ lr <- readTRef (right l)
+ writeTRef (left x) lr
+ when (isNode lr) $ writeTRef (parent lr) x
+
+ xp <- readTRef (parent x)
+ writeTRef (parent l) xp
+
+ if isNil xp
+ then writeTRef (root s) l
+ else do
+ xpr <- readTRef (right xp)
+ if xpr == x
+ then writeTRef (right xp) l
+ else writeTRef (left xp) l
+
+ writeTRef (right l) x
+ writeTRef (parent x) l
+
+setField :: (Node k v -> TRef a) -> a -> Node k v -> STM ()
+setField _ _ Nil = return ()
+setField f v x = writeTRef (f x) v
+
+setColor :: Int -> Node k v -> STM ()
+setColor _ Nil = return ()
+setColor c n = writeTRefInt (color n) c
+
+-- TODO: This complains about matching kinds...
+-- node _ Nil = return Nil
+-- node f x = f x
+--
+-- parentOf, leftOf, rightOf :: Node k v -> STM (Node k v)
+-- parentOf = node (readTRef . parent)
+-- leftOf = node (readTRef . left)
+-- rightOf = node (readTRef . right)
+
+
+readIfNode :: (Node k v -> TRef (Node k v)) -> Node k v -> STM (Node k v)
+readIfNode _ Nil = return Nil
+readIfNode f n = readTRef (f n)
+
+parentOf, leftOf, rightOf :: Node k v -> STM (Node k v)
+parentOf = readIfNode parent
+leftOf = readIfNode left
+rightOf = readIfNode right
+
+colorOf Nil = return bLACK
+colorOf x = readTRefInt (color x)
+
+isLeftBranch :: (Eq k, Eq v) => Node k v -> STM Bool
+isLeftBranch x = do
+ x' <- parentOf x >>= leftOf
+ return $ x == x'
+
+fixAfterInsertion :: (Eq k, Eq v) => RBTree k v -> Node k v -> STM ()
+fixAfterInsertion _ Nil = return ()
+fixAfterInsertion s x = do
+ setColor rED x
+
+ loop x
+
+ ro <- readTRef (root s)
+ c <- readTRefInt (color ro)
+ when (c /= bLACK ) $ writeTRefInt (color ro) bLACK
+ where
+ loop Nil = return ()
+ loop x = do
+ sr <- readTRef (root s)
+ if sr == x
+ then return ()
+ else body x >>= loop
+
+ body x = do
+ xp <- readTRef (parent x)
+ if isNil xp
+ then return Nil
+ else do
+ xpp <- parentOf xp
+ xppl <- leftOf xpp
+
+ c <- readTRefInt (color xp)
+
+ if c /= rED
+ then return Nil
+ else do
+ if xp == xppl
+ then handle x xp xpp rightOf rotateLeft rotateRight
+ else handle x xp xpp leftOf rotateRight rotateLeft
+
+ handle x xp xpp f ra rb = do
+ y <- f xpp
+ c <- colorOf y
+ if c == rED
+ then do
+ setColor bLACK xp
+ setColor bLACK y
+ setColor rED xpp
+ return xpp
+ else do
+ z <- f xp
+ (x',xp',xpp') <- if x == z
+ then do
+ ra s xp
+ xp' <- parentOf xp
+ xpp' <- parentOf xp'
+ return (xp,xp',xpp')
+ else return (x,xp,xpp)
+ setColor bLACK xp'
+ setColor rED xpp'
+ when (isNode xpp') $ rb s xpp'
+ return x'
+
+-- Note: we differ here in not taking a node argument of an exiting
+-- allocated node. The behavior when that argument is NULL in the original
+-- code is to have insert act like find.
+insert' :: (Eq v, Ord k) => RBTree k v -> k -> v -> STM (Node k v)
+insert' s k v = do
+ t <- readTRef (root s)
+ if isNil t
+ then do
+ n <- Node k v Nil Nil Nil 1# {- bLACK -}
+ writeTRef (root s) n
+ return Nil
+ else loop t
+ where
+ loop t = case compare k (key t) of
+ EQ -> return t
+ LT -> handle t left
+ GT -> handle t right
+
+ handle t f = do
+ tc <- readTRef (f t)
+ if isNode tc
+ then loop tc
+ else do
+ n <- Node k v t Nil Nil 1# {- bLACK -}
+ writeTRef (f t) n
+ fixAfterInsertion s n
+ return Nil
+
+successor :: (Eq k, Eq v) => Node k v -> STM (Node k v)
+successor Nil = return Nil
+successor t = do
+ r <- readTRef (right t)
+ if isNode r
+ then leftMost r
+ else readTRef (parent t) >>= rightParent t
+ where
+ leftMost p = do
+ l <- readTRef (left p)
+ case l of
+ Nil -> return p
+ _ -> leftMost l
+
+ rightParent _ Nil = return Nil
+ rightParent c p = do -- Find the first parent further right
+ r <- readTRef (right p)
+ if r == c
+ then readTRef (parent p) >>= rightParent p
+ else return p
+
+
+fixAfterDeletion :: (Eq k, Eq v) => RBTree k v -> Node k v -> STM ()
+fixAfterDeletion tree x = do
+ x' <- loop x
+ when (isNode x') $ do
+ c <- readTRefInt (color x')
+ when (c /= bLACK ) $ writeTRefInt (color x') bLACK
+ where
+ loop x = do
+ r <- readTRef (root tree)
+ case () of
+ () | x == r -> return x
+ | otherwise -> do
+ c <- colorOf x
+ if c /= bLACK
+ then return x
+ else body x >>= loop
+
+ body x = do
+ b <- isLeftBranch x
+ if b
+ then handle x rightOf leftOf rotateRight rotateLeft
+ else handle x leftOf rightOf rotateLeft rotateRight
+
+ handle x fR fL rotateR rotateL = do
+ s <- parentOf x >>= fR
+ c <- colorOf s
+ s' <- if c == rED
+ then do
+ setColor bLACK s
+ parentOf x >>= setColor rED
+ parentOf x >>= rotateL tree
+ parentOf x >>= fR
+ else return s
+ cl <- fL s' >>= colorOf
+ cr <- fR s' >>= colorOf
+ if cl == bLACK && cr == bLACK
+ then setColor rED s' >> parentOf x
+ else do
+ s'' <- if cr == bLACK
+ then do
+ fL s' >>= setColor bLACK
+ setColor rED s'
+ rotateR tree s'
+ parentOf x >>= fR
+ else return s'
+ p <- parentOf x
+ colorOf p >>= (`setColor` s'')
+ setColor bLACK p
+ fR s'' >>= setColor bLACK
+ rotateL tree p
+ readTRef (root tree)
+
+-- link in a new node replacing the given node with new
+-- key and value.
+replace :: (Eq k, Eq v) => k -> v -> RBTree k v -> Node k v -> STM (Node k v)
+replace k v t n@(Node _ _ rp rl rr rc) = do
+ p <- readTRef rp
+ l <- readTRef rl
+ r <- readTRef rr
+ (I# c) <- readTRefInt rc
+ n' <- Node k v p l r c
+ -- update the rest of the tree:
+ b <- isLeftBranch n
+ setField parent n' l -- Set left's parent to n'
+ setField parent n' r -- set right's parent to n'
+ if isNil p
+ then writeTRef (root t) n'
+ else setField (if b then left else right) n' p -- set parent's left or right to n'
+ return n'
+
+deleteNode :: (Eq k, Eq v) => RBTree k v -> Node k v -> STM (Node k v)
+deleteNode s p = do
+ l <- readTRef (left p)
+ r <- readTRef (right p)
+ p' <- if isNode l && isNode r
+ then do
+ suc <- successor p
+ replace (key suc) (value suc) s p
+ return suc
+ else return p
+
+ l' <- readTRef (left p')
+ rep <- if isNode l'
+ then return l'
+ else readTRef (right p')
+ pp <- readTRef (parent p')
+ if isNode rep
+ then do
+ writeTRef (parent rep) pp
+ if isNil pp
+ then writeTRef (root s) rep
+ else do
+ ppl <- readTRef (left pp)
+ if p' == ppl
+ then writeTRef (left pp) rep
+ else writeTRef (right pp) rep
+ writeTRef (left p') Nil
+ writeTRef (right p') Nil
+ writeTRef (parent p') Nil
+ c <- readTRefInt (color p')
+ when (c == bLACK ) $ fixAfterDeletion s rep
+ else if isNil pp
+ then writeTRef (root s) Nil
+ else do
+ c <- readTRefInt (color p')
+ when (c == bLACK ) $ fixAfterDeletion s p'
+ pp' <- readTRef (parent p')
+ when (isNode pp') $ do
+ ppl <- readTRef (left pp')
+ if p' == ppl
+ then writeTRef (left pp') Nil
+ else do
+ ppr <- readTRef (right pp')
+ when (p' == ppr) $ writeTRef (right pp') Nil
+ writeTRef (parent p') Nil
+ return p'
+
+----------------------------------
+-- Public API
+--
+mkRBTree :: STM (RBTree k v)
+mkRBTree = RBTree Nil
+
+-- insert :: (Eq v, Ord k) => RBTree k v -> k -> v -> STM Bool
+insert t k v = isNil <$> insert' t k v <* postVerify t
+
+preVerify _ = return ()
+postVerify _ = return ()
+-- Comment out the type signatures for insert and delete for verify code.
+-- preVerify = verify'
+-- postVerify = verify'
+
+-- delete :: (Eq v, Ord k) => RBTree k v -> k -> STM Bool
+delete t k = do
+ n <- lookup k t
+ if isNode n
+ then isNode <$> (preVerify t *> deleteNode t n <* postVerify t)
+ else return False
+
+update :: (Eq v, Ord k) => RBTree k v -> k -> v -> STM Bool
+update t k v = do
+ n <- insert' t k v
+ case n of
+ Node _ v' _ _ _ _ -> do
+ when (v /= v') $ replace k v t n >> return ()
+ return True
+ Nil -> return False
+
+
+get :: Ord k => RBTree k v -> k -> STM (Maybe v)
+get t k = do
+ n <- lookup k t
+ case n of
+ Node _ v _ _ _ _ -> return (Just v)
+ Nil -> return Nothing
+
+contains :: Ord k => RBTree k v -> k -> STM Bool
+contains t k = isNode <$> lookup k t
+
+----------------------------------------------------
+-- Test code
+--
+#ifdef TESTCODE
+
+unlessM bm a = do
+ b <- bm
+ unless b a
+
+verifyRedBlack :: (Show k, Show v, Eq k, Eq v) => Node k v -> Int -> STM Int
+verifyRedBlack Nil _ = return 1
+verifyRedBlack n d = do
+ l <- readTRef (left n)
+ r <- readTRef (right n)
+ c <- readTRefInt (color n)
+
+ hl <- verifyRedBlack l (d + 1)
+ hr <- verifyRedBlack r (d + 1)
+ if hl == 0 || hr == 0
+ then return 0
+ else do
+ when (hl /= hr) $ error ("Imbalance @depth=" ++ show d ++ " : " ++ show hl ++ " " ++ show hr)
+ lineage l
+ lineage r
+
+ c <- readTRefInt (color n)
+ if c == rED
+ then do
+ unlessM (isBlack l) $ error ("Expected black left of " ++ show (key n))
+ unlessM (isBlack r) $ error ("Expected black right of " ++ show (key n))
+ return hl
+ else return (hl + 1)
+ where
+ lineage Nil = return ()
+ lineage c = do
+ p <- readTRef (parent c)
+ when (p /= n) $ error ("lineage")
+
+ isBlack Nil = return True
+ isBlack n = readTRefInt (color n) >>= \c -> return (c == bLACK )
+
+assertEq s t v = readTRef t >>= \v' -> when (v /= v') $ error s
+assertIntEq s t v = readTRefInt t >>= \v' -> when (v /= v') $ error s
+
+{-
+inOrder :: Show k => Node k v -> STM [k]
+inOrder Nil = trace "." $ return []
+inOrder n = do
+ l <- readTRef (left n)
+ ol <- trace "(" $ inOrder l
+
+ c <- readTRefInt (color n)
+ r <- trace (if c == rED then "r" else "b") $ readTRef (right n)
+ -- r <- trace (show (key n)) $ readTRef (right n)
+ or <- inOrder r
+ trace ")" $ return $ ol ++ [key n] ++ or
+-- -}
+{--}
+inOrder :: Show k => Node k v -> STM [k]
+inOrder Nil = return []
+inOrder n = do
+ l <- readTRef (left n)
+ ol <- inOrder l
+ r <- readTRef (right n)
+ or <- inOrder r
+ return $ ol ++ [key n] ++ or
+-- -}
+verifyOrder :: (Ord k, Show k) => Node k v -> STM ()
+verifyOrder Nil = return ()
+verifyOrder n = do
+ es <- inOrder n
+ unless (sort es == es) $ error "Ordering."
+
+verifyLinks Nil Nil _ = return ()
+verifyLinks Nil n as = do
+ l <- readTRef (left n)
+ r <- readTRef (right n)
+
+-- case l of
+-- Node k v _ _ _ _ -> print ("l: Node", k, v)
+-- Nil -> print "l: Nil"
+
+-- case r of
+-- Node k v _ _ _ _ -> print ("r: Node", k, v)
+-- Nil -> print "r: Nil"
+
+ assertM "left loop" $ return (l `notElem` as)
+ assertM "right loop" $ return (r `notElem` as)
+
+ when (isNode l) $ verifyLinks n l (l:as)
+ when (isNode r) $ verifyLinks n r (r:as)
+verifyLinks p Nil _ = return ()
+verifyLinks p n as = do
+ p' <- readTRef (parent n)
+ if p /= p'
+ then print (p, p')
+ else return ()
+ assertM "parent mismatch" $ return (p == p')
+ verifyLinks Nil n as
+
+verify' t = do
+ r <- readTRef (root t)
+ verifyLinks Nil r []
+
+verify :: (Eq k, Eq v, Ord k, Show v, Show k) => RBTree k v -> STM Int
+verify t = do
+ r <- readTRef (root t)
+ if isNil r
+ then print ("root is Nil") >> return 1
+ else do
+
+-- case r of
+-- Node k v _ _ _ _ -> print ("Node", k, v)
+-- Nil -> print "Nil"
+
+ assertEq ("Root parent not Nil " ++ show (key r)) (parent r) Nil
+ assertIntEq ("Root color not Black " ++ show (key r)) (color r) bLACK
+
+ verifyLinks Nil r ([])
+ verifyOrder r
+ verifyRedBlack r 0
+
+assertM s v = do
+ b <- v
+ unless b $ error s
+
+insertTest :: [Int] -> STM Int
+insertTest as = do
+ r <- mkRBTree
+ forM_ as $ \a -> do
+ -- print ("insert", a)
+ assertM "Insert failed" $ insert r a a
+ verify r
+ verify r
+
+deleteTest :: [Int] -> [Int] -> STM ()
+deleteTest as bs = do
+ r <- mkRBTree
+ forM_ as $ \a -> do
+ assertM "insert failed" $ insert r a a
+ verify r
+ forM_ bs $ \b -> do
+ assertM "delete failed" $ delete r b
+ verify r
+
+testMain' = do
+ insertTest [4,6,9,1,8,7,2]
+
+testMain'' = do
+ forM_ (inits [4,6,9,1,8,7,2,3,0,5]) $ \as -> do
+ putStrLn $ "Inserting " ++ show as
+ insertTest as
+
+testMain''' = do
+ forM_ (zip (inits [4,6,9,1,8,7,2,3,0,5]) (map reverse (inits [4,6,9,1,8,7,2,3,0,5]))) $ \(as,bs) -> do
+ putStrLn $ "Inserting " ++ show as ++ " deleting " ++ show bs
+ insertTest as
+
+testMain = do
+ let as = [92,86,34,84, 5,64, 1, 87,11,39
+ ,17,15,13,66,63,38,69, 67,88,16
+ , 9,95,31,96,19,33,21, 27,65,10
+ ,23,32,80,41,36,14,37, 54,98,51
+ ,55,45,43,97,61,60, 2, 12,49,85
+ , 8,76,46,78,48,56,35,100,29,90
+ ,99,70,73,52,81,20, 3, 68,22,83
+ ,71,72, 4,74,47,94,77, 89,59,91
+ ,93,75,25,50, 6,58, 7, 62,53,40
+ ,26,24,42,30,18,28,79, 82,44,57
+ ]
+ forM_ (inits as) $ \bs -> do
+ putStrLn $ "Inserting " ++ show bs
+ insertTest bs
+#endif
diff --git a/benchmarks/PPoPP2019/src/RBTreeNode.hs b/benchmarks/PPoPP2019/src/RBTreeNode.hs
new file mode 100644
index 0000000..3daaf82
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/RBTreeNode.hs
@@ -0,0 +1,283 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+module RBTreeNode
+ ( Node(..)
+ , Key
+ , Value
+ , Color(..)
+ , writeKey
+ , writeColor
+ , writeValue
+ , writeParent
+ , writeLeft
+ , writeRight
+
+ , writeKeyP
+ , writeColorP
+ , writeValueP
+ , writeParentP
+ , writeLeftP
+ , writeRightP
+
+ , parent
+ , left
+ , right
+ , key
+ , value
+ , color
+ , mkNode
+ , nil
+
+ , lookupNode'
+ ) where
+
+import GHC.Num
+import GHC.ST
+import GHC.Base
+import GHC.Conc
+import GHC.Word
+import GHC.Prim
+
+import System.IO.Unsafe (unsafePerformIO)
+
+#define KEY 0
+#define VALUE 1
+#define COLOR 2
+
+-- #define SEPARATE_POINTERS
+#ifdef SEPARATE_POINTERS
+#define PARENT 0
+#define LEFT 8
+#define RIGHT 16
+#define PTRS 24
+#define WORDS 3
+#define PTRSZH 24#
+#define WORDSZH 3#
+#else
+#define PARENT 0
+#define LEFT 1
+#define RIGHT 2
+#define PTRS 3
+#define WORDS 3
+#define PTRSZH 3#
+#define WORDSZH 3#
+#endif
+
+type Key = Word
+type Value = Word
+
+-- data Node = Node {-# UNPACK #-} !(STMMutableArray# RealWorld Node) | Nil
+data Node = Node { unNode :: !(STMMutableArray# RealWorld Any) }
+
+{-# NOINLINE nil' #-}
+nil' :: Node
+nil' = unsafePerformIO $ do
+ !n <- rawNil
+ writePIO n LEFT n
+ writePIO n RIGHT n
+ writePIO n PARENT n
+ return n
+ where
+ writePIO marr (W# w#) (Node !a) = IO $ \s# ->
+ case writeSTMArray# (unNode marr) (word2Int# w#) (unsafeCoerce# a) s# of
+ s2# -> (# s2#, () #)
+
+ rawNil = IO $ \s1# ->
+ case newSTMArray# PTRSZH WORDSZH undefined s1# of
+ (# s2#, marr# #) -> (# s2#, Node marr# #)
+
+{-# NOINLINE nil #-}
+nil :: Node
+nil = unsafePerformIO $ rawNil
+ where
+ rawNil = IO $ \s1# ->
+ case newSTMArray# PTRSZH WORDSZH undefined s1# of
+ (# s2#, marr# #) ->
+ case writeSTMArray# marr# 0# (unsafeCoerce# marr#) s2# of
+ s3# ->
+ case writeSTMArray# marr# 1# (unsafeCoerce# marr#) s3# of
+ s4# ->
+ case writeSTMArray# marr# 2# (unsafeCoerce# marr#) s4# of
+ s5# -> (# s5#, Node marr# #)
+
+lookupNode' :: Key -> Node -> STM Node
+lookupNode' (W# k#) !(Node !a#) = STM $ \s# -> go a# s#
+ where
+ !(Node !nil#) = nil
+
+ go a# s1# =
+ case sameSTMMutableArray# a# nil# of
+ 1# -> (# s1#, nil #)
+ _ -> case readTArrayWord# a# 0## s1# of
+ (# s2#, w# #) ->
+ case k# `eqWord#` w# of
+ 1# -> (# s2#, Node a# #)
+ _ -> case k# `ltWord#` w# of
+ 1# -> case readTArray# a# 1## s2# of
+ (# s3#, a #) -> go (unsafeCoerce# a) s3#
+ _ -> case readTArray# a# 2## s2# of
+ (# s3#, a #) -> go (unsafeCoerce# a) s3#
+
+
+data Color = Red | Black
+ deriving (Eq, Show, Read)
+
+newNode :: Int -> Int -> Node -> STM Node
+newNode (I# ptrs#) (I# words#) (Node !a) = STM $ \s1# ->
+ case newSTMArray# ptrs# words# (unsafeCoerce# a) s1# of
+ (# s2#, marr# #) -> (# s2#, Node marr# #)
+{-# INLINE newNode #-}
+
+unsafeReadNode :: Node -> Word -> STM Node
+unsafeReadNode marr (W# w#) = STM $ \s# ->
+ case readTArray# (unNode marr) w# s# of
+ (# s2#, a #) -> (# s2#, Node (unsafeCoerce# a) #)
+{-# INLINE unsafeReadNode #-}
+
+unsafeWriteNode :: Node -> Word -> Node -> STM ()
+unsafeWriteNode marr (W# w#) (Node !a) = STM $ \s# ->
+ case writeTArray# (unNode marr) w# (unsafeCoerce# a) s# of
+ s2# -> (# s2#, () #)
+{-# INLINE unsafeWriteNode #-}
+
+unsafeWriteNodeP :: Node -> Word -> Node -> STM ()
+unsafeWriteNodeP marr (W# w#) (Node !a) = STM $ \s# ->
+ case writeSTMArray# (unNode marr) (word2Int# w#) (unsafeCoerce# a) s# of
+ s2# -> (# s2#, () #)
+{-# INLINE unsafeWriteNodeP #-}
+
+unsafeReadNodeWord :: Node -> Word -> STM Word
+unsafeReadNodeWord marr (W# wi#) = STM $ \s# ->
+ case readTArrayWord# (unNode marr) wi# s# of
+ (# s2#, w# #) -> (# s2#, W# w# #)
+{-# INLINE unsafeReadNodeWord #-}
+
+unsafeWriteNodeWord :: Node -> Word -> Word -> STM ()
+unsafeWriteNodeWord marr (W# wi#) (W# w#) = STM $ \s# ->
+ case writeTArrayWord# (unNode marr) wi# w# s# of
+ s2# -> (# s2#, () #)
+{-# INLINE unsafeWriteNodeWord #-}
+
+unsafeWriteNodeWordP :: Node -> Word -> Word -> STM ()
+unsafeWriteNodeWordP marr (W# wi#) (W# w#) = STM $ \s# ->
+ case writeSTMArrayWord# (unNode marr) (word2Int# wi#) w# s# of
+ s2# -> (# s2#, () #)
+{-# INLINE unsafeWriteNodeWordP #-}
+
+lengthNode :: Node -> Int
+lengthNode marr = I# (sizeofSTMMutableArray# (unNode marr))
+{-# INLINE lengthNode #-}
+
+lengthNodeWords :: Node -> Int
+lengthNodeWords marr = I# (sizeofSTMMutableArrayWords# (unNode marr))
+{-# INLINE lengthNodeWords #-}
+
+instance Eq Node where
+ (Node t) == (Node t') =
+ case sameSTMMutableArray# t t' of
+ 0# -> False
+ _ -> True
+
+
+writeKey :: Node -> Word -> STM ()
+writeKey s x = unsafeWriteNodeWord s KEY x
+{-# INLINE writeKey #-}
+
+writeKeyP :: Node -> Word -> STM ()
+writeKeyP s x = unsafeWriteNodeWordP s KEY x
+{-# INLINE writeKeyP #-}
+
+writeValue :: Node -> Word -> STM ()
+writeValue s x = unsafeWriteNodeWord s VALUE x
+{-# INLINE writeValue #-}
+
+writeValueP :: Node -> Word -> STM ()
+writeValueP s x = unsafeWriteNodeWordP s VALUE x
+{-# INLINE writeValueP #-}
+
+writeColor :: Node -> Color -> STM ()
+writeColor s Black = unsafeWriteNodeWord s COLOR 0
+writeColor s Red = unsafeWriteNodeWord s COLOR 1
+{-# INLINE writeColor #-}
+
+writeColorP :: Node -> Color -> STM ()
+writeColorP s Black = unsafeWriteNodeWordP s COLOR 0
+writeColorP s Red = unsafeWriteNodeWordP s COLOR 1
+{-# INLINE writeColorP #-}
+
+writeParent :: Node -> Node -> STM ()
+writeParent s x = unsafeWriteNode s PARENT x
+{-# INLINE writeParent #-}
+
+writeLeft :: Node -> Node -> STM ()
+writeLeft s x = unsafeWriteNode s LEFT x
+{-# INLINE writeLeft #-}
+
+writeRight :: Node -> Node -> STM ()
+writeRight s x = unsafeWriteNode s RIGHT x
+{-# INLINE writeRight #-}
+
+writeParentP :: Node -> Node -> STM ()
+writeParentP s x = unsafeWriteNodeP s PARENT x
+{-# INLINE writeParentP #-}
+
+writeLeftP :: Node -> Node -> STM ()
+writeLeftP s x = unsafeWriteNodeP s LEFT x
+{-# INLINE writeLeftP #-}
+
+writeRightP :: Node -> Node -> STM ()
+writeRightP s x = unsafeWriteNodeP s RIGHT x
+{-# INLINE writeRightP #-}
+
+mkNode :: Key -> Value -> Color -> STM Node
+mkNode k v c = do
+ s <- newNode PTRS WORDS nil
+ -- We just made the node so it is private and we can access it
+ -- non-transactionally.
+ writeKeyP s k
+ writeValueP s v
+ writeColorP s c
+ return s
+{-# INLINE mkNode #-}
+
+key :: Node -> STM Key
+key s = unsafeReadNodeWord s KEY
+{- For non-monomorphic keys we need to do something else for nil (which
+ - shouldn't be compaired anyway! So this should just go away...
+key s
+ | s == nil = return 0
+ | otherwise = unsafeReadNodeWord s KEY
+-}
+{-# INLINE key #-}
+
+value :: Node -> STM Value
+value s = unsafeReadNodeWord s VALUE
+{- See key
+value s
+ | s == nil = return 0
+ | otherwise = unsafeReadNodeWord s VALUE
+-}
+{-# INLINE value #-}
+
+color :: Node -> STM Color
+color s = do
+ w <- unsafeReadNodeWord s COLOR
+ case w == (0 :: Word) of
+ True -> return Black
+ _ -> return Red
+{-# INLINE color #-}
+
+parent :: Node -> STM Node
+parent s = unsafeReadNode s PARENT
+{-# INLINE parent #-}
+
+left :: Node -> STM Node
+left s = unsafeReadNode s LEFT
+{-# INLINE left #-}
+
+right :: Node -> STM Node
+right s = unsafeReadNode s RIGHT
+{-# INLINE right #-}
+
diff --git a/benchmarks/PPoPP2019/src/RBTreeTStruct.hs b/benchmarks/PPoPP2019/src/RBTreeTStruct.hs
new file mode 100644
index 0000000..7609dd6
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/RBTreeTStruct.hs
@@ -0,0 +1,554 @@
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE CPP #-}
+module RBTreeTStruct
+ ( RBTree
+ , mkRBTree
+
+ , insert
+ , delete
+ , update
+ , get
+ , contains
+
+ , benchCode
+#ifdef TESTCODE
+ , testMain
+
+ , verify
+#endif
+ ) where
+
+import Prelude hiding (lookup)
+
+import GHC.Conc.Sync
+import Control.Applicative
+import Control.Monad
+import Control.Exception
+
+import Data.List (sort,inits)
+import Data.Word
+import Debug.Trace
+
+import System.IO.Unsafe
+import RBTreeNode
+
+import GHC.Conc(unsafeIOToSTM)
+
+benchCode :: String
+benchCode = "RBTreeTStruct"
+
+isNil :: Node -> Bool
+isNil s = s == nil
+
+isNode = not . isNil
+
+newtype RBTree = RBTree { root :: TVar Node }
+
+lookupNode :: Key -> Node -> STM Node
+lookupNode k n
+ | n == nil = return nil
+ | otherwise = do
+ k' <- key n
+ case compare k k' of
+ EQ -> return n
+ LT -> left n >>= lookupNode k
+ GT -> right n >>= lookupNode k
+
+lookup :: Word -> RBTree -> STM Node
+lookup k t = readTVar (root t) >>= lookupNode' k
+
+rotateLeft :: RBTree -> Node -> STM ()
+rotateLeft s x = do
+ r <- right x
+ rl <- left r
+ writeRight x rl
+ when (isNode rl) $ writeParent rl x
+
+ xp <- parent x
+ writeParent r xp
+
+ if isNil xp
+ then writeTVar (root s) r
+ else do
+ xpl <- left xp
+ if xpl == x
+ then writeLeft xp r
+ else writeRight xp r
+
+ writeLeft r x
+ writeParent x r
+
+
+rotateRight :: RBTree -> Node -> STM ()
+rotateRight s x = do
+ l <- left x
+ lr <- right l
+ writeLeft x lr
+ when (isNode lr) $ writeParent lr x
+
+ xp <- parent x
+ writeParent l xp
+
+ if isNil xp
+ then writeTVar (root s) l
+ else do
+ xpr <- right xp
+ if xpr == x
+ then writeRight xp l
+ else writeLeft xp l
+
+ writeRight l x
+ writeParent x l
+
+setColor :: Color -> Node -> STM ()
+setColor c n = writeColor n c
+
+node f x
+ | x == nil = return nil
+ | otherwise = f x
+
+parentOf, leftOf, rightOf :: Node -> STM Node
+parentOf = node parent
+leftOf = node left
+rightOf = node right
+
+colorOf x
+ | x == nil = return Black
+ | otherwise = color x
+
+isLeftBranch :: Node -> STM Bool
+isLeftBranch x = do
+ x' <- parentOf x >>= leftOf
+ return $ x == x'
+
+fixAfterInsertion :: RBTree -> Node -> STM ()
+fixAfterInsertion s x
+ | x == nil = return ()
+ | otherwise = do
+ setColor Red x
+
+ loop x
+
+ ro <- readTVar (root s)
+ c <- color ro
+ when (c /= Black) $ writeColor ro Black
+ where
+ loop x
+ | x == nil = return ()
+ | otherwise = do
+ sr <- readTVar (root s)
+ if sr == x
+ then return ()
+ else body x >>= loop
+
+ body x = do
+ xp <- parent x
+ if isNil xp
+ then return nil
+ else do
+ xpp <- parentOf xp
+ xppl <- leftOf xpp
+
+ c <- color xp
+
+ if c /= Red
+ then return nil
+ else do
+ if xp == xppl
+ then handle x xp xpp rightOf rotateLeft rotateRight
+ else handle x xp xpp leftOf rotateRight rotateLeft
+
+ handle x xp xpp f ra rb = do
+ y <- f xpp
+ c <- colorOf y
+ if c == Red
+ then do
+ setColor Black xp
+ setColor Black y
+ setColor Red xpp
+ return xpp
+ else do
+ z <- f xp
+ (x',xp',xpp') <- if x == z
+ then do
+ ra s xp
+ xp' <- parentOf xp
+ xpp' <- parentOf xp'
+ return (xp,xp',xpp')
+ else return (x,xp,xpp)
+ setColor Black xp'
+ setColor Red xpp'
+ when (isNode xpp') $ rb s xpp'
+ return x'
+
+
+-- Note: we differ here in not taking a node argument of an exiting
+-- allocated node. The behavior when that argument is NULL in the original
+-- code is to have insert act like find.
+insert' :: RBTree -> Key -> Value -> STM Node
+insert' s k v = do
+ t <- readTVar (root s)
+ if isNil t
+ then do
+ n <- mkNode k v Black
+ writeTVar (root s) n
+ return nil
+ else loop t
+ where
+ loop t = key t >>= \k' -> case compare k k' of
+ EQ -> return t
+ LT -> handle t left writeLeft
+ GT -> handle t right writeRight
+
+ handle t get set = do
+ tc <- get t
+ if isNode tc
+ then loop tc
+ else do
+ n <- mkNode k v Black
+ writeParentP n t -- non-transactional access
+ set t n
+ fixAfterInsertion s n
+ return nil
+
+successor :: Node -> STM Node
+successor t
+ | t == nil = return nil
+ | otherwise = do
+ r <- right t
+ if isNode r
+ then leftMost r
+ else parent t >>= rightParent t
+ where
+ leftMost p = do
+ l <- left p
+ if isNil l
+ then return p
+ else leftMost l
+
+ rightParent c p
+ | p == nil = return nil
+ | otherwise = do -- Find the first parent further right
+ r <- right p
+ if r == c
+ then parent p >>= rightParent p
+ else return p
+
+fixAfterDeletion :: RBTree -> Node -> STM ()
+fixAfterDeletion tree x = do
+ x' <- loop x
+ when (isNode x') $ do
+ c <- color x'
+ when (c /= Black) $ writeColor x' Black
+ where
+ loop x = do
+ r <- readTVar (root tree)
+ case () of
+ () | x == r -> return x
+ | otherwise -> do
+ c <- colorOf x
+ if c /= Black
+ then return x
+ else body x >>= loop
+
+ body x = do
+ b <- isLeftBranch x
+ if b
+ then handle x rightOf leftOf rotateRight rotateLeft
+ else handle x leftOf rightOf rotateLeft rotateRight
+
+ handle x fR fL rotateR rotateL = do
+ s <- parentOf x >>= fR
+ c <- colorOf s
+ s' <- if c == Red
+ then do
+ setColor Black s
+ parentOf x >>= setColor Red
+ parentOf x >>= rotateL tree
+ parentOf x >>= fR
+ else return s
+ cl <- fL s' >>= colorOf
+ cr <- fR s' >>= colorOf
+ if cl == Black && cr == Black
+ then setColor Red s' >> parentOf x
+ else do
+ s'' <- if cr == Black
+ then do
+ fL s' >>= setColor Black
+ setColor Red s'
+ rotateR tree s'
+ parentOf x >>= fR
+ else return s'
+ p <- parentOf x
+ colorOf p >>= (`setColor` s'')
+ setColor Black p
+ fR s'' >>= setColor Black
+ rotateL tree p
+ readTVar (root tree)
+
+-- Update key and value in a node in place.
+updateKV :: Key -> Value -> Node -> STM ()
+updateKV k v n = do
+ writeKey n k
+ writeValue n v
+
+deleteNode :: RBTree -> Node -> STM Node
+deleteNode s p = do
+ l <- left p
+ r <- right p
+ p' <- if isNode l && isNode r
+ then do
+ suc <- successor p
+ k <- key suc
+ v <- value suc
+ updateKV k v p
+ return suc
+ else return p
+
+ l' <- left p'
+ rep <- if isNode l'
+ then return l'
+ else right p'
+ pp <- parent p'
+ if isNode rep
+ then do
+ writeParent rep pp
+ if isNil pp
+ then writeTVar (root s) rep
+ else do
+ ppl <- left pp
+ if p' == ppl
+ then writeLeft pp rep
+ else writeRight pp rep
+ writeLeft p' nil
+ writeRight p' nil
+ writeParent p' nil
+ c <- color p'
+ when (c == Black) $ fixAfterDeletion s rep
+ else if isNil pp
+ then writeTVar (root s) nil
+ else do
+ c <- color p'
+ when (c == Black) $ fixAfterDeletion s p'
+ pp' <- parent p'
+ when (isNode pp') $ do
+ ppl <- left pp'
+ if p' == ppl
+ then writeLeft pp' nil
+ else do
+ ppr <- right pp'
+ when (p' == ppr) $ writeRight pp' nil
+ writeParent p' nil
+ return p'
+
+----------------------------------
+-- Public API
+--
+mkRBTree :: STM (RBTree)
+mkRBTree = RBTree <$> newTVar nil
+
+insert :: RBTree -> Key -> Value -> STM Bool
+insert t k v = do
+ isNil <$> insert' t k v <* postVerify t
+
+{-
+verifyContains t k = do
+ b <- contains t k
+ if b
+ then return ()
+ else error ("Expected key " ++ show k)
+
+verifyDelete t k = do
+ b <- contains t k
+ if not b
+ then return ()
+ else error ("Found deleted key " ++ show k)
+-}
+preVerify _ = return ()
+postVerify _ = return ()
+-- preVerify = verify'
+-- postVerify = verify'
+
+delete :: RBTree -> Key -> STM Bool
+delete t k = do
+ n <- lookup k t
+ if isNode n
+ then isNode <$> (preVerify t *> deleteNode t n <* postVerify t)
+ else return False
+
+update :: RBTree -> Key -> Value -> STM Bool
+update t k v = do
+ n <- insert' t k v
+ if isNil n
+ then return False
+ else do
+ v' <- value n
+ when (v /= v') $ updateKV k v n
+ return True
+
+get :: RBTree -> Key -> STM (Maybe Value)
+get t k = do
+ n <- lookup k t
+ if isNil n
+ then return Nothing
+ else Just <$> value n
+
+contains :: RBTree -> Key -> STM Bool
+contains t k = isNode <$> lookup k t
+
+----------------------------------------------------
+-- Test code
+--
+-- #define TESTCODE
+#ifdef TESTCODE
+
+unlessM bm a = do
+ b <- bm
+ unless b a
+
+verifyRedBlack :: Node -> Int -> STM Int
+verifyRedBlack n d
+ | n == nil = return 1
+ | otherwise = do
+ l <- left n
+ r <- right n
+ c <- color n
+
+ hl <- verifyRedBlack l (d + 1)
+ hr <- verifyRedBlack r (d + 1)
+ if hl == 0 || hr == 0
+ then return 0
+ else do
+ when (hl /= hr) $ error ("Imbalance @depth=" ++ show d ++ " : " ++ show hl ++ " " ++ show hr)
+ lineage l
+ lineage r
+
+ c <- color n
+ if c == Red
+ then do
+ unlessM (isBlack l) $ key n >>= \k -> error ("Expected black left of " ++ show k)
+ unlessM (isBlack r) $ key n >>= \k -> error ("Expected black right of " ++ show k)
+ return hl
+ else return (hl + 1)
+ where
+ lineage c
+ | c == nil = return ()
+ | otherwise = do
+ p <- parent c
+ when (p /= n) $ error ("lineage")
+
+ isBlack n
+ | n == nil = return True
+ | otherwise = color n >>= \c -> return (c == Black)
+
+assertEq s get v = get >>= \v' -> when (v /= v') $ error s
+
+inOrder :: Node -> STM [Key]
+inOrder n
+ | n == nil = return []
+ | otherwise = do
+ l <- left n
+ ol <- inOrder l
+ r <- right n
+ or <- inOrder r
+ k <- key n
+ return $ ol ++ [k] ++ or
+
+verifyOrder :: Node -> STM ()
+verifyOrder n
+ | n == nil = return ()
+ | otherwise = do
+ es <- inOrder n
+ unless (sort es == es) $ error "Ordering."
+
+verifyLinks p n as
+ | p == nil && n == nil = return ()
+ | p == nil = do
+ l <- left n
+ r <- right n
+
+ assertM "left loop" $ return (l `notElem` as)
+ assertM "right loop" $ return (r `notElem` as)
+
+ when (isNode l) $ verifyLinks n l (l:as)
+ when (isNode r) $ verifyLinks n r (r:as)
+ | n == nil = return ()
+ | otherwise = do
+ p' <- parent n
+ assertM "parent mismatch" $ return (p == p')
+ verifyLinks nil n as
+
+verify' t = do
+ r <- readTVar (root t)
+ verifyLinks nil r []
+
+debug :: String -> STM ()
+debug s = return $ unsafePerformIO $ putStrLn s
+
+verify :: RBTree -> STM Int
+verify t = do
+ debug $ "Verifying."
+ r <- readTVar (root t)
+ if isNil r
+ then return 1
+ else do
+ k <- key r
+ assertEq ("Root parent not Nil " ++ show k) (parent r) nil
+ assertEq ("Root color not Black " ++ show k) (color r) Black
+
+ verifyLinks nil r ([])
+ verifyOrder r
+ verifyRedBlack r 0
+
+assertM s v = do
+ b <- v
+ unless b $ error s
+
+insertTest :: [Key] -> IO Int
+insertTest as = atomically $ do
+ r <- mkRBTree
+ debug $ "Tree made."
+ forM_ as $ \a -> do
+ debug $ "Inserting " ++ show a
+ assertM "Insert failed" $ insert r a a
+ verify r
+
+deleteTest :: [Key] -> [Key] -> IO ()
+deleteTest as bs = atomically $ do
+ r <- mkRBTree
+ forM_ as $ \a -> do
+ assertM "insert failed" $ insert r a a
+ verify r
+ forM_ bs $ \b -> do
+ assertM "delete failed" $ delete r b
+ verify r
+
+testMain' = do
+ insertTest [4,6,9,1,8,7,2]
+
+testMain'' = do
+ forM_ (inits [4,6,9,1,8,7,2,3,0,5]) $ \as -> do
+ putStrLn $ "Inserting " ++ show as
+ insertTest as
+
+testMain''' = do
+ forM_ (zip (inits [4,6,9,1,8,7,2,3,0,5]) (map reverse (inits [4,6,9,1,8,7,2,3,0,5]))) $ \(as,bs) -> do
+ putStrLn $ "Inserting " ++ show as ++ " deleting " ++ show bs
+ insertTest as
+
+testMain = do
+ let as = [92,86,34,84, 5,64, 1, 87,11,39
+ ,17,15,13,66,63,38,69, 67,88,16
+ , 9,95,31,96,19,33,21, 27,65,10
+ ,23,32,80,41,36,14,37, 54,98,51
+ ,55,45,43,97,61,60, 2, 12,49,85
+ , 8,76,46,78,48,56,35,100,29,90
+ ,99,70,73,52,81,20, 3, 68,22,83
+ ,71,72, 4,74,47,94,77, 89,59,91
+ ,93,75,25,50, 6,58, 7, 62,53,40
+ ,26,24,42,30,18,28,79, 82,44,57
+ ]
+ forM_ (inits as) $ \bs -> do
+ putStrLn $ "Inserting " ++ show bs
+ insertTest bs
+#endif
diff --git a/benchmarks/PPoPP2019/src/RBTreeTVar.hs b/benchmarks/PPoPP2019/src/RBTreeTVar.hs
new file mode 100644
index 0000000..d1f85b7
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/RBTreeTVar.hs
@@ -0,0 +1,564 @@
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE CPP #-}
+module RBTreeTVar
+ ( RBTree
+ , mkRBTree
+
+ , insert
+ , delete
+ , update
+ , get
+ , contains
+
+ , benchCode
+#ifdef TESTCODE
+ , testMain
+
+ , verify
+#endif
+ ) where
+
+import Prelude hiding (lookup)
+
+import GHC.Conc.Sync
+import Control.Applicative
+import Control.Monad
+import Control.Exception
+
+import Data.List (sort,inits)
+import Debug.Trace
+
+benchCode :: String
+benchCode = "RBTreeTVar"
+
+data Node k v
+ = Node { key :: !k
+ , value :: !v
+ , parent :: TVar (Node k v)
+ , left :: TVar (Node k v)
+ , right :: TVar (Node k v)
+ , color :: TVar Color
+ }
+ | Nil
+
+instance Eq k => Eq (Node k v) where
+ Nil == Nil = True
+ Nil == _ = False
+ _ == Nil = False
+
+ (Node k _ _ _ _ _) == (Node k' _ _ _ _ _) = k == k'
+
+isNil :: Node k v -> Bool
+isNil Nil = True
+isNil _ = False
+
+isNode = not . isNil
+
+data Color = Red | Black
+ deriving (Eq, Show, Read)
+
+newtype RBTree k v = RBTree { root :: TVar (Node k v) }
+
+lookupNode :: Ord k => k -> Node k v -> STM (Node k v)
+lookupNode _ Nil = return Nil
+lookupNode s n@(Node k v _ tl tr _)
+ = case compare s k of
+ EQ -> return n
+ LT -> readTVar tl >>= lookupNode s
+ GT -> readTVar tr >>= lookupNode s
+
+lookup :: Ord k => k -> RBTree k v -> STM (Node k v)
+lookup k t = readTVar (root t) >>= lookupNode k
+
+rotateLeft :: (Eq v, Eq k) => RBTree k v -> Node k v -> STM ()
+rotateLeft s x = do
+ r <- readTVar (right x)
+ rl <- readTVar (left r)
+ writeTVar (right x) rl
+ when (isNode rl) $ writeTVar (parent rl) x
+
+ xp <- readTVar (parent x)
+ writeTVar (parent r) xp
+
+ if isNil xp
+ then writeTVar (root s) r
+ else do
+ xpl <- readTVar (left xp)
+ if xpl == x
+ then writeTVar (left xp) r
+ else writeTVar (right xp) r
+
+ writeTVar (left r) x
+ writeTVar (parent x) r
+
+
+rotateRight :: (Eq v, Eq k) => RBTree k v -> Node k v -> STM ()
+rotateRight s x = do
+ l <- readTVar (left x)
+ lr <- readTVar (right l)
+ writeTVar (left x) lr
+ when (isNode lr) $ writeTVar (parent lr) x
+
+ xp <- readTVar (parent x)
+ writeTVar (parent l) xp
+
+ if isNil xp
+ then writeTVar (root s) l
+ else do
+ xpr <- readTVar (right xp)
+ if xpr == x
+ then writeTVar (right xp) l
+ else writeTVar (left xp) l
+
+ writeTVar (right l) x
+ writeTVar (parent x) l
+
+setField :: (Node k v -> TVar a) -> a -> Node k v -> STM ()
+setField _ _ Nil = return ()
+setField f v x = writeTVar (f x) v
+
+setColor :: Color -> Node k v -> STM ()
+setColor = setField color
+
+node _ Nil = return Nil
+node f x = f x
+
+parentOf, leftOf, rightOf :: Node k v -> STM (Node k v)
+parentOf = node (readTVar . parent)
+leftOf = node (readTVar . left)
+rightOf = node (readTVar . right)
+
+colorOf Nil = return Black
+colorOf x = readTVar (color x)
+
+isLeftBranch :: (Eq k, Eq v) => Node k v -> STM Bool
+isLeftBranch x = do
+ x' <- parentOf x >>= leftOf
+ return $ x == x'
+
+fixAfterInsertion :: (Eq k, Eq v) => RBTree k v -> Node k v -> STM ()
+fixAfterInsertion _ Nil = return ()
+fixAfterInsertion s x = do
+ setColor Red x
+
+ loop x
+
+ ro <- readTVar (root s)
+ c <- readTVar (color ro)
+ when (c /= Black) $ writeTVar (color ro) Black
+ where
+ loop Nil = return ()
+ loop x = do
+ sr <- readTVar (root s)
+ if sr == x
+ then return ()
+ else body x >>= loop
+
+ body x = do
+ xp <- readTVar (parent x)
+ if isNil xp
+ then return Nil
+ else do
+ xpp <- parentOf xp
+ xppl <- leftOf xpp
+
+ c <- readTVar (color xp)
+
+ if c /= Red
+ then return Nil
+ else do
+ if xp == xppl
+ then handle x xp xpp rightOf rotateLeft rotateRight
+ else handle x xp xpp leftOf rotateRight rotateLeft
+
+ handle x xp xpp f ra rb = do
+ y <- f xpp
+ c <- colorOf y
+ if c == Red
+ then do
+ setColor Black xp
+ setColor Black y
+ setColor Red xpp
+ return xpp
+ else do
+ z <- f xp
+ (x',xp',xpp') <- if x == z
+ then do
+ ra s xp
+ xp' <- parentOf xp
+ xpp' <- parentOf xp'
+ return (xp,xp',xpp')
+ else return (x,xp,xpp)
+ setColor Black xp'
+ setColor Red xpp'
+ when (isNode xpp') $ rb s xpp'
+ return x'
+
+-- Note: we differ here in not taking a node argument of an exiting
+-- allocated node. The behavior when that argument is NULL in the original
+-- code is to have insert act like find.
+insert' :: (Eq v, Ord k) => RBTree k v -> k -> v -> STM (Node k v)
+insert' s k v = do
+ t <- readTVar (root s)
+ if isNil t
+ then do
+ n <- Node k v
+ <$> newTVar Nil
+ <*> newTVar Nil
+ <*> newTVar Nil
+ <*> newTVar Black
+ writeTVar (root s) n
+ return Nil
+ else loop t
+ where
+ loop t = case compare k (key t) of
+ EQ -> return t
+ LT -> handle t left
+ GT -> handle t right
+
+ handle t f = do
+ tc <- readTVar (f t)
+ if isNode tc
+ then loop tc
+ else do
+ n <- Node k v
+ <$> newTVar t
+ <*> newTVar Nil
+ <*> newTVar Nil
+ <*> newTVar Black
+ writeTVar (f t) n
+ fixAfterInsertion s n
+ return Nil
+
+successor :: (Eq k, Eq v) => Node k v -> STM (Node k v)
+successor Nil = return Nil
+successor t = do
+ r <- readTVar (right t)
+ if isNode r
+ then leftMost r
+ else readTVar (parent t) >>= rightParent t
+ where
+ leftMost p = do
+ l <- readTVar (left p)
+ case l of
+ Nil -> return p
+ _ -> leftMost l
+
+ rightParent _ Nil = return Nil
+ rightParent c p = do -- Find the first parent further right
+ r <- readTVar (right p)
+ if r == c
+ then readTVar (parent p) >>= rightParent p
+ else return p
+
+
+fixAfterDeletion :: (Eq k, Eq v) => RBTree k v -> Node k v -> STM ()
+fixAfterDeletion tree x = do
+ x' <- loop x
+ when (isNode x') $ do
+ c <- readTVar (color x')
+ when (c /= Black) $ writeTVar (color x') Black
+ where
+ loop x = do
+ r <- readTVar (root tree)
+ case () of
+ () | x == r -> return x
+ | otherwise -> do
+ c <- colorOf x
+ if c /= Black
+ then return x
+ else body x >>= loop
+
+ body x = do
+ b <- isLeftBranch x
+ if b
+ then handle x rightOf leftOf rotateRight rotateLeft
+ else handle x leftOf rightOf rotateLeft rotateRight
+
+ handle x fR fL rotateR rotateL = do
+ s <- parentOf x >>= fR
+ c <- colorOf s
+ s' <- if c == Red
+ then do
+ setColor Black s
+ parentOf x >>= setColor Red
+ parentOf x >>= rotateL tree
+ parentOf x >>= fR
+ else return s
+ cl <- fL s' >>= colorOf
+ cr <- fR s' >>= colorOf
+ if cl == Black && cr == Black
+ then setColor Red s' >> parentOf x
+ else do
+ s'' <- if cr == Black
+ then do
+ fL s' >>= setColor Black
+ setColor Red s'
+ rotateR tree s'
+ parentOf x >>= fR
+ else return s'
+ p <- parentOf x
+ colorOf p >>= (`setColor` s'')
+ setColor Black p
+ fR s'' >>= setColor Black
+ rotateL tree p
+ readTVar (root tree)
+
+-- link in a new node replacing the given node with new
+-- key and value.
+replace :: (Eq k, Eq v) => k -> v -> RBTree k v -> Node k v -> STM (Node k v)
+replace k v t n@(Node _ _ p l r c) = do
+ let n' = Node k v p l r c
+ -- update the rest of the tree:
+ b <- isLeftBranch n
+ readTVar l >>= setField parent n'
+ readTVar r >>= setField parent n'
+ np <- readTVar p
+ if isNil np
+ then writeTVar (root t) n'
+ else setField (if b then left else right) n' np
+ return n'
+
+deleteNode :: (Eq k, Eq v) => RBTree k v -> Node k v -> STM (Node k v)
+deleteNode s p = do
+ l <- readTVar (left p)
+ r <- readTVar (right p)
+ p' <- if isNode l && isNode r
+ then do
+ suc <- successor p
+ replace (key suc) (value suc) s p
+ return suc
+ else return p
+
+ l' <- readTVar (left p')
+ rep <- if isNode l'
+ then return l'
+ else readTVar (right p')
+ pp <- readTVar (parent p')
+ if isNode rep
+ then do
+ writeTVar (parent rep) pp
+ if isNil pp
+ then writeTVar (root s) rep
+ else do
+ ppl <- readTVar (left pp)
+ if p' == ppl
+ then writeTVar (left pp) rep
+ else writeTVar (right pp) rep
+ writeTVar (left p') Nil
+ writeTVar (right p') Nil
+ writeTVar (parent p') Nil
+ c <- readTVar (color p')
+ when (c == Black) $ fixAfterDeletion s rep
+ else if isNil pp
+ then writeTVar (root s) Nil
+ else do
+ c <- readTVar (color p')
+ when (c == Black) $ fixAfterDeletion s p'
+ pp' <- readTVar (parent p')
+ when (isNode pp') $ do
+ ppl <- readTVar (left pp')
+ if p' == ppl
+ then writeTVar (left pp') Nil
+ else do
+ ppr <- readTVar (right pp')
+ when (p' == ppr) $ writeTVar (right pp') Nil
+ writeTVar (parent p') Nil
+ return p'
+
+----------------------------------
+-- Public API
+--
+mkRBTree :: STM (RBTree k v)
+mkRBTree = RBTree <$> newTVar Nil
+
+insert :: (Eq v, Ord k) => RBTree k v -> k -> v -> STM Bool
+insert t k v = isNil <$> insert' t k v <* postVerify t
+
+preVerify _ = return ()
+postVerify _ = return ()
+-- preVerify = verify'
+-- postVerify = verify'
+
+delete :: (Eq v, Ord k) => RBTree k v -> k -> STM Bool
+delete t k = do
+ n <- lookup k t
+ if isNode n
+ then isNode <$> (preVerify t *> deleteNode t n <* postVerify t)
+ else return False
+
+update :: (Eq v, Ord k) => RBTree k v -> k -> v -> STM Bool
+update t k v = do
+ n <- insert' t k v
+ case n of
+ Node _ v' _ _ _ _ -> do
+ when (v /= v') $ replace k v t n >> return ()
+ return True
+ Nil -> return False
+
+
+get :: Ord k => RBTree k v -> k -> STM (Maybe v)
+get t k = do
+ n <- lookup k t
+ case n of
+ Node _ v _ _ _ _ -> return (Just v)
+ Nil -> return Nothing
+
+contains :: Ord k => RBTree k v -> k -> STM Bool
+contains t k = isNode <$> lookup k t
+
+----------------------------------------------------
+-- Test code
+--
+#ifdef TESTCODE
+
+unlessM bm a = do
+ b <- bm
+ unless b a
+
+verifyRedBlack :: (Show k, Show v, Eq k, Eq v) => Node k v -> Int -> STM Int
+verifyRedBlack Nil _ = return 1
+verifyRedBlack n d = do
+ l <- readTVar (left n)
+ r <- readTVar (right n)
+ c <- readTVar (color n)
+
+ hl <- verifyRedBlack l (d + 1)
+ hr <- verifyRedBlack r (d + 1)
+ if hl == 0 || hr == 0
+ then return 0
+ else do
+ when (hl /= hr) $ error ("Imbalance @depth=" ++ show d ++ " : " ++ show hl ++ " " ++ show hr)
+ lineage l
+ lineage r
+
+ c <- readTVar (color n)
+ if c == Red
+ then do
+ unlessM (isBlack l) $ error ("Expected black left of " ++ show (key n))
+ unlessM (isBlack r) $ error ("Expected black right of " ++ show (key n))
+ return hl
+ else return (hl + 1)
+ where
+ lineage Nil = return ()
+ lineage c = do
+ p <- readTVar (parent c)
+ when (p /= n) $ error ("lineage")
+
+ isBlack Nil = return True
+ isBlack n = readTVar (color n) >>= \c -> return (c == Black)
+
+assertEq s t v = readTVar t >>= \v' -> when (v /= v') $ error s
+
+{-
+inOrder :: Show k => Node k v -> STM [k]
+inOrder Nil = trace "." $ return []
+inOrder n = do
+ l <- readTVar (left n)
+ ol <- trace "(" $ inOrder l
+
+ c <- readTVar (color n)
+ r <- trace (if c == Red then "r" else "b") $ readTVar (right n)
+ -- r <- trace (show (key n)) $ readTVar (right n)
+ or <- inOrder r
+ trace ")" $ return $ ol ++ [key n] ++ or
+-- -}
+{--}
+inOrder :: Show k => Node k v -> STM [k]
+inOrder Nil = return []
+inOrder n = do
+ l <- readTVar (left n)
+ ol <- inOrder l
+ r <- readTVar (right n)
+ or <- inOrder r
+ return $ ol ++ [key n] ++ or
+-- -}
+verifyOrder :: (Ord k, Show k) => Node k v -> STM ()
+verifyOrder Nil = return ()
+verifyOrder n = do
+ es <- inOrder n
+ unless (sort es == es) $ error "Ordering."
+
+verifyLinks Nil Nil _ = return ()
+verifyLinks Nil n as = do
+ l <- readTVar (left n)
+ r <- readTVar (right n)
+
+ assertM "left loop" $ return (l `notElem` as)
+ assertM "right loop" $ return (r `notElem` as)
+
+ when (isNode l) $ verifyLinks n l (l:as)
+ when (isNode r) $ verifyLinks n r (r:as)
+verifyLinks p Nil _ = return ()
+verifyLinks p n as = do
+ p' <- readTVar (parent n)
+ assertM "parent mismatch" $ return (p == p')
+ verifyLinks Nil n as
+
+verify' t = do
+ r <- readTVar (root t)
+ verifyLinks Nil r []
+
+verify :: (Eq k, Eq v, Ord k, Show v, Show k) => RBTree k v -> STM Int
+verify t = do
+ r <- readTVar (root t)
+ if isNil r
+ then return 1
+ else do
+ assertEq ("Root parent not Nil " ++ show (key r)) (parent r) Nil
+ assertEq ("Root color not Black " ++ show (key r)) (color r) Black
+
+ verifyLinks Nil r ([])
+ verifyOrder r
+ verifyRedBlack r 0
+
+assertM s v = do
+ b <- v
+ unless b $ error s
+
+insertTest :: [Int] -> IO Int
+insertTest as = atomically $ do
+ r <- mkRBTree
+ forM_ as $ \a -> do
+ assertM "Insert failed" $ insert r a a
+ verify r
+
+deleteTest :: [Int] -> [Int] -> IO ()
+deleteTest as bs = atomically $ do
+ r <- mkRBTree
+ forM_ as $ \a -> do
+ assertM "insert failed" $ insert r a a
+ verify r
+ forM_ bs $ \b -> do
+ assertM "delete failed" $ delete r b
+ verify r
+
+testMain' = do
+ insertTest [4,6,9,1,8,7,2]
+
+testMain'' = do
+ forM_ (inits [4,6,9,1,8,7,2,3,0,5]) $ \as -> do
+ putStrLn $ "Inserting " ++ show as
+ insertTest as
+
+testMain''' = do
+ forM_ (zip (inits [4,6,9,1,8,7,2,3,0,5]) (map reverse (inits [4,6,9,1,8,7,2,3,0,5]))) $ \(as,bs) -> do
+ putStrLn $ "Inserting " ++ show as ++ " deleting " ++ show bs
+ insertTest as
+
+testMain = do
+ let as = [92,86,34,84, 5,64, 1, 87,11,39
+ ,17,15,13,66,63,38,69, 67,88,16
+ , 9,95,31,96,19,33,21, 27,65,10
+ ,23,32,80,41,36,14,37, 54,98,51
+ ,55,45,43,97,61,60, 2, 12,49,85
+ , 8,76,46,78,48,56,35,100,29,90
+ ,99,70,73,52,81,20, 3, 68,22,83
+ ,71,72, 4,74,47,94,77, 89,59,91
+ ,93,75,25,50, 6,58, 7, 62,53,40
+ ,26,24,42,30,18,28,79, 82,44,57
+ ]
+ forM_ (inits as) $ \bs -> do
+ putStrLn $ "Inserting " ++ show bs
+ insertTest as
+#endif
diff --git a/benchmarks/PPoPP2019/src/STMContainers/Bimap.hs b/benchmarks/PPoPP2019/src/STMContainers/Bimap.hs
new file mode 100644
index 0000000..d2fe30e
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/STMContainers/Bimap.hs
@@ -0,0 +1,142 @@
+module STMContainers.Bimap
+(
+ Bimap,
+ Association,
+ Key,
+ new,
+ newIO,
+ insert1,
+ insert2,
+ delete1,
+ delete2,
+ lookup1,
+ lookup2,
+ focus1,
+ focus2,
+ null,
+)
+where
+
+import STMContainers.Prelude hiding (insert, delete, lookup, alter, foldM, toList, empty, null)
+import qualified Focus
+import qualified STMContainers.Map as Map
+
+
+-- |
+-- A bidirectional map.
+-- Essentially a bijection between subsets of its two argument types.
+--
+-- For one value of a left-hand type this map contains one value
+-- of the right-hand type and vice versa.
+data Bimap a b =
+ Bimap {m1 :: !(Map.Map a b), m2 :: !(Map.Map b a)}
+ deriving (Typeable)
+
+-- |
+-- A constraint for associations.
+type Association a b = (Key a, Key b)
+
+-- |
+-- A constraint for keys.
+type Key k = Map.Key k
+
+-- |
+-- Construct a new bimap.
+{-# INLINABLE new #-}
+new :: STM (Bimap a b)
+new = Bimap <$> Map.new <*> Map.new
+
+-- |
+-- Construct a new bimap in IO.
+--
+-- This is useful for creating it on a top-level using 'unsafePerformIO',
+-- because using 'atomically' inside 'unsafePerformIO' isn't possible.
+{-# INLINABLE newIO #-}
+newIO :: IO (Bimap a b)
+newIO = Bimap <$> Map.newIO <*> Map.newIO
+
+-- |
+-- Check on being empty.
+{-# INLINABLE null #-}
+null :: Bimap a b -> STM Bool
+null = Map.null . m1
+
+-- |
+-- Look up a right value by a left value.
+{-# INLINABLE lookup1 #-}
+lookup1 :: (Association a b) => a -> Bimap a b -> STM (Maybe b)
+lookup1 k = Map.lookup k . m1
+
+-- |
+-- Look up a left value by a right value.
+{-# INLINABLE lookup2 #-}
+lookup2 :: (Association a b) => b -> Bimap a b -> STM (Maybe a)
+lookup2 k = Map.lookup k . m2
+
+-- |
+-- Insert an association by a left value.
+{-# INLINABLE insert1 #-}
+insert1 :: (Association a b) => b -> a -> Bimap a b -> STM ()
+insert1 b a (Bimap m1 m2) =
+ do
+ Map.insert b a m1
+ Map.insert a b m2
+
+-- |
+-- Insert an association by a right value.
+{-# INLINABLE insert2 #-}
+insert2 :: (Association a b) => a -> b -> Bimap a b -> STM ()
+insert2 b a (Bimap m1 m2) = (inline insert1) b a (Bimap m2 m1)
+
+-- |
+-- Delete an association by a left value.
+{-# INLINABLE delete1 #-}
+delete1 :: (Association a b) => a -> Bimap a b -> STM ()
+delete1 k (Bimap m1 m2) =
+ Map.focus lookupAndDeleteStrategy k m1 >>=
+ mapM_ (\k' -> Map.delete k' m2)
+ where
+ lookupAndDeleteStrategy r =
+ return (r, Focus.Remove)
+
+-- |
+-- Delete an association by a right value.
+{-# INLINABLE delete2 #-}
+delete2 :: (Association a b) => b -> Bimap a b -> STM ()
+delete2 k (Bimap m1 m2) = (inline delete1) k (Bimap m2 m1)
+
+-- |
+-- Focus on a right value by a left value with a strategy.
+--
+-- This function allows to perform composite operations in a single access
+-- to a map item.
+-- E.g., you can look up an item and delete it at the same time,
+-- or update it and return the new value.
+{-# INLINABLE focus1 #-}
+focus1 :: (Association a b) => Focus.StrategyM STM b r -> a -> Bimap a b -> STM r
+focus1 s a (Bimap m1 m2) =
+ do
+ (r, d, mb) <- Map.focus s' a m1
+ case d of
+ Focus.Keep ->
+ return ()
+ Focus.Remove ->
+ forM_ mb $ \b -> Map.delete b m2
+ Focus.Replace b' ->
+ do
+ forM_ mb $ \b -> Map.delete b m2
+ Map.insert a b' m2
+ return r
+ where
+ s' = \k -> s k >>= \(r, d) -> return ((r, d, k), d)
+
+-- |
+-- Focus on a left value by a right value with a strategy.
+--
+-- This function allows to perform composite operations in a single access
+-- to a map item.
+-- E.g., you can look up an item and delete it at the same time,
+-- or update it and return the new value.
+{-# INLINABLE focus2 #-}
+focus2 :: (Association a b) => Focus.StrategyM STM a r -> b -> Bimap a b -> STM r
+focus2 s b (Bimap m1 m2) = (inline focus1) s b (Bimap m2 m1)
diff --git a/benchmarks/PPoPP2019/src/STMContainers/HAMT.hs b/benchmarks/PPoPP2019/src/STMContainers/HAMT.hs
new file mode 100644
index 0000000..54f7d1a
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/STMContainers/HAMT.hs
@@ -0,0 +1,34 @@
+module STMContainers.HAMT where
+
+import STMContainers.Prelude hiding (insert, lookup, delete, foldM)
+import qualified STMContainers.HAMT.Nodes as Nodes
+import qualified Focus
+
+
+type HAMT e = Nodes.Nodes e
+
+type Element e = (Nodes.Element e, Hashable (Nodes.ElementKey e))
+
+{-# INLINE insert #-}
+insert :: (Element e) => e -> HAMT e -> STM ()
+insert e = Nodes.insert e (hash (Nodes.elementKey e)) (Nodes.elementKey e) 0
+
+{-# INLINE focus #-}
+focus :: (Element e) => Focus.StrategyM STM e r -> Nodes.ElementKey e -> HAMT e -> STM r
+focus s k = Nodes.focus s (hash k) k 0
+
+{-# INLINE foldM #-}
+foldM :: (a -> e -> STM a) -> a -> HAMT e -> STM a
+foldM step acc = Nodes.foldM step acc 0
+
+{-# INLINE new #-}
+new :: STM (HAMT e)
+new = Nodes.new
+
+{-# INLINE newIO #-}
+newIO :: IO (HAMT e)
+newIO = Nodes.newIO
+
+{-# INLINE null #-}
+null :: HAMT e -> STM Bool
+null = Nodes.null
diff --git a/benchmarks/PPoPP2019/src/STMContainers/HAMT/Level.hs b/benchmarks/PPoPP2019/src/STMContainers/HAMT/Level.hs
new file mode 100644
index 0000000..ce5c382
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/STMContainers/HAMT/Level.hs
@@ -0,0 +1,30 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+module STMContainers.HAMT.Level where
+
+import STMContainers.Prelude hiding (mask)
+
+
+-- |
+-- A depth level of a node.
+-- Must be a multiple of the 'step' value.
+type Level = Int
+
+{-# INLINE hashIndex #-}
+hashIndex :: Level -> (Int -> Int)
+hashIndex l i = mask .&. unsafeShiftR i l
+
+{-# INLINE mask #-}
+mask :: Int
+mask = bit step - 1
+
+{-# INLINE step #-}
+step :: Int
+step = 5
+
+{-# INLINE limit #-}
+limit :: Int
+limit = bitSize (undefined :: Int)
+
+{-# INLINE succ #-}
+succ :: Level -> Level
+succ = (+ step)
diff --git a/benchmarks/PPoPP2019/src/STMContainers/HAMT/Nodes.hs b/benchmarks/PPoPP2019/src/STMContainers/HAMT/Nodes.hs
new file mode 100644
index 0000000..da088bf
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/STMContainers/HAMT/Nodes.hs
@@ -0,0 +1,154 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+module STMContainers.HAMT.Nodes where
+
+import STMContainers.Prelude hiding (insert, lookup, delete, foldM, null)
+import qualified STMContainers.Prelude as Prelude
+import qualified STMContainers.WordArray as WordArray
+import qualified STMContainers.SizedArray as SizedArray
+import qualified STMContainers.HAMT.Level as Level
+import qualified Focus
+
+
+type Nodes e = TVar (WordArray.WordArray (Node e))
+
+data Node e =
+ Nodes {-# UNPACK #-} !(Nodes e) |
+ Leaf {-# UNPACK #-} !Hash !e |
+ Leaves {-# UNPACK #-} !Hash {-# UNPACK #-} !(SizedArray.SizedArray e)
+
+type Hash = Int
+
+class (Eq (ElementKey e)) => Element e where
+ type ElementKey e
+ elementKey :: e -> ElementKey e
+
+{-# INLINE new #-}
+new :: STM (Nodes e)
+new = newTVar WordArray.empty
+
+{-# INLINE newIO #-}
+newIO :: IO (Nodes e)
+newIO = newTVarIO WordArray.empty
+
+insert :: (Element e) => e -> Hash -> ElementKey e -> Level.Level -> Nodes e -> STM ()
+insert e h k l ns = do
+ a <- readTVar ns
+ let write n = writeTVar ns $ WordArray.set i n a
+ case WordArray.lookup i a of
+ Nothing -> write (Leaf h e)
+ Just n -> case n of
+ Nodes ns' -> insert e h k (Level.succ l) ns'
+ Leaf h' e' ->
+ if h' == h
+ then if elementKey e' == k
+ then write (Leaf h e)
+ else write (Leaves h (SizedArray.pair e e'))
+ else do
+ nodes <- pair h (Leaf h e) h' (Leaf h' e') (Level.succ l)
+ write (Nodes nodes)
+ Leaves h' la ->
+ if h' == h
+ then case SizedArray.find ((== k) . elementKey) la of
+ Just (lai, _) ->
+ write (Leaves h' (SizedArray.insert lai e la))
+ Nothing ->
+ write (Leaves h' (SizedArray.append e la))
+ else
+ write . Nodes =<< pair h (Leaf h e) h' (Leaves h' la) (Level.succ l)
+ where
+ i = Level.hashIndex l h
+
+pair :: Hash -> Node e -> Hash -> Node e -> Level.Level -> STM (Nodes e)
+pair h1 n1 h2 n2 l =
+ if i1 == i2
+ then newTVar . WordArray.singleton i1 . Nodes =<< pair h1 n1 h2 n2 (Level.succ l)
+ else newTVar $ WordArray.pair i1 n1 i2 n2
+ where
+ hashIndex = Level.hashIndex l
+ i1 = hashIndex h1
+ i2 = hashIndex h2
+
+focus :: (Element e) => Focus.StrategyM STM e r -> Hash -> ElementKey e -> Level.Level -> Nodes e -> STM r
+focus s h k l ns = do
+ a <- readTVar ns
+ (r, a'm) <- WordArray.focusM s' ai a
+ maybe (return ()) (writeTVar ns) a'm
+ return r
+ where
+ ai = Level.hashIndex l h
+ s' = \case
+ Nothing -> traversePair (return . fmap (Leaf h)) =<< s Nothing
+ Just n -> case n of
+ Nodes ns' -> do
+ r <- focus s h k (Level.succ l) ns'
+ null ns' >>= \case
+ True -> return (r, Focus.Remove)
+ False -> return (r, Focus.Keep)
+ Leaf h' e' ->
+ case h' == h of
+ True ->
+ case elementKey e' == k of
+ True ->
+ traversePair (return . fmap (Leaf h)) =<< s (Just e')
+ False ->
+ traversePair processDecision =<< s Nothing
+ where
+ processDecision = \case
+ Focus.Replace e ->
+ return (Focus.Replace (Leaves h (SizedArray.pair e e')))
+ _ ->
+ return Focus.Keep
+ False ->
+ traversePair processDecision =<< s Nothing
+ where
+ processDecision = \case
+ Focus.Replace e -> do
+ ns' <- pair h (Leaf h e) h' (Leaf h' e') (Level.succ l)
+ return (Focus.Replace (Nodes ns'))
+ _ -> return Focus.Keep
+ Leaves h' a' ->
+ case h' == h of
+ True ->
+ case SizedArray.find ((== k) . elementKey) a' of
+ Just (i', e') ->
+ s (Just e') >>= traversePair processDecision
+ where
+ processDecision = \case
+ Focus.Keep ->
+ return Focus.Keep
+ Focus.Remove ->
+ case SizedArray.delete i' a' of
+ a'' -> case SizedArray.null a'' of
+ False -> return (Focus.Replace (Leaves h' a''))
+ True -> return Focus.Remove
+ Focus.Replace e ->
+ return (Focus.Replace (Leaves h' (SizedArray.insert i' e a')))
+ Nothing ->
+ s Nothing >>= traversePair processDecision
+ where
+ processDecision = \case
+ Focus.Replace e ->
+ return (Focus.Replace (Leaves h' (SizedArray.append e a')))
+ _ ->
+ return Focus.Keep
+ False ->
+ s Nothing >>= traversePair processDecision
+ where
+ processDecision = \case
+ Focus.Replace e -> do
+ ns' <- pair h (Leaf h e) h' (Leaves h' a') (Level.succ l)
+ return (Focus.Replace (Nodes ns'))
+ _ ->
+ return Focus.Keep
+
+null :: Nodes e -> STM Bool
+null = fmap WordArray.null . readTVar
+
+foldM :: (a -> e -> STM a) -> a -> Level.Level -> Nodes e -> STM a
+foldM step acc level =
+ readTVar >=> foldlM step' acc
+ where
+ step' acc' = \case
+ Nodes ns -> foldM step acc' (Level.succ level) ns
+ Leaf _ e -> step acc' e
+ Leaves _ a -> SizedArray.foldM step acc' a
diff --git a/benchmarks/PPoPP2019/src/STMContainers/LICENSE b/benchmarks/PPoPP2019/src/STMContainers/LICENSE
new file mode 100644
index 0000000..fe32f2b
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/STMContainers/LICENSE
@@ -0,0 +1,22 @@
+Copyright (c) 2014, Nikita Volkov
+
+Permission is hereby granted, free of charge, to any person
+obtaining a copy of this software and associated documentation
+files (the "Software"), to deal in the Software without
+restriction, including without limitation the rights to use,
+copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the
+Software is furnished to do so, subject to the following
+conditions:
+
+The above copyright notice and this permission notice shall be
+included in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
+OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
+OTHER DEALINGS IN THE SOFTWARE.
diff --git a/benchmarks/PPoPP2019/src/STMContainers/Map.hs b/benchmarks/PPoPP2019/src/STMContainers/Map.hs
new file mode 100644
index 0000000..6dcc042
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/STMContainers/Map.hs
@@ -0,0 +1,89 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+module STMContainers.Map
+(
+ Map,
+ Key,
+ new,
+ newIO,
+ insert,
+ delete,
+ lookup,
+ focus,
+ null,
+)
+where
+
+import STMContainers.Prelude hiding (insert, delete, lookup, alter, foldM, toList, empty, null)
+import qualified STMContainers.HAMT as HAMT
+import qualified STMContainers.HAMT.Nodes as HAMTNodes
+import qualified Focus
+
+
+-- |
+-- A hash table, based on an STM-specialized hash array mapped trie.
+newtype Map k v = Map (HAMT.HAMT (k, v))
+ deriving (Typeable)
+
+-- |
+-- A constraint for keys.
+type Key a = (Eq a, Hashable a)
+
+instance (Eq k) => HAMTNodes.Element (k, v) where
+ type ElementKey (k, v) = k
+ elementKey (k, v) = k
+
+{-# INLINE associationValue #-}
+associationValue :: (k, v) -> v
+associationValue (_, v) = v
+
+-- |
+-- Look up an item.
+{-# INLINE lookup #-}
+lookup :: (Key k) => k -> Map k v -> STM (Maybe v)
+lookup k = focus Focus.lookupM k
+
+-- |
+-- Insert a value at a key.
+{-# INLINE insert #-}
+insert :: (Key k) => v -> k -> Map k v -> STM ()
+insert !v !k (Map h) = HAMT.insert (k, v) h
+
+-- |
+-- Delete an item by a key.
+{-# INLINE delete #-}
+delete :: (Key k) => k -> Map k v -> STM ()
+delete k (Map h) = HAMT.focus Focus.deleteM k h
+
+-- |
+-- Focus on an item by a key with a strategy.
+--
+-- This function allows to perform composite operations in a single access
+-- to a map item.
+-- E.g., you can look up an item and delete it at the same time,
+-- or update it and return the new value.
+{-# INLINE focus #-}
+focus :: (Key k) => Focus.StrategyM STM v r -> k -> Map k v -> STM r
+focus f k (Map h) = HAMT.focus f' k h
+ where
+ f' = (fmap . fmap . fmap) (\v -> k `seq` v `seq` (k, v)) . f . fmap associationValue
+
+-- |
+-- Construct a new map.
+{-# INLINE new #-}
+new :: STM (Map k v)
+new = Map <$> HAMT.new
+
+-- |
+-- Construct a new map in IO.
+--
+-- This is useful for creating it on a top-level using 'unsafePerformIO',
+-- because using 'atomically' inside 'unsafePerformIO' isn't possible.
+{-# INLINE newIO #-}
+newIO :: IO (Map k v)
+newIO = Map <$> HAMT.newIO
+
+-- |
+-- Check, whether the map is empty.
+{-# INLINE null #-}
+null :: Map k v -> STM Bool
+null (Map h) = HAMT.null h
diff --git a/benchmarks/PPoPP2019/src/STMContainers/Multimap.hs b/benchmarks/PPoPP2019/src/STMContainers/Multimap.hs
new file mode 100644
index 0000000..1ec60c7
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/STMContainers/Multimap.hs
@@ -0,0 +1,147 @@
+module STMContainers.Multimap
+(
+ Multimap,
+ Association,
+ Key,
+ Value,
+ new,
+ newIO,
+ insert,
+ delete,
+ deleteByKey,
+ lookup,
+ focus,
+ null,
+)
+where
+
+import STMContainers.Prelude hiding (insert, delete, lookup, alter, foldM, toList, empty, null)
+import qualified Focus
+import qualified STMContainers.Map as Map
+import qualified STMContainers.Set as Set
+
+
+-- |
+-- A multimap, based on an STM-specialized hash array mapped trie.
+--
+-- Basically it's just a wrapper API around @'Map.Map' k ('Set.Set' v)@.
+newtype Multimap k v = Multimap (Map.Map k (Set.Set v))
+ deriving (Typeable)
+
+-- |
+-- A constraint for associations.
+type Association k v = (Key k, Value v)
+
+-- |
+-- A constraint for keys.
+type Key k = Map.Key k
+
+-- |
+-- A constraint for values.
+type Value v = Set.Element v
+
+-- |
+-- Look up an item by a value and a key.
+{-# INLINE lookup #-}
+lookup :: (Association k v) => v -> k -> Multimap k v -> STM Bool
+lookup v k (Multimap m) =
+ maybe (return False) (Set.lookup v) =<< Map.lookup k m
+
+-- |
+-- Insert an item.
+{-# INLINABLE insert #-}
+insert :: (Association k v) => v -> k -> Multimap k v -> STM ()
+insert v k (Multimap m) =
+ Map.focus ms k m
+ where
+ ms =
+ \case
+ Just s ->
+ do
+ Set.insert v s
+ return ((), Focus.Keep)
+ Nothing ->
+ do
+ s <- Set.new
+ Set.insert v s
+ return ((), Focus.Replace s)
+
+-- |
+-- Delete an item by a value and a key.
+{-# INLINABLE delete #-}
+delete :: (Association k v) => v -> k -> Multimap k v -> STM ()
+delete v k (Multimap m) =
+ Map.focus ms k m
+ where
+ ms =
+ \case
+ Just s ->
+ do
+ Set.delete v s
+ Set.null s >>= returnDecision . bool Focus.Keep Focus.Remove
+ Nothing ->
+ returnDecision Focus.Keep
+ where
+ returnDecision c = return ((), c)
+
+-- |
+-- Delete all values associated with a key.
+{-# INLINEABLE deleteByKey #-}
+deleteByKey :: Key k => k -> Multimap k v -> STM ()
+deleteByKey k (Multimap m) =
+ Map.delete k m
+
+-- |
+-- Focus on an item with a strategy by a value and a key.
+--
+-- This function allows to perform simultaneous lookup and modification.
+--
+-- The strategy is over a unit since we already know,
+-- which value we're focusing on and it doesn't make sense to replace it,
+-- however we still can decide wether to keep or remove it.
+{-# INLINE focus #-}
+focus :: (Association k v) => Focus.StrategyM STM () r -> v -> k -> Multimap k v -> STM r
+focus =
+ \s v k (Multimap m) -> Map.focus (liftSetItemStrategy v s) k m
+ where
+ liftSetItemStrategy ::
+ (Set.Element e) => e -> Focus.StrategyM STM () r -> Focus.StrategyM STM (Set.Set e) r
+ liftSetItemStrategy e s =
+ \case
+ Nothing ->
+ traversePair liftDecision =<< s Nothing
+ where
+ liftDecision =
+ \case
+ Focus.Replace b ->
+ do
+ s <- Set.new
+ Set.insert e s
+ return (Focus.Replace s)
+ _ ->
+ return Focus.Keep
+ Just set ->
+ do
+ r <- Set.focus s e set
+ (r,) . bool Focus.Keep Focus.Remove <$> Set.null set
+
+-- |
+-- Construct a new multimap.
+{-# INLINE new #-}
+new :: STM (Multimap k v)
+new = Multimap <$> Map.new
+
+-- |
+-- Construct a new multimap in IO.
+--
+-- This is useful for creating it on a top-level using 'unsafePerformIO',
+-- because using 'atomically' inside 'unsafePerformIO' isn't possible.
+{-# INLINE newIO #-}
+newIO :: IO (Multimap k v)
+newIO = Multimap <$> Map.newIO
+
+-- |
+-- Check on being empty.
+{-# INLINE null #-}
+null :: Multimap k v -> STM Bool
+null (Multimap m) = Map.null m
diff --git a/benchmarks/PPoPP2019/src/STMContainers/Prelude.hs b/benchmarks/PPoPP2019/src/STMContainers/Prelude.hs
new file mode 100644
index 0000000..788fdda
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/STMContainers/Prelude.hs
@@ -0,0 +1,36 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+module STMContainers.Prelude
+(
+ module Exports,
+ bug,
+ bottom,
+ traversePair,
+)
+where
+
+-- base
+-------------------------
+import BasePrelude as Exports
+
+-- hashable
+-------------------------
+import Data.Hashable as Exports (Hashable(..))
+
+-- transformers
+-------------------------
+import Control.Monad.Trans.Class as Exports
+
+-- custom
+-------------------------
+import qualified Debug.Trace.LocationTH
+
+bug = [e| $(Debug.Trace.LocationTH.failure) . (msg <>) |]
+ where
+ msg = "A \"stm-containers\" package bug: " :: String
+
+bottom = [e| $bug "Bottom evaluated" |]
+
+-- | A replacement for the missing 'Traverse' instance of pair in base < 4.7.
+traversePair :: Functor f => (a -> f b) -> (c, a) -> f (c, b)
+traversePair f (x, y) = (,) x <$> f y
diff --git a/benchmarks/PPoPP2019/src/STMContainers/Set.hs b/benchmarks/PPoPP2019/src/STMContainers/Set.hs
new file mode 100644
index 0000000..52dceb8
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/STMContainers/Set.hs
@@ -0,0 +1,92 @@
+module STMContainers.Set
+(
+ Set,
+ Element,
+ new,
+ newIO,
+ insert,
+ delete,
+ lookup,
+ focus,
+ null,
+)
+where
+
+import STMContainers.Prelude hiding (insert, delete, lookup, alter, foldM, toList, empty, null)
+import qualified STMContainers.HAMT as HAMT
+import qualified STMContainers.HAMT.Nodes as HAMTNodes
+import qualified Focus
+
+
+-- |
+-- A hash set, based on an STM-specialized hash array mapped trie.
+newtype Set e = Set {hamt :: HAMT.HAMT (HAMTElement e)}
+ deriving (Typeable)
+
+-- |
+-- A constraint for elements.
+type Element a = (Eq a, Hashable a)
+
+newtype HAMTElement e = HAMTElement e
+
+instance (Eq e) => HAMTNodes.Element (HAMTElement e) where
+ type ElementKey (HAMTElement e) = e
+ elementKey (HAMTElement e) = e
+
+{-# INLINE elementValue #-}
+elementValue :: HAMTElement e -> e
+elementValue (HAMTElement e) = e
+
+-- |
+-- Insert a new element.
+{-# INLINE insert #-}
+insert :: (Element e) => e -> Set e -> STM ()
+insert e = HAMT.insert (HAMTElement e) . hamt
+
+-- |
+-- Delete an element.
+{-# INLINE delete #-}
+delete :: (Element e) => e -> Set e -> STM ()
+delete e = HAMT.focus Focus.deleteM e . hamt
+
+-- |
+-- Lookup an element.
+{-# INLINE lookup #-}
+lookup :: (Element e) => e -> Set e -> STM Bool
+lookup e = fmap (maybe False (const True)) . HAMT.focus Focus.lookupM e . hamt
+
+-- |
+-- Focus on an element with a strategy.
+--
+-- This function allows to perform simultaneous lookup and modification.
+--
+-- The strategy is over a unit since we already know,
+-- which element we're focusing on and it doesn't make sense to replace it,
+-- however we still can decide wether to keep or remove it.
+{-# INLINE focus #-}
+focus :: (Element e) => Focus.StrategyM STM () r -> e -> Set e -> STM r
+focus s e = HAMT.focus elementStrategy e . hamt
+ where
+ elementStrategy =
+ (fmap . fmap . fmap) (const (HAMTElement e)) . s . fmap (const ())
+
+-- |
+-- Construct a new set.
+{-# INLINE new #-}
+new :: STM (Set e)
+new = Set <$> HAMT.new
+
+-- |
+-- Construct a new set in IO.
+--
+-- This is useful for creating it on a top-level using 'unsafePerformIO',
+-- because using 'atomically' inside 'unsafePerformIO' isn't possible.
+{-# INLINE newIO #-}
+newIO :: IO (Set e)
+newIO = Set <$> HAMT.newIO
+
+-- |
+-- Check, whether the set is empty.
+{-# INLINE null #-}
+null :: Set e -> STM Bool
+null = HAMT.null . hamt
diff --git a/benchmarks/PPoPP2019/src/STMContainers/SizedArray.hs b/benchmarks/PPoPP2019/src/STMContainers/SizedArray.hs
new file mode 100644
index 0000000..f201592
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/STMContainers/SizedArray.hs
@@ -0,0 +1,88 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+module STMContainers.SizedArray where
+
+import STMContainers.Prelude hiding (lookup, toList, foldM)
+import Data.Primitive.Array
+import qualified STMContainers.Prelude as Prelude
+import qualified Focus
+
+-- |
+-- An array,
+-- which sacrifices the performance for space-efficiency and thread-safety.
+data SizedArray a =
+ SizedArray {-# UNPACK #-} !Int {-# UNPACK #-} !(Array a)
+
+instance Foldable SizedArray where
+ {-# INLINE foldr #-}
+ foldr step r (SizedArray size array) =
+ foldr step r $ map (indexArray array) [0 .. pred size]
+
+-- |
+-- An index of an element.
+type Index = Int
+
+{-# INLINE pair #-}
+pair :: a -> a -> SizedArray a
+pair e e' =
+ runST $ do
+ a <- newArray 2 e
+ writeArray a 1 e'
+ SizedArray 2 <$> unsafeFreezeArray a
+
+-- |
+-- Get the amount of elements.
+{-# INLINE size #-}
+size :: SizedArray a -> Int
+size (SizedArray b _) = b
+
+-- |
+-- Get the amount of elements.
+{-# INLINE null #-}
+null :: SizedArray a -> Bool
+null = (== 0) . size
+
+{-# INLINE find #-}
+find :: (a -> Bool) -> SizedArray a -> Maybe (Index, a)
+find p (SizedArray s a) = loop 0
+ where
+ loop i = if i < s
+ then let e = indexArray a i in if p e
+ then Just (i, e)
+ else loop (succ i)
+ else Nothing
+
+-- |
+-- Unsafe. Doesn't check the index overflow.
+{-# INLINE insert #-}
+insert :: Index -> a -> SizedArray a -> SizedArray a
+insert i e (SizedArray s a) =
+ runST $ do
+ m' <- newArray s undefined
+ forM_ [0 .. pred s] $ \i' -> indexArrayM a i' >>= writeArray m' i'
+ writeArray m' i e
+ SizedArray s <$> unsafeFreezeArray m'
+
+{-# INLINE delete #-}
+delete :: Index -> SizedArray a -> SizedArray a
+delete i (SizedArray s a) =
+ runST $ do
+ m' <- newArray (pred s) undefined
+ forM_ [0 .. pred i] $ \i' -> indexArrayM a i' >>= writeArray m' i'
+ forM_ [succ i .. pred s] $ \i' -> indexArrayM a i' >>= writeArray m' (pred i')
+ SizedArray (pred s) <$> unsafeFreezeArray m'
+
+{-# INLINE append #-}
+append :: a -> SizedArray a -> SizedArray a
+append e (SizedArray s a) =
+ runST $ do
+ m' <- newArray (succ s) undefined
+ forM_ [0 .. pred s] $ \i -> indexArrayM a i >>= writeArray m' i
+ writeArray m' s e
+ SizedArray (succ s) <$> unsafeFreezeArray m'
+
+{-# INLINE foldM #-}
+foldM :: (Monad m) => (a -> b -> m a) -> a -> SizedArray b -> m a
+foldM step acc (SizedArray size array) =
+ Prelude.foldM step' acc [0 .. pred size]
+ where
+ step' acc' i = indexArrayM array i >>= step acc'
diff --git a/benchmarks/PPoPP2019/src/STMContainers/WordArray.hs b/benchmarks/PPoPP2019/src/STMContainers/WordArray.hs
new file mode 100644
index 0000000..5fa34e0
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/STMContainers/WordArray.hs
@@ -0,0 +1,199 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+module STMContainers.WordArray where
+
+import STMContainers.Prelude hiding (lookup, toList, traverse_)
+import Data.Primitive.Array
+import qualified STMContainers.Prelude as Prelude
+import qualified STMContainers.WordArray.Indices as Indices
+import qualified Focus
+
+
+-- |
+-- An immutable space-efficient sparse array,
+-- which can store only as many elements as there are bits in the machine word.
+data WordArray e =
+ WordArray {-# UNPACK #-} !Indices {-# UNPACK #-} !(Array e)
+
+instance Foldable WordArray where
+ {-# INLINE foldr #-}
+ foldr step r (WordArray indices array) =
+ foldr (step . indexArray array) r $ Indices.positions indices
+
+-- |
+-- A bitmap of set elements.
+type Indices = Indices.Indices
+
+-- |
+-- An index of an element.
+type Index = Int
+
+{-# INLINE indices #-}
+indices :: WordArray e -> Indices
+indices (WordArray b _) = b
+
+{-# INLINE maxSize #-}
+maxSize :: Int
+maxSize = Indices.maxSize
+
+{-# INLINE empty #-}
+empty :: WordArray e
+empty = WordArray 0 a
+ where
+ a = runST $ newArray 0 undefined >>= unsafeFreezeArray
+
+-- |
+-- An array with a single element at the specified index.
+{-# INLINE singleton #-}
+singleton :: Index -> e -> WordArray e
+singleton i e =
+ let b = Indices.insert i 0
+ a = runST $ newArray 1 e >>= unsafeFreezeArray
+ in WordArray b a
+
+{-# INLINE pair #-}
+pair :: Index -> e -> Index -> e -> WordArray e
+pair i e i' e' =
+ WordArray is a
+ where
+ is = Indices.fromList [i, i']
+ a =
+ runST $ if
+ | i < i' -> do
+ a <- newArray 2 e
+ writeArray a 1 e'
+ unsafeFreezeArray a
+ | i > i' -> do
+ a <- newArray 2 e
+ writeArray a 0 e'
+ unsafeFreezeArray a
+ | i == i' -> do
+ a <- newArray 1 e'
+ unsafeFreezeArray a
+
+-- |
+-- Unsafe.
+-- Assumes that the list is sorted and contains no duplicate indexes.
+{-# INLINE fromList #-}
+fromList :: [(Index, e)] -> WordArray e
+fromList l =
+ runST $ do
+ indices <- newSTRef 0
+ array <- newArray (length l) undefined
+ forM_ (zip l [0..]) $ \((i, e), ai) -> do
+ modifySTRef indices $ Indices.insert i
+ writeArray array ai e
+ WordArray <$> readSTRef indices <*> unsafeFreezeArray array
+
+{-# INLINE toList #-}
+toList :: WordArray e -> [(Index, e)]
+toList (WordArray is a) = do
+ i <- Indices.toList is
+ e <- indexArrayM a (Indices.position i is)
+ return (i, e)
+
+-- |
+-- Convert into a list representation.
+{-# INLINE toMaybeList #-}
+toMaybeList :: WordArray e -> [Maybe e]
+toMaybeList w = do
+ i <- [0 .. pred Indices.maxSize]
+ return $ lookup i w
+
+{-# INLINE elements #-}
+elements :: WordArray e -> [e]
+elements (WordArray indices array) =
+ map (\i -> indexArray array (Indices.position i indices)) .
+ Indices.toList $
+ indices
+
+-- |
+-- Set an element value at the index.
+{-# INLINE set #-}
+set :: Index -> e -> WordArray e -> WordArray e
+set i e (WordArray b a) =
+ let
+ sparseIndex = Indices.position i b
+ size = Indices.size b
+ in if Indices.elem i b
+ then
+ let a' = runST $ do
+ ma' <- newArray size undefined
+ forM_ [0 .. (size - 1)] $ \i -> indexArrayM a i >>= writeArray ma' i
+ writeArray ma' sparseIndex e
+ unsafeFreezeArray ma'
+ in WordArray b a'
+ else
+ let a' = runST $ do
+ ma' <- newArray (size + 1) undefined
+ forM_ [0 .. (sparseIndex - 1)] $ \i -> indexArrayM a i >>= writeArray ma' i
+ writeArray ma' sparseIndex e
+ forM_ [sparseIndex .. (size - 1)] $ \i -> indexArrayM a i >>= writeArray ma' (i + 1)
+ unsafeFreezeArray ma'
+ b' = Indices.insert i b
+ in WordArray b' a'
+
+-- |
+-- Remove an element.
+{-# INLINE unset #-}
+unset :: Index -> WordArray e -> WordArray e
+unset i (WordArray b a) =
+ if Indices.elem i b
+ then
+ let
+ b' = Indices.invert i b
+ a' = runST $ do
+ ma' <- newArray (pred size) undefined
+ forM_ [0 .. pred sparseIndex] $ \i -> indexArrayM a i >>= writeArray ma' i
+ forM_ [succ sparseIndex .. pred size] $ \i -> indexArrayM a i >>= writeArray ma' (pred i)
+ unsafeFreezeArray ma'
+ sparseIndex = Indices.position i b
+ size = Indices.size b
+ in WordArray b' a'
+ else WordArray b a
+
+-- |
+-- Lookup an item at the index.
+{-# INLINE lookup #-}
+lookup :: Index -> WordArray e -> Maybe e
+lookup i (WordArray b a) =
+ if Indices.elem i b
+ then Just (indexArray a (Indices.position i b))
+ else Nothing
+
+-- |
+-- Lookup strictly, using 'indexArrayM'.
+{-# INLINE lookupM #-}
+lookupM :: Monad m => Index -> WordArray e -> m (Maybe e)
+lookupM i (WordArray b a) =
+ if Indices.elem i b
+ then liftM Just (indexArrayM a (Indices.position i b))
+ else return Nothing
+
+-- |
+-- Check, whether there is an element at the index.
+{-# INLINE isSet #-}
+isSet :: Index -> WordArray e -> Bool
+isSet i = Indices.elem i . indices
+
+-- |
+-- Get the amount of elements.
+{-# INLINE size #-}
+size :: WordArray e -> Int
+size = Indices.size . indices
+
+{-# INLINE null #-}
+null :: WordArray e -> Bool
+null = Indices.null . indices
+
+{-# INLINE focusM #-}
+focusM :: Monad m => Focus.StrategyM m a r -> Index -> WordArray a -> m (r, Maybe (WordArray a))
+focusM f i w = do
+ let em = lookup i w
+ (r, c) <- f em
+ let w' = case c of
+ Focus.Keep -> Nothing
+ Focus.Remove -> case em of
+ Nothing -> Nothing
+ Just _ -> Just $ unset i w
+ Focus.Replace e' -> Just $ set i e' w
+ return (r, w')
diff --git a/benchmarks/PPoPP2019/src/STMContainers/WordArray/Indices.hs b/benchmarks/PPoPP2019/src/STMContainers/WordArray/Indices.hs
new file mode 100644
index 0000000..4dcb381
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/STMContainers/WordArray/Indices.hs
@@ -0,0 +1,69 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+module STMContainers.WordArray.Indices where
+
+import STMContainers.Prelude hiding (toList, traverse_)
+import qualified STMContainers.Prelude as Prelude
+
+
+-- |
+-- A compact set of indices.
+type Indices = Int
+
+type Index = Int
+
+type Position = Int
+
+-- |
+-- A number of indexes, preceding this one.
+{-# INLINE position #-}
+position :: Index -> Indices -> Position
+position i b = popCount (b .&. (bit i - 1))
+
+{-# INLINE singleton #-}
+singleton :: Index -> Indices
+singleton = bit
+
+{-# INLINE insert #-}
+insert :: Index -> Indices -> Indices
+insert i = (bit i .|.)
+
+{-# INLINE invert #-}
+invert :: Index -> Indices -> Indices
+invert i = (bit i `xor`)
+
+{-# INLINE elem #-}
+elem :: Index -> Indices -> Bool
+elem = flip testBit
+
+{-# INLINE size #-}
+size :: Indices -> Int
+size = popCount
+
+{-# INLINE null #-}
+null :: Indices -> Bool
+null = (== 0)
+
+{-# INLINE maxSize #-}
+maxSize :: Int
+maxSize = bitSize (undefined :: Indices)
+
+{-# INLINE fromList #-}
+fromList :: [Index] -> Indices
+fromList = Prelude.foldr (.|.) 0 . map bit
+
+{-# INLINE toList #-}
+toList :: Indices -> [Index]
+toList w = filter (testBit w) allIndices
+
+{-# INLINE positions #-}
+positions :: Indices -> [Position]
+positions = enumFromTo 0 . pred . size
+
+{-# NOINLINE allIndices #-}
+allIndices :: [Index]
+allIndices = [0 .. pred maxSize]
+
+{-# INLINE foldr #-}
+foldr :: (Index -> r -> r) -> r -> Indices -> r
+foldr s r ix =
+ Prelude.foldr (\i r' -> if testBit ix i then s i r' else r') r allIndices
diff --git a/benchmarks/PPoPP2019/src/System/Random/PCG/Class.hs b/benchmarks/PPoPP2019/src/System/Random/PCG/Class.hs
new file mode 100644
index 0000000..ddabe5d
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/System/Random/PCG/Class.hs
@@ -0,0 +1,473 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UnboxedTuples #-}
+-- |
+-- Module : System.Random.PCG.Class
+-- Copyright : Copyright (c) 2014-2015, Christopher Chalmers
+-- License : BSD3
+-- Maintainer : Christopher Chalmers
+-- Stability : experimental
+-- Portability: CPP
+--
+-- Classes for working with random numbers along with utility functions.
+-- In a future release this module may disappear and use another module
+-- for this functionality.
+module System.Random.PCG.Class
+ ( -- * Classes
+ Generator (..)
+ , Variate (..)
+
+ -- * Type restricted versions
+ -- ** uniform
+ , uniformW8, uniformW16, uniformW32, uniformW64
+ , uniformI8, uniformI16, uniformI32, uniformI64
+ , uniformF, uniformD, uniformBool
+
+ -- ** uniformR
+ , uniformRW8, uniformRW16, uniformRW32, uniformRW64
+ , uniformRI8, uniformRI16, uniformRI32, uniformRI64
+ , uniformRF, uniformRD, uniformRBool
+
+ -- ** uniformB
+ , uniformBW8, uniformBW16, uniformBW32, uniformBW64
+ , uniformBI8, uniformBI16, uniformBI32, uniformBI64
+ , uniformBF, uniformBD, uniformBBool
+
+ -- * Utilities
+ , Unsigned
+ , wordsTo64Bit
+ , wordToBool
+ , wordToFloat
+ , wordsToDouble
+ , sysRandom
+ ) where
+
+#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
+#include "MachDeps.h"
+#endif
+
+import Control.Monad
+import Data.Bits
+import Data.ByteString (useAsCString)
+import Data.Int
+import Data.Word
+import Foreign (castPtr, peek)
+import System.Entropy
+
+class Monad m => Generator g m where
+ uniform1 :: (Word32 -> a) -> g -> m a
+ uniform2 :: (Word32 -> Word32 -> a) -> g -> m a
+ uniform1B :: Integral a => (Word32 -> a) -> Word32 -> g -> m a
+
+class Variate a where
+ -- | Generate a uniformly distributed random vairate.
+ --
+ -- * Use entire range for integral types.
+ --
+ -- * Use (0,1] range for floating types.
+ uniform :: Generator g m => g -> m a
+
+ -- | Generate a uniformly distributed random vairate in the given
+ -- range.
+ --
+ -- * Use inclusive range for integral types.
+ --
+ -- * Use (a,b] range for floating types.
+ uniformR :: Generator g m => (a,a) -> g -> m a
+
+ -- | Generate a uniformly distributed random vairate in the range
+ -- [0,b). For integral types the bound must be less than the max bound
+ -- of 'Word32' (4294967295). Behaviour is undefined for negative
+ -- bounds.
+ uniformB :: Generator g m => a -> g -> m a
+
+------------------------------------------------------------------------
+-- Variate instances
+------------------------------------------------------------------------
+
+instance Variate Int8 where
+ uniform = uniform1 fromIntegral
+ {-# INLINE uniform #-}
+ uniformR a g = uniformRange a g
+ {-# INLINE uniformR #-}
+ uniformB b g = uniform1B fromIntegral (fromIntegral b) g
+ {-# INLINE uniformB #-}
+
+instance Variate Int16 where
+ uniform = uniform1 fromIntegral
+ {-# INLINE uniform #-}
+ uniformR a g = uniformRange a g
+ {-# INLINE uniformR #-}
+ uniformB b g = uniform1B fromIntegral (fromIntegral b) g
+ {-# INLINE uniformB #-}
+
+instance Variate Int32 where
+ uniform = uniform1 fromIntegral
+ {-# INLINE uniform #-}
+ uniformR a g = uniformRange a g
+ {-# INLINE uniformR #-}
+ uniformB b g = uniform1B fromIntegral (fromIntegral b) g
+ {-# INLINE uniformB #-}
+
+instance Variate Int64 where
+ uniform = uniform2 wordsTo64Bit
+ {-# INLINE uniform #-}
+ uniformR a g = uniformRange a g
+ {-# INLINE uniformR #-}
+ uniformB b g = uniform1B fromIntegral (fromIntegral b) g
+ {-# INLINE uniformB #-}
+
+instance Variate Word8 where
+ uniform = uniform1 fromIntegral
+ {-# INLINE uniform #-}
+ uniformR a g = uniformRange a g
+ {-# INLINE uniformR #-}
+ uniformB b g = uniform1B fromIntegral (fromIntegral b) g
+ {-# INLINE uniformB #-}
+
+instance Variate Word16 where
+ uniform = uniform1 fromIntegral
+ {-# INLINE uniform #-}
+ uniformR a g = uniformRange a g
+ {-# INLINE uniformR #-}
+ uniformB b g = uniform1B fromIntegral (fromIntegral b) g
+ {-# INLINE uniformB #-}
+
+instance Variate Word32 where
+ uniform = uniform1 fromIntegral
+ {-# INLINE uniform #-}
+ uniformR a g = uniformRange a g
+ {-# INLINE uniformR #-}
+ uniformB b g = uniform1B fromIntegral (fromIntegral b) g
+ {-# INLINE uniformB #-}
+
+instance Variate Word64 where
+ uniform = uniform2 wordsTo64Bit
+ {-# INLINE uniform #-}
+ uniformR a g = uniformRange a g
+ {-# INLINE uniformR #-}
+ uniformB b g = uniform1B fromIntegral (fromIntegral b) g
+ {-# INLINE uniformB #-}
+
+instance Variate Bool where
+ uniform = uniform1 wordToBool
+ {-# INLINE uniform #-}
+ uniformR (False,True) g = uniform g
+ uniformR (False,False) _ = return False
+ uniformR (True,True) _ = return True
+ uniformR (True,False) g = uniform g
+ {-# INLINE uniformR #-}
+ uniformB False _ = return False
+ uniformB _ g = uniform g
+ {-# INLINE uniformB #-}
+
+instance Variate Float where
+ uniform = uniform1 wordToFloat
+ {-# INLINE uniform #-}
+ uniformR (x1,x2) = uniform1 (\w -> x1 + (x2-x1) * wordToFloat w)
+ {-# INLINE uniformR #-}
+ -- subtract 2**(-33) to go from (0,b] to [0,b) (I think)
+ uniformB b g = (subtract 1.16415321826934814453125e-10) `liftM` uniformR (0,b) g
+ {-# INLINE uniformB #-}
+
+instance Variate Double where
+ uniform = uniform2 wordsToDouble
+ {-# INLINE uniform #-}
+ uniformR (x1,x2) = uniform2 (\w1 w2 -> x1 + (x2-x1) * wordsToDouble w1 w2)
+ {-# INLINE uniformR #-}
+ -- subtract 2**(-53) to go from (0,b] to [0,b) (I think)
+ uniformB b g = (subtract 1.1102230246251565404236316680908203125e-16) `liftM` uniformR (0,b) g
+ {-# INLINE uniformB #-}
+
+instance Variate Word where
+#if WORD_SIZE_IN_BITS < 64
+ uniform = uniform1 fromIntegral
+#else
+ uniform = uniform2 wordsTo64Bit
+#endif
+ {-# INLINE uniform #-}
+ uniformR a g = uniformRange a g
+ {-# INLINE uniformR #-}
+ uniformB b g = uniform1B fromIntegral (fromIntegral b) g
+ {-# INLINE uniformB #-}
+
+instance Variate Int where
+#if WORD_SIZE_IN_BITS < 64
+ uniform = uniform1 fromIntegral
+#else
+ uniform = uniform2 wordsTo64Bit
+#endif
+ {-# INLINE uniform #-}
+ uniformR a g = uniformRange a g
+ {-# INLINE uniformR #-}
+ uniformB b g = uniform1B fromIntegral (fromIntegral b) g
+ {-# INLINE uniformB #-}
+
+instance (Variate a, Variate b) => Variate (a,b) where
+ uniform g = (,) `liftM` uniform g `ap` uniform g
+ {-# INLINE uniform #-}
+ uniformR ((x1,y1),(x2,y2)) g = (,) `liftM` uniformR (x1,x2) g `ap` uniformR (y1,y2) g
+ {-# INLINE uniformR #-}
+ uniformB (b1,b2) g = (,) `liftM` uniformB b1 g `ap` uniformB b2 g
+ {-# INLINE uniformB #-}
+
+instance (Variate a, Variate b, Variate c) => Variate (a,b,c) where
+ uniform g = (,,) `liftM` uniform g `ap` uniform g `ap` uniform g
+ {-# INLINE uniform #-}
+ uniformR ((x1,y1,z1),(x2,y2,z2)) g =
+ (,,) `liftM` uniformR (x1,x2) g `ap` uniformR (y1,y2) g `ap` uniformR (z1,z2) g
+ {-# INLINE uniformR #-}
+ uniformB (b1,b2,b3) g = (,,) `liftM` uniformB b1 g `ap` uniformB b2 g `ap` uniformB b3 g
+ {-# INLINE uniformB #-}
+
+instance (Variate a, Variate b, Variate c, Variate d) => Variate (a,b,c,d) where
+ uniform g = (,,,) `liftM` uniform g `ap` uniform g `ap` uniform g `ap` uniform g
+ {-# INLINE uniform #-}
+ uniformR ((x1,y1,z1,t1),(x2,y2,z2,t2)) g =
+ (,,,) `liftM` uniformR (x1,x2) g `ap` uniformR (y1,y2) g `ap`
+ uniformR (z1,z2) g `ap` uniformR (t1,t2) g
+ {-# INLINE uniformR #-}
+ uniformB (b1,b2,b3,b4) g = (,,,) `liftM` uniformB b1 g `ap` uniformB b2 g `ap` uniformB b3 g `ap` uniformB b4 g
+ {-# INLINE uniformB #-}
+
+------------------------------------------------------------------------
+-- Type restricted versions
+------------------------------------------------------------------------
+
+-- uniform -------------------------------------------------------------
+
+uniformI8 :: Generator g m => g -> m Int8
+uniformI8 = uniform
+{-# INLINE uniformI8 #-}
+
+uniformI16 :: Generator g m => g -> m Int16
+uniformI16 = uniform
+{-# INLINE uniformI16 #-}
+
+uniformI32 :: Generator g m => g -> m Int32
+uniformI32 = uniform
+{-# INLINE uniformI32 #-}
+
+uniformI64 :: Generator g m => g -> m Int64
+uniformI64 = uniform
+{-# INLINE uniformI64 #-}
+
+uniformW8 :: Generator g m => g -> m Word8
+uniformW8 = uniform
+{-# INLINE uniformW8 #-}
+
+uniformW16 :: Generator g m => g -> m Word16
+uniformW16 = uniform
+{-# INLINE uniformW16 #-}
+
+uniformW32 :: Generator g m => g -> m Word32
+uniformW32 = uniform
+{-# INLINE uniformW32 #-}
+
+uniformW64 :: Generator g m => g -> m Word64
+uniformW64 = uniform
+{-# INLINE uniformW64 #-}
+
+uniformBool :: Generator g m => g -> m Bool
+uniformBool = uniform
+{-# INLINE uniformBool #-}
+
+uniformF :: Generator g m => g -> m Float
+uniformF = uniform
+{-# INLINE uniformF #-}
+
+uniformD :: Generator g m => g -> m Double
+uniformD = uniform
+{-# INLINE uniformD #-}
+
+-- uniformR ------------------------------------------------------------
+
+uniformRI8 :: Generator g m => (Int8, Int8) -> g -> m Int8
+uniformRI8 = uniformR
+{-# INLINE uniformRI8 #-}
+
+uniformRI16 :: Generator g m => (Int16, Int16) -> g -> m Int16
+uniformRI16 = uniformR
+{-# INLINE uniformRI16 #-}
+
+uniformRI32 :: Generator g m => (Int32, Int32) -> g -> m Int32
+uniformRI32 = uniformR
+{-# INLINE uniformRI32 #-}
+
+uniformRI64 :: Generator g m => (Int64, Int64) -> g -> m Int64
+uniformRI64 = uniformR
+{-# INLINE uniformRI64 #-}
+
+uniformRW8 :: Generator g m => (Word8, Word8) -> g -> m Word8
+uniformRW8 = uniformR
+{-# INLINE uniformRW8 #-}
+
+uniformRW16 :: Generator g m => (Word16, Word16) -> g -> m Word16
+uniformRW16 = uniformR
+{-# INLINE uniformRW16 #-}
+
+uniformRW32 :: Generator g m => (Word32, Word32) -> g -> m Word32
+uniformRW32 = uniformR
+{-# INLINE uniformRW32 #-}
+
+uniformRW64 :: Generator g m => (Word64, Word64) -> g -> m Word64
+uniformRW64 = uniformR
+{-# INLINE uniformRW64 #-}
+
+uniformRBool :: Generator g m => (Bool, Bool) -> g -> m Bool
+uniformRBool = uniformR
+{-# INLINE uniformRBool #-}
+
+uniformRF :: Generator g m => (Float, Float) -> g -> m Float
+uniformRF = uniformR
+{-# INLINE uniformRF #-}
+
+uniformRD :: Generator g m => (Double, Double) -> g -> m Double
+uniformRD = uniformR
+{-# INLINE uniformRD #-}
+
+-- uniformB ------------------------------------------------------------
+
+uniformBI8 :: Generator g m => Int8 -> g -> m Int8
+uniformBI8 = uniformB
+{-# INLINE uniformBI8 #-}
+
+uniformBI16 :: Generator g m => Int16 -> g -> m Int16
+uniformBI16 = uniformB
+{-# INLINE uniformBI16 #-}
+
+uniformBI32 :: Generator g m => Int32 -> g -> m Int32
+uniformBI32 = uniformB
+{-# INLINE uniformBI32 #-}
+
+uniformBI64 :: Generator g m => Int64 -> g -> m Int64
+uniformBI64 = uniformB
+{-# INLINE uniformBI64 #-}
+
+uniformBW8 :: Generator g m => Word8 -> g -> m Word8
+uniformBW8 = uniformB
+{-# INLINE uniformBW8 #-}
+
+uniformBW16 :: Generator g m => Word16 -> g -> m Word16
+uniformBW16 = uniformB
+{-# INLINE uniformBW16 #-}
+
+uniformBW32 :: Generator g m => Word32 -> g -> m Word32
+uniformBW32 = uniformB
+{-# INLINE uniformBW32 #-}
+
+uniformBW64 :: Generator g m => Word64 -> g -> m Word64
+uniformBW64 = uniformB
+{-# INLINE uniformBW64 #-}
+
+uniformBBool :: Generator g m => Bool -> g -> m Bool
+uniformBBool = uniformB
+{-# INLINE uniformBBool #-}
+
+uniformBF :: Generator g m => Float -> g -> m Float
+uniformBF = uniformB
+{-# INLINE uniformBF #-}
+
+uniformBD :: Generator g m => Double -> g -> m Double
+uniformBD = uniformB
+{-# INLINE uniformBD #-}
+
+------------------------------------------------------------------------
+-- Utilities
+------------------------------------------------------------------------
+
+sub :: (Integral a, Integral (Unsigned a)) => a -> a -> Unsigned a
+sub x y = fromIntegral x - fromIntegral y
+{-# INLINE sub #-}
+
+add :: (Integral a, Integral (Unsigned a)) => a -> Unsigned a -> a
+add m x = m + fromIntegral x
+{-# INLINE add #-}
+
+wordsTo64Bit :: Integral a => Word32 -> Word32 -> a
+wordsTo64Bit x y =
+ fromIntegral ((fromIntegral x `shiftL` 32) .|. fromIntegral y :: Word64)
+{-# INLINE wordsTo64Bit #-}
+
+wordToBool :: Word32 -> Bool
+wordToBool i = (i .&. 1) /= 0
+{-# INLINE wordToBool #-}
+
+wordToFloat :: Word32 -> Float
+wordToFloat x = (fromIntegral i * m_inv_32) + 0.5 + m_inv_33
+ where m_inv_33 = 1.16415321826934814453125e-10
+ m_inv_32 = 2.3283064365386962890625e-10
+ i = fromIntegral x :: Int32
+{-# INLINE wordToFloat #-}
+
+wordsToDouble :: Word32 -> Word32 -> Double
+wordsToDouble x y = (fromIntegral u * m_inv_32 + (0.5 + m_inv_53) +
+ fromIntegral (v .&. 0xFFFFF) * m_inv_52)
+ where m_inv_52 = 2.220446049250313080847263336181640625e-16
+ m_inv_53 = 1.1102230246251565404236316680908203125e-16
+ m_inv_32 = 2.3283064365386962890625e-10
+ u = fromIntegral x :: Int32
+ v = fromIntegral y :: Int32
+{-# INLINE wordsToDouble #-}
+
+-- IO randoms
+
+-- | Generate a random number using "System.Entropy".
+--
+-- Use RDRAND if available and XOR with @\/dev\/urandom@ on Unix and
+-- CryptAPI on Windows. This entropy is considered cryptographically
+-- secure but not true entropy.
+sysRandom :: IO Word64
+sysRandom = do
+ bs <- getEntropy 8
+ useAsCString bs $ peek . castPtr
+
+uniformRange
+ :: (Generator g m, Integral a, Variate a, Integral (Unsigned a),
+ Bounded (Unsigned a), Variate (Unsigned a))
+ => (a,a) -> g -> m a
+uniformRange (x1,x2) g
+ | n == 0 = uniform g -- Abuse overflow in unsigned types
+ | otherwise = loop
+ where
+ -- Allow ranges where x2= 707
+{-# LANGUAGE RoleAnnotations #-}
+#endif
+-- |
+-- Module : System.Random.PCG.Fast.Pure
+-- Copyright : Copyright (c) 2015, Christopher Chalmers
+-- License : BSD3
+-- Maintainer : Christopher Chalmers
+-- Stability : experimental
+-- Portability: CPP
+--
+-- Experimental pure haskell version of the fast variant of the PCG
+-- random number generator. This module can perform faster than the c
+-- bindings version, especially for parallel code.
+--
+-- See for details.
+--
+-- @
+-- import Control.Monad.ST
+-- import System.Random.PCG.Fast.Pure
+--
+-- three :: [Double]
+-- three = runST $ do
+-- g <- create
+-- a <- uniform g
+-- b <- uniform g
+-- c <- uniform g
+-- return [a,b,c]
+-- @
+module System.Random.PCG.Fast.Pure
+ ( -- * Gen
+ Gen, GenIO
+ , create, initialize
+
+ -- * Getting random numbers
+ , Variate (..)
+ , advance, retract
+
+ -- * Seeds
+ , FrozenGen, save, restore, seed, initFrozen
+
+ -- * Type restricted versions
+ -- ** uniform
+ , uniformW8, uniformW16, uniformW32, uniformW64
+ , uniformI8, uniformI16, uniformI32, uniformI64
+ , uniformF, uniformD, uniformBool
+
+ -- ** uniformR
+ , uniformRW8, uniformRW16, uniformRW32, uniformRW64
+ , uniformRI8, uniformRI16, uniformRI32, uniformRI64
+ , uniformRF, uniformRD, uniformRBool
+
+ -- ** uniformB
+ , uniformBW8, uniformBW16, uniformBW32, uniformBW64
+ , uniformBI8, uniformBI16, uniformBI32, uniformBI64
+ , uniformBF, uniformBD, uniformBBool
+
+ , Pair(..), pair
+ ) where
+
+import Control.Monad.Primitive
+import Data.Bits
+import Data.Primitive.ByteArray
+import GHC.Word
+
+import System.Random.PCG.Class
+
+newtype FrozenGen = F Word64
+ deriving (Show, Eq, Ord)
+
+-- | State of the random number generator.
+newtype Gen = G (MutableByteArray RealWorld)
+
+type GenIO = Gen
+
+-- $setup
+-- >>> import System.Random.PCG.Fast.Pure
+-- >>> import System.Random.PCG.Class
+-- >>> import Control.Monad
+
+-- internals -----------------------------------------------------------
+
+data Pair = P {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word32
+ deriving Show
+
+fastMultiplier :: Word64
+fastMultiplier = 6364136223846793005
+
+-- Compute the next state of the generator
+state :: Word64 -> Word64
+state s = s * fastMultiplier
+
+-- Compute the output random number from the state of the generator.
+output :: Word64 -> Word32
+output s = fromIntegral $
+ ((s `shiftR` 22) `xor` s) `unsafeShiftR` (fromIntegral (s `shiftR` 61) + 22)
+
+-- Compute the next state and output in a strict pair.
+pair :: Word64 -> Pair
+pair s = P (state s) (output s)
+
+-- Given some bound and the generator, compute the new state and bounded
+-- random number.
+bounded :: Word32 -> Word64 -> Pair
+bounded b s0 = go s0
+ where
+ t = negate b `mod` b
+ go !s | r >= t = P s' (r `mod` b)
+ | otherwise = go s'
+ where P s' r = pair s
+{-# INLINE bounded #-}
+
+advancing
+ :: Word64 -- amount to advance by
+ -> Word64 -- state
+ -> Word64 -- multiplier
+ -> Word64 -- increment
+ -> Word64 -- new state
+advancing d0 s m0 p0 = go d0 m0 p0 1 0
+ where
+ go d cm cp am ap
+ | d <= 0 = am * s + ap
+ | odd d = go d' cm' cp' (am * cm) (ap * cm + cp)
+ | otherwise = go d' cm' cp' am ap
+ where
+ cm' = cm * cm
+ cp' = (cm + 1) * cp
+ d' = d `div` 2
+
+advanceFast :: Word64 -> FrozenGen -> FrozenGen
+advanceFast d (F s) = F $ advancing d s fastMultiplier 0
+
+------------------------------------------------------------------------
+-- Seed
+------------------------------------------------------------------------
+
+-- | Save the state of a 'Gen' in a 'Seed'.
+save :: GenIO -> IO FrozenGen
+save (G a) = F <$> readByteArray a 0
+{-# INLINE save #-}
+
+-- | Restore a 'Gen' from a 'Seed'.
+restore :: FrozenGen -> IO GenIO
+restore (F f) = do
+-- a <- newByteArray 8
+ a <- newByteArray 48 -- 8 Fill a whole cacheline
+ writeByteArray a 0 f
+ return $! G a
+{-# INLINE restore #-}
+
+-- | Generate a new seed using single 'Word64'.
+--
+-- >>> initFrozen 0
+-- FrozenGen 1
+initFrozen :: Word64 -> FrozenGen
+initFrozen w = F (w .|. 1)
+
+-- | Standard initial seed.
+seed :: FrozenGen
+seed = F 0xcafef00dd15ea5e5
+
+-- | Create a 'Gen' from a fixed initial seed.
+create :: IO GenIO
+create = restore seed
+
+-- | Initialize a generator a single word.
+--
+-- >>> initialize 0 >>= save
+-- FrozenGen 1
+initialize :: Word64 -> IO GenIO
+initialize a = restore (initFrozen a)
+
+-- | Advance the given generator n steps in log(n) time. (Note that a
+-- \"step\" is a single random 32-bit (or less) 'Variate'. Data types
+-- such as 'Double' or 'Word64' require two \"steps\".)
+--
+-- >>> create >>= \g -> replicateM_ 1000 (uniformW32 g) >> uniformW32 g
+-- 3725702568
+-- >>> create >>= \g -> replicateM_ 500 (uniformD g) >> uniformW32 g
+-- 3725702568
+-- >>> create >>= \g -> advance 1000 g >> uniformW32 g
+-- 3725702568
+advance :: Word64 -> GenIO -> IO ()
+advance u (G a) = do
+ s <- readByteArray a 0
+ let (F s') = advanceFast u (F s)
+ writeByteArray a 0 s'
+{-# INLINE advance #-}
+
+-- | Retract the given generator n steps in log(2^64-n) time. This
+-- is just @advance (-n)@.
+--
+-- >>> create >>= \g -> replicateM 3 (uniformW32 g)
+-- [2951688802,2698927131,361549788]
+-- >>> create >>= \g -> retract 1 g >> replicateM 3 (uniformW32 g)
+-- [954135925,2951688802,2698927131]
+retract :: Word64 -> GenIO -> IO ()
+retract u g = advance (-u) g
+{-# INLINE retract #-}
+
+------------------------------------------------------------------------
+-- Instances
+------------------------------------------------------------------------
+
+instance Generator GenIO IO where
+ uniform1 f (G a) = do
+ s <- readByteArray a 0
+ let P s' r = pair s
+ writeByteArray a 0 s'
+ return $! f r
+ {-# INLINE uniform1 #-}
+
+ uniform2 f (G a) = do
+ s <- readByteArray a 0
+ let s' = state s
+ writeByteArray a 0 (state s')
+ return $! f (output s) (output s')
+ {-# INLINE uniform2 #-}
+
+ uniform1B f b (G a) = do
+ s <- readByteArray a 0
+ let P s' r = bounded b s
+ writeByteArray a 0 s'
+ return $! f r
+ {-# INLINE uniform1B #-}
diff --git a/benchmarks/PPoPP2019/src/Throughput.hs b/benchmarks/PPoPP2019/src/Throughput.hs
new file mode 100644
index 0000000..1167521
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/Throughput.hs
@@ -0,0 +1,163 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE CPP #-}
+module Throughput
+ ( throughputMain
+ , throughputMain'
+ , locallyCountingForever
+ , locallyCountingForever'
+ , locallyCountingIterate
+ , locallyCountingIterate'
+ , voidForever
+ , ThroughputAction
+
+ , newCount
+ , readCount
+ , incCount
+ , Count(..)
+ , CountIO
+ ) where
+
+import GHC.Conc.Sync
+import Control.Concurrent
+import Control.Concurrent.MVar
+import Control.Monad
+import Control.Applicative
+import Control.Exception (finally)
+
+import Data.IORef
+#ifdef BYTECOUNTER
+import Control.Monad.Primitive
+import Data.Primitive.ByteArray
+#endif
+
+import GHC.Word
+
+import System.IO
+
+
+-- Here we provide a framework for running some worker threads for a given
+-- amount of time. We may also want to collect data as these threads work in a
+-- thread local way. To achieve this we will run the worker action forever and
+-- kill all the worker threads after the desired time has elapsed. The
+-- framework will wait for all the threads to complete after killing and then
+-- record and result in the actual elapsed time. Each worker action given must
+-- spawn its own looping thread. Wrappers for this looping and spawning are
+-- given as 'locallyCountingForever' and 'voidForever'. The first one counts
+-- every time the action runs in a thread local counter and gives access to
+-- that counter with an 'IO' action. The second doesn't do any reporting, but
+-- simply loops forever in a thread.
+
+type ThroughputAction a = IO (ThreadId, a)
+#ifdef BYTECOUNTER
+newtype Count = C (MutableByteArray RealWorld)
+
+type CountIO = Count
+
+newCount :: Word64 -> IO Count
+newCount i = do
+ a <- newByteArray 48 -- 8 (fill a whole cacheline instead)
+ writeByteArray a 0 i
+ return $! C a
+{-# INLINE newCount #-}
+
+readCount :: Count -> IO Word64
+readCount (C a) = readByteArray a 0
+{-# INLINE readCount #-}
+
+incCount :: Count -> IO ()
+incCount (C a) = do
+ c <- readByteArray a 0
+ writeByteArray a 0 (c+1::Word64)
+{-# INLINE incCount #-}
+#else
+newtype Count = C (IORef Word64)
+type CountIO = Count
+
+newCount :: Word64 -> IO Count
+newCount i = do
+ a <- newIORef i
+ return $! C a
+{-# INLINE newCount #-}
+
+readCount :: Count -> IO Word64
+readCount (C a) = readIORef a
+{-# INLINE readCount #-}
+
+incCount :: Count -> IO ()
+incCount (C a) = do
+ modifyIORef' a succ
+{-# INLINE incCount #-}
+#endif
+
+
+locallyCountingIterate' :: Int -> (a -> IO a) -> a -> ThroughputAction (IO Word64)
+locallyCountingIterate' i step initial = do
+ c <- newCount 0
+ t <- forkOn i $ act c initial
+ return (t, readCount c)
+ where
+ act c x = do
+ x' <- step x
+ incCount c
+ act c x'
+
+locallyCountingIterate :: (a -> IO a) -> a -> ThroughputAction (IO Word64)
+locallyCountingIterate step initial = do
+ c <- newCount 0
+ t <- forkIO $ act c initial
+ return (t, readCount c)
+ where
+ act c x = do
+ x' <- step x
+ incCount c
+ act c x'
+
+
+locallyCountingForever' :: Int -> IO () -> ThroughputAction (IO Word64)
+locallyCountingForever' i act = do
+ c <- newCount 0
+ t <- forkOn i . forever $ (incCount c >> act)
+ return (t, readCount c)
+
+locallyCountingForever :: IO () -> ThroughputAction (IO Word64)
+locallyCountingForever act = do
+ c <- newCount 0
+ t <- forkIO . forever $ (incCount c >> act)
+ return (t, readCount c)
+
+voidForever :: Int -> IO () -> ThroughputAction ()
+voidForever i act = do
+ t <- forkOn i . forever $ act
+ return (t, ())
+
+throughputMain :: Int -> [IO ()] -> IO (Double,Double)
+throughputMain timeout ws = fst <$> throughputMain' timeout (zipWith voidForever [0..length ws-1] ws)
+
+throughputMain' :: Int -> [ThroughputAction a] -> IO ((Double,Double), [a])
+throughputMain' timeout ws = do
+ -- Record start time.
+ start <- getTime
+
+ -- Start threads
+ (unzip -> (ts,rs),vs) <- fmap unzip . forM ws $ \w -> do
+ v <- newEmptyMVar
+ r <- finally w (putMVar v ())
+ return (r,v)
+
+ -- Wait for time
+ threadDelay timeout
+
+ endA <- getTime
+
+ -- Kill threads
+ mapM_ killThread ts
+ mapM_ takeMVar vs -- Wait for the finish signal
+
+ -- result in total time
+ end <- getTime
+
+ return $! ((end - start, endA - start), rs)
+
+
+foreign import ccall unsafe "throughput_gettime" getTime :: IO Double
diff --git a/benchmarks/PPoPP2019/src/Treap.hs b/benchmarks/PPoPP2019/src/Treap.hs
new file mode 100644
index 0000000..533397c
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/Treap.hs
@@ -0,0 +1,64 @@
+{-# LANGUAGE CPP #-}
+module Treap
+ ( Tree
+ , mkTree
+
+ , insert
+ , delete
+ , update
+ , get
+ , contains
+
+ , benchCode
+ ) where
+
+import Control.Applicative
+import Data.Word
+import Data.Maybe (isJust)
+
+import GHC.Conc
+
+#if defined(MUT)
+import qualified TreapMutSTM as T
+#define M STM
+#elif defined(TVAR)
+import qualified TreapTVar as T
+#define M STM
+#else
+#error Unknown Treap Variant
+#endif
+
+benchCode :: String
+benchCode = T.benchCode
+
+type Tree = T.Treap
+
+----------------------------------
+-- Public API
+--
+mkTree :: M Tree
+mkTree = T.mkTreap
+
+-- #define TESTCODE
+#ifdef TESTCODE
+insert :: Tree -> Word -> Word -> M Bool
+insert = T.insertV
+
+delete :: Tree -> Word -> M Bool
+delete = T.deleteV
+#else
+insert :: Tree -> Word -> Word -> M Bool
+insert = T.insert
+
+delete :: Tree -> Word -> M Bool
+delete = T.delete
+#endif
+
+get :: Tree -> Word -> M (Maybe Word)
+get = T.get
+
+update :: Tree -> Word -> Word -> M Bool
+update t k v = T.insert t k v >> return False
+
+contains :: Tree -> Word -> M Bool
+contains t k = T.contains t k
diff --git a/benchmarks/PPoPP2019/src/TreapMut.hs b/benchmarks/PPoPP2019/src/TreapMut.hs
new file mode 100644
index 0000000..f94bdf9
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/TreapMut.hs
@@ -0,0 +1,305 @@
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE MutableFields #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE BangPatterns #-}
+{- LANGUAGE Strict -}
+-- #define TESTCODE
+module TreapMut
+ ( Treap
+ , mkTreap
+ , insert
+ , get
+ , contains
+ , delete
+
+ , benchCode
+#ifdef TESTCODE
+ , verifyTreap
+ , insertV
+ , deleteV
+#endif
+ ) where
+
+import qualified System.Random.PCG.Fast.Pure as R
+-- import qualified Data.Vector.Unboxed.Mutable as U
+import Data.Primitive.ByteArray
+import Control.Monad.Primitive
+import System.Random.PCG.Class (sysRandom)
+import Data.Word (Word64, Word32, Word)
+import Control.Monad
+
+import GHC.Types
+import GHC.Prim
+import GHC.IO
+import GHC.Int
+import GHC.Conc
+
+benchCode :: String
+benchCode = "TreapMut"
+
+------------------------------
+-- Random
+
+-- | Constant for aligning RNG seed to cache-line
+-- which usually is 64 Kb long (while seed only is 'Data.Word64').
+cacheFactor :: Int
+cacheFactor = 8
+
+type RandomState = MutableByteArray
+
+-- Obtains PCG state, generate random value and store new state
+gen :: RandomState -> Int -> IO Word32
+gen v !i = do
+ let i' = i * cacheFactor
+ st <- readByteArray v i'
+ let (R.P st' x) = R.pair st
+ writeByteArray v i' st'
+ return x
+
+
+----------------------------------------------
+-- mutable
+
+type Mutable a = Ref# RealWorld a
+
+readRef :: Mutable a -> IO a
+readRef r = IO (\s# -> readRef# r s#)
+
+writeRef :: Mutable a -> a -> IO ()
+writeRef r l = IO (\s1# -> case writeRef# r l s1# of
+ s2# -> (# s2#, () #))
+
+---------------------------------------------
+-- Treap
+
+type Key = Word
+type Value = Word
+type Priority = Word32 -- native to our PRNG
+
+data Treap where
+ Treap :: RandomState
+ -> mutable Node
+ -> IO Treap
+
+data Node where
+ Node :: !Key -- Key
+ -> !Value -- Value
+ -> !Priority -- Priority
+ -> mutable Node -- Left
+ -> mutable Node -- Right
+ -> IO Node
+ Nil :: Node
+
+key :: Node -> Key
+key (Node k _ _ _ _) = k
+
+value :: Node -> Value
+value (Node _ v _ _ _) = v
+
+priority :: Node -> Priority
+priority (Node _ _ p _ _) = p
+
+
+left :: Node -> Mutable Node
+left (Node _ _ _ l _) = l
+
+right :: Node -> Mutable Node
+right (Node _ _ _ _ r) = r
+
+instance Show Node where
+ show Nil = "Nil"
+ show (Node k v _ _ _) = show ("Node " ++ show k ++ " " ++ show v)
+
+instance Eq Node where
+ Nil == Nil = True
+ Nil == _ = False
+ _ == Nil = False
+
+-- x == y = case reallyUnsafePtrEquality# x y of
+-- 0# -> False
+-- _ -> True
+ (Node k _ _ _ _) == (Node k' _ _ _ _) = k == k'
+
+isNil :: Node -> Bool
+isNil Nil = True
+isNil _ = False
+
+isNode = not . isNil
+
+mkTreap :: IO Treap
+mkTreap = do
+ cn <- getNumCapabilities
+ statev <- newByteArray (cn * cacheFactor * 8)
+ forM_ [0..cn-1] $ \i -> do
+ seed <- sysRandom
+ writeByteArray statev (i * cacheFactor) seed
+ Treap statev Nil
+
+-- Implementation somewhat follows:
+-- https://github.com/frol/completely-unscientific-benchmarks/blob/master/c%23/Program.cs
+mkNode :: Treap -> Key -> Value -> IO Node
+mkNode (Treap s _) k v = do
+ cn <- do
+ tid <- myThreadId
+ fst `fmap` threadCapability tid
+ p <- gen s cn
+ Node k v p Nil Nil
+
+merge :: Node -> Node -> IO Node
+merge Nil g = return g
+merge l Nil = return l
+merge l@(Node _ _ lp _ lr) g@(Node _ _ gp gl _)
+ | lp < gp = do
+ lrn <- readRef lr
+ merge lrn g >>= writeRef lr
+ return l
+ | otherwise = do
+ gln <- readRef gl
+ merge l gln >>= writeRef gl
+ return g
+
+splitL :: Key -> Node -> IO (Node, Node)
+splitL _ Nil = return (Nil, Nil)
+splitL key n@(Node k _ _ l r)
+ | k < key = do
+ (f, s) <- readRef r >>= splitL key
+ writeRef r f
+ return (n, s)
+ | otherwise = do
+ (f, s) <- readRef l >>= splitL key
+ writeRef l s
+ return (f, n)
+
+splitLEq :: Key -> Node -> IO (Node, Node)
+splitLEq _ Nil = return (Nil, Nil)
+splitLEq key n@(Node k _ _ l r)
+ | k <= key = do
+ (f, s) <- readRef r >>= splitLEq key
+ writeRef r f
+ return (n, s)
+ | otherwise = do
+ (f, s) <- readRef l >>= splitLEq key
+ writeRef l s
+ return (f, n)
+
+merge3 :: Node -> Node -> Node -> IO Node
+merge3 l e g = do
+ l' <- merge l e
+ merge l' g
+
+split :: Key -> Node -> IO (Node, Node, Node)
+split k n = do
+ (lof, los) <- splitL k n
+ (egf, egs) <- splitLEq k los
+ return (lof, egf, egs)
+
+nodeContains :: Key -> Node -> IO Bool
+nodeContains k n = do
+ let loop Nil = return False
+ loop (Node k' _ _ l r)
+ | k < k' = readRef l >>= loop
+ | k > k' = readRef r >>= loop
+ | otherwise = return True
+ loop n
+
+nodeGet :: Key -> Node -> IO (Maybe Value)
+nodeGet k n = do
+ let loop Nil = return Nothing
+ loop (Node k' v _ l r)
+ | k < k' = readRef l >>= loop
+ | k > k' = readRef r >>= loop
+ | otherwise = return (Just v)
+ loop n
+
+get :: Treap -> Key -> IO (Maybe Value)
+get (Treap _ n) k = readRef n >>= nodeGet k
+
+contains :: Treap -> Key -> IO Bool
+contains (Treap _ n) k = readRef n >>= nodeContains k
+
+insert :: Treap -> Key -> Value -> IO Bool
+insert t@(Treap s nr) k v = do
+ n <- readRef nr
+ b <- nodeContains k n
+ if b
+ then return False
+ else do
+ (l,e,g) <- split k n
+ e' <- mkNode t k v
+ merge3 l e' g >>= writeRef nr
+ return True
+
+delete :: Treap -> Key -> IO Bool
+delete (Treap _ nr) k = do
+ n <- readRef nr
+ b <- nodeContains k n
+ if not b
+ then return False
+ else do
+ (l,e,g) <- split k n
+ merge l g >>= writeRef nr
+ return True
+
+#ifdef TESTCODE
+assertIO :: Show s => String -> s -> Bool -> IO ()
+assertIO _ _ True = return ()
+assertIO s v False = error (s ++ "\n -- " ++ show v)
+
+verifyNode :: Node -> IO Int
+verifyNode Nil = return 0
+verifyNode (Node k v p l r) = do
+ ln <- readRef l
+ rn <- readRef r
+
+ when (isNode ln) $ do
+ assertIO "left <" (key ln, k) (key ln < k)
+ assertIO "prio >=" (priority ln, p) (priority ln >= p)
+ when (isNode rn) $ do
+ assertIO "right >" (key rn, k) (key rn > k)
+ assertIO "prio >=" (priority rn, p) (priority rn >= p)
+
+ ls <- verifyNode ln
+ rs <- verifyNode rn
+ return (ls + rs + 1)
+
+verifyTreap :: Treap -> IO Int
+verifyTreap (Treap _ n) = readRef n >>= verifyNode
+
+insertV :: Treap -> Key -> Value -> IO Bool
+insertV t k v = do
+ s1 <- verifyTreap t
+ b1 <- contains t k
+ b2 <- insert t k v
+ b3 <- contains t k
+ s2 <- verifyTreap t
+ assertIO "insert check" (b1,b2,b3)
+ ( (b1 && not b2 && b3) -- already present, stays
+ || (not b1 && b2 && b3)) -- not present, is added.
+ mv <- get t k
+ assertIO "insert value check" (mv, v, b2)
+ (case mv of
+ Nothing -> False
+ Just v' -> v == v' || not b2)
+ assertIO "insert size" (s1,s2,b2)
+ ( (b2 && s1 == s2 - 1)
+ || (not b2 && s1 == s2))
+ return b2
+
+deleteV :: Treap -> Key -> IO Bool
+deleteV t k = do
+ s1 <- verifyTreap t
+ b1 <- contains t k
+ b2 <- delete t k
+ b3 <- contains t k
+ s2 <- verifyTreap t
+ assertIO "delete check" (b1,b2,b3)
+ ( (not b1 && not b2 && not b3) -- already gone, stays gone.
+ || (b1 && b2 && not b3)) -- is present, goes away.
+ assertIO "delete size" (s1,s2,b2)
+ ( (b2 && s1 == s2 + 1)
+ || (not b2 && s1 == s2))
+ return b2
+#endif
diff --git a/benchmarks/PPoPP2019/src/TreapMutSTM.hs b/benchmarks/PPoPP2019/src/TreapMutSTM.hs
new file mode 100644
index 0000000..59053c9
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/TreapMutSTM.hs
@@ -0,0 +1,308 @@
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE MutableFields #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE Strict #-}
+-- #define TESTCODE
+module TreapMutSTM
+ ( Treap
+ , mkTreap
+ , insert
+ , get
+ , contains
+ , delete
+
+ , benchCode
+#ifdef TESTCODE
+ , verifyTreap
+ , insertV
+ , deleteV
+#endif
+ ) where
+
+import qualified System.Random.PCG.Fast.Pure as R
+-- import qualified Data.Vector.Unboxed.Mutable as U
+import Data.Primitive.ByteArray
+import Control.Monad.Primitive
+import System.Random.PCG.Class (sysRandom)
+import Data.Word (Word64, Word32, Word)
+import Control.Monad
+
+import GHC.Types
+import GHC.Prim
+import GHC.IO
+import GHC.Int
+import GHC.Conc
+
+benchCode :: String
+benchCode = "TreapMutSTM"
+
+------------------------------
+-- Random
+
+-- | Constant for aligning RNG seed to cache-line
+-- which usually is 64 Kb long (while seed only is 'Data.Word64').
+cacheFactor :: Int
+cacheFactor = 8
+
+type RandomState = MutableByteArray RealWorld
+
+-- Obtains PCG state, generate random value and store new state
+gen :: RandomState -> Int -> IO Word32
+gen v !i = do
+ let i' = i * cacheFactor
+ st <- readByteArray v i'
+ let (R.P st' x) = R.pair st
+ writeByteArray v i' st'
+ return x
+
+
+----------------------------------------------
+-- mutable
+
+type Mutable a = Ref# RealWorld a
+
+readRef :: Mutable a -> STM a
+readRef r = STM (\s# -> readTRef# r s#)
+
+writeRef :: Mutable a -> a -> STM ()
+writeRef r l = STM (\s1# -> case writeTRef# r l s1# of
+ s2# -> (# s2#, () #))
+
+---------------------------------------------
+-- Treap
+
+type Key = Word
+type Value = Word
+type Priority = Word32 -- native to our PRNG
+
+data Treap where
+ Treap :: RandomState
+ -> mutable Node
+ -> STM Treap
+
+data Node where
+ Node :: !Key -- Key
+ -> !Value -- Value
+ -> !Priority -- Priority
+ -> mutable Node -- Left
+ -> mutable Node -- Right
+ -> STM Node
+ Nil :: Node
+
+key :: Node -> Key
+key (Node k _ _ _ _) = k
+
+value :: Node -> Value
+value (Node _ v _ _ _) = v
+
+priority :: Node -> Priority
+priority (Node _ _ p _ _) = p
+
+
+left :: Node -> Mutable Node
+left (Node _ _ _ l _) = l
+
+right :: Node -> Mutable Node
+right (Node _ _ _ _ r) = r
+
+instance Show Node where
+ show Nil = "Nil"
+ show (Node k v _ _ _) = show ("Node " ++ show k ++ " " ++ show v)
+
+instance Eq Node where
+ Nil == Nil = True
+ Nil == _ = False
+ _ == Nil = False
+
+-- x == y = case reallyUnsafePtrEquality# x y of
+-- 0# -> False
+-- _ -> True
+ (Node k _ _ _ _) == (Node k' _ _ _ _) = k == k'
+
+isNil :: Node -> Bool
+isNil Nil = True
+isNil _ = False
+
+isNode = not . isNil
+
+mkTreap :: STM Treap
+mkTreap = do
+ state <- unsafeIOToSTM $ do
+ cn <- getNumCapabilities
+ statev <- newByteArray (cn * cacheFactor * 8)
+ forM_ [0..cn-1] $ \i -> do
+ seed <- sysRandom
+ writeByteArray statev (i * cacheFactor) seed
+ return statev
+ Treap state Nil -- This isn't ideal...
+
+-- Implementation somewhat follows:
+-- https://github.com/frol/completely-unscientific-benchmarks/blob/master/c%23/Program.cs
+mkNode :: Treap -> Key -> Value -> STM Node
+mkNode (Treap s _) k v = do
+ p <- unsafeIOToSTM $ do
+ cn <- do
+ tid <- myThreadId
+ fst `fmap` threadCapability tid
+ gen s cn
+ Node k v p Nil Nil
+
+merge :: Node -> Node -> STM Node
+merge Nil g = return g
+merge l Nil = return l
+merge l@(Node _ _ lp _ lr) g@(Node _ _ gp gl _)
+ | lp < gp = do
+ lrn <- readRef lr
+ merge lrn g >>= writeRef lr
+ return l
+ | otherwise = do
+ gln <- readRef gl
+ merge l gln >>= writeRef gl
+ return g
+
+splitL :: Key -> Node -> STM (Node, Node)
+splitL _ Nil = return (Nil, Nil)
+splitL key n@(Node k _ _ l r)
+ | k < key = do
+ (f, s) <- readRef r >>= splitL key
+ writeRef r f
+ return (n, s)
+ | otherwise = do
+ (f, s) <- readRef l >>= splitL key
+ writeRef l s
+ return (f, n)
+
+splitLEq :: Key -> Node -> STM (Node, Node)
+splitLEq _ Nil = return (Nil, Nil)
+splitLEq key n@(Node k _ _ l r)
+ | k <= key = do
+ (f, s) <- readRef r >>= splitLEq key
+ writeRef r f
+ return (n, s)
+ | otherwise = do
+ (f, s) <- readRef l >>= splitLEq key
+ writeRef l s
+ return (f, n)
+
+merge3 :: Node -> Node -> Node -> STM Node
+merge3 l e g = do
+ l' <- merge l e
+ merge l' g
+
+split :: Key -> Node -> STM (Node, Node, Node)
+split k n = do
+ (lof, los) <- splitL k n
+ (egf, egs) <- splitLEq k los
+ return (lof, egf, egs)
+
+nodeContains :: Key -> Node -> STM Bool
+nodeContains k n = do
+ let loop Nil = return False
+ loop (Node k' _ _ l r)
+ | k < k' = readRef l >>= loop
+ | k > k' = readRef r >>= loop
+ | otherwise = return True
+ loop n
+
+nodeGet :: Key -> Node -> STM (Maybe Value)
+nodeGet k n = do
+ let loop Nil = return Nothing
+ loop (Node k' v _ l r)
+ | k < k' = readRef l >>= loop
+ | k > k' = readRef r >>= loop
+ | otherwise = return (Just v)
+ loop n
+
+get :: Treap -> Key -> STM (Maybe Value)
+get (Treap _ n) k = readRef n >>= nodeGet k
+
+contains :: Treap -> Key -> STM Bool
+contains (Treap _ n) k = readRef n >>= nodeContains k
+
+insert :: Treap -> Key -> Value -> STM Bool
+insert t@(Treap s nr) k v = do
+ n <- readRef nr
+ b <- nodeContains k n
+ if b
+ then return False
+ else do
+ (l,e,g) <- split k n
+ e' <- mkNode t k v
+ merge3 l e' g >>= writeRef nr
+ return True
+
+delete :: Treap -> Key -> STM Bool
+delete (Treap _ nr) k = do
+ n <- readRef nr
+ b <- nodeContains k n
+ if not b
+ then return False
+ else do
+ (l,e,g) <- split k n
+ merge l g >>= writeRef nr
+ return True
+
+#ifdef TESTCODE
+assertSTM :: Show s => String -> s -> Bool -> STM ()
+assertSTM _ _ True = return ()
+assertSTM s v False = error (s ++ "\n -- " ++ show v)
+
+verifyNode :: Node -> STM Int
+verifyNode Nil = return 0
+verifyNode (Node k v p l r) = do
+ ln <- readRef l
+ rn <- readRef r
+
+ when (isNode ln) $ do
+ assertSTM "left <" (key ln, k) (key ln < k)
+ assertSTM "prio >=" (priority ln, p) (priority ln >= p)
+ when (isNode rn) $ do
+ assertSTM "right >" (key rn, k) (key rn > k)
+ assertSTM "prio >=" (priority rn, p) (priority rn >= p)
+
+ ls <- verifyNode ln
+ rs <- verifyNode rn
+ return (ls + rs + 1)
+
+verifyTreap :: Treap -> STM Int
+verifyTreap (Treap _ n) = readRef n >>= verifyNode
+
+insertV :: Treap -> Key -> Value -> STM Bool
+insertV t k v = do
+ s1 <- verifyTreap t
+ b1 <- contains t k
+ b2 <- insert t k v
+ b3 <- contains t k
+ s2 <- verifyTreap t
+ assertSTM "insert check" (b1,b2,b3)
+ ( (b1 && not b2 && b3) -- already present, stays
+ || (not b1 && b2 && b3)) -- not present, is added.
+ mv <- get t k
+ assertSTM "insert value check" (mv, v, b2)
+ (case mv of
+ Nothing -> False
+ Just v' -> v == v' || not b2)
+ assertSTM "insert size" (s1,s2,b2)
+ ( (b2 && s1 == s2 - 1)
+ || (not b2 && s1 == s2))
+ return b2
+
+deleteV :: Treap -> Key -> STM Bool
+deleteV t k = do
+ s1 <- verifyTreap t
+ b1 <- contains t k
+ b2 <- delete t k
+ b3 <- contains t k
+ s2 <- verifyTreap t
+ assertSTM "delete check" (b1,b2,b3)
+ ( (not b1 && not b2 && not b3) -- already gone, stays gone.
+ || (b1 && b2 && not b3)) -- is present, goes away.
+ assertSTM "delete size" (s1,s2,b2)
+ ( (b2 && s1 == s2 + 1)
+ || (not b2 && s1 == s2))
+ return b2
+#endif
diff --git a/benchmarks/PPoPP2019/src/TreapTVar.hs b/benchmarks/PPoPP2019/src/TreapTVar.hs
new file mode 100644
index 0000000..da5dd03
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/TreapTVar.hs
@@ -0,0 +1,317 @@
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE BangPatterns #-}
+{- LANGUAGE Strict -}
+-- #define TESTCODE
+module TreapTVar
+ ( Treap
+ , mkTreap
+ , insert
+ , get
+ , contains
+ , delete
+
+ , benchCode
+#ifdef TESTCODE
+ , verifyTreap
+ , insertV
+ , deleteV
+#endif
+ ) where
+
+import qualified System.Random.PCG.Fast.Pure as R
+-- import qualified Data.Vector.Unboxed.Mutable as U
+import Data.Primitive.ByteArray
+import Control.Monad.Primitive
+import System.Random.PCG.Class (sysRandom)
+import Data.Word (Word64, Word32, Word)
+import Control.Monad
+
+import GHC.Types
+import GHC.Prim
+import GHC.IO
+import GHC.Int
+import GHC.Conc
+import GHC.Conc.Sync
+
+benchCode :: String
+benchCode = "TreapTVar"
+
+------------------------------
+-- Random
+
+-- | Constant for aligning RNG seed to cache-line
+-- which usually is 64 Kb long (while seed only is 'Data.Word64').
+cacheFactor :: Int
+cacheFactor = 8
+
+type RandomState = MutableByteArray RealWorld
+
+-- Obtains PCG state, generate random value and store new state
+gen :: RandomState -> Int -> IO Word32
+gen v !i = do
+ let i' = i * cacheFactor
+ st <- readByteArray v i'
+ let (R.P st' x) = R.pair st
+ writeByteArray v i' st'
+ return x
+
+
+----------------------------------------------
+-- mutable
+
+type Mutable a = TVar a
+
+readRef :: Mutable a -> STM a
+readRef = readTVar
+
+writeRef :: Mutable a -> a -> STM ()
+writeRef = writeTVar
+
+---------------------------------------------
+-- Treap
+
+type Key = Word
+type Value = Word
+type Priority = Word32 -- native to our PRNG
+
+data Treap where
+ Treap :: RandomState
+ -> TVar Node
+ -> Treap
+
+data Node where
+ Node :: !Key -- Key
+ -> !Value -- Value
+ -> !Priority -- Priority
+ -> TVar Node -- Left
+ -> TVar Node -- Right
+ -> Node
+ Nil :: Node
+
+key :: Node -> Key
+key (Node k _ _ _ _) = k
+
+value :: Node -> Value
+value (Node _ v _ _ _) = v
+
+priority :: Node -> Priority
+priority (Node _ _ p _ _) = p
+
+
+left :: Node -> Mutable Node
+left (Node _ _ _ l _) = l
+
+right :: Node -> Mutable Node
+right (Node _ _ _ _ r) = r
+
+instance Show Node where
+ show Nil = "Nil"
+ show (Node k v _ _ _) = show ("Node " ++ show k ++ " " ++ show v)
+
+instance Eq Node where
+ Nil == Nil = True
+ Nil == _ = False
+ _ == Nil = False
+
+-- x == y = case reallyUnsafePtrEquality# x y of
+-- 0# -> False
+-- _ -> True
+ (Node k _ _ _ _) == (Node k' _ _ _ _) = k == k'
+
+isNil :: Node -> Bool
+isNil Nil = True
+isNil _ = False
+
+isNode = not . isNil
+
+mkTreapIO :: IO Treap
+mkTreapIO = do
+ cn <- getNumCapabilities
+ statev <- newByteArray (cn * cacheFactor * 8)
+ forM_ [0..cn-1] $ \i -> do
+ seed <- sysRandom
+ writeByteArray statev (i * cacheFactor) seed
+ Treap statev <$> newTVarIO Nil
+
+mkTreap :: STM Treap
+mkTreap = do
+ state <- unsafeIOToSTM $ do
+ cn <- getNumCapabilities
+ statev <- newByteArray (cn * cacheFactor * 8)
+ forM_ [0..cn-1] $ \i -> do
+ seed <- sysRandom
+ writeByteArray statev (i * cacheFactor) seed
+ return statev
+ Treap state <$> newTVar Nil
+
+
+-- Implementation somewhat follows:
+-- https://github.com/frol/completely-unscientific-benchmarks/blob/master/c%23/Program.cs
+mkNode :: Treap -> Key -> Value -> STM Node
+mkNode (Treap s _) k v = do
+ p <- unsafeIOToSTM $ do
+ cn <- do
+ tid <- myThreadId
+ fst `fmap` threadCapability tid
+ gen s cn
+ Node k v p <$> newTVar Nil <*> newTVar Nil
+
+merge :: Node -> Node -> STM Node
+merge Nil g = return g
+merge l Nil = return l
+merge l@(Node _ _ lp _ lr) g@(Node _ _ gp gl _)
+ | lp < gp = do
+ lrn <- readRef lr
+ merge lrn g >>= writeRef lr
+ return l
+ | otherwise = do
+ gln <- readRef gl
+ merge l gln >>= writeRef gl
+ return g
+
+splitL :: Key -> Node -> STM (Node, Node)
+splitL _ Nil = return (Nil, Nil)
+splitL key n@(Node k _ _ l r)
+ | k < key = do
+ (f, s) <- readRef r >>= splitL key
+ writeRef r f
+ return (n, s)
+ | otherwise = do
+ (f, s) <- readRef l >>= splitL key
+ writeRef l s
+ return (f, n)
+
+splitLEq :: Key -> Node -> STM (Node, Node)
+splitLEq _ Nil = return (Nil, Nil)
+splitLEq key n@(Node k _ _ l r)
+ | k <= key = do
+ (f, s) <- readRef r >>= splitLEq key
+ writeRef r f
+ return (n, s)
+ | otherwise = do
+ (f, s) <- readRef l >>= splitLEq key
+ writeRef l s
+ return (f, n)
+
+merge3 :: Node -> Node -> Node -> STM Node
+merge3 l e g = do
+ l' <- merge l e
+ merge l' g
+
+split :: Key -> Node -> STM (Node, Node, Node)
+split k n = do
+ (lof, los) <- splitL k n
+ (egf, egs) <- splitLEq k los
+ return (lof, egf, egs)
+
+nodeContains :: Key -> Node -> STM Bool
+nodeContains k n = do
+ let loop Nil = return False
+ loop (Node k' _ _ l r)
+ | k < k' = readRef l >>= loop
+ | k > k' = readRef r >>= loop
+ | otherwise = return True
+ loop n
+
+nodeGet :: Key -> Node -> STM (Maybe Value)
+nodeGet k n = do
+ let loop Nil = return Nothing
+ loop (Node k' v _ l r)
+ | k < k' = readRef l >>= loop
+ | k > k' = readRef r >>= loop
+ | otherwise = return (Just v)
+ loop n
+
+get :: Treap -> Key -> STM (Maybe Value)
+get (Treap _ n) k = readRef n >>= nodeGet k
+
+contains :: Treap -> Key -> STM Bool
+contains (Treap _ n) k = readRef n >>= nodeContains k
+
+insert :: Treap -> Key -> Value -> STM Bool
+insert t@(Treap s nr) k v = do
+ n <- readRef nr
+ b <- nodeContains k n
+ if b
+ then return False
+ else do
+ (l,e,g) <- split k n
+ e' <- mkNode t k v
+ merge3 l e' g >>= writeRef nr
+ return True
+
+delete :: Treap -> Key -> STM Bool
+delete (Treap _ nr) k = do
+ n <- readRef nr
+ b <- nodeContains k n
+ if not b
+ then return False
+ else do
+ (l,e,g) <- split k n
+ merge l g >>= writeRef nr
+ return True
+
+#ifdef TESTCODE
+assertSTM :: Show s => String -> s -> Bool -> STM ()
+assertSTM _ _ True = return ()
+assertSTM s v False = error (s ++ "\n -- " ++ show v)
+
+verifyNode :: Node -> STM Int
+verifyNode Nil = return 0
+verifyNode (Node k v p l r) = do
+ ln <- readRef l
+ rn <- readRef r
+
+ when (isNode ln) $ do
+ assertSTM "left <" (key ln, k) (key ln < k)
+ assertSTM "prio >=" (priority ln, p) (priority ln >= p)
+ when (isNode rn) $ do
+ assertSTM "right >" (key rn, k) (key rn > k)
+ assertSTM "prio >=" (priority rn, p) (priority rn >= p)
+
+ ls <- verifyNode ln
+ rs <- verifyNode rn
+ return (ls + rs + 1)
+
+verifyTreap :: Treap -> STM Int
+verifyTreap (Treap _ n) = readRef n >>= verifyNode
+
+insertV :: Treap -> Key -> Value -> STM Bool
+insertV t k v = do
+ s1 <- verifyTreap t
+ b1 <- contains t k
+ b2 <- insert t k v
+ b3 <- contains t k
+ s2 <- verifyTreap t
+ assertSTM "insert check" (b1,b2,b3)
+ ( (b1 && not b2 && b3) -- already present, stays
+ || (not b1 && b2 && b3)) -- not present, is added.
+ mv <- get t k
+ assertSTM "insert value check" (mv, v, b2)
+ (case mv of
+ Nothing -> False
+ Just v' -> v == v' || not b2)
+ assertSTM "insert size" (s1,s2,b2)
+ ( (b2 && s1 == s2 - 1)
+ || (not b2 && s1 == s2))
+ return b2
+
+deleteV :: Treap -> Key -> STM Bool
+deleteV t k = do
+ s1 <- verifyTreap t
+ b1 <- contains t k
+ b2 <- delete t k
+ b3 <- contains t k
+ s2 <- verifyTreap t
+ assertSTM "delete check" (b1,b2,b3)
+ ( (not b1 && not b2 && not b3) -- already gone, stays gone.
+ || (b1 && b2 && not b3)) -- is present, goes away.
+ assertSTM "delete size" (s1,s2,b2)
+ ( (b2 && s1 == s2 + 1)
+ || (not b2 && s1 == s2))
+ return b2
+#endif
diff --git a/benchmarks/PPoPP2019/src/base-prelude-1.2.0.1/CHANGELOG.md b/benchmarks/PPoPP2019/src/base-prelude-1.2.0.1/CHANGELOG.md
new file mode 100644
index 0000000..1e6bd23
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/base-prelude-1.2.0.1/CHANGELOG.md
@@ -0,0 +1,41 @@
+# 1.2
+
+* Replace the `Foreign` export with `Foreign.Storable`, `Foreign.Ptr`, `Foreign.ForeignPtr`, `Foreign.StablePtr`. It's more conservative and way less likely to cause name collisions.
+
+# 1.1
+
+* Export `Foreign`
+
+# 1.0.1
+
+* Relaxed the "base" dependency
+
+# 1
+
+No changes.
+
+# 0.2
+
+* Reexported `Data.Bifunctor`.
+
+* `first` and `second` are now (conditionally) exported from `Data.Bifunctor`, not `Control.Arrow`; note that if your version of base is lower than 4.8, `first` and `second` won't be available at all.
+
+# 0.1.21
+
+* Reexported `printf` and `hPrintf` from `Text.Printf`.
+
+# 0.1.20
+
+* Reexported `Numeric`.
+
+# 0.1.19
+
+* Avoided the clash between `(&)` and `sortOn` defined in the package and versions of these functions imported from base.
+
+# 0.1.18
+
+* Added implementations of `(&)` and `sortOn` (normally not available in older versions of base).
+
+# 0.1.17
+
+* Reexported `Control.Monad.Fix`.
diff --git a/benchmarks/PPoPP2019/src/base-prelude-1.2.0.1/LICENSE b/benchmarks/PPoPP2019/src/base-prelude-1.2.0.1/LICENSE
new file mode 100644
index 0000000..fe32f2b
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/base-prelude-1.2.0.1/LICENSE
@@ -0,0 +1,22 @@
+Copyright (c) 2014, Nikita Volkov
+
+Permission is hereby granted, free of charge, to any person
+obtaining a copy of this software and associated documentation
+files (the "Software"), to deal in the Software without
+restriction, including without limitation the rights to use,
+copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the
+Software is furnished to do so, subject to the following
+conditions:
+
+The above copyright notice and this permission notice shall be
+included in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
+OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
+OTHER DEALINGS IN THE SOFTWARE.
diff --git a/benchmarks/PPoPP2019/src/base-prelude-1.2.0.1/Setup.hs b/benchmarks/PPoPP2019/src/base-prelude-1.2.0.1/Setup.hs
new file mode 100644
index 0000000..9a994af
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/base-prelude-1.2.0.1/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/benchmarks/PPoPP2019/src/base-prelude-1.2.0.1/base-prelude.cabal b/benchmarks/PPoPP2019/src/base-prelude-1.2.0.1/base-prelude.cabal
new file mode 100644
index 0000000..26a8982
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/base-prelude-1.2.0.1/base-prelude.cabal
@@ -0,0 +1,61 @@
+name:
+ base-prelude
+version:
+ 1.2.0.1
+synopsis:
+ The most complete prelude formed solely from the "base" package
+description:
+ A library which aims to reexport all the non-conflicting and
+ most general definitions from the \"base\" package.
+ This includes APIs for applicatives, arrows, monoids, foldables, traversables,
+ exceptions, generics, ST, MVars and STM.
+ .
+ This package will never have any dependencies other than \"base\".
+ .
+ /Versioning policy/
+ .
+ The versioning policy of this package deviates from PVP in the sense
+ that its exports in part are transitively determined by the version of \"base\".
+ Therefore it's recommended for the users of \"base-prelude\" to specify
+ the bounds of \"base\" as well.
+category:
+ Prelude
+homepage:
+ https://github.com/nikita-volkov/base-prelude
+bug-reports:
+ https://github.com/nikita-volkov/base-prelude/issues
+author:
+ Nikita Volkov
+maintainer:
+ Nikita Volkov
+copyright:
+ (c) 2014, Nikita Volkov
+license:
+ MIT
+license-file:
+ LICENSE
+build-type:
+ Simple
+extra-source-files:
+ CHANGELOG.md
+cabal-version:
+ >=1.10
+
+
+source-repository head
+ type:
+ git
+ location:
+ git://github.com/nikita-volkov/base-prelude.git
+
+
+library
+ hs-source-dirs:
+ library
+ other-modules:
+ exposed-modules:
+ BasePrelude
+ build-depends:
+ base >= 4.6 && < 5
+ default-language:
+ Haskell2010
diff --git a/benchmarks/PPoPP2019/src/base-prelude-1.2.0.1/library/BasePrelude.hs b/benchmarks/PPoPP2019/src/base-prelude-1.2.0.1/library/BasePrelude.hs
new file mode 100644
index 0000000..76d8f4b
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/base-prelude-1.2.0.1/library/BasePrelude.hs
@@ -0,0 +1,206 @@
+{-# LANGUAGE CPP #-}
+-- |
+-- This module reexports most of the definitions from the \"base\" package,
+-- which are meant to be imported unqualified.
+--
+-- For details check out the source.
+module BasePrelude
+(
+ module Exports,
+ -- * Reimplementations of functions presented in versions of \"base\" newer than 4.6
+ -- ** Data.Bool
+ bool,
+ -- ** Data.Function
+ (&),
+ -- ** Data.Functor
+ ($>),
+ -- ** Data.List
+ isSubsequenceOf,
+ sortOn,
+ uncons,
+ -- ** Debug.Trace
+ traceShowId,
+ traceM,
+ traceShowM,
+)
+where
+
+-- Reexports
+-------------------------
+
+import Control.Applicative as Exports
+import Control.Arrow as Exports hiding (first, second)
+import Control.Category as Exports
+import Control.Concurrent as Exports
+import Control.Exception as Exports
+import Control.Monad as Exports hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM)
+import Control.Monad.Fix as Exports hiding (fix)
+import Control.Monad.ST as Exports
+#if MIN_VERSION_base(4,8,0)
+import Data.Bifunctor as Exports
+#endif
+import Data.Bits as Exports
+import Data.Bool as Exports hiding (bool)
+import Data.Char as Exports
+import Data.Complex as Exports
+import Data.Data as Exports
+import Data.Dynamic as Exports
+import Data.Either as Exports
+import Data.Fixed as Exports
+import Data.Foldable as Exports
+import Data.Functor as Exports hiding (($>))
+import Data.Function as Exports hiding ((.), id, (&))
+import Data.Int as Exports
+import Data.IORef as Exports
+import Data.Ix as Exports
+import Data.List as Exports hiding (sortOn, isSubsequenceOf, uncons, concat, foldr, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, find, maximumBy, minimumBy, mapAccumL, mapAccumR, foldl')
+import Data.Maybe as Exports
+import Data.Monoid as Exports
+import Data.Ord as Exports
+import Data.Ratio as Exports
+import Data.STRef as Exports
+import Data.String as Exports
+import Data.Traversable as Exports
+import Data.Tuple as Exports
+import Data.Unique as Exports
+import Data.Version as Exports
+import Data.Word as Exports
+import Debug.Trace as Exports hiding (traceShowId, traceM, traceShowM)
+import Foreign.Storable as Exports
+import Foreign.Ptr as Exports
+import Foreign.ForeignPtr as Exports
+import Foreign.StablePtr as Exports
+import GHC.Conc as Exports hiding (withMVar, threadWaitWriteSTM, threadWaitWrite, threadWaitReadSTM, threadWaitRead)
+import GHC.Exts as Exports (lazy, inline, sortWith, groupWith)
+import GHC.Generics as Exports (Generic)
+import GHC.IO.Exception as Exports
+import Numeric as Exports
+import Prelude as Exports hiding (concat, foldr, mapM_, sequence_, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, mapM, sequence, id, (.))
+import System.Environment as Exports
+import System.Exit as Exports
+import System.IO as Exports (Handle, hClose)
+import System.IO.Error as Exports
+import System.IO.Unsafe as Exports
+import System.Mem as Exports
+import System.Mem.StableName as Exports
+import System.Timeout as Exports
+import Text.ParserCombinators.ReadP as Exports (ReadP, ReadS, readP_to_S, readS_to_P)
+import Text.ParserCombinators.ReadPrec as Exports (ReadPrec, readPrec_to_P, readP_to_Prec, readPrec_to_S, readS_to_Prec)
+import Text.Printf as Exports (printf, hPrintf)
+import Text.Read as Exports (Read(..), readMaybe, readEither)
+import Unsafe.Coerce as Exports
+
+-- Conditional imports for reimplementations
+#if MIN_VERSION_base(4,7,0)
+import Data.Bool (bool)
+import Debug.Trace (traceShowId, traceM, traceShowM)
+import Data.Functor (($>))
+#endif
+#if MIN_VERSION_base(4,8,0)
+import Data.Function ((&))
+import Data.List (isSubsequenceOf, sortOn, uncons)
+#endif
+
+
+---------------------------------
+-- Reimplementations for base-4.7
+---------------------------------
+
+#if !MIN_VERSION_base(4,7,0)
+
+-- | Case analysis for the 'Bool' type.
+-- @bool a b p@ evaluates to @a@ when @p@ is @False@, and evaluates to @b@
+-- when @p@ is @True@.
+bool :: a -> a -> Bool -> a
+bool f t b = if b then t else f
+
+{-|
+Like 'traceShow' but returns the shown value instead of a third value.
+-}
+traceShowId :: (Show a) => a -> a
+traceShowId a = trace (show a) a
+
+{-|
+Like 'trace' but returning unit in an arbitrary monad. Allows for convenient
+use in do-notation. Note that the application of 'trace' is not an action in the
+monad, as 'traceIO' is in the 'IO' monad.
+
+> ... = do
+> x <- ...
+> traceM $ "x: " ++ show x
+> y <- ...
+> traceM $ "y: " ++ show y
+-}
+traceM :: (Monad m) => String -> m ()
+traceM string = trace string $ return ()
+
+{-|
+Like 'traceM', but uses 'show' on the argument to convert it to a 'String'.
+
+> ... = do
+> x <- ...
+> traceShowM $ x
+> y <- ...
+> traceShowM $ x + y
+-}
+traceShowM :: (Show a, Monad m) => a -> m ()
+traceShowM = traceM . show
+
+infixl 4 $>
+
+-- | Flipped version of '<$'.
+($>) :: Functor f => f a -> b -> f b
+($>) = flip (<$)
+
+#endif
+
+---------------------------------
+-- Reimplementations for base-4.8
+---------------------------------
+
+#if !MIN_VERSION_base(4,8,0)
+
+infixl 1 &
+
+-- | '&' is a reverse application operator. This provides notational
+-- convenience. Its precedence is one higher than that of the forward
+-- application operator '$', which allows '&' to be nested in '$'.
+(&) :: a -> (a -> b) -> b
+x & f = f x
+
+-- | The 'isSubsequenceOf' function takes two lists and returns 'True' if the
+-- first list is a subsequence of the second list.
+--
+-- @'isSubsequenceOf' x y@ is equivalent to @'elem' x ('subsequences' y)@.
+--
+-- ==== __Examples__
+--
+-- >>> isSubsequenceOf "GHC" "The Glorious Haskell Compiler"
+-- True
+-- >>> isSubsequenceOf ['a','d'..'z'] ['a'..'z']
+-- True
+-- >>> isSubsequenceOf [1..10] [10,9..0]
+-- False
+isSubsequenceOf :: (Eq a) => [a] -> [a] -> Bool
+isSubsequenceOf [] _ = True
+isSubsequenceOf _ [] = False
+isSubsequenceOf a@(x:a') (y:b) | x == y = isSubsequenceOf a' b
+ | otherwise = isSubsequenceOf a b
+
+-- | Decompose a list into its head and tail. If the list is empty,
+-- returns 'Nothing'. If the list is non-empty, returns @'Just' (x, xs)@,
+-- where @x@ is the head of the list and @xs@ its tail.
+uncons :: [a] -> Maybe (a, [a])
+uncons [] = Nothing
+uncons (x:xs) = Just (x, xs)
+
+-- | Sort a list by comparing the results of a key function applied to each
+-- element. @sortOn f@ is equivalent to @sortBy . comparing f@, but has the
+-- performance advantage of only evaluating @f@ once for each element in the
+-- input list. This is called the decorate-sort-undecorate paradigm, or
+-- Schwartzian transform.
+sortOn :: Ord b => (a -> b) -> [a] -> [a]
+sortOn f =
+ map snd . sortBy (comparing fst) . map (\x -> let y = f x in y `seq` (y, x))
+
+#endif
diff --git a/benchmarks/PPoPP2019/src/cbits/gettime.c b/benchmarks/PPoPP2019/src/cbits/gettime.c
new file mode 100644
index 0000000..a122e5c
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/cbits/gettime.c
@@ -0,0 +1,13 @@
+// Modified from criterion: github.com/bos/criterion/
+// Copyright (c) 2009, 2010 Bryan O'Sullivan
+
+#include
+
+double throughput_gettime(void)
+{
+ struct timespec ts;
+
+ clock_gettime(CLOCK_MONOTONIC, &ts);
+
+ return ts.tv_sec + ts.tv_nsec * 1e-9;
+}
diff --git a/benchmarks/PPoPP2019/src/entropy-0.4/LICENSE b/benchmarks/PPoPP2019/src/entropy-0.4/LICENSE
new file mode 100644
index 0000000..6d24e89
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/entropy-0.4/LICENSE
@@ -0,0 +1,30 @@
+Copyright (c) Thomas DuBuisson
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions
+are met:
+
+1. Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the distribution.
+
+3. Neither the name of the author nor the names of his contributors
+ may be used to endorse or promote products derived from this software
+ without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS
+OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGE.
diff --git a/benchmarks/PPoPP2019/src/entropy-0.4/README.md b/benchmarks/PPoPP2019/src/entropy-0.4/README.md
new file mode 100644
index 0000000..7a5d865
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/entropy-0.4/README.md
@@ -0,0 +1,25 @@
+# Introduction
+
+This package allows Haskell users to easily acquire entropy for use in critical
+security applications by calling out to either windows crypto api, unix/linux's
+`/dev/urandom`. Hardware RNGs (currently RDRAND, patches welcome) are supported
+via the `hardwareRNG` function.
+
+If you wish to obtain an XOR of the hardware and system RNG consider:
+
+```
+import Data.Bits (xor)
+import qualified Data.ByteString as B
+import qualified Control.Exception as X
+
+xorRNG sz = do hw <- hardwareRNG sz
+ h <- openHandle
+ sys <- hGetEntropy h `X.finally` closeHandle h
+ pure $ B.pack $ B.zipWith xor hw sys
+```
+
+This package supports Windows, {li,u}nix, QNX, and has preliminary support for HaLVM.
+
+Typically tested on Linux and OSX - testers are as welcome as patches.
+
+[](https://travis-ci.org/TomMD/entropy)
diff --git a/benchmarks/PPoPP2019/src/entropy-0.4/Setup.hs b/benchmarks/PPoPP2019/src/entropy-0.4/Setup.hs
new file mode 100644
index 0000000..49b693f
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/entropy-0.4/Setup.hs
@@ -0,0 +1,76 @@
+{-# LANGUAGE CPP #-}
+import Control.Monad
+import Distribution.Simple
+import Distribution.Simple.LocalBuildInfo
+import Distribution.Simple.Setup
+import Distribution.PackageDescription
+import Distribution.Simple.Utils
+import Distribution.Simple.Program
+import Distribution.Verbosity
+import System.Process
+import System.Directory
+import System.FilePath
+import System.Exit
+import System.IO
+
+main = defaultMainWithHooks hk
+ where
+ hk = simpleUserHooks { buildHook = \pd lbi uh bf -> do
+ -- let ccProg = Program "gcc" undefined undefined undefined
+ let hcProg = Program "ghc" undefined undefined undefined
+ mConf = lookupProgram hcProg (withPrograms lbi)
+ err = error "Could not determine C compiler"
+ cc = locationPath . programLocation . maybe err id $ mConf
+ b <- canUseRDRAND cc
+ let newWithPrograms1 = userSpecifyArgs "gcc" cArgs (withPrograms lbi)
+ newWithPrograms = userSpecifyArgs "ghc" cArgsHC newWithPrograms1
+ lbiNew = if b then (lbi {withPrograms = newWithPrograms }) else lbi
+ buildHook simpleUserHooks pd lbiNew uh bf
+ }
+
+cArgs :: [String]
+cArgs = ["-DHAVE_RDRAND"]
+
+cArgsHC :: [String]
+cArgsHC = cArgs ++ map ("-optc" ++) cArgs
+
+canUseRDRAND :: FilePath -> IO Bool
+canUseRDRAND cc = do
+ withTempDirectory normal "" "testRDRAND" $ \tmpDir -> do
+ writeFile (tmpDir ++ "/testRDRAND.c")
+ (unlines [ "#include "
+ , "int main() {"
+ , " uint64_t therand;"
+ , " unsigned char err;"
+ , " asm volatile(\"rdrand %0 ; setc %1\""
+ , " : \"=r\" (therand), \"=qm\" (err));"
+ , " return (!err);"
+ , "}"
+ ])
+ ec <- myRawSystemExitCode normal cc [tmpDir "testRDRAND.c", "-o", tmpDir ++ "/a.o","-c"]
+ notice normal $ "Result of RDRAND Test: " ++ show (ec == ExitSuccess)
+ return (ec == ExitSuccess)
+
+myRawSystemExitCode :: Verbosity -> FilePath -> [String] -> IO ExitCode
+#if __GLASGOW_HASKELL__ >= 704
+-- We know for sure, that if GHC >= 7.4 implies Cabal >= 1.14
+myRawSystemExitCode = rawSystemExitCode
+#else
+-- Legacy branch:
+-- We implement our own 'rawSystemExitCode', this will even work if
+-- the user happens to have Cabal >= 1.14 installed with GHC 7.0 or
+-- 7.2
+myRawSystemExitCode verbosity path args = do
+ printRawCommandAndArgs verbosity path args
+ hFlush stdout
+ exitcode <- rawSystem path args
+ unless (exitcode == ExitSuccess) $ do
+ debug verbosity $ path ++ " returned " ++ show exitcode
+ return exitcode
+ where
+ printRawCommandAndArgs :: Verbosity -> FilePath -> [String] -> IO ()
+ printRawCommandAndArgs verbosity path args
+ | verbosity >= deafening = print (path, args)
+ | verbosity >= verbose = putStrLn $ unwords (path : args)
+ | otherwise = return ()
+#endif
diff --git a/benchmarks/PPoPP2019/src/entropy-0.4/System/Entropy.hs b/benchmarks/PPoPP2019/src/entropy-0.4/System/Entropy.hs
new file mode 100644
index 0000000..db809f0
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/entropy-0.4/System/Entropy.hs
@@ -0,0 +1,77 @@
+{-# LANGUAGE CPP, ForeignFunctionInterface, BangPatterns, ScopedTypeVariables #-}
+{-|
+ Maintainer: Thomas.DuBuisson@gmail.com
+ Stability: beta
+ Portability: portable
+
+ Obtain entropy from system sources or x86 RDRAND when available.
+
+ Currently supporting:
+
+ - Windows via CryptoAPI
+ - *nix systems via @\/dev\/urandom@
+ - Includes QNX
+ - Xen (only when RDRAND is available)
+-}
+
+module System.Entropy
+ ( getEntropy,
+ getHardwareEntropy,
+ CryptHandle,
+ openHandle,
+ hGetEntropy,
+ closeHandle
+ ) where
+#if defined(isWindows)
+import System.EntropyWindows
+#else
+#ifdef XEN
+import System.EntropyXen
+#else
+import System.EntropyNix
+#endif
+#endif
+
+import qualified Data.ByteString as B
+import Control.Exception (bracket)
+
+-- |Get a specific number of bytes of cryptographically
+-- secure random data using the *system-specific* sources.
+-- (As of 0.4. Verions <0.4 mixed system and hardware sources)
+--
+-- The returned random value is considered cryptographically secure but not true entropy.
+--
+-- On some platforms this requies a file handle which can lead to resource
+-- exhaustion in some situations.
+getEntropy :: Int -- ^ Number of bytes
+ -> IO B.ByteString
+getEntropy = bracket openHandle closeHandle . flip hGetEntropy
+
+-- |Get a specific number of bytes of cryptographically
+-- secure random data using a supported *hardware* random bit generator.
+--
+-- If there is no hardware random number generator then @Nothing@ is returned.
+-- If any call returns non-Nothing then it should never be @Nothing@ unless
+-- there has been a hardware failure.
+--
+-- If trust of the CPU allows it and no context switching is important,
+-- a bias to the hardware rng with system rng as fall back is trivial:
+--
+-- @
+-- let fastRandom nr = maybe (getEntropy nr) pure =<< getHardwareEntropy nr
+-- @
+--
+-- The old, @<0.4@, behavior is possible using @xor@ from 'Data.Bits':
+--
+-- @
+-- let oldRandom nr =
+-- do hwRnd <- maybe (replicate nr 0) BS.unpack <$> getHardwareEntropy nr
+-- sysRnd <- BS.unpack <$> getEntropy nr
+-- pure $ BS.pack $ zipWith xor sysRnd hwRnd
+-- @
+--
+-- A less maliable mixing can be accomplished by replacing `xor` with a
+-- composition of concat and cryptographic hash.
+getHardwareEntropy :: Int -- ^ Number of bytes
+ -> IO (Maybe B.ByteString)
+getHardwareEntropy = hardwareRandom
diff --git a/benchmarks/PPoPP2019/src/entropy-0.4/System/EntropyNix.hs b/benchmarks/PPoPP2019/src/entropy-0.4/System/EntropyNix.hs
new file mode 100644
index 0000000..01a7bc4
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/entropy-0.4/System/EntropyNix.hs
@@ -0,0 +1,98 @@
+{-# LANGUAGE CPP, ForeignFunctionInterface, BangPatterns, ScopedTypeVariables #-}
+{-|
+ Maintainer: Thomas.DuBuisson@gmail.com
+ Stability: beta
+ Portability: portable
+
+ Obtain entropy from system sources or x86 RDRAND when available.
+
+-}
+
+module System.EntropyNix
+ ( CryptHandle
+ , openHandle
+ , hGetEntropy
+ , closeHandle
+ , hardwareRandom
+ ) where
+
+import Control.Monad (liftM, when)
+import Data.ByteString as B
+import System.IO.Error (mkIOError, eofErrorType, ioeSetErrorString)
+import Data.Bits (xor)
+
+import Foreign (allocaBytes)
+import Foreign.Ptr
+import Foreign.C.Types
+import Data.ByteString.Internal as B
+
+#ifdef arch_i386
+-- See .cabal wrt GCC 4.8.2 asm compilation bug
+#undef HAVE_RDRAND
+#endif
+
+import System.Posix (openFd, closeFd, fdReadBuf, OpenMode(..), defaultFileFlags, Fd)
+
+source :: FilePath
+source = "/dev/urandom"
+
+-- |Handle for manual resource management
+data CryptHandle
+ = CH Fd
+
+-- | Get random values from the hardward RNG or return Nothing if no
+-- supported hardware RNG is available.
+--
+-- Supported hardware:
+-- * RDRAND
+-- * Patches welcome
+hardwareRandom :: Int -> IO (Maybe B.ByteString)
+#ifdef HAVE_RDRAND
+hardwareRandom n =
+ do b <- cpuHasRdRand
+ if b
+ then Just <$> B.create n (\ptr ->
+ do r <- c_get_rand_bytes (castPtr ptr) (fromIntegral n)
+ when (r /= 0) (fail "RDRand failed to gather entropy"))
+ else pure Nothing
+#else
+hardwareRandom _ = pure Nothing
+#endif
+
+-- |Open a `CryptHandle`
+openHandle :: IO CryptHandle
+openHandle = do CH `fmap` nonRDRandHandle
+ where
+ nonRDRandHandle :: IO Fd
+ nonRDRandHandle = openFd source ReadOnly Nothing defaultFileFlags
+
+-- |Close the `CryptHandle`
+closeHandle :: CryptHandle -> IO ()
+closeHandle (CH h) = closeFd h
+
+-- |Read random data from a `CryptHandle`
+hGetEntropy :: CryptHandle -> Int -> IO B.ByteString
+hGetEntropy (CH h) = fdReadBS h
+
+fdReadBS :: Fd -> Int -> IO B.ByteString
+fdReadBS fd n =
+ allocaBytes n $ \buf -> go buf n
+ where
+ go buf 0 = B.packCStringLen (castPtr buf, fromIntegral n)
+ go buf cnt | cnt <= n = do
+ rc <- fdReadBuf fd (plusPtr buf (n - cnt)) (fromIntegral cnt)
+ case rc of
+ 0 -> ioError (ioeSetErrorString (mkIOError eofErrorType "fdRead" Nothing Nothing) "EOF")
+ n' -> go buf (cnt - fromIntegral n')
+ go _ _ = error "Impossible! The count of bytes left to read is greater than the request or less than zero!"
+
+#ifdef HAVE_RDRAND
+foreign import ccall unsafe "cpu_has_rdrand"
+ c_cpu_has_rdrand :: IO CInt
+
+foreign import ccall unsafe "get_rand_bytes"
+ c_get_rand_bytes :: Ptr CUChar -> CSize -> IO CInt
+
+cpuHasRdRand :: IO Bool
+cpuHasRdRand = (/= 0) `fmap` c_cpu_has_rdrand
+#endif
diff --git a/benchmarks/PPoPP2019/src/entropy-0.4/System/EntropyWindows.hs b/benchmarks/PPoPP2019/src/entropy-0.4/System/EntropyWindows.hs
new file mode 100644
index 0000000..3659ffe
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/entropy-0.4/System/EntropyWindows.hs
@@ -0,0 +1,139 @@
+{-# LANGUAGE CPP, ForeignFunctionInterface, BangPatterns, ScopedTypeVariables #-}
+{-|
+ Maintainer: Thomas.DuBuisson@gmail.com
+ Stability: beta
+ Portability: portable
+
+ Obtain entropy from system sources.
+-}
+
+module System.EntropyWindows
+ ( CryptHandle
+ , openHandle
+ , hGetEntropy
+ , closeHandle
+ , hardwareRandom
+ ) where
+
+import Control.Monad (liftM, when)
+import System.IO.Error (mkIOError, eofErrorType, ioeSetErrorString)
+import Foreign (allocaBytes)
+import Data.ByteString as B
+import Data.ByteString.Internal as BI
+import Data.Int (Int32)
+import Data.Bits (xor)
+import Data.Word (Word32, Word8)
+import Foreign.C.String (CString, withCString)
+import Foreign.C.Types
+import Foreign.Ptr (Ptr, nullPtr, castPtr)
+import Foreign.Marshal.Alloc (alloca)
+import Foreign.Marshal.Utils (toBool)
+import Foreign.Storable (peek)
+
+{- C example for windows rng - taken from a blog, can't recall which one but thank you!
+ #include
+ #include
+ ...
+ //
+ // DISCLAIMER: Don't forget to check your error codes!!
+ // I am not checking as to make the example simple...
+ //
+ HCRYPTPROV hCryptCtx = NULL;
+ BYTE randomArray[128];
+
+ CryptAcquireContext(&hCryptCtx, NULL, MS_DEF_PROV, PROV_RSA_FULL, CRYPT_VERIFYCONTEXT);
+ CryptGenRandom(hCryptCtx, 128, randomArray);
+ CryptReleaseContext(hCryptCtx, 0);
+-}
+
+
+#ifdef arch_i386
+-- See .cabal wrt GCC 4.8.2 asm compilation bug
+#undef HAVE_RDRAND
+#endif
+
+#ifdef HAVE_RDRAND
+foreign import ccall unsafe "cpu_has_rdrand"
+ c_cpu_has_rdrand :: IO CInt
+
+foreign import ccall unsafe "get_rand_bytes"
+ c_get_rand_bytes :: Ptr CUChar -> CSize -> IO CInt
+
+cpuHasRdRand :: IO Bool
+cpuHasRdRand = (/= 0) `fmap` c_cpu_has_rdrand
+#endif
+
+data CryptHandle
+ = CH Word32
+
+
+-- | Get random values from the hardward RNG or return Nothing if no
+-- supported hardware RNG is available.
+--
+-- Supported hardware:
+-- * RDRAND
+-- * Patches welcome
+hardwareRandom :: Int -> IO (Maybe B.ByteString)
+#ifdef HAVE_RDRAND
+hardwareRandom n =
+ do b <- cpuHasRdRand
+ if b
+ then Just <$> BI.create n (\ptr ->
+ do r <- c_get_rand_bytes (castPtr ptr) (fromIntegral n)
+ when (r /= 0) (fail "RDRand failed to gather entropy"))
+ else pure Nothing
+#else
+hardwareRandom _ = pure Nothing
+#endif
+
+-- Define the constants we need from WinCrypt.h
+msDefProv :: String
+msDefProv = "Microsoft Base Cryptographic Provider v1.0"
+provRSAFull :: Word32
+provRSAFull = 1
+cryptVerifyContext :: Word32
+cryptVerifyContext = fromIntegral 0xF0000000
+
+-- Declare the required CryptoAPI imports
+foreign import stdcall unsafe "CryptAcquireContextA"
+ c_cryptAcquireCtx :: Ptr Word32 -> CString -> CString -> Word32 -> Word32 -> IO Int32
+foreign import stdcall unsafe "CryptGenRandom"
+ c_cryptGenRandom :: Word32 -> Word32 -> Ptr Word8 -> IO Int32
+foreign import stdcall unsafe "CryptReleaseContext"
+ c_cryptReleaseCtx :: Word32 -> Word32 -> IO Int32
+
+cryptAcquireCtx :: IO Word32
+cryptAcquireCtx =
+ alloca $ \handlePtr ->
+ withCString msDefProv $ \provName -> do
+ stat <- c_cryptAcquireCtx handlePtr nullPtr provName provRSAFull cryptVerifyContext
+ if (toBool stat)
+ then peek handlePtr
+ else fail "c_cryptAcquireCtx"
+
+cryptGenRandom :: Word32 -> Int -> IO B.ByteString
+cryptGenRandom h i =
+ BI.create i $ \c_buffer -> do
+ stat <- c_cryptGenRandom h (fromIntegral i) c_buffer
+ if (toBool stat)
+ then return ()
+ else fail "c_cryptGenRandom"
+
+cryptReleaseCtx :: Word32 -> IO ()
+cryptReleaseCtx h = do
+ stat <- c_cryptReleaseCtx h 0
+ if (toBool stat)
+ then return ()
+ else fail "c_cryptReleaseCtx"
+
+-- |Open a handle from which random data can be read
+openHandle :: IO CryptHandle
+openHandle = CH `fmap` cryptAcquireCtx
+
+-- |Close the `CryptHandle`
+closeHandle :: CryptHandle -> IO ()
+closeHandle (CH h) = cryptReleaseCtx h
+
+-- |Read from `CryptHandle`
+hGetEntropy :: CryptHandle -> Int -> IO B.ByteString
+hGetEntropy (CH h) n = cryptGenRandom h n
diff --git a/benchmarks/PPoPP2019/src/entropy-0.4/System/EntropyXen.hs b/benchmarks/PPoPP2019/src/entropy-0.4/System/EntropyXen.hs
new file mode 100644
index 0000000..c1799cc
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/entropy-0.4/System/EntropyXen.hs
@@ -0,0 +1,76 @@
+{-# LANGUAGE CPP, ForeignFunctionInterface, BangPatterns, ScopedTypeVariables #-}
+{-|
+ Maintainer: Thomas.DuBuisson@gmail.com
+ Stability: beta
+ Portability: portable
+
+ Obtain entropy from RDRAND when available.
+
+-}
+
+module System.EntropyXen
+ ( CryptHandle
+ , openHandle
+ , hGetEntropy
+ , closeHandle
+ , hardwardRNG
+ ) where
+
+import Control.Monad (liftM, when)
+import Data.ByteString as B
+import System.IO.Error (mkIOError, eofErrorType, ioeSetErrorString)
+
+import Foreign (allocaBytes)
+import Foreign.Ptr
+import Foreign.C.Types
+import Data.ByteString.Internal as B
+
+#ifdef arch_i386
+-- See .cabal wrt GCC 4.8.2 asm compilation bug
+#undef HAVE_RDRAND
+#endif
+
+#ifndef HAVE_RDRAND
+#error "The entropy package requires RDRAND support when using the halvm/Xen"
+#endif
+data CryptHandle = UseRdRand -- or die trying
+
+-- |Open a `CryptHandle`
+openHandle :: IO CryptHandle
+openHandle = do
+ b <- cpuHasRdRand
+ if b then return UseRdRand
+ else nonRDRandHandle
+ where
+ nonRDRandHandle :: IO CryptHandle
+ nonRDRandHandle = error "entropy: On halvm there is no entropy other than RDRAND."
+
+-- |Close the `CryptHandle`
+closeHandle :: CryptHandle -> IO ()
+closeHandle UseRdRand = return ()
+
+-- | Get random values from the hardward RNG or return Nothing if no
+-- supported hardware RNG is available.
+--
+-- Supported hardware:
+-- * RDRAND
+-- * Patches welcome
+hardwareRandom :: Int -> IO (Maybe B.ByteString)
+hardwareRandom sz = Just <$> hGetEntropy UseRdRand sz
+
+-- |Read random data from a `CryptHandle`, which uses RDRAND (when on Xen)
+hGetEntropy :: CryptHandle -> Int -> IO B.ByteString
+hGetEntropy UseRdRand = \n -> do
+ B.create n $ \ptr -> do
+ r <- c_get_rand_bytes (castPtr ptr) (fromIntegral n)
+ when (r /= 0)
+ (fail "RDRand failed to gather entropy")
+
+foreign import ccall unsafe "cpu_has_rdrand"
+ c_cpu_has_rdrand :: IO CInt
+
+foreign import ccall unsafe "get_rand_bytes"
+ c_get_rand_bytes :: Ptr CUChar -> CSize -> IO CInt
+
+cpuHasRdRand :: IO Bool
+cpuHasRdRand = (/= 0) `fmap` c_cpu_has_rdrand
diff --git a/benchmarks/PPoPP2019/src/entropy-0.4/cbits/rdrand.c b/benchmarks/PPoPP2019/src/entropy-0.4/cbits/rdrand.c
new file mode 100644
index 0000000..4fa8b1b
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/entropy-0.4/cbits/rdrand.c
@@ -0,0 +1,99 @@
+#ifdef HAVE_RDRAND
+
+#include
+#include
+
+int cpu_has_rdrand()
+{
+ uint32_t ax,bx,cx,dx,func=1;
+ __asm__ volatile ("cpuid":\
+ "=a" (ax), "=b" (bx), "=c" (cx), "=d" (dx) : "a" (func));
+ return (cx & 0x40000000);
+}
+
+#ifdef arch_x86_64
+// Returns 1 on success
+static inline int _rdrand64_step(uint64_t *therand)
+{
+ unsigned char err;
+ asm volatile("rdrand %0 ; setc %1"
+ : "=r" (*therand), "=qm" (err));
+ return (int) err;
+}
+
+// Returns 0 on success, non-zero on failure.
+int get_rand_bytes(uint8_t *therand, size_t len)
+{
+ int cnt;
+ int fail=0;
+ uint8_t *p = therand;
+ uint8_t *end = therand + len;
+ if((uint64_t)p%8 != 0) {
+ uint64_t tmp;
+ fail |= !_rdrand64_step(&tmp);
+ while((uint64_t)p%8 != 0 && p != end) {
+ *p = (uint8_t)(tmp & 0xFF);
+ tmp = tmp >> 8;
+ p++;
+ }
+ }
+ for(; p <= end - sizeof(uint64_t); p+=sizeof(uint64_t)) {
+ fail |= !_rdrand64_step((uint64_t *)p);
+ }
+ if(p != end) {
+ uint64_t tmp;
+ int cnt;
+ fail |= !_rdrand64_step(&tmp);
+ while(p != end) {
+ *p = (uint8_t)(tmp & 0xFF);
+ tmp = tmp >> 8;
+ p++;
+ }
+ }
+ return fail;
+}
+#endif /* x86-64 */
+
+#ifdef arch_i386
+// Returns 1 on success
+static inline int _rdrand32_step(uint32_t *therand)
+{
+ unsigned char err;
+ asm volatile("rdrand %0 ; setc %1"
+ : "=r" (*therand), "=qm" (err));
+ return (int) err;
+}
+
+int get_rand_bytes(uint8_t *therand, size_t len)
+{
+ int cnt;
+ int fail=0;
+ uint8_t *p = therand;
+ uint8_t *end = therand + len;
+ if((uint32_t)p % sizeof(uint32_t) != 0) {
+ uint32_t tmp;
+ fail |= !_rdrand32_step(&tmp);
+ while((uint32_t)p % sizeof(uint32_t) != 0 && p != end) {
+ *p = (uint8_t)(tmp & 0xFF);
+ tmp = tmp >> 8;
+ p++;
+ }
+ }
+ for(; p <= end - sizeof(uint32_t); p+=sizeof(uint32_t)) {
+ fail |= !_rdrand32_step((uint32_t *)p);
+ }
+ if(p != end) {
+ uint32_t tmp;
+ int cnt;
+ fail |= !_rdrand32_step(&tmp);
+ while(p != end) {
+ *p = (uint8_t)(tmp & 0xFF);
+ tmp = tmp >> 8;
+ p++;
+ }
+ }
+ return fail;
+}
+#endif /* i386 */
+
+#endif // RDRAND
diff --git a/benchmarks/PPoPP2019/src/entropy-0.4/cbits/rdrand.h b/benchmarks/PPoPP2019/src/entropy-0.4/cbits/rdrand.h
new file mode 100644
index 0000000..9f43a72
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/entropy-0.4/cbits/rdrand.h
@@ -0,0 +1,10 @@
+#ifndef rdrand_h
+#ifdef HAVE_RDRAND
+#include
+
+int cpu_has_rdrand()
+
+// Returns 0 on success, non-zero on failure.
+int get_rand_bytes(uint8_t *therand, size_t len)
+#endif // HAVE_RDRAND
+#endif // rdrand_h
diff --git a/benchmarks/PPoPP2019/src/entropy-0.4/entropy.cabal b/benchmarks/PPoPP2019/src/entropy-0.4/entropy.cabal
new file mode 100644
index 0000000..2dc104b
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/entropy-0.4/entropy.cabal
@@ -0,0 +1,79 @@
+name: entropy
+version: 0.4
+x-revision: 1
+description: A platform independent method to obtain cryptographically strong entropy
+ (RDRAND, urandom, CryptAPI, and patches welcome)
+ Users looking for cryptographically strong (number-theoretically
+ sound) PRNGs should see the 'DRBG' package too.
+synopsis: A platform independent entropy source
+license: BSD3
+license-file: LICENSE
+copyright: Thomas DuBuisson
+author: Thomas DuBuisson
+maintainer: Thomas DuBuisson
+category: Data, Cryptography
+homepage: https://github.com/TomMD/entropy
+bug-reports: https://github.com/TomMD/entropy/issues
+stability: stable
+-- build-type: Simple
+-- ^^ Used for HaLVM
+build-type: Custom
+-- ^^ Test for RDRAND support using 'ghc'
+cabal-version: >=1.10
+tested-with: GHC == 8.2.2
+-- data-files:
+extra-source-files: ./cbits/rdrand.c, ./cbits/rdrand.h, README.md
+
+-- Notice to compile with HaLVM the above 'build-type' must be changed
+-- to 'Simple' instead of 'Custom'. The current build system naively
+-- runs GHC to determine if the compiler supports RDRAND before proceeding.
+flag halvm
+ description: Build for the HaLVM
+ default: False
+
+
+custom-setup
+ setup-depends: Cabal >= 1.10 && < 2.2
+ , base < 5
+ , filepath < 1.5
+ , directory < 1.4
+ , process < 1.7
+
+library
+ ghc-options: -O2
+ exposed-modules: System.Entropy
+ if os(windows)
+ other-modules: System.EntropyWindows
+ else {
+ if os(halvm)
+ other-modules: System.EntropyXen
+ else
+ other-modules: System.EntropyNix
+ }
+ other-extensions: CPP, ForeignFunctionInterface, BangPatterns,
+ ScopedTypeVariables
+ build-depends: base >= 4.8 && < 5, bytestring
+ default-language: Haskell2010
+ if(os(halvm))
+ cpp-options: -DXEN -DHAVE_RDRAND
+ cc-options: -DXEN -DHAVE_RDRAND
+ if arch(x86_64)
+ cpp-options: -Darch_x86_64
+ cc-options: -Darch_x86_64 -O2
+ -- gcc 4.8.2 on i386 fails to compile rdrand.c when using -fPIC!
+ c-sources: cbits/rdrand.c
+ include-dirs: cbits
+ if arch(i386)
+ cpp-options: -Darch_i386
+ cc-options: -Darch_i386 -O2
+ if os(windows)
+ cpp-options: -DisWindows
+ cc-options: -DisWindows
+ extra-libraries: advapi32
+ else
+ if !os(halvm)
+ Build-Depends: unix
+
+source-repository head
+ type: git
+ location: https://github.com/TomMD/entropy
diff --git a/benchmarks/PPoPP2019/src/focus-0.1.5.2/LICENSE b/benchmarks/PPoPP2019/src/focus-0.1.5.2/LICENSE
new file mode 100644
index 0000000..fe32f2b
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/focus-0.1.5.2/LICENSE
@@ -0,0 +1,22 @@
+Copyright (c) 2014, Nikita Volkov
+
+Permission is hereby granted, free of charge, to any person
+obtaining a copy of this software and associated documentation
+files (the "Software"), to deal in the Software without
+restriction, including without limitation the rights to use,
+copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the
+Software is furnished to do so, subject to the following
+conditions:
+
+The above copyright notice and this permission notice shall be
+included in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
+OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
+OTHER DEALINGS IN THE SOFTWARE.
diff --git a/benchmarks/PPoPP2019/src/focus-0.1.5.2/Setup.hs b/benchmarks/PPoPP2019/src/focus-0.1.5.2/Setup.hs
new file mode 100644
index 0000000..9a994af
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/focus-0.1.5.2/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/benchmarks/PPoPP2019/src/focus-0.1.5.2/focus.cabal b/benchmarks/PPoPP2019/src/focus-0.1.5.2/focus.cabal
new file mode 100644
index 0000000..bcf3309
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/focus-0.1.5.2/focus.cabal
@@ -0,0 +1,65 @@
+name:
+ focus
+version:
+ 0.1.5.2
+synopsis:
+ A general abstraction for manipulating elements of container data structures
+description:
+ An API for construction of free-form strategies of access and manipulation of
+ elements of arbitrary data structures.
+ It allows to implement efficient composite patterns, e.g.,
+ a simultaneous update and lookup of an element,
+ and even more complex things.
+ .
+ Strategies are meant to be interpreted by the host data structure libraries.
+ Thus they allow to implement all access and modification patterns of
+ a data structure with just a single function,
+ which interprets strategies.
+ .
+ This library provides pure and monadic interfaces,
+ so it supports both immutable and mutable data structures.
+category:
+ Containers, Data
+homepage:
+ https://github.com/nikita-volkov/focus
+bug-reports:
+ https://github.com/nikita-volkov/focus/issues
+author:
+ Nikita Volkov
+maintainer:
+ Nikita Volkov
+copyright:
+ (c) 2014, Nikita Volkov
+license:
+ MIT
+license-file:
+ LICENSE
+build-type:
+ Simple
+cabal-version:
+ >=1.10
+tested-with:
+ GHC==7.6.3,
+ GHC==7.8.4,
+ GHC==7.10.3,
+ GHC==8.0.1
+ GHC==8.2.1
+
+source-repository head
+ type:
+ git
+ location:
+ git://github.com/nikita-volkov/focus.git
+
+
+library
+ hs-source-dirs:
+ library
+ exposed-modules:
+ Focus
+ build-depends:
+ base >= 4.6 && < 5
+ default-extensions:
+ DeriveFunctor, NoImplicitPrelude, TupleSections
+ default-language:
+ Haskell2010
diff --git a/benchmarks/PPoPP2019/src/focus-0.1.5.2/library/Focus.hs b/benchmarks/PPoPP2019/src/focus-0.1.5.2/library/Focus.hs
new file mode 100644
index 0000000..468a3ce
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/focus-0.1.5.2/library/Focus.hs
@@ -0,0 +1,115 @@
+module Focus where
+
+import Prelude hiding (adjust, update, alter, insert, delete, lookup)
+import Control.Monad
+
+
+-- |
+-- A general modification function for some match.
+-- By processing a 'Maybe' value it produces some value to emit and
+-- a 'Decision' to perform on the match.
+--
+-- The interpretation of this function is up to the context APIs.
+type Strategy a r = Maybe a -> (r, Decision a)
+
+-- |
+-- A monadic version of 'Strategy'.
+type StrategyM m a r = Maybe a -> m (r, Decision a)
+
+-- |
+-- What to do with the focused value.
+--
+-- The interpretation of the commands is up to the context APIs.
+data Decision a =
+ Keep |
+ Remove |
+ Replace a
+ deriving (Functor)
+
+
+-- * Constructors for common pure patterns
+-------------------------
+
+-- |
+-- Reproduces the behaviour of
+-- @Data.Map.@.
+{-# INLINE adjust #-}
+adjust :: (a -> a) -> Strategy a ()
+adjust f = maybe ((), Keep) (\a -> ((), Replace (f a)))
+
+-- |
+-- Reproduces the behaviour of
+-- @Data.Map.@.
+{-# INLINE update #-}
+update :: (a -> Maybe a) -> Strategy a ()
+update f = maybe ((), Keep) (\a -> ((), maybe Remove Replace (f a)))
+
+-- |
+-- Reproduces the behaviour of
+-- @Data.Map.@.
+{-# INLINE alter #-}
+alter :: (Maybe a -> Maybe a) -> Strategy a ()
+alter f = ((),) . maybe Remove Replace . f
+
+-- |
+-- Reproduces the behaviour of
+-- @Data.Map.@.
+{-# INLINE insert #-}
+insert :: a -> Strategy a ()
+insert a = const ((), Replace a)
+
+-- |
+-- Reproduces the behaviour of
+-- @Data.Map.@.
+{-# INLINE delete #-}
+delete :: Strategy a ()
+delete = const ((), Remove)
+
+-- |
+-- Reproduces the behaviour of
+-- @Data.Map.@.
+{-# INLINE lookup #-}
+lookup :: Strategy a (Maybe a)
+lookup r = (r, Keep)
+
+
+-- * Constructors for monadic patterns
+-------------------------
+
+-- |
+-- A monadic version of 'adjust'.
+{-# INLINE adjustM #-}
+adjustM :: (Monad m) => (a -> m a) -> StrategyM m a ()
+adjustM f = maybe (return ((), Keep)) (liftM (((),) . Replace) . f)
+
+-- |
+-- A monadic version of 'update'.
+{-# INLINE updateM #-}
+updateM :: (Monad m) => (a -> m (Maybe a)) -> StrategyM m a ()
+updateM f = maybe (return ((), Keep)) (liftM (((),) . maybe Remove Replace) . f)
+
+-- |
+-- A monadic version of 'alter'.
+{-# INLINE alterM #-}
+alterM :: (Monad m) => (Maybe a -> m (Maybe a)) -> StrategyM m a ()
+alterM f = liftM (((),) . maybe Remove Replace) . f
+
+-- |
+-- A monadic version of 'insert'.
+{-# INLINE insertM #-}
+insertM :: (Monad m) => a -> StrategyM m a ()
+insertM = fmap return . insert
+
+-- |
+-- A monadic version of 'delete'.
+{-# INLINE deleteM #-}
+deleteM :: (Monad m) => StrategyM m a ()
+deleteM = fmap return delete
+
+-- |
+-- A monadic version of 'lookup'.
+{-# INLINE lookupM #-}
+lookupM :: (Monad m) => StrategyM m a (Maybe a)
+lookupM = fmap return lookup
+
+
diff --git a/benchmarks/PPoPP2019/src/hashable-1.2.6.1/CHANGES.md b/benchmarks/PPoPP2019/src/hashable-1.2.6.1/CHANGES.md
new file mode 100644
index 0000000..b938239
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/hashable-1.2.6.1/CHANGES.md
@@ -0,0 +1,225 @@
+## Version 1.2.6.1
+
+ * Use typeRepFingerprint from Type.Reflection.Unsafe
+
+ * Bump minimum version of base to 4.4.
+
+## Version 1.2.6.0
+
+ * Add support for type-indexed `Typeable`.
+
+ * Rework the `Generic` hashable for sums.
+
+## Version 1.2.5.0
+
+ * Add `Hashable1` and `Hashable2`
+
+ * Add instances for: `Eq1`, `Ord1`, `Show1`, `Ptr`, `FunPtr`, `IntPtr`, `WordPtr`
+
+ * Add `Hashed` type for caching the `hash` function result.
+
+## Version 1.2.4.0
+
+ * Add instances for: Unique, Version, Fixed, NonEmpty, Min, Max, Arg,
+ First, Last, WrappedMonoid, Option
+
+ * Support GHC 8.0
+
+## Version 1.2.3.3
+
+ * Support integer-simple.
+
+## Version 1.2.3.2
+
+ * Add support for GHC 7.10 typeRepFingerprint
+
+## Version 1.2.3.1
+
+ * Added support for random 1.1.*.
+
+## Version 1.2.3.0
+
+ * Silence integer literal overflow warning
+
+ * Add support for GHC 7.10 `integer-gmp2` & `Natural`
+
+ * Add instance for Data.Void
+
+ * Make the SSE .cabal flags manual
+
+ * Add an upper bound on bytestring
+
+## Version 1.2.2.0
+
+ * Add instances for `Data.ByteString.Short`
+
+ * Use a 32-bit default salt on 32-bit archs.
+
+## Version 1.2.1.0
+
+ * Revert instances to their 1.1 implementations to regain the
+ performance we had then.
+
+ * Remove use of random salt altogether. Without using SipHash the
+ benefit is unclear (i.e. collision attacks still work) and the
+ complexity is no longer worth it.
+
+ * Documentation improvements.
+
+## Version 1.2.0.10
+
+ * Fix for GHC 7.0.
+
+## Version 1.2.0.9
+
+ * Stop using SipHash. The current implementation still has segfault
+ causing bugs that we won't be able to fix soon.
+
+ * Stop using Wang hash. It degrades performance of fixed-size integer
+ hashing too much.
+
+## Version 1.2.0.8
+
+ * Fix linking issue when SSE was disabled.
+
+ * Hash small signed Integers correctly.
+
+## Version 1.2.0.7
+
+ * Add flags to control usage of SSE.
+
+## Version 1.2.0.6
+
+ * Fix another segfault caused by SSE2 code.
+
+## Version 1.2.0.5
+
+ * More portability fixes.
+
+ * Force stack alignment to 16 bytes everywhere. Fixes a segfault.
+
+ * Fix bug where code relied on rewrite rules firing for correctness.
+
+## Version1.2.0.4
+
+ * Update docs to match code.
+
+ * Work around bug in GHCi runtime linker, which never call static
+ initializers.
+
+## Version1.2.0.3
+
+ * Make building of SSE 4.1 code conditional, as it doesn't work on all
+ platforms.
+
+ * Use a fixed salt, but allow random salting. Random salting by
+ default broke people's code.
+
+## Version1.2.0.2
+
+ * Work around ghci linker bug on Windows.
+
+## Version1.2.0.1
+
+ * Fix performance bug in SSE implementation of SipHash.
+
+ * Fix segfault due to incorrect stack alignment on Windows.
+
+## Version1.2.0.0
+
+ * Switch string hashing from FNV-1 to SipHash, in an effort to
+ prevent collision attacks.
+
+ * Switch fixed-size integer hashing to Wang hash.
+
+ * The default salt now switched on every program run, in an effort to
+ prevent collision attacks.
+
+ * Move hash method out of Hashable type class.
+
+ * Add support for generic instance deriving.
+
+ * Add instance for Ordering.
+
+## Version1.1.2.5
+
+ * Bug fix for bytestring < 0.10.0.
+
+## Version1.1.2.4
+
+ * Switch string hashing from Bernstein to FNV-1
+
+ * Faster instance for Integer.
+
+ * Update dependency on base, ghc-prim
+
+ * Now works with GHC 7.6.
+
+## Version1.1.2.3
+
+ * Add instance for TypeRep.
+
+ * Update dependency on test-framework.
+
+## Version1.1.2.2
+
+ * Bug fix for GHC 7.4
+
+## Version1.1.2.1
+
+ * Update dependency on test-framework.
+
+ * Improve documentation of combine.
+
+## Version1.1.2.0
+
+ * Add instances for Interger, Ratio, Float, Double, and StableName.
+
+ * Fix hash collision issues for lists and tuples when using a
+ user-specified salt.
+
+## Version1.1.1.0
+
+ * Improved instances for tuples and lists.
+
+ * Add instances for StableName, Float, Double, Integer, and Ratio.
+
+## Version1.1.1.0
+
+ * Add hashWithSalt, which allows the user to create different hash
+ values for the same input by providing different seeds. This is
+ useful for application like Cuckoo hashing which need a family of
+ hash functions.
+
+ * Fix a bug in the Hashable instance for Int64/Word64 on 32-bit
+ platforms.
+
+ * Improved resilience to leading zero in the input being hashed.
+
+## Version1.1.0.0
+
+ * Add instance for: strict and lazy Texts, ThreadId
+
+ * Add hashPtrWithSalt and hashByteArrayWithSalt.
+
+ * Faster ByteArray# hashing.
+
+ * Fix a signedness bug that affected ByteString.
+
+ * Fix ByteString hashing to work correctly on both 32 and 64-bit
+ platforms.
+
+## Version1.0.1.1
+
+ * Fix bug in Hashable instance for lazy ByteStrings where differences
+ in the internal structure of the ByteString could cause different
+ hash values for ByteStrings that are equal according to ==.
+
+## Version1.0.1.0
+
+ * Add two helpers for creating Hashable instances: hashPtr and
+ hashByteArray.
+
+## Version1.0.0
+
+ * Separate Hashable class to its own package from hashmap 1.0.0.3.
diff --git a/benchmarks/PPoPP2019/src/hashable-1.2.6.1/Data/Hashable.hs b/benchmarks/PPoPP2019/src/hashable-1.2.6.1/Data/Hashable.hs
new file mode 100644
index 0000000..6c393d1
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/hashable-1.2.6.1/Data/Hashable.hs
@@ -0,0 +1,213 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702
+{-# LANGUAGE Trustworthy #-}
+#endif
+
+------------------------------------------------------------------------
+-- |
+-- Module : Data.Hashable
+-- Copyright : (c) Milan Straka 2010
+-- (c) Johan Tibell 2011
+-- (c) Bryan O'Sullivan 2011, 2012
+-- License : BSD-style
+-- Maintainer : johan.tibell@gmail.com
+-- Stability : provisional
+-- Portability : portable
+--
+-- This module defines a class, 'Hashable', for types that can be
+-- converted to a hash value. This class exists for the benefit of
+-- hashing-based data structures. The module provides instances for
+-- most standard types. Efficient instances for other types can be
+-- generated automatically and effortlessly using the generics support
+-- in GHC 7.2 and above.
+--
+-- The easiest way to get started is to use the 'hash' function. Here
+-- is an example session with @ghci@.
+--
+-- > ghci> import Data.Hashable
+-- > ghci> hash "foo"
+-- > 60853164
+
+module Data.Hashable
+ (
+ -- * Hashing and security
+ -- $security
+
+ -- * Computing hash values
+ Hashable(..)
+
+ -- * Creating new instances
+ -- | There are two ways to create new instances: by deriving
+ -- instances automatically using GHC's generic programming
+ -- support or by writing instances manually.
+
+ -- ** Generic instances
+ -- $generics
+
+ -- *** Understanding a compiler error
+ -- $generic_err
+
+ -- ** Writing instances by hand
+ -- $blocks
+
+ -- *** Hashing contructors with multiple fields
+ -- $multiple-fields
+
+ -- *** Hashing types with multiple constructors
+ -- $multiple-ctors
+
+ , hashUsing
+ , hashPtr
+ , hashPtrWithSalt
+#if defined(__GLASGOW_HASKELL__)
+ , hashByteArray
+ , hashByteArrayWithSalt
+#endif
+ -- * Caching hashes
+ , Hashed
+ , hashed
+ , unhashed
+ , mapHashed
+ , traverseHashed
+ ) where
+
+import Data.Hashable.Class
+
+#ifdef GENERICS
+import Data.Hashable.Generic ()
+#endif
+
+-- $security
+-- #security#
+--
+-- Applications that use hash-based data structures to store input
+-- from untrusted users can be susceptible to \"hash DoS\", a class of
+-- denial-of-service attack that uses deliberately chosen colliding
+-- inputs to force an application into unexpectedly behaving with
+-- quadratic time complexity.
+--
+-- At this time, the string hashing functions used in this library are
+-- susceptible to such attacks and users are recommended to either use
+-- a 'Data.Map' to store keys derived from untrusted input or to use a
+-- hash function (e.g. SipHash) that's resistant to such attacks. A
+-- future version of this library might ship with such hash functions.
+
+-- $generics
+--
+-- Beginning with GHC 7.2, the recommended way to make instances of
+-- 'Hashable' for most types is to use the compiler's support for
+-- automatically generating default instances.
+--
+-- > {-# LANGUAGE DeriveGeneric #-}
+-- >
+-- > import GHC.Generics (Generic)
+-- > import Data.Hashable
+-- >
+-- > data Foo a = Foo a String
+-- > deriving (Eq, Generic)
+-- >
+-- > instance Hashable a => Hashable (Foo a)
+-- >
+-- > data Colour = Red | Green | Blue
+-- > deriving Generic
+-- >
+-- > instance Hashable Colour
+--
+-- If you omit a body for the instance declaration, GHC will generate
+-- a default instance that correctly and efficiently hashes every
+-- constructor and parameter.
+
+-- $generic_err
+--
+-- Suppose you intend to use the generic machinery to automatically
+-- generate a 'Hashable' instance.
+--
+-- > data Oops = Oops
+-- > -- forgot to add "deriving Generic" here!
+-- >
+-- > instance Hashable Oops
+--
+-- And imagine that, as in the example above, you forget to add a
+-- \"@deriving 'Generic'@\" clause to your data type. At compile time,
+-- you will get an error message from GHC that begins roughly as
+-- follows:
+--
+-- > No instance for (GHashable (Rep Oops))
+--
+-- This error can be confusing, as 'GHashable' is not exported (it is
+-- an internal typeclass used by this library's generics machinery).
+-- The correct fix is simply to add the missing \"@deriving
+-- 'Generic'@\".
+
+-- $blocks
+--
+-- To maintain high quality hashes, new 'Hashable' instances should be
+-- built using existing 'Hashable' instances, combinators, and hash
+-- functions.
+--
+-- The functions below can be used when creating new instances of
+-- 'Hashable'. For example, for many string-like types the
+-- 'hashWithSalt' method can be defined in terms of either
+-- 'hashPtrWithSalt' or 'hashByteArrayWithSalt'. Here's how you could
+-- implement an instance for the 'B.ByteString' data type, from the
+-- @bytestring@ package:
+--
+-- > import qualified Data.ByteString as B
+-- > import qualified Data.ByteString.Internal as B
+-- > import qualified Data.ByteString.Unsafe as B
+-- > import Data.Hashable
+-- > import Foreign.Ptr (castPtr)
+-- >
+-- > instance Hashable B.ByteString where
+-- > hashWithSalt salt bs = B.inlinePerformIO $
+-- > B.unsafeUseAsCStringLen bs $ \(p, len) ->
+-- > hashPtrWithSalt p (fromIntegral len) salt
+
+-- $multiple-fields
+--
+-- Hash constructors with multiple fields by chaining 'hashWithSalt':
+--
+-- > data Date = Date Int Int Int
+-- >
+-- > instance Hashable Date where
+-- > hashWithSalt s (Date yr mo dy) =
+-- > s `hashWithSalt`
+-- > yr `hashWithSalt`
+-- > mo `hashWithSalt` dy
+--
+-- If you need to chain hashes together, use 'hashWithSalt' and follow
+-- this recipe:
+--
+-- > combineTwo h1 h2 = h1 `hashWithSalt` h2
+
+-- $multiple-ctors
+--
+-- For a type with several value constructors, there are a few
+-- possible approaches to writing a 'Hashable' instance.
+--
+-- If the type is an instance of 'Enum', the easiest path is to
+-- convert it to an 'Int', and use the existing 'Hashable' instance
+-- for 'Int'.
+--
+-- > data Color = Red | Green | Blue
+-- > deriving Enum
+-- >
+-- > instance Hashable Color where
+-- > hashWithSalt = hashUsing fromEnum
+--
+-- If the type's constructors accept parameters, it is important to
+-- distinguish the constructors. To distinguish the constructors, add
+-- a different integer to the hash computation of each constructor:
+--
+-- > data Time = Days Int
+-- > | Weeks Int
+-- > | Months Int
+-- >
+-- > instance Hashable Time where
+-- > hashWithSalt s (Days n) = s `hashWithSalt`
+-- > (0::Int) `hashWithSalt` n
+-- > hashWithSalt s (Weeks n) = s `hashWithSalt`
+-- > (1::Int) `hashWithSalt` n
+-- > hashWithSalt s (Months n) = s `hashWithSalt`
+-- > (2::Int) `hashWithSalt` n
diff --git a/benchmarks/PPoPP2019/src/hashable-1.2.6.1/Data/Hashable/Class.hs b/benchmarks/PPoPP2019/src/hashable-1.2.6.1/Data/Hashable/Class.hs
new file mode 100644
index 0000000..d10472b
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/hashable-1.2.6.1/Data/Hashable/Class.hs
@@ -0,0 +1,874 @@
+{-# LANGUAGE BangPatterns, CPP, ForeignFunctionInterface, MagicHash,
+ ScopedTypeVariables, UnliftedFFITypes #-}
+
+#if __GLASGOW_HASKELL__ < 710
+{-# LANGUAGE DeriveDataTypeable #-}
+#endif
+
+#if __GLASGOW_HASKELL__ >= 801
+{-# LANGUAGE PolyKinds #-} -- For TypeRep instances
+#endif
+
+#ifdef GENERICS
+{-# LANGUAGE DefaultSignatures, FlexibleContexts, GADTs,
+ MultiParamTypeClasses, EmptyDataDecls #-}
+#endif
+
+------------------------------------------------------------------------
+-- |
+-- Module : Data.Hashable.Class
+-- Copyright : (c) Milan Straka 2010
+-- (c) Johan Tibell 2011
+-- (c) Bryan O'Sullivan 2011, 2012
+-- License : BSD-style
+-- Maintainer : johan.tibell@gmail.com
+-- Stability : provisional
+-- Portability : portable
+--
+-- This module defines a class, 'Hashable', for types that can be
+-- converted to a hash value. This class exists for the benefit of
+-- hashing-based data structures. The module provides instances for
+-- most standard types.
+
+module Data.Hashable.Class
+ (
+ -- * Computing hash values
+ Hashable(..)
+ , Hashable1(..)
+ , Hashable2(..)
+#ifdef GENERICS
+ -- ** Support for generics
+ , GHashable(..)
+ , HashArgs(..)
+ , Zero
+ , One
+#endif
+
+ -- * Creating new instances
+ , hashUsing
+ , hashPtr
+ , hashPtrWithSalt
+ , hashByteArray
+ , hashByteArrayWithSalt
+ , defaultHashWithSalt
+ -- * Higher Rank Functions
+ , hashWithSalt1
+ , hashWithSalt2
+ , defaultLiftHashWithSalt
+ -- * Caching hashes
+ , Hashed
+ , hashed
+ , unhashed
+ , mapHashed
+ , traverseHashed
+ ) where
+
+import Control.Applicative (Const(..))
+import Control.Exception (assert)
+import Data.Bits (shiftL, shiftR, xor)
+import Data.Int (Int8, Int16, Int32, Int64)
+import Data.List (foldl')
+import Data.Ratio (Ratio, denominator, numerator)
+import Data.Version (Version(..))
+import Data.Word (Word8, Word16, Word32, Word64)
+import Foreign.C (CString)
+import Foreign.Marshal.Utils (with)
+import Foreign.Ptr (Ptr, FunPtr, IntPtr, WordPtr, castPtr, castFunPtrToPtr, ptrToIntPtr)
+import Foreign.Storable (alignment, peek, sizeOf)
+import GHC.Base (ByteArray#)
+import GHC.Conc (ThreadId(..))
+import GHC.Prim (ThreadId#)
+import System.IO.Unsafe (unsafeDupablePerformIO)
+import System.Mem.StableName
+import Data.Unique (Unique, hashUnique)
+
+-- As we use qualified F.Foldable, we don't get warnings with newer base
+import qualified Data.Foldable as F
+
+#if MIN_VERSION_base(4,7,0)
+import Data.Proxy (Proxy)
+#endif
+
+#if MIN_VERSION_base(4,7,0)
+import Data.Fixed (Fixed(..))
+#endif
+
+#if MIN_VERSION_base(4,8,0)
+import Data.Functor.Identity (Identity(..))
+#endif
+
+#ifdef GENERICS
+import GHC.Generics
+#endif
+
+#if __GLASGOW_HASKELL__ >= 801
+import Type.Reflection (Typeable, TypeRep, SomeTypeRep(..))
+import Type.Reflection.Unsafe (typeRepFingerprint)
+import GHC.Fingerprint.Type(Fingerprint(..))
+#elif __GLASGOW_HASKELL__ >= 710
+import Data.Typeable (typeRepFingerprint, Typeable, TypeRep)
+import GHC.Fingerprint.Type(Fingerprint(..))
+#elif __GLASGOW_HASKELL__ >= 702
+import Data.Typeable.Internal (Typeable, TypeRep (..))
+import GHC.Fingerprint.Type(Fingerprint(..))
+#elif __GLASGOW_HASKELL__ >= 606
+import Data.Typeable (typeRepKey, Typeable, TypeRep)
+#endif
+
+#if __GLASGOW_HASKELL__ >= 703
+import Foreign.C (CLong(..))
+import Foreign.C.Types (CInt(..))
+#else
+import Foreign.C (CLong)
+import Foreign.C.Types (CInt)
+#endif
+
+#if !(MIN_VERSION_base(4,8,0))
+import Data.Word (Word)
+#endif
+
+#if MIN_VERSION_base(4,7,0)
+import Data.Bits (finiteBitSize)
+#else
+import Data.Bits (bitSize)
+#endif
+
+#if !(MIN_VERSION_bytestring(0,10,0))
+import qualified Data.ByteString.Lazy.Internal as BL -- foldlChunks
+#endif
+
+#if MIN_VERSION_bytestring(0,10,4)
+import qualified Data.ByteString.Short.Internal as BSI
+#endif
+
+#ifdef VERSION_integer_gmp
+
+# if MIN_VERSION_integer_gmp(1,0,0)
+# define MIN_VERSION_integer_gmp_1_0_0
+# endif
+
+import GHC.Exts (Int(..))
+import GHC.Integer.GMP.Internals (Integer(..))
+# if defined(MIN_VERSION_integer_gmp_1_0_0)
+import GHC.Exts (sizeofByteArray#)
+import GHC.Integer.GMP.Internals (BigNat(BN#))
+# endif
+#endif
+
+#if MIN_VERSION_base(4,8,0)
+import Data.Void (Void, absurd)
+import GHC.Natural (Natural(..))
+import GHC.Exts (Word(..))
+#endif
+
+#if MIN_VERSION_base(4,9,0)
+import qualified Data.List.NonEmpty as NE
+import Data.Semigroup
+import Data.Functor.Classes (Eq1(..),Ord1(..),Show1(..),showsUnaryWith)
+
+import Data.Functor.Compose (Compose(..))
+import qualified Data.Functor.Product as FP
+import qualified Data.Functor.Sum as FS
+#endif
+
+import Data.String (IsString(..))
+
+#include "MachDeps.h"
+
+infixl 0 `hashWithSalt`
+
+------------------------------------------------------------------------
+-- * Computing hash values
+
+-- | A default salt used in the implementation of 'hash'.
+defaultSalt :: Int
+#if WORD_SIZE_IN_BITS == 64
+defaultSalt = -2578643520546668380 -- 0xdc36d1615b7400a4
+#else
+defaultSalt = 0x087fc72c
+#endif
+{-# INLINE defaultSalt #-}
+
+-- | The class of types that can be converted to a hash value.
+--
+-- Minimal implementation: 'hashWithSalt'.
+class Hashable a where
+ -- | Return a hash value for the argument, using the given salt.
+ --
+ -- The general contract of 'hashWithSalt' is:
+ --
+ -- * If two values are equal according to the '==' method, then
+ -- applying the 'hashWithSalt' method on each of the two values
+ -- /must/ produce the same integer result if the same salt is
+ -- used in each case.
+ --
+ -- * It is /not/ required that if two values are unequal
+ -- according to the '==' method, then applying the
+ -- 'hashWithSalt' method on each of the two values must produce
+ -- distinct integer results. However, the programmer should be
+ -- aware that producing distinct integer results for unequal
+ -- values may improve the performance of hashing-based data
+ -- structures.
+ --
+ -- * This method can be used to compute different hash values for
+ -- the same input by providing a different salt in each
+ -- application of the method. This implies that any instance
+ -- that defines 'hashWithSalt' /must/ make use of the salt in
+ -- its implementation.
+ hashWithSalt :: Int -> a -> Int
+
+ -- | Like 'hashWithSalt', but no salt is used. The default
+ -- implementation uses 'hashWithSalt' with some default salt.
+ -- Instances might want to implement this method to provide a more
+ -- efficient implementation than the default implementation.
+ hash :: a -> Int
+ hash = hashWithSalt defaultSalt
+
+#ifdef GENERICS
+ default hashWithSalt :: (Generic a, GHashable Zero (Rep a)) => Int -> a -> Int
+ hashWithSalt salt = ghashWithSalt HashArgs0 salt . from
+
+data Zero
+data One
+
+data HashArgs arity a where
+ HashArgs0 :: HashArgs Zero a
+ HashArgs1 :: (Int -> a -> Int) -> HashArgs One a
+
+-- | The class of types that can be generically hashed.
+class GHashable arity f where
+ ghashWithSalt :: HashArgs arity a -> Int -> f a -> Int
+
+#endif
+
+class Hashable1 t where
+ -- | Lift a hashing function through the type constructor.
+ liftHashWithSalt :: (Int -> a -> Int) -> Int -> t a -> Int
+#ifdef GENERICS
+ default liftHashWithSalt :: (Generic1 t, GHashable One (Rep1 t)) => (Int -> a -> Int) -> Int -> t a -> Int
+ liftHashWithSalt h salt = ghashWithSalt (HashArgs1 h) salt . from1
+#endif
+
+class Hashable2 t where
+ -- | Lift a hashing function through the binary type constructor.
+ liftHashWithSalt2 :: (Int -> a -> Int) -> (Int -> b -> Int) -> Int -> t a b -> Int
+
+-- | Lift the 'hashWithSalt' function through the type constructor.
+--
+-- > hashWithSalt1 = liftHashWithSalt hashWithSalt
+hashWithSalt1 :: (Hashable1 f, Hashable a) => Int -> f a -> Int
+hashWithSalt1 = liftHashWithSalt hashWithSalt
+
+-- | Lift the 'hashWithSalt' function through the type constructor.
+--
+-- > hashWithSalt2 = liftHashWithSalt2 hashWithSalt hashWithSalt
+hashWithSalt2 :: (Hashable2 f, Hashable a, Hashable b) => Int -> f a b -> Int
+hashWithSalt2 = liftHashWithSalt2 hashWithSalt hashWithSalt
+
+-- | Lift the 'hashWithSalt' function halfway through the type constructor.
+-- This function makes a suitable default implementation of 'liftHashWithSalt',
+-- given that the type constructor @t@ in question can unify with @f a@.
+defaultLiftHashWithSalt :: (Hashable2 f, Hashable a) => (Int -> b -> Int) -> Int -> f a b -> Int
+defaultLiftHashWithSalt h = liftHashWithSalt2 hashWithSalt h
+
+-- | Since we support a generic implementation of 'hashWithSalt' we
+-- cannot also provide a default implementation for that method for
+-- the non-generic instance use case. Instead we provide
+-- 'defaultHashWith'.
+defaultHashWithSalt :: Hashable a => Int -> a -> Int
+defaultHashWithSalt salt x = salt `combine` hash x
+
+-- | Transform a value into a 'Hashable' value, then hash the
+-- transformed value using the given salt.
+--
+-- This is a useful shorthand in cases where a type can easily be
+-- mapped to another type that is already an instance of 'Hashable'.
+-- Example:
+--
+-- > data Foo = Foo | Bar
+-- > deriving (Enum)
+-- >
+-- > instance Hashable Foo where
+-- > hashWithSalt = hashUsing fromEnum
+hashUsing :: (Hashable b) =>
+ (a -> b) -- ^ Transformation function.
+ -> Int -- ^ Salt.
+ -> a -- ^ Value to transform.
+ -> Int
+hashUsing f salt x = hashWithSalt salt (f x)
+{-# INLINE hashUsing #-}
+
+instance Hashable Int where
+ hash = id
+ hashWithSalt = defaultHashWithSalt
+
+instance Hashable Int8 where
+ hash = fromIntegral
+ hashWithSalt = defaultHashWithSalt
+
+instance Hashable Int16 where
+ hash = fromIntegral
+ hashWithSalt = defaultHashWithSalt
+
+instance Hashable Int32 where
+ hash = fromIntegral
+ hashWithSalt = defaultHashWithSalt
+
+instance Hashable Int64 where
+ hash n
+#if MIN_VERSION_base(4,7,0)
+ | finiteBitSize (undefined :: Int) == 64 = fromIntegral n
+#else
+ | bitSize (undefined :: Int) == 64 = fromIntegral n
+#endif
+ | otherwise = fromIntegral (fromIntegral n `xor`
+ (fromIntegral n `shiftR` 32 :: Word64))
+ hashWithSalt = defaultHashWithSalt
+
+instance Hashable Word where
+ hash = fromIntegral
+ hashWithSalt = defaultHashWithSalt
+
+instance Hashable Word8 where
+ hash = fromIntegral
+ hashWithSalt = defaultHashWithSalt
+
+instance Hashable Word16 where
+ hash = fromIntegral
+ hashWithSalt = defaultHashWithSalt
+
+instance Hashable Word32 where
+ hash = fromIntegral
+ hashWithSalt = defaultHashWithSalt
+
+instance Hashable Word64 where
+ hash n
+#if MIN_VERSION_base(4,7,0)
+ | finiteBitSize (undefined :: Int) == 64 = fromIntegral n
+#else
+ | bitSize (undefined :: Int) == 64 = fromIntegral n
+#endif
+ | otherwise = fromIntegral (n `xor` (n `shiftR` 32))
+ hashWithSalt = defaultHashWithSalt
+
+instance Hashable () where
+ hash = fromEnum
+ hashWithSalt = defaultHashWithSalt
+
+instance Hashable Bool where
+ hash = fromEnum
+ hashWithSalt = defaultHashWithSalt
+
+instance Hashable Ordering where
+ hash = fromEnum
+ hashWithSalt = defaultHashWithSalt
+
+instance Hashable Char where
+ hash = fromEnum
+ hashWithSalt = defaultHashWithSalt
+
+#if defined(MIN_VERSION_integer_gmp_1_0_0)
+instance Hashable BigNat where
+ hashWithSalt salt (BN# ba) = hashByteArrayWithSalt ba 0 numBytes salt
+ `hashWithSalt` size
+ where
+ size = numBytes `quot` SIZEOF_HSWORD
+ numBytes = I# (sizeofByteArray# ba)
+#endif
+
+#if MIN_VERSION_base(4,8,0)
+instance Hashable Natural where
+# if defined(MIN_VERSION_integer_gmp_1_0_0)
+ hash (NatS# n) = hash (W# n)
+ hash (NatJ# bn) = hash bn
+
+ hashWithSalt salt (NatS# n) = hashWithSalt salt (W# n)
+ hashWithSalt salt (NatJ# bn) = hashWithSalt salt bn
+# else
+ hash (Natural n) = hash n
+
+ hashWithSalt salt (Natural n) = hashWithSalt salt n
+# endif
+#endif
+
+instance Hashable Integer where
+#if defined(VERSION_integer_gmp)
+# if defined(MIN_VERSION_integer_gmp_1_0_0)
+ hash (S# n) = (I# n)
+ hash (Jp# bn) = hash bn
+ hash (Jn# bn) = negate (hash bn)
+
+ hashWithSalt salt (S# n) = hashWithSalt salt (I# n)
+ hashWithSalt salt (Jp# bn) = hashWithSalt salt bn
+ hashWithSalt salt (Jn# bn) = negate (hashWithSalt salt bn)
+# else
+ hash (S# int) = I# int
+ hash n@(J# size# byteArray)
+ | n >= minInt && n <= maxInt = fromInteger n :: Int
+ | otherwise = let size = I# size#
+ numBytes = SIZEOF_HSWORD * abs size
+ in hashByteArrayWithSalt byteArray 0 numBytes defaultSalt
+ `hashWithSalt` size
+ where minInt = fromIntegral (minBound :: Int)
+ maxInt = fromIntegral (maxBound :: Int)
+
+ hashWithSalt salt (S# n) = hashWithSalt salt (I# n)
+ hashWithSalt salt n@(J# size# byteArray)
+ | n >= minInt && n <= maxInt = hashWithSalt salt (fromInteger n :: Int)
+ | otherwise = let size = I# size#
+ numBytes = SIZEOF_HSWORD * abs size
+ in hashByteArrayWithSalt byteArray 0 numBytes salt
+ `hashWithSalt` size
+ where minInt = fromIntegral (minBound :: Int)
+ maxInt = fromIntegral (maxBound :: Int)
+# endif
+#else
+ hashWithSalt salt = foldl' hashWithSalt salt . go
+ where
+ go n | inBounds n = [fromIntegral n :: Int]
+ | otherwise = fromIntegral n : go (n `shiftR` WORD_SIZE_IN_BITS)
+ maxInt = fromIntegral (maxBound :: Int)
+ inBounds x = x >= fromIntegral (minBound :: Int) && x <= maxInt
+#endif
+
+#if MIN_VERSION_base(4,9,0)
+-- Starting with base-4.9, numerator/denominator don't need 'Integral' anymore
+instance Hashable a => Hashable (Ratio a) where
+#else
+instance (Integral a, Hashable a) => Hashable (Ratio a) where
+#endif
+ {-# SPECIALIZE instance Hashable (Ratio Integer) #-}
+ hash a = hash (numerator a) `hashWithSalt` denominator a
+ hashWithSalt s a = s `hashWithSalt` numerator a `hashWithSalt` denominator a
+
+instance Hashable Float where
+ hash x
+ | isIEEE x =
+ assert (sizeOf x >= sizeOf (0::Word32) &&
+ alignment x >= alignment (0::Word32)) $
+ hash ((unsafeDupablePerformIO $ with x $ peek . castPtr) :: Word32)
+ | otherwise = hash (show x)
+ hashWithSalt = defaultHashWithSalt
+
+instance Hashable Double where
+ hash x
+ | isIEEE x =
+ assert (sizeOf x >= sizeOf (0::Word64) &&
+ alignment x >= alignment (0::Word64)) $
+ hash ((unsafeDupablePerformIO $ with x $ peek . castPtr) :: Word64)
+ | otherwise = hash (show x)
+ hashWithSalt = defaultHashWithSalt
+
+-- | A value with bit pattern (01)* (or 5* in hexa), for any size of Int.
+-- It is used as data constructor distinguisher. GHC computes its value during
+-- compilation.
+distinguisher :: Int
+distinguisher = fromIntegral $ (maxBound :: Word) `quot` 3
+{-# INLINE distinguisher #-}
+
+instance Hashable a => Hashable (Maybe a) where
+ hash Nothing = 0
+ hash (Just a) = distinguisher `hashWithSalt` a
+ hashWithSalt = hashWithSalt1
+
+instance Hashable1 Maybe where
+ liftHashWithSalt _ s Nothing = s `combine` 0
+ liftHashWithSalt h s (Just a) = s `combine` distinguisher `h` a
+
+instance (Hashable a, Hashable b) => Hashable (Either a b) where
+ hash (Left a) = 0 `hashWithSalt` a
+ hash (Right b) = distinguisher `hashWithSalt` b
+ hashWithSalt = hashWithSalt1
+
+instance Hashable a => Hashable1 (Either a) where
+ liftHashWithSalt = defaultLiftHashWithSalt
+
+instance Hashable2 Either where
+ liftHashWithSalt2 h _ s (Left a) = s `combine` 0 `h` a
+ liftHashWithSalt2 _ h s (Right b) = s `combine` distinguisher `h` b
+
+instance (Hashable a1, Hashable a2) => Hashable (a1, a2) where
+ hash (a1, a2) = hash a1 `hashWithSalt` a2
+ hashWithSalt = hashWithSalt1
+
+instance Hashable a1 => Hashable1 ((,) a1) where
+ liftHashWithSalt = defaultLiftHashWithSalt
+
+instance Hashable2 (,) where
+ liftHashWithSalt2 h1 h2 s (a1, a2) = s `h1` a1 `h2` a2
+
+instance (Hashable a1, Hashable a2, Hashable a3) => Hashable (a1, a2, a3) where
+ hash (a1, a2, a3) = hash a1 `hashWithSalt` a2 `hashWithSalt` a3
+ hashWithSalt = hashWithSalt1
+
+instance (Hashable a1, Hashable a2) => Hashable1 ((,,) a1 a2) where
+ liftHashWithSalt = defaultLiftHashWithSalt
+
+instance Hashable a1 => Hashable2 ((,,) a1) where
+ liftHashWithSalt2 h1 h2 s (a1, a2, a3) =
+ (s `hashWithSalt` a1) `h1` a2 `h2` a3
+
+instance (Hashable a1, Hashable a2, Hashable a3, Hashable a4) =>
+ Hashable (a1, a2, a3, a4) where
+ hash (a1, a2, a3, a4) = hash a1 `hashWithSalt` a2
+ `hashWithSalt` a3 `hashWithSalt` a4
+ hashWithSalt = hashWithSalt1
+
+instance (Hashable a1, Hashable a2, Hashable a3) => Hashable1 ((,,,) a1 a2 a3) where
+ liftHashWithSalt = defaultLiftHashWithSalt
+
+instance (Hashable a1, Hashable a2) => Hashable2 ((,,,) a1 a2) where
+ liftHashWithSalt2 h1 h2 s (a1, a2, a3, a4) =
+ (s `hashWithSalt` a1 `hashWithSalt` a2) `h1` a3 `h2` a4
+
+instance (Hashable a1, Hashable a2, Hashable a3, Hashable a4, Hashable a5)
+ => Hashable (a1, a2, a3, a4, a5) where
+ hash (a1, a2, a3, a4, a5) =
+ hash a1 `hashWithSalt` a2 `hashWithSalt` a3
+ `hashWithSalt` a4 `hashWithSalt` a5
+ hashWithSalt = hashWithSalt1
+
+instance (Hashable a1, Hashable a2, Hashable a3,
+ Hashable a4) => Hashable1 ((,,,,) a1 a2 a3 a4) where
+ liftHashWithSalt = defaultLiftHashWithSalt
+
+instance (Hashable a1, Hashable a2, Hashable a3)
+ => Hashable2 ((,,,,) a1 a2 a3) where
+ liftHashWithSalt2 h1 h2 s (a1, a2, a3, a4, a5) =
+ (s `hashWithSalt` a1 `hashWithSalt` a2
+ `hashWithSalt` a3) `h1` a4 `h2` a5
+
+
+instance (Hashable a1, Hashable a2, Hashable a3, Hashable a4, Hashable a5,
+ Hashable a6) => Hashable (a1, a2, a3, a4, a5, a6) where
+ hash (a1, a2, a3, a4, a5, a6) =
+ hash a1 `hashWithSalt` a2 `hashWithSalt` a3
+ `hashWithSalt` a4 `hashWithSalt` a5 `hashWithSalt` a6
+ hashWithSalt = hashWithSalt1
+
+instance (Hashable a1, Hashable a2, Hashable a3, Hashable a4,
+ Hashable a5) => Hashable1 ((,,,,,) a1 a2 a3 a4 a5) where
+ liftHashWithSalt = defaultLiftHashWithSalt
+
+instance (Hashable a1, Hashable a2, Hashable a3,
+ Hashable a4) => Hashable2 ((,,,,,) a1 a2 a3 a4) where
+ liftHashWithSalt2 h1 h2 s (a1, a2, a3, a4, a5, a6) =
+ (s `hashWithSalt` a1 `hashWithSalt` a2 `hashWithSalt` a3
+ `hashWithSalt` a4) `h1` a5 `h2` a6
+
+
+instance (Hashable a1, Hashable a2, Hashable a3, Hashable a4, Hashable a5,
+ Hashable a6, Hashable a7) =>
+ Hashable (a1, a2, a3, a4, a5, a6, a7) where
+ hash (a1, a2, a3, a4, a5, a6, a7) =
+ hash a1 `hashWithSalt` a2 `hashWithSalt` a3
+ `hashWithSalt` a4 `hashWithSalt` a5 `hashWithSalt` a6 `hashWithSalt` a7
+ hashWithSalt s (a1, a2, a3, a4, a5, a6, a7) =
+ s `hashWithSalt` a1 `hashWithSalt` a2 `hashWithSalt` a3
+ `hashWithSalt` a4 `hashWithSalt` a5 `hashWithSalt` a6 `hashWithSalt` a7
+
+instance (Hashable a1, Hashable a2, Hashable a3, Hashable a4, Hashable a5, Hashable a6) => Hashable1 ((,,,,,,) a1 a2 a3 a4 a5 a6) where
+ liftHashWithSalt = defaultLiftHashWithSalt
+
+instance (Hashable a1, Hashable a2, Hashable a3, Hashable a4,
+ Hashable a5) => Hashable2 ((,,,,,,) a1 a2 a3 a4 a5) where
+ liftHashWithSalt2 h1 h2 s (a1, a2, a3, a4, a5, a6, a7) =
+ (s `hashWithSalt` a1 `hashWithSalt` a2 `hashWithSalt` a3
+ `hashWithSalt` a4 `hashWithSalt` a5) `h1` a6 `h2` a7
+
+instance Hashable (StableName a) where
+ hash = hashStableName
+ hashWithSalt = defaultHashWithSalt
+
+-- Auxillary type for Hashable [a] definition
+data SPInt = SP !Int !Int
+
+instance Hashable a => Hashable [a] where
+ {-# SPECIALIZE instance Hashable [Char] #-}
+ hashWithSalt = hashWithSalt1
+
+instance Hashable1 [] where
+ liftHashWithSalt h salt arr = finalise (foldl' step (SP salt 0) arr)
+ where
+ finalise (SP s l) = hashWithSalt s l
+ step (SP s l) x = SP (h s x) (l + 1)
+
+-- | Compute the hash of a ThreadId.
+hashThreadId :: ThreadId -> Int
+hashThreadId (ThreadId t) = hash (fromIntegral (getThreadId t) :: Int)
+
+foreign import ccall unsafe "rts_getThreadId" getThreadId
+ :: ThreadId# -> CInt
+
+instance Hashable ThreadId where
+ hash = hashThreadId
+ hashWithSalt = defaultHashWithSalt
+
+instance Hashable (Ptr a) where
+ hashWithSalt salt p = hashWithSalt salt $ ptrToIntPtr p
+
+instance Hashable (FunPtr a) where
+ hashWithSalt salt p = hashWithSalt salt $ castFunPtrToPtr p
+
+instance Hashable IntPtr where
+ hash n = fromIntegral n
+ hashWithSalt = defaultHashWithSalt
+
+instance Hashable WordPtr where
+ hash n = fromIntegral n
+ hashWithSalt = defaultHashWithSalt
+
+#if __GLASGOW_HASKELL__ < 801
+-- | Compute the hash of a TypeRep, in various GHC versions we can do this quickly.
+hashTypeRep :: TypeRep -> Int
+{-# INLINE hashTypeRep #-}
+#if __GLASGOW_HASKELL__ >= 710
+-- Fingerprint is just the MD5, so taking any Int from it is fine
+hashTypeRep tr = let Fingerprint x _ = typeRepFingerprint tr in fromIntegral x
+#elif __GLASGOW_HASKELL__ >= 702
+-- Fingerprint is just the MD5, so taking any Int from it is fine
+hashTypeRep (TypeRep (Fingerprint x _) _ _) = fromIntegral x
+#elif __GLASGOW_HASKELL__ >= 606
+hashTypeRep = unsafeDupablePerformIO . typeRepKey
+#else
+hashTypeRep = hash . show
+#endif
+
+instance Hashable TypeRep where
+ hash = hashTypeRep
+ hashWithSalt = defaultHashWithSalt
+ {-# INLINE hash #-}
+
+#else
+
+hashTypeRep :: Type.Reflection.TypeRep a -> Int
+hashTypeRep tr =
+ let Fingerprint x _ = typeRepFingerprint tr in fromIntegral x
+
+instance Hashable Type.Reflection.SomeTypeRep where
+ hash (Type.Reflection.SomeTypeRep r) = hashTypeRep r
+ hashWithSalt = defaultHashWithSalt
+ {-# INLINE hash #-}
+
+instance Hashable (Type.Reflection.TypeRep a) where
+ hash = hashTypeRep
+ hashWithSalt = defaultHashWithSalt
+ {-# INLINE hash #-}
+#endif
+
+#if MIN_VERSION_base(4,8,0)
+instance Hashable Void where
+ hashWithSalt _ = absurd
+#endif
+
+-- | Compute a hash value for the content of this pointer.
+hashPtr :: Ptr a -- ^ pointer to the data to hash
+ -> Int -- ^ length, in bytes
+ -> IO Int -- ^ hash value
+hashPtr p len = hashPtrWithSalt p len defaultSalt
+
+-- | Compute a hash value for the content of this pointer, using an
+-- initial salt.
+--
+-- This function can for example be used to hash non-contiguous
+-- segments of memory as if they were one contiguous segment, by using
+-- the output of one hash as the salt for the next.
+hashPtrWithSalt :: Ptr a -- ^ pointer to the data to hash
+ -> Int -- ^ length, in bytes
+ -> Int -- ^ salt
+ -> IO Int -- ^ hash value
+hashPtrWithSalt p len salt =
+ fromIntegral `fmap` c_hashCString (castPtr p) (fromIntegral len)
+ (fromIntegral salt)
+
+foreign import ccall unsafe "hashable_fnv_hash" c_hashCString
+ :: CString -> CLong -> CLong -> IO CLong
+
+-- | Compute a hash value for the content of this 'ByteArray#',
+-- beginning at the specified offset, using specified number of bytes.
+hashByteArray :: ByteArray# -- ^ data to hash
+ -> Int -- ^ offset, in bytes
+ -> Int -- ^ length, in bytes
+ -> Int -- ^ hash value
+hashByteArray ba0 off len = hashByteArrayWithSalt ba0 off len defaultSalt
+{-# INLINE hashByteArray #-}
+
+-- | Compute a hash value for the content of this 'ByteArray#', using
+-- an initial salt.
+--
+-- This function can for example be used to hash non-contiguous
+-- segments of memory as if they were one contiguous segment, by using
+-- the output of one hash as the salt for the next.
+hashByteArrayWithSalt
+ :: ByteArray# -- ^ data to hash
+ -> Int -- ^ offset, in bytes
+ -> Int -- ^ length, in bytes
+ -> Int -- ^ salt
+ -> Int -- ^ hash value
+hashByteArrayWithSalt ba !off !len !h =
+ fromIntegral $ c_hashByteArray ba (fromIntegral off) (fromIntegral len)
+ (fromIntegral h)
+
+foreign import ccall unsafe "hashable_fnv_hash_offset" c_hashByteArray
+ :: ByteArray# -> CLong -> CLong -> CLong -> CLong
+
+-- | Combine two given hash values. 'combine' has zero as a left
+-- identity.
+combine :: Int -> Int -> Int
+combine h1 h2 = (h1 * 16777619) `xor` h2
+
+instance Hashable Unique where
+ hash = hashUnique
+ hashWithSalt = defaultHashWithSalt
+
+instance Hashable Version where
+ hashWithSalt salt (Version branch tags) =
+ salt `hashWithSalt` branch `hashWithSalt` tags
+
+#if MIN_VERSION_base(4,7,0)
+-- Using hashWithSalt1 would cause needless constraint
+instance Hashable (Fixed a) where
+ hashWithSalt salt (MkFixed i) = hashWithSalt salt i
+instance Hashable1 Fixed where
+ liftHashWithSalt _ salt (MkFixed i) = hashWithSalt salt i
+#endif
+
+#if MIN_VERSION_base(4,8,0)
+instance Hashable a => Hashable (Identity a) where
+ hashWithSalt = hashWithSalt1
+instance Hashable1 Identity where
+ liftHashWithSalt h salt (Identity x) = h salt x
+#endif
+
+-- Using hashWithSalt1 would cause needless constraint
+instance Hashable a => Hashable (Const a b) where
+ hashWithSalt salt (Const x) = hashWithSalt salt x
+
+instance Hashable a => Hashable1 (Const a) where
+ liftHashWithSalt = defaultLiftHashWithSalt
+
+instance Hashable2 Const where
+ liftHashWithSalt2 f _ salt (Const x) = f salt x
+
+#if MIN_VERSION_base(4,7,0)
+instance Hashable (Proxy a) where
+ hash _ = 0
+ hashWithSalt s _ = s
+
+instance Hashable1 Proxy where
+ liftHashWithSalt _ s _ = s
+#endif
+
+-- instances formerly provided by 'semigroups' package
+#if MIN_VERSION_base(4,9,0)
+instance Hashable a => Hashable (NE.NonEmpty a) where
+ hashWithSalt p (a NE.:| as) = p `hashWithSalt` a `hashWithSalt` as
+
+instance Hashable a => Hashable (Min a) where
+ hashWithSalt p (Min a) = hashWithSalt p a
+
+instance Hashable a => Hashable (Max a) where
+ hashWithSalt p (Max a) = hashWithSalt p a
+
+instance (Hashable a, Hashable b) => Hashable (Arg a b) where
+ hashWithSalt p (Arg a b) = hashWithSalt p a `hashWithSalt` b
+
+instance Hashable a => Hashable (First a) where
+ hashWithSalt p (First a) = hashWithSalt p a
+
+instance Hashable a => Hashable (Last a) where
+ hashWithSalt p (Last a) = hashWithSalt p a
+
+instance Hashable a => Hashable (WrappedMonoid a) where
+ hashWithSalt p (WrapMonoid a) = hashWithSalt p a
+
+instance Hashable a => Hashable (Option a) where
+ hashWithSalt p (Option a) = hashWithSalt p a
+#endif
+
+-- instances for @Data.Functor.{Product,Sum,Compose}@, present
+-- in base-4.9 and onward.
+#if MIN_VERSION_base(4,9,0)
+-- | In general, @hash (Compose x) ≠hash x@. However, @hashWithSalt@ satisfies
+-- its variant of this equivalence.
+instance (Hashable1 f, Hashable1 g, Hashable a) => Hashable (Compose f g a) where
+ hashWithSalt = hashWithSalt1
+
+instance (Hashable1 f, Hashable1 g) => Hashable1 (Compose f g) where
+ liftHashWithSalt h s = liftHashWithSalt (liftHashWithSalt h) s . getCompose
+
+instance (Hashable1 f, Hashable1 g) => Hashable1 (FP.Product f g) where
+ liftHashWithSalt h s (FP.Pair a b) = liftHashWithSalt h (liftHashWithSalt h s a) b
+
+instance (Hashable1 f, Hashable1 g, Hashable a) => Hashable (FP.Product f g a) where
+ hashWithSalt = hashWithSalt1
+
+instance (Hashable1 f, Hashable1 g) => Hashable1 (FS.Sum f g) where
+ liftHashWithSalt h s (FS.InL a) = liftHashWithSalt h (s `combine` 0) a
+ liftHashWithSalt h s (FS.InR a) = liftHashWithSalt h (s `combine` distinguisher) a
+
+instance (Hashable1 f, Hashable1 g, Hashable a) => Hashable (FS.Sum f g a) where
+ hashWithSalt = hashWithSalt1
+#endif
+
+-- | A hashable value along with the result of the 'hash' function.
+data Hashed a = Hashed a {-# UNPACK #-} !Int
+ deriving (Typeable)
+
+-- | Wrap a hashable value, caching the 'hash' function result.
+hashed :: Hashable a => a -> Hashed a
+hashed a = Hashed a (hash a)
+
+-- | Unwrap hashed value.
+unhashed :: Hashed a -> a
+unhashed (Hashed a _) = a
+
+-- | Uses precomputed hash to detect inequality faster
+instance Eq a => Eq (Hashed a) where
+ Hashed a ha == Hashed b hb = ha == hb && a == b
+
+instance Ord a => Ord (Hashed a) where
+ Hashed a _ `compare` Hashed b _ = a `compare` b
+
+instance Show a => Show (Hashed a) where
+ showsPrec d (Hashed a _) = showParen (d > 10) $
+ showString "hashed" . showChar ' ' . showsPrec 11 a
+
+instance Hashable (Hashed a) where
+ hashWithSalt = defaultHashWithSalt
+ hash (Hashed _ h) = h
+
+-- This instance is a little unsettling. It is unusal for
+-- 'liftHashWithSalt' to ignore its first argument when a
+-- value is actually available for it to work on.
+instance Hashable1 Hashed where
+ liftHashWithSalt _ s (Hashed _ h) = defaultHashWithSalt s h
+
+instance (IsString a, Hashable a) => IsString (Hashed a) where
+ fromString s = let r = fromString s in Hashed r (hash r)
+
+instance F.Foldable Hashed where
+ foldr f acc (Hashed a _) = f a acc
+
+-- | 'Hashed' cannot be 'Functor'
+mapHashed :: Hashable b => (a -> b) -> Hashed a -> Hashed b
+mapHashed f (Hashed a _) = hashed (f a)
+
+-- | 'Hashed' cannot be 'Traversable'
+traverseHashed :: (Hashable b, Functor f) => (a -> f b) -> Hashed a -> f (Hashed b)
+traverseHashed f (Hashed a _) = fmap hashed (f a)
+
+-- instances for @Data.Functor.Classes@ higher rank typeclasses
+-- in base-4.9 and onward.
+#if MIN_VERSION_base(4,9,0)
+instance Eq1 Hashed where
+ liftEq f (Hashed a ha) (Hashed b hb) = ha == hb && f a b
+
+instance Ord1 Hashed where
+ liftCompare f (Hashed a _) (Hashed b _) = f a b
+
+instance Show1 Hashed where
+ liftShowsPrec sp _ d (Hashed a _) = showsUnaryWith sp "hashed" d a
+#endif
+
+
diff --git a/benchmarks/PPoPP2019/src/hashable-1.2.6.1/Data/Hashable/Generic.hs b/benchmarks/PPoPP2019/src/hashable-1.2.6.1/Data/Hashable/Generic.hs
new file mode 100644
index 0000000..3e8fe65
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/hashable-1.2.6.1/Data/Hashable/Generic.hs
@@ -0,0 +1,125 @@
+{-# LANGUAGE BangPatterns, FlexibleInstances, KindSignatures,
+ ScopedTypeVariables, TypeOperators,
+ MultiParamTypeClasses, GADTs, FlexibleContexts #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+------------------------------------------------------------------------
+-- |
+-- Module : Data.Hashable.Generic
+-- Copyright : (c) Bryan O'Sullivan 2012
+-- License : BSD-style
+-- Maintainer : bos@serpentine.com
+-- Stability : provisional
+-- Portability : GHC >= 7.2
+--
+-- Hashable support for GHC generics.
+
+module Data.Hashable.Generic
+ (
+ ) where
+
+import Data.Bits (shiftR)
+import Data.Hashable.Class
+import GHC.Generics
+
+-- Type without constructors
+instance GHashable arity V1 where
+ ghashWithSalt _ salt _ = hashWithSalt salt ()
+
+-- Constructor without arguments
+instance GHashable arity U1 where
+ ghashWithSalt _ salt U1 = hashWithSalt salt ()
+
+instance (GHashable arity a, GHashable arity b) => GHashable arity (a :*: b) where
+ ghashWithSalt toHash salt (x :*: y) =
+ (ghashWithSalt toHash (ghashWithSalt toHash salt x) y)
+
+-- Metadata (constructor name, etc)
+instance GHashable arity a => GHashable arity (M1 i c a) where
+ ghashWithSalt targs salt = ghashWithSalt targs salt . unM1
+
+-- Constants, additional parameters, and rank-1 recursion
+instance Hashable a => GHashable arity (K1 i a) where
+ ghashWithSalt _ = hashUsing unK1
+
+instance GHashable One Par1 where
+ ghashWithSalt (HashArgs1 h) salt = h salt . unPar1
+
+instance Hashable1 f => GHashable One (Rec1 f) where
+ ghashWithSalt (HashArgs1 h) salt = liftHashWithSalt h salt . unRec1
+
+instance (Hashable1 f, GHashable One g) => GHashable One (f :.: g) where
+ ghashWithSalt targs salt = liftHashWithSalt (ghashWithSalt targs) salt . unComp1
+
+class SumSize f => GSum arity f where
+ hashSum :: HashArgs arity a -> Int -> Int -> f a -> Int
+ -- hashSum args salt index value = ...
+
+-- [Note: Hashing a sum type]
+--
+-- The tree structure is used in GHC.Generics to represent the sum (and
+-- product) part of the generic represention of the type, e.g.:
+--
+-- (C0 ... :+: C1 ...) :+: (C2 ... :+: (C3 ... :+: C4 ...))
+--
+-- The value constructed with C2 constructor is represented as (R1 (L1 ...)).
+-- Yet, if we think that this tree is a flat (heterogenous) list:
+--
+-- [C0 ..., C1 ..., C2 ..., C3 ..., C4... ]
+--
+-- then the value constructed with C2 is a (dependent) pair (2, ...), and
+-- hashing it is simple:
+--
+-- salt `hashWithSalt` (2 :: Int) `hashWithSalt` ...
+--
+-- This is what we do below. When drilling down the tree, we count how many
+-- leafs are to the left (`index` variable). At the leaf case C1, we'll have an
+-- actual index into the sum.
+--
+-- This works well for balanced data. However for recursive types like:
+--
+-- data Nat = Z | S Nat
+--
+-- the `hashWithSalt salt (S (S (S Z)))` is
+--
+-- salt `hashWithSalt` (1 :: Int) -- first S
+-- `hashWithSalt` (1 :: Int) -- second S
+-- `hashWithSalt` (1 :: Int) -- third S
+-- `hashWithSalt` (0 :: Int) -- Z
+-- `hashWithSalt` () -- U1
+--
+-- For that type the manual implementation:
+--
+-- instance Hashable Nat where
+-- hashWithSalt salt n = hashWithSalt salt (natToInteger n)
+--
+-- would be better performing CPU and hash-quality wise (assuming that
+-- Integer's Hashable is of high quality).
+--
+instance (GSum arity a, GSum arity b) => GHashable arity (a :+: b) where
+ ghashWithSalt toHash salt = hashSum toHash salt 0
+
+instance (GSum arity a, GSum arity b) => GSum arity (a :+: b) where
+ hashSum toHash !salt !index s = case s of
+ L1 x -> hashSum toHash salt index x
+ R1 x -> hashSum toHash salt (index + sizeL) x
+ where
+ sizeL = unTagged (sumSize :: Tagged a)
+ {-# INLINE hashSum #-}
+
+instance GHashable arity a => GSum arity (C1 c a) where
+ hashSum toHash !salt !index (M1 x) = ghashWithSalt toHash (hashWithSalt salt index) x
+ {-# INLINE hashSum #-}
+
+class SumSize f where
+ sumSize :: Tagged f
+
+newtype Tagged (s :: * -> *) = Tagged {unTagged :: Int}
+
+instance (SumSize a, SumSize b) => SumSize (a :+: b) where
+ sumSize = Tagged $ unTagged (sumSize :: Tagged a) +
+ unTagged (sumSize :: Tagged b)
+
+instance SumSize (C1 c a) where
+ sumSize = Tagged 1
+
diff --git a/benchmarks/PPoPP2019/src/hashable-1.2.6.1/Data/Hashable/Lifted.hs b/benchmarks/PPoPP2019/src/hashable-1.2.6.1/Data/Hashable/Lifted.hs
new file mode 100644
index 0000000..e477518
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/hashable-1.2.6.1/Data/Hashable/Lifted.hs
@@ -0,0 +1,96 @@
+------------------------------------------------------------------------
+-- |
+-- Module : Data.Hashable.Class
+-- Copyright : (c) Milan Straka 2010
+-- (c) Johan Tibell 2011
+-- (c) Bryan O'Sullivan 2011, 2012
+-- License : BSD-style
+-- Maintainer : johan.tibell@gmail.com
+-- Stability : provisional
+-- Portability : portable
+--
+-- Lifting of the 'Hashable' class to unary and binary type constructors.
+-- These classes are needed to express the constraints on arguments of
+-- types that are parameterized by type constructors. Fixed-point data
+-- types and monad transformers are such types.
+
+module Data.Hashable.Lifted
+ ( -- * Type Classes
+ Hashable1(..)
+ , Hashable2(..)
+ -- * Auxiliary Functions
+ , hashWithSalt1
+ , hashWithSalt2
+ , defaultLiftHashWithSalt
+ -- * Motivation
+ -- $motivation
+ ) where
+
+import Data.Hashable.Class
+
+-- $motivation
+--
+-- This type classes provided in this module are used to express constraints
+-- on type constructors in a Haskell98-compatible fashion. As an example, consider
+-- the following two types (Note that these instances are not actually provided
+-- because @hashable@ does not have @transformers@ or @free@ as a dependency):
+--
+-- > newtype WriterT w m a = WriterT { runWriterT :: m (a, w) }
+-- > data Free f a = Pure a | Free (f (Free f a))
+--
+-- The 'Hashable1' instances for @WriterT@ and @Free@ could be written as:
+--
+-- > instance (Hashable w, Hashable1 m) => Hashable1 (WriterT w m) where
+-- > liftHashWithSalt h s (WriterT m) =
+-- > liftHashWithSalt (liftHashWithSalt2 h hashWithSalt) s m
+-- > instance Hashable1 f => Hashable1 (Free f) where
+-- > liftHashWithSalt h = go where
+-- > go s x = case x of
+-- > Pure a -> h s a
+-- > Free p -> liftHashWithSalt go s p
+--
+-- The 'Hashable' instances for these types can be trivially recovered with
+-- 'hashWithSalt1':
+--
+-- > instance (Hashable w, Hashable1 m, Hashable a) => Hashable (WriterT w m a) where
+-- > hashWithSalt = hashWithSalt1
+-- > instance (Hashable1 f, Hashable a) => Hashable (Free f a) where
+-- > hashWithSalt = hashWithSalt1
+
+--
+-- $discussion
+--
+-- Regardless of whether 'hashWithSalt1' is used to provide an implementation
+-- of 'hashWithSalt', they should produce the same hash when called with
+-- the same arguments. This is the only law that 'Hashable1' and 'Hashable2'
+-- are expected to follow.
+--
+-- The typeclasses in this module only provide lifting for 'hashWithSalt', not
+-- for 'hash'. This is because such liftings cannot be defined in a way that
+-- would satisfy the @liftHash@ variant of the above law. As an illustration
+-- of the problem we run into, let us assume that 'Hashable1' were
+-- given a 'liftHash' method:
+--
+-- > class Hashable1 t where
+-- > liftHash :: (Int -> a) -> t a -> Int
+-- > liftHashWithSalt :: (Int -> a -> Int) -> Int -> t a -> Int
+--
+-- Even for a type as simple as 'Maybe', the problem manifests itself. The
+-- 'Hashable' instance for 'Maybe' is:
+--
+-- > distinguisher :: Int
+-- > distinguisher = ...
+-- >
+-- > instance Hashable a => Hashable (Maybe a) where
+-- > hash Nothing = 0
+-- > hash (Just a) = distinguisher `hashWithSalt` a
+-- > hashWithSalt s Nothing = ...
+-- > hashWithSalt s (Just a) = ...
+--
+-- The implementation of 'hash' calls 'hashWithSalt' on @a@. The hypothetical
+-- @liftHash@ defined earlier only accepts an argument that corresponds to
+-- the implementation of 'hash' for @a@. Consequently, this formulation of
+-- @liftHash@ would not provide a way to match the current behavior of 'hash'
+-- for 'Maybe'. This problem gets worse when 'Either' and @[]@ are considered.
+-- The solution adopted in this library is to omit @liftHash@ entirely.
+
diff --git a/benchmarks/PPoPP2019/src/hashable-1.2.6.1/Data/Hashable/RandomSource.hs b/benchmarks/PPoPP2019/src/hashable-1.2.6.1/Data/Hashable/RandomSource.hs
new file mode 100644
index 0000000..678d04a
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/hashable-1.2.6.1/Data/Hashable/RandomSource.hs
@@ -0,0 +1,32 @@
+{-# LANGUAGE CPP, ForeignFunctionInterface #-}
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702
+{-# LANGUAGE Trustworthy #-}
+#endif
+
+module Data.Hashable.RandomSource
+ (
+ getRandomBytes
+ , getRandomBytes_
+ ) where
+
+import Data.ByteString as B
+import Data.ByteString.Internal (create)
+import Foreign.C.Error (throwErrnoIfMinus1_)
+#if MIN_VERSION_base(4,5,0)
+import Foreign.C.Types (CInt(CInt))
+#else
+import Foreign.C.Types (CInt)
+#endif
+import Foreign.Ptr (Ptr)
+
+getRandomBytes :: Int -> IO ByteString
+getRandomBytes nbytes
+ | nbytes <= 0 = return B.empty
+ | otherwise = create nbytes $ flip (getRandomBytes_ "getRandomBytes") nbytes
+
+getRandomBytes_ :: String -> Ptr a -> Int -> IO ()
+getRandomBytes_ what ptr nbytes = do
+ throwErrnoIfMinus1_ what $ c_getRandomBytes ptr (fromIntegral nbytes)
+
+foreign import ccall unsafe "hashable_getRandomBytes" c_getRandomBytes
+ :: Ptr a -> CInt -> IO CInt
diff --git a/benchmarks/PPoPP2019/src/hashable-1.2.6.1/Data/Hashable/SipHash.hs b/benchmarks/PPoPP2019/src/hashable-1.2.6.1/Data/Hashable/SipHash.hs
new file mode 100644
index 0000000..aef6cbd
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/hashable-1.2.6.1/Data/Hashable/SipHash.hs
@@ -0,0 +1,159 @@
+{-# LANGUAGE BangPatterns, CPP, GeneralizedNewtypeDeriving, RecordWildCards #-}
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+
+module Data.Hashable.SipHash
+ (
+ LE64
+ , Sip
+ , fromWord64
+ , fullBlock
+ , lastBlock
+ , finalize
+ , hashByteString
+ ) where
+
+#include "MachDeps.h"
+
+import Data.Bits ((.|.), (.&.), rotateL, shiftL, xor)
+#if MIN_VERSION_base(4,5,0)
+import Data.Bits (unsafeShiftL)
+#endif
+import Data.Word (Word8, Word64)
+import Foreign.ForeignPtr (withForeignPtr)
+import Foreign.Ptr (Ptr, castPtr, plusPtr)
+import Data.ByteString.Internal (ByteString(PS), inlinePerformIO)
+import Foreign.Storable (peek)
+import Numeric (showHex)
+
+newtype LE64 = LE64 { fromLE64 :: Word64 }
+ deriving (Eq)
+
+instance Show LE64 where
+ show (LE64 !v) = let s = showHex v ""
+ in "0x" ++ replicate (16 - length s) '0' ++ s
+
+data Sip = Sip {
+ v0 :: {-# UNPACK #-} !Word64, v1 :: {-# UNPACK #-} !Word64
+ , v2 :: {-# UNPACK #-} !Word64, v3 :: {-# UNPACK #-} !Word64
+ }
+
+fromWord64 :: Word64 -> LE64
+#ifndef WORDS_BIGENDIAN
+fromWord64 = LE64
+#else
+#error big endian support TBD
+#endif
+
+initState :: (Sip -> r) -> Word64 -> Word64 -> r
+initState k k0 k1 = k (Sip s0 s1 s2 s3)
+ where !s0 = (k0 `xor` 0x736f6d6570736575)
+ !s1 = (k1 `xor` 0x646f72616e646f6d)
+ !s2 = (k0 `xor` 0x6c7967656e657261)
+ !s3 = (k1 `xor` 0x7465646279746573)
+
+sipRound :: (Sip -> r) -> Sip -> r
+sipRound k Sip{..} = k (Sip v0_c v1_d v2_c v3_d)
+ where v0_a = v0 + v1
+ v2_a = v2 + v3
+ v1_a = v1 `rotateL` 13
+ v3_a = v3 `rotateL` 16
+ v1_b = v1_a `xor` v0_a
+ v3_b = v3_a `xor` v2_a
+ v0_b = v0_a `rotateL` 32
+ v2_b = v2_a + v1_b
+ v0_c = v0_b + v3_b
+ v1_c = v1_b `rotateL` 17
+ v3_c = v3_b `rotateL` 21
+ v1_d = v1_c `xor` v2_b
+ v3_d = v3_c `xor` v0_c
+ v2_c = v2_b `rotateL` 32
+
+fullBlock :: Int -> LE64 -> (Sip -> r) -> Sip -> r
+fullBlock c m k st@Sip{..}
+ | c == 2 = sipRound (sipRound k') st'
+ | otherwise = runRounds c k' st'
+ where k' st1@Sip{..} = k st1{ v0 = v0 `xor` fromLE64 m }
+ st' = st{ v3 = v3 `xor` fromLE64 m }
+{-# INLINE fullBlock #-}
+
+runRounds :: Int -> (Sip -> r) -> Sip -> r
+runRounds c k = go 0
+ where go i st
+ | i < c = sipRound (go (i+1)) st
+ | otherwise = k st
+{-# INLINE runRounds #-}
+
+lastBlock :: Int -> Int -> LE64 -> (Sip -> r) -> Sip -> r
+lastBlock !c !len !m k st =
+#ifndef WORDS_BIGENDIAN
+ fullBlock c (LE64 m') k st
+#else
+#error big endian support TBD
+#endif
+ where m' = fromLE64 m .|. ((fromIntegral len .&. 0xff) `shiftL` 56)
+{-# INLINE lastBlock #-}
+
+finalize :: Int -> (Word64 -> r) -> Sip -> r
+finalize d k st@Sip{..}
+ | d == 4 = sipRound (sipRound (sipRound (sipRound k'))) st'
+ | otherwise = runRounds d k' st'
+ where k' Sip{..} = k $! v0 `xor` v1 `xor` v2 `xor` v3
+ st' = st{ v2 = v2 `xor` 0xff }
+{-# INLINE finalize #-}
+
+hashByteString :: Int -> Int -> Word64 -> Word64 -> ByteString -> Word64
+hashByteString !c !d k0 k1 (PS fp off len) =
+ inlinePerformIO . withForeignPtr fp $ \basePtr ->
+ let ptr0 = basePtr `plusPtr` off
+ scant = len .&. 7
+ endBlocks = ptr0 `plusPtr` (len - scant)
+ go !ptr st
+ | ptr == endBlocks = readLast ptr
+ | otherwise = do
+ m <- peekLE64 ptr
+ fullBlock c m (go (ptr `plusPtr` 8)) st
+ where
+ zero !m _ _ = lastBlock c len (LE64 m) (finalize d return) st
+ one k m p s = do
+ w <- fromIntegral `fmap` peekByte p
+ k (m .|. (w `unsafeShiftL` s)) (p `plusPtr` 1) (s+8)
+ readLast p =
+ case scant of
+ 0 -> zero 0 p (0::Int)
+ 1 -> one zero 0 p 0
+ 2 -> one (one zero) 0 p 0
+ 3 -> one (one (one zero)) 0 p 0
+ 4 -> one (one (one (one zero))) 0 p 0
+ 5 -> one (one (one (one (one zero)))) 0 p 0
+ 6 -> one (one (one (one (one (one zero))))) 0 p 0
+ _ -> one (one (one (one (one (one (one zero)))))) 0 p 0
+ in initState (go ptr0) k0 k1
+
+peekByte :: Ptr Word8 -> IO Word8
+peekByte = peek
+
+peekLE64 :: Ptr Word8 -> IO LE64
+#if defined(x86_64_HOST_ARCH) || defined(i386_HOST_ARCH)
+-- platforms on which unaligned loads are legal and usually fast
+peekLE64 p = LE64 `fmap` peek (castPtr p)
+#else
+peekLE64 p = do
+ let peek8 d = fromIntegral `fmap` peekByte (p `plusPtr` d)
+ b0 <- peek8 0
+ b1 <- peek8 1
+ b2 <- peek8 2
+ b3 <- peek8 3
+ b4 <- peek8 4
+ b5 <- peek8 5
+ b6 <- peek8 6
+ b7 <- peek8 7
+ let !w = (b7 `shiftL` 56) .|. (b6 `shiftL` 48) .|. (b5 `shiftL` 40) .|.
+ (b4 `shiftL` 32) .|. (b3 `shiftL` 24) .|. (b2 `shiftL` 16) .|.
+ (b1 `shiftL` 8) .|. b0
+ return (fromWord64 w)
+#endif
+
+#if !(MIN_VERSION_base(4,5,0))
+unsafeShiftL :: Word64 -> Int -> Word64
+unsafeShiftL = shiftL
+#endif
diff --git a/benchmarks/PPoPP2019/src/hashable-1.2.6.1/LICENSE b/benchmarks/PPoPP2019/src/hashable-1.2.6.1/LICENSE
new file mode 100644
index 0000000..7130957
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/hashable-1.2.6.1/LICENSE
@@ -0,0 +1,30 @@
+Copyright Milan Straka 2010
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Milan Straka nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/benchmarks/PPoPP2019/src/hashable-1.2.6.1/README.md b/benchmarks/PPoPP2019/src/hashable-1.2.6.1/README.md
new file mode 100644
index 0000000..d692480
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/hashable-1.2.6.1/README.md
@@ -0,0 +1,7 @@
+The hashable package
+====================
+
+This package defines a class, `Hashable`, for types that can be
+converted to a hash value. This class exists for the benefit of
+hashing-based data structures. The package provides instances for
+basic types and a way to combine hash values.
diff --git a/benchmarks/PPoPP2019/src/hashable-1.2.6.1/Setup.hs b/benchmarks/PPoPP2019/src/hashable-1.2.6.1/Setup.hs
new file mode 100644
index 0000000..cd7dc32
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/hashable-1.2.6.1/Setup.hs
@@ -0,0 +1,3 @@
+#!/usr/bin/env runhaskell
+import Distribution.Simple
+main = defaultMain
diff --git a/benchmarks/PPoPP2019/src/hashable-1.2.6.1/benchmarks/Benchmarks.hs b/benchmarks/PPoPP2019/src/hashable-1.2.6.1/benchmarks/Benchmarks.hs
new file mode 100644
index 0000000..331642e
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/hashable-1.2.6.1/benchmarks/Benchmarks.hs
@@ -0,0 +1,314 @@
+{-# LANGUAGE BangPatterns, CPP, ForeignFunctionInterface, MagicHash,
+ UnboxedTuples, DeriveGeneric #-}
+
+module Main (main) where
+
+import Control.Monad.ST
+import Criterion.Main
+import Data.Hashable
+import Data.Hashable.SipHash
+import Data.Int
+import Foreign.ForeignPtr
+import GHC.Exts
+import GHC.ST (ST(..))
+import Data.Word
+import Foreign.C.Types (CInt(..), CLong(..), CSize(..))
+import Foreign.Ptr
+import Data.ByteString.Internal
+import GHC.Generics (Generic)
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.Text as T
+import qualified Data.Text.Lazy as TL
+import qualified Crypto.MAC.SipHash as HS
+import qualified Data.ByteString.Char8 as B8
+
+-- Benchmark English words (5 and 8), base64 encoded integers (11),
+-- SHA1 hashes as hex (40), and large blobs (1 Mb).
+main :: IO ()
+main = do
+ -- We do not actually care about the contents of these pointers.
+ fp5 <- mallocForeignPtrBytes 5
+ fp8 <- mallocForeignPtrBytes 8
+ fp11 <- mallocForeignPtrBytes 11
+ fp40 <- mallocForeignPtrBytes 40
+ fp128 <- mallocForeignPtrBytes 128
+ fp512 <- mallocForeignPtrBytes 512
+ let !mb = 2^(20 :: Int) -- 1 Mb
+ fp1Mb <- mallocForeignPtrBytes mb
+
+ let exP = P 22.0203 234.19 'x' 6424
+ exS = S3
+ exPS = PS3 'z' 7715
+
+ -- We don't care about the contents of these either.
+ let !ba5 = new 5; !ba8 = new 8; !ba11 = new 11; !ba40 = new 40
+ !ba128 = new 128; !ba512 = new 512; !ba1Mb = new mb
+
+ s5 = ['\0'..'\4']; s8 = ['\0'..'\7']; s11 = ['\0'..'\10']
+ s40 = ['\0'..'\39']; s128 = ['\0'..'\127']; s512 = ['\0'..'\511']
+ s1Mb = ['\0'..'\999999']
+
+ !bs5 = B8.pack s5; !bs8 = B8.pack s8; !bs11 = B8.pack s11
+ !bs40 = B8.pack s40; !bs128 = B8.pack s128; !bs512 = B8.pack s512
+ !bs1Mb = B8.pack s1Mb
+
+ blmeg = BL.take (fromIntegral mb) . BL.fromChunks . repeat
+ bl5 = BL.fromChunks [bs5]; bl8 = BL.fromChunks [bs8]
+ bl11 = BL.fromChunks [bs11]; bl40 = BL.fromChunks [bs40]
+ bl128 = BL.fromChunks [bs128]; bl512 = BL.fromChunks [bs512]
+ bl1Mb_40 = blmeg bs40; bl1Mb_128 = blmeg bs128
+ bl1Mb_64k = blmeg (B8.take 65536 bs1Mb)
+
+ !t5 = T.pack s5; !t8 = T.pack s8; !t11 = T.pack s11
+ !t40 = T.pack s40; !t128 = T.pack s128; !t512 = T.pack s512
+ !t1Mb = T.pack s1Mb
+
+ tlmeg = TL.take (fromIntegral mb) . TL.fromChunks . repeat
+ tl5 = TL.fromStrict t5; tl8 = TL.fromStrict t8
+ tl11 = TL.fromStrict t11; tl40 = TL.fromStrict t40
+ tl128 = TL.fromStrict t128; tl512 = TL.fromChunks (replicate 4 t128)
+ tl1Mb_40 = tlmeg t40; tl1Mb_128 = tlmeg t128
+ tl1Mb_64k = tlmeg (T.take 65536 t1Mb)
+
+ let k0 = 0x4a7330fae70f52e8
+ k1 = 0x919ea5953a9a1ec9
+ sipHash = hashByteString 2 4 k0 k1
+ hsSipHash = HS.hash (HS.SipKey k0 k1)
+ cSipHash (PS fp off len) =
+ inlinePerformIO . withForeignPtr fp $ \ptr ->
+ return $! c_siphash 2 4 k0 k1 (ptr `plusPtr` off) (fromIntegral len)
+ cSipHash24 (PS fp off len) =
+ inlinePerformIO . withForeignPtr fp $ \ptr ->
+ return $! c_siphash24 k0 k1 (ptr `plusPtr` off) (fromIntegral len)
+ fnvHash (PS fp off len) =
+ inlinePerformIO . withForeignPtr fp $ \ptr ->
+ return $! fnv_hash (ptr `plusPtr` off) (fromIntegral len) 2166136261
+#ifdef HAVE_SSE2
+ sse2SipHash (PS fp off len) =
+ inlinePerformIO . withForeignPtr fp $ \ptr ->
+ return $! sse2_siphash k0 k1 (ptr `plusPtr` off) (fromIntegral len)
+#endif
+#ifdef HAVE_SSE41
+ sse41SipHash (PS fp off len) =
+ inlinePerformIO . withForeignPtr fp $ \ptr ->
+ return $! sse41_siphash k0 k1 (ptr `plusPtr` off) (fromIntegral len)
+#endif
+
+ withForeignPtr fp5 $ \ p5 ->
+ withForeignPtr fp8 $ \ p8 ->
+ withForeignPtr fp11 $ \ p11 ->
+ withForeignPtr fp40 $ \ p40 ->
+ withForeignPtr fp128 $ \ p128 ->
+ withForeignPtr fp512 $ \ p512 ->
+ withForeignPtr fp1Mb $ \ p1Mb ->
+ defaultMain
+ [ bgroup "hashPtr"
+ [ bench "5" $ whnfIO $ hashPtr p5 5
+ , bench "8" $ whnfIO $ hashPtr p8 8
+ , bench "11" $ whnfIO $ hashPtr p11 11
+ , bench "40" $ whnfIO $ hashPtr p40 40
+ , bench "128" $ whnfIO $ hashPtr p128 128
+ , bench "512" $ whnfIO $ hashPtr p512 512
+ , bench "2^20" $ whnfIO $ hashPtr p1Mb mb
+ ]
+ , bgroup "hashByteArray"
+ [ bench "5" $ whnf (hashByteArray ba5 0) 5
+ , bench "8" $ whnf (hashByteArray ba8 0) 8
+ , bench "11" $ whnf (hashByteArray ba11 0) 11
+ , bench "40" $ whnf (hashByteArray ba40 0) 40
+ , bench "128" $ whnf (hashByteArray ba128 0) 128
+ , bench "512" $ whnf (hashByteArray ba512 0) 512
+ , bench "2^20" $ whnf (hashByteArray ba1Mb 0) mb
+ ]
+ , bgroup "hash"
+ [ bgroup "ByteString"
+ [ bgroup "strict"
+ [ bench "5" $ whnf hash bs5
+ , bench "8" $ whnf hash bs8
+ , bench "11" $ whnf hash bs11
+ , bench "40" $ whnf hash bs40
+ , bench "128" $ whnf hash bs128
+ , bench "512" $ whnf hash bs512
+ , bench "2^20" $ whnf hash bs1Mb
+ ]
+ , bgroup "lazy"
+ [ bench "5" $ whnf hash bl5
+ , bench "8" $ whnf hash bl8
+ , bench "11" $ whnf hash bl11
+ , bench "40" $ whnf hash bl40
+ , bench "128" $ whnf hash bl128
+ , bench "512" $ whnf hash bl512
+ , bench "2^20_40" $ whnf hash bl1Mb_40
+ , bench "2^20_128" $ whnf hash bl1Mb_128
+ , bench "2^20_64k" $ whnf hash bl1Mb_64k
+ ]
+ ]
+ , bgroup "String"
+ [ bench "5" $ whnf hash s5
+ , bench "8" $ whnf hash s8
+ , bench "11" $ whnf hash s11
+ , bench "40" $ whnf hash s40
+ , bench "128" $ whnf hash s128
+ , bench "512" $ whnf hash s512
+ , bench "2^20" $ whnf hash s1Mb
+ ]
+ , bgroup "Text"
+ [ bgroup "strict"
+ [ bench "5" $ whnf hash t5
+ , bench "8" $ whnf hash t8
+ , bench "11" $ whnf hash t11
+ , bench "40" $ whnf hash t40
+ , bench "128" $ whnf hash t128
+ , bench "512" $ whnf hash t512
+ , bench "2^20" $ whnf hash t1Mb
+ ]
+ , bgroup "lazy"
+ [ bench "5" $ whnf hash tl5
+ , bench "8" $ whnf hash tl8
+ , bench "11" $ whnf hash tl11
+ , bench "40" $ whnf hash tl40
+ , bench "128" $ whnf hash tl128
+ , bench "512" $ whnf hash tl512
+ , bench "2^20_40" $ whnf hash tl1Mb_40
+ , bench "2^20_128" $ whnf hash tl1Mb_128
+ , bench "2^20_64k" $ whnf hash tl1Mb_64k
+ ]
+ ]
+ , bench "Int8" $ whnf hash (0xef :: Int8)
+ , bench "Int16" $ whnf hash (0x7eef :: Int16)
+ , bench "Int32" $ whnf hash (0x7eadbeef :: Int32)
+ , bench "Int" $ whnf hash (0x7eadbeefdeadbeef :: Int)
+ , bench "Int64" $ whnf hash (0x7eadbeefdeadbeef :: Int64)
+ , bench "Double" $ whnf hash (0.3780675796601578 :: Double)
+ ]
+ , bgroup "sipHash"
+ [ bench "5" $ whnf sipHash bs5
+ , bench "8" $ whnf sipHash bs8
+ , bench "11" $ whnf sipHash bs11
+ , bench "40" $ whnf sipHash bs40
+ , bench "128" $ whnf sipHash bs128
+ , bench "512" $ whnf sipHash bs512
+ , bench "2^20" $ whnf sipHash bs1Mb
+ ]
+ , bgroup "cSipHash"
+ [ bench "5" $ whnf cSipHash bs5
+ , bench "8" $ whnf cSipHash bs8
+ , bench "11" $ whnf cSipHash bs11
+ , bench "40" $ whnf cSipHash bs40
+ , bench "128" $ whnf cSipHash bs128
+ , bench "512" $ whnf cSipHash bs512
+ , bench "2^20" $ whnf cSipHash bs1Mb
+ ]
+ , bgroup "cSipHash24"
+ [ bench "5" $ whnf cSipHash24 bs5
+ , bench "8" $ whnf cSipHash24 bs8
+ , bench "11" $ whnf cSipHash24 bs11
+ , bench "40" $ whnf cSipHash24 bs40
+ , bench "128" $ whnf cSipHash24 bs128
+ , bench "512" $ whnf cSipHash24 bs512
+ , bench "2^20" $ whnf cSipHash24 bs1Mb
+ ]
+#ifdef HAVE_SSE2
+ , bgroup "sse2SipHash"
+ [ bench "5" $ whnf sse2SipHash bs5
+ , bench "8" $ whnf sse2SipHash bs8
+ , bench "11" $ whnf sse2SipHash bs11
+ , bench "40" $ whnf sse2SipHash bs40
+ , bench "128" $ whnf sse2SipHash bs128
+ , bench "512" $ whnf sse2SipHash bs512
+ , bench "2^20" $ whnf sse2SipHash bs1Mb
+ ]
+#endif
+#ifdef HAVE_SSE41
+ , bgroup "sse41SipHash"
+ [ bench "5" $ whnf sse41SipHash bs5
+ , bench "8" $ whnf sse41SipHash bs8
+ , bench "11" $ whnf sse41SipHash bs11
+ , bench "40" $ whnf sse41SipHash bs40
+ , bench "128" $ whnf sse41SipHash bs128
+ , bench "512" $ whnf sse41SipHash bs512
+ , bench "2^20" $ whnf sse41SipHash bs1Mb
+ ]
+#endif
+ , bgroup "pkgSipHash"
+ [ bench "5" $ whnf hsSipHash bs5
+ , bench "8" $ whnf hsSipHash bs8
+ , bench "11" $ whnf hsSipHash bs11
+ , bench "40" $ whnf hsSipHash bs40
+ , bench "128" $ whnf hsSipHash bs128
+ , bench "512" $ whnf hsSipHash bs512
+ , bench "2^20" $ whnf hsSipHash bs1Mb
+ ]
+ , bgroup "fnv"
+ [ bench "5" $ whnf fnvHash bs5
+ , bench "8" $ whnf fnvHash bs8
+ , bench "11" $ whnf fnvHash bs11
+ , bench "40" $ whnf fnvHash bs40
+ , bench "128" $ whnf fnvHash bs128
+ , bench "512" $ whnf fnvHash bs512
+ , bench "2^20" $ whnf fnvHash bs1Mb
+ ]
+ , bgroup "Int"
+ [ bench "id32" $ whnf id (0x7eadbeef :: Int32)
+ , bench "id64" $ whnf id (0x7eadbeefdeadbeef :: Int64)
+ , bench "wang32" $ whnf hash_wang_32 0xdeadbeef
+ , bench "wang64" $ whnf hash_wang_64 0xdeadbeefdeadbeef
+ , bench "jenkins32a" $ whnf hash_jenkins_32a 0xdeadbeef
+ , bench "jenkins32b" $ whnf hash_jenkins_32b 0xdeadbeef
+ ]
+ , bgroup "Generic"
+ [ bench "product" $ whnf hash exP
+ , bench "sum" $ whnf hash exS
+ , bench "product and sum" $ whnf hash exPS
+ ]
+ ]
+
+data ByteArray = BA { unBA :: !ByteArray# }
+
+new :: Int -> ByteArray#
+new (I# n#) = unBA (runST $ ST $ \s1 ->
+ case newByteArray# n# s1 of
+ (# s2, ary #) -> case unsafeFreezeByteArray# ary s2 of
+ (# s3, ba #) -> (# s3, BA ba #))
+
+foreign import ccall unsafe "hashable_siphash" c_siphash
+ :: CInt -> CInt -> Word64 -> Word64 -> Ptr Word8 -> CSize -> Word64
+foreign import ccall unsafe "hashable_siphash24" c_siphash24
+ :: Word64 -> Word64 -> Ptr Word8 -> CSize -> Word64
+#ifdef HAVE_SSE2
+foreign import ccall unsafe "hashable_siphash24_sse2" sse2_siphash
+ :: Word64 -> Word64 -> Ptr Word8 -> CSize -> Word64
+#endif
+#ifdef HAVE_SSE41
+foreign import ccall unsafe "hashable_siphash24_sse41" sse41_siphash
+ :: Word64 -> Word64 -> Ptr Word8 -> CSize -> Word64
+#endif
+
+foreign import ccall unsafe "hashable_fnv_hash" fnv_hash
+ :: Ptr Word8 -> CLong -> CLong -> CLong
+
+foreign import ccall unsafe "hashable_wang_32" hash_wang_32
+ :: Word32 -> Word32
+foreign import ccall unsafe "hashable_wang_64" hash_wang_64
+ :: Word64 -> Word64
+foreign import ccall unsafe "hash_jenkins_32a" hash_jenkins_32a
+ :: Word32 -> Word32
+foreign import ccall unsafe "hash_jenkins_32b" hash_jenkins_32b
+ :: Word32 -> Word32
+
+data PS
+ = PS1 Int Char Bool
+ | PS2 String ()
+ | PS3 Char Int
+ deriving (Generic)
+
+data P = P Double Float Char Int
+ deriving (Generic)
+
+data S = S1 | S2 | S3 | S4 | S5
+ deriving (Generic)
+
+instance Hashable PS
+instance Hashable P
+instance Hashable S
+
diff --git a/benchmarks/PPoPP2019/src/hashable-1.2.6.1/benchmarks/cbits/inthash.c b/benchmarks/PPoPP2019/src/hashable-1.2.6.1/benchmarks/cbits/inthash.c
new file mode 100644
index 0000000..5fc32e9
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/hashable-1.2.6.1/benchmarks/cbits/inthash.c
@@ -0,0 +1,28 @@
+#include
+
+/*
+ * 32-bit hashes by Bob Jenkins.
+ */
+
+uint32_t hash_jenkins_32a(uint32_t a)
+{
+ a = (a+0x7ed55d16) + (a<<12);
+ a = (a^0xc761c23c) ^ (a>>19);
+ a = (a+0x165667b1) + (a<<5);
+ a = (a+0xd3a2646c) ^ (a<<9);
+ a = (a+0xfd7046c5) + (a<<3);
+ a = (a^0xb55a4f09) ^ (a>>16);
+ return a;
+}
+
+uint32_t hash_jenkins_32b(uint32_t a)
+{
+ a -= (a<<6);
+ a ^= (a>>17);
+ a -= (a<<9);
+ a ^= (a<<4);
+ a -= (a<<3);
+ a ^= (a<<10);
+ a ^= (a>>15);
+ return a;
+}
diff --git a/benchmarks/PPoPP2019/src/hashable-1.2.6.1/benchmarks/cbits/siphash-sse2.c b/benchmarks/PPoPP2019/src/hashable-1.2.6.1/benchmarks/cbits/siphash-sse2.c
new file mode 100644
index 0000000..74762bc
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/hashable-1.2.6.1/benchmarks/cbits/siphash-sse2.c
@@ -0,0 +1,129 @@
+/*
+ * The original code was developed by Samuel Neves, and has been
+ * only lightly modified.
+ *
+ * Used with permission.
+ */
+#pragma GCC target("sse2")
+
+#include
+#include "siphash.h"
+
+#define _mm_roti_epi64(x, c) ((16 == (c)) ? _mm_shufflelo_epi16((x), _MM_SHUFFLE(2,1,0,3)) : _mm_xor_si128(_mm_slli_epi64((x), (c)), _mm_srli_epi64((x), 64-(c))))
+
+u64 hashable_siphash24_sse2(u64 ik0, u64 ik1, const u8 *m, size_t n)
+{
+ __m128i v0, v1, v2, v3;
+ __m128i k0, k1;
+ __m128i mi, mask, len;
+ size_t i, k;
+ union { u64 gpr; __m128i xmm; } hash;
+ const u8 *p;
+
+ /* We used to use the _mm_seti_epi32 intrinsic to initialize
+ SSE2 registers. This compiles to a movdqa instruction,
+ which requires 16-byte alignment. On 32-bit Windows, it
+ looks like ghc's runtime linker doesn't align ".rdata"
+ sections as requested, so we got segfaults for our trouble.
+
+ Now we use an intrinsic that cares less about alignment
+ (_mm_loadu_si128, aka movdqu) instead, and all seems
+ happy. */
+
+ static const u32 const iv[6][4] = {
+ { 0x70736575, 0x736f6d65, 0, 0 },
+ { 0x6e646f6d, 0x646f7261, 0, 0 },
+ { 0x6e657261, 0x6c796765, 0, 0 },
+ { 0x79746573, 0x74656462, 0, 0 },
+ { -1, -1, 0, 0 },
+ { 255, 0, 0, 0 },
+ };
+
+ k0 = _mm_loadl_epi64((__m128i*)(&ik0));
+ k1 = _mm_loadl_epi64((__m128i*)(&ik1));
+
+ v0 = _mm_xor_si128(k0, _mm_loadu_si128((__m128i*) &iv[0]));
+ v1 = _mm_xor_si128(k1, _mm_loadu_si128((__m128i*) &iv[1]));
+ v2 = _mm_xor_si128(k0, _mm_loadu_si128((__m128i*) &iv[2]));
+ v3 = _mm_xor_si128(k1, _mm_loadu_si128((__m128i*) &iv[3]));
+
+#define HALF_ROUND(a,b,c,d,s,t) \
+ do \
+ { \
+ a = _mm_add_epi64(a, b); c = _mm_add_epi64(c, d); \
+ b = _mm_roti_epi64(b, s); d = _mm_roti_epi64(d, t); \
+ b = _mm_xor_si128(b, a); d = _mm_xor_si128(d, c); \
+ } while(0)
+
+#define COMPRESS(v0,v1,v2,v3) \
+ do \
+ { \
+ HALF_ROUND(v0,v1,v2,v3,13,16); \
+ v0 = _mm_shufflelo_epi16(v0, _MM_SHUFFLE(1,0,3,2)); \
+ HALF_ROUND(v2,v1,v0,v3,17,21); \
+ v2 = _mm_shufflelo_epi16(v2, _MM_SHUFFLE(1,0,3,2)); \
+ } while(0)
+
+ for(i = 0; i < (n-n%8); i += 8)
+ {
+ mi = _mm_loadl_epi64((__m128i*)(m + i));
+ v3 = _mm_xor_si128(v3, mi);
+ if (SIPHASH_ROUNDS == 2) {
+ COMPRESS(v0,v1,v2,v3); COMPRESS(v0,v1,v2,v3);
+ } else {
+ for (k = 0; k < SIPHASH_ROUNDS; ++k)
+ COMPRESS(v0,v1,v2,v3);
+ }
+ v0 = _mm_xor_si128(v0, mi);
+ }
+
+ p = m + n;
+
+ /* We must be careful to not trigger a segfault by reading an
+ unmapped page. So where is the end of our input? */
+
+ if (((uintptr_t) p & 4095) == 0)
+ /* Exactly at a page boundary: do not read past the end. */
+ mi = _mm_setzero_si128();
+ else if (((uintptr_t) p & 4095) <= 4088)
+ /* Inside a page: safe to read past the end, as we'll
+ mask out any bits we shouldn't have looked at below. */
+ mi = _mm_loadl_epi64((__m128i*)(m + i));
+ else
+ /* Within 8 bytes of the end of a page: ensure that
+ our final read re-reads some bytes so that we do
+ not cross the page boundary, then shift our result
+ right so that the re-read bytes vanish. */
+ mi = _mm_srli_epi64(_mm_loadl_epi64((__m128i*)(((uintptr_t) m + i) & ~7)),
+ 8 * (((uintptr_t) m + i) % 8));
+
+ len = _mm_set_epi32(0, 0, (n&0xff) << 24, 0);
+ mask = _mm_srli_epi64(_mm_loadu_si128((__m128i*) &iv[4]), 8*(8-n%8));
+ mi = _mm_xor_si128(_mm_and_si128(mi, mask), len);
+
+ v3 = _mm_xor_si128(v3, mi);
+ if (SIPHASH_ROUNDS == 2) {
+ COMPRESS(v0,v1,v2,v3); COMPRESS(v0,v1,v2,v3);
+ } else {
+ for (k = 0; k < SIPHASH_ROUNDS; ++k)
+ COMPRESS(v0,v1,v2,v3);
+ }
+ v0 = _mm_xor_si128(v0, mi);
+
+ v2 = _mm_xor_si128(v2, _mm_loadu_si128((__m128i*) &iv[5]));
+ if (SIPHASH_FINALROUNDS == 4) {
+ COMPRESS(v0,v1,v2,v3); COMPRESS(v0,v1,v2,v3);
+ COMPRESS(v0,v1,v2,v3); COMPRESS(v0,v1,v2,v3);
+ } else {
+ for (k = 0; k < SIPHASH_FINALROUNDS; ++k)
+ COMPRESS(v0,v1,v2,v3);
+ }
+
+ v0 = _mm_xor_si128(_mm_xor_si128(v0, v1), _mm_xor_si128(v2, v3));
+ hash.xmm = v0;
+
+#undef COMPRESS
+#undef HALF_ROUND
+ //return _mm_extract_epi32(v0, 0) | (((u64)_mm_extract_epi32(v0, 1)) << 32);
+ return hash.gpr;
+}
diff --git a/benchmarks/PPoPP2019/src/hashable-1.2.6.1/benchmarks/cbits/siphash-sse41.c b/benchmarks/PPoPP2019/src/hashable-1.2.6.1/benchmarks/cbits/siphash-sse41.c
new file mode 100644
index 0000000..a8cf081
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/hashable-1.2.6.1/benchmarks/cbits/siphash-sse41.c
@@ -0,0 +1,86 @@
+/*
+ * The original code was developed by Samuel Neves, and has been
+ * only lightly modified.
+ *
+ * Used with permission.
+ */
+#pragma GCC target("sse4.1")
+
+#include
+#include "siphash.h"
+
+// Specialized for siphash, do not reuse
+#define rotate16(x) _mm_shufflehi_epi16((x), _MM_SHUFFLE(2,1,0,3))
+
+#define _mm_roti_epi64(x, c) (((c) == 16) ? rotate16((x)) : _mm_xor_si128(_mm_slli_epi64((x), (c)), _mm_srli_epi64((x), 64-(c))))
+//#define _mm_roti_epi64(x, c) _mm_xor_si128(_mm_slli_epi64((x), (c)), _mm_srli_epi64((x), 64-(c)))
+
+
+u64 hashable_siphash24_sse41(u64 _k0, u64 _k1, const unsigned char *m, size_t n)
+{
+ __m128i v0, v1, v02, v13;
+ __m128i k0;
+ __m128i mi, mask, len, h;
+ const __m128i zero = _mm_setzero_si128();
+ size_t i, k;
+ union { u64 gpr; __m128i xmm; } hash;
+ unsigned char key[16];
+
+ ((u64 *)key)[0] = _k0;
+ ((u64 *)key)[1] = _k1;
+
+ k0 = _mm_loadu_si128((__m128i*)(key + 0));
+
+ v0 = _mm_xor_si128(k0, _mm_set_epi32(0x646f7261, 0x6e646f6d, 0x736f6d65, 0x70736575));
+ v1 = _mm_xor_si128(k0, _mm_set_epi32(0x74656462, 0x79746573, 0x6c796765, 0x6e657261));
+
+ v02 = _mm_unpacklo_epi64(v0, v1);
+ v13 = _mm_unpackhi_epi64(v0, v1);
+
+#define HALF_ROUND(a,b,s,t) \
+do \
+{ \
+ __m128i b1,b2; \
+ a = _mm_add_epi64(a, b); \
+ b1 = _mm_roti_epi64(b, s); b2 = _mm_roti_epi64(b, t); b = _mm_blend_epi16(b1, b2, 0xF0); \
+ b = _mm_xor_si128(b, a); \
+} while(0)
+
+#define COMPRESS(v02,v13) \
+ do \
+ { \
+ HALF_ROUND(v02,v13,13,16); \
+ v02 = _mm_shuffle_epi32(v02, _MM_SHUFFLE(0,1,3,2)); \
+ HALF_ROUND(v02,v13,17,21); \
+ v02 = _mm_shuffle_epi32(v02, _MM_SHUFFLE(0,1,3,2)); \
+ } while(0)
+
+ for(i = 0; i < (n-n%8); i += 8)
+ {
+ mi = _mm_loadl_epi64((__m128i*)(m + i));
+ v13 = _mm_xor_si128(v13, _mm_unpacklo_epi64(zero, mi));
+ for(k = 0; k < SIPHASH_ROUNDS; ++k) COMPRESS(v02,v13);
+ v02 = _mm_xor_si128(v02, mi);
+ }
+
+ mi = _mm_loadl_epi64((__m128i*)(m + i));
+ len = _mm_set_epi32(0, 0, (n&0xff) << 24, 0);
+ mask = _mm_srli_epi64(_mm_set_epi32(0, 0, 0xffffffff, 0xffffffff), 8*(8-n%8));
+ mi = _mm_xor_si128(_mm_and_si128(mi, mask), len);
+
+ v13 = _mm_xor_si128(v13, _mm_unpacklo_epi64(zero, mi));
+ for(k = 0; k < SIPHASH_ROUNDS; ++k) COMPRESS(v02,v13);
+ v02 = _mm_xor_si128(v02, mi);
+
+ v02 = _mm_xor_si128(v02, _mm_set_epi32(0, 0xff, 0, 0));
+ for(k = 0; k < SIPHASH_FINALROUNDS; ++k) COMPRESS(v02,v13);
+
+ v0 = _mm_xor_si128(v02, v13);
+ v0 = _mm_xor_si128(v0, _mm_castps_si128(_mm_movehl_ps(_mm_castsi128_ps(zero), _mm_castsi128_ps(v0))));
+ hash.xmm = v0;
+
+#undef COMPRESS
+#undef HALF_ROUND
+ //return _mm_extract_epi32(v0, 0) | (((u64)_mm_extract_epi32(v0, 1)) << 32);
+ return hash.gpr;
+}
diff --git a/benchmarks/PPoPP2019/src/hashable-1.2.6.1/benchmarks/cbits/siphash.c b/benchmarks/PPoPP2019/src/hashable-1.2.6.1/benchmarks/cbits/siphash.c
new file mode 100644
index 0000000..7ed11d8
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/hashable-1.2.6.1/benchmarks/cbits/siphash.c
@@ -0,0 +1,262 @@
+/* Almost a verbatim copy of the reference implementation. */
+
+#include
+#include "siphash.h"
+
+#define ROTL(x,b) (u64)(((x) << (b)) | ((x) >> (64 - (b))))
+
+#define SIPROUND \
+ do { \
+ v0 += v1; v1=ROTL(v1,13); v1 ^= v0; v0=ROTL(v0,32); \
+ v2 += v3; v3=ROTL(v3,16); v3 ^= v2; \
+ v0 += v3; v3=ROTL(v3,21); v3 ^= v0; \
+ v2 += v1; v1=ROTL(v1,17); v1 ^= v2; v2=ROTL(v2,32); \
+ } while(0)
+
+#if defined(__i386)
+# define _siphash24 plain_siphash24
+#endif
+
+static inline u64 odd_read(const u8 *p, int count, u64 val, int shift)
+{
+ switch (count) {
+ case 7: val |= ((u64)p[6]) << (shift + 48);
+ case 6: val |= ((u64)p[5]) << (shift + 40);
+ case 5: val |= ((u64)p[4]) << (shift + 32);
+ case 4: val |= ((u64)p[3]) << (shift + 24);
+ case 3: val |= ((u64)p[2]) << (shift + 16);
+ case 2: val |= ((u64)p[1]) << (shift + 8);
+ case 1: val |= ((u64)p[0]) << shift;
+ }
+ return val;
+}
+
+static inline u64 _siphash(int c, int d, u64 k0, u64 k1,
+ const u8 *str, size_t len)
+{
+ u64 v0 = 0x736f6d6570736575ull ^ k0;
+ u64 v1 = 0x646f72616e646f6dull ^ k1;
+ u64 v2 = 0x6c7967656e657261ull ^ k0;
+ u64 v3 = 0x7465646279746573ull ^ k1;
+ const u8 *end, *p;
+ u64 b;
+ int i;
+
+ for (p = str, end = str + (len & ~7); p < end; p += 8) {
+ u64 m = peek_u64le((u64 *) p);
+ v3 ^= m;
+ if (c == 2) {
+ SIPROUND;
+ SIPROUND;
+ } else {
+ for (i = 0; i < c; i++)
+ SIPROUND;
+ }
+ v0 ^= m;
+ }
+
+ b = odd_read(p, len & 7, ((u64) len) << 56, 0);
+
+ v3 ^= b;
+ if (c == 2) {
+ SIPROUND;
+ SIPROUND;
+ } else {
+ for (i = 0; i < c; i++)
+ SIPROUND;
+ }
+ v0 ^= b;
+
+ v2 ^= 0xff;
+ if (d == 4) {
+ SIPROUND;
+ SIPROUND;
+ SIPROUND;
+ SIPROUND;
+ } else {
+ for (i = 0; i < d; i++)
+ SIPROUND;
+ }
+ b = v0 ^ v1 ^ v2 ^ v3;
+ return b;
+}
+
+
+static inline u64 _siphash24(u64 k0, u64 k1, const u8 *str, size_t len)
+{
+ return _siphash(2, 4, k0, k1, str, len);
+}
+
+#if defined(__i386)
+# undef _siphash24
+
+static u64 (*_siphash24)(u64 k0, u64 k1, const u8 *, size_t);
+
+static void maybe_use_sse()
+ __attribute__((constructor));
+
+static void maybe_use_sse()
+{
+ uint32_t eax = 1, ebx, ecx, edx;
+
+ __asm volatile
+ ("mov %%ebx, %%edi;" /* 32bit PIC: don't clobber ebx */
+ "cpuid;"
+ "mov %%ebx, %%esi;"
+ "mov %%edi, %%ebx;"
+ :"+a" (eax), "=S" (ebx), "=c" (ecx), "=d" (edx)
+ : :"edi");
+
+#if defined(HAVE_SSE2)
+ if (edx & (1 << 26))
+ _siphash24 = hashable_siphash24_sse2;
+#if defined(HAVE_SSE41)
+ else if (ecx & (1 << 19))
+ _siphash24 = hashable_siphash24_sse41;
+#endif
+ else
+#endif
+ _siphash24 = plain_siphash24;
+}
+
+#endif
+
+/* ghci's linker fails to call static initializers. */
+static inline void ensure_sse_init()
+{
+#if defined(__i386)
+ if (_siphash24 == NULL)
+ maybe_use_sse();
+#endif
+}
+
+u64 hashable_siphash(int c, int d, u64 k0, u64 k1, const u8 *str, size_t len)
+{
+ return _siphash(c, d, k0, k1, str, len);
+}
+
+u64 hashable_siphash24(u64 k0, u64 k1, const u8 *str, size_t len)
+{
+ ensure_sse_init();
+ return _siphash24(k0, k1, str, len);
+}
+
+/* Used for ByteArray#s. We can't treat them like pointers in
+ native Haskell, but we can in unsafe FFI calls.
+ */
+u64 hashable_siphash24_offset(u64 k0, u64 k1,
+ const u8 *str, size_t off, size_t len)
+{
+ ensure_sse_init();
+ return _siphash24(k0, k1, str + off, len);
+}
+
+static int _siphash_chunk(int c, int d, int buffered, u64 v[5],
+ const u8 *str, size_t len, size_t totallen)
+{
+ u64 v0 = v[0], v1 = v[1], v2 = v[2], v3 = v[3], m, b;
+ const u8 *p, *end;
+ u64 carry = 0;
+ int i;
+
+ if (buffered > 0) {
+ int unbuffered = 8 - buffered;
+ int tobuffer = unbuffered > len ? len : unbuffered;
+ int shift = buffered << 3;
+
+ m = odd_read(str, tobuffer, v[4], shift);
+ str += tobuffer;
+ buffered += tobuffer;
+ len -= tobuffer;
+
+ if (buffered < 8)
+ carry = m;
+ else {
+ v3 ^= m;
+ if (c == 2) {
+ SIPROUND;
+ SIPROUND;
+ } else {
+ for (i = 0; i < c; i++)
+ SIPROUND;
+ }
+ v0 ^= m;
+ buffered = 0;
+ m = 0;
+ }
+ }
+
+ for (p = str, end = str + (len & ~7); p < end; p += 8) {
+ m = peek_u64le((u64 *) p);
+ v3 ^= m;
+ if (c == 2) {
+ SIPROUND;
+ SIPROUND;
+ } else {
+ for (i = 0; i < c; i++)
+ SIPROUND;
+ }
+ v0 ^= m;
+ }
+
+ b = odd_read(p, len & 7, 0, 0);
+
+ if (totallen == -1) {
+ v[0] = v0;
+ v[1] = v1;
+ v[2] = v2;
+ v[3] = v3;
+ v[4] = b | carry;
+
+ return buffered + (len & 7);
+ }
+
+ b |= ((u64) totallen) << 56;
+
+ v3 ^= b;
+ if (c == 2) {
+ SIPROUND;
+ SIPROUND;
+ } else {
+ for (i = 0; i < c; i++)
+ SIPROUND;
+ }
+ v0 ^= b;
+
+ v2 ^= 0xff;
+ if (d == 4) {
+ SIPROUND;
+ SIPROUND;
+ SIPROUND;
+ SIPROUND;
+ } else {
+ for (i = 0; i < d; i++)
+ SIPROUND;
+ }
+ v[4] = v0 ^ v1 ^ v2 ^ v3;
+ return 0;
+}
+
+void hashable_siphash_init(u64 k0, u64 k1, u64 *v)
+{
+ v[0] = 0x736f6d6570736575ull ^ k0;
+ v[1] = 0x646f72616e646f6dull ^ k1;
+ v[2] = 0x6c7967656e657261ull ^ k0;
+ v[3] = 0x7465646279746573ull ^ k1;
+ v[4] = 0;
+}
+
+int hashable_siphash24_chunk(int buffered, u64 v[5], const u8 *str,
+ size_t len, size_t totallen)
+{
+ return _siphash_chunk(2, 4, buffered, v, str, len, totallen);
+}
+
+/*
+ * Used for ByteArray#.
+ */
+int hashable_siphash24_chunk_offset(int buffered, u64 v[5], const u8 *str,
+ size_t off, size_t len, size_t totallen)
+{
+ return _siphash_chunk(2, 4, buffered, v, str + off, len, totallen);
+}
diff --git a/benchmarks/PPoPP2019/src/hashable-1.2.6.1/benchmarks/cbits/siphash.h b/benchmarks/PPoPP2019/src/hashable-1.2.6.1/benchmarks/cbits/siphash.h
new file mode 100644
index 0000000..05a565f
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/hashable-1.2.6.1/benchmarks/cbits/siphash.h
@@ -0,0 +1,68 @@
+#ifndef _hashable_siphash_h
+#define _hashable_siphash_h
+
+#include
+#include
+
+typedef uint64_t u64;
+typedef uint32_t u32;
+typedef uint16_t u16;
+typedef uint8_t u8;
+
+#define SIPHASH_ROUNDS 2
+#define SIPHASH_FINALROUNDS 4
+
+u64 hashable_siphash(int, int, u64, u64, const u8 *, size_t);
+u64 hashable_siphash24(u64, u64, const u8 *, size_t);
+
+#if defined(__i386)
+
+/* To use SSE instructions, we have to adjust the stack from its
+ default of 4-byte alignment to use 16-byte alignment. */
+
+# define ALIGNED_STACK __attribute__((force_align_arg_pointer))
+
+u64 hashable_siphash24_sse2(u64, u64, const u8 *, size_t) ALIGNED_STACK;
+u64 hashable_siphash24_sse41(u64, u64, const u8 *, size_t) ALIGNED_STACK;
+#endif
+
+#if defined(_WIN32)
+# define __LITTLE_ENDIAN 1234
+# define __BIG_ENDIAN 4321
+# define __BYTE_ORDER __LITTLE_ENDIAN
+
+#elif (defined(__FreeBSD__) && __FreeBSD_version >= 470000) || defined(__OpenBSD__) || defined(__NetBSD__)
+# include
+# define __BIG_ENDIAN BIG_ENDIAN
+# define __LITTLE_ENDIAN LITTLE_ENDIAN
+# define __BYTE_ORDER BYTE_ORDER
+
+#elif (defined(BSD) && (BSD >= 199103)) || defined(__APPLE__)
+# include
+# define __BIG_ENDIAN BIG_ENDIAN
+# define __LITTLE_ENDIAN LITTLE_ENDIAN
+# define __BYTE_ORDER BYTE_ORDER
+
+#elif defined(__linux__)
+# include
+#endif
+
+static inline u64 peek_u64le(const u64 *p)
+{
+ u64 x = *p;
+
+#if __BYTE_ORDER == __BIG_ENDIAN
+ x = ((x & 0xff00000000000000ull) >> 56) |
+ ((x & 0x00ff000000000000ull) >> 40) |
+ ((x & 0x0000ff0000000000ull) >> 24) |
+ ((x & 0x000000ff00000000ull) >> 8) |
+ ((x & 0x00000000ff000000ull) << 8) |
+ ((x & 0x0000000000ff0000ull) << 24) |
+ ((x & 0x000000000000ff00ull) << 40) |
+ ((x & 0x00000000000000ffull) << 56);
+#endif
+
+ return x;
+}
+
+#endif /* _hashable_siphash_h */
diff --git a/benchmarks/PPoPP2019/src/hashable-1.2.6.1/benchmarks/cbits/wang.c b/benchmarks/PPoPP2019/src/hashable-1.2.6.1/benchmarks/cbits/wang.c
new file mode 100644
index 0000000..ea37ff9
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/hashable-1.2.6.1/benchmarks/cbits/wang.c
@@ -0,0 +1,29 @@
+/*
+ * These hash functions were developed by Thomas Wang.
+ *
+ * http://www.concentric.net/~ttwang/tech/inthash.htm
+ */
+
+#include
+
+uint32_t hashable_wang_32(uint32_t a)
+{
+ a = (a ^ 61) ^ (a >> 16);
+ a = a + (a << 3);
+ a = a ^ (a >> 4);
+ a = a * 0x27d4eb2d;
+ a = a ^ (a >> 15);
+ return a;
+}
+
+uint64_t hashable_wang_64(uint64_t key)
+{
+ key = (~key) + (key << 21); // key = (key << 21) - key - 1;
+ key = key ^ ((key >> 24) | (key << 40));
+ key = (key + (key << 3)) + (key << 8); // key * 265
+ key = key ^ ((key >> 14) | (key << 50));
+ key = (key + (key << 2)) + (key << 4); // key * 21
+ key = key ^ ((key >> 28) | (key << 36));
+ key = key + (key << 31);
+ return key;
+}
diff --git a/benchmarks/PPoPP2019/src/hashable-1.2.6.1/cbits/fnv.c b/benchmarks/PPoPP2019/src/hashable-1.2.6.1/cbits/fnv.c
new file mode 100644
index 0000000..5640b66
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/hashable-1.2.6.1/cbits/fnv.c
@@ -0,0 +1,53 @@
+/*
+Copyright Johan Tibell 2011
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Johan Tibell nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+*/
+
+/* FNV-1 hash
+ *
+ * The FNV-1 hash description: http://isthe.com/chongo/tech/comp/fnv/
+ * The FNV-1 hash is public domain: http://isthe.com/chongo/tech/comp/fnv/#public_domain
+ */
+long hashable_fnv_hash(const unsigned char* str, long len, long hash) {
+
+ while (len--) {
+ hash = (hash * 16777619) ^ *str++;
+ }
+
+ return hash;
+}
+
+/* Used for ByteArray#s. We can't treat them like pointers in
+ native Haskell, but we can in unsafe FFI calls.
+ */
+long hashable_fnv_hash_offset(const unsigned char* str, long offset, long len, long hash) {
+ return hashable_fnv_hash(str + offset, len, hash);
+}
diff --git a/benchmarks/PPoPP2019/src/hashable-1.2.6.1/cbits/getRandomBytes.c b/benchmarks/PPoPP2019/src/hashable-1.2.6.1/cbits/getRandomBytes.c
new file mode 100644
index 0000000..25fb369
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/hashable-1.2.6.1/cbits/getRandomBytes.c
@@ -0,0 +1,93 @@
+/*
+Copyright Bryan O'Sullivan 2012
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Johan Tibell nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+*/
+
+#include "MachDeps.h"
+
+int hashable_getRandomBytes(unsigned char *dest, int nbytes);
+
+#if defined(mingw32_HOST_OS) || defined(__MINGW32__)
+
+#include
+#include
+
+int hashable_getRandomBytes(unsigned char *dest, int nbytes)
+{
+ HCRYPTPROV hCryptProv;
+ int ret;
+
+ if (!CryptAcquireContextA(&hCryptProv, NULL, NULL, PROV_RSA_FULL,
+ CRYPT_VERIFYCONTEXT))
+ return -1;
+
+ ret = CryptGenRandom(hCryptProv, (DWORD) nbytes, (BYTE *) dest) ? nbytes : -1;
+
+ CryptReleaseContext(hCryptProv, 0);
+
+ bail:
+ return ret;
+}
+
+#else
+
+#include
+#include
+#include
+
+/* Assumptions: /dev/urandom exists and does something sane, and does
+ not block. */
+
+int hashable_getRandomBytes(unsigned char *dest, int nbytes)
+{
+ ssize_t off, nread;
+ int fd;
+
+ fd = open("/dev/urandom", O_RDONLY);
+ if (fd == -1)
+ return -1;
+
+ for (off = 0; nbytes > 0; nbytes -= nread) {
+ nread = read(fd, dest + off, nbytes);
+ off += nread;
+ if (nread == -1) {
+ off = -1;
+ break;
+ }
+ }
+
+ bail:
+ close(fd);
+
+ return off;
+}
+
+#endif
diff --git a/benchmarks/PPoPP2019/src/hashable-1.2.6.1/examples/Main.hs b/benchmarks/PPoPP2019/src/hashable-1.2.6.1/examples/Main.hs
new file mode 100644
index 0000000..5d3fa28
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/hashable-1.2.6.1/examples/Main.hs
@@ -0,0 +1,50 @@
+{-# LANGUAGE DeriveGeneric #-}
+import Data.Hashable
+import Data.Hashable.Lifted
+import GHC.Generics (Generic)
+
+data Foo
+ = Foo1 Int Char Bool
+ | Foo2 String ()
+ deriving (Generic)
+
+instance Hashable Foo
+
+data Bar = Bar Double Float
+ deriving (Generic)
+
+instance Hashable Bar
+
+-- printHash :: (Hashable a, Show a) => a -> IO ()
+-- printHash = print . hash
+
+main :: IO ()
+main = do
+ putStrLn "Hashing Foo1"
+ print . hash $ Foo1 22 'y' True
+ putStrLn "Hashing Foo2"
+ print . hash $ Foo2 "hello" ()
+ putStrLn "Hashing Bar"
+ print . hash $ Bar 55.50 9.125
+
+-----------------------------------
+-- Higher Rank Hashable Examples --
+-----------------------------------
+
+newtype WriterT w m a = WriterT { runWriterT :: m (a, w) }
+data Free f a = Pure a | Free (f (Free f a))
+
+instance (Hashable w, Hashable1 m) => Hashable1 (WriterT w m) where
+ liftHashWithSalt h s (WriterT m) =
+ liftHashWithSalt (liftHashWithSalt2 h hashWithSalt) s m
+instance Hashable1 f => Hashable1 (Free f) where
+ liftHashWithSalt h = go where
+ go s x = case x of
+ Pure a -> h s a
+ Free p -> liftHashWithSalt go s p
+
+instance (Hashable w, Hashable1 m, Hashable a) => Hashable (WriterT w m a) where
+ hashWithSalt = hashWithSalt1
+instance (Hashable1 f, Hashable a) => Hashable (Free f a) where
+ hashWithSalt = hashWithSalt1
+
diff --git a/benchmarks/PPoPP2019/src/hashable-1.2.6.1/hashable.cabal b/benchmarks/PPoPP2019/src/hashable-1.2.6.1/hashable.cabal
new file mode 100644
index 0000000..2f6df40
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/hashable-1.2.6.1/hashable.cabal
@@ -0,0 +1,172 @@
+Name: hashable
+Version: 1.2.6.1
+x-revision: 2
+Synopsis: A class for types that can be converted to a hash value
+Description: This package defines a class, 'Hashable', for types that
+ can be converted to a hash value. This class
+ exists for the benefit of hashing-based data
+ structures. The package provides instances for
+ basic types and a way to combine hash values.
+Homepage: http://github.com/tibbe/hashable
+License: BSD3
+License-file: LICENSE
+Author: Milan Straka
+ Johan Tibell
+Maintainer: johan.tibell@gmail.com
+bug-reports: https://github.com/tibbe/hashable/issues
+Stability: Provisional
+Category: Data
+Build-type: Simple
+Cabal-version: >=1.8
+-- tests/Properties.hs shouldn't have to go here, but the source files
+-- for the test-suite stanzas don't get picked up by `cabal sdist`.
+Extra-source-files:
+ CHANGES.md, README.md, tests/Properties.hs,
+ benchmarks/Benchmarks.hs, benchmarks/cbits/*.c, benchmarks/cbits/*.h
+
+Flag integer-gmp
+ Description: Are we using integer-gmp to provide fast Integer instances?
+ Default: True
+
+Flag sse2
+ Description: Do we want to assume that a target supports SSE 2?
+ Default: True
+ Manual: True
+
+Flag sse41
+ Description: Do we want to assume that a target supports SSE 4.1?
+ Default: False
+ Manual: True
+
+Flag examples
+ Description: Build example modules
+ Default: False
+ Manual: True
+
+Library
+ Exposed-modules: Data.Hashable
+ Data.Hashable.Lifted
+ Other-modules: Data.Hashable.Class
+ Build-depends: base >= 4.4 && < 4.11,
+ bytestring >= 0.9 && < 0.11,
+ deepseq >= 1.3
+ if impl(ghc)
+ Build-depends: ghc-prim,
+ text >= 0.11.0.5
+ if impl(ghc) && flag(integer-gmp)
+ Build-depends: integer-gmp >= 0.2
+
+ if impl(ghc >= 7.2.1)
+ CPP-Options: -DGENERICS
+ Other-modules: Data.Hashable.Generic
+
+ C-sources:
+ cbits/fnv.c
+
+ Ghc-options: -Wall
+ if impl(ghc >= 6.8)
+ Ghc-options: -fwarn-tabs
+ else
+ c-sources: cbits/getRandomBytes.c
+ other-modules: Data.Hashable.RandomSource
+ if os(windows)
+ extra-libraries: advapi32
+
+Test-suite tests
+ Type: exitcode-stdio-1.0
+ Hs-source-dirs: tests
+ Main-is: Main.hs
+ Other-modules: Properties Regress
+ Build-depends: base >= 4.0 && < 5.0,
+ bytestring,
+ ghc-prim,
+ hashable,
+ test-framework >= 0.3.3,
+ test-framework-hunit,
+ test-framework-quickcheck2 >= 0.2.9,
+ HUnit,
+ QuickCheck >= 2.4.0.1,
+ random >= 1.0 && < 1.2,
+ text >= 0.11.0.5
+ if !os(windows)
+ Build-depends: unix
+ CPP-options: -DHAVE_MMAP
+ Other-modules: Regress.Mmap
+
+ Ghc-options: -Wall -fno-warn-orphans
+ if impl(ghc >= 7.2.1)
+ CPP-Options: -DGENERICS
+
+benchmark benchmarks
+ -- We cannot depend on the hashable library directly as that creates
+ -- a dependency cycle.
+ hs-source-dirs: . benchmarks
+
+ main-is: Benchmarks.hs
+ other-modules:
+ Data.Hashable
+ Data.Hashable.Class
+ Data.Hashable.RandomSource
+ Data.Hashable.SipHash
+ type: exitcode-stdio-1.0
+
+ build-depends:
+ base,
+ bytestring,
+ criterion >= 1.0,
+ ghc-prim,
+ siphash,
+ text
+
+ if impl(ghc)
+ Build-depends: ghc-prim,
+ text >= 0.11.0.5
+ if impl(ghc) && flag(integer-gmp)
+ Build-depends: integer-gmp >= 0.2
+
+ if impl(ghc >= 7.2.1)
+ CPP-Options: -DGENERICS
+
+ include-dirs:
+ benchmarks/cbits
+
+ includes:
+ siphash.h
+
+ c-sources:
+ benchmarks/cbits/inthash.c
+ benchmarks/cbits/siphash.c
+ benchmarks/cbits/wang.c
+ cbits/fnv.c
+
+ if (arch(i386) || arch(x86_64)) && flag(sse2)
+ cpp-options: -DHAVE_SSE2
+ c-sources:
+ benchmarks/cbits/siphash-sse2.c
+
+ if flag(sse41)
+ cpp-options: -DHAVE_SSE41
+ c-sources:
+ benchmarks/cbits/siphash-sse41.c
+
+ Ghc-options: -Wall -O2
+ if impl(ghc >= 6.8)
+ Ghc-options: -fwarn-tabs
+ else
+ c-sources: cbits/getRandomBytes.c
+ other-modules: Data.Hashable.RandomSource
+ if os(windows)
+ extra-libraries: advapi32
+
+
+Executable hashable-examples
+ if flag(examples)
+ build-depends: base, hashable
+ else
+ buildable: False
+ hs-source-dirs: examples
+ main-is: Main.hs
+
+source-repository head
+ type: git
+ location: https://github.com/tibbe/hashable.git
diff --git a/benchmarks/PPoPP2019/src/hashable-1.2.6.1/tests/Main.hs b/benchmarks/PPoPP2019/src/hashable-1.2.6.1/tests/Main.hs
new file mode 100644
index 0000000..844096f
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/hashable-1.2.6.1/tests/Main.hs
@@ -0,0 +1,14 @@
+-- | Tests for the 'Data.Hashable' module. We test functions by
+-- comparing the C and Haskell implementations.
+
+module Main (main) where
+
+import Properties (properties)
+import Regress (regressions)
+import Test.Framework (defaultMain, testGroup)
+
+main :: IO ()
+main = defaultMain [
+ testGroup "properties" properties
+ , testGroup "regressions" regressions
+ ]
diff --git a/benchmarks/PPoPP2019/src/hashable-1.2.6.1/tests/Properties.hs b/benchmarks/PPoPP2019/src/hashable-1.2.6.1/tests/Properties.hs
new file mode 100644
index 0000000..7a63cc4
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/hashable-1.2.6.1/tests/Properties.hs
@@ -0,0 +1,264 @@
+{-# LANGUAGE BangPatterns, CPP, GeneralizedNewtypeDeriving, MagicHash,
+ Rank2Types, UnboxedTuples #-}
+#ifdef GENERICS
+{-# LANGUAGE DeriveGeneric, ScopedTypeVariables #-}
+#endif
+
+-- | QuickCheck tests for the 'Data.Hashable' module. We test
+-- functions by comparing the C and Haskell implementations.
+
+module Properties (properties) where
+
+import Data.Hashable (Hashable, hash, hashByteArray, hashPtr,
+ Hashed, hashed, unhashed, hashWithSalt)
+import Data.Hashable.Lifted (hashWithSalt1)
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.Text as T
+import qualified Data.Text.Lazy as TL
+import Data.List (nub)
+import Control.Monad (ap, liftM)
+import System.IO.Unsafe (unsafePerformIO)
+import Foreign.Marshal.Array (withArray)
+import GHC.Base (ByteArray#, Int(..), newByteArray#, unsafeCoerce#,
+ writeWord8Array#)
+import GHC.ST (ST(..), runST)
+import GHC.Word (Word8(..))
+import Test.QuickCheck hiding ((.&.))
+import Test.Framework (Test, testGroup)
+import Test.Framework.Providers.QuickCheck2 (testProperty)
+#ifdef GENERICS
+import GHC.Generics
+#endif
+
+#if MIN_VERSION_bytestring(0,10,4)
+import qualified Data.ByteString.Short as BS
+#endif
+
+------------------------------------------------------------------------
+-- * Properties
+
+instance Arbitrary T.Text where
+ arbitrary = T.pack `fmap` arbitrary
+
+instance Arbitrary TL.Text where
+ arbitrary = TL.pack `fmap` arbitrary
+
+instance Arbitrary B.ByteString where
+ arbitrary = B.pack `fmap` arbitrary
+
+instance Arbitrary BL.ByteString where
+ arbitrary = sized $ \n -> resize (round (sqrt (toEnum n :: Double)))
+ ((BL.fromChunks . map (B.pack . nonEmpty)) `fmap` arbitrary)
+ where nonEmpty (NonEmpty a) = a
+
+#if MIN_VERSION_bytestring(0,10,4)
+instance Arbitrary BS.ShortByteString where
+ arbitrary = BS.pack `fmap` arbitrary
+#endif
+
+-- | Validate the implementation by comparing the C and Haskell
+-- versions.
+pHash :: [Word8] -> Bool
+pHash xs = unsafePerformIO $ withArray xs $ \ p ->
+ (hashByteArray (fromList xs) 0 len ==) `fmap` hashPtr p len
+ where len = length xs
+
+-- | Content equality implies hash equality.
+pText :: T.Text -> T.Text -> Bool
+pText a b = if (a == b) then (hash a == hash b) else True
+
+-- | Content equality implies hash equality.
+pTextLazy :: TL.Text -> TL.Text -> Bool
+pTextLazy a b = if (a == b) then (hash a == hash b) else True
+
+-- | A small positive integer.
+newtype ChunkSize = ChunkSize { unCS :: Int }
+ deriving (Eq, Ord, Num, Integral, Real, Enum)
+
+instance Show ChunkSize where show = show . unCS
+
+instance Arbitrary ChunkSize where
+ arbitrary = (ChunkSize . (`mod` maxChunkSize)) `fmap`
+ (arbitrary `suchThat` ((/=0) . (`mod` maxChunkSize)))
+ where maxChunkSize = 16
+
+-- | Ensure that the rechunk function causes a rechunked string to
+-- still match its original form.
+pTextRechunk :: T.Text -> NonEmptyList ChunkSize -> Bool
+pTextRechunk t cs = TL.fromStrict t == rechunkText t cs
+
+-- | Lazy strings must hash to the same value no matter how they are
+-- chunked.
+pTextLazyRechunked :: T.Text
+ -> NonEmptyList ChunkSize -> NonEmptyList ChunkSize -> Bool
+pTextLazyRechunked t cs0 cs1 =
+ hash (rechunkText t cs0) == hash (rechunkText t cs1)
+
+-- | Break up a string into chunks of different sizes.
+rechunkText :: T.Text -> NonEmptyList ChunkSize -> TL.Text
+rechunkText t0 (NonEmpty cs0) = TL.fromChunks . go t0 . cycle $ cs0
+ where
+ go t _ | T.null t = []
+ go t (c:cs) = a : go b cs
+ where (a,b) = T.splitAt (unCS c) t
+ go _ [] = error "Properties.rechunk - The 'impossible' happened!"
+
+#if MIN_VERSION_bytestring(0,10,4)
+-- | Content equality implies hash equality.
+pBSShort :: BS.ShortByteString -> BS.ShortByteString -> Bool
+pBSShort a b = if (a == b) then (hash a == hash b) else True
+#endif
+
+-- | Content equality implies hash equality.
+pBS :: B.ByteString -> B.ByteString -> Bool
+pBS a b = if (a == b) then (hash a == hash b) else True
+
+-- | Content equality implies hash equality.
+pBSLazy :: BL.ByteString -> BL.ByteString -> Bool
+pBSLazy a b = if (a == b) then (hash a == hash b) else True
+
+-- | Break up a string into chunks of different sizes.
+rechunkBS :: B.ByteString -> NonEmptyList ChunkSize -> BL.ByteString
+rechunkBS t0 (NonEmpty cs0) = BL.fromChunks . go t0 . cycle $ cs0
+ where
+ go t _ | B.null t = []
+ go t (c:cs) = a : go b cs
+ where (a,b) = B.splitAt (unCS c) t
+ go _ [] = error "Properties.rechunkBS - The 'impossible' happened!"
+
+-- | Ensure that the rechunk function causes a rechunked string to
+-- still match its original form.
+pBSRechunk :: B.ByteString -> NonEmptyList ChunkSize -> Bool
+pBSRechunk t cs = fromStrict t == rechunkBS t cs
+
+-- | Lazy bytestrings must hash to the same value no matter how they
+-- are chunked.
+pBSLazyRechunked :: B.ByteString
+ -> NonEmptyList ChunkSize -> NonEmptyList ChunkSize -> Bool
+pBSLazyRechunked t cs1 cs2 = hash (rechunkBS t cs1) == hash (rechunkBS t cs2)
+
+-- This wrapper is required by 'runST'.
+data ByteArray = BA { unBA :: ByteArray# }
+
+-- | Create a 'ByteArray#' from a list of 'Word8' values.
+fromList :: [Word8] -> ByteArray#
+fromList xs0 = unBA (runST $ ST $ \ s1# ->
+ case newByteArray# len# s1# of
+ (# s2#, marr# #) -> case go s2# 0 marr# xs0 of
+ s3# -> (# s3#, BA (unsafeCoerce# marr#) #))
+ where
+ !(I# len#) = length xs0
+ go s# _ _ [] = s#
+ go s# i@(I# i#) marr# ((W8# x):xs) =
+ case writeWord8Array# marr# i# x s# of
+ s2# -> go s2# (i + 1) marr# xs
+
+-- Generics
+
+#ifdef GENERICS
+
+data Product2 a b = Product2 a b
+ deriving (Generic)
+
+instance (Arbitrary a, Arbitrary b) => Arbitrary (Product2 a b) where
+ arbitrary = Product2 `liftM` arbitrary `ap` arbitrary
+
+instance (Hashable a, Hashable b) => Hashable (Product2 a b)
+
+data Product3 a b c = Product3 a b c
+ deriving (Generic)
+
+instance (Arbitrary a, Arbitrary b, Arbitrary c) =>
+ Arbitrary (Product3 a b c) where
+ arbitrary = Product3 `liftM` arbitrary `ap` arbitrary `ap` arbitrary
+
+instance (Hashable a, Hashable b, Hashable c) => Hashable (Product3 a b c)
+
+-- Hashes of all product types of the same shapes should be the same.
+
+pProduct2 :: Int -> String -> Bool
+pProduct2 x y = hash (x, y) == hash (Product2 x y)
+
+pProduct3 :: Double -> Maybe Bool -> (Int, String) -> Bool
+pProduct3 x y z = hash (x, y, z) == hash (Product3 x y z)
+
+data Sum2 a b = S2a a | S2b b
+ deriving (Eq, Ord, Show, Generic)
+
+instance (Hashable a, Hashable b) => Hashable (Sum2 a b)
+
+data Sum3 a b c = S3a a | S3b b | S3c c
+ deriving (Eq, Ord, Show, Generic)
+
+instance (Hashable a, Hashable b, Hashable c) => Hashable (Sum3 a b c)
+
+-- Hashes of the same parameter, but with different sum constructors,
+-- should differ. (They might legitimately collide, but that's
+-- vanishingly unlikely.)
+
+pSum2_differ :: Int -> Bool
+pSum2_differ x = nub hs == hs
+ where hs = [ hash (S2a x :: Sum2 Int Int)
+ , hash (S2b x :: Sum2 Int Int) ]
+
+pSum3_differ :: Int -> Bool
+pSum3_differ x = nub hs == hs
+ where hs = [ hash (S3a x :: Sum3 Int Int Int)
+ , hash (S3b x :: Sum3 Int Int Int)
+ , hash (S3c x :: Sum3 Int Int Int) ]
+
+#endif
+
+instance (Arbitrary a, Hashable a) => Arbitrary (Hashed a) where
+ arbitrary = fmap hashed arbitrary
+ shrink xs = map hashed $ shrink $ unhashed xs
+
+pLiftedHashed :: Int -> Hashed (Either Int String) -> Bool
+pLiftedHashed s h = hashWithSalt s h == hashWithSalt1 s h
+
+properties :: [Test]
+properties =
+ [ testProperty "bernstein" pHash
+ , testGroup "text"
+ [ testProperty "text/strict" pText
+ , testProperty "text/lazy" pTextLazy
+ , testProperty "text/rechunk" pTextRechunk
+ , testProperty "text/rechunked" pTextLazyRechunked
+ ]
+ , testGroup "bytestring"
+ [ testProperty "bytestring/strict" pBS
+ , testProperty "bytestring/lazy" pBSLazy
+#if MIN_VERSION_bytestring(0,10,4)
+ , testProperty "bytestring/short" pBSShort
+#endif
+ , testProperty "bytestring/rechunk" pBSRechunk
+ , testProperty "bytestring/rechunked" pBSLazyRechunked
+ ]
+#ifdef GENERICS
+ , testGroup "generics"
+ [
+ -- Note: "product2" and "product3" have been temporarily
+ -- disabled until we have added a 'hash' method to the GHashable
+ -- class. Until then (a,b) hashes to a different value than (a
+ -- :*: b). While this is not incorrect, it would be nicer if
+ -- they didn't. testProperty "product2" pProduct2 , testProperty
+ -- "product3" pProduct3
+ testProperty "sum2_differ" pSum2_differ
+ , testProperty "sum3_differ" pSum3_differ
+ ]
+#endif
+ , testGroup "lifted law"
+ [ testProperty "Hashed" pLiftedHashed
+ ]
+ ]
+
+------------------------------------------------------------------------
+-- Utilities
+
+fromStrict :: B.ByteString -> BL.ByteString
+#if MIN_VERSION_bytestring(0,10,0)
+fromStrict = BL.fromStrict
+#else
+fromStrict b = BL.fromChunks [b]
+#endif
diff --git a/benchmarks/PPoPP2019/src/hashable-1.2.6.1/tests/Regress.hs b/benchmarks/PPoPP2019/src/hashable-1.2.6.1/tests/Regress.hs
new file mode 100644
index 0000000..d06d0a0
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/hashable-1.2.6.1/tests/Regress.hs
@@ -0,0 +1,47 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveGeneric #-}
+
+module Regress (regressions) where
+
+import qualified Test.Framework as F
+import Test.Framework.Providers.HUnit (testCase)
+import Test.HUnit ((@=?))
+import GHC.Generics (Generic)
+import Data.List (nub)
+
+#ifdef HAVE_MMAP
+import qualified Regress.Mmap as Mmap
+#endif
+
+import Data.Hashable
+
+regressions :: [F.Test]
+regressions = [] ++
+#ifdef HAVE_MMAP
+ Mmap.regressions ++
+#endif
+ [ F.testGroup "Generic: sum of nullary constructors"
+ [ testCase "0" $ nullaryCase 0 S0
+ , testCase "1" $ nullaryCase 1 S1
+ , testCase "2" $ nullaryCase 2 S2
+ , testCase "3" $ nullaryCase 3 S3
+ , testCase "4" $ nullaryCase 4 S4
+ ]
+ , testCase "Generic: Peano https://github.com/tibbe/hashable/issues/135" $ do
+ let ns = take 20 $ iterate S Z
+ let hs = map hash ns
+ hs @=? nub hs
+ ]
+ where
+ nullaryCase :: Int -> SumOfNullary -> IO ()
+ nullaryCase n s = do
+ let salt = 42
+ let expected = salt `hashWithSalt` n `hashWithSalt` ()
+ let actual = hashWithSalt salt s
+ expected @=? actual
+
+data SumOfNullary = S0 | S1 | S2 | S3 | S4 deriving (Generic)
+instance Hashable SumOfNullary
+
+data Nat = Z | S Nat deriving (Generic)
+instance Hashable Nat
diff --git a/benchmarks/PPoPP2019/src/hashable-1.2.6.1/tests/Regress/Mmap.hsc b/benchmarks/PPoPP2019/src/hashable-1.2.6.1/tests/Regress/Mmap.hsc
new file mode 100644
index 0000000..b106af3
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/hashable-1.2.6.1/tests/Regress/Mmap.hsc
@@ -0,0 +1,73 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+
+module Regress.Mmap (regressions) where
+
+#include
+
+import Control.Exception (bracket, evaluate)
+import Control.Monad (forM_)
+import Data.Bits ((.|.))
+import Data.ByteString.Internal (ByteString(..))
+import Data.Hashable (hash)
+import Foreign.C.Error (throwErrnoIf, throwErrnoIfMinus1, throwErrnoIfMinus1_)
+import Foreign.C.Types (CInt(..), CSize(..))
+import Foreign.Ptr (Ptr, intPtrToPtr, nullPtr, plusPtr)
+import GHC.ForeignPtr (newForeignPtr_)
+import System.Posix.Types (COff(..))
+import Test.Framework (Test)
+import Test.Framework.Providers.HUnit (testCase)
+import qualified Data.ByteString as B
+
+withMapping :: (Ptr a -> Int -> IO ()) -> IO ()
+withMapping go = do
+ pageSize <- fromIntegral `fmap` getPageSize
+ let mappingSize = pageSize * 2
+ bracket (mmap
+ nullPtr
+ mappingSize
+ ((#const PROT_READ) .|. (#const PROT_WRITE))
+ ((#const MAP_ANON) .|. (#const MAP_PRIVATE))
+ (-1)
+ 0)
+ (flip munmap mappingSize) $ \mappingPtr -> do
+ go mappingPtr (fromIntegral pageSize)
+ mprotect (mappingPtr `plusPtr` fromIntegral pageSize)
+ pageSize (#const PROT_NONE)
+
+hashNearPageBoundary :: IO ()
+hashNearPageBoundary =
+ withMapping $ \ptr pageSize -> do
+ let initialSize = 16
+ fp <- newForeignPtr_ (ptr `plusPtr` (pageSize - initialSize))
+ let bs0 = PS fp 0 initialSize
+ forM_ (B.tails bs0) $ \bs -> do
+ evaluate (hash bs)
+
+regressions :: [Test]
+regressions = [
+ testCase "hashNearPageBoundary" hashNearPageBoundary
+ ]
+
+mmap :: Ptr a -> CSize -> CInt -> CInt -> CInt -> COff -> IO (Ptr a)
+mmap addr len prot flags fd offset =
+ throwErrnoIf (== intPtrToPtr (#const MAP_FAILED)) "mmap" $
+ c_mmap addr len prot flags fd offset
+
+munmap :: Ptr a -> CSize -> IO CInt
+munmap addr len = throwErrnoIfMinus1 "munmap" $ c_munmap addr len
+
+mprotect :: Ptr a -> CSize -> CInt -> IO ()
+mprotect addr len prot =
+ throwErrnoIfMinus1_ "mprotect" $ c_mprotect addr len prot
+
+foreign import ccall unsafe "sys/mman.h mmap"
+ c_mmap :: Ptr a -> CSize -> CInt -> CInt -> CInt -> COff -> IO (Ptr a)
+
+foreign import ccall unsafe "sys/mman.h munmap"
+ c_munmap :: Ptr a -> CSize -> IO CInt
+
+foreign import ccall unsafe "sys/mman.h mprotect"
+ c_mprotect :: Ptr a -> CSize -> CInt -> IO CInt
+
+foreign import ccall unsafe "unistd.h getpagesize"
+ getPageSize :: IO CInt
diff --git a/benchmarks/PPoPP2019/src/loch-th-0.2.1/Debug/Trace/LocationTH.hs b/benchmarks/PPoPP2019/src/loch-th-0.2.1/Debug/Trace/LocationTH.hs
new file mode 100644
index 0000000..8432328
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/loch-th-0.2.1/Debug/Trace/LocationTH.hs
@@ -0,0 +1,184 @@
+-- |
+-- Module : Debug.Trace.LocationTH
+-- Copyright : (c) Tomas Janousek 2011
+-- License : BSD-style
+-- Maintainer : tomi@nomi.cz
+-- Stability : experimental
+-- Portability : non-portable (requires Template haskell)
+-- Tested : GHC 7.0.3
+--
+-- This module provides a Template Haskell based mechanism to tag failures
+-- with the location of the failure call. The location message includes the
+-- file name, line and column numbers.
+--
+
+{-# LANGUAGE TemplateHaskell #-}
+module Debug.Trace.LocationTH
+ ( __LOCATION__
+ , assert
+ , failure
+ , undef
+ , check
+ , checkIO
+ , checkTrace
+ , checkTraceIO
+ ) where
+
+import qualified Control.Exception as C
+import Control.Exception (throw, AssertionFailed(..))
+import Language.Haskell.TH.Ppr (pprint)
+import Language.Haskell.TH.Syntax (location, Loc(..), Q, Exp, lift)
+import System.IO.Unsafe (unsafePerformIO)
+import Text.PrettyPrint.HughesPJ
+
+ppUnless :: Bool -> Doc -> Doc
+ppUnless True _ = empty
+ppUnless False doc = doc
+
+-- | Pretty print Loc. Mostly copypasted pprUserSpan from GHC 7.
+pprLoc :: Loc -> Doc
+pprLoc (Loc { loc_filename = src_path
+ , loc_start = (sline, start_col)
+ , loc_end = (eline, end_col) })
+ | sline == eline = hcat
+ [ text src_path <> colon
+ , int sline, char ':', int start_col
+ , ppUnless (end_col - start_col <= 1)
+ (char '-' <> int (end_col-1))
+ ]
+ | otherwise = hcat
+ [ text src_path <> colon
+ , parens (int sline <> char ',' <> int start_col)
+ , char '-'
+ , parens (int eline <> char ',' <>
+ if end_col == 0 then int end_col else int (end_col-1))
+ ]
+
+--
+-- | Get the location of current splice as a 'String'.
+--
+-- @$__LOCATION__ :: 'String'@
+--
+-- >>> $__LOCATION__
+-- ":1:1-13"
+--
+__LOCATION__ :: Q Exp
+__LOCATION__ = lift =<< (render . pprLoc) `fmap` location
+
+--
+-- | If the first argument evaluates to 'True', then the result is the second
+-- argument. Otherwise an 'AssertionFailed' exception is raised, containing a
+-- 'String' with the source file and line number of the call to 'assert'.
+--
+-- @$(assert [| 'False' |]) :: a -> a@
+--
+-- >>> $(assert [| 5 + 5 == 9 |]) "foo"
+-- "*** Exception: :1:3-25: Assertion `(5 GHC.Num.+ 5) GHC.Classes.== 9' failed
+--
+assert :: Q Exp -> Q Exp
+assert t = do
+ st <- pprint `fmap` t
+ [| assert' $t $__LOCATION__ st |]
+
+assert' :: Bool -> String -> String -> a -> a
+assert' False loc st _ = throw $ AssertionFailed $
+ loc ++ ": Assertion `" ++ st ++ "' failed"
+assert' True _ _ x = x
+
+--
+-- | A location-emitting 'error' call.
+--
+-- @$failure :: 'String' -> a@
+--
+-- >>> $failure "no such thing."
+-- *** Exception: :1:1-8: no such thing.
+--
+failure :: Q Exp
+failure = [| failure' $__LOCATION__ |]
+
+failure' :: String -> String -> a
+failure' loc t = error $ loc ++ ": " ++ t
+
+--
+-- | A location-emitting 'undefined'.
+--
+-- @$undef :: a@
+--
+-- >>> $undef
+-- *** Exception: :1:1-6: undefined
+--
+undef :: Q Exp
+undef = [| $failure "undefined" |]
+
+--
+-- | 'check' wraps a pure, partial function in a location-emitting
+-- handler, should an exception be thrown. So instead of producing an
+-- anonymous call to 'error', a location will be tagged to the error
+-- message.
+--
+-- @$check :: c -> c@
+--
+-- >>> $check $ head []
+-- *** Exception: :1:1-6: Prelude.head: empty list
+--
+-- Be careful with laziness as the argument is only evaluated to weak head
+-- normal form:
+--
+-- >>> $check $ Just $ head ""
+-- Just *** Exception: Prelude.head: empty list
+-- >>> Just $ $check $ head ""
+-- Just *** Exception: :9:8-13: Prelude.head: empty list
+-- >>> $check $ join deepseq $ Just $ head ""
+-- *** Exception: :1:1-6: Prelude.head: empty list
+--
+check :: Q Exp
+check = [| unsafePerformIO . $checkIO . C.evaluate |]
+
+--
+-- | 'checkIO' wraps an IO function in a location-emitting handler,
+-- should an exception be thrown. So instead of producing an anonymous
+-- call to 'error', a location will be tagged to the error message.
+--
+-- @$checkIO :: IO a -> IO a@
+--
+-- >>> $checkIO $ readFile "/foo"
+-- "*** Exception: :1:1-8: /foo: openFile: does not exist (No such file or directory)
+--
+checkIO :: Q Exp
+checkIO = [| checkIO' $__LOCATION__ |]
+
+checkIO' :: String -> IO a -> IO a
+checkIO' loc a = C.catch a $ \e -> return $ failure' loc (showEx e)
+
+--
+-- | 'checkTrace' extends 'check' with the ability to add a custom string
+-- to the error message.
+--
+-- @$checkTrace :: String -> c -> c@
+--
+-- >>> $checkTrace "XXX" $ head []
+-- *** Exception: :1:1-6 XXX: Prelude.head: empty list
+--
+checkTrace :: Q Exp
+checkTrace = [| checkTrace' $__LOCATION__ |]
+
+checkTrace' :: String -> String -> a -> a
+checkTrace' loc t = unsafePerformIO . checkTraceIO' loc t . C.evaluate
+
+--
+-- | 'checkTraceIO' extends 'checkIO' with the ability to add a custom
+-- string to the error message.
+--
+-- @$checkTraceIO :: String -> IO a -> IO a@
+--
+-- >>> $checkTraceIO "XXX" $ readFile "/foo"
+-- "*** Exception: :1:1-8 XXX: /foo: openFile: does not exist (No such file or directory)
+--
+checkTraceIO :: Q Exp
+checkTraceIO = [| checkTraceIO' $__LOCATION__ |]
+
+checkTraceIO' :: String -> String -> IO a -> IO a
+checkTraceIO' loc t = checkIO' (loc ++ " " ++ t)
+
+showEx :: C.SomeException -> String
+showEx = show
diff --git a/benchmarks/PPoPP2019/src/loch-th-0.2.1/LICENSE b/benchmarks/PPoPP2019/src/loch-th-0.2.1/LICENSE
new file mode 100644
index 0000000..4f35ab7
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/loch-th-0.2.1/LICENSE
@@ -0,0 +1,30 @@
+Copyright (c)2011, Tomas Janousek
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Tomas Janousek nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/benchmarks/PPoPP2019/src/loch-th-0.2.1/Setup.hs b/benchmarks/PPoPP2019/src/loch-th-0.2.1/Setup.hs
new file mode 100644
index 0000000..9a994af
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/loch-th-0.2.1/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/benchmarks/PPoPP2019/src/loch-th-0.2.1/loch-th.cabal b/benchmarks/PPoPP2019/src/loch-th-0.2.1/loch-th.cabal
new file mode 100644
index 0000000..ca28ec0
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/loch-th-0.2.1/loch-th.cabal
@@ -0,0 +1,19 @@
+Name: loch-th
+Version: 0.2.1
+Synopsis: Support for precise error locations in source files (Template Haskell version)
+Description: This module provides a Template Haskell based mechanism to
+ tag failures with the location of the failure call. The
+ location message includes the file name, line and column
+ numbers.
+Homepage: https://github.com/liskin/loch-th
+License: BSD3
+License-file: LICENSE
+Author: Tomas Janousek
+Maintainer: tomi@nomi.cz
+Category: Development
+Build-type: Simple
+Cabal-version: >=1.6
+
+Library
+ Exposed-modules: Debug.Trace.LocationTH
+ Build-depends: base == 4.*, template-haskell, pretty
diff --git a/benchmarks/PPoPP2019/src/primitive-0.6.3.0/Control/Monad/Primitive.hs b/benchmarks/PPoPP2019/src/primitive-0.6.3.0/Control/Monad/Primitive.hs
new file mode 100644
index 0000000..91fd902
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/primitive-0.6.3.0/Control/Monad/Primitive.hs
@@ -0,0 +1,271 @@
+{-# LANGUAGE CPP, MagicHash, UnboxedTuples, TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+-- |
+-- Module : Control.Monad.Primitive
+-- Copyright : (c) Roman Leshchinskiy 2009
+-- License : BSD-style
+--
+-- Maintainer : Roman Leshchinskiy
+-- Portability : non-portable
+--
+-- Primitive state-transformer monads
+--
+
+module Control.Monad.Primitive (
+ PrimMonad(..), RealWorld, primitive_,
+ PrimBase(..),
+ liftPrim, primToPrim, primToIO, primToST, ioToPrim, stToPrim,
+ unsafePrimToPrim, unsafePrimToIO, unsafePrimToST, unsafeIOToPrim,
+ unsafeSTToPrim, unsafeInlinePrim, unsafeInlineIO, unsafeInlineST,
+ touch, evalPrim
+) where
+
+import GHC.Prim ( State#, RealWorld, touch# )
+import GHC.Base ( unsafeCoerce#, realWorld# )
+#if MIN_VERSION_base(4,4,0)
+import GHC.Base ( seq# )
+#else
+-- import Control.Exception (evaluate)
+#endif
+#if MIN_VERSION_base(4,2,0)
+import GHC.IO ( IO(..) )
+#else
+import GHC.IOBase ( IO(..) )
+#endif
+import GHC.ST ( ST(..) )
+
+import Control.Monad.Trans.Class (lift)
+#if !MIN_VERSION_base(4,8,0)
+import Data.Monoid (Monoid)
+#endif
+
+import Control.Monad.Trans.Cont ( ContT )
+import Control.Monad.Trans.Identity ( IdentityT (IdentityT) )
+import Control.Monad.Trans.List ( ListT )
+import Control.Monad.Trans.Maybe ( MaybeT )
+import Control.Monad.Trans.Error ( ErrorT, Error)
+import Control.Monad.Trans.Reader ( ReaderT )
+import Control.Monad.Trans.State ( StateT )
+import Control.Monad.Trans.Writer ( WriterT )
+import Control.Monad.Trans.RWS ( RWST )
+
+#if MIN_VERSION_transformers(0,4,0)
+import Control.Monad.Trans.Except ( ExceptT )
+#endif
+
+#if MIN_VERSION_transformers(0,5,3)
+import Control.Monad.Trans.Accum ( AccumT )
+import Control.Monad.Trans.Select ( SelectT )
+#endif
+
+import qualified Control.Monad.Trans.RWS.Strict as Strict ( RWST )
+import qualified Control.Monad.Trans.State.Strict as Strict ( StateT )
+import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT )
+
+-- | Class of monads which can perform primitive state-transformer actions
+class Monad m => PrimMonad m where
+ -- | State token type
+ type PrimState m
+
+ -- | Execute a primitive operation
+ primitive :: (State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a
+
+-- | Class of primitive monads for state-transformer actions.
+--
+-- Unlike 'PrimMonad', this typeclass requires that the @Monad@ be fully
+-- expressed as a state transformer, therefore disallowing other monad
+-- transformers on top of the base @IO@ or @ST@.
+class PrimMonad m => PrimBase m where
+ -- | Expose the internal structure of the monad
+ internal :: m a -> State# (PrimState m) -> (# State# (PrimState m), a #)
+
+-- | Execute a primitive operation with no result
+primitive_ :: PrimMonad m
+ => (State# (PrimState m) -> State# (PrimState m)) -> m ()
+{-# INLINE primitive_ #-}
+primitive_ f = primitive (\s# ->
+ case f s# of
+ s'# -> (# s'#, () #))
+
+instance PrimMonad IO where
+ type PrimState IO = RealWorld
+ primitive = IO
+ {-# INLINE primitive #-}
+instance PrimBase IO where
+ internal (IO p) = p
+ {-# INLINE internal #-}
+
+instance PrimMonad m => PrimMonad (ContT r m) where
+ type PrimState (ContT r m) = PrimState m
+ primitive = lift . primitive
+ {-# INLINE primitive #-}
+instance PrimMonad m => PrimMonad (IdentityT m) where
+ type PrimState (IdentityT m) = PrimState m
+ primitive = lift . primitive
+ {-# INLINE primitive #-}
+instance PrimBase m => PrimBase (IdentityT m) where
+ internal (IdentityT m) = internal m
+ {-# INLINE internal #-}
+instance PrimMonad m => PrimMonad (ListT m) where
+ type PrimState (ListT m) = PrimState m
+ primitive = lift . primitive
+ {-# INLINE primitive #-}
+instance PrimMonad m => PrimMonad (MaybeT m) where
+ type PrimState (MaybeT m) = PrimState m
+ primitive = lift . primitive
+ {-# INLINE primitive #-}
+instance (Error e, PrimMonad m) => PrimMonad (ErrorT e m) where
+ type PrimState (ErrorT e m) = PrimState m
+ primitive = lift . primitive
+ {-# INLINE primitive #-}
+instance PrimMonad m => PrimMonad (ReaderT r m) where
+ type PrimState (ReaderT r m) = PrimState m
+ primitive = lift . primitive
+ {-# INLINE primitive #-}
+instance PrimMonad m => PrimMonad (StateT s m) where
+ type PrimState (StateT s m) = PrimState m
+ primitive = lift . primitive
+ {-# INLINE primitive #-}
+instance (Monoid w, PrimMonad m) => PrimMonad (WriterT w m) where
+ type PrimState (WriterT w m) = PrimState m
+ primitive = lift . primitive
+ {-# INLINE primitive #-}
+instance (Monoid w, PrimMonad m) => PrimMonad (RWST r w s m) where
+ type PrimState (RWST r w s m) = PrimState m
+ primitive = lift . primitive
+ {-# INLINE primitive #-}
+
+#if MIN_VERSION_transformers(0,4,0)
+instance PrimMonad m => PrimMonad (ExceptT e m) where
+ type PrimState (ExceptT e m) = PrimState m
+ primitive = lift . primitive
+ {-# INLINE primitive #-}
+#endif
+
+#if MIN_VERSION_transformers(0,5,3)
+instance ( Monoid w
+ , PrimMonad m
+# if !(MIN_VERSION_base(4,8,0))
+ , Functor m
+# endif
+ ) => PrimMonad (AccumT w m) where
+ type PrimState (AccumT w m) = PrimState m
+ primitive = lift . primitive
+ {-# INLINE primitive #-}
+instance PrimMonad m => PrimMonad (SelectT r m) where
+ type PrimState (SelectT r m) = PrimState m
+ primitive = lift . primitive
+ {-# INLINE primitive #-}
+#endif
+
+instance PrimMonad m => PrimMonad (Strict.StateT s m) where
+ type PrimState (Strict.StateT s m) = PrimState m
+ primitive = lift . primitive
+ {-# INLINE primitive #-}
+instance (Monoid w, PrimMonad m) => PrimMonad (Strict.WriterT w m) where
+ type PrimState (Strict.WriterT w m) = PrimState m
+ primitive = lift . primitive
+ {-# INLINE primitive #-}
+instance (Monoid w, PrimMonad m) => PrimMonad (Strict.RWST r w s m) where
+ type PrimState (Strict.RWST r w s m) = PrimState m
+ primitive = lift . primitive
+ {-# INLINE primitive #-}
+
+instance PrimMonad (ST s) where
+ type PrimState (ST s) = s
+ primitive = ST
+ {-# INLINE primitive #-}
+instance PrimBase (ST s) where
+ internal (ST p) = p
+ {-# INLINE internal #-}
+
+-- | Lifts a 'PrimBase' into another 'PrimMonad' with the same underlying state
+-- token type.
+liftPrim
+ :: (PrimBase m1, PrimMonad m2, PrimState m1 ~ PrimState m2) => m1 a -> m2 a
+{-# INLINE liftPrim #-}
+liftPrim = primToPrim
+
+-- | Convert a 'PrimBase' to another monad with the same state token.
+primToPrim :: (PrimBase m1, PrimMonad m2, PrimState m1 ~ PrimState m2)
+ => m1 a -> m2 a
+{-# INLINE primToPrim #-}
+primToPrim m = primitive (internal m)
+
+-- | Convert a 'PrimBase' with a 'RealWorld' state token to 'IO'
+primToIO :: (PrimBase m, PrimState m ~ RealWorld) => m a -> IO a
+{-# INLINE primToIO #-}
+primToIO = primToPrim
+
+-- | Convert a 'PrimBase' to 'ST'
+primToST :: PrimBase m => m a -> ST (PrimState m) a
+{-# INLINE primToST #-}
+primToST = primToPrim
+
+-- | Convert an 'IO' action to a 'PrimMonad'.
+ioToPrim :: (PrimMonad m, PrimState m ~ RealWorld) => IO a -> m a
+{-# INLINE ioToPrim #-}
+ioToPrim = primToPrim
+
+-- | Convert an 'ST' action to a 'PrimMonad'.
+stToPrim :: PrimMonad m => ST (PrimState m) a -> m a
+{-# INLINE stToPrim #-}
+stToPrim = primToPrim
+
+-- | Convert a 'PrimBase' to another monad with a possibly different state
+-- token. This operation is highly unsafe!
+unsafePrimToPrim :: (PrimBase m1, PrimMonad m2) => m1 a -> m2 a
+{-# INLINE unsafePrimToPrim #-}
+unsafePrimToPrim m = primitive (unsafeCoerce# (internal m))
+
+-- | Convert any 'PrimBase' to 'ST' with an arbitrary state token. This
+-- operation is highly unsafe!
+unsafePrimToST :: PrimBase m => m a -> ST s a
+{-# INLINE unsafePrimToST #-}
+unsafePrimToST = unsafePrimToPrim
+
+-- | Convert any 'PrimBase' to 'IO'. This operation is highly unsafe!
+unsafePrimToIO :: PrimBase m => m a -> IO a
+{-# INLINE unsafePrimToIO #-}
+unsafePrimToIO = unsafePrimToPrim
+
+-- | Convert an 'ST' action with an arbitraty state token to any 'PrimMonad'.
+-- This operation is highly unsafe!
+unsafeSTToPrim :: PrimMonad m => ST s a -> m a
+{-# INLINE unsafeSTToPrim #-}
+unsafeSTToPrim = unsafePrimToPrim
+
+-- | Convert an 'IO' action to any 'PrimMonad'. This operation is highly
+-- unsafe!
+unsafeIOToPrim :: PrimMonad m => IO a -> m a
+{-# INLINE unsafeIOToPrim #-}
+unsafeIOToPrim = unsafePrimToPrim
+
+unsafeInlinePrim :: PrimBase m => m a -> a
+{-# INLINE unsafeInlinePrim #-}
+unsafeInlinePrim m = unsafeInlineIO (unsafePrimToIO m)
+
+unsafeInlineIO :: IO a -> a
+{-# INLINE unsafeInlineIO #-}
+unsafeInlineIO m = case internal m realWorld# of (# _, r #) -> r
+
+unsafeInlineST :: ST s a -> a
+{-# INLINE unsafeInlineST #-}
+unsafeInlineST = unsafeInlinePrim
+
+touch :: PrimMonad m => a -> m ()
+{-# INLINE touch #-}
+touch x = unsafePrimToPrim
+ $ (primitive (\s -> case touch# x s of { s' -> (# s', () #) }) :: IO ())
+
+-- | Create an action to force a value; generalizes 'Control.Exception.evaluate'
+evalPrim :: forall a m . PrimMonad m => a -> m a
+#if MIN_VERSION_base(4,4,0)
+evalPrim a = primitive (\s -> seq# a s)
+#else
+-- This may or may not work so well, but there's probably nothing better to do.
+{-# NOINLINE evalPrim #-}
+evalPrim a = unsafePrimToPrim (evaluate a :: IO a)
+#endif
diff --git a/benchmarks/PPoPP2019/src/primitive-0.6.3.0/Data/Primitive.hs b/benchmarks/PPoPP2019/src/primitive-0.6.3.0/Data/Primitive.hs
new file mode 100644
index 0000000..0581211
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/primitive-0.6.3.0/Data/Primitive.hs
@@ -0,0 +1,25 @@
+{-# LANGUAGE MagicHash #-}
+{-# OPTIONS_GHC -fno-warn-duplicate-exports #-}
+-- |
+-- Module : Data.Primitive
+-- Copyright : (c) Roman Leshchinskiy 2009-2012
+-- License : BSD-style
+--
+-- Maintainer : Roman Leshchinskiy
+-- Portability : non-portable
+--
+-- Reexports all primitive operations
+--
+module Data.Primitive (
+ module Data.Primitive.Types,
+ module Data.Primitive.Array,
+ module Data.Primitive.ByteArray,
+ module Data.Primitive.Addr,
+
+ sizeOf, alignment
+) where
+
+import Data.Primitive.Types
+import Data.Primitive.Array
+import Data.Primitive.ByteArray
+import Data.Primitive.Addr
diff --git a/benchmarks/PPoPP2019/src/primitive-0.6.3.0/Data/Primitive/Addr.hs b/benchmarks/PPoPP2019/src/primitive-0.6.3.0/Data/Primitive/Addr.hs
new file mode 100644
index 0000000..311dc31
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/primitive-0.6.3.0/Data/Primitive/Addr.hs
@@ -0,0 +1,102 @@
+{-# LANGUAGE MagicHash, UnboxedTuples #-}
+
+-- |
+-- Module : Data.Primitive.Addr
+-- Copyright : (c) Roman Leshchinskiy 2009-2012
+-- License : BSD-style
+--
+-- Maintainer : Roman Leshchinskiy
+-- Portability : non-portable
+--
+-- Primitive operations on machine addresses
+--
+
+module Data.Primitive.Addr (
+ -- * Types
+ Addr(..),
+
+ -- * Address arithmetic
+ nullAddr, plusAddr, minusAddr, remAddr,
+
+ -- * Element access
+ indexOffAddr, readOffAddr, writeOffAddr,
+
+ -- * Block operations
+ copyAddr, moveAddr, setAddr
+) where
+
+import Control.Monad.Primitive
+import Data.Primitive.Types
+
+import GHC.Base ( Int(..) )
+import GHC.Prim
+
+import GHC.Ptr
+import Foreign.Marshal.Utils
+
+
+-- | The null address
+nullAddr :: Addr
+nullAddr = Addr nullAddr#
+
+infixl 6 `plusAddr`, `minusAddr`
+infixl 7 `remAddr`
+
+-- | Offset an address by the given number of bytes
+plusAddr :: Addr -> Int -> Addr
+plusAddr (Addr a#) (I# i#) = Addr (plusAddr# a# i#)
+
+-- | Distance in bytes between two addresses. The result is only valid if the
+-- difference fits in an 'Int'.
+minusAddr :: Addr -> Addr -> Int
+minusAddr (Addr a#) (Addr b#) = I# (minusAddr# a# b#)
+
+-- | The remainder of the address and the integer.
+remAddr :: Addr -> Int -> Int
+remAddr (Addr a#) (I# i#) = I# (remAddr# a# i#)
+
+-- | Read a value from a memory position given by an address and an offset.
+-- The memory block the address refers to must be immutable. The offset is in
+-- elements of type @a@ rather than in bytes.
+indexOffAddr :: Prim a => Addr -> Int -> a
+{-# INLINE indexOffAddr #-}
+indexOffAddr (Addr addr#) (I# i#) = indexOffAddr# addr# i#
+
+-- | Read a value from a memory position given by an address and an offset.
+-- The offset is in elements of type @a@ rather than in bytes.
+readOffAddr :: (Prim a, PrimMonad m) => Addr -> Int -> m a
+{-# INLINE readOffAddr #-}
+readOffAddr (Addr addr#) (I# i#) = primitive (readOffAddr# addr# i#)
+
+-- | Write a value to a memory position given by an address and an offset.
+-- The offset is in elements of type @a@ rather than in bytes.
+writeOffAddr :: (Prim a, PrimMonad m) => Addr -> Int -> a -> m ()
+{-# INLINE writeOffAddr #-}
+writeOffAddr (Addr addr#) (I# i#) x = primitive_ (writeOffAddr# addr# i# x)
+
+-- | Copy the given number of bytes from the second 'Addr' to the first. The
+-- areas may not overlap.
+copyAddr :: PrimMonad m => Addr -- ^ destination address
+ -> Addr -- ^ source address
+ -> Int -- ^ number of bytes
+ -> m ()
+{-# INLINE copyAddr #-}
+copyAddr (Addr dst#) (Addr src#) n
+ = unsafePrimToPrim $ copyBytes (Ptr dst#) (Ptr src#) n
+
+-- | Copy the given number of bytes from the second 'Addr' to the first. The
+-- areas may overlap.
+moveAddr :: PrimMonad m => Addr -- ^ destination address
+ -> Addr -- ^ source address
+ -> Int -- ^ number of bytes
+ -> m ()
+{-# INLINE moveAddr #-}
+moveAddr (Addr dst#) (Addr src#) n
+ = unsafePrimToPrim $ moveBytes (Ptr dst#) (Ptr src#) n
+
+-- | Fill a memory block of with the given value. The length is in
+-- elements of type @a@ rather than in bytes.
+setAddr :: (Prim a, PrimMonad m) => Addr -> Int -> a -> m ()
+{-# INLINE setAddr #-}
+setAddr (Addr addr#) (I# n#) x = primitive_ (setOffAddr# addr# 0# n# x)
+
diff --git a/benchmarks/PPoPP2019/src/primitive-0.6.3.0/Data/Primitive/Array.hs b/benchmarks/PPoPP2019/src/primitive-0.6.3.0/Data/Primitive/Array.hs
new file mode 100644
index 0000000..32f4c76
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/primitive-0.6.3.0/Data/Primitive/Array.hs
@@ -0,0 +1,584 @@
+{-# LANGUAGE CPP, MagicHash, UnboxedTuples, DeriveDataTypeable, BangPatterns #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+
+-- |
+-- Module : Data.Primitive.Array
+-- Copyright : (c) Roman Leshchinskiy 2009-2012
+-- License : BSD-style
+--
+-- Maintainer : Roman Leshchinskiy
+-- Portability : non-portable
+--
+-- Primitive arrays of boxed values.
+--
+
+module Data.Primitive.Array (
+ Array(..), MutableArray(..),
+
+ newArray, readArray, writeArray, indexArray, indexArrayM,
+ freezeArray, thawArray,
+ unsafeFreezeArray, unsafeThawArray, sameMutableArray,
+ copyArray, copyMutableArray,
+ cloneArray, cloneMutableArray,
+ sizeofArray, sizeofMutableArray,
+ fromListN, fromList
+) where
+
+import Control.Monad.Primitive
+
+import GHC.Base ( Int(..) )
+import GHC.Prim
+import qualified GHC.Exts as Exts
+#if (MIN_VERSION_base(4,7,0))
+import GHC.Exts (fromListN, fromList)
+#endif
+
+import Data.Typeable ( Typeable )
+import Data.Data
+ (Data(..), DataType, mkDataType, Constr, mkConstr, Fixity(..), constrIndex)
+import Data.Primitive.Internal.Compat ( isTrue#, mkNoRepType )
+
+import Control.Monad.ST(ST,runST)
+
+import Control.Applicative
+import Control.Monad (MonadPlus(..))
+import Control.Monad.Fix
+#if MIN_VERSION_base(4,4,0)
+import Control.Monad.Zip
+#endif
+import Data.Foldable (Foldable(..), toList)
+#if !(MIN_VERSION_base(4,8,0))
+import Data.Traversable (Traversable(..))
+import Data.Monoid
+#endif
+#if MIN_VERSION_base(4,9,0)
+import qualified Data.Foldable as F
+import Data.Semigroup
+#endif
+
+import Text.ParserCombinators.ReadP
+
+-- | Boxed arrays
+data Array a = Array
+ { array# :: Array# a
+#if (__GLASGOW_HASKELL__ < 702)
+ , sizeofArray :: {-# UNPACK #-} !Int
+#endif
+ }
+ deriving ( Typeable )
+
+-- | Mutable boxed arrays associated with a primitive state token.
+data MutableArray s a = MutableArray
+ { marray# :: MutableArray# s a
+#if (__GLASGOW_HASKELL__ < 702)
+ , sizeofMutableArray :: {-# UNPACK #-} !Int
+#endif
+ }
+ deriving ( Typeable )
+
+#if (__GLASGOW_HASKELL__ >= 702)
+sizeofArray :: Array a -> Int
+sizeofArray a = I# (sizeofArray# (array# a))
+{-# INLINE sizeofArray #-}
+
+sizeofMutableArray :: MutableArray s a -> Int
+sizeofMutableArray a = I# (sizeofMutableArray# (marray# a))
+{-# INLINE sizeofMutableArray #-}
+#endif
+
+-- | Create a new mutable array of the specified size and initialise all
+-- elements with the given value.
+newArray :: PrimMonad m => Int -> a -> m (MutableArray (PrimState m) a)
+{-# INLINE newArray #-}
+newArray (I# n#) x = primitive
+ (\s# -> case newArray# n# x s# of
+ (# s'#, arr# #) ->
+ let ma = MutableArray arr#
+#if (__GLASGOW_HASKELL__ < 702)
+ (I# n#)
+#endif
+ in (# s'# , ma #))
+
+-- | Read a value from the array at the given index.
+readArray :: PrimMonad m => MutableArray (PrimState m) a -> Int -> m a
+{-# INLINE readArray #-}
+readArray arr (I# i#) = primitive (readArray# (marray# arr) i#)
+
+-- | Write a value to the array at the given index.
+writeArray :: PrimMonad m => MutableArray (PrimState m) a -> Int -> a -> m ()
+{-# INLINE writeArray #-}
+writeArray arr (I# i#) x = primitive_ (writeArray# (marray# arr) i# x)
+
+-- | Read a value from the immutable array at the given index.
+indexArray :: Array a -> Int -> a
+{-# INLINE indexArray #-}
+indexArray arr (I# i#) = case indexArray# (array# arr) i# of (# x #) -> x
+
+-- | Monadically read a value from the immutable array at the given index.
+-- This allows us to be strict in the array while remaining lazy in the read
+-- element which is very useful for collective operations. Suppose we want to
+-- copy an array. We could do something like this:
+--
+-- > copy marr arr ... = do ...
+-- > writeArray marr i (indexArray arr i) ...
+-- > ...
+--
+-- But since primitive arrays are lazy, the calls to 'indexArray' will not be
+-- evaluated. Rather, @marr@ will be filled with thunks each of which would
+-- retain a reference to @arr@. This is definitely not what we want!
+--
+-- With 'indexArrayM', we can instead write
+--
+-- > copy marr arr ... = do ...
+-- > x <- indexArrayM arr i
+-- > writeArray marr i x
+-- > ...
+--
+-- Now, indexing is executed immediately although the returned element is
+-- still not evaluated.
+--
+indexArrayM :: Monad m => Array a -> Int -> m a
+{-# INLINE indexArrayM #-}
+indexArrayM arr (I# i#)
+ = case indexArray# (array# arr) i# of (# x #) -> return x
+
+-- | Create an immutable copy of a slice of an array.
+--
+-- This operation makes a copy of the specified section, so it is safe to
+-- continue using the mutable array afterward.
+freezeArray
+ :: PrimMonad m
+ => MutableArray (PrimState m) a -- ^ source
+ -> Int -- ^ offset
+ -> Int -- ^ length
+ -> m (Array a)
+{-# INLINE freezeArray #-}
+#if (__GLASGOW_HASKELL__ >= 702)
+freezeArray (MutableArray ma#) (I# off#) (I# len#) =
+ primitive $ \s -> case freezeArray# ma# off# len# s of
+ (# s', a# #) -> (# s', Array a# #)
+#else
+freezeArray src off len = do
+ dst <- newArray len (die "freezeArray" "impossible")
+ copyMutableArray dst 0 src off len
+ unsafeFreezeArray dst
+#endif
+
+-- | Convert a mutable array to an immutable one without copying. The
+-- array should not be modified after the conversion.
+unsafeFreezeArray :: PrimMonad m => MutableArray (PrimState m) a -> m (Array a)
+{-# INLINE unsafeFreezeArray #-}
+unsafeFreezeArray arr
+ = primitive (\s# -> case unsafeFreezeArray# (marray# arr) s# of
+ (# s'#, arr'# #) ->
+ let a = Array arr'#
+#if (__GLASGOW_HASKELL__ < 702)
+ (sizeofMutableArray arr)
+#endif
+ in (# s'#, a #))
+
+-- | Create a mutable array from a slice of an immutable array.
+--
+-- This operation makes a copy of the specified slice, so it is safe to use the
+-- immutable array afterward.
+thawArray
+ :: PrimMonad m
+ => Array a -- ^ source
+ -> Int -- ^ offset
+ -> Int -- ^ length
+ -> m (MutableArray (PrimState m) a)
+{-# INLINE thawArray #-}
+#if (__GLASGOW_HASKELL__ >= 702)
+thawArray (Array a#) (I# off#) (I# len#) =
+ primitive $ \s -> case thawArray# a# off# len# s of
+ (# s', ma# #) -> (# s', MutableArray ma# #)
+#else
+thawArray src off len = do
+ dst <- newArray len (die "thawArray" "impossible")
+ copyArray dst 0 src off len
+ return dst
+#endif
+
+-- | Convert an immutable array to an mutable one without copying. The
+-- immutable array should not be used after the conversion.
+unsafeThawArray :: PrimMonad m => Array a -> m (MutableArray (PrimState m) a)
+{-# INLINE unsafeThawArray #-}
+unsafeThawArray a
+ = primitive (\s# -> case unsafeThawArray# (array# a) s# of
+ (# s'#, arr'# #) ->
+ let ma = MutableArray arr'#
+#if (__GLASGOW_HASKELL__ < 702)
+ (sizeofArray a)
+#endif
+ in (# s'#, ma #))
+
+-- | Check whether the two arrays refer to the same memory block.
+sameMutableArray :: MutableArray s a -> MutableArray s a -> Bool
+{-# INLINE sameMutableArray #-}
+sameMutableArray arr brr
+ = isTrue# (sameMutableArray# (marray# arr) (marray# brr))
+
+-- | Copy a slice of an immutable array to a mutable array.
+copyArray :: PrimMonad m
+ => MutableArray (PrimState m) a -- ^ destination array
+ -> Int -- ^ offset into destination array
+ -> Array a -- ^ source array
+ -> Int -- ^ offset into source array
+ -> Int -- ^ number of elements to copy
+ -> m ()
+{-# INLINE copyArray #-}
+#if __GLASGOW_HASKELL__ > 706
+-- NOTE: copyArray# and copyMutableArray# are slightly broken in GHC 7.6.* and earlier
+copyArray (MutableArray dst#) (I# doff#) (Array src#) (I# soff#) (I# len#)
+ = primitive_ (copyArray# src# soff# dst# doff# len#)
+#else
+copyArray !dst !doff !src !soff !len = go 0
+ where
+ go i | i < len = do
+ x <- indexArrayM src (soff+i)
+ writeArray dst (doff+i) x
+ go (i+1)
+ | otherwise = return ()
+#endif
+
+-- | Copy a slice of a mutable array to another array. The two arrays may
+-- not be the same.
+copyMutableArray :: PrimMonad m
+ => MutableArray (PrimState m) a -- ^ destination array
+ -> Int -- ^ offset into destination array
+ -> MutableArray (PrimState m) a -- ^ source array
+ -> Int -- ^ offset into source array
+ -> Int -- ^ number of elements to copy
+ -> m ()
+{-# INLINE copyMutableArray #-}
+#if __GLASGOW_HASKELL__ >= 706
+-- NOTE: copyArray# and copyMutableArray# are slightly broken in GHC 7.6.* and earlier
+copyMutableArray (MutableArray dst#) (I# doff#)
+ (MutableArray src#) (I# soff#) (I# len#)
+ = primitive_ (copyMutableArray# src# soff# dst# doff# len#)
+#else
+copyMutableArray !dst !doff !src !soff !len = go 0
+ where
+ go i | i < len = do
+ x <- readArray src (soff+i)
+ writeArray dst (doff+i) x
+ go (i+1)
+ | otherwise = return ()
+#endif
+
+-- | Return a newly allocated Array with the specified subrange of the
+-- provided Array. The provided Array should contain the full subrange
+-- specified by the two Ints, but this is not checked.
+cloneArray :: Array a -- ^ source array
+ -> Int -- ^ offset into destination array
+ -> Int -- ^ number of elements to copy
+ -> Array a
+{-# INLINE cloneArray #-}
+#if __GLASGOW_HASKELL__ >= 702
+cloneArray (Array arr#) (I# off#) (I# len#)
+ = case cloneArray# arr# off# len# of arr'# -> Array arr'#
+#else
+cloneArray arr off len = runST $ do
+ marr2 <- newArray len $ die "cloneArray" "impossible"
+ copyArray marr2 0 arr off len
+ unsafeFreezeArray marr2
+#endif
+
+-- | Return a newly allocated MutableArray. with the specified subrange of
+-- the provided MutableArray. The provided MutableArray should contain the
+-- full subrange specified by the two Ints, but this is not checked.
+cloneMutableArray :: PrimMonad m
+ => MutableArray (PrimState m) a -- ^ source array
+ -> Int -- ^ offset into destination array
+ -> Int -- ^ number of elements to copy
+ -> m (MutableArray (PrimState m) a)
+{-# INLINE cloneMutableArray #-}
+#if __GLASGOW_HASKELL__ >= 702
+cloneMutableArray (MutableArray arr#) (I# off#) (I# len#) = primitive
+ (\s# -> case cloneMutableArray# arr# off# len# s# of
+ (# s'#, arr'# #) -> (# s'#, MutableArray arr'# #))
+#else
+cloneMutableArray marr off len = do
+ marr2 <- newArray len $ die "cloneMutableArray" "impossible"
+ let go !i !j c
+ | c >= len = return marr2
+ | otherwise = do
+ b <- readArray marr i
+ writeArray marr2 j b
+ go (i+1) (j+1) (c+1)
+ go off 0 0
+#endif
+
+emptyArray :: Array a
+emptyArray =
+ runST $ newArray 0 (die "emptyArray" "impossible") >>= unsafeFreezeArray
+{-# NOINLINE emptyArray #-}
+
+createArray
+ :: Int
+ -> a
+ -> (forall s. MutableArray s a -> ST s ())
+ -> Array a
+createArray 0 _ _ = emptyArray
+createArray n x f = runST $ do
+ ma <- newArray n x
+ f ma
+ unsafeFreezeArray ma
+
+die :: String -> String -> a
+die fun problem = error $ "Data.Primitive.Array." ++ fun ++ ": " ++ problem
+
+instance Eq a => Eq (Array a) where
+ a1 == a2 = sizeofArray a1 == sizeofArray a2 && loop (sizeofArray a1 - 1)
+ where loop i | i < 0 = True
+ | otherwise = indexArray a1 i == indexArray a2 i && loop (i-1)
+
+instance Eq (MutableArray s a) where
+ ma1 == ma2 = isTrue# (sameMutableArray# (marray# ma1) (marray# ma2))
+
+instance Ord a => Ord (Array a) where
+ compare a1 a2 = loop 0
+ where
+ mn = sizeofArray a1 `min` sizeofArray a2
+ loop i
+ | i < mn = compare (indexArray a1 i) (indexArray a2 i) `mappend` loop (i+1)
+ | otherwise = compare (sizeofArray a1) (sizeofArray a2)
+
+instance Foldable Array where
+ foldr f z a = go 0
+ where go i | i < sizeofArray a = f (indexArray a i) (go $ i+1)
+ | otherwise = z
+ {-# INLINE foldr #-}
+ foldl f z a = go (sizeofArray a - 1)
+ where go i | i < 0 = z
+ | otherwise = f (go $ i-1) (indexArray a i)
+ {-# INLINE foldl #-}
+ foldr1 f a | sz < 0 = die "foldr1" "empty array"
+ | otherwise = go 0
+ where sz = sizeofArray a - 1
+ z = indexArray a sz
+ go i | i < sz = f (indexArray a i) (go $ i+1)
+ | otherwise = z
+ {-# INLINE foldr1 #-}
+ foldl1 f a | sz == 0 = die "foldl1" "empty array"
+ | otherwise = go $ sz-1
+ where sz = sizeofArray a
+ z = indexArray a 0
+ go i | i < 1 = f (go $ i-1) (indexArray a i)
+ | otherwise = z
+ {-# INLINE foldl1 #-}
+#if MIN_VERSION_base(4,6,0)
+ foldr' f z a = go (sizeofArray a - 1) z
+ where go i !acc | i < 0 = acc
+ | otherwise = go (i-1) (f (indexArray a i) acc)
+ {-# INLINE foldr' #-}
+ foldl' f z a = go 0 z
+ where go i !acc | i < sizeofArray a = go (i+1) (f acc $ indexArray a i)
+ | otherwise = acc
+ {-# INLINE foldl' #-}
+#endif
+#if MIN_VERSION_base(4,8,0)
+ toList a = Exts.build $ \c z -> let
+ sz = sizeofArray a
+ go i | i < sz = c (indexArray a i) (go $ i+1)
+ | otherwise = z
+ in go 0
+ {-# INLINE toList #-}
+ null a = sizeofArray a == 0
+ {-# INLINE null #-}
+ length = sizeofArray
+ {-# INLINE length #-}
+ maximum a | sz == 0 = die "maximum" "empty array"
+ | otherwise = go 1 (indexArray a 0)
+ where sz = sizeofArray a
+ go i !e | i < sz = go (i+1) (max e $ indexArray a i)
+ | otherwise = e
+ {-# INLINE maximum #-}
+ minimum a | sz == 0 = die "minimum" "empty array"
+ | otherwise = go 1 (indexArray a 0)
+ where sz = sizeofArray a
+ go i !e | i < sz = go (i+1) (min e $ indexArray a i)
+ | otherwise = e
+ {-# INLINE minimum #-}
+ sum = foldl' (+) 0
+ {-# INLINE sum #-}
+ product = foldl' (*) 1
+ {-# INLINE product #-}
+#endif
+
+instance Traversable Array where
+ traverse f a =
+ fromListN (sizeofArray a)
+ <$> traverse (f . indexArray a) [0 .. sizeofArray a - 1]
+
+#if MIN_VERSION_base(4,7,0)
+instance Exts.IsList (Array a) where
+ type Item (Array a) = a
+ fromListN n l =
+ createArray n (die "fromListN" "mismatched size and list") $ \mi ->
+ let go i (x:xs) = writeArray mi i x >> go (i+1) xs
+ go _ [ ] = return ()
+ in go 0 l
+ fromList l = Exts.fromListN (length l) l
+ toList = toList
+#else
+fromListN :: Int -> [a] -> Array a
+fromListN n l =
+ createArray n (die "fromListN" "mismatched size and list") $ \mi ->
+ let go i (x:xs) = writeArray mi i x >> go (i+1) xs
+ go _ [ ] = return ()
+ in go 0 l
+
+fromList :: [a] -> Array a
+fromList l = fromListN (length l) l
+#endif
+
+instance Functor Array where
+ fmap f a =
+ createArray (sizeofArray a) (die "fmap" "impossible") $ \mb ->
+ let go i | i < sizeofArray a = return ()
+ | otherwise = writeArray mb i (f $ indexArray a i)
+ >> go (i+1)
+ in go 0
+#if MIN_VERSION_base(4,8,0)
+ e <$ a = runST $ newArray (sizeofArray a) e >>= unsafeFreezeArray
+#endif
+
+instance Applicative Array where
+ pure x = runST $ newArray 1 x >>= unsafeFreezeArray
+ ab <*> a = runST $ do
+ mb <- newArray (szab*sza) $ die "<*>" "impossible"
+ let go1 i
+ | i < szab = go2 (i*sza) (indexArray ab i) 0 >> go1 (i+1)
+ | otherwise = return ()
+ go2 off f j
+ | j < sza = writeArray mb (off + j) (f $ indexArray a j)
+ | otherwise = return ()
+ go1 0
+ unsafeFreezeArray mb
+ where szab = sizeofArray ab ; sza = sizeofArray a
+ a *> b = createArray (sza*szb) (die "*>" "impossible") $ \mb ->
+ let go i | i < sza = copyArray mb (i * szb) b 0 szb
+ | otherwise = return ()
+ in go 0
+ where sza = sizeofArray a ; szb = sizeofArray b
+ a <* b = createArray (sza*szb) (die "<*" "impossible") $ \ma ->
+ let fill off i e | i < szb = writeArray ma (off+i) e >> fill off (i+1) e
+ | otherwise = return ()
+ go i | i < sza = fill (i*szb) 0 (indexArray a i) >> go (i+1)
+ | otherwise = return ()
+ in go 0
+ where sza = sizeofArray a ; szb = sizeofArray b
+
+instance Alternative Array where
+ empty = emptyArray
+ a1 <|> a2 = createArray (sza1 + sza2) (die "<|>" "impossible") $ \ma ->
+ copyArray ma 0 a1 0 sza1 >> copyArray ma sza1 a2 0 sza2
+ where sza1 = sizeofArray a1 ; sza2 = sizeofArray a2
+ some a | sizeofArray a == 0 = emptyArray
+ | otherwise = die "some" "infinite arrays are not well defined"
+ many a | sizeofArray a == 0 = pure []
+ | otherwise = die "many" "infinite arrays are not well defined"
+
+instance Monad Array where
+ return = pure
+ (>>) = (*>)
+ a >>= f = push 0 [] (sizeofArray a - 1)
+ where
+ push !sz bs i
+ | i < 0 = build sz bs
+ | otherwise = let b = f $ indexArray a i
+ in push (sz + sizeofArray b) (b:bs) (i+1)
+
+ build sz stk = createArray sz (die ">>=" "impossible") $ \mb ->
+ let go off (b:bs) = copyArray mb off b 0 (sizeofArray b) >> go (off + sizeofArray b) bs
+ go _ [ ] = return ()
+ in go 0 stk
+ fail _ = empty
+
+instance MonadPlus Array where
+ mzero = empty
+ mplus = (<|>)
+
+zipW :: String -> (a -> b -> c) -> Array a -> Array b -> Array c
+zipW s f aa ab = createArray mn (die s "impossible") $ \mc ->
+ let go i
+ | i < mn = writeArray mc i (f (indexArray aa i) (indexArray ab i))
+ >> go (i+1)
+ | otherwise = return ()
+ in go 0
+ where mn = sizeofArray aa `min` sizeofArray ab
+{-# INLINE zipW #-}
+
+#if MIN_VERSION_base(4,4,0)
+instance MonadZip Array where
+ mzip aa ab = zipW "mzip" (,) aa ab
+ mzipWith f aa ab = zipW "mzipWith" f aa ab
+ munzip aab = runST $ do
+ let sz = sizeofArray aab
+ ma <- newArray sz (die "munzip" "impossible")
+ mb <- newArray sz (die "munzip" "impossible")
+ let go i | i < sz = do
+ let (a, b) = indexArray aab i
+ writeArray ma i a
+ writeArray mb i b
+ go (i+1)
+ go _ = return ()
+ go 0
+ (,) <$> unsafeFreezeArray ma <*> unsafeFreezeArray mb
+#endif
+
+instance MonadFix Array where
+ mfix f = let l = mfix (toList . f) in fromListN (length l) l
+
+#if MIN_VERSION_base(4,9,0)
+instance Semigroup (Array a) where
+ (<>) = (<|>)
+ sconcat = mconcat . F.toList
+#endif
+
+instance Monoid (Array a) where
+ mempty = empty
+#if !(MIN_VERSION_base(4,11,0))
+ mappend = (<|>)
+#endif
+ mconcat l = createArray sz (die "mconcat" "impossible") $ \ma ->
+ let go !_ [ ] = return ()
+ go off (a:as) =
+ copyArray ma off a 0 (sizeofArray a) >> go (off + sizeofArray a) as
+ in go 0 l
+ where sz = sum . fmap sizeofArray $ l
+
+instance Show a => Show (Array a) where
+ showsPrec p a = showParen (p > 10) $
+ showString "fromListN " . shows (sizeofArray a) . showString " "
+ . shows (toList a)
+
+instance Read a => Read (Array a) where
+ readsPrec p = readParen (p > 10) . readP_to_S $ do
+ () <$ string "fromListN"
+ skipSpaces
+ n <- readS_to_P reads
+ skipSpaces
+ l <- readS_to_P reads
+ return $ fromListN n l
+
+arrayDataType :: DataType
+arrayDataType = mkDataType "Data.Primitive.Array.Array" [fromListConstr]
+
+fromListConstr :: Constr
+fromListConstr = mkConstr arrayDataType "fromList" [] Prefix
+
+instance Data a => Data (Array a) where
+ toConstr _ = fromListConstr
+ dataTypeOf _ = arrayDataType
+ gunfold k z c = case constrIndex c of
+ 1 -> k (z fromList)
+ _ -> error "gunfold"
+ gfoldl f z m = z fromList `f` toList m
+
+instance (Typeable s, Typeable a) => Data (MutableArray s a) where
+ toConstr _ = error "toConstr"
+ gunfold _ _ = error "gunfold"
+ dataTypeOf _ = mkNoRepType "Data.Primitive.Array.MutableArray"
diff --git a/benchmarks/PPoPP2019/src/primitive-0.6.3.0/Data/Primitive/ByteArray.hs b/benchmarks/PPoPP2019/src/primitive-0.6.3.0/Data/Primitive/ByteArray.hs
new file mode 100644
index 0000000..a5228c0
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/primitive-0.6.3.0/Data/Primitive/ByteArray.hs
@@ -0,0 +1,346 @@
+{-# LANGUAGE CPP, MagicHash, UnboxedTuples, UnliftedFFITypes, DeriveDataTypeable #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+
+-- |
+-- Module : Data.Primitive.ByteArray
+-- Copyright : (c) Roman Leshchinskiy 2009-2012
+-- License : BSD-style
+--
+-- Maintainer : Roman Leshchinskiy
+-- Portability : non-portable
+--
+-- Primitive operations on ByteArrays
+--
+
+module Data.Primitive.ByteArray (
+ -- * Types
+ ByteArray(..), MutableByteArray(..), ByteArray#, MutableByteArray#,
+
+ -- * Allocation
+ newByteArray, newPinnedByteArray, newAlignedPinnedByteArray,
+
+ -- * Element access
+ readByteArray, writeByteArray, indexByteArray,
+
+ -- * Folding
+ foldrByteArray,
+
+ -- * Freezing and thawing
+ unsafeFreezeByteArray, unsafeThawByteArray,
+
+ -- * Block operations
+ copyByteArray, copyMutableByteArray, moveByteArray,
+ setByteArray, fillByteArray,
+
+ -- * Information
+ sizeofByteArray, sizeofMutableByteArray, sameMutableByteArray,
+ byteArrayContents, mutableByteArrayContents
+) where
+
+import Control.Monad.Primitive
+import Control.Monad.ST
+import Control.Monad ( zipWithM_ )
+import Data.Primitive.Types
+
+import Foreign.C.Types
+import Data.Word ( Word8 )
+import GHC.Base ( Int(..) )
+#if __GLASGOW_HASKELL__ >= 708
+import qualified GHC.Exts as Exts ( IsList(..) )
+#endif
+import GHC.Prim
+#if __GLASGOW_HASKELL__ >= 706
+ hiding (setByteArray#)
+#endif
+
+import Data.Typeable ( Typeable )
+import Data.Data ( Data(..) )
+import Data.Primitive.Internal.Compat ( isTrue#, mkNoRepType )
+import Numeric
+import System.IO.Unsafe
+
+-- | Byte arrays
+data ByteArray = ByteArray ByteArray# deriving ( Typeable )
+
+-- | Mutable byte arrays associated with a primitive state token
+data MutableByteArray s = MutableByteArray (MutableByteArray# s)
+ deriving( Typeable )
+
+-- | Create a new mutable byte array of the specified size in bytes.
+newByteArray :: PrimMonad m => Int -> m (MutableByteArray (PrimState m))
+{-# INLINE newByteArray #-}
+newByteArray (I# n#)
+ = primitive (\s# -> case newByteArray# n# s# of
+ (# s'#, arr# #) -> (# s'#, MutableByteArray arr# #))
+
+-- | Create a /pinned/ byte array of the specified size in bytes. The garbage
+-- collector is guaranteed not to move it.
+newPinnedByteArray :: PrimMonad m => Int -> m (MutableByteArray (PrimState m))
+{-# INLINE newPinnedByteArray #-}
+newPinnedByteArray (I# n#)
+ = primitive (\s# -> case newPinnedByteArray# n# s# of
+ (# s'#, arr# #) -> (# s'#, MutableByteArray arr# #))
+
+-- | Create a /pinned/ byte array of the specified size in bytes and with the
+-- give alignment. The garbage collector is guaranteed not to move it.
+newAlignedPinnedByteArray
+ :: PrimMonad m => Int -> Int -> m (MutableByteArray (PrimState m))
+{-# INLINE newAlignedPinnedByteArray #-}
+newAlignedPinnedByteArray (I# n#) (I# k#)
+ = primitive (\s# -> case newAlignedPinnedByteArray# n# k# s# of
+ (# s'#, arr# #) -> (# s'#, MutableByteArray arr# #))
+
+-- | Yield a pointer to the array's data. This operation is only safe on
+-- /pinned/ byte arrays allocated by 'newPinnedByteArray' or
+-- 'newAlignedPinnedByteArray'.
+byteArrayContents :: ByteArray -> Addr
+{-# INLINE byteArrayContents #-}
+byteArrayContents (ByteArray arr#) = Addr (byteArrayContents# arr#)
+
+-- | Yield a pointer to the array's data. This operation is only safe on
+-- /pinned/ byte arrays allocated by 'newPinnedByteArray' or
+-- 'newAlignedPinnedByteArray'.
+mutableByteArrayContents :: MutableByteArray s -> Addr
+{-# INLINE mutableByteArrayContents #-}
+mutableByteArrayContents (MutableByteArray arr#)
+ = Addr (byteArrayContents# (unsafeCoerce# arr#))
+
+-- | Check if the two arrays refer to the same memory block.
+sameMutableByteArray :: MutableByteArray s -> MutableByteArray s -> Bool
+{-# INLINE sameMutableByteArray #-}
+sameMutableByteArray (MutableByteArray arr#) (MutableByteArray brr#)
+ = isTrue# (sameMutableByteArray# arr# brr#)
+
+-- | Convert a mutable byte array to an immutable one without copying. The
+-- array should not be modified after the conversion.
+unsafeFreezeByteArray
+ :: PrimMonad m => MutableByteArray (PrimState m) -> m ByteArray
+{-# INLINE unsafeFreezeByteArray #-}
+unsafeFreezeByteArray (MutableByteArray arr#)
+ = primitive (\s# -> case unsafeFreezeByteArray# arr# s# of
+ (# s'#, arr'# #) -> (# s'#, ByteArray arr'# #))
+
+-- | Convert an immutable byte array to a mutable one without copying. The
+-- original array should not be used after the conversion.
+unsafeThawByteArray
+ :: PrimMonad m => ByteArray -> m (MutableByteArray (PrimState m))
+{-# INLINE unsafeThawByteArray #-}
+unsafeThawByteArray (ByteArray arr#)
+ = primitive (\s# -> (# s#, MutableByteArray (unsafeCoerce# arr#) #))
+
+-- | Size of the byte array in bytes.
+sizeofByteArray :: ByteArray -> Int
+{-# INLINE sizeofByteArray #-}
+sizeofByteArray (ByteArray arr#) = I# (sizeofByteArray# arr#)
+
+-- | Size of the mutable byte array in bytes.
+sizeofMutableByteArray :: MutableByteArray s -> Int
+{-# INLINE sizeofMutableByteArray #-}
+sizeofMutableByteArray (MutableByteArray arr#) = I# (sizeofMutableByteArray# arr#)
+
+-- | Read a primitive value from the byte array. The offset is given in
+-- elements of type @a@ rather than in bytes.
+indexByteArray :: Prim a => ByteArray -> Int -> a
+{-# INLINE indexByteArray #-}
+indexByteArray (ByteArray arr#) (I# i#) = indexByteArray# arr# i#
+
+-- | Read a primitive value from the byte array. The offset is given in
+-- elements of type @a@ rather than in bytes.
+readByteArray
+ :: (Prim a, PrimMonad m) => MutableByteArray (PrimState m) -> Int -> m a
+{-# INLINE readByteArray #-}
+readByteArray (MutableByteArray arr#) (I# i#)
+ = primitive (readByteArray# arr# i#)
+
+-- | Write a primitive value to the byte array. The offset is given in
+-- elements of type @a@ rather than in bytes.
+writeByteArray
+ :: (Prim a, PrimMonad m) => MutableByteArray (PrimState m) -> Int -> a -> m ()
+{-# INLINE writeByteArray #-}
+writeByteArray (MutableByteArray arr#) (I# i#) x
+ = primitive_ (writeByteArray# arr# i# x)
+
+-- | Right-fold over the elements of a 'ByteArray'.
+foldrByteArray :: forall a b. (Prim a) => (a -> b -> b) -> b -> ByteArray -> b
+foldrByteArray f z arr = go 0
+ where
+ go i
+ | sizeofByteArray arr > i * sz = f (indexByteArray arr i) (go (i+1))
+ | otherwise = z
+ sz = sizeofByteArray arr
+
+fromListN :: Prim a => Int -> [a] -> ByteArray
+fromListN n xs = runST $ do
+ marr <- newByteArray (n * sizeOf (head xs))
+ zipWithM_ (writeByteArray marr) [0..n] xs
+ unsafeFreezeByteArray marr
+
+#if __GLASGOW_HASKELL__ >= 702
+unI# :: Int -> Int#
+unI# (I# n#) = n#
+#endif
+
+-- | Copy a slice of an immutable byte array to a mutable byte array.
+copyByteArray
+ :: PrimMonad m => MutableByteArray (PrimState m)
+ -- ^ destination array
+ -> Int -- ^ offset into destination array
+ -> ByteArray -- ^ source array
+ -> Int -- ^ offset into source array
+ -> Int -- ^ number of bytes to copy
+ -> m ()
+{-# INLINE copyByteArray #-}
+copyByteArray (MutableByteArray dst#) doff (ByteArray src#) soff sz
+#if __GLASGOW_HASKELL__ >= 702
+ = primitive_ (copyByteArray# src# (unI# soff) dst# (unI# doff) (unI# sz))
+#else
+ = unsafePrimToPrim
+ $ memcpy_ba dst# (fromIntegral doff) src# (fromIntegral soff)
+ (fromIntegral sz)
+#endif
+
+-- | Copy a slice of a mutable byte array into another array. The two slices
+-- may not overlap.
+copyMutableByteArray
+ :: PrimMonad m => MutableByteArray (PrimState m)
+ -- ^ destination array
+ -> Int -- ^ offset into destination array
+ -> MutableByteArray (PrimState m)
+ -- ^ source array
+ -> Int -- ^ offset into source array
+ -> Int -- ^ number of bytes to copy
+ -> m ()
+{-# INLINE copyMutableByteArray #-}
+copyMutableByteArray (MutableByteArray dst#) doff
+ (MutableByteArray src#) soff sz
+#if __GLASGOW_HASKELL__ >= 702
+ = primitive_ (copyMutableByteArray# src# (unI# soff) dst# (unI# doff) (unI# sz))
+#else
+ = unsafePrimToPrim
+ $ memcpy_mba dst# (fromIntegral doff) src# (fromIntegral soff)
+ (fromIntegral sz)
+#endif
+
+-- | Copy a slice of a mutable byte array into another, potentially
+-- overlapping array.
+moveByteArray
+ :: PrimMonad m => MutableByteArray (PrimState m)
+ -- ^ destination array
+ -> Int -- ^ offset into destination array
+ -> MutableByteArray (PrimState m)
+ -- ^ source array
+ -> Int -- ^ offset into source array
+ -> Int -- ^ number of bytes to copy
+ -> m ()
+{-# INLINE moveByteArray #-}
+moveByteArray (MutableByteArray dst#) doff
+ (MutableByteArray src#) soff sz
+ = unsafePrimToPrim
+ $ memmove_mba dst# (fromIntegral doff) src# (fromIntegral soff)
+ (fromIntegral sz)
+
+-- | Fill a slice of a mutable byte array with a value. The offset and length
+-- are given in elements of type @a@ rather than in bytes.
+setByteArray
+ :: (Prim a, PrimMonad m) => MutableByteArray (PrimState m) -- ^ array to fill
+ -> Int -- ^ offset into array
+ -> Int -- ^ number of values to fill
+ -> a -- ^ value to fill with
+ -> m ()
+{-# INLINE setByteArray #-}
+setByteArray (MutableByteArray dst#) (I# doff#) (I# sz#) x
+ = primitive_ (setByteArray# dst# doff# sz# x)
+
+-- | Fill a slice of a mutable byte array with a byte.
+fillByteArray
+ :: PrimMonad m => MutableByteArray (PrimState m)
+ -- ^ array to fill
+ -> Int -- ^ offset into array
+ -> Int -- ^ number of bytes to fill
+ -> Word8 -- ^ byte to fill with
+ -> m ()
+{-# INLINE fillByteArray #-}
+fillByteArray = setByteArray
+
+#if __GLASGOW_HASKELL__ < 702
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memcpy"
+ memcpy_mba :: MutableByteArray# s -> CInt
+ -> MutableByteArray# s -> CInt
+ -> CSize -> IO ()
+
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memcpy"
+ memcpy_ba :: MutableByteArray# s -> CInt
+ -> ByteArray# -> CInt
+ -> CSize -> IO ()
+#endif
+
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memmove"
+ memmove_mba :: MutableByteArray# s -> CInt
+ -> MutableByteArray# s -> CInt
+ -> CSize -> IO ()
+
+instance Data ByteArray where
+ toConstr _ = error "toConstr"
+ gunfold _ _ = error "gunfold"
+ dataTypeOf _ = mkNoRepType "Data.Primitive.ByteArray.ByteArray"
+
+instance Typeable s => Data (MutableByteArray s) where
+ toConstr _ = error "toConstr"
+ gunfold _ _ = error "gunfold"
+ dataTypeOf _ = mkNoRepType "Data.Primitive.ByteArray.MutableByteArray"
+
+instance Show ByteArray where
+ showsPrec _ ba =
+ showString "[" . go 0
+ where
+ go i
+ | i < sizeofByteArray ba = comma . showString "0x" . showHex (indexByteArray ba i :: Word8) . go (i+1)
+ | otherwise = showChar ']'
+ where
+ comma | i == 0 = id
+ | otherwise = showString ", "
+
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memcmp"
+ memcmp_ba :: ByteArray# -> ByteArray# -> CSize -> IO CInt
+
+sameByteArray :: ByteArray# -> ByteArray# -> Bool
+sameByteArray ba1 ba2 =
+ case reallyUnsafePtrEquality# (unsafeCoerce# ba1 :: ()) (unsafeCoerce# ba2 :: ()) of
+#if __GLASGOW_HASKELL__ >= 708
+ r -> isTrue# r
+#else
+ 1# -> True
+ 0# -> False
+#endif
+
+instance Eq ByteArray where
+ ba1@(ByteArray ba1#) == ba2@(ByteArray ba2#)
+ | sameByteArray ba1# ba2# = True
+ | sizeofByteArray ba1 /= sizeofByteArray ba2 = False
+ | otherwise =
+ case unsafeDupablePerformIO $ memcmp_ba ba1# ba2# (fromIntegral $ sizeofByteArray ba1) of
+ 0 -> True
+ _ -> False
+
+instance Ord ByteArray where
+ ba1@(ByteArray ba1#) `compare` ba2@(ByteArray ba2#)
+ | sameByteArray ba1# ba2# = EQ
+ | n1 /= n2 = n1 `compare` n2
+ | otherwise =
+ case unsafeDupablePerformIO $ memcmp_ba ba1# ba2# (fromIntegral n1) of
+ x | x > 0 -> GT
+ | x == 0 -> EQ
+ | otherwise -> LT
+ where
+ n1 = sizeofByteArray ba1
+ n2 = sizeofByteArray ba2
+
+#if __GLASGOW_HASKELL__ >= 708
+instance Exts.IsList ByteArray where
+ type Item ByteArray = Word8
+
+ toList = foldrByteArray (:) []
+ fromList xs = fromListN (length xs) xs
+ fromListN = fromListN
+#endif
diff --git a/benchmarks/PPoPP2019/src/primitive-0.6.3.0/Data/Primitive/Internal/Compat.hs b/benchmarks/PPoPP2019/src/primitive-0.6.3.0/Data/Primitive/Internal/Compat.hs
new file mode 100644
index 0000000..f6b8016
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/primitive-0.6.3.0/Data/Primitive/Internal/Compat.hs
@@ -0,0 +1,38 @@
+{-# LANGUAGE CPP, MagicHash #-}
+
+-- |
+-- Module : Data.Primitive.Internal.Compat
+-- Copyright : (c) Roman Leshchinskiy 2011-2012
+-- License : BSD-style
+--
+-- Maintainer : Roman Leshchinskiy
+-- Portability : non-portable
+--
+-- Compatibility functions
+--
+
+module Data.Primitive.Internal.Compat (
+ isTrue#
+ , mkNoRepType
+ ) where
+
+#if MIN_VERSION_base(4,2,0)
+import Data.Data (mkNoRepType)
+#else
+import Data.Data (mkNorepType)
+#endif
+
+#if MIN_VERSION_base(4,7,0)
+import GHC.Exts (isTrue#)
+#endif
+
+
+
+#if !MIN_VERSION_base(4,2,0)
+mkNoRepType = mkNorepType
+#endif
+
+#if !MIN_VERSION_base(4,7,0)
+isTrue# :: Bool -> Bool
+isTrue# b = b
+#endif
diff --git a/benchmarks/PPoPP2019/src/primitive-0.6.3.0/Data/Primitive/Internal/Operations.hs b/benchmarks/PPoPP2019/src/primitive-0.6.3.0/Data/Primitive/Internal/Operations.hs
new file mode 100644
index 0000000..091e11f
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/primitive-0.6.3.0/Data/Primitive/Internal/Operations.hs
@@ -0,0 +1,90 @@
+{-# LANGUAGE MagicHash, UnliftedFFITypes #-}
+
+-- |
+-- Module : Data.Primitive.Internal.Operations
+-- Copyright : (c) Roman Leshchinskiy 2011-2012
+-- License : BSD-style
+--
+-- Maintainer : Roman Leshchinskiy
+-- Portability : non-portable
+--
+-- Internal operations
+--
+
+
+module Data.Primitive.Internal.Operations (
+ setWord8Array#, setWord16Array#, setWord32Array#,
+ setWord64Array#, setWordArray#,
+ setInt8Array#, setInt16Array#, setInt32Array#,
+ setInt64Array#, setIntArray#,
+ setAddrArray#, setFloatArray#, setDoubleArray#, setWideCharArray#,
+
+ setWord8OffAddr#, setWord16OffAddr#, setWord32OffAddr#,
+ setWord64OffAddr#, setWordOffAddr#,
+ setInt8OffAddr#, setInt16OffAddr#, setInt32OffAddr#,
+ setInt64OffAddr#, setIntOffAddr#,
+ setAddrOffAddr#, setFloatOffAddr#, setDoubleOffAddr#, setWideCharOffAddr#
+) where
+
+import Data.Primitive.MachDeps (Word64_#, Int64_#)
+import Foreign.C.Types
+import GHC.Prim
+
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word8"
+ setWord8Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Word# -> IO ()
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word16"
+ setWord16Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Word# -> IO ()
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word32"
+ setWord32Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Word# -> IO ()
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word64"
+ setWord64Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Word64_# -> IO ()
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word"
+ setWordArray# :: MutableByteArray# s -> CPtrdiff -> CSize -> Word# -> IO ()
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word8"
+ setInt8Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Int# -> IO ()
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word16"
+ setInt16Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Int# -> IO ()
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word32"
+ setInt32Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Int# -> IO ()
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word64"
+ setInt64Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Int64_# -> IO ()
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word"
+ setIntArray# :: MutableByteArray# s -> CPtrdiff -> CSize -> Int# -> IO ()
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Ptr"
+ setAddrArray# :: MutableByteArray# s -> CPtrdiff -> CSize -> Addr# -> IO ()
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Float"
+ setFloatArray# :: MutableByteArray# s -> CPtrdiff -> CSize -> Float# -> IO ()
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Double"
+ setDoubleArray# :: MutableByteArray# s -> CPtrdiff -> CSize -> Double# -> IO ()
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Char"
+ setWideCharArray# :: MutableByteArray# s -> CPtrdiff -> CSize -> Char# -> IO ()
+
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word8"
+ setWord8OffAddr# :: Addr# -> CPtrdiff -> CSize -> Word# -> IO ()
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word16"
+ setWord16OffAddr# :: Addr# -> CPtrdiff -> CSize -> Word# -> IO ()
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word32"
+ setWord32OffAddr# :: Addr# -> CPtrdiff -> CSize -> Word# -> IO ()
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word64"
+ setWord64OffAddr# :: Addr# -> CPtrdiff -> CSize -> Word64_# -> IO ()
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word"
+ setWordOffAddr# :: Addr# -> CPtrdiff -> CSize -> Word# -> IO ()
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word8"
+ setInt8OffAddr# :: Addr# -> CPtrdiff -> CSize -> Int# -> IO ()
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word16"
+ setInt16OffAddr# :: Addr# -> CPtrdiff -> CSize -> Int# -> IO ()
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word32"
+ setInt32OffAddr# :: Addr# -> CPtrdiff -> CSize -> Int# -> IO ()
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word64"
+ setInt64OffAddr# :: Addr# -> CPtrdiff -> CSize -> Int64_# -> IO ()
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word"
+ setIntOffAddr# :: Addr# -> CPtrdiff -> CSize -> Int# -> IO ()
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Ptr"
+ setAddrOffAddr# :: Addr# -> CPtrdiff -> CSize -> Addr# -> IO ()
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Float"
+ setFloatOffAddr# :: Addr# -> CPtrdiff -> CSize -> Float# -> IO ()
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Double"
+ setDoubleOffAddr# :: Addr# -> CPtrdiff -> CSize -> Double# -> IO ()
+foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Char"
+ setWideCharOffAddr# :: Addr# -> CPtrdiff -> CSize -> Char# -> IO ()
+
diff --git a/benchmarks/PPoPP2019/src/primitive-0.6.3.0/Data/Primitive/MachDeps.hs b/benchmarks/PPoPP2019/src/primitive-0.6.3.0/Data/Primitive/MachDeps.hs
new file mode 100644
index 0000000..d36c252
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/primitive-0.6.3.0/Data/Primitive/MachDeps.hs
@@ -0,0 +1,123 @@
+{-# LANGUAGE CPP, MagicHash #-}
+-- |
+-- Module : Data.Primitive.MachDeps
+-- Copyright : (c) Roman Leshchinskiy 2009-2012
+-- License : BSD-style
+--
+-- Maintainer : Roman Leshchinskiy
+-- Portability : non-portable
+--
+-- Machine-dependent constants
+--
+
+module Data.Primitive.MachDeps where
+
+#include "MachDeps.h"
+
+import GHC.Prim
+
+sIZEOF_CHAR,
+ aLIGNMENT_CHAR,
+
+ sIZEOF_INT,
+ aLIGNMENT_INT,
+
+ sIZEOF_WORD,
+ aLIGNMENT_WORD,
+
+ sIZEOF_DOUBLE,
+ aLIGNMENT_DOUBLE,
+
+ sIZEOF_FLOAT,
+ aLIGNMENT_FLOAT,
+
+ sIZEOF_PTR,
+ aLIGNMENT_PTR,
+
+ sIZEOF_FUNPTR,
+ aLIGNMENT_FUNPTR,
+
+ sIZEOF_STABLEPTR,
+ aLIGNMENT_STABLEPTR,
+
+ sIZEOF_INT8,
+ aLIGNMENT_INT8,
+
+ sIZEOF_WORD8,
+ aLIGNMENT_WORD8,
+
+ sIZEOF_INT16,
+ aLIGNMENT_INT16,
+
+ sIZEOF_WORD16,
+ aLIGNMENT_WORD16,
+
+ sIZEOF_INT32,
+ aLIGNMENT_INT32,
+
+ sIZEOF_WORD32,
+ aLIGNMENT_WORD32,
+
+ sIZEOF_INT64,
+ aLIGNMENT_INT64,
+
+ sIZEOF_WORD64,
+ aLIGNMENT_WORD64 :: Int
+
+
+sIZEOF_CHAR = SIZEOF_HSCHAR
+aLIGNMENT_CHAR = ALIGNMENT_HSCHAR
+
+sIZEOF_INT = SIZEOF_HSINT
+aLIGNMENT_INT = ALIGNMENT_HSINT
+
+sIZEOF_WORD = SIZEOF_HSWORD
+aLIGNMENT_WORD = ALIGNMENT_HSWORD
+
+sIZEOF_DOUBLE = SIZEOF_HSDOUBLE
+aLIGNMENT_DOUBLE = ALIGNMENT_HSDOUBLE
+
+sIZEOF_FLOAT = SIZEOF_HSFLOAT
+aLIGNMENT_FLOAT = ALIGNMENT_HSFLOAT
+
+sIZEOF_PTR = SIZEOF_HSPTR
+aLIGNMENT_PTR = ALIGNMENT_HSPTR
+
+sIZEOF_FUNPTR = SIZEOF_HSFUNPTR
+aLIGNMENT_FUNPTR = ALIGNMENT_HSFUNPTR
+
+sIZEOF_STABLEPTR = SIZEOF_HSSTABLEPTR
+aLIGNMENT_STABLEPTR = ALIGNMENT_HSSTABLEPTR
+
+sIZEOF_INT8 = SIZEOF_INT8
+aLIGNMENT_INT8 = ALIGNMENT_INT8
+
+sIZEOF_WORD8 = SIZEOF_WORD8
+aLIGNMENT_WORD8 = ALIGNMENT_WORD8
+
+sIZEOF_INT16 = SIZEOF_INT16
+aLIGNMENT_INT16 = ALIGNMENT_INT16
+
+sIZEOF_WORD16 = SIZEOF_WORD16
+aLIGNMENT_WORD16 = ALIGNMENT_WORD16
+
+sIZEOF_INT32 = SIZEOF_INT32
+aLIGNMENT_INT32 = ALIGNMENT_INT32
+
+sIZEOF_WORD32 = SIZEOF_WORD32
+aLIGNMENT_WORD32 = ALIGNMENT_WORD32
+
+sIZEOF_INT64 = SIZEOF_INT64
+aLIGNMENT_INT64 = ALIGNMENT_INT64
+
+sIZEOF_WORD64 = SIZEOF_WORD64
+aLIGNMENT_WORD64 = ALIGNMENT_WORD64
+
+#if WORD_SIZE_IN_BITS == 32
+type Word64_# = Word64#
+type Int64_# = Int64#
+#else
+type Word64_# = Word#
+type Int64_# = Int#
+#endif
+
diff --git a/benchmarks/PPoPP2019/src/primitive-0.6.3.0/Data/Primitive/MutVar.hs b/benchmarks/PPoPP2019/src/primitive-0.6.3.0/Data/Primitive/MutVar.hs
new file mode 100644
index 0000000..f707bfb
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/primitive-0.6.3.0/Data/Primitive/MutVar.hs
@@ -0,0 +1,86 @@
+{-# LANGUAGE MagicHash, UnboxedTuples, DeriveDataTypeable #-}
+
+-- |
+-- Module : Data.Primitive.MutVar
+-- Copyright : (c) Justin Bonnar 2011, Roman Leshchinskiy 2011-2012
+-- License : BSD-style
+--
+-- Maintainer : Roman Leshchinskiy
+-- Portability : non-portable
+--
+-- Primitive boxed mutable variables
+--
+
+module Data.Primitive.MutVar (
+ MutVar(..),
+
+ newMutVar,
+ readMutVar,
+ writeMutVar,
+
+ atomicModifyMutVar,
+ atomicModifyMutVar',
+ modifyMutVar,
+ modifyMutVar'
+) where
+
+import Control.Monad.Primitive ( PrimMonad(..), primitive_ )
+import GHC.Prim ( MutVar#, sameMutVar#, newMutVar#,
+ readMutVar#, writeMutVar#, atomicModifyMutVar# )
+import Data.Primitive.Internal.Compat ( isTrue# )
+import Data.Typeable ( Typeable )
+
+-- | A 'MutVar' behaves like a single-element mutable array associated
+-- with a primitive state token.
+data MutVar s a = MutVar (MutVar# s a)
+ deriving ( Typeable )
+
+instance Eq (MutVar s a) where
+ MutVar mva# == MutVar mvb# = isTrue# (sameMutVar# mva# mvb#)
+
+-- | Create a new 'MutVar' with the specified initial value
+newMutVar :: PrimMonad m => a -> m (MutVar (PrimState m) a)
+{-# INLINE newMutVar #-}
+newMutVar initialValue = primitive $ \s# ->
+ case newMutVar# initialValue s# of
+ (# s'#, mv# #) -> (# s'#, MutVar mv# #)
+
+-- | Read the value of a 'MutVar'
+readMutVar :: PrimMonad m => MutVar (PrimState m) a -> m a
+{-# INLINE readMutVar #-}
+readMutVar (MutVar mv#) = primitive (readMutVar# mv#)
+
+-- | Write a new value into a 'MutVar'
+writeMutVar :: PrimMonad m => MutVar (PrimState m) a -> a -> m ()
+{-# INLINE writeMutVar #-}
+writeMutVar (MutVar mv#) newValue = primitive_ (writeMutVar# mv# newValue)
+
+-- | Atomically mutate the contents of a 'MutVar'
+atomicModifyMutVar :: PrimMonad m => MutVar (PrimState m) a -> (a -> (a,b)) -> m b
+{-# INLINE atomicModifyMutVar #-}
+atomicModifyMutVar (MutVar mv#) f = primitive $ atomicModifyMutVar# mv# f
+
+-- | Strict version of 'atomicModifyMutVar'. This forces both the value stored
+-- in the 'MutVar' as well as the value returned.
+atomicModifyMutVar' :: PrimMonad m => MutVar (PrimState m) a -> (a -> (a, b)) -> m b
+{-# INLINE atomicModifyMutVar' #-}
+atomicModifyMutVar' mv f = do
+ b <- atomicModifyMutVar mv force
+ b `seq` return b
+ where
+ force x = let (a, b) = f x in (a, a `seq` b)
+
+-- | Mutate the contents of a 'MutVar'
+modifyMutVar :: PrimMonad m => MutVar (PrimState m) a -> (a -> a) -> m ()
+{-# INLINE modifyMutVar #-}
+modifyMutVar (MutVar mv#) g = primitive_ $ \s# ->
+ case readMutVar# mv# s# of
+ (# s'#, a #) -> writeMutVar# mv# (g a) s'#
+
+-- | Strict version of 'modifyMutVar'
+modifyMutVar' :: PrimMonad m => MutVar (PrimState m) a -> (a -> a) -> m ()
+{-# INLINE modifyMutVar' #-}
+modifyMutVar' (MutVar mv#) g = primitive_ $ \s# ->
+ case readMutVar# mv# s# of
+ (# s'#, a #) -> let a' = g a in a' `seq` writeMutVar# mv# a' s'#
+
diff --git a/benchmarks/PPoPP2019/src/primitive-0.6.3.0/Data/Primitive/SmallArray.hs b/benchmarks/PPoPP2019/src/primitive-0.6.3.0/Data/Primitive/SmallArray.hs
new file mode 100644
index 0000000..f95dbdf
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/primitive-0.6.3.0/Data/Primitive/SmallArray.hs
@@ -0,0 +1,639 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+-- |
+-- Module : Data.Primitive.SmallArray
+-- Copyright: (c) 2015 Dan Doel
+-- License: BSD3
+--
+-- Maintainer: libraries@haskell.org
+-- Portability: non-portable
+--
+-- Small arrays are boxed (im)mutable arrays.
+--
+-- The underlying structure of the 'Array' type contains a card table, allowing
+-- segments of the array to be marked as having been mutated. This allows the
+-- garbage collector to only re-traverse segments of the array that have been
+-- marked during certain phases, rather than having to traverse the entire
+-- array.
+--
+-- 'SmallArray' lacks this table. This means that it takes up less memory and
+-- has slightly faster writes. It is also more efficient during garbage
+-- collection so long as the card table would have a single entry covering the
+-- entire array. These advantages make them suitable for use as arrays that are
+-- known to be small.
+--
+-- The card size is 128, so for uses much larger than that, 'Array' would likely
+-- be superior.
+--
+-- The underlying type, 'SmallArray#', was introduced in GHC 7.10, so prior to
+-- that version, this module simply implements small arrays as 'Array'.
+
+module Data.Primitive.SmallArray
+ ( SmallArray(..)
+ , SmallMutableArray(..)
+ , newSmallArray
+ , readSmallArray
+ , writeSmallArray
+ , copySmallArray
+ , copySmallMutableArray
+ , indexSmallArray
+ , indexSmallArrayM
+ , cloneSmallArray
+ , cloneSmallMutableArray
+ , freezeSmallArray
+ , unsafeFreezeSmallArray
+ , thawSmallArray
+ , unsafeThawSmallArray
+ , sizeofSmallArray
+ , sizeofSmallMutableArray
+ ) where
+
+
+#if (__GLASGOW_HASKELL__ >= 710)
+#define HAVE_SMALL_ARRAY 1
+#endif
+
+#if MIN_VERSION_base(4,7,0)
+import GHC.Exts hiding (toList)
+import qualified GHC.Exts
+#endif
+
+import Control.Applicative
+import Control.Monad
+import Control.Monad.Fix
+import Control.Monad.Primitive
+import Control.Monad.ST
+#if MIN_VERSION_base(4,4,0)
+import Control.Monad.Zip
+#endif
+import Data.Data
+import Data.Foldable
+import Data.Functor.Identity
+import Data.Monoid
+#if MIN_VERSION_base(4,9,0)
+import qualified Data.Semigroup as Sem
+#endif
+import Text.ParserCombinators.ReadPrec
+import Text.Read
+import Text.Read.Lex
+
+#if !(HAVE_SMALL_ARRAY)
+import Data.Primitive.Array
+import Data.Traversable
+#endif
+
+#if HAVE_SMALL_ARRAY
+data SmallArray a = SmallArray (SmallArray# a)
+ deriving Typeable
+#else
+newtype SmallArray a = SmallArray (Array a) deriving
+ ( Eq
+ , Ord
+ , Show
+ , Read
+ , Foldable
+ , Traversable
+ , Functor
+ , Applicative
+ , Alternative
+ , Monad
+ , MonadPlus
+#if MIN_VERSION_base(4,4,0)
+ , MonadZip
+#endif
+ , MonadFix
+ , Monoid
+ , Typeable
+ )
+
+#if MIN_VERSION_base(4,7,0)
+instance IsList (SmallArray a) where
+ type Item (SmallArray a) = a
+ fromListN n l = SmallArray (fromListN n l)
+ fromList l = SmallArray (fromList l)
+ toList (SmallArray a) = toList a
+#endif
+#endif
+
+#if HAVE_SMALL_ARRAY
+data SmallMutableArray s a = SmallMutableArray (SmallMutableArray# s a)
+ deriving Typeable
+#else
+newtype SmallMutableArray s a = SmallMutableArray (MutableArray s a)
+ deriving (Eq, Typeable)
+#endif
+
+-- | Create a new small mutable array.
+newSmallArray
+ :: PrimMonad m
+ => Int -- ^ size
+ -> a -- ^ initial contents
+ -> m (SmallMutableArray (PrimState m) a)
+#if HAVE_SMALL_ARRAY
+newSmallArray (I# i#) x = primitive $ \s ->
+ case newSmallArray# i# x s of
+ (# s', sma# #) -> (# s', SmallMutableArray sma# #)
+#else
+newSmallArray n e = SmallMutableArray `liftM` newArray n e
+#endif
+{-# INLINE newSmallArray #-}
+
+-- | Read the element at a given index in a mutable array.
+readSmallArray
+ :: PrimMonad m
+ => SmallMutableArray (PrimState m) a -- ^ array
+ -> Int -- ^ index
+ -> m a
+#if HAVE_SMALL_ARRAY
+readSmallArray (SmallMutableArray sma#) (I# i#) =
+ primitive $ readSmallArray# sma# i#
+#else
+readSmallArray (SmallMutableArray a) = readArray a
+#endif
+{-# INLINE readSmallArray #-}
+
+-- | Write an element at the given idex in a mutable array.
+writeSmallArray
+ :: PrimMonad m
+ => SmallMutableArray (PrimState m) a -- ^ array
+ -> Int -- ^ index
+ -> a -- ^ new element
+ -> m ()
+#if HAVE_SMALL_ARRAY
+writeSmallArray (SmallMutableArray sma#) (I# i#) x =
+ primitive_ $ writeSmallArray# sma# i# x
+#else
+writeSmallArray (SmallMutableArray a) = writeArray a
+#endif
+{-# INLINE writeSmallArray #-}
+
+-- | Look up an element in an immutable array.
+--
+-- The purpose of returning a result using a monad is to allow the caller to
+-- avoid retaining references to the array. Evaluating the return value will
+-- cause the array lookup to be performed, even though it may not require the
+-- element of the array to be evaluated (which could throw an exception). For
+-- instance:
+--
+-- > data Box a = Box a
+-- > ...
+-- >
+-- > f sa = case indexSmallArrayM sa 0 of
+-- > Box x -> ...
+--
+-- 'x' is not a closure that references 'sa' as it would be if we instead
+-- wrote:
+--
+-- > let x = indexSmallArray sa 0
+--
+-- And does not prevent 'sa' from being garbage collected.
+--
+-- Note that 'Identity' is not adequate for this use, as it is a newtype, and
+-- cannot be evaluated without evaluating the element.
+indexSmallArrayM
+ :: Monad m
+ => SmallArray a -- ^ array
+ -> Int -- ^ index
+ -> m a
+#if HAVE_SMALL_ARRAY
+indexSmallArrayM (SmallArray sa#) (I# i#) =
+ case indexSmallArray# sa# i# of
+ (# x #) -> pure x
+#else
+indexSmallArrayM (SmallArray a) = indexArrayM a
+#endif
+{-# INLINE indexSmallArrayM #-}
+
+-- | Look up an element in an immutable array.
+indexSmallArray
+ :: SmallArray a -- ^ array
+ -> Int -- ^ index
+ -> a
+#if HAVE_SMALL_ARRAY
+indexSmallArray sa i = runIdentity $ indexSmallArrayM sa i
+#else
+indexSmallArray (SmallArray a) = indexArray a
+#endif
+{-# INLINE indexSmallArray #-}
+
+-- | Create a copy of a slice of an immutable array.
+cloneSmallArray
+ :: SmallArray a -- ^ source
+ -> Int -- ^ offset
+ -> Int -- ^ length
+ -> SmallArray a
+#if HAVE_SMALL_ARRAY
+cloneSmallArray (SmallArray sa#) (I# i#) (I# j#) =
+ SmallArray (cloneSmallArray# sa# i# j#)
+#else
+cloneSmallArray (SmallArray a) i j = SmallArray $ cloneArray a i j
+#endif
+{-# INLINE cloneSmallArray #-}
+
+-- | Create a copy of a slice of a mutable array.
+cloneSmallMutableArray
+ :: PrimMonad m
+ => SmallMutableArray (PrimState m) a -- ^ source
+ -> Int -- ^ offset
+ -> Int -- ^ length
+ -> m (SmallMutableArray (PrimState m) a)
+#if HAVE_SMALL_ARRAY
+cloneSmallMutableArray (SmallMutableArray sma#) (I# o#) (I# l#) =
+ primitive $ \s -> case cloneSmallMutableArray# sma# o# l# s of
+ (# s', smb# #) -> (# s', SmallMutableArray smb# #)
+#else
+cloneSmallMutableArray (SmallMutableArray ma) i j =
+ SmallMutableArray `liftM` cloneMutableArray ma i j
+#endif
+{-# INLINE cloneSmallMutableArray #-}
+
+-- | Create an immutable array corresponding to a slice of a mutable array.
+--
+-- This operation copies the portion of the array to be frozen.
+freezeSmallArray
+ :: PrimMonad m
+ => SmallMutableArray (PrimState m) a -- ^ source
+ -> Int -- ^ offset
+ -> Int -- ^ length
+ -> m (SmallArray a)
+#if HAVE_SMALL_ARRAY
+freezeSmallArray (SmallMutableArray sma#) (I# i#) (I# j#) =
+ primitive $ \s -> case freezeSmallArray# sma# i# j# s of
+ (# s', sa# #) -> (# s', SmallArray sa# #)
+#else
+freezeSmallArray (SmallMutableArray ma) i j =
+ SmallArray `liftM` freezeArray ma i j
+#endif
+{-# INLINE freezeSmallArray #-}
+
+-- | Render a mutable array immutable.
+--
+-- This operation performs no copying, so care must be taken not to modify the
+-- input array after freezing.
+unsafeFreezeSmallArray
+ :: PrimMonad m => SmallMutableArray (PrimState m) a -> m (SmallArray a)
+#if HAVE_SMALL_ARRAY
+unsafeFreezeSmallArray (SmallMutableArray sma#) =
+ primitive $ \s -> case unsafeFreezeSmallArray# sma# s of
+ (# s', sa# #) -> (# s', SmallArray sa# #)
+#else
+unsafeFreezeSmallArray (SmallMutableArray ma) =
+ SmallArray `liftM` unsafeFreezeArray ma
+#endif
+{-# INLINE unsafeFreezeSmallArray #-}
+
+-- | Create a mutable array corresponding to a slice of an immutable array.
+--
+-- This operation copies the portion of the array to be thawed.
+thawSmallArray
+ :: PrimMonad m
+ => SmallArray a -- ^ source
+ -> Int -- ^ offset
+ -> Int -- ^ length
+ -> m (SmallMutableArray (PrimState m) a)
+#if HAVE_SMALL_ARRAY
+thawSmallArray (SmallArray sa#) (I# o#) (I# l#) =
+ primitive $ \s -> case thawSmallArray# sa# o# l# s of
+ (# s', sma# #) -> (# s', SmallMutableArray sma# #)
+#else
+thawSmallArray (SmallArray a) off len =
+ SmallMutableArray `liftM` thawArray a off len
+#endif
+{-# INLINE thawSmallArray #-}
+
+-- | Render an immutable array mutable.
+--
+-- This operation performs no copying, so care must be taken with its use.
+unsafeThawSmallArray
+ :: PrimMonad m => SmallArray a -> m (SmallMutableArray (PrimState m) a)
+#if HAVE_SMALL_ARRAY
+unsafeThawSmallArray (SmallArray sa#) =
+ primitive $ \s -> case unsafeThawSmallArray# sa# s of
+ (# s', sma# #) -> (# s', SmallMutableArray sma# #)
+#else
+unsafeThawSmallArray (SmallArray a) = SmallMutableArray `liftM` unsafeThawArray a
+#endif
+{-# INLINE unsafeThawSmallArray #-}
+
+-- | Copy a slice of an immutable array into a mutable array.
+copySmallArray
+ :: PrimMonad m
+ => SmallMutableArray (PrimState m) a -- ^ destination
+ -> Int -- ^ destination offset
+ -> SmallArray a -- ^ source
+ -> Int -- ^ source offset
+ -> Int -- ^ length
+ -> m ()
+#if HAVE_SMALL_ARRAY
+copySmallArray
+ (SmallMutableArray dst#) (I# do#) (SmallArray src#) (I# so#) (I# l#) =
+ primitive_ $ copySmallArray# src# so# dst# do# l#
+#else
+copySmallArray (SmallMutableArray dst) i (SmallArray src) = copyArray dst i src
+#endif
+{-# INLINE copySmallArray #-}
+
+-- | Copy a slice of one mutable array into another.
+copySmallMutableArray
+ :: PrimMonad m
+ => SmallMutableArray (PrimState m) a -- ^ destination
+ -> Int -- ^ destination offset
+ -> SmallMutableArray (PrimState m) a -- ^ source
+ -> Int -- ^ source offset
+ -> Int -- ^ length
+ -> m ()
+#if HAVE_SMALL_ARRAY
+copySmallMutableArray
+ (SmallMutableArray dst#) (I# do#)
+ (SmallMutableArray src#) (I# so#)
+ (I# l#) =
+ primitive_ $ copySmallMutableArray# src# so# dst# do# l#
+#else
+copySmallMutableArray (SmallMutableArray dst) i (SmallMutableArray src) =
+ copyMutableArray dst i src
+#endif
+{-# INLINE copySmallMutableArray #-}
+
+sizeofSmallArray :: SmallArray a -> Int
+#if HAVE_SMALL_ARRAY
+sizeofSmallArray (SmallArray sa#) = I# (sizeofSmallArray# sa#)
+#else
+sizeofSmallArray (SmallArray a) = sizeofArray a
+#endif
+{-# INLINE sizeofSmallArray #-}
+
+sizeofSmallMutableArray :: SmallMutableArray s a -> Int
+#if HAVE_SMALL_ARRAY
+sizeofSmallMutableArray (SmallMutableArray sa#) =
+ I# (sizeofSmallMutableArray# sa#)
+#else
+sizeofSmallMutableArray (SmallMutableArray ma) = sizeofMutableArray ma
+#endif
+{-# INLINE sizeofSmallMutableArray #-}
+
+#if HAVE_SMALL_ARRAY
+die :: String -> String -> a
+die fun problem = error $ "Data.Primitive.SmallArray." ++ fun ++ ": " ++ problem
+
+emptySmallArray :: SmallArray a
+emptySmallArray =
+ runST $ newSmallArray 0 (die "emptySmallArray" "impossible")
+ >>= unsafeFreezeSmallArray
+{-# NOINLINE emptySmallArray #-}
+
+createSmallArray
+ :: Int -> a -> (forall s. SmallMutableArray s a -> ST s ()) -> SmallArray a
+createSmallArray 0 _ _ = emptySmallArray
+createSmallArray i x k =
+ runST $ newSmallArray i x >>= \sa -> k sa *> unsafeFreezeSmallArray sa
+{-# INLINE createSmallArray #-}
+
+infixl 1 ?
+(?) :: (a -> b -> c) -> (b -> a -> c)
+(?) = flip
+{-# INLINE (?) #-}
+
+noOp :: a -> ST s ()
+noOp = const $ pure ()
+
+instance Eq a => Eq (SmallArray a) where
+ sa1 == sa2 = length sa1 == length sa2 && loop (length sa1 - 1)
+ where
+ loop i
+ | i < 0 = True
+ | otherwise = indexSmallArray sa1 i == indexSmallArray sa2 i && loop (i-1)
+
+instance Eq (SmallMutableArray s a) where
+ SmallMutableArray sma1# == SmallMutableArray sma2# =
+ isTrue# (sameSmallMutableArray# sma1# sma2#)
+
+instance Ord a => Ord (SmallArray a) where
+ compare sl sr = fix ? 0 $ \go i ->
+ if i < l
+ then compare (indexSmallArray sl i) (indexSmallArray sr i) <> go (i+1)
+ else compare (length sl) (length sr)
+ where l = length sl `min` length sr
+
+instance Foldable SmallArray where
+ foldr f z sa = fix ? 0 $ \go i ->
+ if i < length sa
+ then f (indexSmallArray sa i) (go $ i+1)
+ else z
+ {-# INLINE foldr #-}
+
+ foldr' f z sa = fix ? z ? length sa - 1 $ \go acc i ->
+ if i < 0
+ then acc
+ else go (f (indexSmallArray sa i) acc) (i-1)
+ {-# INLINE foldr' #-}
+
+ foldl f z sa = fix ? length sa - 1 $ \go i ->
+ if i < 0
+ then z
+ else f (go $ i-1) $ indexSmallArray sa i
+ {-# INLINE foldl #-}
+
+ foldl' f z sa = fix ? z ? 0 $ \go acc i ->
+ if i < length sa
+ then go (f acc $ indexSmallArray sa i) (i+1)
+ else acc
+ {-# INLINE foldl' #-}
+
+ foldr1 f sa
+ | sz == 0 = die "foldr1" "empty list"
+ | otherwise = fix ? 0 $ \go i ->
+ if i < sz-1
+ then f (indexSmallArray sa i) (go $ i+1)
+ else indexSmallArray sa $ sz-1
+ where sz = sizeofSmallArray sa
+ {-# INLINE foldr1 #-}
+
+ foldl1 f sa
+ | sz == 0 = die "foldl1" "empty list"
+ | otherwise = fix ? sz-1 $ \go i ->
+ if i < 1
+ then indexSmallArray sa 0
+ else f (go $ i-1) (indexSmallArray sa i)
+ where sz = sizeofSmallArray sa
+ {-# INLINE foldl1 #-}
+
+ null sa = sizeofSmallArray sa == 0
+ {-# INLINE null #-}
+
+ length = sizeofSmallArray
+ {-# INLINE length #-}
+
+instance Traversable SmallArray where
+ traverse f sa = fromListN l <$> traverse (f . indexSmallArray sa) [0..l-1]
+ where l = length sa
+
+instance Functor SmallArray where
+ fmap f sa = createSmallArray (length sa) (die "fmap" "impossible") $ \smb ->
+ fix ? 0 $ \go i ->
+ when (i < length sa) $
+ writeSmallArray smb i (f $ indexSmallArray sa i) *> go (i+1)
+ {-# INLINE fmap #-}
+
+ x <$ sa = createSmallArray (length sa) x noOp
+
+instance Applicative SmallArray where
+ pure x = createSmallArray 1 x noOp
+
+ sa *> sb = createSmallArray (la*lb) (die "*>" "impossible") $ \smb ->
+ fix ? 0 $ \go i ->
+ when (i < la) $
+ copySmallArray smb 0 sb 0 lb *> go (i+1)
+ where
+ la = length sa ; lb = length sb
+
+ sa <* sb = createSmallArray (la*lb) (indexSmallArray sa $ la-1) $ \sma ->
+ fix ? 0 $ \outer i -> when (i < la-1) $ do
+ let a = indexSmallArray sa i
+ fix ? 0 $ \inner j ->
+ when (j < lb) $
+ writeSmallArray sma (la*i + j) a *> inner (j+1)
+ outer $ i+1
+ where
+ la = length sa ; lb = length sb
+
+ sf <*> sx = createSmallArray (lf*lx) (die "<*>" "impossible") $ \smb ->
+ fix ? 0 $ \outer i -> when (i < lf) $ do
+ let f = indexSmallArray sf i
+ fix ? 0 $ \inner j ->
+ when (j < lx) $
+ writeSmallArray smb (lf*i + j) (f $ indexSmallArray sx j)
+ *> inner (j+1)
+ outer $ i+1
+ where
+ lf = length sf ; lx = length sx
+
+instance Alternative SmallArray where
+ empty = emptySmallArray
+
+ sl <|> sr =
+ createSmallArray (length sl + length sr) (die "<|>" "impossible") $ \sma ->
+ copySmallArray sma 0 sl 0 (length sl)
+ *> copySmallArray sma (length sl) sr 0 (length sr)
+
+ many sa | null sa = pure []
+ | otherwise = die "many" "infinite arrays are not well defined"
+
+ some sa | null sa = emptySmallArray
+ | otherwise = die "some" "infinite arrays are not well defined"
+
+instance Monad SmallArray where
+ return = pure
+ (>>) = (*>)
+
+ sa >>= f = collect 0 [] (la-1)
+ where
+ la = length sa
+ collect sz stk i
+ | i < 0 = createSmallArray sz (die ">>=" "impossible") $ fill 0 stk
+ | otherwise = let sb = f $ indexSmallArray sa i in
+ collect (sz + length sb) (sb:stk) (i-1)
+
+ fill _ [ ] _ = return ()
+ fill off (sb:sbs) smb =
+ copySmallArray smb off sb 0 (length sb)
+ *> fill (off + length sb) sbs smb
+
+ fail _ = emptySmallArray
+
+instance MonadPlus SmallArray where
+ mzero = empty
+ mplus = (<|>)
+
+zipW :: String -> (a -> b -> c) -> SmallArray a -> SmallArray b -> SmallArray c
+zipW nm = \f sa sb -> let mn = length sa `min` length sb in
+ createSmallArray mn (die nm "impossible") $ \mc ->
+ fix ? 0 $ \go i -> when (i < mn) $
+ writeSmallArray mc i (f (indexSmallArray sa i) (indexSmallArray sb i))
+ *> go (i+1)
+{-# INLINE zipW #-}
+
+instance MonadZip SmallArray where
+ mzip = zipW "mzip" (,)
+ mzipWith = zipW "mzipWith"
+ {-# INLINE mzipWith #-}
+ munzip sab = runST $ do
+ let sz = length sab
+ sma <- newSmallArray sz $ die "munzip" "impossible"
+ smb <- newSmallArray sz $ die "munzip" "impossible"
+ fix ? 0 $ \go i ->
+ when (i < sz) $ case indexSmallArray sab i of
+ (x, y) -> do writeSmallArray sma i x
+ writeSmallArray smb i y
+ go $ i+1
+ (,) <$> unsafeFreezeSmallArray sma
+ <*> unsafeFreezeSmallArray smb
+
+instance MonadFix SmallArray where
+ mfix f = fromList . mfix $ toList . f
+
+#if MIN_VERSION_base(4,9,0)
+instance Sem.Semigroup (SmallArray a) where
+ (<>) = (<|>)
+ sconcat = mconcat . toList
+#endif
+
+instance Monoid (SmallArray a) where
+ mempty = empty
+#if !(MIN_VERSION_base(4,11,0))
+ mappend = (<|>)
+#endif
+ mconcat sas = createSmallArray n (die "mconcat" "impossible") $ \sma ->
+ fix ? 0 ? sas $ \go off l -> case l of
+ [] -> return ()
+ sa:stk -> copySmallArray sma off sa 0 (length sa) *> go (off+1) stk
+ where n = sum . fmap length $ sas
+
+instance IsList (SmallArray a) where
+ type Item (SmallArray a) = a
+ fromListN n l =
+ createSmallArray n (die "fromListN" "mismatched size and list") $ \sma ->
+ fix ? 0 ? l $ \go i li -> case li of
+ [] -> pure ()
+ x:xs -> writeSmallArray sma i x *> go (i+1) xs
+ fromList l = fromListN (length l) l
+ toList sa = indexSmallArray sa <$> [0 .. length sa - 1]
+
+instance Show a => Show (SmallArray a) where
+ showsPrec p sa = showParen (p > 10) $
+ showString "fromListN " . shows (length sa) . showString " "
+ . shows (toList sa)
+
+instance Read a => Read (SmallArray a) where
+ readPrec = parens . prec 10 $ do
+ Symbol "fromListN" <- lexP
+ Number nu <- lexP
+ n <- maybe empty pure $ numberToInteger nu
+ fromListN (fromIntegral n) <$> readPrec
+
+smallArrayDataType :: DataType
+smallArrayDataType =
+ mkDataType "Data.Primitive.SmallArray.SmallArray" [fromListConstr]
+
+fromListConstr :: Constr
+fromListConstr = mkConstr smallArrayDataType "fromList" [] Prefix
+
+instance Data a => Data (SmallArray a) where
+ toConstr _ = fromListConstr
+ dataTypeOf _ = smallArrayDataType
+ gunfold k z c = case constrIndex c of
+ 1 -> k (z fromList)
+ _ -> die "gunfold" "SmallArray"
+ gfoldl f z m = z fromList `f` toList m
+
+instance (Typeable s, Typeable a) => Data (SmallMutableArray s a) where
+ toConstr _ = die "toConstr" "SmallMutableArray"
+ gunfold _ _ = die "gunfold" "SmallMutableArray"
+ dataTypeOf _ = mkNoRepType "Data.Primitive.SmallArray.SmallMutableArray"
+#endif
diff --git a/benchmarks/PPoPP2019/src/primitive-0.6.3.0/Data/Primitive/Types.hs b/benchmarks/PPoPP2019/src/primitive-0.6.3.0/Data/Primitive/Types.hs
new file mode 100644
index 0000000..b7d2c7c
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/primitive-0.6.3.0/Data/Primitive/Types.hs
@@ -0,0 +1,207 @@
+{-# LANGUAGE CPP, UnboxedTuples, MagicHash, DeriveDataTypeable #-}
+
+-- |
+-- Module : Data.Primitive.Types
+-- Copyright : (c) Roman Leshchinskiy 2009-2012
+-- License : BSD-style
+--
+-- Maintainer : Roman Leshchinskiy
+-- Portability : non-portable
+--
+-- Basic types and classes for primitive array operations
+--
+
+module Data.Primitive.Types (
+ Prim(..),
+ sizeOf, alignment,
+
+ Addr(..),
+) where
+
+import Control.Monad.Primitive
+import Data.Primitive.MachDeps
+import Data.Primitive.Internal.Operations
+
+import GHC.Base (
+ Int(..), Char(..),
+ )
+import GHC.Float (
+ Float(..), Double(..)
+ )
+import GHC.Word (
+ Word(..), Word8(..), Word16(..), Word32(..), Word64(..)
+ )
+import GHC.Int (
+ Int8(..), Int16(..), Int32(..), Int64(..)
+ )
+
+import GHC.Ptr (
+ Ptr(..), FunPtr(..)
+ )
+
+import GHC.Prim
+#if __GLASGOW_HASKELL__ >= 706
+ hiding (setByteArray#)
+#endif
+
+import Data.Typeable ( Typeable )
+import Data.Data ( Data(..) )
+import Data.Primitive.Internal.Compat ( isTrue#, mkNoRepType )
+
+-- | A machine address
+data Addr = Addr Addr# deriving ( Typeable )
+
+instance Eq Addr where
+ Addr a# == Addr b# = isTrue# (eqAddr# a# b#)
+ Addr a# /= Addr b# = isTrue# (neAddr# a# b#)
+
+instance Ord Addr where
+ Addr a# > Addr b# = isTrue# (gtAddr# a# b#)
+ Addr a# >= Addr b# = isTrue# (geAddr# a# b#)
+ Addr a# < Addr b# = isTrue# (ltAddr# a# b#)
+ Addr a# <= Addr b# = isTrue# (leAddr# a# b#)
+
+instance Data Addr where
+ toConstr _ = error "toConstr"
+ gunfold _ _ = error "gunfold"
+ dataTypeOf _ = mkNoRepType "Data.Primitive.Types.Addr"
+
+
+-- | Class of types supporting primitive array operations
+class Prim a where
+
+ -- | Size of values of type @a@. The argument is not used.
+ sizeOf# :: a -> Int#
+
+ -- | Alignment of values of type @a@. The argument is not used.
+ alignment# :: a -> Int#
+
+ -- | Read a value from the array. The offset is in elements of type
+ -- @a@ rather than in bytes.
+ indexByteArray# :: ByteArray# -> Int# -> a
+
+ -- | Read a value from the mutable array. The offset is in elements of type
+ -- @a@ rather than in bytes.
+ readByteArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, a #)
+
+ -- | Write a value to the mutable array. The offset is in elements of type
+ -- @a@ rather than in bytes.
+ writeByteArray# :: MutableByteArray# s -> Int# -> a -> State# s -> State# s
+
+ -- | Fill a slice of the mutable array with a value. The offset and length
+ -- of the chunk are in elements of type @a@ rather than in bytes.
+ setByteArray# :: MutableByteArray# s -> Int# -> Int# -> a -> State# s -> State# s
+
+ -- | Read a value from a memory position given by an address and an offset.
+ -- The memory block the address refers to must be immutable. The offset is in
+ -- elements of type @a@ rather than in bytes.
+ indexOffAddr# :: Addr# -> Int# -> a
+
+ -- | Read a value from a memory position given by an address and an offset.
+ -- The offset is in elements of type @a@ rather than in bytes.
+ readOffAddr# :: Addr# -> Int# -> State# s -> (# State# s, a #)
+
+ -- | Write a value to a memory position given by an address and an offset.
+ -- The offset is in elements of type @a@ rather than in bytes.
+ writeOffAddr# :: Addr# -> Int# -> a -> State# s -> State# s
+
+ -- | Fill a memory block given by an address, an offset and a length.
+ -- The offset and length are in elements of type @a@ rather than in bytes.
+ setOffAddr# :: Addr# -> Int# -> Int# -> a -> State# s -> State# s
+
+-- | Size of values of type @a@. The argument is not used.
+sizeOf :: Prim a => a -> Int
+sizeOf x = I# (sizeOf# x)
+
+-- | Alignment of values of type @a@. The argument is not used.
+alignment :: Prim a => a -> Int
+alignment x = I# (alignment# x)
+
+#define derivePrim(ty, ctr, sz, align, idx_arr, rd_arr, wr_arr, set_arr, idx_addr, rd_addr, wr_addr, set_addr) \
+instance Prim (ty) where { \
+ sizeOf# _ = unI# sz \
+; alignment# _ = unI# align \
+; indexByteArray# arr# i# = ctr (idx_arr arr# i#) \
+; readByteArray# arr# i# s# = case rd_arr arr# i# s# of \
+ { (# s1#, x# #) -> (# s1#, ctr x# #) } \
+; writeByteArray# arr# i# (ctr x#) s# = wr_arr arr# i# x# s# \
+; setByteArray# arr# i# n# (ctr x#) s# \
+ = let { i = fromIntegral (I# i#) \
+ ; n = fromIntegral (I# n#) \
+ } in \
+ case unsafeCoerce# (internal (set_arr arr# i n x#)) s# of \
+ { (# s1#, _ #) -> s1# } \
+ \
+; indexOffAddr# addr# i# = ctr (idx_addr addr# i#) \
+; readOffAddr# addr# i# s# = case rd_addr addr# i# s# of \
+ { (# s1#, x# #) -> (# s1#, ctr x# #) } \
+; writeOffAddr# addr# i# (ctr x#) s# = wr_addr addr# i# x# s# \
+; setOffAddr# addr# i# n# (ctr x#) s# \
+ = let { i = fromIntegral (I# i#) \
+ ; n = fromIntegral (I# n#) \
+ } in \
+ case unsafeCoerce# (internal (set_addr addr# i n x#)) s# of \
+ { (# s1#, _ #) -> s1# } \
+; {-# INLINE sizeOf# #-} \
+; {-# INLINE alignment# #-} \
+; {-# INLINE indexByteArray# #-} \
+; {-# INLINE readByteArray# #-} \
+; {-# INLINE writeByteArray# #-} \
+; {-# INLINE setByteArray# #-} \
+; {-# INLINE indexOffAddr# #-} \
+; {-# INLINE readOffAddr# #-} \
+; {-# INLINE writeOffAddr# #-} \
+; {-# INLINE setOffAddr# #-} \
+}
+
+unI# :: Int -> Int#
+unI# (I# n#) = n#
+
+derivePrim(Word, W#, sIZEOF_WORD, aLIGNMENT_WORD,
+ indexWordArray#, readWordArray#, writeWordArray#, setWordArray#,
+ indexWordOffAddr#, readWordOffAddr#, writeWordOffAddr#, setWordOffAddr#)
+derivePrim(Word8, W8#, sIZEOF_WORD8, aLIGNMENT_WORD8,
+ indexWord8Array#, readWord8Array#, writeWord8Array#, setWord8Array#,
+ indexWord8OffAddr#, readWord8OffAddr#, writeWord8OffAddr#, setWord8OffAddr#)
+derivePrim(Word16, W16#, sIZEOF_WORD16, aLIGNMENT_WORD16,
+ indexWord16Array#, readWord16Array#, writeWord16Array#, setWord16Array#,
+ indexWord16OffAddr#, readWord16OffAddr#, writeWord16OffAddr#, setWord16OffAddr#)
+derivePrim(Word32, W32#, sIZEOF_WORD32, aLIGNMENT_WORD32,
+ indexWord32Array#, readWord32Array#, writeWord32Array#, setWord32Array#,
+ indexWord32OffAddr#, readWord32OffAddr#, writeWord32OffAddr#, setWord32OffAddr#)
+derivePrim(Word64, W64#, sIZEOF_WORD64, aLIGNMENT_WORD64,
+ indexWord64Array#, readWord64Array#, writeWord64Array#, setWord64Array#,
+ indexWord64OffAddr#, readWord64OffAddr#, writeWord64OffAddr#, setWord64OffAddr#)
+derivePrim(Int, I#, sIZEOF_INT, aLIGNMENT_INT,
+ indexIntArray#, readIntArray#, writeIntArray#, setIntArray#,
+ indexIntOffAddr#, readIntOffAddr#, writeIntOffAddr#, setIntOffAddr#)
+derivePrim(Int8, I8#, sIZEOF_INT8, aLIGNMENT_INT8,
+ indexInt8Array#, readInt8Array#, writeInt8Array#, setInt8Array#,
+ indexInt8OffAddr#, readInt8OffAddr#, writeInt8OffAddr#, setInt8OffAddr#)
+derivePrim(Int16, I16#, sIZEOF_INT16, aLIGNMENT_INT16,
+ indexInt16Array#, readInt16Array#, writeInt16Array#, setInt16Array#,
+ indexInt16OffAddr#, readInt16OffAddr#, writeInt16OffAddr#, setInt16OffAddr#)
+derivePrim(Int32, I32#, sIZEOF_INT32, aLIGNMENT_INT32,
+ indexInt32Array#, readInt32Array#, writeInt32Array#, setInt32Array#,
+ indexInt32OffAddr#, readInt32OffAddr#, writeInt32OffAddr#, setInt32OffAddr#)
+derivePrim(Int64, I64#, sIZEOF_INT64, aLIGNMENT_INT64,
+ indexInt64Array#, readInt64Array#, writeInt64Array#, setInt64Array#,
+ indexInt64OffAddr#, readInt64OffAddr#, writeInt64OffAddr#, setInt64OffAddr#)
+derivePrim(Float, F#, sIZEOF_FLOAT, aLIGNMENT_FLOAT,
+ indexFloatArray#, readFloatArray#, writeFloatArray#, setFloatArray#,
+ indexFloatOffAddr#, readFloatOffAddr#, writeFloatOffAddr#, setFloatOffAddr#)
+derivePrim(Double, D#, sIZEOF_DOUBLE, aLIGNMENT_DOUBLE,
+ indexDoubleArray#, readDoubleArray#, writeDoubleArray#, setDoubleArray#,
+ indexDoubleOffAddr#, readDoubleOffAddr#, writeDoubleOffAddr#, setDoubleOffAddr#)
+derivePrim(Char, C#, sIZEOF_CHAR, aLIGNMENT_CHAR,
+ indexWideCharArray#, readWideCharArray#, writeWideCharArray#, setWideCharArray#,
+ indexWideCharOffAddr#, readWideCharOffAddr#, writeWideCharOffAddr#, setWideCharOffAddr#)
+derivePrim(Addr, Addr, sIZEOF_PTR, aLIGNMENT_PTR,
+ indexAddrArray#, readAddrArray#, writeAddrArray#, setAddrArray#,
+ indexAddrOffAddr#, readAddrOffAddr#, writeAddrOffAddr#, setAddrOffAddr#)
+derivePrim(Ptr a, Ptr, sIZEOF_PTR, aLIGNMENT_PTR,
+ indexAddrArray#, readAddrArray#, writeAddrArray#, setAddrArray#,
+ indexAddrOffAddr#, readAddrOffAddr#, writeAddrOffAddr#, setAddrOffAddr#)
+derivePrim(FunPtr a, FunPtr, sIZEOF_PTR, aLIGNMENT_PTR,
+ indexAddrArray#, readAddrArray#, writeAddrArray#, setAddrArray#,
+ indexAddrOffAddr#, readAddrOffAddr#, writeAddrOffAddr#, setAddrOffAddr#)
diff --git a/benchmarks/PPoPP2019/src/primitive-0.6.3.0/Data/Primitive/UnliftedArray.hs b/benchmarks/PPoPP2019/src/primitive-0.6.3.0/Data/Primitive/UnliftedArray.hs
new file mode 100644
index 0000000..ce26845
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/primitive-0.6.3.0/Data/Primitive/UnliftedArray.hs
@@ -0,0 +1,365 @@
+{-# Language MagicHash #-}
+{-# Language UnboxedTuples #-}
+{-# Language DeriveDataTypeable #-}
+
+-- |
+-- Module : Data.Primitive.UnliftedArray
+-- Copyright : (c) Dan Doel 2016
+-- License : BSD-style
+--
+-- Maintainer : Libraries
+-- Portability : non-portable
+--
+-- GHC contains three general classes of value types:
+--
+-- 1. Unboxed types: values are machine values made up of fixed numbers of bytes
+-- 2. Unlifted types: values are pointers, but strictly evaluated
+-- 3. Lifted types: values are pointers, lazily evaluated
+--
+-- The first category can be stored in a 'ByteArray', and this allows types in
+-- category 3 that are simple wrappers around category 1 types to be stored
+-- more efficiently using a 'ByteArray'. This module provides the same facility
+-- for category 2 types.
+--
+-- GHC has two primitive types, 'ArrayArray#' and 'MutableArrayArray#'. These
+-- are arrays of pointers, but of category 2 values, so they are known to not
+-- be bottom. This allows types that are wrappers around such types to be stored
+-- in an array without an extra level of indirection.
+--
+-- The way that the 'ArrayArray#' API works is that one can read and write
+-- 'ArrayArray#' values to the positions. This works because all category 2
+-- types share a uniform representation, unlike unboxed values which are
+-- represented by varying (by type) numbers of bytes. However, using the
+-- this makes the internal API very unsafe to use, as one has to coerce values
+-- to and from 'ArrayArray#'.
+--
+-- The API presented by this module is more type safe. 'UnliftedArray' and
+-- 'MutableUnliftedArray' are parameterized by the type of arrays they contain, and
+-- the coercions necessary are abstracted into a class, 'PrimUnlifted', of things
+-- that are eligible to be stored.
+
+module Data.Primitive.UnliftedArray
+ ( UnliftedArray(..)
+ , MutableUnliftedArray(..)
+ , PrimUnlifted(..)
+ , unsafeNewUnliftedArray
+ , newUnliftedArray
+ , setUnliftedArray
+ , sizeofUnliftedArray
+ , sizeofMutableUnliftedArray
+ , readUnliftedArray
+ , writeUnliftedArray
+ , indexUnliftedArray
+ , indexUnliftedArrayM
+ , unsafeFreezeUnliftedArray
+ , freezeUnliftedArray
+ , thawUnliftedArray
+ , sameMutableUnliftedArray
+ , copyUnliftedArray
+ , copyMutableUnliftedArray
+ , cloneUnliftedArray
+ , cloneMutableUnliftedArray
+-- Missing operations:
+-- , unsafeThawUnliftedArray
+ ) where
+
+import Data.Typeable
+
+import GHC.Prim
+import GHC.Base (Int(..))
+
+import Control.Monad.Primitive
+
+import Control.Monad.ST (runST)
+
+import Data.Primitive.Internal.Compat ( isTrue# )
+
+import Data.Primitive.Array (Array)
+import qualified Data.Primitive.Array as A
+import Data.Primitive.ByteArray (ByteArray)
+import qualified Data.Primitive.ByteArray as BA
+import qualified Data.Primitive.SmallArray as SA
+import qualified Data.Primitive.MutVar as MV
+
+-- | Immutable arrays that efficiently store types that are simple wrappers
+-- around unlifted primitive types. The values of the unlifted type are
+-- stored directly, eliminating a layer of indirection.
+data UnliftedArray e = UnliftedArray ArrayArray#
+ deriving (Typeable)
+
+-- | Mutable arrays that efficiently store types that are simple wrappers
+-- around unlifted primitive types. The values of the unlifted type are
+-- stored directly, eliminating a layer of indirection.
+data MutableUnliftedArray s e = MutableUnliftedArray (MutableArrayArray# s)
+ deriving (Typeable)
+
+-- | Classifies the types that are able to be stored in 'UnliftedArray' and
+-- 'MutableUnliftedArray'. These should be types that are just liftings of the
+-- unlifted pointer types, so that their internal contents can be safely coerced
+-- into an 'ArrayArray#'.
+class PrimUnlifted a where
+ toArrayArray# :: a -> ArrayArray#
+ fromArrayArray# :: ArrayArray# -> a
+
+instance PrimUnlifted (UnliftedArray e) where
+ toArrayArray# (UnliftedArray aa#) = aa#
+ fromArrayArray# aa# = UnliftedArray aa#
+
+instance PrimUnlifted (MutableUnliftedArray s e) where
+ toArrayArray# (MutableUnliftedArray maa#) = unsafeCoerce# maa#
+ fromArrayArray# aa# = MutableUnliftedArray (unsafeCoerce# aa#)
+
+instance PrimUnlifted (Array a) where
+ toArrayArray# (A.Array a#) = unsafeCoerce# a#
+ fromArrayArray# aa# = A.Array (unsafeCoerce# aa#)
+
+instance PrimUnlifted (A.MutableArray s a) where
+ toArrayArray# (A.MutableArray ma#) = unsafeCoerce# ma#
+ fromArrayArray# aa# = A.MutableArray (unsafeCoerce# aa#)
+
+instance PrimUnlifted ByteArray where
+ toArrayArray# (BA.ByteArray ba#) = unsafeCoerce# ba#
+ fromArrayArray# aa# = BA.ByteArray (unsafeCoerce# aa#)
+
+instance PrimUnlifted (BA.MutableByteArray s) where
+ toArrayArray# (BA.MutableByteArray mba#) = unsafeCoerce# mba#
+ fromArrayArray# aa# = BA.MutableByteArray (unsafeCoerce# aa#)
+
+instance PrimUnlifted (SA.SmallArray a) where
+ toArrayArray# (SA.SmallArray sa#) = unsafeCoerce# sa#
+ fromArrayArray# aa# = SA.SmallArray (unsafeCoerce# aa#)
+
+instance PrimUnlifted (SA.SmallMutableArray s a) where
+ toArrayArray# (SA.SmallMutableArray sma#) = unsafeCoerce# sma#
+ fromArrayArray# aa# = SA.SmallMutableArray (unsafeCoerce# aa#)
+
+instance PrimUnlifted (MV.MutVar s a) where
+ toArrayArray# (MV.MutVar mv#) = unsafeCoerce# mv#
+ fromArrayArray# aa# = MV.MutVar (unsafeCoerce# aa#)
+
+-- | Creates a new 'MutableUnliftedArray'. This function is unsafe, because it
+-- allows access to the raw contents of the underlying 'ArrayArray#'.
+unsafeNewUnliftedArray
+ :: (PrimMonad m)
+ => Int -- ^ size
+ -> m (MutableUnliftedArray (PrimState m) a)
+unsafeNewUnliftedArray (I# i#) = primitive $ \s -> case newArrayArray# i# s of
+ (# s', maa# #) -> (# s', MutableUnliftedArray maa# #)
+{-# inline unsafeNewUnliftedArray #-}
+
+-- | Sets all the positions in an unlifted array to the designated value.
+setUnliftedArray
+ :: (PrimMonad m, PrimUnlifted a)
+ => MutableUnliftedArray (PrimState m) a -- ^ destination
+ -> a -- ^ value to fill with
+ -> m ()
+setUnliftedArray mua v = loop $ sizeofMutableUnliftedArray mua - 1
+ where
+ loop i | i < 0 = return ()
+ | otherwise = writeUnliftedArray mua i v >> loop (i-1)
+{-# inline setUnliftedArray #-}
+
+-- | Creates a new 'MutableUnliftedArray' with the specified value as initial
+-- contents. This is slower than 'unsafeNewUnliftedArray', but safer.
+newUnliftedArray
+ :: (PrimMonad m, PrimUnlifted a)
+ => Int -- ^ size
+ -> a -- ^ initial value
+ -> m (MutableUnliftedArray (PrimState m) a)
+newUnliftedArray len v =
+ unsafeNewUnliftedArray len >>= \mua -> setUnliftedArray mua v >> return mua
+{-# inline newUnliftedArray #-}
+
+-- | Yields the length of an 'UnliftedArray'.
+sizeofUnliftedArray :: UnliftedArray e -> Int
+sizeofUnliftedArray (UnliftedArray aa#) = I# (sizeofArrayArray# aa#)
+{-# inline sizeofUnliftedArray #-}
+
+-- | Yields the length of a 'MutableUnliftedArray'.
+sizeofMutableUnliftedArray :: MutableUnliftedArray s e -> Int
+sizeofMutableUnliftedArray (MutableUnliftedArray maa#)
+ = I# (sizeofMutableArrayArray# maa#)
+{-# inline sizeofMutableUnliftedArray #-}
+
+-- Internal indexing function.
+--
+-- Note: ArrayArray# is strictly evaluated, so this should have similar
+-- consequences to indexArray#, where matching on the unboxed single causes the
+-- array access to happen.
+indexUnliftedArrayU
+ :: PrimUnlifted a
+ => UnliftedArray a
+ -> Int
+ -> (# a #)
+indexUnliftedArrayU (UnliftedArray src#) (I# i#)
+ = case indexArrayArrayArray# src# i# of
+ aa# -> (# fromArrayArray# aa# #)
+{-# inline indexUnliftedArrayU #-}
+
+-- | Gets the value at the specified position of an 'UnliftedArray'.
+indexUnliftedArray
+ :: PrimUnlifted a
+ => UnliftedArray a -- ^ source
+ -> Int -- ^ index
+ -> a
+indexUnliftedArray ua i
+ = case indexUnliftedArrayU ua i of (# v #) -> v
+{-# inline indexUnliftedArray #-}
+
+-- | Gets the value at the specified position of an 'UnliftedArray'.
+-- The purpose of the 'Monad' is to allow for being eager in the
+-- 'UnliftedArray' value without having to introduce a data dependency
+-- directly on the result value.
+--
+-- It should be noted that this is not as much of a problem as with a normal
+-- 'Array', because elements of an 'UnliftedArray' are guaranteed to not
+-- be exceptional. This function is provided in case it is more desirable
+-- than being strict in the result value.
+indexUnliftedArrayM
+ :: (PrimUnlifted a, Monad m)
+ => UnliftedArray a -- ^ source
+ -> Int -- ^ index
+ -> m a
+indexUnliftedArrayM ua i
+ = case indexUnliftedArrayU ua i of
+ (# v #) -> return v
+{-# inline indexUnliftedArrayM #-}
+
+-- | Gets the value at the specified position of a 'MutableUnliftedArray'.
+readUnliftedArray
+ :: (PrimMonad m, PrimUnlifted a)
+ => MutableUnliftedArray (PrimState m) a -- ^ source
+ -> Int -- ^ index
+ -> m a
+readUnliftedArray (MutableUnliftedArray maa#) (I# i#)
+ = primitive $ \s -> case readArrayArrayArray# maa# i# s of
+ (# s', aa# #) -> (# s', fromArrayArray# aa# #)
+{-# inline readUnliftedArray #-}
+
+-- | Sets the value at the specified position of a 'MutableUnliftedArray'.
+writeUnliftedArray
+ :: (PrimMonad m, PrimUnlifted a)
+ => MutableUnliftedArray (PrimState m) a -- ^ destination
+ -> Int -- ^ index
+ -> a -- ^ value
+ -> m ()
+writeUnliftedArray (MutableUnliftedArray maa#) (I# i#) a
+ = primitive_ (writeArrayArrayArray# maa# i# (toArrayArray# a))
+{-# inline writeUnliftedArray #-}
+
+-- | Freezes a 'MutableUnliftedArray', yielding an 'UnliftedArray'. This simply
+-- marks the array as frozen in place, so it should only be used when no further
+-- modifications to the mutable array will be performed.
+unsafeFreezeUnliftedArray
+ :: (PrimMonad m)
+ => MutableUnliftedArray (PrimState m) a
+ -> m (UnliftedArray a)
+unsafeFreezeUnliftedArray (MutableUnliftedArray maa#)
+ = primitive $ \s -> case unsafeFreezeArrayArray# maa# s of
+ (# s', aa# #) -> (# s', UnliftedArray aa# #)
+{-# inline unsafeFreezeUnliftedArray #-}
+
+-- | Determines whether two 'MutableUnliftedArray' values are the same. This is
+-- object/pointer identity, not based on the contents.
+sameMutableUnliftedArray
+ :: MutableUnliftedArray s a
+ -> MutableUnliftedArray s a
+ -> Bool
+sameMutableUnliftedArray (MutableUnliftedArray maa1#) (MutableUnliftedArray maa2#)
+ = isTrue# (sameMutableArrayArray# maa1# maa2#)
+{-# inline sameMutableUnliftedArray #-}
+
+-- | Copies the contents of an immutable array into a mutable array.
+copyUnliftedArray
+ :: (PrimMonad m)
+ => MutableUnliftedArray (PrimState m) a -- ^ destination
+ -> Int -- ^ offset into destination
+ -> UnliftedArray a -- ^ source
+ -> Int -- ^ offset into source
+ -> Int -- ^ number of elements to copy
+ -> m ()
+copyUnliftedArray
+ (MutableUnliftedArray dst) (I# doff)
+ (UnliftedArray src) (I# soff) (I# ln) =
+ primitive_ $ copyArrayArray# src soff dst doff ln
+{-# inline copyUnliftedArray #-}
+
+-- | Copies the contents of one mutable array into another.
+copyMutableUnliftedArray
+ :: (PrimMonad m)
+ => MutableUnliftedArray (PrimState m) a -- ^ destination
+ -> Int -- ^ offset into destination
+ -> MutableUnliftedArray (PrimState m) a -- ^ source
+ -> Int -- ^ offset into source
+ -> Int -- ^ number of elements to copy
+ -> m ()
+copyMutableUnliftedArray
+ (MutableUnliftedArray dst) (I# doff)
+ (MutableUnliftedArray src) (I# soff) (I# ln) =
+ primitive_ $ copyMutableArrayArray# src soff dst doff ln
+{-# inline copyMutableUnliftedArray #-}
+
+-- | Freezes a portion of a 'MutableUnliftedArray', yielding an 'UnliftedArray'.
+-- This operation is safe, in that it copies the frozen portion, and the
+-- existing mutable array may still be used afterward.
+freezeUnliftedArray
+ :: (PrimMonad m)
+ => MutableUnliftedArray (PrimState m) a -- ^ source
+ -> Int -- ^ offset
+ -> Int -- ^ length
+ -> m (UnliftedArray a)
+freezeUnliftedArray src off len = do
+ dst <- unsafeNewUnliftedArray len
+ copyMutableUnliftedArray dst 0 src off len
+ unsafeFreezeUnliftedArray dst
+{-# inline freezeUnliftedArray #-}
+
+-- | Thaws a portion of an 'UnliftedArray', yielding a 'MutableUnliftedArray'.
+-- This copies the thawed portion, so mutations will not affect the original
+-- array.
+thawUnliftedArray
+ :: (PrimMonad m)
+ => UnliftedArray a -- ^ source
+ -> Int -- ^ offset
+ -> Int -- ^ length
+ -> m (MutableUnliftedArray (PrimState m) a)
+thawUnliftedArray src off len = do
+ dst <- unsafeNewUnliftedArray len
+ copyUnliftedArray dst 0 src off len
+ return dst
+{-# inline thawUnliftedArray #-}
+
+-- | Creates a copy of a portion of an 'UnliftedArray'
+cloneUnliftedArray
+ :: UnliftedArray a -- ^ source
+ -> Int -- ^ offset
+ -> Int -- ^ length
+ -> UnliftedArray a
+cloneUnliftedArray src off len =
+ runST $ thawUnliftedArray src off len >>= unsafeFreezeUnliftedArray
+{-# inline cloneUnliftedArray #-}
+
+-- | Creates a new 'MutableUnliftedArray' containing a copy of a portion of
+-- another mutable array.
+cloneMutableUnliftedArray
+ :: (PrimMonad m)
+ => MutableUnliftedArray (PrimState m) a -- ^ source
+ -> Int -- ^ offset
+ -> Int -- ^ length
+ -> m (MutableUnliftedArray (PrimState m) a)
+cloneMutableUnliftedArray src off len = do
+ dst <- unsafeNewUnliftedArray len
+ copyMutableUnliftedArray dst 0 src off len
+ return dst
+{-# inline cloneMutableUnliftedArray #-}
+
+instance Eq (MutableUnliftedArray s a) where
+ (==) = sameMutableUnliftedArray
+
+instance (Eq a, PrimUnlifted a) => Eq (UnliftedArray a) where
+ aa1 == aa2 = sizeofUnliftedArray aa1 == sizeofUnliftedArray aa2
+ && loop (sizeofUnliftedArray aa1 - 1)
+ where
+ loop i
+ | i < 0 = True
+ | otherwise = indexUnliftedArray aa1 i == indexUnliftedArray aa2 i && loop (i-1)
diff --git a/benchmarks/PPoPP2019/src/primitive-0.6.3.0/LICENSE b/benchmarks/PPoPP2019/src/primitive-0.6.3.0/LICENSE
new file mode 100644
index 0000000..fc213a6
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/primitive-0.6.3.0/LICENSE
@@ -0,0 +1,30 @@
+Copyright (c) 2008-2009, Roman Leshchinskiy
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+- Redistributions of source code must retain the above copyright notice,
+this list of conditions and the following disclaimer.
+
+- Redistributions in binary form must reproduce the above copyright notice,
+this list of conditions and the following disclaimer in the documentation
+and/or other materials provided with the distribution.
+
+- Neither name of the University nor the names of its contributors may be
+used to endorse or promote products derived from this software without
+specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF
+GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
+DAMAGE.
+
diff --git a/benchmarks/PPoPP2019/src/primitive-0.6.3.0/Setup.hs b/benchmarks/PPoPP2019/src/primitive-0.6.3.0/Setup.hs
new file mode 100644
index 0000000..200a2e5
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/primitive-0.6.3.0/Setup.hs
@@ -0,0 +1,3 @@
+import Distribution.Simple
+main = defaultMain
+
diff --git a/benchmarks/PPoPP2019/src/primitive-0.6.3.0/cbits/primitive-memops.c b/benchmarks/PPoPP2019/src/primitive-0.6.3.0/cbits/primitive-memops.c
new file mode 100644
index 0000000..81b1d6f
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/primitive-0.6.3.0/cbits/primitive-memops.c
@@ -0,0 +1,56 @@
+#include
+#include "primitive-memops.h"
+
+void hsprimitive_memcpy( void *dst, ptrdiff_t doff, void *src, ptrdiff_t soff, size_t len )
+{
+ memcpy( (char *)dst + doff, (char *)src + soff, len );
+}
+
+void hsprimitive_memmove( void *dst, ptrdiff_t doff, void *src, ptrdiff_t soff, size_t len )
+{
+ memmove( (char *)dst + doff, (char *)src + soff, len );
+}
+
+#define MEMSET(TYPE, ATYPE) \
+void hsprimitive_memset_ ## TYPE (Hs ## TYPE *p, ptrdiff_t off, size_t n, ATYPE x) \
+{ \
+ p += off; \
+ if (x == 0) \
+ memset(p, 0, n * sizeof(Hs ## TYPE)); \
+ else if (sizeof(Hs ## TYPE) == sizeof(int)*2) { \
+ int *q = (int *)p; \
+ const int *r = (const int *)(void *)&x; \
+ while (n>0) { \
+ q[0] = r[0]; \
+ q[1] = r[1]; \
+ q += 2; \
+ --n; \
+ } \
+ } \
+ else { \
+ while (n>0) { \
+ *p++ = x; \
+ --n; \
+ } \
+ } \
+}
+
+int hsprimitive_memcmp( HsWord8 *s1, HsWord8 *s2, size_t n )
+{
+ return memcmp( s1, s2, n );
+}
+
+void hsprimitive_memset_Word8 (HsWord8 *p, ptrdiff_t off, size_t n, HsWord x)
+{
+ memset( (char *)(p+off), x, n );
+}
+
+/* MEMSET(HsWord8, HsWord) */
+MEMSET(Word16, HsWord)
+MEMSET(Word32, HsWord)
+MEMSET(Word64, HsWord64)
+MEMSET(Word, HsWord)
+MEMSET(Ptr, HsPtr)
+MEMSET(Float, HsFloat)
+MEMSET(Double, HsDouble)
+MEMSET(Char, HsChar)
diff --git a/benchmarks/PPoPP2019/src/primitive-0.6.3.0/cbits/primitive-memops.h b/benchmarks/PPoPP2019/src/primitive-0.6.3.0/cbits/primitive-memops.h
new file mode 100644
index 0000000..d7c3396
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/primitive-0.6.3.0/cbits/primitive-memops.h
@@ -0,0 +1,23 @@
+#ifndef haskell_primitive_memops_h
+#define haskell_primitive_memops_h
+
+#include
+#include
+#include
+
+void hsprimitive_memcpy( void *dst, ptrdiff_t doff, void *src, ptrdiff_t soff, size_t len );
+void hsprimitive_memmove( void *dst, ptrdiff_t doff, void *src, ptrdiff_t soff, size_t len );
+int hsprimitive_memcmp( HsWord8 *s1, HsWord8 *s2, size_t n );
+
+void hsprimitive_memset_Word8 (HsWord8 *, ptrdiff_t, size_t, HsWord);
+void hsprimitive_memset_Word16 (HsWord16 *, ptrdiff_t, size_t, HsWord);
+void hsprimitive_memset_Word32 (HsWord32 *, ptrdiff_t, size_t, HsWord);
+void hsprimitive_memset_Word64 (HsWord64 *, ptrdiff_t, size_t, HsWord64);
+void hsprimitive_memset_Word (HsWord *, ptrdiff_t, size_t, HsWord);
+void hsprimitive_memset_Ptr (HsPtr *, ptrdiff_t, size_t, HsPtr);
+void hsprimitive_memset_Float (HsFloat *, ptrdiff_t, size_t, HsFloat);
+void hsprimitive_memset_Double (HsDouble *, ptrdiff_t, size_t, HsDouble);
+void hsprimitive_memset_Char (HsChar *, ptrdiff_t, size_t, HsChar);
+
+#endif
+
diff --git a/benchmarks/PPoPP2019/src/primitive-0.6.3.0/changelog.md b/benchmarks/PPoPP2019/src/primitive-0.6.3.0/changelog.md
new file mode 100644
index 0000000..7ecfaec
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/primitive-0.6.3.0/changelog.md
@@ -0,0 +1,103 @@
+## Changes in version 0.6.3.0
+
+ * Add `PrimMonad` instances for `ContT`, `AccumT`, and `SelectT` from
+ `transformers`
+
+ * Add `Eq`, `Ord`, `Show`, and `IsList` instances for `ByteArray`
+
+ * Add `Semigroup` instances for `Array` and `SmallArray`. This allows
+ `primitive` to build on GHC 8.4 and later.
+
+## Changes in version 0.6.2.0
+
+ * Drop support for GHCs before 7.4
+
+ * `SmallArray` support
+
+ * `ArrayArray#` based support for more efficient arrays of unlifted pointer types
+
+ * Make `Array` and the like instances of various classes for convenient use
+
+ * Add `Prim` instances for Ptr and FunPtr
+
+ * Add `ioToPrim`, `stToPrim` and unsafe counterparts for situations that would
+ otherwise require type ascriptions on `primToPrim`
+
+ * Add `evalPrim`
+
+ * Add `PrimBase` instance for `IdentityT`
+
+## Changes in version 0.6.1.0
+
+ * Use more appropriate types in internal memset functions, which prevents
+ overflows/segfaults on 64-bit systems.
+
+ * Fixed a warning on GHC 7.10
+
+ * Worked around a -dcore-lint bug in GHC 7.6/7.7
+
+## Changes in version 0.6
+
+ * Split PrimMonad into two classes to allow automatic lifting of primitive
+ operations into monad transformers. The `internal` operation has moved to the
+ `PrimBase` class.
+
+ * Fixed the test suite on older GHCs
+
+## Changes in version 0.5.4.0
+
+ * Changed primitive_ to work around an oddity with GHC's code generation
+ on certain versions that led to side effects not happening when used
+ in conjunction with certain very unsafe IO performers.
+
+ * Allow primitive to build on GHC 7.9
+
+## Changes in version 0.5.3.0
+
+ * Implement `cloneArray` and `cloneMutableArray` primitives
+ (with fall-back implementations for GHCs prior to version 7.2.1)
+
+## Changes in version 0.5.2.1
+
+ * Add strict variants of `MutVar` modification functions
+ `atomicModifyMutVar'` and `modifyMutVar'`
+
+ * Fix compilation on Solaris 10 with GNU C 3.4.3
+
+## Changes in version 0.5.1.0
+
+ * Add support for GHC 7.7's new primitive `Bool` representation
+
+## Changes in version 0.5.0.1
+
+ * Disable array copying primitives for GHC 7.6.* and earlier
+
+## Changes in version 0.5
+
+ * New in `Data.Primitive.MutVar`: `atomicModifyMutVar`
+
+ * Efficient block fill operations: `setByteArray`, `setAddr`
+
+## Changes in version 0.4.1
+
+ * New module `Data.Primitive.MutVar`
+
+## Changes in version 0.4.0.1
+
+ * Critical bug fix in `fillByteArray`
+
+## Changes in version 0.4
+
+ * Support for GHC 7.2 array copying primitives
+
+ * New in `Data.Primitive.ByteArray`: `copyByteArray`,
+ `copyMutableByteArray`, `moveByteArray`, `fillByteArray`
+
+ * Deprecated in `Data.Primitive.ByteArray`: `memcpyByteArray`,
+ `memcpyByteArray'`, `memmoveByteArray`, `memsetByteArray`
+
+ * New in `Data.Primitive.Array`: `copyArray`, `copyMutableByteArray`
+
+ * New in `Data.Primitive.Addr`: `copyAddr`, `moveAddr`
+
+ * Deprecated in `Data.Primitive.Addr`: `memcpyAddr`
diff --git a/benchmarks/PPoPP2019/src/primitive-0.6.3.0/primitive.cabal b/benchmarks/PPoPP2019/src/primitive-0.6.3.0/primitive.cabal
new file mode 100644
index 0000000..f5a4644
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/primitive-0.6.3.0/primitive.cabal
@@ -0,0 +1,78 @@
+Name: primitive
+Version: 0.6.3.0
+License: BSD3
+License-File: LICENSE
+
+Author: Roman Leshchinskiy
+Maintainer: libraries@haskell.org
+Copyright: (c) Roman Leshchinskiy 2009-2012
+Homepage: https://github.com/haskell/primitive
+Bug-Reports: https://github.com/haskell/primitive/issues
+Category: Data
+Synopsis: Primitive memory-related operations
+Cabal-Version: >= 1.10
+Build-Type: Simple
+Description: This package provides various primitive memory-related operations.
+
+Extra-Source-Files: changelog.md
+
+Tested-With:
+ GHC == 7.4.2,
+ GHC == 7.6.3,
+ GHC == 7.8.4,
+ GHC == 7.10.3,
+ GHC == 8.0.2,
+ GHC == 8.2.2,
+ GHC == 8.4.1
+
+Library
+ Default-Language: Haskell2010
+ Other-Extensions:
+ BangPatterns, CPP, DeriveDataTypeable,
+ MagicHash, TypeFamilies, UnboxedTuples, UnliftedFFITypes
+
+ Exposed-Modules:
+ Control.Monad.Primitive
+ Data.Primitive
+ Data.Primitive.MachDeps
+ Data.Primitive.Types
+ Data.Primitive.Array
+ Data.Primitive.ByteArray
+ Data.Primitive.SmallArray
+ Data.Primitive.UnliftedArray
+ Data.Primitive.Addr
+ Data.Primitive.MutVar
+
+ Other-Modules:
+ Data.Primitive.Internal.Compat
+ Data.Primitive.Internal.Operations
+
+ Build-Depends: base >= 4.5 && < 4.12
+ , ghc-prim >= 0.2 && < 0.6
+ , transformers >= 0.2 && < 0.6
+
+ Ghc-Options: -O2 -Wall
+
+ Include-Dirs: cbits
+ Install-Includes: primitive-memops.h
+ includes: primitive-memops.h
+ c-sources: cbits/primitive-memops.c
+ cc-options: -O3 -fomit-frame-pointer -Wall
+ if !os(solaris)
+ cc-options: -ftree-vectorize
+ if arch(i386) || arch(x86_64)
+ cc-options: -msse2
+
+test-suite test
+ Default-Language: Haskell2010
+ hs-source-dirs: test
+ main-is: main.hs
+ type: exitcode-stdio-1.0
+ build-depends: base
+ , ghc-prim
+ , primitive
+ ghc-options: -O2
+
+source-repository head
+ type: git
+ location: https://github.com/haskell/primitive
diff --git a/benchmarks/PPoPP2019/src/transformers-base-0.4.4/LICENSE b/benchmarks/PPoPP2019/src/transformers-base-0.4.4/LICENSE
new file mode 100644
index 0000000..9d51261
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/transformers-base-0.4.4/LICENSE
@@ -0,0 +1,27 @@
+Copyright (c) 2011, Mikhail Vorozhtsov, Bas van Dijk
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+- Redistributions of source code must retain the above copyright notice,
+ this list of conditions and the following disclaimer.
+- Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the distribution.
+- Neither the names of the copyright owners nor the names of the
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
diff --git a/benchmarks/PPoPP2019/src/transformers-base-0.4.4/Setup.hs b/benchmarks/PPoPP2019/src/transformers-base-0.4.4/Setup.hs
new file mode 100644
index 0000000..9a994af
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/transformers-base-0.4.4/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/benchmarks/PPoPP2019/src/transformers-base-0.4.4/src/Control/Monad/Base.hs b/benchmarks/PPoPP2019/src/transformers-base-0.4.4/src/Control/Monad/Base.hs
new file mode 100644
index 0000000..ac0c886
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/transformers-base-0.4.4/src/Control/Monad/Base.hs
@@ -0,0 +1,114 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE UnicodeSyntax #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+#if MIN_VERSION_base(4,4,0)
+{-# LANGUAGE Safe #-}
+#endif
+
+#if MIN_VERSION_transformers(0,4,0)
+-- Hide warnings for the deprecated ErrorT transformer:
+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
+#endif
+
+module Control.Monad.Base
+ ( MonadBase(..)
+ , liftBaseDefault
+ ) where
+
+import Data.Monoid
+import Data.Functor.Identity
+import Control.Applicative (Applicative(..))
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.Identity
+import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.List
+import Control.Monad.Trans.Reader
+import qualified Control.Monad.Trans.Writer.Lazy as L
+import qualified Control.Monad.Trans.Writer.Strict as S
+import qualified Control.Monad.Trans.State.Lazy as L
+import qualified Control.Monad.Trans.State.Strict as S
+import qualified Control.Monad.Trans.RWS.Lazy as L
+import qualified Control.Monad.Trans.RWS.Strict as S
+import Control.Monad.Trans.Error
+import Control.Monad.Trans.Cont
+import Control.Monad.Trans.Except
+#if !MIN_VERSION_base(4,4,0) && HS_TRANSFORMERS_BASE__ORPHANS
+import Control.Monad (ap)
+import qualified Control.Monad.ST.Lazy as L
+import qualified Control.Monad.ST.Strict as S
+#endif
+#if MIN_VERSION_base(4,4,0)
+import qualified Control.Monad.ST.Lazy.Safe as L
+import qualified Control.Monad.ST.Safe as S
+#endif
+import Control.Monad.STM (STM)
+
+class (Applicative b, Applicative m, Monad b, Monad m)
+ ⇒ MonadBase b m | m → b where
+ -- | Lift a computation from the base monad
+ liftBase ∷ b α → m α
+
+#define BASE(M) \
+instance MonadBase (M) (M) where liftBase = id
+
+BASE(IO)
+BASE(Maybe)
+BASE(Either e)
+BASE([])
+BASE((→) r)
+BASE(Identity)
+
+BASE(STM)
+
+#if !MIN_VERSION_base(4,4,0) && HS_TRANSFORMERS_BASE__ORPHANS
+instance Applicative (L.ST s) where
+ pure = return
+ (<*>) = ap
+
+instance Applicative (S.ST s) where
+ pure = return
+ (<*>) = ap
+
+BASE(L.ST s)
+BASE(S.ST s)
+#endif
+
+#if MIN_VERSION_base(4,4,0)
+BASE(L.ST s)
+BASE(S.ST s)
+#endif
+
+#undef BASE
+
+-- | Can be used as a default implementation for 'liftBase'.
+--
+-- Note that: @liftBaseDefault = 'lift' . 'liftBase'@
+liftBaseDefault ∷ (MonadTrans t, MonadBase b m) ⇒ b α → t m α
+liftBaseDefault = lift . liftBase
+
+#define TRANS(T) \
+instance (MonadBase b m) ⇒ MonadBase b (T m) where liftBase = liftBaseDefault
+
+TRANS(IdentityT)
+TRANS(MaybeT)
+TRANS(ListT)
+TRANS(ReaderT r)
+TRANS(L.StateT s)
+TRANS(S.StateT s)
+TRANS(ContT r)
+TRANS(ExceptT e)
+#undef TRANS
+
+#define TRANS_CTX(CTX, T) \
+instance (CTX, MonadBase b m) ⇒ MonadBase b (T m) where liftBase = liftBaseDefault
+
+TRANS_CTX(Monoid w, L.WriterT w)
+TRANS_CTX(Monoid w, S.WriterT w)
+TRANS_CTX(Monoid w, L.RWST r w s)
+TRANS_CTX(Monoid w, S.RWST r w s)
+TRANS_CTX(Error e, ErrorT e)
+#undef TRANS_CTX
diff --git a/benchmarks/PPoPP2019/src/transformers-base-0.4.4/transformers-base.cabal b/benchmarks/PPoPP2019/src/transformers-base-0.4.4/transformers-base.cabal
new file mode 100644
index 0000000..352f8ed
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/transformers-base-0.4.4/transformers-base.cabal
@@ -0,0 +1,50 @@
+Name: transformers-base
+Version: 0.4.4
+x-revision: 1
+Category: Control
+Stability: experimental
+Synopsis: Lift computations from the bottom of a transformer stack
+Description:
+ This package provides a straightforward port of @monadLib@'s BaseM
+ typeclass to @transformers@.
+
+Homepage: https://github.com/mvv/transformers-base
+Bug-Reports: https://github.com/mvv/transformers-base/issues
+
+Author:
+ Mikhail Vorozhtsov ,
+ Bas van Dijk
+Maintainer: Mikhail Vorozhtsov
+Copyright:
+ 2011 Mikhail Vorozhtsov ,
+ Bas van Dijk
+License: BSD3
+License-File: LICENSE
+
+Cabal-Version: >= 1.6.0
+Build-Type: Simple
+
+Source-Repository head
+ Type: git
+ Location: https://github.com/mvv/transformers-base.git
+
+Flag OrphanInstances
+ Description:
+ Declare orphan Applicative instances for lazy and strict ST if needed
+ Default: True
+
+Library
+ Build-Depends:
+ base >= 3 && < 5,
+ base < 4.4 || >= 4.5,
+ stm >= 2.3,
+ transformers >= 0.2,
+ transformers-compat >= 0.2
+ Hs-Source-Dirs: src
+ GHC-Options: -Wall
+ if flag(OrphanInstances)
+ CPP-Options: -DHS_TRANSFORMERS_BASE__ORPHANS=1
+ else
+ CPP-Options: -DHS_TRANSFORMERS_BASE__ORPHANS=0
+ Exposed-Modules:
+ Control.Monad.Base
diff --git a/benchmarks/PPoPP2019/src/transformers-compat-0.5.1.4/.ghci b/benchmarks/PPoPP2019/src/transformers-compat-0.5.1.4/.ghci
new file mode 100644
index 0000000..231eb17
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/transformers-compat-0.5.1.4/.ghci
@@ -0,0 +1 @@
+:set -isrc -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h
diff --git a/benchmarks/PPoPP2019/src/transformers-compat-0.5.1.4/.gitignore b/benchmarks/PPoPP2019/src/transformers-compat-0.5.1.4/.gitignore
new file mode 100644
index 0000000..51f70d3
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/transformers-compat-0.5.1.4/.gitignore
@@ -0,0 +1,9 @@
+dist
+docs
+wiki
+TAGS
+tags
+wip
+.DS_Store
+.*.swp
+.*.swo
diff --git a/benchmarks/PPoPP2019/src/transformers-compat-0.5.1.4/.travis.yml b/benchmarks/PPoPP2019/src/transformers-compat-0.5.1.4/.travis.yml
new file mode 100644
index 0000000..a067492
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/transformers-compat-0.5.1.4/.travis.yml
@@ -0,0 +1,29 @@
+language: haskell
+before_install:
+ # Uncomment whenever hackage is down.
+ # - mkdir -p ~/.cabal && cp config ~/.cabal/config && cabal update
+
+ # Try installing some of the build-deps with apt-get for speed.
+ - ./travis-cabal-apt-install --only-dependencies --force-reinstall $mode
+
+ - sudo apt-get -q -y install hlint || cabal install hlint
+
+install:
+ - cabal configure $mode
+ - cabal build
+
+script:
+ - $script
+ - hlint 0.2 --cpp-define HLINT
+ - hlint 0.3 --cpp-define HLINT
+
+notifications:
+ irc:
+ channels:
+ - "irc.freenode.org#haskell-lens"
+ skip_join: true
+ template:
+ - "\x0313transformers-compat\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}"
+
+env:
+ - mode="--enable-tests" script="cabal test"
diff --git a/benchmarks/PPoPP2019/src/transformers-compat-0.5.1.4/.vim.custom b/benchmarks/PPoPP2019/src/transformers-compat-0.5.1.4/.vim.custom
new file mode 100644
index 0000000..86321a8
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/transformers-compat-0.5.1.4/.vim.custom
@@ -0,0 +1,31 @@
+" Add the following to your .vimrc to automatically load this on startup
+
+" if filereadable(".vim.custom")
+" so .vim.custom
+" endif
+
+function StripTrailingWhitespace()
+ let myline=line(".")
+ let mycolumn = col(".")
+ silent %s/ *$//
+ call cursor(myline, mycolumn)
+endfunction
+
+" enable syntax highlighting
+syntax on
+
+" search for the tags file anywhere between here and /
+set tags=TAGS;/
+
+" highlight tabs and trailing spaces
+set listchars=tab:‗‗,trail:‗
+set list
+
+" f2 runs hasktags
+map :exec ":!hasktags -x -c --ignore src"
+
+" strip trailing whitespace before saving
+" au BufWritePre *.hs,*.markdown silent! cal StripTrailingWhitespace()
+
+" rebuild hasktags after saving
+au BufWritePost *.hs silent! :exec ":!hasktags -x -c --ignore src"
diff --git a/benchmarks/PPoPP2019/src/transformers-compat-0.5.1.4/0.2/Control/Applicative/Backwards.hs b/benchmarks/PPoPP2019/src/transformers-compat-0.5.1.4/0.2/Control/Applicative/Backwards.hs
new file mode 100644
index 0000000..62da141
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/transformers-compat-0.5.1.4/0.2/Control/Applicative/Backwards.hs
@@ -0,0 +1,82 @@
+{-# LANGUAGE CPP #-}
+
+#ifndef HASKELL98
+# if __GLASGOW_HASKELL__ >= 702
+{-# LANGUAGE Safe #-}
+# endif
+# if __GLASGOW_HASKELL__ >= 706
+{-# LANGUAGE PolyKinds #-}
+# endif
+#endif
+-- |
+-- Module : Control.Applicative.Backwards
+-- Copyright : (c) Russell O'Connor 2009
+-- License : BSD-style (see the file LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : portable
+--
+-- Making functors with an 'Applicative' instance that performs actions
+-- in the reverse order.
+--
+-- NB: This module is only included in @lens@ for backwards compatibility with
+-- @transformers@ versions before 3.0.
+module Control.Applicative.Backwards where
+
+import Data.Functor.Classes
+
+import Prelude hiding (foldr, foldr1, foldl, foldl1)
+import Control.Applicative
+import Data.Foldable
+import Data.Traversable
+
+-- | The same functor, but with an 'Applicative' instance that performs
+-- actions in the reverse order.
+newtype Backwards f a = Backwards { forwards :: f a }
+
+instance (Eq1 f) => Eq1 (Backwards f) where
+ liftEq eq (Backwards x) (Backwards y) = liftEq eq x y
+
+instance (Ord1 f) => Ord1 (Backwards f) where
+ liftCompare comp (Backwards x) (Backwards y) = liftCompare comp x y
+
+instance (Read1 f) => Read1 (Backwards f) where
+ liftReadsPrec rp rl = readsData $
+ readsUnaryWith (liftReadsPrec rp rl) "Backwards" Backwards
+
+instance (Show1 f) => Show1 (Backwards f) where
+ liftShowsPrec sp sl d (Backwards x) =
+ showsUnaryWith (liftShowsPrec sp sl) "Backwards" d x
+
+instance (Eq1 f, Eq a) => Eq (Backwards f a) where (==) = eq1
+instance (Ord1 f, Ord a) => Ord (Backwards f a) where compare = compare1
+instance (Read1 f, Read a) => Read (Backwards f a) where readsPrec = readsPrec1
+instance (Show1 f, Show a) => Show (Backwards f a) where showsPrec = showsPrec1
+
+-- | Derived instance.
+instance (Functor f) => Functor (Backwards f) where
+ fmap f (Backwards a) = Backwards (fmap f a)
+
+-- | Apply @f@-actions in the reverse order.
+instance (Applicative f) => Applicative (Backwards f) where
+ pure a = Backwards (pure a)
+ Backwards f <*> Backwards a = Backwards (a <**> f)
+
+-- | Try alternatives in the same order as @f@.
+instance (Alternative f) => Alternative (Backwards f) where
+ empty = Backwards empty
+ Backwards x <|> Backwards y = Backwards (x <|> y)
+
+-- | Derived instance.
+instance (Foldable f) => Foldable (Backwards f) where
+ foldMap f (Backwards t) = foldMap f t
+ foldr f z (Backwards t) = foldr f z t
+ foldl f z (Backwards t) = foldl f z t
+ foldr1 f (Backwards t) = foldr1 f t
+ foldl1 f (Backwards t) = foldl1 f t
+
+-- | Derived instance.
+instance (Traversable f) => Traversable (Backwards f) where
+ traverse f (Backwards t) = fmap Backwards (traverse f t)
+ sequenceA (Backwards t) = fmap Backwards (sequenceA t)
diff --git a/benchmarks/PPoPP2019/src/transformers-compat-0.5.1.4/0.2/Control/Applicative/Lift.hs b/benchmarks/PPoPP2019/src/transformers-compat-0.5.1.4/0.2/Control/Applicative/Lift.hs
new file mode 100644
index 0000000..c9310e0
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/transformers-compat-0.5.1.4/0.2/Control/Applicative/Lift.hs
@@ -0,0 +1,138 @@
+{-# LANGUAGE CPP #-}
+
+#ifndef HASKELL98
+# if __GLASGOW_HASKELL__ >= 704
+{-# LANGUAGE Safe #-}
+# elif __GLASGOW_HASKELL__ >= 702
+{-# LANGUAGE Trustworthy #-}
+# endif
+#endif
+-- |
+-- Module : Control.Applicative.Lift
+-- Copyright : (c) Ross Paterson 2010
+-- License : BSD-style (see the file LICENSE)
+--
+-- Maintainer : ross@soi.city.ac.uk
+-- Stability : experimental
+-- Portability : portable
+--
+-- Adding a new kind of pure computation to an applicative functor.
+--
+-- NB: This module is only included in @lens@ for backwards compatibility with
+-- @transformers@ versions before 3.0.
+
+module Control.Applicative.Lift (
+ -- * Lifting an applicative
+ Lift(..),
+ unLift,
+ mapLift,
+ -- * Collecting errors
+ Errors,
+ runErrors,
+ failure
+ ) where
+
+import Data.Functor.Classes
+
+import Control.Applicative
+import Data.Foldable (Foldable(foldMap))
+import Data.Functor.Constant
+import Data.Monoid (Monoid(..))
+import Data.Traversable (Traversable(traverse))
+
+-- | Applicative functor formed by adding pure computations to a given
+-- applicative functor.
+data Lift f a = Pure a | Other (f a)
+
+instance (Eq1 f) => Eq1 (Lift f) where
+ liftEq eq (Pure x1) (Pure x2) = eq x1 x2
+ liftEq _ (Pure _) (Other _) = False
+ liftEq _ (Other _) (Pure _) = False
+ liftEq eq (Other y1) (Other y2) = liftEq eq y1 y2
+
+instance (Ord1 f) => Ord1 (Lift f) where
+ liftCompare comp (Pure x1) (Pure x2) = comp x1 x2
+ liftCompare _ (Pure _) (Other _) = LT
+ liftCompare _ (Other _) (Pure _) = GT
+ liftCompare comp (Other y1) (Other y2) = liftCompare comp y1 y2
+
+instance (Read1 f) => Read1 (Lift f) where
+ liftReadsPrec rp rl = readsData $
+ readsUnaryWith rp "Pure" Pure `mappend`
+ readsUnaryWith (liftReadsPrec rp rl) "Other" Other
+
+instance (Show1 f) => Show1 (Lift f) where
+ liftShowsPrec sp _ d (Pure x) = showsUnaryWith sp "Pure" d x
+ liftShowsPrec sp sl d (Other y) =
+ showsUnaryWith (liftShowsPrec sp sl) "Other" d y
+
+instance (Eq1 f, Eq a) => Eq (Lift f a) where (==) = eq1
+instance (Ord1 f, Ord a) => Ord (Lift f a) where compare = compare1
+instance (Read1 f, Read a) => Read (Lift f a) where readsPrec = readsPrec1
+instance (Show1 f, Show a) => Show (Lift f a) where showsPrec = showsPrec1
+
+instance (Functor f) => Functor (Lift f) where
+ fmap f (Pure x) = Pure (f x)
+ fmap f (Other y) = Other (fmap f y)
+
+instance (Foldable f) => Foldable (Lift f) where
+ foldMap f (Pure x) = f x
+ foldMap f (Other y) = foldMap f y
+
+instance (Traversable f) => Traversable (Lift f) where
+ traverse f (Pure x) = Pure <$> f x
+ traverse f (Other y) = Other <$> traverse f y
+
+-- | A combination is 'Pure' only if both parts are.
+instance (Applicative f) => Applicative (Lift f) where
+ pure = Pure
+ Pure f <*> Pure x = Pure (f x)
+ Pure f <*> Other y = Other (f <$> y)
+ Other f <*> Pure x = Other (($ x) <$> f)
+ Other f <*> Other y = Other (f <*> y)
+
+-- | A combination is 'Pure' only either part is.
+instance (Alternative f) => Alternative (Lift f) where
+ empty = Other empty
+ Pure x <|> _ = Pure x
+ Other _ <|> Pure y = Pure y
+ Other x <|> Other y = Other (x <|> y)
+
+-- | Projection to the other functor.
+unLift :: (Applicative f) => Lift f a -> f a
+unLift (Pure x) = pure x
+unLift (Other e) = e
+
+-- | Apply a transformation to the other computation.
+mapLift :: (f a -> g a) -> Lift f a -> Lift g a
+mapLift _ (Pure x) = Pure x
+mapLift f (Other e) = Other (f e)
+
+-- | An applicative functor that collects a monoid (e.g. lists) of errors.
+-- A sequence of computations fails if any of its components do, but
+-- unlike monads made with 'ExceptT' from "Control.Monad.Trans.Except",
+-- these computations continue after an error, collecting all the errors.
+--
+-- * @'pure' f '<*>' 'pure' x = 'pure' (f x)@
+--
+-- * @'pure' f '<*>' 'failure' e = 'failure' e@
+--
+-- * @'failure' e '<*>' 'pure' x = 'failure' e@
+--
+-- * @'failure' e1 '<*>' 'failure' e2 = 'failure' (e1 '<>' e2)@
+--
+type Errors e = Lift (Constant e)
+
+-- | Extractor for computations with accumulating errors.
+--
+-- * @'runErrors' ('pure' x) = 'Right' x@
+--
+-- * @'runErrors' ('failure' e) = 'Left' e@
+--
+runErrors :: Errors e a -> Either e a
+runErrors (Other (Constant e)) = Left e
+runErrors (Pure x) = Right x
+
+-- | Report an error.
+failure :: e -> Errors e a
+failure e = Other (Constant e)
diff --git a/benchmarks/PPoPP2019/src/transformers-compat-0.5.1.4/0.2/Data/Functor/Reverse.hs b/benchmarks/PPoPP2019/src/transformers-compat-0.5.1.4/0.2/Data/Functor/Reverse.hs
new file mode 100644
index 0000000..d8c8957
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/transformers-compat-0.5.1.4/0.2/Data/Functor/Reverse.hs
@@ -0,0 +1,87 @@
+{-# LANGUAGE CPP #-}
+
+#ifndef HASKELL98
+# if __GLASGOW_HASKELL__ >= 702
+{-# LANGUAGE Safe #-}
+# endif
+# if __GLASGOW_HASKELL__ >= 706
+{-# LANGUAGE PolyKinds #-}
+# endif
+#endif
+-- |
+-- Module : Data.Functor.Reverse
+-- Copyright : (c) Russell O'Connor 2009
+-- License : BSD-style (see the file LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : experimental
+-- Portability : portable
+--
+-- Making functors whose elements are notionally in the reverse order
+-- from the original functor.
+--
+-- /NB:/ Note this module is only included in @lens@ for backwards
+-- compatibility with older @containers@ versions.
+
+module Data.Functor.Reverse where
+
+import Control.Applicative.Backwards
+import Data.Functor.Classes
+
+import Prelude hiding (foldr, foldr1, foldl, foldl1)
+import Control.Applicative
+import Data.Foldable
+import Data.Traversable
+import Data.Monoid
+
+-- | The same functor, but with 'Foldable' and 'Traversable' instances
+-- that process the elements in the reverse order.
+newtype Reverse f a = Reverse { getReverse :: f a }
+
+instance (Eq1 f) => Eq1 (Reverse f) where
+ liftEq eq (Reverse x) (Reverse y) = liftEq eq x y
+
+instance (Ord1 f) => Ord1 (Reverse f) where
+ liftCompare comp (Reverse x) (Reverse y) = liftCompare comp x y
+
+instance (Read1 f) => Read1 (Reverse f) where
+ liftReadsPrec rp rl = readsData $
+ readsUnaryWith (liftReadsPrec rp rl) "Reverse" Reverse
+
+instance (Show1 f) => Show1 (Reverse f) where
+ liftShowsPrec sp sl d (Reverse x) =
+ showsUnaryWith (liftShowsPrec sp sl) "Reverse" d x
+
+instance (Eq1 f, Eq a) => Eq (Reverse f a) where (==) = eq1
+instance (Ord1 f, Ord a) => Ord (Reverse f a) where compare = compare1
+instance (Read1 f, Read a) => Read (Reverse f a) where readsPrec = readsPrec1
+instance (Show1 f, Show a) => Show (Reverse f a) where showsPrec = showsPrec1
+
+-- | Derived instance.
+instance (Functor f) => Functor (Reverse f) where
+ fmap f (Reverse a) = Reverse (fmap f a)
+
+-- | Derived instance.
+instance (Applicative f) => Applicative (Reverse f) where
+ pure a = Reverse (pure a)
+ Reverse f <*> Reverse a = Reverse (f <*> a)
+
+-- | Derived instance.
+instance (Alternative f) => Alternative (Reverse f) where
+ empty = Reverse empty
+ Reverse x <|> Reverse y = Reverse (x <|> y)
+
+-- | Fold from right to left.
+instance (Foldable f) => Foldable (Reverse f) where
+ foldMap f (Reverse t) = getDual (foldMap (Dual . f) t)
+ foldr f z (Reverse t) = foldl (flip f) z t
+ foldl f z (Reverse t) = foldr (flip f) z t
+ foldr1 f (Reverse t) = foldl1 (flip f) t
+ foldl1 f (Reverse t) = foldr1 (flip f) t
+
+-- | Traverse from right to left.
+instance (Traversable f) => Traversable (Reverse f) where
+ traverse f (Reverse t) =
+ fmap Reverse . forwards $ traverse (Backwards . f) t
+ sequenceA (Reverse t) =
+ fmap Reverse . forwards $ sequenceA (fmap Backwards t)
diff --git a/benchmarks/PPoPP2019/src/transformers-compat-0.5.1.4/0.3/Control/Monad/Signatures.hs b/benchmarks/PPoPP2019/src/transformers-compat-0.5.1.4/0.3/Control/Monad/Signatures.hs
new file mode 100644
index 0000000..e23b6a0
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/transformers-compat-0.5.1.4/0.3/Control/Monad/Signatures.hs
@@ -0,0 +1,59 @@
+{-# LANGUAGE CPP #-}
+
+#ifndef HASKELL98
+# if __GLASGOW_HASKELL__ >= 702
+{-# LANGUAGE Safe #-}
+# endif
+# if __GLASGOW_HASKELL__ >= 706
+{-# LANGUAGE PolyKinds #-}
+# endif
+#endif
+-----------------------------------------------------------------------------
+-- |
+-- Module : Control.Monad.Signatures
+-- Copyright : (c) Ross Paterson 2012
+-- License : BSD-style (see the file LICENSE)
+--
+-- Maintainer : ross@soi.city.ac.uk
+-- Stability : experimental
+-- Portability : portable
+--
+-- Signatures for monad operations that require specialized lifting.
+-- Each signature has a uniformity property that the lifting should satisfy.
+-----------------------------------------------------------------------------
+
+module Control.Monad.Signatures (
+ CallCC, Catch, Listen, Pass
+ ) where
+
+-- | Signature of the @callCC@ operation,
+-- introduced in "Control.Monad.Trans.Cont".
+-- Any lifting function @liftCallCC@ should satisfy
+--
+-- * @'lift' (f k) = f' ('lift' . k) => 'lift' (cf f) = liftCallCC cf f'@
+--
+type CallCC m a b = ((a -> m b) -> m a) -> m a
+
+-- | Signature of the @catchE@ operation,
+-- introduced in "Control.Monad.Trans.Except".
+-- Any lifting function @liftCatch@ should satisfy
+--
+-- * @'lift' (cf m f) = liftCatch ('lift' . cf) ('lift' f)@
+--
+type Catch e m a = m a -> (e -> m a) -> m a
+
+-- | Signature of the @listen@ operation,
+-- introduced in "Control.Monad.Trans.Writer".
+-- Any lifting function @liftListen@ should satisfy
+--
+-- * @'lift' . liftListen = liftListen . 'lift'@
+--
+type Listen w m a = m a -> m (a, w)
+
+-- | Signature of the @pass@ operation,
+-- introduced in "Control.Monad.Trans.Writer".
+-- Any lifting function @liftPass@ should satisfy
+--
+-- * @'lift' . liftPass = liftPass . 'lift'@
+--
+type Pass w m a = m (a, w -> w) -> m a
diff --git a/benchmarks/PPoPP2019/src/transformers-compat-0.5.1.4/0.3/Control/Monad/Trans/Except.hs b/benchmarks/PPoPP2019/src/transformers-compat-0.5.1.4/0.3/Control/Monad/Trans/Except.hs
new file mode 100644
index 0000000..99ed86e
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/transformers-compat-0.5.1.4/0.3/Control/Monad/Trans/Except.hs
@@ -0,0 +1,314 @@
+{-# LANGUAGE CPP #-}
+
+#ifndef MIN_VERSION_base
+#define MIN_VERSION_base(x,y,z) 1
+#endif
+
+#ifndef MIN_VERSION_mtl
+#define MIN_VERSION_mtl(x,y,z) 1
+#endif
+
+#ifndef HASKELL98
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE UndecidableInstances #-}
+# if __GLASGOW_HASKELL__ >= 704
+{-# LANGUAGE Safe #-}
+# elif __GLASGOW_HASKELL__ >= 702
+{-# LANGUAGE Trustworthy #-}
+# endif
+#endif
+-----------------------------------------------------------------------------
+-- |
+-- Module : Control.Monad.Trans.Except
+-- Copyright : (C) 2013 Ross Paterson
+-- (C) 2015 Edward Kmett
+-- License : BSD-style (see the file LICENSE)
+--
+-- Maintainer : ross@soi.city.ac.uk
+-- Stability : experimental
+-- Portability : portable
+--
+-- This monad transformer extends a monad with the ability throw exceptions.
+--
+-- A sequence of actions terminates normally, producing a value,
+-- only if none of the actions in the sequence throws an exception.
+-- If one throws an exception, the rest of the sequence is skipped and
+-- the composite action exits with that exception.
+--
+-- If the value of the exception is not required, the variant in
+-- "Control.Monad.Trans.Maybe" may be used instead.
+-----------------------------------------------------------------------------
+
+module Control.Monad.Trans.Except (
+ -- * The Except monad
+ Except,
+ except,
+ runExcept,
+ mapExcept,
+ withExcept,
+ -- * The ExceptT monad transformer
+ ExceptT(..),
+ mapExceptT,
+ withExceptT,
+ -- * Exception operations
+ throwE,
+ catchE,
+ -- * Lifting other operations
+ liftCallCC,
+ liftListen,
+ liftPass,
+ ) where
+
+import Control.Applicative
+import Control.Monad
+import Control.Monad.Fix
+import Control.Monad.IO.Class
+import Control.Monad.Signatures
+import Control.Monad.Trans.Class
+#if MIN_VERSION_base(4,4,0)
+import Control.Monad.Zip (MonadZip(mzipWith))
+#endif
+
+#ifndef HASKELL98
+import Control.Monad.Writer.Class
+import Control.Monad.State.Class
+import Control.Monad.Reader.Class
+import Control.Monad.Cont.Class
+import Control.Monad.Error.Class
+import Control.Monad.RWS.Class
+#endif
+
+import Data.Foldable (Foldable(foldMap))
+import Data.Functor.Classes
+import Data.Functor.Identity
+import Data.Monoid
+import Data.Traversable (Traversable(traverse))
+
+-- | The parameterizable exception monad.
+--
+-- Computations are either exceptions or normal values.
+--
+-- The 'return' function returns a normal value, while @>>=@ exits
+-- on the first exception.
+type Except e = ExceptT e Identity
+
+-- | Constructor for computations in the exception monad.
+-- (The inverse of 'runExcept').
+except :: Either e a -> Except e a
+except m = ExceptT (Identity m)
+
+-- | Extractor for computations in the exception monad.
+-- (The inverse of 'except').
+runExcept :: Except e a -> Either e a
+runExcept (ExceptT m) = runIdentity m
+
+-- | Map the unwrapped computation using the given function.
+--
+-- * @'runExcept' ('mapExcept' f m) = f ('runExcept' m)@
+mapExcept :: (Either e a -> Either e' b)
+ -> Except e a
+ -> Except e' b
+mapExcept f = mapExceptT (Identity . f . runIdentity)
+
+-- | Transform any exceptions thrown by the computation using the given
+-- function (a specialization of 'withExceptT').
+withExcept :: (e -> e') -> Except e a -> Except e' a
+withExcept = withExceptT
+
+-- | A monad transformer that adds exceptions to other monads.
+--
+-- @ExceptT@ constructs a monad parameterized over two things:
+--
+-- * e - The exception type.
+--
+-- * m - The inner monad.
+--
+-- The 'return' function yields a computation that produces the given
+-- value, while @>>=@ sequences two subcomputations, exiting on the
+-- first exception.
+newtype ExceptT e m a = ExceptT { runExceptT :: m (Either e a) }
+
+instance (Eq e, Eq1 m) => Eq1 (ExceptT e m) where
+ liftEq eq (ExceptT x) (ExceptT y) = liftEq (liftEq eq) x y
+
+instance (Ord e, Ord1 m) => Ord1 (ExceptT e m) where
+ liftCompare comp (ExceptT x) (ExceptT y) =
+ liftCompare (liftCompare comp) x y
+
+instance (Read e, Read1 m) => Read1 (ExceptT e m) where
+ liftReadsPrec rp rl = readsData $
+ readsUnaryWith (liftReadsPrec rp' rl') "ExceptT" ExceptT
+ where
+ rp' = liftReadsPrec rp rl
+ rl' = liftReadList rp rl
+
+instance (Show e, Show1 m) => Show1 (ExceptT e m) where
+ liftShowsPrec sp sl d (ExceptT m) =
+ showsUnaryWith (liftShowsPrec sp' sl') "ExceptT" d m
+ where
+ sp' = liftShowsPrec sp sl
+ sl' = liftShowList sp sl
+
+instance (Eq e, Eq1 m, Eq a) => Eq (ExceptT e m a) where (==) = eq1
+instance (Ord e, Ord1 m, Ord a) => Ord (ExceptT e m a) where compare = compare1
+instance (Read e, Read1 m, Read a) => Read (ExceptT e m a) where
+ readsPrec = readsPrec1
+instance (Show e, Show1 m, Show a) => Show (ExceptT e m a) where
+ showsPrec = showsPrec1
+
+-- | Map the unwrapped computation using the given function.
+--
+-- * @'runExceptT' ('mapExceptT' f m) = f ('runExceptT' m)@
+mapExceptT :: (m (Either e a) -> n (Either e' b))
+ -> ExceptT e m a
+ -> ExceptT e' n b
+mapExceptT f m = ExceptT $ f (runExceptT m)
+
+-- | Transform any exceptions thrown by the computation using the
+-- given function.
+withExceptT :: (Functor m) => (e -> e') -> ExceptT e m a -> ExceptT e' m a
+withExceptT f = mapExceptT $ fmap $ either (Left . f) Right
+
+instance (Functor m) => Functor (ExceptT e m) where
+ fmap f = ExceptT . fmap (fmap f) . runExceptT
+
+instance (Foldable f) => Foldable (ExceptT e f) where
+ foldMap f (ExceptT a) = foldMap (either (const mempty) f) a
+
+instance (Traversable f) => Traversable (ExceptT e f) where
+ traverse f (ExceptT a) =
+ ExceptT <$> traverse (either (pure . Left) (fmap Right . f)) a
+
+instance (Functor m, Monad m) => Applicative (ExceptT e m) where
+ pure a = ExceptT $ return (Right a)
+ ExceptT f <*> ExceptT v = ExceptT $ do
+ mf <- f
+ case mf of
+ Left e -> return (Left e)
+ Right k -> do
+ mv <- v
+ case mv of
+ Left e -> return (Left e)
+ Right x -> return (Right (k x))
+
+instance (Functor m, Monad m, Monoid e) => Alternative (ExceptT e m) where
+ empty = ExceptT $ return (Left mempty)
+ ExceptT mx <|> ExceptT my = ExceptT $ do
+ ex <- mx
+ case ex of
+ Left e -> liftM (either (Left . mappend e) Right) my
+ Right x -> return (Right x)
+
+instance (Monad m) => Monad (ExceptT e m) where
+ return a = ExceptT $ return (Right a)
+ m >>= k = ExceptT $ do
+ a <- runExceptT m
+ case a of
+ Left e -> return (Left e)
+ Right x -> runExceptT (k x)
+ fail = ExceptT . fail
+
+instance (Monad m, Monoid e) => MonadPlus (ExceptT e m) where
+ mzero = ExceptT $ return (Left mempty)
+ ExceptT m `mplus` ExceptT n = ExceptT $ do
+ a <- m
+ case a of
+ Left e -> liftM (either (Left . mappend e) Right) n
+ Right x -> return (Right x)
+
+instance (MonadFix m) => MonadFix (ExceptT e m) where
+ mfix f = ExceptT (mfix (runExceptT . f . either (const bomb) id))
+ where bomb = error "mfix (ExceptT): inner computation returned Left value"
+
+instance MonadTrans (ExceptT e) where
+ lift = ExceptT . liftM Right
+
+instance (MonadIO m) => MonadIO (ExceptT e m) where
+ liftIO = lift . liftIO
+
+#if MIN_VERSION_base(4,4,0)
+instance (MonadZip m) => MonadZip (ExceptT e m) where
+ mzipWith f (ExceptT a) (ExceptT b) = ExceptT $ mzipWith (liftA2 f) a b
+#endif
+
+-- | Signal an exception value @e@.
+--
+-- * @'runExceptT' ('throwE' e) = 'return' ('Left' e)@
+--
+-- * @'throwE' e >>= m = 'throwE' e@
+throwE :: (Monad m) => e -> ExceptT e m a
+throwE = ExceptT . return . Left
+
+-- | Handle an exception.
+--
+-- * @'catchE' h ('lift' m) = 'lift' m@
+--
+-- * @'catchE' h ('throwE' e) = h e@
+catchE :: (Monad m) =>
+ ExceptT e m a -- ^ the inner computation
+ -> (e -> ExceptT e' m a) -- ^ a handler for exceptions in the inner
+ -- computation
+ -> ExceptT e' m a
+m `catchE` h = ExceptT $ do
+ a <- runExceptT m
+ case a of
+ Left l -> runExceptT (h l)
+ Right r -> return (Right r)
+
+-- | Lift a @callCC@ operation to the new monad.
+liftCallCC :: CallCC m (Either e a) (Either e b) -> CallCC (ExceptT e m) a b
+liftCallCC callCC f = ExceptT $
+ callCC $ \ c ->
+ runExceptT (f (\ a -> ExceptT $ c (Right a)))
+
+-- | Lift a @listen@ operation to the new monad.
+liftListen :: (Monad m) => Listen w m (Either e a) -> Listen w (ExceptT e m) a
+liftListen listen = mapExceptT $ \ m -> do
+ (a, w) <- listen m
+ return $! fmap (\ r -> (r, w)) a
+
+-- | Lift a @pass@ operation to the new monad.
+liftPass :: (Monad m) => Pass w m (Either e a) -> Pass w (ExceptT e m) a
+liftPass pass = mapExceptT $ \ m -> pass $ do
+ a <- m
+ return $! case a of
+ Left l -> (Left l, id)
+ Right (r, f) -> (Right r, f)
+
+-- incurring the mtl dependency for these avoids packages that need them introducing orphans.
+
+#ifndef HASKELL98
+
+instance Monad m => MonadError e (ExceptT e m) where
+ throwError = throwE
+ catchError = catchE
+
+instance MonadWriter w m => MonadWriter w (ExceptT e m) where
+ tell = lift . tell
+ listen = liftListen listen
+ pass = liftPass pass
+#if MIN_VERSION_mtl(2,1,0)
+ writer = lift . writer
+#endif
+
+instance MonadState s m => MonadState s (ExceptT e m) where
+ get = lift get
+ put = lift . put
+#if MIN_VERSION_mtl(2,1,0)
+ state = lift . state
+#endif
+
+instance MonadReader r m => MonadReader r (ExceptT e m) where
+ ask = lift ask
+ local = mapExceptT . local
+#if MIN_VERSION_mtl(2,1,0)
+ reader = lift . reader
+#endif
+
+instance MonadRWS r w s m => MonadRWS r w s (ExceptT e m)
+
+instance MonadCont m => MonadCont (ExceptT e m) where
+ callCC = liftCallCC callCC
+
+#endif
diff --git a/benchmarks/PPoPP2019/src/transformers-compat-0.5.1.4/0.3/Data/Functor/Classes.hs b/benchmarks/PPoPP2019/src/transformers-compat-0.5.1.4/0.3/Data/Functor/Classes.hs
new file mode 100644
index 0000000..5baddd8
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/transformers-compat-0.5.1.4/0.3/Data/Functor/Classes.hs
@@ -0,0 +1,839 @@
+{-# LANGUAGE CPP #-}
+
+#ifndef MIN_VERSION_transformers
+#define MIN_VERSION_transformers(a,b,c) 1
+#endif
+
+#ifndef HASKELL98
+# if __GLASGOW_HASKELL__ >= 704
+{-# LANGUAGE Safe #-}
+# elif __GLASGOW_HASKELL__ >= 702
+{-# LANGUAGE Trustworthy #-}
+# endif
+# if __GLASGOW_HASKELL__ >= 708
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE StandaloneDeriving #-}
+# endif
+#endif
+-----------------------------------------------------------------------------
+-- |
+-- Module : Data.Functor.Classes
+-- Copyright : (c) Ross Paterson 2013, Edward Kmett 2014
+-- License : BSD-style (see the file LICENSE)
+--
+-- Maintainer : R.Paterson@city.ac.uk
+-- Stability : experimental
+-- Portability : portable
+--
+-- Liftings of the Prelude classes 'Eq', 'Ord', 'Read' and 'Show' to
+-- unary and binary type constructors.
+--
+-- These classes are needed to express the constraints on arguments of
+-- transformers in portable Haskell. Thus for a new transformer @T@,
+-- one might write instances like
+--
+-- > instance (Eq1 f) => Eq1 (T f) where ...
+-- > instance (Ord1 f) => Ord1 (T f) where ...
+-- > instance (Read1 f) => Read1 (T f) where ...
+-- > instance (Show1 f) => Show1 (T f) where ...
+--
+-- If these instances can be defined, defining instances of the base
+-- classes is mechanical:
+--
+-- > instance (Eq1 f, Eq a) => Eq (T f a) where (==) = eq1
+-- > instance (Ord1 f, Ord a) => Ord (T f a) where compare = compare1
+-- > instance (Read1 f, Read a) => Read (T f a) where readsPrec = readsPrec1
+-- > instance (Show1 f, Show a) => Show (T f a) where showsPrec = showsPrec1
+--
+-----------------------------------------------------------------------------
+
+module Data.Functor.Classes (
+ -- * Liftings of Prelude classes
+ -- ** For unary constructors
+ Eq1(..), eq1,
+ Ord1(..), compare1,
+ Read1(..), readsPrec1,
+ Show1(..), showsPrec1,
+ -- ** For binary constructors
+ Eq2(..), eq2,
+ Ord2(..), compare2,
+ Read2(..), readsPrec2,
+ Show2(..), showsPrec2,
+ -- * Helper functions
+ -- $example
+ readsData,
+ readsUnaryWith,
+ readsBinaryWith,
+ showsUnaryWith,
+ showsBinaryWith,
+ -- ** Obsolete helpers
+ readsUnary,
+ readsUnary1,
+ readsBinary1,
+ showsUnary,
+ showsUnary1,
+ showsBinary1,
+ ) where
+
+import Control.Applicative (Const(Const))
+import Data.Functor.Identity (Identity(Identity))
+import Data.Monoid (mappend)
+import Text.Show (showListWith)
+
+import Control.Monad.Trans.Error
+import Control.Monad.Trans.Identity
+import Control.Monad.Trans.List
+import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.Writer.Lazy as Lazy
+import Control.Monad.Trans.Writer.Strict as Strict
+import Data.Functor.Compose
+import Data.Functor.Constant
+import Data.Functor.Product
+
+#if MIN_VERSION_transformers(0,3,0)
+import Control.Applicative.Lift
+import Control.Applicative.Backwards
+import Data.Functor.Reverse
+#endif
+
+#ifndef HASKELL98
+# if __GLASGOW_HASKELL__ >= 708
+import Data.Typeable
+# endif
+#endif
+
+-- | Lifting of the 'Eq' class to unary type constructors.
+class Eq1 f where
+ -- | Lift an equality test through the type constructor.
+ --
+ -- The function will usually be applied to an equality function,
+ -- but the more general type ensures that the implementation uses
+ -- it to compare elements of the first container with elements of
+ -- the second.
+ liftEq :: (a -> b -> Bool) -> f a -> f b -> Bool
+
+-- | Lift the standard @('==')@ function through the type constructor.
+eq1 :: (Eq1 f, Eq a) => f a -> f a -> Bool
+eq1 = liftEq (==)
+
+-- | Lifting of the 'Ord' class to unary type constructors.
+class (Eq1 f) => Ord1 f where
+ -- | Lift a 'compare' function through the type constructor.
+ --
+ -- The function will usually be applied to a comparison function,
+ -- but the more general type ensures that the implementation uses
+ -- it to compare elements of the first container with elements of
+ -- the second.
+ liftCompare :: (a -> b -> Ordering) -> f a -> f b -> Ordering
+
+-- | Lift the standard 'compare' function through the type constructor.
+compare1 :: (Ord1 f, Ord a) => f a -> f a -> Ordering
+compare1 = liftCompare compare
+
+-- | Lifting of the 'Read' class to unary type constructors.
+class Read1 f where
+ -- | 'readsPrec' function for an application of the type constructor
+ -- based on 'readsPrec' and 'readList' functions for the argument type.
+ liftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a)
+
+ -- | 'readList' function for an application of the type constructor
+ -- based on 'readsPrec' and 'readList' functions for the argument type.
+ -- The default implementation using standard list syntax is correct
+ -- for most types.
+ liftReadList :: (Int -> ReadS a) -> ReadS [a] -> ReadS [f a]
+ liftReadList rp rl = readListWith (liftReadsPrec rp rl 0)
+
+-- | Read a list (using square brackets and commas), given a function
+-- for reading elements.
+readListWith :: ReadS a -> ReadS [a]
+readListWith rp =
+ readParen False (\r -> [pr | ("[",s) <- lex r, pr <- readl s])
+ where
+ readl s = [([],t) | ("]",t) <- lex s] ++
+ [(x:xs,u) | (x,t) <- rp s, (xs,u) <- readl' t]
+ readl' s = [([],t) | ("]",t) <- lex s] ++
+ [(x:xs,v) | (",",t) <- lex s, (x,u) <- rp t, (xs,v) <- readl' u]
+
+-- | Lift the standard 'readsPrec' and 'readList' functions through the
+-- type constructor.
+readsPrec1 :: (Read1 f, Read a) => Int -> ReadS (f a)
+readsPrec1 = liftReadsPrec readsPrec readList
+
+-- | Lifting of the 'Show' class to unary type constructors.
+class Show1 f where
+ -- | 'showsPrec' function for an application of the type constructor
+ -- based on 'showsPrec' and 'showList' functions for the argument type.
+ liftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) ->
+ Int -> f a -> ShowS
+
+ -- | 'showList' function for an application of the type constructor
+ -- based on 'showsPrec' and 'showList' functions for the argument type.
+ -- The default implementation using standard list syntax is correct
+ -- for most types.
+ liftShowList :: (Int -> a -> ShowS) -> ([a] -> ShowS) ->
+ [f a] -> ShowS
+ liftShowList sp sl = showListWith (liftShowsPrec sp sl 0)
+
+-- | Lift the standard 'showsPrec' and 'showList' functions through the
+-- type constructor.
+showsPrec1 :: (Show1 f, Show a) => Int -> f a -> ShowS
+showsPrec1 = liftShowsPrec showsPrec showList
+
+-- | Lifting of the 'Eq' class to binary type constructors.
+class Eq2 f where
+ -- | Lift equality tests through the type constructor.
+ --
+ -- The function will usually be applied to equality functions,
+ -- but the more general type ensures that the implementation uses
+ -- them to compare elements of the first container with elements of
+ -- the second.
+ liftEq2 :: (a -> b -> Bool) -> (c -> d -> Bool) -> f a c -> f b d -> Bool
+
+-- | Lift the standard @('==')@ function through the type constructor.
+eq2 :: (Eq2 f, Eq a, Eq b) => f a b -> f a b -> Bool
+eq2 = liftEq2 (==) (==)
+
+-- | Lifting of the 'Ord' class to binary type constructors.
+class (Eq2 f) => Ord2 f where
+ -- | Lift 'compare' functions through the type constructor.
+ --
+ -- The function will usually be applied to comparison functions,
+ -- but the more general type ensures that the implementation uses
+ -- them to compare elements of the first container with elements of
+ -- the second.
+ liftCompare2 :: (a -> b -> Ordering) -> (c -> d -> Ordering) ->
+ f a c -> f b d -> Ordering
+
+-- | Lift the standard 'compare' function through the type constructor.
+compare2 :: (Ord2 f, Ord a, Ord b) => f a b -> f a b -> Ordering
+compare2 = liftCompare2 compare compare
+
+-- | Lifting of the 'Read' class to binary type constructors.
+class Read2 f where
+ -- | 'readsPrec' function for an application of the type constructor
+ -- based on 'readsPrec' and 'readList' functions for the argument types.
+ liftReadsPrec2 :: (Int -> ReadS a) -> ReadS [a] ->
+ (Int -> ReadS b) -> ReadS [b] -> Int -> ReadS (f a b)
+
+ -- | 'readList' function for an application of the type constructor
+ -- based on 'readsPrec' and 'readList' functions for the argument types.
+ -- The default implementation using standard list syntax is correct
+ -- for most types.
+ liftReadList2 :: (Int -> ReadS a) -> ReadS [a] ->
+ (Int -> ReadS b) -> ReadS [b] -> ReadS [f a b]
+ liftReadList2 rp1 rl1 rp2 rl2 =
+ readListWith (liftReadsPrec2 rp1 rl1 rp2 rl2 0)
+
+-- | Lift the standard 'readsPrec' function through the type constructor.
+readsPrec2 :: (Read2 f, Read a, Read b) => Int -> ReadS (f a b)
+readsPrec2 = liftReadsPrec2 readsPrec readList readsPrec readList
+
+-- | Lifting of the 'Show' class to binary type constructors.
+class Show2 f where
+ -- | 'showsPrec' function for an application of the type constructor
+ -- based on 'showsPrec' and 'showList' functions for the argument types.
+ liftShowsPrec2 :: (Int -> a -> ShowS) -> ([a] -> ShowS) ->
+ (Int -> b -> ShowS) -> ([b] -> ShowS) -> Int -> f a b -> ShowS
+
+ -- | 'showList' function for an application of the type constructor
+ -- based on 'showsPrec' and 'showList' functions for the argument types.
+ -- The default implementation using standard list syntax is correct
+ -- for most types.
+ liftShowList2 :: (Int -> a -> ShowS) -> ([a] -> ShowS) ->
+ (Int -> b -> ShowS) -> ([b] -> ShowS) -> [f a b] -> ShowS
+ liftShowList2 sp1 sl1 sp2 sl2 =
+ showListWith (liftShowsPrec2 sp1 sl1 sp2 sl2 0)
+
+-- | Lift the standard 'showsPrec' function through the type constructor.
+showsPrec2 :: (Show2 f, Show a, Show b) => Int -> f a b -> ShowS
+showsPrec2 = liftShowsPrec2 showsPrec showList showsPrec showList
+
+-- Instances for Prelude type constructors
+
+instance Eq1 Maybe where
+ liftEq _ Nothing Nothing = True
+ liftEq _ Nothing (Just _) = False
+ liftEq _ (Just _) Nothing = False
+ liftEq eq (Just x) (Just y) = eq x y
+
+instance Ord1 Maybe where
+ liftCompare _ Nothing Nothing = EQ
+ liftCompare _ Nothing (Just _) = LT
+ liftCompare _ (Just _) Nothing = GT
+ liftCompare comp (Just x) (Just y) = comp x y
+
+instance Read1 Maybe where
+ liftReadsPrec rp _ d =
+ readParen False (\ r -> [(Nothing,s) | ("Nothing",s) <- lex r])
+ `mappend`
+ readsData (readsUnaryWith rp "Just" Just) d
+
+instance Show1 Maybe where
+ liftShowsPrec _ _ _ Nothing = showString "Nothing"
+ liftShowsPrec sp _ d (Just x) = showsUnaryWith sp "Just" d x
+
+instance Eq1 [] where
+ liftEq _ [] [] = True
+ liftEq _ [] (_:_) = False
+ liftEq _ (_:_) [] = False
+ liftEq eq (x:xs) (y:ys) = eq x y && liftEq eq xs ys
+
+instance Ord1 [] where
+ liftCompare _ [] [] = EQ
+ liftCompare _ [] (_:_) = LT
+ liftCompare _ (_:_) [] = GT
+ liftCompare comp (x:xs) (y:ys) = comp x y `mappend` liftCompare comp xs ys
+
+instance Read1 [] where
+ liftReadsPrec _ rl _ = rl
+
+instance Show1 [] where
+ liftShowsPrec _ sl _ = sl
+
+instance Eq2 (,) where
+ liftEq2 e1 e2 (x1, y1) (x2, y2) = e1 x1 x2 && e2 y1 y2
+
+instance Ord2 (,) where
+ liftCompare2 comp1 comp2 (x1, y1) (x2, y2) =
+ comp1 x1 x2 `mappend` comp2 y1 y2
+
+instance Read2 (,) where
+ liftReadsPrec2 rp1 _ rp2 _ _ = readParen False $ \ r ->
+ [((x,y), w) | ("(",s) <- lex r,
+ (x,t) <- rp1 0 s,
+ (",",u) <- lex t,
+ (y,v) <- rp2 0 u,
+ (")",w) <- lex v]
+
+instance Show2 (,) where
+ liftShowsPrec2 sp1 _ sp2 _ _ (x, y) =
+ showChar '(' . sp1 0 x . showChar ',' . sp2 0 y . showChar ')'
+
+instance (Eq a) => Eq1 ((,) a) where
+ liftEq = liftEq2 (==)
+
+instance (Ord a) => Ord1 ((,) a) where
+ liftCompare = liftCompare2 compare
+
+instance (Read a) => Read1 ((,) a) where
+ liftReadsPrec = liftReadsPrec2 readsPrec readList
+
+instance (Show a) => Show1 ((,) a) where
+ liftShowsPrec = liftShowsPrec2 showsPrec showList
+
+instance Eq2 Either where
+ liftEq2 e1 _ (Left x) (Left y) = e1 x y
+ liftEq2 _ _ (Left _) (Right _) = False
+ liftEq2 _ _ (Right _) (Left _) = False
+ liftEq2 _ e2 (Right x) (Right y) = e2 x y
+
+instance Ord2 Either where
+ liftCompare2 comp1 _ (Left x) (Left y) = comp1 x y
+ liftCompare2 _ _ (Left _) (Right _) = LT
+ liftCompare2 _ _ (Right _) (Left _) = GT
+ liftCompare2 _ comp2 (Right x) (Right y) = comp2 x y
+
+instance Read2 Either where
+ liftReadsPrec2 rp1 _ rp2 _ = readsData $
+ readsUnaryWith rp1 "Left" Left `mappend`
+ readsUnaryWith rp2 "Right" Right
+
+instance Show2 Either where
+ liftShowsPrec2 sp1 _ _ _ d (Left x) = showsUnaryWith sp1 "Left" d x
+ liftShowsPrec2 _ _ sp2 _ d (Right x) = showsUnaryWith sp2 "Right" d x
+
+instance (Eq a) => Eq1 (Either a) where
+ liftEq = liftEq2 (==)
+
+instance (Ord a) => Ord1 (Either a) where
+ liftCompare = liftCompare2 compare
+
+instance (Read a) => Read1 (Either a) where
+ liftReadsPrec = liftReadsPrec2 readsPrec readList
+
+instance (Show a) => Show1 (Either a) where
+ liftShowsPrec = liftShowsPrec2 showsPrec showList
+
+-- Instances for other functors defined in the base package
+
+instance Eq1 Identity where
+ liftEq eq (Identity x) (Identity y) = eq x y
+
+instance Ord1 Identity where
+ liftCompare comp (Identity x) (Identity y) = comp x y
+
+instance Read1 Identity where
+ liftReadsPrec rp _ = readsData $
+ readsUnaryWith rp "Identity" Identity
+
+instance Show1 Identity where
+ liftShowsPrec sp _ d (Identity x) = showsUnaryWith sp "Identity" d x
+
+instance Eq2 Const where
+ liftEq2 eq _ (Const x) (Const y) = eq x y
+
+instance Ord2 Const where
+ liftCompare2 comp _ (Const x) (Const y) = comp x y
+
+instance Read2 Const where
+ liftReadsPrec2 rp _ _ _ = readsData $
+ readsUnaryWith rp "Const" Const
+
+instance Show2 Const where
+ liftShowsPrec2 sp _ _ _ d (Const x) = showsUnaryWith sp "Const" d x
+
+instance (Eq a) => Eq1 (Const a) where
+ liftEq = liftEq2 (==)
+instance (Ord a) => Ord1 (Const a) where
+ liftCompare = liftCompare2 compare
+instance (Read a) => Read1 (Const a) where
+ liftReadsPrec = liftReadsPrec2 readsPrec readList
+instance (Show a) => Show1 (Const a) where
+ liftShowsPrec = liftShowsPrec2 showsPrec showList
+
+-- Building blocks
+
+-- | @'readsData' p d@ is a parser for datatypes where each alternative
+-- begins with a data constructor. It parses the constructor and
+-- passes it to @p@. Parsers for various constructors can be constructed
+-- with 'readsUnary', 'readsUnary1' and 'readsBinary1', and combined with
+-- @mappend@ from the @Monoid@ class.
+readsData :: (String -> ReadS a) -> Int -> ReadS a
+readsData reader d =
+ readParen (d > 10) $ \ r -> [res | (kw,s) <- lex r, res <- reader kw s]
+
+-- | @'readsUnaryWith' rp n c n'@ matches the name of a unary data constructor
+-- and then parses its argument using @rp@.
+readsUnaryWith :: (Int -> ReadS a) -> String -> (a -> t) -> String -> ReadS t
+readsUnaryWith rp name cons kw s =
+ [(cons x,t) | kw == name, (x,t) <- rp 11 s]
+
+-- | @'readsBinaryWith' rp1 rp2 n c n'@ matches the name of a binary
+-- data constructor and then parses its arguments using @rp1@ and @rp2@
+-- respectively.
+readsBinaryWith :: (Int -> ReadS a) -> (Int -> ReadS b) ->
+ String -> (a -> b -> t) -> String -> ReadS t
+readsBinaryWith rp1 rp2 name cons kw s =
+ [(cons x y,u) | kw == name, (x,t) <- rp1 11 s, (y,u) <- rp2 11 t]
+
+-- | @'showsUnaryWith' sp n d x@ produces the string representation of a
+-- unary data constructor with name @n@ and argument @x@, in precedence
+-- context @d@.
+showsUnaryWith :: (Int -> a -> ShowS) -> String -> Int -> a -> ShowS
+showsUnaryWith sp name d x = showParen (d > 10) $
+ showString name . showChar ' ' . sp 11 x
+
+-- | @'showsBinaryWith' sp1 sp2 n d x y@ produces the string
+-- representation of a binary data constructor with name @n@ and arguments
+-- @x@ and @y@, in precedence context @d@.
+showsBinaryWith :: (Int -> a -> ShowS) -> (Int -> b -> ShowS) ->
+ String -> Int -> a -> b -> ShowS
+showsBinaryWith sp1 sp2 name d x y = showParen (d > 10) $
+ showString name . showChar ' ' . sp1 11 x . showChar ' ' . sp2 11 y
+
+-- Obsolete building blocks
+
+-- | @'readsUnary' n c n'@ matches the name of a unary data constructor
+-- and then parses its argument using 'readsPrec'.
+{-# DEPRECATED readsUnary "Use readsUnaryWith to define liftReadsPrec" #-}
+readsUnary :: (Read a) => String -> (a -> t) -> String -> ReadS t
+readsUnary name cons kw s =
+ [(cons x,t) | kw == name, (x,t) <- readsPrec 11 s]
+
+-- | @'readsUnary1' n c n'@ matches the name of a unary data constructor
+-- and then parses its argument using 'readsPrec1'.
+{-# DEPRECATED readsUnary1 "Use readsUnaryWith to define liftReadsPrec" #-}
+readsUnary1 :: (Read1 f, Read a) => String -> (f a -> t) -> String -> ReadS t
+readsUnary1 name cons kw s =
+ [(cons x,t) | kw == name, (x,t) <- readsPrec1 11 s]
+
+-- | @'readsBinary1' n c n'@ matches the name of a binary data constructor
+-- and then parses its arguments using 'readsPrec1'.
+{-# DEPRECATED readsBinary1 "Use readsBinaryWith to define liftReadsPrec" #-}
+readsBinary1 :: (Read1 f, Read1 g, Read a) =>
+ String -> (f a -> g a -> t) -> String -> ReadS t
+readsBinary1 name cons kw s =
+ [(cons x y,u) | kw == name,
+ (x,t) <- readsPrec1 11 s, (y,u) <- readsPrec1 11 t]
+
+-- | @'showsUnary' n d x@ produces the string representation of a unary data
+-- constructor with name @n@ and argument @x@, in precedence context @d@.
+{-# DEPRECATED showsUnary "Use showsUnaryWith to define liftShowsPrec" #-}
+showsUnary :: (Show a) => String -> Int -> a -> ShowS
+showsUnary name d x = showParen (d > 10) $
+ showString name . showChar ' ' . showsPrec 11 x
+
+-- | @'showsUnary1' n d x@ produces the string representation of a unary data
+-- constructor with name @n@ and argument @x@, in precedence context @d@.
+{-# DEPRECATED showsUnary1 "Use showsUnaryWith to define liftShowsPrec" #-}
+showsUnary1 :: (Show1 f, Show a) => String -> Int -> f a -> ShowS
+showsUnary1 name d x = showParen (d > 10) $
+ showString name . showChar ' ' . showsPrec1 11 x
+
+-- | @'showsBinary1' n d x y@ produces the string representation of a binary
+-- data constructor with name @n@ and arguments @x@ and @y@, in precedence
+-- context @d@.
+{-# DEPRECATED showsBinary1 "Use showsBinaryWith to define liftShowsPrec" #-}
+showsBinary1 :: (Show1 f, Show1 g, Show a) =>
+ String -> Int -> f a -> g a -> ShowS
+showsBinary1 name d x y = showParen (d > 10) $
+ showString name . showChar ' ' . showsPrec1 11 x .
+ showChar ' ' . showsPrec1 11 y
+
+
+instance (Eq e, Eq1 m) => Eq1 (ErrorT e m) where
+ liftEq eq (ErrorT x) (ErrorT y) = liftEq (liftEq eq) x y
+
+instance (Ord e, Ord1 m) => Ord1 (ErrorT e m) where
+ liftCompare comp (ErrorT x) (ErrorT y) = liftCompare (liftCompare comp) x y
+
+instance (Read e, Read1 m) => Read1 (ErrorT e m) where
+ liftReadsPrec rp rl = readsData $
+ readsUnaryWith (liftReadsPrec rp' rl') "ErrorT" ErrorT
+ where
+ rp' = liftReadsPrec rp rl
+ rl' = liftReadList rp rl
+
+instance (Show e, Show1 m) => Show1 (ErrorT e m) where
+ liftShowsPrec sp sl d (ErrorT m) =
+ showsUnaryWith (liftShowsPrec sp' sl') "ErrorT" d m
+ where
+ sp' = liftShowsPrec sp sl
+ sl' = liftShowList sp sl
+
+instance (Eq e, Eq1 m, Eq a) => Eq (ErrorT e m a) where (==) = eq1
+instance (Ord e, Ord1 m, Ord a) => Ord (ErrorT e m a) where compare = compare1
+instance (Read e, Read1 m, Read a) => Read (ErrorT e m a) where
+ readsPrec = readsPrec1
+instance (Show e, Show1 m, Show a) => Show (ErrorT e m a) where
+ showsPrec = showsPrec1
+
+instance (Eq1 f) => Eq1 (IdentityT f) where
+ liftEq eq (IdentityT x) (IdentityT y) = liftEq eq x y
+
+instance (Ord1 f) => Ord1 (IdentityT f) where
+ liftCompare comp (IdentityT x) (IdentityT y) = liftCompare comp x y
+
+instance (Read1 f) => Read1 (IdentityT f) where
+ liftReadsPrec rp rl = readsData $
+ readsUnaryWith (liftReadsPrec rp rl) "IdentityT" IdentityT
+
+instance (Show1 f) => Show1 (IdentityT f) where
+ liftShowsPrec sp sl d (IdentityT m) =
+ showsUnaryWith (liftShowsPrec sp sl) "IdentityT" d m
+
+instance (Eq1 f, Eq a) => Eq (IdentityT f a) where (==) = eq1
+instance (Ord1 f, Ord a) => Ord (IdentityT f a) where compare = compare1
+instance (Read1 f, Read a) => Read (IdentityT f a) where readsPrec = readsPrec1
+instance (Show1 f, Show a) => Show (IdentityT f a) where showsPrec = showsPrec1
+
+instance (Eq1 m) => Eq1 (ListT m) where
+ liftEq eq (ListT x) (ListT y) = liftEq (liftEq eq) x y
+
+instance (Ord1 m) => Ord1 (ListT m) where
+ liftCompare comp (ListT x) (ListT y) = liftCompare (liftCompare comp) x y
+
+instance (Read1 m) => Read1 (ListT m) where
+ liftReadsPrec rp rl = readsData $
+ readsUnaryWith (liftReadsPrec rp' rl') "ListT" ListT
+ where
+ rp' = liftReadsPrec rp rl
+ rl' = liftReadList rp rl
+
+instance (Show1 m) => Show1 (ListT m) where
+ liftShowsPrec sp sl d (ListT m) =
+ showsUnaryWith (liftShowsPrec sp' sl') "ListT" d m
+ where
+ sp' = liftShowsPrec sp sl
+ sl' = liftShowList sp sl
+
+instance (Eq1 m, Eq a) => Eq (ListT m a) where (==) = eq1
+instance (Ord1 m, Ord a) => Ord (ListT m a) where compare = compare1
+instance (Read1 m, Read a) => Read (ListT m a) where readsPrec = readsPrec1
+instance (Show1 m, Show a) => Show (ListT m a) where showsPrec = showsPrec1
+
+instance (Eq1 m) => Eq1 (MaybeT m) where
+ liftEq eq (MaybeT x) (MaybeT y) = liftEq (liftEq eq) x y
+
+instance (Ord1 m) => Ord1 (MaybeT m) where
+ liftCompare comp (MaybeT x) (MaybeT y) = liftCompare (liftCompare comp) x y
+
+instance (Read1 m) => Read1 (MaybeT m) where
+ liftReadsPrec rp rl = readsData $
+ readsUnaryWith (liftReadsPrec rp' rl') "MaybeT" MaybeT
+ where
+ rp' = liftReadsPrec rp rl
+ rl' = liftReadList rp rl
+
+instance (Show1 m) => Show1 (MaybeT m) where
+ liftShowsPrec sp sl d (MaybeT m) =
+ showsUnaryWith (liftShowsPrec sp' sl') "MaybeT" d m
+ where
+ sp' = liftShowsPrec sp sl
+ sl' = liftShowList sp sl
+
+instance (Eq1 m, Eq a) => Eq (MaybeT m a) where (==) = eq1
+instance (Ord1 m, Ord a) => Ord (MaybeT m a) where compare = compare1
+instance (Read1 m, Read a) => Read (MaybeT m a) where readsPrec = readsPrec1
+instance (Show1 m, Show a) => Show (MaybeT m a) where showsPrec = showsPrec1
+
+instance (Eq w, Eq1 m) => Eq1 (Lazy.WriterT w m) where
+ liftEq eq (Lazy.WriterT m1) (Lazy.WriterT m2) =
+ liftEq (liftEq2 eq (==)) m1 m2
+
+instance (Ord w, Ord1 m) => Ord1 (Lazy.WriterT w m) where
+ liftCompare comp (Lazy.WriterT m1) (Lazy.WriterT m2) =
+ liftCompare (liftCompare2 comp compare) m1 m2
+
+instance (Read w, Read1 m) => Read1 (Lazy.WriterT w m) where
+ liftReadsPrec rp rl = readsData $
+ readsUnaryWith (liftReadsPrec rp' rl') "WriterT" Lazy.WriterT
+ where
+ rp' = liftReadsPrec2 rp rl readsPrec readList
+ rl' = liftReadList2 rp rl readsPrec readList
+
+instance (Show w, Show1 m) => Show1 (Lazy.WriterT w m) where
+ liftShowsPrec sp sl d (Lazy.WriterT m) =
+ showsUnaryWith (liftShowsPrec sp' sl') "WriterT" d m
+ where
+ sp' = liftShowsPrec2 sp sl showsPrec showList
+ sl' = liftShowList2 sp sl showsPrec showList
+
+instance (Eq w, Eq1 m, Eq a) => Eq (Lazy.WriterT w m a) where
+ (==) = eq1
+instance (Ord w, Ord1 m, Ord a) => Ord (Lazy.WriterT w m a) where
+ compare = compare1
+instance (Read w, Read1 m, Read a) => Read (Lazy.WriterT w m a) where
+ readsPrec = readsPrec1
+instance (Show w, Show1 m, Show a) => Show (Lazy.WriterT w m a) where
+ showsPrec = showsPrec1
+
+instance (Eq w, Eq1 m) => Eq1 (Strict.WriterT w m) where
+ liftEq eq (Strict.WriterT m1) (Strict.WriterT m2) =
+ liftEq (liftEq2 eq (==)) m1 m2
+
+instance (Ord w, Ord1 m) => Ord1 (Strict.WriterT w m) where
+ liftCompare comp (Strict.WriterT m1) (Strict.WriterT m2) =
+ liftCompare (liftCompare2 comp compare) m1 m2
+
+instance (Read w, Read1 m) => Read1 (Strict.WriterT w m) where
+ liftReadsPrec rp rl = readsData $
+ readsUnaryWith (liftReadsPrec rp' rl') "WriterT" Strict.WriterT
+ where
+ rp' = liftReadsPrec2 rp rl readsPrec readList
+ rl' = liftReadList2 rp rl readsPrec readList
+
+instance (Show w, Show1 m) => Show1 (Strict.WriterT w m) where
+ liftShowsPrec sp sl d (Strict.WriterT m) =
+ showsUnaryWith (liftShowsPrec sp' sl') "WriterT" d m
+ where
+ sp' = liftShowsPrec2 sp sl showsPrec showList
+ sl' = liftShowList2 sp sl showsPrec showList
+
+instance (Eq w, Eq1 m, Eq a) => Eq (Strict.WriterT w m a) where
+ (==) = eq1
+instance (Ord w, Ord1 m, Ord a) => Ord (Strict.WriterT w m a) where
+ compare = compare1
+instance (Read w, Read1 m, Read a) => Read (Strict.WriterT w m a) where
+ readsPrec = readsPrec1
+instance (Show w, Show1 m, Show a) => Show (Strict.WriterT w m a) where
+ showsPrec = showsPrec1
+
+instance (Eq1 f, Eq1 g) => Eq1 (Compose f g) where
+ liftEq eq (Compose x) (Compose y) = liftEq (liftEq eq) x y
+
+instance (Ord1 f, Ord1 g) => Ord1 (Compose f g) where
+ liftCompare comp (Compose x) (Compose y) =
+ liftCompare (liftCompare comp) x y
+
+instance (Read1 f, Read1 g) => Read1 (Compose f g) where
+ liftReadsPrec rp rl = readsData $
+ readsUnaryWith (liftReadsPrec rp' rl') "Compose" Compose
+ where
+ rp' = liftReadsPrec rp rl
+ rl' = liftReadList rp rl
+
+instance (Show1 f, Show1 g) => Show1 (Compose f g) where
+ liftShowsPrec sp sl d (Compose x) =
+ showsUnaryWith (liftShowsPrec sp' sl') "Compose" d x
+ where
+ sp' = liftShowsPrec sp sl
+ sl' = liftShowList sp sl
+
+instance (Eq1 f, Eq1 g, Eq a) => Eq (Compose f g a) where
+ (==) = eq1
+instance (Ord1 f, Ord1 g, Ord a) => Ord (Compose f g a) where
+ compare = compare1
+instance (Read1 f, Read1 g, Read a) => Read (Compose f g a) where
+ readsPrec = readsPrec1
+instance (Show1 f, Show1 g, Show a) => Show (Compose f g a) where
+ showsPrec = showsPrec1
+
+instance (Eq1 f, Eq1 g) => Eq1 (Product f g) where
+ liftEq eq (Pair x1 y1) (Pair x2 y2) = liftEq eq x1 x2 && liftEq eq y1 y2
+
+instance (Ord1 f, Ord1 g) => Ord1 (Product f g) where
+ liftCompare comp (Pair x1 y1) (Pair x2 y2) =
+ liftCompare comp x1 x2 `mappend` liftCompare comp y1 y2
+
+instance (Read1 f, Read1 g) => Read1 (Product f g) where
+ liftReadsPrec rp rl = readsData $
+ readsBinaryWith (liftReadsPrec rp rl) (liftReadsPrec rp rl) "Pair" Pair
+
+instance (Show1 f, Show1 g) => Show1 (Product f g) where
+ liftShowsPrec sp sl d (Pair x y) =
+ showsBinaryWith (liftShowsPrec sp sl) (liftShowsPrec sp sl) "Pair" d x y
+
+instance (Eq1 f, Eq1 g, Eq a) => Eq (Product f g a)
+ where (==) = eq1
+instance (Ord1 f, Ord1 g, Ord a) => Ord (Product f g a) where
+ compare = compare1
+instance (Read1 f, Read1 g, Read a) => Read (Product f g a) where
+ readsPrec = readsPrec1
+instance (Show1 f, Show1 g, Show a) => Show (Product f g a) where
+ showsPrec = showsPrec1
+
+instance Eq2 Constant where
+ liftEq2 eq _ (Constant x) (Constant y) = eq x y
+instance Ord2 Constant where
+ liftCompare2 comp _ (Constant x) (Constant y) = comp x y
+instance Read2 Constant where
+ liftReadsPrec2 rp _ _ _ = readsData $
+ readsUnaryWith rp "Constant" Constant
+instance Show2 Constant where
+ liftShowsPrec2 sp _ _ _ d (Constant x) = showsUnaryWith sp "Constant" d x
+
+instance (Eq a) => Eq1 (Constant a) where
+ liftEq = liftEq2 (==)
+instance (Ord a) => Ord1 (Constant a) where
+ liftCompare = liftCompare2 compare
+instance (Read a) => Read1 (Constant a) where
+ liftReadsPrec = liftReadsPrec2 readsPrec readList
+instance (Show a) => Show1 (Constant a) where
+ liftShowsPrec = liftShowsPrec2 showsPrec showList
+
+instance Eq a => Eq (Constant a b) where
+ Constant a == Constant b = a == b
+instance Ord a => Ord (Constant a b) where
+ compare (Constant a) (Constant b) = compare a b
+instance (Read a) => Read (Constant a b) where
+ readsPrec = readsData $
+ readsUnaryWith readsPrec "Constant" Constant
+instance (Show a) => Show (Constant a b) where
+ showsPrec d (Constant x) = showsUnaryWith showsPrec "Constant" d x
+
+instance Show a => Show (Identity a) where
+ showsPrec d (Identity a) = showParen (d > 10) $
+ showString "Identity " . showsPrec 11 a
+instance Read a => Read (Identity a) where
+ readsPrec d = readParen (d > 10) (\r -> [(Identity m,t) | ("Identity",s) <- lex r, (m,t) <- readsPrec 11 s])
+instance Eq a => Eq (Identity a) where
+ Identity a == Identity b = a == b
+instance Ord a => Ord (Identity a) where
+ compare (Identity a) (Identity b) = compare a b
+
+#if MIN_VERSION_transformers(0,3,0)
+instance (Eq1 f) => Eq1 (Lift f) where
+ liftEq eq (Pure x1) (Pure x2) = eq x1 x2
+ liftEq _ (Pure _) (Other _) = False
+ liftEq _ (Other _) (Pure _) = False
+ liftEq eq (Other y1) (Other y2) = liftEq eq y1 y2
+
+instance (Ord1 f) => Ord1 (Lift f) where
+ liftCompare comp (Pure x1) (Pure x2) = comp x1 x2
+ liftCompare _ (Pure _) (Other _) = LT
+ liftCompare _ (Other _) (Pure _) = GT
+ liftCompare comp (Other y1) (Other y2) = liftCompare comp y1 y2
+
+instance (Read1 f) => Read1 (Lift f) where
+ liftReadsPrec rp rl = readsData $
+ readsUnaryWith rp "Pure" Pure `mappend`
+ readsUnaryWith (liftReadsPrec rp rl) "Other" Other
+
+instance (Show1 f) => Show1 (Lift f) where
+ liftShowsPrec sp _ d (Pure x) = showsUnaryWith sp "Pure" d x
+ liftShowsPrec sp sl d (Other y) =
+ showsUnaryWith (liftShowsPrec sp sl) "Other" d y
+
+instance (Eq1 f, Eq a) => Eq (Lift f a) where (==) = eq1
+instance (Ord1 f, Ord a) => Ord (Lift f a) where compare = compare1
+instance (Read1 f, Read a) => Read (Lift f a) where readsPrec = readsPrec1
+instance (Show1 f, Show a) => Show (Lift f a) where showsPrec = showsPrec1
+
+instance (Eq1 f) => Eq1 (Backwards f) where
+ liftEq eq (Backwards x) (Backwards y) = liftEq eq x y
+
+instance (Ord1 f) => Ord1 (Backwards f) where
+ liftCompare comp (Backwards x) (Backwards y) = liftCompare comp x y
+
+instance (Read1 f) => Read1 (Backwards f) where
+ liftReadsPrec rp rl = readsData $
+ readsUnaryWith (liftReadsPrec rp rl) "Backwards" Backwards
+
+instance (Show1 f) => Show1 (Backwards f) where
+ liftShowsPrec sp sl d (Backwards x) =
+ showsUnaryWith (liftShowsPrec sp sl) "Backwards" d x
+
+instance (Eq1 f, Eq a) => Eq (Backwards f a) where (==) = eq1
+instance (Ord1 f, Ord a) => Ord (Backwards f a) where compare = compare1
+instance (Read1 f, Read a) => Read (Backwards f a) where readsPrec = readsPrec1
+instance (Show1 f, Show a) => Show (Backwards f a) where showsPrec = showsPrec1
+
+instance (Eq1 f) => Eq1 (Reverse f) where
+ liftEq eq (Reverse x) (Reverse y) = liftEq eq x y
+
+instance (Ord1 f) => Ord1 (Reverse f) where
+ liftCompare comp (Reverse x) (Reverse y) = liftCompare comp x y
+
+instance (Read1 f) => Read1 (Reverse f) where
+ liftReadsPrec rp rl = readsData $
+ readsUnaryWith (liftReadsPrec rp rl) "Reverse" Reverse
+
+instance (Show1 f) => Show1 (Reverse f) where
+ liftShowsPrec sp sl d (Reverse x) =
+ showsUnaryWith (liftShowsPrec sp sl) "Reverse" d x
+
+instance (Eq1 f, Eq a) => Eq (Reverse f a) where (==) = eq1
+instance (Ord1 f, Ord a) => Ord (Reverse f a) where compare = compare1
+instance (Read1 f, Read a) => Read (Reverse f a) where readsPrec = readsPrec1
+instance (Show1 f, Show a) => Show (Reverse f a) where showsPrec = showsPrec1
+#endif
+
+#ifndef HASKELL98
+# if __GLASGOW_HASKELL__ >= 708
+deriving instance Typeable Eq1
+deriving instance Typeable Eq2
+deriving instance Typeable Ord1
+deriving instance Typeable Ord2
+deriving instance Typeable Read1
+deriving instance Typeable Read2
+deriving instance Typeable Show1
+deriving instance Typeable Show2
+# endif
+#endif
+
+{- $example
+These functions can be used to assemble 'Read' and 'Show' instances for
+new algebraic types. For example, given the definition
+
+> data T f a = Zero a | One (f a) | Two a (f a)
+
+a standard 'Read1' instance may be defined as
+
+> instance (Read1 f) => Read1 (T f) where
+> liftReadsPrec rp rl = readsData $
+> readsUnaryWith rp "Zero" Zero `mappend`
+> readsUnaryWith (liftReadsPrec rp rl) "One" One `mappend`
+> readsBinaryWith rp (liftReadsPrec rp rl) "Two" Two
+
+and the corresponding 'Show1' instance as
+
+> instance (Show1 f) => Show1 (T f) where
+> liftShowsPrec sp _ d (Zero x) =
+> showsUnaryWith sp "Zero" d x
+> liftShowsPrec sp sl d (One x) =
+> showsUnaryWith (liftShowsPrec sp sl) "One" d x
+> liftShowsPrec sp sl d (Two x y) =
+> showsBinaryWith sp (liftShowsPrec sp sl) "Two" d x y
+
+-}
diff --git a/benchmarks/PPoPP2019/src/transformers-compat-0.5.1.4/0.3/Data/Functor/Sum.hs b/benchmarks/PPoPP2019/src/transformers-compat-0.5.1.4/0.3/Data/Functor/Sum.hs
new file mode 100644
index 0000000..18e28cc
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/transformers-compat-0.5.1.4/0.3/Data/Functor/Sum.hs
@@ -0,0 +1,133 @@
+{-# LANGUAGE CPP #-}
+
+#ifndef HASKELL98
+# if __GLASGOW_HASKELL__ >= 702
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE EmptyDataDecls #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+# endif
+# if __GLASGOW_HASKELL__ >= 706
+{-# LANGUAGE PolyKinds #-}
+# endif
+# if __GLASGOW_HASKELL__ >= 708
+{-# LANGUAGE AutoDeriveTypeable #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE KindSignatures #-}
+# endif
+#endif
+-- |
+-- Module : Data.Functor.Sum
+-- Copyright : (c) Ross Paterson 2014
+-- License : BSD-style (see the file LICENSE)
+--
+-- Maintainer : ross@soi.city.ac.uk
+-- Stability : experimental
+-- Portability : portable
+--
+-- Sums, lifted to functors.
+
+module Data.Functor.Sum (
+ Sum(..),
+ ) where
+
+import Control.Applicative
+import Data.Foldable (Foldable(foldMap))
+import Data.Functor.Classes
+import Data.Monoid (mappend)
+import Data.Traversable (Traversable(traverse))
+
+#ifndef HASKELL98
+# if __GLASGOW_HASKELL__ >= 702
+import GHC.Generics
+# endif
+# if __GLASGOW_HASKELL__ >= 708
+import Data.Data
+# endif
+#endif
+
+-- | Lifted sum of functors.
+data Sum f g a = InL (f a) | InR (g a)
+
+#ifndef HASKELL98
+# if __GLASGOW_HASKELL__ >= 702
+deriving instance Generic (Sum f g a)
+
+instance Generic1 (Sum f g) where
+ type Rep1 (Sum f g) =
+ D1 MDSum (C1 MCInL (S1 NoSelector (Rec1 f))
+ :+: C1 MCInR (S1 NoSelector (Rec1 g)))
+ from1 (InL f) = M1 (L1 (M1 (M1 (Rec1 f))))
+ from1 (InR g) = M1 (R1 (M1 (M1 (Rec1 g))))
+ to1 (M1 (L1 (M1 (M1 f)))) = InL (unRec1 f)
+ to1 (M1 (R1 (M1 (M1 g)))) = InR (unRec1 g)
+
+data MDSum
+data MCInL
+data MCInR
+
+instance Datatype MDSum where
+ datatypeName _ = "Sum"
+ moduleName _ = "Data.Functor.Sum"
+
+instance Constructor MCInL where
+ conName _ = "InL"
+
+instance Constructor MCInR where
+ conName _ = "InR"
+# endif
+
+# if __GLASGOW_HASKELL__ >= 708
+deriving instance Typeable Sum
+deriving instance (Data (f a), Data (g a), Typeable f, Typeable g, Typeable a)
+ => Data (Sum (f :: * -> *) (g :: * -> *) (a :: *))
+# endif
+#endif
+
+instance (Eq1 f, Eq1 g) => Eq1 (Sum f g) where
+ liftEq eq (InL x1) (InL x2) = liftEq eq x1 x2
+ liftEq _ (InL _) (InR _) = False
+ liftEq _ (InR _) (InL _) = False
+ liftEq eq (InR y1) (InR y2) = liftEq eq y1 y2
+
+instance (Ord1 f, Ord1 g) => Ord1 (Sum f g) where
+ liftCompare comp (InL x1) (InL x2) = liftCompare comp x1 x2
+ liftCompare _ (InL _) (InR _) = LT
+ liftCompare _ (InR _) (InL _) = GT
+ liftCompare comp (InR y1) (InR y2) = liftCompare comp y1 y2
+
+instance (Read1 f, Read1 g) => Read1 (Sum f g) where
+ liftReadsPrec rp rl = readsData $
+ readsUnaryWith (liftReadsPrec rp rl) "InL" InL `mappend`
+ readsUnaryWith (liftReadsPrec rp rl) "InR" InR
+
+instance (Show1 f, Show1 g) => Show1 (Sum f g) where
+ liftShowsPrec sp sl d (InL x) =
+ showsUnaryWith (liftShowsPrec sp sl) "InL" d x
+ liftShowsPrec sp sl d (InR y) =
+ showsUnaryWith (liftShowsPrec sp sl) "InR" d y
+
+instance (Eq1 f, Eq1 g, Eq a) => Eq (Sum f g a) where
+ (==) = eq1
+instance (Ord1 f, Ord1 g, Ord a) => Ord (Sum f g a) where
+ compare = compare1
+instance (Read1 f, Read1 g, Read a) => Read (Sum f g a) where
+ readsPrec = readsPrec1
+instance (Show1 f, Show1 g, Show a) => Show (Sum f g a) where
+ showsPrec = showsPrec1
+
+instance (Functor f, Functor g) => Functor (Sum f g) where
+ fmap f (InL x) = InL (fmap f x)
+ fmap f (InR y) = InR (fmap f y)
+
+instance (Foldable f, Foldable g) => Foldable (Sum f g) where
+ foldMap f (InL x) = foldMap f x
+ foldMap f (InR y) = foldMap f y
+
+instance (Traversable f, Traversable g) => Traversable (Sum f g) where
+ traverse f (InL x) = InL <$> traverse f x
+ traverse f (InR y) = InR <$> traverse f y
diff --git a/benchmarks/PPoPP2019/src/transformers-compat-0.5.1.4/CHANGELOG.markdown b/benchmarks/PPoPP2019/src/transformers-compat-0.5.1.4/CHANGELOG.markdown
new file mode 100644
index 0000000..2be1633
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/transformers-compat-0.5.1.4/CHANGELOG.markdown
@@ -0,0 +1,58 @@
+0.4.0.4
+-------
+
+0.4.0.3
+-------
+
+0.4.0.2
+-------
+* Each of these is a build with a different set of flags configured. Building this way allows us to work around bugs in `cabal`'s backtracker.
+
+0.4
+---
+* Added support for the missing `ExceptT` instances from `mtl`.
+
+ This was not done lightly. While this means that by default incurring a dependency on `transformers-compat` drags in `mtl` when you are
+ using an old `transformers`, it means that users do not have to orphan these instances and permits wider adoption of `ExceptT`.
+
+ If you absolutely can't stand `mtl` and really want this package to build as valid `Haskell98`, then you can use `cabal install transformers-compat -f-mtl` to avoid incurring the dependency to get these instances. However, that is effectively an unsupported configuration.
+
+0.3.3.4
+-------
+
+0.3.3.3
+-------
+
+0.3.3.2
+-------
+* These releases were a successful attempt to fix build problems caused by the cabal backtracker.
+* Each of these is a build with a different set of flags configured.
+
+0.3.2
+-----
+* This release was a failed (or at least, only partially successful) attempt to fix build problems caused by the cabal backtracker.
+
+0.3.1
+-----
+* `transformers 0.4.1` compatibility
+
+0.3
+---
+* Added the instances for `Data.Functor.Classes` from `transformers 0.4`
+* Switched `Control.Applicative.Backwards` and `Data.Functor.Reverse` to the split constructor/accessor style from `transformers 0.4`.
+
+0.2
+---
+* Added the new types and classes from `transformers 0.4`
+
+0.1.1.1
+-------
+* Wrote a better synopsis
+
+0.1.1
+-----
+* Updated to trick `cabal` into building an empty `libHStransformers-compat-0.1.a` on GHC 7.6.
+
+0.1
+---
+* Repository initialized by pulling the `transformers-0.2` compatibility layer out of `lens`.
diff --git a/benchmarks/PPoPP2019/src/transformers-compat-0.5.1.4/HLint.hs b/benchmarks/PPoPP2019/src/transformers-compat-0.5.1.4/HLint.hs
new file mode 100644
index 0000000..7578b03
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/transformers-compat-0.5.1.4/HLint.hs
@@ -0,0 +1 @@
+ignore "Warning: Avoid lambda"
diff --git a/benchmarks/PPoPP2019/src/transformers-compat-0.5.1.4/LICENSE b/benchmarks/PPoPP2019/src/transformers-compat-0.5.1.4/LICENSE
new file mode 100644
index 0000000..50586d1
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/transformers-compat-0.5.1.4/LICENSE
@@ -0,0 +1,30 @@
+Copyright 2012-2015 Edward Kmett
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions
+are met:
+
+1. Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the distribution.
+
+3. Neither the name of the author nor the names of his contributors
+ may be used to endorse or promote products derived from this software
+ without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGE.
diff --git a/benchmarks/PPoPP2019/src/transformers-compat-0.5.1.4/README.markdown b/benchmarks/PPoPP2019/src/transformers-compat-0.5.1.4/README.markdown
new file mode 100644
index 0000000..60e9361
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/transformers-compat-0.5.1.4/README.markdown
@@ -0,0 +1,17 @@
+transformers-compat
+===================
+
+[](https://hackage.haskell.org/package/transformers-compat) [](http://travis-ci.org/ekmett/transformers-compat)
+
+This provides a thin compatibility shim on top of transformers-0.2 to add the types that were added in transformers-0.3.
+
+This enables users to maintain haskell-platform compatibility, while still gaining access ot the new functionality.
+
+Contact Information
+-------------------
+
+Contributions and bug reports are welcome!
+
+Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net.
+
+-Edward Kmett
diff --git a/benchmarks/PPoPP2019/src/transformers-compat-0.5.1.4/Setup.lhs b/benchmarks/PPoPP2019/src/transformers-compat-0.5.1.4/Setup.lhs
new file mode 100644
index 0000000..6cbd928
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/transformers-compat-0.5.1.4/Setup.lhs
@@ -0,0 +1,7 @@
+#!/usr/bin/runhaskell
+> module Main (main) where
+
+> import Distribution.Simple
+
+> main :: IO ()
+> main = defaultMain
diff --git a/benchmarks/PPoPP2019/src/transformers-compat-0.5.1.4/config b/benchmarks/PPoPP2019/src/transformers-compat-0.5.1.4/config
new file mode 100644
index 0000000..a9287ce
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/transformers-compat-0.5.1.4/config
@@ -0,0 +1,16 @@
+-- This provides a custom ~/.cabal/config file for use when hackage is down that should work on unix
+--
+-- This is particularly useful for travis-ci to get it to stop complaining
+-- about a broken build when everything is still correct on our end.
+--
+-- This uses Luite Stegeman's mirror of hackage provided by his 'hdiff' site instead
+--
+-- To enable this, uncomment the before_script in .travis.yml
+
+remote-repo: hdiff.luite.com:http://hdiff.luite.com/packages/archive
+remote-repo-cache: ~/.cabal/packages
+world-file: ~/.cabal/world
+build-summary: ~/.cabal/logs/build.log
+remote-build-reporting: anonymous
+install-dirs user
+install-dirs global
diff --git a/benchmarks/PPoPP2019/src/transformers-compat-0.5.1.4/src/Control/Monad/Trans/Instances.hs b/benchmarks/PPoPP2019/src/transformers-compat-0.5.1.4/src/Control/Monad/Trans/Instances.hs
new file mode 100644
index 0000000..75b4735
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/transformers-compat-0.5.1.4/src/Control/Monad/Trans/Instances.hs
@@ -0,0 +1,386 @@
+{-# LANGUAGE CPP #-}
+
+#ifndef HASKELL98
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE EmptyDataDecls #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+
+# if __GLASGOW_HASKELL__ >= 702
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE Trustworthy #-}
+# endif
+
+# if __GLASGOW_HASKELL__ >= 706
+{-# LANGUAGE PolyKinds #-}
+# endif
+
+# if __GLASGOW_HASKELL__ >= 708
+{-# LANGUAGE DataKinds #-}
+# endif
+#endif
+
+{-# OPTIONS_GHC -fno-warn-deprecations #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Control.Monad.Trans.Instances
+-- Copyright : (C) 2012-16 Edward Kmett
+-- License : BSD-style (see the file LICENSE)
+-- Maintainer : Edward Kmett
+-- Stability : provisional
+-- Portability : portable
+--
+-- Backports orphan instances which are not provided by other modules in
+-- @transformers-compat@.
+----------------------------------------------------------------------------
+module Control.Monad.Trans.Instances () where
+
+#ifndef MIN_VERSION_base
+#define MIN_VERSION_base(a,b,c) 1
+#endif
+
+#ifndef MIN_VERSION_transformers
+#define MIN_VERSION_transformers(a,b,c) 1
+#endif
+
+import Control.Applicative.Backwards (Backwards(..))
+import Control.Applicative.Lift (Lift(..))
+import Control.Monad.IO.Class (MonadIO)
+import Control.Monad.Trans.Class (MonadTrans)
+import Control.Monad.Trans.Cont (ContT(..))
+import Control.Monad.Trans.Error (ErrorT(..))
+import Control.Monad.Trans.Except ()
+import Control.Monad.Trans.Identity (IdentityT(..))
+import Control.Monad.Trans.List (ListT(..))
+import Control.Monad.Trans.Maybe (MaybeT(..))
+import qualified Control.Monad.Trans.RWS.Lazy as Lazy (RWST(..))
+import qualified Control.Monad.Trans.RWS.Strict as Strict (RWST(..))
+import Control.Monad.Trans.Reader (ReaderT(..))
+import qualified Control.Monad.Trans.State.Lazy as Lazy (StateT(..))
+import qualified Control.Monad.Trans.State.Strict as Strict (StateT(..))
+import qualified Control.Monad.Trans.Writer.Lazy as Lazy (WriterT(..))
+import qualified Control.Monad.Trans.Writer.Strict as Strict (WriterT(..))
+import Data.Functor.Classes
+import Data.Functor.Compose (Compose(..))
+import Data.Functor.Constant (Constant(..))
+import Data.Functor.Identity (Identity(..))
+import Data.Functor.Product (Product(..))
+import Data.Functor.Reverse (Reverse(..))
+import Data.Functor.Sum ()
+
+import Control.Applicative
+import Control.Monad (MonadPlus(..))
+import Control.Monad.Fix (MonadFix(..))
+import Data.Foldable (Foldable(..))
+import Data.Maybe (fromMaybe)
+import Data.Monoid (Monoid(..))
+import Data.Traversable (Traversable(..))
+
+#if MIN_VERSION_base(4,4,0)
+import Control.Monad.Zip (MonadZip(..))
+#endif
+
+#if MIN_VERSION_base(4,8,0)
+import Data.Bifunctor (Bifunctor(..))
+#endif
+
+#ifndef HASKELL98
+import Data.Data (Data)
+import Data.Typeable
+
+# if __GLASGOW_HASKELL__ >= 702
+import GHC.Generics
+# endif
+#endif
+
+#if !(MIN_VERSION_transformers(0,3,0))
+-- Foldable/Traversable instances
+instance (Foldable f) => Foldable (ErrorT e f) where
+ foldMap f (ErrorT a) = foldMap (either (const mempty) f) a
+
+instance (Traversable f) => Traversable (ErrorT e f) where
+ traverse f (ErrorT a) =
+ ErrorT <$> traverse (either (pure . Left) (fmap Right . f)) a
+
+instance (Foldable f) => Foldable (IdentityT f) where
+ foldMap f (IdentityT a) = foldMap f a
+
+instance (Traversable f) => Traversable (IdentityT f) where
+ traverse f (IdentityT a) = IdentityT <$> traverse f a
+
+instance (Foldable f) => Foldable (ListT f) where
+ foldMap f (ListT a) = foldMap (foldMap f) a
+
+instance (Traversable f) => Traversable (ListT f) where
+ traverse f (ListT a) = ListT <$> traverse (traverse f) a
+
+instance (Foldable f) => Foldable (MaybeT f) where
+ foldMap f (MaybeT a) = foldMap (foldMap f) a
+
+instance (Traversable f) => Traversable (MaybeT f) where
+ traverse f (MaybeT a) = MaybeT <$> traverse (traverse f) a
+
+instance (Foldable f) => Foldable (Lazy.WriterT w f) where
+ foldMap f = foldMap (f . fst) . Lazy.runWriterT
+
+instance (Traversable f) => Traversable (Lazy.WriterT w f) where
+ traverse f = fmap Lazy.WriterT . traverse f' . Lazy.runWriterT where
+ f' (a, b) = fmap (\ c -> (c, b)) (f a)
+
+instance (Foldable f) => Foldable (Strict.WriterT w f) where
+ foldMap f = foldMap (f . fst) . Strict.runWriterT
+
+instance (Traversable f) => Traversable (Strict.WriterT w f) where
+ traverse f = fmap Strict.WriterT . traverse f' . Strict.runWriterT where
+ f' (a, b) = fmap (\ c -> (c, b)) (f a)
+
+-- MonadFix instances for IdentityT and MaybeT
+instance (MonadFix m) => MonadFix (IdentityT m) where
+ mfix f = IdentityT (mfix (runIdentityT . f))
+
+instance (MonadFix m) => MonadFix (MaybeT m) where
+ mfix f = MaybeT (mfix (runMaybeT . f . fromMaybe bomb))
+ where bomb = error "mfix (MaybeT): inner computation returned Nothing"
+
+# if !(MIN_VERSION_base(4,9,0))
+-- Monad instances for Product
+instance (Monad f, Monad g) => Monad (Product f g) where
+ return x = Pair (return x) (return x)
+ Pair m n >>= f = Pair (m >>= fstP . f) (n >>= sndP . f)
+ where
+ fstP (Pair a _) = a
+ sndP (Pair _ b) = b
+
+instance (MonadPlus f, MonadPlus g) => MonadPlus (Product f g) where
+ mzero = Pair mzero mzero
+ Pair x1 y1 `mplus` Pair x2 y2 = Pair (x1 `mplus` x2) (y1 `mplus` y2)
+
+instance (MonadFix f, MonadFix g) => MonadFix (Product f g) where
+ mfix f = Pair (mfix (fstP . f)) (mfix (sndP . f))
+ where
+ fstP (Pair a _) = a
+ sndP (Pair _ b) = b
+# endif
+#endif
+
+#if !(MIN_VERSION_transformers(0,4,0))
+-- Alternative IO instance
+# if !(MIN_VERSION_base(4,9,0))
+-- The version bounds of transformers prior to 0.4.0.0 should prevent this
+-- instance from being compiled on base-4.8.0.0 and later, but we'll put
+-- a check here just to be safe.
+instance Alternative IO where
+ empty = mzero
+ (<|>) = mplus
+# endif
+#endif
+
+#if MIN_VERSION_transformers(0,4,0) && !(MIN_VERSION_transformers(0,4,3))
+-- transformers-0.4-specific Eq1, Ord1, Read1, and Show1 instances for Const
+instance (Eq a) => Eq1 (Const a) where
+ eq1 (Const x) (Const y) = x == y
+instance (Ord a) => Ord1 (Const a) where
+ compare1 (Const x) (Const y) = compare x y
+instance (Read a) => Read1 (Const a) where
+ readsPrec1 = readsData $ readsUnary "Const" Const
+instance (Show a) => Show1 (Const a) where
+ showsPrec1 d (Const x) = showsUnary "Const" d x
+#endif
+
+#if !(MIN_VERSION_transformers(0,5,0))
+-- Monoid Constant instance
+instance (Monoid a) => Monoid (Constant a b) where
+ mempty = Constant mempty
+ Constant x `mappend` Constant y = Constant (x `mappend` y)
+
+-- MonadZip instances
+# if MIN_VERSION_base(4,4,0)
+instance (MonadZip m) => MonadZip (IdentityT m) where
+ mzipWith f (IdentityT a) (IdentityT b) = IdentityT (mzipWith f a b)
+
+instance (MonadZip m) => MonadZip (ListT m) where
+ mzipWith f (ListT a) (ListT b) = ListT $ mzipWith (zipWith f) a b
+
+instance (MonadZip m) => MonadZip (MaybeT m) where
+ mzipWith f (MaybeT a) (MaybeT b) = MaybeT $ mzipWith (liftA2 f) a b
+
+instance (MonadZip m) => MonadZip (ReaderT r m) where
+ mzipWith f (ReaderT m) (ReaderT n) = ReaderT $ \ a ->
+ mzipWith f (m a) (n a)
+
+instance (Monoid w, MonadZip m) => MonadZip (Lazy.WriterT w m) where
+ mzipWith f (Lazy.WriterT x) (Lazy.WriterT y) = Lazy.WriterT $
+ mzipWith (\ ~(a, w) ~(b, w') -> (f a b, w `mappend` w')) x y
+
+instance (Monoid w, MonadZip m) => MonadZip (Strict.WriterT w m) where
+ mzipWith f (Strict.WriterT x) (Strict.WriterT y) = Strict.WriterT $
+ mzipWith (\ (a, w) (b, w') -> (f a b, w `mappend` w')) x y
+
+# if !(MIN_VERSION_base(4,8,0))
+instance MonadZip Identity where
+ mzipWith f (Identity x) (Identity y) = Identity (f x y)
+ munzip (Identity (a, b)) = (Identity a, Identity b)
+# endif
+
+# if !(MIN_VERSION_base(4,9,0))
+instance (MonadZip f, MonadZip g) => MonadZip (Product f g) where
+ mzipWith f (Pair x1 y1) (Pair x2 y2) = Pair (mzipWith f x1 x2) (mzipWith f y1 y2)
+# endif
+# endif
+
+# if MIN_VERSION_base(4,8,0)
+-- Bifunctor Constant instance
+instance Bifunctor Constant where
+ first f (Constant x) = Constant (f x)
+ second _ (Constant x) = Constant x
+# else
+-- Monoid Identity instance
+instance (Monoid a) => Monoid (Identity a) where
+ mempty = Identity mempty
+ mappend (Identity x) (Identity y) = Identity (mappend x y)
+# endif
+
+# ifndef HASKELL98
+-- Typeable instances
+# if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710
+deriving instance Typeable Backwards
+deriving instance Typeable Constant
+deriving instance Typeable ContT
+deriving instance Typeable ErrorT
+deriving instance Typeable IdentityT
+deriving instance Typeable Lift
+deriving instance Typeable ListT
+deriving instance Typeable MaybeT
+deriving instance Typeable MonadTrans
+deriving instance Typeable Lazy.RWST
+deriving instance Typeable Strict.RWST
+deriving instance Typeable ReaderT
+deriving instance Typeable Reverse
+deriving instance Typeable Lazy.StateT
+deriving instance Typeable Strict.StateT
+
+# if !(MIN_VERSION_base(4,9,0))
+deriving instance Typeable Compose
+deriving instance Typeable MonadIO
+deriving instance Typeable Product
+# endif
+# endif
+
+-- Identity instances
+# if !(MIN_VERSION_base(4,8,0))
+deriving instance Typeable1 Identity
+deriving instance Data a => Data (Identity a)
+
+# if __GLASGOW_HASKELL__ >= 702
+instance Generic (Identity a) where
+ type Rep (Identity a) = D1 MDIdentity (C1 MCIdentity (S1 MSIdentity (Rec0 a)))
+ from (Identity x) = M1 (M1 (M1 (K1 x)))
+ to (M1 (M1 (M1 (K1 x)))) = Identity x
+
+instance Generic1 Identity where
+ type Rep1 Identity = D1 MDIdentity (C1 MCIdentity (S1 MSIdentity Par1))
+ from1 (Identity x) = M1 (M1 (M1 (Par1 x)))
+ to1 (M1 (M1 (M1 x))) = Identity (unPar1 x)
+
+data MDIdentity
+data MCIdentity
+data MSIdentity
+
+instance Datatype MDIdentity where
+ datatypeName _ = "Identity"
+ moduleName _ = "Data.Functor.Identity"
+# if __GLASGOW_HASKELL__ >= 708
+ isNewtype _ = True
+# endif
+
+instance Constructor MCIdentity where
+ conName _ = "Identity"
+ conIsRecord _ = True
+
+instance Selector MSIdentity where
+ selName _ = "runIdentity"
+# endif
+
+# if __GLASGOW_HASKELL__ >= 708
+deriving instance Typeable 'Identity
+# endif
+# endif
+
+# if !(MIN_VERSION_base(4,9,0))
+# if __GLASGOW_HASKELL__ >= 702
+-- Generic(1) instances for Compose
+instance Generic (Compose f g a) where
+ type Rep (Compose f g a) =
+ D1 MDCompose
+ (C1 MCCompose
+ (S1 MSCompose (Rec0 (f (g a)))))
+ from (Compose x) = M1 (M1 (M1 (K1 x)))
+ to (M1 (M1 (M1 (K1 x)))) = Compose x
+
+instance Functor f => Generic1 (Compose f g) where
+ type Rep1 (Compose f g) =
+ D1 MDCompose
+ (C1 MCCompose
+ (S1 MSCompose (f :.: Rec1 g)))
+ from1 (Compose x) = M1 (M1 (M1 (Comp1 (fmap Rec1 x))))
+ to1 (M1 (M1 (M1 x))) = Compose (fmap unRec1 (unComp1 x))
+
+data MDCompose
+data MCCompose
+data MSCompose
+
+instance Datatype MDCompose where
+ datatypeName _ = "Compose"
+ moduleName _ = "Data.Functor.Compose"
+# if __GLASGOW_HASKELL__ >= 708
+ isNewtype _ = True
+# endif
+
+instance Constructor MCCompose where
+ conName _ = "Compose"
+ conIsRecord _ = True
+
+instance Selector MSCompose where
+ selName _ = "getCompose"
+
+-- Generic(1) instances for Product
+instance Generic (Product f g a) where
+ type Rep (Product f g a) =
+ D1 MDProduct
+ (C1 MCPair
+ (S1 NoSelector (Rec0 (f a)) :*: S1 NoSelector (Rec0 (g a))))
+ from (Pair f g) = M1 (M1 (M1 (K1 f) :*: M1 (K1 g)))
+ to (M1 (M1 (M1 (K1 f) :*: M1 (K1 g)))) = Pair f g
+
+instance Generic1 (Product f g) where
+ type Rep1 (Product f g) =
+ D1 MDProduct
+ (C1 MCPair
+ (S1 NoSelector (Rec1 f) :*: S1 NoSelector (Rec1 g)))
+ from1 (Pair f g) = M1 (M1 (M1 (Rec1 f) :*: M1 (Rec1 g)))
+ to1 (M1 (M1 (M1 f :*: M1 g))) = Pair (unRec1 f) (unRec1 g)
+
+data MDProduct
+data MCPair
+
+instance Datatype MDProduct where
+ datatypeName _ = "Product"
+ moduleName _ = "Data.Functor.Product"
+
+instance Constructor MCPair where
+ conName _ = "Pair"
+# endif
+
+# if __GLASGOW_HASKELL__ >= 708
+-- Data instances for Compose and Product
+deriving instance (Data (f (g a)), Typeable f, Typeable g, Typeable a)
+ => Data (Compose (f :: * -> *) (g :: * -> *) (a :: *))
+deriving instance (Data (f a), Data (g a), Typeable f, Typeable g, Typeable a)
+ => Data (Product (f :: * -> *) (g :: * -> *) (a :: *))
+# endif
+# endif
+# endif
+#endif
diff --git a/benchmarks/PPoPP2019/src/transformers-compat-0.5.1.4/transformers-compat.cabal b/benchmarks/PPoPP2019/src/transformers-compat-0.5.1.4/transformers-compat.cabal
new file mode 100644
index 0000000..0e9f987
--- /dev/null
+++ b/benchmarks/PPoPP2019/src/transformers-compat-0.5.1.4/transformers-compat.cabal
@@ -0,0 +1,99 @@
+name: transformers-compat
+category: Compatibility
+version: 0.5.1.4
+license: BSD3
+cabal-version: >= 1.8
+license-file: LICENSE
+author: Edward A. Kmett
+maintainer: Edward A. Kmett
+stability: provisional
+homepage: http://github.com/ekmett/transformers-compat/
+bug-reports: http://github.com/ekmett/transformers-compat/issues
+copyright: Copyright (C) 2012-2015 Edward A. Kmett
+synopsis: A small compatibility shim exposing the new types from transformers 0.3 and 0.4 to older Haskell platforms.
+description:
+ This package includes backported versions of types that were added
+ to transformers in transformers 0.3, 0.4, and 0.5 for users who need strict
+ transformers 0.2 or 0.3 compatibility to run on old versions of the
+ platform, but also need those types.
+ .
+ Those users should be able to just depend on @transformers >= 0.2@
+ and @transformers-compat >= 0.3@.
+ .
+ Note: missing methods are not supplied, but this at least permits the types to be used.
+
+build-type: Simple
+tested-with: GHC == 7.0.4, GHC == 7.4.1, GHC == 7.4.2, GHC == 7.6.1, GHC == 7.8.2, GHC == 7.10.3, GHC == 8.0.1
+extra-source-files:
+ .travis.yml
+ .ghci
+ .gitignore
+ .vim.custom
+ config
+ HLint.hs
+ README.markdown
+ CHANGELOG.markdown
+
+source-repository head
+ type: git
+ location: git://github.com/ekmett/transformers-compat.git
+
+flag two
+ default: False
+ description: Use transformers 0.2. This will be selected by cabal picking the appropriate version.
+ manual: True
+
+flag three
+ default: False
+ manual: True
+ description: Use transformers 0.3. This will be selected by cabal picking the appropriate version.
+
+flag mtl
+ default: True
+ manual: True
+ description: -f-mtl Disables support for mtl for transformers 0.2 and 0.3. That is an unsupported configuration, and results in missing instances for `ExceptT`, but keeps the package Haskell 98.
+
+library
+ build-depends:
+ base >= 4.3 && < 5
+
+ hs-source-dirs:
+ src
+
+ exposed-modules:
+ Control.Monad.Trans.Instances
+
+ other-modules:
+ Paths_transformers_compat
+
+ if flag(three)
+ hs-source-dirs: 0.3
+ build-depends:
+ transformers >= 0.3 && < 0.4,
+ mtl >= 2.1 && < 2.2
+ else
+ if flag(two)
+ hs-source-dirs: 0.2 0.3
+ build-depends:
+ transformers >= 0.2 && < 0.3,
+ mtl >= 2.0 && < 2.1
+ else
+ build-depends: transformers >= 0.4.1 && < 0.6
+
+ if !flag(mtl)
+ cpp-options: -DHASKELL98
+ else
+ build-depends: ghc-prim
+
+ if flag(two)
+ exposed-modules:
+ Control.Applicative.Backwards
+ Control.Applicative.Lift
+ Data.Functor.Reverse
+
+ if flag(two) || flag(three)
+ exposed-modules:
+ Control.Monad.Trans.Except
+ Control.Monad.Signatures
+ Data.Functor.Classes
+ Data.Functor.Sum
diff --git a/benchmarks/PPoPP2019/topo-cores-sockets-threads-12 b/benchmarks/PPoPP2019/topo-cores-sockets-threads-12
new file mode 100644
index 0000000..41d5829
--- /dev/null
+++ b/benchmarks/PPoPP2019/topo-cores-sockets-threads-12
@@ -0,0 +1,12 @@
+0
+2
+4
+6
+8
+10
+1
+3
+5
+7
+9
+11
diff --git a/benchmarks/PPoPP2019/topo-cores-sockets-threads-20 b/benchmarks/PPoPP2019/topo-cores-sockets-threads-20
new file mode 100644
index 0000000..ae810f6
--- /dev/null
+++ b/benchmarks/PPoPP2019/topo-cores-sockets-threads-20
@@ -0,0 +1,20 @@
+0
+2
+4
+6
+8
+10
+12
+14
+16
+18
+1
+3
+5
+7
+9
+11
+13
+15
+17
+19
diff --git a/benchmarks/PPoPP2019/topo-cores-sockets-threads-24 b/benchmarks/PPoPP2019/topo-cores-sockets-threads-24
new file mode 100644
index 0000000..fb671ed
--- /dev/null
+++ b/benchmarks/PPoPP2019/topo-cores-sockets-threads-24
@@ -0,0 +1,24 @@
+0
+2
+4
+6
+8
+10
+12
+14
+16
+18
+20
+22
+1
+3
+5
+7
+9
+11
+13
+15
+17
+19
+21
+23
diff --git a/benchmarks/PPoPP2019/topo-cores-sockets-threads-32 b/benchmarks/PPoPP2019/topo-cores-sockets-threads-32
new file mode 100644
index 0000000..01ba158
--- /dev/null
+++ b/benchmarks/PPoPP2019/topo-cores-sockets-threads-32
@@ -0,0 +1,32 @@
+0
+2
+4
+6
+8
+10
+12
+14
+16
+18
+20
+22
+24
+26
+28
+30
+1
+3
+5
+7
+9
+11
+13
+15
+17
+19
+21
+23
+25
+27
+29
+31
diff --git a/benchmarks/PPoPP2019/topo-cores-sockets-threads-34 b/benchmarks/PPoPP2019/topo-cores-sockets-threads-34
new file mode 100644
index 0000000..79dab33
--- /dev/null
+++ b/benchmarks/PPoPP2019/topo-cores-sockets-threads-34
@@ -0,0 +1,36 @@
+0
+2
+4
+6
+8
+10
+12
+14
+16
+18
+20
+22
+24
+26
+28
+30
+32
+34
+1
+3
+5
+7
+9
+11
+13
+15
+17
+19
+21
+23
+25
+27
+29
+31
+33
+35
diff --git a/benchmarks/PPoPP2019/topo-cores-sockets-threads-40 b/benchmarks/PPoPP2019/topo-cores-sockets-threads-40
new file mode 100644
index 0000000..4e96af8
--- /dev/null
+++ b/benchmarks/PPoPP2019/topo-cores-sockets-threads-40
@@ -0,0 +1,40 @@
+0
+2
+4
+6
+8
+10
+12
+14
+16
+18
+1
+3
+5
+7
+9
+11
+13
+15
+17
+19
+20
+22
+24
+26
+28
+30
+32
+34
+36
+38
+21
+23
+25
+27
+29
+31
+33
+35
+37
+39
diff --git a/benchmarks/PPoPP2019/topo-cores-sockets-threads-48 b/benchmarks/PPoPP2019/topo-cores-sockets-threads-48
new file mode 100644
index 0000000..355d8ff
--- /dev/null
+++ b/benchmarks/PPoPP2019/topo-cores-sockets-threads-48
@@ -0,0 +1,48 @@
+0
+2
+4
+6
+8
+10
+12
+14
+16
+18
+20
+22
+1
+3
+5
+7
+9
+11
+13
+15
+17
+19
+21
+23
+24
+26
+28
+30
+32
+34
+36
+38
+40
+42
+44
+46
+25
+27
+29
+31
+33
+35
+37
+39
+41
+43
+45
+47
diff --git a/benchmarks/PPoPP2019/topo-cores-sockets-threads-64 b/benchmarks/PPoPP2019/topo-cores-sockets-threads-64
new file mode 100644
index 0000000..8bf3107
--- /dev/null
+++ b/benchmarks/PPoPP2019/topo-cores-sockets-threads-64
@@ -0,0 +1,64 @@
+0
+2
+4
+6
+8
+10
+12
+14
+16
+18
+20
+22
+24
+26
+28
+30
+1
+3
+5
+7
+9
+11
+13
+15
+17
+19
+21
+23
+25
+27
+29
+31
+32
+34
+36
+38
+40
+42
+44
+46
+48
+50
+52
+54
+56
+58
+60
+62
+33
+35
+37
+39
+41
+43
+45
+47
+49
+51
+53
+55
+57
+59
+61
+63
diff --git a/benchmarks/PPoPP2019/topo-cores-sockets-threads-72 b/benchmarks/PPoPP2019/topo-cores-sockets-threads-72
new file mode 100644
index 0000000..0d53634
--- /dev/null
+++ b/benchmarks/PPoPP2019/topo-cores-sockets-threads-72
@@ -0,0 +1,72 @@
+0
+2
+4
+6
+8
+10
+12
+14
+16
+18
+20
+22
+24
+26
+28
+30
+32
+34
+1
+3
+5
+7
+9
+11
+13
+15
+17
+19
+21
+23
+25
+27
+29
+31
+33
+35
+36
+38
+40
+42
+44
+46
+48
+50
+52
+54
+56
+58
+60
+62
+64
+66
+68
+70
+37
+39
+41
+43
+45
+47
+49
+51
+53
+55
+57
+59
+61
+63
+65
+67
+69
+71
diff --git a/benchmarks/PPoPP2019/topo-cores-sockets-threads-8 b/benchmarks/PPoPP2019/topo-cores-sockets-threads-8
new file mode 100644
index 0000000..334c477
--- /dev/null
+++ b/benchmarks/PPoPP2019/topo-cores-sockets-threads-8
@@ -0,0 +1,8 @@
+0
+2
+4
+6
+1
+3
+5
+7
diff --git a/benchmarks/PPoPP2019/topo-cores-sockets-threads-Xeon b/benchmarks/PPoPP2019/topo-cores-sockets-threads-Xeon
new file mode 100644
index 0000000..0d53634
--- /dev/null
+++ b/benchmarks/PPoPP2019/topo-cores-sockets-threads-Xeon
@@ -0,0 +1,72 @@
+0
+2
+4
+6
+8
+10
+12
+14
+16
+18
+20
+22
+24
+26
+28
+30
+32
+34
+1
+3
+5
+7
+9
+11
+13
+15
+17
+19
+21
+23
+25
+27
+29
+31
+33
+35
+36
+38
+40
+42
+44
+46
+48
+50
+52
+54
+56
+58
+60
+62
+64
+66
+68
+70
+37
+39
+41
+43
+45
+47
+49
+51
+53
+55
+57
+59
+61
+63
+65
+67
+69
+71
diff --git a/benchmarks/PPoPP2019/topo-cores-sockets-threads-i7 b/benchmarks/PPoPP2019/topo-cores-sockets-threads-i7
new file mode 100644
index 0000000..334c477
--- /dev/null
+++ b/benchmarks/PPoPP2019/topo-cores-sockets-threads-i7
@@ -0,0 +1,8 @@
+0
+2
+4
+6
+1
+3
+5
+7