Transfer strictness and arity info when abstracting over type variables

See Note [transferPolyIdInfo] in Id.lhs, and test
	eyeball/demand-on-polymorphic-floatouts.hs

Max Bolingbroke discovered that we were gratuitiously losing strictness
info.  This simple patch fixes it.  But see the above note for things
that are still discarded: worker info and rules.

diff --git a/compiler/basicTypes/Id.lhs b/compiler/basicTypes/Id.lhs
index cb2422d..9145bad 100644 (file)
--- a/compiler/basicTypes/Id.lhs
+++ b/compiler/basicTypes/Id.lhs
@@ -22,7 +22,7 @@ module Id (
        -- Modifying an Id
        setIdName, setIdUnique, Id.setIdType, setIdExported, setIdNotExported, 
        setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo,
-       zapLamIdInfo, zapDemandIdInfo, zapFragileIdInfo,
+       zapLamIdInfo, zapDemandIdInfo, zapFragileIdInfo, transferPolyIdInfo,
 
        -- Predicates
        isImplicitId, isDeadBinder, isDictId, isStrictId,
@@ -585,3 +585,35 @@ zapFragileIdInfo :: Id -> Id
 zapFragileIdInfo = zapInfo zapFragileInfo 
 \end{code}
 
+Note [transferPolyIdInfo]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+
+   f = /\a. let g = rhs in ...
+
+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.
+
+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)
+
+\begin{code}
+transferPolyIdInfo :: Id -> Id -> Id
+transferPolyIdInfo old_id 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)
+\end{code}
+

diff --git a/compiler/simplCore/SetLevels.lhs b/compiler/simplCore/SetLevels.lhs
index 77db0bc..fb9ca7f 100644 (file)
--- a/compiler/simplCore/SetLevels.lhs
+++ b/compiler/simplCore/SetLevels.lhs
@@ -62,16 +62,18 @@ module SetLevels (
 
 import CoreSyn
 
-import DynFlags        ( FloatOutSwitches(..) )
+import DynFlags                ( FloatOutSwitches(..) )
 import CoreUtils       ( exprType, exprIsTrivial, mkPiTypes )
 import CoreFVs         -- all of it
 import CoreSubst       ( Subst, emptySubst, extendInScope, extendIdSubst,
                          cloneIdBndr, cloneRecIdBndrs )
 import Id              ( Id, idType, mkSysLocal, isOneShotLambda,
-                         zapDemandIdInfo,
+                         zapDemandIdInfo, transferPolyIdInfo,
                          idSpecialisation, idWorkerInfo, setIdInfo
                        )
-import IdInfo          ( workerExists, vanillaIdInfo, isEmptySpecInfo )
+import IdInfo          ( workerExists, vanillaIdInfo, isEmptySpecInfo,
+                          setNewStrictnessInfo, newStrictnessInfo,
+                         setArityInfo, arityInfo )
 import Var
 import VarSet
 import VarEnv
@@ -831,17 +833,18 @@ type LvlM result = UniqSM result
 initLvl                = initUs_
 \end{code}
 
+
 \begin{code}
 newPolyBndrs dest_lvl env abs_vars bndrs = do
     uniqs <- getUniquesM
     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 = mkSysLocal (mkFastString str) uniq poly_ty
+    mk_poly_bndr bndr uniq = transferPolyIdInfo bndr $         -- Note [transferPolyIdInfo] in Id.lhs
+                            mkSysLocal (mkFastString str) uniq poly_ty
                           where
                             str     = "poly_" ++ occNameString (getOccName bndr)
                             poly_ty = mkPiTypes abs_vars (idType bndr)
-       
 
 newLvlVar :: String 
          -> [CoreBndr] -> Type         -- Abstract wrt these bndrs

diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs
index f298ace..c33bc3d 100644 (file)
--- a/compiler/simplCore/SimplUtils.lhs
+++ b/compiler/simplCore/SimplUtils.lhs
@@ -1165,7 +1165,8 @@ 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   = mkLocalId poly_name poly_ty 
+                 poly_id   = transferPolyIdInfo var $  -- 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, 
                -- because we were looking at occurrence-analysed but as yet unsimplified code!