%
% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
-\section[WwLib]{A library for the ``worker/wrapper'' back-end to the strictness analyser}
+\section[WwLib]{A library for the ``worker\/wrapper'' back-end to the strictness analyser}
\begin{code}
module WwLib ( mkWwBodies, mkWWstr, mkWorkerArgs ) where
import CoreSyn
import CoreUtils ( exprType )
-import Id ( Id, idType, mkSysLocal, idNewDemandInfo, setIdNewDemandInfo,
+import Id ( Id, idType, mkSysLocal, idDemandInfo, setIdDemandInfo,
isOneShotLambda, setOneShotLambda, setIdUnfolding,
setIdInfo
)
import IdInfo ( vanillaIdInfo )
-import DataCon ( deepSplitProductType_maybe, deepSplitProductType )
-import NewDemand ( Demand(..), DmdResult(..), Demands(..) )
-import MkId ( realWorldPrimId, voidArgId, mkRuntimeErrorApp, rUNTIME_ERROR_ID,
+import DataCon
+import Demand ( Demand(..), DmdResult(..), Demands(..) )
+import MkCore ( mkRuntimeErrorApp, aBSENT_ERROR_ID )
+import MkId ( realWorldPrimId, voidArgId,
mkUnpackCase, mkProductBox )
+import TysPrim ( realWorldStatePrimTy )
import TysWiredIn ( tupleCon )
-import Type ( Type, isUnLiftedType, mkFunTys,
- splitForAllTys, splitFunTys, isAlgType
- )
-import Coercion ( mkSymCoercion, splitNewTypeRepCo_maybe )
+import Type
+import Coercion ( mkSymCo, splitNewTypeRepCo_maybe )
import BasicTypes ( Boxity(..) )
-import Var ( Var, isId )
-import UniqSupply ( returnUs, thenUs, getUniquesUs, UniqSM )
-import Util ( zipWithEqual, notNull )
+import Literal ( absentLiteralOf )
+import UniqSupply
+import Unique
+import Util ( zipWithEqual )
import Outputable
-import List ( zipWith4 )
+import FastString
\end{code}
\begin{verbatim}
g :: forall a . Int -> [a] -> a
-g = /\ a -> \ x ys ->
+g = \/\ a -> \ x ys ->
case x of
0 -> head ys
_ -> head (tail ys)
-- wrapper (an unfolding)
g :: forall a . Int -> [a] -> a
-g = /\ a -> \ x ys ->
+g = \/\ a -> \ x ys ->
case x of
I# x# -> $wg a x# ys
-- call the worker; don't forget the type args!
-- worker
$wg :: forall a . Int# -> [a] -> a
-$wg = /\ a -> \ x# ys ->
+$wg = \/\ a -> \ x# ys ->
let
x = I# x#
in
%* *
%************************************************************************
-@mkWwBodies@ is called when doing the worker/wrapper split inside a module.
+@mkWwBodies@ is called when doing the worker\/wrapper split inside a module.
\begin{code}
mkWwBodies :: Type -- Type of original function
-- 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
- where
- one_shots' = one_shots ++ repeat False
+ = do { let arg_info = demands `zip` (one_shots ++ repeat False)
+ ; (wrap_args, wrap_fn_args, work_fn_args, res_ty) <- mkWWargs emptyTvSubst fun_ty arg_info
+ ; (work_args, wrap_fn_str, work_fn_str) <- mkWWstr wrap_args
+
+ -- 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)
+
+ ; let (work_lam_args, work_call_args) = mkWorkerArgs work_args res_ty
+ ; return ([idDemandInfo v | v <- work_call_args, isId v],
+ 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
\end{code}
%* *
%************************************************************************
-
We really want to "look through" coerces.
Reason: I've seen this situation:
the \x to get what we want.
\begin{code}
--- mkWWargs is driven off the function type and arity.
+-- mkWWargs just does eta expansion
+-- is driven off the function type and arity.
-- It chomps bites off foralls, arrows, newtypes
-- and keeps repeating that until it's satisfied the supplied arity
-mkWWargs :: Type
- -> [Demand]
- -> [Bool] -- True for a one-shot arg; ** may be infinite **
+mkWWargs :: TvSubst -- Freshening substitution to apply to the type
+ -- See Note [Freshen type variables]
+ -> Type -- The type of the function
+ -> [(Demand,Bool)] -- Demands and one-shot info for value arguments
-> UniqSM ([Var], -- Wrapper args
CoreExpr -> CoreExpr, -- Wrapper fn
CoreExpr -> CoreExpr, -- Worker fn
Type) -- Type of wrapper body
-mkWWargs fun_ty demands one_shots
+mkWWargs subst fun_ty arg_info
| Just (rep_ty, co) <- splitNewTypeRepCo_maybe fun_ty
-- The newtype case is for when the function has
-- a recursive newtype after the arrow (rare)
-- 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 ->
- let
- (tyvars, tau) = splitForAllTys fun_ty
- (arg_tys, body_ty) = splitFunTys tau
-
- n_demands = length demands
- n_arg_tys = length arg_tys
- n_args = n_demands `min` n_arg_tys
-
- new_fun_ty = mkFunTys (drop n_demands arg_tys) body_ty
- 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
- 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
-
- mkWWargs new_fun_ty
- new_demands
- new_one_shots `thenUs` \ (more_wrap_args, wrap_fn_args, work_fn_args, res_ty) ->
-
- returnUs (wrap_args ++ more_wrap_args,
- mkLams wrap_args . wrap_fn_args,
- work_fn_args . applyToVars wrap_args,
- res_ty)
+ --
+ -- Note (Sept 08): This case applies even if demands is empty.
+ -- I'm not quite sure why; perhaps it makes it
+ -- easier for CPR
+ = do { (wrap_args, wrap_fn_args, work_fn_args, res_ty)
+ <- mkWWargs subst rep_ty arg_info
+ ; return (wrap_args,
+ \e -> Cast (wrap_fn_args e) (mkSymCo co),
+ \e -> work_fn_args (Cast e co),
+ res_ty) }
+
+ | null arg_info
+ = return ([], id, id, substTy subst fun_ty)
+
+ | Just (tv, fun_ty') <- splitForAllTy_maybe fun_ty
+ = do { let (subst', tv') = substTyVarBndr subst tv
+ -- This substTyVarBndr clones the type variable when necy
+ -- See Note [Freshen type variables]
+ ; (wrap_args, wrap_fn_args, work_fn_args, res_ty)
+ <- mkWWargs subst' fun_ty' arg_info
+ ; return (tv' : wrap_args,
+ Lam tv' . wrap_fn_args,
+ work_fn_args . (`App` Type (mkTyVarTy tv')),
+ res_ty) }
+
+ | ((dmd,one_shot):arg_info') <- arg_info
+ , Just (arg_ty, fun_ty') <- splitFunTy_maybe fun_ty
+ = do { uniq <- getUniqueM
+ ; let arg_ty' = substTy subst arg_ty
+ id = mk_wrap_arg uniq arg_ty' dmd one_shot
+ ; (wrap_args, wrap_fn_args, work_fn_args, res_ty)
+ <- mkWWargs subst fun_ty' arg_info'
+ ; return (id : wrap_args,
+ Lam id . wrap_fn_args,
+ work_fn_args . (`App` varToCoreExpr id),
+ res_ty) }
| otherwise
- = returnUs ([], id, id, fun_ty)
-
+ = WARN( True, ppr fun_ty ) -- Should not happen: if there is a demand
+ return ([], id, id, substTy subst fun_ty) -- then there should be a function arrow
applyToVars :: [Var] -> CoreExpr -> CoreExpr
applyToVars vars fn = mkVarApps fn vars
+mk_wrap_arg :: Unique -> Type -> Demand -> Bool -> Id
mk_wrap_arg uniq ty dmd one_shot
- = set_one_shot one_shot (setIdNewDemandInfo (mkSysLocal FSLIT("w") uniq ty) dmd)
+ = set_one_shot one_shot (setIdDemandInfo (mkSysLocal (fsLit "w") uniq ty) dmd)
where
set_one_shot True id = setOneShotLambda id
set_one_shot False id = id
\end{code}
-
+Note [Freshen type variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Wen we do a worker/wrapper split, we must not use shadowed names,
+else we'll get
+ f = /\ a /\a. fw a a
+which is obviously wrong. Type variables can can in principle shadow,
+within a type (e.g. forall a. a -> forall a. a->a). But type
+variables *are* mentioned in <blah>, so we must substitute.
+
+That's why we carry the TvSubst through mkWWargs
+
%************************************************************************
%* *
\subsection{Strictness stuff}
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
+ = case idDemandInfo arg of
- -- Absent case. We don't deal with absence for unlifted types,
- -- 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)
+ -- Absent case. We can't always handle absence for arbitrary
+ -- unlifted types, so we need to choose just the cases we can
+ -- (that's what mk_absent_let does)
+ Abs | Just work_fn <- mk_absent_let arg
+ -> return ([], nop_fn, work_fn)
-- 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
-- so should (all) the corresponding worker arguments be
-- This bites when we do w/w on a case join point
- set_worker_arg_info worker_arg demand = set_one_shot (setIdNewDemandInfo worker_arg demand)
+ set_worker_arg_info worker_arg demand = set_one_shot (setIdDemandInfo worker_arg demand)
set_one_shot | isOneShotLambda arg = setOneShotLambda
| otherwise = \x -> x
+
+----------------------
+nop_fn :: CoreExpr -> CoreExpr
+nop_fn body = body
\end{code}
Type) -- Type of worker's body
mkWWcpr body_ty RetCPR
- | not (isAlgType body_ty)
- = WARN( True, text "mkWWcpr: non-algebraic body type" <+> ppr body_ty )
- returnUs (id, id, body_ty)
+ | not (isClosedAlgType body_ty)
+ = WARN( True,
+ text "mkWWcpr: non-algebraic or open body type" <+> ppr 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}
%* *
%************************************************************************
+Note [Absent errors]
+~~~~~~~~~~~~~~~~~~~~
+We make a new binding for Ids that are marked absent, thus
+ let x = absentError "x :: Int"
+The idea is that this binding will never be used; but if it
+buggily is used we'll get a runtime error message.
+
+Coping with absence for *unlifted* types is important; see, for
+example, Trac #4306. For these we find a suitable literal,
+using Literal.absentLiteralOf. We don't have literals for
+every primitive type, so the function is partial.
+
+ [I did try the experiment of using an error thunk for unlifted
+ things too, relying on the simplifier to drop it as dead code,
+ by making absentError
+ (a) *not* be a bottoming Id,
+ (b) be "ok for speculation"
+ But that relies on the simplifier finding that it really
+ is dead code, which is fragile, and indeed failed when
+ profiling is on, which disables various optimisations. So
+ using a literal will do.]
\begin{code}
-mk_absent_let arg body
+mk_absent_let :: Id -> Maybe (CoreExpr -> CoreExpr)
+mk_absent_let arg
| not (isUnLiftedType arg_ty)
- = Let (NonRec arg abs_rhs) body
+ = Just (Let (NonRec arg abs_rhs))
+ | Just (tc, _) <- splitTyConApp_maybe arg_ty
+ , Just lit <- absentLiteralOf tc
+ = Just (Let (NonRec arg (Lit lit)))
+ | arg_ty `eqType` realWorldStatePrimTy
+ = Just (Let (NonRec arg (Var realWorldPrimId)))
| otherwise
- = panic "WwLib: haven't done mk_absent_let for primitives yet"
+ = WARN( True, ptext (sLit "No absent value for") <+> ppr arg_ty )
+ Nothing
where
- arg_ty = idType arg
- abs_rhs = mkRuntimeErrorApp rUNTIME_ERROR_ID arg_ty msg
- msg = "Oops! Entered absent arg " ++ showSDocDebug (ppr arg <+> ppr (idType arg))
+ arg_ty = idType arg
+ abs_rhs = mkRuntimeErrorApp aBSENT_ERROR_ID arg_ty msg
+ msg = 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 uniq ty = mkSysLocal FSLIT("ww") uniq ty
+mk_ww_local :: Unique -> Type -> Id
+mk_ww_local uniq ty = mkSysLocal (fsLit "ww") uniq ty
\end{code}
projects / ghc-hetmet.git / blobdiff