X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FCmmCPSZ.hs;h=23e57d72b6c453f890b21949c821f2c4e12bbaeb;hp=5f3775b26f7f7d068614d1f57de52cef937ee6df;hb=edc0bafd3fcd01b85a2e8894e5dfe149eb0e0857;hpb=5dc8b425443200a5160b9d1399aca1808bfcffee diff --git a/compiler/cmm/CmmCPSZ.hs b/compiler/cmm/CmmCPSZ.hs index 5f3775b..23e57d7 100644 --- a/compiler/cmm/CmmCPSZ.hs +++ b/compiler/cmm/CmmCPSZ.hs @@ -1,3 +1,7 @@ +{-# OPTIONS_GHC -XNoMonoLocalBinds #-} +-- Norman likes local bindings +-- If this module lives on I'd like to get rid of this flag in due course + module CmmCPSZ ( -- | Converts C-- with full proceedures and parameters -- to a CPS transformed C-- with the stack made manifest. @@ -18,10 +22,11 @@ import ZipCfgCmmRep import DynFlags import ErrUtils -import FiniteMap import HscTypes -import Maybe -import Monad +import Data.Maybe +import Control.Monad +import Data.Map (Map) +import qualified Data.Map as Map import Outputable import StaticFlags @@ -46,19 +51,16 @@ protoCmmCPSZ :: HscEnv -- Compilation env including -> (TopSRT, [CmmZ]) -- SRT table and accumulating list of compiled procs -> CmmZ -- Input C-- with Procedures -> IO (TopSRT, [CmmZ]) -- Output CPS transformed C-- -protoCmmCPSZ hsc_env (topSRT, rst) (Cmm tops) - | not (dopt Opt_TryNewCodeGen (hsc_dflags hsc_env)) - = return (topSRT, Cmm tops : rst) -- Only if -fnew-codegen - | otherwise - = do let dflags = hsc_dflags hsc_env - showPass dflags "CPSZ" - (cafEnvs, tops) <- liftM unzip $ mapM (cpsTop hsc_env) tops - let topCAFEnv = mkTopCAFInfo (concat cafEnvs) - (topSRT, tops) <- foldM (toTops hsc_env topCAFEnv) (topSRT, []) tops - -- (topSRT, tops) <- foldM (\ z f -> f topCAFEnv z) (topSRT, []) toTops - let cmms = Cmm (reverse (concat tops)) - dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (ppr cmms) - return (topSRT, cmms : rst) +protoCmmCPSZ hsc_env (topSRT, rst) (Cmm tops) = + do let dflags = hsc_dflags hsc_env + showPass dflags "CPSZ" + (cafEnvs, tops) <- liftM unzip $ mapM (cpsTop hsc_env) tops + let topCAFEnv = mkTopCAFInfo (concat cafEnvs) + (topSRT, tops) <- foldM (toTops hsc_env topCAFEnv) (topSRT, []) tops + -- (topSRT, tops) <- foldM (\ z f -> f topCAFEnv z) (topSRT, []) toTops + let cmms = Cmm (reverse (concat tops)) + dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (ppr cmms) + return (topSRT, cmms : rst) {- [Note global fuel] ~~~~~~~~~~~~~~~~~~~~~ @@ -70,7 +72,7 @@ global to one compiler session. cpsTop :: HscEnv -> CmmTopZ -> IO ([(CLabel, CAFSet)], [(CAFSet, CmmTopForInfoTables)]) -cpsTop _ p@(CmmData {}) = return ([], [(emptyFM, NoInfoTable p)]) +cpsTop _ p@(CmmData {}) = return ([], [(Map.empty, NoInfoTable p)]) cpsTop hsc_env (CmmProc h l args (stackInfo@(entry_off, _), g)) = do dump Opt_D_dump_cmmz "Pre Proc Points Added" g @@ -84,9 +86,13 @@ cpsTop hsc_env (CmmProc h l args (stackInfo@(entry_off, _), g)) = dump Opt_D_dump_cmmz "Pre common block elimination" g g <- return $ elimCommonBlocks g dump Opt_D_dump_cmmz "Post common block elimination" g + + ----------- Proc points ------------------- procPoints <- run $ minimalProcPointSet callPPs g g <- run $ addProcPointProtocols callPPs procPoints g dump Opt_D_dump_cmmz "Post Proc Points Added" g + + ----------- Spills and reloads ------------------- g <- -- pprTrace "pre Spills" (ppr g) $ dual_rewrite Opt_D_dump_cmmz "spills and reloads" @@ -101,45 +107,61 @@ cpsTop hsc_env (CmmProc h l args (stackInfo@(entry_off, _), g)) = dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination" (removeDeadAssignmentsAndReloads procPoints) g -- Remove redundant reloads (and any other redundant asst) + + ----------- Debug only: add code to put zero in dead stack slots---- -- Debugging: stubbing slots on death can cause crashes early g <- -- trace "post dead-assign elim" $ if opt_StubDeadValues then run $ stubSlotsOnDeath g else return 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 () + + ------------ Manifest the the stack pointer -------- g <- run $ manifestSP areaMap entry_off g dump Opt_D_dump_cmmz "after manifestSP" g -- UGH... manifestSP can require updates to the procPointMap. -- We can probably do something quicker here for the update... + + ------------- Split into separate procedures ------------ procPointMap <- run $ procPointAnalysis procPoints g dump Opt_D_dump_cmmz "procpoint map" procPointMap gs <- run $ splitAtProcPoints l callPPs procPoints procPointMap (CmmProc h l args (stackInfo, g)) - mapM (dump Opt_D_dump_cmmz "after splitting") gs + 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 + mapM_ (dump Opt_D_dump_cmmz "after lowerSafeForeignCalls") gs -- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES let gs' = map (setInfoTableStackMap slotEnv areaMap) gs - mapM (dump Opt_D_dump_cmmz "after setInfoTableStackMap") gs' + mapM_ (dump Opt_D_dump_cmmz "after setInfoTableStackMap") gs' let gs'' = map (bundleCAFs cafEnv) gs' - mapM (dump Opt_D_dump_cmmz "after bundleCAFs") gs'' + mapM_ (dump Opt_D_dump_cmmz "after bundleCAFs") gs'' return (localCAFs, gs'') where dflags = hsc_dflags hsc_env mbpprTrace x y z = if dopt Opt_D_dump_cmmz dflags then pprTrace x y z else z dump f txt g = dumpIfSet_dyn dflags f txt (ppr g) + + run :: FuelMonad a -> IO a run = runFuelIO (hsc_OptFuel hsc_env) + dual_rewrite flag txt pass g = do dump flag ("Pre " ++ txt) g g <- run $ pass g @@ -149,7 +171,7 @@ cpsTop hsc_env (CmmProc h l args (stackInfo@(entry_off, _), g)) = -- This probably belongs in CmmBuildInfoTables? -- We're just finishing the job here: once we know what CAFs are defined -- in non-static closures, we can build the SRTs. -toTops :: HscEnv -> FiniteMap CLabel CAFSet -> (TopSRT, [[CmmTopZ]]) +toTops :: HscEnv -> Map CLabel CAFSet -> (TopSRT, [[CmmTopZ]]) -> [(CAFSet, CmmTopForInfoTables)] -> IO (TopSRT, [[CmmTopZ]]) toTops hsc_env topCAFEnv (topSRT, tops) gs =