From 77ab3ef5ce7625b0c6dd208464d3a13d61e88c5e Mon Sep 17 00:00:00 2001 From: anabra Date: Thu, 10 Oct 2019 16:40:21 +0200 Subject: [PATCH 1/8] ES CBy: added modules --- grin/grin.cabal | 6 + .../ExtendedSyntax/CreatedBy/CodeGen.hs | 360 ++++++++++++++++++ .../ExtendedSyntax/CreatedBy/CodeGenBase.hs | 199 ++++++++++ .../ExtendedSyntax/CreatedBy/Pretty.hs | 38 ++ .../ExtendedSyntax/CreatedBy/Readback.hs | 104 +++++ .../ExtendedSyntax/CreatedBy/Result.hs | 53 +++ .../ExtendedSyntax/CreatedBy/Util.hs | 178 +++++++++ 7 files changed, 938 insertions(+) create mode 100644 grin/src/AbstractInterpretation/ExtendedSyntax/CreatedBy/CodeGen.hs create mode 100644 grin/src/AbstractInterpretation/ExtendedSyntax/CreatedBy/CodeGenBase.hs create mode 100644 grin/src/AbstractInterpretation/ExtendedSyntax/CreatedBy/Pretty.hs create mode 100644 grin/src/AbstractInterpretation/ExtendedSyntax/CreatedBy/Readback.hs create mode 100644 grin/src/AbstractInterpretation/ExtendedSyntax/CreatedBy/Result.hs create mode 100644 grin/src/AbstractInterpretation/ExtendedSyntax/CreatedBy/Util.hs diff --git a/grin/grin.cabal b/grin/grin.cabal index 55049ead..6fd3a24d 100644 --- a/grin/grin.cabal +++ b/grin/grin.cabal @@ -24,6 +24,12 @@ library AbstractInterpretation.ExtendedSyntax.ReduceCpp AbstractInterpretation.ExtendedSyntax.Reduce AbstractInterpretation.ExtendedSyntax.Util + AbstractInterpretation.ExtendedSyntax.CreatedBy.Result + AbstractInterpretation.ExtendedSyntax.CreatedBy.Readback + AbstractInterpretation.ExtendedSyntax.CreatedBy.Util + AbstractInterpretation.ExtendedSyntax.CreatedBy.CodeGen + AbstractInterpretation.ExtendedSyntax.CreatedBy.CodeGenBase + AbstractInterpretation.ExtendedSyntax.CreatedBy.Pretty AbstractInterpretation.ExtendedSyntax.EffectTracking.CodeGenBase AbstractInterpretation.ExtendedSyntax.EffectTracking.CodeGen AbstractInterpretation.ExtendedSyntax.EffectTracking.Pretty diff --git a/grin/src/AbstractInterpretation/ExtendedSyntax/CreatedBy/CodeGen.hs b/grin/src/AbstractInterpretation/ExtendedSyntax/CreatedBy/CodeGen.hs new file mode 100644 index 00000000..5c037a40 --- /dev/null +++ b/grin/src/AbstractInterpretation/ExtendedSyntax/CreatedBy/CodeGen.hs @@ -0,0 +1,360 @@ +{-# LANGUAGE LambdaCase, TupleSections, TemplateHaskell, OverloadedStrings, RecordWildCards #-} +module AbstractInterpretation.ExtendedSyntax.CreatedBy.CodeGen where + +import Control.Monad.Writer +import Control.Monad.State + +import Data.Set (Set) +import Data.Map (Map) +import Data.Vector (Vector) + +import qualified Data.Set as Set +import qualified Data.Map as Map +import qualified Data.Vector as Vec +import Data.Functor.Foldable as Foldable + +import Lens.Micro.Platform + +import Grin.ExtendedSyntax.Grin +import Grin.ExtendedSyntax.TypeEnvDefs +import qualified AbstractInterpretation.ExtendedSyntax.IR as IR +import AbstractInterpretation.ExtendedSyntax.IR (Instruction(..), AbstractProgram(..), emptyAbstractProgram, AbstractMapping(..)) +import AbstractInterpretation.ExtendedSyntax.CreatedBy.CodeGenBase +import AbstractInterpretation.ExtendedSyntax.HeapPointsTo.CodeGen (litToSimpleType, unitType, codegenSimpleType) -- FIXME: why? remove, refactor +import AbstractInterpretation.ExtendedSyntax.HeapPointsTo.Result (undefinedProducer) -- FIXME: why? remove, refactor + +data CByMapping + = CByMapping + { _producerMap :: Map.Map IR.Reg Name + , _hptMapping :: AbstractMapping + } deriving (Show) + +concat <$> mapM makeLenses [''CByMapping] + +-- HPT program with producer information about nodes ; for each node, it contains the node's possible producers in the first field +mkCByProgramM :: CG (AbstractProgram, CByMapping) +mkCByProgramM = do + CGState{..} <- get + let prg = AbstractProgram + { _absMemoryCounter = _sMemoryCounter + , _absRegisterCounter = _sRegisterCounter + , _absInstructions = _sInstructions + } + mapping = CByMapping + { _producerMap = _sProducerMap + , _hptMapping = AbstractMapping + { _absRegisterMap = _sRegisterMap + , _absFunctionArgMap = _sFunctionArgMap + , _absTagMap = _sTagMap + } + } + pure (prg, mapping) + +type Producer = IR.Int32 + +addProducer :: IR.Reg -> Name -> CG () +addProducer r v = sProducerMap %= Map.insert r v + +registerToProducer :: IR.Reg -> Producer +registerToProducer (IR.Reg r) = fromIntegral r + +undefinedProducerName :: Name +undefinedProducerName = "#undefined" + + +codeGenNodeTypeCBy :: Tag -> Vector SimpleType -> CG IR.Reg +codeGenNodeTypeCBy tag ts = do + irTag <- getTag tag + r <- codeGenTaggedNodeType tag ts + emit IR.Set {dstReg = r, constant = IR.CNodeItem irTag 0 undefinedProducer} + pure r + +codeGenVal :: Val -> CG IR.Reg +codeGenVal = \case + ConstTagNode tag vals -> do + r <- newReg + irTag <- getTag tag + emit IR.Set {dstReg = r, constant = IR.CNodeType irTag (length vals + 1)} + emit IR.Set {dstReg = r, constant = IR.CNodeItem irTag 0 (registerToProducer r)} + forM_ (zip [1..] vals) $ \(idx, val) -> case val of + Var name -> do + valReg <- getReg name + emit IR.Extend + { srcReg = valReg + , dstSelector = IR.NodeItem irTag idx + , dstReg = r + } + Lit lit -> emit IR.Set {dstReg = r, constant = IR.CNodeItem irTag idx (litToSimpleType lit)} + Undefined (T_SimpleType t) -> do + tmp <- codeGenSimpleType t + emit IR.Extend + { srcReg = tmp + , dstSelector = IR.NodeItem irTag idx + , dstReg = r + } + _ -> error $ "illegal node item value " ++ show val + pure r + Unit -> do + r <- newReg + emit IR.Set {dstReg = r, constant = IR.CSimpleType (-1)} + pure r + Lit lit -> do + r <- newReg + emit IR.Set + { dstReg = r + , constant = IR.CSimpleType (litToSimpleType lit) + } + pure r + Var name -> getReg name + Undefined t -> codeGenType codeGenSimpleType (codeGenNodeSetWith codeGenNodeTypeCBy) t + val -> error $ "unsupported value " ++ show val + +typeTag :: Name -> Tag +typeTag n = Tag F n -- FIXME: this is a hack + +projectType :: IR.Reg -> Ty -> CG [(Name, IR.Reg)] +projectType argReg = \case + TySimple{} -> pure [] + TyVar name -> pure [(name, argReg)] + TyCon name args -> do + r <- newReg + emit IR.Fetch {addressReg = argReg, dstReg = r} + irTag <- getTag $ typeTag name + fmap concat $ forM (zip [1..] args) $ \(idx, ty) -> do + r1 <- newReg + emit IR.Project {srcSelector = IR.NodeItem irTag idx, srcReg = r, dstReg = r1} + projectType r1 ty + +constructType :: [(Name, IR.Reg)] -> Ty -> CG IR.Reg +constructType argMap = \case + TySimple simpleType -> do + r <- newReg + emit IR.Set {dstReg = r, constant = IR.CSimpleType (codegenSimpleType simpleType)} + pure r + TyVar name -> do + r <- newReg + mapM_ emit [IR.Move {srcReg = q, dstReg = r} | (n,q) <- argMap, n == name] + pure r + TyCon name args -> do + -- construct type node + valReg <- newReg + irTag <- getTag $ typeTag name + emit IR.Set {dstReg = valReg, constant = IR.CNodeType irTag (length args)} + emit IR.Set {dstReg = valReg, constant = IR.CNodeItem irTag 0 undefinedProducer} + -- fill type node componets + forM_ (zip [1..] args) $ \(idx, ty) -> do + q <- constructType argMap ty + emit IR.Extend + { srcReg = q + , dstSelector = IR.NodeItem irTag idx + , dstReg = valReg + } + -- store type node on abstract heap + loc <- newMem + r <- newReg + emit IR.Store {srcReg = valReg, address = loc} + emit IR.Set {dstReg = r, constant = IR.CHeapLocation loc} + pure r + +codeGenExternal :: External -> [Val] -> CG Result +codeGenExternal External{..} args = do + valRegs <- mapM codeGenVal args + argMap <- concat <$> zipWithM projectType valRegs eArgsType + R <$> constructType argMap eRetType + +codeGen :: Exp -> (AbstractProgram, CByMapping) +codeGen e = flip evalState emptyCGState $ para folder e >> mkCByProgramM where + folder :: ExpF (Exp, CG Result) -> CG Result + folder = \case + ProgramF exts defs -> do + mapM_ addExternal exts + mapM_ snd defs + pure Z + + DefF name args (_,body) -> do + (funResultReg, funArgRegs) <- getOrAddFunRegs name $ length args + zipWithM_ addReg args funArgRegs + body >>= \case + Z -> emit IR.Set {dstReg = funResultReg, constant = IR.CSimpleType unitType} + R r -> emit IR.Move {srcReg = r, dstReg = funResultReg} + pure Z + + EBindF (SReturn lhs,leftExp) (Var v) (_,rightExp) + | ConstTagNode{} <- lhs -> cgProducer leftExp v rightExp + | Undefined T_NodeSet{} <- lhs -> cgProducer leftExp v rightExp + where + cgProducer lExp p rExp = do + reg <- lExp + let R r = reg + addReg v r + addProducer r v + rExp + EBindF (_,leftExp) lpat (_,rightExp) -> do + leftExp >>= \case + Z -> case lpat of + Unit -> pure () + Var name -> do + r <- newReg + emit IR.Set {dstReg = r, constant = IR.CSimpleType unitType} + addReg name r + _ -> error $ "pattern mismatch at CreatedBy bind codegen, expected Unit got " ++ show lpat + R r -> case lpat of -- QUESTION: should the evaluation continue if the pattern does not match yet? + Unit -> pure () -- TODO: is this ok? or error? + Lit{} -> pure () -- TODO: is this ok? or error? + Var name -> addReg name r + ConstTagNode tag args -> do + irTag <- getTag tag + bindInstructions <- forM (zip [1..] args) $ \(idx, arg) -> case arg of + Var name -> do + argReg <- newReg + addReg name argReg + pure [ IR.Project { srcReg = r + , srcSelector = IR.NodeItem irTag idx + , dstReg = argReg + } + ] + Lit {} -> pure [] + _ -> error $ "illegal node pattern component " ++ show arg + emit IR.If + { condition = IR.NodeTypeExists irTag + , srcReg = r + , instructions = concat bindInstructions + } + _ -> error $ "unsupported lpat " ++ show lpat + rightExp + + ECaseF val alts_ -> do + valReg <- codeGenVal val + caseResultReg <- newReg + + -- save scrutinee register mapping + scrutRegMapping <- case val of + Var name -> Just . (name,) <$> getReg name + _ -> pure Nothing + {- + TODO: + - create scope monadic combinator to handle scopes + - set scrutinee value to the case alternative pattern value in the alternative scope + -} + alts <- sequence . fmap snd $ alts_ + + forM_ alts $ \(A cpat altM) -> do + let codeGenAlt bindM = codeGenBlock_ $ do + bindM + altM >>= \case + Z -> emit IR.Set {dstReg = caseResultReg, constant = IR.CSimpleType unitType} -- pure () + R altResultReg -> emit IR.Move {srcReg = altResultReg, dstReg = caseResultReg} + + case cpat of + NodePat tag vars -> do + irTag <- getTag tag + altInstructions <- codeGenAlt $ do + -- restrict scrutinee to alternative's domain + forM_ scrutRegMapping $ \(name, _) -> do + altScrutReg <- newReg + addReg name altScrutReg + -- NOTE: We just create a new empty register, and associate it with the scrutinee in this alternative. Then we annotate the register with restricted properties of the scrutinee. + emit IR.Project + { srcSelector = IR.ConditionAsSelector $ IR.NodeTypeExists irTag + , srcReg = valReg + , dstReg = altScrutReg + } + + -- bind pattern variables + forM_ (zip [1..] vars) $ \(idx, name) -> do + argReg <- newReg + addReg name argReg + emit IR.Project {srcSelector = IR.NodeItem irTag idx, srcReg = valReg, dstReg = argReg} + emit IR.If {condition = IR.NodeTypeExists irTag, srcReg = valReg, instructions = altInstructions} + + LitPat lit -> do + altInstructions <- codeGenAlt $ + -- restrict scrutinee to alternative's domain + forM_ scrutRegMapping $ \(name, _) -> do + altScrutReg <- newReg + addReg name altScrutReg + emit IR.Project + { srcSelector = IR.ConditionAsSelector $ IR.SimpleTypeExists (litToSimpleType lit) + , srcReg = valReg + , dstReg = altScrutReg + } + emit IR.If {condition = IR.SimpleTypeExists (litToSimpleType lit), srcReg = valReg, instructions = altInstructions} + + DefaultPat -> do + tags <- Set.fromList <$> sequence [getTag tag | A (NodePat tag _) _ <- alts] + altInstructions <- codeGenAlt $ + -- restrict scrutinee to alternative's domain + forM_ scrutRegMapping $ \(name, _) -> do + altScrutReg <- newReg + addReg name altScrutReg + emit IR.Project + { srcSelector = IR.ConditionAsSelector $ IR.AnyNotIn tags + , srcReg = valReg + , dstReg = altScrutReg + } + emit IR.If {condition = IR.AnyNotIn tags, srcReg = valReg, instructions = altInstructions} + + _ -> error $ "CBy does not support the following case pattern: " ++ show cpat + + -- restore scrutinee register mapping + maybe (pure ()) (uncurry addReg) scrutRegMapping + + pure $ R caseResultReg + + AltF cpat (_,exp) -> pure $ A cpat exp + + SAppF name args -> getExternal name >>= \case + Just ext -> do + res <- codeGenExternal ext args + let R r = res + -- HINT: workaround + ----------- + -- copy args to definition's variables ; read function result register + (funResultReg, funArgRegs) <- getOrAddFunRegs name $ length args + valRegs <- mapM codeGenVal args + zipWithM_ (\src dst -> emit IR.Move {srcReg = src, dstReg = dst}) valRegs funArgRegs + -- old prim codegen + let External{..} = ext + isTySimple TySimple{} = True + isTySimple _ = False + emit IR.Move {srcReg = r, dstReg = funResultReg} + when (isTySimple eRetType && all isTySimple eArgsType) $ do + zipWithM_ (\argReg (TySimple argTy) -> emit IR.Set {dstReg = argReg, constant = IR.CSimpleType (codegenSimpleType argTy)}) funArgRegs eArgsType + + pure res + + ----------- + + Nothing -> do + -- copy args to definition's variables ; read function result register + (funResultReg, funArgRegs) <- getOrAddFunRegs name $ length args + valRegs <- mapM codeGenVal args + zipWithM_ (\src dst -> emit IR.Move {srcReg = src, dstReg = dst}) valRegs funArgRegs + pure $ R funResultReg + + + SReturnF val -> R <$> codeGenVal val + + SStoreF val -> do + loc <- newMem + r <- newReg + valReg <- codeGenVal val + emit IR.Store {srcReg = valReg, address = loc} + emit IR.Set {dstReg = r, constant = IR.CHeapLocation loc} + pure $ R r + + SFetchIF name maybeIndex -> case maybeIndex of + Just {} -> error "CBy codegen does not support indexed fetch" + Nothing -> do + addressReg <- getReg name + r <- newReg + emit IR.Fetch {addressReg = addressReg, dstReg = r} + pure $ R r + + SUpdateF name val -> do + addressReg <- getReg name + valReg <- codeGenVal val + emit IR.Update {srcReg = valReg, addressReg = addressReg} + pure Z + + SBlockF (_,exp) -> exp diff --git a/grin/src/AbstractInterpretation/ExtendedSyntax/CreatedBy/CodeGenBase.hs b/grin/src/AbstractInterpretation/ExtendedSyntax/CreatedBy/CodeGenBase.hs new file mode 100644 index 00000000..475a9ab3 --- /dev/null +++ b/grin/src/AbstractInterpretation/ExtendedSyntax/CreatedBy/CodeGenBase.hs @@ -0,0 +1,199 @@ +{-# LANGUAGE LambdaCase, RecordWildCards, RankNTypes, TemplateHaskell #-} +module AbstractInterpretation.ExtendedSyntax.CreatedBy.CodeGenBase where + +import Data.Int +import Data.Word +import Data.Set (Set) +import Data.Map (Map) +import Data.Vector (Vector) + +import qualified Data.Bimap as Bimap +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Vector as Vec + +import Control.Monad.State + +import Lens.Micro.Platform + +import Grin.ExtendedSyntax.Grin +import Grin.ExtendedSyntax.TypeEnvDefs +import qualified AbstractInterpretation.ExtendedSyntax.IR as IR +import AbstractInterpretation.ExtendedSyntax.IR (Instruction(..), Reg(..)) + +data CGState + = CGState + { _sMemoryCounter :: Word32 + , _sRegisterCounter :: Word32 + , _sInstructions :: [Instruction] + + -- mapping + + , _sRegisterMap :: Map Name Reg + , _sFunctionArgMap :: Map Name (Reg, [Reg]) + , _sTagMap :: Bimap.Bimap Tag IR.Tag + , _sProducerMap :: Map.Map Reg Name + + -- internal + + , _sExternalMap :: Map Name External + } + deriving (Show) + +concat <$> mapM makeLenses [''CGState] + +emptyCGState :: CGState +emptyCGState = CGState + { _sMemoryCounter = 0 + , _sRegisterCounter = 0 + , _sInstructions = [] + + -- mapping + + , _sRegisterMap = mempty + , _sFunctionArgMap = mempty + , _sTagMap = Bimap.empty + , _sProducerMap = mempty + + , _sExternalMap = mempty + } + +type CG = State CGState + +data Result + = R IR.Reg + | Z + | A CPat (CG Result) + +emit :: IR.Instruction -> CG () +emit inst = modify' $ \s@CGState{..} -> s {_sInstructions = inst : _sInstructions} + +addExternal :: External -> CG () +addExternal e = modify' $ \s@CGState{..} -> s {_sExternalMap = Map.insert (eName e) e _sExternalMap} + +getExternal :: Name -> CG (Maybe External) +getExternal name = Map.lookup name <$> gets _sExternalMap + +-- creates regsiters for function arguments and result +getOrAddFunRegs :: Name -> Int -> CG (IR.Reg, [IR.Reg]) +getOrAddFunRegs name arity = do + funMap <- gets _sFunctionArgMap + case Map.lookup name funMap of + Just x -> pure x + Nothing -> do + resReg <- newReg + argRegs <- replicateM arity newReg + let funRegs = (resReg, argRegs) + modify' $ \s@CGState{..} -> s {_sFunctionArgMap = Map.insert name funRegs _sFunctionArgMap} + pure funRegs + +newReg :: CG IR.Reg +newReg = state $ \s@CGState{..} -> (IR.Reg _sRegisterCounter, s {_sRegisterCounter = succ _sRegisterCounter}) + +newMem :: CG IR.Mem +newMem = state $ \s@CGState{..} -> (IR.Mem _sMemoryCounter, s {_sMemoryCounter = succ _sMemoryCounter}) + +addReg :: Name -> IR.Reg -> CG () +addReg name reg = modify' $ \s@CGState{..} -> s {_sRegisterMap = Map.insert name reg _sRegisterMap} + +getReg :: Name -> CG IR.Reg +getReg name = do + regMap <- gets _sRegisterMap + case Map.lookup name regMap of + Nothing -> error $ "unknown variable " ++ unpackName name + Just reg -> pure reg + +getTag :: Tag -> CG IR.Tag +getTag tag = do + tagMap <- gets _sTagMap + case Bimap.lookup tag tagMap of + Just t -> pure t + Nothing -> do + let t = IR.Tag . fromIntegral $ Bimap.size tagMap + modify' $ \s -> s {_sTagMap = Bimap.insert tag t tagMap} + pure t + +codeGenBlock :: CG a -> CG (a,[IR.Instruction]) +codeGenBlock genM = do + instructions <- state $ \s@CGState{..} -> (_sInstructions, s {_sInstructions = []}) + ret <- genM + blockInstructions <- state $ \s@CGState{..} -> (reverse _sInstructions, s {_sInstructions = instructions}) + pure (ret, blockInstructions) + +codeGenBlock_ :: CG a -> CG [IR.Instruction] +codeGenBlock_ = fmap snd . codeGenBlock + +codeGenSimpleType :: SimpleType -> CG IR.Reg +codeGenSimpleType = \case + T_Unit -> newRegWithSimpleType (-1) + T_Int64 -> newRegWithSimpleType (-2) + T_Word64 -> newRegWithSimpleType (-3) + T_Float -> newRegWithSimpleType (-4) + T_Bool -> newRegWithSimpleType (-5) + T_String -> newRegWithSimpleType (-6) + T_Char -> newRegWithSimpleType (-7) + T_UnspecifiedLocation -> newRegWithSimpleType (-8) + T_Location locs -> do + r <- newReg + let locs' = map fromIntegral locs + mapM_ (`extendSimpleType` r) locs' + pure r + t -> newReg + where + -- TODO: rename simple type to something more generic, + newRegWithSimpleType :: IR.SimpleType -> CG IR.Reg + newRegWithSimpleType irTy = newReg >>= extendSimpleType irTy + + -- TODO: rename simple type to something more generic, + extendSimpleType :: IR.SimpleType -> IR.Reg -> CG IR.Reg + extendSimpleType irTy r = do + emit IR.Set + { dstReg = r + , constant = IR.CSimpleType irTy + } + pure r + +codeGenNodeSetWith :: (Tag -> Vector SimpleType -> CG IR.Reg) -> + NodeSet -> CG IR.Reg +codeGenNodeSetWith cgNodeTy ns = do + let (tags, argss) = unzip . Map.toList $ ns + dst <- newReg + nodeRegs <- zipWithM cgNodeTy tags argss + forM_ nodeRegs $ \src -> emit IR.Move { srcReg = src, dstReg = dst } + pure dst + +-- Generate a node type from type information, +-- but preserve the first field for tag information. +codeGenTaggedNodeType :: Tag -> Vector SimpleType -> CG IR.Reg +codeGenTaggedNodeType tag ts = do + let ts' = Vec.toList ts + r <- newReg + irTag <- getTag tag + argRegs <- mapM codeGenSimpleType ts' + emit IR.Set {dstReg = r, constant = IR.CNodeType irTag (length argRegs + 1)} + forM_ (zip [1..] argRegs) $ \(idx, argReg) -> + emit IR.Extend {srcReg = argReg, dstSelector = IR.NodeItem irTag idx, dstReg = r} + pure r + +-- FIXME: the following type signature is a bad oman ; it's not intuitive ; no-go ; refactor! +codeGenType :: (SimpleType -> CG IR.Reg) -> + (NodeSet -> CG IR.Reg) -> + Type -> CG IR.Reg +codeGenType cgSimpleTy cgNodeTy = \case + T_SimpleType t -> cgSimpleTy t + T_NodeSet ns -> cgNodeTy ns + +isPointer :: IR.Predicate +isPointer = IR.ValueIn (IR.Range 0 (maxBound :: Int32)) + +isNotPointer :: IR.Predicate +isNotPointer = IR.ValueIn (IR.Range (minBound :: Int32) 0) + +-- For simple types, copies only pointer information +-- For nodes, copies the structure and the pointer information in the fields +copyStructureWithPtrInfo :: IR.Reg -> IR.Reg -> IR.Instruction +copyStructureWithPtrInfo srcReg dstReg = IR.ConditionalMove + { srcReg = srcReg + , predicate = isPointer + , dstReg = dstReg + } diff --git a/grin/src/AbstractInterpretation/ExtendedSyntax/CreatedBy/Pretty.hs b/grin/src/AbstractInterpretation/ExtendedSyntax/CreatedBy/Pretty.hs new file mode 100644 index 00000000..5d84c386 --- /dev/null +++ b/grin/src/AbstractInterpretation/ExtendedSyntax/CreatedBy/Pretty.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE RecordWildCards #-} +module AbstractInterpretation.ExtendedSyntax.CreatedBy.Pretty where + +import Data.Functor.Foldable as Foldable +import Text.PrettyPrint.ANSI.Leijen + +import Data.Map (Map) +import qualified Data.Map as Map + +import Grin.Pretty +import Grin.Grin (Tag, Name) + +import AbstractInterpretation.ExtendedSyntax.CreatedBy.Result +import AbstractInterpretation.ExtendedSyntax.HeapPointsTo.Pretty + +instance Pretty ProducerSet where + pretty (ProducerSet ps) = prettyBracedList + . map prettySimplePair + . Map.toList $ ps + +instance Pretty ProducerMap where + pretty (ProducerMap pm) = prettyKeyValue $ Map.toList pm + +instance Pretty ProducerGraph where + pretty (ProducerGraph pMap) = pretty pMap + +instance Pretty GroupedProducers where + pretty (All prods) = yellow (text "Producer Groups (all)") + <$$> indent 4 (pretty prods) + pretty (Active prods) = yellow (text "Producer Groups (only for actives)") + <$$> indent 4 (pretty prods) + +instance Pretty CByResult where + pretty CByResult{..} = vsep + [ pretty _hptResult + , yellow (text "Producers") <$$> indent 4 (pretty _producers) + , pretty _groupedProducers + ] diff --git a/grin/src/AbstractInterpretation/ExtendedSyntax/CreatedBy/Readback.hs b/grin/src/AbstractInterpretation/ExtendedSyntax/CreatedBy/Readback.hs new file mode 100644 index 00000000..040741bc --- /dev/null +++ b/grin/src/AbstractInterpretation/ExtendedSyntax/CreatedBy/Readback.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE RecordWildCards #-} + +module AbstractInterpretation.ExtendedSyntax.CreatedBy.Readback where + +import Data.Set (Set) +import Data.Map (Map) +import Data.Vector (Vector) +import qualified Data.Set as S +import qualified Data.Map as M +import qualified Data.Vector as V + +import Data.Maybe + +import Lens.Micro.Platform + +import Grin.ExtendedSyntax.Grin (Name, Tag) +import AbstractInterpretation.ExtendedSyntax.IR (Reg(..)) +import AbstractInterpretation.ExtendedSyntax.Reduce (ComputerState) +import AbstractInterpretation.ExtendedSyntax.CreatedBy.CodeGen as CBy hiding (Producer) +import AbstractInterpretation.ExtendedSyntax.CreatedBy.Util +import AbstractInterpretation.ExtendedSyntax.CreatedBy.Result +import AbstractInterpretation.ExtendedSyntax.HeapPointsTo.Result +import AbstractInterpretation.ExtendedSyntax.LiveVariable.Result (LVAResult) + + +-- HPTResult with producer info +type HPTResultP = HPTResult +type Producer = Int + +-- node with its possible producers in its first field +type NodeP = Node +-- typeSet with producer info for its nodeSet +type TypeSetP = TypeSet + +regToProd :: Reg -> Producer +regToProd (Reg i) = fromIntegral i + +toProdMap :: Map Reg Name -> Map Producer Name +toProdMap = M.mapKeys regToProd + +-- Adds the undefined producer to a producer mapping +withUndefined :: Map Producer Name -> Map Producer Name +withUndefined = M.insert udProdId udProdName + where udProdId = fromIntegral undefinedProducer + udProdName = undefinedProducerName + +-- the heap locations will be interpreted as producers +-- also, the undefined value will hold the undefined producer's id +toProducer :: SimpleType -> Producer +toProducer (T_Location n) = n +toProducer (Local UndefinedProducer) = fromIntegral . fromHPTLocal $ UndefinedProducer +toProducer t = error $ "Incorrect information for producer. Expected T_Location Int or the undefined producer, got: " ++ show t + +-- removes the producers info from nodes +dropProducer :: NodeP -> Node +dropProducer = V.tail + +-- removes the producer info from the nodes in a typeSet +simplifyTypeSet :: TypeSetP -> TypeSet +simplifyTypeSet = over (nodeSet.nodeTagMap) (M.map dropProducer) + +unsafeUncons :: Vector a -> (a, Vector a) +unsafeUncons = (,) <$> V.head <*> V.tail + +getProducer :: NodeP -> Set Producer +getProducer = fst . extractProducer + +-- we assume that the producer will always be present in the register mapping +getNamedProducer :: Map Producer Name -> NodeP -> Set Name +getNamedProducer regs = S.map (`lookupE` regs) . fst . extractProducer + where lookupE k m = fromMaybe (error $ hasNoName k) $ M.lookup k m + hasNoName p = "Producer with id " ++ show p ++ " has no name. " ++ fix + fix = "Possible fix: run producer name introduction before the created-by analysis" + +extractProducer :: NodeP -> (Set Producer, Node) +extractProducer nodeP = (S.map toProducer ps, node) + where (ps,node) = unsafeUncons nodeP + +toCByResult :: CByMapping -> ComputerState -> CByResult +toCByResult CByMapping{..} comp = CByResult hptResult producers groupedProducers + where prodMap = withUndefined . toProdMap $ _producerMap + hptProdResult@HPTResult{..} = toHPTResult _hptMapping comp + + mem = V.map (over nodeTagMap (M.map dropProducer)) _memory + regs = M.map simplifyTypeSet _register + funs = M.map (over _1 simplifyTypeSet) + . M.map (over _2 (V.map simplifyTypeSet)) + $ _function + hptResult = HPTResult mem regs funs + + producers = ProducerMap $ M.map (ProducerSet . getNamedProducer') _register + + groupedProducers = All $ groupAllProducers producers + + getNamedProducer' :: TypeSet -> Map Tag (Set Name) + getNamedProducer' = M.map (getNamedProducer prodMap) + . _nodeTagMap + . _nodeSet + +toCByResultWithLiveness :: LVAResult -> CByMapping -> ComputerState -> CByResult +toCByResultWithLiveness lvaResult cbyMapping comp + | CByResult hptResult producers _ <- toCByResult cbyMapping comp + , groupedProducers <- Active $ groupActiveProducers lvaResult producers + = CByResult hptResult producers groupedProducers diff --git a/grin/src/AbstractInterpretation/ExtendedSyntax/CreatedBy/Result.hs b/grin/src/AbstractInterpretation/ExtendedSyntax/CreatedBy/Result.hs new file mode 100644 index 00000000..772a52fb --- /dev/null +++ b/grin/src/AbstractInterpretation/ExtendedSyntax/CreatedBy/Result.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE TemplateHaskell, GeneralizedNewtypeDeriving #-} + +module AbstractInterpretation.ExtendedSyntax.CreatedBy.Result where + +import Data.Set (Set) +import Data.Map (Map) +import qualified Data.Map as Map + +import Lens.Micro.Platform + +import Grin.ExtendedSyntax.Grin (Name, Tag) +import AbstractInterpretation.ExtendedSyntax.HeapPointsTo.Result + +-- possible producers grouped by tags +newtype ProducerMap = ProducerMap { _producerMap :: Map Name ProducerSet } + deriving (Eq, Show) +newtype ProducerSet = ProducerSet { _producerSet :: Map Tag (Set Name) } + deriving (Eq, Show) + +-- TODO: NewtypeDeriving or DerivingVia +instance Monoid ProducerSet where + mempty = ProducerSet Map.empty +instance Semigroup ProducerSet where + (<>) (ProducerSet x) (ProducerSet y) = ProducerSet $ Map.unionWith mappend x y + +instance Monoid ProducerMap where + mempty = ProducerMap Map.empty +instance Semigroup ProducerMap where + (<>) (ProducerMap x) (ProducerMap y) = ProducerMap $ Map.unionWith mappend x y + +-- A graph representing the connections between producers. +-- p1 <-t-> p2 means: producers p1 and p2 share a consumer for tag t +-- In a ProducerMap, we map variables to producers, +-- in a ProducerGraph we map producers to other producers. +newtype ProducerGraph = ProducerGraph { _producerGraph :: ProducerMap } + deriving (Eq, Show, Semigroup, Monoid) + +data GroupedProducers + = All ProducerGraph -- All producers are grouped + | Active ProducerGraph -- Groups are calcualted only for active producers (inactive producers have only reflexive connections) + deriving (Show) + +data CByResult + = CByResult + { _hptResult :: HPTResult + , _producers :: ProducerMap + , _groupedProducers :: GroupedProducers + } deriving (Show) + +emptyCByResult :: CByResult +emptyCByResult = CByResult emptyHPTResult mempty (All mempty) + +concat <$> mapM makeLenses [''ProducerMap, ''ProducerSet, ''CByResult, ''ProducerGraph] diff --git a/grin/src/AbstractInterpretation/ExtendedSyntax/CreatedBy/Util.hs b/grin/src/AbstractInterpretation/ExtendedSyntax/CreatedBy/Util.hs new file mode 100644 index 00000000..3c3ff1c9 --- /dev/null +++ b/grin/src/AbstractInterpretation/ExtendedSyntax/CreatedBy/Util.hs @@ -0,0 +1,178 @@ +module AbstractInterpretation.ExtendedSyntax.CreatedBy.Util where + +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Vector (Vector) +import qualified Data.Vector as Vec + +import Data.Maybe +import Data.Functor.Foldable as Foldable + +import Control.Monad.State + +import Grin.ExtendedSyntax.Grin + +import AbstractInterpretation.ExtendedSyntax.LiveVariable.Result +import AbstractInterpretation.ExtendedSyntax.CreatedBy.CodeGen (undefinedProducerName) +import AbstractInterpretation.ExtendedSyntax.CreatedBy.Result + +import Transformations.Util + +{- NOTE: The functions in this module handle #undefined producers + as well. This means that the producer groupings will + include a variable named "#undefined" if any undefined + values appear in the code +-} + +-- An untyped representation of the ProducerGraph (easier to handle). +type ProducerGraph' = Map Name (Map Tag (Set Name)) + +-- Constructs the connection graph between all producers. +-- First, it constructs the basic connection graph, +-- then it calculcates the basic graph's transitive closure. +groupAllProducers :: ProducerMap -> ProducerGraph +groupAllProducers = toProducerGraph + . transitiveClosure + . undirectedReflexiveClosure + . mkBasicProdGraph + +-- Constructs the connection graph between the active producers. +-- First, it constructs the basic connection graph. +-- Then it calculcates the basic graph's transitive closure for the active producers. +-- Then it inserts the inactive producers with only reflexive connections. +-- This way, the function calculates the transitive closure for potentially less nodes, +-- but still retains information about all producers. +groupActiveProducers :: LVAResult -> ProducerMap -> ProducerGraph +groupActiveProducers lvaResult prodMap = toProducerGraph groupedProducers where + + groupedProducers :: ProducerGraph' + groupedProducers = Map.union groupedActives reflexiveInactives + + reflexiveInactives :: ProducerGraph' + reflexiveInactives = onlyReflexiveConnections + . flip Map.withoutKeys activeProds + $ basicGraph + + groupedActives :: ProducerGraph' + groupedActives = transitiveClosure + . undirectedReflexiveClosure + . flip Map.restrictKeys activeProds + $ basicGraph + + + basicGraph :: ProducerGraph' + basicGraph = mkBasicProdGraph prodMap + + activeProds :: Set Name + activeProds = collectActiveProducers lvaResult prodMap + +toProducerGraph :: ProducerGraph' -> ProducerGraph +toProducerGraph = ProducerGraph . ProducerMap . Map.map ProducerSet + +fromProducerGraph :: ProducerGraph -> ProducerGraph' +fromProducerGraph = Map.map _producerSet . _producerMap . _producerGraph + +collectActiveProducers :: LVAResult -> ProducerMap -> Set Name +collectActiveProducers lvaResult = selectActiveProducers lvaResult . collectProducers + +collectProducers :: ProducerMap -> Set Name +collectProducers = mconcat + . concatMap Map.elems + . Map.elems + . Map.map _producerSet + . _producerMap + + +-- Selects the active producers from a producer set. +-- A producers is active if at least one of its tags has a live field. +-- Producers are grouped by tags for each consumer, which means +-- only producers with active tags will be grouped. As a consequence, +-- we do not have to (explicitly) consider tag liveness info here. +selectActiveProducers :: LVAResult -> Set Name -> Set Name +selectActiveProducers lvaResult prods = Map.keysSet + . Map.filter isNodeLive' + . producerLiveness + $ lvaResult + where + + producerLiveness :: LVAResult -> Map Name Liveness + producerLiveness = flip Map.restrictKeys prods . _registerLv + + isNodeLive' :: Liveness -> Bool + isNodeLive' (NodeSet m) = any hasLiveField m + isNodeLive' _ = error "Producers cannot have non-node liveness information" + + +-- Constructs the basic connection graph between all producers. +-- If a consumer has multiple producers with the same tag, +-- then one producer will be selected, and the others will be connected to it. +mkBasicProdGraph :: ProducerMap -> ProducerGraph' +mkBasicProdGraph producers = flip execState mempty $ do + let + -- All the active producers found in the program grouped by tags. + taggedGroups :: [(Tag, Set Name)] + taggedGroups = concatMap (Map.toList . _producerSet) + . Map.elems + . _producerMap + $ producers + + forM taggedGroups $ \(t,ps) -> do + let (p:_) = Set.toList ps + entry = Map.singleton t ps + update = Map.unionWith Set.union + modify $ Map.insertWith update p entry + +-- Deletes all connections then connects each producer with itself +onlyReflexiveConnections :: ProducerGraph' -> ProducerGraph' +onlyReflexiveConnections = Map.mapWithKey (\k m -> Map.map (const $ Set.singleton k) m) + +-- Creates an undirected graph from a directed one by connecting vertices +-- in both directions. Also connects each vertex with itself. +undirectedReflexiveClosure :: ProducerGraph' -> ProducerGraph' +undirectedReflexiveClosure m = flip execState m $ do + let pList = Map.toList + . Map.map Map.toList + . Map.map (Map.map Set.toList) + $ m + -- for each (p, (t, [p1 .. pn])), + -- it add the entries: (p1, (t, [p])) .. (pn, (t, [p])) + -- also insert p into (p, (t, [p1 .. pn])), + forM pList $ \(p, taggedGroups) -> + forM taggedGroups $ \(t, ps) -> + forM ps $ \p' -> do + let entry = Map.singleton t (Set.singleton p) + itself = Map.singleton t (Set.singleton p) + update = Map.unionWith Set.union + modify $ Map.insertWith update p' entry -- undirecting + modify $ Map.insertWith update p itself -- reflexivity + +-- Transitive closure for undirected graphs. +transitiveClosure :: ProducerGraph' -> ProducerGraph' +transitiveClosure m + | next <- tcStep m + , next /= m + = transitiveClosure next + | otherwise = m + where + + lookup' :: (Ord k, Monoid v) => k -> Map k v -> v + lookup' k = fromMaybe mempty . Map.lookup k + + -- if p1 --t-> p2 and p2 --t-> p3 then p1 --t-> p3 + tcStep :: ProducerGraph' -> ProducerGraph' + tcStep m = flip execState m $ do + let pList = Map.toList + . Map.map Map.toList + . Map.map (Map.map Set.toList) + $ m + forM pList $ \(p, taggedGroups) -> + forM taggedGroups $ \(t, ps) -> + forM ps $ \p' -> do + let entry = (lookup' t . lookup' p' $ m) :: Set Name + update = Map.adjust (Set.union entry) t + modify $ Map.adjust update p + +withoutUndefined :: ProducerGraph' -> ProducerGraph' +withoutUndefined = Map.delete undefinedProducerName From 88885d98ce1b0ff96f9fc8542d1ee935d392f1be Mon Sep 17 00:00:00 2001 From: anabra Date: Sun, 13 Oct 2019 23:00:55 +0200 Subject: [PATCH 2/8] ES CBy: fixed codegen --- .../ExtendedSyntax/CreatedBy/CodeGen.hs | 312 ++++++++++-------- 1 file changed, 166 insertions(+), 146 deletions(-) diff --git a/grin/src/AbstractInterpretation/ExtendedSyntax/CreatedBy/CodeGen.hs b/grin/src/AbstractInterpretation/ExtendedSyntax/CreatedBy/CodeGen.hs index 5c037a40..740899e6 100644 --- a/grin/src/AbstractInterpretation/ExtendedSyntax/CreatedBy/CodeGen.hs +++ b/grin/src/AbstractInterpretation/ExtendedSyntax/CreatedBy/CodeGen.hs @@ -16,7 +16,9 @@ import Data.Functor.Foldable as Foldable import Lens.Micro.Platform import Grin.ExtendedSyntax.Grin +import Grin.ExtendedSyntax.Pretty (PP(..)) import Grin.ExtendedSyntax.TypeEnvDefs +import Transformations.ExtendedSyntax.Util (paraM) import qualified AbstractInterpretation.ExtendedSyntax.IR as IR import AbstractInterpretation.ExtendedSyntax.IR (Instruction(..), AbstractProgram(..), emptyAbstractProgram, AbstractMapping(..)) import AbstractInterpretation.ExtendedSyntax.CreatedBy.CodeGenBase @@ -52,8 +54,8 @@ mkCByProgramM = do type Producer = IR.Int32 -addProducer :: IR.Reg -> Name -> CG () -addProducer r v = sProducerMap %= Map.insert r v +addProducer :: Name -> IR.Reg -> CG () +addProducer v r = sProducerMap %= Map.insert r v registerToProducer :: IR.Reg -> Producer registerToProducer (IR.Reg r) = fromIntegral r @@ -71,28 +73,18 @@ codeGenNodeTypeCBy tag ts = do codeGenVal :: Val -> CG IR.Reg codeGenVal = \case - ConstTagNode tag vals -> do + ConstTagNode tag args -> do r <- newReg irTag <- getTag tag - emit IR.Set {dstReg = r, constant = IR.CNodeType irTag (length vals + 1)} + emit IR.Set {dstReg = r, constant = IR.CNodeType irTag (length args + 1)} emit IR.Set {dstReg = r, constant = IR.CNodeItem irTag 0 (registerToProducer r)} - forM_ (zip [1..] vals) $ \(idx, val) -> case val of - Var name -> do - valReg <- getReg name - emit IR.Extend - { srcReg = valReg - , dstSelector = IR.NodeItem irTag idx - , dstReg = r - } - Lit lit -> emit IR.Set {dstReg = r, constant = IR.CNodeItem irTag idx (litToSimpleType lit)} - Undefined (T_SimpleType t) -> do - tmp <- codeGenSimpleType t - emit IR.Extend - { srcReg = tmp - , dstSelector = IR.NodeItem irTag idx - , dstReg = r - } - _ -> error $ "illegal node item value " ++ show val + forM_ (zip [1..] args) $ \(idx, arg) -> do + valReg <- getReg arg + emit IR.Extend + { srcReg = valReg + , dstSelector = IR.NodeItem irTag idx + , dstReg = r + } pure r Unit -> do r <- newReg @@ -107,7 +99,6 @@ codeGenVal = \case pure r Var name -> getReg name Undefined t -> codeGenType codeGenSimpleType (codeGenNodeSetWith codeGenNodeTypeCBy) t - val -> error $ "unsupported value " ++ show val typeTag :: Name -> Tag typeTag n = Tag F n -- FIXME: this is a hack @@ -156,89 +147,104 @@ constructType argMap = \case emit IR.Set {dstReg = r, constant = IR.CHeapLocation loc} pure r -codeGenExternal :: External -> [Val] -> CG Result +codeGenExternal :: External -> [Name] -> CG Result codeGenExternal External{..} args = do - valRegs <- mapM codeGenVal args + valRegs <- mapM getReg args argMap <- concat <$> zipWithM projectType valRegs eArgsType R <$> constructType argMap eRetType +-- TODO: remove +codeGenProducer :: CG Result -> Name -> CG Result -> CG Result +codeGenProducer cgLeftExp prodName cgRightExp = do + lResult <- cgLeftExp + let R r = lResult + addReg prodName r + addProducer prodName r + cgRightExp + +producesNode :: Val -> Bool +producesNode ConstTagNode{} = True +producesNode (Undefined T_NodeSet{}) = True +producesNode _ = False + +asPatternDataflow :: IR.Reg -> BPat -> CG () +asPatternDataflow r asPat@(AsPat _ asVal) = case asVal of + Unit -> pure () + Lit{} -> pure () + Var v -> addReg v r + ConstTagNode tag args -> do + irTag <- getTag tag + bindInstructions <- forM (zip [1..] args) $ \(idx, arg) -> do + argReg <- newReg + addReg arg argReg + pure [ IR.Project { srcReg = r + , srcSelector = IR.NodeItem irTag idx + , dstReg = argReg + } + ] + emit IR.If + { condition = IR.NodeTypeExists irTag + , srcReg = r + , instructions = concat bindInstructions + } + valPat -> error $ "unsupported @pattern: " ++ show (PP asPat) +asPatternDataflow _ pat = error $ "not @pattern: " ++ show (PP pat) + codeGen :: Exp -> (AbstractProgram, CByMapping) -codeGen e = flip evalState emptyCGState $ para folder e >> mkCByProgramM where - folder :: ExpF (Exp, CG Result) -> CG Result +codeGen e = flip evalState emptyCGState $ paraM folder e >> mkCByProgramM where + folder :: ExpF (Exp, Result) -> CG Result folder = \case ProgramF exts defs -> do mapM_ addExternal exts - mapM_ snd defs pure Z - DefF name args (_,body) -> do + DefF name args (_,bodyRes) -> do (funResultReg, funArgRegs) <- getOrAddFunRegs name $ length args zipWithM_ addReg args funArgRegs - body >>= \case + case bodyRes of Z -> emit IR.Set {dstReg = funResultReg, constant = IR.CSimpleType unitType} R r -> emit IR.Move {srcReg = r, dstReg = funResultReg} pure Z - EBindF (SReturn lhs,leftExp) (Var v) (_,rightExp) - | ConstTagNode{} <- lhs -> cgProducer leftExp v rightExp - | Undefined T_NodeSet{} <- lhs -> cgProducer leftExp v rightExp - where - cgProducer lExp p rExp = do - reg <- lExp - let R r = reg - addReg v r - addProducer r v - rExp - EBindF (_,leftExp) lpat (_,rightExp) -> do - leftExp >>= \case - Z -> case lpat of - Unit -> pure () - Var name -> do - r <- newReg - emit IR.Set {dstReg = r, constant = IR.CSimpleType unitType} - addReg name r - _ -> error $ "pattern mismatch at CreatedBy bind codegen, expected Unit got " ++ show lpat - R r -> case lpat of -- QUESTION: should the evaluation continue if the pattern does not match yet? - Unit -> pure () -- TODO: is this ok? or error? - Lit{} -> pure () -- TODO: is this ok? or error? - Var name -> addReg name r - ConstTagNode tag args -> do - irTag <- getTag tag - bindInstructions <- forM (zip [1..] args) $ \(idx, arg) -> case arg of - Var name -> do - argReg <- newReg - addReg name argReg - pure [ IR.Project { srcReg = r - , srcSelector = IR.NodeItem irTag idx - , dstReg = argReg - } - ] - Lit {} -> pure [] - _ -> error $ "illegal node pattern component " ++ show arg - emit IR.If - { condition = IR.NodeTypeExists irTag - , srcReg = r - , instructions = concat bindInstructions - } - _ -> error $ "unsupported lpat " ++ show lpat - rightExp - - ECaseF val alts_ -> do - valReg <- codeGenVal val + EBindF (_, Z) (VarPat var) (_, rhsRes) -> do + r <- newReg + addReg var r + pure rhsRes + EBindF (SReturn lhs, R r) (VarPat var) (_, rhsRes) + | producesNode lhs -> do + addReg var r + addProducer var r + pure rhsRes + EBindF (_, R r) (VarPat var) (_, rhsRes) -> do + addReg var r + pure rhsRes + + EBindF (_, Z) (AsPat var val) (_, rhsRes) -> do + r <- newReg + emit IR.Set {dstReg = r, constant = IR.CSimpleType unitType} + addReg var r + case val of + Unit -> pure () + Var inner -> addReg inner r + _ -> error $ "pattern mismatch at CreatedBy bind codegen, expected Unit got " ++ show (PP val) + pure rhsRes + EBindF (SReturn lhs, R r) asPat@(AsPat var _) (_, rhsRes) + | producesNode lhs -> do + addReg var r + addProducer var r + asPatternDataflow r asPat + pure rhsRes + EBindF (_, R r) asPat@(AsPat var _) (_, rhsRes) -> do + addReg var r + asPatternDataflow r asPat + pure rhsRes + + ECaseF scrut alts -> do + scrutReg <- getReg scrut caseResultReg <- newReg - -- save scrutinee register mapping - scrutRegMapping <- case val of - Var name -> Just . (name,) <$> getReg name - _ -> pure Nothing - {- - TODO: - - create scope monadic combinator to handle scopes - - set scrutinee value to the case alternative pattern value in the alternative scope - -} - alts <- sequence . fmap snd $ alts_ - - forM_ alts $ \(A cpat altM) -> do + let altResults = map snd alts + forM_ altResults $ \(A cpat altM) -> do let codeGenAlt bindM = codeGenBlock_ $ do bindM altM >>= \case @@ -250,58 +256,74 @@ codeGen e = flip evalState emptyCGState $ para folder e >> mkCByProgramM where irTag <- getTag tag altInstructions <- codeGenAlt $ do -- restrict scrutinee to alternative's domain - forM_ scrutRegMapping $ \(name, _) -> do - altScrutReg <- newReg - addReg name altScrutReg - -- NOTE: We just create a new empty register, and associate it with the scrutinee in this alternative. Then we annotate the register with restricted properties of the scrutinee. - emit IR.Project - { srcSelector = IR.ConditionAsSelector $ IR.NodeTypeExists irTag - , srcReg = valReg - , dstReg = altScrutReg - } + altScrutReg <- newReg + addReg scrut altScrutReg + {- NOTE: We just create a new empty register, and associate it with the scrutinee in this alternative. + Then we annotate the register with restricted properties of the scrutinee. + -} + emit IR.Project + { srcSelector = IR.ConditionAsSelector $ IR.NodeTypeExists irTag + , srcReg = scrutReg + , dstReg = altScrutReg + } -- bind pattern variables - forM_ (zip [1..] vars) $ \(idx, name) -> do - argReg <- newReg - addReg name argReg - emit IR.Project {srcSelector = IR.NodeItem irTag idx, srcReg = valReg, dstReg = argReg} - emit IR.If {condition = IR.NodeTypeExists irTag, srcReg = valReg, instructions = altInstructions} + forM_ (zip [1..] vars) $ \(idx, var) -> do + argReg <- newReg + addReg var argReg + emit IR.Project + { srcSelector = IR.NodeItem irTag idx + , srcReg = scrutReg + , dstReg = argReg + } + emit IR.If + { condition = IR.NodeTypeExists irTag + , srcReg = scrutReg + , instructions = altInstructions + } LitPat lit -> do - altInstructions <- codeGenAlt $ + altInstructions <- codeGenAlt $ do -- restrict scrutinee to alternative's domain - forM_ scrutRegMapping $ \(name, _) -> do - altScrutReg <- newReg - addReg name altScrutReg - emit IR.Project - { srcSelector = IR.ConditionAsSelector $ IR.SimpleTypeExists (litToSimpleType lit) - , srcReg = valReg - , dstReg = altScrutReg - } - emit IR.If {condition = IR.SimpleTypeExists (litToSimpleType lit), srcReg = valReg, instructions = altInstructions} + altScrutReg <- newReg + addReg scrut altScrutReg + emit IR.Project + { srcSelector = IR.ConditionAsSelector $ IR.SimpleTypeExists (litToSimpleType lit) + , srcReg = scrutReg + , dstReg = altScrutReg + } + emit IR.If + { condition = IR.SimpleTypeExists (litToSimpleType lit) + , srcReg = scrutReg + , instructions = altInstructions + } DefaultPat -> do - tags <- Set.fromList <$> sequence [getTag tag | A (NodePat tag _) _ <- alts] - altInstructions <- codeGenAlt $ + tags <- Set.fromList <$> sequence [getTag tag | A (NodePat tag _) _ <- altResults] + altInstructions <- codeGenAlt $ do -- restrict scrutinee to alternative's domain - forM_ scrutRegMapping $ \(name, _) -> do - altScrutReg <- newReg - addReg name altScrutReg - emit IR.Project - { srcSelector = IR.ConditionAsSelector $ IR.AnyNotIn tags - , srcReg = valReg - , dstReg = altScrutReg - } - emit IR.If {condition = IR.AnyNotIn tags, srcReg = valReg, instructions = altInstructions} - - _ -> error $ "CBy does not support the following case pattern: " ++ show cpat + altScrutReg <- newReg + addReg scrut altScrutReg + emit IR.Project + { srcSelector = IR.ConditionAsSelector $ IR.AnyNotIn tags + , srcReg = scrutReg + , dstReg = altScrutReg + } + emit IR.If + { condition = IR.AnyNotIn tags + , srcReg = scrutReg + , instructions = altInstructions + } -- restore scrutinee register mapping - maybe (pure ()) (uncurry addReg) scrutRegMapping + addReg scrut scrutReg pure $ R caseResultReg - AltF cpat (_,exp) -> pure $ A cpat exp + {- NOTE: The alternatives are already evaluated, + we only have return them. + -} + AltF cpat (_,exp) -> pure $ A cpat (pure exp) SAppF name args -> getExternal name >>= \case Just ext -> do @@ -311,8 +333,8 @@ codeGen e = flip evalState emptyCGState $ para folder e >> mkCByProgramM where ----------- -- copy args to definition's variables ; read function result register (funResultReg, funArgRegs) <- getOrAddFunRegs name $ length args - valRegs <- mapM codeGenVal args - zipWithM_ (\src dst -> emit IR.Move {srcReg = src, dstReg = dst}) valRegs funArgRegs + argRegs <- mapM getReg args + zipWithM_ (\src dst -> emit IR.Move {srcReg = src, dstReg = dst}) argRegs funArgRegs -- old prim codegen let External{..} = ext isTySimple TySimple{} = True @@ -328,33 +350,31 @@ codeGen e = flip evalState emptyCGState $ para folder e >> mkCByProgramM where Nothing -> do -- copy args to definition's variables ; read function result register (funResultReg, funArgRegs) <- getOrAddFunRegs name $ length args - valRegs <- mapM codeGenVal args - zipWithM_ (\src dst -> emit IR.Move {srcReg = src, dstReg = dst}) valRegs funArgRegs + argRegs <- mapM getReg args + zipWithM_ (\src dst -> emit IR.Move {srcReg = src, dstReg = dst}) argRegs funArgRegs pure $ R funResultReg SReturnF val -> R <$> codeGenVal val - SStoreF val -> do + SStoreF var -> do loc <- newMem r <- newReg - valReg <- codeGenVal val - emit IR.Store {srcReg = valReg, address = loc} + varReg <- getReg var + emit IR.Store {srcReg = varReg, address = loc} emit IR.Set {dstReg = r, constant = IR.CHeapLocation loc} pure $ R r - SFetchIF name maybeIndex -> case maybeIndex of - Just {} -> error "CBy codegen does not support indexed fetch" - Nothing -> do - addressReg <- getReg name - r <- newReg - emit IR.Fetch {addressReg = addressReg, dstReg = r} - pure $ R r - - SUpdateF name val -> do - addressReg <- getReg name - valReg <- codeGenVal val - emit IR.Update {srcReg = valReg, addressReg = addressReg} + SFetchF ptr -> do + ptrReg <- getReg ptr + r <- newReg + emit IR.Fetch {addressReg = ptrReg, dstReg = r} + pure $ R r + + SUpdateF ptr var -> do + ptrReg <- getReg ptr + varReg <- getReg var + emit IR.Update {srcReg = varReg, addressReg = ptrReg} pure Z - SBlockF (_,exp) -> exp + SBlockF (_,exp) -> pure exp From 90314fb47430052e7ef751103563fbe08ccfcea1 Mon Sep 17 00:00:00 2001 From: anabra Date: Sun, 13 Oct 2019 23:02:30 +0200 Subject: [PATCH 3/8] ES CBy: Pretty imports --- .../AbstractInterpretation/ExtendedSyntax/CreatedBy/Pretty.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/grin/src/AbstractInterpretation/ExtendedSyntax/CreatedBy/Pretty.hs b/grin/src/AbstractInterpretation/ExtendedSyntax/CreatedBy/Pretty.hs index 5d84c386..73f06c0d 100644 --- a/grin/src/AbstractInterpretation/ExtendedSyntax/CreatedBy/Pretty.hs +++ b/grin/src/AbstractInterpretation/ExtendedSyntax/CreatedBy/Pretty.hs @@ -7,8 +7,8 @@ import Text.PrettyPrint.ANSI.Leijen import Data.Map (Map) import qualified Data.Map as Map -import Grin.Pretty -import Grin.Grin (Tag, Name) +import Grin.ExtendedSyntax.Pretty +import Grin.ExtendedSyntax.Grin (Tag, Name) import AbstractInterpretation.ExtendedSyntax.CreatedBy.Result import AbstractInterpretation.ExtendedSyntax.HeapPointsTo.Pretty From 1d082886220f0796377b5ab6595f7397678bc7cc Mon Sep 17 00:00:00 2001 From: anabra Date: Sun, 13 Oct 2019 23:20:54 +0200 Subject: [PATCH 4/8] ES CBy: added test modules --- grin/grin.cabal | 4 +- grin/src/Test/ExtendedSyntax/IO.hs | 83 ++++ .../ExtendedSyntax/CreatedBySpec.hs | 448 ++++++++++++++++++ 3 files changed, 534 insertions(+), 1 deletion(-) create mode 100644 grin/src/Test/ExtendedSyntax/IO.hs create mode 100644 grin/test/AbstractInterpretation/ExtendedSyntax/CreatedBySpec.hs diff --git a/grin/grin.cabal b/grin/grin.cabal index 6fd3a24d..83f94b4a 100644 --- a/grin/grin.cabal +++ b/grin/grin.cabal @@ -130,9 +130,10 @@ library Test.Test Test.Util Test.ExtendedSyntax.Assertions - Test.ExtendedSyntax.Util + Test.ExtendedSyntax.IO Test.ExtendedSyntax.Old.Grammar Test.ExtendedSyntax.Old.Test + Test.ExtendedSyntax.Util Transformations.BindNormalisation Transformations.CountVariableUse Transformations.EffectMap @@ -319,6 +320,7 @@ test-suite grin-test PrimOpsSpec NametableSpec AbstractInterpretation.ExtendedSyntax.EffectTrackingSpec + AbstractInterpretation.ExtendedSyntax.CreatedBySpec AbstractInterpretation.ExtendedSyntax.HptSpec AbstractInterpretation.ExtendedSyntax.LiveVariableSpec AbstractInterpretation.ExtendedSyntax.SharingSpec diff --git a/grin/src/Test/ExtendedSyntax/IO.hs b/grin/src/Test/ExtendedSyntax/IO.hs new file mode 100644 index 00000000..f4bca192 --- /dev/null +++ b/grin/src/Test/ExtendedSyntax/IO.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving + , StandaloneDeriving + , FlexibleInstances + , DerivingStrategies + #-} +module Test.ExtendedSyntax.IO where + +import System.FilePath + +import Data.Text (Text) +import qualified Data.Text.IO as T (readFile) + +import Grin.ExtendedSyntax.Grin +import Grin.ExtendedSyntax.Parse + +import Test.Hspec +import Test.Hspec.Core.Spec (SpecM(..)) + +import Control.Monad.Trans + +deriving newtype instance MonadIO (SpecM ()) + +stackRoot :: FilePath +stackRoot = "" + +stackSrc :: FilePath +stackSrc = ".." + +stackTest :: FilePath +stackTest = "test" + +readProgram :: FilePath -> IO Exp +readProgram = readProgramWith parseProg + +readProgramWith :: (Text -> a) -> FilePath -> IO a +readProgramWith parse fp = do + src <- T.readFile fp + return $ parse src + +withCurDir :: FilePath -> FilePath -> FilePath +withCurDir curDir fp = if curDir == stackTest + then "." fp + else (curDir stackTest) fp + +testGroup :: String -> Spec -> IO () +testGroup name tests = hspec $ describe name tests + +mkSpecFromWith' :: (Text -> a) + -> FilePath + -> (a -> b) + -> [FilePath] + -> [b -> Spec] + -> Spec +mkSpecFromWith' parse curDir calcInfo srcs validators = do + foundResults <- liftIO $ mapM calcInfoIO srcs' + let validatedResults = zipWith ($) validators foundResults + sequence_ validatedResults + + where srcs' = map (withCurDir curDir) srcs + calcInfoIO fp = calcInfo <$> readProgramWith parse fp + +mkSpecFromWith :: FilePath + -> (Exp -> a) + -> [FilePath] + -> [a -> Spec] + -> Spec +mkSpecFromWith = mkSpecFromWith' parseProg + +mkBeforeAfterSpecFrom :: FilePath + -> (Exp -> a) + -> [FilePath] + -> [FilePath] + -> [FilePath -> a -> Spec] + -> Spec +mkBeforeAfterSpecFrom curDir calcInfo befores afters validators = do + foundResults <- liftIO $ mapM calcInfoIO befores' + let validators' = zipWith ($) validators afters' + validatedResults = zipWith ($) validators' foundResults + sequence_ validatedResults + + where befores' = map (withCurDir curDir) befores + afters' = map (withCurDir curDir) afters + calcInfoIO fp = calcInfo <$> readProgram fp diff --git a/grin/test/AbstractInterpretation/ExtendedSyntax/CreatedBySpec.hs b/grin/test/AbstractInterpretation/ExtendedSyntax/CreatedBySpec.hs new file mode 100644 index 00000000..2c0152c7 --- /dev/null +++ b/grin/test/AbstractInterpretation/ExtendedSyntax/CreatedBySpec.hs @@ -0,0 +1,448 @@ +{-# LANGUAGE OverloadedStrings, QuasiQuotes #-} +module AbstractInterpretation.ExtendedSyntax.CreatedBySpec (spec, calcCByResult) where + +import Data.Monoid ((<>)) +import qualified Data.Map as M +import qualified Data.Set as S +import qualified Data.Vector as V + +import System.FilePath + +import Grin.ExtendedSyntax.Grin hiding (SimpleType(..)) +import Grin.ExtendedSyntax.TH + +import Test.Hspec +import Test.ExtendedSyntax.IO +import Test.ExtendedSyntax.Old.Test +import Test.ExtendedSyntax.Util +import Test.ExtendedSyntax.Assertions + +import AbstractInterpretation.ExtendedSyntax.IR hiding (Tag) +import AbstractInterpretation.ExtendedSyntax.Reduce +import AbstractInterpretation.ExtendedSyntax.CreatedBy.CodeGen +import AbstractInterpretation.ExtendedSyntax.CreatedBy.Result +import AbstractInterpretation.ExtendedSyntax.CreatedBy.Readback +import AbstractInterpretation.ExtendedSyntax.HeapPointsTo.Result as HPT + + + +runTests :: IO () +runTests = hspec spec + +spec :: Spec +spec = do + let calcProducers = _producers . calcCByResult + calcHPTResultWithCBy = _hptResult . calcCByResult + mkProducerSet = ProducerSet . M.fromList . map (\(t,xs) -> (t,S.fromList xs)) + emptyProducerSet = mkProducerSet [] + unspecLoc = tySetFromTypes [T_UnspecifiedLocation] + loc = tySetFromTypes . pure . T_Location + mkNode = V.fromList . map S.fromList + mkNodeSet = HPT.NodeSet . M.fromList . map (\(t,v) -> (t,mkNode v)) + mkTySet = tySetFromNodeSet . mkNodeSet + tySetFromNodeSet = TypeSet mempty + tySetFromTypes = flip TypeSet mempty . S.fromList + mkSimpleMain t = (tySetFromTypes [t], mempty) + + describe "Created-By producers are calculated correctly for" $ do + it "pures" $ do + let exp = [prog| + grinMain = + a <- pure (CInt 5) + b <- pure a + c <- pure b + pure c + |] + let producerA = mkProducerSet [(Tag C "Int", ["a"])] + let puresExpected = ProducerMap $ + M.fromList + [ ("a", producerA) + , ("b", producerA) + , ("c", producerA) + ] + (calcProducers exp) `shouldBe` puresExpected + + it "function_call" $ do + let exp = [prog| + grinMain = + a <- pure (CInt 5) + b <- pure a + c <- f 5 + d <- g 5 + pure 5 + + f x = + x1 <- pure (CInt 5) + pure x1 + + g y = + y1 <- f y + pure y1 + |] + let producerA = mkProducerSet [(Tag C "Int", ["a"])] + producerX1 = mkProducerSet [(Tag C "Int", ["x1"])] + expected = ProducerMap $ + M.fromList [ ("a", producerA) + , ("b", producerA) + , ("c", producerX1) + , ("d", producerX1) + , ("x", emptyProducerSet) + , ("x1", producerX1) + , ("y", emptyProducerSet) + , ("y1", producerX1) + ] + (calcProducers exp) `shouldBe` expected + + it "case_simple" $ do + let exp = [prog| + grinMain = + a <- f 0 + pure a + + f x = + case x of + 0 -> x0 <- pure (CInt 5) + pure x0 + 1 -> x1 <- pure (CBool 0) + pure x1 + |] + let expected = ProducerMap $ + M.fromList [ ("a", producerA) + , ("x", emptyProducerSet) + , ("x0", producerX0) + , ("x1", producerX1) + ] + producerA = mkProducerSet [ (Tag C "Int", ["x0"]) + , (Tag C "Bool", ["x1"]) + ] + producerX0 = mkProducerSet [(Tag C "Int", ["x0"])] + producerX1 = mkProducerSet [(Tag C "Bool", ["x1"])] + (calcProducers exp) `shouldBe` expected + + it "heap" $ do + let exp = [prog| + grinMain = + x0 <- pure (CInt 5) + x1 <- pure (CBool 0) + x2 <- pure (CBool 1) + p0 <- store x0 + p1 <- store x1 + update p0 x2 + update p1 x2 + y0 <- fetch p0 + y1 <- fetch p1 + pure 5 + |] + let expected = ProducerMap $ + M.fromList [ ("x0", producerX0) + , ("x1", producerX1) + , ("x2", producerX2) + , ("p0", emptyProducerSet) + , ("p1", emptyProducerSet) + , ("y0", producerY0) + , ("y1", producerY1) + ] + producerX0 = mkProducerSet [(Tag C "Int", ["x0"])] + producerX1 = mkProducerSet [(Tag C "Bool", ["x1"])] + producerX2 = mkProducerSet [(Tag C "Bool", ["x2"])] + producerY0 = producerX0 <> producerX2 + producerY1 = producerX1 <> producerX2 + (calcProducers exp) `shouldBe` expected + + it "pointer_in_node" $ do + let exp = [prog| + grinMain = + n0 <- pure (CNil) + p0 <- store n0 + n1 <- pure (CCons 5 p0) + case n1 of + (CCons x pxs) -> xs <- fetch pxs + pure 5 + |] + let expected = ProducerMap $ + M.fromList [ ("n0", producerN0) + , ("p0", emptyProducerSet) + , ("n1", producerN1) + , ("x", emptyProducerSet) + , ("pxs", emptyProducerSet) + , ("xs", producerXS) + ] + producerN0 = mkProducerSet [(Tag C "Nil", ["n0"])] + producerN1 = mkProducerSet [(Tag C "Cons", ["n1"])] + producerXS = producerN0 + (calcProducers exp)` shouldBe` expected + + it "case_restricted_1" $ do + let exp = [prog| + grinMain = + a0 <- f 0 + r0 <- case a0 of + (CInt c0) -> b0 <- pure (CInt 5) + pure b0 + (CBool c1) -> b1 <- pure (CBool 0) + pure b1 + (CNope c2) -> b2 <- pure (CNope 1) + pure b2 + pure r0 + + + f x = + case x of + 0 -> x0 <- pure (CInt 5) + pure x0 + 1 -> x1 <- pure (CBool 0) + pure x1 + |] + let expected = ProducerMap $ + M.fromList [ ("a0", producerA0) + , ("r0", producerR0) + , ("b0", producerB0) + , ("b1", producerB1) + , ("b2", emptyProducerSet) + , ("c0", emptyProducerSet) + , ("c1", emptyProducerSet) + , ("c2", emptyProducerSet) + , ("x", emptyProducerSet) + , ("x0", producerX0) + , ("x1", producerX1) + ] + producerX0 = mkProducerSet [(Tag C "Int", ["x0"])] + producerX1 = mkProducerSet [(Tag C "Bool", ["x1"])] + producerA0 = producerX0 <> producerX1 + producerB0 = mkProducerSet [(Tag C "Int", ["b0"])] + producerB1 = mkProducerSet [(Tag C "Bool", ["b1"])] + producerR0 = producerB0 <> producerB1 + (calcProducers exp) `shouldBe` expected + + it "case_restricted_2" $ do + let exp = [prog| + grinMain = + a0 <- f 0 + r0 <- case a0 of + (CInt c0) -> b0 <- f 0 + pure b0 + (CBool c1) -> b1 <- pure (CBool 0) + pure b1 + (CNope c2) -> b2 <- pure (CNope 1) + pure b2 + pure r0 + + f x = + case x of + 0 -> x0 <- pure (CInt 5) + pure x0 + 1 -> x1 <- pure (CBool 0) + pure x1 + |] + let expected = ProducerMap $ + M.fromList [ ("a0", producerA0) + , ("r0", producerR0) + , ("b0", producerB0) + , ("b1", producerB1) + , ("b2", emptyProducerSet) + , ("c0", emptyProducerSet) + , ("c1", emptyProducerSet) + , ("c2", emptyProducerSet) + , ("x", emptyProducerSet) + , ("x0", producerX0) + , ("x1", producerX1) + ] + producerX0 = mkProducerSet [(Tag C "Int", ["x0"])] + producerX1 = mkProducerSet [(Tag C "Bool", ["x1"])] + producerA0 = producerX0 <> producerX1 + producerB0 = producerX0 <> producerX1 + producerB1 = mkProducerSet [(Tag C "Bool", ["b1"])] + producerR0 = producerB0 <> producerB1 + (calcProducers exp) `shouldBe` expected + + it "case_restricted_3" $ do + let exp = [prog| + grinMain = + a0 <- f 1 + a1 <- pure (CWord 3) + r0 <- case a0 of + (CInt c0) -> b0 <- g a0 + pure b0 + (CBool c1) -> b1 <- g a1 + pure b1 + (CNope c2) -> b2 <- pure (CNope 1) + pure b2 + pure r0 + + f x = + case x of + 0 -> x0 <- pure (CInt 5) + pure x0 + 1 -> x1 <- pure (CBool 0) + pure x1 + + g y = + case y of + (CInt n) -> y0 <- pure (CInt 5) + pure y0 + (CBool b) -> y1 <- pure (CBool 0) + pure y1 + (CWord w) -> y2 <- pure (CWord 3) + pure y2 + |] + let restrictedBy (ProducerSet ps) tag = ProducerSet $ M.filterWithKey (\k _ -> k == tag) ps + let expected = ProducerMap $ + M.fromList [ ("a0", producerA0) + , ("a1", producerA1) + , ("r0", producerR0) + , ("b0", producerB0) + , ("b1", producerB1) + , ("b2", emptyProducerSet) + , ("c0", emptyProducerSet) + , ("c1", emptyProducerSet) + , ("c2", emptyProducerSet) + , ("x", emptyProducerSet) + , ("x0", producerX0) + , ("x1", producerX1) + , ("y", producerY) + , ("y0", producerY0) + , ("y1", emptyProducerSet) -- because the control never reaches it + , ("y2", producerY2) + , ("n", emptyProducerSet) + , ("b", emptyProducerSet) + , ("w", emptyProducerSet) + ] + producerX0 = mkProducerSet [(Tag C "Int", ["x0"])] + producerX1 = mkProducerSet [(Tag C "Bool", ["x1"])] + producerA0 = producerX0 <> producerX1 + producerA1 = mkProducerSet [(Tag C "Word", ["a1"])] + producerY = producerA0 `restrictedBy` (Tag C "Int") <> producerA1 + producerY0 = mkProducerSet [(Tag C "Int", ["y0"])] + producerY1 = mkProducerSet [(Tag C "Bool", ["y1"])] + producerY2 = mkProducerSet [(Tag C "Word", ["y2"])] + producerB0 = producerY0 <> producerY2 -- because the analysis is not context sensitive + producerB1 = producerY0 <> producerY2 -- because the analysis is not context sensitive + producerR0 = producerB0 <> producerB1 + (calcProducers exp) `shouldBe` expected + + it "undefined" $ do + let exp = [prog| + grinMain = + p0 <- store (CNil) + p1 <- store (CCons 0 p0) + x0 <- pure (#undefined :: T_Int64) + n0 <- pure (#undefined :: {CCons[T_Int64,{0,1}]}) + p2 <- store n0 + n1 <- pure (#undefined :: {CNil[],CCons[T_Int64,{2}]}) + n2 <- pure (CCons (#undefined :: T_Int64) p0) + pure 5 + |] + let expected =ProducerMap $ + M.fromList [ ("n0", producerN0) + , ("n1", producerN1) + , ("n2", producerN2) + , ("p0", emptyProducerSet) + , ("p1", emptyProducerSet) + , ("p2", emptyProducerSet) + , ("x0", emptyProducerSet) + ] + producerN0 = mkProducerSet [(Tag C "Cons", [undefinedProducerName])] + producerN1 = mkProducerSet [(Tag C "Cons", [undefinedProducerName]), (Tag C "Nil", [undefinedProducerName])] + producerN2 = mkProducerSet [(Tag C "Cons", ["n2"])] + (calcProducers exp) `shouldBe` expected + + it "unspec_loc" $ do + let exp = [prog| + grinMain = + n0 <- pure (CNil) + p0 <- case 0 of + 0 -> store n0 + 1 -> pure (#undefined :: #ptr) + n1 <- fetch p0 + pure 0 + |] + let expected = ProducerMap $ + M.fromList [ ("n0", producerN0) + , ("n1", producerN0) + , ("p0", emptyProducerSet) + ] + producerN0 = mkProducerSet [(cNil, ["n0"])] + (calcProducers exp) `shouldBe` expected + + describe "Created-By type info" $ do + + it "undefined" $ do + let exp = [prog| + grinMain = + p0 <- store (CNil) + p1 <- store (CCons 0 p0) + x0 <- pure (#undefined :: T_Int64) + n0 <- pure (#undefined :: {CCons[T_Int64,{0,1}]}) + p2 <- store n0 + n1 <- pure (#undefined :: {CNil[],CCons[T_Int64,{2}]}) + n2 <- pure (CCons (#undefined :: T_Int64) p0) + pure 5 + |] + let expected = HPTResult + { HPT._memory = undefinedExpectedHeap + , HPT._register = undefinedExpectedRegisters + , HPT._function = undefinedExpectedFunctions + } + undefinedExpectedRegisters = M.fromList + [ ("p0", loc 0) + , ("p1", loc 1) + , ("p2", loc 2) + , ("x0", tySetFromTypes [T_Int64]) + , ("n0", tySetFromNodeSet nodeSetN0) + , ("n1", typeN1) + , ("n2", typeN2) + ] + where typeN1 = mkTySet [ (cCons, [[T_Int64], [T_Location 2]]) + , (cNil, []) + ] + typeN2 = mkTySet [ (cCons, [[T_Int64], [T_Location 0]]) + ] + undefinedExpectedFunctions = M.singleton "grinMain" (mkSimpleMain T_Int64) + undefinedExpectedHeap = V.fromList + [ mkNodeSet [(cNil, [])] + , mkNodeSet [(cCons, [[T_Int64], [T_Location 0]])] + , nodeSetN0 + ] + + + nodeSetN0 = mkNodeSet [(cCons, [[T_Int64], [T_Location 0, T_Location 1]])] + (calcHPTResultWithCBy exp) `shouldBe` expected + + it "unspec_loc" $ do + let exp = [prog| + grinMain = + p0 <- case 0 of + 0 -> store (CInt 5) + 1 -> pure (#undefined :: #ptr) + n0 <- fetch p0 + n1 <- pure (#undefined :: {CNode[#ptr]}) + (CNode p1) <- pure n1 + x0 <- fetch p1 + update p0 x0 + |] + let expected = HPTResult + { HPT._memory = unspecLocExpectedHeap + , HPT._register = unspecLocExpectedRegisters + , HPT._function = unspecLocExpectedFunctions + } + + nodeSetN0, nodeSetN1 :: HPT.NodeSet + nodeSetN0 = mkNodeSet [(cInt, [[T_Int64]])] + nodeSetN1 = mkNodeSet [(cNode, [[T_UnspecifiedLocation]])] + unspecLocExpectedHeap = V.fromList [ nodeSetN0 ] + unspecLocExpectedRegisters = M.fromList + [ ("p0", tySetFromTypes [T_Location 0, T_UnspecifiedLocation]) + , ("p1", unspecLoc) + , ("n0", tySetFromNodeSet nodeSetN0) + , ("n1", tySetFromNodeSet nodeSetN1) + , ("x0", tySetFromTypes []) + ] + unspecLocExpectedFunctions = M.singleton "grinMain" (mkSimpleMain T_Unit) + (calcHPTResultWithCBy exp) `shouldBe` expected + +calcCByResult :: Exp -> CByResult +calcCByResult prog + | (cbyProgram, cbyMapping) <- codeGen prog + , computer <- _airComp . evalAbstractProgram $ cbyProgram + , cbyResult <- toCByResult cbyMapping computer + = cbyResult From 29129b997f486e6927c74d7f0cfff5cdfd8dd897 Mon Sep 17 00:00:00 2001 From: anabra Date: Sun, 13 Oct 2019 23:24:51 +0200 Subject: [PATCH 5/8] ES CBy: removed Test.IO --- grin/grin.cabal | 1 - grin/src/Test/ExtendedSyntax/IO.hs | 83 ------------------- .../ExtendedSyntax/CreatedBySpec.hs | 5 -- 3 files changed, 89 deletions(-) delete mode 100644 grin/src/Test/ExtendedSyntax/IO.hs diff --git a/grin/grin.cabal b/grin/grin.cabal index 83f94b4a..388b0666 100644 --- a/grin/grin.cabal +++ b/grin/grin.cabal @@ -130,7 +130,6 @@ library Test.Test Test.Util Test.ExtendedSyntax.Assertions - Test.ExtendedSyntax.IO Test.ExtendedSyntax.Old.Grammar Test.ExtendedSyntax.Old.Test Test.ExtendedSyntax.Util diff --git a/grin/src/Test/ExtendedSyntax/IO.hs b/grin/src/Test/ExtendedSyntax/IO.hs deleted file mode 100644 index f4bca192..00000000 --- a/grin/src/Test/ExtendedSyntax/IO.hs +++ /dev/null @@ -1,83 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving - , StandaloneDeriving - , FlexibleInstances - , DerivingStrategies - #-} -module Test.ExtendedSyntax.IO where - -import System.FilePath - -import Data.Text (Text) -import qualified Data.Text.IO as T (readFile) - -import Grin.ExtendedSyntax.Grin -import Grin.ExtendedSyntax.Parse - -import Test.Hspec -import Test.Hspec.Core.Spec (SpecM(..)) - -import Control.Monad.Trans - -deriving newtype instance MonadIO (SpecM ()) - -stackRoot :: FilePath -stackRoot = "" - -stackSrc :: FilePath -stackSrc = ".." - -stackTest :: FilePath -stackTest = "test" - -readProgram :: FilePath -> IO Exp -readProgram = readProgramWith parseProg - -readProgramWith :: (Text -> a) -> FilePath -> IO a -readProgramWith parse fp = do - src <- T.readFile fp - return $ parse src - -withCurDir :: FilePath -> FilePath -> FilePath -withCurDir curDir fp = if curDir == stackTest - then "." fp - else (curDir stackTest) fp - -testGroup :: String -> Spec -> IO () -testGroup name tests = hspec $ describe name tests - -mkSpecFromWith' :: (Text -> a) - -> FilePath - -> (a -> b) - -> [FilePath] - -> [b -> Spec] - -> Spec -mkSpecFromWith' parse curDir calcInfo srcs validators = do - foundResults <- liftIO $ mapM calcInfoIO srcs' - let validatedResults = zipWith ($) validators foundResults - sequence_ validatedResults - - where srcs' = map (withCurDir curDir) srcs - calcInfoIO fp = calcInfo <$> readProgramWith parse fp - -mkSpecFromWith :: FilePath - -> (Exp -> a) - -> [FilePath] - -> [a -> Spec] - -> Spec -mkSpecFromWith = mkSpecFromWith' parseProg - -mkBeforeAfterSpecFrom :: FilePath - -> (Exp -> a) - -> [FilePath] - -> [FilePath] - -> [FilePath -> a -> Spec] - -> Spec -mkBeforeAfterSpecFrom curDir calcInfo befores afters validators = do - foundResults <- liftIO $ mapM calcInfoIO befores' - let validators' = zipWith ($) validators afters' - validatedResults = zipWith ($) validators' foundResults - sequence_ validatedResults - - where befores' = map (withCurDir curDir) befores - afters' = map (withCurDir curDir) afters - calcInfoIO fp = calcInfo <$> readProgram fp diff --git a/grin/test/AbstractInterpretation/ExtendedSyntax/CreatedBySpec.hs b/grin/test/AbstractInterpretation/ExtendedSyntax/CreatedBySpec.hs index 2c0152c7..469bdf98 100644 --- a/grin/test/AbstractInterpretation/ExtendedSyntax/CreatedBySpec.hs +++ b/grin/test/AbstractInterpretation/ExtendedSyntax/CreatedBySpec.hs @@ -6,18 +6,13 @@ import qualified Data.Map as M import qualified Data.Set as S import qualified Data.Vector as V -import System.FilePath - import Grin.ExtendedSyntax.Grin hiding (SimpleType(..)) import Grin.ExtendedSyntax.TH import Test.Hspec -import Test.ExtendedSyntax.IO -import Test.ExtendedSyntax.Old.Test import Test.ExtendedSyntax.Util import Test.ExtendedSyntax.Assertions -import AbstractInterpretation.ExtendedSyntax.IR hiding (Tag) import AbstractInterpretation.ExtendedSyntax.Reduce import AbstractInterpretation.ExtendedSyntax.CreatedBy.CodeGen import AbstractInterpretation.ExtendedSyntax.CreatedBy.Result From 39884bf077a739d6d7130333aecb45839eed266e Mon Sep 17 00:00:00 2001 From: anabra Date: Mon, 14 Oct 2019 01:18:07 +0200 Subject: [PATCH 6/8] ES CBy: reverted paraM to para in codegen --- .../ExtendedSyntax/CreatedBy/CodeGen.hs | 96 +++++++++++-------- 1 file changed, 54 insertions(+), 42 deletions(-) diff --git a/grin/src/AbstractInterpretation/ExtendedSyntax/CreatedBy/CodeGen.hs b/grin/src/AbstractInterpretation/ExtendedSyntax/CreatedBy/CodeGen.hs index 740899e6..1f33e4c3 100644 --- a/grin/src/AbstractInterpretation/ExtendedSyntax/CreatedBy/CodeGen.hs +++ b/grin/src/AbstractInterpretation/ExtendedSyntax/CreatedBy/CodeGen.hs @@ -18,13 +18,15 @@ import Lens.Micro.Platform import Grin.ExtendedSyntax.Grin import Grin.ExtendedSyntax.Pretty (PP(..)) import Grin.ExtendedSyntax.TypeEnvDefs -import Transformations.ExtendedSyntax.Util (paraM) import qualified AbstractInterpretation.ExtendedSyntax.IR as IR import AbstractInterpretation.ExtendedSyntax.IR (Instruction(..), AbstractProgram(..), emptyAbstractProgram, AbstractMapping(..)) import AbstractInterpretation.ExtendedSyntax.CreatedBy.CodeGenBase import AbstractInterpretation.ExtendedSyntax.HeapPointsTo.CodeGen (litToSimpleType, unitType, codegenSimpleType) -- FIXME: why? remove, refactor import AbstractInterpretation.ExtendedSyntax.HeapPointsTo.Result (undefinedProducer) -- FIXME: why? remove, refactor +-- TODO: remove +import Debug.Trace + data CByMapping = CByMapping { _producerMap :: Map.Map IR.Reg Name @@ -190,60 +192,70 @@ asPatternDataflow r asPat@(AsPat _ asVal) = case asVal of valPat -> error $ "unsupported @pattern: " ++ show (PP asPat) asPatternDataflow _ pat = error $ "not @pattern: " ++ show (PP pat) +{- NOTE: para is needed to specify the order of evalution of the lhs and rhs on binds. + paraM would execute both lhs and rhs before running the action that actually adds + the variables to the scope (addReg). +-} codeGen :: Exp -> (AbstractProgram, CByMapping) -codeGen e = flip evalState emptyCGState $ paraM folder e >> mkCByProgramM where - folder :: ExpF (Exp, Result) -> CG Result +codeGen e = flip evalState emptyCGState $ para folder e >> mkCByProgramM where + folder :: ExpF (Exp, CG Result) -> CG Result folder = \case ProgramF exts defs -> do mapM_ addExternal exts + mapM_ snd defs pure Z DefF name args (_,bodyRes) -> do (funResultReg, funArgRegs) <- getOrAddFunRegs name $ length args zipWithM_ addReg args funArgRegs - case bodyRes of + bodyRes >>= \case Z -> emit IR.Set {dstReg = funResultReg, constant = IR.CSimpleType unitType} R r -> emit IR.Move {srcReg = r, dstReg = funResultReg} pure Z - EBindF (_, Z) (VarPat var) (_, rhsRes) -> do - r <- newReg - addReg var r - pure rhsRes - EBindF (SReturn lhs, R r) (VarPat var) (_, rhsRes) - | producesNode lhs -> do - addReg var r - addProducer var r - pure rhsRes - EBindF (_, R r) (VarPat var) (_, rhsRes) -> do - addReg var r - pure rhsRes - - EBindF (_, Z) (AsPat var val) (_, rhsRes) -> do - r <- newReg - emit IR.Set {dstReg = r, constant = IR.CSimpleType unitType} - addReg var r - case val of - Unit -> pure () - Var inner -> addReg inner r - _ -> error $ "pattern mismatch at CreatedBy bind codegen, expected Unit got " ++ show (PP val) - pure rhsRes - EBindF (SReturn lhs, R r) asPat@(AsPat var _) (_, rhsRes) - | producesNode lhs -> do - addReg var r - addProducer var r - asPatternDataflow r asPat - pure rhsRes - EBindF (_, R r) asPat@(AsPat var _) (_, rhsRes) -> do - addReg var r - asPatternDataflow r asPat - pure rhsRes - - ECaseF scrut alts -> do - scrutReg <- getReg scrut + -- NOTE: variable patterns + EBindF (lhs, cgLhs) (VarPat var) (_, cgRhs) -> do + lhsRes <- cgLhs + case lhsRes of + Z -> do + r <- newReg + addReg var r + R r -> do + case lhs of + SReturn val | producesNode val -> do + addReg var r + addProducer var r + _ -> addReg var r + cgRhs + + -- NOTE: @patterns + EBindF (lhs, cgLhs) asPat@(AsPat var valPat) (_, cgRhs) -> do + lhsRes <- cgLhs + case lhsRes of + Z -> do + r <- newReg + emit IR.Set {dstReg = r, constant = IR.CSimpleType unitType} + addReg var r + case valPat of + Unit -> pure () + Var inner -> addReg inner r + _ -> error $ "pattern mismatch at CreatedBy bind codegen, expected Unit got " ++ show (PP valPat) + R r -> do + case lhs of + SReturn val | producesNode val -> do + addReg var r + addProducer var r + asPatternDataflow r asPat + _ -> do + addReg var r + asPatternDataflow r asPat + cgRhs + + ECaseF scrut alts_ -> do + scrutReg <- getReg scrut caseResultReg <- newReg + altResults <- sequence . fmap snd $ alts_ - let altResults = map snd alts forM_ altResults $ \(A cpat altM) -> do let codeGenAlt bindM = codeGenBlock_ $ do bindM @@ -323,7 +335,7 @@ codeGen e = flip evalState emptyCGState $ paraM folder e >> mkCByProgramM where {- NOTE: The alternatives are already evaluated, we only have return them. -} - AltF cpat (_,exp) -> pure $ A cpat (pure exp) + AltF cpat (_, cgAlt) -> pure $ A cpat cgAlt SAppF name args -> getExternal name >>= \case Just ext -> do @@ -377,4 +389,4 @@ codeGen e = flip evalState emptyCGState $ paraM folder e >> mkCByProgramM where emit IR.Update {srcReg = varReg, addressReg = ptrReg} pure Z - SBlockF (_,exp) -> pure exp + SBlockF (_, cgBlock) -> cgBlock From 5cea477d9ad75c98702b12802f3c279c9145a053 Mon Sep 17 00:00:00 2001 From: anabra Date: Mon, 14 Oct 2019 19:22:25 +0200 Subject: [PATCH 7/8] ES CBy: fixed tests --- .../ExtendedSyntax/CreatedBySpec.hs | 207 ++++++++++++------ 1 file changed, 144 insertions(+), 63 deletions(-) diff --git a/grin/test/AbstractInterpretation/ExtendedSyntax/CreatedBySpec.hs b/grin/test/AbstractInterpretation/ExtendedSyntax/CreatedBySpec.hs index 469bdf98..4a33de63 100644 --- a/grin/test/AbstractInterpretation/ExtendedSyntax/CreatedBySpec.hs +++ b/grin/test/AbstractInterpretation/ExtendedSyntax/CreatedBySpec.hs @@ -20,6 +20,14 @@ import AbstractInterpretation.ExtendedSyntax.CreatedBy.Readback import AbstractInterpretation.ExtendedSyntax.HeapPointsTo.Result as HPT +-- TODO: @patern tests + +{- NOTE: Variables with names like "z" are introduced just for naming. + They are not relevant to the result of the analysis. + + Variables with names like "_" are introduced just for named bindings. + They will never be used. +-} runTests :: IO () runTests = hspec spec @@ -42,32 +50,37 @@ spec = do describe "Created-By producers are calculated correctly for" $ do it "pures" $ do let exp = [prog| - grinMain = - a <- pure (CInt 5) + grinMain = + z0 <- pure 0 + a <- pure (CInt z0) b <- pure a c <- pure b - pure c - |] + pure a + |] let producerA = mkProducerSet [(Tag C "Int", ["a"])] let puresExpected = ProducerMap $ M.fromList [ ("a", producerA) , ("b", producerA) , ("c", producerA) + + , ("z0", emptyProducerSet) ] (calcProducers exp) `shouldBe` puresExpected it "function_call" $ do let exp = [prog| grinMain = - a <- pure (CInt 5) + z0 <- pure 0 + a <- pure (CInt z0) b <- pure a - c <- f 5 - d <- g 5 + c <- f z0 + d <- g z0 pure 5 f x = - x1 <- pure (CInt 5) + z1 <- pure 0 + x1 <- pure (CInt z1) pure x1 g y = @@ -85,27 +98,35 @@ spec = do , ("x1", producerX1) , ("y", emptyProducerSet) , ("y1", producerX1) + + , ("z0", emptyProducerSet) + , ("z1", emptyProducerSet) ] (calcProducers exp) `shouldBe` expected it "case_simple" $ do let exp = [prog| grinMain = - a <- f 0 + z0 <- pure 0 + a <- f z0 pure a f x = - case x of - 0 -> x0 <- pure (CInt 5) - pure x0 - 1 -> x1 <- pure (CBool 0) - pure x1 + z1 <- pure 0 + case x of + 0 -> x0 <- pure (CInt z1) + pure x0 + 1 -> x1 <- pure (CBool z1) + pure x1 |] let expected = ProducerMap $ M.fromList [ ("a", producerA) , ("x", emptyProducerSet) , ("x0", producerX0) , ("x1", producerX1) + + , ("z0", emptyProducerSet) + , ("z1", emptyProducerSet) ] producerA = mkProducerSet [ (Tag C "Int", ["x0"]) , (Tag C "Bool", ["x1"]) @@ -117,13 +138,14 @@ spec = do it "heap" $ do let exp = [prog| grinMain = - x0 <- pure (CInt 5) - x1 <- pure (CBool 0) - x2 <- pure (CBool 1) + z0 <- pure 0 + x0 <- pure (CInt z0) + x1 <- pure (CBool z0) + x2 <- pure (CBool z0) p0 <- store x0 p1 <- store x1 - update p0 x2 - update p1 x2 + _1 <- update p0 x2 + _2 <- update p1 x2 y0 <- fetch p0 y1 <- fetch p1 pure 5 @@ -136,6 +158,10 @@ spec = do , ("p1", emptyProducerSet) , ("y0", producerY0) , ("y1", producerY1) + + , ("z0", emptyProducerSet) + , ("_1", emptyProducerSet) + , ("_2", emptyProducerSet) ] producerX0 = mkProducerSet [(Tag C "Int", ["x0"])] producerX1 = mkProducerSet [(Tag C "Bool", ["x1"])] @@ -147,9 +173,10 @@ spec = do it "pointer_in_node" $ do let exp = [prog| grinMain = + z0 <- pure 0 n0 <- pure (CNil) p0 <- store n0 - n1 <- pure (CCons 5 p0) + n1 <- pure (CCons z0 p0) case n1 of (CCons x pxs) -> xs <- fetch pxs pure 5 @@ -161,6 +188,8 @@ spec = do , ("x", emptyProducerSet) , ("pxs", emptyProducerSet) , ("xs", producerXS) + + , ("z0", emptyProducerSet) ] producerN0 = mkProducerSet [(Tag C "Nil", ["n0"])] producerN1 = mkProducerSet [(Tag C "Cons", ["n1"])] @@ -170,23 +199,25 @@ spec = do it "case_restricted_1" $ do let exp = [prog| grinMain = - a0 <- f 0 + z0 <- pure 0 + a0 <- f z0 r0 <- case a0 of - (CInt c0) -> b0 <- pure (CInt 5) + (CInt c0) -> b0 <- pure (CInt z0) pure b0 - (CBool c1) -> b1 <- pure (CBool 0) + (CBool c1) -> b1 <- pure (CBool z0) pure b1 - (CNope c2) -> b2 <- pure (CNope 1) + (CNope c2) -> b2 <- pure (CNope z0) pure b2 pure r0 f x = - case x of - 0 -> x0 <- pure (CInt 5) - pure x0 - 1 -> x1 <- pure (CBool 0) - pure x1 + z1 <- pure 0 + case x of + 0 -> x0 <- pure (CInt z0) + pure x0 + 1 -> x1 <- pure (CBool z0) + pure x1 |] let expected = ProducerMap $ M.fromList [ ("a0", producerA0) @@ -200,6 +231,9 @@ spec = do , ("x", emptyProducerSet) , ("x0", producerX0) , ("x1", producerX1) + + , ("z0", emptyProducerSet) + , ("z1", emptyProducerSet) ] producerX0 = mkProducerSet [(Tag C "Int", ["x0"])] producerX1 = mkProducerSet [(Tag C "Bool", ["x1"])] @@ -212,22 +246,24 @@ spec = do it "case_restricted_2" $ do let exp = [prog| grinMain = - a0 <- f 0 + z0 <- pure 0 + a0 <- f z0 r0 <- case a0 of - (CInt c0) -> b0 <- f 0 + (CInt c0) -> b0 <- f z0 pure b0 - (CBool c1) -> b1 <- pure (CBool 0) + (CBool c1) -> b1 <- pure (CBool z0) pure b1 - (CNope c2) -> b2 <- pure (CNope 1) + (CNope c2) -> b2 <- pure (CNope z0) pure b2 pure r0 f x = - case x of - 0 -> x0 <- pure (CInt 5) - pure x0 - 1 -> x1 <- pure (CBool 0) - pure x1 + z1 <- pure 0 + case x of + 0 -> x0 <- pure (CInt z1) + pure x0 + 1 -> x1 <- pure (CBool z1) + pure x1 |] let expected = ProducerMap $ M.fromList [ ("a0", producerA0) @@ -241,6 +277,9 @@ spec = do , ("x", emptyProducerSet) , ("x0", producerX0) , ("x1", producerX1) + + , ("z0", emptyProducerSet) + , ("z1", emptyProducerSet) ] producerX0 = mkProducerSet [(Tag C "Int", ["x0"])] producerX1 = mkProducerSet [(Tag C "Bool", ["x1"])] @@ -253,32 +292,35 @@ spec = do it "case_restricted_3" $ do let exp = [prog| grinMain = - a0 <- f 1 - a1 <- pure (CWord 3) + z0 <- pure 1 + a0 <- f z0 + a1 <- pure (CWord z0) r0 <- case a0 of (CInt c0) -> b0 <- g a0 pure b0 (CBool c1) -> b1 <- g a1 pure b1 - (CNope c2) -> b2 <- pure (CNope 1) + (CNope c2) -> b2 <- pure (CNope z0) pure b2 pure r0 f x = - case x of - 0 -> x0 <- pure (CInt 5) - pure x0 - 1 -> x1 <- pure (CBool 0) - pure x1 + z1 <- pure 1 + case x of + 0 -> x0 <- pure (CInt z1) + pure x0 + 1 -> x1 <- pure (CBool z1) + pure x1 g y = - case y of - (CInt n) -> y0 <- pure (CInt 5) - pure y0 - (CBool b) -> y1 <- pure (CBool 0) - pure y1 - (CWord w) -> y2 <- pure (CWord 3) - pure y2 + z2 <- pure 1 + case y of + (CInt n) -> y0 <- pure (CInt z2) + pure y0 + (CBool b) -> y1 <- pure (CBool z2) + pure y1 + (CWord w) -> y2 <- pure (CWord z2) + pure y2 |] let restrictedBy (ProducerSet ps) tag = ProducerSet $ M.filterWithKey (\k _ -> k == tag) ps let expected = ProducerMap $ @@ -301,6 +343,10 @@ spec = do , ("n", emptyProducerSet) , ("b", emptyProducerSet) , ("w", emptyProducerSet) + + , ("z0", emptyProducerSet) + , ("z1", emptyProducerSet) + , ("z2", emptyProducerSet) ] producerX0 = mkProducerSet [(Tag C "Int", ["x0"])] producerX1 = mkProducerSet [(Tag C "Bool", ["x1"])] @@ -318,13 +364,19 @@ spec = do it "undefined" $ do let exp = [prog| grinMain = - p0 <- store (CNil) - p1 <- store (CCons 0 p0) + z0 <- pure 0 + z1 <- pure (CNil) + z3 <- pure (#undefined :: T_Int64) + + p0 <- store z1 + z2 <- pure (CCons z0 p0) + + p1 <- store z2 x0 <- pure (#undefined :: T_Int64) n0 <- pure (#undefined :: {CCons[T_Int64,{0,1}]}) p2 <- store n0 n1 <- pure (#undefined :: {CNil[],CCons[T_Int64,{2}]}) - n2 <- pure (CCons (#undefined :: T_Int64) p0) + n2 <- pure (CCons z3 p0) pure 5 |] let expected =ProducerMap $ @@ -335,17 +387,26 @@ spec = do , ("p1", emptyProducerSet) , ("p2", emptyProducerSet) , ("x0", emptyProducerSet) + + , ("z0", emptyProducerSet) + , ("z1", producerZ1) + , ("z2", producerZ2) + , ("z3", emptyProducerSet) ] producerN0 = mkProducerSet [(Tag C "Cons", [undefinedProducerName])] producerN1 = mkProducerSet [(Tag C "Cons", [undefinedProducerName]), (Tag C "Nil", [undefinedProducerName])] producerN2 = mkProducerSet [(Tag C "Cons", ["n2"])] + + producerZ1 = mkProducerSet [(Tag C "Nil", ["z1"])] + producerZ2 = mkProducerSet [(Tag C "Cons", ["z2"])] (calcProducers exp) `shouldBe` expected it "unspec_loc" $ do let exp = [prog| grinMain = + z0 <- pure 0 n0 <- pure (CNil) - p0 <- case 0 of + p0 <- case z0 of 0 -> store n0 1 -> pure (#undefined :: #ptr) n1 <- fetch p0 @@ -355,6 +416,8 @@ spec = do M.fromList [ ("n0", producerN0) , ("n1", producerN0) , ("p0", emptyProducerSet) + + , ("z0", emptyProducerSet) ] producerN0 = mkProducerSet [(cNil, ["n0"])] (calcProducers exp) `shouldBe` expected @@ -364,13 +427,19 @@ spec = do it "undefined" $ do let exp = [prog| grinMain = - p0 <- store (CNil) - p1 <- store (CCons 0 p0) + z0 <- pure 0 + z1 <- pure (CNil) + z3 <- pure (#undefined :: T_Int64) + + p0 <- store z1 + z2 <- pure (CCons z0 p0) + + p1 <- store z2 x0 <- pure (#undefined :: T_Int64) n0 <- pure (#undefined :: {CCons[T_Int64,{0,1}]}) p2 <- store n0 n1 <- pure (#undefined :: {CNil[],CCons[T_Int64,{2}]}) - n2 <- pure (CCons (#undefined :: T_Int64) p0) + n2 <- pure (CCons z3 p0) pure 5 |] let expected = HPTResult @@ -386,6 +455,11 @@ spec = do , ("n0", tySetFromNodeSet nodeSetN0) , ("n1", typeN1) , ("n2", typeN2) + + , ("z0", tySetFromTypes [T_Int64]) + , ("z1", tySetFromNodeSet $ mkNodeSet [ (cNil, []) ]) + , ("z2", tySetFromNodeSet $ mkNodeSet [ (cCons, [[T_Int64], [T_Location 0]]) ]) + , ("z3", tySetFromTypes [T_Int64]) ] where typeN1 = mkTySet [ (cCons, [[T_Int64], [T_Location 2]]) , (cNil, []) @@ -406,12 +480,15 @@ spec = do it "unspec_loc" $ do let exp = [prog| grinMain = - p0 <- case 0 of - 0 -> store (CInt 5) + z0 <- pure 0 + z1 <- pure (CInt z0) + + p0 <- case z0 of + 0 -> store z1 1 -> pure (#undefined :: #ptr) n0 <- fetch p0 n1 <- pure (#undefined :: {CNode[#ptr]}) - (CNode p1) <- pure n1 + _1@(CNode p1) <- pure n1 x0 <- fetch p1 update p0 x0 |] @@ -431,6 +508,10 @@ spec = do , ("n0", tySetFromNodeSet nodeSetN0) , ("n1", tySetFromNodeSet nodeSetN1) , ("x0", tySetFromTypes []) + + , ("z0", tySetFromTypes [T_Int64]) + , ("z1", tySetFromNodeSet $ mkNodeSet [ (cInt, [ [T_Int64] ]) ]) + , ("_1", tySetFromNodeSet $ mkNodeSet [ (cNode, [ [T_UnspecifiedLocation] ]) ]) ] unspecLocExpectedFunctions = M.singleton "grinMain" (mkSimpleMain T_Unit) (calcHPTResultWithCBy exp) `shouldBe` expected From 845c5355679bb7be64f79597b882f7a9654d1c86 Mon Sep 17 00:00:00 2001 From: anabra Date: Mon, 14 Oct 2019 19:51:28 +0200 Subject: [PATCH 8/8] ES CBy: added @pattern tests --- .../ExtendedSyntax/CreatedBySpec.hs | 48 +++++++++++++++++-- 1 file changed, 45 insertions(+), 3 deletions(-) diff --git a/grin/test/AbstractInterpretation/ExtendedSyntax/CreatedBySpec.hs b/grin/test/AbstractInterpretation/ExtendedSyntax/CreatedBySpec.hs index 4a33de63..fb3a9889 100644 --- a/grin/test/AbstractInterpretation/ExtendedSyntax/CreatedBySpec.hs +++ b/grin/test/AbstractInterpretation/ExtendedSyntax/CreatedBySpec.hs @@ -20,8 +20,6 @@ import AbstractInterpretation.ExtendedSyntax.CreatedBy.Readback import AbstractInterpretation.ExtendedSyntax.HeapPointsTo.Result as HPT --- TODO: @patern tests - {- NOTE: Variables with names like "z" are introduced just for naming. They are not relevant to the result of the analysis. @@ -68,7 +66,7 @@ spec = do ] (calcProducers exp) `shouldBe` puresExpected - it "function_call" $ do + it "function_calls" $ do let exp = [prog| grinMain = z0 <- pure 0 @@ -422,6 +420,50 @@ spec = do producerN0 = mkProducerSet [(cNil, ["n0"])] (calcProducers exp) `shouldBe` expected + it "variable as-patterns" $ do + let exp = [prog| + grinMain = + z0 <- pure 0 + a1@a2 <- pure (CInt z0) + b1 <- pure a1 + b2 <- pure a2 + c1 <- pure b1 + c2 <- pure b2 + pure a1 + |] + let producerA1 = mkProducerSet [(Tag C "Int", ["a1"])] + let puresExpected = ProducerMap $ + M.fromList + [ ("a1", producerA1) + , ("a2", producerA1) + , ("b1", producerA1) + , ("b2", producerA1) + , ("c1", producerA1) + , ("c2", producerA1) + + , ("z0", emptyProducerSet) + ] + (calcProducers exp) `shouldBe` puresExpected + + it "node as-patterns" $ do + let exp = [prog| + grinMain = + z0 <- pure 0 + a@(CInt _1) <- pure (CInt z0) + b <- pure a + pure a + |] + let producerA = mkProducerSet [(Tag C "Int", ["a"])] + let puresExpected = ProducerMap $ + M.fromList + [ ("a", producerA) + , ("b", producerA) + + , ("_1", emptyProducerSet) + , ("z0", emptyProducerSet) + ] + (calcProducers exp) `shouldBe` puresExpected + describe "Created-By type info" $ do it "undefined" $ do