aclocal.m4

@@ -206,7 +206,7 @@ AC_DEFUN([FPTOOLS_SET_HASKELL_PLATFORM_VARS],
             ;;
         arm)
             GET_ARM_ISA()
-            test -z "[$]2" || eval "[$]2=\"ArchARM \$ARM_ISA \$ARM_ISA_EXT \$ARM_ABI}\""
+            test -z "[$]2" || eval "[$]2=\"ArchARM \$ARM_ISA \$ARM_ISA_EXT \$ARM_ABI\""
             ;;
         aarch64)
             test -z "[$]2" || eval "[$]2=ArchARM64"

compiler/GHC/Core/Coercion.hs

@@ -1891,7 +1891,9 @@ substForAllCoBndrUsingLC sym sco (LC subst lc_env) tv co
 --
 --   For the inverse operation, see 'liftCoMatch'
 ty_co_subst :: LiftingContext -> Role -> Type -> Coercion
-ty_co_subst lc role ty
+ty_co_subst !lc role ty
+    -- !lc: making this function strict in lc allows callers to
+    -- pass its two components separately, rather than boxing them
   = go role ty
   where
     go :: Role -> Type -> Coercion
@@ -2864,9 +2866,9 @@ simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs
          -- need a coercion (kind_co :: old_kind ~ new_kind).
          --
          -- The bangs here have been observed to improve performance
-         -- significantly in optimized builds.
-         let kind_co = mkSymCo $
-                       liftCoSubst Nominal lc (tyCoBinderType binder)
+         -- significantly in optimized builds; see #18502
+         let !kind_co = mkSymCo $
+                        liftCoSubst Nominal lc (tyCoBinderType binder)
              !casted_xi = xi `mkCastTy` kind_co
              casted_co =  mkCoherenceLeftCo role xi kind_co co
 

compiler/GHC/Core/Opt/Simplify.hs

@@ -1004,7 +1004,7 @@ simplExprF1 env (App fun arg) cont
                                 , sc_hole_ty = hole'
                                 , sc_cont    = cont } }
       _       ->
-          -- crucially, these are /lazy/ bindings. They will
+          -- Crucially, sc_hole_ty is a /lazy/ binding.  It will
           -- be forced only if we need to run contHoleType.
           -- When these are forced, we might get quadratic behavior;
           -- this quadratic blowup could be avoided by drilling down
@@ -1012,17 +1012,10 @@ simplExprF1 env (App fun arg) cont
           -- (instead of one-at-a-time). But in practice, we have not
           -- observed the quadratic behavior, so this extra entanglement
           -- seems not worthwhile.
-          --
-          -- But the (exprType fun) is repeated, to push it into two
-          -- separate, rarely used, thunks; rather than always alloating
-          -- a shared thunk.  Makes a small efficiency difference
-        let fun_ty = exprType fun
-            (m, _, _) = splitFunTy fun_ty
-        in
         simplExprF env fun $
         ApplyToVal { sc_arg = arg, sc_env = env
                    , sc_hole_ty = substTy env (exprType fun)
-                   , sc_dup = NoDup, sc_cont = cont, sc_mult = m }
+                   , sc_dup = NoDup, sc_cont = cont }
 
 simplExprF1 env expr@(Lam {}) cont
   = {-#SCC "simplExprF1-Lam" #-}
@@ -1327,8 +1320,8 @@ rebuild env expr cont
       Select { sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont }
         -> rebuildCase (se `setInScopeFromE` env) expr bndr alts cont
 
-      StrictArg { sc_fun = fun, sc_cont = cont, sc_fun_ty = fun_ty, sc_mult = m }
-        -> rebuildCall env (addValArgTo fun (m, expr) fun_ty ) cont
+      StrictArg { sc_fun = fun, sc_cont = cont, sc_fun_ty = fun_ty }
+        -> rebuildCall env (addValArgTo fun expr fun_ty ) cont
       StrictBind { sc_bndr = b, sc_bndrs = bs, sc_body = body
                  , sc_env = se, sc_cont = cont }
         -> do { (floats1, env') <- simplNonRecX (se `setInScopeFromE` env) b expr
@@ -1420,7 +1413,7 @@ simplCast env body co0 cont0
         --         co1 :: t1 ~ s1
         --         co2 :: s2 ~ t2
         addCoerce co cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se
-                                      , sc_dup = dup, sc_cont = tail, sc_mult = m })
+                                      , sc_dup = dup, sc_cont = tail })
           | Just (co1, m_co2) <- pushCoValArg co
           , let new_ty = coercionRKind co1
           , not (isTypeLevPoly new_ty)  -- Without this check, we get a lev-poly arg
@@ -1444,8 +1437,7 @@ simplCast env body co0 cont0
                                     , sc_env  = arg_se'
                                     , sc_dup  = dup'
                                     , sc_cont = tail'
-                                    , sc_hole_ty = coercionLKind co
-                                    , sc_mult = m }) } }
+                                    , sc_hole_ty = coercionLKind co }) } }
 
         addCoerce co cont
           | isReflexiveCo co = return cont  -- Having this at the end makes a huge
@@ -1981,17 +1973,18 @@ rebuildCall env info (ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_c
 -- runRW# :: forall (r :: RuntimeRep) (o :: TYPE r). (State# RealWorld -> o) -> o
 -- K[ runRW# rr ty body ]  -->  runRW rr' ty' (\s. K[ body s ])
 rebuildCall env (ArgInfo { ai_fun = fun_id, ai_args = rev_args })
-            (ApplyToVal { sc_arg = arg, sc_env = arg_se, sc_cont = cont, sc_mult = m })
+            (ApplyToVal { sc_arg = arg, sc_env = arg_se
+                        , sc_cont = cont, sc_hole_ty = fun_ty })
   | fun_id `hasKey` runRWKey
   , not (contIsStop cont)  -- Don't fiddle around if the continuation is boring
   , [ TyArg {}, TyArg {} ] <- rev_args
   = do { s <- newId (fsLit "s") Many realWorldStatePrimTy
-       ; let env'  = (arg_se `setInScopeFromE` env) `addNewInScopeIds` [s]
+       ; let (m,_,_) = splitFunTy fun_ty
+             env'  = (arg_se `setInScopeFromE` env) `addNewInScopeIds` [s]
              ty'   = contResultType cont
              cont' = ApplyToVal { sc_dup = Simplified, sc_arg = Var s
                                 , sc_env = env', sc_cont = cont
-                                , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy ty'
-                                , sc_mult = m }
+                                , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy ty' }
                      -- cont' applies to s, then K
        ; body' <- simplExprC env' arg cont'
        ; let arg'  = Lam s body'
@@ -2002,10 +1995,10 @@ rebuildCall env (ArgInfo { ai_fun = fun_id, ai_args = rev_args })
 rebuildCall env fun_info
             (ApplyToVal { sc_arg = arg, sc_env = arg_se
                         , sc_dup = dup_flag, sc_hole_ty = fun_ty
-                        , sc_cont = cont, sc_mult = m })
+                        , sc_cont = cont })
   -- Argument is already simplified
   | isSimplified dup_flag     -- See Note [Avoid redundant simplification]
-  = rebuildCall env (addValArgTo fun_info (m, arg) fun_ty) cont
+  = rebuildCall env (addValArgTo fun_info arg fun_ty) cont
 
   -- Strict arguments
   | isStrictArgInfo fun_info
@@ -2014,7 +2007,7 @@ rebuildCall env fun_info
     simplExprF (arg_se `setInScopeFromE` env) arg
                (StrictArg { sc_fun = fun_info, sc_fun_ty = fun_ty
                           , sc_dup = Simplified
-                          , sc_cont = cont, sc_mult = m })
+                          , sc_cont = cont })
                 -- Note [Shadowing]
 
   -- Lazy arguments
@@ -2025,7 +2018,7 @@ rebuildCall env fun_info
         -- floating a demanded let.
   = do  { arg' <- simplExprC (arg_se `setInScopeFromE` env) arg
                              (mkLazyArgStop arg_ty (lazyArgContext fun_info))
-        ; rebuildCall env (addValArgTo fun_info (m, arg') fun_ty) cont }
+        ; rebuildCall env (addValArgTo fun_info  arg' fun_ty) cont }
   where
     arg_ty = funArgTy fun_ty
 
@@ -2233,24 +2226,10 @@ trySeqRules in_env scrut rhs cont
                         , as_hole_ty = res2_ty }
                 , ValArg { as_arg = no_cast_scrut
                          , as_dmd = seqDmd
-                         , as_hole_ty = res3_ty
-                         , as_mult = Many } ]
-                -- The multiplicity of the scrutiny above is Many because the type
-                -- of seq requires that its first argument is unrestricted. The
-                -- typing rule of case also guarantees it though. In a more
-                -- general world, where the first argument of seq would have
-                -- affine multiplicity, then we could use the multiplicity of
-                -- the case (held in the case binder) instead.
+                         , as_hole_ty = res3_ty } ]
     rule_cont = ApplyToVal { sc_dup = NoDup, sc_arg = rhs
                            , sc_env = in_env, sc_cont = cont
-                           , sc_hole_ty = res4_ty, sc_mult = Many }
-                           -- The multiplicity in sc_mult above is the
-                           -- multiplicity of the second argument of seq. Since
-                           -- seq's type, as it stands, imposes that its second
-                           -- argument be unrestricted, so is
-                           -- sc_mult. However, a more precise typing rule,
-                           -- for seq, would be to have it be linear. In which
-                           -- case, sc_mult should be 1.
+                           , sc_hole_ty = res4_ty }
 
     -- Lazily evaluated, so we don't do most of this
 
@@ -3304,7 +3283,7 @@ mkDupableContWithDmds env _
 
 mkDupableContWithDmds env _
     (StrictArg { sc_fun = fun, sc_cont = cont
-               , sc_fun_ty = fun_ty, sc_mult = m })
+               , sc_fun_ty = fun_ty })
   -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable
   | thumbsUpPlanA cont
   = -- Use Plan A of Note [Duplicating StrictArg]
@@ -3318,18 +3297,17 @@ mkDupableContWithDmds env _
                 , StrictArg { sc_fun = fun { ai_args = args' }
                             , sc_cont = cont'
                             , sc_fun_ty = fun_ty
-                            , sc_mult = m
                             , sc_dup = OkToDup} ) }
 
   | otherwise
   = -- Use Plan B of Note [Duplicating StrictArg]
     --   K[ f a b <> ]   -->   join j x = K[ f a b x ]
     --                         j <>
-    do { let arg_ty = funArgTy fun_ty
-             rhs_ty = contResultType cont
-       ; arg_bndr <- newId (fsLit "arg") m arg_ty   -- ToDo: check this linearity argument
+    do { let rhs_ty       = contResultType cont
+             (m,arg_ty,_) = splitFunTy fun_ty
+       ; arg_bndr <- newId (fsLit "arg") m arg_ty
        ; let env' = env `addNewInScopeIds` [arg_bndr]
-       ; (floats, join_rhs) <- rebuildCall env' (addValArgTo fun (m, Var arg_bndr) fun_ty) cont
+       ; (floats, join_rhs) <- rebuildCall env' (addValArgTo fun (Var arg_bndr) fun_ty) cont
        ; mkDupableStrictBind env' arg_bndr (wrapFloats floats join_rhs) rhs_ty }
   where
     thumbsUpPlanA (StrictArg {})               = False
@@ -3349,7 +3327,7 @@ mkDupableContWithDmds env dmds
 
 mkDupableContWithDmds env dmds
     (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_env = se
-                , sc_cont = cont, sc_hole_ty = hole_ty, sc_mult = mult })
+                , sc_cont = cont, sc_hole_ty = hole_ty })
   =     -- e.g.         [...hole...] (...arg...)
         --      ==>
         --              let a = ...arg...
@@ -3369,7 +3347,7 @@ mkDupableContWithDmds env dmds
                                          -- has turned arg'' into a fresh variable
                                          -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils
                               , sc_dup = OkToDup, sc_cont = cont'
-                              , sc_hole_ty = hole_ty, sc_mult = mult }) }
+                              , sc_hole_ty = hole_ty }) }
 
 mkDupableContWithDmds env _
     (Select { sc_bndr = case_bndr, sc_alts = alts, sc_env = se, sc_cont = cont })
@@ -3439,7 +3417,6 @@ mkDupableStrictBind env arg_bndr join_rhs res_ty
                             , sc_fun    = arg_info
                             , sc_fun_ty = idType join_bndr
                             , sc_cont   = mkBoringStop res_ty
-                            , sc_mult   = Many   -- ToDo: check this!
                             } ) }
 
 mkDupableAlt :: Platform -> OutId

compiler/GHC/Core/Opt/Simplify/Utils.hs

@@ -125,8 +125,7 @@ data SimplCont
                                 -- See Note [The hole type in ApplyToTy/Val]
       , sc_arg  :: InExpr       -- The argument,
       , sc_env  :: StaticEnv    -- see Note [StaticEnv invariant]
-      , sc_cont :: SimplCont
-      , sc_mult :: Mult }
+      , sc_cont :: SimplCont }
 
   | ApplyToTy          -- (ApplyToTy ty K)[e] = K[ e ty ]
       { sc_arg_ty  :: OutType     -- Argument type
@@ -160,8 +159,7 @@ data SimplCont
       , sc_fun_ty :: OutType   -- Type of the function (f e1 .. en),
                                -- presumably (arg_ty -> res_ty)
                                -- where res_ty is expected by sc_cont
-      , sc_cont :: SimplCont
-      , sc_mult :: Mult }
+      , sc_cont :: SimplCont }
 
   | TickIt              -- (TickIt t K)[e] = K[ tick t e ]
         (Tickish Id)    -- Tick tickish <hole>
@@ -282,8 +280,7 @@ data ArgInfo
     }
 
 data ArgSpec
-  = ValArg { as_mult :: Mult
-           , as_dmd  :: Demand        -- Demand placed on this argument
+  = ValArg { as_dmd  :: Demand        -- Demand placed on this argument
            , as_arg  :: OutExpr       -- Apply to this (coercion or value); c.f. ApplyToVal
            , as_hole_ty :: OutType }  -- Type of the function (presumably t1 -> t2)
 
@@ -300,16 +297,15 @@ instance Outputable ArgInfo where
               , text "args =" <+> ppr args ])
 
 instance Outputable ArgSpec where
-  ppr (ValArg { as_mult = mult, as_arg = arg })  = text "ValArg" <+> ppr mult <+> ppr arg
+  ppr (ValArg { as_arg = arg })  = text "ValArg" <+> ppr arg
   ppr (TyArg { as_arg_ty = ty }) = text "TyArg" <+> ppr ty
   ppr (CastBy c)                 = text "CastBy" <+> ppr c
 
-addValArgTo :: ArgInfo -> (Mult, OutExpr) -> OutType -> ArgInfo
-addValArgTo ai (w, arg) hole_ty
+addValArgTo :: ArgInfo ->  OutExpr -> OutType -> ArgInfo
+addValArgTo ai arg hole_ty
   | ArgInfo { ai_dmds = dmd:dmds, ai_discs = _:discs, ai_rules = rules } <- ai
       -- Pop the top demand and and discounts off
-  , let arg_spec = ValArg { as_arg = arg, as_hole_ty = hole_ty
-                          , as_mult = w, as_dmd = dmd }
+  , let arg_spec = ValArg { as_arg = arg, as_hole_ty = hole_ty, as_dmd = dmd }
   = ai { ai_args  = arg_spec : ai_args ai
        , ai_dmds  = dmds
        , ai_discs = discs
@@ -345,9 +341,9 @@ pushSimplifiedArgs env  (arg : args) k
   = case arg of
       TyArg { as_arg_ty = arg_ty, as_hole_ty = hole_ty }
                -> ApplyToTy  { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = rest }
-      ValArg { as_arg = arg, as_hole_ty = hole_ty, as_mult = w }
+      ValArg { as_arg = arg, as_hole_ty = hole_ty }
              -> ApplyToVal { sc_arg = arg, sc_env = env, sc_dup = Simplified
-                           , sc_hole_ty = hole_ty, sc_cont = rest, sc_mult = w }
+                           , sc_hole_ty = hole_ty, sc_cont = rest }
       CastBy c -> CastIt c rest
   where
     rest = pushSimplifiedArgs env args k
@@ -446,7 +442,7 @@ contHoleType (TickIt _ k)                     = contHoleType k
 contHoleType (CastIt co _)                    = coercionLKind co
 contHoleType (StrictBind { sc_bndr = b, sc_dup = dup, sc_env = se })
   = perhapsSubstTy dup se (idType b)
-contHoleType (StrictArg  { sc_fun_ty = ty, sc_mult = _m })  = funArgTy ty
+contHoleType (StrictArg  { sc_fun_ty = ty })  = funArgTy ty
 contHoleType (ApplyToTy  { sc_hole_ty = ty }) = ty  -- See Note [The hole type in ApplyToTy]
 contHoleType (ApplyToVal { sc_hole_ty = ty }) = ty  -- See Note [The hole type in ApplyToTy/Val]
 contHoleType (Select { sc_dup = d, sc_bndr =  b, sc_env = se })
@@ -464,12 +460,14 @@ contHoleType (Select { sc_dup = d, sc_bndr =  b, sc_env = se })
 contHoleScaling :: SimplCont -> Mult
 contHoleScaling (Stop _ _) = One
 contHoleScaling (CastIt _ k) = contHoleScaling k
-contHoleScaling (StrictBind { sc_bndr = id, sc_cont = k }) =
-  (idMult id) `mkMultMul` contHoleScaling k
-contHoleScaling (StrictArg { sc_mult = w, sc_cont = k }) =
-  w `mkMultMul` contHoleScaling k
-contHoleScaling (Select { sc_bndr = id, sc_cont = k }) =
-  (idMult id) `mkMultMul` contHoleScaling k
+contHoleScaling (StrictBind { sc_bndr = id, sc_cont = k })
+  = idMult id `mkMultMul` contHoleScaling k
+contHoleScaling (Select { sc_bndr = id, sc_cont = k })
+  = idMult id `mkMultMul` contHoleScaling k
+contHoleScaling (StrictArg { sc_fun_ty = fun_ty, sc_cont = k })
+  = w `mkMultMul` contHoleScaling k
+  where
+    (w, _, _) = splitFunTy fun_ty
 contHoleScaling (ApplyToTy { sc_cont = k }) = contHoleScaling k
 contHoleScaling (ApplyToVal { sc_cont = k }) = contHoleScaling k
 contHoleScaling (TickIt _ k) = contHoleScaling k

compiler/GHC/Rename/Pat.hs

@@ -236,19 +236,30 @@ newPatName (LetMk is_top fix_env) rdr_name
         do { name <- case is_top of
                        NotTopLevel -> newLocalBndrRn rdr_name
                        TopLevel    -> newTopSrcBinder rdr_name
-           ; bindLocalNames [name] $       -- Do *not* use bindLocalNameFV here
-                                        -- See Note [View pattern usage]
+           ; bindLocalNames [name] $
+                 -- Do *not* use bindLocalNameFV here;
+                 --   see Note [View pattern usage]
+                 -- For the TopLevel case
+                 --   see Note [bindLocalNames for an External name]
              addLocalFixities fix_env [name] $
              thing_inside name })
 
-    -- Note: the bindLocalNames is somewhat suspicious
-    --       because it binds a top-level name as a local name.
-    --       however, this binding seems to work, and it only exists for
-    --       the duration of the patterns and the continuation;
-    --       then the top-level name is added to the global env
-    --       before going on to the RHSes (see GHC.Rename.Module).
+{- Note [bindLocalNames for an External name]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In the TopLevel case, the use of bindLocalNames here is somewhat
+suspicious because it binds a top-level External name in the
+LocalRdrEnv.  c.f. Note [LocalRdrEnv] in GHC.Types.Name.Reader.
+
+However, this only happens when renaming the LHS (only) of a top-level
+pattern binding.  Even though this only the LHS, we need to bring the
+binder into scope in the pattern itself in case the binder is used in
+subsequent view patterns.  A bit bizarre, something like
+  (x, Just y <- f x) = e
+
+Anyway, bindLocalNames does work, and the binding only exists for the
+duration of the pattern; then the top-level name is added to the
+global env before going on to the RHSes (see GHC.Rename.Module).
 
-{-
 Note [View pattern usage]
 ~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider

compiler/GHC/Tc/Deriv.hs

@@ -2038,9 +2038,12 @@ genDerivStuff mechanism loc clas inst_tys tyvars
         -> gen_newtype_or_via rhs_ty
 
       -- Try a stock deriver
-      DerivSpecStock { dsm_stock_dit    = DerivInstTys{dit_rep_tc = rep_tc}
+      DerivSpecStock { dsm_stock_dit    = DerivInstTys
+                        { dit_rep_tc = rep_tc
+                        , dit_rep_tc_args = rep_tc_args
+                        }
                      , dsm_stock_gen_fn = gen_fn }
-        -> do (binds, faminsts, field_names) <- gen_fn loc rep_tc inst_tys
+        -> do (binds, faminsts, field_names) <- gen_fn loc rep_tc rep_tc_args inst_tys
               pure (binds, [], faminsts, field_names)
 
       -- Try DeriveAnyClass

compiler/GHC/Tc/Deriv/Functor.hs

@@ -151,10 +151,10 @@ is a similar algorithm for generating `p <$ x` (for some constant `p`):
   $(coreplace 'a '(tb -> tc) x) = \(y:tb[b/a]) -> $(coreplace 'a' 'tc' (x $(replace 'a 'tb y)))
 -}
 
-gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)
+gen_Functor_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)
 -- When the argument is phantom, we can use  fmap _ = coerce
 -- See Note [Phantom types with Functor, Foldable, and Traversable]
-gen_Functor_binds loc tycon
+gen_Functor_binds loc tycon _
   | Phantom <- last (tyConRoles tycon)
   = (unitBag fmap_bind, emptyBag)
   where
@@ -165,10 +165,10 @@ gen_Functor_binds loc tycon
                                coerce_Expr]
     fmap_match_ctxt = mkPrefixFunRhs fmap_name
 
-gen_Functor_binds loc tycon
+gen_Functor_binds loc tycon tycon_args
   = (listToBag [fmap_bind, replace_bind], emptyBag)
   where
-    data_cons = tyConDataCons tycon
+    data_cons = getPossibleDataCons tycon tycon_args
     fmap_name = L loc fmap_RDR
 
     -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]
@@ -787,10 +787,10 @@ could surprise users if they switch to other types, but Ryan Scott seems to
 think it's okay to do it for now.
 -}
 
-gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)
+gen_Foldable_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)
 -- When the parameter is phantom, we can use foldMap _ _ = mempty
 -- See Note [Phantom types with Functor, Foldable, and Traversable]
-gen_Foldable_binds loc tycon
+gen_Foldable_binds loc tycon _
   | Phantom <- last (tyConRoles tycon)
   = (unitBag foldMap_bind, emptyBag)
   where
@@ -801,7 +801,7 @@ gen_Foldable_binds loc tycon
                                   mempty_Expr]
     foldMap_match_ctxt = mkPrefixFunRhs foldMap_name
 
-gen_Foldable_binds loc tycon
+gen_Foldable_binds loc tycon tycon_args
   | null data_cons  -- There's no real point producing anything but
                     -- foldMap for a type with no constructors.
   = (unitBag foldMap_bind, emptyBag)
@@ -809,7 +809,7 @@ gen_Foldable_binds loc tycon
   | otherwise
   = (listToBag [foldr_bind, foldMap_bind, null_bind], emptyBag)
   where
-    data_cons = tyConDataCons tycon
+    data_cons = getPossibleDataCons tycon tycon_args
 
     foldr_bind = mkRdrFunBind (L loc foldable_foldr_RDR) eqns
     eqns = map foldr_eqn data_cons
@@ -1016,10 +1016,10 @@ removes all such types from consideration.
 See Note [Generated code for DeriveFoldable and DeriveTraversable].
 -}
 
-gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)
+gen_Traversable_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)
 -- When the argument is phantom, we can use traverse = pure . coerce
 -- See Note [Phantom types with Functor, Foldable, and Traversable]
-gen_Traversable_binds loc tycon
+gen_Traversable_binds loc tycon _
   | Phantom <- last (tyConRoles tycon)
   = (unitBag traverse_bind, emptyBag)
   where
@@ -1031,10 +1031,10 @@ gen_Traversable_binds loc tycon
                        (nlHsApps pure_RDR [nlHsApp coerce_Expr z_Expr])]
     traverse_match_ctxt = mkPrefixFunRhs traverse_name
 
-gen_Traversable_binds loc tycon
+gen_Traversable_binds loc tycon tycon_args
   = (unitBag traverse_bind, emptyBag)
   where
-    data_cons = tyConDataCons tycon
+    data_cons = getPossibleDataCons tycon tycon_args
 
     traverse_name = L loc traverse_RDR
 

compiler/GHC/Tc/Deriv/Generate.hs

@@ -33,7 +33,9 @@ module GHC.Tc.Deriv.Generate (
         mkCoerceClassMethEqn,
         genAuxBinds,
         ordOpTbl, boxConTbl, litConTbl,
-        mkRdrFunBind, mkRdrFunBindEC, mkRdrFunBindSE, error_Expr
+        mkRdrFunBind, mkRdrFunBindEC, mkRdrFunBindSE, error_Expr,
+
+        getPossibleDataCons, tyConInstArgTys
     ) where
 
 #include "HsVersions.h"
@@ -212,14 +214,14 @@ for the instance decl, which it probably wasn't, so the decls
 produced don't get through the typechecker.
 -}
 
-gen_Eq_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)
-gen_Eq_binds loc tycon = do
+gen_Eq_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)
+gen_Eq_binds loc tycon tycon_args = do
     -- See Note [Auxiliary binders]
     con2tag_RDR <- new_con2tag_rdr_name loc tycon
 
     return (method_binds con2tag_RDR, aux_binds con2tag_RDR)
   where
-    all_cons = tyConDataCons tycon
+    all_cons = getPossibleDataCons tycon tycon_args
     (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon all_cons
 
     -- If there are ten or more (arbitrary number) nullary constructors,
@@ -396,8 +398,8 @@ gtResult OrdGE      = true_Expr
 gtResult OrdGT      = true_Expr
 
 ------------
-gen_Ord_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)
-gen_Ord_binds loc tycon = do
+gen_Ord_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)
+gen_Ord_binds loc tycon tycon_args = do
     -- See Note [Auxiliary binders]
     con2tag_RDR <- new_con2tag_rdr_name loc tycon
 
@@ -432,7 +434,7 @@ gen_Ord_binds loc tycon = do
         -- We want *zero-based* tags, because that's what
         -- con2Tag returns (generated by untag_Expr)!
 
-    tycon_data_cons = tyConDataCons tycon
+    tycon_data_cons = getPossibleDataCons tycon tycon_args
     single_con_type = isSingleton tycon_data_cons
     (first_con : _) = tycon_data_cons
     (last_con : _)  = reverse tycon_data_cons
@@ -646,8 +648,8 @@ instance ... Enum (Foo ...) where
 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
 -}
 
-gen_Enum_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)
-gen_Enum_binds loc tycon = do
+gen_Enum_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)
+gen_Enum_binds loc tycon _ = do
     -- See Note [Auxiliary binders]
     con2tag_RDR <- new_con2tag_rdr_name loc tycon
     tag2con_RDR <- new_tag2con_rdr_name loc tycon
@@ -738,8 +740,8 @@ gen_Enum_binds loc tycon = do
 ************************************************************************
 -}
 
-gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)
-gen_Bounded_binds loc tycon
+gen_Bounded_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)
+gen_Bounded_binds loc tycon _
   | isEnumerationTyCon tycon
   = (listToBag [ min_bound_enum, max_bound_enum ], emptyBag)
   | otherwise
@@ -825,9 +827,9 @@ we follow the scheme given in Figure~19 of the Haskell~1.2 report
 (p.~147).
 -}
 
-gen_Ix_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)
+gen_Ix_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)
 
-gen_Ix_binds loc tycon = do
+gen_Ix_binds loc tycon _ = do
     -- See Note [Auxiliary binders]
     con2tag_RDR <- new_con2tag_rdr_name loc tycon
     tag2con_RDR <- new_tag2con_rdr_name loc tycon
@@ -1028,10 +1030,10 @@ These instances are also useful for Read (Either Int Emp), where
 we want to be able to parse (Left 3) just fine.
 -}
 
-gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> TyCon
+gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> [Type]
                -> (LHsBinds GhcPs, BagDerivStuff)
 
-gen_Read_binds get_fixity loc tycon
+gen_Read_binds get_fixity loc tycon _
   = (listToBag [read_prec, default_readlist, default_readlistprec], emptyBag)
   where
     -----------------------------------------------------------------------
@@ -1212,13 +1214,13 @@ Example
                     -- the most tightly-binding operator
 -}
 
-gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> TyCon
+gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> [Type]
                -> (LHsBinds GhcPs, BagDerivStuff)
 
-gen_Show_binds get_fixity loc tycon
+gen_Show_binds get_fixity loc tycon tycon_args
   = (unitBag shows_prec, emptyBag)
   where
-    data_cons = tyConDataCons tycon
+    data_cons = getPossibleDataCons tycon tycon_args
     shows_prec = mkFunBindEC 2 loc showsPrec_RDR id (map pats_etc data_cons)
     comma_space = nlHsVar showCommaSpace_RDR
 
@@ -1385,9 +1387,10 @@ we generate
 gen_Data_binds :: SrcSpan
                -> TyCon                 -- For data families, this is the
                                         --  *representation* TyCon
+               -> [Type]
                -> TcM (LHsBinds GhcPs,  -- The method bindings
                        BagDerivStuff)   -- Auxiliary bindings
-gen_Data_binds loc rep_tc
+gen_Data_binds loc rep_tc _
   = do { -- See Note [Auxiliary binders]
          dataT_RDR  <- new_dataT_rdr_name loc rep_tc
        ; dataC_RDRs <- traverse (new_dataC_rdr_name loc) data_cons
@@ -1616,8 +1619,8 @@ Example:
 -}
 
 
-gen_Lift_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)
-gen_Lift_binds loc tycon = (listToBag [lift_bind, liftTyped_bind], emptyBag)
+gen_Lift_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)
+gen_Lift_binds loc tycon tycon_args = (listToBag [lift_bind, liftTyped_bind], emptyBag)
   where
     lift_bind      = mkFunBindEC 1 loc lift_RDR (nlHsApp pure_Expr)
                                  (map (pats_etc mk_exp) data_cons)
@@ -1626,7 +1629,7 @@ gen_Lift_binds loc tycon = (listToBag [lift_bind, liftTyped_bind], emptyBag)
 
     mk_exp = ExpBr noExtField
     mk_texp = TExpBr noExtField
-    data_cons = tyConDataCons tycon
+    data_cons = getPossibleDataCons tycon tycon_args
 
     pats_etc mk_bracket data_con
       = ([con_pat], lift_Expr)
@@ -2515,6 +2518,39 @@ newAuxBinderRdrName loc parent occ_fun = do
   uniq <- newUnique
   pure $ Exact $ mkSystemNameAt uniq (occ_fun (nameOccName parent)) loc
 
+-- | @getPossibleDataCons tycon tycon_args@ returns the constructors of @tycon@
+-- whose return types match when checked against @tycon_args@.
+--
+-- See Note [Filter out impossible GADT data constructors]
+getPossibleDataCons :: TyCon -> [Type] -> [DataCon]
+getPossibleDataCons tycon tycon_args = filter isPossible $ tyConDataCons tycon
+  where
+    isPossible = not . dataConCannotMatch (tyConInstArgTys tycon tycon_args)
+
+-- | Given a type constructor @tycon@ of arity /n/ and a list of argument types
+-- @tycon_args@ of length /m/,
+--
+-- @
+-- tyConInstArgTys tycon tycon_args
+-- @
+--
+-- returns
+--
+-- @
+-- [tycon_arg_{1}, tycon_arg_{2}, ..., tycon_arg_{m}, extra_arg_{m+1}, ..., extra_arg_{n}]
+-- @
+--
+-- where @extra_args@ are distinct type variables.
+--
+-- Examples:
+--
+-- * Given @tycon: Foo a b@ and @tycon_args: [Int, Bool]@, return @[Int, Bool]@.
+--
+-- * Given @tycon: Foo a b@ and @tycon_args: [Int]@, return @[Int, b]@.
+tyConInstArgTys :: TyCon -> [Type] -> [Type]
+tyConInstArgTys tycon tycon_args = chkAppend tycon_args $ map mkTyVarTy tycon_args_suffix
+  where
+    tycon_args_suffix = drop (length tycon_args) $ tyConTyVars tycon
 
 {-
 Note [Auxiliary binders]
@@ -2733,4 +2769,56 @@ derived instances within the same module, not separated by any TH splices.
 (This is the case described in "Wrinkle: Reducing code duplication".) In
 situation (1), we can at least fall back on GHC's simplifier to pick up
 genAuxBinds' slack.
+
+Note [Filter out impossible GADT data constructors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Some stock-derivable classes will filter out impossible GADT data constructors,
+to rule out problematic constructors when deriving instances. e.g.
+
+```
+data Foo a where
+  X :: Foo Int
+  Y :: (Bool -> Bool) -> Foo Bool
+```
+
+when deriving an instance on `Foo Int`, `Y` should be treated as if it didn't
+exist in the first place. For instance, if we write
+
+```
+deriving instance Eq (Foo Int)
+```
+
+it should generate:
+
+```
+instance Eq (Foo Int) where
+  X == X = True
+```
+
+Classes that filter constructors:
+
+* Eq
+* Ord
+* Show
+* Lift
+* Functor
+* Foldable
+* Traversable
+
+Classes that do not filter constructors:
+
+* Enum: doesn't make sense for GADTs in the first place
+* Bounded: only makes sense for GADTs with a single constructor
+* Ix: only makes sense for GADTs with a single constructor
+* Read: `Read a` returns `a` instead of consumes `a`, so filtering data
+  constructors would make this function _more_ partial instead of less
+* Data: derived implementations of gunfold rely on a constructor-indexing
+  scheme that wouldn't work if certain constructors were filtered out
+* Generic/Generic1: doesn't make sense for GADTs
+
+Classes that do not currently filter constructors may do so in the future, if
+there is a valid use-case and we have requirements for how they should work.
+
+See #16341 and the T16341.hs test case.
 -}

compiler/GHC/Tc/Deriv/Infer.hs

@@ -260,9 +260,7 @@ inferConstraintsStock (DerivInstTys { dit_cls_tys     = cls_tys
            -- substitute each type variable with its counterpart in the derived
            -- instance. rep_tc_args lists each of these counterpart types in
            -- the same order as the type variables.
-           all_rep_tc_args
-             = rep_tc_args ++ map mkTyVarTy
-                                  (drop (length rep_tc_args) rep_tc_tvs)
+           all_rep_tc_args = tyConInstArgTys rep_tc rep_tc_args
 
                -- Stupid constraints
            stupid_constraints

compiler/GHC/Tc/Deriv/Utils.hs

@@ -218,8 +218,9 @@ data DerivSpecMechanism
       -- instance, including what type constructor the last argument is
       -- headed by. See @Note [DerivEnv and DerivSpecMechanism]@.
     , dsm_stock_gen_fn ::
-        SrcSpan -> TyCon
-                -> [Type]
+        SrcSpan -> TyCon  -- dit_rep_tc
+                -> [Type] -- dit_rep_tc_args
+                -> [Type] -- inst_tys
                 -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name])
       -- ^ This function returns three things:
       --
@@ -424,7 +425,7 @@ instance Outputable DerivContext where
 -- See @Note [Deriving strategies]@ in "GHC.Tc.Deriv".
 data OriginativeDerivStatus
   = CanDeriveStock            -- Stock class, can derive
-      (SrcSpan -> TyCon -> [Type]
+      (SrcSpan -> TyCon -> [Type] -> [Type]
                -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]))
   | StockClassError SDoc      -- Stock class, but can't do it
   | CanDeriveAnyClass         -- See Note [Deriving any class]
@@ -563,6 +564,7 @@ hasStockDeriving
   :: Class -> Maybe (SrcSpan
                      -> TyCon
                      -> [Type]
+                     -> [Type]
                      -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]))
 hasStockDeriving clas
   = assocMaybe gen_list (getUnique clas)
@@ -571,6 +573,7 @@ hasStockDeriving clas
       :: [(Unique, SrcSpan
                    -> TyCon
                    -> [Type]
+                   -> [Type]
                    -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]))]
     gen_list = [ (eqClassKey,          simpleM gen_Eq_binds)
                , (ordClassKey,         simpleM gen_Ord_binds)
@@ -587,25 +590,25 @@ hasStockDeriving clas
                , (genClassKey,         generic (gen_Generic_binds Gen0))
                , (gen1ClassKey,        generic (gen_Generic_binds Gen1)) ]
 
-    simple gen_fn loc tc _
-      = let (binds, deriv_stuff) = gen_fn loc tc
+    simple gen_fn loc tc tc_args _
+      = let (binds, deriv_stuff) = gen_fn loc tc tc_args
         in return (binds, deriv_stuff, [])
 
     -- Like `simple`, but monadic. The only monadic thing that these functions
     -- do is allocate new Uniques, which are used for generating the names of
     -- auxiliary bindings.
     -- See Note [Auxiliary binders] in GHC.Tc.Deriv.Generate.
-    simpleM gen_fn loc tc _
-      = do { (binds, deriv_stuff) <- gen_fn loc tc
+    simpleM gen_fn loc tc tc_args _
+      = do { (binds, deriv_stuff) <- gen_fn loc tc tc_args
            ; return (binds, deriv_stuff, []) }
 
-    read_or_show gen_fn loc tc _
+    read_or_show gen_fn loc tc tc_args _
       = do { fix_env <- getDataConFixityFun tc
-           ; let (binds, deriv_stuff) = gen_fn fix_env loc tc
+           ; let (binds, deriv_stuff) = gen_fn fix_env loc tc tc_args
                  field_names          = all_field_names tc
            ; return (binds, deriv_stuff, field_names) }
 
-    generic gen_fn _ tc inst_tys
+    generic gen_fn _ tc _ inst_tys
       = do { (binds, faminst) <- gen_fn tc inst_tys
            ; let field_names = all_field_names tc
            ; return (binds, unitBag (DerivFamInst faminst), field_names) }

compiler/GHC/Types/Name/Reader.hs

@@ -338,13 +338,24 @@ instance Ord RdrName where
 ************************************************************************
 -}
 
+{- Note [LocalRdrEnv]
+~~~~~~~~~~~~~~~~~~~~~
+The LocalRdrEnv is used to store local bindings (let, where, lambda, case).
+
+* It is keyed by OccName, because we never use it for qualified names.
+
+* It maps the OccName to a Name.  That Name is almost always an
+  Internal Name, but (hackily) it can be External too for top-level
+  pattern bindings.  See Note [bindLocalNames for an External name]
+  in GHC.Rename.Pat
+
+* We keep the current mapping (lre_env), *and* the set of all Names in
+  scope (lre_in_scope).  Reason: see Note [Splicing Exact names] in
+  GHC.Rename.Env.
+-}
+
 -- | Local Reader Environment
---
--- This environment is used to store local bindings
--- (@let@, @where@, lambda, @case@).
--- It is keyed by OccName, because we never use it for qualified names
--- We keep the current mapping, *and* the set of all Names in scope
--- Reason: see Note [Splicing Exact names] in "GHC.Rename.Env"
+-- See Note [LocalRdrEnv]
 data LocalRdrEnv = LRE { lre_env      :: OccEnv Name
                        , lre_in_scope :: NameSet }
 
@@ -364,16 +375,15 @@ emptyLocalRdrEnv = LRE { lre_env = emptyOccEnv
                        , lre_in_scope = emptyNameSet }
 
 extendLocalRdrEnv :: LocalRdrEnv -> Name -> LocalRdrEnv
--- The Name should be a non-top-level thing
+-- See Note [LocalRdrEnv]
 extendLocalRdrEnv lre@(LRE { lre_env = env, lre_in_scope = ns }) name
-  = WARN( isExternalName name, ppr name )
-    lre { lre_env      = extendOccEnv env (nameOccName name) name
+  = lre { lre_env      = extendOccEnv env (nameOccName name) name
         , lre_in_scope = extendNameSet ns name }
 
 extendLocalRdrEnvList :: LocalRdrEnv -> [Name] -> LocalRdrEnv
+-- See Note [LocalRdrEnv]
 extendLocalRdrEnvList lre@(LRE { lre_env = env, lre_in_scope = ns }) names
-  = WARN( any isExternalName names, ppr names )
-    lre { lre_env = extendOccEnvList env [(nameOccName n, n) | n <- names]
+  = lre { lre_env = extendOccEnvList env [(nameOccName n, n) | n <- names]
         , lre_in_scope = extendNameSetList ns names }
 
 lookupLocalRdrEnv :: LocalRdrEnv -> RdrName -> Maybe Name

libraries/base/Data/Maybe.hs

@@ -149,7 +149,7 @@ fromJust Nothing  = error "Maybe.fromJust: Nothing" -- yuck
 fromJust (Just x) = x
 
 -- | The 'fromMaybe' function takes a default value and a 'Maybe'
--- value.  If the 'Maybe' is 'Nothing', it returns the default values;
+-- value.  If the 'Maybe' is 'Nothing', it returns the default value;
 -- otherwise, it returns the value contained in the 'Maybe'.
 --
 -- ==== __Examples__

libraries/ghc-bignum/src/GHC/Num/BigNat.hs

@@ -228,8 +228,8 @@ bigNatToWordList bn = go (bigNatSize# bn)
 -- | Convert two Word# (most-significant first) into a BigNat
 bigNatFromWord2# :: Word# -> Word# -> BigNat#
 bigNatFromWord2# 0## 0## = bigNatZero# (# #)
-bigNatFromWord2# 0## n   = bigNatFromWord# n
-bigNatFromWord2# w1 w2   = wordArrayFromWord2# w1 w2
+bigNatFromWord2# 0## l   = bigNatFromWord# l
+bigNatFromWord2# h   l   = wordArrayFromWord2# h l
 
 -- | Convert a BigNat into a Word#
 bigNatToWord# :: BigNat# -> Word#

libraries/ghc-bignum/src/GHC/Num/Natural.hs

@@ -86,8 +86,8 @@ naturalFromWord# x = NS x
 -- | Convert two Word# (most-significant first) into a Natural
 naturalFromWord2# :: Word# -> Word# -> Natural
 naturalFromWord2# 0## 0## = naturalZero
-naturalFromWord2# 0## n   = NS n
-naturalFromWord2# w1 w2   = NB (bigNatFromWord2# w2 w1)
+naturalFromWord2# 0## l   = NS l
+naturalFromWord2# h   l   = NB (bigNatFromWord2# h l)
 
 -- | Create a Natural from a Word
 naturalFromWord :: Word -> Natural

libraries/ghc-bignum/src/GHC/Num/WordArray.hs

@@ -121,12 +121,14 @@ withNewWordArrayTrimedMaybe# sz act = case runRW# io of (# _, a #) -> a
 
 -- | Create a WordArray# from two Word#
 --
--- `byteArrayFromWord2# msw lsw = lsw:msw`
+-- `wordArrayFromWord2# h l
+--    where h is the most significant word
+--          l is the least significant word
 wordArrayFromWord2# :: Word# -> Word# -> WordArray#
-wordArrayFromWord2# msw lsw   =
+wordArrayFromWord2# h l   =
    withNewWordArray# 2# \mwa s ->
-      case mwaWrite# mwa 0# lsw s of
-         s -> mwaWrite# mwa 1# msw s
+      case mwaWrite# mwa 0# l s of
+         s -> mwaWrite# mwa 1# h s
 
 -- | Create a WordArray# from one Word#
 wordArrayFromWord# :: Word# -> WordArray#

testsuite/tests/deriving/should_compile/T16341.hs

+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveLift #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE StandaloneDeriving #-}
+
+module T16341 where
+
+import Language.Haskell.TH.Syntax (Lift)
+
+data Foo a where
+  Foo1 :: Foo Int
+  Foo2 :: (Bool -> Bool) -> Foo Bool
+
+-- These instances should work whether or not `Foo2` is a constructor in
+-- `Foo`, because the `Foo Int` designation precludes `Foo2` from being
+-- a reachable constructor
+deriving instance Show (Foo Int)
+deriving instance Eq (Foo Int)
+deriving instance Ord (Foo Int)
+deriving instance Lift (Foo Int)
+
+data Bar a b where
+  Bar1 :: b -> Bar Int b
+  Bar2 :: (Bool -> Bool) -> b -> Bar Bool b
+
+deriving instance Functor (Bar Int)
+deriving instance Foldable (Bar Int)
+deriving instance Traversable (Bar Int)

testsuite/tests/deriving/should_compile/all.T

@@ -118,6 +118,7 @@ test('T15398', normal, compile, [''])
 test('T15637', normal, compile, [''])
 test('T15831', normal, compile, [''])
 test('T16179', normal, compile, [''])
+test('T16341', normal, compile, [''])
 test('T16518', normal, compile, [''])
 test('T17324', normal, compile, [''])
 test('T17339', normal, compile,

testsuite/tests/numeric/should_run/T18509.hs

+import Numeric.Natural
+
+main :: IO ()
+main = do
+   print $ (0xFFFFFFFF0 * 0xFFFFFFFF0 :: Natural)
+   print $ (2 :: Natural) ^ (190 :: Int)

testsuite/tests/numeric/should_run/T18509.stdout

+4722366480670621958400
+1569275433846670190958947355801916604025588861116008628224

testsuite/tests/numeric/should_run/all.T

@@ -71,3 +71,4 @@ test('T497', normal, compile_and_run, ['-O'])
 test('T17303', normal, compile_and_run, [''])
 test('T18359', normal, compile_and_run, [''])
 test('T18499', normal, compile_and_run, [''])
+test('T18509', normal, compile_and_run, [''])