X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplStg%2FSimplStg.lhs;h=bdb8c761c8d99583d8f5d4e5e600d99fa9639b72;hb=ef5b4b146aa172d8ac10f39b5eb3d7a0f948d8f1;hp=48ac2b65010aee428c7cbeae8f5091851377aba0;hpb=7b0181919416d8f04324575b7e17031ca692f5b0;p=ghc-hetmet.git diff --git a/ghc/compiler/simplStg/SimplStg.lhs b/ghc/compiler/simplStg/SimplStg.lhs index 48ac2b6..bdb8c76 100644 --- a/ghc/compiler/simplStg/SimplStg.lhs +++ b/ghc/compiler/simplStg/SimplStg.lhs @@ -1,126 +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 -import Ubiq{-uitous-} +#include "HsVersions.h" import StgSyn -import StgUtils -import LambdaLift ( liftProgram ) -import Name ( isLocallyDefined ) +import CostCentre ( CollectedCCs ) import SCCfinal ( stgMassageForProfiling ) -import SatStgRhs ( satStgRhs ) import StgLint ( lintStgBindings ) -import StgSAT ( doStaticArgs ) import StgStats ( showStgStats ) -import StgVarInfo ( setStgVarInfo ) -import UpdAnal ( updateAnalyse ) +import SRT ( computeSRTs ) -import CmdLineOpts ( opt_EnsureSplittableC, opt_SccGroup, - opt_StgDoLetNoEscapes, opt_D_verbose_stg2stg, - StgToDo(..) - ) -import Id ( nullIdEnv, lookupIdEnv, addOneToIdEnv, - growIdEnvList, isNullIdEnv, IdEnv(..), - GenId{-instance Eq/Outputable -} +import CmdLineOpts ( DynFlags, DynFlag(..), dopt, + StgToDo(..), dopt_StgToDo ) -import MainMonad ( writeMn, thenMn_, thenMn, returnMn, MainIO(..) ) -import Maybes ( maybeToBool ) -import Name ( isExported ) -import PprType ( GenType{-instance Outputable-} ) -import Pretty ( ppShow, ppAbove, ppAboves, ppStr ) -import UniqSupply ( splitUniqSupply ) -import Util ( mapAccumL, panic, assertPanic ) - -unlocaliseId = panic "SimplStg.unlocaliseId (ToDo)" +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) - -> PprStyle -- printing style (for debugging only) - -> UniqSupply -- a name supply - -> [StgBinding] -- input... - -> MainIO - ([StgBinding], -- output program... - ([CostCentre], -- local cost-centres that need to be decl'd - [CostCentre])) -- "extern" cost-centres - -stg2stg stg_todos module_name ppr_style us binds - = BSCC("Stg2Stg") - case (splitUniqSupply us) of { (us4now, us4later) -> +stg2stg :: DynFlags -- includes spec of what stg-to-stg passes to do + -> Module -- module name (profiling only) + -> [StgBinding] -- input... + -> IO ( [(StgBinding,[(Id,[Id])])] -- output program... + , CollectedCCs) -- cost centre information (declared and used) - (if do_verbose_stg2stg then - writeMn stderr "VERBOSE STG-TO-STG:\n" `thenMn_` - writeMn stderr (ppShow 1000 - (ppAbove (ppStr ("*** Core2Stg:")) - (ppAboves (map (ppr ppr_style) (setStgVarInfo False binds))) - )) - else returnMn ()) `thenMn_` +stg2stg dflags module_name binds + = do { showPass dflags "Stg2Stg" + ; us <- mkSplitUniqSupply 'g' - -- Do the main business! - foldl_mn do_stg_pass (binds, us4now, ([],[])) stg_todos - `thenMn` \ (processed_binds, _, cost_centres) -> - -- Do essential wind-up: part (a) is SatStgRhs + ; doIfSet_dyn dflags Opt_D_verbose_stg2stg + (printDump (text "VERBOSE STG-TO-STG:")) - -- Not optional, because correct arity information is used by - -- the code generator. Afterwards do setStgVarInfo; it gives - -- the wrong answers if arities are subsequently changed, - -- which stgSatRhs might do. Furthermore, setStgVarInfo - -- decides about let-no-escape things, which in turn do a - -- better job if arities are correct, which is done by - -- satStgRhs. + ; (binds', us', ccs) <- end_pass us "Stg2Stg" ([],[],[]) binds - case (satStgRhs processed_binds us4later) of { saturated_binds -> + -- Do the main business! + ; (processed_binds, _, cost_centres) + <- foldl_mn do_stg_pass (binds', us', ccs) + (dopt_StgToDo dflags) - -- Essential wind-up: part (b), eliminate indirections + ; let srt_binds = computeSRTs processed_binds - let no_ind_binds = elimIndirections saturated_binds in + ; dumpIfSet_dyn dflags Opt_D_dump_stg "STG syntax:" + (pprStgBindingsWithSRTs srt_binds) + ; return (srt_binds, cost_centres) + } - -- Essential wind-up: part (c), 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. - -- - let - -- ToDo: provide proper flag control! - binds_to_mangle - = if not do_unlocalising - then no_ind_binds - else snd (unlocaliseStgBinds unlocal_tag nullIdEnv no_ind_binds) - in - returnMn (setStgVarInfo do_let_no_escapes binds_to_mangle, cost_centres) - }} - ESCC where - do_let_no_escapes = opt_StgDoLetNoEscapes - do_verbose_stg2stg = opt_D_verbose_stg2stg - - (do_unlocalising, unlocal_tag) - = case (opt_EnsureSplittableC) of - Nothing -> (False, panic "tag") - Just tag -> (True, tag) - - grp_name = case (opt_SccGroup) of - Just xx -> xx - Nothing -> module_name -- default: module name - - ------------- - stg_linter = if False -- LATER: switch_is_on DoCoreLinting -- ToDo: DoStgLinting flag - then lintStgBindings ppr_style + stg_linter = if dopt Opt_DoStgLinting dflags + then lintStgBindings else ( \ whodunnit binds -> binds ) ------------------------------------------- @@ -129,230 +66,31 @@ stg2stg stg_todos module_name ppr_style us binds (us1, us2) = splitUniqSupply us in case to_do of - StgDoStaticArgs -> - ASSERT(null (fst ccs) && null (snd ccs)) - BSCC("StgStaticArgs") - let - binds3 = doStaticArgs binds us1 - in - end_pass us2 "StgStaticArgs" ccs binds3 - ESCC - - StgDoUpdateAnalysis -> - ASSERT(null (fst ccs) && null (snd ccs)) - BSCC("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)) - ESCC - D_stg_stats -> trace (showStgStats binds) end_pass us2 "StgStats" ccs binds - StgDoLambdaLift -> - BSCC("StgLambdaLift") - -- NB We have to do setStgVarInfo first! - let - binds3 = liftProgram us1 (setStgVarInfo do_let_no_escapes binds) - in - end_pass us2 "LambdaLift" ccs binds3 - ESCC - StgDoMassageForProfiling -> - BSCC("ProfMassage") + _scc_ "ProfMassage" let (collected_CCs, binds3) - = stgMassageForProfiling module_name grp_name us1 binds + = stgMassageForProfiling dflags module_name us1 binds in end_pass us2 "ProfMassage" collected_CCs binds3 - ESCC end_pass us2 what ccs binds2 - = -- report verbosely, if required - (if do_verbose_stg2stg then - writeMn stderr (ppShow 1000 - (ppAbove (ppStr ("*** "++what++":")) - (ppAboves (map (ppr ppr_style) binds2)) - )) - else returnMn ()) `thenMn_` - let - linted_binds = stg_linter what binds2 - in - returnMn (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) -- add to description of what's happened (reverse order) -- here so it can be inlined... -foldl_mn f z [] = returnMn z -foldl_mn f z (x:xs) = f z x `thenMn` \ zz -> +foldl_mn f z [] = return z +foldl_mn f z (x:xs) = f z x >>= \ zz -> foldl_mn f zz xs \end{code} - -%************************************************************************ -%* * -\subsection[SimplStg-unlocalise]{Unlocalisation in STG code} -%* * -%************************************************************************ - -The idea of all this ``unlocalise'' stuff is that in certain (prelude -only) modules we split up the .hc file into lots of separate little -files, which are separately compiled by the C compiler. That gives -lots of little .o files. The idea is that if you happen to mention -one of them you don't necessarily pull them all in. (Pulling in a -piece you don't need can be v bad, because it may mention other pieces -you don't need either, and so on.) - -Sadly, splitting up .hc files means that local names (like s234) are -now globally visible, which can lead to clashes between two .hc -files. So unlocaliseWhatnot goes through making all the local things -into global things, essentially by giving them full names so when they -are printed they'll have their module name too. Pretty revolting -really. - -\begin{code} -type UnlocalEnv = IdEnv Id - -lookup_uenv :: UnlocalEnv -> Id -> Id -lookup_uenv env id = case lookupIdEnv env id of - Nothing -> id - Just new_id -> new_id - -unlocaliseStgBinds :: FAST_STRING -> UnlocalEnv -> [StgBinding] -> (UnlocalEnv, [StgBinding]) - -unlocaliseStgBinds mod uenv [] = (uenv, []) - -unlocaliseStgBinds mod uenv (b : bs) - = BIND unlocal_top_bind mod uenv b _TO_ (new_uenv, new_b) -> - BIND unlocaliseStgBinds mod new_uenv bs _TO_ (uenv3, new_bs) -> - (uenv3, new_b : new_bs) - BEND BEND - ------------------- - -unlocal_top_bind :: FAST_STRING -> UnlocalEnv -> StgBinding -> (UnlocalEnv, StgBinding) - -unlocal_top_bind mod uenv bind@(StgNonRec binder _) - = let new_uenv = case unlocaliseId mod binder of - Nothing -> uenv - Just new_binder -> addOneToIdEnv uenv binder new_binder - in - (new_uenv, renameTopStgBind (lookup_uenv new_uenv) bind) - -unlocal_top_bind mod uenv bind@(StgRec pairs) - = let maybe_unlocaliseds = [ (b, unlocaliseId mod b) | (b, _) <- pairs ] - new_uenv = growIdEnvList uenv [ (b,new_b) - | (b, Just new_b) <- maybe_unlocaliseds] - in - (new_uenv, renameTopStgBind (lookup_uenv new_uenv) bind) -\end{code} - -%************************************************************************ -%* * -\subsection[SimplStg-indirections]{Eliminating indirections in STG code} -%* * -%************************************************************************ - -In @elimIndirections@, we look for things at the top-level of the form... -\begin{verbatim} - x_local = ....rhs... - ... - x_exported = x_local - ... -\end{verbatim} -In cases we find like this, we go {\em backwards} and replace -\tr{x_local} with \tr{...rhs...}, to produce -\begin{verbatim} - x_exported = ...rhs... - ... - ... -\end{verbatim} -This saves a gratuitous jump -(from \tr{x_exported} to \tr{x_local}), and makes strictness -information propagate better. - -If more than one exported thing is equal to a local thing (i.e., the -local thing really is shared), then we eliminate only the first one. Thus: -\begin{verbatim} - x_local = ....rhs... - ... - x_exported1 = x_local - ... - x_exported2 = x_local - ... -\end{verbatim} -becomes -\begin{verbatim} - x_exported1 = ....rhs... - ... - ... - x_exported2 = x_exported1 - ... -\end{verbatim} - -We also have to watch out for - - f = \xyz -> g x y z - -This can arise post lambda lifting; the original might have been - - f = \xyz -> letrec g = [xy] \ [k] -> e - in - g z - -Strategy: first collect the info; then make a \tr{Id -> Id} mapping. -Then blast the whole program (LHSs as well as RHSs) with it. - -\begin{code} -elimIndirections :: [StgBinding] -> [StgBinding] - -elimIndirections binds_in - = if isNullIdEnv blast_env then - binds_in -- Nothing to do - else - [renameTopStgBind lookup_fn bind | Just bind <- reduced_binds] - where - lookup_fn id = case lookupIdEnv blast_env id of - Just new_id -> new_id - Nothing -> id - - (blast_env, reduced_binds) = mapAccumL try_bind nullIdEnv binds_in - - try_bind :: IdEnv Id -> StgBinding -> (IdEnv Id, Maybe StgBinding) - try_bind env_so_far - (StgNonRec exported_binder - (StgRhsClosure _ _ _ _ - lambda_args - (StgApp (StgVarArg local_binder) fun_args _) - )) - | isExported exported_binder && -- Only if this is exported - not (isExported local_binder) && -- Only if this one is defined in this - isLocallyDefined local_binder && -- module, so that we *can* change its - -- binding to be the exported thing! - not (in_dom env_so_far local_binder) && -- Only if we havn't seen it before - args_match lambda_args fun_args -- Just an eta-expansion - - = (addOneToIdEnv env_so_far local_binder exported_binder, - Nothing) - where - args_match [] [] = True - args_match (la:las) (StgVarArg fa:fas) = la == fa && args_match las fas - args_match _ _ = False - - try_bind env_so_far bind - = (env_so_far, Just bind) - - in_dom env id = maybeToBool (lookupIdEnv env id) -\end{code} - -@renameTopStgBind@ renames top level binders and all occurrences thereof. - -\begin{code} -renameTopStgBind :: (Id -> Id) -> StgBinding -> StgBinding - -renameTopStgBind fn (StgNonRec b rhs) = StgNonRec (fn b) (mapStgBindeesRhs fn rhs) -renameTopStgBind fn (StgRec pairs) = StgRec [ (fn b, mapStgBindeesRhs fn r) | (b, r) <- pairs ] -\end{code}