- mk_ww_arg_processing args infos max_extra_args
- -- we've already discounted for absent args,
- -- so we don't change max_extra_args
- `thenMaybeUs` \ (wrap_rest, work_args_info, work_rest) ->
-
- -- wrapper doesn't pass this arg to worker:
- returnUs (Just (
- -- wrapper:
- \ hole -> wrap_rest hole,
-
- -- worker:
- work_args_info, -- NB: no argument added
- \ hole -> mk_absent_let arg arg_ty (work_rest hole)
- ))
- --)
- where
- 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)
- ))
+ returnUs (\ work_id -> mkLams tyvars $ mkLams args $
+ mkApps (Var work_id)
+ (map (Type . mkTyVarTy) tyvars ++ [mkConApp unitDataCon []]),
+ \ body -> mkLams (tyvars ++ [void_arg]) body,
+ [WwLazy True])
+
+mkWwBodies tyvars wrap_args body_ty demands
+ | otherwise
+ = 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)
+\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"