diff --git a/gibbon-compiler/examples/soa_ir_examples/addList.gibbon b/gibbon-compiler/examples/soa_ir_examples/addList.gibbon new file mode 100644 index 000000000..d02ea7fc8 --- /dev/null +++ b/gibbon-compiler/examples/soa_ir_examples/addList.gibbon @@ -0,0 +1,45 @@ +-- AoS list representation of add1 +{meta: FunMeta {funRec = Rec, funInline = NoInline, funCanTriggerGC = False}} +add1 :: List -> List + {locvars [LRM {lrmLoc = Single "loc_154", + lrmReg = AoSR (VarR "r_156"), + lrmMode = Input}, + LRM {lrmLoc = Single "loc_155", + lrmReg = AoSR (VarR "r_157"), + lrmMode = Output}], + effs: [], + locrets: [], + parallel: False} +add1 lst_17_96_134 = + letloc (Single "loc_218") = ((Single "loc_155") + 1) in + letloc (Single "loc_219") = ((Single "loc_218") + 8) in + case lst_17_96_134 of + Nil -> + (Nil (Single "loc_155")) + Cons i_18_97_135::(Single "case_213") rst_19_98_136::(Single "case_214") -> + let i1_20_99_137 :: Int = i_18_97_135 + 1 in + let fltPkd_102_138 :: (Packed List (Single "loc_219")) = (add1 [(Single "case_214"),(Single "loc_219")] rst_19_98_136) in + (Cons (Single "loc_155") i1_20_99_137 fltPkd_102_138) + +-- SoA list representation of add1 +{meta: FunMeta {funRec = Rec, funInline = NoInline, funCanTriggerGC = False}} +add1 :: List -> List + {locvars [LRM {lrmLoc = SoA "loc_154" [(("Cons", 0), "loc_156")], + lrmReg = SoAR (VarR "r_156") [(("Cons", 0)), (VarR "r_158")], + lrmMode = Input}, + LRM {lrmLoc = SoA "loc_155" [(("Cons", 0), "loc_157")] , + lrmReg = SoAR (VarR "r_157") [(("Cons", 0), (VarR "r_159"))], + lrmMode = Output}], + effs: [], + locrets: [], + parallel: False} +add1 lst_17_96_134 = + letloc (SoA "loc_218" [(("Cons", 0), "loc_219")]) = (SoA ("loc_155" + 1) [(("Cons", 0), ("loc_157" + 8))]) in + case lst_17_96_134 of + Nil -> + (Nil (SoA "loc_155" [(("Cons", 0), "loc_157")])) + Cons i_18_97_135::(Single "case_213") rst_19_98_136::(Single "case_214") -> + let i1_20_99_137 :: Int = i_18_97_135 + 1 in + let fltPkd_102_138 :: (Packed List (SoA "loc_218" [(("Cons", 0), "loc_219")])) = (add1 [(Single "case_213"), (Single "case_214"),(SoA "loc_218" [(("Cons", 0), "loc_219")])] rst_19_98_136) in + (Cons (SoA "loc_155" [(("Cons", 0), "loc_157")]) i1_20_99_137 fltPkd_102_138) + diff --git a/gibbon-compiler/examples/soa_ir_examples/mkList.gibbon b/gibbon-compiler/examples/soa_ir_examples/mkList.gibbon new file mode 100644 index 000000000..31ae335ec --- /dev/null +++ b/gibbon-compiler/examples/soa_ir_examples/mkList.gibbon @@ -0,0 +1,39 @@ +-- AoS IR representation +{meta: FunMeta {funRec = Rec, funInline = NoInline, funCanTriggerGC = False}} +mkList :: Int -> List + {locvars [LRM {lrmLoc = Single "loc_140", + lrmReg = AoSR (VarR "r_141"), + 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_175") + 8) in + let fltIf_97_118 :: Bool = <=(length_14_82_117, 0) in + if fltIf_97_118 + then (Nil (Single "loc_140")) + else let fltAppE_98_119 :: Int = length_14_82_117 - 1 in + let rst_15_83_120 :: (Packed List (Single "loc_176")) = (mkList [(Single "loc_176")] fltAppE_98_119) in + (Cons (Single "loc_140") length_14_82_117 rst_15_83_120) + + +-- SoA IR representation +{meta: FunMeta {funRec = Rec, funInline = NoInline, funCanTriggerGC = False}} +mkList :: Int -> List + {locvars [LRM {lrmLoc = SoA "loc_140" [(("Cons", 0), "loc_141")], + lrmReg = SoAR (VarR "r_141") [("Cons", 0), (VarR "r_142")], + lrmMode = Output}], + effs: [], + locrets: [], + parallel: False} +mkList length_14_82_117 = + -- This may need a new IR primitive?? to increment an SoA loc. + letloc (SoA "loc_175" [(("Cons", 0), "loc_176")]) = (SoA ("loc_175" + 1) [(("Cons", 0), ("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) + diff --git a/gibbon-compiler/src/Gibbon/Common.hs b/gibbon-compiler/src/Gibbon/Common.hs index d4ce648ce..ec4a05204 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 + Var(..), LocVar(..), Location, FieldIndex , RegVar, fromVar, toVar, varAppend, toEndV, toEndVLoc, toSeqV, cleanFunName , TyVar(..), isUserTv , Symbol, intern, unintern @@ -139,6 +139,9 @@ toSeqV v = varAppend v (toVar "_seq") -- | A location variable stores the abstract location. type Location = Var +-- | The position or index of a field in a data constructor value. +type FieldIndex = Int + data LocVar = Single Location deriving (Show, Ord, Eq, Read, Generic, NFData, Out) diff --git a/gibbon-compiler/src/Gibbon/L2/Examples.hs b/gibbon-compiler/src/Gibbon/L2/Examples.hs index f47242816..5e931cc22 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") (VarR "r3") Input, LRM (Single "lout4") (VarR "r750") Output] + [LRM (Single "lin2") (AoSR $ VarR "r3") Input, LRM (Single "lout4") (AoSR $ 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") (VarR "r20") Input, LRM (Single "lout21") (VarR "r751") Output] + [LRM (Single "lin19") (AoSR $ VarR "r20") Input, LRM (Single "lout21") (AoSR $ 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") (VarR "r24") Input, LRM (Single "lout25") (VarR "r752") Output] + [LRM (Single "lin23") (AoSR $ VarR "r24") Input, LRM (Single "lout25") (AoSR$ 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") (VarR "r38") Input, LRM (Single "lout39") (VarR "r753") Output] + [LRM (Single "lin37") (AoSR $ VarR "r38") Input, LRM (Single "lout39") (AoSR $ 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") (VarR "r113") Input] + [LRM (Single "lin112") (AoSR $ 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") (VarR "r240") Input] + [LRM (Single "lin241") (AoSR $ 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") (VarR "r127") Output] + [LRM (Single "lout126") (AoSR $ 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") (VarR "r271") Output] + [LRM (Single "lout272") (AoSR $ 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") (VarR "r751") Output, LRM (Single "lout754") (VarR "r753") Output] + [LRM (Single "lout752") (AoSR $ VarR "r751") Output, LRM (Single "lout754") (AoSR $ 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") (VarR "r300") Output] + [LRM (Single "lout301") (AoSR $ 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") (VarR "r760") Input] + [LRM (Single "lin761") (AoSR $ 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") (VarR "r350") Input, - LRM (Single "lin352") (VarR "r351") Input, - LRM (Single "lout353") (VarR "r754") Output] + [LRM (Single "lin351") (AoSR $ VarR "r350") Input, + LRM (Single "lin352") (AoSR $ VarR "r351") Input, + LRM (Single "lout353") (AoSR $ 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") (VarR "r132") Input, LRM (Single "lout133") (VarR "r755") Output] + [LRM (Single "lin131") (AoSR $ VarR "r132") Input, LRM (Single "lout133") (AoSR $ 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") (VarR "r500") Input, LRM (Single "lout502") (VarR "r756") Output] + [LRM (Single "lin501") (AoSR $ VarR "r500") Input, LRM (Single "lout502") (AoSR $ 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") (VarR "r523") Input] + [LRM (Single "lin524") (AoSR $ 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") (VarR "r540") Output] + [LRM (Single "lout541") (AoSR $ 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") (VarR "r760") Input] + [LRM (Single "lin761") (AoSR $ 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") (VarR "r570") Input, LRM (Single "lout572") (VarR "r757") Output] + [LRM (Single "lin571") (AoSR $ VarR "r570") Input, LRM (Single "lout572") (AoSR $ 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") (VarR "r600") Input, LRM (Single "lout602") (VarR "r758") Output] + [LRM (Single "lin601") (AoSR $ VarR "r600") Input, LRM (Single "lout602") (AoSR $ 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") (VarR "r701") Input, - LRM (Single "lout703") (VarR "r759") Output] + [LRM (Single "lin702") (AoSR $ VarR "r701") Input, + LRM (Single "lout703") (AoSR $ 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") (VarR "r650") Input, - LRM (Single "lin652") (VarR "r650") Input, - LRM (Single "lout653") (VarR "r760") Output] + [LRM (Single "lin651") (AoSR $ VarR "r650") Input, + LRM (Single "lin652") (AoSR $ VarR "r650") Input, + LRM (Single "lout653") (AoSR $ 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") (VarR "r271") Output] + [LRM (Single "lout272") (AoSR $ 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") (VarR "r740") Input] + [LRM (Single "lin741") (AoSR $ 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") (VarR "r801") Input, LRM (Single "lout803") (VarR "r803") Output] + [LRM (Single "lin802") (AoSR $ VarR "r801") Input, LRM (Single "lout803") (AoSR $ 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 30ebafb82..3e5569e5c 100644 --- a/gibbon-compiler/src/Gibbon/L2/Syntax.hs +++ b/gibbon-compiler/src/Gibbon/L2/Syntax.hs @@ -32,6 +32,7 @@ module Gibbon.L2.Syntax -- * Regions and locations , LocVar , Region(..) + , ExtendedRegion(..) , Modality(..) , LRM(..) , dummyLRM @@ -478,7 +479,19 @@ 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) +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 NFData Region where rnf (GlobR v _) = rnf v @@ -486,6 +499,16 @@ instance NFData Region where 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' + + -- | The modality of locations and cursors: input/output, for reading -- and writing, respectively. @@ -498,7 +521,7 @@ instance NFData Modality where -- | A location and region, together with modality. data LRM = LRM { lrmLoc :: LocVar - , lrmReg :: Region + , lrmReg :: ExtendedRegion , lrmMode :: Modality } deriving (Read,Show,Eq,Ord, Generic) @@ -509,7 +532,7 @@ instance NFData LRM where -- | A designated doesn't-really-exist-anywhere location. dummyLRM :: LRM -dummyLRM = LRM (singleLocVar "l_dummy") (VarR "r_dummy") Input +dummyLRM = LRM (singleLocVar "l_dummy") (AoSR $ VarR "r_dummy") Input regionToVar :: Region -> Var regionToVar r = case r of @@ -649,15 +672,29 @@ outLocVars ty = L.map (\(LRM l _ _) -> l) $ L.filter (\(LRM _ _ m) -> m == Output) (locVars ty) outRegVars :: ArrowTy2 ty2 -> [LocVar] -outRegVars ty = L.map (\(LRM _ r _) -> (singleLocVar (regionToVar r))) $ - L.filter (\(LRM _ _ m) -> m == Output) (locVars ty) +outRegVars ty = L.concatMap (\(LRM _ r _) -> case r of + AoSR rr -> [(singleLocVar (regionToVar rr))] + SoAR rr fieldRegions -> + let + regVars = [regionToVar rr] ++ L.map (\(_, fregs) -> regionToVar fregs) fieldRegions + in L.map singleLocVar regVars + ) $ L.filter (\(LRM _ _ m) -> m == Output) (locVars ty) inRegVars :: ArrowTy2 ty2 -> [LocVar] -inRegVars ty = L.nub $ L.map (\(LRM _ r _) -> (singleLocVar (regionToVar r))) $ - L.filter (\(LRM _ _ m) -> m == Input) (locVars ty) +inRegVars ty = L.nub $ L.concatMap (\(LRM _ r _) -> case r of + AoSR rr -> [singleLocVar $ regionToVar rr] + SoAR rr fieldRegions -> + let + regVars = [regionToVar rr] ++ L.map (\(_, fregs) -> regionToVar fregs) fieldRegions + in L.map singleLocVar regVars + ) $ L.filter (\(LRM _ _ m) -> m == Input) (locVars ty) allRegVars :: ArrowTy2 ty2 -> [LocVar] -allRegVars ty = L.nub $ L.map (\(LRM _ r _) -> (singleLocVar (regionToVar r))) (locVars ty) +allRegVars ty = L.nub $ L.concatMap (\(LRM _ r _) -> case r of + AoSR rr -> [singleLocVar $ regionToVar rr] + SoAR rr fieldRegions -> [singleLocVar $ regionToVar rr] + ++ L.map (\(_, freg) -> singleLocVar $ regionToVar freg) fieldRegions + ) (locVars ty) -- | Apply a location substitution to a type. substLoc :: M.Map LocVar LocVar -> Ty2 -> Ty2 diff --git a/gibbon-compiler/src/Gibbon/L2/Typecheck.hs b/gibbon-compiler/src/Gibbon/L2/Typecheck.hs index d3d488ccb..6a8a3a480 100644 --- a/gibbon-compiler/src/Gibbon/L2/Typecheck.hs +++ b/gibbon-compiler/src/Gibbon/L2/Typecheck.hs @@ -1013,7 +1013,9 @@ getRegion exp (ConstraintSet cs) l = go $ S.toList cs funRegs :: [LRM] -> RegionSet funRegs ((LRM _l r _m):lrms) = let (RegionSet rs) = funRegs lrms - in RegionSet $ S.insert (regionToVar r) rs + in case r of + AoSR reg -> RegionSet $ S.insert (regionToVar reg) rs + SoAR _ _ -> error "TODO: Typecheck: implement SoA Region." funRegs [] = RegionSet $ S.empty globalReg :: Region @@ -1021,8 +1023,9 @@ globalReg = GlobR "GLOBAL" BigInfinite -- | Get the constraints from the location bindings in a function type. funConstrs :: [LRM] -> ConstraintSet -funConstrs ((LRM l r _m):lrms) = - extendConstrs (InRegionC l r) $ funConstrs lrms +funConstrs ((LRM l r _m):lrms) = case r of + AoSR reg -> extendConstrs (InRegionC l reg) $ funConstrs lrms + SoAR _ _ -> error "TODO: funConstrs: SoAR case not implemented!" funConstrs [] = ConstraintSet $ S.empty -- | Get the type state implied by the location bindings in a function type. diff --git a/gibbon-compiler/src/Gibbon/NewL2/Syntax.hs b/gibbon-compiler/src/Gibbon/NewL2/Syntax.hs index 70e3d8a17..48f91e834 100644 --- a/gibbon-compiler/src/Gibbon/NewL2/Syntax.hs +++ b/gibbon-compiler/src/Gibbon/NewL2/Syntax.hs @@ -93,7 +93,9 @@ instance NFData LREM where rnf (LREM a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d fromLRM :: Old.LRM -> LREM -fromLRM (Old.LRM loc reg mode) = LREM loc (Old.regionToVar reg) (toEndV (Old.regionToVar reg)) mode +fromLRM (Old.LRM loc reg mode) = case reg of + Old.AoSR r -> LREM loc (Old.regionToVar r) (toEndV (Old.regionToVar r)) mode + Old.SoAR _ _ -> error "TODO: NewL2/Syntax.hs, fromLRM, implement SoA region." data LocArg = Loc LREM | EndWitness LREM Var diff --git a/gibbon-compiler/src/Gibbon/Passes/AddRAN.hs b/gibbon-compiler/src/Gibbon/Passes/AddRAN.hs index 7f659cebc..a2da2286a 100644 --- a/gibbon-compiler/src/Gibbon/Passes/AddRAN.hs +++ b/gibbon-compiler/src/Gibbon/Passes/AddRAN.hs @@ -328,7 +328,10 @@ needsRAN Prog{ddefs,fundefs,mainExp} = then S.empty else let tyenv = M.fromList $ zip funArgs (inTys funTy) env2 = Env2 tyenv funenv - renv = M.fromList $ L.map (\lrm -> (lrmLoc lrm, regionToVar (lrmReg lrm))) (locVars funTy) + 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." + ) (locVars funTy) in needsRANExp ddefs fundefs env2 renv M.empty [] funBody funs = M.foldr (\f acc -> acc `S.union` dofun f) S.empty fundefs diff --git a/gibbon-compiler/src/Gibbon/Passes/AddTraversals.hs b/gibbon-compiler/src/Gibbon/Passes/AddTraversals.hs index c9d79e9e8..0c70cb381 100644 --- a/gibbon-compiler/src/Gibbon/Passes/AddTraversals.hs +++ b/gibbon-compiler/src/Gibbon/Passes/AddTraversals.hs @@ -48,7 +48,10 @@ addTraversalsFn ddefs fundefs f@FunDef{funName, funArgs, funTy, funBody} = do let funenv = initFunEnv fundefs tyenv = M.fromList $ fragileZip funArgs (inTys funTy) env2 = Env2 tyenv funenv - renv = M.fromList $ L.map (\lrm -> (lrmLoc lrm, regionToVar (lrmReg lrm))) + 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." + ) (locVars funTy) bod' <- addTraversalsExp ddefs fundefs env2 renv (fromVar funName) funBody return $ f {funBody = bod'} diff --git a/gibbon-compiler/src/Gibbon/Passes/CalculateBounds.hs b/gibbon-compiler/src/Gibbon/Passes/CalculateBounds.hs index 359190632..58e95cb76 100644 --- a/gibbon-compiler/src/Gibbon/Passes/CalculateBounds.hs +++ b/gibbon-compiler/src/Gibbon/Passes/CalculateBounds.hs @@ -33,7 +33,10 @@ calculateBoundsFun ddefs env2 varSzEnv f@FunDef { funName, funBody, funTy, funAr if "_" `L.isPrefixOf` fromVar funName then return f else do - let locRegEnv = M.fromList $ map (\lv -> (lrmLoc lv, regionToVar $ lrmReg lv)) (locVars funTy) + let locRegEnv = M.fromList $ map (\lv -> case (lrmReg lv) of + AoSR reg -> (lrmLoc lv, regionToVar reg) + SoAR _ _ -> error "TODO: calculateBoundsFn SoA region not implemented." + ) (locVars funTy) let locTyEnv = M.map (const $ BoundedSize 0) locRegEnv let argTys = M.fromList $ zip funArgs (arrIns funTy) let env2' = env2 { vEnv = argTys } diff --git a/gibbon-compiler/src/Gibbon/Passes/InferLocations.hs b/gibbon-compiler/src/Gibbon/Passes/InferLocations.hs index 00e320b2e..c37d16a49 100644 --- a/gibbon-compiler/src/Gibbon/Passes/InferLocations.hs +++ b/gibbon-compiler/src/Gibbon/Passes/InferLocations.hs @@ -150,7 +150,7 @@ convertFunTy (from,to,isPar) = do where toLRM md ls = mapM (\v -> do r <- freshLocVar "r" - return $ LRM v (VarR (unwrapLocVar r)) md) + return $ LRM v (AoSR $ VarR (unwrapLocVar r)) md) (F.toList ls) convertTy :: Ty1 -> PassM Ty2 diff --git a/gibbon-compiler/src/Gibbon/Passes/ParAlloc.hs b/gibbon-compiler/src/Gibbon/Passes/ParAlloc.hs index 629dffad7..271f016be 100644 --- a/gibbon-compiler/src/Gibbon/Passes/ParAlloc.hs +++ b/gibbon-compiler/src/Gibbon/Passes/ParAlloc.hs @@ -75,7 +75,10 @@ parAlloc Prog{ddefs,fundefs,mainExp} = do when (hasParallelism funTy && hasPacked ret_ty && gopt Opt_Gibbon1 dflags) $ error "gibbon: Cannot compile parallel allocations in Gibbon1 mode." - let initRegEnv = M.fromList $ map (\(LRM lc r _) -> (lc, regionToVar r)) (locVars funTy) + let initRegEnv = M.fromList $ map (\(LRM lc r _) -> case r of + AoSR reg -> (lc, regionToVar reg) + SoAR _ _ -> error "TODO: parAlloc structure of arrays not implemented yet." + ) (locVars funTy) funArgs' = L.map Single funArgs initTyEnv = M.fromList $ zip funArgs' (arrIns funTy) env2 = Env2 initTyEnv (initFunEnv' fundefs) diff --git a/gibbon-compiler/src/Gibbon/Passes/RemoveCopies.hs b/gibbon-compiler/src/Gibbon/Passes/RemoveCopies.hs index 8fd8d344d..e6e892be7 100644 --- a/gibbon-compiler/src/Gibbon/Passes/RemoveCopies.hs +++ b/gibbon-compiler/src/Gibbon/Passes/RemoveCopies.hs @@ -35,7 +35,10 @@ 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 _) -> (lc, regionToVar r)) (locVars funTy) + let initLocEnv = M.fromList $ map (\(LRM lc r _) -> case r of + AoSR reg -> (lc, regionToVar reg) + SoAR _ _ -> error "TODO: removeCopiesFn structure of arrays not implemented yet." + ) (locVars funTy) initTyEnv = M.fromList $ zip funArgs (arrIns funTy) env2 = Env2 initTyEnv (initFunEnv fundefs) bod' <- removeCopiesExp ddefs fundefs initLocEnv env2 funBody diff --git a/gibbon-compiler/src/Gibbon/Passes/ReorderScalarWrites.hs b/gibbon-compiler/src/Gibbon/Passes/ReorderScalarWrites.hs index 12b832716..35125d03f 100644 --- a/gibbon-compiler/src/Gibbon/Passes/ReorderScalarWrites.hs +++ b/gibbon-compiler/src/Gibbon/Passes/ReorderScalarWrites.hs @@ -38,13 +38,16 @@ 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) -> - let renv' = M.insert loc reg renv - aenv' = case mode of - L2.Output -> - let reg_locs = RegionLocs [loc] S.empty - in M.insert reg reg_locs aenv - L2.Input -> aenv - in (renv',aenv')) + case reg of + L2.AoSR rr -> let renv' = M.insert loc rr renv + aenv' = case mode of + L2.Output -> + let reg_locs = RegionLocs [loc] S.empty + in M.insert rr reg_locs aenv + L2.Input -> aenv + in (renv',aenv') + L2.SoAR _ _ -> error "TODO: writeOrderMarkers structure of arrays not implemented yet." + ) (M.empty,M.empty) (L2.locVars funTy) init_ty_env = M.fromList $ zip funArgs (L2.arrIns funTy) diff --git a/gibbon-compiler/src/Gibbon/Passes/ThreadRegions.hs b/gibbon-compiler/src/Gibbon/Passes/ThreadRegions.hs index 33dfb51f6..8ee1c5af6 100644 --- a/gibbon-compiler/src/Gibbon/Passes/ThreadRegions.hs +++ b/gibbon-compiler/src/Gibbon/Passes/ThreadRegions.hs @@ -11,6 +11,7 @@ import Gibbon.Common import Gibbon.DynFlags -- import Gibbon.NewL2.Syntax as L2 import Gibbon.NewL2.Syntax as NewL2 +import Gibbon.L2.Syntax as Old -------------------------------------------------------------------------------- @@ -92,12 +93,15 @@ threadRegions Prog{ddefs,fundefs,mainExp} = do threadRegionsExp ddefs fundefs [] M.empty env2 M.empty M.empty M.empty M.empty M.empty M.empty S.empty S.empty mn return $ Prog ddefs fundefs' mainExp' -threadRegionsFn :: DDefs Ty2 -> FunDefs2 -> NewL2.FunDef2 -> PassM NewL2.FunDef2 +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 _) -> (lc, regionToVar r)) (locVars funTy) + 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." + ) (locVars funTy) initTyEnv = M.fromList $ zip funArgs (arrIns funTy) env2 = Env2 initTyEnv (initFunEnv fundefs) - fn :: Ty2 -> M.Map LocVar TyCon -> M.Map LocVar TyCon + fn :: NewL2.Ty2 -> M.Map LocVar TyCon -> M.Map LocVar TyCon fn = (\ty acc -> case unTy2 ty of PackedTy tycon loc -> M.insert loc tycon acc ProdTy tys -> foldr fn acc (map MkTy2 tys) @@ -105,7 +109,10 @@ threadRegionsFn ddefs fundefs f@FunDef{funName,funArgs,funTy,funMeta,funBody} = rlocs_env = foldr fn M.empty (arrIns funTy) wlocs_env = fn (arrOut funTy) M.empty fnlocargs = map fromLRM (locVars funTy) - region_locs = M.fromList $ map (\(LRM l r _m) -> (regionToVar r, [l])) (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." + ) (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 dflags <- getDynFlags @@ -133,17 +140,20 @@ threadRegionsFn ddefs fundefs f@FunDef{funName,funArgs,funTy,funMeta,funBody} = packed_outs boundschecks = concatMap (\(LRM loc reg mode) -> - if mode == Output - then let rv = regionToVar reg - end_rv = toEndV rv - -- rv = end_reg - bc = boundsCheck ddefs (locs_tycons M.! loc) - locarg = NewL2.Loc (LREM loc rv end_rv mode) - regarg = NewL2.EndOfReg rv mode end_rv - in -- dbgTraceIt ("boundscheck" ++ sdoc ((locs_tycons M.! loc), bc)) $ - -- maintain shadowstack in no eager promotion mode - [("_",[],MkTy2 IntTy, Ext$ BoundsCheck bc regarg locarg)] - else []) + case reg of + AoSR rr -> if mode == Output + then let rv = regionToVar rr + end_rv = toEndV rv + -- rv = end_reg + bc = boundsCheck ddefs (locs_tycons M.! loc) + locarg = NewL2.Loc (LREM loc rv end_rv mode) + regarg = NewL2.EndOfReg rv mode end_rv + in -- dbgTraceIt ("boundscheck" ++ sdoc ((locs_tycons M.! loc), bc)) $ + -- 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 -- If eager promotion is disabled, growing a region can also trigger a GC. @@ -155,7 +165,7 @@ threadRegionsFn ddefs fundefs f@FunDef{funName,funArgs,funTy,funMeta,funBody} = -threadRegionsExp :: DDefs Ty2 -> FunDefs2 -> [LREM] -> RegEnv -> Env2 Var Ty2 +threadRegionsExp :: DDefs NewL2.Ty2 -> NewL2.FunDefs2 -> [LREM] -> RegEnv -> Env2 Var NewL2.Ty2 -> RightmostRegEnv -> AllocEnv -> AllocEnv -> PkdEnv -> OrderedLocsEnv -> RanEnv -> S.Set LocVar -> S.Set LocVar -> NewL2.Exp2 -> PassM NewL2.Exp2 @@ -164,7 +174,7 @@ threadRegionsExp ddefs fundefs fnLocArgs renv env2 lfenv rlocs_env wlocs_env pkd AppE f applocs args -> do let ty = gRecoverType ddefs env2 ex argtys = map (gRecoverType ddefs env2) args - argtylocs = concatMap locsInTy argtys + argtylocs = concatMap NewL2.locsInTy argtys in_regs = foldr (\x acc -> if S.member x indirs || S.member x redirs -- Since a region should always point to just one cursor -- Unwraping a regions stored in LocVar should be fine. @@ -187,7 +197,7 @@ threadRegionsExp ddefs fundefs fnLocArgs renv env2 lfenv rlocs_env wlocs_env pkd -- locations and therefore, input and output regions. if hasPacked (unTy2 ty) then do - let out_tylocs = locsInTy ty + let out_tylocs = NewL2.locsInTy ty let out_regs = map (\l -> let r = (renv # l) in NewL2.EndOfReg r Output (toEndV r)) out_tylocs let newapplocs = in_regs ++ out_regs ++ applocs' return $ AppE f newapplocs args @@ -205,8 +215,8 @@ threadRegionsExp ddefs fundefs fnLocArgs renv env2 lfenv rlocs_env wlocs_env pkd case unTy2 argty of -- Indirection or redirection cursor. CursorTy -> [singleLocVar w] - _ -> locsInTy argty - _ -> locsInTy argty) + _ -> NewL2.locsInTy argty + _ -> NewL2.locsInTy argty) args let in_regargs = foldr (\x acc -> if S.member x indirs || S.member x redirs @@ -219,7 +229,7 @@ threadRegionsExp ddefs fundefs fnLocArgs renv env2 lfenv rlocs_env wlocs_env pkd Nothing -> acc) [] argtylocs -------------------- - let outretlocs = if hasPacked (unTy2 ty) then locsInTy ty else [] + let outretlocs = if hasPacked (unTy2 ty) then NewL2.locsInTy ty else [] out_regvars = map (renv #) outretlocs out_regvars' <- mapM (\r -> gensym r) out_regvars let out_regargs = map (\r -> NewL2.EndOfReg r Output (toEndV r)) out_regvars @@ -308,13 +318,13 @@ threadRegionsExp ddefs fundefs fnLocArgs renv env2 lfenv rlocs_env wlocs_env pkd -------------------- let env2' = extendVEnv v ty env2 rlocs_env' = updRLocsEnv (unTy2 ty) rlocs_env - wlocs_env' = foldr (\loc acc -> M.delete loc acc) wlocs_env (locsInTy ty) + wlocs_env' = foldr (\loc acc -> M.delete loc acc) wlocs_env (NewL2.locsInTy ty) bod3 <- threadRegionsExp ddefs fundefs fnLocArgs renv4 env2' lfenv rlocs_env' wlocs_env' pkd_env1 region_locs3 ran_env indirs redirs bod2 -- shadowstack ops -------------------- let -- free = S.fromList $ freeLocVars bod - free = ss_free_locs (S.fromList ((singleLocVar v) : locsInTy ty ++ (map toLocVar locs))) env2' bod + free = ss_free_locs (S.fromList ((singleLocVar v) : NewL2.locsInTy ty ++ (map toLocVar locs))) env2' bod free_wlocs = free `S.intersection` (M.keysSet wlocs_env') free_rlocs = free `S.intersection` (M.keysSet rlocs_env') free_rlocs' = let tmp = map (\(x,(MkTy2 (PackedTy _ loc))) -> (Just x,loc)) $ @@ -352,7 +362,7 @@ threadRegionsExp ddefs fundefs fnLocArgs renv env2 lfenv rlocs_env wlocs_env pkd let pkd_env1 = M.insert loc (renv # loc) pkd_env let env2' = extendVEnv v ty env2 rlocs_env' = updRLocsEnv (unTy2 ty) rlocs_env - wlocs_env' = foldr (\loc2 acc -> M.delete loc2 acc) wlocs_env (locsInTy ty) + wlocs_env' = foldr (\loc2 acc -> M.delete loc2 acc) wlocs_env (NewL2.locsInTy ty) LetE <$> (v,locs,ty,) <$> go rhs <*> threadRegionsExp ddefs fundefs fnLocArgs renv env2' lfenv' rlocs_env' wlocs_env' pkd_env1 region_locs ran_env indirs redirs bod @@ -374,7 +384,7 @@ threadRegionsExp ddefs fundefs fnLocArgs renv env2 lfenv rlocs_env wlocs_env pkd let pkd_env' = M.insert loc (renv # loc) pkd_env let env2' = extendVEnv v ty env2 rlocs_env' = updRLocsEnv (unTy2 ty) rlocs_env - wlocs_env' = foldr (\loc2 acc -> M.delete loc2 acc) wlocs_env (locsInTy ty) + wlocs_env' = foldr (\loc2 acc -> M.delete loc2 acc) wlocs_env (NewL2.locsInTy ty) bod' <- threadRegionsExp ddefs fundefs fnLocArgs renv env2' lfenv rlocs_env' wlocs_env' pkd_env' region_locs ran_env indirs redirs bod let boundscheck = let locarg = a' regarg = b' @@ -399,13 +409,13 @@ threadRegionsExp ddefs fundefs fnLocArgs renv env2 lfenv rlocs_env wlocs_env pkd newretlocs = retlocs ++ locs let env2' = extendVEnv v ty env2 rlocs_env' = updRLocsEnv (unTy2 ty) rlocs_env - wlocs_env' = foldr (\loc acc -> M.delete loc acc) wlocs_env (locsInTy ty) + wlocs_env' = foldr (\loc acc -> M.delete loc acc) wlocs_env (NewL2.locsInTy ty) bod1 <- threadRegionsExp ddefs fundefs fnLocArgs renv env2' lfenv rlocs_env' wlocs_env' pkd_env region_locs ran_env indirs redirs bod -- shadowstack ops -------------------- let -- free = S.fromList $ freeLocVars bod - free = ss_free_locs (S.fromList ((singleLocVar v) : locsInTy ty ++ (map toLocVar locs))) env2' bod + free = ss_free_locs (S.fromList ((singleLocVar v) : NewL2.locsInTy ty ++ (map toLocVar locs))) env2' bod free_wlocs = free `S.intersection` (M.keysSet wlocs_env') free_rlocs = free `S.intersection` (M.keysSet rlocs_env') free_rlocs' = let tmp = map (\(x,(MkTy2 (PackedTy _ loc))) -> (Just x,loc)) $ @@ -460,7 +470,7 @@ threadRegionsExp ddefs fundefs fnLocArgs renv env2 lfenv rlocs_env wlocs_env pkd RetE locs v -> do let ty = lookupVEnv v env2 fn m = (\r -> NewL2.EndOfReg r m (toEndV r)) - outtylocs = locsInTy ty + outtylocs = NewL2.locsInTy ty outtyregvars = foldr (\loc acc -> case M.lookup loc lfenv of Nothing -> (renv # loc) : acc @@ -551,7 +561,7 @@ threadRegionsExp ddefs fundefs fnLocArgs renv env2 lfenv rlocs_env wlocs_env pkd then foldr (\lc acc -> M.insert (singleLocVar lc) reg acc) renv1 vars else renv1 renv1' = foldr (\lc acc -> M.insert lc reg acc) renv0 locs - env21' = extendPatternMatchEnv dcon ddefs vars locs env21 + env21' = NewL2.extendPatternMatchEnv dcon ddefs vars locs env21 rlocs_env1' = foldr (\(loc,ty) acc -> case unTy2 ty of PackedTy tycon _ -> M.insert loc tycon acc @@ -582,7 +592,7 @@ threadRegionsExp ddefs fundefs fnLocArgs renv env2 lfenv rlocs_env wlocs_env pkd (dcon,vlocargs,) <$> (threadRegionsExp ddefs fundefs fnLocArgs renv1' env21' lfenv1 rlocs_env1' wlocs_env1 pkd_env1' region_locs1' ran_env1' indirs1' redirs1' bod) - ss_free_locs :: S.Set LocVar -> Env2 Var Ty2 -> Exp2 -> S.Set LocVar + ss_free_locs :: S.Set LocVar -> Env2 Var NewL2.Ty2 -> NewL2.Exp2 -> S.Set LocVar ss_free_locs bound env20 ex0 = let mapfunc = S.map (\w -> case M.lookup w (vEnv env20) of -- assumption: it's a location @@ -610,8 +620,8 @@ hole_tycon = "HOLE" ss_ops :: S.Set (Maybe Var, LocVar) -> S.Set LocVar -> AllocEnv -> AllocEnv -> RegEnv -> PassM - ([(Var, [LocArg], Ty2, Exp2)], [(Var, [LocArg], Ty2, Exp2)], - [(Var, [LocArg], Ty2, Exp2)], [(Var, [LocArg], Ty2, Exp2)]) + ([(Var, [LocArg], NewL2.Ty2, NewL2.Exp2)], [(Var, [LocArg], NewL2.Ty2, NewL2.Exp2)], + [(Var, [LocArg], NewL2.Ty2, NewL2.Exp2)], [(Var, [LocArg], NewL2.Ty2, NewL2.Exp2)]) ss_ops free_rlocs free_wlocs rlocs_env wlocs_env renv = do rpush <- (foldrM (\(mb_x,loc) acc -> do push <- gensym "ss_push" @@ -622,7 +632,7 @@ ss_ops free_rlocs free_wlocs rlocs_env wlocs_env renv = do Nothing -> pure ((push,[],MkTy2 (ProdTy []), Ext $ SSPush Read loc (singleLocVar $ toEndV (renv # loc)) tycon) : acc) Just x -> pure ((push,[],MkTy2 (ProdTy []), Ext $ SSPush Read (singleLocVar x) (singleLocVar $ toEndV (renv # loc)) tycon) : acc)) [] - free_rlocs) :: PassM [(Var, [LocArg], Ty2, Exp2)] + free_rlocs) :: PassM [(Var, [LocArg], NewL2.Ty2, NewL2.Exp2)] wpush <- (foldrM (\x acc -> do push <- gensym "ss_push" let tycon = wlocs_env # x @@ -630,7 +640,7 @@ ss_ops free_rlocs free_wlocs rlocs_env wlocs_env renv = do then pure acc else pure ((push,[],MkTy2 (ProdTy []), Ext $ SSPush Write x (singleLocVar $ toEndV (renv # x)) tycon) : acc)) [] - free_wlocs) :: PassM [(Var, [LocArg], Ty2, Exp2)] + free_wlocs) :: PassM [(Var, [LocArg], NewL2.Ty2, NewL2.Exp2)] let fn = (\(_x,locs,ty,Ext (SSPush a b c _)) -> gensym "ss_pop" >>= \y -> pure (y,locs,ty,Ext (SSPop a b c))) rpop <- mapM fn (reverse rpush) wpop <- mapM fn (reverse wpush) @@ -638,10 +648,10 @@ ss_ops free_rlocs free_wlocs rlocs_env wlocs_env renv = do -- Inspect an AST and return locations in a RetE form. -findRetLocs :: Exp2 -> [LocArg] +findRetLocs :: NewL2.Exp2 -> [LocArg] findRetLocs e0 = go e0 [] where - go :: Exp2 -> [LocArg] -> [LocArg] + go :: NewL2.Exp2 -> [LocArg] -> [LocArg] go ex acc = case ex of VarE{} -> acc @@ -690,7 +700,7 @@ findRetLocs e0 = go e0 [] -- constructors of this type. The assumption is that whatever writes -- that packed value will do a bounds check again. Note that only AppE's -- do boundschecking, DataConE's dont. We should fix this. -boundsCheck :: DDefs2 -> TyCon -> Int +boundsCheck :: NewL2.DDefs2 -> TyCon -> Int boundsCheck ddefs tycon = let dcons = getConOrdering ddefs tycon spaceReqd tys = foldl (\(bytes, seen_packed) ty -> @@ -712,7 +722,7 @@ boundsCheck ddefs tycon = -- gFreeVars ++ locations ++ region variables - (args to datacons) -- Terrible hack to unwrapLocVar atm, this will likely need to change. -allFreeVars_sans_datacon_args :: Exp2 -> S.Set Var +allFreeVars_sans_datacon_args :: NewL2.Exp2 -> S.Set Var allFreeVars_sans_datacon_args ex = case ex of AppE _ locs args -> S.fromList (map (unwrapLocVar . toLocVar) locs) `S.union` (S.unions (map allFreeVars_sans_datacon_args args)) @@ -753,7 +763,7 @@ allFreeVars_sans_datacon_args ex = ---------------------------------------- -substEndReg :: Either LocVar RegVar -> RegVar -> Exp2 -> Exp2 +substEndReg :: Either LocVar RegVar -> RegVar -> NewL2.Exp2 -> NewL2.Exp2 substEndReg loc_or_reg end_reg ex = case ex of AppE f locs args -> AppE f (map gosubst locs) (map go args) diff --git a/gibbon-compiler/src/Gibbon/Pretty.hs b/gibbon-compiler/src/Gibbon/Pretty.hs index 79ceab195..dd742fb21 100644 --- a/gibbon-compiler/src/Gibbon/Pretty.hs +++ b/gibbon-compiler/src/Gibbon/Pretty.hs @@ -488,6 +488,9 @@ 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.Modality where pprintWithStyle _ mode = text $ show mode diff --git a/gibbon-compiler/tests/RouteEnds.hs b/gibbon-compiler/tests/RouteEnds.hs index edba8b6b5..a3ceea24c 100644 --- a/gibbon-compiler/tests/RouteEnds.hs +++ b/gibbon-compiler/tests/RouteEnds.hs @@ -64,7 +64,7 @@ assertRouteEnds prg fnName expected = expected @=? lRets -- | add1 reaches the end of its input case_add1_test2 :: Assertion -case_add1_test2 = assertRouteEnds add1Prog "add1" [EndOf $ LRM (singleLocVar "lin2") (VarR "r3") Input] +case_add1_test2 = assertRouteEnds add1Prog "add1" [EndOf $ LRM (singleLocVar "lin2") (AoSR $ VarR "r3") Input] {- @@ -85,13 +85,13 @@ case_id2 = assertRouteEnds id2Prog "id2" [] -- | copyTree does case_copyTree :: Assertion -case_copyTree = assertRouteEnds copyTreeProg "copyTree" [EndOf $ LRM (singleLocVar "lin23") (VarR "r24") Input] +case_copyTree = assertRouteEnds copyTreeProg "copyTree" [EndOf $ LRM (singleLocVar "lin23") (AoSR $ VarR "r24") Input] case_id3 :: Assertion case_id3 = assertRouteEnds id3Prog "id3" [] case_copy_on_id1 :: Assertion -case_copy_on_id1 = assertRouteEnds copyOnId1Prog "id1WithCopy" [EndOf $ LRM (singleLocVar "lin19") (VarR "r20") Input] +case_copy_on_id1 = assertRouteEnds copyOnId1Prog "id1WithCopy" [EndOf $ LRM (singleLocVar "lin19") (AoSR $ VarR "r20") Input] -- | routeEnds2Tests :: TestTree