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

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
26
import Control.Monad
27
import Outputable
Ian Lynagh's avatar
Ian Lynagh committed
28
import Platform
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 "doSRTs" #-} doSRTs dflags topSRT tops
48
     dumpWith dflags Opt_D_dump_cmm_cps "Post CPS Cmm" cmms
49

50
     return (topSRT, cmms)
51 52


53 54
cpsTop :: HscEnv -> CmmDecl -> IO (CAFEnv, [CmmDecl])
cpsTop _ p@(CmmData {}) = return (mapEmpty, [p])
55
cpsTop hsc_env proc =
56
    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
       CmmProc h l v g <- {-# SCC "cmmCfgOpts(1)" #-}
64
            return $ cmmCfgOptsProc splitting_proc_points proc
65
       dump Opt_D_dump_cmm_cfg "Post control-flow optimsations" g
66

67 68 69
       let !TopInfo {stack_info=StackInfo { arg_space = entry_off
                                          , do_layout = do_layout }} = h

Simon Marlow's avatar
Simon Marlow committed
70 71 72
       ----------- Eliminate common blocks -------------------------------------
       g <- {-# SCC "elimCommonBlocks" #-}
            condPass Opt_CmmElimCommonBlocks elimCommonBlocks g
73
                     Opt_D_dump_cmm_cbe "Post common block elimination"
74

75 76
       -- Any work storing block Labels must be performed _after_
       -- elimCommonBlocks
77

Simon Marlow's avatar
Simon Marlow committed
78
       ----------- Proc points -------------------------------------------------
79 80 81 82 83 84 85 86 87
       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
88
       when (not (setNull noncall_pps) && dopt Opt_D_dump_cmm dflags) $
89
         pprTrace "Non-call proc points: " (ppr noncall_pps) $ return ()
90

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

       ----------- Layout the stack and manifest Sp ----------------------------
Simon Marlow's avatar
Simon Marlow committed
99 100
       (g, stackmaps) <-
            {-# SCC "layoutStack" #-}
101 102 103
            if do_layout
               then runUniqSM $ cmmLayoutStack dflags proc_points entry_off g
               else return (g, mapEmpty)
104
       dump Opt_D_dump_cmm_sp "Layout Stack" g
Simon Marlow's avatar
Simon Marlow committed
105

Simon Marlow's avatar
Simon Marlow committed
106 107
       ----------- Sink and inline assignments *after* stack layout ------------
       g <- {-# SCC "sink2" #-}
108
            condPass Opt_CmmSink (cmmSink dflags) g
109
                     Opt_D_dump_cmm_rewrite "Sink assignments (2)"
110

Simon Marlow's avatar
Simon Marlow committed
111
       ------------- CAF analysis ----------------------------------------------
Simon Marlow's avatar
Simon Marlow committed
112
       let cafEnv = {-# SCC "cafAnal" #-} cafAnal g
113
       dumpIfSet_dyn dflags Opt_D_dump_cmm "CAFEnv" (ppr cafEnv)
114

115 116
       if splitting_proc_points
          then do
Simon Marlow's avatar
Simon Marlow committed
117
            ------------- Split into separate procedures -----------------------
118 119
            pp_map  <- {-# SCC "procPointAnalysis" #-} runUniqSM $
                             procPointAnalysis proc_points g
120
            dumpWith dflags Opt_D_dump_cmm_procmap "procpoint map" pp_map
121
            gs <- {-# SCC "splitAtProcPoints" #-} runUniqSM $
122
                  splitAtProcPoints dflags l call_pps proc_points pp_map
123
                                    (CmmProc h l v g)
124
            dumps Opt_D_dump_cmm_split "Post splitting" gs
125
     
Simon Marlow's avatar
Simon Marlow committed
126
            ------------- Populate info tables with stack info -----------------
127
            gs <- {-# SCC "setInfoTableStackMap" #-}
128
                  return $ map (setInfoTableStackMap dflags stackmaps) gs
129
            dumps Opt_D_dump_cmm_info "after setInfoTableStackMap" gs
130
     
Simon Marlow's avatar
Simon Marlow committed
131
            ----------- Control-flow optimisations -----------------------------
132
            gs <- {-# SCC "cmmCfgOpts(2)" #-}
133 134 135
                  return $ if optLevel dflags >= 1
                             then map (cmmCfgOptsProc splitting_proc_points) gs
                             else gs
136 137
            gs <- return (map removeUnreachableBlocksProc gs)
                -- Note [unreachable blocks]
138
            dumps Opt_D_dump_cmm_cfg "Post control-flow optimsations" gs
139 140 141 142 143

            return (cafEnv, gs)

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

Simon Marlow's avatar
Simon Marlow committed
146
            ------------- Populate info tables with stack info -----------------
147
            g <- {-# SCC "setInfoTableStackMap" #-}
148
                  return $ setInfoTableStackMap dflags stackmaps g
149
            dump' Opt_D_dump_cmm_info "after setInfoTableStackMap" g
150
     
Simon Marlow's avatar
Simon Marlow committed
151
            ----------- Control-flow optimisations -----------------------------
152
            g <- {-# SCC "cmmCfgOpts(2)" #-}
153 154 155
                 return $ if optLevel dflags >= 1
                             then cmmCfgOptsProc splitting_proc_points g
                             else g
156 157
            g <- return (removeUnreachableBlocksProc g)
                -- Note [unreachable blocks]
158
            dump' Opt_D_dump_cmm_cfg "Post control-flow optimsations" g
159 160

            return (cafEnv, [g])
161

162
  where dflags = hsc_dflags hsc_env
Ian Lynagh's avatar
Ian Lynagh committed
163
        platform = targetPlatform dflags
164
        dump = dumpGraph dflags
165
        dump' = dumpWith dflags
166

Simon Marlow's avatar
Simon Marlow committed
167
        dumps flag name
168
           = mapM_ (dumpWith dflags flag name)
Simon Marlow's avatar
Simon Marlow committed
169

Simon Marlow's avatar
Simon Marlow committed
170
        condPass flag pass g dumpflag dumpname =
ian@well-typed.com's avatar
ian@well-typed.com committed
171
            if gopt flag dflags
Simon Marlow's avatar
Simon Marlow committed
172 173 174 175 176 177 178
               then do
                    g <- return $ pass g
                    dump dumpflag dumpname g
                    return g
               else return g


179 180 181 182 183
        -- 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
184
                             || not (tablesNextToCode dflags)
ian@well-typed.com's avatar
ian@well-typed.com committed
185 186
                             || -- Note [inconsistent-pic-reg]
                                usingInconsistentPicReg
PHO's avatar
PHO committed
187 188 189 190 191
        usingInconsistentPicReg = ( platformArch platform == ArchX86 ||
                                    platformArch platform == ArchPPC
                                  )
                               && platformOS platform == OSDarwin
                               && gopt Opt_PIC dflags
192

ian@well-typed.com's avatar
ian@well-typed.com committed
193
{- Note [inconsistent-pic-reg]
194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209

On x86/Darwin, PIC is implemented by inserting a sequence like

    call 1f
 1: popl %reg

at the proc entry point, and then referring to labels as offsets from
%reg.  If we don't split proc points, then we could have many entry
points in a proc that would need this sequence, and each entry point
would then get a different value for %reg.  If there are any join
points, then at the join point we don't have a consistent value for
%reg, so we don't know how to refer to labels.

Hence, on x86/Darwin, we have to split proc points, and then each proc
point will get its own PIC initialisation sequence.

PHO's avatar
PHO committed
210 211 212 213 214 215
The situation is the same for ppc/Darwin. We use essentially the same
sequence to load the program counter onto reg:

    bcl  20,31,1f
 1: mflr reg

216 217 218 219 220 221 222 223 224 225 226
This isn't an issue on x86/ELF, where the sequence is

    call 1f
 1: popl %reg
    addl $_GLOBAL_OFFSET_TABLE_+(.-1b), %reg

so %reg always has a consistent value: the address of
_GLOBAL_OFFSET_TABLE_, regardless of which entry point we arrived via.

-}

227
{- Note [unreachable blocks]
228

229 230 231 232 233 234 235
The control-flow optimiser sometimes leaves unreachable blocks behind
containing junk code.  If these blocks make it into the native code
generator then they trigger a register allocator panic because they
refer to undefined LocalRegs, so we must eliminate any unreachable
blocks before passing the code onwards.

-}
236

237 238 239 240
runUniqSM :: UniqSM a -> IO a
runUniqSM m = do
  us <- mkSplitUniqSupply 'u'
  return (initUs_ us m)
241

242

243
dumpGraph :: DynFlags -> DumpFlag -> String -> CmmGraph -> IO ()
Simon Marlow's avatar
Simon Marlow committed
244
dumpGraph dflags flag name g = do
ian@well-typed.com's avatar
ian@well-typed.com committed
245
  when (gopt Opt_DoCmmLinting dflags) $ do_lint g
246
  dumpWith dflags flag name g
247
 where
248
  do_lint g = case cmmLintGraph dflags g of
Simon Marlow's avatar
Simon Marlow committed
249
                 Just err -> do { fatalErrorMsg dflags err
250 251 252
                                ; ghcExit dflags 1
                                }
                 Nothing  -> return ()
Simon Marlow's avatar
Simon Marlow committed
253

254
dumpWith :: Outputable a => DynFlags -> DumpFlag -> String -> a -> IO ()
255
dumpWith dflags flag txt g = do
256 257
         -- ToDo: No easy way of say "dump all the cmm, *and* split
         -- them into files."  Also, -ddump-cmm doesn't play nicely
Simon Marlow's avatar
Simon Marlow committed
258
         -- with -ddump-to-file, since the headers get omitted.
259
   dumpIfSet_dyn dflags flag txt (ppr g)
260
   when (not (dopt flag dflags)) $
261
      dumpIfSet_dyn dflags Opt_D_dump_cmm txt (ppr g)
262