From 713b32a591db467a8e9e266ffa3a3bf453b7d4c3 Mon Sep 17 00:00:00 2001 From: simonpj Date: Mon, 15 Oct 2001 15:06:01 +0000 Subject: [PATCH] [project @ 2001-10-15 15:06:01 by simonpj] -------------------------- Tidy up arity propagation -------------------------- Due to excessive complexity, correct arity information was getting lost on the way to interface files. As a result, a function that had CPR info __S SLm (say), was getting arity 0, and this confused the (old) CPR analyser ("lub of function and HasCPR"). I hope this fixes the above error (which showed up somewhere in compiling Edison), but I'm going to commit it right now anyway. Meanwhile I'll recompile Edison too. Details ~~~~~~~ Digging out the rather obscure cause made me tidy up the CgInfo stuff. The story is now * The CgInfo field of an Id gets attached to the Id *only* in the TypeEnv of the ModuleDetails, during CoreTidy. This ModuleDetails stuff is used a) to generate the interface file b) to import into other modules in GHCi * No CgInfo field is in the CoreBindings which are passed downsteam to CorePrep and thence CodeGen. Quite right too... it's the downstream stuff that *generates* the CgInfo. * But the Arity field *is* now passed on through CoreTidy (like strictness info) since it is usefully used by CorePrep. * On the way I simplified the ArityInfo field of an IdInfo to simply Arity instead of Maybe Arity --- ghc/compiler/basicTypes/Id.lhs | 15 ++++++-------- ghc/compiler/basicTypes/IdInfo.lhs | 27 ++++++++---------------- ghc/compiler/coreSyn/CoreTidy.lhs | 40 +++++++++++++++++++++--------------- ghc/compiler/ilxGen/IlxGen.lhs | 5 ++--- 4 files changed, 41 insertions(+), 46 deletions(-) diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index c45304f..b212920 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -43,7 +43,7 @@ module Id ( -- IdInfo stuff setIdUnfolding, - setIdArityInfo, + setIdArity, setIdDemandInfo, setIdNewDemandInfo, setIdStrictness, setIdNewStrictness, zapIdNewStrictness, setIdTyGenInfo, @@ -53,7 +53,7 @@ module Id ( setIdCprInfo, setIdOccInfo, - idArity, idArityInfo, + idArity, idDemandInfo, idNewDemandInfo, idStrictness, idNewStrictness, idNewStrictness_maybe, getNewStrictness, idTyGenInfo, @@ -108,7 +108,7 @@ import Outputable import Unique ( Unique, mkBuiltinUnique ) infixl 1 `setIdUnfolding`, - `setIdArityInfo`, + `setIdArity`, `setIdDemandInfo`, `setIdStrictness`, `setIdNewDemandInfo`, @@ -309,14 +309,11 @@ isDeadBinder bndr | isId bndr = isDeadOcc (idOccInfo bndr) \begin{code} --------------------------------- -- ARITY -idArityInfo :: Id -> ArityInfo -idArityInfo id = arityInfo (idInfo id) - idArity :: Id -> Arity -idArity id = arityLowerBound (idArityInfo id) +idArity id = arityInfo (idInfo id) -setIdArityInfo :: Id -> Arity -> Id -setIdArityInfo id arity = modifyIdInfo (`setArityInfo` arity) id +setIdArity :: Id -> Arity -> Id +setIdArity id arity = modifyIdInfo (`setArityInfo` arity) id --------------------------------- -- STRICTNESS diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index cfc1d38..0a8067b 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -20,8 +20,8 @@ module IdInfo ( -- Arity ArityInfo, - exactArity, unknownArity, hasArity, - arityInfo, setArityInfo, ppArityInfo, arityLowerBound, + unknownArity, + arityInfo, setArityInfo, ppArityInfo, -- New demand and strictness info newStrictnessInfo, setNewStrictnessInfo, mkNewStrictnessInfo, @@ -49,7 +49,7 @@ module IdInfo ( demandInfo, setDemandInfo, -- Inline prags - InlinePragInfo(..), + InlinePragInfo, inlinePragInfo, setInlinePragInfo, -- Occurrence info @@ -310,7 +310,7 @@ setUnfoldingInfo info uf = info { unfoldingInfo = uf } setDemandInfo info dd = info { demandInfo = dd } -setArityInfo info ar = info { arityInfo = Just ar } +setArityInfo info ar = info { arityInfo = ar } setCgInfo info cg = info { cgInfo = cg } setCprInfo info cp = info { cprInfo = cp } setLBVarInfo info lb = info { lbvarInfo = lb } @@ -359,7 +359,7 @@ of their arities; so it should not be asking... (but other things besides the code-generator need arity info!) \begin{code} -type ArityInfo = Maybe Arity +type ArityInfo = Arity -- A partial application of this Id to up to n-1 value arguments -- does essentially no work. That is not necessarily the -- same as saying that it has n leading lambdas, because coerces @@ -369,21 +369,12 @@ type ArityInfo = Maybe Arity -- an extra lambda floats up to the binding site. seqArity :: ArityInfo -> () -seqArity a = arityLowerBound a `seq` () +seqArity a = a `seq` () -exactArity = Just -unknownArity = Nothing +unknownArity = 0 :: Arity -arityLowerBound :: ArityInfo -> Arity -arityLowerBound Nothing = 0 -arityLowerBound (Just n) = n - -hasArity :: ArityInfo -> Bool -hasArity Nothing = False -hasArity other = True - -ppArityInfo Nothing = empty -ppArityInfo (Just arity) = hsep [ptext SLIT("Arity"), int arity] +ppArityInfo 0 = empty +ppArityInfo n = hsep [ptext SLIT("Arity"), int n] \end{code} %************************************************************************ diff --git a/ghc/compiler/coreSyn/CoreTidy.lhs b/ghc/compiler/coreSyn/CoreTidy.lhs index 82b15af..4e1a4d5 100644 --- a/ghc/compiler/coreSyn/CoreTidy.lhs +++ b/ghc/compiler/coreSyn/CoreTidy.lhs @@ -24,7 +24,7 @@ import Id ( idType, idInfo, idName, isExportedId, idSpecialisation, idUnique, isDataConWrapId, mkVanillaGlobal, mkGlobalId, isLocalId, isDataConId, mkUserLocal, isGlobalId, globalIdDetails, - idNewDemandInfo, setIdNewDemandInfo, + idNewDemandInfo, setIdNewDemandInfo, setIdCgInfo, idNewStrictness, setIdNewStrictness ) import IdInfo {- loads of stuff -} @@ -155,7 +155,7 @@ tidyCorePgm dflags mod pcs cg_info_env isGlobalName (idName bndr)] ; let ((orig_ns', occ_env, subst_env), tidy_binds) - = mapAccumL (tidyTopBind mod ext_ids cg_info_env) + = mapAccumL (tidyTopBind mod ext_ids) init_tidy_env binds_in ; let tidy_rules = tidyIdRules (occ_env,subst_env) ext_rules @@ -163,7 +163,8 @@ tidyCorePgm dflags mod pcs cg_info_env ; let prs' = prs { prsOrig = orig_ns' } pcs' = pcs { pcs_PRS = prs' } - ; let final_ids = [ id | bind <- tidy_binds + ; let final_ids = [ addCgInfo cg_info_env id + | bind <- tidy_binds , id <- bindersOf bind , isGlobalName (idName id)] @@ -189,6 +190,16 @@ tidyCorePgm dflags mod pcs cg_info_env ; return (pcs', tidy_details) } +addCgInfo :: CgInfoEnv -> Id -> Id +-- Pin on the info that comes from the code generator +-- This doesn't make its way into the *bindings* that +-- go on to the code generator (that might give black holes etc) +-- Rather, it's pinned onto the Id in the type environment +-- that (a) generates the interface file +-- (b) in GHCi goes into subsequent compilations +addCgInfo cg_info_env id + = id `setIdCgInfo` lookupCgInfo cg_info_env (idName id) + tidyCoreExpr :: CoreExpr -> IO CoreExpr tidyCoreExpr expr = return (tidyExpr emptyTidyEnv expr) \end{code} @@ -375,19 +386,18 @@ type TopTidyEnv = (NameSupply, TidyOccEnv, VarEnv Var) tidyTopBind :: Module -> IdEnv Bool -- Domain = Ids that should be external -- True <=> their unfolding is external too - -> CgInfoEnv -> TopTidyEnv -> CoreBind -> (TopTidyEnv, CoreBind) -tidyTopBind mod ext_ids cg_info_env top_tidy_env (NonRec bndr rhs) +tidyTopBind mod ext_ids top_tidy_env (NonRec bndr rhs) = ((orig,occ,subst) , NonRec bndr' rhs') where ((orig,occ,subst), bndr') - = tidyTopBinder mod ext_ids cg_info_env rec_tidy_env rhs' top_tidy_env bndr + = tidyTopBinder mod ext_ids rec_tidy_env rhs' top_tidy_env bndr rec_tidy_env = (occ,subst) rhs' = tidyExpr rec_tidy_env rhs -tidyTopBind mod ext_ids cg_info_env top_tidy_env (Rec prs) +tidyTopBind mod ext_ids top_tidy_env (Rec prs) = (final_env, Rec prs') where (final_env@(_,occ,subst), prs') = mapAccumL do_one top_tidy_env prs @@ -397,13 +407,12 @@ tidyTopBind mod ext_ids cg_info_env top_tidy_env (Rec prs) = ((orig,occ,subst), (bndr',rhs')) where ((orig,occ,subst), bndr') - = tidyTopBinder mod ext_ids cg_info_env + = tidyTopBinder mod ext_ids rec_tidy_env rhs' top_tidy_env bndr rhs' = tidyExpr rec_tidy_env rhs tidyTopBinder :: Module -> IdEnv Bool - -> CgInfoEnv -> TidyEnv -> CoreExpr -- The TidyEnv is used to tidy the IdInfo -- The expr is the already-tided RHS @@ -411,7 +420,7 @@ tidyTopBinder :: Module -> IdEnv Bool -> TopTidyEnv -> Id -> (TopTidyEnv, Id) -- NB: tidyTopBinder doesn't affect the unique supply -tidyTopBinder mod ext_ids cg_info_env tidy_env rhs +tidyTopBinder mod ext_ids tidy_env rhs env@(ns2, occ_env2, subst_env2) id | isDataConWrapId id -- Don't tidy constructor wrappers @@ -451,8 +460,7 @@ tidyTopBinder mod ext_ids cg_info_env tidy_env rhs is_external (idName id) ty' = tidyTopType (idType id) - cg_info = lookupCgInfo cg_info_env name' - idinfo' = tidyIdInfo tidy_env is_external unfold_info cg_info id + idinfo' = tidyIdInfo tidy_env is_external unfold_info id id' | isGlobalId id = mkGlobalId (globalIdDetails id) name' ty' idinfo' | otherwise = mkVanillaGlobal name' ty' idinfo' @@ -470,17 +478,17 @@ tidyTopBinder mod ext_ids cg_info_env tidy_env rhs | otherwise = noUnfolding -tidyIdInfo tidy_env is_external unfold_info cg_info id +tidyIdInfo tidy_env is_external unfold_info id | opt_OmitInterfacePragmas || not is_external -- No IdInfo if the Id isn't external, or if we don't have -O = vanillaIdInfo - `setCgInfo` cg_info + `setArityInfo` arityInfo core_idinfo `setNewStrictnessInfo` newStrictnessInfo core_idinfo - -- Keep strictness; it's used by CorePrep + -- Keep strictness and arity; both are used by CorePrep | otherwise = vanillaIdInfo - `setCgInfo` cg_info + `setArityInfo` arityInfo core_idinfo `setNewStrictnessInfo` newStrictnessInfo core_idinfo `setInlinePragInfo` inlinePragInfo core_idinfo `setUnfoldingInfo` unfold_info diff --git a/ghc/compiler/ilxGen/IlxGen.lhs b/ghc/compiler/ilxGen/IlxGen.lhs index 9a90422..1f3a7d1 100644 --- a/ghc/compiler/ilxGen/IlxGen.lhs +++ b/ghc/compiler/ilxGen/IlxGen.lhs @@ -8,8 +8,7 @@ module IlxGen( ilxGen ) where import Char ( ord, chr ) import StgSyn -import Id ( idType, idName, isDeadBinder, idArityInfo ) -import IdInfo ( arityLowerBound ) +import Id ( idType, idName, isDeadBinder, idArity ) import Var ( Var, Id, TyVar, isId, isTyVar, tyVarKind, tyVarName ) import VarEnv import VarSet ( isEmptyVarSet ) @@ -772,7 +771,7 @@ ilxFunAppAfterPush env fun args tail_call case lookupIlxBindEnv env fun of Just (_, StgRhsClosure _ _ _ Updatable _ _) -> Nothing Just (place, StgRhsClosure _ _ fvs _ args _) -> Just (place,fun,args,fvs) - _ -> Nothing -- trace (show fun ++ " --> " ++ show (arityLowerBound (idArityInfo fun))) + _ -> Nothing -- trace (show fun ++ " --> " ++ show (idArity fun)) type KnownClosure = Maybe ( IlxEnv -- Of the binding site of the function , Id -- The function -- 1.7.10.4