, setInfoTableSRT, setInfoTableStackMap
, TopSRT, emptySRT, srtToData
, bundleCAFs
- , finishInfoTables, lowerSafeForeignCalls, extendEnvsForSafeForeignCalls )
+ , finishInfoTables, lowerSafeForeignCalls
+ , cafTransfers, liveSlotTransfers
+ , extendEnvWithSafeForeignCalls, extendEnvsForSafeForeignCalls )
where
#include "HsVersions.h"
do let liftCAF lbl () z = -- get CAFs for functions without static closures
case lookupFM topCAFMap lbl of Just cafs -> z `plusFM` cafs
Nothing -> addToFM z lbl ()
+ -- For each label referring to a function f without a static closure,
+ -- replace it with the CAFs that are reachable from f.
sub_srt topSRT localCafs =
let cafs = keysFM (foldFM liftCAF emptyFM localCafs)
mkSRT topSRT =
-- doesn't have a static closure.
-- (If it has a static closure, it will already have an SRT to
-- keep its CAFs live.)
--- Any procedure referring to a non-static CAF c must keep live the
+-- Any procedure referring to a non-static CAF c must keep live
-- any CAF that is reachable from c.
localCAFInfo :: CAFEnv -> CmmTopZ -> Maybe (CLabel, CAFSet)
localCAFInfo _ (CmmData _ _) = Nothing
bundleCAFs :: CAFEnv -> CmmTopForInfoTables -> (CAFSet, CmmTopForInfoTables)
bundleCAFs cafEnv t@(ProcInfoTable _ procpoints) =
case blockSetToList procpoints of
- [bid] -> (expectJust "bundleCAFs " (lookupBlockEnv cafEnv bid), t)
+ [bid] -> (expectJust "bundleCAFs" (lookupBlockEnv cafEnv bid), t)
_ -> panic "setInfoTableStackMap: unexpect number of procpoints"
-- until we stop splitting the graphs at procpoints in the native path
bundleCAFs cafEnv t@(FloatingInfoTable _ bid _) =
-- Our analyses capture the dataflow facts at block boundaries, but we need
-- to extend the CAF and live-slot analyses to safe foreign calls as well,
-- which show up as middle nodes.
+extendEnvWithSafeForeignCalls ::
+ BackwardTransfers Middle Last a -> BlockEnv a -> CmmGraph -> BlockEnv a
+extendEnvWithSafeForeignCalls transfers env g = fold_blocks block env g
+ where block b z =
+ tail (bt_last_in transfers l (lookup env)) z head
+ where (head, last) = goto_end (G.unzip b)
+ l = case last of LastOther l -> l
+ LastExit -> panic "extendEnvs lastExit"
+ tail _ z (ZFirst _) = z
+ tail fact env (ZHead h m@(MidForeignCall (Safe bid _) _ _ _)) =
+ tail (mid m fact) (extendBlockEnv env bid fact) h
+ tail fact env (ZHead h m) = tail (mid m fact) env h
+ lookup map k = expectJust "extendEnvWithSafeFCalls" $ lookupBlockEnv map k
+ mid = bt_middle_in transfers
+
+
extendEnvsForSafeForeignCalls :: CAFEnv -> SlotEnv -> CmmGraph -> (CAFEnv, SlotEnv)
extendEnvsForSafeForeignCalls cafEnv slotEnv g =
fold_blocks block (cafEnv, slotEnv) g
tail s b@(ZBlock (ZFirst _) _) =
do state <- s
return $ state { s_blocks = insertBlock (G.zip b) (s_blocks state) }
- tail s (ZBlock (ZHead h m@(MidForeignCall (Safe bid updfr_off) _ _ _)) t) =
+ tail s (ZBlock (ZHead h m@(MidForeignCall (Safe bid updfr_off) _ _ _)) t) =
do state <- s
let state' = state
{ s_safeCalls = FloatingInfoTable emptyContInfoTable bid updfr_off :
--------------- Stack layout ----------------
slotEnv <- run $ liveSlotAnal g
mbpprTrace "live slot analysis results: " (ppr slotEnv) $ return ()
- cafEnv <-
- -- trace "post liveSlotAnal" $
- run $ cafAnal g
- (cafEnv, slotEnv) <-
- -- trace "post print cafAnal" $
- return $ extendEnvsForSafeForeignCalls cafEnv slotEnv g
+ -- cafEnv <- -- trace "post liveSlotAnal" $ run $ cafAnal g
+ -- (cafEnv, slotEnv) <-
+ -- -- trace "post print cafAnal" $
+ -- return $ extendEnvsForSafeForeignCalls cafEnv slotEnv g
+ slotEnv <- return $ extendEnvWithSafeForeignCalls liveSlotTransfers slotEnv g
mbpprTrace "slotEnv extended for safe foreign calls: " (ppr slotEnv) $ return ()
let areaMap = layout procPoints slotEnv entry_off g
mbpprTrace "areaMap" (ppr areaMap) $ return ()
mapM_ (dump Opt_D_dump_cmmz "after splitting") gs
------------- More CAFs and foreign calls ------------
+ cafEnv <- run $ cafAnal g
+ cafEnv <- return $ extendEnvWithSafeForeignCalls cafTransfers cafEnv g
let localCAFs = catMaybes $ map (localCAFInfo cafEnv) gs
mbpprTrace "localCAFs" (ppr localCAFs) $ return ()
+
gs <- liftM concat $ run $ foldM lowerSafeForeignCalls [] gs
mapM_ (dump Opt_D_dump_cmmz "after lowerSafeForeignCalls") gs