%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
\section[SimplStg]{Driver for simplifying @STG@ programs}
import StgSyn
import LambdaLift ( liftProgram )
-import Name ( isLocallyDefined )
-import UniqSet ( UniqSet(..), mapUniqSet )
-import CostCentre ( CostCentre )
+import CostCentre ( CostCentre, CostCentreStack )
import SCCfinal ( stgMassageForProfiling )
import StgLint ( lintStgBindings )
import StgStats ( showStgStats )
import StgVarInfo ( setStgVarInfo )
import UpdAnal ( updateAnalyse )
+import SRT ( computeSRTs )
-import CmdLineOpts ( opt_SccGroup, --Not used:opt_EnsureSplittableC,
+import CmdLineOpts ( opt_SccGroup,
opt_StgDoLetNoEscapes, opt_D_verbose_stg2stg,
- opt_DoStgLinting,
+ opt_DoStgLinting, opt_D_dump_stg,
StgToDo(..)
)
-import Id ( nullIdEnv, lookupIdEnv, addOneToIdEnv,
- growIdEnvList, isNullIdEnv, IdEnv,
- GenId{-instance Eq/Outputable -}, Id
- )
-import Maybes ( maybeToBool )
-import PprType ( GenType{-instance Outputable-} )
-import ErrUtils ( doIfSet )
+import Id ( Id )
+import Module ( Module, moduleString )
+import VarEnv
+import ErrUtils ( doIfSet, dumpIfSet )
import UniqSupply ( splitUniqSupply, UniqSupply )
-import Util ( mapAccumL, panic, assertPanic )
import IO ( hPutStr, stderr )
import Outputable
-import GlaExts ( trace )
\end{code}
\begin{code}
stg2stg :: [StgToDo] -- spec of what stg-to-stg passes to do
- -> FAST_STRING -- module name (profiling only)
+ -> Module -- module name (profiling only)
-> UniqSupply -- a name supply
-> [StgBinding] -- input...
-> IO
- ([StgBinding], -- output program...
- ([CostCentre], -- local cost-centres that need to be decl'd
- [CostCentre])) -- "extern" cost-centres
+ ([(StgBinding,[Id])], -- output program...
+ ([CostCentre], -- local cost-centres that need to be decl'd
+ [CostCentre], -- "extern" cost-centres
+ [CostCentreStack])) -- pre-defined "singleton" cost centre stacks
stg2stg stg_todos module_name us binds
= case (splitUniqSupply us) of { (us4now, us4later) ->
- doIfSet do_verbose_stg2stg
- (printErrs (text "VERBOSE STG-TO-STG:" $$
- text "*** Core2Stg:" $$
- vcat (map ppr (setStgVarInfo False binds)))) >>
+ doIfSet opt_D_verbose_stg2stg (printErrs (text "VERBOSE STG-TO-STG:")) >>
+
+ end_pass us4now "Core2Stg" ([],[],[]) binds
+ >>= \ (binds', us, ccs) ->
-- Do the main business!
- foldl_mn do_stg_pass (binds, us4now, ([],[])) stg_todos
+ foldl_mn do_stg_pass (binds', us, ccs) stg_todos
>>= \ (processed_binds, _, cost_centres) ->
-- Do essential wind-up
-{- Nuked for now SLPJ Dec 96
-
- -- Essential wind-up: part (a), saturate RHSs
- -- This must occur *after* elimIndirections, because elimIndirections
- -- can change things' arities. Consider:
- -- x_local = f x
- -- x_global = \a -> x_local a
- -- Then elimIndirections will change the program to
- -- x_global = f x
- -- and lo and behold x_global's arity has changed!
- case (satStgRhs processed_binds us4later) of { saturated_binds ->
--}
-
-- Essential wind-up: part (b), do setStgVarInfo. It has to
-- happen regardless, because the code generator uses its
-- decorations.
-- correct, which is done by satStgRhs.
--
- return (setStgVarInfo do_let_no_escapes processed_binds, cost_centres)
+ let
+ annotated_binds = setStgVarInfo opt_StgDoLetNoEscapes processed_binds
+ srt_binds = computeSRTs annotated_binds
+ in
+
+ dumpIfSet opt_D_dump_stg "STG syntax:"
+ (pprStgBindingsWithSRTs srt_binds) >>
+
+ return (srt_binds, cost_centres)
}
+
where
- do_let_no_escapes = opt_StgDoLetNoEscapes
- do_verbose_stg2stg = opt_D_verbose_stg2stg
-
-{-
- (do_unlocalising, unlocal_tag)
- = case opt_EnsureSplittableC of
- Just tag -> (True, _PK_ tag)
- Nothing -> (False, panic "tag")
--}
grp_name = case (opt_SccGroup) of
Just xx -> _PK_ xx
- Nothing -> module_name -- default: module name
+ Nothing -> _PK_ (moduleString module_name) -- default: module name
-------------
- stg_linter = if False --LATER: opt_DoStgLinting (ToDo)
+ stg_linter = if opt_DoStgLinting
then lintStgBindings
else ( \ whodunnit binds -> binds )
StgDoStaticArgs -> panic "STG static argument transformation deleted"
StgDoUpdateAnalysis ->
- ASSERT(null (fst ccs) && null (snd ccs))
_scc_ "StgUpdAnal"
-- NB We have to do setStgVarInfo first! (There's one
-- place free-var info is used) But no let-no-escapes,
_scc_ "StgLambdaLift"
-- NB We have to do setStgVarInfo first!
let
- binds3 = liftProgram module_name us1 (setStgVarInfo do_let_no_escapes binds)
+ binds3 = liftProgram module_name us1 (setStgVarInfo opt_StgDoLetNoEscapes binds)
in
end_pass us2 "LambdaLift" ccs binds3
end_pass us2 what ccs binds2
= -- report verbosely, if required
- (if do_verbose_stg2stg then
+ (if opt_D_verbose_stg2stg then
hPutStr stderr (showSDoc
(text ("*** "++what++":") $$ vcat (map ppr binds2)
))
projects / ghc-hetmet.git / blobdiff