2af53e48776c07101941d0789105a59b0e431f19
[ghc.git] / compiler / simplStg / SimplStg.hs
1 {-
2 (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
3
4 \section[SimplStg]{Driver for simplifying @STG@ programs}
5 -}
6
7 {-# LANGUAGE CPP #-}
8
9 module SimplStg ( stg2stg ) where
10
11 #include "HsVersions.h"
12
13 import GhcPrelude
14
15 import StgSyn
16
17 import CostCentre ( CollectedCCs )
18 import SCCfinal ( stgMassageForProfiling )
19 import StgLint ( lintStgTopBindings )
20 import StgStats ( showStgStats )
21 import UnariseStg ( unarise )
22 import StgCse ( stgCse )
23
24 import DynFlags
25 import Module ( Module )
26 import ErrUtils
27 import SrcLoc
28 import UniqSupply ( mkSplitUniqSupply, splitUniqSupply )
29 import Outputable
30 import Control.Monad
31
32 stg2stg :: DynFlags -- includes spec of what stg-to-stg passes to do
33 -> Module -- module name (profiling only)
34 -> [StgTopBinding] -- input...
35 -> IO ( [StgTopBinding] -- output program...
36 , CollectedCCs) -- cost centre information (declared and used)
37
38 stg2stg dflags module_name binds
39 = do { showPass dflags "Stg2Stg"
40 ; us <- mkSplitUniqSupply 'g'
41
42 ; when (dopt Opt_D_verbose_stg2stg dflags)
43 (putLogMsg dflags NoReason SevDump noSrcSpan
44 (defaultDumpStyle dflags) (text "VERBOSE STG-TO-STG:"))
45
46 ; (binds', us', ccs) <- end_pass us "Stg2Stg" ([],[]) binds
47
48 -- Do the main business!
49 ; let (us0, us1) = splitUniqSupply us'
50 ; (processed_binds, _, cost_centres)
51 <- foldM do_stg_pass (binds', us0, ccs) (getStgToDo dflags)
52
53 ; dumpIfSet_dyn dflags Opt_D_dump_stg "Pre unarise:"
54 (pprStgTopBindings processed_binds)
55
56 ; let un_binds = stg_linter True "Unarise"
57 $ unarise us1 processed_binds
58
59 ; dumpIfSet_dyn dflags Opt_D_dump_stg "STG syntax:"
60 (pprStgTopBindings un_binds)
61
62 ; return (un_binds, cost_centres)
63 }
64
65 where
66 stg_linter unarised
67 | gopt Opt_DoStgLinting dflags = lintStgTopBindings unarised
68 | otherwise = \ _whodunnit binds -> binds
69
70 -------------------------------------------
71 do_stg_pass (binds, us, ccs) to_do
72 = case to_do of
73 D_stg_stats ->
74 trace (showStgStats binds)
75 end_pass us "StgStats" ccs binds
76
77 StgDoMassageForProfiling ->
78 {-# SCC "ProfMassage" #-}
79 let
80 (us1, us2) = splitUniqSupply us
81 (collected_CCs, binds3)
82 = stgMassageForProfiling dflags module_name us1 binds
83 in
84 end_pass us2 "ProfMassage" collected_CCs binds3
85
86 StgCSE ->
87 {-# SCC "StgCse" #-}
88 let
89 binds' = stgCse binds
90 in
91 end_pass us "StgCse" ccs binds'
92
93 end_pass us2 what ccs binds2
94 = do -- report verbosely, if required
95 dumpIfSet_dyn dflags Opt_D_verbose_stg2stg what
96 (vcat (map ppr binds2))
97 let linted_binds = stg_linter False what binds2
98 return (linted_binds, us2, ccs)
99 -- return: processed binds
100 -- UniqueSupply for the next guy to use
101 -- cost-centres to be declared/registered (specialised)
102 -- add to description of what's happened (reverse order)
103
104 -- -----------------------------------------------------------------------------
105 -- StgToDo: abstraction of stg-to-stg passes to run.
106
107 -- | Optional Stg-to-Stg passes.
108 data StgToDo
109 = StgCSE
110 | StgDoMassageForProfiling -- should be (next to) last
111 | D_stg_stats
112
113 -- | Which optional Stg-to-Stg passes to run. Depends on flags, ways etc.
114 getStgToDo :: DynFlags -> [StgToDo]
115 getStgToDo dflags
116 = [ StgCSE | gopt Opt_StgCSE dflags] ++
117 [ StgDoMassageForProfiling | WayProf `elem` ways dflags] ++
118 [ D_stg_stats | stg_stats ]
119 where
120 stg_stats = gopt Opt_StgStats dflags