{- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 A library for the ``worker\/wrapper'' back-end to the strictness analyser -} {-# LANGUAGE CPP #-} module GHC.Core.Opt.WorkWrap.Utils ( mkWwBodies, mkWWstr, mkWorkerArgs , DataConPatContext(..), UnboxingDecision(..), splitArgType_maybe, wantToUnbox , findTypeShape , isWorkerSmallEnough ) where #include "HsVersions.h" import GHC.Prelude import GHC.Core import GHC.Core.Utils ( exprType, mkCast, mkDefaultCase, mkSingleAltCase , bindNonRec, dataConRepFSInstPat ) import GHC.Types.Id import GHC.Types.Id.Info ( JoinArity ) import GHC.Core.DataCon import GHC.Types.Demand import GHC.Types.Cpr import GHC.Core.Make ( mkAbsentErrorApp, mkCoreUbxTup , mkCoreApp, mkCoreLet ) import GHC.Types.Id.Make ( voidArgId, voidPrimId ) import GHC.Builtin.Types ( tupleDataCon ) import GHC.Types.Literal ( mkLitRubbish ) import GHC.Types.Var.Env ( mkInScopeSet ) import GHC.Types.Var.Set ( VarSet ) import GHC.Core.Type import GHC.Core.Multiplicity import GHC.Core.Predicate ( isClassPred ) import GHC.Types.RepType ( isVoidTy, typeMonoPrimRep_maybe ) import GHC.Core.Coercion import GHC.Core.FamInstEnv import GHC.Types.Basic ( Boxity(..) ) import GHC.Core.TyCon import GHC.Core.TyCon.RecWalk import GHC.Types.Unique.Supply import GHC.Types.Unique import GHC.Types.Name ( getOccFS ) import GHC.Data.Maybe import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Driver.Session import GHC.Driver.Ppr import GHC.Data.FastString import GHC.Data.List.SetOps {- ************************************************************************ * * \subsection[mkWrapperAndWorker]{@mkWrapperAndWorker@} * * ************************************************************************ Here's an example. The original function is: \begin{verbatim} g :: forall a . Int -> [a] -> a g = \/\ a -> \ x ys -> case x of 0 -> head ys _ -> head (tail ys) \end{verbatim} From this, we want to produce: \begin{verbatim} -- wrapper (an unfolding) g :: forall a . Int -> [a] -> a g = \/\ a -> \ x ys -> case x of I# x# -> $wg a x# ys -- call the worker; don't forget the type args! -- worker $wg :: forall a . Int# -> [a] -> a $wg = \/\ a -> \ x# ys -> let x = I# x# in case x of -- note: body of g moved intact 0 -> head ys _ -> head (tail ys) \end{verbatim} Something we have to be careful about: Here's an example: \begin{verbatim} -- "f" strictness: U(P)U(P) f (I# a) (I# b) = a +# b g = f -- "g" strictness same as "f" \end{verbatim} \tr{f} will get a worker all nice and friendly-like; that's good. {\em But we don't want a worker for \tr{g}}, even though it has the same strictness as \tr{f}. Doing so could break laziness, at best. Consequently, we insist that the number of strictness-info items is exactly the same as the number of lambda-bound arguments. (This is probably slightly paranoid, but OK in practice.) If it isn't the same, we ``revise'' the strictness info, so that we won't propagate the unusable strictness-info into the interfaces. ************************************************************************ * * \subsection{The worker wrapper core} * * ************************************************************************ @mkWwBodies@ is called when doing the worker\/wrapper split inside a module. -} type WwResult = ([Demand], -- Demands for worker (value) args JoinArity, -- Number of worker (type OR value) args Id -> CoreExpr, -- Wrapper body, lacking only the worker Id CoreExpr -> CoreExpr) -- Worker body, lacking the original function rhs mkWwBodies :: DynFlags -> FamInstEnvs -> VarSet -- Free vars of RHS -- See Note [Freshen WW arguments] -> Id -- The original function -> [Demand] -- Strictness of original function -> Cpr -- Info about function result -> UniqSM (Maybe WwResult) -- wrap_fn_args E = \x y -> E -- work_fn_args E = E x y -- wrap_fn_str E = case x of { (a,b) -> -- case a of { (a1,a2) -> -- E a1 a2 b y }} -- work_fn_str E = \a1 a2 b y -> -- let a = (a1,a2) in -- let x = (a,b) in -- E mkWwBodies :: DynFlags -> FamInstEnvs -> VarSet -> Id -> [Demand] -> Cpr -> UniqSM (Maybe WwResult) mkWwBodies DynFlags dflags FamInstEnvs fam_envs VarSet rhs_fvs Id fun_id [Demand] demands Cpr cpr_info = do { let empty_subst :: TCvSubst empty_subst = InScopeSet -> TCvSubst mkEmptyTCvSubst (VarSet -> InScopeSet mkInScopeSet VarSet rhs_fvs) -- See Note [Freshen WW arguments] ; ([Id] wrap_args, CoreExpr -> CoreExpr wrap_fn_args, CoreExpr -> CoreExpr work_fn_args, Kind res_ty) <- TCvSubst -> Kind -> [Demand] -> UniqSM ([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind) mkWWargs TCvSubst empty_subst Kind fun_ty [Demand] demands ; (Bool useful1, [Id] work_args, CoreExpr -> CoreExpr wrap_fn_str, CoreExpr -> CoreExpr work_fn_str) <- DynFlags -> FamInstEnvs -> Bool -> [Id] -> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr) mkWWstr DynFlags dflags FamInstEnvs fam_envs Bool has_inlineable_prag [Id] wrap_args -- Do CPR w/w. See Note [Always do CPR w/w] ; (Bool useful2, CoreExpr -> CoreExpr wrap_fn_cpr, CoreExpr -> CoreExpr work_fn_cpr, Kind cpr_res_ty) <- Bool -> FamInstEnvs -> Kind -> Cpr -> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind) mkWWcpr (GeneralFlag -> DynFlags -> Bool gopt GeneralFlag Opt_CprAnal DynFlags dflags) FamInstEnvs fam_envs Kind res_ty Cpr cpr_info ; let ([Id] work_lam_args, [Id] work_call_args) = DynFlags -> [Id] -> Kind -> ([Id], [Id]) mkWorkerArgs DynFlags dflags [Id] work_args Kind cpr_res_ty worker_args_dmds :: [Demand] worker_args_dmds = [Id -> Demand idDemandInfo Id v | Id v <- [Id] work_call_args, Id -> Bool isId Id v] wrapper_body :: Id -> CoreExpr wrapper_body = CoreExpr -> CoreExpr wrap_fn_args forall b c a. (b -> c) -> (a -> b) -> a -> c . CoreExpr -> CoreExpr wrap_fn_cpr forall b c a. (b -> c) -> (a -> b) -> a -> c . CoreExpr -> CoreExpr wrap_fn_str forall b c a. (b -> c) -> (a -> b) -> a -> c . [Id] -> CoreExpr -> CoreExpr applyToVars [Id] work_call_args forall b c a. (b -> c) -> (a -> b) -> a -> c . forall b. Id -> Expr b Var worker_body :: CoreExpr -> CoreExpr worker_body = forall b. [b] -> Expr b -> Expr b mkLams [Id] work_lam_argsforall b c a. (b -> c) -> (a -> b) -> a -> c . CoreExpr -> CoreExpr work_fn_str forall b c a. (b -> c) -> (a -> b) -> a -> c . CoreExpr -> CoreExpr work_fn_cpr forall b c a. (b -> c) -> (a -> b) -> a -> c . CoreExpr -> CoreExpr work_fn_args ; if DynFlags -> Int -> [Id] -> Bool isWorkerSmallEnough DynFlags dflags (forall (t :: * -> *) a. Foldable t => t a -> Int length [Demand] demands) [Id] work_args Bool -> Bool -> Bool && Bool -> Bool not ([Id] -> Bool too_many_args_for_join_point [Id] wrap_args) Bool -> Bool -> Bool && ((Bool useful1 Bool -> Bool -> Bool && Bool -> Bool not Bool only_one_void_argument) Bool -> Bool -> Bool || Bool useful2) then forall (m :: * -> *) a. Monad m => a -> m a return (forall a. a -> Maybe a Just ([Demand] worker_args_dmds, forall (t :: * -> *) a. Foldable t => t a -> Int length [Id] work_call_args, Id -> CoreExpr wrapper_body, CoreExpr -> CoreExpr worker_body)) else forall (m :: * -> *) a. Monad m => a -> m a return forall a. Maybe a Nothing } -- We use an INLINE unconditionally, even if the wrapper turns out to be -- something trivial like -- fw = ... -- f = __inline__ (coerce T fw) -- The point is to propagate the coerce to f's call sites, so even though -- f's RHS is now trivial (size 1) we still want the __inline__ to prevent -- fw from being inlined into f's RHS where fun_ty :: Kind fun_ty = Id -> Kind idType Id fun_id mb_join_arity :: Maybe Int mb_join_arity = Id -> Maybe Int isJoinId_maybe Id fun_id has_inlineable_prag :: Bool has_inlineable_prag = Unfolding -> Bool isStableUnfolding (Id -> Unfolding realIdUnfolding Id fun_id) -- See Note [Do not unpack class dictionaries] -- Note [Do not split void functions] only_one_void_argument :: Bool only_one_void_argument | [Demand d] <- [Demand] demands , Just (Kind _, Kind arg_ty1, Kind _) <- Kind -> Maybe (Kind, Kind, Kind) splitFunTy_maybe Kind fun_ty , Demand -> Bool isAbsDmd Demand d Bool -> Bool -> Bool && Kind -> Bool isVoidTy Kind arg_ty1 = Bool True | Bool otherwise = Bool False -- Note [Join points returning functions] too_many_args_for_join_point :: [Id] -> Bool too_many_args_for_join_point [Id] wrap_args | Just Int join_arity <- Maybe Int mb_join_arity , [Id] wrap_args forall a. [a] -> Int -> Bool `lengthExceeds` Int join_arity = WARN(True, text "Unable to worker/wrapper join point with arity " <+> int join_arity <+> text "but" <+> int (length wrap_args) <+> text "args") Bool True | Bool otherwise = Bool False -- See Note [Limit w/w arity] isWorkerSmallEnough :: DynFlags -> Int -> [Var] -> Bool isWorkerSmallEnough :: DynFlags -> Int -> [Id] -> Bool isWorkerSmallEnough DynFlags dflags Int old_n_args [Id] vars = forall a. (a -> Bool) -> [a] -> Int count Id -> Bool isId [Id] vars forall a. Ord a => a -> a -> Bool <= forall a. Ord a => a -> a -> a max Int old_n_args (DynFlags -> Int maxWorkerArgs DynFlags dflags) -- We count only Free variables (isId) to skip Type, Kind -- variables which have no runtime representation. -- Also if the function took 82 arguments before (old_n_args), it's fine if -- it takes <= 82 arguments afterwards. {- Note [Always do CPR w/w] ~~~~~~~~~~~~~~~~~~~~~~~~ At one time we refrained from doing CPR w/w for thunks, on the grounds that we might duplicate work. But that is already handled by the demand analyser, which doesn't give the CPR property if w/w might waste work: see Note [CPR for thunks] in GHC.Core.Opt.DmdAnal. And if something *has* been given the CPR property and we don't w/w, it's a disaster, because then the enclosing function might say it has the CPR property, but now doesn't and there a cascade of disaster. A good example is #5920. Note [Limit w/w arity] ~~~~~~~~~~~~~~~~~~~~~~~~ Guard against high worker arity as it generates a lot of stack traffic. A simplified example is #11565#comment:6 Current strategy is very simple: don't perform w/w transformation at all if the result produces a wrapper with arity higher than -fmax-worker-args and the number arguments before w/w (see #18122). It is a bit all or nothing, consider f (x,y) (a,b,c,d,e ... , z) = rhs Currently we will remove all w/w ness entirely. But actually we could w/w on the (x,y) pair... it's the huge product that is the problem. Could we instead refrain from w/w on an arg-by-arg basis? Yes, that'd solve f. But we can get a lot of args from deeply-nested products: g (a, (b, (c, (d, ...)))) = rhs This is harder to spot on an arg-by-arg basis. Previously mkWwStr was given some "fuel" saying how many arguments it could add; when we ran out of fuel it would stop w/wing. Still not very clever because it had a left-right bias. ************************************************************************ * * \subsection{Making wrapper args} * * ************************************************************************ During worker-wrapper stuff we may end up with an unlifted thing which we want to let-bind without losing laziness. So we add a void argument. E.g. f = /\a -> \x y z -> E::Int# -- E does not mention x,y,z ==> fw = /\ a -> \void -> E f = /\ a -> \x y z -> fw realworld We use the state-token type which generates no code. -} mkWorkerArgs :: DynFlags -> [Var] -> Type -- Type of body -> ([Var], -- Lambda bound args [Var]) -- Args at call site mkWorkerArgs :: DynFlags -> [Id] -> Kind -> ([Id], [Id]) mkWorkerArgs DynFlags dflags [Id] args Kind res_ty | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool any Id -> Bool isId [Id] args Bool -> Bool -> Bool || Bool -> Bool not Bool needsAValueLambda = ([Id] args, [Id] args) | Bool otherwise = ([Id] args forall a. [a] -> [a] -> [a] ++ [Id voidArgId], [Id] args forall a. [a] -> [a] -> [a] ++ [Id voidPrimId]) where -- See "Making wrapper args" section above needsAValueLambda :: Bool needsAValueLambda = Bool lifted -- We may encounter a levity-polymorphic result, in which case we -- conservatively assume that we have laziness that needs preservation. -- See #15186. Bool -> Bool -> Bool || Bool -> Bool not (GeneralFlag -> DynFlags -> Bool gopt GeneralFlag Opt_FunToThunk DynFlags dflags) -- see Note [Protecting the last value argument] -- Might the result be lifted? lifted :: Bool lifted = case HasDebugCallStack => Kind -> Maybe Bool isLiftedType_maybe Kind res_ty of Just Bool lifted -> Bool lifted Maybe Bool Nothing -> Bool True {- Note [Protecting the last value argument] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If the user writes (\_ -> E), they might be intentionally disallowing the sharing of E. Since absence analysis and worker-wrapper are keen to remove such unused arguments, we add in a void argument to prevent the function from becoming a thunk. The user can avoid adding the void argument with the -ffun-to-thunk flag. However, this can create sharing, which may be bad in two ways. 1) It can create a space leak. 2) It can prevent inlining *under a lambda*. If w/w removes the last argument from a function f, then f now looks like a thunk, and so f can't be inlined *under a lambda*. Note [Join points and beta-redexes] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Originally, the worker would invoke the original function by calling it with arguments, thus producing a beta-redex for the simplifier to munch away: \x y z -> e => (\x y z -> e) wx wy wz Now that we have special rules about join points, however, this is Not Good if the original function is itself a join point, as then it may contain invocations of other join points: join j1 x = ... join j2 y = if y == 0 then 0 else j1 y => join j1 x = ... join $wj2 y# = let wy = I# y# in (\y -> if y == 0 then 0 else jump j1 y) wy join j2 y = case y of I# y# -> jump $wj2 y# There can't be an intervening lambda between a join point's declaration and its occurrences, so $wj2 here is wrong. But of course, this is easy enough to fix: ... let join $wj2 y# = let wy = I# y# in let y = wy in if y == 0 then 0 else j1 y ... Hence we simply do the beta-reduction here. (This would be harder if we had to worry about hygiene, but luckily wy is freshly generated.) Note [Join points returning functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It is crucial that the arity of a join point depends on its *callers,* not its own syntax. What this means is that a join point can have "extra lambdas": f :: Int -> Int -> (Int, Int) -> Int f x y = join j (z, w) = \(u, v) -> ... in jump j (x, y) Typically this happens with functions that are seen as computing functions, rather than being curried. (The real-life example was GHC.Data.Graph.Ops.addConflicts.) When we create the wrapper, it *must* be in "eta-contracted" form so that the jump has the right number of arguments: f x y = join $wj z' w' = \u' v' -> let {z = z'; w = w'; u = u'; v = v'} in ... j (z, w) = jump $wj z w (See Note [Join points and beta-redexes] for where the lets come from.) If j were a function, we would instead say f x y = let $wj = \z' w' u' v' -> let {z = z'; w = w'; u = u'; v = v'} in ... j (z, w) (u, v) = $wj z w u v Notice that the worker ends up with the same lambdas; it's only the wrapper we have to be concerned about. FIXME Currently the functionality to produce "eta-contracted" wrappers is unimplemented; we simply give up. ************************************************************************ * * \subsection{Coercion stuff} * * ************************************************************************ 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. -} -- mkWWargs just does eta expansion -- 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 :: TCvSubst -- Freshening substitution to apply to the type -- See Note [Freshen WW arguments] -> Type -- The type of the function -> [Demand] -- Demands and one-shot info for value arguments -> UniqSM ([Var], -- Wrapper args CoreExpr -> CoreExpr, -- Wrapper fn CoreExpr -> CoreExpr, -- Worker fn Type) -- Type of wrapper body mkWWargs :: TCvSubst -> Kind -> [Demand] -> UniqSM ([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind) mkWWargs TCvSubst subst Kind fun_ty [Demand] demands | forall (t :: * -> *) a. Foldable t => t a -> Bool null [Demand] demands = forall (m :: * -> *) a. Monad m => a -> m a return ([], forall a. a -> a id, forall a. a -> a id, HasCallStack => TCvSubst -> Kind -> Kind substTy TCvSubst subst Kind fun_ty) | (Demand dmd:[Demand] demands') <- [Demand] demands , Just (Kind mult, Kind arg_ty, Kind fun_ty') <- Kind -> Maybe (Kind, Kind, Kind) splitFunTy_maybe Kind fun_ty = do { Unique uniq <- forall (m :: * -> *). MonadUnique m => m Unique getUniqueM ; let arg_ty' :: Scaled Kind arg_ty' = HasCallStack => TCvSubst -> Scaled Kind -> Scaled Kind substScaledTy TCvSubst subst (forall a. Kind -> a -> Scaled a Scaled Kind mult Kind arg_ty) id :: Id id = Unique -> Scaled Kind -> Demand -> Id mk_wrap_arg Unique uniq Scaled Kind arg_ty' Demand dmd ; ([Id] wrap_args, CoreExpr -> CoreExpr wrap_fn_args, CoreExpr -> CoreExpr work_fn_args, Kind res_ty) <- TCvSubst -> Kind -> [Demand] -> UniqSM ([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind) mkWWargs TCvSubst subst Kind fun_ty' [Demand] demands' ; forall (m :: * -> *) a. Monad m => a -> m a return (Id id forall a. a -> [a] -> [a] : [Id] wrap_args, forall b. b -> Expr b -> Expr b Lam Id id forall b c a. (b -> c) -> (a -> b) -> a -> c . CoreExpr -> CoreExpr wrap_fn_args, (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr -> CoreExpr apply_or_bind_then CoreExpr -> CoreExpr work_fn_args (forall b. Id -> Expr b varToCoreExpr Id id), Kind res_ty) } | Just (Id tv, Kind fun_ty') <- Kind -> Maybe (Id, Kind) splitForAllTyCoVar_maybe Kind fun_ty = do { Unique uniq <- forall (m :: * -> *). MonadUnique m => m Unique getUniqueM ; let (TCvSubst subst', Id tv') = TCvSubst -> Id -> Unique -> (TCvSubst, Id) cloneTyVarBndr TCvSubst subst Id tv Unique uniq -- See Note [Freshen WW arguments] ; ([Id] wrap_args, CoreExpr -> CoreExpr wrap_fn_args, CoreExpr -> CoreExpr work_fn_args, Kind res_ty) <- TCvSubst -> Kind -> [Demand] -> UniqSM ([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind) mkWWargs TCvSubst subst' Kind fun_ty' [Demand] demands ; forall (m :: * -> *) a. Monad m => a -> m a return (Id tv' forall a. a -> [a] -> [a] : [Id] wrap_args, forall b. b -> Expr b -> Expr b Lam Id tv' forall b c a. (b -> c) -> (a -> b) -> a -> c . CoreExpr -> CoreExpr wrap_fn_args, (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr -> CoreExpr apply_or_bind_then CoreExpr -> CoreExpr work_fn_args (forall b. Kind -> Expr b mkTyArg (Id -> Kind mkTyVarTy Id tv')), Kind res_ty) } | Just (Coercion co, Kind rep_ty) <- Kind -> Maybe (Coercion, Kind) topNormaliseNewType_maybe Kind fun_ty -- The newtype case is for when the function has -- a newtype after the arrow (rare) -- -- It's also important when we have a function returning (say) a pair -- wrapped in a newtype, at least if CPR analysis can look -- through such newtypes, which it probably can since they are -- simply coerces. = do { ([Id] wrap_args, CoreExpr -> CoreExpr wrap_fn_args, CoreExpr -> CoreExpr work_fn_args, Kind res_ty) <- TCvSubst -> Kind -> [Demand] -> UniqSM ([Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind) mkWWargs TCvSubst subst Kind rep_ty [Demand] demands ; let co' :: Coercion co' = HasCallStack => TCvSubst -> Coercion -> Coercion substCo TCvSubst subst Coercion co ; forall (m :: * -> *) a. Monad m => a -> m a return ([Id] wrap_args, \CoreExpr e -> forall b. Expr b -> Coercion -> Expr b Cast (CoreExpr -> CoreExpr wrap_fn_args CoreExpr e) (Coercion -> Coercion mkSymCo Coercion co'), \CoreExpr e -> CoreExpr -> CoreExpr work_fn_args (forall b. Expr b -> Coercion -> Expr b Cast CoreExpr e Coercion co'), Kind res_ty) } | Bool otherwise = WARN( True, ppr fun_ty ) -- Should not happen: if there is a demand forall (m :: * -> *) a. Monad m => a -> m a return ([], forall a. a -> a id, forall a. a -> a id, HasCallStack => TCvSubst -> Kind -> Kind substTy TCvSubst subst Kind fun_ty) -- then there should be a function arrow where -- See Note [Join points and beta-redexes] apply_or_bind_then :: (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr -> CoreExpr apply_or_bind_then CoreExpr -> CoreExpr k CoreExpr arg (Lam Id bndr CoreExpr body) = CoreBind -> CoreExpr -> CoreExpr mkCoreLet (forall b. b -> Expr b -> Bind b NonRec Id bndr CoreExpr arg) (CoreExpr -> CoreExpr k CoreExpr body) -- Important that arg is fresh! apply_or_bind_then CoreExpr -> CoreExpr k CoreExpr arg CoreExpr fun = CoreExpr -> CoreExpr k forall a b. (a -> b) -> a -> b $ SDoc -> CoreExpr -> CoreExpr -> CoreExpr mkCoreApp (String -> SDoc text String "mkWWargs") CoreExpr fun CoreExpr arg applyToVars :: [Var] -> CoreExpr -> CoreExpr applyToVars :: [Id] -> CoreExpr -> CoreExpr applyToVars [Id] vars CoreExpr fn = forall b. Expr b -> [Id] -> Expr b mkVarApps CoreExpr fn [Id] vars mk_wrap_arg :: Unique -> Scaled Type -> Demand -> Id mk_wrap_arg :: Unique -> Scaled Kind -> Demand -> Id mk_wrap_arg Unique uniq (Scaled Kind w Kind ty) Demand dmd = FastString -> Unique -> Kind -> Kind -> Id mkSysLocalOrCoVar (String -> FastString fsLit String "w") Unique uniq Kind w Kind ty Id -> Demand -> Id `setIdDemandInfo` Demand dmd {- Note [Freshen WW arguments] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Wen we do a worker/wrapper split, we must not in-scope names as the arguments of the worker, else we'll get name capture. E.g. -- y1 is in scope from further out f x = ..y1.. If we accidentally choose y1 as a worker argument disaster results: fww y1 y2 = let x = (y1,y2) in ...y1... To avoid this: * We use a fresh unique for both type-variable and term-variable binders Originally we lacked this freshness for type variables, and that led to the very obscure #12562. (A type variable in the worker shadowed an outer term-variable binding.) * Because of this cloning we have to substitute in the type/kind of the new binders. That's why we carry the TCvSubst through mkWWargs. So we need a decent in-scope set, just in case that type/kind itself has foralls. We get this from the free vars of the RHS of the function since those are the only variables that might be captured. It's a lazy thunk, which will only be poked if the type/kind has a forall. Another tricky case was when f :: forall a. a -> forall a. a->a (i.e. with shadowing), and then the worker used the same 'a' twice. -} {- ************************************************************************ * * \subsection{Unboxing Decision for Strictness and CPR} * * ************************************************************************ -} -- | The information needed to build a pattern for a DataCon to be unboxed. -- The pattern can be generated from 'dcpc_dc' and 'dcpc_tc_args' via -- 'GHC.Core.Utils.dataConRepInstPat'. The coercion 'dcpc_co' is for newtype -- wrappers. -- -- If we get @DataConPatContext dc tys co@ for some type @ty@ -- and @dataConRepInstPat ... dc tys = (exs, flds)@, then -- -- * @dc @exs flds :: T tys@ -- * @co :: T tys ~ ty@ data DataConPatContext = DataConPatContext { DataConPatContext -> DataCon dcpc_dc :: !DataCon , DataConPatContext -> [Kind] dcpc_tc_args :: ![Type] , DataConPatContext -> Coercion dcpc_co :: !Coercion } -- | If @splitArgType_maybe ty = Just (dc, tys, co)@ -- then @dc \@tys \@_ex_tys (_args::_arg_tys) :: tc tys@ -- and @co :: ty ~ tc tys@ -- where underscore prefixes are holes, e.g. yet unspecified. -- -- See Note [Which types are unboxed?]. splitArgType_maybe :: FamInstEnvs -> Type -> Maybe DataConPatContext splitArgType_maybe :: FamInstEnvs -> Kind -> Maybe DataConPatContext splitArgType_maybe FamInstEnvs fam_envs Kind ty | let (Coercion co, Kind ty1) = FamInstEnvs -> Kind -> Maybe (Coercion, Kind) topNormaliseType_maybe FamInstEnvs fam_envs Kind ty forall a. Maybe a -> a -> a `orElse` (Kind -> Coercion mkRepReflCo Kind ty, Kind ty) , Just (TyCon tc, [Kind] tc_args) <- HasDebugCallStack => Kind -> Maybe (TyCon, [Kind]) splitTyConApp_maybe Kind ty1 , Just DataCon con <- TyCon -> Maybe DataCon tyConSingleAlgDataCon_maybe TyCon tc = forall a. a -> Maybe a Just DataConPatContext { dcpc_dc :: DataCon dcpc_dc = DataCon con , dcpc_tc_args :: [Kind] dcpc_tc_args = [Kind] tc_args , dcpc_co :: Coercion dcpc_co = Coercion co } splitArgType_maybe FamInstEnvs _ Kind _ = forall a. Maybe a Nothing -- | If @splitResultType_maybe n ty = Just (dc, tys, co)@ -- then @dc \@tys \@_ex_tys (_args::_arg_tys) :: tc tys@ -- and @co :: ty ~ tc tys@ -- where underscore prefixes are holes, e.g. yet unspecified. -- @dc@ is the @n@th data constructor of @tc@. -- -- See Note [Which types are unboxed?]. splitResultType_maybe :: FamInstEnvs -> ConTag -> Type -> Maybe DataConPatContext splitResultType_maybe :: FamInstEnvs -> Int -> Kind -> Maybe DataConPatContext splitResultType_maybe FamInstEnvs fam_envs Int con_tag Kind ty | let (Coercion co, Kind ty1) = FamInstEnvs -> Kind -> Maybe (Coercion, Kind) topNormaliseType_maybe FamInstEnvs fam_envs Kind ty forall a. Maybe a -> a -> a `orElse` (Kind -> Coercion mkRepReflCo Kind ty, Kind ty) , Just (TyCon tc, [Kind] tc_args) <- HasDebugCallStack => Kind -> Maybe (TyCon, [Kind]) splitTyConApp_maybe Kind ty1 , TyCon -> Bool isDataTyCon TyCon tc -- NB: rules out unboxed sums and pairs! , let cons :: [DataCon] cons = TyCon -> [DataCon] tyConDataCons TyCon tc , [DataCon] cons forall a. [a] -> Int -> Bool `lengthAtLeast` Int con_tag -- This might not be true if we import the -- type constructor via a .hs-boot file (#8743) , let con :: DataCon con = [DataCon] cons forall a. Outputable a => [a] -> Int -> a `getNth` (Int con_tag forall a. Num a => a -> a -> a - Int fIRST_TAG) , forall (t :: * -> *) a. Foldable t => t a -> Bool null (DataCon -> [Id] dataConExTyCoVars DataCon con) -- no existentials; -- See Note [Which types are unboxed?] -- and GHC.Core.Opt.CprAnal.extendEnvForDataAlt -- where we also check this. , forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool all forall a. Scaled a -> Bool isLinear (DataCon -> [Kind] -> [Scaled Kind] dataConInstArgTys DataCon con [Kind] tc_args) -- Deactivates CPR worker/wrapper splits on constructors with non-linear -- arguments, for the moment, because they require unboxed tuple with variable -- multiplicity fields. = forall a. a -> Maybe a Just DataConPatContext { dcpc_dc :: DataCon dcpc_dc = DataCon con , dcpc_tc_args :: [Kind] dcpc_tc_args = [Kind] tc_args , dcpc_co :: Coercion dcpc_co = Coercion co } splitResultType_maybe FamInstEnvs _ Int _ Kind _ = forall a. Maybe a Nothing isLinear :: Scaled a -> Bool isLinear :: forall a. Scaled a -> Bool isLinear (Scaled Kind w a _ ) = case Kind w of Kind One -> Bool True Kind _ -> Bool False -- | Describes the outer shape of an argument to be unboxed or left as-is -- Depending on how @s@ is instantiated (e.g., 'Demand'). data UnboxingDecision s = StopUnboxing -- ^ We ran out of strictness info. Leave untouched. | Unbox !DataConPatContext [s] -- ^ The argument is used strictly or the returned product was constructed, so -- unbox it. -- The 'DataConPatContext' carries the bits necessary for -- instantiation with 'dataConRepInstPat'. -- The @[s]@ carries the bits of information with which we can continue -- unboxing, e.g. @s@ will be 'Demand'. wantToUnbox :: FamInstEnvs -> Bool -> Type -> Demand -> UnboxingDecision Demand -- See Note [Which types are unboxed?] wantToUnbox :: FamInstEnvs -> Bool -> Kind -> Demand -> UnboxingDecision Demand wantToUnbox FamInstEnvs fam_envs Bool has_inlineable_prag Kind ty Demand dmd = case FamInstEnvs -> Kind -> Maybe DataConPatContext splitArgType_maybe FamInstEnvs fam_envs Kind ty of Just dcpc :: DataConPatContext dcpc@DataConPatContext{ dcpc_dc :: DataConPatContext -> DataCon dcpc_dc = DataCon dc } | Demand -> Bool isStrUsedDmd Demand dmd Bool -> Bool -> Bool || HasDebugCallStack => Kind -> Bool isUnliftedType Kind ty , let arity :: Int arity = DataCon -> Int dataConRepArity DataCon dc -- See Note [Unpacking arguments with product and polymorphic demands] , Just [Demand] cs <- Demand -> Int -> Maybe [Demand] split_prod_dmd_arity Demand dmd Int arity -- See Note [Do not unpack class dictionaries] , Bool -> Bool not (Bool has_inlineable_prag Bool -> Bool -> Bool && Kind -> Bool isClassPred Kind ty) -- See Note [mkWWstr and unsafeCoerce] , [Demand] cs forall a. [a] -> Int -> Bool `lengthIs` Int arity -- See Note [Add demands for strict constructors] , let cs' :: [Demand] cs' = DataCon -> [Demand] -> [Demand] addDataConStrictness DataCon dc [Demand] cs -> forall s. DataConPatContext -> [s] -> UnboxingDecision s Unbox DataConPatContext dcpc [Demand] cs' Maybe DataConPatContext _ -> forall s. UnboxingDecision s StopUnboxing where split_prod_dmd_arity :: Demand -> Int -> Maybe [Demand] split_prod_dmd_arity Demand dmd Int arity -- For seqDmd, it should behave like <S(AAAA)>, for some -- suitable arity | Demand -> Bool isSeqDmd Demand dmd = forall a. a -> Maybe a Just (forall a. Int -> a -> [a] replicate Int arity Demand absDmd) | Card _ :* Prod [Demand] ds <- Demand dmd = forall a. a -> Maybe a Just [Demand] ds | Bool otherwise = forall a. Maybe a Nothing {- Note [Which types are unboxed?] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Worker/wrapper will unbox 1. A strict data type argument, that * is an algebraic data type (not a newtype) * has a single constructor (thus is a "product") * that may bind existentials We can transform > f (D @ex a b) = e to > $wf @ex a b = e via 'mkWWstr'. 2. The constructed result of a function, if * its type is an algebraic data type (not a newtype) * (might have multiple constructors, in contrast to (1)) * the applied data constructor *does not* bind existentials We can transform > f x y = let ... in D a b to > $wf x y = let ... in (# a, b #) via 'mkWWcpr'. NB: We don't allow existentials for CPR W/W, because we don't have unboxed dependent tuples (yet?). Otherwise, we could transform > f x y = let ... in D @ex (a :: ..ex..) (b :: ..ex..) to > $wf x y = let ... in (# @ex, (a :: ..ex..), (b :: ..ex..) #) The respective tests are in 'splitArgType_maybe' and 'splitResultType_maybe', respectively. Note that the data constructor /can/ have evidence arguments: equality constraints, type classes etc. So it can be GADT. These evidence arguments are simply value arguments, and should not get in the way. Note [Unpacking arguments with product and polymorphic demands] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The argument is unpacked in a case if it has a product type and has a strict *and* used demand put on it. I.e., arguments, with demands such as the following ones: <S,U(U, L)> <S(L,S),U> will be unpacked, but <S,U> or <B,U> will not, because the pieces aren't used. This is quite important otherwise we end up unpacking massive tuples passed to the bottoming function. Example: f :: ((Int,Int) -> String) -> (Int,Int) -> a f g pr = error (g pr) main = print (f fst (1, error "no")) Does 'main' print "error 1" or "error no"? We don't really want 'f' to unbox its second argument. This actually happened in GHC's onwn source code, in Packages.applyPackageFlag, which ended up un-boxing the enormous DynFlags tuple, and being strict in the as-yet-un-filled-in unitState files. Note [Do not unpack class dictionaries] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If we have f :: Ord a => [a] -> Int -> a {-# INLINABLE f #-} and we worker/wrapper f, we'll get a worker with an INLINABLE pragma (see Note [Worker-wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap), which can still be specialised by the type-class specialiser, something like fw :: Ord a => [a] -> Int# -> a BUT if f is strict in the Ord dictionary, we might unpack it, to get fw :: (a->a->Bool) -> [a] -> Int# -> a and the type-class specialiser can't specialise that. An example is #6056. But in any other situation a dictionary is just an ordinary value, and can be unpacked. So we track the INLINABLE pragma, and switch off the unpacking in mkWWstr_one (see the isClassPred test). Historical note: #14955 describes how I got this fix wrong the first time. Note [mkWWstr and unsafeCoerce] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ By using unsafeCoerce, it is possible to make the number of demands fail to match the number of constructor arguments; this happened in #8037. If so, the worker/wrapper split doesn't work right and we get a Core Lint bug. The fix here is simply to decline to do w/w if that happens. Note [Add demands for strict constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this program (due to Roman): data X a = X !a foo :: X Int -> Int -> Int foo (X a) n = go 0 where go i | i < n = a + go (i+1) | otherwise = 0 We want the worker for 'foo' too look like this: $wfoo :: Int# -> Int# -> Int# with the first argument unboxed, so that it is not eval'd each time around the 'go' loop (which would otherwise happen, since 'foo' is not strict in 'a'). It is sound for the wrapper to pass an unboxed arg because X is strict, so its argument must be evaluated. And if we *don't* pass an unboxed argument, we can't even repair it by adding a `seq` thus: foo (X a) n = a `seq` go 0 because the seq is discarded (very early) since X is strict! So here's what we do * We leave the demand-analysis alone. The demand on 'a' in the definition of 'foo' is <L, U(U)>; the strictness info is Lazy because foo's body may or may not evaluate 'a'; but the usage info says that 'a' is unpacked and its content is used. * During worker/wrapper, if we unpack a strict constructor (as we do for 'foo'), we use 'addDataConStrictness' to bump up the strictness on the strict arguments of the data constructor. * That in turn means that, if the usage info supports doing so (i.e. splitProdDmd_maybe returns Just), we will unpack that argument -- even though the original demand (e.g. on 'a') was lazy. * What does "bump up the strictness" mean? Just add a head-strict demand to the strictness! Even for a demand like <L,A> we can safely turn it into <S,A>; remember case (1) of Note [How to do the worker/wrapper split]. The net effect is that the w/w transformation is more aggressive about unpacking the strict arguments of a data constructor, when that eagerness is supported by the usage info. There is the usual danger of reboxing, which as usual we ignore. But if X is monomorphic, and has an UNPACK pragma, then this optimisation is even more important. We don't want the wrapper to rebox an unboxed argument, and pass an Int to $wfoo! This works in nested situations like data family Bar a data instance Bar (a, b) = BarPair !(Bar a) !(Bar b) newtype instance Bar Int = Bar Int foo :: Bar ((Int, Int), Int) -> Int -> Int foo f k = case f of BarPair x y -> case burble of True -> case x of BarPair p q -> ... False -> ... The extra eagerness lets us produce a worker of type: $wfoo :: Int# -> Int# -> Int# -> Int -> Int $wfoo p# q# y# = ... even though the `case x` is only lazily evaluated. --------- Historical note ------------ We used to add data-con strictness demands when demand analysing case expression. However, it was noticed in #15696 that this misses some cases. For instance, consider the program (from T10482) data family Bar a data instance Bar (a, b) = BarPair !(Bar a) !(Bar b) newtype instance Bar Int = Bar Int foo :: Bar ((Int, Int), Int) -> Int -> Int foo f k = case f of BarPair x y -> case burble of True -> case x of BarPair p q -> ... False -> ... We really should be able to assume that `p` is already evaluated since it came from a strict field of BarPair. This strictness would allow us to produce a worker of type: $wfoo :: Int# -> Int# -> Int# -> Int -> Int $wfoo p# q# y# = ... even though the `case x` is only lazily evaluated Indeed before we fixed #15696 this would happen since we would float the inner `case x` through the `case burble` to get: foo f k = case f of BarPair x y -> case x of BarPair p q -> case burble of True -> ... False -> ... However, after fixing #15696 this could no longer happen (for the reasons discussed in ticket:15696#comment:76). This means that the demand placed on `f` would then be significantly weaker (since the False branch of the case on `burble` is not strict in `p` or `q`). Consequently, we now instead account for data-con strictness in mkWWstr_one, applying the strictness demands to the final result of DmdAnal. The result is that we get the strict demand signature we wanted even if we can't float the case on `x` up through the case on `burble`. -} {- ************************************************************************ * * \subsection{Strictness stuff} * * ************************************************************************ -} mkWWstr :: DynFlags -> FamInstEnvs -> Bool -- True <=> INLINEABLE pragma on this function defn -- See Note [Do not unpack class dictionaries] -> [Var] -- Wrapper args; have their demand info on them -- *Includes type variables* -> UniqSM (Bool, -- Is this useful [Var], -- Worker args CoreExpr -> CoreExpr, -- Wrapper body, lacking the worker call -- and without its lambdas -- This fn adds the unboxing CoreExpr -> CoreExpr) -- Worker body, lacking the original body of the function, -- and lacking its lambdas. -- This fn does the reboxing mkWWstr :: DynFlags -> FamInstEnvs -> Bool -> [Id] -> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr) mkWWstr DynFlags dflags FamInstEnvs fam_envs Bool has_inlineable_prag [Id] args = [Id] -> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr) go [Id] args where go_one :: Id -> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr) go_one Id arg = DynFlags -> FamInstEnvs -> Bool -> Id -> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr) mkWWstr_one DynFlags dflags FamInstEnvs fam_envs Bool has_inlineable_prag Id arg go :: [Id] -> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr) go [] = forall (m :: * -> *) a. Monad m => a -> m a return (Bool False, [], CoreExpr -> CoreExpr nop_fn, CoreExpr -> CoreExpr nop_fn) go (Id arg : [Id] args) = do { (Bool useful1, [Id] args1, CoreExpr -> CoreExpr wrap_fn1, CoreExpr -> CoreExpr work_fn1) <- Id -> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr) go_one Id arg ; (Bool useful2, [Id] args2, CoreExpr -> CoreExpr wrap_fn2, CoreExpr -> CoreExpr work_fn2) <- [Id] -> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr) go [Id] args ; forall (m :: * -> *) a. Monad m => a -> m a return ( Bool useful1 Bool -> Bool -> Bool || Bool useful2 , [Id] args1 forall a. [a] -> [a] -> [a] ++ [Id] args2 , CoreExpr -> CoreExpr wrap_fn1 forall b c a. (b -> c) -> (a -> b) -> a -> c . CoreExpr -> CoreExpr wrap_fn2 , CoreExpr -> CoreExpr work_fn1 forall b c a. (b -> c) -> (a -> b) -> a -> c . CoreExpr -> CoreExpr work_fn2) } ---------------------- -- mkWWstr_one wrap_arg = (useful, work_args, wrap_fn, work_fn) -- * wrap_fn assumes wrap_arg is in scope, -- brings into scope work_args (via cases) -- * work_fn assumes work_args are in scope, a -- brings into scope wrap_arg (via lets) -- See Note [How to do the worker/wrapper split] mkWWstr_one :: DynFlags -> FamInstEnvs -> Bool -- True <=> INLINEABLE pragma on this function defn -- See Note [Do not unpack class dictionaries] -> Var -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr) mkWWstr_one :: DynFlags -> FamInstEnvs -> Bool -> Id -> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr) mkWWstr_one DynFlags dflags FamInstEnvs fam_envs Bool has_inlineable_prag Id arg | Id -> Bool isTyVar Id arg = forall (m :: * -> *) a. Monad m => a -> m a return (Bool False, [Id arg], CoreExpr -> CoreExpr nop_fn, CoreExpr -> CoreExpr nop_fn) | Demand -> Bool isAbsDmd Demand dmd , Just CoreExpr -> CoreExpr work_fn <- DynFlags -> Id -> Demand -> Maybe (CoreExpr -> CoreExpr) mk_absent_let DynFlags dflags Id arg Demand dmd -- Absent case. We can't always handle absence for rep-polymorphic -- types, so we need to choose just the cases we can -- (that's what mk_absent_let does) = forall (m :: * -> *) a. Monad m => a -> m a return (Bool True, [], CoreExpr -> CoreExpr nop_fn, CoreExpr -> CoreExpr work_fn) | Unbox DataConPatContext dcpc [Demand] cs <- FamInstEnvs -> Bool -> Kind -> Demand -> UnboxingDecision Demand wantToUnbox FamInstEnvs fam_envs Bool has_inlineable_prag Kind arg_ty Demand dmd = DynFlags -> FamInstEnvs -> Id -> [Demand] -> DataConPatContext -> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr) unbox_one DynFlags dflags FamInstEnvs fam_envs Id arg [Demand] cs DataConPatContext dcpc | Bool otherwise -- Other cases = forall (m :: * -> *) a. Monad m => a -> m a return (Bool False, [Id arg], CoreExpr -> CoreExpr nop_fn, CoreExpr -> CoreExpr nop_fn) where arg_ty :: Kind arg_ty = Id -> Kind idType Id arg dmd :: Demand dmd = Id -> Demand idDemandInfo Id arg unbox_one :: DynFlags -> FamInstEnvs -> Var -> [Demand] -> DataConPatContext -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr) unbox_one :: DynFlags -> FamInstEnvs -> Id -> [Demand] -> DataConPatContext -> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr) unbox_one DynFlags dflags FamInstEnvs fam_envs Id arg [Demand] cs DataConPatContext { dcpc_dc :: DataConPatContext -> DataCon dcpc_dc = DataCon dc, dcpc_tc_args :: DataConPatContext -> [Kind] dcpc_tc_args = [Kind] tc_args , dcpc_co :: DataConPatContext -> Coercion dcpc_co = Coercion co } = do { (Unique case_bndr_uniq:[Unique] pat_bndrs_uniqs) <- forall (m :: * -> *). MonadUnique m => m [Unique] getUniquesM ; let ex_name_fss :: [FastString] ex_name_fss = forall a b. (a -> b) -> [a] -> [b] map forall a. NamedThing a => a -> FastString getOccFS forall a b. (a -> b) -> a -> b $ DataCon -> [Id] dataConExTyCoVars DataCon dc ([Id] ex_tvs', [Id] arg_ids) = [FastString] -> [Unique] -> Kind -> DataCon -> [Kind] -> ([Id], [Id]) dataConRepFSInstPat ([FastString] ex_name_fss forall a. [a] -> [a] -> [a] ++ forall a. a -> [a] repeat FastString ww_prefix) [Unique] pat_bndrs_uniqs (Id -> Kind idMult Id arg) DataCon dc [Kind] tc_args arg_ids' :: [Id] arg_ids' = forall a b c. String -> (a -> b -> c) -> [a] -> [b] -> [c] zipWithEqual String "unbox_one" Id -> Demand -> Id setIdDemandInfo [Id] arg_ids [Demand] cs unbox_fn :: CoreExpr -> CoreExpr unbox_fn = CoreExpr -> Coercion -> Kind -> Unique -> DataCon -> [Id] -> CoreExpr -> CoreExpr mkUnpackCase (forall b. Id -> Expr b Var Id arg) Coercion co (Id -> Kind idMult Id arg) Unique case_bndr_uniq DataCon dc ([Id] ex_tvs' forall a. [a] -> [a] -> [a] ++ [Id] arg_ids') arg_no_unf :: Id arg_no_unf = Id -> Id zapStableUnfolding Id arg -- See Note [Zap unfolding when beta-reducing] -- in GHC.Core.Opt.Simplify; and see #13890 rebox_fn :: CoreExpr -> CoreExpr rebox_fn = forall b. Bind b -> Expr b -> Expr b Let (forall b. b -> Expr b -> Bind b NonRec Id arg_no_unf CoreExpr con_app) con_app :: CoreExpr con_app = forall b. DataCon -> [Kind] -> [Id] -> Expr b mkConApp2 DataCon dc [Kind] tc_args ([Id] ex_tvs' forall a. [a] -> [a] -> [a] ++ [Id] arg_ids') CoreExpr -> Coercion -> CoreExpr `mkCast` Coercion -> Coercion mkSymCo Coercion co ; (Bool _, [Id] worker_args, CoreExpr -> CoreExpr wrap_fn, CoreExpr -> CoreExpr work_fn) <- DynFlags -> FamInstEnvs -> Bool -> [Id] -> UniqSM (Bool, [Id], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr) mkWWstr DynFlags dflags FamInstEnvs fam_envs Bool False ([Id] ex_tvs' forall a. [a] -> [a] -> [a] ++ [Id] arg_ids') ; forall (m :: * -> *) a. Monad m => a -> m a return (Bool True, [Id] worker_args, CoreExpr -> CoreExpr unbox_fn forall b c a. (b -> c) -> (a -> b) -> a -> c . CoreExpr -> CoreExpr wrap_fn, CoreExpr -> CoreExpr work_fn forall b c a. (b -> c) -> (a -> b) -> a -> c . CoreExpr -> CoreExpr rebox_fn) } -- Don't pass the arg, rebox instead ---------------------- nop_fn :: CoreExpr -> CoreExpr nop_fn :: CoreExpr -> CoreExpr nop_fn CoreExpr body = CoreExpr body addDataConStrictness :: DataCon -> [Demand] -> [Demand] -- See Note [Add demands for strict constructors] addDataConStrictness :: DataCon -> [Demand] -> [Demand] addDataConStrictness DataCon con [Demand] ds | Maybe Id Nothing <- DataCon -> Maybe Id dataConWrapId_maybe DataCon con -- DataCon worker=wrapper. Implies no strict fields, so nothing to do = [Demand] ds addDataConStrictness DataCon con [Demand] ds = forall a b c. String -> (a -> b -> c) -> [a] -> [b] -> [c] zipWithEqual String "addDataConStrictness" Demand -> StrictnessMark -> Demand add [Demand] ds [StrictnessMark] strs where strs :: [StrictnessMark] strs = DataCon -> [StrictnessMark] dataConRepStrictness DataCon con add :: Demand -> StrictnessMark -> Demand add Demand dmd StrictnessMark str | StrictnessMark -> Bool isMarkedStrict StrictnessMark str = Demand -> Demand strictifyDmd Demand dmd | Bool otherwise = Demand dmd {- Note [How to do the worker/wrapper split] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The worker-wrapper transformation, mkWWstr_one, takes into account several possibilities to decide if the function is worthy for splitting: 1. If an argument is absent, it would be silly to pass it to the worker. Hence the isAbsDmd case. This case must come first because a demand like <S,A> or <B,A> is possible. E.g. <B,A> comes from a function like f x = error "urk" and <S,A> can come from Note [Add demands for strict constructors] 2. If the argument is evaluated strictly, and we can split the product demand (splitProdDmd_maybe), then unbox it and w/w its pieces. For example f :: (Int, Int) -> Int f p = (case p of (a,b) -> a) + 1 is split to f :: (Int, Int) -> Int f p = case p of (a,b) -> $wf a $wf :: Int -> Int $wf a = a + 1 and g :: Bool -> (Int, Int) -> Int g c p = case p of (a,b) -> if c then a else b is split to g c p = case p of (a,b) -> $gw c a b $gw c a b = if c then a else b 2a But do /not/ split if the components are not used; that is, the usage is just 'Used' rather than 'UProd'. In this case splitProdDmd_maybe returns Nothing. Otherwise we risk decomposing a massive tuple which is barely used. Example: f :: ((Int,Int) -> String) -> (Int,Int) -> a f g pr = error (g pr) main = print (f fst (1, error "no")) Here, f does not take 'pr' apart, and it's stupid to do so. Imagine that it had millions of fields. This actually happened in GHC itself where the tuple was DynFlags 3. A plain 'seqDmd', which is head-strict with usage UHead, can't be split by splitProdDmd_maybe. But we want it to behave just like U(AAAA) for suitable number of absent demands. So we have a special case for it, with arity coming from the data constructor. Note [Worker-wrapper for bottoming functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We used not to split if the result is bottom. [Justification: there's no efficiency to be gained.] But it's sometimes bad not to make a wrapper. Consider fw = \x# -> let x = I# x# in case e of p1 -> error_fn x p2 -> error_fn x p3 -> the real stuff The re-boxing code won't go away unless error_fn gets a wrapper too. [We don't do reboxing now, but in general it's better to pass an unboxed thing to f, and have it reboxed in the error cases....] Note [Record evaluated-ness in worker/wrapper] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have data T = MkT !Int Int f :: T -> T f x = e and f's is strict, and has the CPR property. The we are going to generate this w/w split f x = case x of MkT x1 x2 -> case $wf x1 x2 of (# r1, r2 #) -> MkT r1 r2 $wfw x1 x2 = let x = MkT x1 x2 in case e of MkT r1 r2 -> (# r1, r2 #) Note that * In the worker $wf, inside 'e' we can be sure that x1 will be evaluated (it came from unpacking the argument MkT. But that's no immediately apparent in $wf * In the wrapper 'f', which we'll inline at call sites, we can be sure that 'r1' has been evaluated (because it came from unpacking the result MkT. But that is not immediately apparent from the wrapper code. Missing these facts isn't unsound, but it loses possible future opportunities for optimisation. Solution: use setCaseBndrEvald when creating (A) The arg binders x1,x2 in mkWstr_one See #13077, test T13077 (B) The result binders r1,r2 in mkWWcpr_help See Trace #13077, test T13077a And #13027 comment:20, item (4) to record that the relevant binder is evaluated. ************************************************************************ * * Type scrutiny that is specific to demand analysis * * ************************************************************************ -} findTypeShape :: FamInstEnvs -> Type -> TypeShape -- Uncover the arrow and product shape of a type -- The data type TypeShape is defined in GHC.Types.Demand -- See Note [Trimming a demand to a type] in GHC.Core.Opt.DmdAnal findTypeShape :: FamInstEnvs -> Kind -> TypeShape findTypeShape FamInstEnvs fam_envs Kind ty = RecTcChecker -> Kind -> TypeShape go (Int -> RecTcChecker -> RecTcChecker setRecTcMaxBound Int 2 RecTcChecker initRecTc) Kind ty -- You might think this bound of 2 is low, but actually -- I think even 1 would be fine. This only bites for recursive -- product types, which are rare, and we really don't want -- to look deep into such products -- see #18034 where go :: RecTcChecker -> Kind -> TypeShape go RecTcChecker rec_tc Kind ty | Just (Kind _, Kind _, Kind res) <- Kind -> Maybe (Kind, Kind, Kind) splitFunTy_maybe Kind ty = TypeShape -> TypeShape TsFun (RecTcChecker -> Kind -> TypeShape go RecTcChecker rec_tc Kind res) | Just (TyCon tc, [Kind] tc_args) <- HasDebugCallStack => Kind -> Maybe (TyCon, [Kind]) splitTyConApp_maybe Kind ty = RecTcChecker -> TyCon -> [Kind] -> TypeShape go_tc RecTcChecker rec_tc TyCon tc [Kind] tc_args | Just (Id _, Kind ty') <- Kind -> Maybe (Id, Kind) splitForAllTyCoVar_maybe Kind ty = RecTcChecker -> Kind -> TypeShape go RecTcChecker rec_tc Kind ty' | Bool otherwise = TypeShape TsUnk go_tc :: RecTcChecker -> TyCon -> [Kind] -> TypeShape go_tc RecTcChecker rec_tc TyCon tc [Kind] tc_args | Just (Coercion _, Kind rhs, MCoercion _) <- FamInstEnvs -> TyCon -> [Kind] -> Maybe (Coercion, Kind, MCoercion) topReduceTyFamApp_maybe FamInstEnvs fam_envs TyCon tc [Kind] tc_args = RecTcChecker -> Kind -> TypeShape go RecTcChecker rec_tc Kind rhs | Just DataCon con <- TyCon -> Maybe DataCon tyConSingleAlgDataCon_maybe TyCon tc , Just RecTcChecker rec_tc <- if TyCon -> Bool isTupleTyCon TyCon tc then forall a. a -> Maybe a Just RecTcChecker rec_tc else RecTcChecker -> TyCon -> Maybe RecTcChecker checkRecTc RecTcChecker rec_tc TyCon tc -- We treat tuples specially because they can't cause loops. -- Maybe we should do so in checkRecTc. -- The use of 'dubiousDataConInstArgTys' is OK, since this -- function performs no substitution at all, hence the uniques -- don't matter. = [TypeShape] -> TypeShape TsProd (forall a b. (a -> b) -> [a] -> [b] map (RecTcChecker -> Kind -> TypeShape go RecTcChecker rec_tc) (DataCon -> [Kind] -> [Kind] dubiousDataConInstArgTys DataCon con [Kind] tc_args)) | Just (Kind ty', Coercion _) <- TyCon -> [Kind] -> Maybe (Kind, Coercion) instNewTyCon_maybe TyCon tc [Kind] tc_args , Just RecTcChecker rec_tc <- RecTcChecker -> TyCon -> Maybe RecTcChecker checkRecTc RecTcChecker rec_tc TyCon tc = RecTcChecker -> Kind -> TypeShape go RecTcChecker rec_tc Kind ty' | Bool otherwise = TypeShape TsUnk -- | Exactly 'dataConInstArgTys', but lacks the (ASSERT'ed) precondition that -- the 'DataCon' may not have existentials. The lack of cloning the existentials -- compared to 'dataConInstExAndArgVars' makes this function \"dubious\"; -- only use it where type variables aren't substituted for! dubiousDataConInstArgTys :: DataCon -> [Type] -> [Type] dubiousDataConInstArgTys :: DataCon -> [Kind] -> [Kind] dubiousDataConInstArgTys DataCon dc [Kind] tc_args = [Kind] arg_tys where univ_tvs :: [Id] univ_tvs = DataCon -> [Id] dataConUnivTyVars DataCon dc ex_tvs :: [Id] ex_tvs = DataCon -> [Id] dataConExTyCoVars DataCon dc subst :: TCvSubst subst = TCvSubst -> [Id] -> TCvSubst extendTCvInScopeList (HasDebugCallStack => [Id] -> [Kind] -> TCvSubst zipTvSubst [Id] univ_tvs [Kind] tc_args) [Id] ex_tvs arg_tys :: [Kind] arg_tys = forall a b. (a -> b) -> [a] -> [b] map (HasCallStack => TCvSubst -> Kind -> Kind substTy TCvSubst subst forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. Scaled a -> a scaledThing) (DataCon -> [Scaled Kind] dataConRepArgTys DataCon dc) {- ************************************************************************ * * \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. -} mkWWcpr :: Bool -> FamInstEnvs -> Type -- function body type -> Cpr -- CPR analysis results -> UniqSM (Bool, -- Is w/w'ing useful? CoreExpr -> CoreExpr, -- New wrapper CoreExpr -> CoreExpr, -- New worker Type) -- Type of worker's body mkWWcpr :: Bool -> FamInstEnvs -> Kind -> Cpr -> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind) mkWWcpr Bool opt_CprAnal FamInstEnvs fam_envs Kind body_ty Cpr cpr -- CPR explicitly turned off (or in -O0) | Bool -> Bool not Bool opt_CprAnal = forall (m :: * -> *) a. Monad m => a -> m a return (Bool False, forall a. a -> a id, forall a. a -> a id, Kind body_ty) -- CPR is turned on by default for -O and O2 | Bool otherwise = case Cpr -> Maybe (Int, [Cpr]) asConCpr Cpr cpr of Maybe (Int, [Cpr]) Nothing -> forall (m :: * -> *) a. Monad m => a -> m a return (Bool False, forall a. a -> a id, forall a. a -> a id, Kind body_ty) -- No CPR info Just (Int con_tag, [Cpr] _cprs) | Just DataConPatContext dcpc <- FamInstEnvs -> Int -> Kind -> Maybe DataConPatContext splitResultType_maybe FamInstEnvs fam_envs Int con_tag Kind body_ty -> DataConPatContext -> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind) mkWWcpr_help DataConPatContext dcpc | Bool otherwise -- See Note [non-algebraic or open body type warning] -> WARN( True, text "mkWWcpr: non-algebraic or open body type" <+> ppr body_ty ) forall (m :: * -> *) a. Monad m => a -> m a return (Bool False, forall a. a -> a id, forall a. a -> a id, Kind body_ty) mkWWcpr_help :: DataConPatContext -> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type) mkWWcpr_help :: DataConPatContext -> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Kind) mkWWcpr_help (DataConPatContext { dcpc_dc :: DataConPatContext -> DataCon dcpc_dc = DataCon dc, dcpc_tc_args :: DataConPatContext -> [Kind] dcpc_tc_args = [Kind] tc_args , dcpc_co :: DataConPatContext -> Coercion dcpc_co = Coercion co }) | [Scaled Kind arg_ty] <- DataCon -> [Kind] -> [Scaled Kind] dataConInstArgTys DataCon dc [Kind] tc_args -- NB: No existentials! , [StrictnessMark str_mark] <- DataCon -> [StrictnessMark] dataConRepStrictness DataCon dc , HasDebugCallStack => Kind -> Bool isUnliftedType (forall a. Scaled a -> a scaledThing Scaled Kind arg_ty) , forall a. Scaled a -> Bool isLinear Scaled Kind arg_ty -- Special case when there is a single result of unlifted, linear, type -- -- Wrapper: case (..call worker..) of x -> C x -- Worker: case ( ..body.. ) of C x -> x = do { (Unique work_uniq : Unique arg_uniq : [Unique] _) <- forall (m :: * -> *). MonadUnique m => m [Unique] getUniquesM ; let arg_id :: Id arg_id = Unique -> StrictnessMark -> Scaled Kind -> Id mk_ww_local Unique arg_uniq StrictnessMark str_mark Scaled Kind arg_ty con_app :: CoreExpr con_app = forall b. DataCon -> [Kind] -> [Id] -> Expr b mkConApp2 DataCon dc [Kind] tc_args [Id arg_id] CoreExpr -> Coercion -> CoreExpr `mkCast` Coercion -> Coercion mkSymCo Coercion co ; forall (m :: * -> *) a. Monad m => a -> m a return ( Bool True , \ CoreExpr wkr_call -> CoreExpr -> Id -> CoreExpr -> CoreExpr mkDefaultCase CoreExpr wkr_call Id arg_id CoreExpr con_app , \ CoreExpr body -> CoreExpr -> Coercion -> Kind -> Unique -> DataCon -> [Id] -> CoreExpr -> CoreExpr mkUnpackCase CoreExpr body Coercion co Kind One Unique work_uniq DataCon dc [Id arg_id] (forall b. Id -> Expr b varToCoreExpr Id arg_id) -- varToCoreExpr important here: arg can be a coercion -- Lacking this caused #10658 , forall a. Scaled a -> a scaledThing Scaled Kind arg_ty ) } | Bool otherwise -- The general case -- Wrapper: case (..call worker..) of (# a, b #) -> C a b -- Worker: case ( ...body... ) of C a b -> (# a, b #) -- -- Remark on linearity: in both the case of the wrapper and the worker, -- we build a linear case. All the multiplicity information is kept in -- the constructors (both C and (#, #)). In particular (#,#) is -- parametrised by the multiplicity of its fields. Specifically, in this -- instance, the multiplicity of the fields of (#,#) is chosen to be the -- same as those of C. = do { (Unique work_uniq : Unique wild_uniq : [Unique] pat_bndrs_uniqs) <- forall (m :: * -> *). MonadUnique m => m [Unique] getUniquesM ; let case_mult :: Kind case_mult = Kind One -- see above ([Id] _exs, [Id] arg_ids) = [FastString] -> [Unique] -> Kind -> DataCon -> [Kind] -> ([Id], [Id]) dataConRepFSInstPat (forall a. a -> [a] repeat FastString ww_prefix) [Unique] pat_bndrs_uniqs Kind case_mult DataCon dc [Kind] tc_args wrap_wild :: Id wrap_wild = Unique -> StrictnessMark -> Scaled Kind -> Id mk_ww_local Unique wild_uniq StrictnessMark MarkedStrict (forall a. Kind -> a -> Scaled a Scaled Kind case_mult Kind ubx_tup_ty) ubx_tup_ty :: Kind ubx_tup_ty = CoreExpr -> Kind exprType CoreExpr ubx_tup_app ubx_tup_app :: CoreExpr ubx_tup_app = [Kind] -> [CoreExpr] -> CoreExpr mkCoreUbxTup (forall a b. (a -> b) -> [a] -> [b] map Id -> Kind idType [Id] arg_ids) (forall a b. (a -> b) -> [a] -> [b] map forall b. Id -> Expr b varToCoreExpr [Id] arg_ids) con_app :: CoreExpr con_app = forall b. DataCon -> [Kind] -> [Id] -> Expr b mkConApp2 DataCon dc [Kind] tc_args [Id] arg_ids CoreExpr -> Coercion -> CoreExpr `mkCast` Coercion -> Coercion mkSymCo Coercion co tup_con :: DataCon tup_con = Boxity -> Int -> DataCon tupleDataCon Boxity Unboxed (forall (t :: * -> *) a. Foldable t => t a -> Int length [Id] arg_ids) ; MASSERT( null _exs ) -- Should have been caught by splitResultType_maybe ; forall (m :: * -> *) a. Monad m => a -> m a return (Bool True , \ CoreExpr wkr_call -> CoreExpr -> Id -> AltCon -> [Id] -> CoreExpr -> CoreExpr mkSingleAltCase CoreExpr wkr_call Id wrap_wild (DataCon -> AltCon DataAlt DataCon tup_con) [Id] arg_ids CoreExpr con_app , \ CoreExpr body -> CoreExpr -> Coercion -> Kind -> Unique -> DataCon -> [Id] -> CoreExpr -> CoreExpr mkUnpackCase CoreExpr body Coercion co Kind case_mult Unique work_uniq DataCon dc [Id] arg_ids CoreExpr ubx_tup_app , Kind ubx_tup_ty ) } mkUnpackCase :: CoreExpr -> Coercion -> Mult -> Unique -> DataCon -> [Id] -> CoreExpr -> CoreExpr -- (mkUnpackCase e co uniq Con args body) -- returns -- case e |> co of bndr { Con args -> body } mkUnpackCase :: CoreExpr -> Coercion -> Kind -> Unique -> DataCon -> [Id] -> CoreExpr -> CoreExpr mkUnpackCase (Tick CoreTickish tickish CoreExpr e) Coercion co Kind mult Unique uniq DataCon con [Id] args CoreExpr body -- See Note [Profiling and unpacking] = forall b. CoreTickish -> Expr b -> Expr b Tick CoreTickish tickish (CoreExpr -> Coercion -> Kind -> Unique -> DataCon -> [Id] -> CoreExpr -> CoreExpr mkUnpackCase CoreExpr e Coercion co Kind mult Unique uniq DataCon con [Id] args CoreExpr body) mkUnpackCase CoreExpr scrut Coercion co Kind mult Unique uniq DataCon boxing_con [Id] unpk_args CoreExpr body = CoreExpr -> Id -> AltCon -> [Id] -> CoreExpr -> CoreExpr mkSingleAltCase CoreExpr casted_scrut Id bndr (DataCon -> AltCon DataAlt DataCon boxing_con) [Id] unpk_args CoreExpr body where casted_scrut :: CoreExpr casted_scrut = CoreExpr scrut CoreExpr -> Coercion -> CoreExpr `mkCast` Coercion co bndr :: Id bndr = Unique -> StrictnessMark -> Scaled Kind -> Id mk_ww_local Unique uniq StrictnessMark MarkedStrict (forall a. Kind -> a -> Scaled a Scaled Kind mult (CoreExpr -> Kind exprType CoreExpr casted_scrut)) -- An unpacking case can always be chosen linear, because the variables -- are always passed to a constructor. This limits the {- Note [non-algebraic or open body type warning] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ There are a few cases where the W/W transformation is told that something returns a constructor, but the type at hand doesn't really match this. One real-world example involves unsafeCoerce: foo = IO a foo = unsafeCoerce c_exit foreign import ccall "c_exit" c_exit :: IO () Here CPR will tell you that `foo` returns a () constructor for sure, but trying to create a worker/wrapper for type `a` obviously fails. (This was a real example until ee8e792 in libraries/base.) It does not seem feasible to avoid all such cases already in the analyser (and after all, the analysis is not really wrong), so we simply do nothing here in mkWWcpr. But we still want to emit warning with -DDEBUG, to hopefully catch other cases where something went avoidably wrong. This warning also triggers for the stream fusion library within `text`. We can'easily W/W constructed results like `Stream` because we have no simple way to express existential types in the worker's type signature. Note [Profiling and unpacking] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If the original function looked like f = \ x -> {-# SCC "foo" #-} E then we want the CPR'd worker to look like \ x -> {-# SCC "foo" #-} (case E of I# x -> x) and definitely not \ x -> case ({-# SCC "foo" #-} E) of I# x -> x) This transform doesn't move work or allocation from one cost centre to another. Later [SDM]: presumably this is because we want the simplifier to eliminate the case, and the scc would get in the way? I'm ok with including the case itself in the cost centre, since it is morally part of the function (post transformation) anyway. ************************************************************************ * * \subsection{Utilities} * * ************************************************************************ Note [Absent fillers] ~~~~~~~~~~~~~~~~~~~~~ Consider data T = MkT [Int] [Int] ![Int] -- NB: last field is strict f :: T -> Int# -> blah f ps w = case ps of MkT xs ys zs -> <body mentioning xs> Then f gets a strictness sig of <S(L,A,A)><A>. We make a worker $wf thus: $wf :: [Int] -> blah $wf xs = case ps of MkT xs _ _ -> <body mentioning xs> where ys = absentError "ys :: [Int]" zs = RUBBISH[LiftedRep] @[Int] ps = MkT xs ys zs w = RUBBISH[IntRep] @Int# The absent arguments 'ys', 'zs' and 'w' aren't even passed to the worker. And neither should they! They are never used, their value is irrelevant (hence they are *dead code*) and they are probably discarded after the next run of the Simplifier (when they are in fact *unreachable code*). Yet, we have to come up with "filler" values that we bind the absent arg Ids to. That is exactly what Note [Rubbish values] are for: A convenient way to conjure filler values at any type (and any representation or levity!). Needless to say, there are some wrinkles: 1. In case we have a absent, /lazy/, and /lifted/ arg, we use an error-thunk instead. If absence analysis was wrong (e.g., #11126) and the binding in fact is used, then we get a nice panic message instead of undefined runtime behavior (See Modes of failure from Note [Rubbish values]). Obviously, we can't use an error-thunk if the value is of unlifted rep (like 'Int#' or 'MutVar#'), because we'd immediately evaluate the panic. 2. We also mustn't put an error-thunk (that fills in for an absent value of lifted rep) in a strict field, because #16970 establishes the invariant that strict fields are always evaluated, by (re-)evaluating what is put in a strict field. That's the reason why 'zs' binds a rubbish literal instead of an error-thunk, see #19133. How do we detect when we are about to put an error-thunk in a strict field? Ideally, we'd just look at the 'StrictnessMark' of the DataCon's field, but it's quite nasty to thread the marks though 'mkWWstr' and 'mkWWstr_one'. So we rather look out for a necessary condition for strict fields: Note [Add demands for strict constructors] makes it so that the demand on 'zs' is absent and /strict/: It will get cardinality 'C_10', the empty interval, rather than 'C_00'. Hence the 'isStrictDmd' check: It guarantees we never fill in an error-thunk for an absent strict field. But that also means we emit a rubbish lit for other args that have cardinality 'C_10' (say, the arg to a bottoming function) where we could've used an error-thunk, but that's a small price to pay for simplicity. 3. We can only emit a RubbishLit if the arg's type @arg_ty@ is mono-rep, e.g. of the form @TYPE rep@ where @rep@ is not (and doesn't contain) a variable. Why? Because if we don't know its representation (e.g. size in memory, register class), we don't know what or how much rubbish to emit in codegen. 'typeMonoPrimRep_maybe' returns 'Nothing' in this case and we simply fall back to passing the original parameter to the worker. Note that currently this case should not occur, because binders always have to be representation monomorphic. But in the future, we might allow levity polymorphism, e.g. a polymorphic levity variable in 'BoxedRep'. While (1) and (2) are simply an optimisation in terms of compiler debugging experience, (3) should be irrelevant in most programs, if not all. Historical note: I did try the experiment of using an error thunk for unlifted things too, relying on the simplifier to drop it as dead code. But this is fragile - It fails when profiling is on, which disables various optimisations - It fails when reboxing happens. E.g. data T = MkT Int Int# f p@(MkT a _) = ...g p.... where g is /lazy/ in 'p', but only uses the first component. Then 'f' is /strict/ in 'p', and only uses the first component. So we only pass that component to the worker for 'f', which reconstructs 'p' to pass it to 'g'. Alas we can't say ...f (MkT a (absentError Int# "blah"))... because `MkT` is strict in its Int# argument, so we get an absentError exception when we shouldn't. Very annoying! -} -- | Tries to find a suitable dummy RHS to bind the given absent identifier to. -- -- If @mk_absent_let _ id == Just wrap@, then @wrap e@ will wrap a let binding -- for @id@ with that RHS around @e@. Otherwise, there could no suitable RHS be -- found. mk_absent_let :: DynFlags -> Id -> Demand -> Maybe (CoreExpr -> CoreExpr) mk_absent_let :: DynFlags -> Id -> Demand -> Maybe (CoreExpr -> CoreExpr) mk_absent_let DynFlags dflags Id arg Demand dmd -- The lifted case: Bind 'absentError' for a nice panic message if we are -- wrong (like we were in #11126). See (1) in Note [Absent fillers] | Just [PrimRep LiftedRep] <- Maybe [PrimRep] mb_mono_prim_reps , Bool -> Bool not (Demand -> Bool isStrictDmd Demand dmd) -- See (2) in Note [Absent fillers] = forall a. a -> Maybe a Just (forall b. Bind b -> Expr b -> Expr b Let (forall b. b -> Expr b -> Bind b NonRec Id arg CoreExpr panic_rhs)) -- The default case for mono rep: Bind @RUBBISH[prim_reps] \@arg_ty@ -- See Note [Absent fillers], the main part | Just [PrimRep] prim_reps <- Maybe [PrimRep] mb_mono_prim_reps = forall a. a -> Maybe a Just (Id -> CoreExpr -> CoreExpr -> CoreExpr bindNonRec Id arg (forall b. Expr b -> [Kind] -> Expr b mkTyApps (forall b. Literal -> Expr b Lit ([PrimRep] -> Literal mkLitRubbish [PrimRep] prim_reps)) [Kind arg_ty])) -- Catch all: Either @arg_ty@ wasn't of form @TYPE rep@ or @rep@ wasn't mono rep. -- See (3) in Note [Absent fillers] | Maybe [PrimRep] Nothing <- Maybe [PrimRep] mb_mono_prim_reps = WARN( True, text "No absent value for" <+> ppr arg_ty ) forall a. Maybe a Nothing where arg_ty :: Kind arg_ty = Id -> Kind idType Id arg mb_mono_prim_reps :: Maybe [PrimRep] mb_mono_prim_reps = Kind -> Maybe [PrimRep] typeMonoPrimRep_maybe Kind arg_ty panic_rhs :: CoreExpr panic_rhs = Kind -> String -> CoreExpr mkAbsentErrorApp Kind arg_ty String msg msg :: String msg = DynFlags -> SDoc -> String showSDoc (DynFlags -> GeneralFlag -> DynFlags gopt_set DynFlags dflags GeneralFlag Opt_SuppressUniques) ([SDoc] -> SDoc vcat [ String -> SDoc text String "Arg:" SDoc -> SDoc -> SDoc <+> forall a. Outputable a => a -> SDoc ppr Id arg , String -> SDoc text String "Type:" SDoc -> SDoc -> SDoc <+> forall a. Outputable a => a -> SDoc ppr Kind arg_ty , SDoc file_msg ]) -- We need to suppress uniques here because otherwise they'd -- end up in the generated code as strings. This is bad for -- determinism, because with different uniques the strings -- will have different lengths and hence different costs for -- the inliner leading to different inlining. -- See also Note [Unique Determinism] in GHC.Types.Unique file_msg :: SDoc file_msg = case DynFlags -> Maybe String outputFile DynFlags dflags of Maybe String Nothing -> SDoc empty Just String f -> String -> SDoc text String "In output file " SDoc -> SDoc -> SDoc <+> SDoc -> SDoc quotes (String -> SDoc text String f) ww_prefix :: FastString ww_prefix :: FastString ww_prefix = String -> FastString fsLit String "ww" mk_ww_local :: Unique -> StrictnessMark -> Scaled Type -> Id -- The StrictnessMark comes form the data constructor and says -- whether this field is strict -- See Note [Record evaluated-ness in worker/wrapper] mk_ww_local :: Unique -> StrictnessMark -> Scaled Kind -> Id mk_ww_local Unique uniq StrictnessMark str (Scaled Kind w Kind ty) = StrictnessMark -> Id -> Id setCaseBndrEvald StrictnessMark str forall a b. (a -> b) -> a -> b $ FastString -> Unique -> Kind -> Kind -> Id mkSysLocalOrCoVar FastString ww_prefix Unique uniq Kind w Kind ty