Skip to content

Commit da11f7e

Browse files
vidsinghalvidsinghal
committed
fix indirection in case bindings
1 parent e1793a6 commit da11f7e

File tree

1 file changed

+62
-14
lines changed

1 file changed

+62
-14
lines changed

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

Lines changed: 62 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -98,7 +98,6 @@ followPtrs (Prog ddefs fundefs mainExp) = do
9898
-- no need to update single location variables
9999
Single{} -> return $ (nl ++ [locvar], bnds)
100100
) ([], []) out_locs
101-
102101
let redir_dcon = fst $ fromJust $ L.find (isRedirectionTag . fst) dataCons
103102
let redir_bod = (if isPrinterName funName then LetE (wc,[],ProdTy[],PrimAppE PrintSym [LitSymE (toVar " ->r ")]) else id) $
104103
LetE (callv,endofs,out_ty,AppE funName (in_locs ++ new_out_locs) args) $
@@ -144,24 +143,73 @@ followPtrs (Prog ddefs fundefs mainExp) = do
144143
-- Get data con loc of scrut (indir_ptrloc)
145144
-- Bump this up by 8
146145
-- Make the new SoA location with the data con loc
147-
-- Field locs will all be the same.
148-
let data_con_let = LetLocE (getDconLoc indir_ptrloc) (GetDataConLocSoA indir_ptrloc)
149-
let new_jump_dloc = LetLocE (getDconLoc jump) (AfterConstantLE 8 ((getDconLoc indir_ptrloc)))
150-
let unpack_fld_lets = foldr (\((dcon, idx), lc) acc -> acc ++ [LetLocE lc (GetFieldLocSoA (dcon, idx) indir_ptrloc)]) [] (getAllFieldLocsSoA indir_ptrloc)
146+
-- Field locs will all be the same
147+
indir_br <- case scrt_loc of
148+
SoA{} -> do
149+
let data_con_let = LetLocE (getDconLoc scrt_loc) (GetDataConLocSoA scrt_loc)
150+
let new_jump_dloc = LetLocE (getDconLoc jump) (AfterConstantLE 9 ((getDconLoc scrt_loc)))
151+
let unpack_fld_lets = foldr (\((dcon, idx), lc) acc -> acc ++ [LetLocE lc (GetFieldLocSoA (dcon, idx) scrt_loc)]) [] (getAllFieldLocsSoA scrt_loc)
151152

152-
let indir_bod = Ext $ LetLocE (jump) (GenSoALoc (getDconLoc jump) (getAllFieldLocsSoA indir_ptrloc) ) $
153-
(if isPrinterName funName then LetE (wc,[],ProdTy[],PrimAppE PrintSym [LitSymE (toVar " ->i ")]) else id) $
154-
LetE (callv,endofs,out_ty,AppE funName (in_locs ++ out_locs) args) $
155-
Ext (RetE ret_endofs callv)
156-
let indir_bod' = foldr (\l b -> Ext $ l b) indir_bod ([data_con_let] ++ [new_jump_dloc] ++ unpack_fld_lets)
157-
let indir_dcon = fst $ fromJust $ L.find (isIndirectionTag . fst) dataCons
158-
let indir_br = (indir_dcon,[(indir_ptrv,(indir_ptrloc))],indir_bod')
153+
let indir_bod = Ext $ LetLocE (jump) (GenSoALoc (getDconLoc jump) (getAllFieldLocsSoA scrt_loc) ) $
154+
(if isPrinterName funName then LetE (wc,[],ProdTy[],PrimAppE PrintSym [LitSymE (toVar " ->i ")]) else id) $
155+
LetE (callv,endofs,out_ty,AppE funName (in_locs ++ out_locs) args) $
156+
Ext (RetE ret_endofs callv)
157+
let indir_bod' = foldr (\l b -> Ext $ l b) indir_bod ([data_con_let] ++ [new_jump_dloc] ++ unpack_fld_lets)
158+
let indir_dcon = fst $ fromJust $ L.find (isIndirectionTag . fst) dataCons
159+
return $ (indir_dcon,[(indir_ptrv,(indir_ptrloc))],indir_bod')
160+
Single{} -> do
161+
let indir_bod = Ext $ LetLocE (jump) (AfterConstantLE 8 (indir_ptrloc)) $
162+
(if isPrinterName funName then LetE (wc,[],ProdTy[],PrimAppE PrintSym [LitSymE (toVar " ->i ")]) else id) $
163+
LetE (callv,endofs,out_ty,AppE funName (in_locs ++ out_locs) args) $
164+
Ext (RetE ret_endofs callv)
165+
let indir_dcon = fst $ fromJust $ L.find (isIndirectionTag . fst) dataCons
166+
return $ (indir_dcon,[(indir_ptrv,(indir_ptrloc))],indir_bod)
167+
159168
----------------------------------------
169+
-- [VS: 09/14/2025]
170+
-- In case an output location, that's passed to the function call.
171+
-- for an SoA location, we cannot simply pass this directly.
172+
-- Since we do this by value, we need to update the SoA location,
173+
-- because bounds checking may have updated the value of the location.
174+
-- Note that we only need to update the non packed locations + the data constructor buffer.
175+
-- Other packed types will be updated by the function that traverses it.
176+
(new_out_locs, new_loc_bnds) <- foldrM (\locvar (nl, bnds) -> case locvar of
177+
SoA dloc flocs -> do
178+
-- unpack all locations in the SoA location.
179+
let unpack_dcon = LetLocE (singleLocVar dloc) (GetDataConLocSoA locvar)
180+
let unpack_flds = map (\((dcon, idx), floc) -> do
181+
let flet = LetLocE floc (GetFieldLocSoA (dcon, idx) locvar)
182+
in flet
183+
) flocs
184+
-- make a new name for this loc_var
185+
new_locvar <- freshCommonLoc "copy" locvar
186+
let new_don_loc = getDconLoc new_locvar
187+
-- The data con loc should be unpacked and updated by bounds check.
188+
-- from design of the compiler
189+
let new_don_let = LetLocE new_don_loc (AfterConstantLE 0 (singleLocVar dloc))
190+
let new_fld_locs = getAllFieldLocsSoA new_locvar
191+
new_fld_lets <- foldrM (\((dcon, idx), nfloc) flts -> do
192+
let ty = (lookupDataCon ddefs dcon) !! idx
193+
in case (ty) of
194+
PackedTy{} -> do
195+
let let_for_fld = LetLocE nfloc (GetFieldLocSoA (dcon, idx) locvar)
196+
in pure $ flts ++ [let_for_fld]
197+
_ -> do
198+
let let_for_fld = LetLocE nfloc (AfterConstantLE 0 (getFieldLoc (dcon, idx) locvar))
199+
in pure $ flts ++ [let_for_fld]
200+
) [] new_fld_locs
201+
let new_soa_loc_let = LetLocE new_locvar (GenSoALoc new_don_loc new_fld_locs)
202+
return $ (nl ++ [new_locvar], bnds ++ [unpack_dcon] ++ unpack_flds ++ [new_don_let] ++ new_fld_lets ++ [new_soa_loc_let])
203+
204+
-- no need to update single location variables
205+
Single{} -> return $ (nl ++ [locvar], bnds)
206+
) ([], []) out_locs
160207
let redir_dcon = fst $ fromJust $ L.find (isRedirectionTag . fst) dataCons
161208
let redir_bod = (if isPrinterName funName then LetE (wc,[],ProdTy[],PrimAppE PrintSym [LitSymE (toVar " ->r ")]) else id) $
162-
LetE (callv,endofs,out_ty,AppE funName (in_locs ++ out_locs) args) $
209+
LetE (callv,endofs,out_ty,AppE funName (in_locs ++ new_out_locs) args) $
163210
Ext (RetE endofs callv)
164-
let redir_br = (redir_dcon,[(indir_ptrv,(indir_ptrloc))],redir_bod)
211+
let redir_bod' = foldr (\bnd bod -> Ext $ bnd bod) redir_bod new_loc_bnds
212+
let redir_br = (redir_dcon,[(indir_ptrv,(indir_ptrloc))],redir_bod')
165213
----------------------------------------
166214
(pure (CaseE scrt (brs ++ [indir_br,redir_br])))
167215
IfE a b c -> do

0 commit comments

Comments
 (0)