diff --git a/.devcontainer/Dockerfile b/.devcontainer/Dockerfile index ac420b88c..f6c49bee7 100644 --- a/.devcontainer/Dockerfile +++ b/.devcontainer/Dockerfile @@ -31,8 +31,8 @@ RUN echo "export PATH=${PATH}" >> /home/${USERNAME}/.profile # install ghcup RUN curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh -ARG GHC=9.4.6 -ARG CABAL=3.8.1.0 +ARG GHC=9.10.1 +ARG CABAL=3.12.1.0 ARG STACK=2.9.3 ARG HLS=recommended diff --git a/gibbon-compiler/src/Gibbon/Common.hs b/gibbon-compiler/src/Gibbon/Common.hs index ec4a05204..969a057d8 100644 --- a/gibbon-compiler/src/Gibbon/Common.hs +++ b/gibbon-compiler/src/Gibbon/Common.hs @@ -8,7 +8,7 @@ module Gibbon.Common ( -- * Variables - Var(..), LocVar(..), Location, FieldIndex + Var(..), LocVar(..), Location, FieldIndex, DataCon , RegVar, fromVar, toVar, varAppend, toEndV, toEndVLoc, toSeqV, cleanFunName , TyVar(..), isUserTv , Symbol, intern, unintern @@ -66,7 +66,6 @@ import System.IO.Unsafe ( unsafePerformIO ) import System.Random ( randomIO ) import Debug.Trace import Language.C.Quote.CUDA (ToIdent, toIdent) - import Gibbon.DynFlags -------------------------------------------------------------------------------- @@ -138,12 +137,19 @@ toSeqV v = varAppend v (toVar "_seq") -- | A location variable stores the abstract location. type Location = Var - --- | The position or index of a field in a data constructor value. -type FieldIndex = Int - -data LocVar = Single Location - deriving (Show, Ord, Eq, Read, Generic, NFData, Out) +-- | The position or index of a field in a data constructor value. +type FieldIndex = Int +-- | A data constructor is a String type in the compiler +type DataCon = String + +-- | Single: For storing a single location, useful for adding a cursor in a region. +-- | SoA: A location signature for a structure of arrays representation. +-- The first location points to a location in the data constructor buffer. +-- The list includes locations for each field and a tuple storing +-- information about which data constructor and corresponding index the field +-- comes from. +data LocVar = Single Location | SoA Location [((DataCon, FieldIndex), Location)] + deriving (Show, Ord, Eq, Read, Generic, NFData, Out) -- | Abstract region variables. type RegVar = Var diff --git a/gibbon-compiler/src/Gibbon/L2/Syntax.hs b/gibbon-compiler/src/Gibbon/L2/Syntax.hs index 3e5569e5c..5ae3d2ee5 100644 --- a/gibbon-compiler/src/Gibbon/L2/Syntax.hs +++ b/gibbon-compiler/src/Gibbon/L2/Syntax.hs @@ -185,16 +185,23 @@ data E2Ext loc dec -- | Define a location in terms of a different location. data PreLocExp loc = StartOfRegionLE Region - | AfterConstantLE Int -- Number of bytes after. - loc -- Location which this location is offset from. - | AfterVariableLE Var -- Name of variable v. This loc is size(v) bytes after. - loc -- Location which this location is offset from. - Bool -- Whether it's running in a stolen continuation i.e - -- whether this should return an index in a fresh region or not. - -- It's True by default and flipped by ParAlloc if required. + | AfterConstantLE Int -- Number of bytes after. (In case of an SoA loc, this is the offset into the data constructor buffer) + loc -- Location which this location is offset from. + + | AfterVariableLE Var -- Name of variable v. This loc is size(v) bytes after. + loc -- Location which this location is offset from. + Bool -- Whether it's running in a stolen continuation i.e + -- whether this should return an index in a fresh region or not. + -- It's True by default and flipped by ParAlloc if required. | InRegionLE Region | FreeLE | FromEndLE loc + + | AfterSoALE (PreLocExp loc) [PreLocExp loc] loc -- Compute new SoA location from an old SoA location + -- (PreLocExp loc) -> expression for arithmetic on data constructor buffer + -- [PreLocExp loc] -> expressions for arithmetic on each field location + -- loc, store the old loc, why? -- capture more metadata, also style + deriving (Read, Show, Eq, Ord, Functor, Generic, NFData) type LocExp = PreLocExp LocVar @@ -231,7 +238,7 @@ instance FreeVars LocExp where gFreeVars e = case e of AfterConstantLE _ loc -> S.singleton $ unwrapLocVar loc - AfterVariableLE v loc _ -> S.fromList $ [v, unwrapLocVar loc] + AfterVariableLE v loc _ -> S.fromList [v, unwrapLocVar loc] _ -> S.empty instance (Out l, Out d, Show l, Show d) => Expression (E2Ext l d) where @@ -479,6 +486,17 @@ data Region = GlobR Var Multiplicity -- ^ A global region with lifetime equal to -- are no free locations in the program. deriving (Read,Show,Eq,Ord, Generic) +{- + Why a new datatype? -- Well, For a location, we changed the exisiting datatype, i.e. LocVar. + That's acceptable, because locations are just cursors into regions, they are an indices into + regions which don't necessarily signify an entity/allocated object. + + A region encapsulates an allocated space and i'd like a region to represent a unit of space. + We can create more "complex" regions using that unit, for instance a SoA region. + In additon, it preserves statements like "is region A within region B?" + It would be tough to formalize what is means by saying an SoA region exists within another region + (VarR x). Since an SoA region contains multiple regions. +-} data ExtendedRegion = AoSR Region -- ^ A simple "flat" region where the datatype -- will reside in an array of structure representation. | SoAR Region [((DataCon, FieldIndex), Region)] -- ^ A complex region representation for a datatype diff --git a/gibbon-compiler/src/Gibbon/L2/Typecheck.hs b/gibbon-compiler/src/Gibbon/L2/Typecheck.hs index 6a8a3a480..05c49d4dc 100644 --- a/gibbon-compiler/src/Gibbon/L2/Typecheck.hs +++ b/gibbon-compiler/src/Gibbon/L2/Typecheck.hs @@ -780,6 +780,7 @@ tcExp ddfs env funs constrs regs tstatein exp = (ty,tstate2) <- tcExp ddfs env' funs constrs1 regs tstate1 e tstate3 <- removeLoc exp tstate2 (Single loc) return (ty,tstate3) + {-TODO handle what needs to happen with the wildcard argument, list of offsets in case of soa -} AfterConstantLE i l1 -> do r <- getRegion exp constrs l1 let tstate1 = extendTS (Single loc) (Output,True) $ setAfter l1 tstatein diff --git a/gibbon-compiler/src/Gibbon/L4/Syntax.hs b/gibbon-compiler/src/Gibbon/L4/Syntax.hs index 9ff7cda9e..ec0b4d8ab 100644 --- a/gibbon-compiler/src/Gibbon/L4/Syntax.hs +++ b/gibbon-compiler/src/Gibbon/L4/Syntax.hs @@ -103,7 +103,7 @@ type Label = Var type SymTable = M.Map Word16 String type InfoTable = (M.Map L.TyCon TyConInfo) -type TyConInfo = M.Map L.DataCon DataConInfo +type TyConInfo = M.Map DataCon DataConInfo data DataConInfo = DataConInfo { dcon_tag :: Tag diff --git a/gibbon-compiler/src/Gibbon/Language/Syntax.hs b/gibbon-compiler/src/Gibbon/Language/Syntax.hs index 360ef7c15..4a80b523a 100644 --- a/gibbon-compiler/src/Gibbon/Language/Syntax.hs +++ b/gibbon-compiler/src/Gibbon/Language/Syntax.hs @@ -14,7 +14,7 @@ module Gibbon.Language.Syntax ( -- * Datatype definitions - DDefs, DataCon, TyCon, Tag, IsBoxed, DDef(..) + DDefs, TyCon, Tag, IsBoxed, DDef(..) , lookupDDef, getConOrdering, getTyOfDataCon, lookupDataCon, lkp , lookupDataCon', insertDD, emptyDD, fromListDD, isVoidDDef @@ -78,7 +78,6 @@ import Gibbon.Common type DDefs a = M.Map Var (DDef a) -type DataCon = String type TyCon = String type Tag = Word8 diff --git a/gibbon-compiler/src/Gibbon/NewL2/Syntax.hs b/gibbon-compiler/src/Gibbon/NewL2/Syntax.hs index 48f91e834..5ff7515c3 100644 --- a/gibbon-compiler/src/Gibbon/NewL2/Syntax.hs +++ b/gibbon-compiler/src/Gibbon/NewL2/Syntax.hs @@ -140,7 +140,7 @@ instance FreeVars LocExp where gFreeVars e = case e of Old.AfterConstantLE _ loc -> S.singleton $ unwrapLocVar (toLocVar loc) - Old.AfterVariableLE v loc _ -> S.fromList $ [v, unwrapLocVar (toLocVar loc)] + Old.AfterVariableLE v loc _ -> S.fromList [v, unwrapLocVar (toLocVar loc)] _ -> S.empty diff --git a/gibbon-compiler/src/Gibbon/Passes/CalculateBounds.hs b/gibbon-compiler/src/Gibbon/Passes/CalculateBounds.hs index 58e95cb76..6ee58d3e7 100644 --- a/gibbon-compiler/src/Gibbon/Passes/CalculateBounds.hs +++ b/gibbon-compiler/src/Gibbon/Passes/CalculateBounds.hs @@ -180,9 +180,11 @@ calculateBoundsExp ddefs env2 varSzEnv varLocEnv locRegEnv locOffEnv regSzEnv re else do let (re, off) = case locExp of (StartOfRegionLE r ) -> (regionToVar r, BoundedSize 0) + -- [2024.12.04] VS: currently discarding offsets for SoA representation (AfterConstantLE n l ) -> (locRegEnv # l, locOffEnv # l <> BoundedSize n) -- [2022.12.26] CSK: the lookup in varSzEnv always fails since the -- pass never inserts anything into it. Disabling it for now. + -- [2024.12.04] VS: currently discarding offsets for SoA representation (AfterVariableLE v l _) -> (locRegEnv # l, locOffEnv # (varLocEnv # v)) -- <> varSzEnv # v (InRegionLE r ) -> (regionToVar r, Undefined) (FromEndLE l ) -> (locRegEnv # l, Undefined) diff --git a/gibbon-compiler/src/Gibbon/Passes/Cursorize.hs b/gibbon-compiler/src/Gibbon/Passes/Cursorize.hs index 4ec9e0351..1fed421d8 100644 --- a/gibbon-compiler/src/Gibbon/Passes/Cursorize.hs +++ b/gibbon-compiler/src/Gibbon/Passes/Cursorize.hs @@ -699,6 +699,7 @@ cursorizeLocExp denv tenv senv lvar locExp = in if isBound ((toLocVar) loc) tenv then Right (rhs, [], tenv, senv) else Left$ M.insertWith (++) ((toLocVar) loc) [((unwrapLocVar lvar),[],CursorTy,rhs)] denv + -- TODO: handle product types here {- [2018.03.07]: diff --git a/gibbon-compiler/src/Gibbon/Passes/InferLocations.hs b/gibbon-compiler/src/Gibbon/Passes/InferLocations.hs index c37d16a49..2977c5029 100644 --- a/gibbon-compiler/src/Gibbon/Passes/InferLocations.hs +++ b/gibbon-compiler/src/Gibbon/Passes/InferLocations.hs @@ -103,6 +103,7 @@ import qualified Gibbon.L1.Syntax as L1 import Gibbon.L2.Syntax as L2 hiding (extendVEnv, extendsVEnv, lookupVEnv, lookupFEnv) import Gibbon.Passes.InlineTriv (inlineTriv) import Gibbon.Passes.Flatten (flattenL1) +import Gibbon.DynFlags -------------------------------------------------------------------------------- -- Environments @@ -134,34 +135,113 @@ lookupFEnv v FullEnv{funEnv} = funEnv # v -- If we assume output regions are disjoint from input ones, then we -- can instantiate an L1 function type into a polymorphic L2 one, -- mechanically. -convertFunTy :: ([Ty1],Ty1,Bool) -> PassM (ArrowTy2 Ty2) -convertFunTy (from,to,isPar) = do - from' <- mapM convertTy from - to' <- convertTy to +convertFunTy :: DDefs1 -> ([Ty1],Ty1,Bool) -> PassM (ArrowTy2 Ty2) +convertFunTy ddefs (from,to,isPar) = do + dflags <- getDynFlags + let useSoA = gopt Opt_Packed_SoA dflags + from' <- mapM (convertTy ddefs useSoA) from + to' <- convertTy ddefs useSoA to -- For this simple version, we assume every location is in a separate region: - lrm1 <- concat <$> mapM (toLRM Input) from' - lrm2 <- toLRM Output to' - return $ ArrowTy2 { locVars = lrm1 ++ lrm2 + lrm1 <- concat <$> mapM (toLRM useSoA Input) from' + lrm2 <- toLRM useSoA Output to' + dbgTraceIt "convertFunTy: " dbgTraceIt (sdoc (from', to', lrm1, lrm2, useSoA)) dbgTraceIt "\n" return $ ArrowTy2 { locVars = lrm1 ++ lrm2 , arrIns = from' , arrEffs = S.empty , arrOut = to' , locRets = [] , hasParallelism = isPar } where - toLRM md ls = - mapM (\v -> do r <- freshLocVar "r" - return $ LRM v (AoSR $ VarR (unwrapLocVar r)) md) - (F.toList ls) - -convertTy :: Ty1 -> PassM Ty2 -convertTy ty = traverse (const (freshLocVar "loc")) ty + toLRM soa md ls = do + case soa of + True -> mapM (\v -> do + dataBufRegion <- freshLocVar "r" + case v of + Single _ -> error "InferLocations : toLRM : Expected an SoA location!\n" + SoA _ fieldLocs -> do + fieldRegions <- getSoARegionsFromLocs fieldLocs + let region = SoAR (VarR (unwrapLocVar dataBufRegion)) fieldRegions + return $ LRM v region md + ) (F.toList ls) + False -> mapM (\v -> do r <- freshLocVar "r" + return $ LRM v (AoSR $ VarR (unwrapLocVar r)) md) (F.toList ls) + +getSoARegionsFromLocs :: [((DataCon, Int), Var)] -> PassM [((DataCon, Int), Region)] +getSoARegionsFromLocs locs = case locs of + [] -> return [] + (a, b):rst -> do + regionVariable <- freshLocVar "r" + let region = VarR (unwrapLocVar regionVariable) + rst' <- getSoARegionsFromLocs rst + let elem = (a, region) + return $ [elem] ++ rst' + + + +convertTy :: DDefs1 -> Bool -> Ty1 -> PassM Ty2 +convertTy ddefs useSoA ty = case useSoA of + False -> traverse (const (freshLocVar "loc")) ty + True -> case ty of + PackedTy tycon _ -> do + dconBuff <- freshLocVar "loc" + let dcons = getConOrdering ddefs tycon + locsForFields <- convertTyHelperSoAParent tycon ddefs dcons + let soaLocation = SoA (unwrapLocVar dconBuff) locsForFields + return $ PackedTy tycon soaLocation + _ -> traverse (const (freshLocVar "loc")) ty + +convertTyHelperSoAParent :: TyCon -> DDefs1 -> [DataCon] -> PassM [((DataCon, Int), Var)] +convertTyHelperSoAParent tycon ddefs dcons = do + case dcons of + [] -> return [] + d:rst -> do + out <- convertTyHelperSoAChild tycon ddefs d + outRst <- convertTyHelperSoAParent tycon ddefs rst + return $ out ++ outRst + + + + +convertTyHelperSoAChild :: TyCon -> DDefs1 -> DataCon -> PassM [((DataCon, Int), Var)] +convertTyHelperSoAChild tycon ddefs dcon = do + let fields = lookupDataCon ddefs dcon + let fields' = P.concatMap (\f -> case f of + PackedTy tycon' _ -> if tycon == tycon' + then [] + else [f] + _ -> [f] + + ) fields + let numFields = L.length fields' + let indices = [0 .. numFields] + let namesOfLocs = P.map show fields' + let zipped = zip namesOfLocs indices + out <- convertTyHelperGetLocForField dcon zipped + return out + +convertTyHelperGetLocForField :: DataCon -> [(String, Int)] -> PassM [((DataCon, Int), Var)] +convertTyHelperGetLocForField dcon zipped = do + case zipped of + [] -> return [] + (x, y):xs -> do + elem <- convertTyHelperGetLocForField' dcon y x + rst <- convertTyHelperGetLocForField dcon xs + return $ [elem] ++ rst + +convertTyHelperGetLocForField' :: DataCon -> Int -> String -> PassM ((DataCon, Int), Var) +convertTyHelperGetLocForField' dcon index nameForLoc = do + loc' <- freshLocVar $ "loc_" ++ nameForLoc + return ((dcon, index), (unwrapLocVar loc')) + + convertDDefs :: DDefs Ty1 -> PassM (DDefs Ty2) convertDDefs ddefs = traverse f ddefs where f (DDef tyargs n dcs) = do + dflags <- getDynFlags + let useSoA = gopt Opt_Packed_SoA dflags dcs' <- forM dcs $ \(dc,bnds) -> do bnds' <- forM bnds $ \(isb,ty) -> do - ty' <- convertTy ty + ty' <- convertTy ddefs useSoA ty return (isb, ty') return (dc,bnds') return $ DDef tyargs n dcs' @@ -196,12 +276,16 @@ data Failure = FailUnify Ty2 Ty2 -- | Constraints here mean almost the same thing as they do in the L2 type checker. -- One difference is the presence of an AfterTag constraint, though I'm not opposed to -- adding one to the L2 language for symmetry. +-- [05.12.2024] +-- VS: add AfterSoAL for a new location after an SoA location. +-- first contraint is for a data constructor buffer and list of constraints for the fields. data Constraint = AfterConstantL LocVar Int LocVar | AfterVariableL LocVar Var LocVar | AfterTagL LocVar LocVar | StartRegionL LocVar Region | AfterCopyL LocVar Var Var LocVar Var [LocVar] | FreeL LocVar + | AfterSoAL LocVar Constraint [Constraint] LocVar deriving (Show, Eq, Generic) instance Out Constraint @@ -213,7 +297,9 @@ type Result = (Exp2, Ty2, [Constraint]) data DCArg = ArgFixed Int | ArgVar Var | ArgCopy Var Var Var [LocVar] - deriving Show + deriving (Show, Generic) + +instance Out DCArg inferLocs :: Prog1 -> PassM L2.Prog2 inferLocs initPrg = do @@ -224,13 +310,13 @@ inferLocs initPrg = do dfs' <- lift $ lift $ convertDDefs dfs fenv <- forM fds $ \(FunDef _ _ (intys, outty) bod _meta) -> do let has_par = hasSpawns bod - lift $ lift $ convertFunTy (intys,outty,has_par) + lift $ lift $ convertFunTy dfs (intys,outty,has_par) let fe = FullEnv dfs' M.empty fenv me' <- case me of -- We ignore the type of the main expression inferred in L1.. -- Probably should add a small check here Just (me,_ty) -> do - (me',ty') <- inferExp' fe me [] NoDest + (me',ty') <- inferExp' dfs fe me [] NoDest return $ Just (me',ty') Nothing -> return Nothing fds' <- forM fds $ \(FunDef fn fa (intty,outty) fbod meta) -> do @@ -239,7 +325,7 @@ inferLocs initPrg = do boundLocs = concat $ map locsInTy (arrIns arrty ++ [arrOut arrty]) dest <- destFromType (arrOut arrty) mapM_ fixType_ (arrIns arrty) - (fbod',_) <- inferExp' fe' fbod boundLocs dest + (fbod',_) <- inferExp' dfs fe' fbod boundLocs dest return $ FunDef fn fa arrty fbod' meta return $ Prog dfs' fds' me' prg <- St.runStateT (runExceptT m) M.empty @@ -277,11 +363,30 @@ destFromType' frt = _ -> return NoDest freshTyLocs :: Ty2 -> TiM Ty2 -freshTyLocs ty = +freshTyLocs ty = do + dflags <- getDynFlags + let useSoA = gopt Opt_Packed_SoA dflags case ty of - PackedTy tc lv -> fresh >>= return . PackedTy tc + PackedTy tc lv -> if useSoA + then do + case lv of + SoA dbuf rst -> do + dbuf' <- fresh + rst' <- freshTyLocsSoA rst + let newSoALoc = SoA (unwrapLocVar dbuf') rst' + return $ PackedTy tc newSoALoc + else do fresh >>= return . PackedTy tc ProdTy tys -> mapM freshTyLocs tys >>= return . ProdTy - _ -> return ty + _ -> return ty + +freshTyLocsSoA :: [((DataCon, Int), Var)] -> TiM [((DataCon, Int), Var)] +freshTyLocsSoA lst = do + case lst of + [] -> return [] + (a, b):rst -> do + newLoc <- fresh + rst' <- freshTyLocsSoA rst + return $ [(a, unwrapLocVar newLoc)] ++ rst' fixType_ :: Ty2 -> TiM () fixType_ ty = @@ -291,8 +396,8 @@ fixType_ ty = _ -> return () -- | Wrap the inferExp procedure, and consume all remaining constraints -inferExp' :: FullEnv -> Exp1 -> [LocVar] -> Dest -> TiM (L2.Exp2, L2.Ty2) -inferExp' env exp bound dest= +inferExp' :: DDefs1 -> FullEnv -> Exp1 -> [LocVar] -> Dest -> TiM (L2.Exp2, L2.Ty2) +inferExp' ddefs env exp bound dest= let -- TODO: These should not be necessary, eventually @@ -313,7 +418,7 @@ inferExp' env exp bound dest= AfterConstantL lv1 v lv2 -> Ext (LetLocE lv1 (AfterConstantLE v lv2) a) AfterVariableL lv1 v lv2 -> Ext (LetLocE lv1 (AfterVariableLE v lv2 True) a) StartRegionL lv r -> Ext (LetRegionE r Undefined Nothing (Ext (LetLocE lv (StartOfRegionLE r) a))) - AfterTagL lv1 lv2 -> Ext (LetLocE lv1 (AfterConstantLE 1 lv2) a) + AfterTagL lv1 lv2 -> Ext (LetLocE lv1 (AfterConstantLE 1 lv2) a) {- VS: I think it may be fine to hardcode [] since AfterTagL is reserved for a Tag loc?-} FreeL lv -> Ext (LetLocE lv FreeLE a) AfterCopyL lv1 v1 v' lv2 f lvs -> let arrty = arrOut $ lookupFEnv f env @@ -326,18 +431,18 @@ inferExp' env exp bound dest= in LetE (v',[],copyRetTy, AppE f lvs [VarE v1]) $ Ext (LetLocE lv1 (AfterVariableLE v' lv2 True) a') - in do res <- inferExp env exp dest + in do res <- inferExp ddefs env exp dest (e,ty,cs) <- bindAllLocations res e' <- finishExp e - let (e'',s) = cleanExp e' + let (e'',s) = dbgTraceIt "\n" cleanExp e' unbound = (s S.\\ S.fromList bound) e''' <- bindAllUnbound e'' (S.toList unbound) - return (e''',ty) + dbgTraceIt "Print in inferExp': " dbgTraceIt (sdoc (e, e', e'', e''')) dbgTraceIt "End\n" return (e''',ty) -- | We proceed in a destination-passing style given the target region -- into which we must produce the resulting value. -inferExp :: FullEnv -> Exp1 -> Dest -> TiM Result -inferExp env@FullEnv{dataDefs} ex0 dest = +inferExp :: DDefs1 -> FullEnv -> Exp1 -> Dest -> TiM Result +inferExp ddefs env@FullEnv{dataDefs} ex0 dest = let -- | Check if there are any StartRegion constraints that can be dischaged here. @@ -453,6 +558,7 @@ inferExp env@FullEnv{dataDefs} ex0 dest = -- | Transforms a result by adding a location binding derived from an AfterVariable constraint -- associated with the passed-in variable. + {- TODO: what about the extra list of offset in case of an SoA loc now? -} bindAfterLoc :: Var -> Result -> TiM Result bindAfterLoc v (e,ty,c:cs) = case c of @@ -533,7 +639,7 @@ inferExp env@FullEnv{dataDefs} ex0 dest = let contys = lookupDataCon ddfs con newtys = L.map (\(ty,(_,lv)) -> fmap (const lv) ty) $ zip contys vars' env' = L.foldr (\(v,ty) a -> extendVEnv v ty a) env $ zip (L.map fst vars') newtys - res <- inferExp env' rhs dst + res <- inferExp ddefs env' rhs dst (rhs',ty',cs') <- bindAfterLocs (orderOfVarsOutputDataConE rhs) res -- let cs'' = removeLocs (L.map snd vars') cs' -- TODO: check constraints are correct and fail/repair if they're not!!! @@ -568,7 +674,7 @@ inferExp env@FullEnv{dataDefs} ex0 dest = ProjE i w -> do (e', ty) <- case w of VarE v -> pure (ProjE i (VarE v), let ProdTy tys = lookupVEnv v env in tys !! i) - w' -> (\(e, ProdTy bs, _) -> (ProjE i e, bs !! i)) <$> inferExp env w dest + w' -> (\(e, ProdTy bs, _) -> (ProjE i e, bs !! i)) <$> inferExp ddefs env w dest case dest of NoDest -> return (e', ty, []) TupleDest ds -> err "TODO: handle tuple of destinations for ProjE" @@ -585,24 +691,24 @@ inferExp env@FullEnv{dataDefs} ex0 dest = MkProdE ls -> case dest of - NoDest -> do results <- mapM (\e -> inferExp env e NoDest) ls + NoDest -> do results <- mapM (\e -> inferExp ddefs env e NoDest) ls let pty = case results of [(_,ty,_)] -> ty _ -> ProdTy ([b | (_,b,_) <- results]) return (MkProdE ([a | (a,_,_) <- results]), pty, concat $ [c | (_,_,c) <- results]) SingleDest d -> case ls of - [e] -> do (e',ty,les) <- inferExp env e dest + [e] -> do (e',ty,les) <- inferExp ddefs env e dest return (MkProdE [e'], ty, les) _ -> err $ "Cannot match single destination to tuple: " ++ show ex0 - TupleDest ds -> do results <- mapM (\(e,d) -> inferExp env e d) $ zip ls ds + TupleDest ds -> do results <- mapM (\(e,d) -> inferExp ddefs env e d) $ zip ls ds return (MkProdE ([a | (a,_,_) <- results]), ProdTy ([b | (_,b,_) <- results]), concat $ [c | (_,_,c) <- results]) SpawnE f _ args -> do - (ex0', ty, acs) <- inferExp env (AppE f [] args) dest + (ex0', ty, acs) <- inferExp ddefs env (AppE f [] args) dest case ex0' of AppE f' locs args' -> pure (SpawnE f' locs args', ty, acs) oth -> err $ "SpawnE: " ++ sdoc oth @@ -621,7 +727,7 @@ inferExp env@FullEnv{dataDefs} ex0 dest = -- /cc @vollmerm argTys <- mapM freshTyLocs $ arrIns arrty argDests <- mapM destFromType' argTys - (args', atys, acss) <- L.unzip3 <$> mapM (uncurry $ inferExp env) (zip args argDests) + (args', atys, acss) <- L.unzip3 <$> mapM (uncurry $ inferExp ddefs env) (zip args argDests) let acs = concat acss case dest of SingleDest d -> do @@ -642,11 +748,11 @@ inferExp env@FullEnv{dataDefs} ex0 dest = _ -> err$ "(AppE) Cannot unify NoDest with " ++ sdoc valTy ++ ". This might be caused by a main expression having a packed type." ++ sdoc ex0 TimeIt e t b -> - do (e',ty',cs') <- inferExp env e dest + do (e',ty',cs') <- inferExp ddefs env e dest return (TimeIt e' ty' b, ty', cs') WithArenaE v e -> - do (e',ty',cs') <- inferExp (extendVEnv v ArenaTy env) e dest + do (e',ty',cs') <- inferExp ddefs (extendVEnv v ArenaTy env) e dest return (WithArenaE v e', ty', cs') DataConE () k [] -> do @@ -663,14 +769,14 @@ inferExp env@FullEnv{dataDefs} ex0 dest = NoDest -> do -- CSK: Should this really be an error ? loc <- lift $ lift $ freshLocVar "datacon" - (e',ty,cs) <- inferExp env (DataConE () k ls) (SingleDest loc) + (e',ty,cs) <- inferExp ddefs env (DataConE () k ls) (SingleDest loc) fcs <- tryInRegion cs tryBindReg (e', ty, fcs) TupleDest _ds -> err $ "Expected single location destination for DataConE" ++ sdoc ex0 SingleDest d -> do locs <- sequence $ replicate (length ls) fresh mapM_ fixLoc locs -- Don't allow argument locations to freely unify - ls' <- mapM (\(e,lv) -> (inferExp env e $ SingleDest lv)) $ zip ls locs + ls' <- mapM (\(e,lv) -> (inferExp ddefs env e $ SingleDest lv)) $ zip ls locs -- let ls'' = L.map unNestLet ls' -- bnds = catMaybes $ L.map pullBnds ls' -- env' = addCopyVarToEnv ls' env @@ -697,6 +803,19 @@ inferExp env@FullEnv{dataDefs} ex0 dest = return $ ArgCopy v (unwrapLocVar v') f lvs _ -> err $ "Expected argument to be trivial, got " ++ (show arg) newLocs <- mapM finalLocVar locs + {-VS: DCArg needs to be extended to include offset in case of an SoA loc, harcoding empty list atm. -} + {- Better yet, maybe instead of changing DCArg it might be more natural to change the structure here. + Case d of + Single loc -> This remains the same as now + SoA dataBufferLoc fieldLocs -> + 1.) unpack the locations + 2.) dataBufferLoc + 3.) fieldLocs + for each argument to the data constructor + check its type + add DCArg constraints but using locs for the + dataBufferLoc and fieldLocs + -} let afterVar :: (DCArg, Maybe LocVar, Maybe LocVar) -> Maybe Constraint afterVar ((ArgVar v), (Just loc1), (Just loc2)) = Just $ AfterVariableL loc1 v loc2 @@ -716,7 +835,7 @@ inferExp env@FullEnv{dataDefs} ex0 dest = ((map Just $ Sf.tailErr locs) ++ [Nothing]) (map Just locs)) -- ((map Just $ L.tail locs) ++ [Nothing])) ++ - in tmpconstrs ++ constrs + in dbgTraceIt "Print in afterVar" dbgTraceIt (sdoc (locs, argLs)) dbgTraceIt "\n" tmpconstrs ++ constrs -- traceShow k $ traceShow locs $ --let newe = buildLets bnds $ DataConE d k [ e' | (e',_,_) <- ls''] ls'' <- forM (zip argLs ls') $ \(arg,(e,ty,cs)) -> do @@ -745,17 +864,17 @@ inferExp env@FullEnv{dataDefs} ex0 dest = IfE a b c@ce -> do -- Here we blithely assume BoolTy because L1 typechecking has already passed: - (a',bty,acs) <- inferExp env a NoDest + (a',bty,acs) <- inferExp ddefs env a NoDest assumeEq bty BoolTy -- Here BOTH branches are unified into the destination, so -- there is no need to unify with eachother. - res <- inferExp env b dest + res <- inferExp ddefs env b dest -- bind variables after if branch -- This ensures that the location bindings are not freely floated up to the upper level expressions (b',tyb,csb) <- bindAfterLocs (removeDuplicates (orderOfVarsOutputDataConE b)) res -- Else branch - res' <- inferExp env c dest + res' <- inferExp ddefs env c dest -- bind variables after else branch -- This ensures that the location bindings are not freely floated up to the upper level expressions (c',tyc,csc) <- bindAfterLocs (removeDuplicates (orderOfVarsOutputDataConE c)) res' @@ -766,22 +885,22 @@ inferExp env@FullEnv{dataDefs} ex0 dest = case dest of SingleDest _ -> err "Cannot unify DictInsert with destination" TupleDest _ -> err "Cannot unify DictInsert with destination" - NoDest -> do (d',SymDictTy ar dty',_dcs) <- inferExp env d NoDest - (k',_,_kcs) <- inferExp env k NoDest - dty'' <- lift $ lift $ convertTy dty + NoDest -> do (d',SymDictTy ar dty',_dcs) <- inferExp ddefs env d NoDest + (k',_,_kcs) <- inferExp ddefs env k NoDest + dty'' <- lift $ lift $ convertTy ddefs False dty r <- lift $ lift $ freshRegVar loc <- lift $ lift $ freshLocVar "ins" -- _ <- fixLoc loc - (v',vty,vcs) <- inferExp env v $ SingleDest loc + (v',vty,vcs) <- inferExp ddefs env v $ SingleDest loc let cs = vcs -- (StartRegionL loc r) : vcs dummyDty <- dummyTyLocs dty' return (PrimAppE (DictInsertP dummyDty) [(VarE var),d',k',v'], SymDictTy (Just var) $ stripTyLocs dty'', cs) PrimAppE (DictLookupP dty) [d,k] -> case dest of - SingleDest loc -> do (d',SymDictTy _ _dty,_dcs) <- inferExp env d NoDest - (k',_,_kcs) <- inferExp env k NoDest - dty' <- lift $ lift $ convertTy dty + SingleDest loc -> do (d',SymDictTy _ _dty,_dcs) <- inferExp ddefs env d NoDest + (k',_,_kcs) <- inferExp ddefs env k NoDest + dty' <- lift $ lift $ convertTy ddefs False dty let loc' = locOfTy dty' _ <- fixLoc loc' let e' = PrimAppE (DictLookupP dty') [d',k'] @@ -796,15 +915,15 @@ inferExp env@FullEnv{dataDefs} ex0 dest = case dest of SingleDest _ -> err "Cannot unify DictEmpty with destination" TupleDest _ -> err "Cannot unify DictEmpty with destination" - NoDest -> do dty' <- lift $ lift $ convertTy dty + NoDest -> do dty' <- lift $ lift $ convertTy ddefs False dty return (PrimAppE (DictEmptyP dty') [(VarE var)], SymDictTy (Just var) $ stripTyLocs dty', []) PrimAppE (DictHasKeyP dty) [d,k] -> case dest of SingleDest _ -> err "Cannot unify DictEmpty with destination" TupleDest _ -> err "Cannot unify DictEmpty with destination" - NoDest -> do (d',SymDictTy _ dty',_dcs) <- inferExp env d NoDest - (k',_,_kcs) <- inferExp env k NoDest + NoDest -> do (d',SymDictTy _ dty',_dcs) <- inferExp ddefs env d NoDest + (k',_,_kcs) <- inferExp ddefs env k NoDest dummyDty <- dummyTyLocs dty' return (PrimAppE (DictHasKeyP dummyDty) [d',k'], BoolTy, []) @@ -814,11 +933,11 @@ inferExp env@FullEnv{dataDefs} ex0 dest = case dest of SingleDest d -> err $ "Cannot unify primop " ++ sdoc pr ++ " with destination " ++ sdoc d TupleDest d -> err $ "Cannot unify primop " ++ sdoc pr ++ " with destination " ++ sdoc d - NoDest -> do results <- mapM (\e -> inferExp env e NoDest) [VarE ls] + NoDest -> do results <- mapM (\e -> inferExp ddefs env e NoDest) [VarE ls] -- Assume arguments to PrimAppE are trivial -- so there's no need to deal with constraints or locations - ty <- lift $ lift $ convertTy $ primRetTy pr - pr' <- lift $ lift $ prim pr + ty <- lift $ lift $ convertTy ddefs False $ primRetTy pr + pr' <- lift $ lift $ prim ddefs pr let args = [a | (a,_,_) <- results] ++ [VarE fp] return (PrimAppE pr' args, ty, []) @@ -827,23 +946,23 @@ inferExp env@FullEnv{dataDefs} ex0 dest = SingleDest d -> err $ "Cannot unify primop " ++ sdoc pr ++ " with destination " ++ sdoc dest ++ "in " ++ sdoc ex0 TupleDest d -> case pr of - PrintInt -> inferExp env ex0 NoDest - PrintFloat -> inferExp env ex0 NoDest - PrintBool -> inferExp env ex0 NoDest - PrintSym -> inferExp env ex0 NoDest - VNthP{} -> inferExp env ex0 NoDest + PrintInt -> inferExp ddefs env ex0 NoDest + PrintFloat -> inferExp ddefs env ex0 NoDest + PrintBool -> inferExp ddefs env ex0 NoDest + PrintSym -> inferExp ddefs env ex0 NoDest + VNthP{} -> inferExp ddefs env ex0 NoDest _ -> err $ "Cannot unify primop " ++ sdoc pr ++ " with destination " ++ sdoc dest ++ "in " ++ sdoc ex0 - NoDest -> do results <- mapM (\e -> inferExp env e NoDest) es + NoDest -> do results <- mapM (\e -> inferExp ddefs env e NoDest) es -- Assume arguments to PrimAppE are trivial -- so there's no need to deal with constraints or locations - ty <- lift $ lift $ convertTy $ primRetTy pr - pr' <- lift $ lift $ prim pr + ty <- lift $ lift $ convertTy ddefs False $ primRetTy pr + pr' <- lift $ lift $ prim ddefs pr return (PrimAppE pr' [a | (a,_,_) <- results], ty, []) CaseE ex ls -> do -- Case expressions introduce fresh destinations for the scrutinee: loc <- lift $ lift $ freshLocVar "scrut" - (ex',ty2,cs) <- inferExp env ex (SingleDest loc) + (ex',ty2,cs) <- inferExp ddefs env ex (SingleDest loc) let src = locOfTy ty2 pairs <- mapM (doCase dataDefs env src dest) ls return (CaseE ex' ([a | (a,_,_) <- pairs]), @@ -861,18 +980,19 @@ inferExp env@FullEnv{dataDefs} ex0 dest = let arrty = lookupFEnv f env valTy <- freshTyLocs $ arrOut arrty -- /cc @vollmerm - argTys <- mapM freshTyLocs $ arrIns arrty + argTys <- dbgTraceIt "Print in inferExp, AppE: " dbgTraceIt (sdoc (valTy, arrOut arrty)) dbgTraceIt "End\n" mapM freshTyLocs $ arrIns arrty argDests <- mapM destFromType' argTys - (args', atys, acss) <- L.unzip3 <$> mapM (uncurry $ inferExp env) (zip args argDests) + (args', atys, acss) <- L.unzip3 <$> mapM (uncurry $ inferExp ddefs env) (zip args argDests) let acs = concat acss tupBod <- projTups valTy (VarE vr) bod - res <- inferExp (extendVEnv vr valTy env) tupBod dest + res <- inferExp ddefs (extendVEnv vr valTy env) tupBod dest (bod'',ty'',cs'') <- handleTrailingBindLoc vr res vcs <- tryNeedRegion (locsInTy valTy) ty'' $ acs ++ cs'' fcs <- tryInRegion vcs -- fcs <- tryInRegion $ acs ++ cs'' res' <- tryBindReg (L2.LetE (vr,[], valTy, L2.AppE f (concatMap locsInTy atys ++ locsInTy valTy) args') bod'', ty'', fcs) - bindImmediateDependentLocs (concatMap locsInTy atys ++ locsInTy valTy) res' + res'' <- bindImmediateDependentLocs (concatMap locsInTy atys ++ locsInTy valTy) res' + dbgTraceIt "inferExp: Let, AppE: " dbgTraceIt (sdoc (res', res'')) dbgTraceIt "\n" return res'' AppE{} -> err$ "Malformed function application: " ++ (show ex0) @@ -880,7 +1000,7 @@ inferExp env@FullEnv{dataDefs} ex0 dest = let _ret_ty = arrOut $ lookupFEnv f env -- if isScalarTy ret_ty || isPackedTy ret_ty -- then do - (ex0', ty, cs) <- inferExp env (LetE (vr,locs,bty,(AppE f [] args)) bod) dest + (ex0', ty, cs) <- inferExp ddefs env (LetE (vr,locs,bty,(AppE f [] args)) bod) dest -- Assume that all args are VarE's let args2 = map (\e -> case e of (VarE v) -> VarE v @@ -894,36 +1014,36 @@ inferExp env@FullEnv{dataDefs} ex0 dest = pure (ex0'', ty, cs) SyncE -> do - (bod',ty,cs) <- inferExp env bod dest + (bod',ty,cs) <- inferExp ddefs env bod dest pure (LetE (vr,[],ProdTy [],SyncE) bod', ty, cs) IfE a b c -> do - (boda,tya,csa) <- inferExp env a NoDest + (boda,tya,csa) <- inferExp ddefs env a NoDest -- just assuming tyb == tyc - res <- inferExp env b NoDest + res <- inferExp ddefs env b NoDest (bodb,tyb,csb) <- bindAfterLocs (removeDuplicates (orderOfVarsOutputDataConE b)) res - res' <- inferExp env c NoDest + res' <- inferExp ddefs env c NoDest (bodc,tyc,csc) <- bindAfterLocs (removeDuplicates (orderOfVarsOutputDataConE c)) res' - (bod',ty',cs') <- inferExp (extendVEnv vr tyc env) bod dest + (bod',ty',cs') <- inferExp ddefs (extendVEnv vr tyc env) bod dest let cs = L.nub $ csa ++ csb ++ csc ++ cs' return (L2.LetE (vr,[],tyc,L2.IfE boda bodb bodc) bod', ty', cs) LetE{} -> err $ "Expected let spine, encountered nested lets: " ++ sdoc ex0 LitE i -> do - (bod',ty',cs') <- inferExp (extendVEnv vr IntTy env) bod dest + (bod',ty',cs') <- inferExp ddefs (extendVEnv vr IntTy env) bod dest (bod'',ty'',cs'') <- handleTrailingBindLoc vr (bod', ty', cs') fcs <- tryInRegion cs'' tryBindReg (L2.LetE (vr,[],IntTy,L2.LitE i) bod'', ty'', fcs) CharE i -> do - (bod',ty',cs') <- inferExp (extendVEnv vr CharTy env) bod dest + (bod',ty',cs') <- inferExp ddefs (extendVEnv vr CharTy env) bod dest (bod'',ty'',cs'') <- handleTrailingBindLoc vr (bod', ty', cs') fcs <- tryInRegion cs'' tryBindReg (L2.LetE (vr,[],CharTy,L2.CharE i) bod'', ty'', fcs) FloatE i -> do - (bod',ty',cs') <- inferExp (extendVEnv vr FloatTy env) bod dest + (bod',ty',cs') <- inferExp ddefs (extendVEnv vr FloatTy env) bod dest (bod'',ty'',cs'') <- handleTrailingBindLoc vr (bod', ty', cs') fcs <- tryInRegion cs'' tryBindReg (L2.LetE (vr,[],FloatTy,L2.FloatE i) bod'', ty'', fcs) @@ -933,7 +1053,7 @@ inferExp env@FullEnv{dataDefs} ex0 dest = r <- lift $ lift $ gensym "r" loc <- lift $ lift $ freshLocVar "mmap_file" let rhs' = PrimAppE (ReadPackedFile fp tycon (Just r) (PackedTy tycon loc)) [] - (bod',ty',cs') <- inferExp (extendVEnv vr (PackedTy tycon loc) env) bod dest + (bod',ty',cs') <- inferExp ddefs (extendVEnv vr (PackedTy tycon loc) env) bod dest (bod'',ty'',cs'') <- handleTrailingBindLoc vr (bod', ty', cs') fcs <- tryInRegion cs' tryBindReg ( Ext$ LetRegionE (MMapR r) Undefined Nothing $ Ext $ LetLocE loc (StartOfRegionLE (MMapR r)) $ @@ -942,8 +1062,8 @@ inferExp env@FullEnv{dataDefs} ex0 dest = PrimAppE (WritePackedFile fp _ty0) [VarE packd] -> do - bty' <- lift $ lift $ convertTy bty - (bod',ty',cs') <- inferExp (extendVEnv vr bty' env) bod dest + bty' <- lift $ lift $ convertTy ddefs False bty + (bod',ty',cs') <- inferExp ddefs (extendVEnv vr bty' env) bod dest (bod'',ty'',cs'') <- handleTrailingBindLoc vr (bod', ty', cs') fcs <- tryInRegion cs'' let (PackedTy tycon loc) = lookupVEnv packd env @@ -956,43 +1076,43 @@ inferExp env@FullEnv{dataDefs} ex0 dest = PrimAppE (ReadArrayFile fp ty0) [] -> do - ty <- lift $ lift $ convertTy bty - ty0' <- lift $ lift $ convertTy ty0 - (bod',ty',cs') <- inferExp (extendVEnv vr ty env) bod dest + ty <- lift $ lift $ convertTy ddefs False bty + ty0' <- lift $ lift $ convertTy ddefs False ty0 + (bod',ty',cs') <- inferExp ddefs (extendVEnv vr ty env) bod dest (bod'',ty'',cs''') <- handleTrailingBindLoc vr (bod', ty', cs') fcs <- tryInRegion cs''' tryBindReg (L2.LetE (vr,[],ty, L2.PrimAppE (ReadArrayFile fp ty0') []) bod'', ty'', fcs) -- Don't process the StartOf or SizeOf operation at all, just recur through it PrimAppE RequestSizeOf [(VarE v)] -> do - (bod',ty',cs') <- inferExp (extendVEnv vr CursorTy env) bod dest + (bod',ty',cs') <- inferExp ddefs (extendVEnv vr CursorTy env) bod dest return (L2.LetE (vr,[],IntTy, L2.PrimAppE RequestSizeOf [(L2.VarE v)]) bod', ty', cs') PrimAppE (DictInsertP dty) ls -> do - (e,ty,cs) <- inferExp env (PrimAppE (DictInsertP dty) ls) NoDest - (bod',ty',cs') <- inferExp (extendVEnv vr ty env) bod dest + (e,ty,cs) <- inferExp ddefs env (PrimAppE (DictInsertP dty) ls) NoDest + (bod',ty',cs') <- inferExp ddefs (extendVEnv vr ty env) bod dest (bod'',ty'',cs''') <- handleTrailingBindLoc vr (bod',ty', L.nub $ cs' ++ cs) fcs <- tryInRegion cs''' tryBindReg (L2.LetE (vr,[],ty,e) bod'', ty'', fcs) PrimAppE (DictLookupP dty) ls -> do loc <- lift $ lift $ freshLocVar "dict" - (e,ty,cs) <- inferExp env (PrimAppE (DictLookupP dty) ls) $ SingleDest loc - (bod',ty',cs') <- inferExp (extendVEnv vr ty env) bod dest + (e,ty,cs) <- inferExp ddefs env (PrimAppE (DictLookupP dty) ls) $ SingleDest loc + (bod',ty',cs') <- inferExp ddefs (extendVEnv vr ty env) bod dest (bod'',ty'',cs''') <- handleTrailingBindLoc vr (bod', ty', L.nub $ cs ++ cs') fcs <- tryInRegion cs''' tryBindReg (L2.LetE (vr,[],ty,e) bod'',ty'', fcs) PrimAppE (DictEmptyP dty) ls -> do - (e,ty,cs) <- inferExp env (PrimAppE (DictEmptyP dty) ls) NoDest - (bod',ty',cs') <- inferExp (extendVEnv vr ty env) bod dest + (e,ty,cs) <- inferExp ddefs env (PrimAppE (DictEmptyP dty) ls) NoDest + (bod',ty',cs') <- inferExp ddefs (extendVEnv vr ty env) bod dest (bod'',ty'',cs''') <- handleTrailingBindLoc vr (bod',ty',L.nub $ cs' ++ cs) fcs <- tryInRegion cs''' tryBindReg (L2.LetE (vr,[],ty,e) bod'', ty'', fcs) PrimAppE (DictHasKeyP dty) ls -> do - (e,ty,cs) <- inferExp env (PrimAppE (DictHasKeyP dty) ls) NoDest - (bod',ty',cs') <- inferExp (extendVEnv vr ty env) bod dest + (e,ty,cs) <- inferExp ddefs env (PrimAppE (DictHasKeyP dty) ls) NoDest + (bod',ty',cs') <- inferExp ddefs (extendVEnv vr ty env) bod dest (bod'',ty'',cs''') <- handleTrailingBindLoc vr (bod',ty',L.nub $ cs' ++ cs) fcs <- tryInRegion cs''' tryBindReg (L2.LetE (vr,[],ty,e) bod'', ty'', fcs) @@ -1000,45 +1120,45 @@ inferExp env@FullEnv{dataDefs} ex0 dest = -- Special case for VSortP because we don't want to lookup fp in -- the type environment. PrimAppE p@(VSortP ty) [VarE ls, VarE fp] -> do - lsrec <- mapM (\e -> inferExp env e NoDest) [VarE ls] - ty <- lift $ lift $ convertTy bty - (bod',ty',cs') <- inferExp (extendVEnv vr ty env) bod dest + lsrec <- mapM (\e -> inferExp ddefs env e NoDest) [VarE ls] + ty <- lift $ lift $ convertTy ddefs False bty + (bod',ty',cs') <- inferExp ddefs (extendVEnv vr ty env) bod dest let ls' = [a | (a,_,_) <- lsrec] ++ [VarE fp] cs'' = concat $ [c | (_,_,c) <- lsrec] (bod'',ty'',cs''') <- handleTrailingBindLoc vr (bod', ty', L.nub $ cs' ++ cs'') fcs <- tryInRegion cs''' - p' <- lift $ lift $ prim p + p' <- lift $ lift $ prim ddefs p tryBindReg (L2.LetE (vr,[],ty, L2.PrimAppE p' ls') bod'', ty'', fcs) PrimAppE p ls -> do - lsrec <- mapM (\e -> inferExp env e NoDest) ls - ty <- lift $ lift $ convertTy bty - (bod',ty',cs') <- inferExp (extendVEnv vr ty env) bod dest + lsrec <- mapM (\e -> inferExp ddefs env e NoDest) ls + ty <- lift $ lift $ convertTy ddefs False bty + (bod',ty',cs') <- inferExp ddefs (extendVEnv vr ty env) bod dest let ls' = [a | (a,_,_) <- lsrec] cs'' = concat $ [c | (_,_,c) <- lsrec] (bod'',ty'',cs''') <- handleTrailingBindLoc vr (bod', ty', L.nub $ cs' ++ cs'') fcs <- tryInRegion cs''' - p' <- lift $ lift $ prim p + p' <- lift $ lift $ prim ddefs p tryBindReg (L2.LetE (vr,[],ty, L2.PrimAppE p' ls') bod'', ty'', fcs) DataConE _loc k ls -> do loc <- lift $ lift $ freshLocVar "datacon" - (rhs',rty,rcs) <- inferExp env (DataConE () k ls) $ SingleDest loc - (bod',ty',cs') <- inferExp (extendVEnv vr (PackedTy (getTyOfDataCon dataDefs k) loc) env) bod dest + (rhs',rty,rcs) <- inferExp ddefs env (DataConE () k ls) $ SingleDest loc + (bod',ty',cs') <- inferExp ddefs (extendVEnv vr (PackedTy (getTyOfDataCon dataDefs k) loc) env) bod dest (bod'',ty'',cs'') <- handleTrailingBindLoc vr (bod', ty', L.nub $ cs' ++ rcs) fcs <- tryInRegion cs'' tryBindReg (L2.LetE (vr,[],PackedTy (getTyOfDataCon dataDefs k) loc,rhs') bod'', ty', fcs) LitSymE x -> do - (bod',ty',cs') <- inferExp (extendVEnv vr IntTy env) bod dest + (bod',ty',cs') <- inferExp ddefs (extendVEnv vr IntTy env) bod dest (bod'',ty'',cs'') <- handleTrailingBindLoc vr (bod', ty', cs') fcs <- tryInRegion cs'' tryBindReg (L2.LetE (vr,[],SymTy,L2.LitSymE x) bod'', ty'', fcs) ProjE i arg -> do - (e,ProdTy tys,cs) <- inferExp env arg NoDest - (bod',ty',cs') <- inferExp (extendVEnv vr (tys !! i) env) bod dest + (e,ProdTy tys,cs) <- inferExp ddefs env arg NoDest + (bod',ty',cs') <- inferExp ddefs (extendVEnv vr (tys !! i) env) bod dest (bod'',ty'',cs'') <- handleTrailingBindLoc vr (bod', ty', L.nub $ cs ++ cs') fcs <- tryInRegion cs'' tryBindReg (L2.LetE (vr,[],tys !! i,L2.ProjE i e) bod'', @@ -1046,12 +1166,12 @@ inferExp env@FullEnv{dataDefs} ex0 dest = CaseE ex ls -> do loc <- lift $ lift $ freshLocVar "scrut" - (ex',ty2,cs) <- inferExp env ex (SingleDest loc) + (ex',ty2,cs) <- inferExp ddefs env ex (SingleDest loc) let src = locOfTy ty2 - rhsTy <- lift $ lift $ convertTy bty + rhsTy <- lift $ lift $ convertTy ddefs False bty caseDest <- destFromType' rhsTy pairs <- mapM (doCase dataDefs env src caseDest) ls - (bod',ty',cs') <- inferExp (extendVEnv vr rhsTy env) bod dest + (bod',ty',cs') <- inferExp ddefs (extendVEnv vr rhsTy env) bod dest (bod'',ty'',cs'') <- handleTrailingBindLoc vr (bod', ty', cs') fcs <- tryInRegion cs'' let ccs = L.nub $ cs ++ fcs ++ (concat $ [c | (_,_,c) <- pairs]) @@ -1066,10 +1186,10 @@ inferExp env@FullEnv{dataDefs} ex0 dest = -- there's an assumption that things in a MkProdE will always be a -- variable reference (because of ANF), and the AppE/DataConE cases -- above will do the right thing. - lsrec <- mapM (\e -> inferExp env e NoDest) ls - ty@(ProdTy tys) <- lift $ lift $ convertTy bty + lsrec <- mapM (\e -> inferExp ddefs env e NoDest) ls + ty@(ProdTy tys) <- lift $ lift $ convertTy ddefs False bty let env' = extendVEnv vr ty env - (bod',ty',cs') <- inferExp env' bod dest + (bod',ty',cs') <- inferExp ddefs env' bod dest let als = [a | (a,_,_) <- lsrec] acs = concat $ [c | (_,_,c) <- lsrec] aty = [b | (_,b,_) <- lsrec] @@ -1093,8 +1213,8 @@ inferExp env@FullEnv{dataDefs} ex0 dest = tryBindReg (L2.LetE bind bod'', ty'', fcs) WithArenaE v e -> do - (e',ty,cs) <- inferExp (extendVEnv v ArenaTy env) e NoDest - (bod',ty',cs') <- inferExp (extendVEnv vr ty env) bod dest + (e',ty,cs) <- inferExp ddefs (extendVEnv v ArenaTy env) e NoDest + (bod',ty',cs') <- inferExp ddefs (extendVEnv vr ty env) bod dest (bod'',ty'',cs'') <- handleTrailingBindLoc vr (bod', ty', L.nub $ cs ++ cs') vcs <- tryNeedRegion (locsInTy ty) ty'' cs'' fcs <- tryInRegion vcs @@ -1106,8 +1226,8 @@ inferExp env@FullEnv{dataDefs} ex0 dest = let subdest = case bty of PackedTy _ _ -> SingleDest lv _ -> NoDest - (e',ty,cs) <- inferExp env e subdest - (bod',ty',cs') <- inferExp (extendVEnv vr ty env) bod dest + (e',ty,cs) <- inferExp ddefs env e subdest + (bod',ty',cs') <- inferExp ddefs (extendVEnv vr ty env) bod dest (bod'',ty'',cs'') <- handleTrailingBindLoc vr (bod', ty', L.nub $ cs ++ cs') vcs <- tryNeedRegion (locsInTy ty) ty'' cs'' fcs <- tryInRegion vcs @@ -1118,11 +1238,11 @@ inferExp env@FullEnv{dataDefs} ex0 dest = FoldE{} -> err$ "FoldE unsupported" Ext (L1.AddFixed cur i) -> do - (bod',ty',cs') <- inferExp (extendVEnv vr CursorTy env) bod dest + (bod',ty',cs') <- inferExp ddefs (extendVEnv vr CursorTy env) bod dest return (L2.LetE (vr,[],L2.CursorTy,L2.Ext (L2.AddFixed cur i)) bod', ty', cs') Ext (L1.StartOfPkdCursor cur) -> do - (bod',ty',cs') <- inferExp (extendVEnv vr CursorTy env) bod dest + (bod',ty',cs') <- inferExp ddefs (extendVEnv vr CursorTy env) bod dest return (L2.LetE (vr,[],L2.CursorTy,L2.Ext (L2.StartOfPkdCursor cur)) bod', ty', cs') Ext(BenchE{}) -> error "inferExp: BenchE not handled." @@ -1136,7 +1256,7 @@ inferExp env@FullEnv{dataDefs} ex0 dest = retty :: Ty2 retty = outTy fn_ty e' = TimeIt (AppE fn locs args) (stripTyLocs retty) b - in inferExp env e' dest + in inferExp ddefs env e' dest -- TODO: Should eventually allow src and dest regions to be the same @@ -1678,8 +1798,8 @@ assumeEq a1 a2 = else err $ "Expected these to be equal: " ++ (show a1) ++ ", " ++ (show a2) -- | Convert a prim from L1 to L2 -prim :: Prim Ty1 -> PassM (Prim Ty2) -prim p = case p of +prim :: DDefs1 -> Prim Ty1 -> PassM (Prim Ty2) +prim ddefs p = case p of AddP -> return AddP SubP -> return SubP MulP -> return MulP @@ -1724,40 +1844,40 @@ prim p = case p of PrintSym -> return PrintSym ReadInt -> return PrintInt RequestSizeOf -> return RequestSizeOf - ErrorP sty ty -> convertTy ty >>= \ty -> return (ErrorP sty ty) - DictEmptyP dty -> convertTy dty >>= return . DictEmptyP - DictInsertP dty -> convertTy dty >>= return . DictInsertP - DictLookupP dty -> convertTy dty >>= return . DictLookupP - DictHasKeyP dty -> convertTy dty >>= return . DictHasKeyP - VAllocP elty -> convertTy elty >>= return . VAllocP - VFreeP elty -> convertTy elty >>= return . VFreeP - VFree2P elty -> convertTy elty >>= return . VFree2P - VLengthP elty -> convertTy elty >>= return . VLengthP - VNthP elty -> convertTy elty >>= return . VNthP - VSliceP elty -> convertTy elty >>= return . VSliceP - InplaceVUpdateP elty -> convertTy elty >>= return . InplaceVUpdateP - VConcatP elty -> convertTy elty >>= return . VConcatP - VSortP elty -> convertTy elty >>= return . VSortP - VMergeP elty -> convertTy elty >>= return . VMergeP - PDictAllocP k v -> convertTy k >>= (\k' -> convertTy v >>= \v' -> return $ PDictAllocP k' v') - PDictInsertP k v -> convertTy k >>= (\k' -> convertTy v >>= \v' -> return $ PDictInsertP k' v') - PDictLookupP k v -> convertTy k >>= (\k' -> convertTy v >>= \v' -> return $ PDictLookupP k' v') - PDictHasKeyP k v -> convertTy k >>= (\k' -> convertTy v >>= \v' -> return $ PDictHasKeyP k' v') - PDictForkP k v -> convertTy k >>= (\k' -> convertTy v >>= \v' -> return $ PDictForkP k' v') - PDictJoinP k v -> convertTy k >>= (\k' -> convertTy v >>= \v' -> return $ PDictJoinP k' v') - LLAllocP elty -> convertTy elty >>= return . LLAllocP - LLIsEmptyP elty -> convertTy elty >>= return . LLIsEmptyP - LLConsP elty -> convertTy elty >>= return . LLConsP - LLHeadP elty -> convertTy elty >>= return . LLHeadP - LLTailP elty -> convertTy elty >>= return . LLTailP - LLFreeP elty -> convertTy elty >>= return . LLFreeP - LLFree2P elty -> convertTy elty >>= return . LLFree2P - LLCopyP elty -> convertTy elty >>= return . LLCopyP - InplaceVSortP elty -> convertTy elty >>= return . InplaceVSortP + ErrorP sty ty -> convertTy ddefs False ty >>= \ty -> return (ErrorP sty ty) + DictEmptyP dty -> convertTy ddefs False dty >>= return . DictEmptyP + DictInsertP dty -> convertTy ddefs False dty >>= return . DictInsertP + DictLookupP dty -> convertTy ddefs False dty >>= return . DictLookupP + DictHasKeyP dty -> convertTy ddefs False dty >>= return . DictHasKeyP + VAllocP elty -> convertTy ddefs False elty >>= return . VAllocP + VFreeP elty -> convertTy ddefs False elty >>= return . VFreeP + VFree2P elty -> convertTy ddefs False elty >>= return . VFree2P + VLengthP elty -> convertTy ddefs False elty >>= return . VLengthP + VNthP elty -> convertTy ddefs False elty >>= return . VNthP + VSliceP elty -> convertTy ddefs False elty >>= return . VSliceP + InplaceVUpdateP elty -> convertTy ddefs False elty >>= return . InplaceVUpdateP + VConcatP elty -> convertTy ddefs False elty >>= return . VConcatP + VSortP elty -> convertTy ddefs False elty >>= return . VSortP + VMergeP elty -> convertTy ddefs False elty >>= return . VMergeP + PDictAllocP k v -> convertTy ddefs False k >>= (\k' -> convertTy ddefs False v >>= \v' -> return $ PDictAllocP k' v') + PDictInsertP k v -> convertTy ddefs False k >>= (\k' -> convertTy ddefs False v >>= \v' -> return $ PDictInsertP k' v') + PDictLookupP k v -> convertTy ddefs False k >>= (\k' -> convertTy ddefs False v >>= \v' -> return $ PDictLookupP k' v') + PDictHasKeyP k v -> convertTy ddefs False k >>= (\k' -> convertTy ddefs False v >>= \v' -> return $ PDictHasKeyP k' v') + PDictForkP k v -> convertTy ddefs False k >>= (\k' -> convertTy ddefs False v >>= \v' -> return $ PDictForkP k' v') + PDictJoinP k v -> convertTy ddefs False k >>= (\k' -> convertTy ddefs False v >>= \v' -> return $ PDictJoinP k' v') + LLAllocP elty -> convertTy ddefs False elty >>= return . LLAllocP + LLIsEmptyP elty -> convertTy ddefs False elty >>= return . LLIsEmptyP + LLConsP elty -> convertTy ddefs False elty >>= return . LLConsP + LLHeadP elty -> convertTy ddefs False elty >>= return . LLHeadP + LLTailP elty -> convertTy ddefs False elty >>= return . LLTailP + LLFreeP elty -> convertTy ddefs False elty >>= return . LLFreeP + LLFree2P elty -> convertTy ddefs False elty >>= return . LLFree2P + LLCopyP elty -> convertTy ddefs False elty >>= return . LLCopyP + InplaceVSortP elty -> convertTy ddefs False elty >>= return . InplaceVSortP GetNumProcessors -> pure GetNumProcessors ReadPackedFile{} -> err $ "Can't handle this primop yet in InferLocations:\n"++show p ReadArrayFile{} -> err $ "Can't handle this primop yet in InferLocations:\n"++show p - WritePackedFile fp ty -> convertTy ty >>= return . (WritePackedFile fp) + WritePackedFile fp ty -> convertTy ddefs False ty >>= return . (WritePackedFile fp) SymSetEmpty{} -> return SymSetEmpty SymSetInsert{} -> return SymSetInsert SymSetContains{} -> return SymSetContains diff --git a/gibbon-compiler/src/Gibbon/Passes/ParAlloc.hs b/gibbon-compiler/src/Gibbon/Passes/ParAlloc.hs index 271f016be..56b21747a 100644 --- a/gibbon-compiler/src/Gibbon/Passes/ParAlloc.hs +++ b/gibbon-compiler/src/Gibbon/Passes/ParAlloc.hs @@ -141,6 +141,7 @@ parAllocExp ddefs fundefs env2 reg_env after_env mb_parent_id pending_binds spaw (\acc b -> case b of PVar vbnd -> mkLets [vbnd] acc + {-[2024.12.04] VS: Harcoding an empty list for now, seems bad. TODO: fix-} PAfter (loc1, (w, loc2)) -> Ext $ LetLocE loc1 (AfterVariableLE w loc2 False) $ acc) bod2 pending_binds pure $ LetE (v, endlocs, ty, SyncE) bod3 diff --git a/gibbon-compiler/src/Gibbon/Passes/Simplifier.hs b/gibbon-compiler/src/Gibbon/Passes/Simplifier.hs index e32cef7b4..2f9c77a30 100644 --- a/gibbon-compiler/src/Gibbon/Passes/Simplifier.hs +++ b/gibbon-compiler/src/Gibbon/Passes/Simplifier.hs @@ -134,6 +134,7 @@ simplifyLocBinds only_cse (Prog ddefs fundefs mainExp) = do case ext of LetRegionE reg sz ty bod -> Ext (LetRegionE reg sz ty (go env bod)) LetParRegionE reg sz ty bod -> Ext (LetParRegionE reg sz ty (go env bod)) + {- TODO VS: fix for SOA case -} LetLocE loc (AfterConstantLE i loc2) bod -> case (M.lookup loc2 env) of Nothing -> diff --git a/gibbon-compiler/src/Gibbon/Pretty.hs b/gibbon-compiler/src/Gibbon/Pretty.hs index dd742fb21..0a9ac42ae 100644 --- a/gibbon-compiler/src/Gibbon/Pretty.hs +++ b/gibbon-compiler/src/Gibbon/Pretty.hs @@ -435,10 +435,10 @@ instance Pretty l => Pretty (L2.PreLocExp l) where pprintWithStyle _ le = case le of StartOfRegionLE r -> lparen <> text "startOfRegion" <+> text (sdoc r) <> rparen - AfterConstantLE i loc -> lparen <> pprint loc <+> text "+" <+> int i <> rparen - AfterVariableLE v loc b -> if b - then text "fresh" <> (parens $ pprint loc <+> text "+" <+> doc v) - else parens $ pprint loc <+> text "+" <+> doc v + AfterConstantLE i loc -> lparen <> pprint loc <+> text "+" <+> int i <> rparen + AfterVariableLE v loc b -> if b + then text "fresh" <> (parens $ pprint loc <+> text "+" <+> doc v) + else parens $ pprint loc <+> text "+" <+> doc v InRegionLE r -> lparen <> text "inRegion" <+> text (sdoc r) <> rparen FromEndLE loc -> lparen <> text "fromEnd" <+> pprint loc <> rparen FreeLE -> lparen <> text "free" <> rparen