CmmPipeline.hs 8.16 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 16
import CmmBuildInfoTables
import CmmCommonBlockElim
17
import CmmProcPoint
18
import CmmContFlowOpt
Simon Marlow's avatar
Simon Marlow committed
19
import CmmLayoutStack
20
import CmmSink
21

22
import UniqSupply
23 24
import DynFlags
import ErrUtils
25 26
import HscTypes
import Data.Maybe
Ian Lynagh's avatar
Ian Lynagh committed
27
import Control.Monad
28
import Outputable
Simon Marlow's avatar
Simon Marlow committed
29 30 31

import qualified Data.Set as Set
import Data.Map (Map)
32

33
-----------------------------------------------------------------------------
34
-- | Top level driver for C-- pipeline
35
-----------------------------------------------------------------------------
36 37 38 39 40 41 42 43 44 45 46 47 48
-- 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.
49 50 51 52 53
-- 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
54
                       -- dynamic flags: -dcmm-lint -ddump-cps-cmm
55
             -> TopSRT     -- SRT table and accumulating list of compiled procs
Simon Peyton Jones's avatar
Simon Peyton Jones committed
56
             -> CmmGroup             -- Input C-- with Procedures
57 58
             -> IO (TopSRT, CmmGroup) -- Output CPS transformed C--
cmmPipeline hsc_env topSRT prog =
59
  do let dflags = hsc_dflags hsc_env
60
     --
61
     showPass dflags "CPSZ"
62

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

66
     let topCAFEnv = {-# SCC "topCAFEnv" #-} mkTopCAFInfo (concat cafEnvs)
67 68

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

71 72
     let cmms :: CmmGroup
         cmms = reverse (concat tops)
73

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

76
     return (topSRT, cmms)
77 78 79 80 81 82 83 84

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

85 86 87 88
-- 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
89
cpsTop :: HscEnv -> CmmDecl -> IO ([(CLabel, CAFSet)], [(CAFSet, CmmDecl)])
90
cpsTop _ p@(CmmData {}) = return ([], [(Set.empty, p)])
91 92
cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) l g) =
    do
93
       ----------- Control-flow optimisations ---------------
Simon Marlow's avatar
Simon Marlow committed
94
       g <- {-# SCC "cmmCfgOpts(1)" #-} return $ cmmCfgOpts g
95 96
       dump Opt_D_dump_cmmz_cfg "Post control-flow optimsations" g

97
       ----------- Eliminate common blocks -------------------
Simon Marlow's avatar
Simon Marlow committed
98
       g <- {-# SCC "elimCommonBlocks" #-} return $ elimCommonBlocks g
99 100 101
       dump Opt_D_dump_cmmz_cbe "Post common block elimination" g
       -- Any work storing block Labels must be performed _after_
       -- elimCommonBlocks
102 103

       ----------- Proc points -------------------
Simon Marlow's avatar
Simon Marlow committed
104
       let callPPs = {-# SCC "callProcPoints" #-} callProcPoints g
105
       procPoints <- {-# SCC "minimalProcPointSet" #-} runUniqSM $
106
                     minimalProcPointSet (targetPlatform dflags) callPPs g
107

108 109
       ----------- Layout the stack and manifest Sp ---------------
       -- (also does: removeDeadAssignments, and lowerSafeForeignCalls)
110
       (g, stackmaps) <- {-# SCC "layoutStack" #-}
111
                         runUniqSM $ cmmLayoutStack procPoints entry_off g
Simon Marlow's avatar
Simon Marlow committed
112 113
       dump Opt_D_dump_cmmz_sp "Layout Stack" g

114 115 116 117 118 119 120
       g <- if optLevel dflags >= 99
               then do g <- {-# SCC "sink" #-} return (cmmSink g)
                       dump Opt_D_dump_cmmz_rewrite "Sink assignments" g
                       g <- {-# SCC "inline" #-} return (cmmPeepholeInline g)
                       dump Opt_D_dump_cmmz_rewrite "Peephole inline" g
                       return g
               else return g
121

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
       procPointMap  <- {-# SCC "procPointAnalysis" #-} runUniqSM $
129
                        procPointAnalysis procPoints g
130
       dumpWith dflags Opt_D_dump_cmmz_procmap "procpoint map" procPointMap
131
       gs <- {-# SCC "splitAtProcPoints" #-} runUniqSM $
132
             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 ------------------------------
Simon Marlow's avatar
Simon Marlow committed
136 137
       let cafEnv = {-# SCC "cafAnal" #-} cafAnal g
       let localCAFs = {-# SCC "localCAFs" #-} catMaybes $ map (localCAFInfo 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
        mbpprTrace x y z | dopt Opt_D_dump_cmmz dflags = pprTrace x y z
                         | otherwise = z
160 161
        dump = dumpGraph dflags

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

165 166 167 168
runUniqSM :: UniqSM a -> IO a
runUniqSM m = do
  us <- mkSplitUniqSupply 'u'
  return (initUs_ us m)
169

170

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

182 183
dumpWith :: Outputable a => DynFlags -> DynFlag -> String -> a -> IO ()
dumpWith dflags flag txt g = do
Simon Marlow's avatar
Simon Marlow committed
184 185 186
         -- 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.
187
   dumpIfSet_dyn dflags flag txt (ppr g)
Simon Marlow's avatar
Simon Marlow committed
188
   when (not (dopt flag dflags)) $
189
      dumpIfSet_dyn dflags Opt_D_dump_cmmz txt (ppr g)
190

191 192 193
-- 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.
194 195 196
toTops :: Map CLabel CAFSet -> (TopSRT, [[CmmDecl]])
       -> [(CAFSet, CmmDecl)] -> IO (TopSRT, [[CmmDecl]])
toTops topCAFEnv (topSRT, tops) gs =
197 198 199
  do let setSRT (topSRT, rst) g =
           do (topSRT, gs) <- setInfoTableSRT topCAFEnv topSRT g
              return (topSRT, gs : rst)
200
     (topSRT, gs') <- runUniqSM $ foldM setSRT (topSRT, []) gs
201
     return (topSRT, concat gs' : tops)