X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplStg%2FSimplStg.lhs;h=2b579987d53c1779d7cffdb46c703d6fb73fd4e9;hb=7558fd1e56bd50a251a26066ec92e39f56d8fa9d;hp=a14a2795214f411ab04ca786aa02bbcc66902b5b;hpb=bd8ead09270aec70f5495f1a2b20b6d2ea1ff44f;p=ghc-hetmet.git diff --git a/ghc/compiler/simplStg/SimplStg.lhs b/ghc/compiler/simplStg/SimplStg.lhs index a14a279..2b57998 100644 --- a/ghc/compiler/simplStg/SimplStg.lhs +++ b/ghc/compiler/simplStg/SimplStg.lhs @@ -1,83 +1,61 @@ % -% (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} \begin{code} -#include "HsVersions.h" - module SimplStg ( stg2stg ) where -IMP_Ubiq(){-uitous-} -IMPORT_1_3(IO(hPutStr,stderr)) +#include "HsVersions.h" 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, - opt_StgDoLetNoEscapes, opt_D_verbose_stg2stg, - opt_DoStgLinting, +import CmdLineOpts ( opt_StgDoLetNoEscapes, opt_D_verbose_stg2stg, + opt_DoStgLinting, opt_D_dump_stg, StgToDo(..) ) -import Id ( nullIdEnv, lookupIdEnv, addOneToIdEnv, - growIdEnvList, isNullIdEnv, SYN_IE(IdEnv), - GenId{-instance Eq/Outputable -}, SYN_IE(Id) - ) -import Maybes ( maybeToBool ) -import PprType ( GenType{-instance Outputable-} ) -import ErrUtils ( doIfSet ) -import Outputable ( PprStyle, Outputable(..), printErrs, pprDumpStyle ) -import Pretty ( Doc, ($$), vcat, text, ptext ) +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 \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 pprDumpStyle) (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. @@ -89,25 +67,20 @@ stg2stg stg_todos module_name us binds -- 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 - - ------------- - stg_linter = if False --LATER: opt_DoStgLinting (ToDo) - then lintStgBindings pprDumpStyle + stg_linter = if opt_DoStgLinting + then lintStgBindings else ( \ whodunnit binds -> binds ) ------------------------------------------- @@ -118,14 +91,6 @@ stg2stg stg_todos module_name us binds case to_do of 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, - -- because update analysis doesn't care. - end_pass us2 "UpdAnal" ccs (updateAnalyse (setStgVarInfo False binds)) - D_stg_stats -> trace (showStgStats binds) end_pass us2 "StgStats" ccs binds @@ -134,7 +99,7 @@ stg2stg stg_todos module_name us binds _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 @@ -142,16 +107,15 @@ stg2stg stg_todos module_name us binds _scc_ "ProfMassage" let (collected_CCs, binds3) - = stgMassageForProfiling module_name grp_name us1 binds + = stgMassageForProfiling module_name us1 binds in end_pass us2 "ProfMassage" collected_CCs binds3 end_pass us2 what ccs binds2 = -- report verbosely, if required - (if do_verbose_stg2stg then - hPutStr stderr (show - (($$) (text ("*** "++what++":")) - (vcat (map (ppr pprDumpStyle) binds2)) + (if opt_D_verbose_stg2stg then + hPutStr stderr (showSDoc + (text ("*** "++what++":") $$ vcat (map ppr binds2) )) else return ()) >> let