From: simonpj@microsoft.com <unknown>
Date: Fri, 11 Apr 2008 14:24:18 +0000 (+0000)
Subject: Transfer strictness and arity info when abstracting over type variables
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=27061b5b4008a831eba4784358b040bb1250dcef

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
--- 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
--- 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
--- 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!