From b9aed4384130d250da316cac44acdaefb871a609 Mon Sep 17 00:00:00 2001 From: sof Date: Sat, 5 Jul 1997 02:54:19 +0000 Subject: [PATCH] [project @ 1997-07-05 02:52:48 by sof] --- ghc/compiler/simplStg/LambdaLift.lhs | 2 +- ghc/compiler/simplStg/SimplStg.lhs | 170 --------------------------------- ghc/compiler/specialise/SpecUtils.lhs | 18 ++-- 3 files changed, 11 insertions(+), 179 deletions(-) diff --git a/ghc/compiler/simplStg/LambdaLift.lhs b/ghc/compiler/simplStg/LambdaLift.lhs index 7995a32..38967fe 100644 --- a/ghc/compiler/simplStg/LambdaLift.lhs +++ b/ghc/compiler/simplStg/LambdaLift.lhs @@ -448,7 +448,7 @@ newSupercombinator :: Type -> LiftM Id newSupercombinator ty arity mod ci us idenv - = setIdVisibility mod (mkSysLocal SLIT("sc") uniq ty noSrcLoc) + = setIdVisibility (Just mod) uniq (mkSysLocal SLIT("sc") uniq ty noSrcLoc) `addIdArity` exactArity arity -- ToDo: rm the addIdArity? Just let subsequent stg-saturation pass do it? where diff --git a/ghc/compiler/simplStg/SimplStg.lhs b/ghc/compiler/simplStg/SimplStg.lhs index 8a38376..480d247 100644 --- a/ghc/compiler/simplStg/SimplStg.lhs +++ b/ghc/compiler/simplStg/SimplStg.lhs @@ -30,7 +30,6 @@ import CmdLineOpts ( opt_SccGroup, --Not used:opt_EnsureSplittableC, ) import Id ( nullIdEnv, lookupIdEnv, addOneToIdEnv, growIdEnvList, isNullIdEnv, SYN_IE(IdEnv), - setIdVisibility, GenId{-instance Eq/Outputable -}, SYN_IE(Id) ) import Maybes ( maybeToBool ) @@ -93,23 +92,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 @@ -189,155 +171,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} diff --git a/ghc/compiler/specialise/SpecUtils.lhs b/ghc/compiler/specialise/SpecUtils.lhs index 342e104..4933598 100644 --- a/ghc/compiler/specialise/SpecUtils.lhs +++ b/ghc/compiler/specialise/SpecUtils.lhs @@ -26,20 +26,19 @@ import CmdLineOpts ( opt_SpecialiseOverloaded, opt_SpecialiseUnboxed, opt_SpecialiseAll, opt_PprUserLength ) import Bag ( isEmptyBag, bagToList, Bag ) -import Class ( GenClass{-instance NamedThing-}, SYN_IE(Class), - GenClassOp {- instance NamedThing -} ) +import Class ( GenClass{-instance NamedThing-}, SYN_IE(Class) ) import FiniteMap ( emptyFM, addListToFM_C, plusFM_C, keysFM, lookupWithDefaultFM ) -import Id ( idType, isDictFunId, isConstMethodId_maybe, - isDefaultMethodId_maybe, +import Id ( idType, isDictFunId, + isDefaultMethodId_maybe, mkSameSpecCon, GenId {-instance NamedThing -}, SYN_IE(Id) ) import Maybes ( maybeToBool, catMaybes, firstJust ) import Name ( OccName, pprOccName, modAndOcc, NamedThing(..) ) import Outputable ( PprStyle(..), Outputable(..) ) import PprType ( pprGenType, pprParendGenType, pprMaybeTy, - TyCon{-ditto-}, GenType{-ditto-}, GenTyVar, GenClassOp + TyCon{-ditto-}, GenType{-ditto-}, GenTyVar ) import Pretty -- plenty of it import TyCon ( tyConTyVars, TyCon{-instance NamedThing-} ) @@ -52,11 +51,9 @@ import Util ( equivClasses, zipWithEqual, cmpPString, assertPanic, panic{-ToDo:rm-} ) + cmpType = panic "SpecUtils.cmpType (ToDo: get rid of)" -mkSameSpecCon = panic "SpecUtils.mkSameSpecCon (ToDo)" getInstIdModule = panic "SpecUtils.getInstIdModule (ToDo)" -specialiseTy :: Type -> [Maybe Type] -> Int -> Type -specialiseTy = panic "SpecUtils.specialiseTy (ToDo)" \end{code} @specialiseCallTys@ works out which type args don't need to be specialised on, @@ -291,6 +288,9 @@ pp_tyspec sty pp_mod (_, tycon, tys) choose_ty (tv, Just ty) = (ty, Nothing) pp_idspec :: PprStyle -> Doc -> (OccName, Id, [Maybe Type], Bool) -> Doc +pp_idspec = error "pp_idspec" + +{- LATER pp_idspec sty pp_mod (_, id, tys, is_err) | isDictFunId id @@ -338,4 +338,6 @@ pp_idspec sty pp_mod (_, id, tys, is_err) default_method_maybe = isDefaultMethodId_maybe id is_default_method_id = maybeToBool default_method_maybe + +-} \end{code} -- 1.7.10.4