CmmPipeline.hs 7.88 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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

113 114
--       g <- {-# SCC "sink" #-} runUniqSM $ cmmSink g
--       dump Opt_D_dump_cmmz_rewrite "Sink assignments" g
115

Simon Marlow's avatar
Simon Marlow committed
116
--       ----------- Sink and inline assignments -------------------
117 118
--       g <- {-# SCC "rewriteAssignments" #-} runOptimization $
--            rewriteAssignments platform g
Simon Marlow's avatar
Simon Marlow committed
119
--       dump Opt_D_dump_cmmz_rewrite "Post rewrite assignments" g
120 121

       ------------- Split into separate procedures ------------
122
       procPointMap  <- {-# SCC "procPointAnalysis" #-} runUniqSM $
123
                        procPointAnalysis procPoints g
124
       dumpWith dflags Opt_D_dump_cmmz_procmap "procpoint map" procPointMap
125
       gs <- {-# SCC "splitAtProcPoints" #-} runUniqSM $
126
             splitAtProcPoints l callPPs procPoints procPointMap (CmmProc h l g)
Simon Marlow's avatar
Simon Marlow committed
127
       dumps Opt_D_dump_cmmz_split "Post splitting" gs
128

129
       ------------- More CAFs ------------------------------
Simon Marlow's avatar
Simon Marlow committed
130 131
       let cafEnv = {-# SCC "cafAnal" #-} cafAnal g
       let localCAFs = {-# SCC "localCAFs" #-} catMaybes $ map (localCAFInfo cafEnv) gs
Ian Lynagh's avatar
Ian Lynagh committed
132
       mbpprTrace "localCAFs" (ppr localCAFs) $ return ()
133

134
       -- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES
135 136 137
       gs <- {-# SCC "setInfoTableStackMap" #-}
             return $ map (setInfoTableStackMap stackmaps) gs
       dumps Opt_D_dump_cmmz_info "after setInfoTableStackMap" gs
138

139
       ----------- Control-flow optimisations ---------------
Simon Marlow's avatar
Simon Marlow committed
140 141
       gs <- {-# SCC "cmmCfgOpts(2)" #-} return $ map cmmCfgOptsProc gs
       dumps Opt_D_dump_cmmz_cfg "Post control-flow optimsations" gs
142

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

146
       return (localCAFs, gs)
147

Simon Peyton Jones's avatar
Simon Peyton Jones committed
148
              -- gs        :: [ (CAFSet, CmmDecl) ]
149 150
              -- localCAFs :: [ (CLabel, CAFSet) ] -- statics filtered out(?)

151
  where dflags = hsc_dflags hsc_env
Simon Marlow's avatar
Simon Marlow committed
152 153
        mbpprTrace x y z | dopt Opt_D_dump_cmmz dflags = pprTrace x y z
                         | otherwise = z
154 155
        dump = dumpGraph dflags

Simon Marlow's avatar
Simon Marlow committed
156
        dumps flag name
157
           = mapM_ (dumpWith dflags flag name)
Simon Marlow's avatar
Simon Marlow committed
158

159 160 161 162
runUniqSM :: UniqSM a -> IO a
runUniqSM m = do
  us <- mkSplitUniqSupply 'u'
  return (initUs_ us m)
163

164

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

176 177
dumpWith :: Outputable a => DynFlags -> DynFlag -> String -> a -> IO ()
dumpWith dflags flag txt g = do
Simon Marlow's avatar
Simon Marlow committed
178 179 180
         -- 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.
181
   dumpIfSet_dyn dflags flag txt (ppr g)
Simon Marlow's avatar
Simon Marlow committed
182
   when (not (dopt flag dflags)) $
183
      dumpIfSet_dyn dflags Opt_D_dump_cmmz txt (ppr g)
184

185 186 187
-- 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.
188 189 190
toTops :: Map CLabel CAFSet -> (TopSRT, [[CmmDecl]])
       -> [(CAFSet, CmmDecl)] -> IO (TopSRT, [[CmmDecl]])
toTops topCAFEnv (topSRT, tops) gs =
191 192 193
  do let setSRT (topSRT, rst) g =
           do (topSRT, gs) <- setInfoTableSRT topCAFEnv topSRT g
              return (topSRT, gs : rst)
194
     (topSRT, gs') <- runUniqSM $ foldM setSRT (topSRT, []) gs
195
     return (topSRT, concat gs' : tops)