[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 6 commits: Add GHCi :instances command

Marge Bot gitlab at gitlab.haskell.org
Tue Jun 4 19:14:16 UTC 2019 


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


Commits:
002594b7 by Xavier Denis at 2019-06-04T18:41:29Z
Add GHCi :instances command

This commit adds the `:instances` command to ghci following proosal
number 41.

This makes it possible to query which instances are available to a given
type.

The output of this command is all the possible instances with type
variables and constraints instantiated.

- - - - -
3ecc03df by Ben Gamari at 2019-06-04T18:42:04Z
gitlab-ci: Run bindisttest during CI

- - - - -
c16f3297 by Ben Gamari at 2019-06-04T18:42:04Z
make: Fix bindist installation

This fixes a few vestigial references to `settings` left over from !655.
Fixes #16715.

- - - - -
ba4e3934 by Alp Mestanogullari at 2019-06-04T18:43:17Z
Hadrian: profiling and debug enabled ways support -eventlog too

- - - - -
950efc74 by Matthew Pickering at 2019-06-04T19:14:08Z
Add HEAP_PROF_SAMPLE_END event to mark end of samples

This allows a user to observe how long a sampling period lasts so that
the time taken can be removed from the profiling output.

Fixes #16697

- - - - -
e0cef1b8 by Ben Gamari at 2019-06-04T19:14:09Z
Hadrian: Delete target symlink in createFileLinkUntracked

Previously createFileLinkUntracked would fail if the symlink already
existed.

- - - - -


24 changed files:

- .gitlab-ci.yml
- compiler/main/GHC.hs
- compiler/main/HscMain.hs
- compiler/main/InteractiveEval.hs
- compiler/typecheck/TcRnDriver.hs
- compiler/types/InstEnv.hs
- docs/users_guide/8.10.1-notes.rst
- docs/users_guide/eventlog-formats.rst
- docs/users_guide/ghci.rst
- ghc.mk
- ghc/GHCi/UI.hs
- ghc/ghc.mk
- hadrian/src/Hadrian/Utilities.hs
- hadrian/src/Settings/Builders/Ghc.hs
- includes/rts/EventLogFormat.h
- rts/ProfHeap.c
- rts/Trace.c
- rts/Trace.h
- rts/eventlog/EventLog.c
- rts/eventlog/EventLog.h
- testsuite/tests/ghci/scripts/all.T
- + testsuite/tests/ghci/scripts/ghci064.hs
- + testsuite/tests/ghci/scripts/ghci064.script
- + testsuite/tests/ghci/scripts/ghci064.stdout


Changes:

=====================================
.gitlab-ci.yml
=====================================
@@ -217,6 +217,8 @@ hadrian-ghc-in-ghci:
     - |
       THREADS=`mk/detect-cpu-count.sh`
       make V=0 -j$THREADS WERROR=-Werror
+    - |
+      make bindisttest
     - |
       make binary-dist TAR_COMP_OPTS="-1"
     - |
@@ -650,6 +652,7 @@ nightly-i386-windows-hadrian:
     - bash -c "echo include mk/flavours/${BUILD_FLAVOUR}.mk > mk/build.mk"
     - bash -c "echo 'GhcLibHcOpts+=-haddock' >> mk/build.mk"
     - bash -c "PATH=`pwd`/toolchain/bin:$PATH make -j`mk/detect-cpu-count.sh`"
+    - bash -c "PATH=`pwd`/toolchain/bin:$PATH make bindisttest"
     - bash -c "PATH=`pwd`/toolchain/bin:$PATH make binary-dist TAR_COMP_OPTS=-1"
     - bash -c 'make V=0 test THREADS=`mk/detect-cpu-count.sh` JUNIT_FILE=../../junit.xml'
   tags:


=====================================
compiler/main/GHC.hs
=====================================
@@ -219,6 +219,8 @@ module GHC (
         Kind,
         PredType,
         ThetaType, pprForAll, pprThetaArrowTy,
+        parseInstanceHead,
+        getInstancesForType,
 
         -- ** Entities
         TyThing(..),


=====================================
compiler/main/HscMain.hs
=====================================
@@ -67,6 +67,7 @@ module HscMain
     , hscDecls, hscParseDeclsWithLocation, hscDeclsWithLocation, hscParsedDecls
     , hscTcExpr, TcRnExprMode(..), hscImport, hscKcType
     , hscParseExpr
+    , hscParseType
     , hscCompileCoreExpr
     -- * Low-level exports for hooks
     , hscCompileCoreExpr'
@@ -113,6 +114,7 @@ import SrcLoc
 import TcRnDriver
 import TcIface          ( typecheckIface )
 import TcRnMonad
+import TcHsSyn          ( ZonkFlexi (DefaultFlexi) )
 import NameCache        ( initNameCache )
 import LoadIface        ( ifaceStats, initExternalPackageState )
 import PrelInfo
@@ -1761,7 +1763,7 @@ hscKcType
 hscKcType hsc_env0 normalise str = runInteractiveHsc hsc_env0 $ do
     hsc_env <- getHscEnv
     ty <- hscParseType str
-    ioMsgMaybe $ tcRnType hsc_env normalise ty
+    ioMsgMaybe $ tcRnType hsc_env DefaultFlexi normalise ty
 
 hscParseExpr :: String -> Hsc (LHsExpr GhcPs)
 hscParseExpr expr = do


=====================================
compiler/main/InteractiveEval.hs
=====================================
@@ -30,6 +30,8 @@ module InteractiveEval (
         exprType,
         typeKind,
         parseName,
+        parseInstanceHead,
+        getInstancesForType,
         getDocs,
         GetDocsFailure(..),
         showModule,
@@ -102,6 +104,19 @@ import GHC.Exts
 import Data.Array
 import Exception
 
+import TcRnDriver ( runTcInteractive, tcRnType )
+import TcHsSyn          ( ZonkFlexi (SkolemiseFlexi) )
+
+import TcEnv (tcGetInstEnvs)
+
+import Inst (instDFunType)
+import TcSimplify (solveWanteds)
+import TcRnMonad
+import TcEvidence
+import Data.Bifunctor (second)
+
+import TcSMonad (runTcS)
+
 -- -----------------------------------------------------------------------------
 -- running a statement interactively
 
@@ -937,6 +952,161 @@ typeKind  :: GhcMonad m => Bool -> String -> m (Type, Kind)
 typeKind normalise str = withSession $ \hsc_env -> do
    liftIO $ hscKcType hsc_env normalise str
 
+-- ----------------------------------------------------------------------------
+-- Getting the class instances for a type
+
+{-
+  Note [Querying instances for a type]
+
+  Here is the implementation of GHC proposal 41.
+  (https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0041-ghci-instances.rst)
+
+  The objective is to take a query string representing a (partial) type, and
+  report all the class single-parameter class instances available to that type.
+  Extending this feature to multi-parameter typeclasses is left as future work.
+
+  The general outline of how we solve this is:
+
+  1. Parse the type, leaving skolems in the place of type-holes.
+  2. For every class, get a list of all instances that match with the query type.
+  3. For every matching instance, ask GHC for the context the instance dictionary needs.
+  4. Format and present the results, substituting our query into the instance
+     and simplifying the context.
+
+  For example, given the query "Maybe Int", we want to return:
+
+  instance Show (Maybe Int)
+  instance Read (Maybe Int)
+  instance Eq   (Maybe Int)
+  ....
+
+  [Holes in queries]
+
+  Often times we want to know what instances are available for a polymorphic type,
+  like `Maybe a`, and we'd like to return instances such as:
+
+  instance Show a => Show (Maybe a)
+  ....
+
+  These queries are expressed using type holes, so instead of `Maybe a` the user writes
+  `Maybe _`, we parse the type and during zonking, we skolemise it, replacing the holes
+  with (un-named) type variables.
+
+  When zonking the type holes we have two real choices: replace them with Any or replace
+  them with skolem typevars. Using skolem type variables ensures that the output is more
+  intuitive to end users, and there is no difference in the results between Any and skolems.
+
+-}
+
+-- Find all instances that match a provided type
+getInstancesForType :: GhcMonad m => Type -> m [ClsInst]
+getInstancesForType ty = withSession $ \hsc_env -> do
+  liftIO $ runInteractiveHsc hsc_env $ do
+    ioMsgMaybe $ runTcInteractive hsc_env $ do
+      matches <- findMatchingInstances ty
+      fmap catMaybes . forM matches $ uncurry checkForExistence
+
+-- Parse a type string and turn any holes into skolems
+parseInstanceHead :: GhcMonad m => String -> m Type
+parseInstanceHead str = withSession $ \hsc_env0 -> do
+  (ty, _) <- liftIO $ runInteractiveHsc hsc_env0 $ do
+    hsc_env <- getHscEnv
+    ty <- hscParseType str
+    ioMsgMaybe $ tcRnType hsc_env SkolemiseFlexi True ty
+
+  return ty
+
+-- Get all the constraints required of a dictionary binding
+getDictionaryBindings :: PredType -> TcM WantedConstraints
+getDictionaryBindings theta = do
+  dictName <- newName (mkDictOcc (mkVarOcc "magic"))
+  let dict_var = mkVanillaGlobal dictName theta
+  loc <- getCtLocM (GivenOrigin UnkSkol) Nothing
+  let wCs = mkSimpleWC [CtDerived
+          { ctev_pred = varType dict_var
+          , ctev_loc = loc
+          }]
+
+  return wCs
+
+{-
+  When we've found an instance that a query matches against, we still need to
+  check that all the instance's constraints are satisfiable. checkForExistence
+  creates an instance dictionary and verifies that any unsolved constraints
+  mention a type-hole, meaning it is blocked on an unknown.
+
+  If the instance satisfies this condition, then we return it with the query
+  substituted into the instance and all constraints simplified, for example given:
+
+  instance D a => C (MyType a b) where
+
+  and the query `MyType _ String`
+
+  the unsolved constraints will be [D _] so we apply the substitution:
+
+  { a -> _; b -> String}
+
+  and return the instance:
+
+  instance D _ => C (MyType _ String)
+
+-}
+
+checkForExistence :: ClsInst -> [DFunInstType] -> TcM (Maybe ClsInst)
+checkForExistence res mb_inst_tys = do
+  (tys, thetas) <- instDFunType (is_dfun res) mb_inst_tys
+
+  wanteds <- forM thetas getDictionaryBindings
+  (residuals, _) <- second evBindMapBinds <$> runTcS (solveWanteds (unionsWC wanteds))
+
+  let all_residual_constraints = bagToList $ wc_simple residuals
+  let preds = map ctPred all_residual_constraints
+  if all isSatisfiablePred preds && (null $ wc_impl residuals)
+  then return . Just $ substInstArgs tys preds res
+  else return Nothing
+
+  where
+
+  -- Stricter version of isTyVarClassPred that requires all TyConApps to have at least
+  -- one argument or for the head to be a TyVar. The reason is that we want to ensure
+  -- that all residual constraints mention a type-hole somewhere in the constraint,
+  -- meaning that with the correct choice of a concrete type it could be possible for
+  -- the constraint to be discharged.
+  isSatisfiablePred :: PredType -> Bool
+  isSatisfiablePred ty = case getClassPredTys_maybe ty of
+      Just (_, tys@(_:_)) -> all isTyVarTy tys
+      _                   -> isTyVarTy ty
+
+  empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType (idType $ is_dfun res)))
+
+  {- Create a ClsInst with instantiated arguments and constraints.
+
+     The thetas are the list of constraints that couldn't be solved because
+     they mention a type-hole.
+  -}
+  substInstArgs ::  [Type] -> [PredType] -> ClsInst -> ClsInst
+  substInstArgs tys thetas inst = let
+      subst = foldl' (\a b -> uncurry (extendTvSubstAndInScope a) b) empty_subst (zip dfun_tvs tys)
+      -- Build instance head with arguments substituted in
+      tau   = mkClassPred cls (substTheta subst args)
+      -- Constrain the instance with any residual constraints
+      phi   = mkPhiTy thetas tau
+      sigma = mkForAllTys (map (\v -> Bndr v Inferred) dfun_tvs) phi
+
+    in inst { is_dfun = (is_dfun inst) { varType = sigma }}
+    where
+    (dfun_tvs, _, cls, args) = instanceSig inst
+
+-- Find instances where the head unifies with the provided type
+findMatchingInstances :: Type -> TcM [(ClsInst, [DFunInstType])]
+findMatchingInstances ty = do
+  ies@(InstEnvs {ie_global = ie_global, ie_local = ie_local}) <- tcGetInstEnvs
+  let allClasses = instEnvClasses ie_global ++ instEnvClasses ie_local
+
+  concat <$> mapM (\cls -> do
+    let (matches, _, _) = lookupInstEnv True ies cls [ty]
+    return matches) allClasses
+
 -----------------------------------------------------------------------------
 -- Compile an expression, run it, and deliver the result
 


=====================================
compiler/typecheck/TcRnDriver.hs
=====================================
@@ -2418,10 +2418,11 @@ tcRnImportDecls hsc_env import_decls
 
 -- tcRnType just finds the kind of a type
 tcRnType :: HscEnv
+         -> ZonkFlexi
          -> Bool        -- Normalise the returned type
          -> LHsType GhcPs
          -> IO (Messages, Maybe (Type, Kind))
-tcRnType hsc_env normalise rdr_type
+tcRnType hsc_env flexi normalise rdr_type
   = runTcInteractive hsc_env $
     setXOptM LangExt.PolyKinds $   -- See Note [Kind-generalise in tcRnType]
     do { (HsWC { hswc_ext = wcs, hswc_body = rn_type }, _fvs)
@@ -2444,7 +2445,9 @@ tcRnType hsc_env normalise rdr_type
        -- Do kind generalisation; see Note [Kind-generalise in tcRnType]
        ; kind <- zonkTcType kind
        ; kvs <- kindGeneralize kind
-       ; ty  <- zonkTcTypeToType ty
+       ; e <- mkEmptyZonkEnv flexi
+
+       ; ty  <- zonkTcTypeToTypeX e ty
 
        -- Do validity checking on type
        ; checkValidType (GhciCtxt True) ty


=====================================
compiler/types/InstEnv.hs
=====================================
@@ -21,7 +21,7 @@ module InstEnv (
         emptyInstEnv, extendInstEnv,
         deleteFromInstEnv, deleteDFunFromInstEnv,
         identicalClsInstHead,
-        extendInstEnvList, lookupUniqueInstEnv, lookupInstEnv, instEnvElts,
+        extendInstEnvList, lookupUniqueInstEnv, lookupInstEnv, instEnvElts, instEnvClasses,
         memberInstEnv,
         instIsVisible,
         classInstances, instanceBindFun,
@@ -427,6 +427,9 @@ instEnvElts :: InstEnv -> [ClsInst]
 instEnvElts ie = [elt | ClsIE elts <- eltsUDFM ie, elt <- elts]
   -- See Note [InstEnv determinism]
 
+instEnvClasses :: InstEnv -> [Class]
+instEnvClasses ie = [is_cls e | ClsIE (e : _) <- eltsUDFM ie]
+
 -- | Test if an instance is visible, by checking that its origin module
 -- is in 'VisibleOrphanModules'.
 -- See Note [Instance lookup and orphan instances]


=====================================
docs/users_guide/8.10.1-notes.rst
=====================================
@@ -107,6 +107,11 @@ Compiler
   only convenient workaround was to enable `-fobject-code` for all
   modules.
 
+GHCi
+~~~~
+
+- Added a command `:instances` to show the class instances available for a type.
+
 Runtime system
 ~~~~~~~~~~~~~~
 


=====================================
docs/users_guide/eventlog-formats.rst
=====================================
@@ -84,6 +84,14 @@ in length a single sample may need to be split among multiple
 ``EVENT_HEAP_PROF_SAMPLE`` events. The precise format of the census entries is
 determined by the break-down type.
 
+At the end of the sample period the ``EVENT_HEAP_PROF_SAMPLE_END`` event if
+emitted. This is useful to properly delimit the sampling period and to record
+the total time spent profiling.
+
+
+ * ``EVENT_HEAP_PROF_SAMPLE_END``
+   * ``Word64``: sample number
+
 
 Cost-centre break-down
 ^^^^^^^^^^^^^^^^^^^^^^


=====================================
docs/users_guide/ghci.rst
=====================================
@@ -2539,6 +2539,38 @@ commonly used commands.
 
     The ``:loc-at`` command requires :ghci-cmd:`:set +c` to be set.
 
+.. ghci-cmd:: :instances ⟨type⟩
+
+    Displays all the class instances available to the argument ⟨type⟩.
+    The command will match ⟨type⟩ with the first parameter of every
+    instance and then check that all constraints are satisfiable.
+
+    When combined with ``-XPartialTypeSignatures``, a user can insert
+    wildcards into a query and learn the constraints required of each
+    wildcard for ⟨type⟩ match with an instance.
+
+    The output is a listing of all matching instances, simplified and
+    instantiated as much as possible.
+
+    For example:
+
+    .. code-block:: none
+      >:instances Maybe (Maybe Int)
+      instance Eq (Maybe (Maybe Int)) -- Defined in ‘GHC.Maybe’
+      instance Ord (Maybe (Maybe Int)) -- Defined in ‘GHC.Maybe’
+      instance Show (Maybe (Maybe Int)) -- Defined in ‘GHC.Show’
+      instance Read (Maybe (Maybe Int)) -- Defined in ‘GHC.Read’
+
+      >:set -XPartialTypeSignatures -fno-warn-partial-type-signatures
+
+      >:instances Maybe _
+      instance Eq _ => Eq (Maybe _) -- Defined in ‘GHC.Maybe’
+      instance Semigroup _ => Monoid (Maybe _) -- Defined in ‘GHC.Base’
+      instance Ord _ => Ord (Maybe _) -- Defined in ‘GHC.Maybe’
+      instance Semigroup _ => Semigroup (Maybe _) -- Defined in ‘GHC.Base’
+      instance Show _ => Show (Maybe _) -- Defined in ‘GHC.Show’
+      instance Read _ => Read (Maybe _) -- Defined in ‘GHC.Read’
+
 .. ghci-cmd:: :main; ⟨arg1⟩ ... ⟨argn⟩
 
     When a program is compiled and executed, it can use the ``getArgs``


=====================================
ghc.mk
=====================================
@@ -1021,6 +1021,8 @@ $(eval $(call bindist-list,.,\
     $(BINDIST_LIBS) \
     $(BINDIST_HI) \
     $(BINDIST_EXTRAS) \
+    includes/Makefile \
+    $(includes_SETTINGS) \
     $(includes_H_FILES) \
     $(includes_DERIVEDCONSTANTS) \
     $(includes_GHCCONSTANTS) \
@@ -1037,7 +1039,7 @@ $(eval $(call bindist-list,.,\
     $(wildcard compiler/stage2/doc) \
     $(wildcard libraries/*/dist-install/doc/) \
     $(wildcard libraries/*/*/dist-install/doc/) \
-    $(filter-out settings llvm-targets llvm-passes,$(INSTALL_LIBS)) \
+    $(filter-out llvm-targets llvm-passes,$(INSTALL_LIBS)) \
     $(RTS_INSTALL_LIBS) \
     $(filter-out %/project.mk mk/config.mk %/mk/install.mk,$(MAKEFILE_LIST)) \
     mk/project.mk \


=====================================
ghc/GHCi/UI.hs
=====================================
@@ -223,7 +223,8 @@ ghciCommands = map mkCmd [
   ("unadd",     keepGoingPaths unAddModule,     completeFilename),
   ("undef",     keepGoing undefineMacro,        completeMacro),
   ("unset",     keepGoing unsetOptions,         completeSetOptions),
-  ("where",     keepGoing whereCmd,             noCompletion)
+  ("where",     keepGoing whereCmd,             noCompletion),
+  ("instances", keepGoing' instancesCmd,        completeExpression)
   ] ++ map mkCmdHidden [ -- hidden commands
   ("all-types", keepGoing' allTypesCmd),
   ("complete",  keepGoing completeCmd),
@@ -1779,6 +1780,19 @@ handleGetDocsFailure no_docs = do
     NoDocsInIface {} -> InstallationError msg
     InteractiveName -> ProgramError msg
 
+-----------------------------------------------------------------------------
+-- :instances
+
+instancesCmd :: String -> InputT GHCi ()
+instancesCmd "" =
+  throwGhcException (CmdLineError "syntax: ':instances <type-you-want-instances-for>'")
+instancesCmd s = do
+  handleSourceError GHC.printException $ do
+    ty <- GHC.parseInstanceHead s
+    res <- GHC.getInstancesForType ty
+
+    printForUser $ vcat $ map ppr res
+
 -----------------------------------------------------------------------------
 -- :load, :add, :reload
 


=====================================
ghc/ghc.mk
=====================================
@@ -129,10 +129,7 @@ all_ghc_stage1 : $(GHC_STAGE1)
 all_ghc_stage2 : $(GHC_STAGE2)
 all_ghc_stage3 : $(GHC_STAGE3)
 
-settings : $(includes_SETTINGS)
-	"$(CP)" $< $@
-
-$(INPLACE_LIB)/settings : settings
+$(INPLACE_LIB)/settings : $(includes_SETTINGS)
 	"$(CP)" $< $@
 
 $(INPLACE_LIB)/llvm-targets : llvm-targets
@@ -171,7 +168,7 @@ $(GHC_STAGE2) : $(foreach w,$(GhcLibWays),libraries/base/dist-install/build/GHC/
 
 endif
 
-INSTALL_LIBS += settings
+INSTALL_LIBS += $(includes_SETTINGS)
 INSTALL_LIBS += llvm-targets
 INSTALL_LIBS += llvm-passes
 


=====================================
hadrian/src/Hadrian/Utilities.hs
=====================================
@@ -34,6 +34,7 @@ module Hadrian.Utilities (
     Dynamic, fromDynamic, toDyn, TypeRep, typeOf
     ) where
 
+import Control.Applicative
 import Control.Monad.Extra
 import Data.Char
 import Data.Dynamic (Dynamic, fromDynamic, toDyn)
@@ -296,7 +297,9 @@ createFileLinkUntracked linkTarget link = do
     let dir = takeDirectory link
     liftIO $ IO.createDirectoryIfMissing True dir
     putProgressInfo =<< renderCreateFileLink linkTarget link
-    quietly . liftIO $ IO.createFileLink linkTarget link
+    quietly . liftIO $ do
+        IO.removeFile link <|> return ()
+        IO.createFileLink linkTarget link
 
 -- | Link a file tracking the link target. Create the target directory if
 -- missing.


=====================================
hadrian/src/Settings/Builders/Ghc.hs
=====================================
@@ -176,10 +176,12 @@ wayGhcArgs = do
             , (Threaded  `wayUnit` way) ? arg "-optc-DTHREADED_RTS"
             , (Debug     `wayUnit` way) ? arg "-optc-DDEBUG"
             , (Profiling `wayUnit` way) ? arg "-prof"
-            , (Logging   `wayUnit` way) ? arg "-eventlog"
+            , supportsEventlog way ? arg "-eventlog"
             , (way == debug || way == debugDynamic) ?
               pure ["-ticky", "-DTICKY_TICKY"] ]
 
+  where supportsEventlog w = any (`wayUnit` w) [Logging, Profiling, Debug]
+
 packageGhcArgs :: Args
 packageGhcArgs = do
     package <- getPackage


=====================================
includes/rts/EventLogFormat.h
=====================================
@@ -178,6 +178,7 @@
 #define EVENT_HEAP_PROF_SAMPLE_BEGIN       162
 #define EVENT_HEAP_PROF_SAMPLE_COST_CENTRE 163
 #define EVENT_HEAP_PROF_SAMPLE_STRING      164
+#define EVENT_HEAP_PROF_SAMPLE_END         165
 
 #define EVENT_USER_BINARY_MSG              181
 


=====================================
rts/ProfHeap.c
=====================================
@@ -884,6 +884,7 @@ dumpCensus( Census *census )
         fprintf(hp_file, "\t%" FMT_Word "\n", (W_)count * sizeof(W_));
     }
 
+    traceHeapProfSampleEnd(era);
     printSample(false, census->time);
 }
 


=====================================
rts/Trace.c
=====================================
@@ -623,6 +623,13 @@ void traceHeapProfSampleBegin(StgInt era)
     }
 }
 
+void traceHeapProfSampleEnd(StgInt era)
+{
+    if (eventlog_enabled) {
+        postHeapProfSampleEnd(era);
+    }
+}
+
 void traceHeapProfSampleString(StgWord8 profile_id,
                                const char *label, StgWord residency)
 {


=====================================
rts/Trace.h
=====================================
@@ -288,6 +288,7 @@ void traceTaskDelete_ (Task       *task);
 
 void traceHeapProfBegin(StgWord8 profile_id);
 void traceHeapProfSampleBegin(StgInt era);
+void traceHeapProfSampleEnd(StgInt era);
 void traceHeapProfSampleString(StgWord8 profile_id,
                                const char *label, StgWord residency);
 #if defined(PROFILING)
@@ -335,6 +336,7 @@ void flushTrace(void);
 #define traceHeapProfBegin(profile_id) /* nothing */
 #define traceHeapProfCostCentre(ccID, label, module, srcloc, is_caf) /* nothing */
 #define traceHeapProfSampleBegin(era) /* nothing */
+#define traceHeapProfSampleEnd(era) /* nothing */
 #define traceHeapProfSampleCostCentre(profile_id, stack, residency) /* nothing */
 #define traceHeapProfSampleString(profile_id, label, residency) /* nothing */
 


=====================================
rts/eventlog/EventLog.c
=====================================
@@ -103,6 +103,7 @@ char *EventDesc[] = {
   [EVENT_HEAP_PROF_BEGIN]     = "Start of heap profile",
   [EVENT_HEAP_PROF_COST_CENTRE]   = "Cost center definition",
   [EVENT_HEAP_PROF_SAMPLE_BEGIN]  = "Start of heap profile sample",
+  [EVENT_HEAP_PROF_SAMPLE_END]    = "End of heap profile sample",
   [EVENT_HEAP_PROF_SAMPLE_STRING] = "Heap profile string sample",
   [EVENT_HEAP_PROF_SAMPLE_COST_CENTRE] = "Heap profile cost-centre sample",
   [EVENT_USER_BINARY_MSG]     = "User binary message"
@@ -430,6 +431,10 @@ postHeaderEvents(void)
             eventTypes[t].size = 8;
             break;
 
+        case EVENT_HEAP_PROF_SAMPLE_END:
+            eventTypes[t].size = 8;
+            break;
+
         case EVENT_HEAP_PROF_SAMPLE_STRING:
             eventTypes[t].size = EVENT_SIZE_DYNAMIC;
             break;
@@ -1210,6 +1215,15 @@ void postHeapProfSampleBegin(StgInt era)
     RELEASE_LOCK(&eventBufMutex);
 }
 
+void postHeapProfSampleEnd(StgInt era)
+{
+    ACQUIRE_LOCK(&eventBufMutex);
+    ensureRoomForEvent(&eventBuf, EVENT_HEAP_PROF_SAMPLE_END);
+    postEventHeader(&eventBuf, EVENT_HEAP_PROF_SAMPLE_END);
+    postWord64(&eventBuf, era);
+    RELEASE_LOCK(&eventBufMutex);
+}
+
 void postHeapProfSampleString(StgWord8 profile_id,
                               const char *label,
                               StgWord64 residency)


=====================================
rts/eventlog/EventLog.h
=====================================
@@ -140,6 +140,7 @@ void postTaskDeleteEvent (EventTaskId taskId);
 void postHeapProfBegin(StgWord8 profile_id);
 
 void postHeapProfSampleBegin(StgInt era);
+void postHeapProfSampleEnd(StgInt era);
 
 void postHeapProfSampleString(StgWord8 profile_id,
                               const char *label,


=====================================
testsuite/tests/ghci/scripts/all.T
=====================================
@@ -106,7 +106,7 @@ test('ghci062', [extra_files(['ghci062/', 'ghci062/Test.hs']),
                  when(config.have_ext_interp, extra_ways(['ghci-ext']))],
 		ghci_script, ['ghci062.script'])
 test('ghci063', normal, ghci_script, ['ghci063.script'])
-
+test('ghci064', normal, ghci_script, ['ghci064.script'])
 test('T2452', [extra_hc_opts("-fno-implicit-import-qualified")],
     ghci_script, ['T2452.script'])
 test('T2766', normal, ghci_script, ['T2766.script'])


=====================================
testsuite/tests/ghci/scripts/ghci064.hs
=====================================
@@ -0,0 +1,21 @@
+{-# LANGUAGE FlexibleInstances, TypeFamilies #-}
+import Data.Kind (Type)
+
+class MyShow a where
+  myshow :: a -> String
+
+instance MyShow a => MyShow [a] where
+  myshow xs = concatMap myshow xs
+
+data T = MkT
+
+instance MyShow T where
+  myshow x = "Used generic instance"
+
+instance MyShow [T] where
+  myshow xs = "Used more specific instance"
+
+
+type family F a :: Type
+type instance F [a] = a -> F a
+type instance F Int = Bool


=====================================
testsuite/tests/ghci/scripts/ghci064.script
=====================================
@@ -0,0 +1,21 @@
+-- Test :instances
+:instances Maybe
+
+:set -XPartialTypeSignatures -fno-warn-partial-type-signatures
+-- Test queries with holes
+:instances Maybe _
+
+:load ghci064
+
+-- Test that overlapping instances are all reported in the results
+:instances [_]
+:instances [T]
+
+-- Test that we can find instances for type families
+
+:instances F Int
+
+-- Test to make sure that the constraints of returned instances are all properly verified
+-- We don't want the command to return an Applicative or Monad instance for tuple because
+-- there is no Int Monoid instance.
+:instances (,) Int


=====================================
testsuite/tests/ghci/scripts/ghci064.stdout
=====================================
@@ -0,0 +1,35 @@
+instance GHC.Base.Alternative Maybe -- Defined in ‘GHC.Base’
+instance Applicative Maybe -- Defined in ‘GHC.Base’
+instance Functor Maybe -- Defined in ‘GHC.Base’
+instance Monad Maybe -- Defined in ‘GHC.Base’
+instance GHC.Base.MonadPlus Maybe -- Defined in ‘GHC.Base’
+instance Eq _ => Eq (Maybe _) -- Defined in ‘GHC.Maybe’
+instance Semigroup _ => Monoid (Maybe _) -- Defined in ‘GHC.Base’
+instance Ord _ => Ord (Maybe _) -- Defined in ‘GHC.Maybe’
+instance Semigroup _ => Semigroup (Maybe _)
+  -- Defined in ‘GHC.Base’
+instance Show _ => Show (Maybe _) -- Defined in ‘GHC.Show’
+instance Read _ => Read (Maybe _) -- Defined in ‘GHC.Read’
+instance Eq _ => Eq [_] -- Defined in ‘GHC.Classes’
+instance Monoid [_] -- Defined in ‘GHC.Base’
+instance Ord _ => Ord [_] -- Defined in ‘GHC.Classes’
+instance Semigroup [_] -- Defined in ‘GHC.Base’
+instance Show _ => Show [_] -- Defined in ‘GHC.Show’
+instance Read _ => Read [_] -- Defined in ‘GHC.Read’
+instance [safe] MyShow _ => MyShow [_]
+  -- Defined at ghci064.hs:7:10
+instance Monoid [T] -- Defined in ‘GHC.Base’
+instance Semigroup [T] -- Defined in ‘GHC.Base’
+instance [safe] MyShow [T] -- Defined at ghci064.hs:7:10
+instance [safe] MyShow [T] -- Defined at ghci064.hs:15:10
+instance Eq Bool -- Defined in ‘GHC.Classes’
+instance Ord Bool -- Defined in ‘GHC.Classes’
+instance Show Bool -- Defined in ‘GHC.Show’
+instance Read Bool -- Defined in ‘GHC.Read’
+instance Enum Bool -- Defined in ‘GHC.Enum’
+instance Bounded Bool -- Defined in ‘GHC.Enum’
+instance Data.Bits.Bits Bool -- Defined in ‘Data.Bits’
+instance Data.Bits.FiniteBits Bool -- Defined in ‘Data.Bits’
+instance GHC.Arr.Ix Bool -- Defined in ‘GHC.Arr’
+instance Functor ((,) Int) -- Defined in ‘GHC.Base’
+instance Foldable ((,) Int) -- Defined in ‘Data.Foldable’



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/f7e4e4e0e2c2ac650bf8f4f31eac4d2b7c0fd23e...e0cef1b84ad55ec13e8920a8ae7b93f0b574f40b

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/f7e4e4e0e2c2ac650bf8f4f31eac4d2b7c0fd23e...e0cef1b84ad55ec13e8920a8ae7b93f0b574f40b
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/20190604/e78b5e21/attachment-0001.html>

More information about the ghc-commits mailing list