From: simonpj Date: Fri, 8 Dec 2000 13:20:53 +0000 (+0000) Subject: [project @ 2000-12-08 13:20:52 by simonpj] X-Git-Tag: Approximately_9120_patches~3155 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=11a3ee539ec8fb79cf81410e45b7fd9cbc0cd721;p=ghc-hetmet.git [project @ 2000-12-08 13:20:52 by simonpj] Bogons in previous commit --- diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 5c9f6e8..64f32ff 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -88,7 +88,6 @@ import IdInfo import Demand ( Demand ) import Name ( Name, OccName, mkSysLocalName, mkLocalName, - nameIsLocallyDefined, getOccName, isIPOcc ) import OccName ( UserFS ) diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index 32b3441..e279fe7 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -219,10 +219,11 @@ constantIdInfo :: IdInfo -- we'd better assume it does constantIdInfo = mkIdInfo ConstantId MayHaveCafRefs -mkIdInfo :: IdFlavour -> IdInfo +mkIdInfo :: IdFlavour -> CafInfo -> IdInfo mkIdInfo flv caf = IdInfo { flavourInfo = flv, + cafInfo = caf, arityInfo = UnknownArity, demandInfo = wwLazy, specInfo = emptyCoreRules, @@ -230,7 +231,6 @@ mkIdInfo flv caf workerInfo = NoWorker, strictnessInfo = NoStrictnessInfo, unfoldingInfo = noUnfolding, - cafInfo = caf cprInfo = NoCPRInfo, lbvarInfo = NoLBVarInfo, inlinePragInfo = NoInlinePragInfo, diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index 4d2a1ee..8519f25 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -138,7 +138,7 @@ wiredInIds \begin{code} mkSpecPragmaId occ uniq ty loc - = mkId (mkLocalName uniq occ loc) ty (mkIdInfo SpecPragmaId) + = mkId (mkLocalName uniq occ loc) ty (mkIdInfo SpecPragmaId NoCafRefs) -- Maybe a SysLocal? But then we'd lose the location mkDefaultMethodId dm_name rec_c ty @@ -169,7 +169,7 @@ mkDataConId :: Name -> DataCon -> Id mkDataConId work_name data_con = mkId work_name (dataConRepType data_con) info where - info = mkIdInfo (DataConId data_con) + info = mkIdInfo (DataConId data_con) NoCafRefs `setArityInfo` exactArity arity `setStrictnessInfo` strict_info `setCprInfo` cpr_info @@ -231,7 +231,7 @@ mkDataConWrapId data_con wrap_id = mkId (dataConName data_con) wrap_ty info work_id = dataConId data_con - info = mkIdInfo (DataConWrapId data_con) + info = mkIdInfo (DataConWrapId data_con) NoCafRefs `setUnfoldingInfo` mkTopUnfolding (mkInlineMe wrap_rhs) `setCprInfo` cpr_info -- The Cpr info can be important inside INLINE rhss, where the @@ -239,10 +239,6 @@ mkDataConWrapId data_con `setArityInfo` exactArity arity -- It's important to specify the arity, so that partial -- applications are treated as values - `setCafInfo` NoCafRefs - -- The wrapper Id ends up in STG code as an argument, - -- sometimes before its definition, so we want to - -- signal that it has no CAFs `setTyGenInfo` TyGenNever -- No point generalising its type, since it gets eagerly inlined -- away anyway @@ -412,10 +408,9 @@ mkRecordSelId tycon field_label unpack_id unpackUtf8_id selector_ty = mkForAllTys tyvars $ mkForAllTys field_tyvars $ mkFunTys dict_tys $ mkFunTy data_ty field_tau - info = mkIdInfo (RecordSelId field_label) + info = mkIdInfo (RecordSelId field_label) NoCafRefs `setArityInfo` exactArity (1 + length dict_tys) `setUnfoldingInfo` unfolding - `setCafInfo` NoCafRefs `setTyGenInfo` TyGenNever -- ToDo: consider adding further IdInfo @@ -523,10 +518,9 @@ mkDictSelId name clas field_lbl = mkFieldLabel name tycon ty tag tag = assoc "MkId.mkDictSelId" (classSelIds clas `zip` allFieldLabelTags) sel_id - info = mkIdInfo (RecordSelId field_lbl) + info = mkIdInfo (RecordSelId field_lbl) NoCafRefs `setArityInfo` exactArity 1 `setUnfoldingInfo` unfolding - `setCafInfo` NoCafRefs `setTyGenInfo` TyGenNever -- We no longer use 'must-inline' on record selectors. They'll @@ -569,7 +563,7 @@ mkPrimOpId prim_op name = mkPrimOpIdName prim_op id = mkId name ty info - info = mkIdInfo (PrimOpId prim_op) + info = mkIdInfo (PrimOpId prim_op) NoCafRefs `setSpecInfo` rules `setArityInfo` exactArity arity `setStrictnessInfo` strict_info @@ -600,7 +594,7 @@ mkCCallOpId uniq ccall ty name = mkCCallName uniq occ_str prim_op = CCallOp ccall - info = mkIdInfo (PrimOpId prim_op) + info = mkIdInfo (PrimOpId prim_op) NoCafRefs `setArityInfo` exactArity arity `setStrictnessInfo` strict_info @@ -629,9 +623,11 @@ mkDictFunId dfun_name clas inst_tyvars inst_tys dfun_theta = mkId dfun_name dfun_ty info where dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys) - info = mkIdInfo DictFunId `setTyGenInfo` TyGenNever + info = mkIdInfo DictFunId MayHaveCafRefs + `setTyGenInfo` TyGenNever -- type is wired-in (see comment at TcClassDcl.tcClassSig), so -- do not generalise it + -- An imported dfun may refer to CAFs, so we assume the worst {- 1 dec 99: disable the Mark Jones optimisation for the sake of compatibility with Hugs. diff --git a/ghc/compiler/coreSyn/CoreTidy.lhs b/ghc/compiler/coreSyn/CoreTidy.lhs index f607d13..ceb6580 100644 --- a/ghc/compiler/coreSyn/CoreTidy.lhs +++ b/ghc/compiler/coreSyn/CoreTidy.lhs @@ -363,16 +363,15 @@ tidyTopBinder mod ext_ids tidy_env rhs caf_info tidyIdInfo us tidy_env is_external unfold_info arity_info caf_info id | opt_OmitInterfacePragmas || not is_external -- No IdInfo if the Id isn't external, or if we don't have -O - = mkIdInfo new_flavour + = mkIdInfo new_flavour caf_info `setStrictnessInfo` strictnessInfo core_idinfo `setArityInfo` ArityExactly arity_info - `setCafInfo` caf_info -- Keep strictness, arity and CAF info; it's used by the code generator | otherwise = let (rules', _) = initUs us (tidyRules tidy_env (specInfo core_idinfo)) in - mkIdInfo new_flavour + mkIdInfo new_flavour caf_info `setCprInfo` cprInfo core_idinfo `setStrictnessInfo` strictnessInfo core_idinfo `setInlinePragInfo` inlinePragInfo core_idinfo @@ -380,7 +379,6 @@ tidyIdInfo us tidy_env is_external unfold_info arity_info caf_info id `setWorkerInfo` tidyWorker tidy_env arity_info (workerInfo core_idinfo) `setSpecInfo` rules' `setArityInfo` ArityExactly arity_info - `setCafInfo` caf_info -- this is the final IdInfo, it must agree with the -- code finally generated (i.e. NO more transformations -- after this!). diff --git a/ghc/compiler/simplCore/LiberateCase.lhs b/ghc/compiler/simplCore/LiberateCase.lhs index 2ca9e83..e11950c 100644 --- a/ghc/compiler/simplCore/LiberateCase.lhs +++ b/ghc/compiler/simplCore/LiberateCase.lhs @@ -14,7 +14,9 @@ import CoreSyn import CoreUnfold ( couldBeSmallEnoughToInline ) import Var ( Id ) import VarEnv +import UniqFM ( ufmToList ) import Maybes +import Outputable \end{code} This module walks over @Core@, and looks for @case@ on free variables. @@ -40,13 +42,15 @@ f = \ t -> case v of \end{verbatim} (note the NEED for shadowing) -=> Run Andr\'e's wonder pass ... +=> Simplify + \begin{verbatim} f = \ t -> case v of V a b -> a : (letrec f = \ t -> a : f t in f t) \begin{verbatim} + Better code, because 'a' is free inside the inner letrec, rather than needing projection from v. @@ -141,6 +145,12 @@ data LibCaseEnv initEnv :: Int -> LibCaseEnv initEnv bomb_size = LibCaseEnv bomb_size 0 emptyVarEnv emptyVarEnv [] +pprEnv :: LibCaseEnv -> SDoc +pprEnv (LibCaseEnv _ lvl lvl_env _ scruts) + = vcat [text "LibCaseEnv" <+> int lvl, + fsep (map ppr (ufmToList lvl_env)), + fsep (map ppr scruts)] + bombOutSize (LibCaseEnv bomb_size _ _ _ _) = bomb_size \end{code} @@ -233,16 +243,19 @@ Ids \begin{code} libCaseId :: LibCaseEnv -> Id -> CoreExpr libCaseId env v - | Just the_bind <- lookupRecId env v, -- It's a use of a recursive thing - there_are_free_scruts -- with free vars scrutinised in RHS - = Let the_bind (Var v) + | Just the_bind <- lookupRecId env v -- It's a use of a recursive thing + -- = not (null free_scruts) -- with free vars scrutinised in RHS + = if null free_scruts then + pprTrace "No:" (ppr v $$ pprEnv env) (Var v) + else + pprTrace "Yes:" (ppr v) $ Let the_bind (Var v) | otherwise = Var v where - rec_id_level = lookupLevel env v - there_are_free_scruts = freeScruts env rec_id_level + rec_id_level = lookupLevel env v + free_scruts = freeScruts env rec_id_level \end{code} @@ -283,13 +296,7 @@ addScrutedVar env@(LibCaseEnv bomb lvl lvl_env rec_env scruts) scrut_var lookupRecId :: LibCaseEnv -> Id -> Maybe CoreBind lookupRecId (LibCaseEnv bomb lvl lvl_env rec_env scruts) id -#ifndef DEBUG = lookupVarEnv rec_env id -#else - = case (lookupVarEnv rec_env id) of - xxx@(Just _) -> xxx - xxx -> xxx -#endif lookupLevel :: LibCaseEnv -> Id -> LibCaseLevel lookupLevel (LibCaseEnv bomb lvl lvl_env rec_env scruts) id @@ -299,10 +306,8 @@ lookupLevel (LibCaseEnv bomb lvl lvl_env rec_env scruts) id freeScruts :: LibCaseEnv -> LibCaseLevel -- Level of the recursive Id - -> Bool -- True <=> there is an enclosing case of a variable - -- bound outside (ie level <=) the recursive Id. + -> [Id] -- Ids that are bound ouside the recursive Id, (level <=) + -- but which are scrutinised on the way to this call freeScruts (LibCaseEnv bomb lvl lvl_env rec_env scruts) rec_bind_lvl - = not (null free_scruts) - where - free_scruts = [v | (v,lvl) <- scruts, lvl <= rec_bind_lvl] + = [v | (v,lvl) <- scruts, lvl <= rec_bind_lvl] \end{code}