import CoreSyn
import CoreUtils ( exprType )
import Id ( Id, idType, mkSysLocal, idNewDemandInfo, setIdNewDemandInfo,
- isOneShotLambda, setOneShotLambda,
+ isOneShotLambda, setOneShotLambda, setIdUnfolding,
setIdInfo
)
import IdInfo ( vanillaIdInfo )
import DataCon ( splitProductType_maybe, splitProductType )
import NewDemand ( Demand(..), Keepity(..), DmdResult(..) )
-import PrelInfo ( realWorldPrimId, aBSENT_ERROR_ID )
+import DmdAnal ( both )
+import PrelInfo ( realWorldPrimId, aBSENT_ERROR_ID, eRROR_CSTRING_ID )
import TysPrim ( realWorldStatePrimTy )
import TysWiredIn ( tupleCon )
import Type ( Type, isUnLiftedType, mkFunTys,
splitForAllTys, splitFunTys, splitNewType_maybe, isAlgType
)
-import BasicTypes ( Arity, Boxity(..) )
+import Literal ( Literal(MachStr) )
+import BasicTypes ( Boxity(..) )
import Var ( Var, isId )
import UniqSupply ( returnUs, thenUs, getUniqueUs, getUniquesUs, UniqSM )
import Util ( zipWithEqual )
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( not (null tyvars) || not (null 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) ->
-- but *with* lambdas
mkWWstr res_ty wrap_args
- = mk_ww_str wrap_args `thenUs` \ (work_args, take_apart, put_together) ->
+ = mk_ww_str_s wrap_args `thenUs` \ (work_args, take_apart, put_together) ->
let
work_dmds = [idNewDemandInfo v | v <- work_args, isId v]
apply_to args fn = mkVarApps fn args
take_apart . applyToVars [realWorldPrimId] . apply_to work_args,
mkLams work_args . Lam void_arg . put_together)
- -- Empty case
-mk_ww_str []
- = returnUs ([],
- \ wrapper_body -> wrapper_body,
- \ worker_body -> worker_body)
+----------------------
+nop_fn body = body
+
+----------------------
+mk_ww_str_s []
+ = returnUs ([], nop_fn, nop_fn)
+
+mk_ww_str_s (arg : args)
+ = mk_ww_str arg `thenUs` \ (args1, wrap_fn1, work_fn1) ->
+ mk_ww_str_s args `thenUs` \ (args2, wrap_fn2, work_fn2) ->
+ returnUs (args1 ++ args2, wrap_fn1 . wrap_fn2, work_fn1 . work_fn2)
-mk_ww_str (arg : ds)
+----------------------
+mk_ww_str arg
| isTyVar arg
- = mk_ww_str ds `thenUs` \ (worker_args, wrap_fn, work_fn) ->
- returnUs (arg : worker_args, wrap_fn, work_fn)
+ = returnUs ([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)) ->
- mk_ww_str ds `thenUs` \ (worker_args, wrap_fn, work_fn) ->
- returnUs (worker_args, wrap_fn, mk_absent_let arg . work_fn)
+ returnUs ([], nop_fn, mk_absent_let arg)
-- Seq and keep
- Seq Keep _ [] -> mk_ww_str ds `thenUs` \ (worker_args, wrap_fn, work_fn) ->
- returnUs (arg : worker_args, mk_seq_case arg . wrap_fn, work_fn)
- -- Pass the arg, no need to rebox
-
- -- Seq and discard
- Seq Drop _ [] -> mk_ww_str ds `thenUs` \ (worker_args, wrap_fn, work_fn) ->
- returnUs (worker_args, mk_seq_case arg . wrap_fn, mk_absent_let arg . work_fn)
- -- Don't pass the arg, build absent arg
-
+ Seq _ []
+ -> let
+ arg_w_unf = arg `setIdUnfolding` mkOtherCon []
+ -- 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)
+ -- 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
+ -- 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
+ -- during simplification, so for now I've just nuked this whole case
+
-- Unpack case
- Seq keep _ cs
+ 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 "mk_ww_str" set_worker_arg_info unpk_args cs
+ unpk_args_w_ds = zipWithEqual "mk_ww_str" set_worker_arg_info unpk_args cs'
unbox_fn = mk_unpk_case arg unpk_args data_con arg_tycon
- rebox_fn = mk_pk_let arg data_con tycon_arg_tys unpk_args
+ 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
- mk_ww_str (unpk_args_w_ds ++ 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)
+ mk_ww_str_s 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 )
- mk_ww_str ds `thenUs` \ (worker_args, wrap_fn, work_fn) ->
- returnUs (arg : worker_args, wrap_fn, work_fn)
+ returnUs ([arg], nop_fn, nop_fn)
-- Other cases
- other_demand ->
- mk_ww_str ds `thenUs` \ (worker_args, wrap_fn, work_fn) ->
- returnUs (arg : worker_args, wrap_fn, work_fn)
+ other_demand -> returnUs ([arg], nop_fn, nop_fn)
+
where
-- If the wrapper argument is a one-shot lambda, then
-- so should (all) the corresponding worker arguments be
\begin{code}
mk_absent_let arg body
| not (isUnLiftedType arg_ty)
- = Let (NonRec arg (mkTyApps (Var aBSENT_ERROR_ID) [arg_ty])) body
+ = Let (NonRec arg abs_rhs) body
| otherwise
= 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))]
+ msg = "Oops! Entered absent arg " ++ showSDocDebug (ppr arg <+> ppr (idType arg))
mk_unpk_case arg unpk_args boxing_con boxing_tycon body
-- A data type
-- like (x+y) `seq` ....
sanitiseCaseBndr id = id `setIdInfo` vanillaIdInfo
-mk_pk_let arg boxing_con con_tys unpk_args body
- = Let (NonRec arg (mkConApp boxing_con con_args)) body
- where
- con_args = map Type con_tys ++ map Var unpk_args
-
mk_ww_local uniq ty = mkSysLocal SLIT("ww") uniq ty
\end{code}
projects / ghc-hetmet.git / blobdiff