CmmPipeline.hs 7.55 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 Cmm
Simon Marlow's avatar
Simon Marlow committed
13
import CmmLint
14
15
import CmmBuildInfoTables
import CmmCommonBlockElim
16
import CmmProcPoint
17
import CmmContFlowOpt
Simon Marlow's avatar
Simon Marlow committed
18
import CmmLayoutStack
19
import CmmSink
20
import Hoopl
21

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

29
-----------------------------------------------------------------------------
30
-- | Top level driver for C-- pipeline
31
-----------------------------------------------------------------------------
32

33
cmmPipeline  :: HscEnv -- Compilation env including
34
                       -- dynamic flags: -dcmm-lint -ddump-cps-cmm
35
             -> TopSRT     -- SRT table and accumulating list of compiled procs
Simon Peyton Jones's avatar
Simon Peyton Jones committed
36
             -> CmmGroup             -- Input C-- with Procedures
37
             -> IO (TopSRT, CmmGroup) -- Output CPS transformed C--
38

39
cmmPipeline hsc_env topSRT prog =
40
  do let dflags = hsc_dflags hsc_env
41

42
     showPass dflags "CPSZ"
43

44
     tops <- {-# SCC "tops" #-} mapM (cpsTop hsc_env) prog
45

46
     (topSRT, cmms) <- {-# SCC "toTops" #-} doSRTs topSRT tops
Ian Lynagh's avatar
Ian Lynagh committed
47
     dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (ppr cmms)
48

49
     return (topSRT, cmms)
50
51


52

53
54
cpsTop :: HscEnv -> CmmDecl -> IO (CAFEnv, [CmmDecl])
cpsTop _ p@(CmmData {}) = return (mapEmpty, [p])
55
56
cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) l g) =
    do
Simon Marlow's avatar
Simon Marlow committed
57
       ----------- Control-flow optimisations ----------------------------------
58
59
60
61
62

       -- The first round of control-flow optimisation speeds up the
       -- later passes by removing lots of empty blocks, so we do it
       -- even when optimisation isn't turned on.
       --
63
64
       g <- {-# SCC "cmmCfgOpts(1)" #-}
            return $ cmmCfgOpts splitting_proc_points g
65
66
       dump Opt_D_dump_cmmz_cfg "Post control-flow optimsations" g

Simon Marlow's avatar
Simon Marlow committed
67
68
69
70
       ----------- Eliminate common blocks -------------------------------------
       g <- {-# SCC "elimCommonBlocks" #-}
            condPass Opt_CmmElimCommonBlocks elimCommonBlocks g
                     Opt_D_dump_cmmz_cbe "Post common block elimination"
71

72
73
       -- Any work storing block Labels must be performed _after_
       -- elimCommonBlocks
74

Simon Marlow's avatar
Simon Marlow committed
75
       ----------- Proc points -------------------------------------------------
76
77
78
79
80
81
82
83
84
85
86
       let call_pps = {-# SCC "callProcPoints" #-} callProcPoints g
       proc_points <-
          if splitting_proc_points
             then {-# SCC "minimalProcPointSet" #-} runUniqSM $
                  minimalProcPointSet (targetPlatform dflags) call_pps g
             else
                  return call_pps

       let noncall_pps = proc_points `setDifference` call_pps
       when (not (setNull noncall_pps)) $
         pprTrace "Non-call proc points: " (ppr noncall_pps) $ return ()
87

88
       ----------- Sink and inline assignments *before* stack layout -----------
Simon Marlow's avatar
Simon Marlow committed
89
90
91
92
93
       {-  Maybe enable this later
       g <- {-# SCC "sink1" #-}
            condPass Opt_CmmSink cmmSink g
                     Opt_D_dump_cmmz_rewrite "Sink assignments (1)"
       -}
94
95

       ----------- Layout the stack and manifest Sp ----------------------------
Simon Marlow's avatar
Simon Marlow committed
96
97
98
       (g, stackmaps) <-
            {-# SCC "layoutStack" #-}
            runUniqSM $ cmmLayoutStack dflags proc_points entry_off g
Simon Marlow's avatar
Simon Marlow committed
99
100
       dump Opt_D_dump_cmmz_sp "Layout Stack" g

Simon Marlow's avatar
Simon Marlow committed
101
102
       ----------- Sink and inline assignments *after* stack layout ------------
       g <- {-# SCC "sink2" #-}
103
            condPass Opt_CmmSink (cmmSink dflags) g
Simon Marlow's avatar
Simon Marlow committed
104
                     Opt_D_dump_cmmz_rewrite "Sink assignments (2)"
105

Simon Marlow's avatar
Simon Marlow committed
106
       ------------- CAF analysis ----------------------------------------------
Simon Marlow's avatar
Simon Marlow committed
107
       let cafEnv = {-# SCC "cafAnal" #-} cafAnal g
108

109
110
       if splitting_proc_points
          then do
Simon Marlow's avatar
Simon Marlow committed
111
            ------------- Split into separate procedures -----------------------
112
113
114
115
116
117
118
            pp_map  <- {-# SCC "procPointAnalysis" #-} runUniqSM $
                             procPointAnalysis proc_points g
            dumpWith dflags Opt_D_dump_cmmz_procmap "procpoint map" pp_map
            gs <- {-# SCC "splitAtProcPoints" #-} runUniqSM $
                  splitAtProcPoints l call_pps proc_points pp_map (CmmProc h l g)
            dumps Opt_D_dump_cmmz_split "Post splitting" gs
     
Simon Marlow's avatar
Simon Marlow committed
119
            ------------- Populate info tables with stack info -----------------
120
121
122
123
            gs <- {-# SCC "setInfoTableStackMap" #-}
                  return $ map (setInfoTableStackMap stackmaps) gs
            dumps Opt_D_dump_cmmz_info "after setInfoTableStackMap" gs
     
Simon Marlow's avatar
Simon Marlow committed
124
            ----------- Control-flow optimisations -----------------------------
125
            gs <- {-# SCC "cmmCfgOpts(2)" #-}
126
127
128
                  return $ if optLevel dflags >= 1
                             then map (cmmCfgOptsProc splitting_proc_points) gs
                             else gs
129
130
131
132
133
134
135
136
            dumps Opt_D_dump_cmmz_cfg "Post control-flow optimsations" gs

            return (cafEnv, gs)

          else do
            -- attach info tables to return points
            g <- return $ attachContInfoTables call_pps (CmmProc h l g)

Simon Marlow's avatar
Simon Marlow committed
137
            ------------- Populate info tables with stack info -----------------
138
139
140
141
            g <- {-# SCC "setInfoTableStackMap" #-}
                  return $ setInfoTableStackMap stackmaps g
            dump' Opt_D_dump_cmmz_info "after setInfoTableStackMap" g
     
Simon Marlow's avatar
Simon Marlow committed
142
            ----------- Control-flow optimisations -----------------------------
143
            g <- {-# SCC "cmmCfgOpts(2)" #-}
144
145
146
                 return $ if optLevel dflags >= 1
                             then cmmCfgOptsProc splitting_proc_points g
                             else g
147
148
149
            dump' Opt_D_dump_cmmz_cfg "Post control-flow optimsations" g

            return (cafEnv, [g])
150

151
  where dflags = hsc_dflags hsc_env
152
        dump = dumpGraph dflags
153
        dump' = dumpWith dflags
154

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

Simon Marlow's avatar
Simon Marlow committed
158
159
160
161
162
163
164
165
166
        condPass flag pass g dumpflag dumpname =
            if dopt flag dflags
               then do
                    g <- return $ pass g
                    dump dumpflag dumpname g
                    return g
               else return g


167
168
169
170
171
        -- we don't need to split proc points for the NCG, unless
        -- tablesNextToCode is off.  The latter is because we have no
        -- label to put on info tables for basic blocks that are not
        -- the entry point.
        splitting_proc_points = hscTarget dflags /= HscAsm
172
                             || not (tablesNextToCode dflags)
173

174
175
176
177
runUniqSM :: UniqSM a -> IO a
runUniqSM m = do
  us <- mkSplitUniqSupply 'u'
  return (initUs_ us m)
178

179

Simon Marlow's avatar
Simon Marlow committed
180
181
dumpGraph :: DynFlags -> DynFlag -> String -> CmmGraph -> IO ()
dumpGraph dflags flag name g = do
182
  when (dopt Opt_DoCmmLinting dflags) $ do_lint g
183
  dumpWith dflags flag name g
184
 where
Simon Marlow's avatar
Simon Marlow committed
185
186
  do_lint g = case cmmLintGraph g of
                 Just err -> do { fatalErrorMsg dflags err
187
188
189
                                ; ghcExit dflags 1
                                }
                 Nothing  -> return ()
Simon Marlow's avatar
Simon Marlow committed
190

191
192
dumpWith :: Outputable a => DynFlags -> DynFlag -> String -> a -> IO ()
dumpWith dflags flag txt g = do
Simon Marlow's avatar
Simon Marlow committed
193
194
195
         -- 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.
196
   dumpIfSet_dyn dflags flag txt (ppr g)
Simon Marlow's avatar
Simon Marlow committed
197
   when (not (dopt flag dflags)) $
198
      dumpIfSet_dyn dflags Opt_D_dump_cmmz txt (ppr g)
199