Added haskell versions (parameterized by CLI argument)

koka_bench/haskell/CMakeLists.txt

@@ -0,0 +1,33 @@
+find_program(GHC ghc REQUIRED)
+
+#find_program(GHC "stack")
+#if (GHC)
+#  list(APPEND GHC ghc --)
+#else ()
+#  find_program(GHC ghc REQUIRED)
+#endif ()
+
+# run `$ cabal install --lib parallel`  to compile binarytrees
+
+set(sources cfold.hs deriv.hs nqueens.hs rbtree.hs)
+foreach (source IN LISTS sources)
+  get_filename_component(name "${source}" NAME_WE)
+  set(name "hs-${name}")
+
+  add_custom_command(
+    OUTPUT  ${name}
+    COMMAND ${GHC} -O2 -o ${name} "$<SHELL_PATH:${CMAKE_CURRENT_SOURCE_DIR}/${source}>"
+    DEPENDS ${source}
+    VERBATIM)
+
+  add_custom_target(update-${name} ALL DEPENDS ${CMAKE_CURRENT_BINARY_DIR}/${name})
+
+  add_executable(${name}-exe IMPORTED)
+  set_target_properties(${name}-exe PROPERTIES IMPORTED_LOCATION "${CMAKE_CURRENT_BINARY_DIR}/${name}")
+
+  add_test(NAME ${name} COMMAND ${name}-exe)
+  set_tests_properties(${name} PROPERTIES LABELS haskell)
+endforeach ()
+
+
+

koka_bench/haskell/cfold.hs

@@ -0,0 +1,65 @@
+-- Adapted from https://github.com/leanprover/lean4/blob/IFL19/tests/bench/const_fold.hs
+
+import System.Environment
+
+data Expr = Var Integer
+  | Val Integer
+  | Add Expr Expr
+  | Mul Expr Expr
+
+mk_expr :: Integer -> Integer -> Expr
+mk_expr 0 v = if v == 0 then Var 1 else Val v
+mk_expr n v = Add (mk_expr (n-1) (v+1)) (mk_expr (n-1) (max (v-1) 0))
+
+append_add :: Expr -> Expr -> Expr
+append_add (Add e₁ e₂) e₃ = Add e₁ (append_add e₂ e₃)
+append_add e₁          e₂ = Add e₁ e₂
+
+append_mul :: Expr -> Expr -> Expr
+append_mul (Mul e₁ e₂) e₃  = Mul e₁ (append_mul e₂ e₃)
+append_mul e₁          e₂ = Mul e₁ e₂
+
+reassoc :: Expr -> Expr
+reassoc (Add e₁ e₂) =
+  let e₁' = reassoc e₁ in
+  let e₂' = reassoc e₂ in
+  append_add e₁' e₂'
+reassoc (Mul e₁ e₂) =
+  let e₁' = reassoc e₁ in
+  let e₂' = reassoc e₂ in
+  append_mul e₁' e₂'
+reassoc e = e
+
+const_folding :: Expr -> Expr
+const_folding (Add e₁ e₂) =
+  let e₁' = const_folding e₁ in
+  let e₂' = const_folding e₂ in
+  (case (e₁', e₂') of
+     (Val a, Val b        ) -> Val (a+b)
+     (Val a, Add e (Val b)) -> Add (Val (a+b)) e
+     (Val a, Add (Val b) e) -> Add (Val (a+b)) e
+     (_,     _            ) -> Add e₁' e₂')
+const_folding (Mul e₁ e₂) =
+  let e₁' = const_folding e₁ in
+  let e₂' = const_folding e₂ in
+  (case (e₁', e₂') of
+     (Val a, Val b        ) -> Val (a*b)
+     (Val a, Mul e (Val b)) -> Mul (Val (a*b)) e
+     (Val a, Mul (Val b) e) -> Mul (Val (a*b)) e
+     (_,     _            ) -> Mul e₁' e₂')
+const_folding e         = e
+
+eval :: Expr -> Integer
+eval (Var _) = 0
+eval (Val v) = v
+eval (Add l r) = eval l + eval r
+eval (Mul l r) = eval l * eval r
+
+main :: IO ()
+main = do
+  [arg] <- getArgs
+  let n = read arg
+  let e  = (mk_expr n 1)
+  let v₁ = eval e
+  let v₂ = eval (const_folding (reassoc e))
+  putStrLn (show v₁ ++ " " ++ show v₂)

koka_bench/haskell/deriv.hs

@@ -0,0 +1,86 @@
+-- Adapted from: https://raw.githubusercontent.com/leanprover/lean4/IFL19/tests/bench/deriv.hs
+
+import System.Environment
+
+data Expr =
+    Val Int
+  | Var String
+  | Add Expr Expr
+  | Mul Expr Expr
+  | Pow Expr Expr
+  | Ln  Expr
+
+pown :: Int -> Int -> Int
+pown a 0 = 1
+pown a 1 = a
+pown a n =
+  let b = pown a (n `div` 2) in
+  b * b * (if n `mod` 2 == 0 then 1 else a)
+
+add :: Expr -> Expr -> Expr
+add (Val n)   (Val m)         = Val (n + m)
+add (Val 0)   f               = f
+add f         (Val 0)         = f
+add f         (Val n)         = add (Val n) f
+add (Val n)   (Add (Val m) f) = add (Val (n+m)) f
+add f         (Add (Val n) g) = add (Val n) (add f g)
+add (Add f g) h               = add f (add g h)
+add f         g               = Add f g
+
+mul :: Expr -> Expr -> Expr
+mul (Val n)   (Val m)         = Val (n*m)
+mul (Val 0)   _               = Val 0
+mul _         (Val 0)         = Val 0
+mul (Val 1)   f               = f
+mul f         (Val 1)         = f
+mul f         (Val n)         = mul (Val n) f
+mul (Val n)   (Mul (Val m) f) = mul (Val (n*m)) f
+mul f         (Mul (Val n) g) = mul (Val n) (mul f g)
+mul (Mul f g) h               = mul f (mul g h)
+mul f         g               = Mul f g
+
+pow :: Expr -> Expr -> Expr
+pow (Val m) (Val n) = Val (pown m n)
+pow _       (Val 0) = Val 1
+pow f       (Val 1) = f
+pow (Val 0) _       = Val 0
+pow f       g       = Pow f g
+
+ln :: Expr -> Expr
+ln (Val 1) = Val 0
+ln f       = Ln f
+
+d :: String -> Expr -> Expr
+d x (Val _)   = Val 0
+d x (Var y)   = if x == y then Val 1 else Val 0
+d x (Add f g) = add (d x f) (d x g)
+d x (Mul f g) = add (mul f (d x g)) (mul g (d x f))
+d x (Pow f g) = mul (pow f g) (add (mul (mul g (d x f)) (pow f (Val (-1)))) (mul (ln f) (d x g)))
+d x (Ln f)    = mul (d x f) (pow f (Val (-1)))
+
+count :: Expr -> Integer
+count (Val _) = 1
+count (Var _) = 1
+count (Add f g) = count f + count g
+count (Mul f g) = count f + count g
+count (Pow f g) = count f + count g
+count (Ln f)    = count f
+
+nest_aux :: Int -> (Int -> Expr -> IO Expr) -> Int -> Expr -> IO Expr
+nest_aux s f 0 x = pure x
+nest_aux s f m x = f (s - m) x >>= nest_aux s f (m-1)
+
+nest f n e = nest_aux n f n e
+
+deriv :: Int -> Expr -> IO Expr
+deriv i f = do
+  let f' = d "x" f
+  putStrLn (show (i+1) ++ " count: " ++ (show $ count f'))
+  pure f'
+
+main = do
+  let x = Var "x"
+  let f = pow x x
+  [arg] <- getArgs
+  let n = read arg
+  nest deriv n f

koka_bench/haskell/nqueens.hs

@@ -0,0 +1,44 @@
+
+import System.Environment
+
+data List a = Nil | Cons !a !(List a)
+
+len xs
+  = len' xs 0
+
+len' xs acc
+  = case xs of
+      Nil -> acc
+      Cons _ t -> len' t $! (acc+1)
+
+safe queen diag xs
+  = case xs of
+      Nil      -> True
+      Cons q t -> queen /= q && queen /= q + diag && queen /= q - diag && safe queen (diag + 1) t
+
+appendSafe k soln solns
+  = if (k <= 0)
+     then solns
+     else if safe k 1 soln
+           then appendSafe (k-1) soln (Cons (Cons k soln) solns)
+           else appendSafe (k-1) soln solns
+
+
+extend n acc solns
+  = case solns of
+      Nil            -> acc
+      Cons soln rest -> extend n (appendSafe n soln acc) rest
+
+find_solutions n k
+  = if k == 0
+     then Cons Nil Nil
+     else extend n Nil (find_solutions n (k-1))
+
+-- fst_solution n = head (find_solutions n n)
+
+queens n
+  = len (find_solutions n n)
+
+main = do
+  [arg] <- getArgs
+  print (queens (read arg))

koka_bench/haskell/rbtree.hs

@@ -0,0 +1,70 @@
+-- Adapted from https://github.com/leanprover/lean4/blob/IFL19/tests/bench/rbmap.hs
+-- Modified to be strict in the Tree fields
+import System.Environment
+
+data Color =
+  Red | Black
+
+data Tree α β =
+  Leaf
+  | Node !Color !(Tree α β) !α !β !(Tree α β)
+
+fold :: (α -> β  -> σ  -> σ) -> Tree α β -> σ  -> σ
+fold _ Leaf b               = b
+fold f (Node _ l k v r)   b = fold f r (f k v (fold f l b))
+
+balance1 :: Tree α β -> Tree α β -> Tree α β
+balance1 (Node _ _ kv vv t) (Node _ (Node Red l kx vx r₁) ky vy r₂) = Node Red (Node Black l kx vx r₁) ky vy (Node Black r₂ kv vv t)
+balance1 (Node _ _ kv vv t) (Node _ l₁ ky vy (Node Red l₂ kx vx r)) = Node Red (Node Black l₁ ky vy l₂) kx vx (Node Black r kv vv t)
+balance1 (Node _ _ kv vv t) (Node _ l  ky vy r)                     = Node Black (Node Red l ky vy r) kv vv t
+balance1 _                                                        _ = Leaf
+
+balance2 :: Tree α β -> Tree α β -> Tree α β
+balance2 (Node _ t kv vv _) (Node _ (Node Red l kx₁ vx₁ r₁) ky vy r₂)  = Node Red (Node Black t kv vv l) kx₁ vx₁ (Node Black r₁ ky vy r₂)
+balance2 (Node _ t kv vv _) (Node _ l₁ ky vy (Node Red l₂ kx₂ vx₂ r₂)) = Node Red (Node Black t kv vv l₁) ky vy (Node Black l₂ kx₂ vx₂ r₂)
+balance2 (Node _ t kv vv _) (Node _ l ky vy r)                         = Node Black t kv vv (Node Red l ky vy r)
+balance2 _                                                        _    = Leaf
+
+is_red :: Tree α β -> Bool
+is_red (Node Red _ _ _ _) = True
+is_red _                  = False
+
+lt x y = x < y
+
+ins :: Ord α => Tree α β -> α -> β -> Tree α β
+ins Leaf                 kx vx = Node Red Leaf kx vx Leaf
+ins (Node Red a ky vy b) kx vx =
+   (if lt kx ky then Node Red (ins a kx vx) ky vy b
+    else if lt ky kx then Node Red a ky vy (ins b kx vx)
+    else Node Red a ky vy (ins b kx vx))
+ins (Node Black a ky vy b) kx vx =
+    if lt kx ky then
+      (if is_red a then balance1 (Node Black Leaf ky vy b) (ins a kx vx)
+       else Node Black (ins a kx vx) ky vy b)
+    else if lt ky kx then
+      (if is_red b then balance2 (Node Black a ky vy Leaf) (ins b kx vx)
+       else Node Black a ky vy (ins b kx vx))
+    else Node Black a kx vx b
+
+set_black :: Tree α β -> Tree α β
+set_black (Node _ l k v r) = Node Black l k v r
+set_black e                = e
+
+insert t k v =
+  if is_red t then set_black (ins t k v)
+  else ins t k v
+
+type Map = Tree Int Bool
+
+mk_Map_aux :: Int -> Map -> Map
+mk_Map_aux 0 m = m
+mk_Map_aux n m = let n' = n-1 in mk_Map_aux n' (insert m n' (n' `mod` 10 == 0))
+
+mk_Map n = mk_Map_aux n Leaf
+
+main = do
+  [arg] <- getArgs
+  let n = read arg
+  let m = mk_Map n
+  let v = fold (\_ v r -> if v then r + 1 else r) m 0
+  print v