+{-# 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.
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
-> (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]
~~~~~~~~~~~~~~~~~~~~~
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
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"
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
-- 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 =
projects / ghc-hetmet.git / blobdiff