X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplStg%2FSimplStg.lhs;h=a14a2795214f411ab04ca786aa02bbcc66902b5b;hb=e00e72df666d771c089f1615f66f6257e44c9da1;hp=1f45f077a0c70c32d8f32660d5df25062a4e20ce;hpb=26741ec416bae2c502ef00a2ba0e79050a32cb67;p=ghc-hetmet.git diff --git a/ghc/compiler/simplStg/SimplStg.lhs b/ghc/compiler/simplStg/SimplStg.lhs index 1f45f07..a14a279 100644 --- a/ghc/compiler/simplStg/SimplStg.lhs +++ b/ghc/compiler/simplStg/SimplStg.lhs @@ -12,40 +12,38 @@ IMP_Ubiq(){-uitous-} IMPORT_1_3(IO(hPutStr,stderr)) import StgSyn -import StgUtils import LambdaLift ( liftProgram ) import Name ( isLocallyDefined ) +import UniqSet ( UniqSet(..), mapUniqSet ) +import CostCentre ( CostCentre ) import SCCfinal ( stgMassageForProfiling ) -import SatStgRhs ( satStgRhs ) import StgLint ( lintStgBindings ) -import StgSAT ( doStaticArgs ) import StgStats ( showStgStats ) import StgVarInfo ( setStgVarInfo ) import UpdAnal ( updateAnalyse ) -import CmdLineOpts ( opt_EnsureSplittableC, opt_SccGroup, +import CmdLineOpts ( opt_SccGroup, --Not used:opt_EnsureSplittableC, opt_StgDoLetNoEscapes, opt_D_verbose_stg2stg, + opt_DoStgLinting, StgToDo(..) ) -import Id ( externallyVisibleId, - nullIdEnv, lookupIdEnv, addOneToIdEnv, +import Id ( nullIdEnv, lookupIdEnv, addOneToIdEnv, growIdEnvList, isNullIdEnv, SYN_IE(IdEnv), - GenId{-instance Eq/Outputable -} + GenId{-instance Eq/Outputable -}, SYN_IE(Id) ) import Maybes ( maybeToBool ) import PprType ( GenType{-instance Outputable-} ) -import Pretty ( ppShow, ppAbove, ppAboves, ppStr ) -import UniqSupply ( splitUniqSupply ) +import ErrUtils ( doIfSet ) +import Outputable ( PprStyle, Outputable(..), printErrs, pprDumpStyle ) +import Pretty ( Doc, ($$), vcat, text, ptext ) +import UniqSupply ( splitUniqSupply, UniqSupply ) import Util ( mapAccumL, panic, assertPanic ) - -unlocaliseId = panic "SimplStg.unlocaliseId (ToDo)" \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... -> IO @@ -53,38 +51,34 @@ stg2stg :: [StgToDo] -- spec of what stg-to-stg passes to do ([CostCentre], -- local cost-centres that need to be decl'd [CostCentre])) -- "extern" cost-centres -stg2stg stg_todos module_name ppr_style us binds +stg2stg stg_todos module_name us binds = case (splitUniqSupply us) of { (us4now, us4later) -> - (if do_verbose_stg2stg then - hPutStr stderr "VERBOSE STG-TO-STG:\n" >> - hPutStr stderr (ppShow 1000 - (ppAbove (ppStr ("*** Core2Stg:")) - (ppAboves (map (ppr ppr_style) (setStgVarInfo False binds))) - )) - else return ()) >> + 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: part (a) is SatStgRhs - - -- 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. - - case (satStgRhs processed_binds us4later) of { saturated_binds -> - -- Essential wind-up: part (b), eliminate indirections + -- Do essential wind-up - let no_ind_binds = elimIndirections saturated_binds in +{- 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 (c), do setStgVarInfo. It has to + -- Essential wind-up: part (b), do setStgVarInfo. It has to -- happen regardless, because the code generator uses its -- decorations. -- @@ -94,31 +88,26 @@ stg2stg stg_todos module_name ppr_style us binds -- 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 - return (setStgVarInfo do_let_no_escapes binds_to_mangle, cost_centres) - }} + + return (setStgVarInfo do_let_no_escapes processed_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 - Nothing -> (False, panic "tag") - Just tag -> (True, _PK_ tag) - +{- + (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: switch_is_on DoCoreLinting -- ToDo: DoStgLinting flag - then lintStgBindings ppr_style + stg_linter = if False --LATER: opt_DoStgLinting (ToDo) + then lintStgBindings pprDumpStyle else ( \ whodunnit binds -> binds ) ------------------------------------------- @@ -127,13 +116,7 @@ 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)) - _scc_ "StgStaticArgs" - let - binds3 = doStaticArgs binds us1 - in - end_pass us2 "StgStaticArgs" ccs binds3 + StgDoStaticArgs -> panic "STG static argument transformation deleted" StgDoUpdateAnalysis -> ASSERT(null (fst ccs) && null (snd ccs)) @@ -151,7 +134,7 @@ stg2stg stg_todos module_name ppr_style us binds _scc_ "StgLambdaLift" -- NB We have to do setStgVarInfo first! let - binds3 = liftProgram us1 (setStgVarInfo do_let_no_escapes binds) + binds3 = liftProgram module_name us1 (setStgVarInfo do_let_no_escapes binds) in end_pass us2 "LambdaLift" ccs binds3 @@ -166,9 +149,9 @@ stg2stg stg_todos module_name ppr_style us binds end_pass us2 what ccs binds2 = -- report verbosely, if required (if do_verbose_stg2stg then - hPutStr stderr (ppShow 1000 - (ppAbove (ppStr ("*** "++what++":")) - (ppAboves (map (ppr ppr_style) binds2)) + hPutStr stderr (show + (($$) (text ("*** "++what++":")) + (vcat (map (ppr pprDumpStyle) binds2)) )) else return ()) >> let @@ -185,167 +168,3 @@ 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) - = case (unlocal_top_bind mod uenv b) of { (new_uenv, new_b) -> - case (unlocaliseStgBinds mod new_uenv bs) of { (uenv3, new_bs) -> - (uenv3, new_b : new_bs) }} - ------------------- - -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 _) - )) - | externallyVisibleId exported_binder && -- Only if this is exported - not (externallyVisibleId 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}