2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
4 \section[SimplStg]{Driver for simplifying @STG@ programs}
7 module SimplStg ( stg2stg ) where
9 #include "HsVersions.h"
13 import LambdaLift ( liftProgram )
14 import CostCentre ( CostCentre, CostCentreStack )
15 import SCCfinal ( stgMassageForProfiling )
16 import StgLint ( lintStgBindings )
17 import StgStats ( showStgStats )
18 import StgVarInfo ( setStgVarInfo )
19 import SRT ( computeSRTs )
21 import CmdLineOpts ( DynFlags, DynFlag(..), dopt,
22 opt_StgDoLetNoEscapes,
23 StgToDo(..), dopt_StgToDo
26 import Module ( Module )
27 import ErrUtils ( doIfSet_dyn, dumpIfSet_dyn, showPass )
28 import UniqSupply ( mkSplitUniqSupply, splitUniqSupply, UniqSupply )
29 import IO ( hPutStr, stdout )
34 stg2stg :: DynFlags -- includes spec of what stg-to-stg passes to do
35 -> Module -- module name (profiling only)
36 -> UniqSupply -- a name supply
37 -> [StgBinding] -- input...
39 ([(StgBinding,[Id])], -- output program...
40 ([CostCentre], -- local cost-centres that need to be decl'd
41 [CostCentre], -- "extern" cost-centres
42 [CostCentreStack])) -- pre-defined "singleton" cost centre stacks
44 stg2stg dflags module_name us binds
45 = do { showPass dflags "Stg2Stg"
46 ; us <- mkSplitUniqSupply 'g'
48 ; doIfSet_dyn dflags Opt_D_verbose_stg2stg
49 (printDump (text "VERBOSE STG-TO-STG:"))
51 ; (binds', us', ccs) <- end_pass us "Core2Stg" ([],[],[]) binds
53 -- Do the main business!
54 ; (processed_binds, _, cost_centres)
55 <- foldl_mn do_stg_pass (binds', us', ccs)
58 -- Do essential wind-up
59 -- Essential wind-up: part (b), do setStgVarInfo. It has to
60 -- happen regardless, because the code generator uses its
63 -- Why does it have to happen last? Because earlier passes
64 -- may move things around, which would change the live-var
65 -- info. Also, setStgVarInfo decides about let-no-escape
66 -- things, which in turn do a better job if arities are
67 -- correct, which is done by satStgRhs.
70 ; let annotated_binds = setStgVarInfo opt_StgDoLetNoEscapes processed_binds
71 srt_binds = computeSRTs annotated_binds
73 ; dumpIfSet_dyn dflags Opt_D_dump_stg "STG syntax:"
74 (pprStgBindingsWithSRTs srt_binds)
76 ; return (srt_binds, cost_centres)
80 stg_linter = if dopt Opt_DoStgLinting dflags
82 else ( \ whodunnit binds -> binds )
84 -------------------------------------------
85 do_stg_pass (binds, us, ccs) to_do
87 (us1, us2) = splitUniqSupply us
90 StgDoStaticArgs -> panic "STG static argument transformation deleted"
93 trace (showStgStats binds)
94 end_pass us2 "StgStats" ccs binds
98 -- NB We have to do setStgVarInfo first!
100 binds3 = liftProgram module_name us1 (setStgVarInfo opt_StgDoLetNoEscapes binds)
102 end_pass us2 "LambdaLift" ccs binds3
104 StgDoMassageForProfiling ->
107 (collected_CCs, binds3)
108 = stgMassageForProfiling module_name us1 binds
110 end_pass us2 "ProfMassage" collected_CCs binds3
112 end_pass us2 what ccs binds2
113 = -- report verbosely, if required
114 (if dopt Opt_D_verbose_stg2stg dflags then
115 hPutStr stdout (showSDoc
116 (text ("*** "++what++":") $$ vcat (map ppr binds2)
120 linted_binds = stg_linter what binds2
122 return (linted_binds, us2, ccs)
123 -- return: processed binds
124 -- UniqueSupply for the next guy to use
125 -- cost-centres to be declared/registered (specialised)
126 -- add to description of what's happened (reverse order)
128 -- here so it can be inlined...
129 foldl_mn f z [] = return z
130 foldl_mn f z (x:xs) = f z x >>= \ zz ->