Commit 6561069a authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

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.
parent a77cfb5c
......@@ -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}
......@@ -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
......
......@@ -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)
......
......@@ -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,
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment