- = -- For all others at the moment, we just
- -- pass them to the worker unchanged.
- --pprTrace "Other; num_wrkr_args=" (ppCat [ppInt num_wrkr_args, ppStr ";arg=", ppr PprDebug arg, ppr PprDebug arg_demand]) (
-
- -- Finish args to the right...
- mk_ww_arg_processing args infos max_extra_args
- `thenUsMaybe` \ (wrap_rest, work_args_info, work_rest) ->
-
- returnSUs (Just (
- -- wrapper:
- \ hole -> wrap_rest (CoApp hole (CoVarAtom arg)),
-
- -- worker:
- (arg, arg_demand) : work_args_info,
- \ hole -> work_rest hole
- ))
- --)
+ = 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)) ->
+ mk_ww_str ds `thenUs` \ (worker_args, wrap_fn, work_fn) ->
+ returnUs (worker_args, wrap_fn, mk_absent_let arg . work_fn)
+
+ -- 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
+
+ -- 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 "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
+ 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)
+ -- 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)
+
+ -- Other cases
+ other_demand ->
+ mk_ww_str ds `thenUs` \ (worker_args, wrap_fn, work_fn) ->
+ returnUs (arg : worker_args, wrap_fn, work_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_one_shot | isOneShotLambda arg = setOneShotLambda
+ | otherwise = \x -> x