CmmPipeline.hs 7.09 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
28
import StaticFlags
Simon Marlow's avatar
Simon Marlow committed
29

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

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

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

43
     showPass dflags "CPSZ"
44

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

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

50
     return (topSRT, cmms)
51
52


53

54
55
cpsTop :: HscEnv -> CmmDecl -> IO (CAFEnv, [CmmDecl])
cpsTop _ p@(CmmData {}) = return (mapEmpty, [p])
56
57
cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) l g) =
    do
58
       ----------- Control-flow optimisations ---------------
59
60
       g <- {-# SCC "cmmCfgOpts(1)" #-}
            return $ cmmCfgOpts splitting_proc_points g
61
62
       dump Opt_D_dump_cmmz_cfg "Post control-flow optimsations" g

63
       ----------- Eliminate common blocks -------------------
64
65
66
67
68
69
       g <- if dopt Opt_CmmElimCommonBlocks dflags
               then do g <- {-# SCC "elimCommonBlocks" #-} return $ elimCommonBlocks g
                       dump Opt_D_dump_cmmz_cbe "Post common block elimination" g
                       return g
               else return g

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

       ----------- Proc points -------------------
74
75
76
77
78
79
80
81
82
83
84
       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 ()
85

86
87
88
89
90
91
92
93
       ----------- Sink and inline assignments *before* stack layout -----------
       g <- if False -- maybe enable this later
               then do g <- {-# SCC "sink" #-} return (cmmSink g)
                       dump Opt_D_dump_cmmz_rewrite "Sink assignments" g
                       return g
               else return g

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

99
100
       ----------- Sink and inline assignments -------------------
       g <- if dopt Opt_CmmSink dflags
101
102
103
104
               then do g <- {-# SCC "sink" #-} return (cmmSink g)
                       dump Opt_D_dump_cmmz_rewrite "Sink assignments" g
                       return g
               else return g
105

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

109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
       if splitting_proc_points
          then do
            ------------- Split into separate procedures ------------
            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
     
            ------------- Populate info tables with stack info ------
            gs <- {-# SCC "setInfoTableStackMap" #-}
                  return $ map (setInfoTableStackMap stackmaps) gs
            dumps Opt_D_dump_cmmz_info "after setInfoTableStackMap" gs
     
            ----------- Control-flow optimisations ---------------
125
126
            gs <- {-# SCC "cmmCfgOpts(2)" #-}
                  return $ map (cmmCfgOptsProc splitting_proc_points) gs
127
128
129
130
131
132
133
134
135
136
137
138
139
140
            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)

            ------------- Populate info tables with stack info ------
            g <- {-# SCC "setInfoTableStackMap" #-}
                  return $ setInfoTableStackMap stackmaps g
            dump' Opt_D_dump_cmmz_info "after setInfoTableStackMap" g
     
            ----------- Control-flow optimisations ---------------
141
142
            g <- {-# SCC "cmmCfgOpts(2)" #-}
                 return $ cmmCfgOptsProc splitting_proc_points g
143
144
145
            dump' Opt_D_dump_cmmz_cfg "Post control-flow optimsations" g

            return (cafEnv, [g])
146

147
  where dflags = hsc_dflags hsc_env
148
        dump = dumpGraph dflags
149
        dump' = dumpWith dflags
150

Simon Marlow's avatar
Simon Marlow committed
151
        dumps flag name
152
           = mapM_ (dumpWith dflags flag name)
Simon Marlow's avatar
Simon Marlow committed
153

154
155
156
157
158
159
160
        -- 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
                             || not tablesNextToCode

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

166

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

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