Merge branch 'master' of darcs.haskell.org:/srv/darcs//ghc
[ghc.git] / compiler / cmm / CmmPipeline.hs
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 -- | Converts C-- with an implicit stack and native C-- calls into
7 -- optimized, CPS converted and native-call-less C--. The latter
8 -- C-- can be used to generate assembly.
9 cmmPipeline
10 ) where
11
12 import Cmm
13 import CmmLint
14 import CmmBuildInfoTables
15 import CmmCommonBlockElim
16 import CmmProcPoint
17 import CmmContFlowOpt
18 import CmmLayoutStack
19 import CmmSink
20 import Hoopl
21
22 import UniqSupply
23 import DynFlags
24 import ErrUtils
25 import HscTypes
26 import Control.Monad
27 import Outputable
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
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
47 dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (ppr cmms)
48
49 return (topSRT, cmms)
50
51
52
53 cpsTop :: HscEnv -> CmmDecl -> IO (CAFEnv, [CmmDecl])
54 cpsTop _ p@(CmmData {}) = return (mapEmpty, [p])
55 cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) l g) =
56 do
57 ----------- Control-flow optimisations ---------------
58 g <- {-# SCC "cmmCfgOpts(1)" #-} return $ cmmCfgOpts g
59 dump Opt_D_dump_cmmz_cfg "Post control-flow optimsations" g
60
61 ----------- Eliminate common blocks -------------------
62 g <- {-# SCC "elimCommonBlocks" #-} return $ elimCommonBlocks g
63 dump Opt_D_dump_cmmz_cbe "Post common block elimination" g
64 -- Any work storing block Labels must be performed _after_
65 -- elimCommonBlocks
66
67 ----------- Proc points -------------------
68 let callPPs = {-# SCC "callProcPoints" #-} callProcPoints g
69 procPoints <- {-# SCC "minimalProcPointSet" #-} runUniqSM $
70 minimalProcPointSet (targetPlatform dflags) callPPs g
71
72 ----------- Layout the stack and manifest Sp ---------------
73 -- (also does: removeDeadAssignments, and lowerSafeForeignCalls)
74 (g, stackmaps) <- {-# SCC "layoutStack" #-}
75 runUniqSM $ cmmLayoutStack procPoints entry_off g
76 dump Opt_D_dump_cmmz_sp "Layout Stack" g
77
78 g <- if optLevel dflags >= 99
79 then do g <- {-# SCC "sink" #-} return (cmmSink g)
80 dump Opt_D_dump_cmmz_rewrite "Sink assignments" g
81 g <- {-# SCC "inline" #-} return (cmmPeepholeInline g)
82 dump Opt_D_dump_cmmz_rewrite "Peephole inline" g
83 return g
84 else return g
85
86 -- ----------- Sink and inline assignments -------------------
87 -- g <- {-# SCC "rewriteAssignments" #-} runOptimization $
88 -- rewriteAssignments platform g
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)
97 dumps Opt_D_dump_cmmz_split "Post splitting" gs
98
99 ------------- CAF analysis ------------------------------
100 let cafEnv = {-# SCC "cafAnal" #-} cafAnal g
101
102 ------------- Populate info tables with stack info ------
103 gs <- {-# SCC "setInfoTableStackMap" #-}
104 return $ map (setInfoTableStackMap stackmaps) gs
105 dumps Opt_D_dump_cmmz_info "after setInfoTableStackMap" gs
106
107 ----------- Control-flow optimisations -----------------
108 gs <- {-# SCC "cmmCfgOpts(2)" #-} return $ map cmmCfgOptsProc gs
109 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 dump = dumpGraph dflags
115
116 dumps flag name
117 = mapM_ (dumpWith dflags flag name)
118
119 runUniqSM :: UniqSM a -> IO a
120 runUniqSM m = do
121 us <- mkSplitUniqSupply 'u'
122 return (initUs_ us m)
123
124
125 dumpGraph :: DynFlags -> DynFlag -> String -> CmmGraph -> IO ()
126 dumpGraph dflags flag name g = do
127 when (dopt Opt_DoCmmLinting dflags) $ do_lint g
128 dumpWith dflags flag name g
129 where
130 do_lint g = case cmmLintGraph g of
131 Just err -> do { fatalErrorMsg dflags err
132 ; ghcExit dflags 1
133 }
134 Nothing -> return ()
135
136 dumpWith :: Outputable a => DynFlags -> DynFlag -> String -> a -> IO ()
137 dumpWith dflags flag txt g = do
138 -- ToDo: No easy way of say "dump all the cmmz, *and* split
139 -- them into files." Also, -ddump-cmmz doesn't play nicely
140 -- with -ddump-to-file, since the headers get omitted.
141 dumpIfSet_dyn dflags flag txt (ppr g)
142 when (not (dopt flag dflags)) $
143 dumpIfSet_dyn dflags Opt_D_dump_cmmz txt (ppr g)
144