From 6561069ad5d0b11de223686be59372a3b1e6aed7 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Wed, 4 Feb 2009 08:25:34 +0000 Subject: [PATCH] Improve transferPolyIdInfo for value-arg abstraction If we float a binding out of a *value* lambda, the fixing-up of IdInfo is a bit more complicated than before. Since in principle FloatOut can do this (and thus can do full lambda lifting), it's imporrtant that transferPolyIdInfo does the Right Thing. This doensn't matter unless you use FloatOut's abilty to lambda-lift, which GHC mostly doesn't, yet. But Max used it and tripped over this bug. --- compiler/basicTypes/Id.lhs | 43 +++++++++++++++++++++++++++++-------- compiler/basicTypes/NewDemand.lhs | 7 +++++- compiler/simplCore/SetLevels.lhs | 2 +- compiler/simplCore/SimplUtils.lhs | 2 +- 4 files changed, 42 insertions(+), 12 deletions(-) diff --git a/compiler/basicTypes/Id.lhs b/compiler/basicTypes/Id.lhs index 74fd2cf..676d6cf 100644 --- a/compiler/basicTypes/Id.lhs +++ b/compiler/basicTypes/Id.lhs @@ -106,7 +106,7 @@ import IdInfo import BasicTypes -- Imported and re-exported -import Var( Id, DictId, +import Var( Var, Id, DictId, idInfo, idDetails, globaliseId, isId, isLocalId, isGlobalId, isExportedId ) import qualified Var @@ -132,6 +132,7 @@ import Outputable import Unique import UniqSupply import FastString +import Util( count ) import StaticFlags -- infixl so you can say (id `set` a `set` b) @@ -697,23 +698,47 @@ where g has interesting strictness information. Then if we float thus g' = /\a. rhs f = /\a. ...[g' a/g] -we *do not* want to lose the strictness information on g. Nor arity. +we *do not* want to lose g's + * strictness information + * arity + * inline pragma (though that is bit more debatable) It's simple to retain strictness and arity, but not so simple to retain - worker info - rules + * worker info + * rules so we simply discard those. Sooner or later this may bite us. This transfer is used in two places: FloatOut (long-distance let-floating) SimplUtils.abstractFloats (short-distance let-floating) +If we abstract wrt one or more *value* binders, we must modify the +arity and strictness info before transferring it. E.g. + f = \x. e +--> + g' = \y. \x. e + + substitute (g' y) for g +Notice that g' has an arity one more than the original g + \begin{code} -transferPolyIdInfo :: Id -> Id -> Id -transferPolyIdInfo old_id new_id +transferPolyIdInfo :: Id -- Original Id + -> [Var] -- Abstract wrt these variables + -> Id -- New Id + -> Id +transferPolyIdInfo old_id abstract_wrt new_id = modifyIdInfo transfer new_id where - old_info = idInfo old_id - transfer new_info = new_info `setNewStrictnessInfo` (newStrictnessInfo old_info) - `setArityInfo` (arityInfo old_info) + arity_increase = count isId abstract_wrt -- Arity increases by the + -- number of value binders + + old_info = idInfo old_id + old_arity = arityInfo old_info + old_inline_prag = inlinePragInfo old_info + new_arity = old_arity + arity_increase + old_strictness = newStrictnessInfo old_info + new_strictness = fmap (increaseStrictSigArity arity_increase) old_strictness + + transfer new_info = new_info `setNewStrictnessInfo` new_strictness + `setArityInfo` new_arity + `setInlinePragInfo` old_inline_prag \end{code} diff --git a/compiler/basicTypes/NewDemand.lhs b/compiler/basicTypes/NewDemand.lhs index 668a35e..e97a7db 100644 --- a/compiler/basicTypes/NewDemand.lhs +++ b/compiler/basicTypes/NewDemand.lhs @@ -19,7 +19,7 @@ module NewDemand( StrictSig(..), mkStrictSig, topSig, botSig, cprSig, isTopSig, - splitStrictSig, + splitStrictSig, increaseStrictSigArity, pprIfaceStrictSig, appIsBottom, isBottomingSig, seqStrictSig, ) where @@ -307,6 +307,11 @@ mkStrictSig dmd_ty = StrictSig dmd_ty splitStrictSig :: StrictSig -> ([Demand], DmdResult) splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res) +increaseStrictSigArity :: Int -> StrictSig -> StrictSig +-- Add extra arguments to a strictness signature +increaseStrictSigArity arity_increase (StrictSig (DmdType env dmds res)) + = StrictSig (DmdType env (replicate arity_increase topDmd ++ dmds) res) + isTopSig :: StrictSig -> Bool isTopSig (StrictSig ty) = isTopDmdType ty diff --git a/compiler/simplCore/SetLevels.lhs b/compiler/simplCore/SetLevels.lhs index 6f48272..0235981 100644 --- a/compiler/simplCore/SetLevels.lhs +++ b/compiler/simplCore/SetLevels.lhs @@ -851,7 +851,7 @@ newPolyBndrs dest_lvl env abs_vars bndrs = do let new_bndrs = zipWith mk_poly_bndr bndrs uniqs return (extendPolyLvlEnv dest_lvl env abs_vars (bndrs `zip` new_bndrs), new_bndrs) where - mk_poly_bndr bndr uniq = transferPolyIdInfo bndr $ -- Note [transferPolyIdInfo] in Id.lhs + mk_poly_bndr bndr uniq = transferPolyIdInfo bndr abs_vars $ -- Note [transferPolyIdInfo] in Id.lhs mkSysLocal (mkFastString str) uniq poly_ty where str = "poly_" ++ occNameString (getOccName bndr) diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs index 88abf4a..1c6768d 100644 --- a/compiler/simplCore/SimplUtils.lhs +++ b/compiler/simplCore/SimplUtils.lhs @@ -1199,7 +1199,7 @@ abstractFloats main_tvs body_env body = do { uniq <- getUniqueM ; let poly_name = setNameUnique (idName var) uniq -- Keep same name poly_ty = mkForAllTys tvs_here (idType var) -- But new type of course - poly_id = transferPolyIdInfo var $ -- Note [transferPolyIdInfo] in Id.lhs + poly_id = transferPolyIdInfo var tvs_here $ -- Note [transferPolyIdInfo] in Id.lhs mkLocalId poly_name poly_ty ; return (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tvs_here)) } -- In the olden days, it was crucial to copy the occInfo of the original var, -- 1.7.10.4