- mk_absent_let arg arg_ty body
- = if not (isPrimType arg_ty) then
- Let (NonRec arg (mkTyApp (Var aBSENT_ERROR_ID) [arg_ty])) body
- else -- quite horrible
- panic "WwLib: haven't done mk_absent_let for primitives yet"
-
-
-mk_ww_arg_processing (arg : args) (WwUnpack cmpnt_infos : infos) max_extra_args
- | new_max_extra_args > 0 -- Check that we are prepared to add arguments
- = -- this is the complicated one.
- --pprTrace "Unpack; num_wrkr_args=" (ppCat [ppInt num_wrkr_args, ppStr "; new_max=", ppInt new_num_wrkr_args, ppStr "; arg=", ppr PprDebug arg, ppr PprDebug (WwUnpack cmpnt_infos)]) (
- case maybeAppDataTyCon arg_ty of
-
- Nothing -> -- Not a data type
- panic "mk_ww_arg_processing: not datatype"
-
- Just (_, _, []) -> -- An abstract type
- -- We have to give up on the whole idea
- returnUs Nothing
- Just (_, _, (_:_:_)) -> -- Two or more constructors; that's odd
- panic "mk_ww_arg_processing: multi-constr"
-
- Just (arg_tycon, tycon_arg_tys, [data_con]) ->
- -- The main event: a single-constructor data type
-
- let
- (_,inst_con_arg_tys,_)
- = getInstantiatedDataConSig data_con tycon_arg_tys
- in
- getUniques (length inst_con_arg_tys) `thenUs` \ uniqs ->
-
- let
- unpk_args = zipWithEqual
- (\ u t -> mkSysLocal SLIT("upk") u t mkUnknownSrcLoc)
- uniqs inst_con_arg_tys
- in
- -- In processing the rest, push the sub-component args
- -- and infos on the front of the current bunch
- mk_ww_arg_processing (unpk_args ++ args) (cmpnt_infos ++ infos) new_max_extra_args
- `thenMaybeUs` \ (wrap_rest, work_args_info, work_rest) ->
-
- returnUs (Just (
- -- wrapper: unpack the value
- \ hole -> mk_unpk_case arg unpk_args
- data_con arg_tycon
- (wrap_rest hole),
-
- -- worker: expect the unpacked value;
- -- reconstruct the orig value with a "let"
- work_args_info,
- \ hole -> work_rest (mk_pk_let arg data_con tycon_arg_tys unpk_args hole)
- ))
- --)
+ set_one_shot True id = setOneShotLambda id
+ set_one_shot False id = id
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Strictness stuff}
+%* *
+%************************************************************************
+
+\begin{code}
+mkWWstr :: [Var] -- Wrapper args; have their demand info on them
+ -- *Includes type variables*
+ -> UniqSM ([Var], -- Worker args
+ CoreExpr -> CoreExpr, -- Wrapper body, lacking the worker call
+ -- and without its lambdas
+ -- This fn adds the unboxing
+
+ 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)
+
+
+----------------------
+-- 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)
+
+ | otherwise
+ = case idNewDemandInfo 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)
+
+ -- 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` evaldUnfolding
+ -- 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 (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 weird, and I worry that it might disappear
+ -- during simplification, so for now I've just nuked this whole case
+
+ -- Other cases
+ other_demand -> returnUs ([arg], nop_fn, nop_fn)
+