From 0fa26afe25a285f7d99cea8fd6e7c8258c81325d Mon Sep 17 00:00:00 2001 From: simonpj Date: Fri, 20 Jul 2001 15:22:22 +0000 Subject: [PATCH] [project @ 2001-07-20 15:22:21 by simonpj] ----------------------- Get rid of ArityAtLeast ----------------------- Now that we have CgInfo, with the exact code-generator arity for the value, we don't need the distinction between ArityAtLeast and ArityExactly in the ArityInfo field of an IdInfo. This commit makes type ArityInfo = Maybe Arity and propagates this change consistently through the compiler. --- ghc/compiler/basicTypes/Id.lhs | 2 +- ghc/compiler/basicTypes/IdInfo.lhs | 47 +++++++++++++-------------------- ghc/compiler/basicTypes/MkId.lhs | 12 ++++----- ghc/compiler/simplCore/Simplify.lhs | 6 ++--- ghc/compiler/typecheck/TcIfaceSig.lhs | 2 +- 5 files changed, 29 insertions(+), 40 deletions(-) diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 34f769d..448ed01 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -307,7 +307,7 @@ idArityInfo id = arityInfo (idInfo id) idArity :: Id -> Arity idArity id = arityLowerBound (idArityInfo id) -setIdArityInfo :: Id -> ArityInfo -> Id +setIdArityInfo :: Id -> Arity -> Id setIdArityInfo id arity = modifyIdInfo (`setArityInfo` arity) id --------------------------------- diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index 7e030fd..27919e5 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -20,7 +20,7 @@ module IdInfo ( -- Arity ArityInfo(..), - exactArity, atLeastArity, unknownArity, hasArity, + exactArity, unknownArity, hasArity, arityInfo, setArityInfo, ppArityInfo, arityLowerBound, -- New demand and strictness info @@ -289,7 +289,7 @@ setUnfoldingInfo info uf = info { unfoldingInfo = uf } setDemandInfo info dd = info { demandInfo = dd } -setArityInfo info ar = info { arityInfo = ar } +setArityInfo info ar = info { arityInfo = Just ar } setCgInfo info cg = info { cgInfo = cg } setCprInfo info cp = info { cprInfo = cp } setLBVarInfo info lb = info { lbvarInfo = lb } @@ -304,7 +304,7 @@ vanillaIdInfo :: IdInfo vanillaIdInfo = IdInfo { cgInfo = noCgInfo, - arityInfo = UnknownArity, + arityInfo = unknownArity, demandInfo = wwLazy, specInfo = emptyCoreRules, tyGenInfo = noTyGenInfo, @@ -338,42 +338,31 @@ of their arities; so it should not be asking... (but other things besides the code-generator need arity info!) \begin{code} -data ArityInfo - = UnknownArity -- No idea +type ArityInfo = Maybe 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 + -- may get in the way. - | ArityExactly Arity -- Arity is exactly this. We use this when importing a - -- function; it's already been compiled and we know its - -- arity for sure. - - | ArityAtLeast 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 - -- may get in the way. - - -- functions in the module being compiled. Their arity - -- might increase later in the compilation process, if - -- an extra lambda floats up to the binding site. - deriving( Eq ) + -- The arity might increase later in the compilation process, if + -- an extra lambda floats up to the binding site. seqArity :: ArityInfo -> () seqArity a = arityLowerBound a `seq` () -exactArity = ArityExactly -atLeastArity = ArityAtLeast -unknownArity = UnknownArity +exactArity = Just +unknownArity = Nothing arityLowerBound :: ArityInfo -> Arity -arityLowerBound UnknownArity = 0 -arityLowerBound (ArityAtLeast n) = n -arityLowerBound (ArityExactly n) = n +arityLowerBound Nothing = 0 +arityLowerBound (Just n) = n hasArity :: ArityInfo -> Bool -hasArity UnknownArity = False -hasArity other = True +hasArity Nothing = False +hasArity other = True -ppArityInfo UnknownArity = empty -ppArityInfo (ArityExactly arity) = hsep [ptext SLIT("ArityExactly"), int arity] -ppArityInfo (ArityAtLeast arity) = hsep [ptext SLIT("ArityAtLeast"), int arity] +ppArityInfo Nothing = empty +ppArityInfo (Just arity) = hsep [ptext SLIT("Arity"), int arity] \end{code} %************************************************************************ diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index 27e7e6e..69dec38 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -144,7 +144,7 @@ mkDataConId work_name data_con id = mkGlobalId (DataConId data_con) work_name (dataConRepType data_con) info info = noCafNoTyGenIdInfo `setCgArity` arity - `setArityInfo` exactArity arity + `setArityInfo` arity `setCprInfo` cpr_info `setStrictnessInfo` strict_info `setNewStrictnessInfo` mkNewStrictnessInfo id arity strict_info cpr_info @@ -224,7 +224,7 @@ mkDataConWrapId data_con -- wrapper constructor isn't inlined `setCgArity` arity -- The NoCaf-ness is set by noCafNoTyGenIdInfo - `setArityInfo` exactArity arity + `setArityInfo` arity -- It's important to specify the arity, so that partial -- applications are treated as values `setNewStrictnessInfo` mkNewStrictnessInfo wrap_id arity noStrictnessInfo cpr_info @@ -414,7 +414,7 @@ mkRecordSelId tycon field_label unpack_id unpackUtf8_id arity = 1 + n_dict_tys + n_field_dict_tys info = noCafNoTyGenIdInfo `setCgInfo` (CgInfo arity caf_info) - `setArityInfo` exactArity arity + `setArityInfo` arity `setUnfoldingInfo` unfolding -- ToDo: consider adding further IdInfo @@ -553,7 +553,7 @@ mkDictSelId name clas info = noCafNoTyGenIdInfo `setCgArity` 1 - `setArityInfo` exactArity 1 + `setArityInfo` 1 `setUnfoldingInfo` unfolding -- We no longer use 'must-inline' on record selectors. They'll @@ -605,7 +605,7 @@ mkPrimOpId prim_op info = noCafNoTyGenIdInfo `setSpecInfo` rules `setCgArity` arity - `setArityInfo` exactArity arity + `setArityInfo` arity `setStrictnessInfo` strict_info `setNewStrictnessInfo` mkNewStrictnessInfo id arity strict_info NoCPRInfo @@ -638,7 +638,7 @@ mkFCallId uniq fcall ty info = noCafNoTyGenIdInfo `setCgArity` arity - `setArityInfo` exactArity arity + `setArityInfo` arity `setStrictnessInfo` strict_info `setNewStrictnessInfo` mkNewStrictnessInfo id arity strict_info NoCPRInfo diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 638efec..9058d0a 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -31,7 +31,7 @@ import Id ( Id, idType, idInfo, isDataConId, hasNoBinding, ) import IdInfo ( OccInfo(..), isDeadOcc, isLoopBreaker, setArityInfo, - setUnfoldingInfo, atLeastArity, + setUnfoldingInfo, occInfo ) import Demand ( isStrict ) @@ -633,7 +633,7 @@ completeBinding old_bndr new_bndr top_lvl black_listed new_rhs thing_inside -- We make new IdInfo for the new binder by starting from the old binder, -- doing appropriate substitutions. -- Then we add arity and unfolding info to get the new binder - new_bndr_info = idInfo new_bndr `setArityInfo` arity_info + new_bndr_info = idInfo new_bndr `setArityInfo` arity -- Add the unfolding *only* for non-loop-breakers -- Making loop breakers not have an unfolding at all @@ -657,7 +657,7 @@ completeBinding old_bndr new_bndr top_lvl black_listed new_rhs thing_inside loop_breaker = isLoopBreaker occ_info trivial_rhs = exprIsTrivial new_rhs must_keep_binding = black_listed || loop_breaker || isExportedId old_bndr - arity_info = atLeastArity (exprArity new_rhs) + arity = exprArity new_rhs \end{code} diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index ad444e5..8b255e4 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -90,7 +90,7 @@ tcIdInfo unf_env in_scope_vars name ty info_ins tcPrag info HsCprInfo = returnTc (info `setCprInfo` ReturnsCPR) tcPrag info (HsArity arity) = - returnTc (info `setArityInfo` (ArityExactly arity) + returnTc (info `setArityInfo` arity `setCgArity` arity) tcPrag info (HsUnfold inline_prag expr) -- 1.7.10.4