Print which warning-flag controls an emitted warning
[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 StgSyn
14
15 import CostCentre ( CollectedCCs )
16 import SCCfinal ( stgMassageForProfiling )
17 import StgLint ( lintStgBindings )
18 import StgStats ( showStgStats )
19 import UnariseStg ( unarise )
20
21 import DynFlags
22 import Module ( Module )
23 import ErrUtils
24 import SrcLoc
25 import UniqSupply ( mkSplitUniqSupply, splitUniqSupply )
26 import Outputable
27 import Control.Monad
28
29 stg2stg :: DynFlags -- includes spec of what stg-to-stg passes to do
30 -> Module -- module name (profiling only)
31 -> [StgBinding] -- input...
32 -> IO ( [StgBinding] -- output program...
33 , CollectedCCs) -- cost centre information (declared and used)
34
35 stg2stg dflags module_name binds
36 = do { showPass dflags "Stg2Stg"
37 ; us <- mkSplitUniqSupply 'g'
38
39 ; when (dopt Opt_D_verbose_stg2stg dflags)
40 (log_action dflags dflags NoReason SevDump noSrcSpan defaultDumpStyle (text "VERBOSE STG-TO-STG:"))
41
42 ; (binds', us', ccs) <- end_pass us "Stg2Stg" ([],[],[]) binds
43
44 -- Do the main business!
45 ; let (us0, us1) = splitUniqSupply us'
46 ; (processed_binds, _, cost_centres)
47 <- foldM do_stg_pass (binds', us0, ccs) (getStgToDo dflags)
48
49 ; let un_binds = unarise us1 processed_binds
50
51 ; dumpIfSet_dyn dflags Opt_D_dump_stg "STG syntax:"
52 (pprStgBindings un_binds)
53
54 ; return (un_binds, cost_centres)
55 }
56
57 where
58 stg_linter = if gopt Opt_DoStgLinting dflags
59 then lintStgBindings
60 else ( \ _whodunnit binds -> binds )
61
62 -------------------------------------------
63 do_stg_pass (binds, us, ccs) to_do
64 = let
65 (us1, us2) = splitUniqSupply us
66 in
67 case to_do of
68 D_stg_stats ->
69 trace (showStgStats binds)
70 end_pass us2 "StgStats" ccs binds
71
72 StgDoMassageForProfiling ->
73 {-# SCC "ProfMassage" #-}
74 let
75 (collected_CCs, binds3)
76 = stgMassageForProfiling dflags module_name us1 binds
77 in
78 end_pass us2 "ProfMassage" collected_CCs binds3
79
80 end_pass us2 what ccs binds2
81 = do -- report verbosely, if required
82 dumpIfSet_dyn dflags Opt_D_verbose_stg2stg what
83 (vcat (map ppr binds2))
84 let linted_binds = stg_linter what binds2
85 return (linted_binds, us2, ccs)
86 -- return: processed binds
87 -- UniqueSupply for the next guy to use
88 -- cost-centres to be declared/registered (specialised)
89 -- add to description of what's happened (reverse order)
90
91 -- -----------------------------------------------------------------------------
92 -- StgToDo: abstraction of stg-to-stg passes to run.
93
94 -- | Optional Stg-to-Stg passes.
95 data StgToDo
96 = StgDoMassageForProfiling -- should be (next to) last
97 | D_stg_stats
98
99 -- | Which optional Stg-to-Stg passes to run. Depends on flags, ways etc.
100 getStgToDo :: DynFlags -> [StgToDo]
101 getStgToDo dflags
102 = todo2
103 where
104 stg_stats = gopt Opt_StgStats dflags
105
106 todo1 = if stg_stats then [D_stg_stats] else []
107
108 todo2 | WayProf `elem` ways dflags
109 = StgDoMassageForProfiling : todo1
110 | otherwise
111 = todo1