\section[WwLib]{A library for the ``worker/wrapper'' back-end to the strictness analyser}
\begin{code}
-module WwLib ( mkWwBodies, mkWWstr ) where
+module WwLib ( mkWwBodies, mkWWstr, mkWorkerArgs ) where
#include "HsVersions.h"
)
import IdInfo ( vanillaIdInfo )
import DataCon ( splitProductType_maybe, splitProductType )
-import NewDemand ( Demand(..), Keepity(..), DmdResult(..) )
-import DmdAnal ( both )
-import PrelInfo ( realWorldPrimId, eRROR_CSTRING_ID )
-import TysPrim ( realWorldStatePrimTy )
+import NewDemand ( Demand(..), DmdResult(..), Demands(..) )
+import MkId ( realWorldPrimId, voidArgId, eRROR_CSTRING_ID )
import TysWiredIn ( tupleCon )
import Type ( Type, isUnLiftedType, mkFunTys,
splitForAllTys, splitFunTys, splitNewType_maybe, isAlgType
import Literal ( Literal(MachStr) )
import BasicTypes ( Boxity(..) )
import Var ( Var, isId )
-import UniqSupply ( returnUs, thenUs, getUniqueUs, getUniquesUs, UniqSM )
+import UniqSupply ( returnUs, thenUs, getUniquesUs, UniqSM )
import Util ( zipWithEqual )
import Outputable
import List ( zipWith4 )
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) ->
- mkWWcpr res_ty res_info `thenUs` \ (wrap_fn_cpr, work_fn_cpr, cpr_res_ty) ->
mkWWstr wrap_args `thenUs` \ (work_args, wrap_fn_str, work_fn_str) ->
- hackWorkArgs work_args cpr_res_ty `thenUs` \ (work_lam_args, work_call_args) ->
+ 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_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)
+ 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 = ...
-- fw from being inlined into f's RHS
where
one_shots' = one_shots ++ repeat False
+\end{code}
- -- Horrid special case. If the worker would have no arguments, and the
- -- function returns a primitive type value, that would make the worker into
- -- an unboxed value. We box it by passing a dummy void argument, thus:
- --
- -- f = /\abc. \xyz. fw abc void
- -- fw = /\abc. \v. body
- --
- -- We use the state-token type which generates no code
-hackWorkArgs work_args res_ty
- | any isId work_args || not (isUnLiftedType res_ty)
- = returnUs (work_args, work_args)
- | otherwise
- = getUniqueUs `thenUs` \ void_arg_uniq ->
- let
- void_arg = mk_ww_local void_arg_uniq realWorldStatePrimTy
- in
- returnUs (work_args ++ [void_arg], work_args ++ [realWorldPrimId])
+
+%************************************************************************
+%* *
+\subsection{Making wrapper args}
+%* *
+%************************************************************************
+
+During worker-wrapper stuff we may end up with an unlifted thing
+which we want to let-bind without losing laziness. So we
+add a void argument. E.g.
+
+ f = /\a -> \x y z -> E::Int# -- E does not mention x,y,z
+==>
+ fw = /\ a -> \void -> E
+ f = /\ a -> \x y z -> fw realworld
+
+We use the state-token type which generates no code.
+
+\begin{code}
+mkWorkerArgs :: [Var]
+ -> Type -- Type of body
+ -> ([Var], -- Lambda bound args
+ [Var]) -- Args at call site
+mkWorkerArgs args res_ty
+ | any isId args || not (isUnLiftedType res_ty)
+ = (args, args)
+ | otherwise
+ = (args ++ [voidArgId], args ++ [realWorldPrimId])
\end{code}
| not (null demands)
= getUniquesUs `thenUs` \ wrap_uniqs ->
let
- (tyvars, tau) = splitForAllTys fun_ty
- (arg_tys, body_ty) = splitFunTys tau
+ (tyvars, tau) = splitForAllTys fun_ty
+ (arg_tys, body_ty) = splitFunTys tau
n_demands = length demands
n_arg_tys = length arg_tys
applyToVars vars fn = mkVarApps fn vars
mk_wrap_arg uniq ty dmd one_shot
- = set_one_shot one_shot (setIdNewDemandInfo (mkSysLocal SLIT("w") uniq ty) dmd)
+ = set_one_shot one_shot (setIdNewDemandInfo (mkSysLocal FSLIT("w") uniq ty) dmd)
where
set_one_shot True id = setOneShotLambda id
set_one_shot False id = id
----------------------
+-- mkWWstr_one wrap_arg = (work_args, wrap_fn, work_fn)
+-- * wrap_fn assumes wrap_arg is in scope,
+-- 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 arg
| isTyVar arg
= returnUs ([arg], nop_fn, nop_fn)
Abs | not (isUnLiftedType (idType arg)) ->
returnUs ([], nop_fn, mk_absent_let arg)
- -- Seq and keep
- Seq _ []
+ -- Unpack case
+ Eval (Prod cs)
+ | Just (arg_tycon, tycon_arg_tys, data_con, inst_con_arg_tys)
+ <- splitProductType_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 = mk_unpk_case arg unpk_args data_con arg_tycon
+ rebox_fn = Let (NonRec arg con_app)
+ con_app = mkConApp data_con (map Type tycon_arg_tys ++ map Var unpk_args)
+ in
+ mkWWstr unpk_args_w_ds `thenUs` \ (worker_args, wrap_fn, work_fn) ->
+ returnUs (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
+ -- of dropping seqs in the worker
+ Eval (Poly Abs)
-> let
arg_w_unf = arg `setIdUnfolding` mkOtherCon []
-- Tell the worker arg that it's sure to be evaluated
-- Pass the arg, anyway, even if it is in theory discarded
-- Consider
-- f x y = x `seq` y
- -- x gets a (Seq Drop []) demand, but if we fail to pass it to the worker
+ -- x gets a (Eval (Poly Abs)) demand, but if we fail to pass it to the worker
-- we ABSOLUTELY MUST record that x is evaluated in the wrapper.
-- Something like:
-- f x y = x `seq` fw y
-- fw y = let x{Evald} = error "oops" in (x `seq` y)
-- If we don't pin on the "Evald" flag, the seq doesn't disappear, and
-- we end up evaluating the absent thunk.
- -- But the Evald flag is pretty wierd, and I worry that it might disappear
+ -- But the Evald flag is pretty weird, and I worry that it might disappear
-- during simplification, so for now I've just nuked this whole case
- -- Unpack case
- Seq keep cs
- | Just (arg_tycon, tycon_arg_tys, data_con, inst_con_arg_tys)
- <- splitProductType_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 = mk_unpk_case arg unpk_args data_con arg_tycon
- rebox_fn = Let (NonRec arg con_app)
- con_app = mkConApp data_con (map Type tycon_arg_tys ++ map Var unpk_args)
-
- cs' = case keep of
- Keep -> map (DmdAnal.both Lazy) cs -- Careful! Now we don't pass
- -- the box, we must pass all the
- -- components. In effect
- -- S(LA) --> U(LL)
- Drop -> cs
- Defer -> pprTrace "wwlib" (ppr arg) cs
- in
- mkWWstr unpk_args_w_ds `thenUs` \ (worker_args, wrap_fn, work_fn) ->
-
--- case keep of
--- Keep -> returnUs (arg : worker_args, unbox_fn . wrap_fn, work_fn)
--- -- Pass the arg, no need to rebox
--- Drop -> returnUs (worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn)
--- -- Don't pass the arg, rebox instead
--- I used to be clever here, but consider
--- f n [] = n
--- f n (x:xs) = f (n+x) xs
--- Here n gets (Seq Keep [L]), but it's BAD BAD BAD to pass both n and n#
--- Needs more thought, but the simple thing to do is to accept the reboxing
--- stuff if there are any non-absent arguments (and that case is dealt with above):
-
- returnUs (worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn)
- -- Don't pass the arg, rebox instead
-
- | otherwise ->
- WARN( True, ppr arg )
- returnUs ([arg], nop_fn, nop_fn)
-
-- Other cases
other_demand -> returnUs ([arg], nop_fn, nop_fn)
let
work_wild = mk_ww_local work_uniq body_ty
arg = mk_ww_local arg_uniq con_arg_ty1
+ con_app = mkConApp data_con (map Type tycon_arg_tys ++ [Var arg])
in
- returnUs (\ wkr_call -> Case wkr_call arg [(DEFAULT, [], mkConApp data_con (map Type tycon_arg_tys ++ [Var arg]))],
+ returnUs (\ wkr_call -> Case wkr_call arg [(DEFAULT, [], con_app)],
\ body -> workerCase body work_wild [(DataAlt data_con, [arg], Var arg)],
con_arg_ty1)
-- like (x+y) `seq` ....
sanitiseCaseBndr id = id `setIdInfo` vanillaIdInfo
-mk_ww_local uniq ty = mkSysLocal SLIT("ww") uniq ty
+mk_ww_local uniq ty = mkSysLocal FSLIT("ww") uniq ty
\end{code}
projects / ghc-hetmet.git / blobdiff