2 -- | Converts C-- with full proceedures and parameters
3 -- to a CPS transformed C-- with the stack made manifest.
10 import CmmBuildInfoTables
11 import CmmCommonBlockElimZ
28 -----------------------------------------------------------------------------
29 -- |Top level driver for the CPS pass
30 -----------------------------------------------------------------------------
31 -- There are two complications here:
32 -- 1. We need to compile the procedures in two stages because we need
33 -- an analysis of the procedures to tell us what CAFs they use.
34 -- The first stage returns a map from procedure labels to CAFs,
35 -- along with a closure that will compute SRTs and attach them to
36 -- the compiled procedures.
37 -- The second stage is to combine the CAF information into a top-level
38 -- CAF environment mapping non-static closures to the CAFs they keep live,
39 -- then pass that environment to the closures returned in the first
40 -- stage of compilation.
41 -- 2. We need to thread the module's SRT around when the SRT tables
42 -- are computed for each procedure.
43 -- The SRT needs to be threaded because it is grown lazily.
44 protoCmmCPSZ :: HscEnv -- Compilation env including
45 -- dynamic flags: -dcmm-lint -ddump-cps-cmm
46 -> (TopSRT, [CmmZ]) -- SRT table and
47 -> CmmZ -- Input C-- with Procedures
48 -> IO (TopSRT, [CmmZ]) -- Output CPS transformed C--
49 protoCmmCPSZ hsc_env (topSRT, rst) (Cmm tops)
50 | not (dopt Opt_RunCPSZ (hsc_dflags hsc_env))
51 = return (topSRT, Cmm tops : rst) -- Only if -frun-cps
53 = do let dflags = hsc_dflags hsc_env
54 showPass dflags "CPSZ"
55 (cafEnvs, toTops) <- liftM unzip $ mapM (cpsTop hsc_env) tops
56 let topCAFEnv = mkTopCAFInfo (concat cafEnvs)
57 (topSRT, tops) <- foldM (\ z f -> f topCAFEnv z) (topSRT, []) toTops
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 -> CmmTopZ ->
70 IO ([(CLabel, CAFSet)],
71 (FiniteMap CLabel CAFSet -> (TopSRT, [[CmmTopZ]]) -> IO (TopSRT, [[CmmTopZ]])))
72 cpsTop _ p@(CmmData {}) =
73 return ([], (\ _ (topSRT, tops) -> return (topSRT, [p] : tops)))
74 cpsTop hsc_env (CmmProc h l args g) =
76 dump Opt_D_dump_cmmz "Pre Proc Points Added" g
77 let callPPs = callProcPoints g
78 g <- dual_rewrite Opt_D_dump_cmmz "spills and reloads"
79 (dualLivenessWithInsertion callPPs) g
80 g <- dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination"
81 (removeDeadAssignmentsAndReloads callPPs) g
82 dump Opt_D_dump_cmmz "Pre common block elimination" g
83 g <- return $ elimCommonBlocks g
84 dump Opt_D_dump_cmmz "Post common block elimination" g
85 procPoints <- run $ minimalProcPointSet callPPs g
86 -- print $ "call procPoints: " ++ (showSDoc $ ppr procPoints)
87 g <- run $ addProcPointProtocols callPPs procPoints g
88 dump Opt_D_dump_cmmz "Post Proc Points Added" g
89 g <- dual_rewrite Opt_D_dump_cmmz "spills and reloads"
90 (dualLivenessWithInsertion procPoints) g
91 -- Insert spills at defns; reloads at return points
92 g <- run $ insertLateReloads g -- Duplicate reloads just before uses
93 dump Opt_D_dump_cmmz "Post late reloads" g
94 g <- dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination"
95 (removeDeadAssignmentsAndReloads procPoints) g
96 -- Remove redundant reloads (and any other redundant asst)
97 -- Debugging: stubbing slots on death can cause crashes early
98 g <- if opt_StubDeadValues then run $ stubSlotsOnDeath g else return g
99 mbpprTrace "graph before procPointMap: " (ppr g) $ return ()
100 procPointMap <- run $ procPointAnalysis procPoints g
101 slotEnv <- run $ liveSlotAnal g
102 mbpprTrace "live slot analysis results: " (ppr slotEnv) $ return ()
103 cafEnv <- run $ cafAnal g
104 (cafEnv, slotEnv) <- return $ extendEnvsForSafeForeignCalls cafEnv slotEnv g
105 mbpprTrace "slotEnv extended for safe foreign calls: " (ppr slotEnv) $ return ()
106 let areaMap = layout procPoints slotEnv g
107 mbpprTrace "areaMap" (ppr areaMap) $ return ()
108 g <- run $ manifestSP procPoints procPointMap areaMap g
109 dump Opt_D_dump_cmmz "after manifestSP" g
110 -- UGH... manifestSP can require updates to the procPointMap.
111 -- We can probably do something quicker here for the update...
112 procPointMap <- run $ procPointAnalysis procPoints g
113 gs <- pprTrace "procPointMap" (ppr procPointMap) $
114 run $ splitAtProcPoints l callPPs procPoints procPointMap areaMap
116 mapM (dump Opt_D_dump_cmmz "after splitting") gs
117 let localCAFs = catMaybes $ map (localCAFInfo cafEnv) gs
118 mbpprTrace "localCAFs" (ppr localCAFs) $ return ()
119 gs <- liftM concat $ run $ foldM (lowerSafeForeignCalls procPoints) [] gs
120 mapM (dump Opt_D_dump_cmmz "after lowerSafeForeignCalls") gs
122 -- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES
123 let gs' = map (setInfoTableStackMap slotEnv areaMap) gs
124 mapM (dump Opt_D_dump_cmmz "after setInfoTableStackMap") gs'
125 -- Return: (a) CAFs used by this proc (b) a closure that will compute
126 -- a new SRT for the procedure.
127 let toTops topCAFEnv (topSRT, tops) =
128 do let setSRT (topSRT, rst) g =
129 do (topSRT, gs) <- setInfoTableSRT cafEnv topCAFEnv topSRT g
130 return (topSRT, gs : rst)
131 (topSRT, gs') <- run $ foldM setSRT (topSRT, []) gs'
132 gs' <- mapM finishInfoTables (concat gs')
133 pprTrace "localCAFs" (ppr localCAFs <+> ppr topSRT) $
134 return (topSRT, concat gs' : tops)
135 return (localCAFs, toTops)
136 where dflags = hsc_dflags hsc_env
137 mbpprTrace x y z = if dopt Opt_D_dump_cmmz dflags then pprTrace x y z else z
138 dump f txt g = dumpIfSet_dyn dflags f txt (ppr g)
139 run = runFuelIO (hsc_OptFuel hsc_env)
140 dual_rewrite flag txt pass g =
141 do dump flag ("Pre " ++ txt) g
143 dump flag ("Post " ++ txt) $ g