From 6e51acbd3aa7d3c58bbbc39beb8a959d3ae3bd67 Mon Sep 17 00:00:00 2001 From: Csaba Hruska Date: Mon, 8 Jan 2018 18:25:51 +0100 Subject: [PATCH] some work on extend HPT to infer LLVM types --- .gitignore | 3 +- grin/src/AbstractRunGrin.hs | 60 +++++++++++++++++++++++++------------ grin/src/CodeGenLLVM.hs | 35 +++++++++++++++++++--- grin/src/Eval.hs | 5 +++- grin/src/Pipeline.hs | 6 ++-- grin/src/PrettyHPT.hs | 2 +- 6 files changed, 83 insertions(+), 28 deletions(-) diff --git a/.gitignore b/.gitignore index a4caccaf..b67494d3 100644 --- a/.gitignore +++ b/.gitignore @@ -1,7 +1,8 @@ dist dist-* cabal-dev -*.o +*.s +*.ll *.hi *.chi *.chs.h diff --git a/grin/src/AbstractRunGrin.hs b/grin/src/AbstractRunGrin.hs index e94b43c8..4efb7c88 100644 --- a/grin/src/AbstractRunGrin.hs +++ b/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 diff --git a/grin/src/CodeGenLLVM.hs b/grin/src/CodeGenLLVM.hs index 5a297490..0c122952 100644 --- a/grin/src/CodeGenLLVM.hs +++ b/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 diff --git a/grin/src/Eval.hs b/grin/src/Eval.hs index 04d86a20..0b9c9bab 100644 --- a/grin/src/Eval.hs +++ b/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) = diff --git a/grin/src/Pipeline.hs b/grin/src/Pipeline.hs index e29bdbfd..7d80d4b0 100644 --- a/grin/src/Pipeline.hs +++ b/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 diff --git a/grin/src/PrettyHPT.hs b/grin/src/PrettyHPT.hs index d05f99b3..112468c4 100644 --- a/grin/src/PrettyHPT.hs +++ b/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