1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
|
module CmmCPSZ (
-- | Converts C-- with full proceedures and parameters
-- to a CPS transformed C-- with the stack made manifest.
-- Well, sort of.
protoCmmCPSZ
) where
import CLabel
import Cmm
import CmmBuildInfoTables
import CmmCommonBlockElimZ
import CmmProcPointZ
import CmmSpillReload
import CmmStackLayout
import DFMonad
import PprCmmZ()
import ZipCfgCmmRep
import DynFlags
import ErrUtils
import FiniteMap
import HscTypes
import Data.Maybe
import Control.Monad
import Outputable
import StaticFlags
-----------------------------------------------------------------------------
-- |Top level driver for the CPS pass
-----------------------------------------------------------------------------
-- There are two complications here:
-- 1. We need to compile the procedures in two stages because we need
-- an analysis of the procedures to tell us what CAFs they use.
-- The first stage returns a map from procedure labels to CAFs,
-- along with a closure that will compute SRTs and attach them to
-- the compiled procedures.
-- The second stage is to combine the CAF information into a top-level
-- CAF environment mapping non-static closures to the CAFs they keep live,
-- then pass that environment to the closures returned in the first
-- stage of compilation.
-- 2. We need to thread the module's SRT around when the SRT tables
-- are computed for each procedure.
-- The SRT needs to be threaded because it is grown lazily.
protoCmmCPSZ :: HscEnv -- Compilation env including
-- dynamic flags: -dcmm-lint -ddump-cps-cmm
-> (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) =
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]
~~~~~~~~~~~~~~~~~~~~~
The identity and the last pass are stored in
mutable reference cells in an 'HscEnv' and are
global to one compiler session.
-}
cpsTop :: HscEnv -> CmmTopZ ->
IO ([(CLabel, CAFSet)],
[(CAFSet, CmmTopForInfoTables)])
cpsTop _ p@(CmmData {}) = return ([], [(emptyFM, NoInfoTable p)])
cpsTop hsc_env (CmmProc h l args (stackInfo@(entry_off, _), g)) =
do
dump Opt_D_dump_cmmz "Pre Proc Points Added" g
let callPPs = callProcPoints g
-- Why bother doing it this early?
-- g <- dual_rewrite Opt_D_dump_cmmz "spills and reloads"
-- (dualLivenessWithInsertion callPPs) g
-- g <- run $ insertLateReloads g -- Duplicate reloads just before uses
-- g <- dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination"
-- (removeDeadAssignmentsAndReloads callPPs) 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"
(dualLivenessWithInsertion procPoints) g
-- Insert spills at defns; reloads at return points
g <-
-- pprTrace "pre insertLateReloads" (ppr g) $
run $ insertLateReloads g -- Duplicate reloads just before uses
dump Opt_D_dump_cmmz "Post late reloads" g
g <-
-- pprTrace "post insertLateReloads" (ppr g) $
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
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
------------- 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
-- 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'
let gs'' = map (bundleCAFs cafEnv) 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 = runFuelIO (hsc_OptFuel hsc_env)
dual_rewrite flag txt pass g =
do dump flag ("Pre " ++ txt) g
g <- run $ pass g
dump flag ("Post " ++ txt) $ g
return 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]])
-> [(CAFSet, CmmTopForInfoTables)] -> IO (TopSRT, [[CmmTopZ]])
toTops hsc_env topCAFEnv (topSRT, tops) gs =
do let setSRT (topSRT, rst) g =
do (topSRT, gs) <- setInfoTableSRT topCAFEnv topSRT g
return (topSRT, gs : rst)
(topSRT, gs') <- runFuelIO (hsc_OptFuel hsc_env) $ foldM setSRT (topSRT, []) gs
gs' <- mapM finishInfoTables (concat gs')
return (topSRT, concat gs' : tops)
|
