diff options
16 files changed, 239 insertions, 248 deletions
diff --git a/compiler/GHC/Core/Opt/WorkWrap.hs b/compiler/GHC/Core/Opt/WorkWrap.hs index 18b4d848e1..219990d135 100644 --- a/compiler/GHC/Core/Opt/WorkWrap.hs +++ b/compiler/GHC/Core/Opt/WorkWrap.hs @@ -16,7 +16,6 @@ import GHC.Core import GHC.Core.Unfold import GHC.Core.Unfold.Make import GHC.Core.Utils ( exprType, exprIsHNF ) -import GHC.Core.FVs ( exprFreeVars ) import GHC.Core.Type import GHC.Core.Opt.WorkWrap.Utils import GHC.Core.FamInstEnv @@ -210,7 +209,7 @@ unfolding to the *worker*. So we will get something like this: fw d x y' = let y = I# y' in ...f... How do we "transfer the unfolding"? Easy: by using the old one, wrapped -in work_fn! See GHC.Core.Unfold.mkWorkerUnfolding. +in work_fn! See GHC.Core.Unfold.Make.mkWorkerUnfolding. Note [No worker/wrapper for record selectors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -629,7 +628,13 @@ means GHC.Core.Opt.Arity didn't eta expand that binding. When this happens, it d for a reason (see Note [exprArity invariant] in GHC.Core.Opt.Arity) and we probably have a PAP, cast or trivial expression as RHS. -Performing the worker/wrapper split will implicitly eta-expand the binding to +Below is a historical account of what happened when w/w still did eta expansion. +Nowadays, it doesn't do that, but will simply w/w for the wrong arity, unleashing +a demand signature meant for e.g. 2 args to be unleashed for e.g. 1 arg +(manifest arity). That's at least as terrible as doing eta expansion, so don't +do it. +--- +When worker/wrapper did eta expansion, it implictly eta expanded the binding to idArity, overriding GHC.Core.Opt.Arity's decision. Other than playing fast and loose with divergence, it's also broken for newtypes: @@ -684,7 +689,7 @@ splitFun :: WwOpts -> Id -> IdInfo -> CoreExpr -> UniqSM [(Id, CoreExpr)] splitFun ww_opts fn_id fn_info rhs = warnPprTrace (not (wrap_dmds `lengthIs` (arityInfo fn_info))) (ppr fn_id <+> (ppr wrap_dmds $$ ppr cpr)) $ - do { mb_stuff <- mkWwBodies ww_opts rhs_fvs fn_id wrap_dmds use_cpr_info + do { mb_stuff <- mkWwBodies ww_opts fn_id arg_vars (exprType body) wrap_dmds use_cpr_info ; case mb_stuff of Nothing -> -- No useful wrapper; leave the binding alone return [(fn_id, rhs)] @@ -699,11 +704,13 @@ splitFun ww_opts fn_id fn_info rhs | otherwise -> do { work_uniq <- getUniqueM - ; return (mkWWBindPair ww_opts fn_id fn_info rhs + ; return (mkWWBindPair ww_opts fn_id fn_info arg_vars body work_uniq div cpr stuff) } } where uf_opts = so_uf_opts (wo_simple_opts ww_opts) - rhs_fvs = exprFreeVars rhs + (arg_vars, body) = collectBinders rhs + -- collectBinders was not enough for GHC.Event.IntTable.insertWith + -- last time I checked, where manifest lambdas were wrapped in casts (wrap_dmds, div) = splitDmdSig (dmdSigInfo fn_info) @@ -722,10 +729,10 @@ splitFun ww_opts fn_id fn_info rhs mkWWBindPair :: WwOpts -> Id -> IdInfo - -> CoreExpr -> Unique -> Divergence -> Cpr + -> [Var] -> CoreExpr -> Unique -> Divergence -> Cpr -> ([Demand], JoinArity, Id -> CoreExpr, Expr CoreBndr -> CoreExpr) -> [(Id, CoreExpr)] -mkWWBindPair ww_opts fn_id fn_info rhs work_uniq div cpr +mkWWBindPair ww_opts fn_id fn_info fn_args fn_body work_uniq div cpr (work_demands, join_arity, wrap_fn, work_fn) = [(work_id, work_rhs), (wrap_id, wrap_rhs)] -- Worker first, because wrapper mentions it @@ -736,7 +743,7 @@ mkWWBindPair ww_opts fn_id fn_info rhs work_uniq div cpr simpl_opts = wo_simple_opts ww_opts - work_rhs = work_fn rhs + work_rhs = work_fn (mkLams fn_args fn_body) work_act = case fn_inline_spec of -- See Note [Worker activation] NoInline -> inl_act fn_inl_prag _ -> inl_act wrap_prag diff --git a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs index 61de975bf0..8994af8283 100644 --- a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs +++ b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs @@ -22,12 +22,10 @@ import GHC.Driver.Session import GHC.Driver.Config (initSimpleOpts) import GHC.Core -import GHC.Core.Utils ( exprType, mkCast, mkDefaultCase, mkSingleAltCase - , bindNonRec, dataConRepFSInstPat - , normSplitTyConApp_maybe, exprIsHNF ) +import GHC.Core.Utils import GHC.Core.DataCon -import GHC.Core.Make ( mkAbsentErrorApp, mkCoreUbxTup, mkCoreApp, mkCoreLet - , mkWildValBinder, mkLitRubbish ) +import GHC.Core.Make +import GHC.Core.Subst import GHC.Core.Type import GHC.Core.Multiplicity import GHC.Core.Predicate ( isClassPred ) @@ -38,15 +36,13 @@ import GHC.Core.TyCon.RecWalk import GHC.Core.SimpleOpt( SimpleOpts ) import GHC.Types.Id -import GHC.Types.Id.Info ( JoinArity ) +import GHC.Types.Id.Info import GHC.Types.Demand import GHC.Types.Cpr import GHC.Types.Id.Make ( voidArgId, voidPrimId ) -import GHC.Types.Var.Env ( mkInScopeSet ) -import GHC.Types.Var.Set ( VarSet ) -import GHC.Types.Basic ( Boxity(..) ) +import GHC.Types.Var.Env +import GHC.Types.Basic import GHC.Types.Unique.Supply -import GHC.Types.Unique import GHC.Types.Name ( getOccFS ) import GHC.Data.FastString @@ -165,46 +161,87 @@ type WwResult nop_fn :: CoreExpr -> CoreExpr nop_fn body = body + mkWwBodies :: WwOpts - -> VarSet -- Free vars of RHS - -- See Note [Freshen WW arguments] - -> Id -- The original function - -> [Demand] -- Strictness of original function - -> Cpr -- Info about function result + -> Id -- ^ The original function + -> [Var] -- ^ Manifest args of original function + -> Type -- ^ Result type of the original function, + -- after being stripped of args + -> [Demand] -- ^ Strictness of original function + -> Cpr -- ^ Info about function result -> UniqSM (Maybe WwResult) +-- ^ Given a function definition +-- +-- > data T = MkT Int Bool Char +-- > f :: (a, b) -> Int -> T +-- > f = \x y -> E +-- +-- @mkWwBodies _ 'f' ['x::(a,b)','y::Int'] '(a,b)' ['1P(L,L)', '1P(L)'] '1'@ +-- returns +-- +-- * The wrapper body context for the call to the worker function, lacking +-- only the 'Id' for the worker function: +-- +-- > W[_] :: Id -> CoreExpr +-- > W[work_fn] = \x y -> -- args of the wrapper (cloned_arg_vars) +-- > case x of (a, b) -> -- unbox wrapper args (wrap_fn_str) +-- > case y of I# n -> -- +-- > case <work_fn> a b n of -- call to the worker fun (call_work) +-- > (# i, b, c #) -> MkT i b c -- rebox result (wrap_fn_cpr) +-- +-- * The worker body context that wraps around its hole reboxing defns for x +-- and y, as well as returning CPR transit variables of the unboxed MkT +-- result in an unboxed tuple: +-- +-- > w[_] :: CoreExpr -> CoreExpr +-- > w[fn_rhs] = \a b n -> -- args of the worker (work_lam_args) +-- > let { y = I# n; x = (a, b) } in -- reboxing wrapper args (work_fn_str) +-- > case <fn_rhs> x y of -- call to the original RHS (call_rhs) +-- > MkT i b c -> (# i, b, c #) -- return CPR transit vars (work_fn_cpr) +-- +-- NB: The wrap_rhs hole is to be filled with the original wrapper RHS +-- @\x y -> E@. This is so that we can also use @w@ to transform stable +-- unfoldings, the lambda args of which may be different than x and y. +-- +-- * Id details for the worker function like demands on arguments and its join +-- arity. +-- +-- All without looking at E (except for beta reduction, see Note [Join points +-- and beta-redexes]), which allows us to apply the same split to function body +-- and its unfolding(s) alike. +-- +mkWwBodies opts fun_id arg_vars res_ty demands res_cpr + = do { massertPpr (filter isId arg_vars `equalLength` demands) + (text "wrong wrapper arity" $$ ppr fun_id $$ ppr arg_vars $$ ppr res_ty $$ ppr demands) + + -- Clone and prepare arg_vars of the original fun RHS + -- See Note [Freshen WW arguments] + -- and Note [Zap IdInfo on worker args] + ; uniq_supply <- getUniqueSupplyM + ; let args_free_tcvs = tyCoVarsOfTypes (res_ty : map varType arg_vars) + empty_subst = mkEmptySubst (mkInScopeSet args_free_tcvs) + zapped_arg_vars = map zap_var arg_vars + (subst, cloned_arg_vars) = cloneBndrs empty_subst uniq_supply zapped_arg_vars + res_ty' = GHC.Core.Subst.substTy subst res_ty --- 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 opts rhs_fvs fun_id demands cpr_info - = do { let empty_subst = mkEmptyTCvSubst (mkInScopeSet rhs_fvs) - -- See Note [Freshen WW arguments] - - ; (wrap_args, wrap_fn_args, work_fn_args, res_ty) - <- mkWWargs empty_subst fun_ty demands ; (useful1, work_args, wrap_fn_str, work_fn_str) - <- mkWWstr opts inlineable_flag wrap_args + <- mkWWstr opts inlineable_flag cloned_arg_vars -- Do CPR w/w. See Note [Always do CPR w/w] ; (useful2, wrap_fn_cpr, work_fn_cpr, cpr_res_ty) - <- mkWWcpr_entry opts res_ty cpr_info + <- mkWWcpr_entry opts res_ty' res_cpr ; let (work_lam_args, work_call_args) = mkWorkerArgs fun_id (wo_fun_to_thunk opts) work_args cpr_res_ty + call_work work_fn = mkVarApps (Var work_fn) work_call_args + call_rhs fn_rhs = mkVarAppsBeta fn_rhs cloned_arg_vars + -- See Note [Join points and beta-redexes] + wrapper_body = mkLams cloned_arg_vars . wrap_fn_cpr . wrap_fn_str . call_work + worker_body = mkLams work_lam_args . work_fn_str . work_fn_cpr . call_rhs worker_args_dmds = [idDemandInfo v | v <- work_call_args, isId v] - wrapper_body = wrap_fn_args . wrap_fn_cpr . wrap_fn_str . applyToVars work_call_args . Var - worker_body = mkLams work_lam_args. work_fn_str . work_fn_cpr . work_fn_args ; if isWorkerSmallEnough (wo_max_worker_args opts) (length demands) work_args - && not (too_many_args_for_join_point wrap_args) + && not (too_many_args_for_join_point arg_vars) && ((useful1 && not only_one_void_argument) || useful2) then return (Just (worker_args_dmds, length work_call_args, wrapper_body, worker_body)) @@ -218,7 +255,11 @@ mkWwBodies opts rhs_fvs fun_id demands cpr_info -- 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 = idType fun_id + zap_var v | isTyVar v = v + | otherwise = modifyIdInfo zap_info v + zap_info info -- See Note [Zap IdInfo on worker args] + = info `setOccInfo` noOccInfo + mb_join_arity = isJoinId_maybe fun_id inlineable_flag -- See Note [Do not unpack class dictionaries] | isStableUnfolding (realIdUnfolding fun_id) = MaybeArgOfInlineableFun @@ -227,8 +268,8 @@ mkWwBodies opts rhs_fvs fun_id demands cpr_info -- Note [Do not split void functions] only_one_void_argument | [d] <- demands - , Just (_, arg_ty1, _) <- splitFunTy_maybe fun_ty - , isAbsDmd d && isVoidTy arg_ty1 + , [v] <- filter isId arg_vars + , isAbsDmd d && isVoidTy (idType v) = True | otherwise = False @@ -244,6 +285,13 @@ mkWwBodies opts rhs_fvs fun_id demands cpr_info | otherwise = False +-- | Version of 'GHC.Core.mkVarApps' that does beta reduction on-the-fly. +-- PRECONDITION: The arg vars don't shadow each other or any of the free vars of +-- the function expression. +mkVarAppsBeta :: CoreExpr -> [Var] -> CoreExpr +mkVarAppsBeta (Lam b body) (v:vs) = bindNonRec b (varToCoreExpr v) $! mkVarAppsBeta body vs +mkVarAppsBeta f vars = mkVarApps f vars + -- See Note [Limit w/w arity] isWorkerSmallEnough :: Int -> Int -> [Var] -> Bool isWorkerSmallEnough max_worker_args old_n_args vars @@ -293,6 +341,20 @@ out of fuel it would stop w/wing. Still not very clever because it had a left-right bias. +Note [Zap IdInfo on worker args] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We have to zap the following IdInfo when re-using arg variables of the original +function for the worker: + + * OccInfo: Dead wrapper args now occur in Apps of the worker's call to the + original fun body. Those occurrences will quickly cancel away with the lambdas + of the fun body in the next run of the Simplifier, but CoreLint will complain + in the meantime, so zap it. + +We zap in mkWwBodies because we need the zapped variables both when binding them +in mkWWstr (mk_absent_let, specifically) and in mkWorkerArgs, where we produce +the call to the fun body. + ************************************************************************ * * \subsection{Making wrapper args} @@ -419,146 +481,40 @@ 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 subst fun_ty demands - | null demands - = return ([], nop_fn, nop_fn, substTyUnchecked subst fun_ty) - -- I got an ASSERT failure here with `substTy`, and I was - -- disinclined to pursue it since this code is about to be - -- deleted by Sebastian - - | (dmd:demands') <- demands - , Just (mult, arg_ty, fun_ty') <- splitFunTy_maybe fun_ty - = do { uniq <- getUniqueM - ; let arg_ty' = substScaledTy subst (Scaled mult arg_ty) - id = mk_wrap_arg uniq arg_ty' dmd - ; (wrap_args, wrap_fn_args, work_fn_args, res_ty) - <- mkWWargs subst fun_ty' demands' - ; return (id : wrap_args, - Lam id . wrap_fn_args, - apply_or_bind_then work_fn_args (varToCoreExpr id), - res_ty) } - - | Just (tv, fun_ty') <- splitForAllTyCoVar_maybe fun_ty - = do { uniq <- getUniqueM - ; let (subst', tv') = cloneTyVarBndr subst tv uniq - -- See Note [Freshen WW arguments] - ; (wrap_args, wrap_fn_args, work_fn_args, res_ty) - <- mkWWargs subst' fun_ty' demands - ; return (tv' : wrap_args, - Lam tv' . wrap_fn_args, - apply_or_bind_then work_fn_args (mkTyArg (mkTyVarTy tv')), - res_ty) } - - | Just (co, rep_ty) <- topNormaliseNewType_maybe 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 { (wrap_args, wrap_fn_args, work_fn_args, res_ty) - <- mkWWargs subst rep_ty demands - ; let co' = substCo subst co - ; return (wrap_args, - \e -> Cast (wrap_fn_args e) (mkSymCo co'), - \e -> work_fn_args (Cast e co'), - res_ty) } - - | otherwise - = warnPprTrace True (ppr fun_ty) $ -- Should not happen: if there is a demand - return ([], nop_fn, nop_fn, substTy subst fun_ty) -- then there should be a function arrow - where - -- See Note [Join points and beta-redexes] - apply_or_bind_then k arg (Lam bndr body) - = mkCoreLet (NonRec bndr arg) (k body) -- Important that arg is fresh! - apply_or_bind_then k arg fun - = k $ mkCoreApp (text "mkWWargs") fun arg - -applyToVars :: [Var] -> CoreExpr -> CoreExpr -applyToVars vars fn = mkVarApps fn vars - -mk_wrap_arg :: Unique -> Scaled Type -> Demand -> Id -mk_wrap_arg uniq (Scaled w ty) dmd - = mkSysLocalOrCoVar (fsLit "w") uniq w ty - `setIdDemandInfo` 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. +Note [Freshen WW arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we do a worker/wrapper split, we must freshen the arg vars of the original +fun RHS because they might shadow each other. E.g. + + f :: forall a. Maybe a -> forall a. Maybe a -> Int -> Int + f @a x @a y z = case x <|> y of + Nothing -> z + Just _ -> z + 1 + + ==> {WW split unboxing the Int} + + $wf :: forall a. Maybe a -> forall a. Maybe a -> Int# -> Int + $wf @a x @a y wz = (\@a x @a y z -> case x <|> y of ...) ??? x @a y (I# wz) + +(Notice that the code we actually emit will sort-of ANF-ise the lambda args, +leading to even more shadowing issues. The above demonstrates that even if we +try harder we'll still get shadowing issues.) + +What should we put in place for ??? ? Certainly not @a, because that would +reference the wrong, inner a. A similar situation occurred in #12562, we even +saw a type variable in the worker shadowing an outer term-variable binding. + +We avoid the issue by freshening the argument variables from the original fun +RHS through 'cloneBndrs', which will also take care of subsitution in binder +types. Fortunately, it's sufficient to pick the FVs of the arg vars as in-scope +set, so that we don't need to do a FV traversal over the whole body of the +original function. + +At the moment, #12562 has no regression test. As such, this Note is not covered +by any test logic or when bootstrapping the compiler. Yet we clearly want to +freshen the binders, as the example above demonstrates. +Adding a Core pass that maximises shadowing for testing purposes might help, +see #17478. -} {- @@ -1021,8 +977,8 @@ mkAbsentFiller opts arg -- 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] | not (isUnliftedType arg_ty) - , not (isStrictDmd (idDemandInfo arg)) -- See (2) in Note [Absent fillers] - = Just panic_rhs + , not is_strict, not is_evald -- See (2) in Note [Absent fillers] + = Just (mkAbsentErrorApp arg_ty msg) -- The default case for mono rep: Bind `RUBBISH[rr] arg_ty` -- See Note [Absent fillers], the main part @@ -1030,9 +986,9 @@ mkAbsentFiller opts arg = mkLitRubbish arg_ty where - arg_ty = idType arg - - panic_rhs = mkAbsentErrorApp arg_ty msg + arg_ty = idType arg + is_strict = isStrictDmd (idDemandInfo arg) + is_evald = isEvaldUnfolding $ idUnfolding arg msg = renderWithContext (defaultSDocContext { sdocSuppressUniques = True }) @@ -1213,6 +1169,14 @@ Needless to say, there are some wrinkles: 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. + In #19766, we discovered that even if the binder has eval cardinality + 'C_00', it may end up in a strict field, with no surrounding seq + whatsoever! That happens if the calling code has already evaluated + said lambda binder, which will then have an evaluated unfolding + ('isEvaldUnfolding'). That in turn tells the Simplifier it is free to drop + the seq. So we better don't fill in an error-thunk for eval'd arguments + either, just in case it ends up in a strict field! + 3. We can only emit a LitRubbish 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, @@ -1307,7 +1271,7 @@ dubiousDataConInstArgTys dc tc_args = arg_tys univ_tvs = dataConUnivTyVars dc ex_tvs = dataConExTyCoVars dc subst = extendTCvInScopeList (zipTvSubst univ_tvs tc_args) ex_tvs - arg_tys = map (substTy subst . scaledThing) (dataConRepArgTys dc) + arg_tys = map (GHC.Core.Type.substTy subst . scaledThing) (dataConRepArgTys dc) {- ************************************************************************ diff --git a/testsuite/tests/simplCore/should_compile/T13143.stderr b/testsuite/tests/simplCore/should_compile/T13143.stderr index 87fbdd6213..c4c2db7462 100644 --- a/testsuite/tests/simplCore/should_compile/T13143.stderr +++ b/testsuite/tests/simplCore/should_compile/T13143.stderr @@ -70,15 +70,15 @@ T13143.$wg [InlPrag=[2], Occ=LoopBreaker] :: Bool -> Bool -> GHC.Prim.Int# -> GHC.Prim.Int# [GblId, Arity=3, Str=<1L><1L><L>, Unf=OtherCon []] T13143.$wg - = \ (w :: Bool) (w1 :: Bool) (ww :: GHC.Prim.Int#) -> - case w of { + = \ (ds :: Bool) (ds1 :: Bool) (ww :: GHC.Prim.Int#) -> + case ds of { False -> - case w1 of { + case ds1 of { False -> T13143.$wg GHC.Types.False GHC.Types.True ww; True -> GHC.Prim.+# ww 1# }; True -> - case w1 of { + case ds1 of { False -> T13143.$wg GHC.Types.True GHC.Types.True ww; True -> case lvl of wild2 { } } @@ -94,17 +94,17 @@ g [InlPrag=[2]] :: Bool -> Bool -> Int -> Int Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=3,unsat_ok=True,boring_ok=False) - Tmpl= \ (w [Occ=Once1] :: Bool) - (w1 [Occ=Once1] :: Bool) - (w2 [Occ=Once1!] :: Int) -> - case w2 of { GHC.Types.I# ww [Occ=Once1] -> - case T13143.$wg w w1 ww of ww1 [Occ=Once1] { __DEFAULT -> + Tmpl= \ (ds [Occ=Once1] :: Bool) + (ds1 [Occ=Once1] :: Bool) + (p [Occ=Once1!] :: Int) -> + case p of { GHC.Types.I# ww [Occ=Once1] -> + case T13143.$wg ds ds1 ww of ww1 [Occ=Once1] { __DEFAULT -> GHC.Types.I# ww1 } }}] -g = \ (w :: Bool) (w1 :: Bool) (w2 :: Int) -> - case w2 of { GHC.Types.I# ww -> - case T13143.$wg w w1 ww of ww1 { __DEFAULT -> GHC.Types.I# ww1 } +g = \ (ds :: Bool) (ds1 :: Bool) (p :: Int) -> + case p of { GHC.Types.I# ww -> + case T13143.$wg ds ds1 ww of ww1 { __DEFAULT -> GHC.Types.I# ww1 } } diff --git a/testsuite/tests/simplCore/should_compile/T15631.stdout b/testsuite/tests/simplCore/should_compile/T15631.stdout index e9e6a2bcab..ab181b58ed 100644 --- a/testsuite/tests/simplCore/should_compile/T15631.stdout +++ b/testsuite/tests/simplCore/should_compile/T15631.stdout @@ -1,7 +1,7 @@ case GHC.List.$wlenAcc - case GHC.List.$wlenAcc @a w 0# of ww1 { __DEFAULT -> - case GHC.List.reverse1 @a w (GHC.Types.[] @a) of { + case GHC.List.$wlenAcc @a xs 0# of ww1 { __DEFAULT -> + case GHC.List.reverse1 @a xs (GHC.Types.[] @a) of { [] -> case Foo.f1 @a of { GHC.Types.I# v1 -> GHC.Prim.+# ww1 v1 }; case GHC.List.$wlenAcc - case Foo.$wf @a w of ww [Occ=Once1] { __DEFAULT -> - case Foo.$wf @a w of ww { __DEFAULT -> GHC.Types.I# ww } + case Foo.$wf @a xs of ww [Occ=Once1] { __DEFAULT -> + case Foo.$wf @a xs of ww { __DEFAULT -> GHC.Types.I# ww } diff --git a/testsuite/tests/simplCore/should_compile/T18013.stderr b/testsuite/tests/simplCore/should_compile/T18013.stderr index 45f9900830..5c82b03c93 100644 --- a/testsuite/tests/simplCore/should_compile/T18013.stderr +++ b/testsuite/tests/simplCore/should_compile/T18013.stderr @@ -140,8 +140,8 @@ mapMaybeRule [InlPrag=[2]] Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) - Tmpl= \ (@a) (@b) (w [Occ=Once1!] :: Rule IO a b) -> - case w of { Rule @s ww ww1 [Occ=OnceL1!] -> + Tmpl= \ (@a) (@b) (f [Occ=Once1!] :: Rule IO a b) -> + case f of { Rule @s ww ww1 [Occ=OnceL1!] -> T18013a.Rule @IO @(Maybe a) @@ -176,8 +176,8 @@ mapMaybeRule [InlPrag=[2]] ~R# (s -> Maybe a -> IO (Result s (Maybe b)))) }}] mapMaybeRule - = \ (@a) (@b) (w :: Rule IO a b) -> - case w of { Rule @s ww ww1 -> + = \ (@a) (@b) (f :: Rule IO a b) -> + case f of { Rule @s ww ww1 -> let { lvl :: Result s (Maybe b) [LclId, Unf=OtherCon []] diff --git a/testsuite/tests/simplCore/should_compile/T19246.stderr b/testsuite/tests/simplCore/should_compile/T19246.stderr index 0c7894e56d..acfe1500b8 100644 --- a/testsuite/tests/simplCore/should_compile/T19246.stderr +++ b/testsuite/tests/simplCore/should_compile/T19246.stderr @@ -6,6 +6,6 @@ ==================== Tidy Core rules ==================== "SPEC f" [2] forall ($dOrd :: Ord Int). f @Int $dOrd = $sf "SPEC/T19246 $wf @Int" [2] - forall (w :: Ord Int). $wf @Int w = $s$wf + forall ($dOrd :: Ord Int). $wf @Int $dOrd = $s$wf diff --git a/testsuite/tests/simplCore/should_compile/T3717.stderr b/testsuite/tests/simplCore/should_compile/T3717.stderr index 6e8fe19294..bd6417b729 100644 --- a/testsuite/tests/simplCore/should_compile/T3717.stderr +++ b/testsuite/tests/simplCore/should_compile/T3717.stderr @@ -61,15 +61,15 @@ foo [InlPrag=[2]] :: Int -> Int Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) - Tmpl= \ (w [Occ=Once1!] :: Int) -> - case w of { GHC.Types.I# ww [Occ=Once1] -> + Tmpl= \ (ds [Occ=Once1!] :: Int) -> + case ds of { GHC.Types.I# ww [Occ=Once1] -> case T3717.$wfoo ww of ww1 [Occ=Once1] { __DEFAULT -> GHC.Types.I# ww1 } }}] foo - = \ (w :: Int) -> - case w of { GHC.Types.I# ww -> + = \ (ds :: Int) -> + case ds of { GHC.Types.I# ww -> case T3717.$wfoo ww of ww1 { __DEFAULT -> GHC.Types.I# ww1 } } diff --git a/testsuite/tests/simplCore/should_compile/T3772.stdout b/testsuite/tests/simplCore/should_compile/T3772.stdout index 5ead45f9c3..abf4b8db14 100644 --- a/testsuite/tests/simplCore/should_compile/T3772.stdout +++ b/testsuite/tests/simplCore/should_compile/T3772.stdout @@ -69,10 +69,10 @@ foo [InlPrag=[final]] :: Int -> () Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) - Tmpl= \ (w [Occ=Once1!] :: Int) -> - case w of { GHC.Types.I# ww [Occ=Once1] -> T3772.$wfoo ww }}] + Tmpl= \ (n [Occ=Once1!] :: Int) -> + case n of { GHC.Types.I# ww [Occ=Once1] -> T3772.$wfoo ww }}] foo - = \ (w :: Int) -> case w of { GHC.Types.I# ww -> T3772.$wfoo ww } + = \ (n :: Int) -> case n of { GHC.Types.I# ww -> T3772.$wfoo ww } diff --git a/testsuite/tests/simplCore/should_compile/T4908.stderr b/testsuite/tests/simplCore/should_compile/T4908.stderr index f8f9107485..afea396826 100644 --- a/testsuite/tests/simplCore/should_compile/T4908.stderr +++ b/testsuite/tests/simplCore/should_compile/T4908.stderr @@ -63,10 +63,10 @@ T4908.$wf [InlPrag=[2]] :: Int# -> (Int, Int) -> Bool Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [30 20] 101 20}] T4908.$wf - = \ (ww :: Int#) (w :: (Int, Int)) -> + = \ (ww :: Int#) (x :: (Int, Int)) -> case ww of ds { __DEFAULT -> - case w of { (a, b) -> + case x of { (a, b) -> case b of { I# ds1 -> case ds1 of ds2 { __DEFAULT -> T4908.f_$s$wf a ds2 (-# ds 1#); @@ -85,10 +85,10 @@ f [InlPrag=[2]] :: Int -> (Int, Int) -> Bool Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False) - Tmpl= \ (w [Occ=Once1!] :: Int) (w1 [Occ=Once1] :: (Int, Int)) -> - case w of { I# ww [Occ=Once1] -> T4908.$wf ww w1 }}] -f = \ (w :: Int) (w1 :: (Int, Int)) -> - case w of { I# ww -> T4908.$wf ww w1 } + Tmpl= \ (ds [Occ=Once1!] :: Int) (x [Occ=Once1] :: (Int, Int)) -> + case ds of { I# ww [Occ=Once1] -> T4908.$wf ww x }}] +f = \ (ds :: Int) (x :: (Int, Int)) -> + case ds of { I# ww -> T4908.$wf ww x } ------ Local rules for imported ids -------- diff --git a/testsuite/tests/simplCore/should_compile/T4930.stderr b/testsuite/tests/simplCore/should_compile/T4930.stderr index 3321809415..9da0009f84 100644 --- a/testsuite/tests/simplCore/should_compile/T4930.stderr +++ b/testsuite/tests/simplCore/should_compile/T4930.stderr @@ -61,15 +61,15 @@ foo [InlPrag=[2]] :: Int -> Int Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) - Tmpl= \ (w [Occ=Once1!] :: Int) -> - case w of { GHC.Types.I# ww [Occ=Once1] -> + Tmpl= \ (n [Occ=Once1!] :: Int) -> + case n of { GHC.Types.I# ww [Occ=Once1] -> case T4930.$wfoo ww of ww1 [Occ=Once1] { __DEFAULT -> GHC.Types.I# ww1 } }}] foo - = \ (w :: Int) -> - case w of { GHC.Types.I# ww -> + = \ (n :: Int) -> + case n of { GHC.Types.I# ww -> case T4930.$wfoo ww of ww1 { __DEFAULT -> GHC.Types.I# ww1 } } diff --git a/testsuite/tests/simplCore/should_compile/T5298.stdout b/testsuite/tests/simplCore/should_compile/T5298.stdout index 67b106c3be..661e893028 100644 --- a/testsuite/tests/simplCore/should_compile/T5298.stdout +++ b/testsuite/tests/simplCore/should_compile/T5298.stdout @@ -6,8 +6,8 @@ $wg 0# -> 1# } -- -g = \ w -> - case w of { I# ww -> case $wg ww of ww1 { __DEFAULT -> I# ww1 } } +g = \ ds -> + case ds of { I# ww -> case $wg ww of ww1 { __DEFAULT -> I# ww1 } } ------ Local rules for imported ids -------- diff --git a/testsuite/tests/simplCore/should_compile/T8331.stderr b/testsuite/tests/simplCore/should_compile/T8331.stderr index e84edead21..7219016651 100644 --- a/testsuite/tests/simplCore/should_compile/T8331.stderr +++ b/testsuite/tests/simplCore/should_compile/T8331.stderr @@ -16,7 +16,7 @@ ReaderT r (ST s) a -> ReaderT r (ST s) b -> ReaderT r (ST s) b)) "SPEC $c>> @(ST s) _" forall (@s) (@r) ($dMonad :: Monad (ST s)). - $fMonadReaderT_$c>> @(ST s) @r $dMonad + $fMonadReaderT1 @(ST s) @r $dMonad = $fMonadAbstractIOSTReaderT_$s$c>> @s @r "SPEC $cliftA2 @(ST s) _" forall (@s) (@r) ($dApplicative :: Applicative (ST s)). diff --git a/testsuite/tests/simplCore/should_compile/spec-inline.stderr b/testsuite/tests/simplCore/should_compile/spec-inline.stderr index 319eba03cb..2ba178e6bf 100644 --- a/testsuite/tests/simplCore/should_compile/spec-inline.stderr +++ b/testsuite/tests/simplCore/should_compile/spec-inline.stderr @@ -80,12 +80,12 @@ Roman.$wgo [InlPrag=[2]] :: Maybe Int -> Maybe Int -> GHC.Prim.Int# Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [61 30] 249 0}] Roman.$wgo - = \ (w :: Maybe Int) (w1 :: Maybe Int) -> - case w1 of { + = \ (u :: Maybe Int) (ds :: Maybe Int) -> + case ds of { Nothing -> case Roman.foo3 of wild1 { }; Just x -> case x of { GHC.Types.I# ipv -> - case w of { + case u of { Nothing -> Roman.foo_$s$wgo (GHC.Prim.*# 7# ipv) 10#; Just n -> case n of { GHC.Types.I# x2 -> @@ -116,14 +116,14 @@ Roman.foo_go [InlPrag=[2]] :: Maybe Int -> Maybe Int -> Int Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False) - Tmpl= \ (w [Occ=Once1] :: Maybe Int) - (w1 [Occ=Once1] :: Maybe Int) -> - case Roman.$wgo w w1 of ww [Occ=Once1] { __DEFAULT -> + Tmpl= \ (u [Occ=Once1] :: Maybe Int) + (ds [Occ=Once1] :: Maybe Int) -> + case Roman.$wgo u ds of ww [Occ=Once1] { __DEFAULT -> GHC.Types.I# ww }}] Roman.foo_go - = \ (w :: Maybe Int) (w1 :: Maybe Int) -> - case Roman.$wgo w w1 of ww { __DEFAULT -> GHC.Types.I# ww } + = \ (u :: Maybe Int) (ds :: Maybe Int) -> + case Roman.$wgo u ds of ww { __DEFAULT -> GHC.Types.I# ww } -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} Roman.foo2 :: Int diff --git a/testsuite/tests/stranal/should_compile/T16029.stdout b/testsuite/tests/stranal/should_compile/T16029.stdout index 2d1f2106f3..76bf2617fb 100644 --- a/testsuite/tests/stranal/should_compile/T16029.stdout +++ b/testsuite/tests/stranal/should_compile/T16029.stdout @@ -4,8 +4,8 @@ :: GHC.Prim.Int# -> GHC.Prim.Int# = \ (ww :: GHC.Prim.Int#) -> g2 [InlPrag=[2]] :: T -> Int -> Int - Tmpl= \ (w [Occ=Once1!] :: T) (w1 [Occ=Once1!] :: Int) -> - = \ (w :: T) (w1 :: Int) -> + Tmpl= \ (ds [Occ=Once1!] :: T) (ds1 [Occ=Once1!] :: Int) -> + = \ (ds :: T) (ds1 :: Int) -> g1 [InlPrag=[2]] :: S -> Int -> Int - Tmpl= \ (w [Occ=Once1!] :: S) (w1 [Occ=Once1!] :: Int) -> - = \ (w :: S) (w1 :: Int) -> + Tmpl= \ (ds [Occ=Once1!] :: S) (ds1 [Occ=Once1!] :: Int) -> + = \ (ds :: S) (ds1 :: Int) -> diff --git a/testsuite/tests/stranal/should_compile/T19766.hs b/testsuite/tests/stranal/should_compile/T19766.hs new file mode 100644 index 0000000000..1062c57cc1 --- /dev/null +++ b/testsuite/tests/stranal/should_compile/T19766.hs @@ -0,0 +1,19 @@ +{-# OPTIONS_GHC -O #-} + +module T19766 where + +data T a b = T !a !b + +data HasT = A (T Int Int) | B (T Int Int) + +getT :: HasT -> T Int Int +getT (A t) = t +getT (B t) = t + +f :: HasT -> [Int] +f ht = case getT ht of t@(T _ _) -> reverse $ reverse $ reverse $ reverse $ reverse $ reverse $ lookupGRE t 15 [1,2,3,4] +{-# NOINLINE f #-} + +lookupGRE :: T Int a -> Int -> [Int] -> [Int] +lookupGRE ~(T n _) !k xs = [ x | x <- xs, x+k == n ] +{-# NOINLINE lookupGRE #-} diff --git a/testsuite/tests/stranal/should_compile/all.T b/testsuite/tests/stranal/should_compile/all.T index f5ebbf289a..9a210ea165 100644 --- a/testsuite/tests/stranal/should_compile/all.T +++ b/testsuite/tests/stranal/should_compile/all.T @@ -66,6 +66,7 @@ test('T18894b', [ grep_errmsg(r'Arity=2') ], compile, ['-ddump-stranal -dsuppre test('T18982', [ grep_errmsg(r'\$w. .*Int#$') ], compile, ['-dppr-cols=1000 -ddump-simpl -dsuppress-idinfo -dsuppress-uniques']) test('T19180', normal, compile, ['']) +test('T19766', [ grep_errmsg(r'absentError') ], compile, ['-ddump-worker-wrapper']) test('T19849', normal, compile, ['']) test('T19882a', normal, compile, ['']) test('T19882b', normal, compile, ['']) |