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