X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fstranal%2FWorkWrap.lhs;h=86f64371ca70952946d775be8e6090aba0d0783a;hb=cae34044d89a87bd3da83b0e867b4a5d6994079a;hp=92eaf088aa0cb9815fbfc9b4f5af3835e0a7347e;hpb=b822aa0e9411a1909988c0367d342671806a0f75;p=ghc-hetmet.git

diff --git a/ghc/compiler/stranal/WorkWrap.lhs b/ghc/compiler/stranal/WorkWrap.lhs
index 92eaf08..86f6437 100644
--- a/ghc/compiler/stranal/WorkWrap.lhs
+++ b/ghc/compiler/stranal/WorkWrap.lhs
@@ -10,25 +10,20 @@ module WorkWrap ( wwTopBinds, mkWrapper ) where
 
 import CoreSyn
 import CoreUnfold	( Unfolding, certainlyWillInline )
-import CmdLineOpts	( opt_UF_CreationThreshold , opt_D_verbose_core2core, 
-                          opt_D_dump_worker_wrapper
-			)
+import CmdLineOpts	( opt_D_verbose_core2core, opt_D_dump_worker_wrapper )
 import CoreLint		( beginPass, endPass )
-import CoreUtils	( exprType, exprArity, exprEtaExpandArity )
-import DataCon		( DataCon )
+import CoreUtils	( exprType, exprEtaExpandArity )
 import MkId		( mkWorkerId )
-import Id		( Id, idType, idStrictness, setIdArityInfo, isOneShotLambda,
+import Id		( Id, idType, idStrictness, idArity, isOneShotLambda,
 			  setIdStrictness, idInlinePragma, 
 			  setIdWorkerInfo, idCprInfo, setInlinePragma )
-import VarSet
 import Type		( Type, isNewType, splitForAllTys, splitFunTys )
 import IdInfo		( mkStrictnessInfo, noStrictnessInfo, StrictnessInfo(..),
-			  CprInfo(..), exactArity, InlinePragInfo(..), WorkerInfo(..)
+			  CprInfo(..), exactArity, InlinePragInfo(..), isNeverInlinePrag,
+			  WorkerInfo(..)
 			)
 import Demand           ( Demand, wwLazy )
-import SaLib
 import UniqSupply	( UniqSupply, initUs_, returnUs, thenUs, mapUs, getUniqueUs, UniqSM )
-import UniqSet
 import WwLib
 import Outputable
 \end{code}
@@ -189,14 +184,30 @@ tryWW	:: Bool				-- True <=> a non-recursive binding
 					-- if two, then a worker and a
 					-- wrapper.
 tryWW non_rec fn_id rhs
-  | non_rec
-    && certainlyWillInline fn_id
-	-- No point in worker/wrappering something that is going to be
+  | isNeverInlinePrag inline_prag || arity == 0
+  = 	-- Don't split things that will never be inlined
+    returnUs [ (fn_id, rhs) ]
+
+  | non_rec && not do_coerce_ww && certainlyWillInline fn_id
+	-- No point in worker/wrappering a function that is going to be
 	-- INLINEd wholesale anyway.  If the strictness analyser is run
 	-- twice, this test also prevents wrappers (which are INLINEd)
 	-- from being re-done.
 	--
+	-- The do_coerce_ww test is so that
+	-- a function with a coerce should w/w to get rid
+	-- of the coerces, which can significantly improve its arity.
+	-- Example:  f []     = return [] :: IO [Int]
+	--	     f (x:xs) = return (x:xs)
+	-- If we aren't careful we end up with
+	--	f = \ x -> case x of {
+	--		     x:xs -> __coerce (IO [Int]) (\ s -> (# s, x:xs #)
+	--		     []   -> lvl_sJ8
+	--
+	--
 	-- OUT OF DATE NOTE, kept for info:
+	-- It's out of date because now wrappers look very cheap 
+	-- even when they are inlined.
 	--   In this case we add an INLINE pragma to the RHS.  Why?
 	--   Because consider
 	--	  f = \x -> g x x
@@ -204,8 +215,6 @@ tryWW non_rec fn_id rhs
 	--   Then f is small, so we don't w/w it.  But g is big, and we do, so
 	--   g's wrapper will get inlined in f's RHS, which makes f look big now.
 	--   So f doesn't get inlined, but it is strict and we have failed to w/w it.
-	-- It's out of date because now wrappers look very cheap 
-	-- even when they are inlined.
   = returnUs [ (fn_id, rhs) ]
 
   | not (do_strict_ww || do_cpr_ww || do_coerce_ww)
@@ -222,13 +231,9 @@ tryWW non_rec fn_id rhs
 	work_id | has_strictness = proto_work_id `setIdStrictness` mkStrictnessInfo (work_demands, result_bot)
 		| otherwise	 = proto_work_id
 
-	wrap_arity = exprArity wrap_rhs		-- Might be greater than the current visible arity
-						-- if the function returns bottom
-						
 	wrap_rhs = wrap_fn work_id
 	wrap_id  = fn_id `setIdStrictness`      wrapper_strictness
-                         `setIdWorkerInfo`	HasWorker work_id wrap_arity
-			 `setIdArityInfo`	exactArity wrap_arity
+                         `setIdWorkerInfo`	HasWorker work_id arity
 			 `setInlinePragma`	NoInlinePragInfo	-- Put it on the worker instead
 		-- Add info to the wrapper:
 		--	(a) we want to set its arity
@@ -237,12 +242,12 @@ tryWW non_rec fn_id rhs
     in
     returnUs ([(work_id, work_rhs), (wrap_id, wrap_rhs)])
 	-- Worker first, because wrapper mentions it
-	-- Arrange to inline the wrapper unconditionally
+	-- mkWwBodies has already built a wrap_rhs with an INLINE pragma wrapped around it
   where
     fun_ty = idType fn_id
-    arity  = exprEtaExpandArity rhs
+    arity  = idArity fn_id	-- The arity is set by the simplifier using exprEtaExpandArity
+				-- So it may be more than the number of top-level-visible lambdas
 
-	-- Don't split something which is marked unconditionally NOINLINE
     inline_prag  = idInlinePragma fn_id
 
     strictness_info           = idStrictness fn_id