Simon Peyton Jones pushed to branch wip/T26746 at Glasgow Haskell Compiler / GHC Commits: 472df471 by Peter Trommler at 2026-01-08T13:28:54-05:00 Use half-word literals in info tables With this commit info tables are mapped to the same assembler code on big-endian and little-endian platforms. Fixes #26579. - - - - - 393f9c51 by Simon Peyton Jones at 2026-01-08T13:29:35-05:00 Refactor srutOkForBinderSwap This MR does a small refactor: * Moves `scrutOkForBinderSwap` and `BinderSwapDecision` to GHC.Core.Utils * Inverts the sense of the coercion it returns, which makes more sense No effect on behaviour - - - - - ad76fb0f by Simon Peyton Jones at 2026-01-08T13:29:36-05:00 Improve case merging This small MR makes case merging happen a bit more often than it otherwise could, by getting join points out of the way. See #26709 and GHC.Core.Utils Note [Floating join points out of DEFAULT alternatives] - - - - - 4c9395f5 by Cheng Shao at 2026-01-08T13:30:16-05:00 hadrian: remove broken hsc2hs flag when cross compiling to windows This patch removes the `--via-asm` hsc2hs flag when cross compiling to windows. With recent llvm-mingw toolchain, it would fail with: ``` x86_64-w64-mingw32-hsc2hs: Cannot combine instructions: [Quad 8,Long 4,Long 241,Ref ".Ltmp1-.Ltmp0"] ``` The hsc2hs default `--cross-compile` logic is slower but works. - - - - - 71fdef55 by Simon Peyton Jones at 2026-01-08T13:30:57-05:00 Try harder to keep the substitution empty Avoid unnecessary cloning of variables in the Simplifier. Addresses #26724, See Note [Keeping the substitution empty] We get some big wins in compile time Metrics: compile_time/bytes allocated ------------------------------------- Baseline Test Metric value New value Change ---------------------------------------------------------------------------- CoOpt_Singletons(normal) ghc/alloc 721,544,088 692,174,216 -4.1% GOOD LargeRecord(normal) ghc/alloc 1,268,031,157 1,265,168,448 -0.2% T14766(normal) ghc/alloc 918,218,533 688,432,296 -25.0% GOOD T15703(normal) ghc/alloc 318,103,629 306,638,016 -3.6% GOOD T17836(normal) ghc/alloc 419,174,584 418,400,824 -0.2% T18478(normal) ghc/alloc 471,042,976 470,261,376 -0.2% T20261(normal) ghc/alloc 573,387,162 563,663,336 -1.7% T24984(normal) ghc/alloc 87,832,666 87,636,168 -0.2% T25196(optasm) ghc/alloc 1,103,284,040 1,101,376,992 -0.2% hard_hole_fits(normal) ghc/alloc 224,981,413 224,608,208 -0.2% geo. mean -0.3% minimum -25.0% maximum +0.1% Metric Decrease: CoOpt_Singletons T14766 T15703 - - - - - 30341168 by Simon Peyton Jones at 2026-01-08T13:31:38-05:00 Add regression test for #24867 - - - - - c4171ad8 by Simon Peyton Jones at 2026-01-08T23:22:58+00:00 Improve newtype unwrapping See #26746 - - - - - 7d80320e by Simon Peyton Jones at 2026-01-08T23:22:58+00:00 Wibble - - - - - 21 changed files: - compiler/GHC/Cmm/Info.hs - compiler/GHC/Cmm/Utils.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Subst.hs - compiler/GHC/Core/TyCo/Subst.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/Tc/Instance/Family.hs - compiler/GHC/Tc/Solver/Equality.hs - compiler/GHC/Tc/Solver/Monad.hs - hadrian/src/Settings/Builders/Hsc2Hs.hs - + testsuite/tests/pmcheck/should_compile/T24867.hs - + testsuite/tests/pmcheck/should_compile/T24867.stderr - testsuite/tests/pmcheck/should_compile/all.T - + testsuite/tests/simplCore/should_compile/T26709.hs - + testsuite/tests/simplCore/should_compile/T26709.stderr - testsuite/tests/simplCore/should_compile/all.T - + testsuite/tests/typecheck/should_compile/T26746.hs - testsuite/tests/typecheck/should_compile/all.T Changes: ===================================== compiler/GHC/Cmm/Info.hs ===================================== @@ -28,7 +28,7 @@ module GHC.Cmm.Info ( conInfoTableSizeB, stdSrtBitmapOffset, stdClosureTypeOffset, - stdPtrsOffset, stdNonPtrsOffset, + stdPtrsOffset, stdNonPtrsOffset ) where import GHC.Prelude @@ -194,7 +194,7 @@ mkInfoTableContents profile ; let (srt_label, srt_bitmap) = mkSRTLit platform info_lbl srt ; (liveness_lit, liveness_data) <- mkLivenessBits platform frame ; let - std_info = mkStdInfoTable profile prof_lits rts_tag srt_bitmap liveness_lit + std_info = mkStdInfoTable profile prof_lits rts_tag srt_bitmap [liveness_lit] rts_tag | Just tag <- mb_rts_tag = tag | null liveness_data = rET_SMALL -- Fits in extra_bits | otherwise = rET_BIG -- Does not; extra_bits is @@ -202,7 +202,8 @@ mkInfoTableContents profile ; return (prof_data ++ liveness_data, (std_info, srt_label)) } | HeapRep _ ptrs nonptrs closure_type <- smrep - = do { let layout = packIntsCLit platform ptrs nonptrs + = do { let layout = [ mkStgHalfWordCLit platform ptrs, + mkStgHalfWordCLit platform nonptrs] ; (prof_lits, prof_data) <- mkProfLits platform prof ; let (srt_label, srt_bitmap) = mkSRTLit platform info_lbl srt ; (mb_srt_field, mb_layout, extra_bits, ct_data) @@ -214,11 +215,23 @@ mkInfoTableContents profile ; return (prof_data ++ ct_data, (std_info, extra_bits)) } where platform = profilePlatform profile + mk_extra_bits :: Int -> Int -> [CmmLit] + mk_extra_bits low high + = if platformTablesNextToCode platform + -- In mkInfoTable do_one_info extra bits are reversed for TNTC + -- so we must generate the high address halfword before + -- the low address halfword. + then [ mkStgHalfWordCLit platform high + , mkStgHalfWordCLit platform low + ] + else [ mkStgHalfWordCLit platform low + , mkStgHalfWordCLit platform high + ] mk_pieces :: ClosureTypeInfo -> [CmmLit] - -> UniqDSM ( Maybe CmmLit -- Override the SRT field with this - , Maybe CmmLit -- Override the layout field with this - , [CmmLit] -- "Extra bits" for info table - , [RawCmmDecl]) -- Auxiliary data decls + -> UniqDSM ( Maybe CmmLit -- Override the SRT field with this + , Maybe [CmmLit] -- Override the layout field with this + , [CmmLit] -- "Extra bits" for info table + , [RawCmmDecl]) -- Auxiliary data decls mk_pieces (Constr con_tag con_descr) _no_srt -- A data constructor = do { (descr_lit, decl) <- newStringLit con_descr ; return ( Just (CmmInt (fromIntegral con_tag) @@ -230,18 +243,19 @@ mkInfoTableContents profile mk_pieces (ThunkSelector offset) _no_srt = return (Just (CmmInt 0 (halfWordWidth platform)), - Just (mkWordCLit platform (fromIntegral offset)), [], []) + Just [(mkWordCLit platform (fromIntegral offset))], [], []) -- Layout known (one free var); we use the layout field for offset mk_pieces (Fun arity (ArgSpec fun_type)) srt_label - = do { let extra_bits = packIntsCLit platform fun_type arity : srt_label + = do { let extra_bits = mk_extra_bits fun_type arity + ++ srt_label ; return (Nothing, Nothing, extra_bits, []) } mk_pieces (Fun arity (ArgGen arg_bits)) srt_label = do { (liveness_lit, liveness_data) <- mkLivenessBits platform arg_bits ; let fun_type | null liveness_data = aRG_GEN | otherwise = aRG_GEN_BIG - extra_bits = [ packIntsCLit platform fun_type arity ] + extra_bits = mk_extra_bits fun_type arity ++ (if inlineSRT platform then [] else [ srt_lit ]) ++ [ liveness_lit, slow_entry ] ; return (Nothing, Nothing, extra_bits, liveness_data) } @@ -255,11 +269,13 @@ mkInfoTableContents profile mkInfoTableContents _ _ _ = panic "mkInfoTableContents" -- NonInfoTable dealt with earlier -packIntsCLit :: Platform -> Int -> Int -> CmmLit -packIntsCLit platform a b = packHalfWordsCLit platform - (toStgHalfWord platform (fromIntegral a)) - (toStgHalfWord platform (fromIntegral b)) +mkStgWordCLit :: Platform -> StgWord -> CmmLit +mkStgWordCLit platform wd = CmmInt (fromStgWord wd) (wordWidth platform) +mkStgHalfWordCLit :: Platform -> Int -> CmmLit +mkStgHalfWordCLit platform hwd + = CmmInt (fromStgHalfWord (toStgHalfWord platform (fromIntegral hwd))) + (halfWordWidth platform) mkSRTLit :: Platform -> CLabel @@ -385,15 +401,15 @@ mkStdInfoTable -> (CmmLit,CmmLit) -- Closure type descr and closure descr (profiling) -> Int -- Closure RTS tag -> CmmLit -- SRT length - -> CmmLit -- layout field + -> [CmmLit] -- layout field -> [CmmLit] -mkStdInfoTable profile (type_descr, closure_descr) cl_type srt layout_lit +mkStdInfoTable profile (type_descr, closure_descr) cl_type srt layout_lits = -- Parallel revertible-black hole field prof_info -- Ticky info (none at present) -- Debug info (none at present) - ++ [layout_lit, tag, srt] + ++ layout_lits ++ [tag, srt] where platform = profilePlatform profile ===================================== compiler/GHC/Cmm/Utils.hs ===================================== @@ -13,10 +13,9 @@ module GHC.Cmm.Utils( -- CmmLit zeroCLit, mkIntCLit, - mkWordCLit, packHalfWordsCLit, + mkWordCLit, mkByteStringCLit, mkFileEmbedLit, mkDataLits, mkRODataLits, - mkStgWordCLit, -- CmmExpr mkIntExpr, zeroExpr, @@ -211,22 +210,6 @@ mkRODataLits lbl lits needsRelocation (CmmLabelOff _ _) = True needsRelocation _ = False -mkStgWordCLit :: Platform -> StgWord -> CmmLit -mkStgWordCLit platform wd = CmmInt (fromStgWord wd) (wordWidth platform) - -packHalfWordsCLit :: Platform -> StgHalfWord -> StgHalfWord -> CmmLit --- Make a single word literal in which the lower_half_word is --- at the lower address, and the upper_half_word is at the --- higher address --- ToDo: consider using half-word lits instead --- but be careful: that's vulnerable when reversed -packHalfWordsCLit platform lower_half_word upper_half_word - = case platformByteOrder platform of - BigEndian -> mkWordCLit platform ((l `shiftL` halfWordSizeInBits platform) .|. u) - LittleEndian -> mkWordCLit platform (l .|. (u `shiftL` halfWordSizeInBits platform)) - where l = fromStgHalfWord lower_half_word - u = fromStgHalfWord upper_half_word - --------------------------------------------------- -- -- CmmExpr ===================================== compiler/GHC/Core/Opt/OccurAnal.hs ===================================== @@ -28,7 +28,7 @@ core expression with (hopefully) improved usage information. module GHC.Core.Opt.OccurAnal ( occurAnalysePgm, occurAnalyseExpr, - zapLambdaBndrs, BinderSwapDecision(..), scrutOkForBinderSwap + zapLambdaBndrs ) where import GHC.Prelude hiding ( head, init, last, tail ) @@ -36,7 +36,7 @@ import GHC.Prelude hiding ( head, init, last, tail ) import GHC.Core import GHC.Core.FVs import GHC.Core.Utils ( exprIsTrivial, isDefaultAlt, isExpandableApp, - mkCastMCo, mkTicks ) + mkCastMCo, mkTicks, BinderSwapDecision(..), scrutOkForBinderSwap ) import GHC.Core.Opt.Arity ( joinRhsArity, isOneShotBndr ) import GHC.Core.Coercion import GHC.Core.Type @@ -3537,6 +3537,7 @@ doesn't use it. So this is only to satisfy the perhaps-over-picky Lint. -} addBndrSwap :: OutExpr -> Id -> OccEnv -> OccEnv +-- See Note [Binder swap] -- See Note [The binder-swap substitution] addBndrSwap scrut case_bndr env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = rng_vars }) @@ -3544,7 +3545,7 @@ addBndrSwap scrut case_bndr , scrut_var /= case_bndr -- Consider: case x of x { ... } -- Do not add [x :-> x] to occ_bs_env, else lookupBndrSwap will loop - = env { occ_bs_env = extendVarEnv swap_env scrut_var (case_bndr', mco) + = env { occ_bs_env = extendVarEnv swap_env scrut_var (case_bndr', mkSymMCo mco) , occ_bs_rng = rng_vars `extendVarSet` case_bndr' `unionVarSet` tyCoVarsOfMCo mco } @@ -3554,27 +3555,6 @@ addBndrSwap scrut case_bndr case_bndr' = zapIdOccInfo case_bndr -- See Note [Zap case binders in proxy bindings] --- | See bBinderSwaOk. -data BinderSwapDecision - = NoBinderSwap - | DoBinderSwap OutVar MCoercion - -scrutOkForBinderSwap :: OutExpr -> BinderSwapDecision --- If (scrutOkForBinderSwap e = DoBinderSwap v mco, then --- v = e |> mco --- See Note [Case of cast] --- See Historical Note [Care with binder-swap on dictionaries] --- --- We use this same function in SpecConstr, and Simplify.Iteration, --- when something binder-swap-like is happening -scrutOkForBinderSwap e - = case e of - Tick _ e -> scrutOkForBinderSwap e -- Drop ticks - Var v -> DoBinderSwap v MRefl - Cast (Var v) co -> DoBinderSwap v (MCo (mkSymCo co)) - -- Cast: see Note [Case of cast] - _ -> NoBinderSwap - lookupBndrSwap :: OccEnv -> Id -> (CoreExpr, Id) -- See Note [The binder-swap substitution] -- Returns an expression of the same type as Id ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -22,7 +22,7 @@ import GHC.Core.TyCo.Compare( eqType ) import GHC.Core.Opt.Simplify.Env import GHC.Core.Opt.Simplify.Inline import GHC.Core.Opt.Simplify.Utils -import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr, zapLambdaBndrs, scrutOkForBinderSwap, BinderSwapDecision (..) ) +import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr, zapLambdaBndrs ) import GHC.Core.Make ( FloatBind, mkImpossibleExpr, castBottomExpr ) import qualified GHC.Core.Make import GHC.Core.Coercion hiding ( substCo, substCoVar ) @@ -3601,11 +3601,13 @@ addAltUnfoldings env case_bndr bndr_swap con_app env1 = addBinderUnfolding env case_bndr con_app_unf -- See Note [Add unfolding for scrutinee] + -- e.g. case (x |> co) of K a b -> blah + -- We add to `x` the unfolding (K a b |> sym co) env2 | DoBinderSwap v mco <- bndr_swap = addBinderUnfolding env1 v $ if isReflMCo mco -- isReflMCo: avoid calling mk_simple_unf then con_app_unf -- twice in the common case - else mk_simple_unf (mkCastMCo con_app mco) + else mk_simple_unf (mkCastMCo con_app (mkSymMCo mco)) | otherwise = env1 ===================================== compiler/GHC/Core/Opt/Simplify/Utils.hs ===================================== @@ -2693,7 +2693,7 @@ mkCase, mkCase1, mkCase2, mkCase3 mkCase mode scrut outer_bndr alts_ty alts | sm_case_merge mode - , Just (joins, alts') <- mergeCaseAlts outer_bndr alts + , Just (joins, alts') <- mergeCaseAlts scrut outer_bndr alts = do { tick (CaseMerge outer_bndr) ; case_expr <- mkCase1 mode scrut outer_bndr alts_ty alts' ; return (mkLets joins case_expr) } ===================================== compiler/GHC/Core/Opt/SpecConstr.hs ===================================== @@ -29,7 +29,6 @@ import GHC.Core.Opt.Simplify.Inline import GHC.Core.FVs ( exprsFreeVarsList, exprFreeVars ) import GHC.Core.Opt.Monad import GHC.Core.Opt.WorkWrap.Utils -import GHC.Core.Opt.OccurAnal( BinderSwapDecision(..), scrutOkForBinderSwap ) import GHC.Core.DataCon import GHC.Core.Class( classTyVars ) import GHC.Core.Coercion hiding( substCo ) ===================================== compiler/GHC/Core/Subst.hs ===================================== @@ -380,8 +380,10 @@ substIdBndr _doc rec_subst subst@(Subst in_scope env tvs cvs) old_id old_ty = idType old_id old_w = idMult old_id - no_type_change = (isEmptyVarEnv tvs && isEmptyVarEnv cvs) || + no_type_change = isEmptyTCvSubst subst || (noFreeVarsOfType old_ty && noFreeVarsOfType old_w) + -- isEmptyTCvSubst: see Note [Keeping the substitution empty] + -- in GHC.Core.TyCo.Subst -- new_id has the right IdInfo -- The lazy-set is because we're in a loop here, with ===================================== compiler/GHC/Core/TyCo/Subst.hs ===================================== @@ -960,7 +960,8 @@ substTyVarBndrUsing subst_fn subst@(Subst in_scope idenv tenv cenv) old_var -- Assertion check that we are not capturing something in the substitution old_ki = tyVarKind old_var - no_kind_change = noFreeVarsOfType old_ki -- verify that kind is closed + no_kind_change = isEmptyTCvSubst subst || noFreeVarsOfType old_ki + -- isEmptyTCvSubst: see Note [Keeping the substitution empty] no_change = no_kind_change && (new_var == old_var) -- no_change means that the new_var is identical in -- all respects to the old_var (same unique, same kind) @@ -988,7 +989,8 @@ substCoVarBndrUsing subst_fn subst@(Subst in_scope idenv tenv cenv) old_var (Subst (in_scope `extendInScopeSet` new_var) idenv tenv new_cenv, new_var) where new_co = mkCoVarCo new_var - no_kind_change = noFreeVarsOfTypes [t1, t2] + no_kind_change = isEmptyTCvSubst subst || noFreeVarsOfTypes [t1, t2] + -- isEmptyTCvSubst: see Note [Keeping the substitution empty] no_change = new_var == old_var && no_kind_change new_cenv | no_change = delVarEnv cenv old_var @@ -1034,3 +1036,22 @@ substTyCoBndr subst (Anon ty af) = (subst, Anon (substScaledTy subst ty substTyCoBndr subst (Named (Bndr tv vis)) = (subst', Named (Bndr tv' vis)) where (subst', tv') = substVarBndr subst tv + +{- Note [Keeping the substitution empty] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A very common situation is where we run over a term doing no cloning, +no substitution, nothing. In that case the TCvSubst will be empty, and +it is /very/ valuable to /keep/ it empty: + +* It's wasted effort to build up an identity substitution mapping + [x:->x, y:->y]. + +* When we come to a binder, if the incoming substitution is empty, + we can avoid substituting its type; and that in turn may mean that + the binder itself does not change and we don't need to extend the + substitution. + +* In the Simplifier we substitute over both types and coercions. + If the substitution is empty, this is a no-op -- but only if it + is empty! +-} ===================================== compiler/GHC/Core/Utils.hs ===================================== @@ -19,6 +19,7 @@ module GHC.Core.Utils ( mergeAlts, mergeCaseAlts, trimConArgs, filterAlts, combineIdenticalAlts, refineDefaultAlt, scaleAltsBy, + BinderSwapDecision(..), scrutOkForBinderSwap, -- * Properties of expressions exprType, coreAltType, coreAltsType, @@ -72,7 +73,7 @@ import GHC.Platform import GHC.Core import GHC.Core.Ppr -import GHC.Core.FVs( bindFreeVars ) +import GHC.Core.FVs( exprFreeVars, bindFreeVars ) import GHC.Core.DataCon import GHC.Core.Type as Type import GHC.Core.Predicate( isEqPred ) @@ -112,11 +113,11 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc +import Control.Monad ( guard ) import Data.ByteString ( ByteString ) import Data.Function ( on ) import Data.List ( sort, sortBy, partition, zipWith4, mapAccumL ) import Data.Ord ( comparing ) -import Control.Monad ( guard ) import qualified Data.Set as Set {- @@ -590,6 +591,28 @@ The default alternative must be first, if it exists at all. This makes it easy to find, though it makes matching marginally harder. -} +data BinderSwapDecision + = NoBinderSwap + | DoBinderSwap OutVar MCoercion + +scrutOkForBinderSwap :: OutExpr -> BinderSwapDecision +-- If (scrutOkForBinderSwap e = DoBinderSwap v mco, then +-- e = v |> mco +-- See Note [Case of cast] +-- See Historical Note [Care with binder-swap on dictionaries] +-- +-- We use this same function in SpecConstr, and Simplify.Iteration, +-- when something binder-swap-like is happening +-- +-- See Note [Binder swap] in GHC.Core.Opt.OccurAnal +scrutOkForBinderSwap e + = case e of + Tick _ e -> scrutOkForBinderSwap e -- Drop ticks + Var v -> DoBinderSwap v MRefl + Cast (Var v) co -> DoBinderSwap v (MCo co) + -- Cast: see Note [Case of cast] + _ -> NoBinderSwap + -- | Extract the default case alternative findDefault :: [Alt b] -> ([Alt b], Maybe (Expr b)) findDefault (Alt DEFAULT args rhs : alts) = assert (null args) (alts, Just rhs) @@ -651,11 +674,12 @@ filters down the matching alternatives in GHC.Core.Opt.Simplify.rebuildCase. -} --------------------------------- -mergeCaseAlts :: Id -> [CoreAlt] -> Maybe ([CoreBind], [CoreAlt]) +mergeCaseAlts :: CoreExpr -> Id -> [CoreAlt] -> Maybe ([CoreBind], [CoreAlt]) -- See Note [Merge Nested Cases] -mergeCaseAlts outer_bndr (Alt DEFAULT _ deflt_rhs : outer_alts) +mergeCaseAlts scrut outer_bndr (Alt DEFAULT _ deflt_rhs : outer_alts) | Just (joins, inner_alts) <- go deflt_rhs - = Just (joins, mergeAlts outer_alts inner_alts) + , Just aux_binds <- mk_aux_binds joins + = Just ( aux_binds ++ joins, mergeAlts outer_alts inner_alts ) -- NB: mergeAlts gives priority to the left -- case x of -- A -> e1 @@ -665,6 +689,20 @@ mergeCaseAlts outer_bndr (Alt DEFAULT _ deflt_rhs : outer_alts) -- When we merge, we must ensure that e1 takes -- precedence over e2 as the value for A! where + scrut_fvs = exprFreeVars scrut + + -- See Note [Floating join points out of DEFAULT alternatives] + mk_aux_binds join_binds + | not (any mentions_outer_bndr join_binds) + = Just [] -- Good! No auxiliary bindings needed + | exprIsTrivial scrut + , not (outer_bndr `elemVarSet` scrut_fvs) + = Just [NonRec outer_bndr scrut] -- Need a fixup binding + | otherwise + = Nothing -- Can't do it + + mentions_outer_bndr bind = outer_bndr `elemVarSet` bindFreeVars bind + go :: CoreExpr -> Maybe ([CoreBind], [CoreAlt]) -- Whizzo: we can merge! @@ -702,11 +740,10 @@ mergeCaseAlts outer_bndr (Alt DEFAULT _ deflt_rhs : outer_alts) = do { (joins, alts) <- go body -- Check for capture; but only if we could otherwise do a merge - ; let capture = outer_bndr `elem` bindersOf bind - || outer_bndr `elemVarSet` bindFreeVars bind - ; guard (not capture) + -- (i.e. the recursive `go` succeeds) + ; guard (okToFloatJoin scrut_fvs outer_bndr bind) - ; return (bind:joins, alts ) } + ; return (bind : joins, alts ) } | otherwise = Nothing @@ -718,7 +755,18 @@ mergeCaseAlts outer_bndr (Alt DEFAULT _ deflt_rhs : outer_alts) go _ = Nothing -mergeCaseAlts _ _ = Nothing +mergeCaseAlts _ _ _ = Nothing + +okToFloatJoin :: VarSet -> Id -> CoreBind -> Bool +-- Check a join-point binding to see if it can be floated out of +-- the DEFAULT branch of a `case`. +-- See Note [Floating join points out of DEFAULT alternatives] +okToFloatJoin scrut_fvs outer_bndr bind + = not (any bad_bndr (bindersOf bind)) + where + bad_bndr bndr = bndr == outer_bndr -- (a) + || bndr `elemVarSet` scrut_fvs -- (b) + --------------------------------- mergeAlts :: [Alt a] -> [Alt a] -> [Alt a] @@ -927,10 +975,46 @@ Wrinkles non-join-points unless the /outer/ case has just one alternative; doing so would risk more allocation + Floating out join points isn't entirely straightforward. + See Note [Floating join points out of DEFAULT alternatives] + (MC5) See Note [Cascading case merge] See also Note [Example of case-merging and caseRules] in GHC.Core.Opt.Simplify.Utils +Note [Floating join points out of DEFAULT alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this, from (MC4) of Note [Merge Nested Cases] + case x of r + DEFAULT -> join j = rhs in case r of ... + alts + +We want to float that join point out to give this + join j = rhs + case x of r + DEFAULT -> case r of ... + alts + +But doing so is flat-out wrong if the scoping gets messed up: + (a) case x of r { DEFAULT -> join r = ... in ...r... } + (b) case j of r { DEFAULT -> join j = ... in ... } + (c) case x of r { DEFAULT -> join j = ...r.. in ... } +In all these cases we can't float the join point out because r changes its +meaning. For (a) and (b) the Simplifier removes shadowing, so they'll +be solved in the next iteration. But case (c) will persist. + +Happily, we can fix up case (c) by adding an auxiliary binding, like this + let r = e in + join j = rhs[r] + case e of r + DEFAULT -> ...r... + ...other alts... + +We can only do this if + * We don't introduce shadowing: that is `j` and `r` do not appear free in `e`. + (Again the Simplifier will eliminate such shadowing.) + * The scrutinee `e` is trivial so that the transformation doesn't duplicate work. + Note [Cascading case merge] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/Tc/Instance/Family.hs ===================================== @@ -5,7 +5,7 @@ module GHC.Tc.Instance.Family ( FamInstEnvs, tcGetFamInstEnvs, checkFamInstConsistency, tcExtendLocalFamInstEnv, tcLookupDataFamInst, tcLookupDataFamInst_maybe, - tcTopNormaliseNewTypeTF_maybe, + tcUnwrapNewtype_maybe, -- * Injectivity reportInjectivityErrors, reportConflictingInjectivityErrs @@ -46,7 +46,6 @@ import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.FV -import GHC.Data.Bag( Bag, unionBags, unitBag ) import GHC.Data.Maybe import Control.Monad @@ -452,16 +451,16 @@ tcLookupDataFamInst_maybe fam_inst_envs tc tc_args | otherwise = Nothing --- | 'tcTopNormaliseNewTypeTF_maybe' gets rid of top-level newtypes, --- potentially looking through newtype /instances/ and type synonyms. +-- | 'tcUnwrapNewtype_mabye' gets rid of top-level newtypes, +-- potentially also looking through newtype /instances/ -- -- It is only used by the type inference engine (specifically, when -- solving representational equality), and hence it is careful to unwrap -- only if the relevant data constructor is in scope. That's why -- it gets a GlobalRdrEnv argument. -- --- It is careful not to unwrap data/newtype instances nor synonyms --- if it can't continue unwrapping. Such care is necessary for proper +-- It is careful not to unwrap data/newtype instances if it can't +-- unwrap the newtype inside it. Such care is necessary for proper -- error messages. -- -- It does not look through type families. @@ -471,39 +470,35 @@ tcLookupDataFamInst_maybe fam_inst_envs tc tc_args -- co : ty ~R rep_ty -- gres are the GREs for the data constructors that -- had to be in scope -tcTopNormaliseNewTypeTF_maybe :: FamInstEnvs - -> GlobalRdrEnv - -> Type - -> Maybe ((Bag GlobalRdrElt, TcCoercion), Type) -tcTopNormaliseNewTypeTF_maybe faminsts rdr_env ty --- cf. FamInstEnv.topNormaliseType_maybe and Coercion.topNormaliseNewType_maybe - = topNormaliseTypeX stepper plus ty +tcUnwrapNewtype_maybe :: FamInstEnvs + -> GlobalRdrEnv + -> Type + -> Maybe (GlobalRdrElt, TcCoercion, Type) +tcUnwrapNewtype_maybe faminsts rdr_env ty + | Just (tc,tys) <- tcSplitTyConApp_maybe ty + = try_fam_unwrap tc tys + | otherwise + = Nothing where - plus :: (Bag GlobalRdrElt, TcCoercion) -> (Bag GlobalRdrElt, TcCoercion) - -> (Bag GlobalRdrElt, TcCoercion) - plus (gres1, co1) (gres2, co2) = ( gres1 `unionBags` gres2 - , co1 `mkTransCo` co2 ) - - stepper :: NormaliseStepper (Bag GlobalRdrElt, TcCoercion) - stepper = unwrap_newtype `composeSteppers` unwrap_newtype_instance - - -- For newtype instances we take a double step or nothing, so that + -- For newtype /instances/ we take a double step or nothing, so that -- we don't return the representation type of the newtype instance, -- which would lead to terrible error messages - unwrap_newtype_instance rec_nts tc tys - | Just (tc', tys', co) <- tcLookupDataFamInst_maybe faminsts tc tys - = fmap (mkTransCo co) <$> unwrap_newtype rec_nts tc' tys' - | otherwise = NS_Done + try_fam_unwrap tc tys + | Just (tc', tys', fam_co) <- tcLookupDataFamInst_maybe faminsts tc tys + , Just (gre, nt_co, ty') <- try_nt_unwrap tc' tys' + = Just (gre, mkTransCo fam_co nt_co, ty') + | otherwise + = try_nt_unwrap tc tys - unwrap_newtype rec_nts tc tys + try_nt_unwrap tc tys | Just con <- newTyConDataCon_maybe tc , Just gre <- lookupGRE_Name rdr_env (dataConName con) -- This is where we check that the -- data constructor is in scope - = (,) (unitBag gre) <$> unwrapNewTypeStepper rec_nts tc tys - + , Just (ty', co) <- instNewTyCon_maybe tc tys + = Just (gre, co, ty') | otherwise - = NS_Done + = Nothing {- ************************************************************************ ===================================== compiler/GHC/Tc/Solver/Equality.hs ===================================== @@ -23,7 +23,7 @@ import GHC.Tc.Types.CtLoc import GHC.Tc.Types.Origin import GHC.Tc.Utils.Unify import GHC.Tc.Utils.TcType -import GHC.Tc.Instance.Family ( tcTopNormaliseNewTypeTF_maybe ) +import GHC.Tc.Instance.Family ( tcUnwrapNewtype_maybe ) import qualified GHC.Tc.Utils.Monad as TcM import GHC.Core.Type @@ -48,7 +48,6 @@ import GHC.Utils.Misc import GHC.Utils.Monad import GHC.Data.Pair -import GHC.Data.Bag import Control.Monad import Data.Maybe ( isJust, isNothing ) import Data.List ( zip4 ) @@ -334,24 +333,46 @@ can_eq_nc rewritten rdr_env envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2 | Just ty1' <- coreView ty1 = can_eq_nc rewritten rdr_env envs ev eq_rel ty1' ps_ty1 ty2 ps_ty2 | Just ty2' <- coreView ty2 = can_eq_nc rewritten rdr_env envs ev eq_rel ty1 ps_ty1 ty2' ps_ty2 --- need to check for reflexivity in the ReprEq case. --- See Note [Eager reflexivity check] --- Check only when rewritten because the zonk_eq_types check in canEqNC takes --- care of the non-rewritten case. -can_eq_nc True _rdr_env _envs ev ReprEq ty1 _ ty2 _ - | ty1 `tcEqType` ty2 - = canEqReflexive ev ReprEq ty1 - -- When working with ReprEq, unwrap newtypes. +-- See Note [Eager reflexivity check] -- See Note [Unwrap newtypes first] -- This must be above the TyVarTy case, in order to guarantee (TyEq:N) +-- +-- We unwrap *one layer only*; `can_eq_newtype_nc` then loops back to +-- `can_eq_nc`. If there is a recursive newtype, so that we keep +-- unwrapping, the depth limit in `can_eq_newtype_nc` will blow up. +can_eq_nc _rewritten _rdr_env _envs ev eq_rel ty1 _ ty2 _ + | ReprEq <- eq_rel + , TyConApp tc1 tys1 <- ty1 + , TyConApp tc2 tys2 <- ty2 + , tc1 == tc2 + , ok tys1 tys2 (tyConRoles tc1) + = canDecomposableTyConAppOK ev eq_rel tc1 (ty1,tys1) (ty2,tys2) + where + ok :: [TcType] -> [TcType] -> [Role] -> Bool + -- OK to decompose a representational equality + -- if the args are already equal (see Note [Eager reflexivity check]) + -- or are phantom role + -- You might think that representational role would be OK but T9117: + -- newtype Phant a = MkPhant Char + -- type role Phant representational + -- [W] Phant Int ~R# Phant Char + -- We do not want to decompose to Int ~R# Char; better to unwrap + ok (ty1:tys1) (ty2:tys2) (r:rs) + | Phantom <- r = ok tys1 tys2 rs + | ty1 `tcEqType` ty2 = ok tys1 tys2 rs + | otherwise = False + ok [] [] _ = True + ok _ _ [] = False -- Oversaturated TyCon + ok _ _ _ = pprPanic "can_eq_nc:mismatch" (ppr ty1 $$ ppr ty2) + can_eq_nc _rewritten rdr_env envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2 | ReprEq <- eq_rel - , Just stuff1 <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty1 + , Just stuff1 <- tcUnwrapNewtype_maybe envs rdr_env ty1 = can_eq_newtype_nc rdr_env envs ev NotSwapped stuff1 ty2 ps_ty2 | ReprEq <- eq_rel - , Just stuff2 <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty2 + , Just stuff2 <- tcUnwrapNewtype_maybe envs rdr_env ty2 = can_eq_newtype_nc rdr_env envs ev IsSwapped stuff2 ty1 ps_ty1 -- Then, get rid of casts @@ -374,6 +395,11 @@ can_eq_nc _rewritten _rdr_env _envs ev eq_rel ty1@(LitTy l1) _ (LitTy l2) _ = do { setEqIfWanted ev (mkReflCPH eq_rel ty1) ; stopWith ev "Equal LitTy" } +can_eq_nc _rewritten _rdr_env _envs ev eq_rel + s1@ForAllTy{} _ + s2@ForAllTy{} _ + = can_eq_nc_forall ev eq_rel s1 s2 + -- Decompose FunTy: (s -> t) and (c => t) -- NB: don't decompose (Int -> blah) ~ (Show a => blah) can_eq_nc _rewritten _rdr_env _envs ev eq_rel @@ -401,19 +427,18 @@ can_eq_nc rewritten _rdr_env _envs ev eq_rel ty1 _ ty2 _ , rewritten || both_generative = canTyConApp ev eq_rel both_generative (ty1,tc1,tys1) (ty2,tc2,tys2) -can_eq_nc _rewritten _rdr_env _envs ev eq_rel - s1@ForAllTy{} _ - s2@ForAllTy{} _ - = can_eq_nc_forall ev eq_rel s1 s2 - --- See Note [Canonicalising type applications] about why we require rewritten types --- Use tcSplitAppTy, not matching on AppTy, to catch oversaturated type families --- NB: Only decompose AppTy for nominal equality. --- See Note [Decomposing AppTy equalities] -can_eq_nc True _rdr_env _envs ev NomEq ty1 _ ty2 _ - | Just (t1, s1) <- tcSplitAppTy_maybe ty1 +-- Decompose applications +can_eq_nc rewritten _rdr_env _envs ev eq_rel ty1 _ ty2 _ + | True <- rewritten -- Why True? See Note [Canonicalising type applications] + -- Use tcSplitAppTy, not matching on AppTy, to catch oversaturated type families + , Just (t1, s1) <- tcSplitAppTy_maybe ty1 , Just (t2, s2) <- tcSplitAppTy_maybe ty2 - = can_eq_app ev t1 s1 t2 s2 + = case eq_rel of + NomEq -> can_eq_app ev t1 s1 t2 s2 + -- Only decompose AppTy for nominal equality. + -- See Note [Decomposing AppTy equalities] + ReprEq | ty1 `tcEqType` ty2 -> canEqReflexive ev ReprEq ty1 + | otherwise -> finishCanWithIrred ReprEqReason ev ------------------- -- Can't decompose. @@ -776,13 +801,13 @@ though, because we check our depth in `can_eq_newtype_nc`. can_eq_newtype_nc :: GlobalRdrEnv -> FamInstEnvs -> CtEvidence -- ^ :: ty1 ~ ty2 -> SwapFlag - -> ((Bag GlobalRdrElt, TcCoercion), TcType) -- ^ :: ty1 ~ ty1' + -> (GlobalRdrElt, TcCoercion, TcType) -- ^ :: ty1 ~ ty1' -> TcType -- ^ ty2 -> TcType -- ^ ty2, with type synonyms -> TcS (StopOrContinue (Either IrredCt EqCt)) -can_eq_newtype_nc rdr_env envs ev swapped ((gres, co1), ty1') ty2 ps_ty2 +can_eq_newtype_nc rdr_env envs ev swapped (gre, co1, ty1') ty2 ps_ty2 = do { traceTcS "can_eq_newtype_nc" $ - vcat [ ppr ev, ppr swapped, ppr co1, ppr gres, ppr ty1', ppr ty2 ] + vcat [ ppr ev, ppr swapped, ppr co1, ppr gre, ppr ty1', ppr ty2 ] -- Check for blowing our stack, and increase the depth -- See Note [Newtypes can blow the stack] @@ -791,14 +816,19 @@ can_eq_newtype_nc rdr_env envs ev swapped ((gres, co1), ty1') ty2 ps_ty2 -- Next, we record uses of newtype constructors, since coercing -- through newtypes is tantamount to using their constructors. - ; recordUsedGREs gres + ; recordUsedGRE gre ; let redn1 = mkReduction co1 ty1' redn2 = mkReflRedn Representational ps_ty2 - ; new_ev <- rewriteEqEvidence ev' swapped redn1 redn2 + ; new_ev <- rewriteEqEvidence ev' (flipSwap swapped) redn2 redn1 emptyCoHoleSet - ; can_eq_nc False rdr_env envs new_ev ReprEq ty1' ty1' ty2 ps_ty2 } + -- ty1 is the one being unwrapped. Loop back to can_eq_nc with + -- the arguments flipped so that ty2 is looked at first in the + -- next iteration. That way if we have (Id Rec) ~R# (Id Rec) + -- where newtype Id a = MkId a and newtype Rec = MkRec Rec + -- we'll unwrap both Ids, then spot Rec=Rec. + ; can_eq_nc False rdr_env envs new_ev ReprEq ty2 ps_ty2 ty1' ty1' } --------- -- ^ Decompose a type application. @@ -896,7 +926,7 @@ canTyConApp ev eq_rel both_generative (ty1,tc1,tys1) (ty2,tc2,tys2) | tc1 == tc2 , tys1 `equalLength` tys2 = do { inerts <- getInertSet - ; if can_decompose inerts + ; if canDecomposeTcApp ev eq_rel tc1 inerts then canDecomposableTyConAppOK ev eq_rel tc1 (ty1,tys1) (ty2,tys2) else assert (eq_rel == ReprEq) $ canEqSoftFailure ReprEqReason ev ty1 ty2 } @@ -918,19 +948,25 @@ canTyConApp ev eq_rel both_generative (ty1,tc1,tys1) (ty2,tc2,tys2) | otherwise = canEqSoftFailure ReprEqReason ev ty1 ty2 - where + + +canDecomposeTcApp :: CtEvidence -> EqRel -> TyCon -> InertSet -> Bool -- See Note [Decomposing TyConApp equalities] -- and Note [Decomposing newtype equalities] - can_decompose inerts - = isInjectiveTyCon tc1 (eqRelRole eq_rel) - || (assert (eq_rel == ReprEq) $ - -- assert: isInjectiveTyCon is always True for Nominal except +canDecomposeTcApp ev eq_rel tc inerts + | isInjectiveTyCon tc eq_role = True + | isGiven ev = False + | otherwise = assert (eq_rel == ReprEq) $ + assert (isNewTyCon tc || isDataFamilyTyCon tc) $ + noGivenNewtypeReprEqs tc inerts + -- assert: isInjectiveTyCon is always True for eq_rel=NomEq except -- for type synonyms/families, neither of which happen here - -- Moreover isInjectiveTyCon is True for Representational - -- for algebraic data types. So we are down to newtypes - -- and data families. - ctEvFlavour ev == Wanted && noGivenNewtypeReprEqs tc1 inerts) - -- See Note [Decomposing newtype equalities] (EX2) + -- assert: isInjectiveTyCon is True for Representational for algebraic + -- data types. So we are down to newtypes and data families. + -- noGivenNewtypeReprEqs: see Note [Decomposing newtype equalities] (EX3) + -- Decomposing here is a last resort + where + eq_role = eqRelRole eq_rel {- Note [Canonicalising TyCon/TyCon equalities] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -945,7 +981,7 @@ Suppose we are canonicalising [W] Int ~R# DF (TF a). Then (TC1) We might have an inert Given (a ~# Char), so if we rewrote the wanted (i.e. went around again in `can_eq_nc` with `rewritten`=True, we'd get [W] Int ~R# DF Bool - and then the `tcTopNormaliseNewTypeTF_maybe` call would fire and + and then the `tcUnwrapNewtype_maybe` call would fire and we'd unwrap the newtype. So we must do that "go round again" bit. Hence the complicated guard (rewritten || both_generative) in `can_eq_nc`. @@ -1154,15 +1190,16 @@ There are two ways in which decomposing (N ty1) ~r (N ty2) could be incomplete: data instance D Int = MkD1 (D Char) data instance D Bool = MkD2 (D Char) Now suppose we have - [W] g1: D Int ~R# D a - [W] g2: a ~# Bool - If we solve g2 first, giving a:=Bool, then we can solve g1 easily: + [W] g1: D Int ~R# D alpha + [W] g2: alpha ~# Bool + If we solve g2 first, giving alpha:=Bool, then we can solve g1 easily: D Int ~R# D Char ~R# D Bool by newtype unwrapping. BUT: if we instead attempt to solve g1 first, we can unwrap the LHS (only) - leaving [W] D Char ~#R D Bool - If we decompose now, we'll get (Char ~R# Bool), which is insoluble. + leaving [W] D Char ~#R D alpha + If we decompose now, we'll get (Char ~R# alpha), which is insoluble, since + alpha turns out to be Bool. CONCLUSION: prioritise nominal equalites in the work list. See Note [Prioritise equalities] in GHC.Tc.Solver.InertSet. ===================================== compiler/GHC/Tc/Solver/Monad.hs ===================================== @@ -22,7 +22,7 @@ module GHC.Tc.Solver.Monad ( updWorkListTcS, pushLevelNoWorkList, pushTcLevelM_, - runTcPluginTcS, recordUsedGREs, + runTcPluginTcS, recordUsedGRE, matchGlobalInst, TcM.ClsInstResult(..), QCInst(..), @@ -1519,18 +1519,16 @@ tcLookupTyCon n = wrapTcS $ TcM.tcLookupTyCon n -- pure veneer of TcS. But it's just about warnings around unused imports -- and local constructors (GHC will issue fewer warnings than it otherwise -- might), so it's not worth losing sleep over. -recordUsedGREs :: Bag GlobalRdrElt -> TcS () -recordUsedGREs gres - = do { wrapTcS $ TcM.addUsedGREs NoDeprecationWarnings gre_list +recordUsedGRE :: GlobalRdrElt -> TcS () +recordUsedGRE gre + = do { wrapTcS $ TcM.addUsedGRE NoDeprecationWarnings gre -- If a newtype constructor was imported, don't warn about not -- importing it... - ; wrapTcS $ traverse_ (TcM.keepAlive . greName) gre_list } + ; wrapTcS $ TcM.keepAlive (greName gre) } -- ...and similarly, if a newtype constructor was defined in the same -- module, don't warn about it being unused. -- See Note [Tracking unused binding and imports] in GHC.Tc.Utils. - where - gre_list = bagToList gres -- Various smaller utilities [TODO, maybe will be absorbed in the instance matcher] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== hadrian/src/Settings/Builders/Hsc2Hs.hs ===================================== @@ -34,13 +34,6 @@ hsc2hsBuilderArgs = builder Hsc2Hs ? do , notStage0 ? arg ("--cflag=-D" ++ tOs ++ "_HOST_OS=1" ) , arg $ "--cflag=-D__GLASGOW_HASKELL__=" ++ version , arg $ "--template=" ++ tmpl - -- We'll assume we compile with gcc or clang, and both support - -- `-S` and can as such use the --via-asm flag, which should be - -- faster and is required for cross compiling to windows, as the c - -- compiler complains about non-constant expressions even though - -- they are constant and end up as constants in the assembly. - -- See #12849 - , flag CrossCompiling ? isWinTarget ? arg "--via-asm" , arg =<< getInput , arg "-o", arg =<< getOutput ] ===================================== testsuite/tests/pmcheck/should_compile/T24867.hs ===================================== @@ -0,0 +1,17 @@ +{-# LANGUAGE DataKinds, TypeFamilies, GADTs #-} +{-# OPTIONS_GHC -Winaccessible-code -Werror #-} + +module T24867 where + +data T = Z | S + +data ST n where + SS :: ST S + +type family F n where + F Z = Z + F S = Z + +-- Should be rejected with inaccessible RHS +f :: F m ~ n => ST m -> ST n -> () +f _ SS = () ===================================== testsuite/tests/pmcheck/should_compile/T24867.stderr ===================================== @@ -0,0 +1,4 @@ +T24867.hs:17:1: error: [GHC-94210] [-Woverlapping-patterns (in -Wdefault), Werror=overlapping-patterns] + Pattern match has inaccessible right hand side + In an equation for ‘f’: f _ SS = ... + ===================================== testsuite/tests/pmcheck/should_compile/all.T ===================================== @@ -181,3 +181,4 @@ test('T25257', normal, compile, [overlapping_incomplete]) test('T24845', [], compile, [overlapping_incomplete]) test('T22652', [], compile, [overlapping_incomplete]) test('T22652a', [], compile, [overlapping_incomplete]) +test('T24867', [], compile_fail, [overlapping_incomplete]) ===================================== testsuite/tests/simplCore/should_compile/T26709.hs ===================================== @@ -0,0 +1,11 @@ +module T26709 where + +data T = A | B | C + +f x = case x of + A -> True + _ -> let {-# NOINLINE j #-} + j y = y && not (f x) + in case x of + B -> j True + C -> j False ===================================== testsuite/tests/simplCore/should_compile/T26709.stderr ===================================== @@ -0,0 +1,32 @@ +[1 of 1] Compiling T26709 ( T26709.hs, T26709.o ) + +==================== Tidy Core ==================== +Result size of Tidy Core + = {terms: 26, types: 9, coercions: 0, joins: 1/1} + +Rec { +-- RHS size: {terms: 25, types: 7, coercions: 0, joins: 1/1} +f [Occ=LoopBreaker] :: T -> Bool +[GblId, Arity=1, Str=<SL>, Unf=OtherCon []] +f = \ (x :: T) -> + join { + j [InlPrag=NOINLINE, Dmd=MC(1,L)] :: Bool -> Bool + [LclId[JoinId(1)(Just [!])], Arity=1, Str=<1L>, Unf=OtherCon []] + j (eta [OS=OneShot] :: Bool) + = case eta of { + False -> GHC.Internal.Types.False; + True -> + case f x of { + False -> GHC.Internal.Types.True; + True -> GHC.Internal.Types.False + } + } } in + case x of { + A -> GHC.Internal.Types.True; + B -> jump j GHC.Internal.Types.True; + C -> jump j GHC.Internal.Types.False + } +end Rec } + + + ===================================== testsuite/tests/simplCore/should_compile/all.T ===================================== @@ -564,3 +564,9 @@ test('T26116', normal, compile, ['-O -ddump-rules']) test('T26117', [grep_errmsg(r'==')], compile, ['-O -ddump-simpl -dsuppress-uniques']) test('T26349', normal, compile, ['-O -ddump-rules']) test('T26681', normal, compile, ['-O']) + +# T26709: we expect three `case` expressions not four +test('T26709', [grep_errmsg(r'case')], + multimod_compile, + ['T26709', '-O -ddump-simpl -dsuppress-uniques -dno-typeable-binds']) + ===================================== testsuite/tests/typecheck/should_compile/T26746.hs ===================================== @@ -0,0 +1,33 @@ +module T26746 where + +import Data.Coerce + +newtype Foo a = Foo (Foo a) +newtype Age = MkAge Int + +ex1 :: (Foo Age) -> (Foo Int) +ex1 = coerce + +newtype Womble a = MkWomble (Foo a) + +ex2 :: Womble (Foo Age) -> (Foo Int) +ex2 = coerce + +ex3 :: (Foo Age) -> Womble (Foo Int) +ex3 = coerce + + +-- Surprisingly this one works: +newtype Z1 = MkZ1 Z2 +newtype Z2 = MKZ2 Z1 + +ex4 :: Z1 -> Z2 +ex4 = coerce + +-- But this one does not (commented out) +-- newtype Y1 = MkY1 Y2 +-- newtype Y2 = MKY2 Y3 +-- newtype Y3 = MKY3 Y1 +-- +-- ex5 :: Y1 -> Y3 +-- ex5 = coerce ===================================== testsuite/tests/typecheck/should_compile/all.T ===================================== @@ -957,3 +957,4 @@ test('T17705', normal, compile, ['']) test('T14745', normal, compile, ['']) test('T26451', normal, compile, ['']) test('T26582', normal, compile, ['']) +test('T26746', normal, compile, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5657cef9aa4f898eb089e0ca60b4782... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5657cef9aa4f898eb089e0ca60b4782... You're receiving this email because of your account on gitlab.haskell.org.