1 #if __GLASGOW_HASKELL__ >= 611
2 {-# OPTIONS_GHC -XNoMonoLocalBinds #-}
4 -- Norman likes local bindings
5 -- If this module lives on I'd like to get rid of this flag in due course
8 -- | Converts C-- with full proceedures and parameters
9 -- to a CPS transformed C-- with the stack made manifest.
16 import CmmBuildInfoTables
17 import CmmCommonBlockElimZ
31 import qualified Data.Map as Map
35 -----------------------------------------------------------------------------
36 -- |Top level driver for the CPS pass
37 -----------------------------------------------------------------------------
38 -- There are two complications here:
39 -- 1. We need to compile the procedures in two stages because we need
40 -- an analysis of the procedures to tell us what CAFs they use.
41 -- The first stage returns a map from procedure labels to CAFs,
42 -- along with a closure that will compute SRTs and attach them to
43 -- the compiled procedures.
44 -- The second stage is to combine the CAF information into a top-level
45 -- CAF environment mapping non-static closures to the CAFs they keep live,
46 -- then pass that environment to the closures returned in the first
47 -- stage of compilation.
48 -- 2. We need to thread the module's SRT around when the SRT tables
49 -- are computed for each procedure.
50 -- The SRT needs to be threaded because it is grown lazily.
51 protoCmmCPSZ :: HscEnv -- Compilation env including
52 -- dynamic flags: -dcmm-lint -ddump-cps-cmm
53 -> (TopSRT, [CmmZ]) -- SRT table and accumulating list of compiled procs
54 -> CmmZ -- Input C-- with Procedures
55 -> IO (TopSRT, [CmmZ]) -- Output CPS transformed C--
56 protoCmmCPSZ hsc_env (topSRT, rst) (Cmm tops) =
57 do let dflags = hsc_dflags hsc_env
58 showPass dflags "CPSZ"
59 (cafEnvs, tops) <- liftM unzip $ mapM (cpsTop hsc_env) tops
60 let topCAFEnv = mkTopCAFInfo (concat cafEnvs)
61 (topSRT, tops) <- foldM (toTops hsc_env topCAFEnv) (topSRT, []) tops
62 -- (topSRT, tops) <- foldM (\ z f -> f topCAFEnv z) (topSRT, []) toTops
63 let cmms = Cmm (reverse (concat tops))
64 dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (ppr cmms)
65 return (topSRT, cmms : rst)
69 The identity and the last pass are stored in
70 mutable reference cells in an 'HscEnv' and are
71 global to one compiler session.
74 cpsTop :: HscEnv -> CmmTopZ ->
75 IO ([(CLabel, CAFSet)],
76 [(CAFSet, CmmTopForInfoTables)])
77 cpsTop _ p@(CmmData {}) = return ([], [(Map.empty, NoInfoTable p)])
78 cpsTop hsc_env (CmmProc h l args (stackInfo@(entry_off, _), g)) =
80 dump Opt_D_dump_cmmz "Pre Proc Points Added" g
81 let callPPs = callProcPoints g
82 -- Why bother doing it this early?
83 -- g <- dual_rewrite Opt_D_dump_cmmz "spills and reloads"
84 -- (dualLivenessWithInsertion callPPs) g
85 -- g <- run $ insertLateReloads g -- Duplicate reloads just before uses
86 -- g <- dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination"
87 -- (removeDeadAssignmentsAndReloads callPPs) g
88 dump Opt_D_dump_cmmz "Pre common block elimination" g
89 g <- return $ elimCommonBlocks g
90 dump Opt_D_dump_cmmz "Post common block elimination" g
92 ----------- Proc points -------------------
93 procPoints <- run $ minimalProcPointSet callPPs g
94 g <- run $ addProcPointProtocols callPPs procPoints g
95 dump Opt_D_dump_cmmz "Post Proc Points Added" g
97 ----------- Spills and reloads -------------------
99 -- pprTrace "pre Spills" (ppr g) $
100 dual_rewrite Opt_D_dump_cmmz "spills and reloads"
101 (dualLivenessWithInsertion procPoints) g
102 -- Insert spills at defns; reloads at return points
104 -- pprTrace "pre insertLateReloads" (ppr g) $
105 run $ insertLateReloads g -- Duplicate reloads just before uses
106 dump Opt_D_dump_cmmz "Post late reloads" g
108 -- pprTrace "post insertLateReloads" (ppr g) $
109 dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination"
110 (removeDeadAssignmentsAndReloads procPoints) g
111 -- Remove redundant reloads (and any other redundant asst)
113 ----------- Debug only: add code to put zero in dead stack slots----
114 -- Debugging: stubbing slots on death can cause crashes early
116 -- trace "post dead-assign elim" $
117 if opt_StubDeadValues then run $ stubSlotsOnDeath g else return g
120 --------------- Stack layout ----------------
121 slotEnv <- run $ liveSlotAnal g
122 mbpprTrace "live slot analysis results: " (ppr slotEnv) $ return ()
123 -- cafEnv <- -- trace "post liveSlotAnal" $ run $ cafAnal g
124 -- (cafEnv, slotEnv) <-
125 -- -- trace "post print cafAnal" $
126 -- return $ extendEnvsForSafeForeignCalls cafEnv slotEnv g
127 slotEnv <- return $ extendEnvWithSafeForeignCalls liveSlotTransfers slotEnv g
128 mbpprTrace "slotEnv extended for safe foreign calls: " (ppr slotEnv) $ return ()
129 let areaMap = layout procPoints slotEnv entry_off g
130 mbpprTrace "areaMap" (ppr areaMap) $ return ()
132 ------------ Manifest the the stack pointer --------
133 g <- run $ manifestSP areaMap entry_off g
134 dump Opt_D_dump_cmmz "after manifestSP" g
135 -- UGH... manifestSP can require updates to the procPointMap.
136 -- We can probably do something quicker here for the update...
138 ------------- Split into separate procedures ------------
139 procPointMap <- run $ procPointAnalysis procPoints g
140 dump Opt_D_dump_cmmz "procpoint map" procPointMap
141 gs <- run $ splitAtProcPoints l callPPs procPoints procPointMap
142 (CmmProc h l args (stackInfo, g))
143 mapM_ (dump Opt_D_dump_cmmz "after splitting") gs
145 ------------- More CAFs and foreign calls ------------
146 cafEnv <- run $ cafAnal g
147 cafEnv <- return $ extendEnvWithSafeForeignCalls cafTransfers cafEnv g
148 let localCAFs = catMaybes $ map (localCAFInfo cafEnv) gs
149 mbpprTrace "localCAFs" (ppr localCAFs) $ return ()
151 gs <- liftM concat $ run $ foldM lowerSafeForeignCalls [] gs
152 mapM_ (dump Opt_D_dump_cmmz "after lowerSafeForeignCalls") gs
154 -- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES
155 let gs' = map (setInfoTableStackMap slotEnv areaMap) gs
156 mapM_ (dump Opt_D_dump_cmmz "after setInfoTableStackMap") gs'
157 let gs'' = map (bundleCAFs cafEnv) gs'
158 mapM_ (dump Opt_D_dump_cmmz "after bundleCAFs") gs''
159 return (localCAFs, gs'')
160 where dflags = hsc_dflags hsc_env
161 mbpprTrace x y z = if dopt Opt_D_dump_cmmz dflags then pprTrace x y z else z
162 dump f txt g = dumpIfSet_dyn dflags f txt (ppr g)
164 run :: FuelMonad a -> IO a
165 run = runFuelIO (hsc_OptFuel hsc_env)
167 dual_rewrite flag txt pass g =
168 do dump flag ("Pre " ++ txt) g
170 dump flag ("Post " ++ txt) $ g
173 -- This probably belongs in CmmBuildInfoTables?
174 -- We're just finishing the job here: once we know what CAFs are defined
175 -- in non-static closures, we can build the SRTs.
176 toTops :: HscEnv -> Map CLabel CAFSet -> (TopSRT, [[CmmTopZ]])
177 -> [(CAFSet, CmmTopForInfoTables)] -> IO (TopSRT, [[CmmTopZ]])
179 toTops hsc_env topCAFEnv (topSRT, tops) gs =
180 do let setSRT (topSRT, rst) g =
181 do (topSRT, gs) <- setInfoTableSRT topCAFEnv topSRT g
182 return (topSRT, gs : rst)
183 (topSRT, gs') <- runFuelIO (hsc_OptFuel hsc_env) $ foldM setSRT (topSRT, []) gs
184 gs' <- mapM finishInfoTables (concat gs')
185 return (topSRT, concat gs' : tops)