X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplStg%2FSimplStg.lhs;h=e87877cb4c72f3a208fcd26327eea8909b3e1ecd;hb=0a1d263163f12502405b191895fffe48e47b2dfc;hp=a14a2795214f411ab04ca786aa02bbcc66902b5b;hpb=bd8ead09270aec70f5495f1a2b20b6d2ea1ff44f;p=ghc-hetmet.git diff --git a/ghc/compiler/simplStg/SimplStg.lhs b/ghc/compiler/simplStg/SimplStg.lhs index a14a279..e87877c 100644 --- a/ghc/compiler/simplStg/SimplStg.lhs +++ b/ghc/compiler/simplStg/SimplStg.lhs @@ -1,113 +1,63 @@ % -% (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 ( CollectedCCs ) import SCCfinal ( stgMassageForProfiling ) import StgLint ( lintStgBindings ) import StgStats ( showStgStats ) -import StgVarInfo ( setStgVarInfo ) -import UpdAnal ( updateAnalyse ) - -import CmdLineOpts ( opt_SccGroup, --Not used:opt_EnsureSplittableC, - opt_StgDoLetNoEscapes, opt_D_verbose_stg2stg, - opt_DoStgLinting, - 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 UniqSupply ( splitUniqSupply, UniqSupply ) -import Util ( mapAccumL, panic, assertPanic ) +import SRT ( computeSRTs ) + +import Packages ( HomeModules ) +import DynFlags ( DynFlags(..), DynFlag(..), dopt, StgToDo(..), + getStgToDo ) +import Id ( Id ) +import Module ( Module ) +import ErrUtils ( doIfSet_dyn, dumpIfSet_dyn, showPass ) +import UniqSupply ( mkSplitUniqSupply, splitUniqSupply ) +import Outputable \end{code} \begin{code} -stg2stg :: [StgToDo] -- spec of what stg-to-stg passes to do - -> FAST_STRING -- 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 - -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)))) >> - - -- Do the main business! - foldl_mn do_stg_pass (binds, us4now, ([],[])) 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. - -- - -- Why does it have to happen last? Because earlier passes - -- may move things around, which would change the live-var - -- info. Also, setStgVarInfo decides about let-no-escape - -- things, which in turn do a better job if arities are - -- correct, which is done by satStgRhs. - -- - - return (setStgVarInfo do_let_no_escapes processed_binds, cost_centres) +stg2stg :: DynFlags -- includes spec of what stg-to-stg passes to do + -> HomeModules + -> Module -- module name (profiling only) + -> [StgBinding] -- input... + -> IO ( [(StgBinding,[(Id,[Id])])] -- output program... + , CollectedCCs) -- cost centre information (declared and used) + +stg2stg dflags pkg_deps module_name binds + = do { showPass dflags "Stg2Stg" + ; us <- mkSplitUniqSupply 'g' + + ; doIfSet_dyn dflags Opt_D_verbose_stg2stg + (printDump (text "VERBOSE STG-TO-STG:")) + + ; (binds', us', ccs) <- end_pass us "Stg2Stg" ([],[],[]) binds + + -- Do the main business! + ; (processed_binds, _, cost_centres) + <- foldl_mn do_stg_pass (binds', us', ccs) (getStgToDo dflags) + + ; let srt_binds = computeSRTs processed_binds + + ; dumpIfSet_dyn dflags 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 dopt Opt_DoStgLinting dflags + then lintStgBindings else ( \ whodunnit binds -> binds ) ------------------------------------------- @@ -116,48 +66,24 @@ stg2stg stg_todos module_name us binds (us1, us2) = splitUniqSupply us in 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 - StgDoLambdaLift -> - _scc_ "StgLambdaLift" - -- NB We have to do setStgVarInfo first! - let - binds3 = liftProgram module_name us1 (setStgVarInfo do_let_no_escapes binds) - in - end_pass us2 "LambdaLift" ccs binds3 - StgDoMassageForProfiling -> - _scc_ "ProfMassage" + {-# SCC "ProfMassage" #-} let (collected_CCs, binds3) - = stgMassageForProfiling module_name grp_name us1 binds + = stgMassageForProfiling pkg_deps 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)) - )) - else return ()) >> - let - linted_binds = stg_linter what binds2 - in - return (linted_binds, us2, ccs) + = do -- report verbosely, if required + dumpIfSet_dyn dflags Opt_D_verbose_stg2stg what + (vcat (map ppr binds2)) + let linted_binds = stg_linter what binds2 + return (linted_binds, us2, ccs) -- return: processed binds -- UniqueSupply for the next guy to use -- cost-centres to be declared/registered (specialised)