\section[WwLib]{A library for the ``worker/wrapper'' back-end to the 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 WwLib ( mkWwBodies, mkWWstr, mkWorkerArgs ) where
#include "HsVersions.h"
setIdInfo
)
import IdInfo ( vanillaIdInfo )
-import DataCon ( deepSplitProductType_maybe, deepSplitProductType )
+import DataCon
import NewDemand ( Demand(..), DmdResult(..), Demands(..) )
import MkId ( realWorldPrimId, voidArgId, mkRuntimeErrorApp, rUNTIME_ERROR_ID,
mkUnpackCase, mkProductBox )
import Coercion ( mkSymCoercion, splitNewTypeRepCo_maybe )
import BasicTypes ( Boxity(..) )
import Var ( Var, isId )
-import UniqSupply ( returnUs, thenUs, getUniquesUs, UniqSM )
+import UniqSupply
+import Unique
import Util ( zipWithEqual, notNull )
import Outputable
+import FastString
import List ( zipWith4 )
\end{code}
-- let x = (a,b) in
-- E
-mkWwBodies fun_ty demands res_info one_shots
- = mkWWargs fun_ty demands one_shots' `thenUs` \ (wrap_args, wrap_fn_args, work_fn_args, res_ty) ->
- mkWWstr wrap_args `thenUs` \ (work_args, wrap_fn_str, work_fn_str) ->
- let
- (work_lam_args, work_call_args) = mkWorkerArgs work_args res_ty
- in
- -- Don't do CPR if the worker doesn't have any value arguments
- -- Then the worker is just a constant, so we don't want to unbox it.
- (if any isId work_args then
- mkWWcpr res_ty res_info
- else
- returnUs (id, id, res_ty)
- ) `thenUs` \ (wrap_fn_cpr, work_fn_cpr, _cpr_res_ty) ->
-
- returnUs ([idNewDemandInfo v | v <- work_call_args, isId v],
- Note InlineMe . wrap_fn_args . wrap_fn_cpr . wrap_fn_str . applyToVars work_call_args . Var,
- mkLams work_lam_args. work_fn_str . work_fn_cpr . work_fn_args)
- -- We use an INLINE unconditionally, even if the wrapper turns out to be
- -- something trivial like
- -- fw = ...
- -- f = __inline__ (coerce T fw)
- -- The point is to propagate the coerce to f's call sites, so even though
- -- f's RHS is now trivial (size 1) we still want the __inline__ to prevent
- -- fw from being inlined into f's RHS
+mkWwBodies fun_ty demands res_info one_shots = do
+ (wrap_args, wrap_fn_args, work_fn_args, res_ty) <- mkWWargs fun_ty demands one_shots'
+ (work_args, wrap_fn_str, work_fn_str) <- mkWWstr wrap_args
+ let (work_lam_args, work_call_args) = mkWorkerArgs work_args res_ty
+ -- Don't do CPR if the worker doesn't have any value arguments
+ -- Then the worker is just a constant, so we don't want to unbox it.
+ (wrap_fn_cpr, work_fn_cpr, _cpr_res_ty)
+ <- if any isId work_args then
+ mkWWcpr res_ty res_info
+ else
+ return (id, id, res_ty)
+
+ return ([idNewDemandInfo v | v <- work_call_args, isId v],
+ Note InlineMe . wrap_fn_args . wrap_fn_cpr . wrap_fn_str . applyToVars work_call_args . Var,
+ mkLams work_lam_args. work_fn_str . work_fn_cpr . work_fn_args)
+ -- We use an INLINE unconditionally, even if the wrapper turns out to be
+ -- something trivial like
+ -- fw = ...
+ -- f = __inline__ (coerce T fw)
+ -- The point is to propagate the coerce to f's call sites, so even though
+ -- f's RHS is now trivial (size 1) we still want the __inline__ to prevent
+ -- fw from being inlined into f's RHS
where
one_shots' = one_shots ++ repeat False
\end{code}
Type) -- Type of wrapper body
mkWWargs fun_ty demands one_shots
- | Just (rep_ty, co) <- splitNewTypeRepCo_maybe fun_ty
+ | Just (rep_ty, co) <- splitNewTypeRepCo_maybe fun_ty = do
-- The newtype case is for when the function has
-- a recursive newtype after the arrow (rare)
-- We check for arity >= 0 to avoid looping in the case
-- wrapped in a recursive newtype, at least if CPR analysis can look
-- through such newtypes, which it probably can since they are
-- simply coerces.
- = mkWWargs rep_ty demands one_shots `thenUs` \ (wrap_args, wrap_fn_args, work_fn_args, res_ty) ->
- returnUs (wrap_args,
- \ e -> Cast (wrap_fn_args e) (mkSymCoercion co),
- \ e -> work_fn_args (Cast e co),
- res_ty)
- | notNull demands
- = getUniquesUs `thenUs` \ wrap_uniqs ->
+ (wrap_args, wrap_fn_args, work_fn_args, res_ty) <- mkWWargs rep_ty demands one_shots
+ return (wrap_args,
+ \ e -> Cast (wrap_fn_args e) (mkSymCoercion co),
+ \ e -> work_fn_args (Cast e co),
+ res_ty)
+ | notNull demands = do
+ wrap_uniqs <- getUniquesM
let
(tyvars, tau) = splitForAllTys fun_ty
(arg_tys, body_ty) = splitFunTys tau
new_demands = drop n_arg_tys demands
new_one_shots = drop n_args one_shots
- val_args = zipWith4 mk_wrap_arg wrap_uniqs arg_tys demands one_shots
+ val_args = zipWith4 mk_wrap_arg wrap_uniqs arg_tys demands one_shots
wrap_args = tyvars ++ val_args
- in
{- ASSERT( notNull tyvars || notNull arg_tys ) -}
if (null tyvars) && (null arg_tys) then
- pprTrace "mkWWargs" (ppr fun_ty $$ ppr demands)
- returnUs ([], id, id, fun_ty)
- else
+ pprTrace "mkWWargs" (ppr fun_ty $$ ppr demands)
+ return ([], id, id, fun_ty)
+ else do
- mkWWargs new_fun_ty
- new_demands
- new_one_shots `thenUs` \ (more_wrap_args, wrap_fn_args, work_fn_args, res_ty) ->
+ (more_wrap_args, wrap_fn_args, work_fn_args, res_ty) <-
+ mkWWargs new_fun_ty new_demands new_one_shots
- returnUs (wrap_args ++ more_wrap_args,
- mkLams wrap_args . wrap_fn_args,
- work_fn_args . applyToVars wrap_args,
- res_ty)
+ return (wrap_args ++ more_wrap_args,
+ mkLams wrap_args . wrap_fn_args,
+ work_fn_args . applyToVars wrap_args,
+ res_ty)
| otherwise
- = returnUs ([], id, id, fun_ty)
+ = return ([], id, id, fun_ty)
applyToVars :: [Var] -> CoreExpr -> CoreExpr
applyToVars vars fn = mkVarApps fn vars
+mk_wrap_arg :: Unique -> Type -> NewDemand.Demand -> Bool -> Id
mk_wrap_arg uniq ty dmd one_shot
= set_one_shot one_shot (setIdNewDemandInfo (mkSysLocal FSLIT("w") uniq ty) dmd)
where
CoreExpr -> CoreExpr) -- Worker body, lacking the original body of the function,
-- and lacking its lambdas.
-- This fn does the reboxing
-
-----------------------
-nop_fn body = body
-
-----------------------
mkWWstr []
- = returnUs ([], nop_fn, nop_fn)
-
-mkWWstr (arg : args)
- = mkWWstr_one arg `thenUs` \ (args1, wrap_fn1, work_fn1) ->
- mkWWstr args `thenUs` \ (args2, wrap_fn2, work_fn2) ->
- returnUs (args1 ++ args2, wrap_fn1 . wrap_fn2, work_fn1 . work_fn2)
+ = return ([], nop_fn, nop_fn)
+mkWWstr (arg : args) = do
+ (args1, wrap_fn1, work_fn1) <- mkWWstr_one arg
+ (args2, wrap_fn2, work_fn2) <- mkWWstr args
+ return (args1 ++ args2, wrap_fn1 . wrap_fn2, work_fn1 . work_fn2)
----------------------
-- mkWWstr_one wrap_arg = (work_args, wrap_fn, work_fn)
-- brings into scope work_args (via cases)
-- * work_fn assumes work_args are in scope, a
-- brings into scope wrap_arg (via lets)
-
+mkWWstr_one :: Var -> UniqSM ([Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
mkWWstr_one arg
| isTyVar arg
- = returnUs ([arg], nop_fn, nop_fn)
+ = return ([arg], nop_fn, nop_fn)
| otherwise
= case idNewDemandInfo arg of
-- though, because it's not so easy to manufacture a placeholder
-- We'll see if this turns out to be a problem
Abs | not (isUnLiftedType (idType arg)) ->
- returnUs ([], nop_fn, mk_absent_let arg)
+ return ([], nop_fn, mk_absent_let arg)
-- Unpack case
Eval (Prod cs)
| Just (_arg_tycon, _tycon_arg_tys, data_con, inst_con_arg_tys)
<- deepSplitProductType_maybe (idType arg)
- -> getUniquesUs `thenUs` \ uniqs ->
- let
- unpk_args = zipWith mk_ww_local uniqs inst_con_arg_tys
- unpk_args_w_ds = zipWithEqual "mkWWstr" set_worker_arg_info unpk_args cs
- unbox_fn = mkUnpackCase (sanitiseCaseBndr arg) (Var arg) unpk_args data_con
- rebox_fn = Let (NonRec arg con_app)
- con_app = mkProductBox unpk_args (idType arg)
- in
- mkWWstr unpk_args_w_ds `thenUs` \ (worker_args, wrap_fn, work_fn) ->
- returnUs (worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn)
+ -> do uniqs <- getUniquesM
+ let
+ unpk_args = zipWith mk_ww_local uniqs inst_con_arg_tys
+ unpk_args_w_ds = zipWithEqual "mkWWstr" set_worker_arg_info unpk_args cs
+ unbox_fn = mkUnpackCase (sanitiseCaseBndr arg) (Var arg) unpk_args data_con
+ rebox_fn = Let (NonRec arg con_app)
+ con_app = mkProductBox unpk_args (idType arg)
+ (worker_args, wrap_fn, work_fn) <- mkWWstr unpk_args_w_ds
+ return (worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn)
-- Don't pass the arg, rebox instead
-- `seq` demand; evaluate in wrapper in the hope
-- Tell the worker arg that it's sure to be evaluated
-- so that internal seqs can be dropped
in
- returnUs ([arg_w_unf], mk_seq_case arg, nop_fn)
+ return ([arg_w_unf], mk_seq_case arg, nop_fn)
-- Pass the arg, anyway, even if it is in theory discarded
-- Consider
-- f x y = x `seq` y
-- during simplification, so for now I've just nuked this whole case
-- Other cases
- other_demand -> returnUs ([arg], nop_fn, nop_fn)
+ _other_demand -> return ([arg], nop_fn, nop_fn)
where
-- If the wrapper argument is a one-shot lambda, then
set_one_shot | isOneShotLambda arg = setOneShotLambda
| otherwise = \x -> x
+
+----------------------
+nop_fn :: CoreExpr -> CoreExpr
+nop_fn body = body
\end{code}
| not (isClosedAlgType body_ty)
= WARN( True,
text "mkWWcpr: non-algebraic or open body type" <+> ppr body_ty )
- returnUs (id, id, body_ty)
+ return (id, id, body_ty)
- | n_con_args == 1 && isUnLiftedType con_arg_ty1
+ | n_con_args == 1 && isUnLiftedType con_arg_ty1 = do
-- Special case when there is a single result of unlifted type
--
-- Wrapper: case (..call worker..) of x -> C x
-- Worker: case ( ..body.. ) of C x -> x
- = getUniquesUs `thenUs` \ (work_uniq : arg_uniq : _) ->
+ (work_uniq : arg_uniq : _) <- getUniquesM
let
work_wild = mk_ww_local work_uniq body_ty
arg = mk_ww_local arg_uniq con_arg_ty1
con_app = mkProductBox [arg] body_ty
- in
- returnUs (\ wkr_call -> Case wkr_call (arg) (exprType con_app) [(DEFAULT, [], con_app)],
+
+ return (\ wkr_call -> Case wkr_call (arg) (exprType con_app) [(DEFAULT, [], con_app)],
\ body -> workerCase (work_wild) body [arg] data_con (Var arg),
con_arg_ty1)
- | otherwise -- The general case
+ | otherwise = do -- The general case
-- Wrapper: case (..call worker..) of (# a, b #) -> C a b
-- Worker: case ( ...body... ) of C a b -> (# a, b #)
- = getUniquesUs `thenUs` \ uniqs ->
+ uniqs <- getUniquesM
let
(wrap_wild : work_wild : args) = zipWith mk_ww_local uniqs (ubx_tup_ty : body_ty : con_arg_tys)
arg_vars = map Var args
ubx_tup_ty = exprType ubx_tup_app
ubx_tup_app = mkConApp ubx_tup_con (map Type con_arg_tys ++ arg_vars)
con_app = mkProductBox args body_ty
- in
- returnUs (\ wkr_call -> Case wkr_call (wrap_wild) (exprType con_app) [(DataAlt ubx_tup_con, args, con_app)],
+
+ return (\ wkr_call -> Case wkr_call (wrap_wild) (exprType con_app) [(DataAlt ubx_tup_con, args, con_app)],
\ body -> workerCase (work_wild) body args data_con ubx_tup_app,
ubx_tup_ty)
where
n_con_args = length con_arg_tys
con_arg_ty1 = head con_arg_tys
-mkWWcpr body_ty other -- No CPR info
- = returnUs (id, id, body_ty)
+mkWWcpr body_ty _other -- No CPR info
+ = return (id, id, body_ty)
-- If the original function looked like
-- f = \ x -> _scc_ "foo" E
--
-- This transform doesn't move work or allocation
-- from one cost centre to another
-
+workerCase :: Id -> CoreExpr -> [Id] -> DataCon -> CoreExpr -> CoreExpr
workerCase bndr (Note (SCC cc) e) args con body = Note (SCC cc) (mkUnpackCase bndr e args con body)
workerCase bndr e args con body = mkUnpackCase bndr e args con body
\end{code}
\begin{code}
+mk_absent_let :: Id -> CoreExpr -> CoreExpr
mk_absent_let arg body
| not (isUnLiftedType arg_ty)
= Let (NonRec arg abs_rhs) body
abs_rhs = mkRuntimeErrorApp rUNTIME_ERROR_ID arg_ty msg
msg = "Oops! Entered absent arg " ++ showSDocDebug (ppr arg <+> ppr (idType arg))
+mk_seq_case :: Id -> CoreExpr -> CoreExpr
mk_seq_case arg body = Case (Var arg) (sanitiseCaseBndr arg) (exprType body) [(DEFAULT, [], body)]
sanitiseCaseBndr :: Id -> Id
-- like (x+y) `seq` ....
sanitiseCaseBndr id = id `setIdInfo` vanillaIdInfo
+mk_ww_local :: Unique -> Type -> Id
mk_ww_local uniq ty = mkSysLocal FSLIT("ww") uniq ty
\end{code}
projects / ghc-hetmet.git / blobdiff