WIP: decision Tree

Author: vidsinghal

gibbon-compiler/examples/layout_bench/DecisionTree.hs

@@ -0,0 +1,79 @@
+module Bench where
+
+import Basics
+import Gibbon.Vector 
+import Gibbon.PList
+
+type String = Vector Char
+
+data PackedBool = B Int
+
+data DecisionTree = Node PackedBool DecisionTree DecisionTree Inline | Leaf Inline
+
+
+
+mkRandomDecisionTree :: Int -> DecisionTree
+mkRandomDecisionTree depth = if depth <= 0 then Leaf (Str (getRandomString 10))
+                             else 
+                                let randBool = mod rand 2 
+                                    randString = getRandomString 10 
+                                    inline = Str randString
+                                    leftSubtree = mkRandomDecisionTree (depth-1) 
+                                    rightSubtree = mkRandomDecisionTree (depth-1)
+                                  in Node (B randBool) leftSubtree rightSubtree inline
+
+
+
+fromInline :: Inline -> String 
+fromInline inline = case inline of 
+                            Str a -> a
+
+fromBool :: PackedBool -> Int 
+fromBool b = case b of 
+                B bb -> bb
+
+merge_plist :: PList Inline -> PList Inline -> PList Inline 
+merge_plist lst1 lst2 = case lst1 of 
+                            Cons x rst -> Cons x (merge_plist rst lst2)
+                            Nil -> lst2 
+
+
+append_plist :: PList Inline -> Inline -> PList Inline 
+append_plist lst elem = case lst of 
+                              Nil -> (Cons elem) Nil 
+                              Cons x rst -> Cons x (append_plist rst elem)
+
+singleton_plist :: Inline -> PList Inline 
+singleton_plist elem = (Cons elem) Nil
+
+
+accumulateDecisions :: DecisionTree -> PList Inline
+accumulateDecisions tree = case tree of 
+                                Node b left right str -> let bb = fromBool b 
+                                                           in if bb == 1
+                                                              then 
+                                                                let curr = append_plist Nil str
+                                                                    vecLeft = accumulateDecisions left 
+                                                                    cc = singleton_plist (Str (getRandomString 10))
+                                                                    vecRight = accumulateDecisions right 
+                                                                 in merge_plist (merge_plist curr vecLeft) vecRight
+                                                              else 
+                                                                let vecLeft = accumulateDecisions left 
+                                                                    vecRight = accumulateDecisions right
+                                                                  in merge_plist vecLeft vecRight
+                                                                       
+                                Leaf str -> (Cons str) Nil
+
+
+gibbon_main = 
+    let tree = mkRandomDecisionTree 2
+        vec  = accumulateDecisions tree 
+     in printPacked vec
+
+--- filter 
+
+--- Map 
+
+--- Search 
+
+--- Length 

gibbon-compiler/src/Gibbon/Passes/AccessPatternsAnalysis.hs

@@ -97,22 +97,34 @@ greedyOrderOfVertices ee = let     edges' = P.map (\((a, b), c) -> ((P.fromInteg
                                    graph = buildG bounds edgesWithoutWeight
                                    weightMap = P.foldr (\(e, w) mm -> M.insert e w mm) M.empty edges'
                                    v'' = greedyOrderOfVerticesHelper graph (topSort graph) weightMap S.empty
-                                in v'' -- dbgTraceIt (sdoc (v'', (M.elems weightMap)))
+                                in v'' -- dbgTraceIt (sdoc ((topSort graph), (M.elems weightMap))) dbgTraceIt (sdoc (v'', (M.elems weightMap)))
 
 
 greedyOrderOfVerticesHelper :: Graph -> [Int] -> M.Map (Int, Int) Int -> S.Set Int -> [Int]
 greedyOrderOfVerticesHelper graph vertices' weightMap visited = case vertices' of
   [] -> []
   x:xs -> if S.member x visited
           then greedyOrderOfVerticesHelper graph xs weightMap visited
-          else let successors = reachable graph x
+          else let successors = succGraph x (G.edges graph) visited
                    removeCurr = S.toList $ S.delete x (S.fromList successors)
                    orderedSucc = orderedSuccsByWeight removeCurr x weightMap visited
-                   visited' = P.foldr S.insert S.empty orderedSucc
+                   visited' = P.foldr S.insert visited orderedSucc
                    v'' = greedyOrderOfVerticesHelper graph xs weightMap visited'
-                in if successors == [x] 
-                   then orderedSucc ++ v'' --dbgTraceIt (sdoc (v'', orderedSucc))
-                   else [x] ++ orderedSucc ++ v''
+                in  [x] ++ orderedSucc ++ v'' 
+                   -- dbgTraceIt (sdoc (x, successors, removeCurr, orderedSucc, v'', S.toList visited' , S.toList visited ))
+                   --then dbgTraceIt (sdoc (x, successors, removeCurr, orderedSucc, v'', S.toList visited')) orderedSucc ++ v'' --dbgTraceIt (sdoc (v'', orderedSucc))
+                   --else dbgTraceIt (sdoc (x, successors, removeCurr, orderedSucc, v'', S.toList visited')) [x] ++ orderedSucc ++ v''
+
+
+succGraph :: Int -> [(Int, Int)] -> S.Set Int -> [Int]
+succGraph node edges visited = case edges of 
+  [] -> [] 
+  (a, b):xs -> if S.member b visited || S.member a visited
+               then succGraph node xs visited
+               else 
+                if node == a then [b] ++ succGraph node xs visited
+                else succGraph node xs visited
+               
 
 orderedSuccsByWeight :: [Int] -> Int -> M.Map (Int, Int) Int -> S.Set Int -> [Int]
 orderedSuccsByWeight s i weightMap visited = case s of
@@ -271,7 +283,7 @@ removeDuplicates list =
 -- | a.) Multiple datacon fields read in the same expression.
 -- | Since this will be run after flatten, it is safe to assume that only possibly a maximum of two variables can be read in one let binding.
 -- | Except function calls! where more than two fields can be passed as arguments.
-evaluateExpressionFieldGraph ::
+evaluateExpressionFieldGraph :: (Out l, Out d, Out (e l d)) =>
   Maybe (DataCon, Integer) ->
   (G.Vertex -> (((PreExp e l d), Integer), Integer, [Integer])) ->
   (Integer -> Maybe G.Vertex) ->
@@ -416,19 +428,22 @@ evaluateExpressionFieldGraph currField nodeFromVertex vertexFromNode graph xs ma
                       {- list of tuples, where each tuple == ([(dcon, id), ... ], likelihood)    -}
                       succDataCon' =
                         P.zipWith (\x y -> (x, y)) succDataCon succprob
-                      newEdges =
+                      -- FIXME: TODO: This might be needed for the other cases in this function as well. 
+                      -- This is to make sure we recurse on all possible successors. 
+                      newEdges' = constructFieldGraph (Just (dcon, pred)) nodeFromVertex vertexFromNode graph succVertices map datacon 
+                      newEdges = newEdges' ++ ( 
                         P.concat $
                           P.map
                             ( \x ->
                                 case x of
                                   (varsl, prob) ->
                                     P.map (\y -> ((pred, snd y), prob)) varsl
                             )
-                            succDataCon'
+                            succDataCon' )
                    in case newEdges of
                         [] ->
                           case successors of
-                            [] ->
+                            [] -> --dbgTraceIt (sdoc (currField, succVertices, newEdges, newEdges'))
                               []
                                 ++ constructFieldGraph
                                   Nothing
@@ -438,7 +453,7 @@ evaluateExpressionFieldGraph currField nodeFromVertex vertexFromNode graph xs ma
                                   xs
                                   map
                                   datacon
-                            _ ->
+                            _ -> --dbgTraceIt (sdoc (currField, succVertices, newEdges, newEdges'))
                               newEdges
                                 ++ constructFieldGraph
                                   (Just (dcon, pred))
@@ -448,7 +463,7 @@ evaluateExpressionFieldGraph currField nodeFromVertex vertexFromNode graph xs ma
                                   xs
                                   map
                                   datacon
-                        _ ->
+                        _ -> --dbgTraceIt (sdoc (currField, succVertices, newEdges, newEdges'))
                           newEdges
                             ++ constructFieldGraph
                               Nothing
@@ -511,7 +526,7 @@ evaluateExpressionFieldGraph currField nodeFromVertex vertexFromNode graph xs ma
               error
                 "evaluateExpressionFieldGraph: More than one variable from DataCon in a let binding not modelled into Field dependence graph yet!"
 
-constructFieldGraph ::
+constructFieldGraph :: (Out l, Out d, Out (e l d)) =>
   Maybe (DataCon, Integer) ->
   (G.Vertex -> (((PreExp e l d), Integer), Integer, [Integer])) ->
   (Integer -> Maybe G.Vertex) ->
@@ -694,7 +709,7 @@ constructFieldGraph currField nodeFromVertex vertexFromNode graph progress map d
             _ -> error "not expected"
 
 -- | From an expression provided, Recursively find all the variables that come from a DataCon expression, that is, are fields in a DataConE.
-findFieldInDataConFromVariableInExpression ::
+findFieldInDataConFromVariableInExpression :: (Out l, Out d, Out (e l d)) =>
   (PreExp e l d) ->
   [(((PreExp e l d), Integer), Integer, [Integer])] ->
   VariableMap ->
@@ -722,7 +737,7 @@ findFieldInDataConFromVariableInExpression exp graph map datacon =
       let freeVars = freeVarsInOrder rhs
           fromDataCon = P.map (\v -> M.findWithDefault Nothing v map) freeVars
           removeMaybe = Mb.catMaybes fromDataCon
-          newDatacons =
+          newDatacons = --dbgTraceIt (sdoc (v, freeVars))
             [ if dcon == datacon
                 then Just (dcon, id')
                 else Nothing

gibbon-compiler/src/Gibbon/Passes/ControlFlowGraph.hs

@@ -18,7 +18,7 @@ import           Data.Set               as S
 
 -- Haskell Imports
 import           Prelude                as P
-
+import           Text.PrettyPrint.GenericPretty
 
 -- | CFGfunctionMap ex, a map storing a function, represented by Var (function name) to its control flow graph
 -- | Edge == (ex, Integer) the IR expression and its corresponding probability
@@ -58,11 +58,11 @@ type CFGfunctionMap ex
 
 -- | Generate a CFG out of a Function definition.
 -- | Returns a map mapping a function to its corresponding CFG
-getFunctionCFG :: FunDef (PreExp e l d) -> CFGfunctionMap (PreExp e l d)
+getFunctionCFG :: (Out l, Out d, Out (e l d)) => FunDef (PreExp e l d) -> CFGfunctionMap (PreExp e l d)
 getFunctionCFG f@FunDef {funName, funBody, funTy, funArgs} =
   let (edgeList, _, _) = generateCFGExp 0 100 funBody
       (graph, nodeFromVertex, vertexFromKey) = G.graphFromEdges edgeList
-   in M.insert funName (graph, nodeFromVertex, vertexFromKey) (M.empty)
+   in  M.insert funName (graph, nodeFromVertex, vertexFromKey) (M.empty) --dbgTraceIt (sdoc edgeList)
 
 
 -- | generate the Edges from the IR expression.

gibbon-compiler/src/Gibbon/Passes/OptimizeADTLayout.hs

@@ -746,7 +746,7 @@ getVariableAndProducer funName pMap venv@Env2{vEnv, fEnv} ddefs dconName exp =
                         justVariables = Maybe.catMaybes potentialVarsOfTy
                      in if P.null justVariables
                           -- dbgTraceIt (sdoc (funName, dconName, args, venv))
-                          then error "getVariableAndProducer: no variables of Ty to optimize found!"
+                          then Nothing-- dbgTraceIt (sdoc (funName, dconName, args, venv)) error "getVariableAndProducer: no variables of Ty to optimize found!"
                           else
                             if P.length justVariables > 1
                               then error "getVariableAndProducer: More than one variable of the type being optimized is passed to function call. Not implemented yet!"