- 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 (maybeAppDataTyConExpandingDicts 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 = dataConArgTys data_con tycon_arg_tys
- in
- getUniques (length inst_con_arg_tys) `thenUs` \ uniqs ->
-
- let
- unpk_args = zipWithEqual "mk_ww_arg_processing"
- (\ 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)
- ))
+ -- 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
+ | otherwise
+ = panic "WwLib: haven't done mk_absent_let for primitives yet"