From: simonpj <unknown>
Date: Mon, 20 Aug 2001 16:50:13 +0000 (+0000)
Subject: [project @ 2001-08-20 16:50:13 by simonpj]
X-Git-Tag: Approximately_9120_patches~1167
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=0c190d9efcf76845241f756a1507267458b90c90;p=ghc-hetmet.git

[project @ 2001-08-20 16:50:13 by simonpj]
-------------------------------------
	Make NOINLINE zap the strictness info
	-------------------------------------

Make a NOINLINE pragma zap strictness information.
Reasons given in the WorkWrap comment:

	-- Furthermore, zap the strictess info in the Id.  Why?  Because
	-- the NOINLINE says "don't expose any of the inner workings at the call
	-- site" and the strictness is certainly an inner working.
	--
	-- More concretely, the demand analyser discovers the following strictness
	-- for unsafePerformIO:  C(U(AV))
	-- But then consider
	--	unsafePerformIO (\s -> let r = f x in
	--			       case writeIORef v r s of (# s1, _ #) ->
	--			       (# s1, r #)
	-- The strictness analyser will find that the binding for r is strict,
	-- (becuase of uPIO's strictness sig), and so it'll evaluate it before
	-- doing the writeIORef.  This actually makes tests/lib/should_run/memo002
	-- get a deadlock!
	--
	-- Solution: don't expose the strictness of unsafePerformIO.

This fixes the memo002 deadlock.
---

diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs
index 0586195..dd0bf19 100644
--- a/ghc/compiler/basicTypes/Id.lhs
+++ b/ghc/compiler/basicTypes/Id.lhs
@@ -44,8 +44,8 @@ module Id (
 	-- IdInfo stuff
 	setIdUnfolding,
 	setIdArityInfo,
-	setIdDemandInfo, setIdNewDemandInfo,
-	setIdStrictness, setIdNewStrictness,
+	setIdDemandInfo, setIdNewDemandInfo, 
+	setIdStrictness, setIdNewStrictness, zapIdNewStrictness,
         setIdTyGenInfo,
 	setIdWorkerInfo,
 	setIdSpecialisation,
@@ -357,6 +357,9 @@ oldStrictnessFromNew sig = mkStrictnessInfo (map oldDemand dmds, isBotRes res_in
 setIdNewStrictness :: Id -> StrictSig -> Id
 setIdNewStrictness id sig = modifyIdInfo (`setNewStrictnessInfo` Just sig) id
 
+zapIdNewStrictness :: Id -> Id
+zapIdNewStrictness id = modifyIdInfo (`setNewStrictnessInfo` Nothing) id
+
 	---------------------------------
 	-- TYPE GENERALISATION
 idTyGenInfo :: Id -> TyGenInfo
diff --git a/ghc/compiler/stranal/WorkWrap.lhs b/ghc/compiler/stranal/WorkWrap.lhs
index de60e75..fff7082 100644
--- a/ghc/compiler/stranal/WorkWrap.lhs
+++ b/ghc/compiler/stranal/WorkWrap.lhs
@@ -13,7 +13,7 @@ import CoreUnfold	( certainlyWillInline )
 import CoreLint		( showPass, endPass )
 import CoreUtils	( exprType )
 import Id		( Id, idType, idNewStrictness, idArity, isOneShotLambda,
-			  setIdNewStrictness, idInlinePragma, mkWorkerId,
+			  setIdNewStrictness, zapIdNewStrictness, idInlinePragma, mkWorkerId,
 			  setIdWorkerInfo, idCprInfo, setInlinePragma )
 import Type		( Type )
 import IdInfo		( mkStrictnessInfo, noStrictnessInfo, StrictnessInfo(..),
@@ -185,10 +185,28 @@ tryWW	:: RecFlag
 					-- if two, then a worker and a
 					-- wrapper.
 tryWW is_rec fn_id rhs
+  | isNeverInlinePrag inline_prag
+	-- Don't split NOINLINE things, because they will never be inlined
+	-- Furthermore, zap the strictess info in the Id.  Why?  Because
+	-- the NOINLINE says "don't expose any of the inner workings at the call 
+	-- site" and the strictness is certainly an inner working.
+	--
+	-- More concretely, the demand analyser discovers the following strictness
+	-- for unsafePerformIO:  C(U(AV))
+	-- But then consider
+	--	unsafePerformIO (\s -> let r = f x in 
+	--			       case writeIORef v r s of (# s1, _ #) ->
+	--			       (# s1, r #)
+	-- The strictness analyser will find that the binding for r is strict,
+	-- (becuase of uPIO's strictness sig), and so it'll evaluate it before 
+	-- doing the writeIORef.  This actually makes tests/lib/should_run/memo002
+	-- get a deadlock!  
+	--
+	-- Solution: don't expose the strictness of unsafePerformIO.
+  = returnUs [ (zapIdNewStrictness fn_id, rhs) ]
+
   |  arity == 0
 	-- Don't worker-wrapper thunks
-  || isNeverInlinePrag inline_prag
-	-- Don't split things that will never be inlined
   || isNonRec is_rec && certainlyWillInline fn_id
 	-- No point in worker/wrappering a function that is going to be
 	-- INLINEd wholesale anyway.  If the strictness analyser is run