Collect CCs in CorePrep, including CCs in unfoldings
[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 StgLint ( lintStgTopBindings )
18 import StgStats ( showStgStats )
19 import UnariseStg ( unarise )
20 import StgCse ( stgCse )
21
22 import DynFlags
23 import ErrUtils
24 import SrcLoc
25 import UniqSupply ( mkSplitUniqSupply )
26 import Outputable
27 import Control.Monad
28
29 stg2stg :: DynFlags -- includes spec of what stg-to-stg passes to do
30 -> [StgTopBinding] -- input...
31 -> IO [StgTopBinding] -- output program
32
33 stg2stg dflags binds
34 = do { showPass dflags "Stg2Stg"
35 ; us <- mkSplitUniqSupply 'g'
36
37 ; when (dopt Opt_D_verbose_stg2stg dflags)
38 (putLogMsg dflags NoReason SevDump noSrcSpan
39 (defaultDumpStyle dflags) (text "VERBOSE STG-TO-STG:"))
40
41 ; binds' <- end_pass "Stg2Stg" binds
42
43 -- Do the main business!
44 ; processed_binds <- foldM do_stg_pass binds' (getStgToDo dflags)
45
46 ; dumpIfSet_dyn dflags Opt_D_dump_stg "Pre unarise:"
47 (pprStgTopBindings processed_binds)
48
49 ; let un_binds = stg_linter True "Unarise"
50 $ unarise us processed_binds
51
52 ; dumpIfSet_dyn dflags Opt_D_dump_stg "STG syntax:"
53 (pprStgTopBindings un_binds)
54
55 ; return un_binds
56 }
57
58 where
59 stg_linter unarised
60 | gopt Opt_DoStgLinting dflags = lintStgTopBindings unarised
61 | otherwise = \ _whodunnit binds -> binds
62
63 -------------------------------------------
64 do_stg_pass binds to_do
65 = case to_do of
66 D_stg_stats ->
67 trace (showStgStats binds)
68 end_pass "StgStats" binds
69
70 StgCSE ->
71 {-# SCC "StgCse" #-}
72 let
73 binds' = stgCse binds
74 in
75 end_pass "StgCse" binds'
76
77 end_pass what binds2
78 = do -- report verbosely, if required
79 dumpIfSet_dyn dflags Opt_D_verbose_stg2stg what
80 (vcat (map ppr binds2))
81 return (stg_linter False what binds2)
82
83 -- -----------------------------------------------------------------------------
84 -- StgToDo: abstraction of stg-to-stg passes to run.
85
86 -- | Optional Stg-to-Stg passes.
87 data StgToDo
88 = StgCSE
89 | D_stg_stats
90
91 -- | Which optional Stg-to-Stg passes to run. Depends on flags, ways etc.
92 getStgToDo :: DynFlags -> [StgToDo]
93 getStgToDo dflags
94 = [ StgCSE | gopt Opt_StgCSE dflags] ++
95 [ D_stg_stats | stg_stats ]
96 where
97 stg_stats = gopt Opt_StgStats dflags