From 7a8043561844e835bb2f208bca525d8eb7fc631a Mon Sep 17 00:00:00 2001 From: Vidush Singhal Date: Tue, 26 Nov 2024 14:33:15 -0500 Subject: [PATCH 01/11] edit --- .devcontainer/Dockerfile | 4 ++-- gibbon-compiler/src/Gibbon/Common.hs | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) 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..2ba08741f 100644 --- a/gibbon-compiler/src/Gibbon/Common.hs +++ b/gibbon-compiler/src/Gibbon/Common.hs @@ -142,7 +142,7 @@ type Location = Var -- | The position or index of a field in a data constructor value. type FieldIndex = Int -data LocVar = Single Location +data LocVar = Single Location | SoA Location deriving (Show, Ord, Eq, Read, Generic, NFData, Out) -- | Abstract region variables. From 36a951a7377119b626170747e954eec8da30d998 Mon Sep 17 00:00:00 2001 From: Vidush Singhal Date: Wed, 27 Nov 2024 17:03:14 -0500 Subject: [PATCH 02/11] add new ir with soa loc --- .../structurre_of_arrays/new_soa_ir.txt | 39 +++++++++++++++++++ gibbon-compiler/src/Gibbon/Common.hs | 22 ++++++++--- 2 files changed, 55 insertions(+), 6 deletions(-) create mode 100644 gibbon-compiler/examples/structurre_of_arrays/new_soa_ir.txt diff --git a/gibbon-compiler/examples/structurre_of_arrays/new_soa_ir.txt b/gibbon-compiler/examples/structurre_of_arrays/new_soa_ir.txt new file mode 100644 index 000000000..f5c1a3a85 --- /dev/null +++ b/gibbon-compiler/examples/structurre_of_arrays/new_soa_ir.txt @@ -0,0 +1,39 @@ +{meta: FunMeta {funRec = Rec, funInline = NoInline, funCanTriggerGC = False}} +mkList :: Int -> List + {locvars [LRM {lrmLoc = SoA "loc_140" [((Cons, 0), "loc_141")] , + lrmReg = SoAR "r_141" [((Cons, 0), "r_142")] , + lrmMode = Output}], + effs: [], + locrets: [], + parallel: False} +mkList length_14_82_117 = + letloc (Single "loc_175") = ((Single "loc_140") + 1) in + letloc (Single "loc_176") = ((Single "loc_141") + 8) in + let fltIf_97_118 :: Bool = <=(length_14_82_117, 0) in + if fltIf_97_118 + then (Nil (SoA "loc_140" [((Cons, 0), "loc_141")])) + else let fltAppE_98_119 :: Int = length_14_82_117 - 1 in + let rst_15_83_120 :: (Packed List (SoA "loc_175" [((Cons, 0), "loc_176")])) = (mkList [(SoA "loc_175" [((Cons, 0), "loc_176")])] fltAppE_98_119) in + (Cons (SoA "loc_140" [((Cons, 0), "loc_141")]) length_14_82_117 rst_15_83_120) + + + +add1 :: List -> List + {locvars [LRM {lrmLoc = SoA "loc_150" [((Cons, 0), "loc_152")] , + lrmReg = SoAR "r_152" [((Cons, 0), "r_154")] , + lrmMode = Input}, + LRM {lrmLoc = SoA "loc_151" [((Cons, 0), "loc_153")] , + lrmReg = SoAR "r_153" [((Cons, 0), "r_155")] , + lrmMode = Output}], + effs: [], + locrets: [], + parallel: False} +add1 lst_16_94_131 = + letloc (Single "loc_214") = ((Single "loc_151") + 1) in + letloc (Single "loc_215") = ((Single "loc_214") + 8) in + case lst_16_94_131 of + Nil -> + (Nil (Single "loc_151")) + Cons i_17_95_132::(Single "case_209") rst_18_96_133::(Single "case_210") -> + let fltPkd_99_134 :: (Packed List (Single "loc_215")) = (add1 [(Single "case_210"),(Single "loc_215")] rst_18_96_133) in + (Cons (Single "loc_151") i_17_95_132 fltPkd_99_134) diff --git a/gibbon-compiler/src/Gibbon/Common.hs b/gibbon-compiler/src/Gibbon/Common.hs index 2ba08741f..ee5d72979 100644 --- a/gibbon-compiler/src/Gibbon/Common.hs +++ b/gibbon-compiler/src/Gibbon/Common.hs @@ -138,12 +138,22 @@ 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 | SoA Location - deriving (Show, Ord, Eq, Read, Generic, NFData, Out) +-- | Index position of the filed in the data constructor. +type FieldIndex = Int +-- | Location of the buffer where all the data constructor tags are stored. +type DataConBuf = Location +-- | Store the name of the data constructor as a String. +type DataConName = String +-- | Store the location of the buffer with the factored out fields. +-- | Stores extra meta data like data constructor to which it comes from and the index position. +type FieldBuf = ((DataConName, FieldIndex), Location) +-- | List of field locations for a datatype +type FieldLocs = [FieldBuf] +-- | A data type that stores either a single location, AoS +-- | or a SoA representation: A data constructor buffer in addition to location for fields. +-- | LocVar can also be a pointer. +data LocVar = Single Location | SoA DataConBuf FieldLocs + deriving (Show, Ord, Eq, Read, Generic, NFData, Out) -- | Abstract region variables. type RegVar = Var From 376c54e752e3ddf0eb645c259d5ccd5fd5af868f Mon Sep 17 00:00:00 2001 From: Vidush Singhal Date: Mon, 2 Dec 2024 15:01:58 -0500 Subject: [PATCH 03/11] remove duplicate folder --- .../structurre_of_arrays/new_soa_ir.txt | 39 ------------------- 1 file changed, 39 deletions(-) delete mode 100644 gibbon-compiler/examples/structurre_of_arrays/new_soa_ir.txt diff --git a/gibbon-compiler/examples/structurre_of_arrays/new_soa_ir.txt b/gibbon-compiler/examples/structurre_of_arrays/new_soa_ir.txt deleted file mode 100644 index f5c1a3a85..000000000 --- a/gibbon-compiler/examples/structurre_of_arrays/new_soa_ir.txt +++ /dev/null @@ -1,39 +0,0 @@ -{meta: FunMeta {funRec = Rec, funInline = NoInline, funCanTriggerGC = False}} -mkList :: Int -> List - {locvars [LRM {lrmLoc = SoA "loc_140" [((Cons, 0), "loc_141")] , - lrmReg = SoAR "r_141" [((Cons, 0), "r_142")] , - lrmMode = Output}], - effs: [], - locrets: [], - parallel: False} -mkList length_14_82_117 = - letloc (Single "loc_175") = ((Single "loc_140") + 1) in - letloc (Single "loc_176") = ((Single "loc_141") + 8) in - let fltIf_97_118 :: Bool = <=(length_14_82_117, 0) in - if fltIf_97_118 - then (Nil (SoA "loc_140" [((Cons, 0), "loc_141")])) - else let fltAppE_98_119 :: Int = length_14_82_117 - 1 in - let rst_15_83_120 :: (Packed List (SoA "loc_175" [((Cons, 0), "loc_176")])) = (mkList [(SoA "loc_175" [((Cons, 0), "loc_176")])] fltAppE_98_119) in - (Cons (SoA "loc_140" [((Cons, 0), "loc_141")]) length_14_82_117 rst_15_83_120) - - - -add1 :: List -> List - {locvars [LRM {lrmLoc = SoA "loc_150" [((Cons, 0), "loc_152")] , - lrmReg = SoAR "r_152" [((Cons, 0), "r_154")] , - lrmMode = Input}, - LRM {lrmLoc = SoA "loc_151" [((Cons, 0), "loc_153")] , - lrmReg = SoAR "r_153" [((Cons, 0), "r_155")] , - lrmMode = Output}], - effs: [], - locrets: [], - parallel: False} -add1 lst_16_94_131 = - letloc (Single "loc_214") = ((Single "loc_151") + 1) in - letloc (Single "loc_215") = ((Single "loc_214") + 8) in - case lst_16_94_131 of - Nil -> - (Nil (Single "loc_151")) - Cons i_17_95_132::(Single "case_209") rst_18_96_133::(Single "case_210") -> - let fltPkd_99_134 :: (Packed List (Single "loc_215")) = (add1 [(Single "case_210"),(Single "loc_215")] rst_18_96_133) in - (Cons (Single "loc_151") i_17_95_132 fltPkd_99_134) From 43f07a97facb044ca67c96cb0aad14d26857ebb7 Mon Sep 17 00:00:00 2001 From: Vidush Singhal Date: Mon, 2 Dec 2024 15:21:37 -0500 Subject: [PATCH 04/11] move things around, SoA value for locvar --- gibbon-compiler/src/Gibbon/Common.hs | 28 ++++++++----------- gibbon-compiler/src/Gibbon/L4/Syntax.hs | 2 +- gibbon-compiler/src/Gibbon/Language/Syntax.hs | 3 +- 3 files changed, 14 insertions(+), 19 deletions(-) diff --git a/gibbon-compiler/src/Gibbon/Common.hs b/gibbon-compiler/src/Gibbon/Common.hs index ee5d72979..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,21 +137,18 @@ toSeqV v = varAppend v (toVar "_seq") -- | A location variable stores the abstract location. type Location = Var --- | Index position of the filed in the data constructor. +-- | The position or index of a field in a data constructor value. type FieldIndex = Int --- | Location of the buffer where all the data constructor tags are stored. -type DataConBuf = Location --- | Store the name of the data constructor as a String. -type DataConName = String --- | Store the location of the buffer with the factored out fields. --- | Stores extra meta data like data constructor to which it comes from and the index position. -type FieldBuf = ((DataConName, FieldIndex), Location) --- | List of field locations for a datatype -type FieldLocs = [FieldBuf] --- | A data type that stores either a single location, AoS --- | or a SoA representation: A data constructor buffer in addition to location for fields. --- | LocVar can also be a pointer. -data LocVar = Single Location | SoA DataConBuf FieldLocs +-- | 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. 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 From a8ec38633fbf1c4c631ebf9498ad397f64364c9e Mon Sep 17 00:00:00 2001 From: Vidush Singhal Date: Mon, 2 Dec 2024 18:05:24 -0500 Subject: [PATCH 05/11] extended convertTy to handle SoA case --- .../src/Gibbon/Passes/InferLocations.hs | 332 ++++++++++-------- 1 file changed, 195 insertions(+), 137 deletions(-) diff --git a/gibbon-compiler/src/Gibbon/Passes/InferLocations.hs b/gibbon-compiler/src/Gibbon/Passes/InferLocations.hs index c37d16a49..ee4fc4c41 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,14 +135,16 @@ 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 + dbgTraceIt "convertFunTy: " dbgTraceIt (sdoc (from', to', lrm1, lrm2, useSoA)) dbgTraceIt "\n" return $ ArrowTy2 { locVars = lrm1 ++ lrm2 , arrIns = from' , arrEffs = S.empty , arrOut = to' @@ -153,15 +156,70 @@ convertFunTy (from,to,isPar) = do return $ LRM v (AoSR $ VarR (unwrapLocVar r)) md) (F.toList ls) -convertTy :: Ty1 -> PassM Ty2 -convertTy ty = traverse (const (freshLocVar "loc")) ty +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 ddef = lookupDDef ddefs tycon + 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 dcs' <- forM dcs $ \(dc,bnds) -> do bnds' <- forM bnds $ \(isb,ty) -> do - ty' <- convertTy ty + ty' <- convertTy ddefs False ty return (isb, ty') return (dc,bnds') return $ DDef tyargs n dcs' @@ -224,13 +282,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 +297,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 @@ -291,8 +349,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 @@ -326,7 +384,7 @@ 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' @@ -336,8 +394,8 @@ inferExp' env exp bound dest= -- | 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. @@ -533,7 +591,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 +626,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 +643,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 +679,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 +700,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 +721,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 @@ -745,17 +803,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 +824,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 +854,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 +872,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 +885,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]), @@ -863,10 +921,10 @@ 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 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 @@ -880,7 +938,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 +952,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 +991,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 +1000,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 +1014,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 +1058,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 +1104,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 +1124,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 +1151,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 +1164,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 +1176,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 +1194,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 +1736,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 +1782,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 From f370f05e63a29c2c0c65efe90ba948714a0d6cdd Mon Sep 17 00:00:00 2001 From: Vidush Singhal Date: Tue, 3 Dec 2024 13:28:01 -0500 Subject: [PATCH 06/11] generate soa regions in inferlocations --- .../src/Gibbon/Passes/InferLocations.hs | 34 +++++++++++++++---- 1 file changed, 27 insertions(+), 7 deletions(-) diff --git a/gibbon-compiler/src/Gibbon/Passes/InferLocations.hs b/gibbon-compiler/src/Gibbon/Passes/InferLocations.hs index ee4fc4c41..306b2684c 100644 --- a/gibbon-compiler/src/Gibbon/Passes/InferLocations.hs +++ b/gibbon-compiler/src/Gibbon/Passes/InferLocations.hs @@ -142,8 +142,8 @@ convertFunTy ddefs (from,to,isPar) = do 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' + 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 @@ -151,10 +151,31 @@ convertFunTy ddefs (from,to,isPar) = do , locRets = [] , hasParallelism = isPar } where - toLRM md ls = - mapM (\v -> do r <- freshLocVar "r" - return $ LRM v (AoSR $ VarR (unwrapLocVar r)) md) - (F.toList ls) + 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 @@ -162,7 +183,6 @@ convertTy ddefs useSoA ty = case useSoA of True -> case ty of PackedTy tycon _ -> do dconBuff <- freshLocVar "loc" - let ddef = lookupDDef ddefs tycon let dcons = getConOrdering ddefs tycon locsForFields <- convertTyHelperSoAParent tycon ddefs dcons let soaLocation = SoA (unwrapLocVar dconBuff) locsForFields From c38e6c17d7a20e98f8fe85b07b1a5514f6630273 Mon Sep 17 00:00:00 2001 From: Vidush Singhal Date: Tue, 3 Dec 2024 18:41:49 -0500 Subject: [PATCH 07/11] change L2 IR for computation on LocVar --- gibbon-compiler/src/Gibbon/L2/Syntax.hs | 44 +++++++++++++------ .../src/Gibbon/Passes/InferLocations.hs | 4 +- 2 files changed, 34 insertions(+), 14 deletions(-) diff --git a/gibbon-compiler/src/Gibbon/L2/Syntax.hs b/gibbon-compiler/src/Gibbon/L2/Syntax.hs index 3e5569e5c..95d65f0c6 100644 --- a/gibbon-compiler/src/Gibbon/L2/Syntax.hs +++ b/gibbon-compiler/src/Gibbon/L2/Syntax.hs @@ -185,13 +185,15 @@ 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) + [Int] -- Optional list with offset bytes, these offsets can be used for bumping field locations for an SoA location. + loc -- Location which this location is offset from. + | AfterVariableLE Var -- Name of variable v. This loc is size(v) bytes after. + [Var] -- Optional list with offset bytes, each size(v) bytes, these can be used for bumping field locations for an SoA location. + 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 @@ -209,7 +211,7 @@ instance FreeVars (E2Ext l d) where LetRegionE _ _ _ bod -> gFreeVars bod LetParRegionE _ _ _ bod -> gFreeVars bod LetLocE _ rhs bod -> (case rhs of - AfterVariableLE v _loc _ -> S.singleton v + AfterVariableLE v vs _loc _ -> S.singleton v `S.union` S.fromList vs _ -> S.empty) `S.union` gFreeVars bod @@ -230,8 +232,8 @@ instance FreeVars (E2Ext l d) where instance FreeVars LocExp where gFreeVars e = case e of - AfterConstantLE _ loc -> S.singleton $ unwrapLocVar loc - AfterVariableLE v loc _ -> S.fromList $ [v, unwrapLocVar loc] + AfterConstantLE _ _ loc -> S.singleton $ unwrapLocVar loc + AfterVariableLE v vs loc _ -> S.fromList [v, unwrapLocVar loc] `S.union` S.fromList vs _ -> S.empty instance (Out l, Out d, Show l, Show d) => Expression (E2Ext l d) where @@ -479,6 +481,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 @@ -896,7 +909,12 @@ occurs w ex = LetLocE _ le bod -> let oc_bod = go bod in case le of - AfterVariableLE v _ _ -> v `S.member` w || oc_bod + AfterVariableLE v vs _ _ -> let func = (\v accum -> if v `S.member` w + then True || accum + else False || accum + ) + reduce = L.foldr func False vs + in reduce || v `S.member` w || oc_bod StartOfRegionLE{} -> oc_bod AfterConstantLE{} -> oc_bod InRegionLE{} -> oc_bod @@ -1033,8 +1051,8 @@ depList = L.map (\(a,b) -> (a,a,b)) . M.toList . go M.empty dep ex = case ex of StartOfRegionLE r -> [singleLocVar $ regionToVar r] - AfterConstantLE _ loc -> [loc] - AfterVariableLE v loc _ -> [singleLocVar v,loc] + AfterConstantLE _ _ loc -> [loc] + AfterVariableLE v vs loc _ -> [singleLocVar v,loc] ++ L.map singleLocVar vs InRegionLE r -> [singleLocVar $ regionToVar r] FromEndLE loc -> [loc] FreeLE -> [] diff --git a/gibbon-compiler/src/Gibbon/Passes/InferLocations.hs b/gibbon-compiler/src/Gibbon/Passes/InferLocations.hs index 306b2684c..a9db447c6 100644 --- a/gibbon-compiler/src/Gibbon/Passes/InferLocations.hs +++ b/gibbon-compiler/src/Gibbon/Passes/InferLocations.hs @@ -237,9 +237,11 @@ convertTyHelperGetLocForField' dcon index nameForLoc = do 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 ddefs False ty + ty' <- convertTy ddefs useSoA ty return (isb, ty') return (dc,bnds') return $ DDef tyargs n dcs' From 947bdc4069d26b81bc61f55244efc2608a3d2a63 Mon Sep 17 00:00:00 2001 From: Vidush Singhal Date: Wed, 4 Dec 2024 08:33:41 -0500 Subject: [PATCH 08/11] edits --- gibbon-compiler/src/Gibbon/L2/Examples.hs | 110 +++++++++--------- gibbon-compiler/src/Gibbon/L2/Interp.hs | 4 +- gibbon-compiler/src/Gibbon/L2/Typecheck.hs | 5 +- gibbon-compiler/src/Gibbon/NewL2/FromOldL2.hs | 4 +- gibbon-compiler/src/Gibbon/NewL2/Syntax.hs | 8 +- gibbon-compiler/src/Gibbon/Passes/AddRAN.hs | 4 +- .../src/Gibbon/Passes/AddTraversals.hs | 4 +- .../src/Gibbon/Passes/CalculateBounds.hs | 6 +- .../src/Gibbon/Passes/Cursorize.hs | 7 +- .../src/Gibbon/Passes/FindWitnesses.hs | 8 +- .../src/Gibbon/Passes/FollowPtrs.hs | 2 +- .../src/Gibbon/Passes/InferLocations.hs | 59 +++++----- gibbon-compiler/src/Gibbon/Passes/ParAlloc.hs | 21 ++-- .../src/Gibbon/Passes/RegionsInwards.hs | 6 +- .../src/Gibbon/Passes/RemoveCopies.hs | 4 +- .../src/Gibbon/Passes/ReorderScalarWrites.hs | 4 +- .../src/Gibbon/Passes/RouteEnds.hs | 6 +- .../src/Gibbon/Passes/Simplifier.hs | 11 +- .../src/Gibbon/Passes/ThreadRegions.hs | 4 +- gibbon-compiler/src/Gibbon/Pretty.hs | 19 ++- 20 files changed, 160 insertions(+), 136 deletions(-) diff --git a/gibbon-compiler/src/Gibbon/L2/Examples.hs b/gibbon-compiler/src/Gibbon/L2/Examples.hs index 5e931cc22..b1c5b5edb 100644 --- a/gibbon-compiler/src/Gibbon/L2/Examples.hs +++ b/gibbon-compiler/src/Gibbon/L2/Examples.hs @@ -72,10 +72,10 @@ add1FunBod = CaseE (VarE "tr1") VarE "lf8") , ("Node", [("x9",(Single "l10")),("y11",(Single "l12"))], - Ext $ LetLocE (Single "l13") (AfterConstantLE 1 (Single "lout4")) $ + Ext $ LetLocE (Single "l13") (AfterConstantLE 1 [] (Single "lout4")) $ LetE ("x14",[],PackedTy "Tree" (Single "l13"), AppE "add1" [(Single "l10"),(Single "l13")] [VarE "x9"]) $ - Ext $ LetLocE (Single "l15") (AfterVariableLE "x14" (Single "l13") True) $ + Ext $ LetLocE (Single "l15") (AfterVariableLE "x14" [] (Single "l13") True) $ LetE ("y16",[],PackedTy "Tree" (Single "l15"), AppE "add1" [(Single "l12"),(Single "l15")] [VarE "y11"]) $ LetE ("z17",[],PackedTy "Tree" (Single "lout4"), DataConE (Single "lout4") "Node" [ VarE "x14" , VarE "y16"]) $ @@ -85,10 +85,10 @@ add1FunBod = CaseE (VarE "tr1") add1MainExp :: Exp2 add1MainExp = Ext $ LetRegionE (VarR "r99") Undefined Nothing $ Ext $ LetLocE (Single "l100") (StartOfRegionLE (VarR "r99")) $ - Ext $ LetLocE (Single "l101") (AfterConstantLE 1 (Single "l100")) $ + Ext $ LetLocE (Single "l101") (AfterConstantLE 1 [] (Single "l100")) $ LetE ("x102",[],PackedTy "Tree" (Single "l101"), DataConE (Single "l101") "Leaf" [LitE 1]) $ - Ext $ LetLocE (Single "l103") (AfterVariableLE "x102" (Single "l101") True) $ + Ext $ LetLocE (Single "l103") (AfterVariableLE "x102" [] (Single "l101") True) $ LetE ("y104",[],PackedTy "Tree" (Single "l103"), DataConE (Single "l103") "Leaf" [LitE 2]) $ LetE ("z105",[],PackedTy "Tree" (Single "l100"), @@ -124,10 +124,10 @@ leafProg = Prog ddtree M.empty (Just (leafMainExp, PackedTy "Tree" (Single "l151 nodeMainExp :: Exp2 nodeMainExp = Ext $ LetRegionE (VarR "r155") Undefined Nothing $ Ext $ LetLocE (Single "l156") (StartOfRegionLE (VarR "r155")) $ - Ext $ LetLocE (Single "l157") (AfterConstantLE 1 (Single "l156")) $ + Ext $ LetLocE (Single "l157") (AfterConstantLE 1 [] (Single "l156")) $ LetE ("x158",[],PackedTy "Tree" (Single "l157"), DataConE (Single "l157") "Leaf" [LitE 1]) $ - Ext $ LetLocE (Single "l159") (AfterVariableLE "x158" (Single "l157") True) $ + Ext $ LetLocE (Single "l159") (AfterVariableLE "x158" [] (Single "l157") True) $ LetE ("y160",[],PackedTy "Tree" (Single "l159"), DataConE (Single "l159") "Leaf" [LitE 2]) $ LetE ("z161",[],PackedTy "Tree" (Single "l156"), @@ -178,10 +178,10 @@ copyTreeFun = FunDef "copyTree" [ "tr22"] copyFunTy copyBod (FunMeta NotRec NoIn VarE "n28") , ("Node", [("x29",(Single "lx30")),("y31",(Single "ly32"))], - Ext $ LetLocE (Single "lx33") (AfterConstantLE 1 (Single "lout25")) $ + Ext $ LetLocE (Single "lx33") (AfterConstantLE 1 [] (Single "lout25")) $ LetE ("x34", [], PackedTy "Tree" (Single "lx33"), AppE "copyTree" [(Single "lx30"),(Single "lx33")] [VarE "x29"]) $ - Ext $ LetLocE (Single "ly35") (AfterVariableLE "x34" (Single "lx33") True) $ + Ext $ LetLocE (Single "ly35") (AfterVariableLE "x34" [] (Single "lx33") True) $ LetE ("y36", [], PackedTy "Tree" (Single "ly35"), AppE "copyTree" [(Single "ly32"),(Single "ly35")] [VarE "y31"]) $ DataConE (Single "lout25") "Node" [VarE "x34", VarE "y36"]) @@ -190,10 +190,10 @@ copyTreeFun = FunDef "copyTree" [ "tr22"] copyFunTy copyBod (FunMeta NotRec NoIn copyTreeMainExp :: Exp2 copyTreeMainExp = Ext $ LetRegionE (VarR "r200") Undefined Nothing $ Ext $ LetLocE (Single "l201") (StartOfRegionLE (VarR "r200")) $ - Ext $ LetLocE (Single "l202") (AfterConstantLE 1 (Single "l201")) $ + Ext $ LetLocE (Single "l202") (AfterConstantLE 1 [] (Single "l201")) $ LetE ("x203",[],PackedTy "Tree" (Single "l202"), DataConE (Single "l202") "Leaf" [LitE 1]) $ - Ext $ LetLocE (Single "r204") (AfterVariableLE "x203" (Single "l202") True) $ + Ext $ LetLocE (Single "r204") (AfterVariableLE "x203" [] (Single "l202") True) $ LetE ("y205",[],PackedTy "Tree" (Single "r204"), DataConE (Single "r204") "Leaf" [LitE 2]) $ LetE ("z206",[],PackedTy "Tree" (Single "l201"), @@ -240,10 +240,10 @@ copyOnId1Prog = Prog ddtree funs $ Just (copyOnId1MainExp, PackedTy "Tree" (Sing copyOnId1MainExp :: Exp2 copyOnId1MainExp = Ext $ LetRegionE (VarR "r220") Undefined Nothing $ Ext $ LetLocE (Single "l221") (StartOfRegionLE (VarR "r220")) $ - Ext $ LetLocE (Single "l222") (AfterConstantLE 1 (Single "l221")) $ + Ext $ LetLocE (Single "l222") (AfterConstantLE 1 [] (Single "l221")) $ LetE ("l223",[],PackedTy "Tree" (Single "l222"), DataConE (Single "l222") "Leaf" [LitE 1]) $ - Ext $ LetLocE (Single "l224") (AfterVariableLE "l223" (Single "l222") True) $ + Ext $ LetLocE (Single "l224") (AfterVariableLE "l223" [] (Single "l222") True) $ LetE ("l225",[],PackedTy "Tree" (Single "l224"), DataConE (Single "l224") "Leaf" [LitE 2]) $ LetE ("z226",[],PackedTy "Tree" (Single "l221"), @@ -331,10 +331,10 @@ leftmostBod = CaseE (VarE "t111") leftmostMainExp :: Exp2 leftmostMainExp = Ext $ LetRegionE (VarR "r122") Undefined Nothing $ Ext $ LetLocE (Single "l123") (StartOfRegionLE (VarR "r122")) $ - Ext $ LetLocE (Single "l124") (AfterConstantLE 1 (Single "l123")) $ + Ext $ LetLocE (Single "l124") (AfterConstantLE 1 [] (Single "l123")) $ LetE ("x125",[],PackedTy "Tree" (Single "l124"), DataConE (Single "l124") "Leaf" [LitE 1]) $ - Ext $ LetLocE (Single "l126") (AfterVariableLE "x125" (Single "l124") True) $ + Ext $ LetLocE (Single "l126") (AfterVariableLE "x125" [] (Single "l124") True) $ LetE ("y128",[],PackedTy "Tree" (Single "l126"), DataConE (Single "l126") "Leaf" [LitE 2]) $ LetE ("z127",[],PackedTy "Tree" (Single "l123"), @@ -376,10 +376,10 @@ rightmostBod = CaseE (VarE "t242") rightmostMainExp :: Exp2 rightmostMainExp = Ext $ LetRegionE (VarR "r253") Undefined Nothing $ Ext $ LetLocE (Single "l254") (StartOfRegionLE (VarR "r253")) $ - Ext $ LetLocE (Single "l255") (AfterConstantLE 1 (Single "l254")) $ + Ext $ LetLocE (Single "l255") (AfterConstantLE 1 [] (Single "l254")) $ LetE ("x256",[],PackedTy "Tree" (Single "l255"), DataConE (Single "l255") "Leaf" [LitE 1]) $ - Ext $ LetLocE (Single "l257") (AfterVariableLE "x256" (Single "l255") True) $ + Ext $ LetLocE (Single "l257") (AfterVariableLE "x256" [] (Single "l255") True) $ LetE ("y258",[],PackedTy "Tree" (Single "l257"), DataConE (Single "l257") "Leaf" [LitE 2]) $ LetE ("z259",[],PackedTy "Tree" (Single "l254"), @@ -439,10 +439,10 @@ buildTreeFun = FunDef "buildTree" [ "i270"] buildTreeTy buildTreeBod (FunMeta Re IfE (VarE "b279") (DataConE (Single "lout272") "Leaf" [LitE 1]) (LetE ("i273",[], IntTy, PrimAppE SubP [VarE "i270", LitE 1]) $ - Ext $ LetLocE (Single "l274") (AfterConstantLE 1 (Single "lout272")) $ + Ext $ LetLocE (Single "l274") (AfterConstantLE 1 [] (Single "lout272")) $ LetE ("x275",[],PackedTy "Tree" (Single "l274"), AppE "buildTree" [(Single "l274")] [VarE "i273"]) $ - Ext $ LetLocE (Single "l276") (AfterVariableLE "x275" (Single "l274") True) $ + Ext $ LetLocE (Single "l276") (AfterVariableLE "x275" [] (Single "l274") True) $ LetE ("y277",[],PackedTy "Tree" (Single "l276"), AppE "buildTree" [(Single "l276")] [VarE "i273"]) $ LetE ("a278",[],PackedTy "Tree" (Single "lout272"), @@ -520,12 +520,12 @@ buildTreeSumFun = FunDef "buildTreeSum" [ "i302"] buildTreeSumTy buildTreeSumBod MkProdE [LitE 1, VarE "c316"]) $ VarE "t317") (LetE ("i303",[], IntTy, PrimAppE SubP [VarE "i302", LitE 1]) $ - Ext $ LetLocE (Single "l304") (AfterConstantLE 1 (Single "lout301")) $ + Ext $ LetLocE (Single "l304") (AfterConstantLE 1 [] (Single "lout301")) $ LetE ("t318",[],ProdTy [IntTy, PackedTy "Tree" (Single "l304")], AppE "buildTreeSum" [(Single "l304")] [VarE "i303"]) $ LetE ("i309",[],IntTy, ProjE 0 (VarE "t318")) $ LetE ("x305",[],PackedTy "Tree" (Single "l304"), ProjE 1 (VarE "t318")) $ - Ext $ LetLocE (Single "l306") (AfterVariableLE "x305" (Single "l304") True) $ + Ext $ LetLocE (Single "l306") (AfterVariableLE "x305" [] (Single "l304") True) $ LetE ("t319",[],ProdTy [IntTy, PackedTy "Tree" (Single "l306")], AppE "buildTreeSum" [(Single "l306")] [VarE "i303"]) $ LetE ("i310",[],IntTy, ProjE 0 (VarE "t319")) $ @@ -614,7 +614,7 @@ printTupMainExp2 = Ext $ LetRegionE (VarR "r400") Undefined Nothing $ Ext $ LetLocE (Single "l401") (StartOfRegionLE (VarR "r400")) $ LetE ("x402",[], PackedTy "Tree" (Single "l401"), AppE "buildTree" [(Single "l401")] [LitE 2]) $ - Ext $ LetLocE (Single "l403") (AfterVariableLE "x402" (Single "l401") True) $ + Ext $ LetLocE (Single "l403") (AfterVariableLE "x402" [] (Single "l401") True) $ LetE ("y404",[], PackedTy "Tree" (Single "l403"), AppE "buildTree" [(Single "l403")] [LitE 1]) $ LetE ("z405",[], ProdTy [PackedTy "Tree" (Single "l401"), PackedTy "Tree" (Single "l403")], @@ -673,13 +673,13 @@ addTreesFun = FunDef "addTrees" [ "trees354"] addTreesTy addTreesBod (FunMeta Re ("Node", [("x360",(Single "l361")), ("y362",(Single "l363"))], CaseE (VarE "tree2") [("Node", [("x364",(Single "l365")), ("y366", (Single "l367"))], - Ext $ LetLocE (Single "l368") (AfterConstantLE 1 (Single "lout353")) $ + Ext $ LetLocE (Single "l368") (AfterConstantLE 1 [] (Single "lout353")) $ LetE ("tree3",[],ProdTy [PackedTy "Tree" (Single "l361"), PackedTy "Tree" (Single "l365")], MkProdE [VarE "x360", VarE "x364"]) $ LetE ("x369",[],PackedTy "Tree" (Single "l368"), AppE "addTrees" [(Single "l361"),(Single "l365"),(Single "l368")] [VarE "tree3"]) $ - Ext $ LetLocE (Single "l370") (AfterVariableLE "x369" (Single "l368") True) $ + Ext $ LetLocE (Single "l370") (AfterVariableLE "x369" [] (Single "l368") True) $ LetE ("tree4",[],ProdTy [PackedTy "Tree" (Single "l363"), PackedTy "Tree" (Single "l367")], MkProdE [VarE "y362", VarE "y366"]) $ @@ -738,13 +738,13 @@ testProdFun = FunDef "testprod" [ "tup130"] testprodTy testprodBod (FunMeta Rec VarE "tup148" ), ("Node",[("x140",(Single "l141")), ("y142",(Single "l143"))], - Ext $ LetLocE (Single "l144") (AfterConstantLE 1 (Single "lout133")) $ + Ext $ LetLocE (Single "l144") (AfterConstantLE 1 [] (Single "lout133")) $ LetE ("tup145",[], ProdTy [PackedTy "Tree" (Single "l144"), IntTy], AppE "testprod" [(Single "l141"),(Single "l144")] [MkProdE [VarE "x140", VarE "i135"]]) $ LetE ("x149",[], PackedTy "Tree" (Single "l144"), ProjE 0 (VarE "tup145")) $ - Ext $ LetLocE (Single "l146") (AfterVariableLE "x149" (Single "l144") True) $ + Ext $ LetLocE (Single "l146") (AfterVariableLE "x149" [] (Single "l144") True) $ LetE ("tup147",[], ProdTy [PackedTy "Tree" (Single "l146"), IntTy], AppE "testprod" [(Single "l143"),(Single "l146")] [MkProdE [VarE "y142", VarE "i135"]]) $ @@ -769,7 +769,7 @@ testFlattenProg = Prog M.empty (M.fromList [( "intAdd",intAddFun)]) $ Just (test testFlattenBod = Ext $ LetRegionE (VarR "_") Undefined Nothing $ Ext $ LetLocE (Single "_") (StartOfRegionLE (VarR "_")) $ - Ext $ LetLocE (Single "_") (AfterConstantLE 1 (Single "_")) $ + Ext $ LetLocE (Single "_") (AfterConstantLE 1 [] (Single "_")) $ LetE ("v170",[],IntTy, LetE ("v171",[],IntTy, AppE "intAdd" [] @@ -830,12 +830,12 @@ sumUpFun = FunDef "sumUp" [ "tr1"] sumUpFunTy sumUpFunBod (FunMeta Rec NoInline VarE "x505") , ("Inner", [("i506",(Single "l507")),("b508", (Single "l509")),("x510", (Single "l511")),("y512", (Single "l513"))], - Ext $ LetLocE (Single "l514") (AfterConstantLE 1 (Single "lout502")) $ - Ext $ LetLocE (Single "l550") (AfterVariableLE "i506" (Single "l514") True) $ - Ext $ LetLocE (Single "l551") (AfterVariableLE "b508" (Single "l550") True) $ + Ext $ LetLocE (Single "l514") (AfterConstantLE 1 [] (Single "lout502")) $ + Ext $ LetLocE (Single "l550") (AfterVariableLE "i506" [] (Single "l514") True) $ + Ext $ LetLocE (Single "l551") (AfterVariableLE "b508" [] (Single "l550") True) $ LetE ("x515",[],PackedTy "STree" (Single "l551"), AppE "sumUp" [(Single "l511"),(Single "l551")] [VarE "x510"]) $ - Ext $ LetLocE (Single "l516") (AfterVariableLE "x515" (Single "l551") True) $ + Ext $ LetLocE (Single "l516") (AfterVariableLE "x515" [] (Single "l551") True) $ LetE ("y517",[],PackedTy "STree" (Single "l516"), AppE "sumUp" [(Single "l513"),(Single "l516")] [VarE "y512"]) $ LetE ("v518",[],IntTy, AppE "valueSTree" [(Single "l551")] [VarE "x515"]) $ @@ -889,12 +889,12 @@ buildSTreeFun = FunDef "buildSTree" [ "i543"] buildSTreeTy buildSTreeBod (FunMet (LetE ("i548",[], IntTy, PrimAppE SubP [VarE "i543", LitE 1]) $ LetE ("i554",[], IntTy, LitE 0) $ LetE ("b555",[], IntTy, LitE 0) $ - Ext $ LetLocE (Single "l544") (AfterConstantLE 1 (Single "lout541")) $ - Ext $ LetLocE (Single "l552") (AfterVariableLE "i554" (Single "l544") True) $ - Ext $ LetLocE (Single "l553") (AfterVariableLE "b555" (Single "l552") True) $ + Ext $ LetLocE (Single "l544") (AfterConstantLE 1 [] (Single "lout541")) $ + Ext $ LetLocE (Single "l552") (AfterVariableLE "i554" [] (Single "l544") True) $ + Ext $ LetLocE (Single "l553") (AfterVariableLE "b555" [] (Single "l552") True) $ LetE ("x545",[],PackedTy "STree" (Single "l553"), AppE "buildSTree" [(Single "l553")] [VarE "i548"]) $ - Ext $ LetLocE (Single "l545") (AfterVariableLE "x545" (Single "l553") True) $ + Ext $ LetLocE (Single "l545") (AfterVariableLE "x545" [] (Single "l553") True) $ LetE ("y546",[],PackedTy "STree" (Single "l545"), AppE "buildSTree" [(Single "l545")] [VarE "i548"]) $ LetE ("a547",[],PackedTy "STree" (Single "lout541"), @@ -1038,12 +1038,12 @@ setEvenFun = FunDef "setEven" [ "tr570"] setEvenFunTy setEvenFunBod (FunMeta Rec VarE "x575") , ("Inner", [("i576",(Single "l577")),("b578",(Single "l579")),("x580",(Single "l581")),("y582",(Single "l583"))], - Ext $ LetLocE (Single "l584") (AfterConstantLE 1 (Single "lout572")) $ - Ext $ LetLocE (Single "l585") (AfterVariableLE "i576" (Single "l584") True) $ - Ext $ LetLocE (Single "l586") (AfterVariableLE "b578" (Single "l585") True) $ + Ext $ LetLocE (Single "l584") (AfterConstantLE 1 [] (Single "lout572")) $ + Ext $ LetLocE (Single "l585") (AfterVariableLE "i576" [] (Single "l584") True) $ + Ext $ LetLocE (Single "l586") (AfterVariableLE "b578" [] (Single "l585") True) $ LetE ("x587",[],PackedTy "STree" (Single "l586"), AppE "setEven" [(Single "l581"),(Single "l586")] [VarE "x580"]) $ - Ext $ LetLocE (Single "l588") (AfterVariableLE "x587" (Single "l586") True) $ + Ext $ LetLocE (Single "l588") (AfterVariableLE "x587" [] (Single "l586") True) $ LetE ("y589",[],PackedTy "STree" (Single "l588"), AppE "setEven" [(Single "l583"),(Single "l588")] [VarE "y582"]) $ LetE ("v590",[],IntTy, AppE "valueSTree" [(Single "l586")] [VarE "x587"]) $ @@ -1123,14 +1123,14 @@ sumUpSetEvenFun = FunDef "sumUpSetEven" [ "tr600"] sumUpSetEvenFunTy sumUpSetEve VarE "tx606") , ("Inner", [("i607",(Single "l608")),("b609", (Single "l610")),("x611", (Single "l612")),("y613", (Single "l622"))], - Ext $ LetLocE (Single "l614") (AfterConstantLE 1 (Single "lout602")) $ - Ext $ LetLocE (Single "l615") (AfterVariableLE "i607" (Single "l614") True) $ - Ext $ LetLocE (Single "l616") (AfterVariableLE "b609" (Single "l615") True) $ + Ext $ LetLocE (Single "l614") (AfterConstantLE 1 [] (Single "lout602")) $ + Ext $ LetLocE (Single "l615") (AfterVariableLE "i607" [] (Single "l614") True) $ + Ext $ LetLocE (Single "l616") (AfterVariableLE "b609" [] (Single "l615") True) $ LetE ("tx617",[], ProdTy [PackedTy "STree" (Single "l616"), IntTy], AppE "sumUpSetEven" [(Single "l612"),(Single "l616")] [VarE "x611"]) $ LetE ("x618",[],PackedTy "STree" (Single "l616"), ProjE 0 (VarE "tx617")) $ LetE ("v619",[],IntTy, ProjE 1 (VarE "tx617")) $ - Ext $ LetLocE (Single "l620") (AfterVariableLE "x618" (Single "l616") True) $ + Ext $ LetLocE (Single "l620") (AfterVariableLE "x618" [] (Single "l616") True) $ LetE ("tx621",[],ProdTy [PackedTy "STree" (Single "l620"), IntTy], AppE "sumUpSetEven" [(Single "l622"),(Single "l620")] [VarE "y613"]) $ LetE ("y623",[],PackedTy "STree" (Single "l620"), ProjE 0 (VarE "tx621")) $ @@ -1212,11 +1212,11 @@ copyExprFun = FunDef "copyExpr" [ "e700"] copyExprFunTy copyExprFunBod (FunMeta DataConE (Single "lout703") "VARREF" [VarE "v704"] ) , ("LETE", [("v706",(Single "l707")), ("rhs708", (Single "l709")), ("bod710", (Single "l711"))], - Ext $ LetLocE (Single "l712") (AfterConstantLE 1 (Single "lout703")) $ - Ext $ LetLocE (Single "l713") (AfterVariableLE "v706" (Single "l712") True) $ + Ext $ LetLocE (Single "l712") (AfterConstantLE 1 [] (Single "lout703")) $ + Ext $ LetLocE (Single "l713") (AfterVariableLE "v706" [] (Single "l712") True) $ LetE ("rhs714",[], PackedTy "Expr" (Single "l713"), AppE "copyExpr" [(Single "l709"),(Single "l713")] [VarE "rhs708"]) $ - Ext $ LetLocE (Single "l715") (AfterVariableLE "rhs714" (Single "l713") True) $ + Ext $ LetLocE (Single "l715") (AfterVariableLE "rhs714" [] (Single "l713") True) $ LetE ("bod716",[],PackedTy "Expr" (Single "l715"), AppE "copyExpr" [(Single "l711"), (Single "l715")] [VarE "bod710"]) $ LetE ("z717",[],PackedTy "Expr" (Single "lout703"), @@ -1258,13 +1258,13 @@ substFun = FunDef "subst" [ "tr653"] substFunTy substFunBod (FunMeta Rec NoInlin LetE ("b662",[],BoolTy, PrimAppE EqIntP [VarE "v656", VarE "old654"]) -- IfE (VarE "b662") - (Ext $ LetLocE (Single "l663") (AfterConstantLE 1 (Single "lout653")) $ - Ext $ LetLocE (Single "l664") (AfterVariableLE "v656" (Single "l663") True) $ + (Ext $ LetLocE (Single "l663") (AfterConstantLE 1 [] (Single "lout653")) $ + Ext $ LetLocE (Single "l664") (AfterVariableLE "v656" [] (Single "l663") True) $ LetE ("p668",[], ProdTy [IntTy, PackedTy "Expr" (Single "lin651"), PackedTy "Expr" (Single "l659")], MkProdE [VarE "old654", VarE "new655", VarE "rhs658"]) $ LetE ("rhs665",[],PackedTy "Expr" (Single "l664"), AppE "subst" [(Single "lin651"), (Single "l659"), (Single "l664")] [VarE "p668"]) $ - Ext $ LetLocE (Single "l669") (AfterVariableLE "rhs665" (Single "l664") True) $ + Ext $ LetLocE (Single "l669") (AfterVariableLE "rhs665" [] (Single "l664") True) $ LetE ("bod670",[], PackedTy "Expr" (Single "l669"), AppE "copyExpr" [(Single "l661"), (Single "l669")] [VarE "bod660"]) $ LetE ("z671",[], PackedTy "Expr" (Single "lout653"), @@ -1277,11 +1277,11 @@ substFun = FunDef "subst" [ "tr653"] substFunTy substFunBod (FunMeta Rec NoInlin substMainExp :: Exp2 substMainExp = Ext $ LetRegionE (VarR "r720") Undefined Nothing $ Ext $ LetLocE (Single "l721") (StartOfRegionLE (VarR "r720")) $ - Ext $ LetLocE (Single "l722") (AfterConstantLE 1 (Single "l721")) $ - Ext $ LetLocE (Single "l723") (AfterConstantLE 8 (Single "l722")) $ + Ext $ LetLocE (Single "l722") (AfterConstantLE 1 [] (Single "l721")) $ + Ext $ LetLocE (Single "l723") (AfterConstantLE 8 [] (Single "l722")) $ LetE ("rhs724",[], PackedTy "Expr" (Single "l723"), DataConE (Single "l723") "VARREF" [LitE 1]) $ - Ext $ LetLocE (Single "l724") (AfterVariableLE "rhs724" (Single "l723") True) $ + Ext $ LetLocE (Single "l724") (AfterVariableLE "rhs724" [] (Single "l723") True) $ LetE ("bod725",[], PackedTy "Expr" (Single "l724"), DataConE (Single "l724") "VARREF" [LitE 10]) $ LetE ("old726",[],IntTy,LitE 1) $ @@ -1293,7 +1293,7 @@ substMainExp = Ext $ LetRegionE (VarR "r720") Undefined Nothing $ DataConE (Single "l729") "VARREF" [LitE 42]) $ LetE ("p731",[],ProdTy [IntTy, PackedTy "Expr" (Single "l729"), PackedTy "Expr" (Single "l721")], MkProdE [VarE "old726", VarE "new730", VarE "z727"]) $ - Ext $ LetLocE (Single "l730") (AfterVariableLE "new730" (Single "l729") True) $ + Ext $ LetLocE (Single "l730") (AfterVariableLE "new730" [] (Single "l729") True) $ LetE ("z732",[], PackedTy "Expr" (Single "l730"), AppE "subst" [(Single "l729"), (Single "l721"), (Single "l730")] [VarE "p731"]) $ VarE "z732" @@ -1337,11 +1337,11 @@ indrBuildTreeFun = FunDef "indrBuildTree" [ "i270"] indrBuildTreeTy indrBuildTre IfE (VarE "b279") (DataConE (Single "lout272") "Leaf" [LitE 1]) (LetE ("i273",[], IntTy, PrimAppE SubP [VarE "i270", LitE 1]) $ - Ext $ LetLocE (Single "loc_indr") (AfterConstantLE 1 (Single "lout272")) $ - Ext $ LetLocE (Single "l274") (AfterConstantLE 8 (Single "loc_indr")) $ + Ext $ LetLocE (Single "loc_indr") (AfterConstantLE 1 [] (Single "lout272")) $ + Ext $ LetLocE (Single "l274") (AfterConstantLE 8 [] (Single "loc_indr")) $ LetE ("x275",[],PackedTy "Tree" (Single "l274"), AppE "indrBuildTree" [(Single "l274")] [VarE "i273"]) $ - Ext $ LetLocE (Single "l276") (AfterVariableLE "x275" (Single "l274") True) $ + Ext $ LetLocE (Single "l276") (AfterVariableLE "x275" [] (Single "l274") True) $ LetE ("y277",[],PackedTy "Tree" (Single "l276"), AppE "indrBuildTree" [(Single "l276")] [VarE "i273"]) $ LetE ("indr_cur",[],CursorTy,Ext (StartOfPkdCursor "y277")) $ diff --git a/gibbon-compiler/src/Gibbon/L2/Interp.hs b/gibbon-compiler/src/Gibbon/L2/Interp.hs index 4d99d1e65..6f7ebaa10 100644 --- a/gibbon-compiler/src/Gibbon/L2/Interp.hs +++ b/gibbon-compiler/src/Gibbon/L2/Interp.hs @@ -308,7 +308,7 @@ interpExt sizeEnv rc env ddefs fenv ext = Just _ -> go (M.insert (unwrapLocVar loc) (VLoc (regionToVar reg) 0) env) sizeEnv bod - AfterConstantLE i loc2 -> do + AfterConstantLE i _ loc2 -> do case M.lookup (unwrapLocVar loc2) env of Nothing -> error $ "L2.Interp: Unbound location: " ++ sdoc loc2 Just (VLoc reg offset) -> @@ -316,7 +316,7 @@ interpExt sizeEnv rc env ddefs fenv ext = Just val -> error $ "L2.Interp: Unexpected value for " ++ sdoc loc2 ++ ":" ++ sdoc val - AfterVariableLE v loc2 _ -> do + AfterVariableLE v _ loc2 _ -> do case M.lookup (unwrapLocVar loc2) env of Nothing -> error $ "L2.Interp: Unbound location: " ++ sdoc loc2 Just (VLoc reg offset) -> diff --git a/gibbon-compiler/src/Gibbon/L2/Typecheck.hs b/gibbon-compiler/src/Gibbon/L2/Typecheck.hs index 6a8a3a480..04340da5e 100644 --- a/gibbon-compiler/src/Gibbon/L2/Typecheck.hs +++ b/gibbon-compiler/src/Gibbon/L2/Typecheck.hs @@ -780,14 +780,15 @@ 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) - AfterConstantLE i l1 -> + {-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 let constrs1 = extendConstrs (InRegionC (Single loc) r) $ extendConstrs (AfterConstantC i l1 (Single loc)) constrs (ty,tstate2) <- tcExp ddfs env' funs constrs1 regs tstate1 e tstate3 <- removeLoc exp tstate2 (Single loc) return (ty,tstate3) - AfterVariableLE x l1 _ -> + AfterVariableLE x _ l1 _ -> do r <- getRegion exp constrs l1 (_xty,tstate1) <- tcExp ddfs env funs constrs regs tstatein $ VarE x -- NOTE: We now allow aliases (offsets) from scalar vars too. So we can leave out this check diff --git a/gibbon-compiler/src/Gibbon/NewL2/FromOldL2.hs b/gibbon-compiler/src/Gibbon/NewL2/FromOldL2.hs index 229a0634a..51d9584f3 100644 --- a/gibbon-compiler/src/Gibbon/NewL2/FromOldL2.hs +++ b/gibbon-compiler/src/Gibbon/NewL2/FromOldL2.hs @@ -237,10 +237,10 @@ fromOldL2Exp ddefs fundefs locenv env2 ex = toLocArg loc locexp locenv0 = case locexp of StartOfRegionLE reg -> New.Loc (New.LREM loc (regionToVar reg) (toEndV (regionToVar reg)) Output) - AfterConstantLE _ loc2 -> + AfterConstantLE _ _ loc2 -> let (New.Loc lrem) = locenv0 # loc2 in New.Loc (New.LREM loc (New.lremReg lrem) (New.lremEndReg lrem) Output) - AfterVariableLE _ loc2 _ -> + AfterVariableLE _ _ loc2 _ -> let (New.Loc lrem) = locenv0 # loc2 in New.Loc (New.LREM loc (New.lremReg lrem) (New.lremEndReg lrem) Output) InRegionLE reg -> diff --git a/gibbon-compiler/src/Gibbon/NewL2/Syntax.hs b/gibbon-compiler/src/Gibbon/NewL2/Syntax.hs index 48f91e834..0f5bd1fb8 100644 --- a/gibbon-compiler/src/Gibbon/NewL2/Syntax.hs +++ b/gibbon-compiler/src/Gibbon/NewL2/Syntax.hs @@ -139,8 +139,8 @@ toEndFromTaggedV v = (toVar "end_from_tagged_") `varAppend` v 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.AfterConstantLE _ _ loc -> S.singleton $ unwrapLocVar (toLocVar loc) + Old.AfterVariableLE v vs loc _ -> S.fromList [v, unwrapLocVar (toLocVar loc)] `S.union` S.fromList vs _ -> S.empty @@ -510,8 +510,8 @@ depList = L.map (\(a,b) -> (a,a,b)) . M.toList . go M.empty dep ex = case ex of Old.StartOfRegionLE r -> [Old.regionToVar r] - Old.AfterConstantLE _ loc -> [unwrapLocVar $ toLocVar loc] - Old.AfterVariableLE v loc _ -> [v, unwrapLocVar $ toLocVar loc] + Old.AfterConstantLE _ _ loc -> [unwrapLocVar $ toLocVar loc] + Old.AfterVariableLE v vs loc _ -> [v, unwrapLocVar $ toLocVar loc] ++ vs Old.InRegionLE r -> [Old.regionToVar r] Old.FromEndLE loc -> [unwrapLocVar $ toLocVar loc] Old.FreeLE -> [] diff --git a/gibbon-compiler/src/Gibbon/Passes/AddRAN.hs b/gibbon-compiler/src/Gibbon/Passes/AddRAN.hs index a2da2286a..5896e0c8f 100644 --- a/gibbon-compiler/src/Gibbon/Passes/AddRAN.hs +++ b/gibbon-compiler/src/Gibbon/Passes/AddRAN.hs @@ -426,8 +426,8 @@ we need random access for that type. let reg = case rhs of StartOfRegionLE r -> regionToVar r InRegionLE r -> regionToVar r - AfterConstantLE _ lc -> renv # lc - AfterVariableLE _ lc _ -> renv # lc + AfterConstantLE _ _ lc -> renv # lc + AfterVariableLE _ _ lc _ -> renv # lc FromEndLE lc -> renv # lc -- TODO: This needs to be fixed in needsRANExp ddefs fundefs env2 (M.insert loc reg renv) tcenv parlocss bod _ -> S.empty diff --git a/gibbon-compiler/src/Gibbon/Passes/AddTraversals.hs b/gibbon-compiler/src/Gibbon/Passes/AddTraversals.hs index 0c70cb381..e255391bd 100644 --- a/gibbon-compiler/src/Gibbon/Passes/AddTraversals.hs +++ b/gibbon-compiler/src/Gibbon/Passes/AddTraversals.hs @@ -100,8 +100,8 @@ addTraversalsExp ddefs fundefs env2 renv context ex = let reg = case locexp of StartOfRegionLE r -> regionToVar r InRegionLE r -> regionToVar r - AfterConstantLE _ lc -> renv # lc - AfterVariableLE _ lc _ -> renv # lc + AfterConstantLE _ _ lc -> renv # lc + AfterVariableLE _ _ lc _ -> renv # lc FromEndLE lc -> renv # lc -- TODO: This needs to be fixed in Ext <$> LetLocE loc locexp <$> addTraversalsExp ddefs fundefs env2 (M.insert loc reg renv) context bod diff --git a/gibbon-compiler/src/Gibbon/Passes/CalculateBounds.hs b/gibbon-compiler/src/Gibbon/Passes/CalculateBounds.hs index 58e95cb76..66204ced9 100644 --- a/gibbon-compiler/src/Gibbon/Passes/CalculateBounds.hs +++ b/gibbon-compiler/src/Gibbon/Passes/CalculateBounds.hs @@ -180,10 +180,12 @@ calculateBoundsExp ddefs env2 varSzEnv varLocEnv locRegEnv locOffEnv regSzEnv re else do let (re, off) = case locExp of (StartOfRegionLE r ) -> (regionToVar r, BoundedSize 0) - (AfterConstantLE n l ) -> (locRegEnv # l, locOffEnv # l <> BoundedSize n) + -- [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. - (AfterVariableLE v l _) -> (locRegEnv # l, locOffEnv # (varLocEnv # v)) -- <> varSzEnv # v + -- [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) FreeLE -> undefined diff --git a/gibbon-compiler/src/Gibbon/Passes/Cursorize.hs b/gibbon-compiler/src/Gibbon/Passes/Cursorize.hs index 4ec9e0351..159514bb0 100644 --- a/gibbon-compiler/src/Gibbon/Passes/Cursorize.hs +++ b/gibbon-compiler/src/Gibbon/Passes/Cursorize.hs @@ -694,11 +694,12 @@ cursorizeReadPackedFile ddfs fundefs denv tenv senv isPackedContext v path tyc r cursorizeLocExp :: DepEnv -> TyEnv Var Ty2 -> SyncEnv -> LocVar -> LocExp -> Either DepEnv (Exp3, [Binds Exp3], TyEnv Var Ty2, SyncEnv) cursorizeLocExp denv tenv senv lvar locExp = case locExp of - AfterConstantLE i loc -> + AfterConstantLE i [] loc -> let rhs = Ext $ AddCursor ((unwrapLocVar . toLocVar) loc) (LitE i) in if isBound ((toLocVar) loc) tenv then Right (rhs, [], tenv, senv) else Left$ M.insertWith (++) ((toLocVar) loc) [((unwrapLocVar lvar),[],CursorTy,rhs)] denv + AfterConstantLE i irst loc -> error "cursorizeLocExp :: AfterConstantLE Bounds for SoA not implemented." -- TODO: handle product types here {- [2018.03.07]: @@ -711,7 +712,7 @@ For BigInfinite regions, this is simple: But Infinite regions do not support sizes yet. Re-enable this later. -} - AfterVariableLE v locarg was_stolen -> do + AfterVariableLE v [] locarg was_stolen -> do let vty = case M.lookup v tenv of Just ty -> ty Nothing -> case M.lookup v senv of @@ -763,6 +764,8 @@ But Infinite regions do not support sizes yet. Re-enable this later. Right (bod, bnds, tenv', M.delete v senv) else Left $ M.insertWith (++) loc [((unwrapLocVar lvar),[],CursorTy,bod)] denv + AfterVariableLE v vrst locarg was_stolen -> error "TODO: cursorizeLocExp: AfterVariableLE offsets for SoA not implemented yet." + FromEndLE locarg -> let loc = toLocVar locarg in if isBound loc tenv diff --git a/gibbon-compiler/src/Gibbon/Passes/FindWitnesses.hs b/gibbon-compiler/src/Gibbon/Passes/FindWitnesses.hs index c66570ceb..ecacb9496 100644 --- a/gibbon-compiler/src/Gibbon/Passes/FindWitnesses.hs +++ b/gibbon-compiler/src/Gibbon/Passes/FindWitnesses.hs @@ -91,10 +91,10 @@ findWitnesses p@Prog{fundefs} = mapMExprs fn p then Ext $ LetLocE loc locexp $ goE (Set.insert loc bound) mp bod else case locexp of - AfterVariableLE v loc2 b -> - (go (Map.insert loc (DelayLoc (loc, (AfterVariableLE v loc2 b))) mp) bod) - AfterConstantLE i loc2 -> - go (Map.insert loc (DelayLoc (loc, (AfterConstantLE i loc2))) mp) bod + AfterVariableLE v vs loc2 b -> + (go (Map.insert loc (DelayLoc (loc, (AfterVariableLE v vs loc2 b))) mp) bod) + AfterConstantLE i irst loc2 -> + go (Map.insert loc (DelayLoc (loc, (AfterConstantLE i irst loc2))) mp) bod _ -> Ext $ LetLocE loc locexp $ goE (Set.insert loc bound) mp bod LetRegionE r sz ty bod -> Ext $ LetRegionE r sz ty $ go mp bod LetParRegionE r sz ty bod -> Ext $ LetParRegionE r sz ty $ go mp bod diff --git a/gibbon-compiler/src/Gibbon/Passes/FollowPtrs.hs b/gibbon-compiler/src/Gibbon/Passes/FollowPtrs.hs index 1afc2e299..3cb44dc5a 100644 --- a/gibbon-compiler/src/Gibbon/Passes/FollowPtrs.hs +++ b/gibbon-compiler/src/Gibbon/Passes/FollowPtrs.hs @@ -55,7 +55,7 @@ followPtrs (Prog ddefs fundefs mainExp) = do let in_locs = foldr (\loc acc -> if loc == scrt_loc then ((Single indir_ptrv) : acc) else (loc : acc)) [] (inLocVars funTy) let out_locs = outLocVars funTy wc <- gensym "wildcard" - let indir_bod = Ext $ LetLocE (Single jump) (AfterConstantLE 8 (Single indir_ptrloc)) $ + let indir_bod = Ext $ LetLocE (Single jump) (AfterConstantLE 8 [] (Single indir_ptrloc)) $ (if isPrinterName funName then LetE (wc,[],ProdTy[],PrimAppE PrintSym [LitSymE (toVar " ->i ")]) else id) $ LetE (callv,endofs',out_ty,AppE funName (in_locs ++ out_locs) args) $ Ext (RetE ret_endofs callv) diff --git a/gibbon-compiler/src/Gibbon/Passes/InferLocations.hs b/gibbon-compiler/src/Gibbon/Passes/InferLocations.hs index a9db447c6..f61c6201b 100644 --- a/gibbon-compiler/src/Gibbon/Passes/InferLocations.hs +++ b/gibbon-compiler/src/Gibbon/Passes/InferLocations.hs @@ -276,8 +276,11 @@ 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. -data Constraint = AfterConstantL LocVar Int LocVar - | AfterVariableL LocVar Var LocVar +-- [2024.12.04] VS +-- For AfterConstantL and AfterVariableL add a list argument with offsets for fields in an SoA location +-- Optional for AoS Location. +data Constraint = AfterConstantL LocVar Int [Int] LocVar + | AfterVariableL LocVar Var [Var] LocVar | AfterTagL LocVar LocVar | StartRegionL LocVar Region | AfterCopyL LocVar Var Var LocVar Var [LocVar] @@ -390,10 +393,10 @@ inferExp' ddefs env exp bound dest= expr' = foldr addLetLoc expr constrs' addLetLoc i a = case i of - AfterConstantL lv1 v lv2 -> Ext (LetLocE lv1 (AfterConstantLE v lv2) a) - AfterVariableL lv1 v lv2 -> Ext (LetLocE lv1 (AfterVariableLE v lv2 True) a) + AfterConstantL lv1 v vs lv2 -> Ext (LetLocE lv1 (AfterConstantLE v vs lv2) a) + AfterVariableL lv1 v vs lv2 -> Ext (LetLocE lv1 (AfterVariableLE v vs 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 @@ -404,7 +407,7 @@ inferExp' ddefs env exp bound dest= _ -> error "bindAllLocations: Not a packed type" a' = subst v1 (VarE v') a in LetE (v',[],copyRetTy, AppE f lvs [VarE v1]) $ - Ext (LetLocE lv1 (AfterVariableLE v' lv2 True) a') + Ext (LetLocE lv1 (AfterVariableLE v' [] lv2 True) a') in do res <- inferExp ddefs env exp dest (e,ty,cs) <- bindAllLocations res @@ -510,7 +513,7 @@ inferExp ddefs env@FullEnv{dataDefs} ex0 dest = lv2' <- finalLocVar lv2 if lv' == lv1' then do (bod',ty',cs') <- bindImmediateDependentLoc lv (bod,ty,cs) - let bod'' = Ext (LetLocE lv1' (AfterConstantLE 1 lv2') bod') + let bod'' = Ext (LetLocE lv1' (AfterConstantLE 1 [] lv2') bod') return (bod'',ty',cs') else do (bod',ty',cs') <- bindImmediateDependentLoc lv (bod,ty,cs) return (bod',ty',(AfterTagL lv1 lv2):cs') @@ -526,21 +529,22 @@ inferExp ddefs env@FullEnv{dataDefs} ex0 dest = handleTrailingBindLoc v res = do (e,ty,cs) <- bindAfterLoc v res case e of - (Ext (LetLocE lv1 (AfterVariableLE v lv2 True) e)) -> + (Ext (LetLocE lv1 (AfterVariableLE v [] lv2 True) e)) -> do (e',ty',cs') <- bindTrivialAfterLoc lv1 (e,ty,cs) - return (Ext (LetLocE lv1 (AfterVariableLE v lv2 True) e'), ty', cs') + return (Ext (LetLocE lv1 (AfterVariableLE v [] lv2 True) e'), ty', cs') _ -> return (e,ty,cs) -- Should this signal an error instead of silently returning? -- | 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 - AfterVariableL lv1 v' lv2 -> + AfterVariableL lv1 v' vs lv2 -> if v == v' then do lv1' <- finalLocVar lv1 lv2' <- finalLocVar lv2 - let res' = (Ext (LetLocE lv1' (AfterVariableLE v lv2 True) e), ty, cs) + let res' = (Ext (LetLocE lv1' (AfterVariableLE v vs lv2 True) e), ty, cs) res'' <- bindAfterLoc v res' return res'' else do (e',ty',cs') <- bindAfterLoc v (e,ty,cs) @@ -555,7 +559,7 @@ inferExp ddefs env@FullEnv{dataDefs} ex0 dest = copyRetTy = case arrOut arrty of PackedTy _ loc -> substLoc (M.singleton loc lv2) (arrOut arrty) _ -> error "bindAfterLoc: Not a packed type" - let res' = (LetE (v',[],copyRetTy,AppE f lvs [VarE v1]) $ Ext (LetLocE lv1' (AfterVariableLE v' lv2' True) e), ty, cs) + let res' = (LetE (v',[],copyRetTy,AppE f lvs [VarE v1]) $ Ext (LetLocE lv1' (AfterVariableLE v' [] lv2' True) e), ty, cs) res'' <- bindAfterLoc v res' return res'' else do (e',ty',cs') <- bindAfterLoc v (e,ty,cs) @@ -585,16 +589,16 @@ inferExp ddefs env@FullEnv{dataDefs} ex0 dest = lv' <- finalLocVar lv if lv2' == lv' then do (e',ty',cs') <- bindTrivialAfterLoc lv1 (e,ty,cs) - return (Ext (LetLocE lv1' (AfterConstantLE 1 lv2') e'), ty', cs') + return (Ext (LetLocE lv1' (AfterConstantLE 1 [] lv2') e'), ty', cs') else do (e',ty',cs') <- bindTrivialAfterLoc lv (e,ty,cs) return (e',ty',c:cs') - AfterConstantL lv1 v lv2 -> + AfterConstantL lv1 v vs lv2 -> do lv1' <- finalLocVar lv1 lv2' <- finalLocVar lv2 lv' <- finalLocVar lv if lv2' == lv' then do (e',ty',cs') <- bindTrivialAfterLoc lv1 (e,ty,cs) - return (Ext (LetLocE lv1' (AfterConstantLE v lv2') e'), ty', cs') + return (Ext (LetLocE lv1' (AfterConstantLE v vs lv2') e'), ty', cs') else do (e',ty',cs') <- bindTrivialAfterLoc lv (e,ty,cs) return (e',ty',c:cs') _ -> do (e',ty',cs') <- bindTrivialAfterLoc lv (e,ty,cs) @@ -777,11 +781,12 @@ inferExp ddefs 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. -} let afterVar :: (DCArg, Maybe LocVar, Maybe LocVar) -> Maybe Constraint afterVar ((ArgVar v), (Just loc1), (Just loc2)) = - Just $ AfterVariableL loc1 v loc2 + Just $ AfterVariableL loc1 v [] loc2 afterVar ((ArgFixed s), (Just loc1), (Just loc2)) = - Just $ AfterConstantL loc1 s loc2 + Just $ AfterConstantL loc1 s [] loc2 afterVar ((ArgCopy v v' f lvs), (Just loc1), (Just loc2)) = Just $ AfterCopyL loc1 v v' loc2 f lvs afterVar _ = Nothing @@ -1297,12 +1302,12 @@ finishExp e = e1' <- finishExp e1 loc' <- finalLocVar loc lex' <- case lex of - AfterConstantLE i lv -> do + AfterConstantLE i irst lv -> do lv' <- finalLocVar lv - return $ AfterConstantLE i lv' - AfterVariableLE v lv b -> do + return $ AfterConstantLE i irst lv' + AfterVariableLE v vs lv b -> do lv' <- finalLocVar lv - return $ AfterVariableLE v lv' b + return $ AfterVariableLE v vs lv' b oth -> return oth return $ Ext (LetLocE loc' lex' e1') Ext (L2.AddFixed cur i) -> pure $ Ext (L2.AddFixed cur i) @@ -1418,8 +1423,8 @@ cleanExp e = Ext (LetLocE loc lex e) -> let (e',s') = cleanExp e in if S.member loc s' then let ls = case lex of - AfterConstantLE _i lv -> [lv] - AfterVariableLE _v lv _ -> [lv] + AfterConstantLE _i _irst lv -> [lv] + AfterVariableLE _v _vrst lv _ -> [lv] oth -> [] in (Ext (LetLocE loc lex e'), S.delete loc $ S.union s' $ S.fromList ls) @@ -1555,7 +1560,7 @@ moveProjsAfterSync sv ex = case sv of noAfterLoc :: LocVar -> [Constraint] -> [Constraint] -> TiM Bool noAfterLoc lv fcs (c:cs) = case c of - AfterVariableL lv1 v lv2 -> + AfterVariableL lv1 v vs lv2 -> do lv2' <- finalLocVar lv2 lv' <- finalLocVar lv if lv' == lv2' then return False else noAfterLoc lv fcs cs @@ -1568,7 +1573,7 @@ noAfterLoc lv fcs (c:cs) = -- b2 <- noAfterLoc lv1 fcs fcs -- return (b1 && b2) else noAfterLoc lv fcs cs - AfterConstantL lv1 v lv2 -> + AfterConstantL lv1 v vs lv2 -> do lv2' <- finalLocVar lv2 lv' <- finalLocVar lv if lv' == lv2' then return False else noAfterLoc lv fcs cs @@ -1578,11 +1583,11 @@ noAfterLoc _ _ [] = return True noBeforeLoc :: LocVar -> [Constraint] -> TiM Bool noBeforeLoc lv (c:cs) = case c of - AfterVariableL lv1 v lv2 -> + AfterVariableL lv1 v vs lv2 -> do lv1' <- finalLocVar lv1 lv' <- finalLocVar lv if lv' == lv1' then return False else noBeforeLoc lv cs - AfterConstantL lv1 v lv2 -> + AfterConstantL lv1 v vs lv2 -> do lv1' <- finalLocVar lv1 lv' <- finalLocVar lv if lv' == lv1' then return False else noBeforeLoc lv cs diff --git a/gibbon-compiler/src/Gibbon/Passes/ParAlloc.hs b/gibbon-compiler/src/Gibbon/Passes/ParAlloc.hs index 271f016be..67a4cd4c2 100644 --- a/gibbon-compiler/src/Gibbon/Passes/ParAlloc.hs +++ b/gibbon-compiler/src/Gibbon/Passes/ParAlloc.hs @@ -141,7 +141,8 @@ parAllocExp ddefs fundefs env2 reg_env after_env mb_parent_id pending_binds spaw (\acc b -> case b of PVar vbnd -> mkLets [vbnd] acc - PAfter (loc1, (w, loc2)) -> Ext $ LetLocE loc1 (AfterVariableLE w loc2 False) $ 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 @@ -227,7 +228,7 @@ parAllocExp ddefs fundefs env2 reg_env after_env mb_parent_id pending_binds spaw LetLocE loc locexp bod -> do case locexp of -- Binding is swallowed, and it's continuation allocates in a fresh region. - AfterVariableLE v loc2 True | S.member v spawned -> do + AfterVariableLE v vs loc2 True | S.member v spawned -> do let (Just parent_id) = mb_parent_id cont_id <- gensym "cont_id" r <- gensym "rafter" @@ -251,24 +252,24 @@ parAllocExp ddefs fundefs env2 reg_env after_env mb_parent_id pending_binds spaw LetE (not_stolen, [], BoolTy, PrimAppE EqIntP [VarE cont_id, VarE parent_id]) $ IfE (VarE not_stolen) (Ext $ LetAvail [v] $ - Ext $ LetLocE loc (AfterVariableLE v loc2 False) bod2) -- don't allocate in a fresh region + Ext $ LetLocE loc (AfterVariableLE v vs loc2 False) bod2) -- don't allocate in a fresh region (Ext $ LetParRegionE newreg Undefined Nothing $ Ext $ LetLocE (singleLocVar newloc) (StartOfRegionLE newreg) bod1) else pure $ Ext $ LetParRegionE newreg Undefined Nothing $ Ext $ LetLocE (singleLocVar newloc) (StartOfRegionLE newreg) bod1 -- Binding is swallowed, but no fresh region is created. This can brought back safely after a sync. - AfterVariableLE v loc2 True | not (S.member loc2 boundlocs) || not (S.member (singleLocVar v) boundlocs) -> do + AfterVariableLE v _ loc2 True | not (S.member loc2 boundlocs) || not (S.member (singleLocVar v) boundlocs) -> do let pending_binds' = PAfter (loc, (v, loc2)) : pending_binds reg = reg_env # loc2 reg_env' = M.insert loc reg reg_env parAllocExp ddefs fundefs env2 reg_env' after_env mb_parent_id pending_binds' spawned boundlocs region_on_spawn bod - AfterVariableLE v loc2 True | S.member loc2 boundlocs && S.member (singleLocVar v) boundlocs -> do + AfterVariableLE v vs loc2 True | S.member loc2 boundlocs && S.member (singleLocVar v) boundlocs -> do let reg = reg_env # loc2 reg_env' = M.insert loc reg reg_env boundlocs'= S.insert loc boundlocs bod' <- parAllocExp ddefs fundefs env2 reg_env' after_env mb_parent_id pending_binds spawned boundlocs' region_on_spawn bod - pure $ Ext $ LetLocE loc (AfterVariableLE v loc2 False) bod' + pure $ Ext $ LetLocE loc (AfterVariableLE v vs loc2 False) bod' FreeLE -> do let boundlocs'= S.insert loc boundlocs @@ -279,8 +280,8 @@ parAllocExp ddefs fundefs env2 reg_env after_env mb_parent_id pending_binds spaw let reg = case locexp of StartOfRegionLE r -> regionToVar r InRegionLE r -> regionToVar r - AfterConstantLE _ lc -> reg_env # lc - AfterVariableLE _ lc _ -> reg_env # lc + AfterConstantLE _ _ lc -> reg_env # lc + AfterVariableLE _ _ lc _ -> reg_env # lc FromEndLE lc -> reg_env # lc reg_env' = M.insert loc reg reg_env boundlocs'= S.insert loc boundlocs @@ -361,8 +362,8 @@ substLocInExp mp ex1 = go2 lexp = case lexp of StartOfRegionLE{} -> lexp - AfterConstantLE i loc -> AfterConstantLE i (sub loc) - AfterVariableLE i loc b -> AfterVariableLE i (sub loc) b + AfterConstantLE i irst loc -> AfterConstantLE i irst (sub loc) + AfterVariableLE i irst loc b -> AfterVariableLE i irst (sub loc) b InRegionLE{} -> lexp FreeLE -> lexp FromEndLE loc -> FromEndLE (sub loc) diff --git a/gibbon-compiler/src/Gibbon/Passes/RegionsInwards.hs b/gibbon-compiler/src/Gibbon/Passes/RegionsInwards.hs index 2dae01b26..c4506c6b9 100644 --- a/gibbon-compiler/src/Gibbon/Passes/RegionsInwards.hs +++ b/gibbon-compiler/src/Gibbon/Passes/RegionsInwards.hs @@ -80,7 +80,7 @@ placeRegionInwards env scopeSet ex = newEnv = M.insert myKey' valList' tempDict in placeRegionInwards newEnv scopeSet rhs --recurse on rhs using the newenv - AfterConstantLE _ loc' -> do --In case statement, actual match = AfterConstantLE integralVal loc' + AfterConstantLE _ _ loc' -> do --In case statement, actual match = AfterConstantLE integralVal loc' let keyList' = M.keys env key' = F.find (S.member loc') keyList' in case key' of @@ -97,7 +97,7 @@ placeRegionInwards env scopeSet ex = newEnv = M.insert myKey' valList' tempDict in placeRegionInwards newEnv scopeSet rhs - AfterVariableLE _ loc' _ -> do --In case statement, actual match = AfterVariableLE variable loc' boolVal + AfterVariableLE _ _ loc' _ -> do --In case statement, actual match = AfterVariableLE variable loc' boolVal let keyList' = M.keys env key' = F.find (S.member loc') keyList' in case key' of @@ -309,7 +309,7 @@ freeVars ex = case ex of LetLocE _ phs rhs -> case phs of StartOfRegionLE _ -> freeVars rhs - AfterConstantLE _ _ -> freeVars rhs + AfterConstantLE _ _ _ -> freeVars rhs AfterVariableLE{} -> freeVars rhs InRegionLE _ -> freeVars rhs FromEndLE _ -> freeVars rhs diff --git a/gibbon-compiler/src/Gibbon/Passes/RemoveCopies.hs b/gibbon-compiler/src/Gibbon/Passes/RemoveCopies.hs index e6e892be7..fe4c4b082 100644 --- a/gibbon-compiler/src/Gibbon/Passes/RemoveCopies.hs +++ b/gibbon-compiler/src/Gibbon/Passes/RemoveCopies.hs @@ -86,8 +86,8 @@ removeCopiesExp ddefs fundefs lenv env2 ex = let reg = case rhs of StartOfRegionLE r -> regionToVar r InRegionLE r -> regionToVar r - AfterConstantLE _ lc -> lenv # lc - AfterVariableLE _ lc _ -> lenv # lc + AfterConstantLE _ _ lc -> lenv # lc + AfterVariableLE _ _ lc _ -> lenv # lc FromEndLE lc -> lenv # lc -- TODO: This needs to be fixed Ext <$> LetLocE loc rhs <$> removeCopiesExp ddefs fundefs (M.insert loc reg lenv) env2 bod diff --git a/gibbon-compiler/src/Gibbon/Passes/ReorderScalarWrites.hs b/gibbon-compiler/src/Gibbon/Passes/ReorderScalarWrites.hs index 35125d03f..6054ede36 100644 --- a/gibbon-compiler/src/Gibbon/Passes/ReorderScalarWrites.hs +++ b/gibbon-compiler/src/Gibbon/Passes/ReorderScalarWrites.hs @@ -108,8 +108,8 @@ writeOrderMarkers (Prog ddefs fundefs mainExp) = do let reg = case rhs of L2.StartOfRegionLE r -> r L2.InRegionLE r -> r - L2.AfterConstantLE _ lc -> reg_env # lc - L2.AfterVariableLE _ lc _ -> reg_env # lc + L2.AfterConstantLE _ _ lc -> reg_env # lc + L2.AfterVariableLE _ _ lc _ -> reg_env # lc L2.FromEndLE lc -> reg_env # lc reg_env' = M.insert loc reg reg_env case M.lookup reg alloc_env of diff --git a/gibbon-compiler/src/Gibbon/Passes/RouteEnds.hs b/gibbon-compiler/src/Gibbon/Passes/RouteEnds.hs index b0b425686..19d39917b 100644 --- a/gibbon-compiler/src/Gibbon/Passes/RouteEnds.hs +++ b/gibbon-compiler/src/Gibbon/Passes/RouteEnds.hs @@ -326,7 +326,7 @@ routeEnds prg@Prog{ddefs,fundefs,mainExp} = do l2 <- gensym "jump" let l2loc = singleLocVar l2 eor' = mkEnd l1 l2loc eor - e' = Ext $ LetLocE l2loc (AfterConstantLE 1 l1) e + e' = Ext $ LetLocE l2loc (AfterConstantLE 1 [] l1) e e'' <- exp fns retlocs eor' lenv (M.insert l1 l2loc lenv) env2 e' return (dc, vls, e'') Nothing -> error $ "Failed to find " ++ sdoc x ++ " in " ++ sdoc lenv @@ -353,7 +353,7 @@ routeEnds prg@Prog{ddefs,fundefs,mainExp} = do let l2loc = singleLocVar l2 eor' = mkEnd l1 l2loc eor (Just jump) = L1.sizeOfTy ty - e' = Ext $ LetLocE l2loc (AfterConstantLE jump l1) e + e' = Ext $ LetLocE l2loc (AfterConstantLE jump [] l1) e return (eor', e') vars = L.map fst vls varsToLocs = L.map singleLocVar vars @@ -545,7 +545,7 @@ routeEnds prg@Prog{ddefs,fundefs,mainExp} = do scalar_witnesses = go la [] bind_witnesses bod ls = L.foldr (\(v,w,sz) acc -> - Ext $ LetLocE v (AfterConstantLE sz w) acc) + Ext $ LetLocE v (AfterConstantLE sz [] w) acc) bod ls bod' = bind_witnesses e scalar_witnesses bod'' = Ext (LetLocE la (FromEndLE l2) bod') diff --git a/gibbon-compiler/src/Gibbon/Passes/Simplifier.hs b/gibbon-compiler/src/Gibbon/Passes/Simplifier.hs index e32cef7b4..7ff486223 100644 --- a/gibbon-compiler/src/Gibbon/Passes/Simplifier.hs +++ b/gibbon-compiler/src/Gibbon/Passes/Simplifier.hs @@ -134,13 +134,14 @@ 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)) - LetLocE loc (AfterConstantLE i loc2) bod -> + {- TODO VS: fix for SOA case -} + LetLocE loc (AfterConstantLE i irst loc2) bod -> case (M.lookup loc2 env) of Nothing -> - Ext $ LetLocE loc (AfterConstantLE i loc2) $ + Ext $ LetLocE loc (AfterConstantLE i irst loc2) $ go (M.insert loc (loc2,i) env) bod Just (loc3,j) -> - Ext $ LetLocE loc (AfterConstantLE (i+j) loc3) $ + Ext $ LetLocE loc (AfterConstantLE (i+j) irst loc3) $ go (M.insert loc (loc3,i+j) env) bod LetLocE loc rhs bod -> Ext (LetLocE loc rhs (go env bod)) LetAvail vars bod -> Ext (LetAvail vars (go env bod)) @@ -198,8 +199,8 @@ simplifyLocBinds only_cse (Prog ddefs fundefs mainExp) = do LetParRegionE reg sz ty bod -> Ext (LetParRegionE reg sz ty (go0 env1 env2 bod)) LetLocE loc rhs bod -> let rhs' = case rhs of - AfterConstantLE i loc2 -> AfterConstantLE i (substloc env2 loc2) - AfterVariableLE v loc2 b -> AfterVariableLE v (substloc env2 loc2) b + AfterConstantLE i irst loc2 -> AfterConstantLE i irst (substloc env2 loc2) + AfterVariableLE v vrst loc2 b -> AfterVariableLE v vrst (substloc env2 loc2) b _ -> rhs in case M.lookup rhs' env1 of Nothing -> Ext (LetLocE loc rhs' (go0 (M.insert rhs' loc env1) env2 bod)) diff --git a/gibbon-compiler/src/Gibbon/Passes/ThreadRegions.hs b/gibbon-compiler/src/Gibbon/Passes/ThreadRegions.hs index 8ee1c5af6..81bd3a68a 100644 --- a/gibbon-compiler/src/Gibbon/Passes/ThreadRegions.hs +++ b/gibbon-compiler/src/Gibbon/Passes/ThreadRegions.hs @@ -455,8 +455,8 @@ threadRegionsExp ddefs fundefs fnLocArgs renv env2 lfenv rlocs_env wlocs_env pkd let reg = case rhs of StartOfRegionLE r -> regionToVar r InRegionLE r -> regionToVar r - AfterConstantLE _ lc -> renv # (toLocVar lc) - AfterVariableLE _ lc _ -> renv # (toLocVar lc) + AfterConstantLE _ _ lc -> renv # (toLocVar lc) + AfterVariableLE _ _ lc _ -> renv # (toLocVar lc) FromEndLE lc -> renv # (toLocVar lc) wlocs_env' = M.insert loc hole_tycon wlocs_env region_locs1 = case rhs of diff --git a/gibbon-compiler/src/Gibbon/Pretty.hs b/gibbon-compiler/src/Gibbon/Pretty.hs index dd742fb21..2ca52ac4b 100644 --- a/gibbon-compiler/src/Gibbon/Pretty.hs +++ b/gibbon-compiler/src/Gibbon/Pretty.hs @@ -435,10 +435,21 @@ 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 irst loc -> case irst of + {- AoS operation -} + [] -> lparen <> pprint loc <+> text "+" <+> int i <> rparen + {-VS: for some reason i cannot pattern match on loc here!!-} + --_ -> case loc of + -- Single x -> error "This should be an SoA loc!" + -- SoA dataBufLoc fieldLocs -> error "TODO: Pretty print for SoA operation not implemented yet." + AfterVariableLE v vrst loc b -> case vrst of + [] -> if b + then text "fresh" <> (parens $ pprint loc <+> text "+" <+> doc v) + else parens $ pprint loc <+> text "+" <+> doc v + --_ -> case loc of + -- Single x -> error "This should be an SoA loc!" + -- SoA dataBufLoc fieldLocs -> error "TODO: Pretty print for SoA operation not implemented yet." + InRegionLE r -> lparen <> text "inRegion" <+> text (sdoc r) <> rparen FromEndLE loc -> lparen <> text "fromEnd" <+> pprint loc <> rparen FreeLE -> lparen <> text "free" <> rparen From dc0f88e2970e9838cfd783ee63a7922304866dc5 Mon Sep 17 00:00:00 2001 From: Vidush Singhal Date: Thu, 5 Dec 2024 13:52:47 -0500 Subject: [PATCH 09/11] revert change to L2 IR for AfterConstant and AfterVariable --- gibbon-compiler/src/Gibbon/L2/Examples.hs | 110 +++++++++--------- gibbon-compiler/src/Gibbon/L2/Interp.hs | 4 +- gibbon-compiler/src/Gibbon/L2/Syntax.hs | 24 ++-- gibbon-compiler/src/Gibbon/L2/Typecheck.hs | 4 +- gibbon-compiler/src/Gibbon/NewL2/FromOldL2.hs | 4 +- gibbon-compiler/src/Gibbon/NewL2/Syntax.hs | 8 +- gibbon-compiler/src/Gibbon/Passes/AddRAN.hs | 4 +- .../src/Gibbon/Passes/AddTraversals.hs | 4 +- .../src/Gibbon/Passes/CalculateBounds.hs | 4 +- .../src/Gibbon/Passes/Cursorize.hs | 8 +- .../src/Gibbon/Passes/FindWitnesses.hs | 8 +- .../src/Gibbon/Passes/FollowPtrs.hs | 2 +- .../src/Gibbon/Passes/InferLocations.hs | 106 +++++++++++------ gibbon-compiler/src/Gibbon/Passes/ParAlloc.hs | 20 ++-- .../src/Gibbon/Passes/RegionsInwards.hs | 6 +- .../src/Gibbon/Passes/RemoveCopies.hs | 4 +- .../src/Gibbon/Passes/ReorderScalarWrites.hs | 4 +- .../src/Gibbon/Passes/RouteEnds.hs | 6 +- .../src/Gibbon/Passes/Simplifier.hs | 10 +- .../src/Gibbon/Passes/ThreadRegions.hs | 4 +- gibbon-compiler/src/Gibbon/Pretty.hs | 19 +-- 21 files changed, 191 insertions(+), 172 deletions(-) diff --git a/gibbon-compiler/src/Gibbon/L2/Examples.hs b/gibbon-compiler/src/Gibbon/L2/Examples.hs index b1c5b5edb..5e931cc22 100644 --- a/gibbon-compiler/src/Gibbon/L2/Examples.hs +++ b/gibbon-compiler/src/Gibbon/L2/Examples.hs @@ -72,10 +72,10 @@ add1FunBod = CaseE (VarE "tr1") VarE "lf8") , ("Node", [("x9",(Single "l10")),("y11",(Single "l12"))], - Ext $ LetLocE (Single "l13") (AfterConstantLE 1 [] (Single "lout4")) $ + Ext $ LetLocE (Single "l13") (AfterConstantLE 1 (Single "lout4")) $ LetE ("x14",[],PackedTy "Tree" (Single "l13"), AppE "add1" [(Single "l10"),(Single "l13")] [VarE "x9"]) $ - Ext $ LetLocE (Single "l15") (AfterVariableLE "x14" [] (Single "l13") True) $ + Ext $ LetLocE (Single "l15") (AfterVariableLE "x14" (Single "l13") True) $ LetE ("y16",[],PackedTy "Tree" (Single "l15"), AppE "add1" [(Single "l12"),(Single "l15")] [VarE "y11"]) $ LetE ("z17",[],PackedTy "Tree" (Single "lout4"), DataConE (Single "lout4") "Node" [ VarE "x14" , VarE "y16"]) $ @@ -85,10 +85,10 @@ add1FunBod = CaseE (VarE "tr1") add1MainExp :: Exp2 add1MainExp = Ext $ LetRegionE (VarR "r99") Undefined Nothing $ Ext $ LetLocE (Single "l100") (StartOfRegionLE (VarR "r99")) $ - Ext $ LetLocE (Single "l101") (AfterConstantLE 1 [] (Single "l100")) $ + Ext $ LetLocE (Single "l101") (AfterConstantLE 1 (Single "l100")) $ LetE ("x102",[],PackedTy "Tree" (Single "l101"), DataConE (Single "l101") "Leaf" [LitE 1]) $ - Ext $ LetLocE (Single "l103") (AfterVariableLE "x102" [] (Single "l101") True) $ + Ext $ LetLocE (Single "l103") (AfterVariableLE "x102" (Single "l101") True) $ LetE ("y104",[],PackedTy "Tree" (Single "l103"), DataConE (Single "l103") "Leaf" [LitE 2]) $ LetE ("z105",[],PackedTy "Tree" (Single "l100"), @@ -124,10 +124,10 @@ leafProg = Prog ddtree M.empty (Just (leafMainExp, PackedTy "Tree" (Single "l151 nodeMainExp :: Exp2 nodeMainExp = Ext $ LetRegionE (VarR "r155") Undefined Nothing $ Ext $ LetLocE (Single "l156") (StartOfRegionLE (VarR "r155")) $ - Ext $ LetLocE (Single "l157") (AfterConstantLE 1 [] (Single "l156")) $ + Ext $ LetLocE (Single "l157") (AfterConstantLE 1 (Single "l156")) $ LetE ("x158",[],PackedTy "Tree" (Single "l157"), DataConE (Single "l157") "Leaf" [LitE 1]) $ - Ext $ LetLocE (Single "l159") (AfterVariableLE "x158" [] (Single "l157") True) $ + Ext $ LetLocE (Single "l159") (AfterVariableLE "x158" (Single "l157") True) $ LetE ("y160",[],PackedTy "Tree" (Single "l159"), DataConE (Single "l159") "Leaf" [LitE 2]) $ LetE ("z161",[],PackedTy "Tree" (Single "l156"), @@ -178,10 +178,10 @@ copyTreeFun = FunDef "copyTree" [ "tr22"] copyFunTy copyBod (FunMeta NotRec NoIn VarE "n28") , ("Node", [("x29",(Single "lx30")),("y31",(Single "ly32"))], - Ext $ LetLocE (Single "lx33") (AfterConstantLE 1 [] (Single "lout25")) $ + Ext $ LetLocE (Single "lx33") (AfterConstantLE 1 (Single "lout25")) $ LetE ("x34", [], PackedTy "Tree" (Single "lx33"), AppE "copyTree" [(Single "lx30"),(Single "lx33")] [VarE "x29"]) $ - Ext $ LetLocE (Single "ly35") (AfterVariableLE "x34" [] (Single "lx33") True) $ + Ext $ LetLocE (Single "ly35") (AfterVariableLE "x34" (Single "lx33") True) $ LetE ("y36", [], PackedTy "Tree" (Single "ly35"), AppE "copyTree" [(Single "ly32"),(Single "ly35")] [VarE "y31"]) $ DataConE (Single "lout25") "Node" [VarE "x34", VarE "y36"]) @@ -190,10 +190,10 @@ copyTreeFun = FunDef "copyTree" [ "tr22"] copyFunTy copyBod (FunMeta NotRec NoIn copyTreeMainExp :: Exp2 copyTreeMainExp = Ext $ LetRegionE (VarR "r200") Undefined Nothing $ Ext $ LetLocE (Single "l201") (StartOfRegionLE (VarR "r200")) $ - Ext $ LetLocE (Single "l202") (AfterConstantLE 1 [] (Single "l201")) $ + Ext $ LetLocE (Single "l202") (AfterConstantLE 1 (Single "l201")) $ LetE ("x203",[],PackedTy "Tree" (Single "l202"), DataConE (Single "l202") "Leaf" [LitE 1]) $ - Ext $ LetLocE (Single "r204") (AfterVariableLE "x203" [] (Single "l202") True) $ + Ext $ LetLocE (Single "r204") (AfterVariableLE "x203" (Single "l202") True) $ LetE ("y205",[],PackedTy "Tree" (Single "r204"), DataConE (Single "r204") "Leaf" [LitE 2]) $ LetE ("z206",[],PackedTy "Tree" (Single "l201"), @@ -240,10 +240,10 @@ copyOnId1Prog = Prog ddtree funs $ Just (copyOnId1MainExp, PackedTy "Tree" (Sing copyOnId1MainExp :: Exp2 copyOnId1MainExp = Ext $ LetRegionE (VarR "r220") Undefined Nothing $ Ext $ LetLocE (Single "l221") (StartOfRegionLE (VarR "r220")) $ - Ext $ LetLocE (Single "l222") (AfterConstantLE 1 [] (Single "l221")) $ + Ext $ LetLocE (Single "l222") (AfterConstantLE 1 (Single "l221")) $ LetE ("l223",[],PackedTy "Tree" (Single "l222"), DataConE (Single "l222") "Leaf" [LitE 1]) $ - Ext $ LetLocE (Single "l224") (AfterVariableLE "l223" [] (Single "l222") True) $ + Ext $ LetLocE (Single "l224") (AfterVariableLE "l223" (Single "l222") True) $ LetE ("l225",[],PackedTy "Tree" (Single "l224"), DataConE (Single "l224") "Leaf" [LitE 2]) $ LetE ("z226",[],PackedTy "Tree" (Single "l221"), @@ -331,10 +331,10 @@ leftmostBod = CaseE (VarE "t111") leftmostMainExp :: Exp2 leftmostMainExp = Ext $ LetRegionE (VarR "r122") Undefined Nothing $ Ext $ LetLocE (Single "l123") (StartOfRegionLE (VarR "r122")) $ - Ext $ LetLocE (Single "l124") (AfterConstantLE 1 [] (Single "l123")) $ + Ext $ LetLocE (Single "l124") (AfterConstantLE 1 (Single "l123")) $ LetE ("x125",[],PackedTy "Tree" (Single "l124"), DataConE (Single "l124") "Leaf" [LitE 1]) $ - Ext $ LetLocE (Single "l126") (AfterVariableLE "x125" [] (Single "l124") True) $ + Ext $ LetLocE (Single "l126") (AfterVariableLE "x125" (Single "l124") True) $ LetE ("y128",[],PackedTy "Tree" (Single "l126"), DataConE (Single "l126") "Leaf" [LitE 2]) $ LetE ("z127",[],PackedTy "Tree" (Single "l123"), @@ -376,10 +376,10 @@ rightmostBod = CaseE (VarE "t242") rightmostMainExp :: Exp2 rightmostMainExp = Ext $ LetRegionE (VarR "r253") Undefined Nothing $ Ext $ LetLocE (Single "l254") (StartOfRegionLE (VarR "r253")) $ - Ext $ LetLocE (Single "l255") (AfterConstantLE 1 [] (Single "l254")) $ + Ext $ LetLocE (Single "l255") (AfterConstantLE 1 (Single "l254")) $ LetE ("x256",[],PackedTy "Tree" (Single "l255"), DataConE (Single "l255") "Leaf" [LitE 1]) $ - Ext $ LetLocE (Single "l257") (AfterVariableLE "x256" [] (Single "l255") True) $ + Ext $ LetLocE (Single "l257") (AfterVariableLE "x256" (Single "l255") True) $ LetE ("y258",[],PackedTy "Tree" (Single "l257"), DataConE (Single "l257") "Leaf" [LitE 2]) $ LetE ("z259",[],PackedTy "Tree" (Single "l254"), @@ -439,10 +439,10 @@ buildTreeFun = FunDef "buildTree" [ "i270"] buildTreeTy buildTreeBod (FunMeta Re IfE (VarE "b279") (DataConE (Single "lout272") "Leaf" [LitE 1]) (LetE ("i273",[], IntTy, PrimAppE SubP [VarE "i270", LitE 1]) $ - Ext $ LetLocE (Single "l274") (AfterConstantLE 1 [] (Single "lout272")) $ + Ext $ LetLocE (Single "l274") (AfterConstantLE 1 (Single "lout272")) $ LetE ("x275",[],PackedTy "Tree" (Single "l274"), AppE "buildTree" [(Single "l274")] [VarE "i273"]) $ - Ext $ LetLocE (Single "l276") (AfterVariableLE "x275" [] (Single "l274") True) $ + Ext $ LetLocE (Single "l276") (AfterVariableLE "x275" (Single "l274") True) $ LetE ("y277",[],PackedTy "Tree" (Single "l276"), AppE "buildTree" [(Single "l276")] [VarE "i273"]) $ LetE ("a278",[],PackedTy "Tree" (Single "lout272"), @@ -520,12 +520,12 @@ buildTreeSumFun = FunDef "buildTreeSum" [ "i302"] buildTreeSumTy buildTreeSumBod MkProdE [LitE 1, VarE "c316"]) $ VarE "t317") (LetE ("i303",[], IntTy, PrimAppE SubP [VarE "i302", LitE 1]) $ - Ext $ LetLocE (Single "l304") (AfterConstantLE 1 [] (Single "lout301")) $ + Ext $ LetLocE (Single "l304") (AfterConstantLE 1 (Single "lout301")) $ LetE ("t318",[],ProdTy [IntTy, PackedTy "Tree" (Single "l304")], AppE "buildTreeSum" [(Single "l304")] [VarE "i303"]) $ LetE ("i309",[],IntTy, ProjE 0 (VarE "t318")) $ LetE ("x305",[],PackedTy "Tree" (Single "l304"), ProjE 1 (VarE "t318")) $ - Ext $ LetLocE (Single "l306") (AfterVariableLE "x305" [] (Single "l304") True) $ + Ext $ LetLocE (Single "l306") (AfterVariableLE "x305" (Single "l304") True) $ LetE ("t319",[],ProdTy [IntTy, PackedTy "Tree" (Single "l306")], AppE "buildTreeSum" [(Single "l306")] [VarE "i303"]) $ LetE ("i310",[],IntTy, ProjE 0 (VarE "t319")) $ @@ -614,7 +614,7 @@ printTupMainExp2 = Ext $ LetRegionE (VarR "r400") Undefined Nothing $ Ext $ LetLocE (Single "l401") (StartOfRegionLE (VarR "r400")) $ LetE ("x402",[], PackedTy "Tree" (Single "l401"), AppE "buildTree" [(Single "l401")] [LitE 2]) $ - Ext $ LetLocE (Single "l403") (AfterVariableLE "x402" [] (Single "l401") True) $ + Ext $ LetLocE (Single "l403") (AfterVariableLE "x402" (Single "l401") True) $ LetE ("y404",[], PackedTy "Tree" (Single "l403"), AppE "buildTree" [(Single "l403")] [LitE 1]) $ LetE ("z405",[], ProdTy [PackedTy "Tree" (Single "l401"), PackedTy "Tree" (Single "l403")], @@ -673,13 +673,13 @@ addTreesFun = FunDef "addTrees" [ "trees354"] addTreesTy addTreesBod (FunMeta Re ("Node", [("x360",(Single "l361")), ("y362",(Single "l363"))], CaseE (VarE "tree2") [("Node", [("x364",(Single "l365")), ("y366", (Single "l367"))], - Ext $ LetLocE (Single "l368") (AfterConstantLE 1 [] (Single "lout353")) $ + Ext $ LetLocE (Single "l368") (AfterConstantLE 1 (Single "lout353")) $ LetE ("tree3",[],ProdTy [PackedTy "Tree" (Single "l361"), PackedTy "Tree" (Single "l365")], MkProdE [VarE "x360", VarE "x364"]) $ LetE ("x369",[],PackedTy "Tree" (Single "l368"), AppE "addTrees" [(Single "l361"),(Single "l365"),(Single "l368")] [VarE "tree3"]) $ - Ext $ LetLocE (Single "l370") (AfterVariableLE "x369" [] (Single "l368") True) $ + Ext $ LetLocE (Single "l370") (AfterVariableLE "x369" (Single "l368") True) $ LetE ("tree4",[],ProdTy [PackedTy "Tree" (Single "l363"), PackedTy "Tree" (Single "l367")], MkProdE [VarE "y362", VarE "y366"]) $ @@ -738,13 +738,13 @@ testProdFun = FunDef "testprod" [ "tup130"] testprodTy testprodBod (FunMeta Rec VarE "tup148" ), ("Node",[("x140",(Single "l141")), ("y142",(Single "l143"))], - Ext $ LetLocE (Single "l144") (AfterConstantLE 1 [] (Single "lout133")) $ + Ext $ LetLocE (Single "l144") (AfterConstantLE 1 (Single "lout133")) $ LetE ("tup145",[], ProdTy [PackedTy "Tree" (Single "l144"), IntTy], AppE "testprod" [(Single "l141"),(Single "l144")] [MkProdE [VarE "x140", VarE "i135"]]) $ LetE ("x149",[], PackedTy "Tree" (Single "l144"), ProjE 0 (VarE "tup145")) $ - Ext $ LetLocE (Single "l146") (AfterVariableLE "x149" [] (Single "l144") True) $ + Ext $ LetLocE (Single "l146") (AfterVariableLE "x149" (Single "l144") True) $ LetE ("tup147",[], ProdTy [PackedTy "Tree" (Single "l146"), IntTy], AppE "testprod" [(Single "l143"),(Single "l146")] [MkProdE [VarE "y142", VarE "i135"]]) $ @@ -769,7 +769,7 @@ testFlattenProg = Prog M.empty (M.fromList [( "intAdd",intAddFun)]) $ Just (test testFlattenBod = Ext $ LetRegionE (VarR "_") Undefined Nothing $ Ext $ LetLocE (Single "_") (StartOfRegionLE (VarR "_")) $ - Ext $ LetLocE (Single "_") (AfterConstantLE 1 [] (Single "_")) $ + Ext $ LetLocE (Single "_") (AfterConstantLE 1 (Single "_")) $ LetE ("v170",[],IntTy, LetE ("v171",[],IntTy, AppE "intAdd" [] @@ -830,12 +830,12 @@ sumUpFun = FunDef "sumUp" [ "tr1"] sumUpFunTy sumUpFunBod (FunMeta Rec NoInline VarE "x505") , ("Inner", [("i506",(Single "l507")),("b508", (Single "l509")),("x510", (Single "l511")),("y512", (Single "l513"))], - Ext $ LetLocE (Single "l514") (AfterConstantLE 1 [] (Single "lout502")) $ - Ext $ LetLocE (Single "l550") (AfterVariableLE "i506" [] (Single "l514") True) $ - Ext $ LetLocE (Single "l551") (AfterVariableLE "b508" [] (Single "l550") True) $ + Ext $ LetLocE (Single "l514") (AfterConstantLE 1 (Single "lout502")) $ + Ext $ LetLocE (Single "l550") (AfterVariableLE "i506" (Single "l514") True) $ + Ext $ LetLocE (Single "l551") (AfterVariableLE "b508" (Single "l550") True) $ LetE ("x515",[],PackedTy "STree" (Single "l551"), AppE "sumUp" [(Single "l511"),(Single "l551")] [VarE "x510"]) $ - Ext $ LetLocE (Single "l516") (AfterVariableLE "x515" [] (Single "l551") True) $ + Ext $ LetLocE (Single "l516") (AfterVariableLE "x515" (Single "l551") True) $ LetE ("y517",[],PackedTy "STree" (Single "l516"), AppE "sumUp" [(Single "l513"),(Single "l516")] [VarE "y512"]) $ LetE ("v518",[],IntTy, AppE "valueSTree" [(Single "l551")] [VarE "x515"]) $ @@ -889,12 +889,12 @@ buildSTreeFun = FunDef "buildSTree" [ "i543"] buildSTreeTy buildSTreeBod (FunMet (LetE ("i548",[], IntTy, PrimAppE SubP [VarE "i543", LitE 1]) $ LetE ("i554",[], IntTy, LitE 0) $ LetE ("b555",[], IntTy, LitE 0) $ - Ext $ LetLocE (Single "l544") (AfterConstantLE 1 [] (Single "lout541")) $ - Ext $ LetLocE (Single "l552") (AfterVariableLE "i554" [] (Single "l544") True) $ - Ext $ LetLocE (Single "l553") (AfterVariableLE "b555" [] (Single "l552") True) $ + Ext $ LetLocE (Single "l544") (AfterConstantLE 1 (Single "lout541")) $ + Ext $ LetLocE (Single "l552") (AfterVariableLE "i554" (Single "l544") True) $ + Ext $ LetLocE (Single "l553") (AfterVariableLE "b555" (Single "l552") True) $ LetE ("x545",[],PackedTy "STree" (Single "l553"), AppE "buildSTree" [(Single "l553")] [VarE "i548"]) $ - Ext $ LetLocE (Single "l545") (AfterVariableLE "x545" [] (Single "l553") True) $ + Ext $ LetLocE (Single "l545") (AfterVariableLE "x545" (Single "l553") True) $ LetE ("y546",[],PackedTy "STree" (Single "l545"), AppE "buildSTree" [(Single "l545")] [VarE "i548"]) $ LetE ("a547",[],PackedTy "STree" (Single "lout541"), @@ -1038,12 +1038,12 @@ setEvenFun = FunDef "setEven" [ "tr570"] setEvenFunTy setEvenFunBod (FunMeta Rec VarE "x575") , ("Inner", [("i576",(Single "l577")),("b578",(Single "l579")),("x580",(Single "l581")),("y582",(Single "l583"))], - Ext $ LetLocE (Single "l584") (AfterConstantLE 1 [] (Single "lout572")) $ - Ext $ LetLocE (Single "l585") (AfterVariableLE "i576" [] (Single "l584") True) $ - Ext $ LetLocE (Single "l586") (AfterVariableLE "b578" [] (Single "l585") True) $ + Ext $ LetLocE (Single "l584") (AfterConstantLE 1 (Single "lout572")) $ + Ext $ LetLocE (Single "l585") (AfterVariableLE "i576" (Single "l584") True) $ + Ext $ LetLocE (Single "l586") (AfterVariableLE "b578" (Single "l585") True) $ LetE ("x587",[],PackedTy "STree" (Single "l586"), AppE "setEven" [(Single "l581"),(Single "l586")] [VarE "x580"]) $ - Ext $ LetLocE (Single "l588") (AfterVariableLE "x587" [] (Single "l586") True) $ + Ext $ LetLocE (Single "l588") (AfterVariableLE "x587" (Single "l586") True) $ LetE ("y589",[],PackedTy "STree" (Single "l588"), AppE "setEven" [(Single "l583"),(Single "l588")] [VarE "y582"]) $ LetE ("v590",[],IntTy, AppE "valueSTree" [(Single "l586")] [VarE "x587"]) $ @@ -1123,14 +1123,14 @@ sumUpSetEvenFun = FunDef "sumUpSetEven" [ "tr600"] sumUpSetEvenFunTy sumUpSetEve VarE "tx606") , ("Inner", [("i607",(Single "l608")),("b609", (Single "l610")),("x611", (Single "l612")),("y613", (Single "l622"))], - Ext $ LetLocE (Single "l614") (AfterConstantLE 1 [] (Single "lout602")) $ - Ext $ LetLocE (Single "l615") (AfterVariableLE "i607" [] (Single "l614") True) $ - Ext $ LetLocE (Single "l616") (AfterVariableLE "b609" [] (Single "l615") True) $ + Ext $ LetLocE (Single "l614") (AfterConstantLE 1 (Single "lout602")) $ + Ext $ LetLocE (Single "l615") (AfterVariableLE "i607" (Single "l614") True) $ + Ext $ LetLocE (Single "l616") (AfterVariableLE "b609" (Single "l615") True) $ LetE ("tx617",[], ProdTy [PackedTy "STree" (Single "l616"), IntTy], AppE "sumUpSetEven" [(Single "l612"),(Single "l616")] [VarE "x611"]) $ LetE ("x618",[],PackedTy "STree" (Single "l616"), ProjE 0 (VarE "tx617")) $ LetE ("v619",[],IntTy, ProjE 1 (VarE "tx617")) $ - Ext $ LetLocE (Single "l620") (AfterVariableLE "x618" [] (Single "l616") True) $ + Ext $ LetLocE (Single "l620") (AfterVariableLE "x618" (Single "l616") True) $ LetE ("tx621",[],ProdTy [PackedTy "STree" (Single "l620"), IntTy], AppE "sumUpSetEven" [(Single "l622"),(Single "l620")] [VarE "y613"]) $ LetE ("y623",[],PackedTy "STree" (Single "l620"), ProjE 0 (VarE "tx621")) $ @@ -1212,11 +1212,11 @@ copyExprFun = FunDef "copyExpr" [ "e700"] copyExprFunTy copyExprFunBod (FunMeta DataConE (Single "lout703") "VARREF" [VarE "v704"] ) , ("LETE", [("v706",(Single "l707")), ("rhs708", (Single "l709")), ("bod710", (Single "l711"))], - Ext $ LetLocE (Single "l712") (AfterConstantLE 1 [] (Single "lout703")) $ - Ext $ LetLocE (Single "l713") (AfterVariableLE "v706" [] (Single "l712") True) $ + Ext $ LetLocE (Single "l712") (AfterConstantLE 1 (Single "lout703")) $ + Ext $ LetLocE (Single "l713") (AfterVariableLE "v706" (Single "l712") True) $ LetE ("rhs714",[], PackedTy "Expr" (Single "l713"), AppE "copyExpr" [(Single "l709"),(Single "l713")] [VarE "rhs708"]) $ - Ext $ LetLocE (Single "l715") (AfterVariableLE "rhs714" [] (Single "l713") True) $ + Ext $ LetLocE (Single "l715") (AfterVariableLE "rhs714" (Single "l713") True) $ LetE ("bod716",[],PackedTy "Expr" (Single "l715"), AppE "copyExpr" [(Single "l711"), (Single "l715")] [VarE "bod710"]) $ LetE ("z717",[],PackedTy "Expr" (Single "lout703"), @@ -1258,13 +1258,13 @@ substFun = FunDef "subst" [ "tr653"] substFunTy substFunBod (FunMeta Rec NoInlin LetE ("b662",[],BoolTy, PrimAppE EqIntP [VarE "v656", VarE "old654"]) -- IfE (VarE "b662") - (Ext $ LetLocE (Single "l663") (AfterConstantLE 1 [] (Single "lout653")) $ - Ext $ LetLocE (Single "l664") (AfterVariableLE "v656" [] (Single "l663") True) $ + (Ext $ LetLocE (Single "l663") (AfterConstantLE 1 (Single "lout653")) $ + Ext $ LetLocE (Single "l664") (AfterVariableLE "v656" (Single "l663") True) $ LetE ("p668",[], ProdTy [IntTy, PackedTy "Expr" (Single "lin651"), PackedTy "Expr" (Single "l659")], MkProdE [VarE "old654", VarE "new655", VarE "rhs658"]) $ LetE ("rhs665",[],PackedTy "Expr" (Single "l664"), AppE "subst" [(Single "lin651"), (Single "l659"), (Single "l664")] [VarE "p668"]) $ - Ext $ LetLocE (Single "l669") (AfterVariableLE "rhs665" [] (Single "l664") True) $ + Ext $ LetLocE (Single "l669") (AfterVariableLE "rhs665" (Single "l664") True) $ LetE ("bod670",[], PackedTy "Expr" (Single "l669"), AppE "copyExpr" [(Single "l661"), (Single "l669")] [VarE "bod660"]) $ LetE ("z671",[], PackedTy "Expr" (Single "lout653"), @@ -1277,11 +1277,11 @@ substFun = FunDef "subst" [ "tr653"] substFunTy substFunBod (FunMeta Rec NoInlin substMainExp :: Exp2 substMainExp = Ext $ LetRegionE (VarR "r720") Undefined Nothing $ Ext $ LetLocE (Single "l721") (StartOfRegionLE (VarR "r720")) $ - Ext $ LetLocE (Single "l722") (AfterConstantLE 1 [] (Single "l721")) $ - Ext $ LetLocE (Single "l723") (AfterConstantLE 8 [] (Single "l722")) $ + Ext $ LetLocE (Single "l722") (AfterConstantLE 1 (Single "l721")) $ + Ext $ LetLocE (Single "l723") (AfterConstantLE 8 (Single "l722")) $ LetE ("rhs724",[], PackedTy "Expr" (Single "l723"), DataConE (Single "l723") "VARREF" [LitE 1]) $ - Ext $ LetLocE (Single "l724") (AfterVariableLE "rhs724" [] (Single "l723") True) $ + Ext $ LetLocE (Single "l724") (AfterVariableLE "rhs724" (Single "l723") True) $ LetE ("bod725",[], PackedTy "Expr" (Single "l724"), DataConE (Single "l724") "VARREF" [LitE 10]) $ LetE ("old726",[],IntTy,LitE 1) $ @@ -1293,7 +1293,7 @@ substMainExp = Ext $ LetRegionE (VarR "r720") Undefined Nothing $ DataConE (Single "l729") "VARREF" [LitE 42]) $ LetE ("p731",[],ProdTy [IntTy, PackedTy "Expr" (Single "l729"), PackedTy "Expr" (Single "l721")], MkProdE [VarE "old726", VarE "new730", VarE "z727"]) $ - Ext $ LetLocE (Single "l730") (AfterVariableLE "new730" [] (Single "l729") True) $ + Ext $ LetLocE (Single "l730") (AfterVariableLE "new730" (Single "l729") True) $ LetE ("z732",[], PackedTy "Expr" (Single "l730"), AppE "subst" [(Single "l729"), (Single "l721"), (Single "l730")] [VarE "p731"]) $ VarE "z732" @@ -1337,11 +1337,11 @@ indrBuildTreeFun = FunDef "indrBuildTree" [ "i270"] indrBuildTreeTy indrBuildTre IfE (VarE "b279") (DataConE (Single "lout272") "Leaf" [LitE 1]) (LetE ("i273",[], IntTy, PrimAppE SubP [VarE "i270", LitE 1]) $ - Ext $ LetLocE (Single "loc_indr") (AfterConstantLE 1 [] (Single "lout272")) $ - Ext $ LetLocE (Single "l274") (AfterConstantLE 8 [] (Single "loc_indr")) $ + Ext $ LetLocE (Single "loc_indr") (AfterConstantLE 1 (Single "lout272")) $ + Ext $ LetLocE (Single "l274") (AfterConstantLE 8 (Single "loc_indr")) $ LetE ("x275",[],PackedTy "Tree" (Single "l274"), AppE "indrBuildTree" [(Single "l274")] [VarE "i273"]) $ - Ext $ LetLocE (Single "l276") (AfterVariableLE "x275" [] (Single "l274") True) $ + Ext $ LetLocE (Single "l276") (AfterVariableLE "x275" (Single "l274") True) $ LetE ("y277",[],PackedTy "Tree" (Single "l276"), AppE "indrBuildTree" [(Single "l276")] [VarE "i273"]) $ LetE ("indr_cur",[],CursorTy,Ext (StartOfPkdCursor "y277")) $ diff --git a/gibbon-compiler/src/Gibbon/L2/Interp.hs b/gibbon-compiler/src/Gibbon/L2/Interp.hs index 6f7ebaa10..4d99d1e65 100644 --- a/gibbon-compiler/src/Gibbon/L2/Interp.hs +++ b/gibbon-compiler/src/Gibbon/L2/Interp.hs @@ -308,7 +308,7 @@ interpExt sizeEnv rc env ddefs fenv ext = Just _ -> go (M.insert (unwrapLocVar loc) (VLoc (regionToVar reg) 0) env) sizeEnv bod - AfterConstantLE i _ loc2 -> do + AfterConstantLE i loc2 -> do case M.lookup (unwrapLocVar loc2) env of Nothing -> error $ "L2.Interp: Unbound location: " ++ sdoc loc2 Just (VLoc reg offset) -> @@ -316,7 +316,7 @@ interpExt sizeEnv rc env ddefs fenv ext = Just val -> error $ "L2.Interp: Unexpected value for " ++ sdoc loc2 ++ ":" ++ sdoc val - AfterVariableLE v _ loc2 _ -> do + AfterVariableLE v loc2 _ -> do case M.lookup (unwrapLocVar loc2) env of Nothing -> error $ "L2.Interp: Unbound location: " ++ sdoc loc2 Just (VLoc reg offset) -> diff --git a/gibbon-compiler/src/Gibbon/L2/Syntax.hs b/gibbon-compiler/src/Gibbon/L2/Syntax.hs index 95d65f0c6..2c4e678f2 100644 --- a/gibbon-compiler/src/Gibbon/L2/Syntax.hs +++ b/gibbon-compiler/src/Gibbon/L2/Syntax.hs @@ -186,10 +186,9 @@ data E2Ext loc dec -- | Define a location in terms of a different location. data PreLocExp loc = StartOfRegionLE Region | AfterConstantLE Int -- Number of bytes after. (In case of an SoA loc, this is the offset into the data constructor buffer) - [Int] -- Optional list with offset bytes, these offsets can be used for bumping field locations for an SoA location. loc -- Location which this location is offset from. + | AfterVariableLE Var -- Name of variable v. This loc is size(v) bytes after. - [Var] -- Optional list with offset bytes, each size(v) bytes, these can be used for bumping field locations for an SoA location. 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. @@ -197,6 +196,10 @@ data PreLocExp loc = StartOfRegionLE Region | InRegionLE Region | FreeLE | FromEndLE loc + + | AfterVectorLE [PreLocExp loc] + + deriving (Read, Show, Eq, Ord, Functor, Generic, NFData) type LocExp = PreLocExp LocVar @@ -211,7 +214,7 @@ instance FreeVars (E2Ext l d) where LetRegionE _ _ _ bod -> gFreeVars bod LetParRegionE _ _ _ bod -> gFreeVars bod LetLocE _ rhs bod -> (case rhs of - AfterVariableLE v vs _loc _ -> S.singleton v `S.union` S.fromList vs + AfterVariableLE v _loc _ -> S.singleton v _ -> S.empty) `S.union` gFreeVars bod @@ -232,8 +235,8 @@ instance FreeVars (E2Ext l d) where instance FreeVars LocExp where gFreeVars e = case e of - AfterConstantLE _ _ loc -> S.singleton $ unwrapLocVar loc - AfterVariableLE v vs loc _ -> S.fromList [v, unwrapLocVar loc] `S.union` S.fromList vs + AfterConstantLE _ loc -> S.singleton $ 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 @@ -909,12 +912,7 @@ occurs w ex = LetLocE _ le bod -> let oc_bod = go bod in case le of - AfterVariableLE v vs _ _ -> let func = (\v accum -> if v `S.member` w - then True || accum - else False || accum - ) - reduce = L.foldr func False vs - in reduce || v `S.member` w || oc_bod + AfterVariableLE v _ _ -> v `S.member` w || oc_bod StartOfRegionLE{} -> oc_bod AfterConstantLE{} -> oc_bod InRegionLE{} -> oc_bod @@ -1051,8 +1049,8 @@ depList = L.map (\(a,b) -> (a,a,b)) . M.toList . go M.empty dep ex = case ex of StartOfRegionLE r -> [singleLocVar $ regionToVar r] - AfterConstantLE _ _ loc -> [loc] - AfterVariableLE v vs loc _ -> [singleLocVar v,loc] ++ L.map singleLocVar vs + AfterConstantLE _ loc -> [loc] + AfterVariableLE v loc _ -> [singleLocVar v,loc] InRegionLE r -> [singleLocVar $ regionToVar r] FromEndLE loc -> [loc] FreeLE -> [] diff --git a/gibbon-compiler/src/Gibbon/L2/Typecheck.hs b/gibbon-compiler/src/Gibbon/L2/Typecheck.hs index 04340da5e..05c49d4dc 100644 --- a/gibbon-compiler/src/Gibbon/L2/Typecheck.hs +++ b/gibbon-compiler/src/Gibbon/L2/Typecheck.hs @@ -781,14 +781,14 @@ tcExp ddfs env funs constrs regs tstatein exp = 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 -> + AfterConstantLE i l1 -> do r <- getRegion exp constrs l1 let tstate1 = extendTS (Single loc) (Output,True) $ setAfter l1 tstatein let constrs1 = extendConstrs (InRegionC (Single loc) r) $ extendConstrs (AfterConstantC i l1 (Single loc)) constrs (ty,tstate2) <- tcExp ddfs env' funs constrs1 regs tstate1 e tstate3 <- removeLoc exp tstate2 (Single loc) return (ty,tstate3) - AfterVariableLE x _ l1 _ -> + AfterVariableLE x l1 _ -> do r <- getRegion exp constrs l1 (_xty,tstate1) <- tcExp ddfs env funs constrs regs tstatein $ VarE x -- NOTE: We now allow aliases (offsets) from scalar vars too. So we can leave out this check diff --git a/gibbon-compiler/src/Gibbon/NewL2/FromOldL2.hs b/gibbon-compiler/src/Gibbon/NewL2/FromOldL2.hs index 51d9584f3..229a0634a 100644 --- a/gibbon-compiler/src/Gibbon/NewL2/FromOldL2.hs +++ b/gibbon-compiler/src/Gibbon/NewL2/FromOldL2.hs @@ -237,10 +237,10 @@ fromOldL2Exp ddefs fundefs locenv env2 ex = toLocArg loc locexp locenv0 = case locexp of StartOfRegionLE reg -> New.Loc (New.LREM loc (regionToVar reg) (toEndV (regionToVar reg)) Output) - AfterConstantLE _ _ loc2 -> + AfterConstantLE _ loc2 -> let (New.Loc lrem) = locenv0 # loc2 in New.Loc (New.LREM loc (New.lremReg lrem) (New.lremEndReg lrem) Output) - AfterVariableLE _ _ loc2 _ -> + AfterVariableLE _ loc2 _ -> let (New.Loc lrem) = locenv0 # loc2 in New.Loc (New.LREM loc (New.lremReg lrem) (New.lremEndReg lrem) Output) InRegionLE reg -> diff --git a/gibbon-compiler/src/Gibbon/NewL2/Syntax.hs b/gibbon-compiler/src/Gibbon/NewL2/Syntax.hs index 0f5bd1fb8..5ff7515c3 100644 --- a/gibbon-compiler/src/Gibbon/NewL2/Syntax.hs +++ b/gibbon-compiler/src/Gibbon/NewL2/Syntax.hs @@ -139,8 +139,8 @@ toEndFromTaggedV v = (toVar "end_from_tagged_") `varAppend` v instance FreeVars LocExp where gFreeVars e = case e of - Old.AfterConstantLE _ _ loc -> S.singleton $ unwrapLocVar (toLocVar loc) - Old.AfterVariableLE v vs loc _ -> S.fromList [v, unwrapLocVar (toLocVar loc)] `S.union` S.fromList vs + Old.AfterConstantLE _ loc -> S.singleton $ unwrapLocVar (toLocVar loc) + Old.AfterVariableLE v loc _ -> S.fromList [v, unwrapLocVar (toLocVar loc)] _ -> S.empty @@ -510,8 +510,8 @@ depList = L.map (\(a,b) -> (a,a,b)) . M.toList . go M.empty dep ex = case ex of Old.StartOfRegionLE r -> [Old.regionToVar r] - Old.AfterConstantLE _ _ loc -> [unwrapLocVar $ toLocVar loc] - Old.AfterVariableLE v vs loc _ -> [v, unwrapLocVar $ toLocVar loc] ++ vs + Old.AfterConstantLE _ loc -> [unwrapLocVar $ toLocVar loc] + Old.AfterVariableLE v loc _ -> [v, unwrapLocVar $ toLocVar loc] Old.InRegionLE r -> [Old.regionToVar r] Old.FromEndLE loc -> [unwrapLocVar $ toLocVar loc] Old.FreeLE -> [] diff --git a/gibbon-compiler/src/Gibbon/Passes/AddRAN.hs b/gibbon-compiler/src/Gibbon/Passes/AddRAN.hs index 5896e0c8f..a2da2286a 100644 --- a/gibbon-compiler/src/Gibbon/Passes/AddRAN.hs +++ b/gibbon-compiler/src/Gibbon/Passes/AddRAN.hs @@ -426,8 +426,8 @@ we need random access for that type. let reg = case rhs of StartOfRegionLE r -> regionToVar r InRegionLE r -> regionToVar r - AfterConstantLE _ _ lc -> renv # lc - AfterVariableLE _ _ lc _ -> renv # lc + AfterConstantLE _ lc -> renv # lc + AfterVariableLE _ lc _ -> renv # lc FromEndLE lc -> renv # lc -- TODO: This needs to be fixed in needsRANExp ddefs fundefs env2 (M.insert loc reg renv) tcenv parlocss bod _ -> S.empty diff --git a/gibbon-compiler/src/Gibbon/Passes/AddTraversals.hs b/gibbon-compiler/src/Gibbon/Passes/AddTraversals.hs index e255391bd..0c70cb381 100644 --- a/gibbon-compiler/src/Gibbon/Passes/AddTraversals.hs +++ b/gibbon-compiler/src/Gibbon/Passes/AddTraversals.hs @@ -100,8 +100,8 @@ addTraversalsExp ddefs fundefs env2 renv context ex = let reg = case locexp of StartOfRegionLE r -> regionToVar r InRegionLE r -> regionToVar r - AfterConstantLE _ _ lc -> renv # lc - AfterVariableLE _ _ lc _ -> renv # lc + AfterConstantLE _ lc -> renv # lc + AfterVariableLE _ lc _ -> renv # lc FromEndLE lc -> renv # lc -- TODO: This needs to be fixed in Ext <$> LetLocE loc locexp <$> addTraversalsExp ddefs fundefs env2 (M.insert loc reg renv) context bod diff --git a/gibbon-compiler/src/Gibbon/Passes/CalculateBounds.hs b/gibbon-compiler/src/Gibbon/Passes/CalculateBounds.hs index 66204ced9..6ee58d3e7 100644 --- a/gibbon-compiler/src/Gibbon/Passes/CalculateBounds.hs +++ b/gibbon-compiler/src/Gibbon/Passes/CalculateBounds.hs @@ -181,11 +181,11 @@ calculateBoundsExp ddefs env2 varSzEnv varLocEnv locRegEnv locOffEnv regSzEnv re 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) + (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 + (AfterVariableLE v l _) -> (locRegEnv # l, locOffEnv # (varLocEnv # v)) -- <> varSzEnv # v (InRegionLE r ) -> (regionToVar r, Undefined) (FromEndLE l ) -> (locRegEnv # l, Undefined) FreeLE -> undefined diff --git a/gibbon-compiler/src/Gibbon/Passes/Cursorize.hs b/gibbon-compiler/src/Gibbon/Passes/Cursorize.hs index 159514bb0..1fed421d8 100644 --- a/gibbon-compiler/src/Gibbon/Passes/Cursorize.hs +++ b/gibbon-compiler/src/Gibbon/Passes/Cursorize.hs @@ -694,12 +694,12 @@ cursorizeReadPackedFile ddfs fundefs denv tenv senv isPackedContext v path tyc r cursorizeLocExp :: DepEnv -> TyEnv Var Ty2 -> SyncEnv -> LocVar -> LocExp -> Either DepEnv (Exp3, [Binds Exp3], TyEnv Var Ty2, SyncEnv) cursorizeLocExp denv tenv senv lvar locExp = case locExp of - AfterConstantLE i [] loc -> + AfterConstantLE i loc -> let rhs = Ext $ AddCursor ((unwrapLocVar . toLocVar) loc) (LitE i) in if isBound ((toLocVar) loc) tenv then Right (rhs, [], tenv, senv) else Left$ M.insertWith (++) ((toLocVar) loc) [((unwrapLocVar lvar),[],CursorTy,rhs)] denv - AfterConstantLE i irst loc -> error "cursorizeLocExp :: AfterConstantLE Bounds for SoA not implemented." + -- TODO: handle product types here {- [2018.03.07]: @@ -712,7 +712,7 @@ For BigInfinite regions, this is simple: But Infinite regions do not support sizes yet. Re-enable this later. -} - AfterVariableLE v [] locarg was_stolen -> do + AfterVariableLE v locarg was_stolen -> do let vty = case M.lookup v tenv of Just ty -> ty Nothing -> case M.lookup v senv of @@ -764,8 +764,6 @@ But Infinite regions do not support sizes yet. Re-enable this later. Right (bod, bnds, tenv', M.delete v senv) else Left $ M.insertWith (++) loc [((unwrapLocVar lvar),[],CursorTy,bod)] denv - AfterVariableLE v vrst locarg was_stolen -> error "TODO: cursorizeLocExp: AfterVariableLE offsets for SoA not implemented yet." - FromEndLE locarg -> let loc = toLocVar locarg in if isBound loc tenv diff --git a/gibbon-compiler/src/Gibbon/Passes/FindWitnesses.hs b/gibbon-compiler/src/Gibbon/Passes/FindWitnesses.hs index ecacb9496..c66570ceb 100644 --- a/gibbon-compiler/src/Gibbon/Passes/FindWitnesses.hs +++ b/gibbon-compiler/src/Gibbon/Passes/FindWitnesses.hs @@ -91,10 +91,10 @@ findWitnesses p@Prog{fundefs} = mapMExprs fn p then Ext $ LetLocE loc locexp $ goE (Set.insert loc bound) mp bod else case locexp of - AfterVariableLE v vs loc2 b -> - (go (Map.insert loc (DelayLoc (loc, (AfterVariableLE v vs loc2 b))) mp) bod) - AfterConstantLE i irst loc2 -> - go (Map.insert loc (DelayLoc (loc, (AfterConstantLE i irst loc2))) mp) bod + AfterVariableLE v loc2 b -> + (go (Map.insert loc (DelayLoc (loc, (AfterVariableLE v loc2 b))) mp) bod) + AfterConstantLE i loc2 -> + go (Map.insert loc (DelayLoc (loc, (AfterConstantLE i loc2))) mp) bod _ -> Ext $ LetLocE loc locexp $ goE (Set.insert loc bound) mp bod LetRegionE r sz ty bod -> Ext $ LetRegionE r sz ty $ go mp bod LetParRegionE r sz ty bod -> Ext $ LetParRegionE r sz ty $ go mp bod diff --git a/gibbon-compiler/src/Gibbon/Passes/FollowPtrs.hs b/gibbon-compiler/src/Gibbon/Passes/FollowPtrs.hs index 3cb44dc5a..1afc2e299 100644 --- a/gibbon-compiler/src/Gibbon/Passes/FollowPtrs.hs +++ b/gibbon-compiler/src/Gibbon/Passes/FollowPtrs.hs @@ -55,7 +55,7 @@ followPtrs (Prog ddefs fundefs mainExp) = do let in_locs = foldr (\loc acc -> if loc == scrt_loc then ((Single indir_ptrv) : acc) else (loc : acc)) [] (inLocVars funTy) let out_locs = outLocVars funTy wc <- gensym "wildcard" - let indir_bod = Ext $ LetLocE (Single jump) (AfterConstantLE 8 [] (Single indir_ptrloc)) $ + let indir_bod = Ext $ LetLocE (Single jump) (AfterConstantLE 8 (Single indir_ptrloc)) $ (if isPrinterName funName then LetE (wc,[],ProdTy[],PrimAppE PrintSym [LitSymE (toVar " ->i ")]) else id) $ LetE (callv,endofs',out_ty,AppE funName (in_locs ++ out_locs) args) $ Ext (RetE ret_endofs callv) diff --git a/gibbon-compiler/src/Gibbon/Passes/InferLocations.hs b/gibbon-compiler/src/Gibbon/Passes/InferLocations.hs index f61c6201b..61fdb7727 100644 --- a/gibbon-compiler/src/Gibbon/Passes/InferLocations.hs +++ b/gibbon-compiler/src/Gibbon/Passes/InferLocations.hs @@ -279,8 +279,8 @@ data Failure = FailUnify Ty2 Ty2 -- [2024.12.04] VS -- For AfterConstantL and AfterVariableL add a list argument with offsets for fields in an SoA location -- Optional for AoS Location. -data Constraint = AfterConstantL LocVar Int [Int] LocVar - | AfterVariableL LocVar Var [Var] LocVar +data Constraint = AfterConstantL LocVar Int LocVar + | AfterVariableL LocVar Var LocVar | AfterTagL LocVar LocVar | StartRegionL LocVar Region | AfterCopyL LocVar Var Var LocVar Var [LocVar] @@ -296,7 +296,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 @@ -360,11 +362,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 = @@ -393,10 +414,10 @@ inferExp' ddefs env exp bound dest= expr' = foldr addLetLoc expr constrs' addLetLoc i a = case i of - AfterConstantL lv1 v vs lv2 -> Ext (LetLocE lv1 (AfterConstantLE v vs lv2) a) - AfterVariableL lv1 v vs lv2 -> Ext (LetLocE lv1 (AfterVariableLE v vs lv2 True) a) + 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) {- VS: I think it may be fine to hardcode [] since AfterTagL is reserved for a Tag loc?-} + 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 @@ -407,15 +428,15 @@ inferExp' ddefs env exp bound dest= _ -> error "bindAllLocations: Not a packed type" a' = subst v1 (VarE v') a in LetE (v',[],copyRetTy, AppE f lvs [VarE v1]) $ - Ext (LetLocE lv1 (AfterVariableLE v' [] lv2 True) a') + Ext (LetLocE lv1 (AfterVariableLE v' lv2 True) a') 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. @@ -513,7 +534,7 @@ inferExp ddefs env@FullEnv{dataDefs} ex0 dest = lv2' <- finalLocVar lv2 if lv' == lv1' then do (bod',ty',cs') <- bindImmediateDependentLoc lv (bod,ty,cs) - let bod'' = Ext (LetLocE lv1' (AfterConstantLE 1 [] lv2') bod') + let bod'' = Ext (LetLocE lv1' (AfterConstantLE 1 lv2') bod') return (bod'',ty',cs') else do (bod',ty',cs') <- bindImmediateDependentLoc lv (bod,ty,cs) return (bod',ty',(AfterTagL lv1 lv2):cs') @@ -529,9 +550,9 @@ inferExp ddefs env@FullEnv{dataDefs} ex0 dest = handleTrailingBindLoc v res = do (e,ty,cs) <- bindAfterLoc v res case e of - (Ext (LetLocE lv1 (AfterVariableLE v [] lv2 True) e)) -> + (Ext (LetLocE lv1 (AfterVariableLE v lv2 True) e)) -> do (e',ty',cs') <- bindTrivialAfterLoc lv1 (e,ty,cs) - return (Ext (LetLocE lv1 (AfterVariableLE v [] lv2 True) e'), ty', cs') + return (Ext (LetLocE lv1 (AfterVariableLE v lv2 True) e'), ty', cs') _ -> return (e,ty,cs) -- Should this signal an error instead of silently returning? -- | Transforms a result by adding a location binding derived from an AfterVariable constraint @@ -540,11 +561,11 @@ inferExp ddefs env@FullEnv{dataDefs} ex0 dest = bindAfterLoc :: Var -> Result -> TiM Result bindAfterLoc v (e,ty,c:cs) = case c of - AfterVariableL lv1 v' vs lv2 -> + AfterVariableL lv1 v' lv2 -> if v == v' then do lv1' <- finalLocVar lv1 lv2' <- finalLocVar lv2 - let res' = (Ext (LetLocE lv1' (AfterVariableLE v vs lv2 True) e), ty, cs) + let res' = (Ext (LetLocE lv1' (AfterVariableLE v lv2 True) e), ty, cs) res'' <- bindAfterLoc v res' return res'' else do (e',ty',cs') <- bindAfterLoc v (e,ty,cs) @@ -559,7 +580,7 @@ inferExp ddefs env@FullEnv{dataDefs} ex0 dest = copyRetTy = case arrOut arrty of PackedTy _ loc -> substLoc (M.singleton loc lv2) (arrOut arrty) _ -> error "bindAfterLoc: Not a packed type" - let res' = (LetE (v',[],copyRetTy,AppE f lvs [VarE v1]) $ Ext (LetLocE lv1' (AfterVariableLE v' [] lv2' True) e), ty, cs) + let res' = (LetE (v',[],copyRetTy,AppE f lvs [VarE v1]) $ Ext (LetLocE lv1' (AfterVariableLE v' lv2' True) e), ty, cs) res'' <- bindAfterLoc v res' return res'' else do (e',ty',cs') <- bindAfterLoc v (e,ty,cs) @@ -589,16 +610,16 @@ inferExp ddefs env@FullEnv{dataDefs} ex0 dest = lv' <- finalLocVar lv if lv2' == lv' then do (e',ty',cs') <- bindTrivialAfterLoc lv1 (e,ty,cs) - return (Ext (LetLocE lv1' (AfterConstantLE 1 [] lv2') e'), ty', cs') + return (Ext (LetLocE lv1' (AfterConstantLE 1 lv2') e'), ty', cs') else do (e',ty',cs') <- bindTrivialAfterLoc lv (e,ty,cs) return (e',ty',c:cs') - AfterConstantL lv1 v vs lv2 -> + AfterConstantL lv1 v lv2 -> do lv1' <- finalLocVar lv1 lv2' <- finalLocVar lv2 lv' <- finalLocVar lv if lv2' == lv' then do (e',ty',cs') <- bindTrivialAfterLoc lv1 (e,ty,cs) - return (Ext (LetLocE lv1' (AfterConstantLE v vs lv2') e'), ty', cs') + return (Ext (LetLocE lv1' (AfterConstantLE v lv2') e'), ty', cs') else do (e',ty',cs') <- bindTrivialAfterLoc lv (e,ty,cs) return (e',ty',c:cs') _ -> do (e',ty',cs') <- bindTrivialAfterLoc lv (e,ty,cs) @@ -782,11 +803,23 @@ inferExp ddefs env@FullEnv{dataDefs} ex0 dest = _ -> 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 + Just $ AfterVariableL loc1 v loc2 afterVar ((ArgFixed s), (Just loc1), (Just loc2)) = - Just $ AfterConstantL loc1 s [] loc2 + Just $ AfterConstantL loc1 s loc2 afterVar ((ArgCopy v v' f lvs), (Just loc1), (Just loc2)) = Just $ AfterCopyL loc1 v v' loc2 f lvs afterVar _ = Nothing @@ -801,7 +834,7 @@ inferExp ddefs 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 @@ -946,7 +979,7 @@ inferExp ddefs 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 ddefs env) (zip args argDests) let acs = concat acss @@ -957,7 +990,8 @@ inferExp ddefs env@FullEnv{dataDefs} ex0 dest = 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) @@ -1302,12 +1336,12 @@ finishExp e = e1' <- finishExp e1 loc' <- finalLocVar loc lex' <- case lex of - AfterConstantLE i irst lv -> do + AfterConstantLE i lv -> do lv' <- finalLocVar lv - return $ AfterConstantLE i irst lv' - AfterVariableLE v vs lv b -> do + return $ AfterConstantLE i lv' + AfterVariableLE v lv b -> do lv' <- finalLocVar lv - return $ AfterVariableLE v vs lv' b + return $ AfterVariableLE v lv' b oth -> return oth return $ Ext (LetLocE loc' lex' e1') Ext (L2.AddFixed cur i) -> pure $ Ext (L2.AddFixed cur i) @@ -1423,8 +1457,8 @@ cleanExp e = Ext (LetLocE loc lex e) -> let (e',s') = cleanExp e in if S.member loc s' then let ls = case lex of - AfterConstantLE _i _irst lv -> [lv] - AfterVariableLE _v _vrst lv _ -> [lv] + AfterConstantLE _i lv -> [lv] + AfterVariableLE _v lv _ -> [lv] oth -> [] in (Ext (LetLocE loc lex e'), S.delete loc $ S.union s' $ S.fromList ls) @@ -1560,7 +1594,7 @@ moveProjsAfterSync sv ex = case sv of noAfterLoc :: LocVar -> [Constraint] -> [Constraint] -> TiM Bool noAfterLoc lv fcs (c:cs) = case c of - AfterVariableL lv1 v vs lv2 -> + AfterVariableL lv1 v lv2 -> do lv2' <- finalLocVar lv2 lv' <- finalLocVar lv if lv' == lv2' then return False else noAfterLoc lv fcs cs @@ -1573,7 +1607,7 @@ noAfterLoc lv fcs (c:cs) = -- b2 <- noAfterLoc lv1 fcs fcs -- return (b1 && b2) else noAfterLoc lv fcs cs - AfterConstantL lv1 v vs lv2 -> + AfterConstantL lv1 v lv2 -> do lv2' <- finalLocVar lv2 lv' <- finalLocVar lv if lv' == lv2' then return False else noAfterLoc lv fcs cs @@ -1583,11 +1617,11 @@ noAfterLoc _ _ [] = return True noBeforeLoc :: LocVar -> [Constraint] -> TiM Bool noBeforeLoc lv (c:cs) = case c of - AfterVariableL lv1 v vs lv2 -> + AfterVariableL lv1 v lv2 -> do lv1' <- finalLocVar lv1 lv' <- finalLocVar lv if lv' == lv1' then return False else noBeforeLoc lv cs - AfterConstantL lv1 v vs lv2 -> + AfterConstantL lv1 v lv2 -> do lv1' <- finalLocVar lv1 lv' <- finalLocVar lv if lv' == lv1' then return False else noBeforeLoc lv cs diff --git a/gibbon-compiler/src/Gibbon/Passes/ParAlloc.hs b/gibbon-compiler/src/Gibbon/Passes/ParAlloc.hs index 67a4cd4c2..56b21747a 100644 --- a/gibbon-compiler/src/Gibbon/Passes/ParAlloc.hs +++ b/gibbon-compiler/src/Gibbon/Passes/ParAlloc.hs @@ -142,7 +142,7 @@ parAllocExp ddefs fundefs env2 reg_env after_env mb_parent_id pending_binds spaw 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) + PAfter (loc1, (w, loc2)) -> Ext $ LetLocE loc1 (AfterVariableLE w loc2 False) $ acc) bod2 pending_binds pure $ LetE (v, endlocs, ty, SyncE) bod3 @@ -228,7 +228,7 @@ parAllocExp ddefs fundefs env2 reg_env after_env mb_parent_id pending_binds spaw LetLocE loc locexp bod -> do case locexp of -- Binding is swallowed, and it's continuation allocates in a fresh region. - AfterVariableLE v vs loc2 True | S.member v spawned -> do + AfterVariableLE v loc2 True | S.member v spawned -> do let (Just parent_id) = mb_parent_id cont_id <- gensym "cont_id" r <- gensym "rafter" @@ -252,24 +252,24 @@ parAllocExp ddefs fundefs env2 reg_env after_env mb_parent_id pending_binds spaw LetE (not_stolen, [], BoolTy, PrimAppE EqIntP [VarE cont_id, VarE parent_id]) $ IfE (VarE not_stolen) (Ext $ LetAvail [v] $ - Ext $ LetLocE loc (AfterVariableLE v vs loc2 False) bod2) -- don't allocate in a fresh region + Ext $ LetLocE loc (AfterVariableLE v loc2 False) bod2) -- don't allocate in a fresh region (Ext $ LetParRegionE newreg Undefined Nothing $ Ext $ LetLocE (singleLocVar newloc) (StartOfRegionLE newreg) bod1) else pure $ Ext $ LetParRegionE newreg Undefined Nothing $ Ext $ LetLocE (singleLocVar newloc) (StartOfRegionLE newreg) bod1 -- Binding is swallowed, but no fresh region is created. This can brought back safely after a sync. - AfterVariableLE v _ loc2 True | not (S.member loc2 boundlocs) || not (S.member (singleLocVar v) boundlocs) -> do + AfterVariableLE v loc2 True | not (S.member loc2 boundlocs) || not (S.member (singleLocVar v) boundlocs) -> do let pending_binds' = PAfter (loc, (v, loc2)) : pending_binds reg = reg_env # loc2 reg_env' = M.insert loc reg reg_env parAllocExp ddefs fundefs env2 reg_env' after_env mb_parent_id pending_binds' spawned boundlocs region_on_spawn bod - AfterVariableLE v vs loc2 True | S.member loc2 boundlocs && S.member (singleLocVar v) boundlocs -> do + AfterVariableLE v loc2 True | S.member loc2 boundlocs && S.member (singleLocVar v) boundlocs -> do let reg = reg_env # loc2 reg_env' = M.insert loc reg reg_env boundlocs'= S.insert loc boundlocs bod' <- parAllocExp ddefs fundefs env2 reg_env' after_env mb_parent_id pending_binds spawned boundlocs' region_on_spawn bod - pure $ Ext $ LetLocE loc (AfterVariableLE v vs loc2 False) bod' + pure $ Ext $ LetLocE loc (AfterVariableLE v loc2 False) bod' FreeLE -> do let boundlocs'= S.insert loc boundlocs @@ -280,8 +280,8 @@ parAllocExp ddefs fundefs env2 reg_env after_env mb_parent_id pending_binds spaw let reg = case locexp of StartOfRegionLE r -> regionToVar r InRegionLE r -> regionToVar r - AfterConstantLE _ _ lc -> reg_env # lc - AfterVariableLE _ _ lc _ -> reg_env # lc + AfterConstantLE _ lc -> reg_env # lc + AfterVariableLE _ lc _ -> reg_env # lc FromEndLE lc -> reg_env # lc reg_env' = M.insert loc reg reg_env boundlocs'= S.insert loc boundlocs @@ -362,8 +362,8 @@ substLocInExp mp ex1 = go2 lexp = case lexp of StartOfRegionLE{} -> lexp - AfterConstantLE i irst loc -> AfterConstantLE i irst (sub loc) - AfterVariableLE i irst loc b -> AfterVariableLE i irst (sub loc) b + AfterConstantLE i loc -> AfterConstantLE i (sub loc) + AfterVariableLE i loc b -> AfterVariableLE i (sub loc) b InRegionLE{} -> lexp FreeLE -> lexp FromEndLE loc -> FromEndLE (sub loc) diff --git a/gibbon-compiler/src/Gibbon/Passes/RegionsInwards.hs b/gibbon-compiler/src/Gibbon/Passes/RegionsInwards.hs index c4506c6b9..2dae01b26 100644 --- a/gibbon-compiler/src/Gibbon/Passes/RegionsInwards.hs +++ b/gibbon-compiler/src/Gibbon/Passes/RegionsInwards.hs @@ -80,7 +80,7 @@ placeRegionInwards env scopeSet ex = newEnv = M.insert myKey' valList' tempDict in placeRegionInwards newEnv scopeSet rhs --recurse on rhs using the newenv - AfterConstantLE _ _ loc' -> do --In case statement, actual match = AfterConstantLE integralVal loc' + AfterConstantLE _ loc' -> do --In case statement, actual match = AfterConstantLE integralVal loc' let keyList' = M.keys env key' = F.find (S.member loc') keyList' in case key' of @@ -97,7 +97,7 @@ placeRegionInwards env scopeSet ex = newEnv = M.insert myKey' valList' tempDict in placeRegionInwards newEnv scopeSet rhs - AfterVariableLE _ _ loc' _ -> do --In case statement, actual match = AfterVariableLE variable loc' boolVal + AfterVariableLE _ loc' _ -> do --In case statement, actual match = AfterVariableLE variable loc' boolVal let keyList' = M.keys env key' = F.find (S.member loc') keyList' in case key' of @@ -309,7 +309,7 @@ freeVars ex = case ex of LetLocE _ phs rhs -> case phs of StartOfRegionLE _ -> freeVars rhs - AfterConstantLE _ _ _ -> freeVars rhs + AfterConstantLE _ _ -> freeVars rhs AfterVariableLE{} -> freeVars rhs InRegionLE _ -> freeVars rhs FromEndLE _ -> freeVars rhs diff --git a/gibbon-compiler/src/Gibbon/Passes/RemoveCopies.hs b/gibbon-compiler/src/Gibbon/Passes/RemoveCopies.hs index fe4c4b082..e6e892be7 100644 --- a/gibbon-compiler/src/Gibbon/Passes/RemoveCopies.hs +++ b/gibbon-compiler/src/Gibbon/Passes/RemoveCopies.hs @@ -86,8 +86,8 @@ removeCopiesExp ddefs fundefs lenv env2 ex = let reg = case rhs of StartOfRegionLE r -> regionToVar r InRegionLE r -> regionToVar r - AfterConstantLE _ _ lc -> lenv # lc - AfterVariableLE _ _ lc _ -> lenv # lc + AfterConstantLE _ lc -> lenv # lc + AfterVariableLE _ lc _ -> lenv # lc FromEndLE lc -> lenv # lc -- TODO: This needs to be fixed Ext <$> LetLocE loc rhs <$> removeCopiesExp ddefs fundefs (M.insert loc reg lenv) env2 bod diff --git a/gibbon-compiler/src/Gibbon/Passes/ReorderScalarWrites.hs b/gibbon-compiler/src/Gibbon/Passes/ReorderScalarWrites.hs index 6054ede36..35125d03f 100644 --- a/gibbon-compiler/src/Gibbon/Passes/ReorderScalarWrites.hs +++ b/gibbon-compiler/src/Gibbon/Passes/ReorderScalarWrites.hs @@ -108,8 +108,8 @@ writeOrderMarkers (Prog ddefs fundefs mainExp) = do let reg = case rhs of L2.StartOfRegionLE r -> r L2.InRegionLE r -> r - L2.AfterConstantLE _ _ lc -> reg_env # lc - L2.AfterVariableLE _ _ lc _ -> reg_env # lc + L2.AfterConstantLE _ lc -> reg_env # lc + L2.AfterVariableLE _ lc _ -> reg_env # lc L2.FromEndLE lc -> reg_env # lc reg_env' = M.insert loc reg reg_env case M.lookup reg alloc_env of diff --git a/gibbon-compiler/src/Gibbon/Passes/RouteEnds.hs b/gibbon-compiler/src/Gibbon/Passes/RouteEnds.hs index 19d39917b..b0b425686 100644 --- a/gibbon-compiler/src/Gibbon/Passes/RouteEnds.hs +++ b/gibbon-compiler/src/Gibbon/Passes/RouteEnds.hs @@ -326,7 +326,7 @@ routeEnds prg@Prog{ddefs,fundefs,mainExp} = do l2 <- gensym "jump" let l2loc = singleLocVar l2 eor' = mkEnd l1 l2loc eor - e' = Ext $ LetLocE l2loc (AfterConstantLE 1 [] l1) e + e' = Ext $ LetLocE l2loc (AfterConstantLE 1 l1) e e'' <- exp fns retlocs eor' lenv (M.insert l1 l2loc lenv) env2 e' return (dc, vls, e'') Nothing -> error $ "Failed to find " ++ sdoc x ++ " in " ++ sdoc lenv @@ -353,7 +353,7 @@ routeEnds prg@Prog{ddefs,fundefs,mainExp} = do let l2loc = singleLocVar l2 eor' = mkEnd l1 l2loc eor (Just jump) = L1.sizeOfTy ty - e' = Ext $ LetLocE l2loc (AfterConstantLE jump [] l1) e + e' = Ext $ LetLocE l2loc (AfterConstantLE jump l1) e return (eor', e') vars = L.map fst vls varsToLocs = L.map singleLocVar vars @@ -545,7 +545,7 @@ routeEnds prg@Prog{ddefs,fundefs,mainExp} = do scalar_witnesses = go la [] bind_witnesses bod ls = L.foldr (\(v,w,sz) acc -> - Ext $ LetLocE v (AfterConstantLE sz [] w) acc) + Ext $ LetLocE v (AfterConstantLE sz w) acc) bod ls bod' = bind_witnesses e scalar_witnesses bod'' = Ext (LetLocE la (FromEndLE l2) bod') diff --git a/gibbon-compiler/src/Gibbon/Passes/Simplifier.hs b/gibbon-compiler/src/Gibbon/Passes/Simplifier.hs index 7ff486223..2f9c77a30 100644 --- a/gibbon-compiler/src/Gibbon/Passes/Simplifier.hs +++ b/gibbon-compiler/src/Gibbon/Passes/Simplifier.hs @@ -135,13 +135,13 @@ simplifyLocBinds only_cse (Prog ddefs fundefs mainExp) = do 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 irst loc2) bod -> + LetLocE loc (AfterConstantLE i loc2) bod -> case (M.lookup loc2 env) of Nothing -> - Ext $ LetLocE loc (AfterConstantLE i irst loc2) $ + Ext $ LetLocE loc (AfterConstantLE i loc2) $ go (M.insert loc (loc2,i) env) bod Just (loc3,j) -> - Ext $ LetLocE loc (AfterConstantLE (i+j) irst loc3) $ + Ext $ LetLocE loc (AfterConstantLE (i+j) loc3) $ go (M.insert loc (loc3,i+j) env) bod LetLocE loc rhs bod -> Ext (LetLocE loc rhs (go env bod)) LetAvail vars bod -> Ext (LetAvail vars (go env bod)) @@ -199,8 +199,8 @@ simplifyLocBinds only_cse (Prog ddefs fundefs mainExp) = do LetParRegionE reg sz ty bod -> Ext (LetParRegionE reg sz ty (go0 env1 env2 bod)) LetLocE loc rhs bod -> let rhs' = case rhs of - AfterConstantLE i irst loc2 -> AfterConstantLE i irst (substloc env2 loc2) - AfterVariableLE v vrst loc2 b -> AfterVariableLE v vrst (substloc env2 loc2) b + AfterConstantLE i loc2 -> AfterConstantLE i (substloc env2 loc2) + AfterVariableLE v loc2 b -> AfterVariableLE v (substloc env2 loc2) b _ -> rhs in case M.lookup rhs' env1 of Nothing -> Ext (LetLocE loc rhs' (go0 (M.insert rhs' loc env1) env2 bod)) diff --git a/gibbon-compiler/src/Gibbon/Passes/ThreadRegions.hs b/gibbon-compiler/src/Gibbon/Passes/ThreadRegions.hs index 81bd3a68a..8ee1c5af6 100644 --- a/gibbon-compiler/src/Gibbon/Passes/ThreadRegions.hs +++ b/gibbon-compiler/src/Gibbon/Passes/ThreadRegions.hs @@ -455,8 +455,8 @@ threadRegionsExp ddefs fundefs fnLocArgs renv env2 lfenv rlocs_env wlocs_env pkd let reg = case rhs of StartOfRegionLE r -> regionToVar r InRegionLE r -> regionToVar r - AfterConstantLE _ _ lc -> renv # (toLocVar lc) - AfterVariableLE _ _ lc _ -> renv # (toLocVar lc) + AfterConstantLE _ lc -> renv # (toLocVar lc) + AfterVariableLE _ lc _ -> renv # (toLocVar lc) FromEndLE lc -> renv # (toLocVar lc) wlocs_env' = M.insert loc hole_tycon wlocs_env region_locs1 = case rhs of diff --git a/gibbon-compiler/src/Gibbon/Pretty.hs b/gibbon-compiler/src/Gibbon/Pretty.hs index 2ca52ac4b..0a9ac42ae 100644 --- a/gibbon-compiler/src/Gibbon/Pretty.hs +++ b/gibbon-compiler/src/Gibbon/Pretty.hs @@ -435,21 +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 irst loc -> case irst of - {- AoS operation -} - [] -> lparen <> pprint loc <+> text "+" <+> int i <> rparen - {-VS: for some reason i cannot pattern match on loc here!!-} - --_ -> case loc of - -- Single x -> error "This should be an SoA loc!" - -- SoA dataBufLoc fieldLocs -> error "TODO: Pretty print for SoA operation not implemented yet." - AfterVariableLE v vrst loc b -> case vrst of - [] -> if b - then text "fresh" <> (parens $ pprint loc <+> text "+" <+> doc v) - else parens $ pprint loc <+> text "+" <+> doc v - --_ -> case loc of - -- Single x -> error "This should be an SoA loc!" - -- SoA dataBufLoc fieldLocs -> error "TODO: Pretty print for SoA operation not implemented yet." - + 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 From dca44a6cd4e7917fbbfb0e08a9d1801ccc5c1fc6 Mon Sep 17 00:00:00 2001 From: Vidush Singhal Date: Thu, 5 Dec 2024 14:05:47 -0500 Subject: [PATCH 10/11] Add new IR for location after an SoA location. --- gibbon-compiler/src/Gibbon/L2/Syntax.hs | 6 ++++-- gibbon-compiler/src/Gibbon/Passes/InferLocations.hs | 7 ++++--- 2 files changed, 8 insertions(+), 5 deletions(-) diff --git a/gibbon-compiler/src/Gibbon/L2/Syntax.hs b/gibbon-compiler/src/Gibbon/L2/Syntax.hs index 2c4e678f2..5ae3d2ee5 100644 --- a/gibbon-compiler/src/Gibbon/L2/Syntax.hs +++ b/gibbon-compiler/src/Gibbon/L2/Syntax.hs @@ -197,8 +197,10 @@ data PreLocExp loc = StartOfRegionLE Region | FreeLE | FromEndLE loc - | AfterVectorLE [PreLocExp 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) diff --git a/gibbon-compiler/src/Gibbon/Passes/InferLocations.hs b/gibbon-compiler/src/Gibbon/Passes/InferLocations.hs index 61fdb7727..2977c5029 100644 --- a/gibbon-compiler/src/Gibbon/Passes/InferLocations.hs +++ b/gibbon-compiler/src/Gibbon/Passes/InferLocations.hs @@ -276,15 +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. --- [2024.12.04] VS --- For AfterConstantL and AfterVariableL add a list argument with offsets for fields in an SoA location --- Optional for AoS Location. +-- [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 From bd56ec8e530ab7df0647aef9993e61d405907a22 Mon Sep 17 00:00:00 2001 From: vidsinghal Date: Thu, 23 Jan 2025 20:32:22 -0500 Subject: [PATCH 11/11] save work --- gibbon-compiler/examples/add1.hs | 6 +- gibbon-compiler/src/Gibbon/Common.hs | 8 +- gibbon-compiler/src/Gibbon/L2/Examples.hs | 58 +-- gibbon-compiler/src/Gibbon/L2/Syntax.hs | 57 +-- gibbon-compiler/src/Gibbon/L2/Typecheck.hs | 4 +- gibbon-compiler/src/Gibbon/NewL2/Syntax.hs | 2 +- gibbon-compiler/src/Gibbon/Passes/AddRAN.hs | 2 +- .../src/Gibbon/Passes/AddTraversals.hs | 3 +- .../src/Gibbon/Passes/CalculateBounds.hs | 2 +- .../src/Gibbon/Passes/InferLocations.hs | 369 ++++++++++++++---- gibbon-compiler/src/Gibbon/Passes/ParAlloc.hs | 2 +- .../src/Gibbon/Passes/RemoveCopies.hs | 2 +- .../src/Gibbon/Passes/ReorderScalarWrites.hs | 12 +- .../src/Gibbon/Passes/ThreadRegions.hs | 12 +- gibbon-compiler/src/Gibbon/Pretty.hs | 4 +- 15 files changed, 386 insertions(+), 157 deletions(-) diff --git a/gibbon-compiler/examples/add1.hs b/gibbon-compiler/examples/add1.hs index b31d41695..e579d43f3 100644 --- a/gibbon-compiler/examples/add1.hs +++ b/gibbon-compiler/examples/add1.hs @@ -1,9 +1,9 @@ -data Tree = Leaf Int | Node Tree Tree +data Tree = Leaf Int | Node Int Tree Tree add1 :: Tree -> Tree add1 t = case t of Leaf x -> Leaf (x + 1) - Node x1 x2 -> Node (add1 x1) (add1 x2) + Node val x1 x2 -> Node (val+1) (add1 x1) (add1 x2) main :: Tree -main = add1 (Node (Leaf 1) (Leaf 2)) +main = add1 (Node 0 (Leaf 1) (Leaf 2)) diff --git a/gibbon-compiler/src/Gibbon/Common.hs b/gibbon-compiler/src/Gibbon/Common.hs index 969a057d8..4ee157dc9 100644 --- a/gibbon-compiler/src/Gibbon/Common.hs +++ b/gibbon-compiler/src/Gibbon/Common.hs @@ -11,7 +11,7 @@ module Gibbon.Common Var(..), LocVar(..), Location, FieldIndex, DataCon , RegVar, fromVar, toVar, varAppend, toEndV, toEndVLoc, toSeqV, cleanFunName , TyVar(..), isUserTv - , Symbol, intern, unintern + , Symbol, intern, unintern, isSoALoc -- * Gensym monad , SyM, gensym, gensym_tag, genLetter, newUniq, runSyM @@ -166,6 +166,12 @@ instance Out TyVar where docPrec _ = doc + +isSoALoc :: LocVar -> Bool +isSoALoc locvar = case locvar of + Single _ -> False + SoA _ _ -> True + isUserTv :: TyVar -> Bool isUserTv tv = case tv of diff --git a/gibbon-compiler/src/Gibbon/L2/Examples.hs b/gibbon-compiler/src/Gibbon/L2/Examples.hs index 5e931cc22..f47242816 100644 --- a/gibbon-compiler/src/Gibbon/L2/Examples.hs +++ b/gibbon-compiler/src/Gibbon/L2/Examples.hs @@ -54,7 +54,7 @@ add1Fun = FunDef "add1" [ "tr1"] add1FunTy add1FunBod (FunMeta Rec NoInline Fals add1FunTy :: ArrowTy2 Ty2 add1FunTy = ArrowTy2 - [LRM (Single "lin2") (AoSR $ VarR "r3") Input, LRM (Single "lout4") (AoSR $ VarR "r750") Output] + [LRM (Single "lin2") (VarR "r3") Input, LRM (Single "lout4") (VarR "r750") Output] [PackedTy "Tree" (Single "lin2")] S.empty (PackedTy "Tree" (Single "lout4")) @@ -147,7 +147,7 @@ id1Fun = FunDef "id1" [ "tr18"] idFunTy idFunBod (FunMeta NotRec NoInline False) idFunTy :: ArrowTy2 Ty2 idFunTy = ArrowTy2 - [LRM (Single "lin19") (AoSR $ VarR "r20") Input, LRM (Single "lout21") (AoSR $ VarR "r751") Output] + [LRM (Single "lin19") (VarR "r20") Input, LRM (Single "lout21") (VarR "r751") Output] [PackedTy "Tree" (Single "lin19")] (S.empty) (PackedTy "Tree" (Single "lout21")) @@ -164,7 +164,7 @@ copyTreeFun :: FunDef2 copyTreeFun = FunDef "copyTree" [ "tr22"] copyFunTy copyBod (FunMeta NotRec NoInline False) where copyFunTy = ArrowTy2 - [LRM (Single "lin23") (AoSR $ VarR "r24") Input, LRM (Single "lout25") (AoSR$ VarR "r752") Output] + [LRM (Single "lin23") (VarR "r24") Input, LRM (Single "lout25") (VarR "r752") Output] [PackedTy "Tree" (Single "lin23")] S.empty (PackedTy "Tree" (Single "lout25")) @@ -215,7 +215,7 @@ id2Fun = FunDef "id2" [ "tr41"] id2Ty id2Bod (FunMeta NotRec NoInline False) where id2Ty :: ArrowTy2 Ty2 id2Ty = ArrowTy2 - [LRM (Single "lin37") (AoSR $ VarR "r38") Input, LRM (Single "lout39") (AoSR $ VarR "r753") Output] + [LRM (Single "lin37") (VarR "r38") Input, LRM (Single "lout39") (VarR "r753") Output] [PackedTy "Tree" (Single "lin37")] (S.empty) (PackedTy "Tree" (Single "lout39")) @@ -313,7 +313,7 @@ leftmostFun = FunDef "leftmost" [ "t111"] leftmostTy leftmostBod (FunMeta Rec No where leftmostTy :: ArrowTy2 Ty2 leftmostTy = ArrowTy2 - [LRM (Single "lin112") (AoSR $ VarR "r113") Input] + [LRM (Single "lin112") (VarR "r113") Input] [PackedTy "Tree" (Single "lin112")] (S.empty) (IntTy) @@ -354,7 +354,7 @@ rightmostFun = FunDef "rightmost" [ "t242"] rightmostTy rightmostBod (FunMeta Re where rightmostTy :: ArrowTy2 Ty2 rightmostTy = ArrowTy2 - [LRM (Single "lin241") (AoSR $ VarR "r240") Input] + [LRM (Single "lin241") (VarR "r240") Input] [PackedTy "Tree" (Single "lin241")] (S.empty) (IntTy) @@ -400,7 +400,7 @@ buildLeafFun = FunDef "buildLeaf" [ "i125"] buildLeafTy buildLeafBod (FunMeta Re where buildLeafTy :: ArrowTy2 Ty2 buildLeafTy = ArrowTy2 - [LRM (Single "lout126") (AoSR $ VarR "r127") Output] + [LRM (Single "lout126") (VarR "r127") Output] [IntTy] (S.empty) (PackedTy "Tree" (Single "lout126")) @@ -427,7 +427,7 @@ buildTreeFun = FunDef "buildTree" [ "i270"] buildTreeTy buildTreeBod (FunMeta Re where buildTreeTy :: ArrowTy2 Ty2 buildTreeTy = ArrowTy2 - [LRM (Single "lout272") (AoSR $ VarR "r271") Output] + [LRM (Single "lout272") (VarR "r271") Output] [IntTy] (S.empty) (PackedTy "Tree" (Single "lout272")) @@ -467,7 +467,7 @@ buildTwoTreesFun = FunDef "buildTwoTrees" [ "i750"] buildTreeTy buildTreeBod (Fu where buildTreeTy :: ArrowTy2 Ty2 buildTreeTy = ArrowTy2 - [LRM (Single "lout752") (AoSR $ VarR "r751") Output, LRM (Single "lout754") (AoSR $ VarR "r753") Output] + [LRM (Single "lout752") (VarR "r751") Output, LRM (Single "lout754") (VarR "r753") Output] [IntTy] (S.empty) (ProdTy [PackedTy "Tree" (Single "lout752"), PackedTy "Tree" (Single "lout754")]) @@ -504,7 +504,7 @@ buildTreeSumFun = FunDef "buildTreeSum" [ "i302"] buildTreeSumTy buildTreeSumBod where buildTreeSumTy :: ArrowTy2 Ty2 buildTreeSumTy = ArrowTy2 - [LRM (Single "lout301") (AoSR $ VarR "r300") Output] + [LRM (Single "lout301") (VarR "r300") Output] [IntTy] (S.empty) (ProdTy [IntTy, PackedTy "Tree" (Single "lout301")]) @@ -556,7 +556,7 @@ sumTreeFun = FunDef "sumTree" [ "tr762"] sumTreeTy sumTreeBod (FunMeta Rec NoInl where sumTreeTy :: ArrowTy2 Ty2 sumTreeTy = ArrowTy2 - [LRM (Single "lin761") (AoSR $ VarR "r760") Input] + [LRM (Single "lin761") (VarR "r760") Input] [PackedTy "Tree" (Single "lin761")] (S.empty) (IntTy) @@ -646,9 +646,9 @@ addTreesFun = FunDef "addTrees" [ "trees354"] addTreesTy addTreesBod (FunMeta Re where addTreesTy :: ArrowTy2 Ty2 addTreesTy = ArrowTy2 - [LRM (Single "lin351") (AoSR $ VarR "r350") Input, - LRM (Single "lin352") (AoSR $ VarR "r351") Input, - LRM (Single "lout353") (AoSR $ VarR "r754") Output] + [LRM (Single "lin351") (VarR "r350") Input, + LRM (Single "lin352") (VarR "r351") Input, + LRM (Single "lout353") (VarR "r754") Output] [ProdTy [PackedTy "Tree" (Single "lin351"), PackedTy "Tree" (Single "lin352")]] (S.empty) (PackedTy "Tree" (Single "lout353")) @@ -720,7 +720,7 @@ testProdFun :: FunDef2 testProdFun = FunDef "testprod" [ "tup130"] testprodTy testprodBod (FunMeta Rec NoInline False) where testprodTy = ArrowTy2 - [LRM (Single "lin131") (AoSR $ VarR "r132") Input, LRM (Single "lout133") (AoSR $ VarR "r755") Output] + [LRM (Single "lin131") (VarR "r132") Input, LRM (Single "lout133") (VarR "r755") Output] [ProdTy [(PackedTy "Tree" (Single "lin131")), IntTy]] (S.empty) (ProdTy [(PackedTy "Tree" (Single "lout133")), IntTy]) @@ -814,7 +814,7 @@ sumUpFun = FunDef "sumUp" [ "tr1"] sumUpFunTy sumUpFunBod (FunMeta Rec NoInline where sumUpFunTy :: ArrowTy2 Ty2 sumUpFunTy = ArrowTy2 - [LRM (Single "lin501") (AoSR $ VarR "r500") Input, LRM (Single "lout502") (AoSR $ VarR "r756") Output] + [LRM (Single "lin501") (VarR "r500") Input, LRM (Single "lout502") (VarR "r756") Output] [PackedTy "STree" (Single "lin501")] (S.empty) (PackedTy "STree" (Single "lout502")) @@ -853,7 +853,7 @@ valueSTreeFun = FunDef "valueSTree" [ "tr522"] valueSTreeFunTy valueSTreeFunBod where valueSTreeFunTy :: ArrowTy2 Ty2 valueSTreeFunTy = ArrowTy2 - [LRM (Single "lin524") (AoSR $ VarR "r523") Input] + [LRM (Single "lin524") (VarR "r523") Input] [PackedTy "STree" (Single "lin524")] (S.empty) (IntTy) @@ -875,7 +875,7 @@ buildSTreeFun = FunDef "buildSTree" [ "i543"] buildSTreeTy buildSTreeBod (FunMet where buildSTreeTy :: ArrowTy2 Ty2 buildSTreeTy = ArrowTy2 - [LRM (Single "lout541") (AoSR $ VarR "r540") Output] + [LRM (Single "lout541") (VarR "r540") Output] [IntTy] (S.empty) (PackedTy "STree" (Single "lout541")) @@ -923,7 +923,7 @@ sumSTreeFun = FunDef "sumSTree" [ "tr762"] sumSTreeTy sumSTreeBod (FunMeta Rec N where sumSTreeTy :: ArrowTy2 Ty2 sumSTreeTy = ArrowTy2 - [LRM (Single "lin761") (AoSR $ VarR "r760") Input] + [LRM (Single "lin761") (VarR "r760") Input] [PackedTy "STree" (Single "lin761")] (S.empty) (IntTy) @@ -1022,7 +1022,7 @@ setEvenFun = FunDef "setEven" [ "tr570"] setEvenFunTy setEvenFunBod (FunMeta Rec where setEvenFunTy :: ArrowTy2 Ty2 setEvenFunTy = ArrowTy2 - [LRM (Single "lin571") (AoSR $ VarR "r570") Input, LRM (Single "lout572") (AoSR $ VarR "r757") Output] + [LRM (Single "lin571") (VarR "r570") Input, LRM (Single "lout572") (VarR "r757") Output] [PackedTy "STree" (Single "lin571")] (S.empty) (PackedTy "STree" (Single "lout572")) @@ -1105,7 +1105,7 @@ sumUpSetEvenFun = FunDef "sumUpSetEven" [ "tr600"] sumUpSetEvenFunTy sumUpSetEve where sumUpSetEvenFunTy :: ArrowTy2 Ty2 sumUpSetEvenFunTy = ArrowTy2 - [LRM (Single "lin601") (AoSR $ VarR "r600") Input, LRM (Single "lout602") (AoSR $ VarR "r758") Output] + [LRM (Single "lin601") (VarR "r600") Input, LRM (Single "lout602") (VarR "r758") Output] [PackedTy "STree" (Single "lin601")] (S.empty) (ProdTy [PackedTy "STree" (Single "lout602"), IntTy]) @@ -1198,8 +1198,8 @@ copyExprFun = FunDef "copyExpr" [ "e700"] copyExprFunTy copyExprFunBod (FunMeta where copyExprFunTy :: ArrowTy2 Ty2 copyExprFunTy = ArrowTy2 - [LRM (Single "lin702") (AoSR $ VarR "r701") Input, - LRM (Single "lout703") (AoSR $ VarR "r759") Output] + [LRM (Single "lin702") (VarR "r701") Input, + LRM (Single "lout703") (VarR "r759") Output] [PackedTy "Expr" (Single "lin702")] (S.empty) (PackedTy "Expr" (Single "lout703")) @@ -1230,9 +1230,9 @@ substFun = FunDef "subst" [ "tr653"] substFunTy substFunBod (FunMeta Rec NoInlin where substFunTy :: ArrowTy2 Ty2 substFunTy = ArrowTy2 - [LRM (Single "lin651") (AoSR $ VarR "r650") Input, - LRM (Single "lin652") (AoSR $ VarR "r650") Input, - LRM (Single "lout653") (AoSR $ VarR "r760") Output] + [LRM (Single "lin651") (VarR "r650") Input, + LRM (Single "lin652") (VarR "r650") Input, + LRM (Single "lout653") (VarR "r760") Output] [ProdTy [IntTy, PackedTy "Expr" (Single "lin651"), PackedTy "Expr" (Single "lin652")]] @@ -1325,7 +1325,7 @@ indrBuildTreeFun = FunDef "indrBuildTree" [ "i270"] indrBuildTreeTy indrBuildTre where indrBuildTreeTy :: ArrowTy2 Ty2 indrBuildTreeTy = ArrowTy2 - [LRM (Single "lout272") (AoSR $ VarR "r271") Output] + [LRM (Single "lout272") (VarR "r271") Output] [IntTy] (S.empty) (PackedTy "Tree" (Single "lout272")) @@ -1370,7 +1370,7 @@ indrRightmostFun = FunDef "indrRightmost" [ "t742"] indrRightmostTy indrRightmos where indrRightmostTy :: ArrowTy2 Ty2 indrRightmostTy = ArrowTy2 - [LRM (Single "lin741") (AoSR $ VarR "r740") Input] + [LRM (Single "lin741") (VarR "r740") Input] [PackedTy "Tree" (Single "lin741")] S.empty IntTy @@ -1406,7 +1406,7 @@ indrIDFun = FunDef "indrID" [ "tr800"] indrIDTy indrIDBod (FunMeta NotRec NoInli where indrIDTy :: ArrowTy2 Ty2 indrIDTy = ArrowTy2 - [LRM (Single "lin802") (AoSR $ VarR "r801") Input, LRM (Single "lout803") (AoSR $ VarR "r803") Output] + [LRM (Single "lin802") (VarR "r801") Input, LRM (Single "lout803") (VarR "r803") Output] [PackedTy "Tree" (Single "lin802")] (S.empty) (PackedTy "Tree" (Single "lout803")) diff --git a/gibbon-compiler/src/Gibbon/L2/Syntax.hs b/gibbon-compiler/src/Gibbon/L2/Syntax.hs index 5ae3d2ee5..63ec6bd25 100644 --- a/gibbon-compiler/src/Gibbon/L2/Syntax.hs +++ b/gibbon-compiler/src/Gibbon/L2/Syntax.hs @@ -32,7 +32,7 @@ module Gibbon.L2.Syntax -- * Regions and locations , LocVar , Region(..) - , ExtendedRegion(..) + --, ExtendedRegion(..) , Modality(..) , LRM(..) , dummyLRM @@ -484,6 +484,10 @@ data Region = GlobR Var Multiplicity -- ^ A global region with lifetime equal to | MMapR Var -- ^ A region that doesn't result in an (explicit) -- memory allocation. It merely ensures that there -- are no free locations in the program. + + | SoAR Region [((DataCon, FieldIndex), Region)] + + deriving (Read,Show,Eq,Ord, Generic) {- @@ -497,34 +501,41 @@ data Region = GlobR Var Multiplicity -- ^ A global region with lifetime equal to 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 - -- One "flat" buffer makes space for all the data constructors. - -- In addition to a list containing a "flat" buffer for each - -- field. The region can also be mapped to which data constructore - -- and field tuple it belongs to. A structure of arrays representation. - deriving (Read,Show,Eq,Ord, Generic) +-- 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 +-- -- One "flat" buffer makes space for all the data constructors. +-- -- In addition to a list containing a "flat" buffer for each +-- -- field. The region can also be mapped to which data constructore +-- -- and field tuple it belongs to. A structure of arrays representation. +-- deriving (Read,Show,Eq,Ord, Generic) instance Out Region -instance Out ExtendedRegion +-- instance Out ExtendedRegion instance NFData Region where rnf (GlobR v _) = rnf v rnf (DynR v _) = rnf v rnf (VarR v) = rnf v rnf (MMapR v) = rnf v - -instance NFData ExtendedRegion where - rnf (AoSR reg) = rnf reg rnf (SoAR reg fieldRegs) = let - regions = L.map (\(_, fregs) -> fregs) fieldRegs - regions' = L.map rnf regions - in case regions' of - [] -> rnf reg - _ -> L.foldr (\r accum -> r `seq` accum) (rnf reg) regions' + regions = L.map (\(_, fregs) -> fregs) fieldRegs + regions' = L.map rnf regions + in case regions' of + [] -> rnf reg + _ -> L.foldr (\r accum -> r `seq` accum) (rnf reg) regions' + + +-- instance NFData ExtendedRegion where +-- rnf (AoSR reg) = rnf reg +-- rnf (SoAR reg fieldRegs) = let +-- regions = L.map (\(_, fregs) -> fregs) fieldRegs +-- regions' = L.map rnf regions +-- in case regions' of +-- [] -> rnf reg +-- _ -> L.foldr (\r accum -> r `seq` accum) (rnf reg) regions' @@ -539,7 +550,7 @@ instance NFData Modality where -- | A location and region, together with modality. data LRM = LRM { lrmLoc :: LocVar - , lrmReg :: ExtendedRegion + , lrmReg :: Region , lrmMode :: Modality } deriving (Read,Show,Eq,Ord, Generic) @@ -550,7 +561,7 @@ instance NFData LRM where -- | A designated doesn't-really-exist-anywhere location. dummyLRM :: LRM -dummyLRM = LRM (singleLocVar "l_dummy") (AoSR $ VarR "r_dummy") Input +dummyLRM = LRM (singleLocVar "l_dummy") (VarR "r_dummy") Input regionToVar :: Region -> Var regionToVar r = case r of @@ -691,7 +702,7 @@ outLocVars ty = L.map (\(LRM l _ _) -> l) $ outRegVars :: ArrowTy2 ty2 -> [LocVar] outRegVars ty = L.concatMap (\(LRM _ r _) -> case r of - AoSR rr -> [(singleLocVar (regionToVar rr))] + _ -> [(singleLocVar (regionToVar r))] SoAR rr fieldRegions -> let regVars = [regionToVar rr] ++ L.map (\(_, fregs) -> regionToVar fregs) fieldRegions @@ -700,7 +711,7 @@ outRegVars ty = L.concatMap (\(LRM _ r _) -> case r of inRegVars :: ArrowTy2 ty2 -> [LocVar] inRegVars ty = L.nub $ L.concatMap (\(LRM _ r _) -> case r of - AoSR rr -> [singleLocVar $ regionToVar rr] + _ -> [singleLocVar $ regionToVar r] SoAR rr fieldRegions -> let regVars = [regionToVar rr] ++ L.map (\(_, fregs) -> regionToVar fregs) fieldRegions @@ -709,7 +720,7 @@ inRegVars ty = L.nub $ L.concatMap (\(LRM _ r _) -> case r of allRegVars :: ArrowTy2 ty2 -> [LocVar] allRegVars ty = L.nub $ L.concatMap (\(LRM _ r _) -> case r of - AoSR rr -> [singleLocVar $ regionToVar rr] + _ -> [singleLocVar $ regionToVar r] SoAR rr fieldRegions -> [singleLocVar $ regionToVar rr] ++ L.map (\(_, freg) -> singleLocVar $ regionToVar freg) fieldRegions ) (locVars ty) diff --git a/gibbon-compiler/src/Gibbon/L2/Typecheck.hs b/gibbon-compiler/src/Gibbon/L2/Typecheck.hs index 05c49d4dc..2168663f8 100644 --- a/gibbon-compiler/src/Gibbon/L2/Typecheck.hs +++ b/gibbon-compiler/src/Gibbon/L2/Typecheck.hs @@ -1015,7 +1015,7 @@ funRegs :: [LRM] -> RegionSet funRegs ((LRM _l r _m):lrms) = let (RegionSet rs) = funRegs lrms in case r of - AoSR reg -> RegionSet $ S.insert (regionToVar reg) rs + _ -> RegionSet $ S.insert (regionToVar r) rs SoAR _ _ -> error "TODO: Typecheck: implement SoA Region." funRegs [] = RegionSet $ S.empty @@ -1025,7 +1025,7 @@ globalReg = GlobR "GLOBAL" BigInfinite -- | Get the constraints from the location bindings in a function type. funConstrs :: [LRM] -> ConstraintSet funConstrs ((LRM l r _m):lrms) = case r of - AoSR reg -> extendConstrs (InRegionC l reg) $ funConstrs lrms + _ -> extendConstrs (InRegionC l r) $ funConstrs lrms SoAR _ _ -> error "TODO: funConstrs: SoAR case not implemented!" funConstrs [] = ConstraintSet $ S.empty diff --git a/gibbon-compiler/src/Gibbon/NewL2/Syntax.hs b/gibbon-compiler/src/Gibbon/NewL2/Syntax.hs index 5ff7515c3..938a7d227 100644 --- a/gibbon-compiler/src/Gibbon/NewL2/Syntax.hs +++ b/gibbon-compiler/src/Gibbon/NewL2/Syntax.hs @@ -94,7 +94,7 @@ instance NFData LREM where fromLRM :: Old.LRM -> LREM fromLRM (Old.LRM loc reg mode) = case reg of - Old.AoSR r -> LREM loc (Old.regionToVar r) (toEndV (Old.regionToVar r)) mode + _ -> LREM loc (Old.regionToVar reg) (toEndV (Old.regionToVar reg)) mode Old.SoAR _ _ -> error "TODO: NewL2/Syntax.hs, fromLRM, implement SoA region." data LocArg = Loc LREM diff --git a/gibbon-compiler/src/Gibbon/Passes/AddRAN.hs b/gibbon-compiler/src/Gibbon/Passes/AddRAN.hs index a2da2286a..0c6c8c5e2 100644 --- a/gibbon-compiler/src/Gibbon/Passes/AddRAN.hs +++ b/gibbon-compiler/src/Gibbon/Passes/AddRAN.hs @@ -329,8 +329,8 @@ needsRAN Prog{ddefs,fundefs,mainExp} = else let tyenv = M.fromList $ zip funArgs (inTys funTy) env2 = Env2 tyenv funenv renv = M.fromList $ L.map (\lrm -> case (lrmReg lrm) of - AoSR reg -> (lrmLoc lrm, regionToVar reg) SoAR _ _ -> error "TODO: needsRAN structure of arrays not implemented yet." + _ -> (lrmLoc lrm, regionToVar (lrmReg lrm)) ) (locVars funTy) in needsRANExp ddefs fundefs env2 renv M.empty [] funBody diff --git a/gibbon-compiler/src/Gibbon/Passes/AddTraversals.hs b/gibbon-compiler/src/Gibbon/Passes/AddTraversals.hs index 0c70cb381..e19c4c29b 100644 --- a/gibbon-compiler/src/Gibbon/Passes/AddTraversals.hs +++ b/gibbon-compiler/src/Gibbon/Passes/AddTraversals.hs @@ -49,8 +49,9 @@ addTraversalsFn ddefs fundefs f@FunDef{funName, funArgs, funTy, funBody} = do tyenv = M.fromList $ fragileZip funArgs (inTys funTy) env2 = Env2 tyenv funenv renv = M.fromList $ L.map (\lrm -> case (lrmReg lrm) of - AoSR reg -> (lrmLoc lrm, regionToVar reg) SoAR _ _ -> error "TODO: addTraversalsFn structure of arrays not implemented yet." + _ -> (lrmLoc lrm, regionToVar (lrmReg lrm)) + ) (locVars funTy) bod' <- addTraversalsExp ddefs fundefs env2 renv (fromVar funName) funBody diff --git a/gibbon-compiler/src/Gibbon/Passes/CalculateBounds.hs b/gibbon-compiler/src/Gibbon/Passes/CalculateBounds.hs index 6ee58d3e7..2e550018f 100644 --- a/gibbon-compiler/src/Gibbon/Passes/CalculateBounds.hs +++ b/gibbon-compiler/src/Gibbon/Passes/CalculateBounds.hs @@ -34,7 +34,7 @@ calculateBoundsFun ddefs env2 varSzEnv f@FunDef { funName, funBody, funTy, funAr then return f else do let locRegEnv = M.fromList $ map (\lv -> case (lrmReg lv) of - AoSR reg -> (lrmLoc lv, regionToVar reg) + _ -> (lrmLoc lv, regionToVar (lrmReg lv)) SoAR _ _ -> error "TODO: calculateBoundsFn SoA region not implemented." ) (locVars funTy) let locTyEnv = M.map (const $ BoundedSize 0) locRegEnv diff --git a/gibbon-compiler/src/Gibbon/Passes/InferLocations.hs b/gibbon-compiler/src/Gibbon/Passes/InferLocations.hs index 2977c5029..c86d308e2 100644 --- a/gibbon-compiler/src/Gibbon/Passes/InferLocations.hs +++ b/gibbon-compiler/src/Gibbon/Passes/InferLocations.hs @@ -163,7 +163,7 @@ convertFunTy ddefs (from,to,isPar) = do 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) + return $ LRM v (VarR (unwrapLocVar r)) md) (F.toList ls) getSoARegionsFromLocs :: [((DataCon, Int), Var)] -> PassM [((DataCon, Int), Region)] getSoARegionsFromLocs locs = case locs of @@ -265,7 +265,9 @@ type InferState = M.Map LocVar UnifyLoc -- | A location is either fixed or fresh. Two fixed locations cannot unify. data UnifyLoc = FixedLoc LocVar | FreshLoc LocVar - deriving (Show, Eq) + deriving (Show, Eq, Generic) + +instance Out UnifyLoc data Failure = FailUnify Ty2 Ty2 | FailInfer Exp1 @@ -285,6 +287,8 @@ data Constraint = AfterConstantL LocVar Int LocVar | StartRegionL LocVar Region | AfterCopyL LocVar Var Var LocVar Var [LocVar] | FreeL LocVar + -- This might need to change such that there are more constraints to be stored for the + -- data constructor buffer. | AfterSoAL LocVar Constraint [Constraint] LocVar deriving (Show, Eq, Generic) @@ -317,7 +321,7 @@ inferLocs initPrg = do -- Probably should add a small check here Just (me,_ty) -> do (me',ty') <- inferExp' dfs fe me [] NoDest - return $ Just (me',ty') + dbgTraceIt "Print main expression: " dbgTraceIt (sdoc (me')) dbgTraceIt (show fe) dbgTraceIt "End main\n" return $ Just (me',ty') Nothing -> return Nothing fds' <- forM fds $ \(FunDef fn fa (intty,outty) fbod meta) -> do let arrty = lookupFEnv fn fe @@ -326,7 +330,7 @@ inferLocs initPrg = do dest <- destFromType (arrOut arrty) mapM_ fixType_ (arrIns arrty) (fbod',_) <- inferExp' dfs fe' fbod boundLocs dest - return $ FunDef fn fa arrty fbod' meta + dbgTraceIt "Print after inferExp': " dbgTraceIt (sdoc (fn, fbod')) dbgTraceIt "End inferExp'\n" return $ FunDef fn fa arrty fbod' meta return $ Prog dfs' fds' me' prg <- St.runStateT (runExceptT m) M.empty case fst prg of @@ -351,7 +355,7 @@ locsInDest d = case d of destFromType :: Ty2 -> TiM Dest destFromType frt = case frt of - PackedTy _tc lv -> fixLoc lv >> return (SingleDest lv) + PackedTy _tc lv -> fixLoc lv >> dbgTraceIt "destFromType:: " dbgTraceIt (sdoc (lv)) dbgTraceIt "End destFromType.\n" return (SingleDest lv) ProdTy tys -> mapM destFromType tys >>= return . TupleDest _ -> return NoDest @@ -415,6 +419,15 @@ inferExp' ddefs env exp bound dest= expr' = foldr addLetLoc expr constrs' addLetLoc i a = case i of + -- AfterSoALE (PreLocExp loc) [PreLocExp loc] loc + AfterSoAL lv1 dconConstr fieldConstrs lv2 -> let dataConExpression = case dconConstr of + AfterTagL lv1 lv2 -> AfterConstantLE 1 lv2 + _ -> error "bindAllLocations case not handled!" + fieldLocExprs = P.map (\c -> case c of + AfterConstantL lv1 v lv2 -> AfterConstantLE v lv2 + AfterVariableL lv1 v lv2 -> AfterVariableLE v lv2 True + ) fieldConstrs + in Ext (LetLocE lv1 (AfterSoALE dataConExpression fieldLocExprs lv2) a) 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))) @@ -432,12 +445,12 @@ inferExp' ddefs env exp bound dest= Ext (LetLocE lv1 (AfterVariableLE v' lv2 True) a') in do res <- inferExp ddefs env exp dest - (e,ty,cs) <- bindAllLocations res - e' <- finishExp e - let (e'',s) = dbgTraceIt "\n" cleanExp e' + (e,ty,cs) <- dbgTraceIt "Print res after inferExp: " dbgTraceIt (sdoc (res)) dbgTraceIt "End inferExp call.\n" bindAllLocations res + e' <- dbgTraceIt "Print after bind all locations: " dbgTraceIt (sdoc (e, ty, cs)) dbgTraceIt "End bindAllLocations.\n" finishExp e + let (e'',s) = cleanExp e' unbound = (s S.\\ S.fromList bound) - e''' <- bindAllUnbound e'' (S.toList unbound) - dbgTraceIt "Print in inferExp': " dbgTraceIt (sdoc (e, e', e'', e''')) dbgTraceIt "End\n" return (e''',ty) + e''' <- dbgTraceIt "Print after finishExp: " dbgTraceIt (sdoc (e, e', e'', s)) dbgTraceIt "End after finishExp.\n" bindAllUnbound e'' (S.toList unbound) + return (e''',ty) -- | We proceed in a destination-passing style given the target region -- into which we must produce the resulting value. @@ -478,12 +491,27 @@ inferExp ddefs env@FullEnv{dataDefs} ex0 dest = tryInRegion' :: [Constraint] -> [Constraint] -> TiM [Constraint] tryInRegion' fcs (c:cs) = case c of + AfterSoAL lv1 dc fc lv2 -> + do lv1' <- finalLocVar lv1 + lv2' <- finalLocVar lv2 + b1 <- noBeforeLoc lv2' fcs + b2 <- noRegionStart lv2' fcs + b3 <- notFixedLoc lv2' + b3' <- dbgTraceIt "tryInRegion': " dbgTraceIt (sdoc (b1, b2, b3, lv2')) dbgTraceIt "End tryInRegion' aftersoaloc.\n" notFixedLoc lv2' + if b1 && b2 && b3 + then do cs' <- tryInRegion' fcs cs + r <- getNewRegion lv2' + let c' = StartRegionL lv2' r + return (c':c:cs') + else do cs' <- tryInRegion' fcs cs + return (c:cs') AfterTagL lv1 lv2 -> do lv1' <- finalLocVar lv1 lv2' <- finalLocVar lv2 b1 <- noBeforeLoc lv2' fcs b2 <- noRegionStart lv2' fcs b3 <- notFixedLoc lv2' + b3' <- dbgTraceIt "tryInRegion' aftertag: " dbgTraceIt (sdoc (b1, b2, b3, lv2, lv2')) dbgTraceIt "End tryInRegion' afterTag.\n" notFixedLoc lv2' if b1 && b2 && b3 then do cs' <- tryInRegion' fcs cs r <- lift $ lift $ freshRegVar @@ -495,6 +523,36 @@ inferExp ddefs env@FullEnv{dataDefs} ex0 dest = return (c:cs') tryInRegion' _ [] = return [] + getNewRegion :: LocVar -> TiM Region + getNewRegion lc = do + case (isSoALoc lc) of + -- In case of an SoA loc, we need to construct an SoAR region. + True -> do + r <- makeSoARegion lc + return r + False -> do + r <- lift $ lift $ freshRegVar + return r + + makeSoARegion :: LocVar -> TiM Region + makeSoARegion loc = do + case loc of + SoA dbuf rst -> do + dbufRegion <- lift $ lift $ freshRegVar + rstRegions <- makeSoARFields rst + return $ SoAR dbufRegion rstRegions + _ -> error "makeSoARegion: did not expect a location other than a SoA location." + + makeSoARFields :: [((DataCon, Int), Var)] -> TiM [((DataCon, Int), Region)] + makeSoARFields lst = do + case lst of + [] -> return [] + ((d, index), loc):rst -> do + fieldReg <- lift $ lift $ freshRegVar + rst' <- makeSoARFields rst + return $ [((d, index), fieldReg)] ++ rst' + + -- | This function looks at a series of locations and a type, and determines if -- any of those locations could be the start of a region. Similar to `tryInRegion`. -- A location might be the start of a region if there's nothing before it and @@ -502,6 +560,7 @@ inferExp ddefs env@FullEnv{dataDefs} ex0 dest = tryNeedRegion :: [LocVar] -> Ty2 -> [Constraint] -> TiM [Constraint] tryNeedRegion (l:ls) ty cs = do lv <- finalLocVar l + -- dbgTraceIt "Print (l, lv): " dbgTraceIt (sdoc (l, lv)) dbgTraceIt "End lv\n" vls <- mapM finalLocVar (locsInTy ty) if not (lv `L.elem` vls) then do b1 <- noBeforeLoc lv cs @@ -509,10 +568,16 @@ inferExp ddefs env@FullEnv{dataDefs} ex0 dest = b3 <- notFixedLoc lv if b1 && b2 && b3 then do cs' <- tryNeedRegion ls ty cs - r <- lift $ lift $ freshRegVar + -- TODO, in case of a SoA loc + -- We need an SoAR region. + -- That SoA loc would be the start of the SoAR region. + r <- getNewRegion lv + -- dbgTraceIt "Print output from getNewRegion " dbgTraceIt (sdoc (r)) dbgTraceIt "End getNewRegion.\n" let c = StartRegionL lv r + -- dbgTraceIt "tryInRegion true" dbgTraceIt (sdoc (b1, b2, b3, r, lv, l, vls)) dbgTraceIt "End tryInRegion true\n" return (c:cs') else tryNeedRegion ls ty cs + -- dbgTraceIt "tryInRegion false" dbgTraceIt (sdoc (b1, b2, b3, lv, l, vls)) dbgTraceIt "End tryInRegion false\n" else tryNeedRegion ls ty cs tryNeedRegion [] _ cs = return cs @@ -672,7 +737,7 @@ inferExp ddefs env@FullEnv{dataDefs} ex0 dest = (copy (e',ty,[]) d) ProjE i w -> do - (e', ty) <- case w of + (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 ddefs env w dest case dest of @@ -732,7 +797,7 @@ inferExp ddefs env@FullEnv{dataDefs} ex0 dest = case dest of SingleDest d -> do case locsInTy valTy of - [outloc] -> unify d outloc + [outloc] -> dbgTraceIt "Print in AppE" dbgTraceIt (sdoc (valTy, d)) dbgTraceIt "\n" unify d outloc (return (L2.AppE f (concatMap locsInTy atys ++ locsInDest dest) args', valTy, acs)) (err$ "(AppE) Cannot unify" ++ sdoc d ++ " and " ++ sdoc outloc) _ -> err$ "AppE expected a single output location in type: " ++ sdoc valTy @@ -744,7 +809,7 @@ inferExp ddefs env@FullEnv{dataDefs} ex0 dest = _ -> err$ "(AppE) Cannot unify" ++ sdoc dest ++ " and " ++ sdoc valTy NoDest -> case locsInTy valTy of - [] -> return (L2.AppE f (concatMap locsInTy atys ++ locsInDest dest) args', valTy, acs) + [] -> dbgTraceIt "Print in AppE NoDest" dbgTraceIt (sdoc (valTy, NoDest)) dbgTraceIt "\n" return (L2.AppE f (concatMap locsInTy atys ++ locsInDest dest) args', valTy, acs) _ -> 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 -> @@ -761,8 +826,16 @@ inferExp ddefs env@FullEnv{dataDefs} ex0 dest = TupleDest _ds -> err $ "Expected single location destination for DataConE" ++ sdoc ex0 SingleDest d -> do fakeLoc <- fresh - let constrs = [AfterTagL fakeLoc d] - return (DataConE d k [], PackedTy (getTyOfDataCon dataDefs k) d, constrs) + case d of + Single lc -> do + let constrs = [AfterTagL fakeLoc d] + dbgTraceIt "inferExp DataConE single " dbgTraceIt (sdoc (d, constrs)) dbgTraceIt "End inferExp single DataConE.\n" return (DataConE d k [], PackedTy (getTyOfDataCon dataDefs k) d, constrs) + SoA dl fls -> do + -- VS: does this constraint still need to be generated?? + -- For now, I am commenting it out. + let constrs = [] --[AfterTagL fakeLoc (singleLocVar dl)] + dbgTraceIt "inferExp DataConE soa " dbgTraceIt (sdoc (dl)) dbgTraceIt "End soa inferExp DataConE.\n" return (DataConE d k [], PackedTy (getTyOfDataCon dataDefs k) d, constrs) + DataConE () k ls -> case dest of @@ -774,17 +847,21 @@ inferExp ddefs env@FullEnv{dataDefs} ex0 dest = tryBindReg (e', ty, fcs) TupleDest _ds -> err $ "Expected single location destination for DataConE" ++ sdoc ex0 SingleDest d -> do + {- + VS: Here we assign new locations for each argument + in the data contructor. + -} locs <- sequence $ replicate (length ls) fresh mapM_ fixLoc locs -- Don't allow argument locations to freely unify - ls' <- mapM (\(e,lv) -> (inferExp ddefs env e $ SingleDest lv)) $ zip ls locs + ls' <- dbgTraceIt "Print in SingleDest inferExp " dbgTraceIt (sdoc (locs)) dbgTraceIt "End SingleDest inferExp.\n" 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 -- Arguments are either a fixed size or a variable -- TODO: audit this! argLs <- forM [a | (a,_,_) <- ls'] $ \arg -> - case arg of - (VarE v) -> case lookupVEnv v env of + case arg of + (VarE v) -> case lookupVEnv v env of CursorTy -> return $ ArgFixed 8 IntTy -> return $ ArgFixed (fromJust $ sizeOfTy IntTy) FloatTy -> return $ ArgFixed (fromJust $ sizeOfTy FloatTy) @@ -794,17 +871,25 @@ inferExp ddefs env@FullEnv{dataDefs} ex0 dest = VectorTy elt -> return $ ArgFixed (fromJust $ sizeOfTy (VectorTy elt)) ListTy elt -> return $ ArgFixed (fromJust $ sizeOfTy (ListTy elt)) _ -> return $ ArgVar v - (LitE _) -> return $ ArgFixed (fromJust $ sizeOfTy IntTy) - (FloatE _) -> return $ ArgFixed (fromJust $ sizeOfTy FloatTy) - (LitSymE _) -> return $ ArgFixed (fromJust $ sizeOfTy SymTy) - (PrimAppE MkTrue []) -> return $ ArgFixed (fromJust $ sizeOfTy BoolTy) - (PrimAppE MkFalse []) -> return $ ArgFixed (fromJust $ sizeOfTy BoolTy) - (AppE f lvs [(VarE v)]) -> do v' <- lift $ lift $ freshLocVar "cpy" - return $ ArgCopy v (unwrapLocVar v') f lvs - _ -> err $ "Expected argument to be trivial, got " ++ (show arg) + (LitE _) -> return $ ArgFixed (fromJust $ sizeOfTy IntTy) + (FloatE _) -> return $ ArgFixed (fromJust $ sizeOfTy FloatTy) + (LitSymE _) -> return $ ArgFixed (fromJust $ sizeOfTy SymTy) + (PrimAppE MkTrue []) -> return $ ArgFixed (fromJust $ sizeOfTy BoolTy) + (PrimAppE MkFalse []) -> return $ ArgFixed (fromJust $ sizeOfTy BoolTy) + (AppE f lvs [(VarE v)]) -> do + v' <- lift $ lift $ freshLocVar "cpy" + 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. + let afterVar :: (DCArg, Maybe LocVar, Maybe LocVar) -> Maybe Constraint + afterVar ((ArgVar v), (Just loc1), (Just loc2)) = + Just $ AfterVariableL loc1 v loc2 + afterVar ((ArgFixed s), (Just loc1), (Just loc2)) = + Just $ AfterConstantL loc1 s loc2 + afterVar ((ArgCopy v v' f lvs), (Just loc1), (Just loc2)) = + Just $ AfterCopyL loc1 v v' loc2 f lvs + afterVar _ = Nothing + {- VS: Case d of Single loc -> This remains the same as now SoA dataBufferLoc fieldLocs -> @@ -813,40 +898,37 @@ inferExp ddefs env@FullEnv{dataDefs} ex0 dest = 3.) fieldLocs for each argument to the data constructor check its type - add DCArg constraints but using locs for the - dataBufferLoc and fieldLocs + add constraints ... -} - let afterVar :: (DCArg, Maybe LocVar, Maybe LocVar) -> Maybe Constraint - afterVar ((ArgVar v), (Just loc1), (Just loc2)) = - Just $ AfterVariableL loc1 v loc2 - afterVar ((ArgFixed s), (Just loc1), (Just loc2)) = - Just $ AfterConstantL loc1 s loc2 - afterVar ((ArgCopy v v' f lvs), (Just loc1), (Just loc2)) = - Just $ AfterCopyL loc1 v v' loc2 f lvs - afterVar _ = Nothing - constrs = concat $ [c | (_,_,c) <- ls'] - constrs' = if null locs - then constrs - else let tmpconstrs = [AfterTagL (Sf.headErr locs) d] ++ - (mapMaybe afterVar $ zip3 - -- ((map Just $ L.tail ([a | (a,_,_) <- ls' ])) ++ [Nothing]) - argLs - -- (map Just locs) - ((map Just $ Sf.tailErr locs) ++ [Nothing]) - (map Just locs)) - -- ((map Just $ L.tail locs) ++ [Nothing])) ++ - 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 + case d of + Single dVar -> do + let constrs = concat $ [c | (_,_,c) <- ls'] + constrs' = if null locs + then constrs + else let tmpconstrs = [AfterTagL (Sf.headErr locs) d] ++ + (mapMaybe afterVar $ zip3 + -- ((map Just $ L.tail ([a | (a,_,_) <- ls' ])) ++ [Nothing]) + argLs + -- (map Just locs) + ((map Just $ Sf.tailErr locs) ++ [Nothing]) + (map Just locs)) + -- ((map Just $ L.tail locs) ++ [Nothing])) ++ + in dbgTraceIt "Print in afterVar" dbgTraceIt (sdoc (locs, argLs, ls')) dbgTraceIt "\n" tmpconstrs ++ constrs + -- traceShow k $ traceShow locs $ + --let newe = buildLets bnds $ DataConE d k [ e' | (e',_,_) <- ls''] + -- case d of + -- Single loc -> + -- SoA dataConLoc fieldLocs -> + -- dbgTraceIt "Print contrs'" dbgTraceIt (sdoc constrs') dbgTraceIt "\n" + ls'' <- forM (zip argLs ls') $ \(arg,(e,ty,cs)) -> do case e of (AppE _ _ _) -> case arg of ArgCopy _ v' _ _ -> return (VarE v',ty,cs) _ -> undefined _ -> return (e,ty,cs) - -- bod <- return $ DataConE d k [ e' | (e',_,_) <- ls''] - bod <- if (length ls) > 0 && (isCpyCall $ last [e | (e,_,_) <- ls']) - then case last [e | (e,_,_) <- ls'] of + -- bod <- return $ DataConE d k [ e' | (e',_,_) <- ls''] + bod <- if (length ls) > 0 && (isCpyCall $ last [e | (e,_,_) <- ls']) + then case last [e | (e,_,_) <- ls'] of (AppE f lvs e) -> let (ArgCopy _ v' _ copy_locs) = last argLs arrty = arrOut $ lookupFEnv f env @@ -859,8 +941,102 @@ inferExp ddefs env@FullEnv{dataDefs} ex0 dest = in return $ LetE (v',[],copyRetTy, AppE f lvs e) $ DataConE d k [ e' | (e',_,_) <- ls''] _ -> error "inferExp: Unexpected pattern " - else return $ DataConE d k [ e' | (e',_,_) <- ls''] - return (bod, PackedTy (getTyOfDataCon dataDefs k) d, constrs') + else return $ DataConE d k [ e' | (e',_,_) <- ls''] + return (bod, PackedTy (getTyOfDataCon dataDefs k) d, constrs') + SoA dataBufferVar fieldLocs -> do + let dataBufferLoc = Single dataBufferVar + -- Some locs need to be sequentialized with respect to the + -- data contructor buffer. These are the recursive fields, + -- the same datatype. + tyConOfDataCon = getTyOfDataCon ddefs k + (idxsWriteDconBuf, idxsFields) = L.foldr (\res@(_, ty, _) (w, f) -> case ty of + PackedTy tycon _ -> if tycon == tyConOfDataCon + then (w ++ [L.elemIndex res ls'], f) + else (w, f ++ [L.elemIndex res ls']) + _ -> (w, f ++ [L.elemIndex res ls']) + ) ([], []) ls' + idxsWriteDconBuf' = L.reverse idxsWriteDconBuf + idxsFields' = L.reverse idxsFields + argsLsDconBuf = L.map (\(Just idx) -> ls' !! idx) idxsWriteDconBuf' + dcArgDconBuf = L.map (\(Just idx) -> argLs !! idx) idxsWriteDconBuf' + locsDconBuf = L.map (\(Just idx) -> locs !! idx) idxsWriteDconBuf' + -- Other fields need to have constraints with their own output region. + argsLsFields = L.map (\(Just idx) -> ls' !! idx) idxsFields' + dcArgFields = L.map (\(Just idx) -> argLs !! idx) idxsFields' + locsFields = L.map (\(Just idx) -> locs !! idx) idxsFields' + -- Generate the constraints around the data constructor buffer. + -- Generate the constraint right after the DataConstructor Tag. + dataBufferConstraints = case locsDconBuf of + [] -> [] + _ -> let afterTagConstraint = AfterTagL (Sf.headErr locsDconBuf) dataBufferLoc + afterTagConstrsTmp = (mapMaybe afterVar $ zip3 + dcArgDconBuf + ((map Just $ Sf.tailErr locsDconBuf) ++ [Nothing]) + (map Just locsDconBuf) + ) + in [afterTagConstraint] ++ afterTagConstrsTmp + fieldLocVars = P.concatMap (\( (dk, _), locVar) -> if dk == k + then [Single locVar] + else [] + ) fieldLocs + fieldConstraints = (mapMaybe afterVar $ zip3 + dcArgFields + (map Just locsFields) + (map Just fieldLocVars) + ) + -- Generate the constraints around the field buffers. + constrs = concat $ [c | (_,_,c) <- ls'] + out = case dataBufferConstraints of + [dc] -> case dc of + AfterTagL loc_new loc_old -> let newFieldLocs = case d of + SoA dataConLocOld fieldLocsOld -> + P.concatMap (\e@((dcon, findex), locationVar) -> P.concatMap (\cons -> case cons of + AfterConstantL nl _ ol -> if (ol == singleLocVar locationVar) + then [((dcon, findex), unwrapLocVar nl)] + else [] + _ -> error "inferExp: TODO constraint not implemented!" + + ) fieldConstraints + ) fieldLocsOld + newLoc = SoA (unwrapLocVar loc_new) newFieldLocs + soa_constraint = AfterSoAL newLoc dc fieldConstraints d + in soa_constraint + _ -> error "TODO: InferExp SoA, other than AfterTag constraint not expected." + + _ -> error "TODO: InferExp SoA, more that one data constructor constraint not handled." + --newLocVar = + -- SoAConstraints = AfterSoAL LocVar Constraint [Constraint] LocVar + -- dataBufferConstraints ++ fieldConstraints + constrs' = dbgTraceIt "Print dconConstrs" dbgTraceIt (sdoc (d, dataBufferConstraints, fieldConstraints, constrs, out)) dbgTraceIt "End Constraints.\n" [out] ++ constrs + -- traceShow k $ traceShow locs $ + --let newe = buildLets bnds $ DataConE d k [ e' | (e',_,_) <- ls''] + -- case d of + -- Single loc -> + -- SoA dataConLoc fieldLocs -> + -- dbgTraceIt "Print contrs'" dbgTraceIt (sdoc constrs') dbgTraceIt "\n" + ls'' <- forM (zip argLs ls') $ \(arg,(e,ty,cs)) -> do + case e of + (AppE _ _ _) -> case arg of + ArgCopy _ v' _ _ -> return (VarE v',ty,cs) + _ -> undefined + _ -> return (e,ty,cs) + -- bod <- return $ DataConE d k [ e' | (e',_,_) <- ls''] + bod <- if (length ls) > 0 && (isCpyCall $ last [e | (e,_,_) <- ls']) + then case last [e | (e,_,_) <- ls'] of + (AppE f lvs e) -> + let (ArgCopy _ v' _ copy_locs) = last argLs + arrty = arrOut $ lookupFEnv f env + -- Substitute the location occurring at the call site + -- in place of the one in the function's return type + -- re:last because we want the output location. + copyRetTy = case arrty of + PackedTy _ loc -> substLoc (M.singleton loc (last copy_locs)) arrty + _ -> error "inferExp: Not a packed type" + in return $ LetE (v',[],copyRetTy, AppE f lvs e) $ + DataConE d k [ e' | (e',_,_) <- ls''] + _ -> error "inferExp: Unexpected pattern " + else return $ DataConE d k [ e' | (e',_,_) <- ls''] + return (bod, PackedTy (getTyOfDataCon dataDefs k) d, constrs') IfE a b c@ce -> do -- Here we blithely assume BoolTy because L1 typechecking has already passed: @@ -980,19 +1156,23 @@ inferExp ddefs env@FullEnv{dataDefs} ex0 dest = let arrty = lookupFEnv f env valTy <- freshTyLocs $ arrOut arrty -- /cc @vollmerm - argTys <- dbgTraceIt "Print in inferExp, AppE: " dbgTraceIt (sdoc (valTy, arrOut arrty)) dbgTraceIt "End\n" mapM freshTyLocs $ arrIns arrty + argTys <- mapM freshTyLocs $ arrIns arrty argDests <- mapM destFromType' argTys (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 ddefs (extendVEnv vr valTy env) tupBod dest - (bod'',ty'',cs'') <- handleTrailingBindLoc vr res - vcs <- tryNeedRegion (locsInTy valTy) ty'' $ acs ++ cs'' + (bod'',ty'',cs'') <- dbgTraceIt "Print res LetE, inferExp " dbgTraceIt (sdoc (f, res)) dbgTraceIt "End inferExp.\n" handleTrailingBindLoc vr res + let conc_ass_cs'' = acs ++ cs'' + let locs_in_valty = locsInTy valTy + vcs <- tryNeedRegion locs_in_valty ty'' $ conc_ass_cs'' fcs <- tryInRegion vcs + -- dbgTraceIt "Print handle trailing bind loc: " dbgTraceIt (sdoc (ex0, bod'', res, valTy, locs_in_valty, ty'', f)) dbgTraceIt "End handle trailing bind loc\n" -- fcs <- tryInRegion $ acs ++ cs'' - res' <- tryBindReg (L2.LetE (vr,[], valTy, L2.AppE f (concatMap locsInTy atys ++ locsInTy valTy) args') bod'', ty'', fcs) + -- dbgTraceIt "inferExp: Let, AppE: " dbgTraceIt (sdoc (vcs, fcs, res, res', res'', valTy, bod'')) dbgTraceIt "print more: " dbgTraceIt (sdoc (cs'', argDests, argTys, ty'', args', atys, tupBod)) dbgTraceIt "End inferExp (Let, AppE)\n" + res' <- dbgTraceIt "(vcs, fcs) " dbgTraceIt (sdoc (vcs, fcs)) dbgTraceIt "End (vcs, fcs).\n" tryBindReg (L2.LetE (vr,[], valTy, L2.AppE f (concatMap locsInTy atys ++ locsInTy valTy) args') bod'', ty'', fcs) res'' <- bindImmediateDependentLocs (concatMap locsInTy atys ++ locsInTy valTy) res' - dbgTraceIt "inferExp: Let, AppE: " dbgTraceIt (sdoc (res', res'')) dbgTraceIt "\n" return res'' + return res'' AppE{} -> err$ "Malformed function application: " ++ (show ex0) @@ -1285,7 +1465,7 @@ finishExp e = e2' <- finishExp e2 ls' <- mapM finalLocVar ls t' <- finishTy t - return $ LetE (v,ls',t',e1') e2' + dbgTraceIt "Print in finishExp LetE: " dbgTraceIt (sdoc (ls, t, v, e1, ls', t', e1')) dbgTraceIt "End finishExp LetE.\n" return $ LetE (v,ls',t',e1') e2' IfE e1 e2 e3 -> do e1' <- finishExp e1 e2' <- finishExp e2 @@ -1367,7 +1547,7 @@ finishTy t = case t of PackedTy tc lv -> do lv' <- finalLocVar lv - return $ PackedTy tc lv' + dbgTraceIt "Print in finishTy" dbgTraceIt (sdoc (t, lv, lv')) dbgTraceIt "End in finishTy.\n" return $ PackedTy tc lv' ProdTy pls -> do pls' <- mapM finishTy pls return $ ProdTy pls' @@ -1615,6 +1795,8 @@ noAfterLoc lv fcs (c:cs) = _ -> noAfterLoc lv fcs cs noAfterLoc _ _ [] = return True +-- This function checks to see if there are any +-- locations before the current location. noBeforeLoc :: LocVar -> [Constraint] -> TiM Bool noBeforeLoc lv (c:cs) = case c of @@ -1630,6 +1812,11 @@ noBeforeLoc lv (c:cs) = do lv1' <- finalLocVar lv1 lv' <- finalLocVar lv if lv' == lv1' then return False else noBeforeLoc lv cs + -- Location after SoAL + AfterSoAL lv1 dconConstr fieldConstrs lv2 -> + do lv1' <- finalLocVar lv1 + lv' <- finalLocVar lv + if lv' == lv1' then return False else noBeforeLoc lv cs _ -> noBeforeLoc lv cs noBeforeLoc lv [] = return True @@ -1696,27 +1883,31 @@ freshRegVar :: PassM Region freshRegVar = do rv <- gensym (toVar "r") return $ VarR rv +-- VS: ATM, for an SoA location, UnifyLoc does not unify locations correctly +-- The type of the location in main expression is not an SoALoc. +-- Fix the let regions and letlocs for the main expression in first then check again +-- if the downstream locations unify correctly. finalUnifyLoc :: LocVar -> TiM UnifyLoc finalUnifyLoc v = do m <- lift $ St.get case M.lookup v m of - Nothing -> return (FreshLoc v) - Just (FixedLoc v') -> return (FixedLoc v') - Just (FreshLoc v') -> finalUnifyLoc v' + Nothing -> dbgTraceIt "finalUnifyLoc Nothing" dbgTraceIt (sdoc v) dbgTraceIt "End finalUnifyLoc 1\n" return (FreshLoc v) + Just (FixedLoc v') -> dbgTraceIt "finalUnifyLoc FixedLoc" dbgTraceIt (sdoc (v, v')) dbgTraceIt "End finalUnifyLoc 2\n" return (FixedLoc v') + Just (FreshLoc v') -> dbgTraceIt "finalUnifyLoc FreshLoc" dbgTraceIt (sdoc (v, v')) dbgTraceIt "End finalUnifyLoc 3\n" finalUnifyLoc v' notFixedLoc :: LocVar -> TiM Bool notFixedLoc lv = do uv <- finalUnifyLoc lv case uv of - FixedLoc _ -> return False + FixedLoc _ -> dbgTraceIt "Print in notFixedLoc: " dbgTraceIt (sdoc (uv, lv)) dbgTraceIt "End in notFixedLoc.\n" return False _ -> return True finalLocVar :: LocVar -> TiM LocVar finalLocVar v = do u <- finalUnifyLoc v case u of - FixedLoc v' -> return v' - FreshLoc v' -> return v' + FixedLoc v' -> dbgTraceIt "FinalLocVar fixed " dbgTraceIt (sdoc (v, u, v')) dbgTraceIt "End FinalLocVar Fixed\n" return v' + FreshLoc v' -> dbgTraceIt "FinalLocVar fresh " dbgTraceIt (sdoc (v, u, v')) dbgTraceIt "End FinalLocVar Fresh\n" return v' fresh :: TiM LocVar fresh = do @@ -1727,28 +1918,48 @@ freshUnifyLoc = do lv <- fresh return $ FreshLoc lv +freshSoALoc :: LocVar -> TiM LocVar +freshSoALoc lc = do + case lc of + Single _ -> do + l' <- fresh + return l' + SoA dbuf rst -> do + dbuf' <- fresh + rst' <- freshTyLocsSoA rst + let newSoALoc = SoA (unwrapLocVar dbuf') rst' + return newSoALoc + + lookupUnifyLoc :: LocVar -> TiM UnifyLoc lookupUnifyLoc lv = do m <- lift $ St.get case M.lookup lv m of Nothing -> do - l' <- fresh - lift $ St.put $ M.insert lv (FreshLoc l') m - return $ FreshLoc l' - Just (FreshLoc l') -> finalUnifyLoc l' - Just (FixedLoc l') -> return $ FixedLoc l' + case lv of + SoA dbufLoc rstLocs -> do + -- TODO: generate a new SoA Location here + l' <- freshSoALoc lv + lift $ St.put $ M.insert lv (FreshLoc l') m + dbgTraceIt "LookupUnifyLoc Nothing" dbgTraceIt (sdoc (lv, l')) dbgTraceIt "End LookupUnifyLoc Fresh\n" return $ FreshLoc l' + Single _ -> do + l' <- fresh + lift $ St.put $ M.insert lv (FreshLoc l') m + dbgTraceIt "LookupUnifyLoc Nothing" dbgTraceIt (sdoc (lv, l')) dbgTraceIt "End LookupUnifyLoc Fresh\n" return $ FreshLoc l' + Just (FreshLoc l') -> dbgTraceIt "LookupUnifyLoc Fresh" dbgTraceIt (sdoc (lv, l')) dbgTraceIt "End LookupUnifyLoc Fresh\n" finalUnifyLoc l' + Just (FixedLoc l') -> dbgTraceIt "LookupUnifyLoc Fixed" dbgTraceIt (sdoc (lv, l')) dbgTraceIt "End LookupUnifyLoc Fixed\n" return $ FixedLoc l' fixLoc :: LocVar -> TiM UnifyLoc fixLoc lv = do -- l' <- fresh - m <- lift $ St.get + m <- dbgTraceIt "Print in fixLoc " dbgTraceIt (sdoc (lv)) dbgTraceIt "End fixloc.\n" lift $ St.get lift $ St.put $ M.insert lv (FixedLoc lv) m return $ FixedLoc lv assocLoc :: LocVar -> UnifyLoc -> TiM () assocLoc lv ul = do m <- lift $ St.get - lift $ St.put $ M.insert lv ul m + dbgTraceIt "Print in assocLoc " dbgTraceIt (sdoc (lv, ul)) dbgTraceIt "End in assocLoc.\n" lift $ St.put $ M.insert lv ul m -- | The copy repair tactic: copy :: Result -> LocVar -> TiM Result diff --git a/gibbon-compiler/src/Gibbon/Passes/ParAlloc.hs b/gibbon-compiler/src/Gibbon/Passes/ParAlloc.hs index 56b21747a..1ad95f803 100644 --- a/gibbon-compiler/src/Gibbon/Passes/ParAlloc.hs +++ b/gibbon-compiler/src/Gibbon/Passes/ParAlloc.hs @@ -76,7 +76,7 @@ parAlloc Prog{ddefs,fundefs,mainExp} = do error "gibbon: Cannot compile parallel allocations in Gibbon1 mode." let initRegEnv = M.fromList $ map (\(LRM lc r _) -> case r of - AoSR reg -> (lc, regionToVar reg) + _ -> (lc, regionToVar r) SoAR _ _ -> error "TODO: parAlloc structure of arrays not implemented yet." ) (locVars funTy) funArgs' = L.map Single funArgs diff --git a/gibbon-compiler/src/Gibbon/Passes/RemoveCopies.hs b/gibbon-compiler/src/Gibbon/Passes/RemoveCopies.hs index e6e892be7..d63901136 100644 --- a/gibbon-compiler/src/Gibbon/Passes/RemoveCopies.hs +++ b/gibbon-compiler/src/Gibbon/Passes/RemoveCopies.hs @@ -36,7 +36,7 @@ removeCopies Prog{ddefs,fundefs,mainExp} = do removeCopiesFn :: DDefs Ty2 -> FunDefs2 -> FunDef2 -> PassM FunDef2 removeCopiesFn ddefs fundefs f@FunDef{funArgs,funTy,funBody} = do let initLocEnv = M.fromList $ map (\(LRM lc r _) -> case r of - AoSR reg -> (lc, regionToVar reg) + _ -> (lc, regionToVar r) SoAR _ _ -> error "TODO: removeCopiesFn structure of arrays not implemented yet." ) (locVars funTy) initTyEnv = M.fromList $ zip funArgs (arrIns funTy) diff --git a/gibbon-compiler/src/Gibbon/Passes/ReorderScalarWrites.hs b/gibbon-compiler/src/Gibbon/Passes/ReorderScalarWrites.hs index 35125d03f..680c0b191 100644 --- a/gibbon-compiler/src/Gibbon/Passes/ReorderScalarWrites.hs +++ b/gibbon-compiler/src/Gibbon/Passes/ReorderScalarWrites.hs @@ -38,15 +38,15 @@ writeOrderMarkers (Prog ddefs fundefs mainExp) = do gofun f@FunDef{funArgs,funBody,funTy} = do let (reg_env, alloc_env) = foldr (\(L2.LRM loc reg mode) (renv,aenv) -> - case reg of - L2.AoSR rr -> let renv' = M.insert loc rr renv - aenv' = case mode of + case reg of + L2.SoAR _ _ -> error "TODO: writeOrderMarkers structure of arrays not implemented yet." + _ -> let renv' = M.insert loc reg renv + aenv' = case mode of L2.Output -> let reg_locs = RegionLocs [loc] S.empty - in M.insert rr reg_locs aenv + in M.insert reg reg_locs aenv L2.Input -> aenv - in (renv',aenv') - L2.SoAR _ _ -> error "TODO: writeOrderMarkers structure of arrays not implemented yet." + in (renv',aenv') ) (M.empty,M.empty) (L2.locVars funTy) diff --git a/gibbon-compiler/src/Gibbon/Passes/ThreadRegions.hs b/gibbon-compiler/src/Gibbon/Passes/ThreadRegions.hs index 8ee1c5af6..e20d413f0 100644 --- a/gibbon-compiler/src/Gibbon/Passes/ThreadRegions.hs +++ b/gibbon-compiler/src/Gibbon/Passes/ThreadRegions.hs @@ -96,8 +96,8 @@ threadRegions Prog{ddefs,fundefs,mainExp} = do threadRegionsFn :: DDefs NewL2.Ty2 -> NewL2.FunDefs2 -> NewL2.FunDef2 -> PassM NewL2.FunDef2 threadRegionsFn ddefs fundefs f@FunDef{funName,funArgs,funTy,funMeta,funBody} = do let initRegEnv = M.fromList $ map (\(LRM lc r _) -> case r of - AoSR reg -> (lc, regionToVar reg) SoAR _ _ -> error "TODO: threadRegionsFn not implemented for SoA reg." + _ -> (lc, regionToVar r) ) (locVars funTy) initTyEnv = M.fromList $ zip funArgs (arrIns funTy) env2 = Env2 initTyEnv (initFunEnv fundefs) @@ -110,8 +110,8 @@ threadRegionsFn ddefs fundefs f@FunDef{funName,funArgs,funTy,funMeta,funBody} = wlocs_env = fn (arrOut funTy) M.empty fnlocargs = map fromLRM (locVars funTy) region_locs = M.fromList $ map (\(LRM l r _m) -> case r of - AoSR reg -> (regionToVar reg, [l]) SoAR _ _ -> error "TODO: threadRegionsFn structure of arrays not implemented yet." + _ -> (regionToVar r, [l]) ) (locVars funTy) bod' <- threadRegionsExp ddefs fundefs fnlocargs initRegEnv env2 M.empty rlocs_env wlocs_env M.empty region_locs M.empty S.empty S.empty funBody -- Boundschecking @@ -140,9 +140,10 @@ threadRegionsFn ddefs fundefs f@FunDef{funName,funArgs,funTy,funMeta,funBody} = packed_outs boundschecks = concatMap (\(LRM loc reg mode) -> - case reg of - AoSR rr -> if mode == Output - then let rv = regionToVar rr + case reg of + SoAR _ _ -> error "TODO: threadRegionsFn structure of arrays not implemented yet." + _ -> if mode == Output + then let rv = regionToVar reg end_rv = toEndV rv -- rv = end_reg bc = boundsCheck ddefs (locs_tycons M.! loc) @@ -152,7 +153,6 @@ threadRegionsFn ddefs fundefs f@FunDef{funName,funArgs,funTy,funMeta,funBody} = -- maintain shadowstack in no eager promotion mode [("_",[],MkTy2 IntTy, Ext$ BoundsCheck bc regarg locarg)] else [] - SoAR _ _ -> error "TODO: threadRegionsFn structure of arrays not implemented yet." ) (locVars funTy) in diff --git a/gibbon-compiler/src/Gibbon/Pretty.hs b/gibbon-compiler/src/Gibbon/Pretty.hs index 0a9ac42ae..a330836d5 100644 --- a/gibbon-compiler/src/Gibbon/Pretty.hs +++ b/gibbon-compiler/src/Gibbon/Pretty.hs @@ -488,8 +488,8 @@ instance Pretty L2.LocVar where instance Pretty L2.Region where pprintWithStyle _ reg = parens $ text $ sdoc reg -instance Pretty L2.ExtendedRegion where - pprintWithStyle _ reg = parens $ text $ sdoc reg +-- instance Pretty L2.ExtendedRegion where +-- pprintWithStyle _ reg = parens $ text $ sdoc reg instance Pretty L2.Modality where pprintWithStyle _ mode = text $ show mode