X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FCmmCPSZ.hs;fp=compiler%2Fcmm%2FCmmCPSZ.hs;h=0000000000000000000000000000000000000000;hb=889c084e943779e76d19f2ef5e970ff655f511eb;hp=23e57d72b6c453f890b21949c821f2c4e12bbaeb;hpb=f1a90f54590e5a7a32a9c3ef2950740922b1f425;p=ghc-hetmet.git diff --git a/compiler/cmm/CmmCPSZ.hs b/compiler/cmm/CmmCPSZ.hs deleted file mode 100644 index 23e57d7..0000000 --- a/compiler/cmm/CmmCPSZ.hs +++ /dev/null @@ -1,183 +0,0 @@ -{-# 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. - -- Well, sort of. - protoCmmCPSZ -) where - -import CLabel -import Cmm -import CmmBuildInfoTables -import CmmCommonBlockElimZ -import CmmProcPointZ -import CmmSpillReload -import CmmStackLayout -import DFMonad -import PprCmmZ() -import ZipCfgCmmRep - -import DynFlags -import ErrUtils -import HscTypes -import Data.Maybe -import Control.Monad -import Data.Map (Map) -import qualified Data.Map as Map -import Outputable -import StaticFlags - ------------------------------------------------------------------------------ --- |Top level driver for the CPS pass ------------------------------------------------------------------------------ --- There are two complications here: --- 1. We need to compile the procedures in two stages because we need --- an analysis of the procedures to tell us what CAFs they use. --- The first stage returns a map from procedure labels to CAFs, --- along with a closure that will compute SRTs and attach them to --- the compiled procedures. --- The second stage is to combine the CAF information into a top-level --- CAF environment mapping non-static closures to the CAFs they keep live, --- then pass that environment to the closures returned in the first --- stage of compilation. --- 2. We need to thread the module's SRT around when the SRT tables --- are computed for each procedure. --- The SRT needs to be threaded because it is grown lazily. -protoCmmCPSZ :: HscEnv -- Compilation env including - -- dynamic flags: -dcmm-lint -ddump-cps-cmm - -> (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) = - 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] -~~~~~~~~~~~~~~~~~~~~~ -The identity and the last pass are stored in -mutable reference cells in an 'HscEnv' and are -global to one compiler session. --} - -cpsTop :: HscEnv -> CmmTopZ -> - IO ([(CLabel, CAFSet)], - [(CAFSet, CmmTopForInfoTables)]) -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 - let callPPs = callProcPoints g - -- Why bother doing it this early? - -- g <- dual_rewrite Opt_D_dump_cmmz "spills and reloads" - -- (dualLivenessWithInsertion callPPs) g - -- g <- run $ insertLateReloads g -- Duplicate reloads just before uses - -- g <- dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination" - -- (removeDeadAssignmentsAndReloads callPPs) 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" - (dualLivenessWithInsertion procPoints) g - -- Insert spills at defns; reloads at return points - g <- - -- pprTrace "pre insertLateReloads" (ppr g) $ - run $ insertLateReloads g -- Duplicate reloads just before uses - dump Opt_D_dump_cmmz "Post late reloads" g - g <- - -- pprTrace "post insertLateReloads" (ppr 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 - 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 - - ------------- 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 - - -- 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' - let gs'' = map (bundleCAFs cafEnv) 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 - dump flag ("Post " ++ txt) $ g - return 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 -> Map CLabel CAFSet -> (TopSRT, [[CmmTopZ]]) - -> [(CAFSet, CmmTopForInfoTables)] -> IO (TopSRT, [[CmmTopZ]]) - -toTops hsc_env topCAFEnv (topSRT, tops) gs = - do let setSRT (topSRT, rst) g = - do (topSRT, gs) <- setInfoTableSRT topCAFEnv topSRT g - return (topSRT, gs : rst) - (topSRT, gs') <- runFuelIO (hsc_OptFuel hsc_env) $ foldM setSRT (topSRT, []) gs - gs' <- mapM finishInfoTables (concat gs') - return (topSRT, concat gs' : tops)