From df5b491ce79b42987363ae96bc98b633cf55cca2 Mon Sep 17 00:00:00 2001 From: "dias@cs.tufts.edu" Date: Fri, 18 Sep 2009 19:14:17 +0000 Subject: [PATCH] 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. --- compiler/cmm/CmmBuildInfoTables.hs | 28 ++++++++++++++++++++++++---- compiler/cmm/CmmCPSZ.hs | 14 ++++++++------ compiler/cmm/ZipCfgCmmRep.hs | 3 ++- 3 files changed, 34 insertions(+), 11 deletions(-) diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs index 5b6625a..c2be8c9 100644 --- a/compiler/cmm/CmmBuildInfoTables.hs +++ b/compiler/cmm/CmmBuildInfoTables.hs @@ -3,7 +3,9 @@ module CmmBuildInfoTables , setInfoTableSRT, setInfoTableStackMap , TopSRT, emptySRT, srtToData , bundleCAFs - , finishInfoTables, lowerSafeForeignCalls, extendEnvsForSafeForeignCalls ) + , finishInfoTables, lowerSafeForeignCalls + , cafTransfers, liveSlotTransfers + , extendEnvWithSafeForeignCalls, extendEnvsForSafeForeignCalls ) where #include "HsVersions.h" @@ -230,6 +232,8 @@ buildSRTs topSRT topCAFMap cafs = 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 = @@ -303,7 +307,7 @@ to_SRT top_srt off len bmp -- 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 @@ -347,7 +351,7 @@ type StackLayout = [Maybe LocalReg] 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 _) = @@ -409,6 +413,22 @@ finishInfoTables (FloatingInfoTable (CmmInfo _ _ infotbl) 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 @@ -497,7 +517,7 @@ lowerSafeCallBlock state b = tail (return state) (ZBlock head (ZLast last)) 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 : diff --git a/compiler/cmm/CmmCPSZ.hs b/compiler/cmm/CmmCPSZ.hs index 04f360c..f2e245f 100644 --- a/compiler/cmm/CmmCPSZ.hs +++ b/compiler/cmm/CmmCPSZ.hs @@ -116,12 +116,11 @@ cpsTop hsc_env (CmmProc h l args (stackInfo@(entry_off, _), g)) = --------------- 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 () @@ -140,8 +139,11 @@ cpsTop hsc_env (CmmProc h l args (stackInfo@(entry_off, _), g)) = 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 diff --git a/compiler/cmm/ZipCfgCmmRep.hs b/compiler/cmm/ZipCfgCmmRep.hs index a061be8..9aae097 100644 --- a/compiler/cmm/ZipCfgCmmRep.hs +++ b/compiler/cmm/ZipCfgCmmRep.hs @@ -484,7 +484,8 @@ ppr_safety Unsafe = text "unsafe" ppr_call_target :: MidCallTarget -> SDoc 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 t@(CmmLit _) = ppr t -- 1.7.10.4