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.
import BasicTypes
-- Imported and re-exported
import BasicTypes
-- Imported and re-exported
+import Var( Var, Id, DictId,
idInfo, idDetails, globaliseId,
isId, isLocalId, isGlobalId, isExportedId )
import qualified Var
idInfo, idDetails, globaliseId,
isId, isLocalId, isGlobalId, isExportedId )
import qualified Var
import Unique
import UniqSupply
import FastString
import Unique
import UniqSupply
import FastString
import StaticFlags
-- infixl so you can say (id `set` a `set` b)
import StaticFlags
-- infixl so you can say (id `set` a `set` b)
g' = /\a. rhs
f = /\a. ...[g' a/g]
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
It's simple to retain strictness and arity, but not so simple to retain
+ * 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)
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
+
-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
= 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
StrictSig(..), mkStrictSig, topSig, botSig, cprSig,
isTopSig,
StrictSig(..), mkStrictSig, topSig, botSig, cprSig,
isTopSig,
+ splitStrictSig, increaseStrictSigArity,
pprIfaceStrictSig, appIsBottom, isBottomingSig, seqStrictSig,
) where
pprIfaceStrictSig, appIsBottom, isBottomingSig, seqStrictSig,
) where
splitStrictSig :: StrictSig -> ([Demand], DmdResult)
splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res)
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
isTopSig :: StrictSig -> Bool
isTopSig (StrictSig ty) = isTopDmdType ty
let new_bndrs = zipWith mk_poly_bndr bndrs uniqs
return (extendPolyLvlEnv dest_lvl env abs_vars (bndrs `zip` new_bndrs), new_bndrs)
where
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)
mkSysLocal (mkFastString str) uniq poly_ty
where
str = "poly_" ++ occNameString (getOccName bndr)
= 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
= 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,
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,