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
-> Module
-> [StgTopBinding]
-> IO ( [StgTopBinding]
, CollectedCCs)
stg2stg dflags module_name binds
= do { showPass dflags "Stg2Stg"
; us <- mkSplitUniqSupply 'g'
; when (dopt Opt_D_verbose_stg2stg dflags)
(putLogMsg dflags NoReason SevDump noSrcSpan
(defaultDumpStyle dflags) (text "VERBOSE STG-TO-STG:"))
; (binds', us', ccs) <- end_pass us "Stg2Stg" ([],[],[]) binds
; 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 ->
let
(us1, us2) = splitUniqSupply us
(collected_CCs, binds3)
= stgMassageForProfiling dflags module_name us1 binds
in
end_pass us2 "ProfMassage" collected_CCs binds3
StgCSE ->
let
binds' = stgCse binds
in
end_pass us "StgCse" ccs binds'
end_pass us2 what ccs binds2
= do
dumpIfSet_dyn dflags Opt_D_verbose_stg2stg what
(vcat (map ppr binds2))
let linted_binds = stg_linter what binds2
return (linted_binds, us2, ccs)
data StgToDo
= StgCSE
| StgDoMassageForProfiling
| D_stg_stats
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