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