X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fstranal%2FWorkWrap.lhs;h=438afd6cf551431ac4cbc616fdff20e43afe797b;hp=a1b18a98fb2d00266614aa2016b97e49dbc417cb;hb=9bcd95bad83ee937c178970e8b729732e680fe1e;hpb=481b014b46dd53ef5d1c5e679e1d9f08207af96e

diff --git a/compiler/stranal/WorkWrap.lhs b/compiler/stranal/WorkWrap.lhs
index a1b18a9..438afd6 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"
@@ -24,15 +31,15 @@ import IdInfo		( WorkerInfo(..), arityInfo,
 import NewDemand        ( Demand(..), StrictSig(..), DmdType(..), DmdResult(..), 
 			  Demands(..), mkTopDmdType, isBotRes, returnsCPR, topSig, isAbsent
 			)
-import UniqSupply	( UniqSupply, initUs_, returnUs, thenUs, mapUs, getUniqueUs, UniqSM )
+import UniqSupply
 import Unique		( hasKey )
 import BasicTypes	( RecFlag(..), isNonRec, isNeverActive )
 import VarEnv		( isEmptyVarEnv )
 import Maybes		( orElse )
-import DynFlags
 import WwLib
 import Util		( lengthIs, notNull )
 import Outputable
+import MonadUtils
 \end{code}
 
 We take Core bindings whose binders have:
@@ -62,33 +69,12 @@ info for exported values).
 \end{enumerate}
 
 \begin{code}
+wwTopBinds :: UniqSupply -> [CoreBind] -> [CoreBind]
 
-wwTopBinds :: DynFlags 
-	   -> UniqSupply
-	   -> [CoreBind]
-	   -> IO [CoreBind]
-
-wwTopBinds dflags us binds
-  = do {
-	showPass dflags "Worker Wrapper binds";
-
-	-- Create worker/wrappers, and mark binders with their
-	-- "strictness info" [which encodes their worker/wrapper-ness]
-	let { binds' = workersAndWrappers us binds };
-
-	endPass dflags "Worker Wrapper binds" 
-		Opt_D_dump_worker_wrapper binds'
-    }
-\end{code}
-
-
-\begin{code}
-workersAndWrappers :: UniqSupply -> [CoreBind] -> [CoreBind]
-
-workersAndWrappers us top_binds
-  = initUs_ us $
-    mapUs wwBind top_binds `thenUs` \ top_binds' ->
-    returnUs (concat top_binds')
+wwTopBinds us top_binds
+  = initUs_ us $ do
+    top_binds' <- mapM wwBind top_binds
+    return (concat top_binds')
 \end{code}
 
 %************************************************************************
@@ -106,19 +92,18 @@ wwBind	:: CoreBind
 				-- the caller will convert to Expr/Binding,
 				-- as appropriate.
 
-wwBind (NonRec binder rhs)
-  = wwExpr rhs				`thenUs` \ new_rhs ->
-    tryWW NonRecursive binder new_rhs 	`thenUs` \ new_pairs ->
-    returnUs [NonRec b e | (b,e) <- new_pairs]
+wwBind (NonRec binder rhs) = do
+    new_rhs <- wwExpr rhs
+    new_pairs <- tryWW NonRecursive binder new_rhs
+    return [NonRec b e | (b,e) <- new_pairs]
       -- Generated bindings must be non-recursive
       -- because the original binding was.
 
 wwBind (Rec pairs)
-  = mapUs do_one pairs		`thenUs` \ new_pairs ->
-    returnUs [Rec (concat new_pairs)]
+  = return . Rec <$> concatMapM do_one pairs
   where
-    do_one (binder, rhs) = wwExpr rhs 	`thenUs` \ new_rhs ->
-			   tryWW Recursive binder new_rhs
+    do_one (binder, rhs) = do new_rhs <- wwExpr rhs
+                              tryWW Recursive binder new_rhs
 \end{code}
 
 @wwExpr@ basically just walks the tree, looking for appropriate
@@ -129,47 +114,41 @@ matching by looking for strict arguments of the correct type.
 \begin{code}
 wwExpr :: CoreExpr -> UniqSM CoreExpr
 
-wwExpr e@(Type _)   	      = returnUs e
-wwExpr e@(Lit _)    	      = returnUs e
-wwExpr e@(Note InlineMe expr) = returnUs e
+wwExpr e@(Type _)             = return e
+wwExpr e@(Lit _)              = return e
+wwExpr e@(Note InlineMe expr) = return e
 	-- Don't w/w inside InlineMe's
 
 wwExpr e@(Var v)
-  | v `hasKey` lazyIdKey = returnUs lazyIdUnfolding
-  | otherwise            = returnUs e
+  | v `hasKey` lazyIdKey = return lazyIdUnfolding
+  | otherwise            = return e
 	-- HACK alert: Inline 'lazy' after strictness analysis
 	-- (but not inside InlineMe's)
 
 wwExpr (Lam binder expr)
-  = wwExpr expr			`thenUs` \ new_expr ->
-    returnUs (Lam binder new_expr)
+  = Lam binder <$> wwExpr expr
 
 wwExpr (App f a)
-  = wwExpr f			`thenUs` \ new_f ->
-    wwExpr a			`thenUs` \ new_a ->
-    returnUs (App new_f new_a)
+  = App <$> wwExpr f <*> wwExpr a
 
 wwExpr (Note note expr)
-  = wwExpr expr			`thenUs` \ new_expr ->
-    returnUs (Note note new_expr)
+  = Note note <$> wwExpr expr
 
-wwExpr (Cast expr co)
-  = wwExpr expr			`thenUs` \ new_expr ->
-    returnUs (Cast new_expr co)
+wwExpr (Cast expr co) = do
+    new_expr <- wwExpr expr
+    return (Cast new_expr co)
 
 wwExpr (Let bind expr)
-  = wwBind bind			`thenUs` \ intermediate_bind ->
-    wwExpr expr			`thenUs` \ new_expr ->
-    returnUs (mkLets intermediate_bind new_expr)
-
-wwExpr (Case expr binder ty alts)
-  = wwExpr expr				`thenUs` \ new_expr ->
-    mapUs ww_alt alts			`thenUs` \ new_alts ->
-    returnUs (Case new_expr binder ty new_alts)
+  = mkLets <$> wwBind bind <*> wwExpr expr
+
+wwExpr (Case expr binder ty alts) = do
+    new_expr <- wwExpr expr
+    new_alts <- mapM ww_alt alts
+    return (Case new_expr binder ty new_alts)
   where
-    ww_alt (con, binders, rhs)
-      =	wwExpr rhs			`thenUs` \ new_rhs ->
-	returnUs (con, binders, new_rhs)
+    ww_alt (con, binders, rhs) = do
+        new_rhs <- wwExpr rhs
+        return (con, binders, new_rhs)
 \end{code}
 
 %************************************************************************
@@ -190,6 +169,27 @@ reason), then we don't w-w it.
 
 The only reason this is monadised is for the unique supply.
 
+Note [Don't w/w inline things]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's very important to refrain from w/w-ing an INLINE function
+If we do so by mistake we transform
+	f = __inline (\x -> E)
+into
+	f = __inline (\x -> case x of (a,b) -> fw E)
+	fw = \ab -> (__inline (\x -> E)) (a,b)
+and the original __inline now vanishes, so E is no longer
+inside its __inline wrapper.  Death!  Disaster!
+
+Furthermore, if the programmer has marked something as INLINE, 
+we may lose by w/w'ing it.
+
+If the strictness analyser is run twice, this test also prevents
+wrappers (which are INLINEd) from being re-done.
+
+Notice that we refrain from w/w'ing an INLINE function even if it is
+in a recursive group.  It might not be the loop breaker.  (We could
+test for loop-breaker-hood, but I'm not sure that ever matters.)
+
 \begin{code}
 tryWW	:: RecFlag
 	-> Id				-- The fn binder
@@ -201,26 +201,14 @@ tryWW	:: RecFlag
 					-- if two, then a worker and a
 					-- wrapper.
 tryWW is_rec fn_id rhs
-  |  isNonRec is_rec && certainlyWillInline unfolding
-	-- 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.
-	--	
-	-- It's very important to refrain from w/w-ing an INLINE function
-	-- If we do so by mistake we transform
-	--	f = __inline (\x -> E)
-	-- into
-	--	f = __inline (\x -> case x of (a,b) -> fw E)
-	--	fw = \ab -> (__inline (\x -> E)) (a,b)
-	-- and the original __inline now vanishes, so E is no longer
-	-- inside its __inline wrapper.  Death!  Disaster!
+  |  -- isNonRec is_rec && 	-- Now omitted: see Note [Don't w/w inline things]
+     certainlyWillInline unfolding
 
   || 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) ]
+  = return [ (new_fn_id, rhs) ]
 
   | is_thunk && worthSplittingThunk maybe_fn_dmd res_info
   = ASSERT2( isNonRec is_rec, ppr new_fn_id )	-- The thunk must be non-recursive
@@ -230,7 +218,7 @@ tryWW is_rec fn_id rhs
   = splitFun new_fn_id fn_info wrap_dmds res_info inline_prag rhs
 
   | otherwise
-  = returnUs [ (new_fn_id, rhs) ]
+  = return [ (new_fn_id, rhs) ]
 
   where
     fn_info   	 = idInfo fn_id
@@ -257,11 +245,12 @@ tryWW is_rec fn_id rhs
 
 ---------------------
 splitFun fn_id fn_info wrap_dmds res_info inline_prag rhs
-  = WARN( not (wrap_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr res_info) )
+  = WARN( not (wrap_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr res_info) ) 
+    (do {
 	-- The arity should match the signature
-    mkWwBodies fun_ty wrap_dmds res_info one_shots 	`thenUs` \ (work_demands, wrap_fn, work_fn) ->
-    getUniqueUs						`thenUs` \ work_uniq ->
-    let
+      (work_demands, wrap_fn, work_fn) <- mkWwBodies fun_ty wrap_dmds res_info one_shots
+    ; work_uniq <- getUniqueM
+    ; let
 	work_rhs = work_fn rhs
 	work_id  = mkWorkerId work_uniq fn_id (exprType work_rhs) 
 			`setInlinePragma` inline_prag
@@ -281,8 +270,7 @@ splitFun fn_id fn_info wrap_dmds res_info inline_prag rhs
 	wrap_rhs = wrap_fn work_id
 	wrap_id  = fn_id `setIdWorkerInfo` HasWorker work_id arity
 
-    in
-    returnUs ([(work_id, work_rhs), (wrap_id, wrap_rhs)])
+    ; return ([(work_id, work_rhs), (wrap_id, wrap_rhs)]) })
 	-- Worker first, because wrapper mentions it
 	-- mkWwBodies has already built a wrap_rhs with an INLINE pragma wrapped around it
   where
@@ -301,7 +289,7 @@ splitFun fn_id fn_info wrap_dmds res_info inline_prag rhs
 -- Otherwise we spuriously float stuff out of case-expression join points,
 -- which is very annoying.
 get_one_shots (Lam b e)
-  | isId b    = isOneShotLambda b : get_one_shots e
+  | isIdVar b = isOneShotLambda b : get_one_shots e
   | otherwise = get_one_shots e
 get_one_shots (Note _ e) = get_one_shots e
 get_one_shots other	 = noOneShotInfo
@@ -350,9 +338,9 @@ then the splitting will go deeper too.
 --		 I# y -> let x = I# y in x }
 -- See comments above. Is it not beautifully short?
 
-splitThunk fn_id rhs
-  = mkWWstr [fn_id]		`thenUs` \ (_, wrap_fn, work_fn) ->
-    returnUs [ (fn_id, Let (NonRec fn_id rhs) (wrap_fn (work_fn (Var fn_id)))) ]
+splitThunk fn_id rhs = do
+    (_, wrap_fn, work_fn) <- mkWWstr [fn_id]
+    return [ (fn_id, Let (NonRec fn_id rhs) (wrap_fn (work_fn (Var fn_id)))) ]
 \end{code}
 
 
@@ -369,17 +357,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
@@ -396,6 +374,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....]
 
 
 %************************************************************************
@@ -412,9 +403,9 @@ mkWrapper :: Type		-- Wrapper type
 	  -> StrictSig		-- Wrapper strictness info
 	  -> UniqSM (Id -> CoreExpr)	-- Wrapper body, missing worker Id
 
-mkWrapper fun_ty (StrictSig (DmdType _ demands res_info))
-  = mkWwBodies fun_ty demands res_info noOneShotInfo	`thenUs` \ (_, wrap_fn, _) ->
-    returnUs wrap_fn
+mkWrapper fun_ty (StrictSig (DmdType _ demands res_info)) = do
+    (_, wrap_fn, _) <- mkWwBodies fun_ty demands res_info noOneShotInfo
+    return wrap_fn
 
 noOneShotInfo = repeat False
 \end{code}