Skip to content

Commit 8b9645d

Browse files
vidsinghalvidsinghal
committed
Add extra meta-data in data type to signify memory layout + enable to specify this via annotations
1 parent 2fa594e commit 8b9645d

File tree

11 files changed

+68
-30
lines changed

11 files changed

+68
-30
lines changed

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

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,6 @@
1+
12
data List = Cons Int List | Nil
3+
{-# ANN type List "Factored" #-}
24

35

46
mkList :: Int -> List

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

Lines changed: 34 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -154,6 +154,7 @@ data TopLevel
154154
| HFunDef (FunDef Var Exp0)
155155
| HMain (Maybe (Exp0, Ty0))
156156
| HInline Var
157+
| MemLayoutTy TyCon MemoryLayout
157158
deriving (Show, Eq)
158159

159160
type TopTyEnv = TyEnv Var TyScheme
@@ -170,7 +171,8 @@ desugarModule cfg pstate_ref import_route dir (Module _ head_mb _pragmas imports
170171
imported_progs :: [PassM Prog0] <- mapM (processImport cfg pstate_ref (mod_name : import_route) dir) imports
171172
let prog = do
172173
toplevels <- catMaybes <$> mapM (collectTopLevel type_syns funtys) decls
173-
let (defs,_vars,funs,inlines,main) = foldr classify init_acc toplevels
174+
let (defs,_vars,funs,inlines,main, memlayouts) = foldr classify init_acc toplevels
175+
defs' = updateMemoryLayout defs memlayouts
174176
funs' = foldr (\v acc -> M.update (\fn@(FunDef{funMeta}) -> Just (fn { funMeta = funMeta { funInline = Inline }})) v acc) funs inlines
175177
imported_progs' <- mapM id imported_progs
176178
let (defs0,funs0) =
@@ -200,29 +202,44 @@ desugarModule cfg pstate_ref import_route dir (Module _ head_mb _pragmas imports
200202
([], []) -> (M.union ddefs defs1, M.union fundefs funs1)
201203
(_x:_xs,_) -> error $ "Conflicting definitions of " ++ show conflicts1 ++ " found in " ++ mod_name
202204
(_,_x:_xs) -> error $ "Conflicting definitions of " ++ show (S.toList em2) ++ " found in " ++ mod_name)
203-
(defs, funs')
205+
(defs', funs')
204206
imported_progs'
205207
pure (Prog defs0 funs0 main)
206208
pure prog
207209
where
208-
init_acc = (M.empty, M.empty, M.empty, S.empty, Nothing)
210+
init_acc = (M.empty, M.empty, M.empty, S.empty, Nothing, M.empty)
209211
mod_name = moduleName head_mb
210212

211213
moduleName :: Maybe (ModuleHead a) -> String
212214
moduleName Nothing = "Main"
213215
moduleName (Just (ModuleHead _ mod_name1 _warnings _exports)) =
214216
mnameToStr mod_name1
215217

216-
classify thing (defs,vars,funs,inlines,main) =
218+
classify thing (defs,vars,funs,inlines,main, memlayouts) =
217219
case thing of
218-
HDDef d -> (M.insert (tyName d) d defs, vars, funs, inlines, main)
219-
HFunDef f -> (defs, vars, M.insert (funName f) f funs, inlines, main)
220+
HDDef d -> (M.insert (tyName d) d defs, vars, funs, inlines, main, memlayouts)
221+
HFunDef f -> (defs, vars, M.insert (funName f) f funs, inlines, main, memlayouts)
220222
HMain m ->
221223
case main of
222-
Nothing -> (defs, vars, funs, inlines, m)
224+
Nothing -> (defs, vars, funs, inlines, m, memlayouts)
223225
Just _ -> error $ "A module cannot have two main expressions."
224226
++ show mod_name
225-
HInline v -> (defs,vars,funs,S.insert v inlines,main)
227+
HInline v -> (defs,vars,funs,S.insert v inlines,main, memlayouts)
228+
MemLayoutTy tycon l -> (defs,vars,funs,inlines,main, M.insert tycon l memlayouts)
229+
230+
updateMemoryLayout indefs memlayouts =
231+
let defs'' = M.mapWithKey (\k v -> let tyName = fromVar k
232+
layout = M.lookup tyName memlayouts
233+
in case layout of
234+
Just val -> let
235+
v' = v{memLayout=val}
236+
in v'
237+
Nothing -> let
238+
v' = v{memLayout=Linear}
239+
in v'
240+
) indefs
241+
in defs''
242+
226243
desugarModule _ _ _ _ m = error $ "desugarModule: " ++ prettyPrint m
227244

228245
stdlibModules :: [String]
@@ -938,12 +955,20 @@ collectTopLevel type_syns env decl =
938955
-- 'collectTypeSynonyms'.
939956
TypeDecl{} -> pure Nothing
940957

958+
AnnPragma _ annotation ->
959+
case annotation of
960+
TypeAnn _ (Ident _ tycon) (Lit _ (String _ "Factored" _)) -> pure $ Just (MemLayoutTy tycon FullyFactored)
961+
TypeAnn _ (Ident _ tycon) (Lit _ (String _ "Linear" _)) -> pure $ Just (MemLayoutTy tycon Linear)
962+
_ -> error "Memory Layout not yet supported!"
963+
964+
941965
DataDecl _ (DataType _) _ctx decl_head cons _deriving_binds -> do
942966
let (ty_name, ty_args) = desugarDeclHead decl_head
943967
cons' = map (desugarConstr type_syns) cons
944968
if ty_name `S.member` builtinTys
945969
then error $ sdoc ty_name ++ " is a built-in type."
946-
else pure $ Just $ HDDef (DDef ty_name ty_args cons')
970+
-- Default to Linear memory layout but we update it using Ann pragmas if available.
971+
else pure $ Just $ HDDef (DDef ty_name ty_args cons' Linear)
947972

948973
-- Reserved for HS.
949974
PatBind _ (PVar _ (Ident _ "main")) (UnGuardedRhs _ _) _binds ->

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

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -13,7 +13,7 @@ treeDD :: DDefs (UrTy ())
1313
treeDD = (fromListDD [DDef "Tree" []
1414
[ ("Leaf",[(False,IntTy)])
1515
, ("Node",[(False,treeTy)
16-
,(False,treeTy)])]])
16+
,(False,treeTy)])] Linear])
1717

1818
mkAdd1Prog :: Exp1 -> Maybe (Exp1, Ty1) -> Prog1
1919
mkAdd1Prog bod mainExp = Prog treeDD

‎gibbon-compiler/src/Gibbon/L2/Examples.hs‎

Lines changed: 5 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -28,7 +28,7 @@ ddtree = fromListDD [DDef (toVar "Tree") []
2828
[ ("Leaf",[(False,IntTy)])
2929
, ("Node",[ (False,PackedTy "Tree" (Single "l"))
3030
, (False,PackedTy "Tree" (Single "l"))])
31-
]]
31+
] Linear]
3232

3333

3434
tTypeable :: Exp2
@@ -791,7 +791,7 @@ stree = fromListDD [DDef (toVar "STree") []
791791
-- for now, 1 is true, 0 is false
792792
, (False, PackedTy "STree" (Single "l"))
793793
, (False, PackedTy "STree" (Single "l"))])
794-
]]
794+
] Linear]
795795

796796
{-
797797
@@ -1191,7 +1191,7 @@ ddexpr = fromListDD [DDef (toVar "Expr") []
11911191
, ("LETE" , [(False,IntTy),
11921192
(False,PackedTy "Expr" (Single "l")),
11931193
(False,PackedTy "Expr" (Single "l"))])
1194-
]]
1194+
] Linear]
11951195

11961196
copyExprFun :: FunDef2
11971197
copyExprFun = FunDef "copyExpr" [ "e700"] copyExprFunTy copyExprFunBod (FunMeta Rec NoInline False)
@@ -1315,7 +1315,7 @@ ddtree' = fromListDD [DDef (toVar "Tree") []
13151315
, (False,PackedTy "Tree" (Single "l"))
13161316
, (False,PackedTy "Tree" (Single "l"))])
13171317
, (indirectionTag++"1", [(False,CursorTy)])
1318-
]]
1318+
] Linear]
13191319

13201320
-- The rightmost function *without* copy-insertion. Gibbon should add and use
13211321
-- indirection pointers to get to the rightmost node of the tree.
@@ -1473,4 +1473,4 @@ ddsnoclist = fromListDD [DDef (toVar "SnocList") []
14731473
[ ("Nil", [])
14741474
, ("Snoc" , [(False,PackedTy "SnocList" (Single "l")),
14751475
(False,IntTy)])
1476-
]]
1476+
] Linear]

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

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -856,10 +856,10 @@ revertToL1 Prog{ddefs,fundefs,mainExp} =
856856
Just (e,ty) -> Just (revertExp e, stripTyLocs ty)
857857

858858
revertDDef :: DDef Ty2 -> DDef Ty1
859-
revertDDef (DDef tyargs a b) =
859+
revertDDef (DDef tyargs a b l) =
860860
DDef tyargs a
861861
(L.filter (\(dcon,_) -> not $ isIndirectionTag dcon) $
862-
L.map (\(dcon,tys) -> (dcon, L.map (\(x,y) -> (x, stripTyLocs y)) tys)) b)
862+
L.map (\(dcon,tys) -> (dcon, L.map (\(x,y) -> (x, stripTyLocs y)) tys)) b) l
863863

864864
revertFunDef :: FunDef2 -> FunDef1
865865
revertFunDef FunDef{funName,funArgs,funTy,funBody,funMeta} =

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

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -271,7 +271,7 @@ instance (Out l, Out d) => Out (E3Ext l d)
271271

272272
-- | Erase LocVar markers from the data definition
273273
eraseLocMarkers :: DDef L2.Ty2 -> DDef Ty3
274-
eraseLocMarkers (DDef tyargs tyname ls) = DDef tyargs tyname $ L.map go ls
274+
eraseLocMarkers (DDef tyargs tyname ls layout) = DDef tyargs tyname (L.map go ls) layout
275275
where go :: (DataCon,[(IsBoxed,L2.Ty2)]) -> (DataCon,[(IsBoxed,Ty3)])
276276
go (dcon,ls') = (dcon, L.map (\(b,ty) -> (b,L2.stripTyLocs (L2.unTy2 ty))) ls')
277277

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

Lines changed: 11 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -14,7 +14,7 @@
1414
module Gibbon.Language.Syntax
1515
(
1616
-- * Datatype definitions
17-
DDefs, TyCon, Tag, IsBoxed, DDef(..)
17+
DDefs, TyCon, Tag, IsBoxed, MemoryLayout(..), DDef(..)
1818
, lookupDDef, getConOrdering, getTyOfDataCon, lookupDataCon, lkp
1919
, lookupDataCon', insertDD, emptyDD, fromListDD, isVoidDDef
2020

@@ -83,6 +83,13 @@ type Tag = Word8
8383

8484
type IsBoxed = Bool
8585

86+
87+
data MemoryLayout =
88+
FullyFactored
89+
| Linear
90+
| Mixed -- V.S this is not implemented but it would be nice to support mixed layouts.
91+
deriving (Read, Show, Eq, Ord, Out, NFData, Generic)
92+
8693
-- | Data type definitions.
8794
--
8895
-- Monomorphism: In the extreme case we can strip packed datatypes of
@@ -96,7 +103,9 @@ type IsBoxed = Bool
96103
-- fields.
97104
data DDef a = DDef { tyName :: Var
98105
, tyArgs :: [TyVar]
99-
, dataCons :: [(DataCon,[(IsBoxed,a)])] }
106+
, dataCons :: [(DataCon,[(IsBoxed,a)])]
107+
, memLayout :: MemoryLayout -- | The low level memory layout of the data type
108+
}
100109
deriving (Read, Show, Eq, Ord, Functor, Generic)
101110

102111
instance NFData a => NFData (DDef a) where

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

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -421,10 +421,10 @@ revertToL1 Prog{ddefs,fundefs,mainExp} =
421421
Just (e,ty) -> Just (revertExp e, stripTyLocs (unTy2 ty))
422422

423423
revertDDef :: DDef Ty2 -> DDef Ty1
424-
revertDDef (DDef tyargs a b) =
424+
revertDDef (DDef tyargs a b l) =
425425
DDef tyargs a
426426
(L.filter (\(dcon,_) -> not $ isIndirectionTag dcon) $
427-
L.map (\(dcon,tys) -> (dcon, L.map (\(x,y) -> (x, stripTyLocs (unTy2 y))) tys)) b)
427+
L.map (\(dcon,tys) -> (dcon, L.map (\(x,y) -> (x, stripTyLocs (unTy2 y))) tys)) b) l
428428

429429
revertFunDef :: FunDef2 -> FunDef1
430430
revertFunDef FunDef{funName,funArgs,funTy,funBody,funMeta} =

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

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -31,12 +31,12 @@ freshNames (Prog defs funs main) =
3131
return $ Prog defs' funs' main'
3232

3333
freshDDef :: DDef Ty0 -> PassM (DDef Ty0)
34-
freshDDef DDef{tyName,tyArgs,dataCons} = do
34+
freshDDef DDef{tyName,tyArgs,dataCons,memLayout} = do
3535
rigid_tyvars <- mapM (\(UserTv v) -> BoundTv <$> gensym v) tyArgs
3636
let env :: TyVarEnv Ty0
3737
env = M.fromList $ zip tyArgs (map TyVar rigid_tyvars)
3838
dataCons' <- mapM (\(dcon,vs) -> (dcon,) <$> mapM (go (sdoc (dcon,vs)) rigid_tyvars env) vs) dataCons
39-
pure (DDef tyName rigid_tyvars dataCons')
39+
pure (DDef { tyName = tyName, tyArgs = rigid_tyvars, dataCons= dataCons', memLayout = memLayout})
4040
where
4141
go :: String -> [TyVar] -> TyVarEnv Ty0 -> (t, Ty0) -> PassM (t, Ty0)
4242
go msg bound env (b, ty) = do

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

Lines changed: 4 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -276,15 +276,17 @@ convertTyHelperGetLocForField' dcon index nameForLoc = do
276276

277277
convertDDefs :: DDefs Ty1 -> PassM (DDefs Ty2)
278278
convertDDefs ddefs = traverse f ddefs
279-
where f (DDef tyargs n dcs) = do
279+
-- VS: TODO, check the layout here instead of making a flag
280+
-- in order to check the layout
281+
where f (DDef tyargs n dcs layout) = do
280282
dflags <- getDynFlags
281283
let useSoA = gopt Opt_Packed_SoA dflags
282284
dcs' <- forM dcs $ \(dc,bnds) -> do
283285
bnds' <- forM bnds $ \(isb,ty) -> do
284286
ty' <- convertTy ddefs useSoA ty
285287
return (isb, ty')
286288
return (dc,bnds')
287-
return $ DDef tyargs n dcs'
289+
return $ DDef tyargs n dcs' layout
288290

289291
-- Inference algorithm
290292
--------------------------------------------------------------------------------

0 commit comments

Comments
 (0)