2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
4 \section[SimplStg]{Driver for simplifying @STG@ programs}
7 module SimplStg ( stg2stg ) where
9 -- XXX This define is a bit of a hack, and should be done more nicely
10 #define FAST_STRING_NOT_NEEDED 1
11 #include "HsVersions.h"
15 import CostCentre ( CollectedCCs )
16 import SCCfinal ( stgMassageForProfiling )
17 import StgLint ( lintStgBindings )
18 import StgStats ( showStgStats )
19 import SRT ( computeSRTs )
21 import DynFlags ( DynFlags(..), DynFlag(..), dopt, StgToDo(..),
24 import Module ( Module )
25 import ErrUtils ( doIfSet_dyn, dumpIfSet_dyn, showPass )
26 import UniqSupply ( mkSplitUniqSupply, splitUniqSupply )
31 stg2stg :: DynFlags -- includes spec of what stg-to-stg passes to do
32 -> Module -- module name (profiling only)
33 -> [StgBinding] -- input...
34 -> IO ( [(StgBinding,[(Id,[Id])])] -- output program...
35 , CollectedCCs) -- cost centre information (declared and used)
37 stg2stg dflags module_name binds
38 = do { showPass dflags "Stg2Stg"
39 ; us <- mkSplitUniqSupply 'g'
41 ; doIfSet_dyn dflags Opt_D_verbose_stg2stg
42 (printDump (text "VERBOSE STG-TO-STG:"))
44 ; (binds', us', ccs) <- end_pass us "Stg2Stg" ([],[],[]) binds
46 -- Do the main business!
47 ; (processed_binds, _, cost_centres)
48 <- foldl_mn do_stg_pass (binds', us', ccs) (getStgToDo dflags)
50 ; let srt_binds = computeSRTs processed_binds
52 ; dumpIfSet_dyn dflags Opt_D_dump_stg "STG syntax:"
53 (pprStgBindingsWithSRTs srt_binds)
55 ; return (srt_binds, cost_centres)
59 stg_linter = if dopt Opt_DoStgLinting dflags
61 else ( \ _whodunnit binds -> binds )
63 -------------------------------------------
64 do_stg_pass (binds, us, ccs) to_do
66 (us1, us2) = splitUniqSupply us
70 trace (showStgStats binds)
71 end_pass us2 "StgStats" ccs binds
73 StgDoMassageForProfiling ->
74 {-# SCC "ProfMassage" #-}
76 (collected_CCs, binds3)
77 = stgMassageForProfiling this_pkg module_name us1 binds
78 this_pkg = thisPackage dflags
80 end_pass us2 "ProfMassage" collected_CCs binds3
82 end_pass us2 what ccs binds2
83 = do -- report verbosely, if required
84 dumpIfSet_dyn dflags Opt_D_verbose_stg2stg what
85 (vcat (map ppr binds2))
86 let linted_binds = stg_linter what binds2
87 return (linted_binds, us2, ccs)
88 -- return: processed binds
89 -- UniqueSupply for the next guy to use
90 -- cost-centres to be declared/registered (specialised)
91 -- add to description of what's happened (reverse order)
93 -- here so it can be inlined...
94 foldl_mn :: (b -> a -> IO b) -> b -> [a] -> IO b
95 foldl_mn _ z [] = return z
96 foldl_mn f z (x:xs) = f z x >>= \ zz ->