Skip to content

Commit 643ca47

Browse files
vidsinghalvidsinghal
committed
Make Redirections SoA
1 parent 211a88a commit 643ca47

File tree

2 files changed

+68
-32
lines changed

2 files changed

+68
-32
lines changed

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

Lines changed: 53 additions & 25 deletions
Original file line numberDiff line numberDiff line change
@@ -2598,7 +2598,7 @@ unpackDataCon dcon_var freeVarToVarEnv lenv ddfs fundefs denv1 tenv1 senv isPack
25982598

25992599
_ -> error $ "unpackRegularDataCon: Unexpected numnber of varible, type pairs: " ++ show (vlocs,tys)
26002600
{- VS: TODO: handle other cases. Right now, it is only scalar and packed -}
2601-
SoAWin dcur field_cur -> do
2601+
SoAWin dcur _field_cur -> do
26022602
case (vlocs, tys) of
26032603
([],[]) -> processRhs denv tenv
26042604
((v,locarg):rst_vlocs, (MkTy2 ty):rst_tys) ->
@@ -2609,8 +2609,8 @@ unpackDataCon dcon_var freeVarToVarEnv lenv ddfs fundefs denv1 tenv1 senv isPack
26092609
loc_var <- lookupVariable loc fenv
26102610
(tenv', binds) <- scalarBinds ty v loc_var tenv
26112611
let field_idx = fromJust $ L.elemIndex (v, locarg) vlocs1
2612-
let field_cur' = map (\(k@(d, idx), var) -> if (d, idx) == (dcon, field_idx) then (k, (toEndV v)) else (k, var)) field_cur
2613-
let cur = fromJust $ L.lookup (dcon, field_idx) field_cur
2612+
let field_cur' = map (\(k@(d, idx), var) -> if (d, idx) == (dcon, field_idx) then (k, (toEndV v)) else (k, var)) _field_cur
2613+
let cur = fromJust $ L.lookup (dcon, field_idx) _field_cur
26142614
if canBind
26152615
then do
26162616
-- If the location exists in the environment, it indicates that the
@@ -2630,28 +2630,56 @@ unpackDataCon dcon_var freeVarToVarEnv lenv ddfs fundefs denv1 tenv1 senv isPack
26302630
-- An indirection or redirection pointer.
26312631
-- ASSUMPTION: We can always bind it, since it occurs immediately after the tag.
26322632
CursorTy -> do
2633-
tmp <- gensym "readcursor_indir"
2633+
tmp <- dbgTrace (minChatLvl) "Print field_cur: " dbgTrace (minChatLvl) (sdoc (dcur, _field_cur)) dbgTrace (minChatLvl) "End FieldCur\n" gensym "readcursor_indir"
2634+
tmp_flds <- mapM (\((dcon, idx), _) -> gensym "readcursor_indir_flds") _field_cur
26342635
loc_var <- lookupVariable loc fenv
2635-
let field_idx = fromJust $ L.elemIndex (v, locarg) vlocs1
2636-
let cur = fromJust $ L.lookup (dcon, field_idx) field_cur
2636+
var_dcon_next <- gensym "dcon_next"
2637+
vars_next_fields <- mapM (\((dcon, idx), _) -> gensym "field_nxt") _field_cur
2638+
redirection_var_dcon <- gensym "dcon_redir"
2639+
redirection_var_flds <- mapM (\((dcon, idx), _) -> gensym "fld_redir") _field_cur
2640+
--let field_idx = fromJust $ L.elemIndex (v, locarg) vlocs1
2641+
--let cur = fromJust $ L.lookup (dcon, field_idx) _field_cur
26372642
let tenv' = M.union (M.fromList [(tmp , MkTy2 (ProdTy [CursorTy, CursorTy, IntTy])),
2638-
((loc_var) , MkTy2 CursorTy),
2639-
(v , MkTy2 CursorTy),
2640-
(toEndV v, MkTy2 CursorTy),
2641-
(toTagV v, MkTy2 IntTy),
2642-
(toEndFromTaggedV v, MkTy2 CursorTy)])
2643+
--((loc_var) , MkTy2 CursorTy),
2644+
(redirection_var_dcon , MkTy2 CursorTy),
2645+
(toEndV redirection_var_dcon, MkTy2 CursorTy),
2646+
(toTagV redirection_var_dcon, MkTy2 IntTy),
2647+
(toEndFromTaggedV redirection_var_dcon, MkTy2 CursorTy)])
26432648
tenv
26442649
read_cursor = if isIndirectionTag dcon || isRedirectionTag dcon
2645-
then Ext (ReadTaggedCursor cur)
2650+
then Ext (ReadTaggedCursor var_dcon_next)
26462651
else error $ "unpackRegularDataCon: cursorty without indirection/redirection."
2647-
binds = [(tmp , [], ProdTy [CursorTy, CursorTy, IntTy], read_cursor),
2648-
((loc_var) , [], CursorTy, VarE cur),
2649-
(v , [], CursorTy, ProjE 0 (VarE tmp)),
2650-
(toEndV v, [], CursorTy, ProjE 1 (VarE tmp)),
2651-
(toTagV v, [], IntTy , ProjE 2 (VarE tmp)),
2652-
(toEndFromTaggedV v, [], CursorTy, Ext $ AddCursor v (VarE (toTagV v)))]
2653-
bod <- go curw fenv rst_vlocs rst_tys canBind denv tenv' -- (toEndV v)
2654-
return $ mkLets binds bod
2652+
-- v is the variable i want to send to the call.
2653+
-- In this case v is the soa variable where all redirections are unpacked.
2654+
binds = [(var_dcon_next, [], CursorTy, Ext (AddCursor dcur (LitE 1))),
2655+
(tmp , [], ProdTy [CursorTy, CursorTy, IntTy], read_cursor),
2656+
((loc_var) , [], CursorTy, VarE dcur),
2657+
(redirection_var_dcon , [], CursorTy, ProjE 0 (VarE tmp)),
2658+
(toEndV redirection_var_dcon, [], CursorTy, ProjE 1 (VarE tmp)),
2659+
(toTagV redirection_var_dcon, [], IntTy , ProjE 2 (VarE tmp)),
2660+
(toEndFromTaggedV redirection_var_dcon, [], CursorTy, Ext $ AddCursor redirection_var_dcon (VarE (toTagV redirection_var_dcon)))]
2661+
2662+
--generate binds for all fields.
2663+
binds_flields = L.foldr (\((_, idx), var) (index, res) -> let read_cursor_f = if isIndirectionTag dcon || isRedirectionTag dcon
2664+
then Ext (ReadTaggedCursor (vars_next_fields !! index))
2665+
else error $ "unpackRegularDataCon: cursorty without indirection/redirection."
2666+
tmpf = tmp_flds !! index
2667+
new_binds = [(vars_next_fields !! index, [], CursorTy, Ext (AddCursor var (LitE 1))),
2668+
(tmpf , [], ProdTy [CursorTy, CursorTy, IntTy], read_cursor_f),
2669+
--((loc_var) , [], CursorTy, VarE dcur),
2670+
((redirection_var_flds !! index) , [], CursorTy, ProjE 0 (VarE tmpf)),
2671+
(toEndV (redirection_var_flds !! index), [], CursorTy, ProjE 1 (VarE tmpf)),
2672+
(toTagV (redirection_var_flds !! index), [], IntTy , ProjE 2 (VarE tmpf)),
2673+
(toEndFromTaggedV (redirection_var_flds !! index), [], CursorTy, Ext $ AddCursor (redirection_var_flds !! index) (VarE (toTagV (redirection_var_flds !! index))))]
2674+
in (index + 1, res ++ new_binds)
2675+
2676+
) (0, []) _field_cur
2677+
soa_redir_bind = [(v, [], CursorArrayTy (1 + length (redirection_var_flds)), Ext (MakeCursorArray (1 + length (redirection_var_flds)) ([redirection_var_dcon] ++ redirection_var_flds)))]
2678+
tenv'' = M.union (M.fromList [ (v, MkTy2 $ CursorArrayTy (1 + length (redirection_var_flds)))
2679+
] )
2680+
tenv
2681+
bod <- go curw fenv rst_vlocs rst_tys canBind denv tenv'' -- (toEndV v)
2682+
return $ mkLets (binds ++ (snd binds_flields) ++ soa_redir_bind) bod
26552683

26562684

26572685
VectorTy el_ty -> do
@@ -2666,7 +2694,7 @@ unpackDataCon dcon_var freeVarToVarEnv lenv ddfs fundefs denv1 tenv1 senv isPack
26662694
(v , [], ty' , ProjE 0 (VarE tmp)),
26672695
(toEndV v, [], CursorTy, ProjE 1 (VarE tmp))]
26682696
let field_idx = fromJust $ L.elemIndex (v, locarg) vlocs1
2669-
let cur = fromJust $ L.lookup (dcon, field_idx) field_cur
2697+
let cur = fromJust $ L.lookup (dcon, field_idx) _field_cur
26702698
if canBind
26712699
then do
26722700
-- If the location exists in the environment, it indicates that the
@@ -2687,7 +2715,7 @@ unpackDataCon dcon_var freeVarToVarEnv lenv ddfs fundefs denv1 tenv1 senv isPack
26872715
tmp <- gensym "read_list_tuple"
26882716
loc_var <- lookupVariable loc fenv
26892717
let field_idx = fromJust $ L.elemIndex (v, locarg) vlocs1
2690-
let cur = fromJust $ L.lookup (dcon, field_idx) field_cur
2718+
let cur = fromJust $ L.lookup (dcon, field_idx) _field_cur
26912719
let tenv' = M.union (M.fromList [(tmp , MkTy2 (ProdTy [ListTy el_ty, CursorTy])),
26922720
(v , MkTy2 (ListTy el_ty)),
26932721
(toEndV v, MkTy2 CursorTy)])
@@ -2736,13 +2764,13 @@ unpackDataCon dcon_var freeVarToVarEnv lenv ddfs fundefs denv1 tenv1 senv isPack
27362764
-- Flip canBind to indicate that the subsequent fields
27372765
-- should be added to the dependency environment.
27382766
dcon_next <- gensym $ toVar $ (fromVar dcur) ++ "_next"
2739-
let end_fields = map (\(key, varr) -> varr ) field_cur
2767+
let end_fields = map (\(key, varr) -> varr ) _field_cur
27402768
let makeCurArr = Ext $ MakeCursorArray (1 + length (end_fields)) ([dcon_next] ++ end_fields)
27412769
let let_mk_cur_arr = (loc_var, [], CursorArrayTy (1 + length (end_fields)), makeCurArr)
27422770
let dcon_nxt = [(dcon_next,[],CursorTy, Ext $ AddCursor dcur (LitE 1))] ++ [let_mk_cur_arr,(v , [], CursorArrayTy (1 + length (end_fields)), VarE (loc_var))]
27432771
-- make the new curw type
27442772
-- this consists of incrementing the data constructor buffer by one and all the rest of the fields
2745-
let curw' = SoAWin dcon_next field_cur
2773+
let curw' = SoAWin dcon_next _field_cur
27462774
bod <- go curw' fenv rst_vlocs rst_tys False denv tenv'' --(toEndV v)
27472775
return $ mkLets dcon_nxt bod
27482776
else do
@@ -2758,7 +2786,7 @@ unpackDataCon dcon_var freeVarToVarEnv lenv ddfs fundefs denv1 tenv1 senv isPack
27582786
SoA _ fl -> CursorArrayTy (1 + length fl)
27592787
let tenv' = M.insert v (MkTy2 ty3_of_field) tenv
27602788
let field_idx = fromJust $ L.elemIndex (v, locarg) vlocs1
2761-
let cur = fromJust $ L.lookup (dcon, field_idx) field_cur
2789+
let cur = fromJust $ L.lookup (dcon, field_idx) _field_cur
27622790
-- let cur = dcur
27632791
loc_var <- lookupVariable loc fenv
27642792
if canBind

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

Lines changed: 15 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -40,22 +40,30 @@ followPtrs (Prog ddefs fundefs mainExp) = do
4040
if no_copies
4141
then do
4242
indir_ptrv <- gensym "indr"
43+
indir_ptrv_loc <- freshCommonLoc "indr" scrt_loc
4344
callv <- gensym "call"
4445
wc <- gensym "wildcard"
45-
indir_ptrloc <- gensym "case"
46-
endofs <- mapM (\_ -> gensym "endof") (locRets funTy)
47-
let endofs' = map Single endofs
46+
indir_ptrloc <- freshCommonLoc "case" scrt_loc
47+
48+
endofs <- mapM (\lr -> case lr of
49+
EndOf lrm -> do
50+
let loc = lrmLoc lrm
51+
freshCommonLoc "endof" loc
52+
) (locRets funTy)
53+
54+
--endofs <- mapM (\_ -> gensym "endof") (locRets funTy)
55+
--let endofs' = map Single endofs
4856
let args = foldr (\v acc -> if v == scrtv
4957
then ((VarE indir_ptrv) : acc)
5058
else (VarE v : acc))
5159
[] funArgs
52-
let in_locs = foldr (\loc acc -> if loc == scrt_loc then ((Single indir_ptrv) : acc) else (loc : acc)) [] (inLocVars funTy)
60+
let in_locs = foldr (\loc acc -> if loc == scrt_loc then ((indir_ptrloc) : acc) else (loc : acc)) [] (inLocVars funTy)
5361
let out_locs = outLocVars funTy
5462
let redir_dcon = fst $ fromJust $ L.find (isRedirectionTag . fst) dataCons
5563
let redir_bod = (if isPrinterName funName then LetE (wc,[],ProdTy[],PrimAppE PrintSym [LitSymE (toVar " ->r ")]) else id) $
56-
LetE (callv,endofs',out_ty,AppE funName (in_locs ++ out_locs) args) $
57-
Ext (RetE endofs' callv)
58-
let redir_br = (redir_dcon,[(indir_ptrv,(Single indir_ptrloc))],redir_bod)
64+
LetE (callv,endofs,out_ty,AppE funName (in_locs ++ out_locs) args) $
65+
Ext (RetE endofs callv)
66+
let redir_br = (redir_dcon,[(indir_ptrv,(indir_ptrloc))],redir_bod)
5967
----------------------------------------
6068
(pure (CaseE scrt (brs ++ [redir_br])))
6169
else do

0 commit comments

Comments
 (0)