Fixing indirections

cabal.project

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

gibbon-compiler/examples/soa_examples/MonoTree.hs

@@ -0,0 +1,43 @@
+-- test monomorphic things
+module MonoTree where
+
+data Tree = Leaf Int
+          | Node Int Tree Tree
+  deriving Show
+{-# ANN type Tree "Factored" #-}
+
+mkTree :: Int -> Int -> Tree
+mkTree d acc =
+  if d == 0
+  then Leaf (acc)
+  else Node d (mkTree (d-1) (d+acc)) (mkTree (d-1) (d+acc))
+
+add1Tree :: Tree -> Tree
+add1Tree t =
+  case t of
+    Leaf x -> Leaf (x + 1)
+    Node d x1 x2 -> Node (d + 1) (add1Tree x1) (add1Tree x2)
+
+rightMost :: Tree -> Int
+rightMost t = case t of
+                  Leaf x -> x
+                  Node d x1 x2 -> rightMost x2
+
+sumTree :: Tree -> Int
+sumTree tr =
+  case tr of
+    Leaf n    -> n
+    Node d l r -> d + (sumTree l) + (sumTree r)
+
+id :: Tree -> Tree 
+id tree = tree
+
+gibbon_main = let 
+                tree = id (mkTree 23 0) 
+                tree' = (add1Tree tree)
+                tree'' = (add1Tree tree')
+                val = iterate (rightMost tree'') 
+               in (sumTree tree'') + val
+
+main :: IO ()
+main = print gibbon_main

gibbon-compiler/examples/simple_tests/list.hs → gibbon-compiler/examples/soa_examples/list.hs

@@ -1,4 +1,3 @@
-
 data List = Cons Int List | Nil 
 {-# ANN type List "Factored" #-}
 
@@ -17,7 +16,7 @@ add1 lst = case lst of
 		Nil -> Nil 
 		Cons i rst -> let 
 				i1 = i + 1
-                               in Cons i1 (add1 rst)
+							in Cons i1 (add1 rst)
 
 
 --fieldDep :: List -> (Int, List) 
@@ -33,13 +32,13 @@ sumList lst = case lst of
 		   Cons i rst -> let sumRst = sumList rst 
                                   in i + sumRst
 
+id :: List -> List 
+id lst = lst
+
 gibbon_main = let 
-		lst = mkList 20000
-                --lst' = iterate (add1 lst)
-                _ = printPacked lst
-                _ = printsym (quote "NEWLINE")
-                --(val, lst'') = fieldDep lst' 
-	       in sumList lst --() --printPacked lst' --val --sumList lst'
+		lst = mkList 100
+                lst' = id (add1 lst)
+	       in sumList lst'
 
 
 

gibbon-compiler/examples/simple_tests/packedBinaryTree.hs → gibbon-compiler/examples/soa_examples/packedBinaryTree.hs

@@ -1,6 +1,9 @@
 data List = Cons Int List | Nil
 data FloatList = FCons Float FloatList | FNil
 data Tree = Node Int FloatList List Tree Tree | Leaf
+{-# ANN type Tree "Factored" #-}
+{-# ANN type List "Linear" #-}
+{-# ANN type FloatList "Linear" #-}
 
 
 mkList :: Int -> List 
@@ -16,7 +19,7 @@ mkFloatList len = if len <= 0
 mkTree :: Int -> Tree
 mkTree d = if (d <= 0)
 	   then Leaf
-           else Node d (mkFloatList d) (mkList d) (mkTree (d - 1)) (mkTree (d - 1)) 
+           else Node d (mkFloatList 50000) (mkList 50000) (mkTree (d - 1)) (mkTree (d - 1))
 
 add1List :: List -> List
 add1List lst = case lst of 
@@ -70,7 +73,7 @@ sumFloatList :: FloatList -> Int
 sumFloatList lst = 10
 
 gibbon_main = 
-      let tree = mkTree 5
-          tree' = add1Tree tree
-       in sumTree tree'
+      let tree = mkTree 3
+          tree' = iterate (add1Tree tree)
+      in iterate (sumTree tree')
 

gibbon-compiler/examples/simple_tests/packedList.hs → gibbon-compiler/examples/soa_examples/packedList.hs

@@ -1,5 +1,7 @@
 data PackedInt = PacI Int
 data List = Cons Int PackedInt List | Nil 
+{-# ANN type PackedInt "Linear" #-}
+{-# ANN type List "Factored" #-}
 
 addPackedInt' :: PackedInt -> Int -> PackedInt
 addPackedInt' a b = case a of
@@ -40,13 +42,15 @@ sumList lst = case lst of
                                        sumRst = sumList rst
                                      in j + i' + sumRst
 
+id :: List -> List
+id lst = lst
+
+
 gibbon_main = let 
                 pi = mkPackedInt 10
-                lst = mkList 10
-                lst' = add1 lst
-                -- _ = printPacked lst'
-                --(val, lst'') = fieldDep lst'
-               in (sumList lst') --printPacked lst' --val --sumList lst'
+                lst = mkList 100
+                lst' = id (add1 lst)
+               in (sumList lst')
 
 
 

gibbon-compiler/examples/simple_tests/packedTree.hs → gibbon-compiler/examples/soa_examples/packedTree.hs

@@ -1,7 +1,9 @@
 data List = Cons Int List | Nil
 data FloatList = FCons Float FloatList | FNil
 data Tree = Node Int Float FloatList List Tree Tree Tree | Leaf
-
+{-# ANN type Tree "Factored" #-}
+{-# ANN type List "Linear" #-}
+{-# ANN type FloatList "Linear" #-}
 
 mkList :: Int -> List 
 mkList len = if len <= 0 
@@ -18,6 +20,13 @@ mkTree d = if (d <= 0)
 	   then Leaf
            else Node d 1.0 (mkFloatList d) (mkList d) (mkTree (d - 1)) (mkTree (d - 1)) (mkTree (d - 1))
 
+
+rightMostTree :: Tree -> Int
+rightMostTree tree = case tree of 
+                         Node a b c d e f g -> rightMostTree g
+                         Leaf -> 0
+
+
 add1List :: List -> List
 add1List lst = case lst of 
 		 Nil -> Nil 
@@ -74,8 +83,12 @@ sumFloatList lst = case lst of
 			FNil -> 0 
                         FCons x rst -> 1 + (sumFloatList rst)
 
+id :: Tree -> Tree 
+id tree = tree
+
 gibbon_main = 
-      let tree = mkTree 5
-          tree' = add1Tree tree
-       in sumTree tree'
+      let tree = id (mkTree 5)
+          tree' = (id (add1Tree tree))
+          val = (sumTree tree')
+       in val
 

gibbon-compiler/examples/soa_examples/test_copy.hs

@@ -0,0 +1,23 @@
+data Tree = Node Int Tree Tree | Leaf Int
+
+foo :: Int -> Tree
+foo i = let tree = Node i (Leaf i) (Leaf (i+1))
+         in tree
+
+make_node :: Tree -> Tree -> Tree
+make_node t1 t2 = Node 10 t1 t2
+
+foo' :: Tree -> Tree
+foo' tree = tree
+
+
+gibbon_main = 
+      let t1 = foo 20
+          t2 = foo 50
+          t3 = make_node t1 t2
+          t4 = foo' t3
+          --t4' = Node 12 (Leaf 1) (Leaf 2)
+          t5 = Node 12 (Leaf 1) t4 --Node 10 (Node 12 t4 t4') (Node 12 (Leaf 1) (Leaf 1))
+        in printPacked t5
+
+

gibbon-compiler/examples/soa_examples/test_list.ans

@@ -0,0 +1 @@
+5150

gibbon-compiler/examples/soa_examples/test_packed_list.ans

@@ -0,0 +1 @@
+10300

gibbon-compiler/examples/soa_examples/test_packed_tree.ans

@@ -0,0 +1 @@
+919

gibbon-compiler/examples/soa_examples/test_tree.ans

@@ -0,0 +1,3 @@
+(sum: 54604, rightmost: 1)
+
+'#()

gibbon-compiler/examples/simple_tests/tree.hs → gibbon-compiler/examples/soa_examples/tree.hs

@@ -20,24 +20,26 @@ add1Tree t =
 rightmost :: Tree -> Int
 rightmost tree = case tree of 
 		      Leaf i _ -> i
-                      Node _ _ _ _ l r ll rr -> rightmost rr
+                      Node a b c d l r ll rr -> rightmost r 
 
 sumTree :: Tree -> Int
 sumTree tr =
   case tr of
     Leaf n m   -> n
     Node i j k _ l r ll rr -> i + j + k + (sumTree l) + (sumTree r) + (sumTree ll) + (sumTree rr)
 
+id :: Tree -> Tree 
+id tree = tree
+
 gibbon_main = 
-   let tree = mkTree 10
-       -- _ = printPacked tree
-       tree' = add1Tree tree 
-       --_ =  printPacked tree'
-       val = sumTree tree'
-       _ = printsym (quote "\n\n(sum: ")
+   let tree = id (mkTree 10)
+       tree' = (add1Tree tree)
+       tree'' = iterate (id (add1Tree tree'))
+       val = (sumTree tree'')
+       _ = printsym (quote "(sum: ")
        _ = printint val 
        _ = printsym (quote ", rightmost: ")
-       rmost = rightmost tree'
+       rmost = (rightmost tree'')
        _ = printint rmost
        _ = printsym (quote ")\n\n")
-     in sumTree tree'
+     in val

gibbon-compiler/gibbon.cabal

@@ -96,6 +96,7 @@ library
                        Gibbon.Passes.HoistBoundsCheck
                        Gibbon.Passes.ReorderLetExprs
                        Gibbon.Passes.AddCastInstructions
+                       Gibbon.Passes.OptimizeL3
 
   other-extensions:    DeriveDataTypeable CPP
 

gibbon-compiler/src/Gibbon/Common.hs

@@ -33,7 +33,8 @@ module Gibbon.Common
 
          -- * Debugging/logging:
        , dbgLvl, dbgPrint, dbgPrintLn, dbgTrace, dbgTraceIt, minChatLvl
-       , internalError, dumpIfSet, unwrapLocVar, singleLocVar, getDconLoc, getFieldLoc, freshCommonLoc, getAllFieldLocsSoA, varsInLocVar, varsInRegVar
+       , internalError, dumpIfSet, unwrapLocVar, singleLocVar, getDconLoc, getFieldLoc, freshCommonLoc, getAllFieldLocsSoA
+       , varsInLocVar, varsInRegVar, getAllFieldRegsSoA
        , appendNameToLocVar 
 
          -- * Establish conventions for the output of #lang gibbon:
@@ -539,7 +540,7 @@ truePrinted = "#t"
 falsePrinted :: String
 falsePrinted = "#f"
 
-unwrapLocVar :: LocVar -> Var
+unwrapLocVar :: HasCallStack => LocVar -> Var
 unwrapLocVar locvar = case locvar of 
                             Single loc -> loc
                             SoA _dcon _fieldLocs ->
@@ -568,7 +569,7 @@ getDconLoc loc = case loc of
                     SoA dcon _fieldLocs -> Single dcon
                     Single _lc -> loc
 
-getFieldLoc :: (DataCon, FieldIndex) -> LocVar -> LocVar
+getFieldLoc :: HasCallStack => (DataCon, FieldIndex) -> LocVar -> LocVar
 getFieldLoc (dcon, idx) loc = case loc of 
                                 SoA _ fieldLocs -> case Prelude.lookup (dcon, idx) fieldLocs of 
                                                           Just loc' -> loc'
@@ -580,6 +581,12 @@ getAllFieldLocsSoA loc = case loc of
                     SoA _dcon fieldLocs -> fieldLocs
                     Single _lc -> error "getFieldLocs : Did not expect a non SoA location!"
 
+
+getAllFieldRegsSoA :: RegVar -> [((DataCon, Int), RegVar)]
+getAllFieldRegsSoA loc = case loc of 
+                    SoARv _dcon fieldLocs -> fieldLocs
+                    SingleR _lc -> error "getFieldLocs : Did not expect a non SoA location!"
+
 freshSingleLocVar :: String -> PassM LocVar
 freshSingleLocVar m = do v <- gensym (toVar m)
                          return $ Single v