[Git][ghc/ghc][wip/T26989] 2 commits: Update stderr tests

Simon Peyton Jones pushed to branch wip/T26989 at Glasgow Haskell Compiler / GHC Commits: d2ad273a by Simon Peyton Jones at 2026-04-26T17:50:21+01:00 Update stderr tests ...mainly as a result of printing names for dead lambda binders (A debug-output change only.) - - - - - 9e642e00 by Simon Peyton Jones at 2026-04-27T00:11:49+01:00 Add MOutCoercion to ApplyToVal Nicer... but lets see what CI says - - - - - 25 changed files: - compiler/GHC/Core/Opt/Simplify/Env.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - testsuite/tests/codeGen/should_compile/T25177.stderr - testsuite/tests/deSugar/should_compile/T13208.stdout - testsuite/tests/numeric/should_compile/T15547.stderr - testsuite/tests/numeric/should_compile/T20347.stderr - testsuite/tests/numeric/should_compile/T20374.stderr - testsuite/tests/numeric/should_compile/T20376.stderr - testsuite/tests/printer/T18052a.stderr - testsuite/tests/simplCore/should_compile/DsSpecPragmas.stderr - testsuite/tests/simplCore/should_compile/RewriteHigherOrderPatterns.stderr - testsuite/tests/simplCore/should_compile/T18668.stderr - testsuite/tests/simplCore/should_compile/T19246.stderr - testsuite/tests/simplCore/should_compile/T19599.stderr - testsuite/tests/simplCore/should_compile/T19599a.stderr - testsuite/tests/simplCore/should_compile/T21917.stderr - testsuite/tests/simplCore/should_compile/T23074.stderr - testsuite/tests/simplCore/should_compile/T25160.stderr - testsuite/tests/simplCore/should_compile/T25718c.stderr-ws-64 - testsuite/tests/simplCore/should_compile/T26051.stderr - testsuite/tests/simplCore/should_compile/T26116.stderr - testsuite/tests/simplCore/should_compile/T8331.stderr - testsuite/tests/simplCore/should_compile/T8848a.stderr - testsuite/tests/typecheck/should_compile/T13032.stderr Changes: ===================================== compiler/GHC/Core/Opt/Simplify/Env.hs ===================================== @@ -28,7 +28,7 @@ module GHC.Core.Opt.Simplify.Env ( SimplEnvIS, checkSimplEnvIS, pprBadSimplEnvIS, -- * Substitution results - SimplSR(..), mkContEx, substId, lookupRecBndr, + SimplSR(..), substId, lookupRecBndr, -- * Simplifying 'Id' binders simplNonRecBndr, simplNonRecJoinBndr, simplRecBndrs, simplRecJoinBndrs, @@ -488,12 +488,11 @@ data SimplSR -- and v is a join-point of arity a -- <=> x is a join-point of arity a - | ContEx TvSubstEnv -- A suspended substitution - CvSubstEnv - SimplIdSubst + | ContEx SimplEnv InExpr - -- If x :-> ContEx tv cv id e is in the SimplISubst - -- then replace occurrences of x by (subst (tv,cv,id) e) + MOutCoercion + -- If x :-> ContEx static_env e mco is in the SimplISubst + -- then replace occurrences of x by (subst (tv,cv,id) e) |> mco instance Outputable SimplSR where ppr (DoneId v) = text "DoneId" <+> ppr v @@ -503,8 +502,8 @@ instance Outputable SimplSR where NotJoinPoint -> empty JoinPoint n -> parens (int n) - ppr (ContEx _tv _cv _id e) = vcat [text "ContEx" <+> ppr e {-, - ppr (filter_env tv), ppr (filter_env id) -}] + ppr (ContEx _env e _mco) = text "ContEx" <+> ppr e + -- ppr (filter_env tv), ppr (filter_env id) -- where -- fvs = exprFreeVars e -- filter_env env = filterVarEnv_Directly keep env @@ -736,9 +735,6 @@ zapSubstEnv env@(SimplEnv { seInlineDepth = n }) setSubstEnv :: SimplEnv -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> SimplEnv setSubstEnv env tvs cvs ids = env { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids } -mkContEx :: SimplEnv -> InExpr -> SimplSR -mkContEx (SimplEnv { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }) e = ContEx tvs cvs ids e - {- ************************************************************************ * * @@ -1368,17 +1364,15 @@ getTCvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv getFullSubst :: InScopeSet -> SimplEnv -> Subst getFullSubst in_scope (SimplEnv { seIdSubst = id_env, seTvSubst = tv_env, seCvSubst = cv_env }) - = mk_full_subst in_scope tv_env cv_env id_env - -mk_full_subst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> Subst -mk_full_subst in_scope tv_env cv_env id_env = mkSubst in_scope (mapVarEnv to_expr id_env) tv_env cv_env where to_expr :: SimplSR -> CoreExpr -- A tiresome impedence-matcher - to_expr (DoneEx e _) = e - to_expr (DoneId v) = Var v - to_expr (ContEx tvs cvs ids e) = GHC.Core.Subst.substExprSC (mk_full_subst in_scope tvs cvs ids) e + to_expr (DoneEx e _) = e + to_expr (DoneId v) = Var v + to_expr (ContEx env e mco) = mkCastMCo e' mco + where + e' = GHC.Core.Subst.substExprSC (getFullSubst in_scope env) e substTy :: HasDebugCallStack => SimplEnv -> Type -> Type substTy env ty = Type.substTy (getTCvSubst env) ty ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -283,7 +283,7 @@ simplRecOrTopPair :: SimplEnv simplRecOrTopPair env bind_cxt old_bndr new_bndr rhs | Just env' <- preInlineUnconditionally env (bindContextLevel bind_cxt) - old_bndr rhs (UnSimplified env) + old_bndr (UnSimplified env) rhs MRefl = {-#SCC "simplRecOrTopPair-pre-inline-uncond" #-} simplTrace "SimplBindr:inline-uncond1" (ppr old_bndr) $ do { tick (PreInlineUnconditionally old_bndr) @@ -1263,7 +1263,7 @@ simplExprF1 env (App fun arg) cont simplExprF env fun $ ApplyToVal { sc_arg = arg, sc_env = UnSimplified env , sc_hole_ty = substTy env (exprType fun) - , sc_cont = cont } + , sc_cast = MRefl, sc_cont = cont } simplExprF1 env expr@(Lam {}) cont = {-#SCC "simplExprF1-Lam" #-} @@ -1298,7 +1298,7 @@ simplExprF1 env (Let (NonRec bndr rhs) body) cont do { ty' <- simplType env ty ; simplExprF (extendTvSubst env bndr ty') body cont } - | Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs (UnSimplified env) + | Just env' <- preInlineUnconditionally env NotTopLevel bndr (UnSimplified env) rhs MRefl -- Because of the let-can-float invariant, it's ok to -- inline freely, or to drop the binding if it is dead. = do { simplTrace "SimplBindr:inline-uncond2" (ppr bndr) $ @@ -1606,10 +1606,10 @@ rebuild_go env expr cont ApplyToTy { sc_arg_ty = ty, sc_cont = cont} -> rebuild_go env (App expr (Type ty)) cont - ApplyToVal { sc_arg = arg, sc_env = se + ApplyToVal { sc_arg = arg, sc_env = arg_se, sc_cast = arg_mco , sc_cont = cont, sc_hole_ty = fun_ty } -- See Note [Avoid redundant simplification] - -> do { (_, arg') <- simplArg env fun_ty Nothing se arg + -> do { arg' <- simplArg env Nothing fun_ty arg_se arg arg_mco ; rebuild_go env (App expr arg') cont } completeBindX :: SimplEnv @@ -1728,6 +1728,11 @@ optOutCoercion env co already_optimised empty_subst = mkEmptySubst (seInScope env) opts = seOptCoercionOpts env +addCastMCo :: MOutCoercion -> SimplCont -> SimplCont +-- Simpler version of `pushCast` when optionally want to add a cast to the top +addCastMCo MRefl cont = cont +addCastMCo (MCo co) cont = CastIt { sc_co = co, sc_opt = False, sc_cont = cont } + pushCast :: SimplEnv -> OutCoercion -> SimplCont -> SimplM SimplCont pushCast env co cont = go co True cont @@ -1753,8 +1758,7 @@ pushCast env co cont -- co1 :: t1 ~ s1 -- co2 :: s2 ~ t2 go co co_is_opt cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se - , sc_cont = tail - , sc_hole_ty = fun_ty }) + , sc_cast = arg_mco, sc_cont = tail }) | not co_is_opt = -- pushCoValArg duplicates the coercion, so optimise first go (optOutCoercion (zapSubstEnv env) co co_is_opt) True cont @@ -1762,22 +1766,11 @@ pushCast env co cont | Just (m_co1, m_co2) <- pushCoValArg co = {-#SCC "addCoerce-pushCoValArg" #-} do { tail' <- go_mco m_co2 co_is_opt tail - ; case m_co1 of { - MRefl -> return (cont { sc_cont = tail' - , sc_hole_ty = coercionLKind co }) ; - -- See Note [Avoiding simplifying repeatedly] - - MCo co1 -> - do { (arg_se', arg') <- simplArg env fun_ty Nothing arg_se arg - -- When we build the ApplyTo we can't mix the OutCoercion - -- 'co' with the InExpr 'arg', so we simplify - -- to make it all consistent. It's a bit messy. - -- But it isn't a common case. - -- Example of use: #995 - ; return (ApplyToVal { sc_arg = mkCast arg' co1 - , sc_env = arg_se' + ; return (ApplyToVal { sc_arg = arg + , sc_env = arg_se + , sc_cast = m_co1 `mkTransMCo` arg_mco , sc_cont = tail' - , sc_hole_ty = coercionLKind co }) } } } + , sc_hole_ty = coercionLKind co }) } go co co_is_opt cont | isReflCo co = return cont -- Having this at the end makes a huge @@ -1793,25 +1786,24 @@ pushCast env co cont go_mco (MCo co) opt cont = go co opt cont simplArg :: SimplEnvIS -- ^ Used only for its InScopeSet - -> OutType -- ^ Type of the function applied to this arg -> Maybe ArgInfo -- ^ Just <=> This arg `ai` occurs in an app -- `f a1 ... an` where we have ArgInfo on -- how `f` uses `ai`, affecting the Stop -- continuation passed to 'simplExprC' + -> OutType -- ^ Type of the function applied to this arg -> StaticEnv -> CoreExpr -- ^ Expression with its static envt - -> SimplM (StaticEnv, OutExpr) -simplArg _ _ _ se@(Simplified {}) arg - = return (se, arg) -simplArg env fun_ty mb_arg_info (UnSimplified arg_se) arg + -> MOutCoercion -- Wrap this around the result + -> SimplM OutExpr +simplArg _ _ _ (Simplified {}) arg mco + = return (mkCastMCo arg mco) +simplArg env mb_arg_info fun_ty (UnSimplified arg_se) arg mco = do { let arg_env' = arg_se `setInScopeFromE` env arg_ty = funArgTy fun_ty stop = case mb_arg_info of - Nothing -> mkBoringStop arg_ty - Just ai -> mkLazyArgStop arg_ty ai - ; arg' <- simplExprC arg_env' arg stop - ; return (Simplified NoDup, arg') } - -- Return a StaticEnv that includes the in-scope set from 'env', - -- because arg' may well mention those variables (#20639) + Nothing -> mkBoringStop arg_ty + Just ai -> mkLazyArgStop arg_ty ai + cont = addCastMCo mco stop + ; simplExprC arg_env' arg cont } {- ************************************************************************ @@ -1844,54 +1836,67 @@ simpl_lam env bndr body (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont }) = do { tick (BetaReduction bndr) ; simplLam (extendTvSubst env bndr arg_ty) body cont } +{- Next case handles this -- Coercion beta-reduction simpl_lam env bndr body (ApplyToVal { sc_arg = Coercion arg_co, sc_env = arg_se - , sc_cont = cont }) + , sc_cast = arg_mco, sc_cont = cont }) + | let arg_co' = case arg_se of + Simplified {} -> arg_co + UnSimplified arg_se -> substCo (arg_se `setInScopeFromE` env) arg_co + , Just final_arg_co <- case mco of -- C.f. GHC.Core.Utils.mkCast + MRefl -> Just arg_co' + MCo co' | isEqPred (coercionRKind co') + -> Just (mkCoCast arg_co' co') + | otherwise + -> Nothing = assertPpr (isCoVar bndr) (ppr bndr) $ do { tick (BetaReduction bndr) - ; let arg_co' = case arg_se of - Simplified {} -> arg_co - UnSimplified arg_se -> substCo (arg_se `setInScopeFromE` env) arg_co ; simplLam (extendCvSubst env bndr arg_co') body cont } +-} -- Value beta-reduction -- This works for /coercion/ lambdas too simpl_lam env bndr body (ApplyToVal { sc_arg = arg, sc_env = arg_se - , sc_cont = cont + , sc_cast = arg_mco, sc_cont = cont , sc_hole_ty = fun_ty}) - = do { tick (BetaReduction bndr) - ; let from_what = FromBeta arg_levity - arg_levity - | isForAllTy fun_ty = assertPpr (isCoVar bndr) (ppr bndr) Unlifted - | otherwise = typeLevity (funArgTy fun_ty) - -- Example: (\(cv::a ~# b). blah) co - -- The type of (\cv.blah) can be (forall cv. ty); see GHC.Core.Utils.mkLamType - - -- Using fun_ty: see Note [Dark corner with representation polymorphism] - -- e.g (\r \(a::TYPE r) \(x::a). blah) @LiftedRep @Int arg - -- When we come to `x=arg` we must choose lazy/strict correctly - -- It's wrong to err in either direction - -- But fun_ty is an OutType, so is fully substituted - - ; if | Just env' <- preInlineUnconditionally env NotTopLevel bndr arg arg_se - , not (needsCaseBindingL arg_levity arg) + | Just env' <- preInlineUnconditionally env NotTopLevel bndr arg_se arg arg_mco + , not (needsCaseBindingL arg_levity arg) -- Ok to test arg::InExpr in needsCaseBinding because -- exprOkForSpeculation is stable under simplification - -> do { simplTrace "SimplBindr:inline-uncond3" (ppr bndr <+> text ":=" <+> ppr arg $$ ppr (seIdSubst env)) $ - tick (PreInlineUnconditionally bndr) - ; simplLam env' body cont } - - | otherwise - -> case arg_se of - Simplified {} - -- Don't re-simplify if we've simplified it once - -- Including don't preInlineUnconditionally - -- See Note [Avoiding simplifying repeatedly] - -> completeBindX env from_what bndr arg body cont - - UnSimplified arg_env - -> simplNonRecE env from_what bndr (arg, arg_env) body cont + = simplTrace "SimplBindr:inline-uncond3" + (vcat [ ppr bndr <+> text ":=" <+> ppr arg + , ppr (seIdSubst env) ]) $ + do { tick (BetaReduction bndr) + ; tick (PreInlineUnconditionally bndr) + ; simplLam env' body cont } + + | otherwise + = do { tick (BetaReduction bndr) + ; let from_what = FromBeta arg_levity + + ; case (arg_se, arg_mco) of + (UnSimplified arg_env, MRefl) + -- Optimisation: when there is no wrapping coercion use simplNonRecE + -- so that the clever floating out of let-bindings can take place + -- in this round of the Simplifier + -> simplNonRecE env from_what bndr (arg, arg_env) body cont + + _ -> do { arg' <- simplArg env Nothing fun_ty arg_se arg arg_mco + ; completeBindX env from_what bndr arg' body cont } } + where + arg_levity + | isForAllTy fun_ty = assertPpr (isCoVar bndr) (ppr bndr) Unlifted + | otherwise = typeLevity (funArgTy fun_ty) + -- Example: (\(cv::a ~# b). blah) co + -- The type of (\cv.blah) can be (forall cv. ty); see GHC.Core.Utils.mkLamType + + -- Using fun_ty: see Note [Dark corner with representation polymorphism] + -- e.g (\r \(a::TYPE r) \(x::a). blah) @LiftedRep @Int arg + -- When we come to `x=arg` we must choose lazy/strict correctly + -- It's wrong to err in either direction + -- But fun_ty is an OutType, so is fully substituted + -- Discard a non-counting tick on a lambda. This may change the -- cost attribution slightly (moving the allocation of the @@ -2289,17 +2294,18 @@ simplInId env var cont = rebuild env (Var var) cont | otherwise = case substId env var of - ContEx tvs cvs ids e -> simplExprF env' e cont + ContEx se e mco + -> simplExprF (se `setInScopeFromE` env) e (addCastMCo mco cont) -- Don't trimJoinCont; haven't already simplified e, -- so the cont is not embodied in e - where - env' = setSubstEnv env tvs cvs ids - DoneId out_id -> simplOutId zapped_env out_id cont' + DoneId out_id + -> simplOutId zapped_env out_id cont' where cont' = trimJoinCont out_id (idJoinPointHood out_id) cont - DoneEx e mb_join -> simplOutExpr zapped_env e cont' + DoneEx e mb_join + -> simplOutExpr zapped_env e cont' where cont' = trimJoinCont var mb_join cont where @@ -2353,12 +2359,12 @@ simplOutId :: SimplEnvIS -> OutId -> SimplCont -> SimplM (SimplFloats, OutExpr) -- See Note [Simplification of runRW#] in GHC.CoreToSTG.Prep. -- -- runRW# :: forall (r :: RuntimeRep) (o :: TYPE r). (State# RealWorld -> o) -> o --- K[ runRW# @rr @hole_ty body ] --> runRW @rr' @ty' (\s. K[ body s ]) +-- K[ runRW# @rr @hole_ty arg ] --> runRW @rr' @ty' (\s. K[ arg s ]) simplOutId env fun cont | fun `hasKey` runRWKey , ApplyToTy { sc_cont = cont1 } <- cont , ApplyToTy { sc_cont = cont2, sc_arg_ty = hole_ty } <- cont1 - , ApplyToVal { sc_cont = cont3, sc_arg = arg + , ApplyToVal { sc_cont = cont3, sc_arg = arg, sc_cast = arg_mco , sc_env = arg_se, sc_hole_ty = fun_ty } <- cont2 -- Do this even if (contIsStop cont), or if seCaseCase is off. -- See Note [No eta-expansion in runRW#] @@ -2387,7 +2393,8 @@ simplOutId env fun cont _ -> do { s' <- newId (fsLit "s") ManyTy realWorldStatePrimTy ; let (m,_,_) = splitFunTy fun_ty env' = arg_env `addNewInScopeIds` [s'] - cont' = ApplyToVal { sc_arg = Var s' + cont' = addCastMCo arg_mco $ + ApplyToVal { sc_arg = Var s', sc_cast = MRefl , sc_env = Simplified OkDup, sc_cont = inner_cont , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy new_runrw_res_ty } -- cont' applies to s', then K @@ -2472,16 +2479,17 @@ rebuildCall env info (ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_c ---------- Simplify value arguments -------------------- rebuildCall env fun_info - (ApplyToVal { sc_arg = arg, sc_env = arg_se + (ApplyToVal { sc_arg = arg, sc_env = arg_se, sc_cast = arg_mco , sc_hole_ty = fun_ty, sc_cont = cont }) | UnSimplified arg_env <- arg_se , isStrictArgInfo fun_info -- Strict arguments , seCaseCase env -- But only when case-of-case is on. -- See Note [Case-of-case and full laziness] - = simplExprF (arg_env `setInScopeFromE` env) arg - (StrictArg { sc_fun = fun_info, sc_fun_ty = fun_ty - , sc_dup = NoDup - , sc_cont = cont }) + = simplExprF (arg_env `setInScopeFromE` env) arg $ + addCastMCo arg_mco $ + StrictArg { sc_fun = fun_info, sc_fun_ty = fun_ty + , sc_dup = NoDup + , sc_cont = cont } -- Note [Shadowing in the Simplifier] | otherwise -- Lazy, or already simplified arguments @@ -2489,7 +2497,7 @@ rebuildCall env fun_info -- There is no benefit (unlike in a let-binding), and we'd -- have to be very careful about bogus strictness through -- floating a demanded let. - = do { (_, arg') <- simplArg env fun_ty (Just fun_info) arg_se arg + = do { arg' <- simplArg env (Just fun_info) fun_ty arg_se arg arg_mco ; rebuildCall env (addValArgTo fun_info arg' fun_ty) cont } ---------- No further useful info, revert to generic rebuild ------------ @@ -2804,6 +2812,7 @@ trySeqRules in_env scrut rhs cont , as_dmd = seqDmd , as_hole_ty = res3_ty } ] rule_cont = ApplyToVal { sc_env = UnSimplified in_env, sc_arg = rhs + , sc_cast = MRefl , sc_cont = cont, sc_hole_ty = res4_ty } out_args = [Type rhs_rep, Type scrut_ty, Type rhs_ty, no_cast_scrut] @@ -3900,7 +3909,8 @@ knownCon env scrut dc dc_args case_bndr alt_bndrs rhs cont return ( emptyFloats env , extendIdSubst env case_bndr (DoneEx scrut NotJoinPoint)) - | Just env' <- preInlineUnconditionally env NotTopLevel case_bndr con_app (UnSimplified env) + | Just env' <- preInlineUnconditionally env NotTopLevel case_bndr + (UnSimplified env) con_app MRefl = return (emptyFloats env', env') | otherwise @@ -4088,7 +4098,7 @@ mkDupableContWithDmds env dmds , sc_arg_ty = arg_ty, sc_hole_ty = hole_ty }) } mkDupableContWithDmds env dmds - (ApplyToVal { sc_arg = arg, sc_env = se + (ApplyToVal { sc_arg = arg, sc_env = se, sc_cast = arg_mco , sc_cont = cont, sc_hole_ty = hole_ty }) = -- e.g. [...hole...] (...arg...) -- ==> @@ -4098,12 +4108,12 @@ mkDupableContWithDmds env dmds do { let dmd:|cont_dmds = expectNonEmpty dmds ; (floats1, cont') <- mkDupableContWithDmds env cont_dmds cont ; let env' = env `setInScopeFromF` floats1 - ; (_, arg') <- simplArg env' hole_ty Nothing se arg + ; arg' <- simplArg env' Nothing hole_ty se arg arg_mco ; (let_floats2, triv_arg) <- makeTrivial env' NotTopLevel dmd (fsLit "karg") arg' ; let all_floats = floats1 `addLetFloats` let_floats2 ; return ( all_floats , ApplyToVal { sc_arg = triv_arg, sc_env = Simplified OkDup - , sc_cont = cont', sc_hole_ty = hole_ty }) } + , sc_cast = MRefl, sc_cont = cont', sc_hole_ty = hole_ty }) } mkDupableContWithDmds env _ (Select { sc_bndr = case_bndr, sc_alts = alts, sc_env = se, sc_cont = cont }) ===================================== compiler/GHC/Core/Opt/Simplify/Utils.hs ===================================== @@ -172,10 +172,11 @@ data SimplCont , sc_cont :: SimplCont } | ApplyToVal -- (ApplyToVal arg K)[e] = K[ e arg ] - { sc_hole_ty :: OutType -- Type of the function, presumably (forall a. blah) - -- See Note [The hole type in ApplyToTy] - , sc_env :: StaticEnv -- See Note [StaticEnv] - , sc_arg :: CoreExpr -- The argument, + { sc_hole_ty :: OutType -- Type of the function, presumably (forall a. blah) + -- See Note [The hole type in ApplyToTy] + , sc_env :: StaticEnv -- See Note [StaticEnv] + , sc_arg :: CoreExpr -- The argument + , sc_cast :: MOutCoercion -- Wrap this OutCoercion around the (simplified) argument , sc_cont :: SimplCont } | ApplyToTy -- (ApplyToTy ty K)[e] = K[ e ty ] @@ -416,7 +417,7 @@ pushArgs fun_ty (arg:args) cont = ApplyToTy { sc_hole_ty = fun_ty, sc_arg_ty = ty , sc_cont = pushArgs (piResultTy fun_ty ty) args cont } | otherwise - = ApplyToVal { sc_hole_ty = fun_ty + = ApplyToVal { sc_hole_ty = fun_ty, sc_cast = MRefl , sc_arg = arg, sc_env = Simplified NoDup , sc_cont = pushArgs (funResultTy fun_ty) args cont} @@ -428,7 +429,7 @@ pushArgSpec :: ArgSpec -> SimplCont -> SimplCont pushArgSpec (TyArg { as_arg_ty = arg_ty, as_hole_ty = hole_ty }) cont = ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = cont } pushArgSpec (ValArg { as_arg = arg, as_hole_ty = hole_ty }) cont - = ApplyToVal { sc_arg = arg, sc_env = Simplified NoDup + = ApplyToVal { sc_arg = arg, sc_env = Simplified NoDup, sc_cast = MRefl , sc_hole_ty = hole_ty, sc_cont = cont } argSpecArg :: ArgSpec -> OutExpr @@ -1083,8 +1084,8 @@ interestingArg env se e go env n (Var v) = case substId env v of DoneId v' -> go_var n v' - DoneEx e _ -> go (zapSubstEnv env) n e - ContEx tvs cvs ids e -> go (setSubstEnv env tvs cvs ids) n e + DoneEx e _ -> go (zapSubstEnv env) n e + ContEx se e _mco -> go (se `setInScopeFromE` env) n e go _ _ (Lit l) | isLitRubbish l = NonTrivArg -- See (IA3) in Note [Interesting arguments] @@ -1585,13 +1586,13 @@ the former. preInlineUnconditionally :: SimplEnv -> TopLevelFlag -> InId - -> InExpr -> StaticEnv -- These two go together + -> StaticEnv -> CoreExpr -> MOutCoercion -- The argument -> Maybe SimplEnv -- Returned env has extended substitution -- Precondition: rhs satisfies the let-can-float invariant -- See Note [Core let-can-float invariant] in GHC.Core -- Reason: we don't want to inline single uses, or discard dead bindings, -- for unlifted, side-effect-ful bindings -preInlineUnconditionally env top_lvl bndr rhs rhs_se +preInlineUnconditionally env top_lvl bndr rhs_se rhs rhs_mco | not pre_inline_unconditionally = Nothing | not active = Nothing | isTopLevel top_lvl && isDeadEndId bndr = Nothing -- Note [Top-level bottoming Ids] @@ -1603,7 +1604,8 @@ preInlineUnconditionally env top_lvl bndr rhs rhs_se -- See Note [Stable unfoldings and preInlineUnconditionally] | not (isInlinePragma inline_prag) - , Just inl <- maybeUnfoldingTemplate unf = Just $! (extend_subst_with inl) + , Just inl <- maybeUnfoldingTemplate unf = assertPpr (isReflMCo rhs_mco) (ppr bndr) $ + Just $! (extend_subst_with inl) | otherwise = Nothing where @@ -1613,9 +1615,10 @@ preInlineUnconditionally env top_lvl bndr rhs rhs_se -- If not then ContEx -- ToDo: flesh this note out extend_subst_with inl_rhs - = case rhs_se of - Simplified _ -> extendIdSubst env bndr $! DoneEx inl_rhs NotJoinPoint - UnSimplified rhs_env -> extendIdSubst env bndr $! mkContEx rhs_env inl_rhs + = extendIdSubst env bndr $! + case rhs_se of + Simplified _ -> DoneEx (mkCastMCo inl_rhs rhs_mco) NotJoinPoint + UnSimplified rhs_env -> ContEx rhs_env inl_rhs rhs_mco one_occ IAmDead = True -- Happens in ((\x.1) v) one_occ OneOcc{ occ_n_br = 1 ===================================== testsuite/tests/codeGen/should_compile/T25177.stderr ===================================== @@ -9,7 +9,7 @@ d = D 10## RUBBISH(IntRep) lvl = foo d -bar1 = \ _ eta -> case lvl of { W# ipv -> (# eta, () #) } +bar1 = \ x eta -> case lvl of { W# ipv -> (# eta, () #) } bar = bar1 `cast` <Co:6> :: ... ===================================== testsuite/tests/deSugar/should_compile/T13208.stdout ===================================== @@ -1,6 +1,6 @@ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=True)}] -f = \ (@p) _ [Occ=Dead] -> GHC.Internal.Types.True +f = \ (@p) (x [Occ=Dead] :: p) -> GHC.Internal.Types.True Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, ===================================== testsuite/tests/numeric/should_compile/T15547.stderr ===================================== @@ -4,28 +4,28 @@ Result size of Tidy Core = {terms: 40, types: 122, coercions: 26, joins: 0/0} nat2Word# - = \ @n $dKnownNat _ -> + = \ @n $dKnownNat p1 -> naturalToWord# ((natSing $dKnownNat) `cast` <Co:2> :: ...) -foo = \ _ -> 18## +foo = \ ds -> 18## fd - = \ @n $dKnownNat _ -> + = \ @n $dKnownNat ds -> naturalToWord# ((natSing $dKnownNat) `cast` <Co:6> :: ...) -d = \ _ -> 3## +d = \ ds -> 3## fm - = \ @n $dKnownNat _ -> + = \ @n $dKnownNat ds -> naturalToWord# ((natSing $dKnownNat) `cast` <Co:8> :: ...) -m = \ _ -> 9## +m = \ ds -> 9## fp - = \ @n $dKnownNat _ -> + = \ @n $dKnownNat ds -> naturalToWord# ((natSing $dKnownNat) `cast` <Co:10> :: ...) -p = \ _ -> 512## +p = \ ds -> 512## ===================================== testsuite/tests/numeric/should_compile/T20347.stderr ===================================== @@ -5,7 +5,7 @@ Result size of Tidy Core foo0 = \ x -> -# 10# x -foo1 = \ _ -> 10# +foo1 = \ x -> 10# foo2 = \ x -> +# 10# x ===================================== testsuite/tests/numeric/should_compile/T20374.stderr ===================================== @@ -3,15 +3,15 @@ Result size of Tidy Core = {terms: 44, types: 107, coercions: 0, joins: 0/0} -foo0 = \ _ -> (# 0#, 0#, 683234160# #) +foo0 = \ ds -> (# 0#, 0#, 683234160# #) -foo1 = \ _ -> (# 0#, -1#, -683234160# #) +foo1 = \ ds -> (# 0#, -1#, -683234160# #) foo2 = foo0 foo3 = foo1 -foo4 = \ _ -> (# 0#, 0#, 0# #) +foo4 = \ ds -> (# 0#, 0#, 0# #) foo5 = foo4 @@ -19,11 +19,11 @@ foo6 = \ other -> other foo7 = foo6 -foo8 = \ _ -> (# 0#, 0#, 128# #) +foo8 = \ ds -> (# 0#, 0#, 128# #) -foo9 = \ _ -> (# 0#, -1#, -128# #) +foo9 = \ ds -> (# 0#, -1#, -128# #) -foo10 = \ _ -> 1# +foo10 = \ ds -> 1# ===================================== testsuite/tests/numeric/should_compile/T20376.stderr ===================================== @@ -3,11 +3,11 @@ Result size of Tidy Core = {terms: 71, types: 45, coercions: 0, joins: 0/0} -foo0 = \ _ -> 16## +foo0 = \ ds -> 16## -foo1 = \ _ -> 4## +foo1 = \ ds -> 4## -foo2 = \ _ -> 11## +foo2 = \ ds -> 11## foo3 = foo0 @@ -21,11 +21,11 @@ foo3' = foo0' foo4' = I# 31# -ctz0 = \ _ -> 30## +ctz0 = \ ds -> 30## -ctz1 = \ _ -> 6## +ctz1 = \ ds -> 6## -ctz2 = \ _ -> 14## +ctz2 = \ ds -> 14## ctz3 = ctz0 @@ -39,11 +39,11 @@ ctz3' = ctz0' ctz4' = I# 62# -clz1 = \ _ -> 5## +clz1 = \ ds -> 5## -clz2 = \ _ -> 13## +clz2 = \ ds -> 13## -clz3 = \ _ -> 29## +clz3 = \ ds -> 29## clz1' = I# 5# ===================================== testsuite/tests/printer/T18052a.stderr ===================================== @@ -6,7 +6,7 @@ TYPE CONSTRUCTORS PATTERN SYNONYMS (:||:) :: forall {a} {b}. a -> b -> (a, b) Dependent modules: [] -Dependent packages: [(normal, base-4.21.0.0)] +Dependent packages: [(normal, base-4.23.0.0)] ==================== Tidy Core ==================== Result size of Tidy Core @@ -35,7 +35,7 @@ T18052a.$m:||: (@b) (scrut :: (a, b)) (cont :: a -> b -> r) - _ [Occ=Dead] -> + (fail [Occ=Dead] :: (# #) -> r) -> case scrut of { (x, y) -> cont x y } ===================================== testsuite/tests/simplCore/should_compile/DsSpecPragmas.stderr ===================================== @@ -1,78 +1,102 @@ ==================== Tidy Core rules ==================== "USPEC f1 @Word @[e]" - forall (@e) ($dNum :: Num Word) ($dEq :: Eq [e]). + forall (@e) ($dNum [Occ=Dead] :: Num Word) ($dEq :: Eq [e]). f1 @Word @[e] $dNum $dEq - = \ _ [Occ=Dead] _ [Occ=Dead] -> I# 111# + = \ (ds [Occ=Dead] :: Word) (ds1 [Occ=Dead] :: [e]) -> I# 111# "USPEC f1 @Word @_" - forall (@e) ($dNum :: Num Word) ($dEq :: Eq e). + forall (@e) ($dNum [Occ=Dead] :: Num Word) ($dEq :: Eq e). f1 @Word @e $dNum $dEq - = \ _ [Occ=Dead] _ [Occ=Dead] -> I# 111# + = \ (ds [Occ=Dead] :: Word) (ds1 [Occ=Dead] :: e) -> I# 111# "USPEC f1_qc @_ @(g e) @Word" forall (@(g :: * -> *)) (@e) (df :: forall x. Eq x => Eq (g x)) ($dEq :: Eq (g e)) - ($dNum :: Num Word). + ($dNum [Occ=Dead] :: Num Word). f1_qc @g @(g e) @Word df $dEq $dNum - = \ _ [Occ=Dead] _ [Occ=Dead] _ [Occ=Dead] -> C# 'q'# + = \ (ds [Occ=Dead] :: Proxy g) + (ds1 [Occ=Dead] :: g e) + (ds2 [Occ=Dead] :: Word) -> + C# 'q'# "USPEC f2 @_ @_ @Word" - forall (@c) ($dEq :: Eq c) ($dEq1 :: Eq c) ($dNum :: Num Word). + forall (@c) + ($dEq [Occ=Dead] :: Eq c) + ($dEq1 :: Eq c) + ($dNum [Occ=Dead] :: Num Word). f2 @c @c @Word $dEq $dEq1 $dNum - = \ _ [Occ=Dead] _ [Occ=Dead] _ [Occ=Dead] -> I# 2# + = \ (ds [Occ=Dead] :: c) + (ds1 [Occ=Dead] :: c) + (ds2 [Occ=Dead] :: Word) -> + I# 2# "USPEC f3 @Int @_" forall (@(g :: * -> *)) - ($dEq :: Eq Int) + ($dEq [Occ=Dead] :: Eq Int) (df :: forall x. Eq x => Eq (g x)). f3 @Int @g $dEq df = f3_$sf3 @g df "USPEC f3 @_ @[]" - forall (@c) ($dEq :: Eq c) (df :: forall x. Eq x => Eq [x]). + forall (@c) + ($dEq :: Eq c) + (df [Occ=Dead] :: forall x. Eq x => Eq [x]). f3 @c @[] $dEq df = f3_$sf1 @c $dEq "USPEC f4 @_ @(ST s)" - forall (@b) (@s) ($dEq :: Eq b) ($dMonad :: Monad (ST s)). + forall (@b) + (@s) + ($dEq :: Eq b) + ($dMonad [Occ=Dead] :: Monad (ST s)). f4 @b @(ST s) $dEq $dMonad = $fApplicativeST_$cpure @s @b "USPEC f4_qc @Int @_ @_" forall (@(r :: (* -> *) -> * -> *)) (@(n :: * -> *)) - ($dEq :: Eq Int) + ($dEq [Occ=Dead] :: Eq Int) (df :: forall (m :: * -> *). Monad m => Monad (r m)). f4_qc @Int @r @n $dEq df - = \ _ [Occ=Dead] -> () + = \ (ds [Occ=Dead] :: r n Int) -> () "USPEC f5 @(D Int)" - forall ($dEq :: Eq (D Int)). f5 @(D Int) $dEq = f5_$sf5 + forall ($dEq [Occ=Dead] :: Eq (D Int)). f5 @(D Int) $dEq = f5_$sf5 "USPEC f5_qc @Int @D" - forall ($dEq :: Eq Int) - ($dEq1 :: Eq (T Int)) - (df :: forall x. (Eq x, Eq (T x)) => Eq (D x)). + forall ($dEq [Occ=Dead] :: Eq Int) + ($dEq1 [Occ=Dead] :: Eq (T Int)) + (df [Occ=Dead] :: forall x. (Eq x, Eq (T x)) => Eq (D x)). f5_qc @Int @D $dEq $dEq1 df = f5_$sf5 "USPEC f5_qc @Int @_" forall (@(g :: * -> *)) - ($dEq :: Eq Int) - ($dEq1 :: Eq (T Int)) + ($dEq [Occ=Dead] :: Eq Int) + ($dEq1 [Occ=Dead] :: Eq (T Int)) (df :: forall x. (Eq x, Eq (T x)) => Eq (g x)). f5_qc @Int @g $dEq $dEq1 df = f5_qc_$sf5_qc @g df "USPEC f6 @_ @_ @Word" - forall (@c) ($dEq :: Eq c) ($dOrd :: Ord c) ($dNum :: Num Word). + forall (@c) + ($dEq [Occ=Dead] :: Eq c) + ($dOrd :: Ord c) + ($dNum [Occ=Dead] :: Num Word). f6 @c @c @Word $dEq $dOrd $dNum - = \ _ [Occ=Dead] _ [Occ=Dead] _ [Occ=Dead] -> C# 'c'# + = \ (ds [Occ=Dead] :: c) + (ds1 [Occ=Dead] :: c) + (ds2 [Occ=Dead] :: Word) -> + C# 'c'# "USPEC f6_qc @_ @_ @Word" forall (@(h :: * -> *)) - (df :: forall x. Eq x => Eq (h x)) + (df [Occ=Dead] :: forall x. Eq x => Eq (h x)) (df1 :: forall y. Eq y => Ord (h y)) - ($dNum :: Num Word). + ($dNum [Occ=Dead] :: Num Word). f6_qc @h @h @Word df df1 $dNum - = \ _ [Occ=Dead] _ [Occ=Dead] _ [Occ=Dead] -> C# 'd'# + = \ (ds [Occ=Dead] :: Proxy h) + (ds1 [Occ=Dead] :: Proxy h) + (ds2 [Occ=Dead] :: Word) -> + C# 'd'# "USPEC f7 @Int" - forall ($dCls :: Cls (TF Int)) ($dEq :: Eq Int). + forall ($dCls :: Cls (TF Int)) ($dEq [Occ=Dead] :: Eq Int). f7 @Int $dCls $dEq = \ (x [Occ=Once1] :: Int) -> x "USPEC qcfd @C @G" - forall ($dF :: F C G) (df :: forall a b. C (a, b)). + forall ($dF [Occ=Dead] :: F C G) + (df [Occ=Dead] :: forall a b. C (a, b)). qcfd @C @G $dF df = qcfd_x ===================================== testsuite/tests/simplCore/should_compile/RewriteHigherOrderPatterns.stderr ===================================== @@ -3,28 +3,28 @@ Rule fired Module: (RewriteHigherOrderPatterns) Full arity: 1 Before: bar \ x y z -> two (two x y) z - After: (\ f -> True) (\ x y -> two (two x y)) + After: (\ f -> True) (\ x y -> two (two x y)) Rule fired Rule: bar Module: (RewriteHigherOrderPatterns) Full arity: 1 - Before: bar \ x _ z -> two (two x (I# 2#)) z - After: (\ f -> True) (\ x _ -> two (two x (I# 2#))) + Before: bar \ x y z -> two (two x (I# 2#)) z + After: (\ f -> True) (\ x y -> two (two x (I# 2#))) Rule fired Rule: foo Module: (RewriteHigherOrderPatterns) Full arity: 1 Before: foo \ x -> two (two x (I# 2#)) x - After: (\ f -> True) (\ x -> two (two x (I# 2#)) x) + After: (\ f -> True) (\ x -> two (two x (I# 2#)) x) Rule fired Rule: qux Module: (RewriteHigherOrderPatterns) Full arity: 1 Before: qux \ x y -> three (two x (I# 1#)) (I# 2#) y - After: (\ f -> True) (\ x -> three (two x (I# 1#))) + After: (\ f -> True) (\ x -> three (two x (I# 1#))) Rule fired Rule: baz Module: (RewriteHigherOrderPatterns) Full arity: 1 Before: baz \ x -> three (two x (I# 1#)) (I# 2#) x - After: (\ f -> True) (\ x -> three (two x (I# 1#)) (I# 2#)) + After: (\ f -> True) (\ x -> three (two x (I# 1#)) (I# 2#)) ===================================== testsuite/tests/simplCore/should_compile/T18668.stderr ===================================== @@ -3,23 +3,24 @@ Rule fired Module: (T18668) Full arity: 0 Before: GHC.Internal.Prim.+# 2# 3# - After: GHC.Internal.Prim.*# + After: GHC.Internal.Prim.*# Rule fired Rule: *# Module: (BUILTIN) Full arity: 2 Before: GHC.Internal.Prim.*# 2# 3# - After: 6# + After: 6# Rule fired Rule: flip Module: (T18668) Full arity: 1 Before: GHC.Internal.Prim.># 1# 0# - After: (\ (x :: GHC.Internal.Prim.Int#) -> GHC.Internal.Prim.<# x) - 1# + After: (\ (x [Occ=Once1] :: GHC.Internal.Prim.Int#) -> + GHC.Internal.Prim.<# x) + 1# Rule fired Rule: <# Module: (BUILTIN) Full arity: 2 Before: GHC.Internal.Prim.<# 1# 0# - After: 0# + After: 0# ===================================== testsuite/tests/simplCore/should_compile/T19246.stderr ===================================== @@ -5,7 +5,8 @@ ==================== Tidy Core rules ==================== "SPEC/T19246 $wf @Int" [2] - forall ($dOrd :: Ord Int). $wf @Int $dOrd = $s$wf -"USPEC f @Int" [2] forall ($dOrd :: Ord Int). f @Int $dOrd = $sf + forall ($dOrd [Occ=Dead] :: Ord Int). $wf @Int $dOrd = $s$wf +"USPEC f @Int" [2] + forall ($dOrd [Occ=Dead] :: Ord Int). f @Int $dOrd = $sf ===================================== testsuite/tests/simplCore/should_compile/T19599.stderr ===================================== @@ -1,6 +1,8 @@ ==================== Tidy Core rules ==================== "SPEC myShow_impl @Int" - forall ($dMyShow :: MyShow Int). myShow_impl @Int $dMyShow = foo + forall ($dMyShow [Occ=Dead] :: MyShow Int). + myShow_impl @Int $dMyShow + = foo ===================================== testsuite/tests/simplCore/should_compile/T19599a.stderr ===================================== @@ -1,6 +1,6 @@ ==================== Tidy Core rules ==================== "SPEC r_bar @Int" - forall ($dC :: C Int). r_bar @Int $dC = $fCInt_$sr_bar + forall ($dC [Occ=Dead] :: C Int). r_bar @Int $dC = $fCInt_$sr_bar ===================================== testsuite/tests/simplCore/should_compile/T21917.stderr ===================================== @@ -1,7 +1,8 @@ ==================== Tidy Core rules ==================== "SPEC foo @IO @Int" - forall ($dMonad :: Monad IO) ($dIntegral :: Integral Int). + forall ($dMonad [Occ=Dead] :: Monad IO) + ($dIntegral [Occ=Dead] :: Integral Int). foo1 @IO @Int $dMonad $dIntegral = foo_$sfoo ===================================== testsuite/tests/simplCore/should_compile/T23074.stderr ===================================== @@ -1,7 +1,7 @@ ==================== Tidy Core rules ==================== "SPEC $cstimes @Int" - forall ($dIntegral :: Integral Int). + forall ($dIntegral [Occ=Dead] :: Integral Int). $fSemigroupSumInt_$cstimes @Int $dIntegral = foo ===================================== testsuite/tests/simplCore/should_compile/T25160.stderr ===================================== @@ -1,5 +1,6 @@ ==================== Tidy Core rules ==================== -"USPEC bar @_" forall (@a) ($dC :: C a). bar @a $dC = bar_$sbar @a +"USPEC bar @_" + forall (@a) ($dC [Occ=Dead] :: C a). bar @a $dC = bar_$sbar @a ===================================== testsuite/tests/simplCore/should_compile/T25718c.stderr-ws-64 ===================================== @@ -3,37 +3,37 @@ Result size of Tidy Core = {terms: 161, types: 140, coercions: 0, joins: 0/0} -narrow8_ge_lb = \ _ -> True +narrow8_ge_lb = \ x -> True narrow8_le_ub = narrow8_ge_lb -narrow8_gt_ub_false = \ _ -> False +narrow8_gt_ub_false = \ x -> False narrow16_ge_lb = narrow8_ge_lb narrow16_le_ub = narrow8_ge_lb -narrow8w_lt_ub = \ _ -> True +narrow8w_lt_ub = \ x -> True narrow16w_lt_ub = narrow8w_lt_ub -word16_lt_ub = \ _ -> True +word16_lt_ub = \ x -> True -word16_ge_ub_false = \ _ -> False +word16_ge_ub_false = \ x -> False word_to_word8_lt = narrow8w_lt_ub word_to_word16_lt = narrow8w_lt_ub -word8_to_int8_ge = \ _ -> True +word8_to_int8_ge = \ x -> True word16_to_int16_ge = word16_lt_ub -int8_to_word8_le = \ _ -> True +int8_to_word8_le = \ x -> True -int16_to_word16_le = \ _ -> True +int16_to_word16_le = \ x -> True -word8_add_lt_256 = \ _ _ -> True +word8_add_lt_256 = \ x y -> True word16_alts = \ x -> @@ -51,15 +51,15 @@ narrow8_alts word8_sub_lt_256 = word8_add_lt_256 -word16_add_lt_ub = \ _ _ -> True +word16_add_lt_ub = \ x y -> True word16_sub_lt_ub = word16_add_lt_ub -int8_add_ge_lb = \ _ _ -> True +int8_add_ge_lb = \ x y -> True int8_sub_le_ub = int8_add_ge_lb -int16_add_ge_lb = \ _ _ -> True +int16_add_ge_lb = \ x y -> True int16_sub_le_ub = int16_add_ge_lb @@ -67,11 +67,11 @@ narrow32_ge_lb = narrow8_ge_lb narrow32_le_ub = narrow8_ge_lb -word32_to_int32_ge = \ _ -> True +word32_to_int32_ge = \ x -> True -int32_to_word32_le = \ _ -> True +int32_to_word32_le = \ x -> True -int32_add_ge_lb = \ _ _ -> True +int32_add_ge_lb = \ x y -> True int32_sub_le_ub = int32_add_ge_lb @@ -88,7 +88,7 @@ word16_and_lt = word16_lt_ub word32_and_lt = word32_to_int32_ge -word64_and_le = \ _ -> True +word64_and_le = \ x -> True int_and_ge = narrow8_ge_lb @@ -103,11 +103,11 @@ narrow32w_lt_ub = narrow8w_lt_ub word32_lt_ub = word32_to_int32_ge -word32_ge_ub_false = \ _ -> False +word32_ge_ub_false = \ x -> False word_to_word32_lt = narrow8w_lt_ub -word32_add_lt_ub = \ _ _ -> True +word32_add_lt_ub = \ x y -> True word32_sub_lt_ub = word32_add_lt_ub ===================================== testsuite/tests/simplCore/should_compile/T26051.stderr ===================================== @@ -7,7 +7,7 @@ Result size of Specialise = {terms: 31, types: 39, coercions: 8, joins: 0/1} specMe [InlPrag=INLINABLE] :: forall n a. (Integral n, MaybeShowNum a n) => a -> n -> (String, n) [LclIdX, Arity=4, - Unf=Unf{Src=StableUser, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [30 0 0 20] 260 10 + Unf=Unf{Src=StableUser, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [90 60 0 20] 260 10 Tmpl= \ (@n) (@a) ($dIntegral [Occ=Once1] :: Integral n) (irred :: MaybeShowNum a n) (eta [Occ=Once1] :: a) (eta [Occ=Once1] :: n) -> let { $dNum :: Num n @@ -63,7 +63,7 @@ foo = \ (x :: Int) -> specMe @Int @Bool GHC.Internal.Real.$fIntegralInt ($dCTupl -- RHS size: {terms: 37, types: 26, coercions: 0, joins: 0/0} main :: State# RealWorld -> (# State# RealWorld, () #) [LclId, Arity=1, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [0] 301 0}] -main = \ (eta [OS=OneShot] :: State# RealWorld) -> GHC.Internal.IO.Handle.Text.hPutStr2 GHC.Internal.IO.StdHandles.stdout (case GHC.Internal.Enum.eftIntFB @(Int -> Int) (GHC.Internal.Base.mapFB @Int @(Int -> Int) @Int (\ (ds :: Int) (ds1 [OS=OneShot] :: Int -> Int) (v [OS=OneShot] :: Int) -> case v of { I# ipv -> ds1 (case ds of { I# y -> GHC.Internal.Types.I# (+# ipv y) }) }) (\ (x :: Int) -> case foo x of { (_ [Occ=Dead], y) -> y })) (breakpoint @Int) 1# 1000# (GHC.Internal.Types.I# 0#) of { I# n -> GHC.Internal.Show.itos n (GHC.Internal.Types.[] @Char) }) GHC.Internal.Types.True eta +main = \ (eta [OS=OneShot] :: State# RealWorld) -> GHC.Internal.IO.Handle.Text.hPutStr2 GHC.Internal.IO.Handle.FD.stdout (case GHC.Internal.Enum.eftIntFB @(Int -> Int) (GHC.Internal.Base.mapFB @Int @(Int -> Int) @Int (\ (ds :: Int) (ds1 [OS=OneShot] :: Int -> Int) (v [OS=OneShot] :: Int) -> case v of { I# ipv -> ds1 (case ds of { I# y -> GHC.Internal.Types.I# (+# ipv y) }) }) (\ (x :: Int) -> case foo x of { (_ [Occ=Dead], y) -> y })) (breakpoint @Int) 1# 1000# (GHC.Internal.Types.I# 0#) of { I# n -> GHC.Internal.Show.itos n (GHC.Internal.Types.[] @Char) }) GHC.Internal.Types.True eta -- RHS size: {terms: 1, types: 0, coercions: 3, joins: 0/0} main :: IO () @@ -72,7 +72,7 @@ main = main `cast` (Sym (GHC.Internal.Types.N:IO <()>_R) :: (State# RealWorld -> ------ Local rules for imported ids -------- -"SPEC/T26051 $wspecMe @Int @Bool" [2] forall ($dIntegral :: Integral Int) (irred :: MaybeShowNum Bool Int). T26051_Import.$wspecMe @Int @Bool $dIntegral irred = $s$wspecMe -"SPEC/T26051 specMe @Int @Bool" [2] forall ($dIntegral :: Integral Int) (irred :: MaybeShowNum Bool Int). specMe @Int @Bool $dIntegral irred = $sspecMe +"SPEC/T26051 $wspecMe @Int @Bool" [2] forall ($dIntegral [Occ=Dead] :: Integral Int) (irred [Occ=Dead] :: MaybeShowNum Bool Int). T26051_Import.$wspecMe @Int @Bool $dIntegral irred = $s$wspecMe +"SPEC/T26051 specMe @Int @Bool" [2] forall ($dIntegral [Occ=Dead] :: Integral Int) (irred [Occ=Dead] :: MaybeShowNum Bool Int). specMe @Int @Bool $dIntegral irred = $sspecMe ===================================== testsuite/tests/simplCore/should_compile/T26116.stderr ===================================== @@ -1,11 +1,11 @@ ==================== Tidy Core rules ==================== "USPEC $cop1 @T @_" - forall (@a) ($dEq :: Eq (T a)) ($dD :: D a). + forall (@a) ($dEq [Occ=Dead] :: Eq (T a)) ($dD :: D a). $fCTYPEfa_$cop1 @T @a $dEq $dD - = \ _ [Occ=Dead] -> I# 3# + = \ (x [Occ=Dead] :: T a) -> I# 3# "USPEC $fCTYPEfa @T @_" - forall (@a) ($dEq :: Eq (T a)) ($dD :: D a). + forall (@a) ($dEq [Occ=Dead] :: Eq (T a)) ($dD :: D a). $fCTYPEfa @T @a $dEq $dD = $fCTYPEfa_$s$fCTYPEfa @a $dD ===================================== testsuite/tests/simplCore/should_compile/T8331.stderr ===================================== @@ -1,7 +1,7 @@ ==================== Tidy Core rules ==================== "SPEC $c*> @(ST s) @_" - forall (@s) (@r) ($dApplicative :: Applicative (ST s)). + forall (@s) (@r) ($dApplicative [Occ=Dead] :: Applicative (ST s)). $fApplicativeReaderT_$c*> @(ST s) @r $dApplicative = ($fApplicativeReaderT2 @s @r) `cast` (forall (a ::~ <*>_N) (b ::~ <*>_N). @@ -15,7 +15,7 @@ (forall a b. ReaderT r (ST s) a -> ReaderT r (ST s) b -> ReaderT r (ST s) b)) "SPEC $c<$ @(ST s) @_" - forall (@s) (@r) ($dFunctor :: Functor (ST s)). + forall (@s) (@r) ($dFunctor [Occ=Dead] :: Functor (ST s)). $fFunctorReaderT_$c<$ @(ST s) @r $dFunctor = ($fApplicativeReaderT6 @s @r) `cast` (forall (a ::~ <*>_N) (b ::~ <*>_N). @@ -27,7 +27,7 @@ (forall a b. a -> ReaderT r (ST s) b -> r -> STRep s a) (forall a b. a -> ReaderT r (ST s) b -> ReaderT r (ST s) a)) "SPEC $c<* @(ST s) @_" - forall (@s) (@r) ($dApplicative :: Applicative (ST s)). + forall (@s) (@r) ($dApplicative [Occ=Dead] :: Applicative (ST s)). $fApplicativeReaderT_$c<* @(ST s) @r $dApplicative = ($fApplicativeReaderT1 @s @r) `cast` (forall (a ::~ <*>_N) (b ::~ <*>_N). @@ -41,7 +41,7 @@ (forall a b. ReaderT r (ST s) a -> ReaderT r (ST s) b -> ReaderT r (ST s) a)) "SPEC $c<*> @(ST s) @_" - forall (@s) (@r) ($dApplicative :: Applicative (ST s)). + forall (@s) (@r) ($dApplicative [Occ=Dead] :: Applicative (ST s)). $fApplicativeReaderT9 @(ST s) @r $dApplicative = ($fApplicativeReaderT4 @s @r) `cast` (forall (a ::~ <*>_N) (b ::~ <*>_N). @@ -55,11 +55,11 @@ (forall a b. ReaderT r (ST s) (a -> b) -> ReaderT r (ST s) a -> r -> ST s b)) "SPEC $c>> @(ST s) @_" - forall (@s) (@r) ($dMonad :: Monad (ST s)). + forall (@s) (@r) ($dMonad [Occ=Dead] :: Monad (ST s)). $fMonadReaderT_$c>> @(ST s) @r $dMonad = $fMonadAbstractIOSTReaderT_$s$c>> @s @r "SPEC $c>>= @(ST s) @_" - forall (@s) (@r) ($dMonad :: Monad (ST s)). + forall (@s) (@r) ($dMonad [Occ=Dead] :: Monad (ST s)). $fMonadReaderT1 @(ST s) @r $dMonad = ($fMonadAbstractIOSTReaderT2 @s @r) `cast` (forall (a ::~ <*>_N) (b ::~ <*>_N). @@ -73,7 +73,7 @@ (forall a b. ReaderT r (ST s) a -> (a -> ReaderT r (ST s) b) -> r -> ST s b)) "SPEC $cfmap @(ST s) @_" - forall (@s) (@r) ($dFunctor :: Functor (ST s)). + forall (@s) (@r) ($dFunctor [Occ=Dead] :: Functor (ST s)). $fFunctorReaderT_$cfmap @(ST s) @r $dFunctor = ($fApplicativeReaderT7 @s @r) `cast` (forall (a ::~ <*>_N) (b ::~ <*>_N). @@ -85,7 +85,7 @@ (forall a b. (a -> b) -> ReaderT r (ST s) a -> r -> STRep s b) (forall a b. (a -> b) -> ReaderT r (ST s) a -> ReaderT r (ST s) b)) "SPEC $cliftA2 @(ST s) @_" - forall (@s) (@r) ($dApplicative :: Applicative (ST s)). + forall (@s) (@r) ($dApplicative [Occ=Dead] :: Applicative (ST s)). $fApplicativeReaderT_$cliftA2 @(ST s) @r $dApplicative = ($fApplicativeReaderT3 @s @r) `cast` (forall (a ::~ <*>_N) (b ::~ <*>_N) (c ::~ <*>_N). @@ -102,15 +102,15 @@ (a -> b -> c) -> ReaderT r (ST s) a -> ReaderT r (ST s) b -> ReaderT r (ST s) c)) "SPEC $cp1Applicative @(ST s) @_" - forall (@s) (@r) ($dApplicative :: Applicative (ST s)). + forall (@s) (@r) ($dApplicative [Occ=Dead] :: Applicative (ST s)). $fApplicativeReaderT_$cp1Applicative @(ST s) @r $dApplicative = $fApplicativeReaderT_$s$fFunctorReaderT @s @r "SPEC $cp1Monad @(ST s) @_" - forall (@s) (@r) ($dMonad :: Monad (ST s)). + forall (@s) (@r) ($dMonad [Occ=Dead] :: Monad (ST s)). $fMonadReaderT_$cp1Monad @(ST s) @r $dMonad = $fApplicativeReaderT_$s$fApplicativeReaderT @s @r "SPEC $cpure @(ST s) @_" - forall (@s) (@r) ($dApplicative :: Applicative (ST s)). + forall (@s) (@r) ($dApplicative [Occ=Dead] :: Applicative (ST s)). $fApplicativeReaderT_$cpure @(ST s) @r $dApplicative = ($fApplicativeReaderT5 @s @r) `cast` (forall (a ::~ <*>_N). @@ -121,7 +121,7 @@ (forall a. a -> r -> STRep s a) (forall a. a -> ReaderT r (ST s) a)) "SPEC $creturn @(ST s) @_" - forall (@s) (@r) ($dMonad :: Monad (ST s)). + forall (@s) (@r) ($dMonad [Occ=Dead] :: Monad (ST s)). $fMonadReaderT_$creturn @(ST s) @r $dMonad = ($fApplicativeReaderT5 @s @r) `cast` (forall (a ::~ <*>_N). @@ -132,20 +132,21 @@ (forall a. a -> r -> STRep s a) (forall a. a -> ReaderT r (ST s) a)) "SPEC $fApplicativeReaderT @(ST s) @_" - forall (@s) (@r) ($dApplicative :: Applicative (ST s)). + forall (@s) (@r) ($dApplicative [Occ=Dead] :: Applicative (ST s)). $fApplicativeReaderT @(ST s) @r $dApplicative = $fApplicativeReaderT_$s$fApplicativeReaderT @s @r "SPEC $fFunctorReaderT @(ST s) @_" - forall (@s) (@r) ($dFunctor :: Functor (ST s)). + forall (@s) (@r) ($dFunctor [Occ=Dead] :: Functor (ST s)). $fFunctorReaderT @(ST s) @r $dFunctor = $fApplicativeReaderT_$s$fFunctorReaderT @s @r "SPEC $fMonadReaderT @(ST s) @_" - forall (@s) (@r) ($dMonad :: Monad (ST s)). + forall (@s) (@r) ($dMonad [Occ=Dead] :: Monad (ST s)). $fMonadReaderT @(ST s) @r $dMonad = $fMonadAbstractIOSTReaderT_$s$fMonadReaderT @s @r "USPEC useAbstractMonad @(ReaderT Int (ST s))" forall (@s) - ($dMonadAbstractIOST :: MonadAbstractIOST (ReaderT Int (ST s))). + ($dMonadAbstractIOST [Occ=Dead] + :: MonadAbstractIOST (ReaderT Int (ST s))). useAbstractMonad @(ReaderT Int (ST s)) $dMonadAbstractIOST = (useAbstractMonad1 @s) `cast` (<Int>_R ===================================== testsuite/tests/simplCore/should_compile/T8848a.stderr ===================================== @@ -1,6 +1,8 @@ ==================== Tidy Core rules ==================== "USPEC f @[Int] @_" - forall (@b) ($dOrd :: Ord [Int]). f @[Int] @b $dOrd = f_$sf @b + forall (@b) ($dOrd [Occ=Dead] :: Ord [Int]). + f @[Int] @b $dOrd + = f_$sf @b ===================================== testsuite/tests/typecheck/should_compile/T13032.stderr ===================================== @@ -9,7 +9,11 @@ f :: forall a b. (a ~ b) => a -> b -> Bool Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=3,unsat_ok=True,boring_ok=True)}] -f = \ (@a) (@b) _ [Occ=Dead] _ [Occ=Dead] _ [Occ=Dead] -> +f = \ (@a) + (@b) + ($d~ [Occ=Dead] :: a ~ b) + (x [Occ=Dead] :: a) + (y [Occ=Dead] :: b) -> GHC.Internal.Types.True -- RHS size: {terms: 5, types: 0, coercions: 0, joins: 0/0} View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e8ac16f20c85840402906bbe683aab4... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e8ac16f20c85840402906bbe683aab4... You're receiving this email because of your account on gitlab.haskell.org.