Don't export the _info symbol for the data constructor worker bindings

This is safe because GHC never generates a fast call to a data constructor
worker: if the call is seen statically it will be eta-expanded and the
allocation of the data will be inlined. We still need to export the _closure
in case the constructor is used in an unapplied fashion.

4 files changed, 37 insertions, 16 deletions

diff --git a/compiler/codeGen/CgInfoTbls.hs b/compiler/codeGen/CgInfoTbls.hs
index 2745832227..093b9ffaab 100644
--- a/compiler/codeGen/CgInfoTbls.hs
+++ b/compiler/codeGen/CgInfoTbls.hs
@@ -84,12 +84,12 @@ mkCmmInfo cl_info = do
            info = ConstrInfo (ptrs, nptrs)
                              (fromIntegral (dataConTagZ con))
                              conName
-       return $ CmmInfo gc_target Nothing (CmmInfoTable False prof cl_type info)
+       return $ CmmInfo gc_target Nothing (CmmInfoTable False False prof cl_type info)
 
     ClosureInfo { closureName   = name,
                   closureLFInfo = lf_info,
                   closureSRT    = srt } ->
-       return $ CmmInfo gc_target Nothing (CmmInfoTable False prof cl_type info)
+       return $ CmmInfo gc_target Nothing (CmmInfoTable (closureInfoLocal cl_info) False prof cl_type info)
        where
          info =
              case lf_info of
@@ -142,7 +142,7 @@ emitReturnTarget name stmts
         ; let info = CmmInfo
                        gc_target
                        Nothing
-                       (CmmInfoTable False
+                       (CmmInfoTable False False
                         (ProfilingInfo zeroCLit zeroCLit)
                         rET_SMALL -- cmmToRawCmm may convert it to rET_BIG
                         (ContInfo frame srt_info))
diff --git a/compiler/codeGen/ClosureInfo.lhs b/compiler/codeGen/ClosureInfo.lhs
index 4f59d95276..daf476adfc 100644
--- a/compiler/codeGen/ClosureInfo.lhs
+++ b/compiler/codeGen/ClosureInfo.lhs
@@ -50,7 +50,7 @@ module ClosureInfo (
 	isToplevClosure,
 	closureValDescr, closureTypeDescr,	-- profiling
 
-	isStaticClosure,
+	closureInfoLocal, isStaticClosure,
 	cafBlackHoleClosureInfo,
 
 	staticClosureNeedsLink,
@@ -111,7 +111,8 @@ data ClosureInfo
 	closureSMRep  :: !SMRep,	  -- representation used by storage mgr
 	closureSRT    :: !C_SRT,	  -- What SRT applies to this closure
 	closureType   :: !Type,		  -- Type of closure (ToDo: remove)
-	closureDescr  :: !String	  -- closure description (for profiling)
+	closureDescr  :: !String,	  -- closure description (for profiling)
+	closureInfLcl :: Bool             -- can the info pointer be a local symbol?
     }
 
   -- Constructor closures don't have a unique info table label (they use
@@ -341,7 +342,12 @@ mkClosureInfo is_static id lf_info tot_wds ptr_wds srt_info descr
 		  closureSMRep = sm_rep, 
 		  closureSRT = srt_info,
 		  closureType = idType id,
-		  closureDescr = descr }
+		  closureDescr = descr,
+		  closureInfLcl = isDataConWorkId id }
+		    -- Make the _info pointer for the implicit datacon worker binding
+		    -- local. The reason we can do this is that importing code always
+		    -- either uses the _closure or _con_info. By the invariants in CorePrep
+		    -- anything else gets eta expanded.
   where
     name   = idName id
     sm_rep = chooseSMRep is_static lf_info tot_wds ptr_wds
@@ -842,6 +848,9 @@ staticClosureRequired _ _ _ = True
 %************************************************************************
 
 \begin{code}
+closureInfoLocal :: ClosureInfo -> Bool
+closureInfoLocal ClosureInfo{ closureInfLcl = lcl } = lcl
+closureInfoLocal ConInfo{} = False
 
 isStaticClosure :: ClosureInfo -> Bool
 isStaticClosure cl_info = isStaticRep (closureSMRep cl_info)
@@ -927,9 +936,9 @@ infoTableLabelFromCI (ClosureInfo { closureName = name,
 	LFThunk _ _ upd_flag (ApThunk arity) _ -> 
 		mkApInfoTableLabel upd_flag arity
 
-	LFThunk{}      -> mkLocalInfoTableLabel name caf
+	LFThunk{}      -> mkInfoTableLabel name caf
 
-	LFReEntrant _ _ _ _ -> mkLocalInfoTableLabel name caf
+	LFReEntrant _ _ _ _ -> mkInfoTableLabel name caf
 
 	_ -> panic "infoTableLabelFromCI"
 
@@ -1003,7 +1012,8 @@ cafBlackHoleClosureInfo (ClosureInfo { closureName = nm,
 		  closureSMRep  = BlackHoleRep,
 		  closureSRT    = NoC_SRT,
 		  closureType   = ty,
-		  closureDescr  = "" }
+		  closureDescr  = "",
+		  closureInfLcl = False }
 cafBlackHoleClosureInfo _ = panic "cafBlackHoleClosureInfo"
 \end{code}
 
diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs
index a8d91f58d6..7c4f8bc8b8 100644
--- a/compiler/codeGen/StgCmmClosure.hs
+++ b/compiler/codeGen/StgCmmClosure.hs
@@ -56,7 +56,7 @@ module StgCmmClosure (
 	isToplevClosure,
 	closureValDescr, closureTypeDescr,	-- profiling
 
-	isStaticClosure,
+	closureInfoLocal, isStaticClosure,
 	cafBlackHoleClosureInfo, 
 
 	staticClosureNeedsLink, clHasCafRefs 
@@ -679,7 +679,8 @@ data ClosureInfo
 	closureSRT    :: !C_SRT,	  -- What SRT applies to this closure
 	closureType   :: !Type,		  -- Type of closure (ToDo: remove)
 	closureDescr  :: !String,	  -- closure description (for profiling)
-        closureCafs   :: !CafInfo         -- whether the closure may have CAFs
+        closureCafs   :: !CafInfo,        -- whether the closure may have CAFs
+	closureInfLcl :: Bool             -- can the info pointer be a local symbol?
     }
 
   -- Constructor closures don't have a unique info table label (they use
@@ -725,7 +726,12 @@ mkClosureInfo is_static id lf_info tot_wds ptr_wds srt_info descr
 		  closureSRT = srt_info,
 		  closureType = idType id,
 		  closureDescr = descr,
-                  closureCafs = idCafInfo id }
+                  closureCafs = idCafInfo id,
+		  closureInfLcl = isDataConWorkId id }
+		    -- Make the _info pointer for the implicit datacon worker binding
+		    -- local. The reason we can do this is that importing code always
+		    -- either uses the _closure or _con_info. By the invariants in CorePrep
+		    -- anything else gets eta expanded.
   where
     name   = idName id
     sm_rep = chooseSMRep is_static lf_info tot_wds ptr_wds
@@ -756,7 +762,8 @@ cafBlackHoleClosureInfo (ClosureInfo { closureName = nm,
 		  closureSRT    = NoC_SRT,
 		  closureType   = ty,
 		  closureDescr  = "", 
-		  closureCafs   = cafs }
+		  closureCafs   = cafs,
+		  closureInfLcl = False }
 cafBlackHoleClosureInfo _ = panic "cafBlackHoleClosureInfo"
 
 
@@ -931,6 +938,10 @@ staticClosureNeedsLink (ConInfo { closureSMRep = sm_rep, closureCon = con })
 	   GenericRep _ _ _ ConstrNoCaf -> False
 	   _other			-> True
 
+closureInfoLocal :: ClosureInfo -> Bool
+closureInfoLocal ClosureInfo{ closureInfLcl = lcl } = lcl
+closureInfoLocal ConInfo{} = False
+
 isStaticClosure :: ClosureInfo -> Bool
 isStaticClosure cl_info = isStaticRep (closureSMRep cl_info)
 
@@ -997,9 +1008,9 @@ infoTableLabelFromCI cl@(ClosureInfo { closureName = name,
 	LFThunk _ _ upd_flag (ApThunk arity) _ -> 
 		mkApInfoTableLabel upd_flag arity
 
-	LFThunk{}      -> mkLocalInfoTableLabel name $ clHasCafRefs cl
+	LFThunk{}      -> mkInfoTableLabel name $ clHasCafRefs cl
 
-	LFReEntrant _ _ _ _ -> mkLocalInfoTableLabel name $ clHasCafRefs cl
+	LFReEntrant _ _ _ _ -> mkInfoTableLabel name $ clHasCafRefs cl
 
 	_other -> panic "infoTableLabelFromCI"
 
diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs
index eddf257e5f..278c41aef2 100644
--- a/compiler/codeGen/StgCmmLayout.hs
+++ b/compiler/codeGen/StgCmmLayout.hs
@@ -496,7 +496,7 @@ mkCmmInfo cl_info
 	               ad_lit <- mkStringCLit (closureValDescr  cl_info)
 	               return $ ProfilingInfo fd_lit ad_lit
                   else return $ ProfilingInfo (mkIntCLit 0) (mkIntCLit 0)
-	; return (CmmInfoTable (isStaticClosure cl_info) prof cl_type info) }
+	; return (CmmInfoTable (closureInfoLocal cl_info) (isStaticClosure cl_info) prof cl_type info) }
   where
     k_with_con_name con_info con info_lbl =
       do cstr <- mkByteStringCLit $ dataConIdentity con