From: sof <unknown>
Date: Mon, 26 May 1997 02:21:23 +0000 (+0000)
Subject: [project @ 1997-05-26 02:21:23 by sof]
X-Git-Tag: Approximately_1000_patches_recorded~540
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=2e0be817c7117655688f0f8ef03690853dff7292;p=ghc-hetmet.git

[project @ 1997-05-26 02:21:23 by sof]
Added code to retrieve all constructors mentioned in a wrapper (needed for StrictnessInfos)
---

diff --git a/ghc/compiler/stranal/WorkWrap.lhs b/ghc/compiler/stranal/WorkWrap.lhs
index e1621b3..4cadd88 100644
--- a/ghc/compiler/stranal/WorkWrap.lhs
+++ b/ghc/compiler/stranal/WorkWrap.lhs
@@ -9,6 +9,7 @@
 module WorkWrap ( workersAndWrappers ) where
 
 IMP_Ubiq(){-uitous-}
+IMPORT_1_3(List(nub))
 
 import CoreSyn
 import CoreUnfold	( Unfolding, certainlySmallEnoughToInline, calcUnfoldingGuidance )
@@ -212,12 +213,13 @@ tryWW fn_id rhs
 	work_info = noIdInfo `addStrictnessInfo` mkStrictnessInfo work_demands Nothing
 
 	wrap_rhs = wrap_fn work_id
+	ww_cons  = nub (get_ww_cons wrap_rhs)
 	wrap_id  = addInlinePragma (fn_id `addIdStrictness`
-				    mkStrictnessInfo revised_wrap_args_info (Just work_id))
+				    mkStrictnessInfo revised_wrap_args_info (Just (work_id, ww_cons)))
 		-- Add info to the wrapper:
 		--	(a) we want to inline it everywhere
 		-- 	(b) we want to pin on its revised stricteness info
-		--	(c) we pin on its worker id
+		--	(c) we pin on its worker id and the list of constructors mentioned in the wrapper
     in
     returnUs ([(work_id, work_rhs), (wrap_id, wrap_rhs)])
 	-- Worker first, because wrapper mentions it
@@ -230,4 +232,12 @@ tryWW fn_id rhs
     wrap_args_info = case strictness_info of
 			StrictnessInfo args_info _ -> args_info
     revised_wrap_args_info = setUnpackStrategy wrap_args_info
+
+-- This rather crude function snaffles out the constructors needed to 
+-- make the wrapper, so that we can stick them in the strictness info.
+-- They're only needed if this thing gets exported.
+get_ww_cons (Lam _ body)		       = get_ww_cons body
+get_ww_cons (App fn _)  		       = get_ww_cons fn
+get_ww_cons (Case _ (AlgAlts [(con,_,rhs)] _)) = con : get_ww_cons rhs
+get_ww_cons other			       = []
 \end{code}