CmmPipeline.hs 8.29 KB
Newer Older
1
{-# LANGUAGE NoMonoLocalBinds #-}
2
-- Norman likes local bindings
3
-- If this module lives on I'd like to get rid of this extension in due course
4

Edward Z. Yang's avatar
Edward Z. Yang committed
5
module CmmPipeline (
6 7 8 9
  -- | Converts C-- with an implicit stack and native C-- calls into
  -- optimized, CPS converted and native-call-less C--.  The latter
  -- C-- can be used to generate assembly.
  cmmPipeline
10
) where
11

12
import CLabel
13
import Cmm
Simon Marlow's avatar
Simon Marlow committed
14
import CmmLint
15
import CmmLive
16 17
import CmmBuildInfoTables
import CmmCommonBlockElim
18
import CmmProcPoint
19
import CmmRewriteAssignments
20
import CmmContFlowOpt
21
import OptimizationFuel
Simon Marlow's avatar
Simon Marlow committed
22
import CmmLayoutStack
23 24
import Hoopl
import CmmUtils
25 26 27

import DynFlags
import ErrUtils
28 29
import HscTypes
import Data.Maybe
Ian Lynagh's avatar
Ian Lynagh committed
30
import Control.Monad
31 32
import Data.Map (Map)
import qualified Data.Map as Map
33 34
import Data.Set (Set)
import qualified Data.Set as Set
35 36
import Outputable
import StaticFlags
37

38
-----------------------------------------------------------------------------
39
-- | Top level driver for C-- pipeline
40
-----------------------------------------------------------------------------
41 42 43 44 45 46 47 48 49 50 51 52 53
-- 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.
54 55 56 57 58
-- 3. We run control flow optimizations twice, once before any pipeline
--    work is done, and once again at the very end on all of the
--    resulting C-- blocks.  EZY: It's unclear whether or not whether
--    we actually need to do the initial pass.
cmmPipeline  :: HscEnv -- Compilation env including
59
                       -- dynamic flags: -dcmm-lint -ddump-cps-cmm
60
             -> TopSRT     -- SRT table and accumulating list of compiled procs
Simon Peyton Jones's avatar
Simon Peyton Jones committed
61
             -> CmmGroup             -- Input C-- with Procedures
62 63
             -> IO (TopSRT, CmmGroup) -- Output CPS transformed C--
cmmPipeline hsc_env topSRT prog =
64
  do let dflags = hsc_dflags hsc_env
65
     --
66
     showPass dflags "CPSZ"
67

68
     (cafEnvs, tops) <- {-# SCC "tops" #-} liftM unzip $ mapM (cpsTop hsc_env) prog
Simon Peyton Jones's avatar
Simon Peyton Jones committed
69
     -- tops :: [[(CmmDecl,CAFSet]]  (one list per group)
70

71
     let topCAFEnv = {-# SCC "topCAFEnv" #-} mkTopCAFInfo (concat cafEnvs)
72 73

     -- folding over the groups
74
     (topSRT, tops) <- {-# SCC "toTops" #-} foldM (toTops hsc_env topCAFEnv) (topSRT, []) tops
75

76 77
     let cmms :: CmmGroup
         cmms = reverse (concat tops)
78

Ian Lynagh's avatar
Ian Lynagh committed
79
     dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (ppr cmms)
80

81
     return (topSRT, cmms)
82 83 84 85 86 87 88 89

{- [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.
-}

90 91 92 93
-- EZY: It might be helpful to have an easy way of dumping the "pre"
-- input for any given phase, besides just turning it all on with
-- -ddump-cmmz

Simon Peyton Jones's avatar
Simon Peyton Jones committed
94
cpsTop :: HscEnv -> CmmDecl -> IO ([(CLabel, CAFSet)], [(CAFSet, CmmDecl)])
95
cpsTop _ p@(CmmData {}) = return ([], [(Set.empty, p)])
96 97
cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) l g) =
    do
98
       ----------- Control-flow optimisations ---------------
Simon Marlow's avatar
Simon Marlow committed
99
       g <- {-# SCC "cmmCfgOpts(1)" #-} return $ cmmCfgOpts g
100 101
       dump Opt_D_dump_cmmz_cfg "Post control-flow optimsations" g

102
       ----------- Eliminate common blocks -------------------
Simon Marlow's avatar
Simon Marlow committed
103
       g <- {-# SCC "elimCommonBlocks" #-} return $ elimCommonBlocks g
104 105 106
       dump Opt_D_dump_cmmz_cbe "Post common block elimination" g
       -- Any work storing block Labels must be performed _after_
       -- elimCommonBlocks
107 108

       ----------- Proc points -------------------
Simon Marlow's avatar
Simon Marlow committed
109
       let callPPs = {-# SCC "callProcPoints" #-} callProcPoints g
110 111
       procPoints <- {-# SCC "minimalProcPointSet" #-} run $
                     minimalProcPointSet (targetPlatform dflags) callPPs g
112

113 114
       ----------- Layout the stack and manifest Sp ---------------
       -- (also does: removeDeadAssignments, and lowerSafeForeignCalls)
115 116
       (g, stackmaps) <- {-# SCC "layoutStack" #-}
                         run $ cmmLayoutStack procPoints entry_off g
Simon Marlow's avatar
Simon Marlow committed
117 118
       dump Opt_D_dump_cmmz_sp "Layout Stack" g

119 120 121
       g <- {-# SCC "sink" #-} run $ cmmSink g
       dump Opt_D_dump_cmmz_rewrite "Sink assignments" g

Simon Marlow's avatar
Simon Marlow committed
122
--       ----------- Sink and inline assignments -------------------
123 124
--       g <- {-# SCC "rewriteAssignments" #-} runOptimization $
--            rewriteAssignments platform g
Simon Marlow's avatar
Simon Marlow committed
125
--       dump Opt_D_dump_cmmz_rewrite "Post rewrite assignments" g
126 127

       ------------- Split into separate procedures ------------
128 129
       procPointMap  <- {-# SCC "procPointAnalysis" #-} run $
                        procPointAnalysis procPoints g
130
       dumpWith dflags Opt_D_dump_cmmz_procmap "procpoint map" procPointMap
131 132
       gs <- {-# SCC "splitAtProcPoints" #-} run $
             splitAtProcPoints l callPPs procPoints procPointMap (CmmProc h l g)
Simon Marlow's avatar
Simon Marlow committed
133
       dumps Opt_D_dump_cmmz_split "Post splitting" gs
134

135
       ------------- More CAFs ------------------------------
136
       let cafEnv = {-# SCC "cafAnal" #-} cafAnal platform g
137
       let localCAFs = {-# SCC "localCAFs" #-} catMaybes $ map (localCAFInfo platform cafEnv) gs
Ian Lynagh's avatar
Ian Lynagh committed
138
       mbpprTrace "localCAFs" (ppr localCAFs) $ return ()
139

140
       -- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES
141 142 143
       gs <- {-# SCC "setInfoTableStackMap" #-}
             return $ map (setInfoTableStackMap stackmaps) gs
       dumps Opt_D_dump_cmmz_info "after setInfoTableStackMap" gs
144

145
       ----------- Control-flow optimisations ---------------
Simon Marlow's avatar
Simon Marlow committed
146 147
       gs <- {-# SCC "cmmCfgOpts(2)" #-} return $ map cmmCfgOptsProc gs
       dumps Opt_D_dump_cmmz_cfg "Post control-flow optimsations" gs
148

Simon Marlow's avatar
Simon Marlow committed
149 150
       gs <- {-# SCC "bundleCAFs" #-} return $ map (bundleCAFs cafEnv) gs
       dumps Opt_D_dump_cmmz_cafs "after bundleCAFs" gs
151

152
       return (localCAFs, gs)
153

Simon Peyton Jones's avatar
Simon Peyton Jones committed
154
              -- gs        :: [ (CAFSet, CmmDecl) ]
155 156
              -- localCAFs :: [ (CLabel, CAFSet) ] -- statics filtered out(?)

157
  where dflags = hsc_dflags hsc_env
Simon Marlow's avatar
Simon Marlow committed
158 159 160
        platform = targetPlatform dflags
        mbpprTrace x y z | dopt Opt_D_dump_cmmz dflags = pprTrace x y z
                         | otherwise = z
161 162
        dump = dumpGraph dflags

Simon Marlow's avatar
Simon Marlow committed
163
        dumps flag name
164
           = mapM_ (dumpWith dflags flag name)
Simon Marlow's avatar
Simon Marlow committed
165

166 167 168 169 170 171
        -- Runs a required transformation/analysis
        run = runInfiniteFuelIO (hsc_OptFuel hsc_env)
        -- Runs an optional transformation/analysis (and should
        -- thus be subject to optimization fuel)
        runOptimization = runFuelIO (hsc_OptFuel hsc_env)

172

Simon Marlow's avatar
Simon Marlow committed
173 174
dumpGraph :: DynFlags -> DynFlag -> String -> CmmGraph -> IO ()
dumpGraph dflags flag name g = do
175
  when (dopt Opt_DoCmmLinting dflags) $ do_lint g
176
  dumpWith dflags flag name g
177 178 179 180 181 182
 where
  do_lint g = case cmmLintGraph (targetPlatform dflags) g of
                 Just err -> do { printDump err
                                ; ghcExit dflags 1
                                }
                 Nothing  -> return ()
Simon Marlow's avatar
Simon Marlow committed
183

184 185
dumpWith :: Outputable a => DynFlags -> DynFlag -> String -> a -> IO ()
dumpWith dflags flag txt g = do
Simon Marlow's avatar
Simon Marlow committed
186 187 188
         -- ToDo: No easy way of say "dump all the cmmz, *and* split
         -- them into files."  Also, -ddump-cmmz doesn't play nicely
         -- with -ddump-to-file, since the headers get omitted.
189
   dumpIfSet_dyn dflags flag txt (ppr g)
Simon Marlow's avatar
Simon Marlow committed
190
   when (not (dopt flag dflags)) $
191
      dumpIfSet_dyn dflags Opt_D_dump_cmmz txt (ppr g)
192

193 194 195
-- 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.
Simon Peyton Jones's avatar
Simon Peyton Jones committed
196 197
toTops :: HscEnv -> Map CLabel CAFSet -> (TopSRT, [[CmmDecl]])
                 -> [(CAFSet, CmmDecl)] -> IO (TopSRT, [[CmmDecl]])
198 199 200 201 202 203
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
     return (topSRT, concat gs' : tops)