X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplStg%2FSimplStg.lhs;h=d84539b76f81f4ee2126a89ce3856fc44b11c804;hb=7e21843581a45a6f99875c353e5d47fd8a58ff13;hp=975c87f05b56384d2f5f3ddf810880ebffd142ec;hpb=2803545fde09454b5e70b54ab42de319ad64ab66;p=ghc-hetmet.git diff --git a/ghc/compiler/simplStg/SimplStg.lhs b/ghc/compiler/simplStg/SimplStg.lhs index 975c87f..d84539b 100644 --- a/ghc/compiler/simplStg/SimplStg.lhs +++ b/ghc/compiler/simplStg/SimplStg.lhs @@ -4,18 +4,13 @@ \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 SCCfinal ( stgMassageForProfiling ) import StgLint ( lintStgBindings ) @@ -28,26 +23,16 @@ import CmdLineOpts ( opt_SccGroup, --Not used:opt_EnsureSplittableC, opt_DoStgLinting, StgToDo(..) ) -import Id ( nullIdEnv, lookupIdEnv, addOneToIdEnv, - growIdEnvList, isNullIdEnv, SYN_IE(IdEnv), - setIdVisibility, - GenId{-instance Eq/Outputable -}, SYN_IE(Id) - ) -import Maybes ( maybeToBool ) -import PprType ( GenType{-instance Outputable-} ) -import PprStyle ( PprStyle ) -import Pretty ( Doc, ($$), vcat, text, ptext ) +import ErrUtils ( doIfSet ) import UniqSupply ( splitUniqSupply, UniqSupply ) -import Util ( mapAccumL, panic, assertPanic ) -#if __GLASGOW_HASKELL__ >= 202 -import Outputable ( Outputable(..) ) -#endif +import Util ( panic, assertPanic, trace ) +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) - -> PprStyle -- printing style (for debugging only) -> UniqSupply -- a name supply -> [StgBinding] -- input... -> IO @@ -55,16 +40,13 @@ 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 (show - (($$) (ptext SLIT("*** Core2Stg:")) - (vcat (map (ppr ppr_style) (setStgVarInfo False binds))) - )) - else return ()) >> + doIfSet do_verbose_stg2stg + (printErrs (text "VERBOSE STG-TO-STG:" $$ + text "*** Core2Stg:" $$ + vcat (map ppr (setStgVarInfo False binds)))) >> -- Do the main business! foldl_mn do_stg_pass (binds, us4now, ([],[])) stg_todos @@ -96,23 +78,6 @@ stg2stg stg_todos module_name ppr_style us binds -- correct, which is done by satStgRhs. -- -{- - Done in Core now. Nuke soon. SLPJ Nov 96 - - No, STG passes may introduce toplevel bindings which - have to be globalised here (later than Core anyway) -- SOF 2/97 - - Yes, lambda lifting now does the Right Thing. - - let - -- ToDo: provide proper flag control! - binds_to_mangle - = if not do_unlocalising - then processed_binds - else snd (unlocaliseStgBinds unlocal_tag nullIdEnv processed_binds) - in --} - return (setStgVarInfo do_let_no_escapes processed_binds, cost_centres) } where @@ -131,7 +96,7 @@ stg2stg stg_todos module_name ppr_style us binds ------------- stg_linter = if False --LATER: opt_DoStgLinting (ToDo) - then lintStgBindings ppr_style + then lintStgBindings else ( \ whodunnit binds -> binds ) ------------------------------------------- @@ -173,9 +138,8 @@ 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 (show - (($$) (text ("*** "++what++":")) - (vcat (map (ppr ppr_style) binds2)) + hPutStr stderr (showSDoc + (text ("*** "++what++":") $$ vcat (map ppr binds2) )) else return ()) >> let @@ -192,155 +156,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 lookupIdEnv uenv binder of - Just global -> uenv - Nothing -> new_env - where - new_env = addOneToIdEnv uenv binder new_global - new_global = setIdVisibility mod binder - in - (new_uenv, renameTopStgBind (lookup_uenv new_uenv) bind) - -unlocal_top_bind mod uenv bind@(StgRec pairs) = - let - new_env binder uenv = - case lookupIdEnv uenv binder of - Just global -> uenv - Nothing -> env' - where - env' = addOneToIdEnv uenv binder new_global - new_global = setIdVisibility mod binder - - uenv' = foldr (new_env) uenv (map (fst) pairs) - in - (uenv', renameTopStgBind (lookup_uenv uenv') bind) - -\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} - -This utility function simply applies the given function to every -bindee in the program. - -\begin{code} -mapStgBindeesBind :: (Id -> Id) -> StgBinding -> StgBinding -mapStgBindeesBind fn (StgNonRec b rhs) = StgNonRec b (mapStgBindeesRhs fn rhs) -mapStgBindeesBind fn (StgRec pairs) = StgRec [ (b, mapStgBindeesRhs fn r) | (b, r) <- pairs ] - ------------------- -mapStgBindeesRhs :: (Id -> Id) -> StgRhs -> StgRhs -mapStgBindeesRhs fn (StgRhsClosure cc bi fvs u args expr) - = StgRhsClosure - cc bi - (map fn fvs) - u - (map fn args) - (mapStgBindeesExpr fn expr) - -mapStgBindeesRhs fn (StgRhsCon cc con atoms) - = StgRhsCon cc con (map (mapStgBindeesArg fn) atoms) - ------------------- -mapStgBindeesExpr :: (Id -> Id) -> StgExpr -> StgExpr - -mapStgBindeesExpr fn (StgApp f args lvs) - = StgApp (mapStgBindeesArg fn f) - (map (mapStgBindeesArg fn) args) - (mapUniqSet fn lvs) - -mapStgBindeesExpr fn (StgCon con atoms lvs) - = StgCon con (map (mapStgBindeesArg fn) atoms) (mapUniqSet fn lvs) - -mapStgBindeesExpr fn (StgPrim op atoms lvs) - = StgPrim op (map (mapStgBindeesArg fn) atoms) (mapUniqSet fn lvs) - -mapStgBindeesExpr fn (StgLet bind expr) - = StgLet (mapStgBindeesBind fn bind) (mapStgBindeesExpr fn expr) - -mapStgBindeesExpr fn (StgLetNoEscape lvs rhss_lvs bind body) - = StgLetNoEscape (mapUniqSet fn lvs) (mapUniqSet fn rhss_lvs) - (mapStgBindeesBind fn bind) (mapStgBindeesExpr fn body) - -mapStgBindeesExpr fn (StgSCC ty label expr) - = StgSCC ty label (mapStgBindeesExpr fn expr) - -mapStgBindeesExpr fn (StgCase expr lvs1 lvs2 uniq alts) - = StgCase (mapStgBindeesExpr fn expr) - (mapUniqSet fn lvs1) - (mapUniqSet fn lvs2) - uniq - (mapStgBindeesAlts alts) - where - mapStgBindeesAlts (StgAlgAlts ty alts deflt) - = StgAlgAlts ty (map mapStgBindeesBoxed_alt alts) (mapStgBindeesDeflt deflt) - where - mapStgBindeesBoxed_alt (c,ps,use_mask,expr) = (c,ps,use_mask,mapStgBindeesExpr fn expr) - - mapStgBindeesAlts (StgPrimAlts ty alts deflt) - = StgPrimAlts ty (map mapStgBindeesunboxed_alt alts) (mapStgBindeesDeflt deflt) - where - mapStgBindeesunboxed_alt (l,expr) = (l,mapStgBindeesExpr fn expr) - - mapStgBindeesDeflt StgNoDefault = StgNoDefault - mapStgBindeesDeflt (StgBindDefault b used expr) = StgBindDefault b used (mapStgBindeesExpr fn expr) - ------------------- -mapStgBindeesArg :: (Id -> Id) -> StgArg -> StgArg -mapStgBindeesArg fn a@(StgLitArg _) = a -mapStgBindeesArg fn a@(StgConArg _) = a -mapStgBindeesArg fn a@(StgVarArg id) = StgVarArg (fn id) -\end{code}