Skip to content

Commit 8d28fcd

Browse files
vidsinghalvidsinghal
committed
Wip: supporting SoA RANs
1 parent 8b9645d commit 8d28fcd

File tree

8 files changed

+61
-16
lines changed

8 files changed

+61
-16
lines changed

‎gibbon-compiler/examples/simple_tests/tree.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -3,6 +3,7 @@ module Tree where
33
data Tree = Leaf Int Float
44
| Node Int Int Int Float Tree Tree Tree Tree
55
deriving Show
6+
{-# ANN type Tree "Factored" #-}
67

78
mkTree :: Int -> Tree
89
mkTree d =

‎gibbon-compiler/src/Gibbon/Common.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -669,6 +669,7 @@ getFieldRegFromRegVar (dcon, idx) reg = case reg of
669669
SoARv regvar fieldRegs -> case L.lookup (dcon, idx) fieldRegs of
670670
Just freg -> freg
671671
Nothing -> error "getFieldRegFromRegVar: Field location not found!"
672+
672673

673674
-- fromLocVarToRegVar :: LocVar -> RegVar
674675
-- fromLocVarToRegVar loc = case loc of

‎gibbon-compiler/src/Gibbon/Compiler.hs‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -640,6 +640,7 @@ passes :: (Show v) => Config -> L0.Prog0 -> StateT (CompileState v) IO L4.Prog
640640
passes config@Config{dynflags} l0 = do
641641
let isPacked = gopt Opt_Packed dynflags
642642
isSoA = gopt Opt_Packed_SoA dynflags
643+
noRAN = gopt Opt_No_RAN dynflags
643644
biginf = gopt Opt_BigInfiniteRegions dynflags
644645
gibbon1 = gopt Opt_Gibbon1 dynflags
645646
no_rcopies = gopt Opt_No_RemoveCopies dynflags
@@ -747,7 +748,7 @@ Also see Note [Adding dummy traversals] and Note [Adding random access nodes].
747748
748749
-}
749750
l2 <-
750-
if gibbon1
751+
if gibbon1 || noRAN
751752
then do
752753
l2 <- goE2 "addTraversals" addTraversals l2
753754
l2 <- go "L2.typecheck" L2.tcProg l2

‎gibbon-compiler/src/Gibbon/DynFlags.hs‎

Lines changed: 4 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -40,6 +40,7 @@ data GeneralFlag
4040
| Opt_NoEagerPromote -- ^ Disable eager promotion.
4141
| Opt_SimpleWriteBarrier -- ^ Disables eliminate-indirection-chains optimization.
4242
| Opt_Packed_SoA -- ^ Use packed representation but use a structure of arrays representation for the datatype
43+
| Opt_No_RAN -- ^ Don't use shortcut pointers instead use extra traversals to reach get endwitness
4344
deriving (Show,Read,Eq,Ord)
4445

4546
-- | Exactly like GHC's ddump flags.
@@ -117,7 +118,9 @@ dynflagsParser = DynFlags <$> (S.fromList <$> many gflagsParser) <*> (S.fromList
117118
flag' Opt_NoEagerPromote (long "no-eager-promote" <> help "Disable eager promotion.") <|>
118119
flag' Opt_SimpleWriteBarrier (long "simple-write-barrier" <> help "Disables eliminate-indirection-chains optimization.") <|>
119120
flag' Opt_Packed_SoA (long "SoA" <>
120-
help "Use a structure of arrays representation for all datatypes.")
121+
help "Use a structure of arrays representation for all datatypes.") <|>
122+
flag' Opt_No_RAN (long "no-ran" <>
123+
help "Don't use RAN pointers, instead, use extra traversals.")
121124

122125
dflagsParser :: Parser DebugFlag
123126
dflagsParser = flag' Opt_D_Dump_Repair (long "ddump-repair" <>

‎gibbon-compiler/src/Gibbon/L1/Typecheck.hs‎

Lines changed: 5 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -685,9 +685,11 @@ tcExp ddfs env exp =
685685

686686
Ext (StartOfPkdCursor cur) -> do
687687
ty <- lookupVar env cur exp
688-
if isPackedTy ty
689-
then pure CursorTy
690-
else throwError $ GenericTC "Expected a packed argument" exp
688+
case ty of
689+
PackedTy tycon _ -> let dd = lookupDDef ddfs tycon
690+
ranTy = getCursorTypeForDataCon ddfs dd
691+
in pure ranTy
692+
_ -> throwError $ GenericTC "Expected a packed argument" exp
691693

692694
MapE{} -> error $ "L1.Typecheck: TODO: " ++ sdoc exp
693695
FoldE{} -> error $ "L1.Typecheck: TODO: " ++ sdoc exp

‎gibbon-compiler/src/Gibbon/Language/Syntax.hs‎

Lines changed: 26 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -16,7 +16,8 @@ module Gibbon.Language.Syntax
1616
-- * Datatype definitions
1717
DDefs, TyCon, Tag, IsBoxed, MemoryLayout(..), DDef(..)
1818
, lookupDDef, getConOrdering, getTyOfDataCon, lookupDataCon, lkp
19-
, lookupDataCon', insertDD, emptyDD, fromListDD, isVoidDDef
19+
, lookupDataCon', insertDD, emptyDD, fromListDD, isVoidDDef,
20+
getCursorTypeForDataCon
2021

2122
-- * Function definitions
2223
, FunctionTy(..), FunDefs, FunDef(..), FunMeta(..), FunRec(..), FunInline(..)
@@ -162,6 +163,30 @@ lkp dds con =
162163
_ -> error$ "lookupDataCon: found multiple occurences of constructor "++show con
163164
++", in datatypes:\n "++sdoc dds
164165

166+
getCursorTypeForDataCon :: Out a => DDefs (UrTy a) -> DDef (UrTy a) -> UrTy a
167+
getCursorTypeForDataCon ddefs ddef@DDef{tyName, tyArgs, dataCons, memLayout} =
168+
-- remove data constructors introduced by RAN
169+
let dataCons' = concatMap (\e@(dcon, _) -> if ('^' `elem` dcon)
170+
then []
171+
else [e]
172+
) dataCons
173+
in case memLayout of
174+
Linear -> CursorTy
175+
FullyFactored ->
176+
let numFieldBuffers = foldr (\(dcon, _) c -> let fields = lookupDataCon ddefs dcon
177+
c' = foldr (\ty c'' -> case ty of
178+
PackedTy tycon _ ->
179+
if (toVar tycon) == tyName
180+
then c''
181+
else c'' + 1
182+
CursorTy -> c''
183+
CursorArrayTy _ -> c''
184+
_ -> c'' + 1
185+
) c fields
186+
in c'
187+
) 0 dataCons'
188+
in CursorArrayTy (numFieldBuffers + 1)
189+
_ -> error "Memory Layout is not implemented!"
165190

166191
insertDD :: DDef a -> DDefs a -> DDefs a
167192
insertDD d = M.insertWith err' (tyName d) d

‎gibbon-compiler/src/Gibbon/Passes/AddRAN.hs‎

Lines changed: 17 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -150,8 +150,15 @@ addRANExp dont_change_datacons needRANsTyCons ddfs ex =
150150
else do
151151
let -- n elements after the first packed one require RAN's.
152152
needRANsExp = L.drop (length args - n) args
153-
154-
rans <- mkRANs needRANsExp
153+
fields = lookupDataCon ddfs dcon
154+
needsRanFields = L.drop (length fields - n) fields
155+
ranTyFields = map (\ty -> case ty of
156+
PackedTy tycon _ -> let dd = lookupDDef ddfs tycon
157+
in getCursorTypeForDataCon ddfs dd
158+
_ -> CursorTy
159+
) needsRanFields
160+
161+
rans <- mkRANs ranTyFields needRANsExp
155162
let ranArgs = L.map (\(v,_,_,_) -> VarE v) rans
156163
return $ mkLets rans (DataConE loc (toAbsRANDataCon dcon) (ranArgs ++ args))
157164

@@ -243,15 +250,16 @@ withRANDDefs :: Out a => S.Set TyCon -> DDefs (UrTy a) -> DDefs (UrTy a)
243250
withRANDDefs needRANsTyCons ddfs = M.map go ddfs
244251
where
245252
-- go :: DDef a -> DDef b
246-
go dd@DDef{dataCons} =
253+
go dd@DDef{dataCons, memLayout} =
247254
let dcons' = L.foldr (\(dcon,tys) acc ->
248255
case numRANsDataCon ddfs dcon of
249256
0 -> acc
250257
n -> -- Not all types have random access nodes.
251258
if not (getTyOfDataCon ddfs dcon `S.member` needRANsTyCons)
252259
then acc
253260
else
254-
let tys' = [(False,CursorTy) | _ <- [1..n]] ++ tys
261+
let ranTy = getCursorTypeForDataCon ddfs dd
262+
tys' = [(False,ranTy) | _ <- [1..n]] ++ tys
255263
dcon' = toAbsRANDataCon dcon
256264

257265
_tys'' = (False,IntTy) : [(False,IntTy) | _ <- [1..n]] ++ tys
@@ -295,9 +303,9 @@ AddFixed for this purpose.
295303
'mb_most_recent_ran' in the fold below tracks most recent random access nodes.
296304
297305
-}
298-
mkRANs :: [Exp1] -> PassM [(Var, [()], Ty1, Exp1)]
299-
mkRANs needRANsExp =
300-
snd <$> foldlM (\(mb_most_recent_ran, acc) arg -> do
306+
mkRANs :: [(UrTy ())] -> [Exp1] -> PassM [(Var, [()], Ty1, Exp1)]
307+
mkRANs ranTys needRANsExp =
308+
snd <$> foldlM (\(mb_most_recent_ran, acc) (arg, ranTy) -> do
301309
i <- gensym "ran"
302310
-- See Note [Reusing RAN's in case expressions]
303311
let rhs = case arg of
@@ -310,8 +318,8 @@ mkRANs needRANsExp =
310318
FloatE{} -> Ext (L1.AddFixed (fromJust mb_most_recent_ran) (fromJust (sizeOfTy FloatTy)))
311319
LitSymE{} -> Ext (L1.AddFixed (fromJust mb_most_recent_ran) (fromJust (sizeOfTy SymTy)))
312320
oth -> error $ "addRANExp: Expected trivial expression, got: " ++ sdoc oth
313-
return (Just i, acc ++ [(i,[],CursorTy, rhs)]))
314-
(Nothing, []) needRANsExp
321+
return (Just i, acc ++ [(i,[],ranTy, rhs)]))
322+
(Nothing, []) (zip needRANsExp ranTys)
315323

316324
--------------------------------------------------------------------------------
317325

‎gibbon-compiler/src/Gibbon/Passes/InferLocations.hs‎

Lines changed: 5 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -200,7 +200,11 @@ convertTy ddefs useSoA ty = case useSoA of
200200
PackedTy tycon _ -> do
201201
dconBuff <- freshLocVar "loc"
202202
let dcons = getConOrdering ddefs tycon
203-
locsForFields <- convertTyHelperSoAParent tycon ddefs dcons
203+
let dcons' = concatMap (\dcon -> if ('^' `elem` dcon)
204+
then []
205+
else [dcon]
206+
) dcons
207+
locsForFields <- convertTyHelperSoAParent tycon ddefs dcons'
204208
let soaLocation = SoA (unwrapLocVar dconBuff) locsForFields
205209
dbgTrace minChatLvl "Print ty: " dbgTrace minChatLvl (sdoc (PackedTy tycon soaLocation)) dbgTrace minChatLvl "End ty.\n" return $ PackedTy tycon soaLocation
206210
_ -> traverse (const (freshLocVar "loc")) ty

0 commit comments

Comments
 (0)