2 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
4 \section[SimplStg]{Driver for simplifying @STG@ programs}
8 -- The above warning supression flag is a temporary kludge.
9 -- While working on this module you are encouraged to remove it and fix
10 -- any warnings in the module. See
11 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
14 module SimplStg ( stg2stg ) where
16 #include "HsVersions.h"
20 import CostCentre ( CollectedCCs )
21 import SCCfinal ( stgMassageForProfiling )
22 import StgLint ( lintStgBindings )
23 import StgStats ( showStgStats )
24 import SRT ( computeSRTs )
26 import DynFlags ( DynFlags(..), DynFlag(..), dopt, StgToDo(..),
29 import Module ( Module )
30 import ErrUtils ( doIfSet_dyn, dumpIfSet_dyn, showPass )
31 import UniqSupply ( mkSplitUniqSupply, splitUniqSupply )
36 stg2stg :: DynFlags -- includes spec of what stg-to-stg passes to do
37 -> Module -- module name (profiling only)
38 -> [StgBinding] -- input...
39 -> IO ( [(StgBinding,[(Id,[Id])])] -- output program...
40 , CollectedCCs) -- cost centre information (declared and used)
42 stg2stg dflags module_name binds
43 = do { showPass dflags "Stg2Stg"
44 ; us <- mkSplitUniqSupply 'g'
46 ; doIfSet_dyn dflags Opt_D_verbose_stg2stg
47 (printDump (text "VERBOSE STG-TO-STG:"))
49 ; (binds', us', ccs) <- end_pass us "Stg2Stg" ([],[],[]) binds
51 -- Do the main business!
52 ; (processed_binds, _, cost_centres)
53 <- foldl_mn do_stg_pass (binds', us', ccs) (getStgToDo dflags)
55 ; let srt_binds = computeSRTs processed_binds
57 ; dumpIfSet_dyn dflags Opt_D_dump_stg "STG syntax:"
58 (pprStgBindingsWithSRTs srt_binds)
60 ; return (srt_binds, cost_centres)
64 stg_linter = if dopt Opt_DoStgLinting dflags
66 else ( \ whodunnit binds -> binds )
68 -------------------------------------------
69 do_stg_pass (binds, us, ccs) to_do
71 (us1, us2) = splitUniqSupply us
75 trace (showStgStats binds)
76 end_pass us2 "StgStats" ccs binds
78 StgDoMassageForProfiling ->
79 {-# SCC "ProfMassage" #-}
81 (collected_CCs, binds3)
82 = stgMassageForProfiling this_pkg module_name us1 binds
83 this_pkg = thisPackage dflags
85 end_pass us2 "ProfMassage" collected_CCs binds3
87 end_pass us2 what ccs binds2
88 = do -- report verbosely, if required
89 dumpIfSet_dyn dflags Opt_D_verbose_stg2stg what
90 (vcat (map ppr binds2))
91 let linted_binds = stg_linter what binds2
92 return (linted_binds, us2, ccs)
93 -- return: processed binds
94 -- UniqueSupply for the next guy to use
95 -- cost-centres to be declared/registered (specialised)
96 -- add to description of what's happened (reverse order)
98 -- here so it can be inlined...
99 foldl_mn f z [] = return z
100 foldl_mn f z (x:xs) = f z x >>= \ zz ->