Remove GHC's haskell98 dependency
[ghc.git] / compiler / cmm / CmmCPSZ.hs
1 module CmmCPSZ (
2 -- | Converts C-- with full proceedures and parameters
3 -- to a CPS transformed C-- with the stack made manifest.
4 -- Well, sort of.
5 protoCmmCPSZ
6 ) where
7
8 import CLabel
9 import Cmm
10 import CmmBuildInfoTables
11 import CmmCommonBlockElimZ
12 import CmmProcPointZ
13 import CmmSpillReload
14 import CmmStackLayout
15 import DFMonad
16 import PprCmmZ()
17 import ZipCfgCmmRep
18
19 import DynFlags
20 import ErrUtils
21 import FiniteMap
22 import HscTypes
23 import Data.Maybe
24 import Control.Monad
25 import Outputable
26 import StaticFlags
27
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 accumulating list of compiled procs
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_TryNewCodeGen (hsc_dflags hsc_env))
51 = return (topSRT, Cmm tops : rst) -- Only if -fnew-codegen
52 | otherwise
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 -- (topSRT, tops) <- foldM (\ z f -> f topCAFEnv z) (topSRT, []) toTops
59 let cmms = Cmm (reverse (concat tops))
60 dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (ppr cmms)
61 return (topSRT, cmms : rst)
62
63 {- [Note global fuel]
64 ~~~~~~~~~~~~~~~~~~~~~
65 The identity and the last pass are stored in
66 mutable reference cells in an 'HscEnv' and are
67 global to one compiler session.
68 -}
69
70 cpsTop :: HscEnv -> CmmTopZ ->
71 IO ([(CLabel, CAFSet)],
72 [(CAFSet, CmmTopForInfoTables)])
73 cpsTop _ p@(CmmData {}) = return ([], [(emptyFM, NoInfoTable p)])
74 cpsTop hsc_env (CmmProc h l args (stackInfo@(entry_off, _), g)) =
75 do
76 dump Opt_D_dump_cmmz "Pre Proc Points Added" g
77 let callPPs = callProcPoints g
78 -- Why bother doing it this early?
79 -- g <- dual_rewrite Opt_D_dump_cmmz "spills and reloads"
80 -- (dualLivenessWithInsertion callPPs) g
81 -- g <- run $ insertLateReloads g -- Duplicate reloads just before uses
82 -- g <- dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination"
83 -- (removeDeadAssignmentsAndReloads callPPs) g
84 dump Opt_D_dump_cmmz "Pre common block elimination" g
85 g <- return $ elimCommonBlocks g
86 dump Opt_D_dump_cmmz "Post common block elimination" 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
90 g <-
91 -- pprTrace "pre Spills" (ppr g) $
92 dual_rewrite Opt_D_dump_cmmz "spills and reloads"
93 (dualLivenessWithInsertion procPoints) g
94 -- Insert spills at defns; reloads at return points
95 g <-
96 -- pprTrace "pre insertLateReloads" (ppr g) $
97 run $ insertLateReloads g -- Duplicate reloads just before uses
98 dump Opt_D_dump_cmmz "Post late reloads" g
99 g <-
100 -- pprTrace "post insertLateReloads" (ppr g) $
101 dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination"
102 (removeDeadAssignmentsAndReloads procPoints) g
103 -- Remove redundant reloads (and any other redundant asst)
104 -- Debugging: stubbing slots on death can cause crashes early
105 g <-
106 -- trace "post dead-assign elim" $
107 if opt_StubDeadValues then run $ stubSlotsOnDeath g else return g
108 slotEnv <- run $ liveSlotAnal g
109 mbpprTrace "live slot analysis results: " (ppr slotEnv) $ return ()
110 cafEnv <-
111 -- trace "post liveSlotAnal" $
112 run $ cafAnal g
113 (cafEnv, slotEnv) <-
114 -- trace "post print cafAnal" $
115 return $ extendEnvsForSafeForeignCalls cafEnv slotEnv g
116 mbpprTrace "slotEnv extended for safe foreign calls: " (ppr slotEnv) $ return ()
117 let areaMap = layout procPoints slotEnv entry_off g
118 mbpprTrace "areaMap" (ppr areaMap) $ return ()
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...
123 procPointMap <- run $ procPointAnalysis procPoints g
124 dump Opt_D_dump_cmmz "procpoint map" procPointMap
125 gs <- run $ splitAtProcPoints l callPPs procPoints procPointMap
126 (CmmProc h l args (stackInfo, g))
127 mapM_ (dump Opt_D_dump_cmmz "after splitting") gs
128 let localCAFs = catMaybes $ map (localCAFInfo cafEnv) gs
129 mbpprTrace "localCAFs" (ppr localCAFs) $ return ()
130 gs <- liftM concat $ run $ foldM lowerSafeForeignCalls [] gs
131 mapM_ (dump Opt_D_dump_cmmz "after lowerSafeForeignCalls") gs
132
133 -- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES
134 let gs' = map (setInfoTableStackMap slotEnv areaMap) gs
135 mapM_ (dump Opt_D_dump_cmmz "after setInfoTableStackMap") gs'
136 let gs'' = map (bundleCAFs cafEnv) gs'
137 mapM_ (dump Opt_D_dump_cmmz "after bundleCAFs") gs''
138 return (localCAFs, gs'')
139 where dflags = hsc_dflags hsc_env
140 mbpprTrace x y z = if dopt Opt_D_dump_cmmz dflags then pprTrace x y z else z
141 dump f txt g = dumpIfSet_dyn dflags f txt (ppr g)
142 run = runFuelIO (hsc_OptFuel hsc_env)
143 dual_rewrite flag txt pass g =
144 do dump flag ("Pre " ++ txt) g
145 g <- run $ pass g
146 dump flag ("Post " ++ txt) $ g
147 return g
148
149 -- This probably belongs in CmmBuildInfoTables?
150 -- We're just finishing the job here: once we know what CAFs are defined
151 -- in non-static closures, we can build the SRTs.
152 toTops :: HscEnv -> FiniteMap CLabel CAFSet -> (TopSRT, [[CmmTopZ]])
153 -> [(CAFSet, CmmTopForInfoTables)] -> IO (TopSRT, [[CmmTopZ]])
154
155 toTops hsc_env topCAFEnv (topSRT, tops) gs =
156 do let setSRT (topSRT, rst) g =
157 do (topSRT, gs) <- setInfoTableSRT topCAFEnv topSRT g
158 return (topSRT, gs : rst)
159 (topSRT, gs') <- runFuelIO (hsc_OptFuel hsc_env) $ foldM setSRT (topSRT, []) gs
160 gs' <- mapM finishInfoTables (concat gs')
161 return (topSRT, concat gs' : tops)