Skip to content

Commit bb23eb1

Browse files
vidsinghalvidsinghal
committed
fix redirections case
1 parent 1dd3b20 commit bb23eb1

File tree

4 files changed

+171
-67
lines changed

4 files changed

+171
-67
lines changed

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

Lines changed: 5 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -33,10 +33,13 @@ sumList lst = case lst of
3333
Cons i rst -> let sumRst = sumList rst
3434
in i + sumRst
3535

36+
id :: List -> List
37+
id lst = lst
38+
3639
gibbon_main = let
3740
lst = mkList 100
38-
lst' = add1 lst
39-
in sumList lst'
41+
lst' = (add1 lst)
42+
in () --sumList lst'
4043

4144

4245

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

Lines changed: 38 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,6 @@
11
module Gibbon.Passes.AddCastInstructions (addCasts) where
22

3-
import Data.Foldable (foldrM)
3+
import Data.Foldable (foldrM, foldlM)
44
import qualified Data.List as L
55
import qualified Data.Map as M
66
import Gibbon.Common
@@ -49,6 +49,24 @@ addCastsExp fundef cenv env ex =
4949
bod' <- addCastsExp fundef cenv' env' bod
5050
let ex' = foldr (\expr acc -> expr acc) bod' let_expr
5151
pure $ ex'
52+
53+
LetE (v, locs, ty, rhs@(VarE v')) bod -> do
54+
let new_env = extendVEnv v ty env
55+
let tyv' = lookupVEnv v' env
56+
(let_expr, cenv', env') <- case (ty == tyv') of
57+
True -> return $ ([LetE (v, locs, ty, rhs)], cenv, new_env)
58+
False -> do
59+
casted_var <- gensym "cast"
60+
let ncenv = M.insert v' v cenv
61+
let cursory_ty3 :: Ty3 = CursorTy
62+
let nenv = extendVEnv casted_var cursory_ty3 new_env
63+
let cast_ins = Ext $ CastPtr casted_var ty
64+
-- let new_inst = [LetE (v, locs, ty, rhs)] ++ [LetE (casted_var, [], CursorTy, cast_ins)]
65+
let new_inst = [LetE (casted_var, locs, CursorTy, rhs)] ++ [LetE (v, [], ty, cast_ins)]
66+
pure $ (new_inst, ncenv, nenv)
67+
bod' <- addCastsExp fundef cenv' env' bod
68+
let ex' = foldr (\expr acc -> expr acc) bod' let_expr
69+
pure $ ex'
5270

5371
LetE (v, locs, ty, rhs@(Ext (AddrOfCursor (Ext (IndexCursorArray _ _)))) ) bod -> do
5472
let new_env = extendVEnv v ty env
@@ -204,7 +222,25 @@ addCastsExp fundef cenv env ex =
204222
CharE {} -> pure ex
205223
FloatE {} -> pure ex
206224
LitSymE {} -> pure ex
207-
AppE f locs args -> AppE f locs <$> mapM go args
225+
AppE f locs args -> do
226+
let funTy = lookupFEnv f env
227+
let args_zip_ty = zip args (fst funTy ++ [snd funTy])
228+
(lets, new_args) <- foldlM (\(l, args') zipped -> case zipped of
229+
(VarE arg, ty) -> do
230+
let argTy = lookupVEnv arg env
231+
if argTy == ty
232+
then
233+
return $ (l, args' ++ [VarE arg])
234+
else do
235+
let new_arg = case (M.lookup arg cenv) of
236+
Just v' -> VarE v'
237+
Nothing -> error "TODO : Cast not found in env!!"
238+
return $ (l, args' ++ [new_arg])
239+
_ -> return $ (l, args' ++ [fst zipped])
240+
) ([], []) args_zip_ty
241+
-- Expecting AppE to be flat, so only variables are present in AppE.
242+
return $ AppE f locs new_args
243+
208244
PrimAppE pr args -> PrimAppE pr <$> mapM go args
209245
IfE a b c -> do
210246
a' <- go a

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

Lines changed: 93 additions & 50 deletions
Original file line numberDiff line numberDiff line change
@@ -2737,63 +2737,106 @@ unpackDataCon dcon_var freeVarToVarEnv lenv ddfs fundefs denv1 tenv1 senv isPack
27372737
-- An indirection or redirection pointer.
27382738
-- ASSUMPTION: We can always bind it, since it occurs immediately after the tag.
27392739
CursorTy -> do
2740-
tmp <- dbgTrace (minChatLvl) "Print field_cur: " dbgTrace (minChatLvl) (sdoc (dcur, _field_cur)) dbgTrace (minChatLvl) "End FieldCur\n" gensym "readcursor_indir"
2741-
tmp_flds <- mapM (\((dcon, idx), _) -> gensym "readcursor_indir_flds") _field_cur
2742-
loc_var <- lookupVariable loc fenv
2743-
var_dcon_next <- gensym "dcon_next"
2744-
vars_next_fields <- mapM (\((dcon, idx), _) -> gensym "field_nxt") _field_cur
2745-
redirection_var_dcon <- gensym "dcon_redir"
2746-
redirection_var_flds <- mapM (\((dcon, idx), _) -> gensym "fld_redir") _field_cur
2747-
--let field_idx = fromJust $ L.elemIndex (v, locarg) vlocs1
2748-
--let cur = fromJust $ L.lookup (dcon, field_idx) _field_cur
2749-
let tenv' = M.union (M.fromList [(tmp , MkTy2 (ProdTy [CursorTy, CursorTy, IntTy])),
2740+
if isRedirectionTag dcon
2741+
then do
2742+
tmp <- dbgTrace (minChatLvl) "Print field_cur: " dbgTrace (minChatLvl) (sdoc (dcur, _field_cur)) dbgTrace (minChatLvl) "End FieldCur\n" gensym "readcursor_indir"
2743+
tmp_flds <- mapM (\((dcon, idx), _) -> gensym "readcursor_indir_flds") _field_cur
2744+
loc_var <- lookupVariable loc fenv
2745+
var_dcon_next <- gensym "dcon_next"
2746+
vars_next_fields <- mapM (\((dcon, idx), _) -> gensym "field_nxt") _field_cur
2747+
redirection_var_dcon <- gensym "dcon_redir"
2748+
redirection_var_flds <- mapM (\((dcon, idx), _) -> gensym "fld_redir") _field_cur
2749+
--let field_idx = fromJust $ L.elemIndex (v, locarg) vlocs1
2750+
--let cur = fromJust $ L.lookup (dcon, field_idx) _field_cur
2751+
let tenv' = M.union (M.fromList [(tmp , MkTy2 (ProdTy [CursorTy, CursorTy, IntTy])),
27502752
--((loc_var) , MkTy2 CursorTy),
27512753
(redirection_var_dcon , MkTy2 CursorTy),
27522754
(toEndV redirection_var_dcon, MkTy2 CursorTy),
27532755
(toTagV redirection_var_dcon, MkTy2 IntTy),
27542756
(toEndFromTaggedV redirection_var_dcon, MkTy2 CursorTy)])
2755-
tenv
2756-
read_cursor = if isIndirectionTag dcon || isRedirectionTag dcon
2757-
then Ext (ReadTaggedCursor var_dcon_next)
2758-
else error $ "unpackRegularDataCon: cursorty without indirection/redirection."
2759-
-- v is the variable i want to send to the call.
2760-
-- In this case v is the soa variable where all redirections are unpacked.
2761-
binds = [(var_dcon_next, [], CursorTy, Ext (AddCursor dcur (LitE 1))),
2762-
(tmp , [], ProdTy [CursorTy, CursorTy, IntTy], read_cursor),
2763-
((loc_var) , [], CursorTy, VarE dcur),
2764-
(redirection_var_dcon , [], CursorTy, ProjE 0 (VarE tmp)),
2765-
(toEndV redirection_var_dcon, [], CursorTy, ProjE 1 (VarE tmp)),
2766-
(toTagV redirection_var_dcon, [], IntTy , ProjE 2 (VarE tmp)),
2767-
(toEndFromTaggedV redirection_var_dcon, [], CursorTy, Ext $ AddCursor redirection_var_dcon (VarE (toTagV redirection_var_dcon)))]
2768-
2769-
--generate binds for all fields.
2770-
binds_flields = L.foldl (\(index, res) ((dcon', idx), var) -> let read_cursor_f = if isIndirectionTag dcon || isRedirectionTag dcon
2771-
then Ext (ReadTaggedCursor (vars_next_fields !! index))
2772-
else error $ "unpackRegularDataCon: cursorty without indirection/redirection."
2773-
tmpf = tmp_flds !! index
2774-
ty_of_field = (lookupDataCon ddfs dcon') !! idx
2775-
in case ty_of_field of
2776-
(MkTy2 PackedTy{}) -> let new_binds = [(redirection_var_flds !! index, [], CursorTy, Ext (AddCursor var (LitE 0)))]
2777-
in (index + 1, res ++ new_binds)
2778-
(MkTy2 CursorArrayTy{}) -> let new_binds = [(redirection_var_flds !! index, [], CursorTy, Ext (AddCursor var (LitE 0)))]
2757+
tenv
2758+
read_cursor = if isIndirectionTag dcon || isRedirectionTag dcon
2759+
then Ext (ReadTaggedCursor var_dcon_next)
2760+
else error $ "unpackRegularDataCon: cursorty without indirection/redirection."
2761+
-- v is the variable i want to send to the call.
2762+
-- In this case v is the soa variable where all redirections are unpacked.
2763+
binds = [(var_dcon_next, [], CursorTy, Ext (AddCursor dcur (LitE 1))),
2764+
(tmp , [], ProdTy [CursorTy, CursorTy, IntTy], read_cursor),
2765+
((loc_var) , [], CursorTy, VarE dcur),
2766+
(redirection_var_dcon , [], CursorTy, ProjE 0 (VarE tmp)),
2767+
(toEndV redirection_var_dcon, [], CursorTy, ProjE 1 (VarE tmp)),
2768+
(toTagV redirection_var_dcon, [], IntTy , ProjE 2 (VarE tmp)),
2769+
(toEndFromTaggedV redirection_var_dcon, [], CursorTy, Ext $ AddCursor redirection_var_dcon (VarE (toTagV redirection_var_dcon)))]
2770+
2771+
--generate binds for all fields.
2772+
binds_flields = L.foldl (\(index, res) ((dcon', idx), var) -> let read_cursor_f = if isIndirectionTag dcon || isRedirectionTag dcon
2773+
then Ext (ReadTaggedCursor (vars_next_fields !! index))
2774+
else error $ "unpackRegularDataCon: cursorty without indirection/redirection."
2775+
tmpf = tmp_flds !! index
2776+
ty_of_field = (lookupDataCon ddfs dcon') !! idx
2777+
in case ty_of_field of
2778+
(MkTy2 PackedTy{}) -> let new_binds = [(redirection_var_flds !! index, [], CursorTy, Ext (AddCursor var (LitE 0)))]
2779+
in (index + 1, res ++ new_binds)
2780+
(MkTy2 CursorArrayTy{}) -> let new_binds = [(redirection_var_flds !! index, [], CursorTy, Ext (AddCursor var (LitE 0)))]
2781+
in (index + 1, res ++ new_binds)
2782+
_ -> let new_binds = [(vars_next_fields !! index, [], CursorTy, Ext (AddCursor var (LitE 1))),
2783+
(tmpf , [], ProdTy [CursorTy, CursorTy, IntTy], read_cursor_f),
2784+
--((loc_var) , [], CursorTy, VarE dcur),
2785+
((redirection_var_flds !! index) , [], CursorTy, ProjE 0 (VarE tmpf)),
2786+
(toEndV (redirection_var_flds !! index), [], CursorTy, ProjE 1 (VarE tmpf)),
2787+
(toTagV (redirection_var_flds !! index), [], IntTy , ProjE 2 (VarE tmpf)),
2788+
(toEndFromTaggedV (redirection_var_flds !! index), [], CursorTy, Ext $ AddCursor (redirection_var_flds !! index) (VarE (toTagV (redirection_var_flds !! index))))]
27792789
in (index + 1, res ++ new_binds)
2780-
_ -> let new_binds = [(vars_next_fields !! index, [], CursorTy, Ext (AddCursor var (LitE 1))),
2781-
(tmpf , [], ProdTy [CursorTy, CursorTy, IntTy], read_cursor_f),
2782-
--((loc_var) , [], CursorTy, VarE dcur),
2783-
((redirection_var_flds !! index) , [], CursorTy, ProjE 0 (VarE tmpf)),
2784-
(toEndV (redirection_var_flds !! index), [], CursorTy, ProjE 1 (VarE tmpf)),
2785-
(toTagV (redirection_var_flds !! index), [], IntTy , ProjE 2 (VarE tmpf)),
2786-
(toEndFromTaggedV (redirection_var_flds !! index), [], CursorTy, Ext $ AddCursor (redirection_var_flds !! index) (VarE (toTagV (redirection_var_flds !! index))))]
2787-
in (index + 1, res ++ new_binds)
2788-
2789-
) (0, []) _field_cur
2790-
soa_redir_bind = [(v, [], CursorArrayTy (1 + length (redirection_var_flds)), Ext (MakeCursorArray (1 + length (redirection_var_flds)) ([redirection_var_dcon] ++ redirection_var_flds)))]
2791-
tenv'' = M.union (M.fromList [ (v, MkTy2 $ CursorArrayTy (1 + length (redirection_var_flds)))
2792-
] )
2793-
tenv
2794-
bod <- go curw fenv rst_vlocs rst_tys canBind denv tenv'' -- (toEndV v)
2795-
return $ mkLets (binds ++ (snd binds_flields) ++ soa_redir_bind) bod
27962790

2791+
) (0, []) _field_cur
2792+
soa_redir_bind = [(v, [], CursorArrayTy (1 + length (redirection_var_flds)), Ext (MakeCursorArray (1 + length (redirection_var_flds)) ([redirection_var_dcon] ++ redirection_var_flds)))]
2793+
tenv'' = M.union (M.fromList [ (v, MkTy2 $ CursorArrayTy (1 + length (redirection_var_flds)))
2794+
] )
2795+
tenv
2796+
bod <- go curw fenv rst_vlocs rst_tys canBind denv tenv'' -- (toEndV v)
2797+
return $ mkLets (binds ++ (snd binds_flields) ++ soa_redir_bind) bod
2798+
else if isIndirectionTag dcon
2799+
then
2800+
do
2801+
tmp <- gensym "readcursor_indir"
2802+
loc_var <- lookupVariable loc fenv
2803+
let locs_ty = case (loc) of
2804+
FL (Single _) -> CursorTy
2805+
FL (SoA _ flds) -> CursorArrayTy (1 + length (flds))
2806+
_ -> error "Expected location!"
2807+
2808+
let locs_ty3 :: Ty3 = case (loc) of
2809+
FL (Single _) -> CursorTy
2810+
FL (SoA _ flds) -> CursorArrayTy (1 + length (flds))
2811+
_ -> error "Expected location!"
2812+
2813+
--let field_idx = fromJust $ L.elemIndex (v, locarg) vlocs1
2814+
--let cur = fromJust $ L.lookup (dcon, field_idx) _field_cur
2815+
var_dcon_next <- gensym "dcon_next"
2816+
2817+
let tenv' = M.union (M.fromList [(tmp , MkTy2 (ProdTy [CursorTy, CursorTy, IntTy])),
2818+
((loc_var) , MkTy2 locs_ty),
2819+
(v , MkTy2 locs_ty)
2820+
--(toEndV v, MkTy2 CursorTy),
2821+
--(toTagV v, MkTy2 IntTy),
2822+
--(toEndFromTaggedV v, MkTy2 CursorTy)
2823+
])
2824+
tenv
2825+
read_cursor = if isIndirectionTag dcon || isRedirectionTag dcon
2826+
then Ext (ReadTaggedCursor var_dcon_next)
2827+
else error $ "unpackRegularDataCon: cursorty without indirection/redirection."
2828+
binds = [ (var_dcon_next, [], CursorTy, Ext (AddCursor dcur (LitE 1))),
2829+
(tmp , [], ProdTy [CursorTy, CursorTy, IntTy], read_cursor),
2830+
(v , [], CursorTy, ProjE 0 (VarE tmp)),
2831+
-- (toEndV v, [], CursorTy, ProjE 1 (VarE tmp)),
2832+
-- (toTagV v, [], IntTy , ProjE 2 (VarE tmp)),
2833+
-- End of region needs to be calculated differently
2834+
-- (toEndFromTaggedV v, [], CursorTy, Ext $ AddCursor v (VarE (toTagV v))),
2835+
((loc_var) , [], locs_ty3, VarE v)
2836+
]
2837+
bod <- go curw fenv rst_vlocs rst_tys canBind denv tenv' -- (toEndV v)
2838+
return $ mkLets binds bod
2839+
else error $ "unpackRegularDataCon: cursorty without indirection/redirection."
27972840

27982841
VectorTy el_ty -> do
27992842
tmp <- gensym "read_vec_tuple"

0 commit comments

Comments
 (0)