1 {-# OPTIONS_GHC -XNoMonoLocalBinds #-}
2 -- Norman likes local bindings
3 -- If this module lives on I'd like to get rid of this flag in due course
5 -- | Converts C-- with full proceedures and parameters
6 -- to a CPS transformed C-- with the stack made manifest.
14 import CmmBuildInfoTables
15 import CmmCommonBlockElim
19 import OptimizationFuel
27 import qualified Data.Map as Map
31 -----------------------------------------------------------------------------
32 -- |Top level driver for the CPS pass
33 -----------------------------------------------------------------------------
34 -- There are two complications here:
35 -- 1. We need to compile the procedures in two stages because we need
36 -- an analysis of the procedures to tell us what CAFs they use.
37 -- The first stage returns a map from procedure labels to CAFs,
38 -- along with a closure that will compute SRTs and attach them to
39 -- the compiled procedures.
40 -- The second stage is to combine the CAF information into a top-level
41 -- CAF environment mapping non-static closures to the CAFs they keep live,
42 -- then pass that environment to the closures returned in the first
43 -- stage of compilation.
44 -- 2. We need to thread the module's SRT around when the SRT tables
45 -- are computed for each procedure.
46 -- The SRT needs to be threaded because it is grown lazily.
47 protoCmmCPS :: HscEnv -- Compilation env including
48 -- dynamic flags: -dcmm-lint -ddump-cps-cmm
49 -> (TopSRT, [Cmm]) -- SRT table and accumulating list of compiled procs
50 -> Cmm -- Input C-- with Procedures
51 -> IO (TopSRT, [Cmm]) -- Output CPS transformed C--
52 protoCmmCPS hsc_env (topSRT, rst) (Cmm tops) =
53 do let dflags = hsc_dflags hsc_env
54 showPass dflags "CPSZ"
55 (cafEnvs, tops) <- liftM unzip $ mapM (cpsTop hsc_env) tops
56 let topCAFEnv = mkTopCAFInfo (concat cafEnvs)
57 (topSRT, tops) <- foldM (toTops hsc_env topCAFEnv) (topSRT, []) tops
58 let cmms = Cmm (reverse (concat tops))
59 dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (ppr cmms)
60 return (topSRT, cmms : rst)
64 The identity and the last pass are stored in
65 mutable reference cells in an 'HscEnv' and are
66 global to one compiler session.
69 cpsTop :: HscEnv -> CmmTop -> IO ([(CLabel, CAFSet)], [(CAFSet, CmmTop)])
70 cpsTop _ p@(CmmData {}) = return ([], [(Map.empty, p)])
71 cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) l g) =
73 -- Why bother doing it this early?
74 -- g <- dual_rewrite run Opt_D_dump_cmmz "spills and reloads"
75 -- (dualLivenessWithInsertion callPPs) g
76 -- g <- run $ insertLateReloads g -- Duplicate reloads just before uses
77 -- g <- dual_rewrite runOptimization Opt_D_dump_cmmz "Dead Assignment Elimination"
78 -- (removeDeadAssignmentsAndReloads callPPs) g
79 dump Opt_D_dump_cmmz "Pre common block elimination" g
80 g <- return $ elimCommonBlocks g
81 dump Opt_D_dump_cmmz "Post common block elimination" g
83 -- Any work storing block Labels must be performed _after_ elimCommonBlocks
85 ----------- Proc points -------------------
86 let callPPs = callProcPoints g
87 procPoints <- run $ minimalProcPointSet callPPs g
88 g <- run $ addProcPointProtocols callPPs procPoints g
89 dump Opt_D_dump_cmmz "Post Proc Points Added" g
91 ----------- Spills and reloads -------------------
93 -- pprTrace "pre Spills" (ppr g) $
94 dual_rewrite run Opt_D_dump_cmmz "spills and reloads"
95 (dualLivenessWithInsertion procPoints) g
96 -- Insert spills at defns; reloads at return points
98 runOptimization $ rewriteAssignments g
99 dump Opt_D_dump_cmmz "Post rewrite assignments" g
101 -- pprTrace "post insertLateReloads" (ppr g) $
102 dual_rewrite runOptimization Opt_D_dump_cmmz "Dead Assignment Elimination"
103 (removeDeadAssignmentsAndReloads procPoints) g
104 -- Remove redundant reloads (and any other redundant asst)
106 ----------- Debug only: add code to put zero in dead stack slots----
107 -- Debugging: stubbing slots on death can cause crashes early
108 g <- -- trace "post dead-assign elim" $
109 if opt_StubDeadValues then run $ stubSlotsOnDeath g else return g
112 --------------- Stack layout ----------------
113 slotEnv <- run $ liveSlotAnal g
114 mbpprTrace "live slot analysis results: " (ppr slotEnv) $ return ()
115 let areaMap = layout procPoints slotEnv entry_off g
116 mbpprTrace "areaMap" (ppr areaMap) $ return ()
118 ------------ Manifest the stack pointer --------
119 g <- run $ manifestSP areaMap entry_off g
120 dump Opt_D_dump_cmmz "after manifestSP" g
121 -- UGH... manifestSP can require updates to the procPointMap.
122 -- We can probably do something quicker here for the update...
124 ------------- Split into separate procedures ------------
125 procPointMap <- run $ procPointAnalysis procPoints g
126 dump Opt_D_dump_cmmz "procpoint map" procPointMap
127 gs <- run $ splitAtProcPoints l callPPs procPoints procPointMap
129 mapM_ (dump Opt_D_dump_cmmz "after splitting") gs
131 ------------- More CAFs and foreign calls ------------
132 cafEnv <- run $ cafAnal g
133 let localCAFs = catMaybes $ map (localCAFInfo cafEnv) gs
134 mbpprTrace "localCAFs" (ppr localCAFs) $ return ()
136 gs <- run $ mapM (lowerSafeForeignCalls areaMap) gs
137 mapM_ (dump Opt_D_dump_cmmz "after lowerSafeForeignCalls") gs
139 -- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES
140 let gs' = map (setInfoTableStackMap slotEnv areaMap) gs
141 mapM_ (dump Opt_D_dump_cmmz "after setInfoTableStackMap") gs'
142 let gs'' = map (bundleCAFs cafEnv) gs'
143 mapM_ (dump Opt_D_dump_cmmz "after bundleCAFs") gs''
144 return (localCAFs, gs'')
145 where dflags = hsc_dflags hsc_env
146 mbpprTrace x y z = if dopt Opt_D_dump_cmmz dflags then pprTrace x y z else z
147 dump f txt g = dumpIfSet_dyn dflags f txt (ppr g)
148 -- Runs a required transformation/analysis
149 run = runInfiniteFuelIO (hsc_OptFuel hsc_env)
150 -- Runs an optional transformation/analysis (and should
151 -- thus be subject to optimization fuel)
152 runOptimization = runFuelIO (hsc_OptFuel hsc_env)
154 -- pass 'run' or 'runOptimization' for 'r'
155 dual_rewrite r flag txt pass g =
156 do dump flag ("Pre " ++ txt) g
158 dump flag ("Post " ++ txt) $ g
161 -- This probably belongs in CmmBuildInfoTables?
162 -- We're just finishing the job here: once we know what CAFs are defined
163 -- in non-static closures, we can build the SRTs.
164 toTops :: HscEnv -> Map CLabel CAFSet -> (TopSRT, [[CmmTop]])
165 -> [(CAFSet, CmmTop)] -> IO (TopSRT, [[CmmTop]])
166 toTops hsc_env topCAFEnv (topSRT, tops) gs =
167 do let setSRT (topSRT, rst) g =
168 do (topSRT, gs) <- setInfoTableSRT topCAFEnv topSRT g
169 return (topSRT, gs : rst)
170 (topSRT, gs') <- runFuelIO (hsc_OptFuel hsc_env) $ foldM setSRT (topSRT, []) gs
171 return (topSRT, concat gs' : tops)