[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: Fix rtsopts documentation

Marge Bot gitlab at gitlab.haskell.org
Tue Sep 15 12:39:09 UTC 2020



 Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC


Commits:
12df556f by DenisFrezzato at 2020-09-15T08:38:50-04:00
Fix rtsopts documentation

- - - - -
feb39b40 by Simon Peyton Jones at 2020-09-15T08:38:52-04:00
Care with implicit-parameter superclasses

Two bugs, #18627 and #18649, had the same cause: we were not
account for the fact that a constaint tuple might hide an implicit
parameter.

The solution is not hard: look for implicit parameters in
superclasses.  See Note [Local implicit parameters] in
GHC.Core.Predicate.

Then we use this new function in two places

* The "short-cut solver" in GHC.Tc.Solver.Interact.shortCutSolver
  which simply didn't handle implicit parameters properly at all.
  This fixes #18627

* The specialiser, which should not specialise on implicit parameters
  This fixes #18649

There are some lingering worries (see Note [Local implicit
parameters]) but things are much better.

- - - - -
46405e53 by Zubin Duggal at 2020-09-15T08:38:53-04:00
Export enrichHie from GHC.Iface.Ext.Ast

This is useful for `ghcide`

- - - - -
e7327efb by Sylvain Henry at 2020-09-15T08:38:56-04:00
Enhance metrics output

- - - - -
9b49af09 by Ryan Scott at 2020-09-15T08:38:57-04:00
Introduce and use DerivClauseTys (#18662)

This switches `deriv_clause_tys` so that instead of using a list of
`LHsSigType`s to represent the types in a `deriving` clause, it now
uses a sum type. `DctSingle` represents a `deriving` clause with no
enclosing parentheses, while `DctMulti` represents a clause with
enclosing parentheses. This makes pretty-printing easier and avoids
confusion between `HsParTy` and the enclosing parentheses in
`deriving` clauses, which are different semantically.

Fixes #18662.

- - - - -


30 changed files:

- compiler/GHC/Core/Opt/Specialise.hs
- compiler/GHC/Core/Predicate.hs
- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Hs/Extension.hs
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/HsToCore/Docs.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/PostProcess/Haddock.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Tc/Deriv.hs
- compiler/GHC/Tc/Instance/Class.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/Solver.hs
- compiler/GHC/Tc/Solver/Canonical.hs
- compiler/GHC/Tc/Solver/Interact.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/TyCl/Instance.hs
- compiler/GHC/Tc/Utils/TcType.hs
- compiler/GHC/ThToHs.hs
- docs/users_guide/phases.rst
- testsuite/driver/perf_notes.py
- testsuite/driver/runtests.py
- + testsuite/tests/simplCore/should_compile/T18649.hs
- + testsuite/tests/simplCore/should_compile/T18649.stderr
- testsuite/tests/simplCore/should_compile/all.T
- + testsuite/tests/typecheck/should_run/T18627.hs
- + testsuite/tests/typecheck/should_run/T18627.stdout
- testsuite/tests/typecheck/should_run/all.T


Changes:

=====================================
compiler/GHC/Core/Opt/Specialise.hs
=====================================
@@ -2514,9 +2514,12 @@ mkCallUDs' env f args
     -- we decide on a case by case basis if we want to specialise
     -- on this argument; if so, SpecDict, if not UnspecArg
     mk_spec_arg arg (Anon InvisArg pred)
-      | type_determines_value (scaledThing pred)
-      , interestingDict env arg -- Note [Interesting dictionary arguments]
+      | not (isIPLikePred (scaledThing pred))
+              -- See Note [Type determines value]
+      , interestingDict env arg
+              -- See Note [Interesting dictionary arguments]
       = SpecDict arg
+
       | otherwise = UnspecArg
 
     mk_spec_arg _ (Anon VisArg _)
@@ -2529,41 +2532,18 @@ mkCallUDs' env f args
          -- in specImports
          -- Use 'realIdUnfolding' to ignore the loop-breaker flag!
 
-    type_determines_value pred    -- See Note [Type determines value]
-        = case classifyPredType pred of
-            ClassPred cls _ -> not (isIPClass cls)  -- Superclasses can't be IPs
-            EqPred {}       -> True
-            IrredPred {}    -> True   -- Things like (D []) where D is a
-                                      -- Constraint-ranged family; #7785
-            ForAllPred {}   -> True
-
-{-
-Note [Type determines value]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Only specialise on non-IP *class* params, because these are the ones
-whose *type* determines their *value*.  In particular, with implicit
-params, the type args *don't* say what the value of the implicit param
-is!  See #7101.
+{- Note [Type determines value]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Only specialise on non-impicit-parameter predicates, because these
+are the ones whose *type* determines their *value*.  In particular,
+with implicit params, the type args *don't* say what the value of the
+implicit param is!  See #7101.
 
 So we treat implicit params just like ordinary arguments for the
 purposes of specialisation.  Note that we still want to specialise
 functions with implicit params if they have *other* dicts which are
 class params; see #17930.
 
-One apparent additional complexity involves type families. For
-example, consider
-         type family D (v::*->*) :: Constraint
-         type instance D [] = ()
-         f :: D v => v Char -> Int
-If we see a call (f "foo"), we'll pass a "dictionary"
-  () |> (g :: () ~ D [])
-and it's good to specialise f at this dictionary.
-
-So the question is: can an implicit parameter "hide inside" a
-type-family constraint like (D a).  Well, no.  We don't allow
-        type instance D Maybe = ?x:Int
-Hence the IrredPred case in type_determines_value.  See #7785.
-
 Note [Interesting dictionary arguments]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider this


=====================================
compiler/GHC/Core/Predicate.hs
=====================================
@@ -20,9 +20,10 @@ module GHC.Core.Predicate (
   mkClassPred, isDictTy,
   isClassPred, isEqPredClass, isCTupleClass,
   getClassPredTys, getClassPredTys_maybe,
+  classMethodTy, classMethodInstTy,
 
   -- Implicit parameters
-  isIPPred, isIPPred_maybe, isIPTyCon, isIPClass, hasIPPred,
+  isIPLikePred, hasIPSuperClasses, isIPTyCon, isIPClass,
 
   -- Evidence variables
   DictId, isEvVar, isDictId
@@ -39,12 +40,10 @@ import GHC.Core.Multiplicity ( scaledThing )
 
 import GHC.Builtin.Names
 
-import GHC.Data.FastString
 import GHC.Utils.Outputable
 import GHC.Utils.Misc
 import GHC.Utils.Panic
 
-import Control.Monad ( guard )
 
 -- | A predicate in the solver. The solver tries to prove Wanted predicates
 -- from Given ones.
@@ -95,6 +94,26 @@ getClassPredTys_maybe ty = case splitTyConApp_maybe ty of
         Just (tc, tys) | Just clas <- tyConClass_maybe tc -> Just (clas, tys)
         _ -> Nothing
 
+classMethodTy :: Id -> Type
+-- Takes a class selector op :: forall a. C a => meth_ty
+-- and returns the type of its method, meth_ty
+-- The selector can be a superclass selector, in which case
+-- you get back a superclass
+classMethodTy sel_id
+  = funResultTy $        -- meth_ty
+    dropForAlls $        -- C a => meth_ty
+    varType sel_id        -- forall a. C n => meth_ty
+
+classMethodInstTy :: Id -> [Type] -> Type
+-- Takes a class selector op :: forall a b. C a b => meth_ty
+-- and the types [ty1, ty2] at which it is instantiated,
+-- returns the instantiated type of its method, meth_ty[t1/a,t2/b]
+-- The selector can be a superclass selector, in which case
+-- you get back a superclass
+classMethodInstTy sel_id arg_tys
+  = funResultTy $
+    piResultTys (varType sel_id) arg_tys
+
 -- --------------------- Equality predicates ---------------------------------
 
 -- | A choice of equality relation. This is separate from the type 'Role'
@@ -170,7 +189,7 @@ isEqPredClass :: Class -> Bool
 isEqPredClass cls =  cls `hasKey` eqTyConKey
                   || cls `hasKey` heqTyConKey
 
-isClassPred, isEqPred, isEqPrimPred, isIPPred :: PredType -> Bool
+isClassPred, isEqPred, isEqPrimPred :: PredType -> Bool
 isClassPred ty = case tyConAppTyCon_maybe ty of
     Just tyCon | isClassTyCon tyCon -> True
     _                               -> False
@@ -186,9 +205,15 @@ isEqPred ty  -- True of (a ~ b) and (a ~~ b)
 isEqPrimPred ty = isCoVarType ty
   -- True of (a ~# b) (a ~R# b)
 
-isIPPred ty = case tyConAppTyCon_maybe ty of
-    Just tc -> isIPTyCon tc
-    _       -> False
+isCTupleClass :: Class -> Bool
+isCTupleClass cls = isTupleTyCon (classTyCon cls)
+
+
+{- *********************************************************************
+*                                                                      *
+              Implicit parameters
+*                                                                      *
+********************************************************************* -}
 
 isIPTyCon :: TyCon -> Bool
 isIPTyCon tc = tc `hasKey` ipClassKey
@@ -197,31 +222,103 @@ isIPTyCon tc = tc `hasKey` ipClassKey
 isIPClass :: Class -> Bool
 isIPClass cls = cls `hasKey` ipClassKey
 
-isCTupleClass :: Class -> Bool
-isCTupleClass cls = isTupleTyCon (classTyCon cls)
+isIPLikePred :: Type -> Bool
+-- See Note [Local implicit parameters]
+isIPLikePred = is_ip_like_pred initIPRecTc
 
-isIPPred_maybe :: Type -> Maybe (FastString, Type)
-isIPPred_maybe ty =
-  do (tc,[t1,t2]) <- splitTyConApp_maybe ty
-     guard (isIPTyCon tc)
-     x <- isStrLitTy t1
-     return (x,t2)
-
-hasIPPred :: PredType -> Bool
-hasIPPred pred
-  = case classifyPredType pred of
-      ClassPred cls tys
-        | isIPClass     cls -> True
-        | isCTupleClass cls -> any hasIPPred tys
-      _other -> False
 
-{-
-************************************************************************
+is_ip_like_pred :: RecTcChecker -> Type -> Bool
+is_ip_like_pred rec_clss ty
+  | Just (tc, tys) <- splitTyConApp_maybe ty
+  , Just rec_clss' <- if isTupleTyCon tc  -- Tuples never cause recursion
+                      then Just rec_clss
+                      else checkRecTc rec_clss tc
+  , Just cls       <- tyConClass_maybe tc
+  = isIPClass cls || has_ip_super_classes rec_clss' cls tys
+
+  | otherwise
+  = False -- Includes things like (D []) where D is
+          -- a Constraint-ranged family; #7785
+
+hasIPSuperClasses :: Class -> [Type] -> Bool
+-- See Note [Local implicit parameters]
+hasIPSuperClasses = has_ip_super_classes initIPRecTc
+
+has_ip_super_classes :: RecTcChecker -> Class -> [Type] -> Bool
+has_ip_super_classes rec_clss cls tys
+  = any ip_ish (classSCSelIds cls)
+  where
+    -- Check that the type of a superclass determines its value
+    -- sc_sel_id :: forall a b. C a b -> <superclass type>
+    ip_ish sc_sel_id = is_ip_like_pred rec_clss $
+                       classMethodInstTy sc_sel_id tys
+
+initIPRecTc :: RecTcChecker
+initIPRecTc = setRecTcMaxBound 1 initRecTc
+
+{- Note [Local implicit parameters]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The function isIPLikePred tells if this predicate, or any of its
+superclasses, is an implicit parameter.
+
+Why are implicit parameters special?  Unlike normal classes, we can
+have local instances for implicit parameters, in the form of
+   let ?x = True in ...
+So in various places we must be careful not to assume that any value
+of the right type will do; we must carefully look for the innermost binding.
+So isIPLikePred checks whether this is an implicit parameter, or has
+a superclass that is an implicit parameter.
+
+Several wrinkles
+
+* We must be careful with superclasses, as #18649 showed.  Haskell
+  doesn't allow an implicit parameter as a superclass
+    class (?x::a) => C a where ...
+  but with a constraint tuple we might have
+     (% Eq a, ?x::Int %)
+  and /its/ superclasses, namely (Eq a) and (?x::Int), /do/ include an
+  implicit parameter.
+
+  With ConstraintKinds this can apply to /any/ class, e.g.
+     class sc => C sc where ...
+  Then (C (?x::Int)) has (?x::Int) as a superclass.  So we must
+  instantiate and check each superclass, one by one, in
+  hasIPSuperClasses.
+
+* With -XRecursiveSuperClasses, the superclass hunt can go on forever,
+  so we need a RecTcChecker to cut it off.
+
+* Another apparent additional complexity involves type families. For
+  example, consider
+         type family D (v::*->*) :: Constraint
+         type instance D [] = ()
+         f :: D v => v Char -> Int
+  If we see a call (f "foo"), we'll pass a "dictionary"
+    () |> (g :: () ~ D [])
+  and it's good to specialise f at this dictionary.
+
+So the question is: can an implicit parameter "hide inside" a
+type-family constraint like (D a).  Well, no.  We don't allow
+        type instance D Maybe = ?x:Int
+Hence the umbrella 'otherwise' case in is_ip_like_pred.  See #7785.
+
+Small worries (Sept 20):
+* I don't see what stops us having that 'type instance'. Indeed I
+  think nothing does.
+* I'm a little concerned about type variables; such a variable might
+  be instantiated to an implicit parameter.  I don't think this
+  matters in the cases for which isIPLikePred is used, and it's pretty
+  obscure anyway.
+* The superclass hunt stops when it encounters the same class again,
+  but in principle we could have the same class, differently instantiated,
+  and the second time it could have an implicit parameter
+I'm going to treat these as problems for another day. They are all exotic.  -}
+
+{- *********************************************************************
 *                                                                      *
               Evidence variables
 *                                                                      *
-************************************************************************
--}
+********************************************************************* -}
 
 isEvVar :: Var -> Bool
 isEvVar var = isEvVarType (varType var)


=====================================
compiler/GHC/Hs/Decls.hs
=====================================
@@ -25,7 +25,8 @@
 module GHC.Hs.Decls (
   -- * Toplevel declarations
   HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving, LHsFunDep,
-  HsDerivingClause(..), LHsDerivingClause, NewOrData(..), newOrDataToFlavour,
+  HsDerivingClause(..), LHsDerivingClause, DerivClauseTys(..), LDerivClauseTys,
+  NewOrData(..), newOrDataToFlavour,
   StandaloneKindSig(..), LStandaloneKindSig, standaloneKindSigName,
 
   -- ** Class or type declarations
@@ -1321,15 +1322,8 @@ data HsDerivingClause pass
     , deriv_clause_strategy :: Maybe (LDerivStrategy pass)
       -- ^ The user-specified strategy (if any) to use when deriving
       -- 'deriv_clause_tys'.
-    , deriv_clause_tys :: XRec pass [LHsSigType pass]
+    , deriv_clause_tys :: LDerivClauseTys pass
       -- ^ The types to derive.
-      --
-      -- It uses 'LHsSigType's because, with @-XGeneralizedNewtypeDeriving@,
-      -- we can mention type variables that aren't bound by the datatype, e.g.
-      --
-      -- > data T b = ... deriving (C [a])
-      --
-      -- should produce a derived instance for @C [a] (T b)@.
     }
   | XHsDerivingClause !(XXHsDerivingClause pass)
 
@@ -1342,16 +1336,9 @@ instance OutputableBndrId p
                         , deriv_clause_tys      = L _ dct })
     = hsep [ text "deriving"
            , pp_strat_before
-           , pp_dct dct
+           , ppr dct
            , pp_strat_after ]
       where
-        -- This complexity is to distinguish between
-        --    deriving Show
-        --    deriving (Show)
-        pp_dct [HsIB { hsib_body = ty }]
-                 = ppr (parenthesizeHsType appPrec ty)
-        pp_dct _ = parens (interpp'SP dct)
-
         -- @via@ is unique in that in comes /after/ the class being derived,
         -- so we must special-case it.
         (pp_strat_before, pp_strat_after) =
@@ -1359,6 +1346,43 @@ instance OutputableBndrId p
             Just (L _ via at ViaStrategy{}) -> (empty, ppr via)
             _                            -> (ppDerivStrategy dcs, empty)
 
+type LDerivClauseTys pass = XRec pass (DerivClauseTys pass)
+
+-- | The types mentioned in a single @deriving@ clause. This can come in two
+-- forms, 'DctSingle' or 'DctMulti', depending on whether the types are
+-- surrounded by enclosing parentheses or not. These parentheses are
+-- semantically differnt than 'HsParTy'. For example, @deriving ()@ means
+-- \"derive zero classes\" rather than \"derive an instance of the 0-tuple\".
+--
+-- 'DerivClauseTys' use 'LHsSigType' because @deriving@ clauses can mention
+-- type variables that aren't bound by the datatype, e.g.
+--
+-- > data T b = ... deriving (C [a])
+--
+-- should produce a derived instance for @C [a] (T b)@.
+data DerivClauseTys pass
+  = -- | A @deriving@ clause with a single type. Moreover, that type can only
+    -- be a type constructor without any arguments.
+    --
+    -- Example: @deriving Eq@
+    DctSingle (XDctSingle pass) (LHsSigType pass)
+
+    -- | A @deriving@ clause with a comma-separated list of types, surrounded
+    -- by enclosing parentheses.
+    --
+    -- Example: @deriving (Eq, C a)@
+  | DctMulti (XDctMulti pass) [LHsSigType pass]
+
+  | XDerivClauseTys !(XXDerivClauseTys pass)
+
+type instance XDctSingle (GhcPass _) = NoExtField
+type instance XDctMulti  (GhcPass _) = NoExtField
+type instance XXDerivClauseTys (GhcPass _) = NoExtCon
+
+instance OutputableBndrId p => Outputable (DerivClauseTys (GhcPass p)) where
+  ppr (DctSingle _ ty) = ppr ty
+  ppr (DctMulti _ tys) = parens (interpp'SP tys)
+
 -- | Located Standalone Kind Signature
 type LStandaloneKindSig pass = XRec pass (StandaloneKindSig pass)
 


=====================================
compiler/GHC/Hs/Extension.hs
=====================================
@@ -446,6 +446,12 @@ type family XXHsDataDefn      x
 type family XCHsDerivingClause      x
 type family XXHsDerivingClause      x
 
+-- -------------------------------------
+-- DerivClauseTys type families
+type family XDctSingle       x
+type family XDctMulti        x
+type family XXDerivClauseTys x
+
 -- -------------------------------------
 -- ConDecl type families
 type family XConDeclGADT   x


=====================================
compiler/GHC/Hs/Instances.hs
=====================================
@@ -163,6 +163,11 @@ deriving instance Data (HsDerivingClause GhcPs)
 deriving instance Data (HsDerivingClause GhcRn)
 deriving instance Data (HsDerivingClause GhcTc)
 
+-- deriving instance DataIdLR p p => Data (DerivClauseTys p)
+deriving instance Data (DerivClauseTys GhcPs)
+deriving instance Data (DerivClauseTys GhcRn)
+deriving instance Data (DerivClauseTys GhcTc)
+
 -- deriving instance (DataIdLR p p) => Data (ConDecl p)
 deriving instance Data (ConDecl GhcPs)
 deriving instance Data (ConDecl GhcRn)


=====================================
compiler/GHC/HsToCore/Docs.hs
=====================================
@@ -193,13 +193,19 @@ subordinates instMap decl = case decl of
                   , (L _ (ConDeclField _ ns _ doc)) <- (unLoc flds)
                   , (L _ n) <- ns ]
         derivs  = [ (instName, [unLoc doc], M.empty)
-                  | (l, doc) <- mapMaybe (extract_deriv_ty . hsib_body) $
-                                concatMap (unLoc . deriv_clause_tys . unLoc) $
+                  | (l, doc) <- concatMap (extract_deriv_clause_tys .
+                                           deriv_clause_tys . unLoc) $
                                 unLoc $ dd_derivs dd
                   , Just instName <- [lookupSrcSpan l instMap] ]
 
-        extract_deriv_ty :: LHsType GhcRn -> Maybe (SrcSpan, LHsDocString)
-        extract_deriv_ty (L l ty) =
+        extract_deriv_clause_tys :: LDerivClauseTys GhcRn -> [(SrcSpan, LHsDocString)]
+        extract_deriv_clause_tys (L _ dct) =
+          case dct of
+            DctSingle _ ty -> maybeToList $ extract_deriv_ty ty
+            DctMulti _ tys -> mapMaybe extract_deriv_ty tys
+
+        extract_deriv_ty :: LHsSigType GhcRn -> Maybe (SrcSpan, LHsDocString)
+        extract_deriv_ty (HsIB{hsib_body =  L l ty}) =
           case ty of
             -- deriving (forall a. C a {- ^ Doc comment -})
             HsForAllTy{ hst_tele = HsForAllInvis{}


=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -945,13 +945,18 @@ repDerivClause :: LHsDerivingClause GhcRn
                -> MetaM (Core (M TH.DerivClause))
 repDerivClause (L _ (HsDerivingClause
                           { deriv_clause_strategy = dcs
-                          , deriv_clause_tys      = L _ dct }))
+                          , deriv_clause_tys      = dct }))
   = repDerivStrategy dcs $ \(MkC dcs') ->
-    do MkC dct' <- repListM typeTyConName (rep_deriv_ty . hsSigType) dct
+    do MkC dct' <- rep_deriv_clause_tys dct
        rep2 derivClauseName [dcs',dct']
   where
-    rep_deriv_ty :: LHsType GhcRn -> MetaM (Core (M TH.Type))
-    rep_deriv_ty ty = repLTy ty
+    rep_deriv_clause_tys :: LDerivClauseTys GhcRn -> MetaM (Core [M TH.Type])
+    rep_deriv_clause_tys (L _ dct) = case dct of
+      DctSingle _ ty -> rep_deriv_tys [ty]
+      DctMulti _ tys -> rep_deriv_tys tys
+
+    rep_deriv_tys :: [LHsSigType GhcRn] -> MetaM (Core [M TH.Type])
+    rep_deriv_tys = repListM typeTyConName (repLTy . hsSigType)
 
 rep_meth_sigs_binds :: [LSig GhcRn] -> LHsBinds GhcRn
                     -> MetaM ([GenSymBind], [Core (M TH.Dec)])


=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -19,7 +19,7 @@ Main functions for .hie file generation
 {-# LANGUAGE TupleSections #-}
 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
 
-module GHC.Iface.Ext.Ast ( mkHieFile, mkHieFileWithSource, getCompressedAsts) where
+module GHC.Iface.Ext.Ast ( mkHieFile, mkHieFileWithSource, getCompressedAsts, enrichHie) where
 
 import GHC.Utils.Outputable(ppr)
 
@@ -1507,12 +1507,16 @@ instance ToHie (Located [Located (HsDerivingClause GhcRn)]) where
 
 instance ToHie (Located (HsDerivingClause GhcRn)) where
   toHie (L span cl) = concatM $ makeNode cl span : case cl of
-      HsDerivingClause _ strat (L ispan tys) ->
+      HsDerivingClause _ strat dct ->
         [ toHie strat
-        , locOnly ispan
-        , toHie $ map (TS (ResolvedScopes [])) tys
+        , toHie dct
         ]
 
+instance ToHie (Located (DerivClauseTys GhcRn)) where
+  toHie (L span dct) = concatM $ makeNode dct span : case dct of
+      DctSingle _ ty -> [ toHie $ TS (ResolvedScopes[]) ty ]
+      DctMulti _ tys -> [ toHie $ map (TS (ResolvedScopes [])) tys ]
+
 instance ToHie (Located (DerivStrategy GhcRn)) where
   toHie (L span strat) = concatM $ makeNode strat span : case strat of
       StockStrategy -> []


=====================================
compiler/GHC/Parser.y
=====================================
@@ -2276,15 +2276,13 @@ deriving :: { LHsDerivingClause GhcPs }
                  in ams (L full_loc $ HsDerivingClause noExtField (Just $3) $2)
                         [mj AnnDeriving $1] }
 
-deriv_clause_types :: { Located [LHsSigType GhcPs] }
+deriv_clause_types :: { LDerivClauseTys GhcPs }
         : qtycon              { let { tc = sL1 $1 (HsTyVar noExtField NotPromoted $1) } in
-                                sL1 $1 [mkLHsSigType tc] }
-        | '(' ')'             {% ams (sLL $1 $> [])
+                                sL1 $1 (DctSingle noExtField (mkLHsSigType tc)) }
+        | '(' ')'             {% ams (sLL $1 $> (DctMulti noExtField []))
                                      [mop $1,mcp $2] }
-        | '(' deriv_types ')' {% ams (sLL $1 $> $2)
+        | '(' deriv_types ')' {% ams (sLL $1 $> (DctMulti noExtField $2))
                                      [mop $1,mcp $3] }
-             -- Glasgow extension: allow partial
-             -- applications in derivings
 
 -----------------------------------------------------------------------------
 -- Value definitions


=====================================
compiler/GHC/Parser/PostProcess/Haddock.hs
=====================================
@@ -628,15 +628,34 @@ instance HasHaddock (Located (HsDerivingClause GhcPs)) where
               Just (L l (ViaStrategy _)) -> (pure (), registerLocHdkA l)
               Just (L l _) -> (registerLocHdkA l, pure ())
         register_strategy_before
-        deriv_clause_tys' <-
-          extendHdkA (getLoc deriv_clause_tys) $
-          traverse @Located addHaddock deriv_clause_tys
+        deriv_clause_tys' <- addHaddock deriv_clause_tys
         register_strategy_after
         pure HsDerivingClause
           { deriv_clause_ext = noExtField,
             deriv_clause_strategy,
             deriv_clause_tys = deriv_clause_tys' }
 
+-- Process the types in a single deriving clause, which may come in one of the
+-- following forms:
+--
+--    1. A singular type constructor:
+--          deriving Eq -- ^ Comment on Eq
+--
+--    2. A list of comma-separated types surrounded by enclosing parentheses:
+--          deriving ( Eq  -- ^ Comment on Eq
+--                   , C a -- ^ Comment on C a
+--                   )
+instance HasHaddock (Located (DerivClauseTys GhcPs)) where
+  addHaddock (L l_dct dct) =
+    extendHdkA l_dct $
+    case dct of
+      DctSingle x ty -> do
+        ty' <- addHaddock ty
+        pure $ L l_dct $ DctSingle x ty'
+      DctMulti x tys -> do
+        tys' <- addHaddock tys
+        pure $ L l_dct $ DctMulti x tys'
+
 -- Process a single data constructor declaration, which may come in one of the
 -- following forms:
 --


=====================================
compiler/GHC/Rename/Module.hs
=====================================
@@ -1895,15 +1895,25 @@ rnLHsDerivingClause doc
                 (L loc (HsDerivingClause
                               { deriv_clause_ext = noExtField
                               , deriv_clause_strategy = dcs
-                              , deriv_clause_tys = L loc' dct }))
+                              , deriv_clause_tys = dct }))
   = do { (dcs', dct', fvs)
-           <- rnLDerivStrategy doc dcs $ mapFvRn rn_clause_pred dct
+           <- rnLDerivStrategy doc dcs $ rn_deriv_clause_tys dct
        ; warnNoDerivStrat dcs' loc
        ; pure ( L loc (HsDerivingClause { deriv_clause_ext = noExtField
                                         , deriv_clause_strategy = dcs'
-                                        , deriv_clause_tys = L loc' dct' })
+                                        , deriv_clause_tys = dct' })
               , fvs ) }
   where
+    rn_deriv_clause_tys :: LDerivClauseTys GhcPs
+                        -> RnM (LDerivClauseTys GhcRn, FreeVars)
+    rn_deriv_clause_tys (L l dct) = case dct of
+      DctSingle x ty -> do
+        (ty', fvs) <- rn_clause_pred ty
+        pure (L l (DctSingle x ty'), fvs)
+      DctMulti x tys -> do
+        (tys', fvs) <- mapFvRn rn_clause_pred tys
+        pure (L l (DctMulti x tys'), fvs)
+
     rn_clause_pred :: LHsSigType GhcPs -> RnM (LHsSigType GhcRn, FreeVars)
     rn_clause_pred pred_ty = do
       let inf_err = Just (text "Inferred type variables are not allowed")


=====================================
compiler/GHC/Tc/Deriv.hs
=====================================
@@ -437,17 +437,22 @@ makeDerivSpecs :: [DerivInfo]
                -> TcM [EarlyDerivSpec]
 makeDerivSpecs deriv_infos deriv_decls
   = do  { eqns1 <- sequenceA
-                     [ deriveClause rep_tc scoped_tvs dcs preds err_ctxt
+                     [ deriveClause rep_tc scoped_tvs dcs (deriv_clause_preds dct) err_ctxt
                      | DerivInfo { di_rep_tc = rep_tc
                                  , di_scoped_tvs = scoped_tvs
                                  , di_clauses = clauses
                                  , di_ctxt = err_ctxt } <- deriv_infos
                      , L _ (HsDerivingClause { deriv_clause_strategy = dcs
-                                             , deriv_clause_tys = L _ preds })
+                                             , deriv_clause_tys = dct })
                          <- clauses
                      ]
         ; eqns2 <- mapM (recoverM (pure Nothing) . deriveStandalone) deriv_decls
         ; return $ concat eqns1 ++ catMaybes eqns2 }
+  where
+    deriv_clause_preds :: LDerivClauseTys GhcRn -> [LHsSigType GhcRn]
+    deriv_clause_preds (L _ dct) = case dct of
+      DctSingle _ ty -> [ty]
+      DctMulti _ tys -> tys
 
 ------------------------------------------------------------------
 -- | Process the derived classes in a single @deriving@ clause.


=====================================
compiler/GHC/Tc/Instance/Class.hs
=====================================
@@ -388,10 +388,9 @@ makeLitDict clas ty et
     | Just (_, co_dict) <- tcInstNewTyCon_maybe (classTyCon clas) [ty]
           -- co_dict :: KnownNat n ~ SNat n
     , [ meth ]   <- classMethods clas
-    , Just tcRep <- tyConAppTyCon_maybe -- SNat
-                      $ funResultTy         -- SNat n
-                      $ dropForAlls         -- KnownNat n => SNat n
-                      $ idType meth         -- forall n. KnownNat n => SNat n
+    , Just tcRep <- tyConAppTyCon_maybe (classMethodTy meth)
+                    -- If the method type is forall n. KnownNat n => SNat n
+                    -- then tcRep is SNat
     , Just (_, co_rep) <- tcInstNewTyCon_maybe tcRep [ty]
           -- SNat n ~ Integer
     , let ev_tm = mkEvCast et (mkTcSymCo (mkTcTransCo co_dict co_rep))


=====================================
compiler/GHC/Tc/Module.hs
=====================================
@@ -65,9 +65,10 @@ import GHC.Builtin.Types ( unitTy, mkListTy )
 import GHC.Driver.Plugins
 import GHC.Driver.Session
 import GHC.Hs
-import GHC.Iface.Syntax ( ShowSub(..), showToHeader )
-import GHC.Iface.Type   ( ShowForAllFlag(..) )
-import GHC.Core.PatSyn( pprPatSynType )
+import GHC.Iface.Syntax   ( ShowSub(..), showToHeader )
+import GHC.Iface.Type     ( ShowForAllFlag(..) )
+import GHC.Core.PatSyn    ( pprPatSynType )
+import GHC.Core.Predicate ( classMethodTy )
 import GHC.Builtin.Names
 import GHC.Builtin.Utils
 import GHC.Types.Name.Reader
@@ -1014,10 +1015,8 @@ checkBootTyCon is_boot tc1 tc2
           name2 = idName id2
           pname1 = quotes (ppr name1)
           pname2 = quotes (ppr name2)
-          (_, rho_ty1) = splitForAllTys (idType id1)
-          op_ty1 = funResultTy rho_ty1
-          (_, rho_ty2) = splitForAllTys (idType id2)
-          op_ty2 = funResultTy rho_ty2
+          op_ty1 = classMethodTy id1
+          op_ty2 = classMethodTy id2
 
        eqAT (ATI tc1 def_ats1) (ATI tc2 def_ats2)
          = checkBootTyCon is_boot tc1 tc2 `andThenCheck`


=====================================
compiler/GHC/Tc/Solver.hs
=====================================
@@ -1374,7 +1374,7 @@ growThetaTyVars theta tcvs
   | otherwise  = transCloVarSet mk_next seed_tcvs
   where
     seed_tcvs = tcvs `unionVarSet` tyCoVarsOfTypes ips
-    (ips, non_ips) = partition isIPPred theta
+    (ips, non_ips) = partition isIPLikePred theta
                          -- See Note [Inheriting implicit parameters] in GHC.Tc.Utils.TcType
 
     mk_next :: VarSet -> VarSet -- Maps current set to newly-grown ones


=====================================
compiler/GHC/Tc/Solver/Canonical.hs
=====================================
@@ -29,7 +29,7 @@ import GHC.Core.Multiplicity
 import GHC.Core.TyCo.Rep   -- cleverly decomposes types, good for completeness checking
 import GHC.Core.Coercion
 import GHC.Core
-import GHC.Types.Id( idType, mkTemplateLocals )
+import GHC.Types.Id( mkTemplateLocals )
 import GHC.Core.FamInstEnv ( FamInstEnvs )
 import GHC.Tc.Instance.Family ( tcTopNormaliseNewTypeTF_maybe )
 import GHC.Types.Var
@@ -542,7 +542,7 @@ mk_strict_superclasses rec_clss (CtGiven { ctev_evar = evar, ctev_loc = loc })
                          mk_given_desc sel_id sc_pred
            ; mk_superclasses rec_clss given_ev tvs theta sc_pred }
       where
-        sc_pred  = funResultTy (piResultTys (idType sel_id) tys)
+        sc_pred = classMethodInstTy sel_id tys
 
       -- See Note [Nested quantified constraint superclasses]
     mk_given_desc :: Id -> PredType -> (PredType, EvTerm)


=====================================
compiler/GHC/Tc/Solver/Interact.hs
=====================================
@@ -566,10 +566,10 @@ solveOneFromTheOther ev_i ev_w
      ev_id_w = ctEvEvId ev_w
 
      different_level_strategy  -- Both Given
-       | isIPPred pred = if lvl_w > lvl_i then KeepWork  else KeepInert
-       | otherwise     = if lvl_w > lvl_i then KeepInert else KeepWork
+       | isIPLikePred pred = if lvl_w > lvl_i then KeepWork  else KeepInert
+       | otherwise         = if lvl_w > lvl_i then KeepInert else KeepWork
        -- See Note [Replacement vs keeping] (the different-level bullet)
-       -- For the isIPPred case see Note [Shadowing of Implicit Parameters]
+       -- For the isIPLikePred case see Note [Shadowing of Implicit Parameters]
 
      same_level_strategy binds -- Both Given
        | GivenOrigin (InstSC s_i) <- ctLocOrigin loc_i
@@ -1071,6 +1071,8 @@ shortCutSolver dflags ev_w ev_i
  -- programs should typecheck regardless of whether we take this step or
  -- not. See Note [Shortcut solving]
 
+ && not (isIPLikePred (ctEvPred ev_w))   -- Not for implicit parameters (#18627)
+
  && not (xopt LangExt.IncoherentInstances dflags)
  -- If IncoherentInstances is on then we cannot rely on coherence of proofs
  -- in order to justify this optimization: The proof provided by the
@@ -1079,6 +1081,7 @@ shortCutSolver dflags ev_w ev_i
 
  && gopt Opt_SolveConstantDicts dflags
  -- Enabled by the -fsolve-constant-dicts flag
+
   = do { ev_binds_var <- getTcEvBindsVar
        ; ev_binds <- ASSERT2( not (isCoEvBindsVar ev_binds_var ), ppr ev_w )
                      getTcEvBindsMap ev_binds_var


=====================================
compiler/GHC/Tc/Solver/Monad.hs
=====================================
@@ -2527,8 +2527,7 @@ emptyDictMap = emptyTcAppMap
 
 findDict :: DictMap a -> CtLoc -> Class -> [Type] -> Maybe a
 findDict m loc cls tys
-  | isCTupleClass cls
-  , any hasIPPred tys   -- See Note [Tuples hiding implicit parameters]
+  | hasIPSuperClasses cls tys -- See Note [Tuples hiding implicit parameters]
   = Nothing
 
   | Just {} <- isCallStackPred cls tys


=====================================
compiler/GHC/Tc/TyCl/Instance.hs
=====================================
@@ -54,6 +54,7 @@ import GHC.Core.Make   ( nO_METHOD_BINDING_ERROR_ID )
 import GHC.Core.Unfold.Make ( mkInlineUnfoldingWithArity, mkDFunUnfolding )
 import GHC.Core.Type
 import GHC.Core.SimpleOpt
+import GHC.Core.Predicate( classMethodInstTy )
 import GHC.Tc.Types.Evidence
 import GHC.Core.TyCon
 import GHC.Core.Coercion.Axiom
@@ -1634,7 +1635,7 @@ tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys
                               nO_METHOD_BINDING_ERROR_ID
         error_msg dflags = L inst_loc (HsLit noExtField (HsStringPrim NoSourceText
                                               (unsafeMkByteString (error_string dflags))))
-        meth_tau     = funResultTy (piResultTys (idType sel_id) inst_tys)
+        meth_tau     = classMethodInstTy sel_id inst_tys
         error_string dflags = showSDoc dflags
                               (hcat [ppr inst_loc, vbar, ppr sel_id ])
         lam_wrapper  = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars


=====================================
compiler/GHC/Tc/Utils/TcType.hs
=====================================
@@ -79,7 +79,7 @@ module GHC.Tc.Utils.TcType (
   isFloatingTy, isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy,
   isIntegerTy, isNaturalTy,
   isBoolTy, isUnitTy, isCharTy, isCallStackTy, isCallStackPred,
-  hasIPPred, isTauTy, isTauTyCon, tcIsTyVarTy, tcIsForAllTy,
+  isTauTy, isTauTyCon, tcIsTyVarTy, tcIsForAllTy,
   isPredTy, isTyVarClassPred, isTyVarHead, isInsolubleOccursCheck,
   checkValidClsArgs, hasTyVarHead,
   isRigidTy, isAlmostFunctionFree,
@@ -141,7 +141,7 @@ module GHC.Tc.Utils.TcType (
   mkTyConTy, mkTyVarTy, mkTyVarTys,
   mkTyCoVarTy, mkTyCoVarTys,
 
-  isClassPred, isEqPrimPred, isIPPred, isEqPred, isEqPredClass,
+  isClassPred, isEqPrimPred, isIPLikePred, isEqPred, isEqPredClass,
   mkClassPred,
   tcSplitDFunTy, tcSplitDFunHead, tcSplitMethodTy,
   isRuntimeRepVar, isKindLevPoly,
@@ -1747,7 +1747,7 @@ pickCapturedPreds
 pickCapturedPreds qtvs theta
   = filter captured theta
   where
-    captured pred = isIPPred pred || (tyCoVarsOfType pred `intersectsVarSet` qtvs)
+    captured pred = isIPLikePred pred || (tyCoVarsOfType pred `intersectsVarSet` qtvs)
 
 
 -- Superclasses


=====================================
compiler/GHC/ThToHs.hs
=====================================
@@ -1393,12 +1393,25 @@ cvtContext p tys = do { preds' <- mapM cvtPred tys
 cvtPred :: TH.Pred -> CvtM (LHsType GhcPs)
 cvtPred = cvtType
 
+cvtDerivClauseTys :: TH.Cxt -> CvtM (LDerivClauseTys GhcPs)
+cvtDerivClauseTys tys
+  = do { tys' <- mapM cvtType tys
+         -- Since TH.Cxt doesn't indicate the presence or absence of
+         -- parentheses in a deriving clause, we have to choose between
+         -- DctSingle and DctMulti somewhat arbitrarily. We opt to use DctMulti
+         -- unless the TH.Cxt is a singleton list whose type is a bare type
+         -- constructor with no arguments.
+       ; case tys' of
+           [ty'@(L l (HsTyVar _ NotPromoted _))]
+                 -> return $ L l $ DctSingle noExtField $ mkLHsSigType ty'
+           _     -> returnL $ DctMulti noExtField (map mkLHsSigType tys') }
+
 cvtDerivClause :: TH.DerivClause
                -> CvtM (LHsDerivingClause GhcPs)
-cvtDerivClause (TH.DerivClause ds ctxt)
-  = do { ctxt' <- fmap (map mkLHsSigType) <$> cvtContext appPrec ctxt
-       ; ds'   <- traverse cvtDerivStrategy ds
-       ; returnL $ HsDerivingClause noExtField ds' ctxt' }
+cvtDerivClause (TH.DerivClause ds tys)
+  = do { tys' <- cvtDerivClauseTys tys
+       ; ds'  <- traverse cvtDerivStrategy ds
+       ; returnL $ HsDerivingClause noExtField ds' tys' }
 
 cvtDerivStrategy :: TH.DerivStrategy -> CvtM (Hs.LDerivStrategy GhcPs)
 cvtDerivStrategy TH.StockStrategy    = returnL Hs.StockStrategy


=====================================
docs/users_guide/phases.rst
=====================================
@@ -1028,7 +1028,7 @@ for example).
 
     This option affects the processing of RTS control options given
     either on the command line or via the :envvar:`GHCRTS` environment
-    variable. There are three possibilities:
+    variable. There are five possibilities:
 
     ``-rtsopts=none``
         Disable all processing of RTS options. If ``+RTS`` appears


=====================================
testsuite/driver/perf_notes.py
=====================================
@@ -108,12 +108,12 @@ class MetricChange(Enum):
         }
         return strings[self]
 
-    def short_name(self):
+    def hint(self):
         strings = {
-            MetricChange.NewMetric: "new",
-            MetricChange.NoChange:  "unch",
-            MetricChange.Increase:  "incr",
-            MetricChange.Decrease:  "decr"
+            MetricChange.NewMetric: colored(Color.BLUE,"NEW"),
+            MetricChange.NoChange:  "",
+            MetricChange.Increase:  colored(Color.RED, "BAD"),
+            MetricChange.Decrease:  colored(Color.GREEN,"GOOD")
         }
         return strings[self]
 


=====================================
testsuite/driver/runtests.py
=====================================
@@ -348,21 +348,21 @@ def tabulate_metrics(metrics: List[PerfMetric]) -> None:
     hideBaselineEnv = not hasBaseline or all(
         [x.stat.test_env == x.baseline.perfStat.test_env
          for x in metrics if x.baseline is not None])
-    def row(cells: Tuple[str, str, str, str, str, str, str]) -> List[str]:
+    def row(cells: Tuple[str, str, str, str, str, str, str, str]) -> List[str]:
         return [x for (idx, x) in enumerate(list(cells)) if
                 (idx != 2 or not hideBaselineCommit) and
                 (idx != 3 or not hideBaselineEnv )]
 
     headerRows = [
-        row(("", "", "Baseline", "Baseline", "Baseline", "", "")),
-        row(("Test", "Metric", "commit", "environment", "value", "New value", "Change"))
+        row(("", "", "Baseline", "Baseline", "Baseline", "", "", "")),
+        row(("Test", "Metric", "commit", "environment", "value", "New value", "Change", ""))
     ]
     def strDiff(x: PerfMetric) -> str:
         if x.baseline is None:
             return ""
         val0 = x.baseline.perfStat.value
         val1 = x.stat.value
-        return "{}({:+2.1f}%)".format(x.change.short_name(), 100 * (val1 - val0) / val0)
+        return "{:+2.1f}%".format(100 * (val1 - val0) / val0)
     dataRows = [row((
         "{}({})".format(x.stat.test, x.stat.way),
         shorten_metric_name(x.stat.metric),
@@ -374,7 +374,8 @@ def tabulate_metrics(metrics: List[PerfMetric]) -> None:
         "{:13.1f}".format(x.baseline.perfStat.value)
           if x.baseline is not None else "",
         "{:13.1f}".format(x.stat.value),
-        strDiff(x)
+        strDiff(x),
+        "{}".format(x.change.hint())
     )) for x in sorted(metrics, key =
                       lambda m: (m.stat.test, m.stat.way, m.stat.metric))]
     print_table(headerRows, dataRows, 1)


=====================================
testsuite/tests/simplCore/should_compile/T18649.hs
=====================================
@@ -0,0 +1,26 @@
+{-# LANGUAGE ImplicitParams #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+module Test where
+
+import Prelude
+
+type Hidden a =
+  ( ?enable :: a
+  , Eq a  -- removing this "fixes" the issue
+  )
+
+{-# NOINLINE a #-}
+a :: Hidden Bool => Integer -> Bool
+a _ = ?enable
+
+system :: Hidden Bool => Bool
+system = a 0
+
+topEntity :: Bool -> Bool
+topEntity ena = let ?enable = ena
+                in system
+
+someVar = let ?enable = True
+          in system


=====================================
testsuite/tests/simplCore/should_compile/T18649.stderr
=====================================
@@ -0,0 +1,4 @@
+
+==================== Tidy Core rules ====================
+
+


=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -333,3 +333,7 @@ test('T18347', normal, compile, ['-dcore-lint -O'])
 test('T18355', [ grep_errmsg(r'OneShot') ], compile, ['-O -ddump-simpl -dsuppress-uniques'])
 test('T18399', normal, compile, ['-dcore-lint -O'])
 test('T18589', normal, compile, ['-dcore-lint -O'])
+
+# T18649 should /not/ generate a specialisation rule
+test('T18649', normal, compile, ['-O -ddump-rules -Wno-simplifiable-class-constraints'])
+


=====================================
testsuite/tests/typecheck/should_run/T18627.hs
=====================================
@@ -0,0 +1,16 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ImplicitParams #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+module Main where
+
+import GHC.Classes
+
+instance IP "x" Int where
+  ip = 21
+
+baz :: (?x :: Int) => Int
+baz = ?x
+
+main :: IO ()
+main  = let ?x = 42
+        in print baz


=====================================
testsuite/tests/typecheck/should_run/T18627.stdout
=====================================
@@ -0,0 +1 @@
+42


=====================================
testsuite/tests/typecheck/should_run/all.T
=====================================
@@ -146,3 +146,4 @@ test('UnliftedNewtypesDependentFamilyRun', normal, compile_and_run, [''])
 test('UnliftedNewtypesIdentityRun', normal, compile_and_run, [''])
 test('UnliftedNewtypesCoerceRun', normal, compile_and_run, [''])
 test('T17104', normal, compile_and_run, [''])
+test('T18627', normal, compile_and_run, ['-O'])  # Optimisation shows up the bug



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/15748dcb170fab11d975b501baafc0ab61b98bdb...9b49af09cbcf73c18253adf3e381e46c915d5b13

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/15748dcb170fab11d975b501baafc0ab61b98bdb...9b49af09cbcf73c18253adf3e381e46c915d5b13
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200915/0cb4cdc1/attachment-0001.html>


More information about the ghc-commits mailing list