Simon Peyton Jones pushed to branch wip/T26746 at Glasgow Haskell Compiler / GHC

Commits:

21 changed files:

Changes:

  • compiler/GHC/Cmm/Info.hs
    ... ... @@ -28,7 +28,7 @@ module GHC.Cmm.Info (
    28 28 
       conInfoTableSizeB,
    29 29 
       stdSrtBitmapOffset,
    30 30 
       stdClosureTypeOffset,
    31 
    -  stdPtrsOffset, stdNonPtrsOffset,
    31 
    +  stdPtrsOffset, stdNonPtrsOffset
    32 32 
     ) where
    33 33
    34 34 
     import GHC.Prelude
    ... ... @@ -194,7 +194,7 @@ mkInfoTableContents profile
    194 194 
            ; let (srt_label, srt_bitmap) = mkSRTLit platform info_lbl srt
    195 195 
            ; (liveness_lit, liveness_data) <- mkLivenessBits platform frame
    196 196 
            ; let
    197 
    -             std_info = mkStdInfoTable profile prof_lits rts_tag srt_bitmap liveness_lit
    197 
    +             std_info = mkStdInfoTable profile prof_lits rts_tag srt_bitmap [liveness_lit]
    198 198 
                  rts_tag | Just tag <- mb_rts_tag = tag
    199 199 
                          | null liveness_data     = rET_SMALL -- Fits in extra_bits
    200 200 
                          | otherwise              = rET_BIG   -- Does not; extra_bits is
    ... ... @@ -202,7 +202,8 @@ mkInfoTableContents profile
    202 202 
            ; return (prof_data ++ liveness_data, (std_info, srt_label)) }
    203 203
    204 204 
       | HeapRep _ ptrs nonptrs closure_type <- smrep
    205 
    -  = do { let layout  = packIntsCLit platform ptrs nonptrs
    205 
    +  = do { let layout  = [ mkStgHalfWordCLit platform ptrs,
    206 
    +                         mkStgHalfWordCLit platform nonptrs]
    206 207 
            ; (prof_lits, prof_data) <- mkProfLits platform prof
    207 208 
            ; let (srt_label, srt_bitmap) = mkSRTLit platform info_lbl srt
    208 209 
            ; (mb_srt_field, mb_layout, extra_bits, ct_data)
    ... ... @@ -214,11 +215,23 @@ mkInfoTableContents profile
    214 215 
            ; return (prof_data ++ ct_data, (std_info, extra_bits)) }
    215 216 
       where
    216 217 
         platform = profilePlatform profile
    218 
    +    mk_extra_bits :: Int -> Int -> [CmmLit]
    219 
    +    mk_extra_bits low high
    220 
    +      = if platformTablesNextToCode platform
    221 
    +           -- In mkInfoTable do_one_info extra bits are reversed for TNTC
    222 
    +           -- so we must generate the high address halfword before
    223 
    +           -- the low address halfword.
    224 
    +        then [ mkStgHalfWordCLit platform high
    225 
    +             , mkStgHalfWordCLit platform low
    226 
    +             ]
    227 
    +        else [ mkStgHalfWordCLit platform low
    228 
    +             , mkStgHalfWordCLit platform high
    229 
    +             ]
    217 230 
         mk_pieces :: ClosureTypeInfo -> [CmmLit]
    218 
    -              -> UniqDSM ( Maybe CmmLit  -- Override the SRT field with this
    219 
    -                         , Maybe CmmLit  -- Override the layout field with this
    220 
    -                         , [CmmLit]           -- "Extra bits" for info table
    221 
    -                         , [RawCmmDecl])      -- Auxiliary data decls
    231 
    +              -> UniqDSM ( Maybe CmmLit   -- Override the SRT field with this
    232 
    +                         , Maybe [CmmLit] -- Override the layout field with this
    233 
    +                         , [CmmLit]       -- "Extra bits" for info table
    234 
    +                         , [RawCmmDecl])  -- Auxiliary data decls
    222 235 
         mk_pieces (Constr con_tag con_descr) _no_srt    -- A data constructor
    223 236 
           = do { (descr_lit, decl) <- newStringLit con_descr
    224 237 
                ; return ( Just (CmmInt (fromIntegral con_tag)
    ... ... @@ -230,18 +243,19 @@ mkInfoTableContents profile
    230 243
    231 244 
         mk_pieces (ThunkSelector offset) _no_srt
    232 245 
           = return (Just (CmmInt 0 (halfWordWidth platform)),
    233 
    -                Just (mkWordCLit platform (fromIntegral offset)), [], [])
    246 
    +                Just [(mkWordCLit platform (fromIntegral offset))], [], [])
    234 247 
              -- Layout known (one free var); we use the layout field for offset
    235 248
    236 249 
         mk_pieces (Fun arity (ArgSpec fun_type)) srt_label
    237 
    -      = do { let extra_bits = packIntsCLit platform fun_type arity : srt_label
    250 
    +      = do { let extra_bits = mk_extra_bits fun_type arity
    251 
    +                           ++ srt_label
    238 252 
                ; return (Nothing, Nothing,  extra_bits, []) }
    239 253
    240 254 
         mk_pieces (Fun arity (ArgGen arg_bits)) srt_label
    241 255 
           = do { (liveness_lit, liveness_data) <- mkLivenessBits platform arg_bits
    242 256 
                ; let fun_type | null liveness_data = aRG_GEN
    243 257 
                               | otherwise          = aRG_GEN_BIG
    244 
    -                 extra_bits = [ packIntsCLit platform fun_type arity ]
    258 
    +                 extra_bits = mk_extra_bits fun_type arity
    245 259 
                                ++ (if inlineSRT platform then [] else [ srt_lit ])
    246 260 
                                ++ [ liveness_lit, slow_entry ]
    247 261 
                ; return (Nothing, Nothing, extra_bits, liveness_data) }
    ... ... @@ -255,11 +269,13 @@ mkInfoTableContents profile
    255 269
    256 270 
     mkInfoTableContents _ _ _ = panic "mkInfoTableContents"   -- NonInfoTable dealt with earlier
    257 271
    258 
    -packIntsCLit :: Platform -> Int -> Int -> CmmLit
    259 
    -packIntsCLit platform a b = packHalfWordsCLit platform
    260 
    -                           (toStgHalfWord platform (fromIntegral a))
    261 
    -                           (toStgHalfWord platform (fromIntegral b))
    272 
    +mkStgWordCLit :: Platform -> StgWord -> CmmLit
    273 
    +mkStgWordCLit platform wd = CmmInt (fromStgWord wd) (wordWidth platform)
    262 274
    275 
    +mkStgHalfWordCLit :: Platform -> Int -> CmmLit
    276 
    +mkStgHalfWordCLit platform hwd
    277 
    +  = CmmInt (fromStgHalfWord (toStgHalfWord platform (fromIntegral hwd)))
    278 
    +           (halfWordWidth platform)
    263 279
    264 280 
     mkSRTLit :: Platform
    265 281 
              -> CLabel
    ... ... @@ -385,15 +401,15 @@ mkStdInfoTable
    385 401 
        -> (CmmLit,CmmLit)   -- Closure type descr and closure descr  (profiling)
    386 402 
        -> Int               -- Closure RTS tag
    387 403 
        -> CmmLit            -- SRT length
    388 
    -   -> CmmLit            -- layout field
    404 
    +   -> [CmmLit]          -- layout field
    389 405 
        -> [CmmLit]
    390 406
    391 
    -mkStdInfoTable profile (type_descr, closure_descr) cl_type srt layout_lit
    407 
    +mkStdInfoTable profile (type_descr, closure_descr) cl_type srt layout_lits
    392 408 
      =      -- Parallel revertible-black hole field
    393 409 
         prof_info
    394 410 
             -- Ticky info (none at present)
    395 411 
             -- Debug info (none at present)
    396 
    - ++ [layout_lit, tag, srt]
    412 
    + ++ layout_lits ++ [tag, srt]
    397 413
    398 414 
      where
    399 415 
         platform = profilePlatform profile

  • compiler/GHC/Cmm/Utils.hs
    ... ... @@ -13,10 +13,9 @@ module GHC.Cmm.Utils(
    13 13
    14 14 
             -- CmmLit
    15 15 
             zeroCLit, mkIntCLit,
    16 
    -        mkWordCLit, packHalfWordsCLit,
    16 
    +        mkWordCLit,
    17 17 
             mkByteStringCLit, mkFileEmbedLit,
    18 18 
             mkDataLits, mkRODataLits,
    19 
    -        mkStgWordCLit,
    20 19
    21 20 
             -- CmmExpr
    22 21 
             mkIntExpr, zeroExpr,
    ... ... @@ -211,22 +210,6 @@ mkRODataLits lbl lits
    211 210 
         needsRelocation (CmmLabelOff _ _) = True
    212 211 
         needsRelocation _                 = False
    213 212
    214 
    -mkStgWordCLit :: Platform -> StgWord -> CmmLit
    215 
    -mkStgWordCLit platform wd = CmmInt (fromStgWord wd) (wordWidth platform)
    216 
    -
    217 
    -packHalfWordsCLit :: Platform -> StgHalfWord -> StgHalfWord -> CmmLit
    218 
    --- Make a single word literal in which the lower_half_word is
    219 
    --- at the lower address, and the upper_half_word is at the
    220 
    --- higher address
    221 
    --- ToDo: consider using half-word lits instead
    222 
    ---       but be careful: that's vulnerable when reversed
    223 
    -packHalfWordsCLit platform lower_half_word upper_half_word
    224 
    -   = case platformByteOrder platform of
    225 
    -       BigEndian    -> mkWordCLit platform ((l `shiftL` halfWordSizeInBits platform) .|. u)
    226 
    -       LittleEndian -> mkWordCLit platform (l .|. (u `shiftL` halfWordSizeInBits platform))
    227 
    -    where l = fromStgHalfWord lower_half_word
    228 
    -          u = fromStgHalfWord upper_half_word
    229 
    -
    230 213 
     ---------------------------------------------------
    231 214 
     --
    232 215 
     --      CmmExpr

  • compiler/GHC/Core/Opt/OccurAnal.hs
    ... ... @@ -28,7 +28,7 @@ core expression with (hopefully) improved usage information.
    28 28 
     module GHC.Core.Opt.OccurAnal (
    29 29 
         occurAnalysePgm,
    30 30 
         occurAnalyseExpr,
    31 
    -    zapLambdaBndrs, BinderSwapDecision(..), scrutOkForBinderSwap
    31 
    +    zapLambdaBndrs
    32 32 
       ) where
    33 33
    34 34 
     import GHC.Prelude hiding ( head, init, last, tail )
    ... ... @@ -36,7 +36,7 @@ import GHC.Prelude hiding ( head, init, last, tail )
    36 36 
     import GHC.Core
    37 37 
     import GHC.Core.FVs
    38 38 
     import GHC.Core.Utils   ( exprIsTrivial, isDefaultAlt, isExpandableApp,
    39 
    -                          mkCastMCo, mkTicks )
    39 
    +                          mkCastMCo, mkTicks, BinderSwapDecision(..), scrutOkForBinderSwap )
    40 40 
     import GHC.Core.Opt.Arity   ( joinRhsArity, isOneShotBndr )
    41 41 
     import GHC.Core.Coercion
    42 42 
     import GHC.Core.Type
    ... ... @@ -3537,6 +3537,7 @@ doesn't use it. So this is only to satisfy the perhaps-over-picky Lint.
    3537 3537 
     -}
    3538 3538
    3539 3539 
     addBndrSwap :: OutExpr -> Id -> OccEnv -> OccEnv
    3540 
    +-- See Note [Binder swap]
    3540 3541 
     -- See Note [The binder-swap substitution]
    3541 3542 
     addBndrSwap scrut case_bndr
    3542 3543 
                 env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = rng_vars })
    ... ... @@ -3544,7 +3545,7 @@ addBndrSwap scrut case_bndr
    3544 3545 
       , scrut_var /= case_bndr
    3545 3546 
           -- Consider: case x of x { ... }
    3546 3547 
           -- Do not add [x :-> x] to occ_bs_env, else lookupBndrSwap will loop
    3547 
    -  = env { occ_bs_env = extendVarEnv swap_env scrut_var (case_bndr', mco)
    3548 
    +  = env { occ_bs_env = extendVarEnv swap_env scrut_var (case_bndr', mkSymMCo mco)
    3548 3549 
             , occ_bs_rng = rng_vars `extendVarSet` case_bndr'
    3549 3550 
                            `unionVarSet` tyCoVarsOfMCo mco }
    3550 3551
    ... ... @@ -3554,27 +3555,6 @@ addBndrSwap scrut case_bndr
    3554 3555 
         case_bndr' = zapIdOccInfo case_bndr
    3555 3556 
                      -- See Note [Zap case binders in proxy bindings]
    3556 3557
    3557 
    --- | See bBinderSwaOk.
    3558 
    -data BinderSwapDecision
    3559 
    -  = NoBinderSwap
    3560 
    -  | DoBinderSwap OutVar MCoercion
    3561 
    -
    3562 
    -scrutOkForBinderSwap :: OutExpr -> BinderSwapDecision
    3563 
    --- If (scrutOkForBinderSwap e = DoBinderSwap v mco, then
    3564 
    ---    v = e |> mco
    3565 
    --- See Note [Case of cast]
    3566 
    --- See Historical Note [Care with binder-swap on dictionaries]
    3567 
    ---
    3568 
    --- We use this same function in SpecConstr, and Simplify.Iteration,
    3569 
    --- when something binder-swap-like is happening
    3570 
    -scrutOkForBinderSwap e
    3571 
    -  = case e of
    3572 
    -      Tick _ e        -> scrutOkForBinderSwap e  -- Drop ticks
    3573 
    -      Var v           -> DoBinderSwap v MRefl
    3574 
    -      Cast (Var v) co -> DoBinderSwap v (MCo (mkSymCo co))
    3575 
    -                         -- Cast: see Note [Case of cast]
    3576 
    -      _               -> NoBinderSwap
    3577 
    -
    3578 3558 
     lookupBndrSwap :: OccEnv -> Id -> (CoreExpr, Id)
    3579 3559 
     -- See Note [The binder-swap substitution]
    3580 3560 
     -- 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 )
    22 22 
     import GHC.Core.Opt.Simplify.Env
    23 23 
     import GHC.Core.Opt.Simplify.Inline
    24 24 
     import GHC.Core.Opt.Simplify.Utils
    25 
    -import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr, zapLambdaBndrs, scrutOkForBinderSwap, BinderSwapDecision (..) )
    25 
    +import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr, zapLambdaBndrs )
    26 26 
     import GHC.Core.Make       ( FloatBind, mkImpossibleExpr, castBottomExpr )
    27 27 
     import qualified GHC.Core.Make
    28 28 
     import GHC.Core.Coercion hiding ( substCo, substCoVar )
    ... ... @@ -3601,11 +3601,13 @@ addAltUnfoldings env case_bndr bndr_swap con_app
    3601 3601 
         env1 = addBinderUnfolding env case_bndr con_app_unf
    3602 3602
    3603 3603 
         -- See Note [Add unfolding for scrutinee]
    3604 
    +    -- e.g. case (x |> co) of K a b -> blah
    3605 
    +    --      We add to `x` the unfolding  (K a b |> sym co)
    3604 3606 
         env2 | DoBinderSwap v mco <- bndr_swap
    3605 3607 
              = addBinderUnfolding env1 v $
    3606 3608 
                   if isReflMCo mco  -- isReflMCo: avoid calling mk_simple_unf
    3607 3609 
                   then con_app_unf  --            twice in the common case
    3608 
    -              else mk_simple_unf (mkCastMCo con_app mco)
    3610 
    +              else mk_simple_unf (mkCastMCo con_app (mkSymMCo mco))
    3609 3611
    3610 3612 
              | otherwise = env1
    3611 3613

  • compiler/GHC/Core/Opt/Simplify/Utils.hs
    ... ... @@ -2693,7 +2693,7 @@ mkCase, mkCase1, mkCase2, mkCase3
    2693 2693
    2694 2694 
     mkCase mode scrut outer_bndr alts_ty alts
    2695 2695 
       | sm_case_merge mode
    2696 
    -  , Just (joins, alts') <- mergeCaseAlts outer_bndr alts
    2696 
    +  , Just (joins, alts') <- mergeCaseAlts scrut outer_bndr alts
    2697 2697 
       = do  { tick (CaseMerge outer_bndr)
    2698 2698 
             ; case_expr <- mkCase1 mode scrut outer_bndr alts_ty alts'
    2699 2699 
             ; return (mkLets joins case_expr) }

  • compiler/GHC/Core/Opt/SpecConstr.hs
    ... ... @@ -29,7 +29,6 @@ import GHC.Core.Opt.Simplify.Inline
    29 29 
     import GHC.Core.FVs     ( exprsFreeVarsList, exprFreeVars )
    30 30 
     import GHC.Core.Opt.Monad
    31 31 
     import GHC.Core.Opt.WorkWrap.Utils
    32 
    -import GHC.Core.Opt.OccurAnal( BinderSwapDecision(..), scrutOkForBinderSwap )
    33 32 
     import GHC.Core.DataCon
    34 33 
     import GHC.Core.Class( classTyVars )
    35 34 
     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
    380 380
    381 381 
         old_ty = idType old_id
    382 382 
         old_w = idMult old_id
    383 
    -    no_type_change = (isEmptyVarEnv tvs && isEmptyVarEnv cvs) ||
    383 
    +    no_type_change = isEmptyTCvSubst subst ||
    384 384 
                          (noFreeVarsOfType old_ty && noFreeVarsOfType old_w)
    385 
    +                     -- isEmptyTCvSubst: see Note [Keeping the substitution empty]
    386 
    +                     --                  in GHC.Core.TyCo.Subst
    385 387
    386 388 
             -- new_id has the right IdInfo
    387 389 
             -- 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
    960 960 
         -- Assertion check that we are not capturing something in the substitution
    961 961
    962 962 
         old_ki = tyVarKind old_var
    963 
    -    no_kind_change = noFreeVarsOfType old_ki -- verify that kind is closed
    963 
    +    no_kind_change = isEmptyTCvSubst subst || noFreeVarsOfType old_ki
    964 
    +                     -- isEmptyTCvSubst: see Note [Keeping the substitution empty]
    964 965 
         no_change = no_kind_change && (new_var == old_var)
    965 966 
             -- no_change means that the new_var is identical in
    966 967 
             -- 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
    988 989 
         (Subst (in_scope `extendInScopeSet` new_var) idenv tenv new_cenv, new_var)
    989 990 
       where
    990 991 
         new_co         = mkCoVarCo new_var
    991 
    -    no_kind_change = noFreeVarsOfTypes [t1, t2]
    992 
    +    no_kind_change = isEmptyTCvSubst subst || noFreeVarsOfTypes [t1, t2]
    993 
    +                     -- isEmptyTCvSubst: see Note [Keeping the substitution empty]
    992 994 
         no_change      = new_var == old_var && no_kind_change
    993 995
    994 996 
         new_cenv | no_change = delVarEnv cenv old_var
    ... ... @@ -1034,3 +1036,22 @@ substTyCoBndr subst (Anon ty af) = (subst, Anon (substScaledTy subst ty
    1034 1036 
     substTyCoBndr subst (Named (Bndr tv vis)) = (subst', Named (Bndr tv' vis))
    1035 1037 
                                               where
    1036 1038 
                                                 (subst', tv') = substVarBndr subst tv
    1039 
    +
    1040 
    +{- Note [Keeping the substitution empty]
    1041 
    +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    1042 
    +A very common situation is where we run over a term doing no cloning,
    1043 
    +no substitution, nothing.  In that case the TCvSubst will be empty, and
    1044 
    +it is /very/ valuable to /keep/ it empty:
    1045 
    +
    1046 
    +* It's wasted effort to build up an identity substitution mapping
    1047 
    +  [x:->x, y:->y].
    1048 
    +
    1049 
    +* When we come to a binder, if the incoming substitution is empty,
    1050 
    +  we can avoid substituting its type; and that in turn may mean that
    1051 
    +  the binder itself does not change and we don't need to extend the
    1052 
    +  substitution.
    1053 
    +
    1054 
    +* In the Simplifier we substitute over both types and coercions.
    1055 
    +  If the substitution is empty, this is a no-op -- but only if it
    1056 
    +  is empty!
    1057 
    +-}

  • compiler/GHC/Core/Utils.hs
    ... ... @@ -19,6 +19,7 @@ module GHC.Core.Utils (
    19 19 
             mergeAlts, mergeCaseAlts, trimConArgs,
    20 20 
             filterAlts, combineIdenticalAlts, refineDefaultAlt,
    21 21 
             scaleAltsBy,
    22 
    +        BinderSwapDecision(..), scrutOkForBinderSwap,
    22 23
    23 24 
             -- * Properties of expressions
    24 25 
             exprType, coreAltType, coreAltsType,
    ... ... @@ -72,7 +73,7 @@ import GHC.Platform
    72 73
    73 74 
     import GHC.Core
    74 75 
     import GHC.Core.Ppr
    75 
    -import GHC.Core.FVs( bindFreeVars )
    76 
    +import GHC.Core.FVs( exprFreeVars, bindFreeVars )
    76 77 
     import GHC.Core.DataCon
    77 78 
     import GHC.Core.Type as Type
    78 79 
     import GHC.Core.Predicate( isEqPred )
    ... ... @@ -112,11 +113,11 @@ import GHC.Utils.Outputable
    112 113 
     import GHC.Utils.Panic
    113 114 
     import GHC.Utils.Misc
    114 115
    116 
    +import Control.Monad       ( guard )
    115 117 
     import Data.ByteString     ( ByteString )
    116 118 
     import Data.Function       ( on )
    117 119 
     import Data.List           ( sort, sortBy, partition, zipWith4, mapAccumL )
    118 120 
     import Data.Ord            ( comparing )
    119 
    -import Control.Monad       ( guard )
    120 121 
     import qualified Data.Set as Set
    121 122
    122 123 
     {-
    ... ... @@ -590,6 +591,28 @@ The default alternative must be first, if it exists at all.
    590 591 
     This makes it easy to find, though it makes matching marginally harder.
    591 592 
     -}
    592 593
    594 
    +data BinderSwapDecision
    595 
    +  = NoBinderSwap
    596 
    +  | DoBinderSwap OutVar MCoercion
    597 
    +
    598 
    +scrutOkForBinderSwap :: OutExpr -> BinderSwapDecision
    599 
    +-- If (scrutOkForBinderSwap e = DoBinderSwap v mco, then
    600 
    +--    e = v |> mco
    601 
    +-- See Note [Case of cast]
    602 
    +-- See Historical Note [Care with binder-swap on dictionaries]
    603 
    +--
    604 
    +-- We use this same function in SpecConstr, and Simplify.Iteration,
    605 
    +-- when something binder-swap-like is happening
    606 
    +--
    607 
    +-- See Note [Binder swap] in GHC.Core.Opt.OccurAnal
    608 
    +scrutOkForBinderSwap e
    609 
    +  = case e of
    610 
    +      Tick _ e        -> scrutOkForBinderSwap e  -- Drop ticks
    611 
    +      Var v           -> DoBinderSwap v MRefl
    612 
    +      Cast (Var v) co -> DoBinderSwap v (MCo co)
    613 
    +                         -- Cast: see Note [Case of cast]
    614 
    +      _               -> NoBinderSwap
    615 
    +
    593 616 
     -- | Extract the default case alternative
    594 617 
     findDefault :: [Alt b] -> ([Alt b], Maybe (Expr b))
    595 618 
     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.
    651 674 
     -}
    652 675
    653 676 
     ---------------------------------
    654 
    -mergeCaseAlts :: Id -> [CoreAlt] -> Maybe ([CoreBind], [CoreAlt])
    677 
    +mergeCaseAlts :: CoreExpr -> Id -> [CoreAlt] -> Maybe ([CoreBind], [CoreAlt])
    655 678 
     -- See Note [Merge Nested Cases]
    656 
    -mergeCaseAlts outer_bndr (Alt DEFAULT _ deflt_rhs : outer_alts)
    679 
    +mergeCaseAlts scrut outer_bndr (Alt DEFAULT _ deflt_rhs : outer_alts)
    657 680 
       | Just (joins, inner_alts) <- go deflt_rhs
    658 
    -  = Just (joins, mergeAlts outer_alts inner_alts)
    681 
    +  , Just aux_binds <- mk_aux_binds joins
    682 
    +  = Just ( aux_binds ++ joins, mergeAlts outer_alts inner_alts )
    659 683 
                     -- NB: mergeAlts gives priority to the left
    660 684 
                     --      case x of
    661 685 
                     --        A -> e1
    ... ... @@ -665,6 +689,20 @@ mergeCaseAlts outer_bndr (Alt DEFAULT _ deflt_rhs : outer_alts)
    665 689 
                     -- When we merge, we must ensure that e1 takes
    666 690 
                     -- precedence over e2 as the value for A!
    667 691 
       where
    692 
    +    scrut_fvs = exprFreeVars scrut
    693 
    +
    694 
    +    -- See Note [Floating join points out of DEFAULT alternatives]
    695 
    +    mk_aux_binds join_binds
    696 
    +      | not (any mentions_outer_bndr join_binds)
    697 
    +      = Just []                         -- Good!  No auxiliary bindings needed
    698 
    +      | exprIsTrivial scrut
    699 
    +      , not (outer_bndr `elemVarSet` scrut_fvs)
    700 
    +      = Just [NonRec outer_bndr scrut]  -- Need a fixup binding
    701 
    +      | otherwise
    702 
    +      = Nothing                         -- Can't do it
    703 
    +
    704 
    +    mentions_outer_bndr bind = outer_bndr `elemVarSet` bindFreeVars bind
    705 
    +
    668 706 
         go :: CoreExpr -> Maybe ([CoreBind], [CoreAlt])
    669 707
    670 708 
         -- Whizzo: we can merge!
    ... ... @@ -702,11 +740,10 @@ mergeCaseAlts outer_bndr (Alt DEFAULT _ deflt_rhs : outer_alts)
    702 740 
           = do { (joins, alts) <- go body
    703 741
    704 742 
                  -- Check for capture; but only if we could otherwise do a merge
    705 
    -           ; let capture = outer_bndr `elem` bindersOf bind
    706 
    -                           || outer_bndr `elemVarSet` bindFreeVars bind
    707 
    -           ; guard (not capture)
    743 
    +             --    (i.e. the recursive `go` succeeds)
    744 
    +           ; guard (okToFloatJoin scrut_fvs outer_bndr bind)
    708 745
    709 
    -           ; return (bind:joins, alts ) }
    746 
    +           ; return (bind : joins, alts ) }
    710 747 
           | otherwise
    711 748 
           = Nothing
    712 749
    ... ... @@ -718,7 +755,18 @@ mergeCaseAlts outer_bndr (Alt DEFAULT _ deflt_rhs : outer_alts)
    718 755
    719 756 
         go _ = Nothing
    720 757
    721 
    -mergeCaseAlts _ _ = Nothing
    758 
    +mergeCaseAlts _ _ _ = Nothing
    759 
    +
    760 
    +okToFloatJoin :: VarSet -> Id -> CoreBind -> Bool
    761 
    +-- Check a join-point binding to see if it can be floated out of
    762 
    +-- the DEFAULT branch of a `case`.
    763 
    +-- See Note [Floating join points out of DEFAULT alternatives]
    764 
    +okToFloatJoin scrut_fvs outer_bndr bind
    765 
    +  = not (any bad_bndr (bindersOf bind))
    766 
    +  where
    767 
    +    bad_bndr bndr = bndr == outer_bndr              -- (a)
    768 
    +                    || bndr `elemVarSet` scrut_fvs  -- (b)
    769 
    +
    722 770
    723 771 
     ---------------------------------
    724 772 
     mergeAlts :: [Alt a] -> [Alt a] -> [Alt a]
    ... ... @@ -927,10 +975,46 @@ Wrinkles
    927 975 
           non-join-points unless the /outer/ case has just one alternative; doing
    928 976 
           so would risk more allocation
    929 977
    978 
    +      Floating out join points isn't entirely straightforward.
    979 
    +      See Note [Floating join points out of DEFAULT alternatives]
    980 
    +
    930 981 
     (MC5) See Note [Cascading case merge]
    931 982
    932 983 
     See also Note [Example of case-merging and caseRules] in GHC.Core.Opt.Simplify.Utils
    933 984
    985 
    +Note [Floating join points out of DEFAULT alternatives]
    986 
    +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    987 
    +Consider this, from (MC4) of Note [Merge Nested Cases]
    988 
    +   case x of r
    989 
    +     DEFAULT -> join j = rhs in case r of ...
    990 
    +     alts
    991 
    +
    992 
    +We want to float that join point out to give this
    993 
    +   join j = rhs
    994 
    +   case x of r
    995 
    +     DEFAULT -> case r of ...
    996 
    +     alts
    997 
    +
    998 
    +But doing so is flat-out wrong if the scoping gets messed up:
    999 
    +    (a) case x of r { DEFAULT -> join r = ... in ...r... }
    1000 
    +    (b) case j of r { DEFAULT -> join j = ... in ... }
    1001 
    +    (c) case x of r { DEFAULT -> join j = ...r.. in ... }
    1002 
    +In all these cases we can't float the join point out because r changes its
    1003 
    +meaning.  For (a) and (b) the Simplifier removes shadowing, so they'll
    1004 
    +be solved in the next iteration.  But case (c) will persist.
    1005 
    +
    1006 
    +Happily, we can fix up case (c) by adding an auxiliary binding, like this
    1007 
    +    let r = e in
    1008 
    +    join j = rhs[r]
    1009 
    +    case e of r
    1010 
    +       DEFAULT -> ...r...
    1011 
    +       ...other alts...
    1012 
    +
    1013 
    +We can only do this if
    1014 
    +  * We don't introduce shadowing: that is `j` and `r` do not appear free in `e`.
    1015 
    +    (Again the Simplifier will eliminate such shadowing.)
    1016 
    +  * The scrutinee `e` is trivial so that the transformation doesn't duplicate work.
    1017 
    +
    934 1018
    935 1019 
     Note [Cascading case merge]
    936 1020 
     ~~~~~~~~~~~~~~~~~~~~~~~~~~~

  • compiler/GHC/Tc/Instance/Family.hs
    ... ... @@ -5,7 +5,7 @@ module GHC.Tc.Instance.Family (
    5 5 
             FamInstEnvs, tcGetFamInstEnvs,
    6 6 
             checkFamInstConsistency, tcExtendLocalFamInstEnv,
    7 7 
             tcLookupDataFamInst, tcLookupDataFamInst_maybe,
    8 
    -        tcTopNormaliseNewTypeTF_maybe,
    8 
    +        tcUnwrapNewtype_maybe,
    9 9
    10 10 
             -- * Injectivity
    11 11 
             reportInjectivityErrors, reportConflictingInjectivityErrs
    ... ... @@ -46,7 +46,6 @@ import GHC.Utils.Misc
    46 46 
     import GHC.Utils.Panic
    47 47 
     import GHC.Utils.FV
    48 48
    49 
    -import GHC.Data.Bag( Bag, unionBags, unitBag )
    50 49 
     import GHC.Data.Maybe
    51 50
    52 51 
     import Control.Monad
    ... ... @@ -452,16 +451,16 @@ tcLookupDataFamInst_maybe fam_inst_envs tc tc_args
    452 451 
       | otherwise
    453 452 
       = Nothing
    454 453
    455 
    --- | 'tcTopNormaliseNewTypeTF_maybe' gets rid of top-level newtypes,
    456 
    --- potentially looking through newtype /instances/ and type synonyms.
    454 
    +-- | 'tcUnwrapNewtype_mabye' gets rid of top-level newtypes,
    455 
    +-- potentially also looking through newtype /instances/
    457 456 
     --
    458 457 
     -- It is only used by the type inference engine (specifically, when
    459 458 
     -- solving representational equality), and hence it is careful to unwrap
    460 459 
     -- only if the relevant data constructor is in scope.  That's why
    461 460 
     -- it gets a GlobalRdrEnv argument.
    462 461 
     --
    463 
    --- It is careful not to unwrap data/newtype instances nor synonyms
    464 
    --- if it can't continue unwrapping.  Such care is necessary for proper
    462 
    +-- It is careful not to unwrap data/newtype instances if it can't
    463 
    +-- unwrap the newtype inside it.  Such care is necessary for proper
    465 464 
     -- error messages.
    466 465 
     --
    467 466 
     -- It does not look through type families.
    ... ... @@ -471,39 +470,35 @@ tcLookupDataFamInst_maybe fam_inst_envs tc tc_args
    471 470 
     --    co : ty ~R rep_ty
    472 471 
     --    gres are the GREs for the data constructors that
    473 472 
     --                          had to be in scope
    474 
    -tcTopNormaliseNewTypeTF_maybe :: FamInstEnvs
    475 
    -                              -> GlobalRdrEnv
    476 
    -                              -> Type
    477 
    -                              -> Maybe ((Bag GlobalRdrElt, TcCoercion), Type)
    478 
    -tcTopNormaliseNewTypeTF_maybe faminsts rdr_env ty
    479 
    --- cf. FamInstEnv.topNormaliseType_maybe and Coercion.topNormaliseNewType_maybe
    480 
    -  = topNormaliseTypeX stepper plus ty
    473 
    +tcUnwrapNewtype_maybe :: FamInstEnvs
    474 
    +                      -> GlobalRdrEnv
    475 
    +                      -> Type
    476 
    +                      -> Maybe (GlobalRdrElt, TcCoercion, Type)
    477 
    +tcUnwrapNewtype_maybe faminsts rdr_env ty
    478 
    +  | Just (tc,tys) <- tcSplitTyConApp_maybe ty
    479 
    +  = try_fam_unwrap tc tys
    480 
    +  | otherwise
    481 
    +  = Nothing
    481 482 
       where
    482 
    -    plus :: (Bag GlobalRdrElt, TcCoercion) -> (Bag GlobalRdrElt, TcCoercion)
    483 
    -         -> (Bag GlobalRdrElt, TcCoercion)
    484 
    -    plus (gres1, co1) (gres2, co2) = ( gres1 `unionBags` gres2
    485 
    -                                     , co1 `mkTransCo` co2 )
    486 
    -
    487 
    -    stepper :: NormaliseStepper (Bag GlobalRdrElt, TcCoercion)
    488 
    -    stepper = unwrap_newtype `composeSteppers` unwrap_newtype_instance
    489 
    -
    490 
    -    -- For newtype instances we take a double step or nothing, so that
    483 
    +    -- For newtype /instances/ we take a double step or nothing, so that
    491 484 
         -- we don't return the representation type of the newtype instance,
    492 485 
         -- which would lead to terrible error messages
    493 
    -    unwrap_newtype_instance rec_nts tc tys
    494 
    -      | Just (tc', tys', co) <- tcLookupDataFamInst_maybe faminsts tc tys
    495 
    -      = fmap (mkTransCo co) <$> unwrap_newtype rec_nts tc' tys'
    496 
    -      | otherwise = NS_Done
    486 
    +    try_fam_unwrap tc tys
    487 
    +      | Just (tc', tys', fam_co) <- tcLookupDataFamInst_maybe faminsts tc tys
    488 
    +      , Just (gre, nt_co, ty') <- try_nt_unwrap tc' tys'
    489 
    +      = Just (gre, mkTransCo fam_co nt_co, ty')
    490 
    +      | otherwise
    491 
    +      = try_nt_unwrap tc tys
    497 492
    498 
    -    unwrap_newtype rec_nts tc tys
    493 
    +    try_nt_unwrap tc tys
    499 494 
           | Just con <- newTyConDataCon_maybe tc
    500 495 
           , Just gre <- lookupGRE_Name rdr_env (dataConName con)
    501 496 
                -- This is where we check that the
    502 497 
                -- data constructor is in scope
    503 
    -      = (,) (unitBag gre) <$> unwrapNewTypeStepper rec_nts tc tys
    504 
    -
    498 
    +      , Just (ty', co) <- instNewTyCon_maybe tc tys
    499 
    +      = Just (gre, co, ty')
    505 500 
           | otherwise
    506 
    -      = NS_Done
    501 
    +      = Nothing
    507 502
    508 503 
     {-
    509 504 
     ************************************************************************

  • compiler/GHC/Tc/Solver/Equality.hs
    ... ... @@ -23,7 +23,7 @@ import GHC.Tc.Types.CtLoc
    23 23 
     import GHC.Tc.Types.Origin
    24 24 
     import GHC.Tc.Utils.Unify
    25 25 
     import GHC.Tc.Utils.TcType
    26 
    -import GHC.Tc.Instance.Family ( tcTopNormaliseNewTypeTF_maybe )
    26 
    +import GHC.Tc.Instance.Family ( tcUnwrapNewtype_maybe )
    27 27 
     import qualified GHC.Tc.Utils.Monad    as TcM
    28 28
    29 29 
     import GHC.Core.Type
    ... ... @@ -48,7 +48,6 @@ import GHC.Utils.Misc
    48 48 
     import GHC.Utils.Monad
    49 49
    50 50 
     import GHC.Data.Pair
    51 
    -import GHC.Data.Bag
    52 51 
     import Control.Monad
    53 52 
     import Data.Maybe ( isJust, isNothing )
    54 53 
     import Data.List  ( zip4 )
    ... ... @@ -334,24 +333,46 @@ can_eq_nc rewritten rdr_env envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2
    334 333 
       | Just ty1' <- coreView ty1 = can_eq_nc rewritten rdr_env envs ev eq_rel ty1' ps_ty1 ty2  ps_ty2
    335 334 
       | Just ty2' <- coreView ty2 = can_eq_nc rewritten rdr_env envs ev eq_rel ty1  ps_ty1 ty2' ps_ty2
    336 335
    337 
    --- need to check for reflexivity in the ReprEq case.
    338 
    --- See Note [Eager reflexivity check]
    339 
    --- Check only when rewritten because the zonk_eq_types check in canEqNC takes
    340 
    --- care of the non-rewritten case.
    341 
    -can_eq_nc True _rdr_env _envs ev ReprEq ty1 _ ty2 _
    342 
    -  | ty1 `tcEqType` ty2
    343 
    -  = canEqReflexive ev ReprEq ty1
    344 
    -
    345 336 
     -- When working with ReprEq, unwrap newtypes.
    337 
    +-- See Note [Eager reflexivity check]
    346 338 
     -- See Note [Unwrap newtypes first]
    347 339 
     -- This must be above the TyVarTy case, in order to guarantee (TyEq:N)
    340 
    +--
    341 
    +-- We unwrap *one layer only*; `can_eq_newtype_nc` then loops back to
    342 
    +-- `can_eq_nc`.  If there is a recursive newtype, so that we keep
    343 
    +-- unwrapping, the depth limit in `can_eq_newtype_nc` will blow up.
    344 
    +can_eq_nc _rewritten _rdr_env _envs ev eq_rel ty1 _ ty2 _
    345 
    +  | ReprEq <- eq_rel
    346 
    +  , TyConApp tc1 tys1 <- ty1
    347 
    +  , TyConApp tc2 tys2 <- ty2
    348 
    +  , tc1 == tc2
    349 
    +  , ok tys1 tys2 (tyConRoles tc1)
    350 
    +  = canDecomposableTyConAppOK ev eq_rel tc1 (ty1,tys1) (ty2,tys2)
    351 
    +  where
    352 
    +    ok :: [TcType] -> [TcType] -> [Role] -> Bool
    353 
    +    -- OK to decompose a representational equality
    354 
    +    --   if the args are already equal (see Note [Eager reflexivity check])
    355 
    +    --   or are phantom role
    356 
    +    -- You might think that representational role would be OK but T9117:
    357 
    +    --    newtype Phant a = MkPhant Char
    358 
    +    --    type role Phant representational
    359 
    +    --    [W] Phant Int ~R# Phant Char
    360 
    +    --    We do not want to decompose to Int ~R# Char; better to unwrap
    361 
    +    ok (ty1:tys1) (ty2:tys2) (r:rs)
    362 
    +      | Phantom <- r       = ok tys1 tys2 rs
    363 
    +      | ty1 `tcEqType` ty2 = ok tys1 tys2 rs
    364 
    +      | otherwise          = False
    365 
    +    ok [] [] _  = True
    366 
    +    ok _  _  [] = False  -- Oversaturated TyCon
    367 
    +    ok _  _  _  = pprPanic "can_eq_nc:mismatch" (ppr ty1 $$ ppr ty2)
    368 
    +
    348 369 
     can_eq_nc _rewritten rdr_env envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2
    349 370 
       | ReprEq <- eq_rel
    350 
    -  , Just stuff1 <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty1
    371 
    +  , Just stuff1 <- tcUnwrapNewtype_maybe envs rdr_env ty1
    351 372 
       = can_eq_newtype_nc rdr_env envs ev NotSwapped stuff1 ty2 ps_ty2
    352 373
    353 374 
       | ReprEq <- eq_rel
    354 
    -  , Just stuff2 <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty2
    375 
    +  , Just stuff2 <- tcUnwrapNewtype_maybe envs rdr_env ty2
    355 376 
       = can_eq_newtype_nc rdr_env envs ev IsSwapped stuff2 ty1 ps_ty1
    356 377
    357 378 
     -- Then, get rid of casts
    ... ... @@ -374,6 +395,11 @@ can_eq_nc _rewritten _rdr_env _envs ev eq_rel ty1@(LitTy l1) _ (LitTy l2) _
    374 395 
       = do { setEqIfWanted ev (mkReflCPH eq_rel ty1)
    375 396 
            ; stopWith ev "Equal LitTy" }
    376 397
    398 
    +can_eq_nc _rewritten _rdr_env _envs ev eq_rel
    399 
    +           s1@ForAllTy{} _
    400 
    +           s2@ForAllTy{} _
    401 
    +  = can_eq_nc_forall ev eq_rel s1 s2
    402 
    +
    377 403 
     -- Decompose FunTy: (s -> t) and (c => t)
    378 404 
     -- NB: don't decompose (Int -> blah) ~ (Show a => blah)
    379 405 
     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 _
    401 427 
       , rewritten || both_generative
    402 428 
       = canTyConApp ev eq_rel both_generative (ty1,tc1,tys1) (ty2,tc2,tys2)
    403 429
    404 
    -can_eq_nc _rewritten _rdr_env _envs ev eq_rel
    405 
    -           s1@ForAllTy{} _
    406 
    -           s2@ForAllTy{} _
    407 
    -  = can_eq_nc_forall ev eq_rel s1 s2
    408 
    -
    409 
    --- See Note [Canonicalising type applications] about why we require rewritten types
    410 
    --- Use tcSplitAppTy, not matching on AppTy, to catch oversaturated type families
    411 
    --- NB: Only decompose AppTy for nominal equality.
    412 
    ---     See Note [Decomposing AppTy equalities]
    413 
    -can_eq_nc True _rdr_env _envs ev NomEq ty1 _ ty2 _
    414 
    -  | Just (t1, s1) <- tcSplitAppTy_maybe ty1
    430 
    +-- Decompose applications
    431 
    +can_eq_nc rewritten _rdr_env _envs ev eq_rel ty1 _ ty2 _
    432 
    +  | True <- rewritten -- Why True?  See Note [Canonicalising type applications]
    433 
    +  -- Use tcSplitAppTy, not matching on AppTy, to catch oversaturated type families
    434 
    +  , Just (t1, s1) <- tcSplitAppTy_maybe ty1
    415 435 
       , Just (t2, s2) <- tcSplitAppTy_maybe ty2
    416 
    -  = can_eq_app ev t1 s1 t2 s2
    436 
    +  = case eq_rel of
    437 
    +       NomEq  -> can_eq_app ev t1 s1 t2 s2
    438 
    +                 -- Only decompose AppTy for nominal equality.
    439 
    +                 -- See Note [Decomposing AppTy equalities]
    440 
    +       ReprEq | ty1 `tcEqType` ty2 -> canEqReflexive ev ReprEq ty1
    441 
    +              | otherwise          -> finishCanWithIrred ReprEqReason ev
    417 442
    418 443 
     -------------------
    419 444 
     -- Can't decompose.
    ... ... @@ -776,13 +801,13 @@ though, because we check our depth in `can_eq_newtype_nc`.
    776 801 
     can_eq_newtype_nc :: GlobalRdrEnv -> FamInstEnvs
    777 802 
                       -> CtEvidence           -- ^ :: ty1 ~ ty2
    778 803 
                       -> SwapFlag
    779 
    -                  -> ((Bag GlobalRdrElt, TcCoercion), TcType)  -- ^ :: ty1 ~ ty1'
    804 
    +                  -> (GlobalRdrElt, TcCoercion, TcType)  -- ^ :: ty1 ~ ty1'
    780 805 
                       -> TcType               -- ^ ty2
    781 806 
                       -> TcType               -- ^ ty2, with type synonyms
    782 807 
                       -> TcS (StopOrContinue (Either IrredCt EqCt))
    783 
    -can_eq_newtype_nc rdr_env envs ev swapped ((gres, co1), ty1') ty2 ps_ty2
    808 
    +can_eq_newtype_nc rdr_env envs ev swapped (gre, co1, ty1') ty2 ps_ty2
    784 809 
       = do { traceTcS "can_eq_newtype_nc" $
    785 
    -         vcat [ ppr ev, ppr swapped, ppr co1, ppr gres, ppr ty1', ppr ty2 ]
    810 
    +         vcat [ ppr ev, ppr swapped, ppr co1, ppr gre, ppr ty1', ppr ty2 ]
    786 811
    787 812 
              -- Check for blowing our stack, and increase the depth
    788 813 
              -- 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
    791 816
    792 817 
              -- Next, we record uses of newtype constructors, since coercing
    793 818 
              -- through newtypes is tantamount to using their constructors.
    794 
    -       ; recordUsedGREs gres
    819 
    +       ; recordUsedGRE gre
    795 820
    796 821 
            ; let redn1 = mkReduction co1 ty1'
    797 822 
                  redn2 = mkReflRedn Representational ps_ty2
    798 
    -       ; new_ev <- rewriteEqEvidence ev' swapped redn1 redn2
    823 
    +       ; new_ev <- rewriteEqEvidence ev' (flipSwap swapped) redn2 redn1
    799 824 
                                          emptyCoHoleSet
    800 825
    801 
    -       ; can_eq_nc False rdr_env envs new_ev ReprEq ty1' ty1' ty2 ps_ty2 }
    826 
    +       -- ty1 is the one being unwrapped. Loop back to can_eq_nc with
    827 
    +       -- the arguments flipped so that ty2 is looked at first in the
    828 
    +       -- next iteration.  That way if we have (Id Rec) ~R# (Id Rec)
    829 
    +       -- where newtype Id a = MkId a  and newtype Rec = MkRec Rec
    830 
    +       -- we'll unwrap both Ids, then spot Rec=Rec.
    831 
    +       ; can_eq_nc False rdr_env envs new_ev ReprEq ty2 ps_ty2 ty1' ty1' }
    802 832
    803 833 
     ---------
    804 834 
     -- ^ Decompose a type application.
    ... ... @@ -896,7 +926,7 @@ canTyConApp ev eq_rel both_generative (ty1,tc1,tys1) (ty2,tc2,tys2)
    896 926 
       | tc1 == tc2
    897 927 
       , tys1 `equalLength` tys2
    898 928 
       = do { inerts <- getInertSet
    899 
    -       ; if can_decompose inerts
    929 
    +       ; if canDecomposeTcApp ev eq_rel tc1 inerts
    900 930 
              then canDecomposableTyConAppOK ev eq_rel tc1 (ty1,tys1) (ty2,tys2)
    901 931 
              else assert (eq_rel == ReprEq) $
    902 932 
                   canEqSoftFailure ReprEqReason ev ty1 ty2 }
    ... ... @@ -918,19 +948,25 @@ canTyConApp ev eq_rel both_generative (ty1,tc1,tys1) (ty2,tc2,tys2)
    918 948
    919 949 
       | otherwise
    920 950 
       = canEqSoftFailure ReprEqReason ev ty1 ty2
    921 
    -  where
    951 
    +
    952 
    +
    953 
    +canDecomposeTcApp :: CtEvidence -> EqRel -> TyCon -> InertSet -> Bool
    922 954 
          -- See Note [Decomposing TyConApp equalities]
    923 955 
          -- and Note [Decomposing newtype equalities]
    924 
    -    can_decompose inerts
    925 
    -      =  isInjectiveTyCon tc1 (eqRelRole eq_rel)
    926 
    -      || (assert (eq_rel == ReprEq) $
    927 
    -          -- assert: isInjectiveTyCon is always True for Nominal except
    956 
    +canDecomposeTcApp ev eq_rel tc inerts
    957 
    +  | isInjectiveTyCon tc eq_role = True
    958 
    +  | isGiven ev                  = False
    959 
    +  | otherwise                   = assert (eq_rel == ReprEq) $
    960 
    +                                  assert (isNewTyCon tc || isDataFamilyTyCon tc) $
    961 
    +                                  noGivenNewtypeReprEqs tc inerts
    962 
    +          -- assert: isInjectiveTyCon is always True for eq_rel=NomEq except
    928 963 
               --   for type synonyms/families, neither of which happen here
    929 
    -          -- Moreover isInjectiveTyCon is True for Representational
    930 
    -          --   for algebraic data types.  So we are down to newtypes
    931 
    -          --   and data families.
    932 
    -          ctEvFlavour ev == Wanted && noGivenNewtypeReprEqs tc1 inerts)
    933 
    -             -- See Note [Decomposing newtype equalities] (EX2)
    964 
    +          -- assert: isInjectiveTyCon is True for Representational for algebraic
    965 
    +          --   data types.  So we are down to newtypes and data families.
    966 
    +          -- noGivenNewtypeReprEqs: see Note [Decomposing newtype equalities] (EX3)
    967 
    +          --    Decomposing here is a last resort
    968 
    +  where
    969 
    +    eq_role = eqRelRole eq_rel
    934 970
    935 971 
     {- Note [Canonicalising TyCon/TyCon equalities]
    936 972 
     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ... ... @@ -945,7 +981,7 @@ Suppose we are canonicalising [W] Int ~R# DF (TF a). Then
    945 981 
     (TC1) We might have an inert Given (a ~# Char), so if we rewrote the wanted
    946 982 
           (i.e. went around again in `can_eq_nc` with `rewritten`=True, we'd get
    947 983 
              [W] Int ~R# DF Bool
    948 
    -      and then the `tcTopNormaliseNewTypeTF_maybe` call would fire and
    984 
    +      and then the `tcUnwrapNewtype_maybe` call would fire and
    949 985 
           we'd unwrap the newtype.  So we must do that "go round again" bit.
    950 986 
           Hence the complicated guard (rewritten || both_generative) in `can_eq_nc`.
    951 987
    ... ... @@ -1154,15 +1190,16 @@ There are two ways in which decomposing (N ty1) ~r (N ty2) could be incomplete:
    1154 1190 
           data instance D Int  = MkD1 (D Char)
    1155 1191 
           data instance D Bool = MkD2 (D Char)
    1156 1192 
       Now suppose we have
    1157 
    -      [W] g1: D Int ~R# D a
    1158 
    -      [W] g2: a ~# Bool
    1159 
    -  If we solve g2 first, giving a:=Bool, then we can solve g1 easily:
    1193 
    +      [W] g1: D Int ~R# D alpha
    1194 
    +      [W] g2: alpha ~# Bool
    1195 
    +  If we solve g2 first, giving alpha:=Bool, then we can solve g1 easily:
    1160 1196 
           D Int ~R# D Char ~R# D Bool
    1161 1197 
       by newtype unwrapping.
    1162 1198
    1163 1199 
       BUT: if we instead attempt to solve g1 first, we can unwrap the LHS (only)
    1164 
    -  leaving     [W] D Char ~#R D Bool
    1165 
    -  If we decompose now, we'll get (Char ~R# Bool), which is insoluble.
    1200 
    +  leaving     [W] D Char ~#R D alpha
    1201 
    +  If we decompose now, we'll get (Char ~R# alpha), which is insoluble, since
    1202 
    +  alpha turns out to be Bool.
    1166 1203
    1167 1204 
       CONCLUSION: prioritise nominal equalites in the work list.
    1168 1205 
       See Note [Prioritise equalities] in GHC.Tc.Solver.InertSet.

  • compiler/GHC/Tc/Solver/Monad.hs
    ... ... @@ -22,7 +22,7 @@ module GHC.Tc.Solver.Monad (
    22 22 
         updWorkListTcS,
    23 23 
         pushLevelNoWorkList, pushTcLevelM_,
    24 24
    25 
    -    runTcPluginTcS, recordUsedGREs,
    25 
    +    runTcPluginTcS, recordUsedGRE,
    26 26 
         matchGlobalInst, TcM.ClsInstResult(..),
    27 27
    28 28 
         QCInst(..),
    ... ... @@ -1519,18 +1519,16 @@ tcLookupTyCon n = wrapTcS $ TcM.tcLookupTyCon n
    1519 1519 
     -- pure veneer of TcS. But it's just about warnings around unused imports
    1520 1520 
     -- and local constructors (GHC will issue fewer warnings than it otherwise
    1521 1521 
     -- might), so it's not worth losing sleep over.
    1522 
    -recordUsedGREs :: Bag GlobalRdrElt -> TcS ()
    1523 
    -recordUsedGREs gres
    1524 
    -  = do { wrapTcS $ TcM.addUsedGREs NoDeprecationWarnings gre_list
    1522 
    +recordUsedGRE :: GlobalRdrElt -> TcS ()
    1523 
    +recordUsedGRE gre
    1524 
    +  = do { wrapTcS $ TcM.addUsedGRE NoDeprecationWarnings gre
    1525 1525 
              -- If a newtype constructor was imported, don't warn about not
    1526 1526 
              -- importing it...
    1527 
    -       ; wrapTcS $ traverse_ (TcM.keepAlive . greName) gre_list }
    1527 
    +       ; wrapTcS $ TcM.keepAlive (greName gre) }
    1528 1528 
              -- ...and similarly, if a newtype constructor was defined in the same
    1529 1529 
              -- module, don't warn about it being unused.
    1530 1530 
              -- See Note [Tracking unused binding and imports] in GHC.Tc.Utils.
    1531 1531
    1532 
    -  where
    1533 
    -    gre_list = bagToList gres
    1534 1532
    1535 1533 
     -- Various smaller utilities [TODO, maybe will be absorbed in the instance matcher]
    1536 1534 
     -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

  • hadrian/src/Settings/Builders/Hsc2Hs.hs
    ... ... @@ -34,13 +34,6 @@ hsc2hsBuilderArgs = builder Hsc2Hs ? do
    34 34 
                 , notStage0 ? arg ("--cflag=-D" ++ tOs   ++ "_HOST_OS=1"  )
    35 35 
                 , arg $ "--cflag=-D__GLASGOW_HASKELL__=" ++ version
    36 36 
                 , arg $ "--template=" ++ tmpl
    37 
    -              -- We'll assume we compile with gcc or clang, and both support
    38 
    -              -- `-S` and can as such use the --via-asm flag, which should be
    39 
    -              -- faster and is required for cross compiling to windows, as the c
    40 
    -              -- compiler complains about non-constant expressions even though
    41 
    -              -- they are constant and end up as constants in the assembly.
    42 
    -              -- See #12849
    43 
    -            , flag CrossCompiling ? isWinTarget ? arg "--via-asm"
    44 37 
                 , arg =<< getInput
    45 38 
                 , arg "-o", arg =<< getOutput ]
    46 39

  • testsuite/tests/pmcheck/should_compile/T24867.hs
    1 
    +{-# LANGUAGE DataKinds, TypeFamilies, GADTs #-}
    2 
    +{-# OPTIONS_GHC -Winaccessible-code -Werror #-}
    3 
    +
    4 
    +module T24867 where
    5 
    +
    6 
    +data T = Z | S
    7 
    +
    8 
    +data ST n where
    9 
    +  SS :: ST S
    10 
    +
    11 
    +type family F n where
    12 
    +  F Z = Z
    13 
    +  F S = Z
    14 
    +
    15 
    +-- Should be rejected with inaccessible RHS
    16 
    +f :: F m ~ n => ST m -> ST n -> ()
    17 
    +f _ SS = ()

  • testsuite/tests/pmcheck/should_compile/T24867.stderr
    1 
    +T24867.hs:17:1: error: [GHC-94210] [-Woverlapping-patterns (in -Wdefault), Werror=overlapping-patterns]
    2 
    +    Pattern match has inaccessible right hand side
    3 
    +    In an equation for ‘f’: f _ SS = ...
    4 
    +

  • testsuite/tests/pmcheck/should_compile/all.T
    ... ... @@ -181,3 +181,4 @@ test('T25257', normal, compile, [overlapping_incomplete])
    181 181 
     test('T24845', [], compile, [overlapping_incomplete])
    182 182 
     test('T22652', [], compile, [overlapping_incomplete])
    183 183 
     test('T22652a', [], compile, [overlapping_incomplete])
    184 
    +test('T24867', [], compile_fail, [overlapping_incomplete])

  • testsuite/tests/simplCore/should_compile/T26709.hs
    1 
    +module T26709 where
    2 
    +
    3 
    +data T = A | B | C
    4 
    +
    5 
    +f x = case x of
    6 
    +        A -> True
    7 
    +        _ -> let {-# NOINLINE j #-}
    8 
    +                 j y = y && not (f x)
    9 
    +             in case x of
    10 
    +                   B -> j True
    11 
    +                   C -> j False

  • testsuite/tests/simplCore/should_compile/T26709.stderr
    1 
    +[1 of 1] Compiling T26709           ( T26709.hs, T26709.o )
    2 
    +
    3 
    +==================== Tidy Core ====================
    4 
    +Result size of Tidy Core
    5 
    +  = {terms: 26, types: 9, coercions: 0, joins: 1/1}
    6 
    +
    7 
    +Rec {
    8 
    +-- RHS size: {terms: 25, types: 7, coercions: 0, joins: 1/1}
    9 
    +f [Occ=LoopBreaker] :: T -> Bool
    10 
    +[GblId, Arity=1, Str=<SL>, Unf=OtherCon []]
    11 
    +f = \ (x :: T) ->
    12 
    +      join {
    13 
    +        j [InlPrag=NOINLINE, Dmd=MC(1,L)] :: Bool -> Bool
    14 
    +        [LclId[JoinId(1)(Just [!])], Arity=1, Str=<1L>, Unf=OtherCon []]
    15 
    +        j (eta [OS=OneShot] :: Bool)
    16 
    +          = case eta of {
    17 
    +              False -> GHC.Internal.Types.False;
    18 
    +              True ->
    19 
    +                case f x of {
    20 
    +                  False -> GHC.Internal.Types.True;
    21 
    +                  True -> GHC.Internal.Types.False
    22 
    +                }
    23 
    +            } } in
    24 
    +      case x of {
    25 
    +        A -> GHC.Internal.Types.True;
    26 
    +        B -> jump j GHC.Internal.Types.True;
    27 
    +        C -> jump j GHC.Internal.Types.False
    28 
    +      }
    29 
    +end Rec }
    30 
    +
    31 
    +
    32 
    +

  • testsuite/tests/simplCore/should_compile/all.T
    ... ... @@ -564,3 +564,9 @@ test('T26116', normal, compile, ['-O -ddump-rules'])
    564 564 
     test('T26117', [grep_errmsg(r'==')], compile, ['-O -ddump-simpl -dsuppress-uniques'])
    565 565 
     test('T26349',  normal, compile, ['-O -ddump-rules'])
    566 566 
     test('T26681',  normal, compile, ['-O'])
    567 
    +
    568 
    +# T26709: we expect three `case` expressions not four
    569 
    +test('T26709', [grep_errmsg(r'case')],
    570 
    +       multimod_compile,
    571 
    +       ['T26709', '-O -ddump-simpl -dsuppress-uniques -dno-typeable-binds'])
    572 
    +

  • testsuite/tests/typecheck/should_compile/T26746.hs
    1 
    +module T26746 where
    2 
    +
    3 
    +import Data.Coerce
    4 
    +
    5 
    +newtype Foo a = Foo (Foo a)
    6 
    +newtype Age = MkAge Int
    7 
    +
    8 
    +ex1 :: (Foo Age) -> (Foo Int)
    9 
    +ex1 = coerce
    10 
    +
    11 
    +newtype Womble a = MkWomble (Foo a)
    12 
    +
    13 
    +ex2 :: Womble (Foo Age) -> (Foo Int)
    14 
    +ex2 = coerce
    15 
    +
    16 
    +ex3 :: (Foo Age) -> Womble (Foo Int)
    17 
    +ex3 = coerce
    18 
    +
    19 
    +
    20 
    +-- Surprisingly this one works:
    21 
    +newtype Z1 = MkZ1 Z2
    22 
    +newtype Z2 = MKZ2 Z1
    23 
    +
    24 
    +ex4 :: Z1 -> Z2
    25 
    +ex4 = coerce
    26 
    +
    27 
    +-- But this one does not (commented out)
    28 
    +-- newtype Y1 = MkY1 Y2
    29 
    +-- newtype Y2 = MKY2 Y3
    30 
    +-- newtype Y3 = MKY3 Y1
    31 
    +--
    32 
    +-- ex5 :: Y1 -> Y3
    33 
    +-- ex5 = coerce

  • testsuite/tests/typecheck/should_compile/all.T
    ... ... @@ -957,3 +957,4 @@ test('T17705', normal, compile, [''])
    957 957 
     test('T14745', normal, compile, [''])
    958 958 
     test('T26451', normal, compile, [''])
    959 959 
     test('T26582', normal, compile, [''])
    960 
    +test('T26746', normal, compile, [''])

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help