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

diff --git a/compiler/stranal/WorkWrap.lhs b/compiler/stranal/WorkWrap.lhs
index 2f5d38c..3667da8 100644
--- a/compiler/stranal/WorkWrap.lhs
+++ b/compiler/stranal/WorkWrap.lhs
@@ -4,6 +4,13 @@
 \section[WorkWrap]{Worker/wrapper-generating back-end of strictness analyser}
 
 \begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
 module WorkWrap ( wwTopBinds, mkWrapper ) where
 
 #include "HsVersions.h"
@@ -11,11 +18,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,
@@ -26,7 +33,7 @@ import NewDemand        ( Demand(..), StrictSig(..), DmdType(..), DmdResult(..),
 			)
 import UniqSupply	( UniqSupply, initUs_, returnUs, thenUs, mapUs, getUniqueUs, UniqSM )
 import Unique		( hasKey )
-import BasicTypes	( RecFlag(..), isNonRec )
+import BasicTypes	( RecFlag(..), isNonRec, isNeverActive )
 import VarEnv		( isEmptyVarEnv )
 import Maybes		( orElse )
 import DynFlags
@@ -215,6 +222,11 @@ tryWW is_rec fn_id rhs
 	--	fw = \ab -> (__inline (\x -> E)) (a,b)
 	-- and the original __inline now vanishes, so E is no longer
 	-- inside its __inline wrapper.  Death!  Disaster!
+
+  || isNeverActive inline_prag
+	-- No point in worker/wrappering if the thing is never inlined!
+	-- Because the no-inline prag will prevent the wrapper ever
+	-- being inlined at a call site. 
   = returnUs [ (new_fn_id, rhs) ]
 
   | is_thunk && worthSplittingThunk maybe_fn_dmd res_info
@@ -269,6 +281,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 +332,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:
@@ -361,17 +376,7 @@ worthSplittingFun ds res
   = any worth_it ds || returnsCPR res
 	-- worthSplitting returns False for an empty list of demands,
 	-- and hence do_strict_ww is False if arity is zero and there is no CPR
-
-	-- We used not to split if the result is bottom.
-	-- [Justification:  there's no efficiency to be gained.]
-	-- But it's sometimes bad not to make a wrapper.  Consider
-	--	fw = \x# -> let x = I# x# in case e of
-	--					p1 -> error_fn x
-	--					p2 -> error_fn x
-	--					p3 -> the real stuff
-	-- The re-boxing code won't go away unless error_fn gets a wrapper too.
-	-- [We don't do reboxing now, but in general it's better to pass 
-	--  an unboxed thing to f, and have it reboxed in the error cases....]
+  -- See Note [Worker-wrapper for bottoming functions]
   where
     worth_it Abs	      = True	-- Absent arg
     worth_it (Eval (Prod ds)) = True	-- Product arg to evaluate
@@ -388,6 +393,19 @@ worthSplittingThunk maybe_dmd res
     worth_it other	   	     = False
 \end{code}
 
+Note [Worker-wrapper for bottoming functions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We used not to split if the result is bottom.
+[Justification:  there's no efficiency to be gained.]
+
+But it's sometimes bad not to make a wrapper.  Consider
+	fw = \x# -> let x = I# x# in case e of
+					p1 -> error_fn x
+					p2 -> error_fn x
+					p3 -> the real stuff
+The re-boxing code won't go away unless error_fn gets a wrapper too.
+[We don't do reboxing now, but in general it's better to pass an
+unboxed thing to f, and have it reboxed in the error cases....]
 
 
 %************************************************************************