CmmPipeline.hs 8.22 KB
Newer Older
1 2 3
{-# OPTIONS_GHC -XNoMonoLocalBinds #-}
-- Norman likes local bindings
-- If this module lives on I'd like to get rid of this flag 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) <- 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 = mkTopCAFInfo (concat cafEnvs)
72 73

     -- folding over the groups
74
     (topSRT, tops) <- foldM (toTops hsc_env topCAFEnv) (topSRT, []) tops
75

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

79
     dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (pprPlatform (targetPlatform dflags) 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 119
       dump Opt_D_dump_cmmz_sp "Layout Stack" g

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

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

132
       ------------- More CAFs ------------------------------
133
       let cafEnv = {-# SCC "cafAnal" #-} cafAnal platform g
134 135
       let localCAFs = catMaybes $ map (localCAFInfo platform cafEnv) gs
       mbpprTrace "localCAFs" (pprPlatform platform localCAFs) $ return ()
136

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

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

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

149
       return (localCAFs, gs)
150

Simon Peyton Jones's avatar
Simon Peyton Jones committed
151
              -- gs        :: [ (CAFSet, CmmDecl) ]
152 153
              -- localCAFs :: [ (CLabel, CAFSet) ] -- statics filtered out(?)

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

Simon Marlow's avatar
Simon Marlow committed
160 161 162
        dumps flag name
           = mapM_ (dumpWith dflags (pprPlatform platform) flag name)

163 164 165 166 167 168
        -- 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)

169

Simon Marlow's avatar
Simon Marlow committed
170 171
dumpGraph :: DynFlags -> DynFlag -> String -> CmmGraph -> IO ()
dumpGraph dflags flag name g = do
172
  when (dopt Opt_DoCmmLinting dflags) $ do_lint g
Simon Marlow's avatar
Simon Marlow committed
173
  dumpWith dflags (pprPlatform (targetPlatform dflags)) flag name g
174 175 176 177 178 179
 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
180 181 182 183 184 185 186 187 188

dumpWith :: DynFlags -> (a -> SDoc) -> DynFlag -> String -> a -> IO ()
dumpWith dflags pprFun flag txt g = do
         -- 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.
   dumpIfSet_dyn dflags flag txt (pprFun g)
   when (not (dopt flag dflags)) $
      dumpIfSet_dyn dflags Opt_D_dump_cmmz txt (pprFun g)
189

190 191 192
-- 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
193 194
toTops :: HscEnv -> Map CLabel CAFSet -> (TopSRT, [[CmmDecl]])
                 -> [(CAFSet, CmmDecl)] -> IO (TopSRT, [[CmmDecl]])
195 196 197 198 199 200
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)