BreakBulkLog im HHIReducer implementiert

README.md

@@ -628,7 +628,5 @@ Here are some ideas for possible future extensions and improvements.
 - Add support for implicit and explicit parallelism of the graph-reduction engine.
   (implicit parallelism for strict operations, and an explicit `P`-combinator)
 
-## TODO:
-
-- OptEta und Bulk beide zu laufen bringen, aufräumen
-- benchmarks überprüfen!
+## Todo
+- testcases for bulkOptLog

app/Main.hs

@@ -56,48 +56,6 @@ main = do
   putStrLn "The result after reducing the graph:"
   putStrLn $ runST $ printGraph reducedGraph
 
-  let kiselyov = compileKi env optK
-  putStrLn "The result of the kiselyov compiler K opt:"
-  print kiselyov
-
-  let kiselyov' = compileKi env optEta
-  putStrLn "The result of the kiselyov compiler Eta opt:"
-  print kiselyov'
-
-  let graph' = allocate kiselyov
-  putStrLn "The allocated graph:"
-  putStrLn $ runST $ printGraph graph'
-
-  let reducedGraph' = reduceGraph graph'
-  putStrLn "The result after reducing the graph:"
-  putStrLn $ runST $ printGraph reducedGraph'
-
-  timeIt $ print $ tak 60 10 5
-
-  let pEnv = parseEnvironment tak'
-      aExp = compileBulk pEnv
-
-  timeIt $ print $ transLink primitives aExp
-
-  let aExp' = compileEta pEnv
-  timeIt $ print $ transLink primitives aExp'
-
-runTest :: SourceCode -> String
-runTest src =
-  let pEnv = parseEnvironment src
-      aExp = compileBulk pEnv
-      --tExp = translate aExp
-  in show $ transLink primitives aExp --link primitives tExp
-
-tak :: Integer -> Integer -> Integer -> Integer
-tak x y z = if y >= x then z else tak (tak (x-1) y z) (tak (y-1) z x) (tak (z-1) x y)
-
-tak' :: SourceCode
-tak' = [r| 
-  expected = 4
-  tak  = y(λf x y z -> (if (geq y x) z (f (f (sub1 x) y z) (f (sub1 y) z x) (f (sub1 z) x y ))))
-  main = tak 60 10 5
-|]
 
   --demo
 

benchmark/ReductionBenchmarks.hs

@@ -9,7 +9,7 @@ import GraphReduction ( allocate, normalForm, toString, Graph )
 import Data.Maybe (fromJust)
 import Data.STRef ( STRef )
 import Control.Monad.ST ( ST, runST )
-import HhiReducer ( primitives, transLink, CExpr(CInt, CApp) )
+import HhiReducer
 import Control.Monad.Fix ( fix )
 import BenchmarkSources
 
@@ -52,6 +52,9 @@ reduceGraph graph = do
 reducerTest :: CL -> String
 reducerTest expr = show $ transLink primitives expr
 
+reducerTestLog :: CL -> String
+reducerTestLog expr = show $ transLinkLog primitives expr
+
 benchmarks :: IO ()
 benchmarks = do
   fac <- loadTestCase factorial
@@ -75,33 +78,39 @@ benchmarks = do
   print $ reducerTest fac
   print $ reducerTest facEta
   print $ reducerTest facBulk
+  print $ reducerTestLog facBulk
   print $ show $ fact 100
 
   defaultMain [
         bench "factorial Graph-Reduce"    $ nf graphTest fac
       , bench "factorial HHI-Reduce"      $ nf reducerTest fac
       , bench "factorial HHI-Eta"         $ nf reducerTest facEta
       , bench "factorial HHI-Bulk"        $ nf reducerTest facBulk
+      , bench "factorial HHI-Bulk-Log"    $ nf reducerTestLog facBulk
       , bench "factorial Native"          $ nf fact 100
       , bench "fibonacci Graph-Reduce"    $ nf graphTest fib
       , bench "fibonacci HHI-Reduce"      $ nf reducerTest fib
       , bench "fibonacci HHI-Eta"         $ nf reducerTest fibEta
       , bench "fibonacci HHi-Bulk"        $ nf reducerTest fibBulk
+      , bench "fibonacci HHI-Bulk-Log"    $ nf reducerTestLog fibBulk
       , bench "fibonacci Native"          $ nf fibo 10
       , bench "ackermann Graph-Reduce"    $ nf graphTest akk
       , bench "ackermann HHI-Reduce"      $ nf reducerTest akk
       , bench "ackermann HHI-Eta"         $ nf reducerTest akkEta
       , bench "ackermann HHI-Bulk"        $ nf reducerTest akkBulk
+      , bench "ackermann HHI-Bulk-Log"    $ nf reducerTestLog akkBulk
       , bench "ackermann Native"          $ nf ack_2 2
       , bench "gaussian  Graph-Reduce"    $ nf graphTest gau
       , bench "gaussian  HHI-Reduce"      $ nf reducerTest gau
       , bench "gaussian  HHI-Eta"         $ nf reducerTest gauEta
       , bench "gaussian  HHI-Bulk"        $ nf reducerTest gauBulk
+      , bench "gaussian  HHI-Bulk-Log"    $ nf reducerTestLog gauBulk
       , bench "gaussian  Native"          $ nf gaussianSum 100
       , bench "tak       Graph-Reduce"    $ nf graphTest tak
       , bench "tak       HHI-Reduce"      $ nf reducerTest tak
       , bench "tak       HHI-Eta"         $ nf reducerTest takEta
       , bench "tak       HHI-Bulk"        $ nf reducerTest takBulk
+      , bench "tak       HHI-Bulk-Log"    $ nf reducerTestLog takBulk
       , bench "tak       Native"          $ nf tak1 (18,6,3) 
       ]
   return ()

src/HhiReducer.hs

@@ -23,7 +23,6 @@ translate :: CL -> CExpr
 translate (fun :@ arg)   = CApp (translate fun) (translate arg)
 translate (INT k)        = CInt k
 translate (Com c)        = CComb c
---translate lam@(Lam _ _)  = error $ "lambdas should be abstracted already " ++ show lam
 
 -- | apply a CExpr of shape (CFun f) to argument x by evaluating (f x)
 infixl 0 !
@@ -46,10 +45,17 @@ link _definitions expr          = expr
 transLink :: CombinatorDefinitions -> CL -> CExpr
 transLink definitions (fun :@ arg)  = transLink definitions fun ! transLink definitions arg
 transLink _definitions (INT k)      = CInt k
-transLink definitions (Com comb)       = case lookup comb definitions of
+transLink definitions (Com comb)    = case lookup comb definitions of
   Nothing -> resolveBulk comb
   Just e  -> e
 
+transLinkLog :: CombinatorDefinitions -> CL -> CExpr
+transLinkLog definitions (fun :@ arg)  = transLink definitions fun ! transLink definitions arg
+transLinkLog _definitions (INT k)      = CInt k
+transLinkLog definitions (Com comb)    = case lookup comb definitions of
+  Nothing -> resolveBulkLog comb
+  Just e  -> e
+
 type CombinatorDefinitions = [(Combinator,CExpr)]
 
 -- | the set of primary operations: combinators + basic arithmetic functions
@@ -76,13 +82,33 @@ primitives = let (-->) = (,) in
   , ZEROP  --> CFun isZero
   ]
 
+resolveBulkLog :: Combinator -> CExpr
+resolveBulkLog (BulkCom c n) = breakBulkLog (fromString c) n
+  where
+    breakBulkLog :: Combinator -> Int -> CExpr
+    breakBulkLog c 1 = com c
+    breakBulkLog B n = foldr ((!) . (bs!!)) comB (init $ bits n) where
+      bs = [sbi, comB ! (comB ! comB) ! sbi]
+    breakBulkLog c n = foldr ((!) . (bs!!)) (prime c) (init $ bits n) ! comI where
+      bs = [sbi, comB ! (comB ! prime c) ! sbi]
+      prime c = comB ! (comB ! com c) ! comB
+
+    com :: Combinator -> CExpr
+    com c = fromJust $ lookup c primitives
+    sbi :: CExpr
+    sbi = comS ! comB ! comI
+    bits :: Integral t => t -> [t]
+    bits n = r:if q == 0 then [] else bits q where (q, r) = divMod n 2
 
 resolveBulk :: Combinator -> CExpr
 resolveBulk (BulkCom "B" n) = iterate (comB' !) comB !! (n-1) 
 resolveBulk (BulkCom "C" n) = iterate (comC' !) comC !! (n-1)
 resolveBulk (BulkCom "S" n) = iterate (comS' !) comS !! (n-1) 
 resolveBulk anyOther = error $ "not a known combinator: " ++ show anyOther
 
+comI :: CExpr
+comI = CFun id
+
 comS :: CExpr
 comS = CFun (\f -> CFun $ \g -> CFun $ \x -> f!x!(g!x)) -- S F G X = F X (G X)
 

src/Kiselyov.hs

@@ -3,7 +3,7 @@ module Kiselyov
   (
     deBruijn,
     bulkOpt,
-    compileKiEither,
+    --compileKiEither,
     compileBulk,
     compileEta,
     optK,
@@ -39,16 +39,15 @@ bulk :: Combinator -> Int -> CL
 bulk c 1 = Com c
 bulk c n = Com $ BulkCom (show c) n
 
-compileKiEither :: Environment -> (Environment -> DB -> ([Bool],CL)) -> Either String CL
-compileKiEither env convertFun = case lookup "main" env of
-  Nothing   -> Left $ error "main function missing in " ++ show env
-  Just main -> Right $ snd $ convertFun env $ deBruijn main
+-- compileKiEither :: Environment -> (Environment -> DB -> ([Bool],CL)) -> Either String CL
+-- compileKiEither env convertFun = case lookup "main" env of
+--   Nothing   -> Left $ error "main function missing in " ++ show env
+--   Just main -> Right $ snd $ convertFun env $ deBruijn main
 
 compileEta :: Environment -> CL
-compileEta env =
-  case compileKiEither env optEta of
-    Left err -> error $ show err
-    Right cl -> cl
+compileEta env = case lookup "main" env of
+  Nothing   -> error "main function missing"
+  Just main -> snd $ optEta env (deBruijn main)
 
 compileBulk :: Environment -> CL
 compileBulk env = case lookup "main" env of
@@ -108,20 +107,6 @@ zipWithDefault d f     []     ys = f d <$> ys
 zipWithDefault d f     xs     [] = flip f d <$> xs
 zipWithDefault d f (x:xt) (y:yt) = f x y : zipWithDefault d f xt yt
 
-bits :: Integral t => t -> [t]
-bits n = r:if q == 0 then [] else bits q where (q, r) = divMod n 2
-
-breakBulkLog :: Combinator -> Int -> CL
-breakBulkLog c 1 = Com c
-breakBulkLog B n = foldr ((:@) . (bs!!)) (Com B) (init $ bits n) where
-  bs = [sbi, Com B :@ (Com B :@ Com B) :@ sbi]
-breakBulkLog c n = foldr ((:@) . (bs!!)) (prime c) (init $ bits n) :@ Com I where
-  bs = [sbi, Com B :@ (Com B :@ prime c) :@ sbi]
-  prime c = Com B :@ (Com B :@ Com c) :@ Com B
-
-sbi :: CL
-sbi = Com S :@ Com B :@ Com I
-
 bulkLookup :: String -> Environment -> ([Bool], CL)
 bulkLookup s env = case lookup s env of
   Nothing -> ([], Com (fromString s))