X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fstranal%2FWorkWrap.lhs;h=d061de5b8c711a44be5eb0028872068974eb130b;hb=1ca40c2037a0e973dd73d98cd20313ecdbfeb6fc;hp=2f5d38c0691aac0ed2f5c72e0a690eb8537532f1;hpb=f3c4792fad3bf46e5ee500a909287718324c45d1;p=ghc-hetmet.git

diff --git a/compiler/stranal/WorkWrap.lhs b/compiler/stranal/WorkWrap.lhs
index 2f5d38c..d061de5 100644
--- a/compiler/stranal/WorkWrap.lhs
+++ b/compiler/stranal/WorkWrap.lhs
@@ -11,11 +11,11 @@ module WorkWrap ( wwTopBinds, mkWrapper ) where
 import CoreSyn
 import CoreUnfold	( certainlyWillInline )
 import CoreLint		( showPass, endPass )
-import CoreUtils	( exprType, exprIsHNF )
+import CoreUtils	( exprType, exprIsHNF, exprArity )
 import Id		( Id, idType, isOneShotLambda, 
 			  setIdNewStrictness, mkWorkerId,
 			  setIdWorkerInfo, setInlinePragma,
-			  idInfo )
+			  setIdArity, idInfo )
 import MkId		( lazyIdKey, lazyIdUnfolding )
 import Type		( Type )
 import IdInfo		( WorkerInfo(..), arityInfo,
@@ -269,6 +269,9 @@ splitFun fn_id fn_info wrap_dmds res_info inline_prag rhs
 			`setIdNewStrictness` StrictSig (mkTopDmdType work_demands work_res_info)
 				-- Even though we may not be at top level, 
 				-- it's ok to give it an empty DmdEnv
+                        `setIdArity` (exprArity work_rhs)
+                                -- Set the arity so that the Core Lint check that the 
+                                -- arity is consistent with the demand type goes through
 
 	wrap_rhs = wrap_fn work_id
 	wrap_id  = fn_id `setIdWorkerInfo` HasWorker work_id arity
@@ -317,7 +320,7 @@ splitThunk transforms like this:
 Now simplifier will transform to
 
       case x-rhs of 
-	I# a ->	let x* = I# b 
+	I# a ->	let x* = I# a 
 	        in body
 
 which is what we want. Now suppose x-rhs is itself a case: