X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fstranal%2FWwLib.lhs;h=49571f30878a5ca3d18882356aaae1889c183d4b;hb=06e14415fa8aef5be7d01314d08fcd87873cd0da;hp=2cda4f0407774c5a8d02d6a1b0a40e2d4be76e07;hpb=566075c3369dbaefd7fec9b0fde2eb11f521185a;p=ghc-hetmet.git diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs index 2cda4f0..49571f3 100644 --- a/ghc/compiler/stranal/WwLib.lhs +++ b/ghc/compiler/stranal/WwLib.lhs @@ -4,7 +4,7 @@ \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" @@ -16,19 +16,16 @@ import Id ( Id, idType, mkSysLocal, idNewDemandInfo, setIdNewDemandInfo, ) import IdInfo ( vanillaIdInfo ) import DataCon ( splitProductType_maybe, splitProductType ) -import NewDemand ( Demand(..), Keepity(..), DmdResult(..) ) -import DmdAnal ( both ) -import PrelInfo ( eRROR_CSTRING_ID ) -import TysPrim ( realWorldStatePrimTy ) +import NewDemand ( Demand(..), DmdResult(..), Demands(..) ) +import MkId ( realWorldPrimId, voidArgId, mkRuntimeErrorApp, rUNTIME_ERROR_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 Util ( zipWithEqual ) +import UniqSupply ( returnUs, thenUs, getUniquesUs, UniqSM ) +import Util ( zipWithEqual, notNull ) import Outputable import List ( zipWith4 ) \end{code} @@ -123,13 +120,21 @@ mkWwBodies :: Type -- Type of original function 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_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_args' . Var, - mkLams work_args' . work_fn_str . work_fn_cpr . work_fn_args) + 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 = ... @@ -139,24 +144,36 @@ mkWwBodies fun_ty demands res_info one_shots -- 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 - | otherwise - = getUniqueUs `thenUs` \ void_arg_uniq -> - let - void_arg = mk_ww_local void_arg_uniq realWorldStatePrimTy - in - returnUs (work_args ++ [void_arg]) + +%************************************************************************ +%* * +\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} @@ -223,11 +240,11 @@ mkWWargs fun_ty demands one_shots work_fn_args . Note (Coerce rep_ty fun_ty), res_ty) - | not (null demands) + | notNull 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 @@ -240,7 +257,7 @@ mkWWargs fun_ty demands one_shots val_args = zipWith4 mk_wrap_arg wrap_uniqs arg_tys demands one_shots wrap_args = tyvars ++ val_args in -{- ASSERT( not (null tyvars) || not (null arg_tys) ) -} +{- 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) @@ -263,7 +280,7 @@ applyToVars :: [Var] -> CoreExpr -> CoreExpr 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 @@ -302,6 +319,12 @@ mkWWstr (arg : args) ---------------------- +-- 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) @@ -315,8 +338,25 @@ mkWWstr_one arg 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 @@ -326,56 +366,16 @@ mkWWstr_one arg -- 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 - 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) @@ -420,16 +420,22 @@ mkWWcpr body_ty RetCPR | n_con_args == 1 && isUnLiftedType con_arg_ty1 -- 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 : _) -> 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) | otherwise -- 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 -> let (wrap_wild : work_wild : args) = zipWith mk_ww_local uniqs (ubx_tup_ty : body_ty : con_arg_tys) @@ -439,7 +445,7 @@ mkWWcpr body_ty RetCPR ubx_tup_app = mkConApp ubx_tup_con (map Type con_arg_tys ++ arg_vars) con_app = mkConApp data_con (map Type tycon_arg_tys ++ arg_vars) in - returnUs (\ wkr_call -> Case wkr_call wrap_wild [(DataAlt ubx_tup_con, args, con_app)], + returnUs (\ wkr_call -> Case wkr_call wrap_wild [(DataAlt ubx_tup_con, args, con_app)], \ body -> workerCase body work_wild [(DataAlt data_con, args, ubx_tup_app)], ubx_tup_ty) where @@ -481,8 +487,7 @@ mk_absent_let arg body = panic "WwLib: haven't done mk_absent_let for primitives yet" where arg_ty = idType arg --- abs_rhs = mkTyApps (Var aBSENT_ERROR_ID) [arg_ty] - abs_rhs = mkApps (Var eRROR_CSTRING_ID) [Type arg_ty, Lit (MachStr (_PK_ msg))] + abs_rhs = mkRuntimeErrorApp rUNTIME_ERROR_ID arg_ty msg msg = "Oops! Entered absent arg " ++ showSDocDebug (ppr arg <+> ppr (idType arg)) mk_unpk_case arg unpk_args boxing_con boxing_tycon body @@ -504,5 +509,5 @@ sanitiseCaseBndr :: Id -> Id -- 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}