+We really want to "look through" coerces.
+Reason: I've seen this situation:
+
+ let f = coerce T (\s -> E)
+ in \x -> case x of
+ p -> coerce T' f
+ q -> \s -> E2
+ r -> coerce T' f
+
+If only we w/w'd f, we'd get
+ let f = coerce T (\s -> fw s)
+ fw = \s -> E
+ in ...
+
+Now we'll inline f to get
+
+ let fw = \s -> E
+ in \x -> case x of
+ p -> fw
+ q -> \s -> E2
+ r -> fw
+
+Now we'll see that fw has arity 1, and will arity expand
+the \x to get what we want.
+
+\begin{code}
+-- mkWWargs is driven off the function type and arity.
+-- It chomps bites off foralls, arrows, newtypes
+-- and keeps repeating that until it's satisfied the supplied arity
+
+mkWWargs :: Type
+ -> [Demand]
+ -> [Bool] -- True for a one-shot arg; ** may be infinite **
+ -> UniqSM ([Var], -- Wrapper args
+ CoreExpr -> CoreExpr, -- Wrapper fn
+ CoreExpr -> CoreExpr, -- Worker fn
+ Type) -- Type of wrapper body
+
+mkWWargs fun_ty demands one_shots
+ | Just rep_ty <- splitNewType_maybe fun_ty
+ -- The newtype case is for when the function has
+ -- a recursive newtype after the arrow (rare)
+ -- We check for arity >= 0 to avoid looping in the case
+ -- of a function whose type is, in effect, infinite
+ -- [Arity is driven by looking at the term, not just the type.]
+ --
+ -- It's also important when we have a function returning (say) a pair
+ -- wrapped in a recursive newtype, at least if CPR analysis can look
+ -- through such newtypes, which it probably can since they are
+ -- simply coerces.
+ = mkWWargs rep_ty demands one_shots `thenUs` \ (wrap_args, wrap_fn_args, work_fn_args, res_ty) ->
+ returnUs (wrap_args,
+ Note (Coerce fun_ty rep_ty) . wrap_fn_args,
+ work_fn_args . Note (Coerce rep_ty fun_ty),
+ res_ty)
+
+ | not (null demands)
+ = getUniquesUs `thenUs` \ wrap_uniqs ->
+ let
+ (tyvars, tau) = splitForAllTys fun_ty
+ (arg_tys, body_ty) = splitFunTys tau
+
+ n_demands = length demands
+ n_arg_tys = length arg_tys
+ n_args = n_demands `min` n_arg_tys
+
+ new_fun_ty = mkFunTys (drop n_demands arg_tys) body_ty
+ new_demands = drop n_arg_tys demands
+ new_one_shots = drop n_args one_shots
+
+ val_args = zipWith4 mk_wrap_arg wrap_uniqs arg_tys demands one_shots
+ wrap_args = tyvars ++ val_args
+ in
+{- ASSERT( not (null tyvars) || not (null arg_tys) ) -}
+ if (null tyvars) && (null arg_tys) then
+ pprTrace "mkWWargs" (ppr fun_ty $$ ppr demands)
+ returnUs ([], id, id, fun_ty)
+ else
+
+ mkWWargs new_fun_ty
+ new_demands
+ new_one_shots `thenUs` \ (more_wrap_args, wrap_fn_args, work_fn_args, res_ty) ->
+
+ returnUs (wrap_args ++ more_wrap_args,
+ mkLams wrap_args . wrap_fn_args,
+ work_fn_args . applyToVars wrap_args,
+ res_ty)
+
+ | otherwise
+ = returnUs ([], id, id, fun_ty)
+
+
+applyToVars :: [Var] -> CoreExpr -> CoreExpr
+applyToVars vars fn = mkVarApps fn vars
+
+mk_wrap_arg uniq ty dmd one_shot
+ = set_one_shot one_shot (setIdNewDemandInfo (mkSysLocal SLIT("w") uniq ty) dmd)