- = -- 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
- ))
- --)
+ = let
+ wrap_args_w_demands = zipWithEqual "mkWwBodies" setIdDemandInfo wrap_args demands
+ in
+ mkWW wrap_args_w_demands `thenUs` \ (wrap_fn, work_args_w_demands, work_fn) ->
+ returnUs (\ work_id -> mkLams tyvars $ mkLams wrap_args_w_demands $
+ wrap_fn (mkTyApps (Var work_id) (mkTyVarTys tyvars)),
+
+ \ body -> mkLams tyvars $ mkLams work_args_w_demands $
+ work_fn body,
+
+ map getIdDemandInfo work_args_w_demands)
+\end{code}
+
+
+\begin{code}
+mkWW :: [Id] -- Wrapper args; have their demand info on them
+ -> UniqSM (CoreExpr -> CoreExpr, -- Wrapper body, lacking the inner call to the worker
+ -- and without its lambdas
+ [Id], -- Worker args; have their demand info on them
+ CoreExpr -> CoreExpr) -- Worker body, lacking the original body of the function
+
+
+ -- Empty case
+mkWW []
+ = returnUs (\ wrapper_body -> wrapper_body,
+ [],
+ \ worker_body -> worker_body)
+
+
+mkWW (arg : ds)
+ = case getIdDemandInfo arg of
+
+ -- Absent case
+ WwLazy True ->
+ mkWW ds `thenUs` \ (wrap_fn, worker_args, work_fn) ->
+ returnUs (\ wrapper_body -> wrap_fn wrapper_body,
+ worker_args,
+ \ worker_body -> mk_absent_let arg (work_fn worker_body))
+
+
+ -- Unpack case
+ WwUnpack new_or_data True cs ->
+ getUniquesUs (length inst_con_arg_tys) `thenUs` \ uniqs ->
+ let
+ unpk_args = zipWith mk_ww_local uniqs inst_con_arg_tys
+ unpk_args_w_ds = zipWithEqual "mkWW" setIdDemandInfo unpk_args cs
+ in
+ mkWW (unpk_args_w_ds ++ ds) `thenUs` \ (wrap_fn, worker_args, work_fn) ->
+ returnUs (\ wrapper_body -> mk_unpk_case new_or_data arg unpk_args data_con arg_tycon
+ (wrap_fn wrapper_body),
+ worker_args,
+ \ worker_body -> work_fn (mk_pk_let new_or_data arg data_con
+ tycon_arg_tys unpk_args worker_body))
+ where
+ inst_con_arg_tys = dataConArgTys data_con tycon_arg_tys
+ (arg_tycon, tycon_arg_tys, data_con)
+ = case (splitAlgTyConApp_maybe (idType arg)) of
+
+ Just (arg_tycon, tycon_arg_tys, [data_con]) ->
+ -- The main event: a single-constructor data type
+ (arg_tycon, tycon_arg_tys, data_con)
+
+ Just (_, _, data_cons) ->
+ pprPanic "mk_ww_arg_processing:"
+ (text "not one constr (interface files not consistent/up to date?)"
+ $$ (ppr arg <+> ppr (idType arg)))
+
+ Nothing ->
+ panic "mk_ww_arg_processing: not datatype"
+
+
+ -- Other cases
+ other_demand ->
+ mkWW ds `thenUs` \ (wrap_fn, worker_args, work_fn) ->
+ returnUs (\ wrapper_body -> wrap_fn (App wrapper_body (Var arg)),
+ arg : worker_args,
+ work_fn)