Commit df5b491c authored by dias@cs.tufts.edu's avatar dias@cs.tufts.edu
Browse files

Minor refactoring and formatting

Wrote a generic function to extend dataflow results for safe foreign calls.
Should be able to throw it away when we change the representation of safe foreign calls.
parent 787b08bd
...@@ -3,7 +3,9 @@ module CmmBuildInfoTables ...@@ -3,7 +3,9 @@ module CmmBuildInfoTables
, setInfoTableSRT, setInfoTableStackMap , setInfoTableSRT, setInfoTableStackMap
, TopSRT, emptySRT, srtToData , TopSRT, emptySRT, srtToData
, bundleCAFs , bundleCAFs
, finishInfoTables, lowerSafeForeignCalls, extendEnvsForSafeForeignCalls ) , finishInfoTables, lowerSafeForeignCalls
, cafTransfers, liveSlotTransfers
, extendEnvWithSafeForeignCalls, extendEnvsForSafeForeignCalls )
where where
#include "HsVersions.h" #include "HsVersions.h"
...@@ -230,6 +232,8 @@ buildSRTs topSRT topCAFMap cafs = ...@@ -230,6 +232,8 @@ buildSRTs topSRT topCAFMap cafs =
do let liftCAF lbl () z = -- get CAFs for functions without static closures do let liftCAF lbl () z = -- get CAFs for functions without static closures
case lookupFM topCAFMap lbl of Just cafs -> z `plusFM` cafs case lookupFM topCAFMap lbl of Just cafs -> z `plusFM` cafs
Nothing -> addToFM z lbl () 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 = sub_srt topSRT localCafs =
let cafs = keysFM (foldFM liftCAF emptyFM localCafs) let cafs = keysFM (foldFM liftCAF emptyFM localCafs)
mkSRT topSRT = mkSRT topSRT =
...@@ -303,7 +307,7 @@ to_SRT top_srt off len bmp ...@@ -303,7 +307,7 @@ to_SRT top_srt off len bmp
-- doesn't have a static closure. -- doesn't have a static closure.
-- (If it has a static closure, it will already have an SRT to -- (If it has a static closure, it will already have an SRT to
-- keep its CAFs live.) -- 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. -- any CAF that is reachable from c.
localCAFInfo :: CAFEnv -> CmmTopZ -> Maybe (CLabel, CAFSet) localCAFInfo :: CAFEnv -> CmmTopZ -> Maybe (CLabel, CAFSet)
localCAFInfo _ (CmmData _ _) = Nothing localCAFInfo _ (CmmData _ _) = Nothing
...@@ -347,7 +351,7 @@ type StackLayout = [Maybe LocalReg] ...@@ -347,7 +351,7 @@ type StackLayout = [Maybe LocalReg]
bundleCAFs :: CAFEnv -> CmmTopForInfoTables -> (CAFSet, CmmTopForInfoTables) bundleCAFs :: CAFEnv -> CmmTopForInfoTables -> (CAFSet, CmmTopForInfoTables)
bundleCAFs cafEnv t@(ProcInfoTable _ procpoints) = bundleCAFs cafEnv t@(ProcInfoTable _ procpoints) =
case blockSetToList procpoints of case blockSetToList procpoints of
[bid] -> (expectJust "bundleCAFs " (lookupBlockEnv cafEnv bid), t) [bid] -> (expectJust "bundleCAFs" (lookupBlockEnv cafEnv bid), t)
_ -> panic "setInfoTableStackMap: unexpect number of procpoints" _ -> panic "setInfoTableStackMap: unexpect number of procpoints"
-- until we stop splitting the graphs at procpoints in the native path -- until we stop splitting the graphs at procpoints in the native path
bundleCAFs cafEnv t@(FloatingInfoTable _ bid _) = bundleCAFs cafEnv t@(FloatingInfoTable _ bid _) =
...@@ -409,6 +413,22 @@ finishInfoTables (FloatingInfoTable (CmmInfo _ _ infotbl) bid _) = ...@@ -409,6 +413,22 @@ finishInfoTables (FloatingInfoTable (CmmInfo _ _ infotbl) bid _) =
-- Our analyses capture the dataflow facts at block boundaries, but we need -- 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, -- to extend the CAF and live-slot analyses to safe foreign calls as well,
-- which show up as middle nodes. -- 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 -> CmmGraph -> (CAFEnv, SlotEnv)
extendEnvsForSafeForeignCalls cafEnv slotEnv g = extendEnvsForSafeForeignCalls cafEnv slotEnv g =
fold_blocks block (cafEnv, slotEnv) g fold_blocks block (cafEnv, slotEnv) g
...@@ -497,7 +517,7 @@ lowerSafeCallBlock state b = tail (return state) (ZBlock head (ZLast last)) ...@@ -497,7 +517,7 @@ lowerSafeCallBlock state b = tail (return state) (ZBlock head (ZLast last))
tail s b@(ZBlock (ZFirst _) _) = tail s b@(ZBlock (ZFirst _) _) =
do state <- s do state <- s
return $ state { s_blocks = insertBlock (G.zip b) (s_blocks state) } 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 do state <- s
let state' = state let state' = state
{ s_safeCalls = FloatingInfoTable emptyContInfoTable bid updfr_off : { s_safeCalls = FloatingInfoTable emptyContInfoTable bid updfr_off :
......
...@@ -116,12 +116,11 @@ cpsTop hsc_env (CmmProc h l args (stackInfo@(entry_off, _), g)) = ...@@ -116,12 +116,11 @@ cpsTop hsc_env (CmmProc h l args (stackInfo@(entry_off, _), g)) =
--------------- Stack layout ---------------- --------------- Stack layout ----------------
slotEnv <- run $ liveSlotAnal g slotEnv <- run $ liveSlotAnal g
mbpprTrace "live slot analysis results: " (ppr slotEnv) $ return () mbpprTrace "live slot analysis results: " (ppr slotEnv) $ return ()
cafEnv <- -- cafEnv <- -- trace "post liveSlotAnal" $ run $ cafAnal g
-- trace "post liveSlotAnal" $ -- (cafEnv, slotEnv) <-
run $ cafAnal g -- -- trace "post print cafAnal" $
(cafEnv, slotEnv) <- -- return $ extendEnvsForSafeForeignCalls cafEnv slotEnv g
-- trace "post print cafAnal" $ slotEnv <- return $ extendEnvWithSafeForeignCalls liveSlotTransfers slotEnv g
return $ extendEnvsForSafeForeignCalls cafEnv slotEnv g
mbpprTrace "slotEnv extended for safe foreign calls: " (ppr slotEnv) $ return () mbpprTrace "slotEnv extended for safe foreign calls: " (ppr slotEnv) $ return ()
let areaMap = layout procPoints slotEnv entry_off g let areaMap = layout procPoints slotEnv entry_off g
mbpprTrace "areaMap" (ppr areaMap) $ return () mbpprTrace "areaMap" (ppr areaMap) $ return ()
...@@ -140,8 +139,11 @@ cpsTop hsc_env (CmmProc h l args (stackInfo@(entry_off, _), g)) = ...@@ -140,8 +139,11 @@ cpsTop hsc_env (CmmProc h l args (stackInfo@(entry_off, _), g)) =
mapM_ (dump Opt_D_dump_cmmz "after splitting") gs mapM_ (dump Opt_D_dump_cmmz "after splitting") gs
------------- More CAFs and foreign calls ------------ ------------- More CAFs and foreign calls ------------
cafEnv <- run $ cafAnal g
cafEnv <- return $ extendEnvWithSafeForeignCalls cafTransfers cafEnv g
let localCAFs = catMaybes $ map (localCAFInfo cafEnv) gs let localCAFs = catMaybes $ map (localCAFInfo cafEnv) gs
mbpprTrace "localCAFs" (ppr localCAFs) $ return () mbpprTrace "localCAFs" (ppr localCAFs) $ return ()
gs <- liftM concat $ run $ foldM lowerSafeForeignCalls [] gs gs <- liftM concat $ run $ foldM lowerSafeForeignCalls [] gs
mapM_ (dump Opt_D_dump_cmmz "after lowerSafeForeignCalls") gs mapM_ (dump Opt_D_dump_cmmz "after lowerSafeForeignCalls") gs
......
...@@ -484,7 +484,8 @@ ppr_safety Unsafe = text "unsafe" ...@@ -484,7 +484,8 @@ ppr_safety Unsafe = text "unsafe"
ppr_call_target :: MidCallTarget -> SDoc ppr_call_target :: MidCallTarget -> SDoc
ppr_call_target (ForeignTarget fn c) = ppr_fc c <+> ppr_target fn ppr_call_target (ForeignTarget fn c) = ppr_fc c <+> ppr_target fn
ppr_call_target (PrimTarget op) = ppr (CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False IsFunction)) ppr_call_target (PrimTarget op) =
ppr (CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False IsFunction))
ppr_target :: CmmExpr -> SDoc ppr_target :: CmmExpr -> SDoc
ppr_target t@(CmmLit _) = ppr t ppr_target t@(CmmLit _) = ppr t
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment