CmmPipeline.hs 5.41 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
57
       ----------- Control-flow optimisations ---------------
Simon Marlow's avatar
Simon Marlow committed
58
       g <- {-# SCC "cmmCfgOpts(1)" #-} return $ cmmCfgOpts g
59 60
       dump Opt_D_dump_cmmz_cfg "Post control-flow optimsations" g

61
       ----------- Eliminate common blocks -------------------
Simon Marlow's avatar
Simon Marlow committed
62
       g <- {-# SCC "elimCommonBlocks" #-} return $ elimCommonBlocks g
63 64 65
       dump Opt_D_dump_cmmz_cbe "Post common block elimination" g
       -- Any work storing block Labels must be performed _after_
       -- elimCommonBlocks
66 67

       ----------- Proc points -------------------
Simon Marlow's avatar
Simon Marlow committed
68
       let callPPs = {-# SCC "callProcPoints" #-} callProcPoints g
69
       procPoints <- {-# SCC "minimalProcPointSet" #-} runUniqSM $
70
                     minimalProcPointSet (targetPlatform dflags) callPPs g
71

72 73
       ----------- Layout the stack and manifest Sp ---------------
       -- (also does: removeDeadAssignments, and lowerSafeForeignCalls)
74
       (g, stackmaps) <- {-# SCC "layoutStack" #-}
75
                         runUniqSM $ cmmLayoutStack dflags procPoints entry_off g
Simon Marlow's avatar
Simon Marlow committed
76 77
       dump Opt_D_dump_cmmz_sp "Layout Stack" g

78 79 80 81 82 83 84
       g <- if optLevel dflags >= 99
               then do g <- {-# SCC "sink" #-} return (cmmSink g)
                       dump Opt_D_dump_cmmz_rewrite "Sink assignments" g
                       g <- {-# SCC "inline" #-} return (cmmPeepholeInline g)
                       dump Opt_D_dump_cmmz_rewrite "Peephole inline" g
                       return g
               else return g
85

Simon Marlow's avatar
Simon Marlow committed
86
--       ----------- Sink and inline assignments -------------------
87 88
--       g <- {-# SCC "rewriteAssignments" #-} runOptimization $
--            rewriteAssignments platform g
Simon Marlow's avatar
Simon Marlow committed
89
--       dump Opt_D_dump_cmmz_rewrite "Post rewrite assignments" g
90 91

       ------------- Split into separate procedures ------------
92
       procPointMap  <- {-# SCC "procPointAnalysis" #-} runUniqSM $
93
                        procPointAnalysis procPoints g
94
       dumpWith dflags Opt_D_dump_cmmz_procmap "procpoint map" procPointMap
95
       gs <- {-# SCC "splitAtProcPoints" #-} runUniqSM $
96
             splitAtProcPoints l callPPs procPoints procPointMap (CmmProc h l g)
Simon Marlow's avatar
Simon Marlow committed
97
       dumps Opt_D_dump_cmmz_split "Post splitting" gs
98

99
       ------------- CAF analysis ------------------------------
Simon Marlow's avatar
Simon Marlow committed
100
       let cafEnv = {-# SCC "cafAnal" #-} cafAnal g
101

102
       ------------- Populate info tables with stack info ------
103 104 105
       gs <- {-# SCC "setInfoTableStackMap" #-}
             return $ map (setInfoTableStackMap stackmaps) gs
       dumps Opt_D_dump_cmmz_info "after setInfoTableStackMap" gs
106

107
       ----------- Control-flow optimisations -----------------
Simon Marlow's avatar
Simon Marlow committed
108 109
       gs <- {-# SCC "cmmCfgOpts(2)" #-} return $ map cmmCfgOptsProc gs
       dumps Opt_D_dump_cmmz_cfg "Post control-flow optimsations" gs
110

111
       return (cafEnv, gs)
112

113
  where dflags = hsc_dflags hsc_env
114 115
        dump = dumpGraph dflags

Simon Marlow's avatar
Simon Marlow committed
116
        dumps flag name
117
           = mapM_ (dumpWith dflags flag name)
Simon Marlow's avatar
Simon Marlow committed
118

119 120 121 122
runUniqSM :: UniqSM a -> IO a
runUniqSM m = do
  us <- mkSplitUniqSupply 'u'
  return (initUs_ us m)
123

124

Simon Marlow's avatar
Simon Marlow committed
125 126
dumpGraph :: DynFlags -> DynFlag -> String -> CmmGraph -> IO ()
dumpGraph dflags flag name g = do
127
  when (dopt Opt_DoCmmLinting dflags) $ do_lint g
128
  dumpWith dflags flag name g
129
 where
Simon Marlow's avatar
Simon Marlow committed
130 131
  do_lint g = case cmmLintGraph g of
                 Just err -> do { fatalErrorMsg dflags err
132 133 134
                                ; ghcExit dflags 1
                                }
                 Nothing  -> return ()
Simon Marlow's avatar
Simon Marlow committed
135

136 137
dumpWith :: Outputable a => DynFlags -> DynFlag -> String -> a -> IO ()
dumpWith dflags flag txt g = do
Simon Marlow's avatar
Simon Marlow committed
138 139 140
         -- 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.
141
   dumpIfSet_dyn dflags flag txt (ppr g)
Simon Marlow's avatar
Simon Marlow committed
142
   when (not (dopt flag dflags)) $
143
      dumpIfSet_dyn dflags Opt_D_dump_cmmz txt (ppr g)
144