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