From: simonpj <unknown>
Date: Wed, 24 Oct 2001 08:34:04 +0000 (+0000)
Subject: [project @ 2001-10-24 08:34:04 by simonpj]
X-Git-Tag: Approximately_9120_patches~728
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=10edb6aa307238c45aafbbe6c733c70da92b10c3;p=ghc-hetmet.git

[project @ 2001-10-24 08:34:04 by simonpj]
Add strictness info for constructor wrappers
---

diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs
index 75060e9..6c53312 100644
--- a/ghc/compiler/basicTypes/MkId.lhs
+++ b/ghc/compiler/basicTypes/MkId.lhs
@@ -107,8 +107,8 @@ wiredInIds
 	-- 
 	-- [The interface file format now carry such information, but there's
 	-- no way yet of expressing at the definition site for these 
-	-- error-reporting
-	-- functions that they have an 'open' result type. -- sof 1/99]
+	-- error-reporting functions that they have an 'open' 
+	-- result type. -- sof 1/99]
 
       aBSENT_ERROR_ID
     , eRROR_ID
@@ -241,12 +241,19 @@ mkDataConWrapId data_con
 
     wrap_ty = mkForAllTys all_tyvars (mkFunTys all_arg_tys result_ty)
 
+    wrap_sig = mkStrictSig (mkTopDmdType arg_dmds res_info)
     res_info = strictSigResInfo (idNewStrictness work_id)
-    wrap_sig = mkStrictSig (mkTopDmdType (replicate arity topDmd) res_info)
+    arg_dmds = [Abs | d <- dict_args] ++ map mk_dmd strict_marks
+    mk_dmd str | isMarkedStrict str = Eval
+	       | otherwise	    = Lazy
 	-- The Cpr info can be important inside INLINE rhss, where the
 	-- wrapper constructor isn't inlined
-	-- But we are sloppy about the argument demands, because we expect 
-	-- to inline the constructor very vigorously.
+	-- And the argument strictness can be important too; we
+	-- may not inline a contructor when it is partially applied.
+	-- For example:
+	--	data W = C !Int !Int !Int
+	--	...(let w = C x in ...(w p q)...)...
+	-- we want to see that w is strict in its two arguments
 
     wrap_rhs | isNewTyCon tycon
 	     = ASSERT( null ex_tyvars && null ex_dict_args && length orig_arg_tys == 1 )