Tail recursion

cabal.project

@@ -1,4 +1,4 @@
 packages: gibbon-compiler
 
 program-options
-    ghc-options: -Werror
+    ghc-options:

gibbon-compiler/examples/tail_recursion/ConsListLength.hs

@@ -0,0 +1,27 @@
+module ConsListLength where 
+
+
+data ConsIntList = Cons Int (ConsIntList) | Nil
+
+
+
+mkConsIntList :: Int -> ConsIntList
+mkConsIntList len = if len <= 0 
+                    then Nil 
+                    else let 
+                           rst = mkConsIntList (len-1)
+                          in Cons len rst
+
+
+length :: ConsIntList -> Int -> Int
+length lst accum = case lst of 
+                    Nil -> accum 
+                    Cons x rst -> length rst (accum+1)
+
+
+
+gibbon_main = 
+    let n = sizeParam
+        lst = mkConsIntList n
+        len = iterate (length lst 0)
+      in len

gibbon-compiler/examples/tail_recursion/Insertion.hs

@@ -0,0 +1,71 @@
+module Insertion where
+
+import Gibbon.Vector
+
+isort2 :: (a -> a -> Int) -> Vector a -> Vector a
+isort2 cmp xs =
+  let n = length xs
+  in go 1 n cmp (copy xs)
+
+go :: Int -> Int -> (a -> a -> Int) -> Vector a -> Vector a
+go i n cmp ys =
+  if i == n
+  then ys
+  else let ys' = shift i cmp ys
+       in go (i+1) n cmp ys'
+
+
+shift :: Int -> (a -> a -> Int) -> Vector a -> Vector a
+shift j cmp ys =
+  if j == 0
+  then ys
+  else let a = nth ys j
+           b = nth ys (j-1)
+       in if (cmp a b) > 0
+          then ys
+          else let ys' = inplaceUpdate j b ys
+                   ys'' = inplaceUpdate (j-1) a ys'
+               in shift (j-1) cmp ys''
+
+--------------------------------------------------------------------------------
+
+insert :: (a -> a -> Int) -> Vector a -> a -> Int -> Vector a
+insert cmp xs x n =
+  if n == 0
+  then inplaceUpdate 0 x xs
+  else let y = nth xs (n-1)
+       in if (cmp x y) < 0
+          then let xs' = inplaceUpdate n y xs
+               in insert cmp xs' x (n-1)
+          else inplaceUpdate n x xs
+
+isort :: (a -> a -> Int) -> Vector a -> Vector a -> Int -> Vector a
+isort cmp xs b n =
+  let len = length xs
+  in if len <= 1
+  then xs
+  else if n == 0
+       then b
+       else let xs' = isort cmp xs b (n-1)
+            in insert cmp xs' (nth xs n) n
+
+isort1 :: (a -> a -> Int) -> Vector a -> Vector a
+isort1 cmp xs =
+  let n = length xs
+      hd = nth xs 0
+      b :: Vector a
+      b = generate n (\i -> hd)
+  in isort cmp xs b ((length xs) - 1)
+
+--------------------------------------------------------------------------------
+
+gibbon_main =
+  let n = sizeParam
+      ls :: Vector Int
+      ls = generate sizeParam (\i -> n-i)
+
+      ls1 = isort1 compare_int ls
+      ls2 = isort2 compare_int ls
+
+      _ = printVec (\i -> printint i) ls1
+  in (ls1,ls2)

gibbon-compiler/examples/tail_recursion/Map.hs

@@ -0,0 +1,43 @@
+module Map where 
+
+
+data ConsIntList = Cons Int (ConsIntList) | Nil
+
+
+mkConsIntList :: Int -> ConsIntList
+mkConsIntList len = if len <= 0 
+                    then Nil 
+                    else let 
+                           rst = mkConsIntList (len-1)
+                          in Cons len rst
+
+
+map :: (Int -> Int) -> ConsIntList -> ConsIntList
+map f lst = case lst of 
+                    Nil -> Nil 
+                    Cons x rst -> Cons (f x) (map f rst)
+
+
+
+
+add1 :: Int -> Int 
+add1 x = x + 1
+
+checkMapAdd1 :: ConsIntList -> ConsIntList -> Bool 
+checkMapAdd1 lst lst' = case lst of 
+                            Nil -> case lst' of
+                                         Nil -> True 
+                                         _ -> False 
+                            Cons x rst -> case lst' of 
+                                             Nil -> False
+                                             Cons x' rst' -> if (x' == x + 1)
+                                                             then True && checkMapAdd1 rst rst'
+                                                             else False 
+
+gibbon_main = 
+    let len = 10000000
+        lst = mkConsIntList len 
+        lst' = iterate (map add1 lst)
+     in checkMapAdd1 lst lst'
+
+

gibbon-compiler/examples/tail_recursion/MapOnVector.hs

@@ -0,0 +1,16 @@
+module MapOnVector where 
+
+import Gibbon.Vector
+
+add1 :: Int -> Int 
+add1 x = x + 1
+
+
+gibbon_main =
+  let n = sizeParam
+      ls :: Vector Int
+      ls = generate sizeParam (\i -> n-i)
+      -- generate_loop is the recursive function to look at, if it is tail_recursive or not.
+      ls' = iterate (map add1 ls)
+      --_ = printVec (\i -> printint i) ls'
+    in (ls,ls')

gibbon-compiler/gibbon.cabal

@@ -87,6 +87,7 @@ library
                        Gibbon.Passes.RearrangeFree
                        Gibbon.Passes.Codegen
                        Gibbon.Passes.CalculateBounds
+                       Gibbon.Passes.MarkTailCalls
 
   other-extensions:    DeriveDataTypeable CPP
 

gibbon-compiler/src/Gibbon/Compiler.hs

@@ -80,6 +80,7 @@ import           Gibbon.Passes.RouteEnds      (routeEnds)
 import           Gibbon.Passes.FollowPtrs     (followPtrs)
 import           Gibbon.NewL2.FromOldL2       (fromOldL2)
 import           Gibbon.Passes.ThreadRegions  (threadRegions)
+import           Gibbon.Passes.MarkTailCalls  (markTailCalls)
 import           Gibbon.Passes.InferFunAllocs (inferFunAllocs)
 import           Gibbon.Passes.Cursorize      (cursorize)
 import           Gibbon.Passes.FindWitnesses  (findWitnesses)
@@ -609,7 +610,7 @@ benchMainExp l1 = do
                                  (L1.ReadPackedFile benchInput tyc Nothing arg) [])
                         $ L1.LetE (toVar "benchres", [],
                                       ret,
-                                      L1.AppE fnname [] [L1.VarE (toVar tmp)])
+                                      L1.AppE (fnname, NoTail) [] [L1.VarE (toVar tmp)])
                         -- FIXME: should actually return the result,
                         -- as soon as we are able to print it.
                         (if gopt Opt_BenchPrint dynflags
@@ -798,7 +799,7 @@ Also see Note [Adding dummy traversals] and Note [Adding random access nodes].
               -- it adds regions to 'locs' in AppE and LetE which the
               -- typechecker doesn't know how to handle.
               l2' <- go "threadRegions"    threadRegions l2'
-
+              l2' <- go "markTailCalls" markTailCalls l2'
               -- L2 -> L3
               -- TODO: Compose L3.TcM with (ReaderT Config)
               l3 <- go "cursorize"        cursorize     l2'

gibbon-compiler/src/Gibbon/HaskellFrontend.hs

@@ -525,7 +525,7 @@ desugarExp type_syns toplevel e =
                    pure $ VarE v
                  -- Otherwise, 'v' is a top-level value binding, which we
                  -- encode as a function which takes no arguments.
-                 _ -> pure $ AppE v [] []
+                 _ -> pure $ AppE (v, NoTail) [] []
              Nothing -> pure $ VarE v
     Lit _ lit  -> desugarLiteral lit
 
@@ -760,14 +760,14 @@ desugarExp type_syns toplevel e =
                     pure $ Ext (LinearExt (LseqE e2' undefined))
                   else if S.member f keywords
                   then error $ "desugarExp: Keyword not handled: " ++ sdoc f
-                  else AppE f [] <$> (: []) <$> desugarExp type_syns toplevel e2
+                  else AppE (f, NoTail) [] <$> (: []) <$> desugarExp type_syns toplevel e2
           (DataConE tyapp c as) -> (\e2' -> DataConE tyapp c (as ++ [e2'])) <$> desugarExp type_syns toplevel e2
           (Ext (ParE0 ls)) -> do
             e2' <- desugarExp type_syns toplevel e2
             pure $ Ext $ ParE0 (ls ++ [e2'])
-          (AppE f [] ls) -> do
+          (AppE (f, t) [] ls) -> do
             e2' <- desugarExp type_syns toplevel e2
-            pure $ AppE f [] (ls ++ [e2'])
+            pure $ AppE (f, t) [] (ls ++ [e2'])
 
           (Ext (BenchE fn [] ls b)) -> do
             e2' <- desugarExp type_syns toplevel e2
@@ -805,9 +805,9 @@ desugarExp type_syns toplevel e =
             e2' <- desugarExp type_syns toplevel e2
             pure (Ext (LinearExt (LseqE a e2')))
 
-          (Ext (LinearExt (ToLinearE (AppE f [] ls)))) -> do
+          (Ext (LinearExt (ToLinearE (AppE (f, t) [] ls)))) -> do
             e2' <- desugarExp type_syns toplevel e2
-            pure (Ext (LinearExt (ToLinearE (AppE f [] (ls ++ [e2'])))))
+            pure (Ext (LinearExt (ToLinearE (AppE (f, t) [] (ls ++ [e2'])))))
 
           (Ext (LinearExt (ToLinearE (DataConE tyapp dcon ls)))) -> do
             e2' <- desugarExp type_syns toplevel e2
@@ -819,7 +819,7 @@ desugarExp type_syns toplevel e =
 
           (Ext (LinearExt (ToLinearE (VarE fn)))) -> do
             e2' <- desugarExp type_syns toplevel e2
-            pure (Ext (LinearExt (ToLinearE (AppE fn [] [e2']))))
+            pure (Ext (LinearExt (ToLinearE (AppE (fn, NoTail) [] [e2']))))
 
           f -> error ("desugarExp: Couldn't parse function application: (" ++ show f ++ ")")
 
@@ -1226,7 +1226,7 @@ fixupSpawn ex =
     WithArenaE v e -> WithArenaE v (go e)
     SpawnE _ _ args ->
       case args of
-          [(AppE fn tyapps ls)] -> SpawnE fn tyapps ls
+          [(AppE (fn, _) tyapps ls)] -> SpawnE fn tyapps ls
           _ -> error $ "fixupSpawn: incorrect use of spawn: " ++ sdoc ex
     SyncE   -> SyncE
     MapE{}  -> error $ "fixupSpawn: TODO MapE"

gibbon-compiler/src/Gibbon/L0/Interp.hs

@@ -25,7 +25,7 @@ instance InterpExt () Exp0 (E0Ext Ty0 Ty0) where
                 Nothing -> error $ "L0.Interp: Unbound function reference: " ++ sdoc f
                 Just fn -> pure $ VLam (funArgs fn) (funBody fn) M.empty
         BenchE fn locs args _b ->
-          gInterpExp rc valenv ddefs fundefs (AppE fn locs args)
+          gInterpExp rc valenv ddefs fundefs (AppE (fn, NoTail) locs args)
         ParE0 ls -> gInterpExp rc valenv ddefs fundefs (MkProdE ls)
         PrintPacked _ty _arg -> pure $ VProd []
         CopyPacked _ty arg -> gInterpExp rc valenv ddefs fundefs arg