some work on extend HPT to infer LLVM types

.gitignore

@@ -1,7 +1,8 @@
 dist
 dist-*
 cabal-dev
-*.o
+*.s
+*.ll
 *.hi
 *.chi
 *.chs.h

grin/src/AbstractRunGrin.hs

@@ -7,6 +7,7 @@ module AbstractRunGrin
   , RTLocVal(..)
   , RTNode(..)
   , RTVar(..)
+  , emptyComputer
   ) where
 
 import Debug.Trace
@@ -39,9 +40,18 @@ type ADefMap = Map Name ADef
     implement equasion solver for the specific example from the grin paper as a separate app
 -}
 
+data CGType
+  = T_I64
+  | T_Unit
+  | T_Loc
+  | T_Tag
+  | T_UNKNOWN
+  | T_Fun String
+  deriving (Eq, Ord, Show)
+
 data RTLocVal
   = RTLoc Int
-  | BAS
+  | BAS   CGType
   | RTVar Name -- HACK
   deriving (Eq, Ord, Show)
 
@@ -72,7 +82,11 @@ data Step
   | StepAssign  Name VarSet
   deriving Show
 
-emptyComputer = Computer mempty mempty mempty
+emptyComputer = Computer
+  { storeMap  = mempty
+  , envMap    = mempty
+  , steps     = mempty
+  }
 
 type GrinM = ReaderT ADefMap (State Computer)
 
@@ -125,7 +139,12 @@ lookupEnv n = Map.findWithDefault (error $ "missing variable: " ++ n) n <$> gets
 lookupStore :: Int -> GrinM NodeSet
 lookupStore i = IntMap.findWithDefault (error $ "missing location: " ++ show i) i <$> gets storeMap
 
-basVarSet = Set.singleton $ V BAS
+basVarSet cgType = Set.singleton . V . BAS $ cgType
+
+boolVarSet = Set.fromList
+  [ N $ RTNode (Tag C "True" 0) []
+  , N $ RTNode (Tag C "False" 0) []
+  ]
 
 toRTLocVal :: RTVar -> RTLocVal
 toRTLocVal (V a) = a
@@ -137,7 +156,7 @@ toRTNode a = error $ "toRTNode: illegal value " ++ show a
 -}
 evalVal :: Val -> GrinM VarSet
 evalVal = \case
-  v@Lit{}     -> pure basVarSet
+  v@Lit{}     -> pure $ basVarSet T_I64
   Var n       -> lookupEnv n
   ConstTagNode t a -> Set.singleton . N . RTNode t <$> mapM (\x -> Set.map toRTLocVal <$> evalVal x) a
 {-
@@ -148,15 +167,15 @@ evalVal = \case
                   -- TODO: support TagValue ; represent it as normal value instead of BAS
                   pure $ Set.fromList [N $ RTNode t args | t <- values]
 -}
-  v@ValTag{}  -> pure basVarSet
-  v@Unit      -> pure basVarSet
-  v@Loc{}     -> pure basVarSet
+  v@ValTag{}  -> pure $ basVarSet T_Tag
+  v@Unit      -> pure $ basVarSet T_Unit
+  v@Loc{}     -> pure $ basVarSet T_Loc
   x -> fail $ "ERROR: evalVal: " ++ show x
 
 
 selectRTNodeItem :: Maybe Int -> RTVar -> VarSet
 selectRTNodeItem Nothing val = Set.singleton val
-selectRTNodeItem (Just 0) (N (RTNode tag args)) = basVarSet
+selectRTNodeItem (Just 0) (N (RTNode tag args)) = basVarSet T_Tag
 selectRTNodeItem (Just i) (N (RTNode tag args)) = Set.map V $ (args !! (i - 1))
 
 evalSFetchF :: Maybe Int -> VarSet -> GrinM VarSet
@@ -165,7 +184,8 @@ evalSFetchF index vals = mconcat <$> mapM fetch (Set.toList vals) where
     V (RTLoc l) -> {-Set.map N <$> -}mconcat . map (selectRTNodeItem index) . Set.toList <$> lookupStore l
     x -> fail $ "ERROR: evalSimpleExp - Fetch expected location, got: " ++ show x
 
-evalSUpdateF vals v' = mapM_ update vals >> pure basVarSet where
+evalSUpdateF :: VarSet-> NodeSet -> GrinM VarSet
+evalSUpdateF vals v' = mapM_ update vals >> pure (basVarSet T_UNKNOWN) where
  update = \case
    V (RTLoc l) -> IntMap.member l <$> gets storeMap >>= \case
              False -> fail $ "ERROR: evalSimpleExp - Update unknown location: " ++ show l
@@ -205,18 +225,19 @@ evalSAppF n rtVals = do
 evalSimpleExp :: ASimpleExp -> GrinM VarSet
 evalSimpleExp = \case
 
-  _ :< (SAppF n args) -> case n of
+  _ :< (SAppF n args) -> do
+              rtVals <- mapM evalVal args -- Question: is this correct here?
+              case n of
                 -- Special case
                 -- "eval" -> evalEval args
                 -- Primitives
-                "add" -> pure basVarSet
-                "mul" -> pure basVarSet
-                "intPrint" -> pure basVarSet
-                "intGT" -> pure basVarSet
-                "intAdd" -> pure basVarSet
+                "add" -> pure $ basVarSet T_I64
+                "mul" -> pure $ basVarSet T_I64
+                "intPrint" -> pure $ basVarSet $ T_Fun "intPrint"
+                "intGT" -> pure $ basVarSet $ T_Fun "intGT" --boolVarSet
+                "intAdd" -> pure $ basVarSet T_I64
                 -- User defined functions
                 _ -> do
-                  rtVals <- mapM evalVal args -- Question: is this correct here?
                   evalSAppF n rtVals
 
   _ :< (SReturnF v) -> evalVal v
@@ -255,9 +276,10 @@ evalExp x = {-addStep x >> -}case x of
       , AltF (NodePat alttag names) exp <- map unwrap alts
       , tag == alttag
       ]
-    case Set.member (V BAS) vals of
-      False -> pure a
-      True  -> do
+    -- what is this???
+    case [() | V (BAS _) <- Set.toList vals] of
+      [] -> pure a
+      _  -> do
         let notNodePat = \case
               NodePat{} -> False
               _ -> True

grin/src/CodeGenLLVM.hs

@@ -16,6 +16,7 @@ import Data.Map (Map)
 import qualified Data.Map as Map
 
 import Grin
+import AbstractRunGrin
 
 import LLVM.AST hiding (callingConvention)
 import LLVM.AST.Type
@@ -47,14 +48,38 @@ toLLVM fname mod = withContext $ \ctx -> do
   BS.writeFile fname llvm
   pure llvm
 
--- TODO: create Tag map
+
+{-
+    b2     -> {BAS}
+    n13    -> {BAS,sum}
+    n18    -> {BAS}
+    n28    -> {BAS}
+    n29    -> {BAS}
+    n30    -> {BAS}
+    n31    -> {BAS}
+    sum    -> {BAS,sum}
+-}
+
+-- TODO: create Tag map ; get as parameter ; store in reader environment
+{-
+  question: how to calculate from grin or hpt result?
+-}
 tagMap :: Map Tag (Type, Constant)
 tagMap = Map.fromList
   [ (Tag Grin.C "False" 0, (i1, Int 1 0))
   , (Tag Grin.C "True" 0,  (i1, Int 1 1))
   ]
 
--- TODO: create Type map
+-- TODO: create Type map ; calculate once ; store in reader environment
+{-
+  question: how to calculate from grin or hpt result?
+    ANSWER: lookup from HPT result ; function name = result type ; argument names = input type
+
+  TODO:
+    in pre passes build ; store in env
+      function type map (llvm type)
+      variable map (llvm type)
+-}
 typeMap :: Map Grin.Name Type
 typeMap = Map.fromList
   [ ("b2" , i64)
@@ -103,6 +128,7 @@ data Env
   , constantMap       :: Map Grin.Name Operand
   , currentBlockName  :: AST.Name
   , envTempCounter    :: Int
+  , envHPTResult      :: HPTResult
   }
 
 emptyEnv = Env
@@ -112,6 +138,7 @@ emptyEnv = Env
   , constantMap       = mempty
   , currentBlockName  = mkName ""
   , envTempCounter    = 0
+  , envHPTResult      = emptyComputer
   }
 
 type CG = State Env
@@ -215,8 +242,8 @@ toModule Env{..} = defaultModule
   , moduleDefinitions = envDefinitions
   }
 
-codeGen :: Exp -> AST.Module
-codeGen = toModule . flip execState emptyEnv . para folder where
+codeGen :: HPTResult -> Exp -> AST.Module
+codeGen hptResult = toModule . flip execState (emptyEnv {envHPTResult = hptResult}) . para folder where
   folder :: ExpF (Exp, CG Result) -> CG Result
   folder = \case
     SReturnF val -> O <$> codeGenVal val

grin/src/Eval.hs

@@ -8,6 +8,8 @@ import qualified STReduceGrin
 import qualified ReduceGrin
 import qualified JITLLVM
 import qualified CodeGenLLVM
+import qualified AbstractRunGrin
+import Transformations (assignStoreIDs)
 
 data Reducer
   = PureReducer
@@ -24,7 +26,8 @@ eval' reducer fname = do
       case reducer of
         PureReducer -> pure $ ReduceGrin.reduceFun e "grinMain"
         STReducer   -> pure $ STReduceGrin.reduceFun e "grinMain"
-        LLVMReducer -> JITLLVM.eagerJit (CodeGenLLVM.codeGen (Program e)) "grinMain"
+        LLVMReducer -> JITLLVM.eagerJit (CodeGenLLVM.codeGen hptResult (Program e)) "grinMain" where
+          (result, hptResult) = AbstractRunGrin.abstractRun (assignStoreIDs $ Program e) "grinMain"
 
 evalProgram :: Reducer -> Program -> Val
 evalProgram reducer (Program defs) =

grin/src/Pipeline.hs

@@ -148,8 +148,9 @@ printGrinM color = do
 jitLLVM :: PipelineM ()
 jitLLVM = do
   e <- use psExp
+  Just hptResult <- use psHPTResult
   liftIO $ do
-    val <- JITLLVM.eagerJit (CGLLVM.codeGen e) "grinMain"
+    val <- JITLLVM.eagerJit (CGLLVM.codeGen hptResult e) "grinMain"
     print $ pretty val
 
 printAST :: PipelineM ()
@@ -172,9 +173,10 @@ saveLLVM :: FilePath -> PipelineM ()
 saveLLVM fname' = do
   e <- use psExp
   n <- use psTransStep
+  Just hptResult <- use psHPTResult
   o <- view poOutputDir
   let fname = o </> concat [fname',".",show n]
-      code = CGLLVM.codeGen e
+      code = CGLLVM.codeGen hptResult e
       llName = printf "%s.ll" fname
       sName = printf "%s.s" fname
   liftIO . void $ do

grin/src/PrettyHPT.hs

@@ -28,7 +28,7 @@ instance Pretty a => Pretty (Set a) where
 instance Pretty RTLocVal where
   pretty = \case
     RTLoc l     -> int l
-    BAS         -> text "BAS"
+    bas@BAS{}   -> text $ show bas
     RTVar name  -> ondullblack $ red $ text name
 
 instance Pretty RTNode where