- -- 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) True {- useful split -} 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)
- ))
-
- mk_unpk_case arg unpk_args boxing_con boxing_tycon body
- = Case (Var arg) (
- AlgAlts [(boxing_con, unpk_args, body)]
- NoDefault
- )
-
- mk_pk_let arg boxing_con con_tys unpk_args body
- = Let (NonRec arg (Con boxing_con
- (map TyArg con_tys ++ map VarArg unpk_args)))
- body
-
-mk_ww_arg_processing (arg : args) (arg_demand : infos) useful_split max_extra_args
+ mk_ww_str (unpk_args_w_ds ++ ds) `thenUs` \ (worker_args, wrap_fn, work_fn) ->
+ returnUs (worker_args,
+ mk_unpk_case new_or_data arg unpk_args data_con arg_tycon . wrap_fn,
+ work_fn . mk_pk_let new_or_data arg data_con tycon_arg_tys unpk_args)
+ where
+ (arg_tycon, tycon_arg_tys, data_con, inst_con_arg_tys) = splitProductType "mk_ww_str" (idType arg)
+
+ -- 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 (setIdDemandInfo worker_arg demand)
+
+ set_one_shot | isOneShotLambda arg = setOneShotLambda
+ | otherwise = \x -> x
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{CPR stuff}
+%* *
+%************************************************************************
+
+
+@mkWWcpr@ takes the worker/wrapper pair produced from the strictness
+info and adds in the CPR transformation. The worker returns an
+unboxed tuple containing non-CPR components. The wrapper takes this
+tuple and re-produces the correct structured output.
+
+The non-CPR results appear ordered in the unboxed tuple as if by a
+left-to-right traversal of the result structure.
+
+
+\begin{code}
+mkWWcpr :: Type -- function body type
+ -> CprInfo -- CPR analysis results
+ -> UniqSM (CoreExpr -> CoreExpr, -- New wrapper
+ CoreExpr -> CoreExpr, -- New worker
+ Type) -- Type of worker's body
+
+mkWWcpr body_ty NoCPRInfo
+ = returnUs (id, id, body_ty) -- Must be just the strictness transf.
+
+mkWWcpr body_ty ReturnsCPR
+ | not (isAlgType body_ty)
+ = WARN( True, text "mkWWcpr: non-algebraic body type" <+> ppr body_ty )
+ returnUs (id, id, body_ty)
+
+ | n_con_args == 1 && isUnLiftedType con_arg_ty1
+ -- Special case when there is a single result of unlifted type
+ = getUniquesUs 2 `thenUs` \ [work_uniq, arg_uniq] ->
+ let
+ work_wild = mk_ww_local work_uniq body_ty
+ arg = mk_ww_local arg_uniq con_arg_ty1
+ in
+ returnUs (\ wkr_call -> Case wkr_call arg [(DEFAULT, [], mkConApp data_con (map Type tycon_arg_tys ++ [Var arg]))],
+ \ body -> Case body work_wild [(DataAlt data_con, [arg], Var arg)],
+ con_arg_ty1)
+
+ | otherwise -- The general case
+ = getUniquesUs (n_con_args + 2) `thenUs` \ uniqs ->
+ let
+ (wrap_wild : work_wild : args) = zipWith mk_ww_local uniqs (ubx_tup_ty : body_ty : con_arg_tys)
+ arg_vars = map Var args
+ ubx_tup_con = tupleCon Unboxed n_con_args
+ ubx_tup_ty = exprType ubx_tup_app
+ 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)],
+ \ body -> Case body work_wild [(DataAlt data_con, args, ubx_tup_app)],
+ ubx_tup_ty)
+ where
+ (tycon, tycon_arg_tys, data_con, con_arg_tys) = splitProductType "mkWWcpr" body_ty
+ n_con_args = length con_arg_tys
+ con_arg_ty1 = head con_arg_tys
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Utilities}
+%* *
+%************************************************************************
+
+
+\begin{code}
+mk_absent_let arg body
+ | not (isUnLiftedType arg_ty)
+ = Let (NonRec arg (mkTyApps (Var aBSENT_ERROR_ID) [arg_ty])) body