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.

diff --git a/compiler/basicTypes/Id.lhs b/compiler/basicTypes/Id.lhs
index 74fd2cf..676d6cf 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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,