[Git][ghc/ghc][wip/T22715] 3 commits: Allow waiting for timerfd to be interrupted during rts shutdown
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Wed Jan 25 08:14:39 UTC 2023
Simon Peyton Jones pushed to branch wip/T22715 at Glasgow Haskell Compiler / GHC
Commits:
e5383a29 by Wander Hillen at 2023-01-24T20:02:26-05:00
Allow waiting for timerfd to be interrupted during rts shutdown
- - - - -
1957eda1 by Ryan Scott at 2023-01-24T20:03:01-05:00
Restore Compose's Read/Show behavior to match Read1/Show1 instances
Fixes #22816.
- - - - -
d9e4143c by Simon Peyton Jones at 2023-01-25T08:15:20+00:00
Fix in-scope set in specImports
Nothing deep here; I had failed to bring some
floated dictionary binders into scope.
Exposed by -fspecialise-aggressively
Fixes #22715.
- - - - -
10 changed files:
- compiler/GHC/Core/Opt/Specialise.hs
- docs/users_guide/9.8.1-notes.rst
- libraries/base/Data/Functor/Compose.hs
- + libraries/base/tests/T22816.hs
- + libraries/base/tests/T22816.stdout
- libraries/base/tests/all.T
- rts/posix/ticker/Pthread.c
- + testsuite/tests/simplCore/should_compile/T22715_2.hs
- + testsuite/tests/simplCore/should_compile/T22715_2a.hs
- testsuite/tests/simplCore/should_compile/all.T
Changes:
=====================================
compiler/GHC/Core/Opt/Specialise.hs
=====================================
@@ -33,6 +33,7 @@ import GHC.Core.Utils ( exprIsTrivial
import GHC.Core.FVs
import GHC.Core.TyCo.FVs ( tyCoVarsOfTypeList )
import GHC.Core.Opt.Arity( collectBindersPushingCo )
+-- import GHC.Core.Ppr( pprIds )
import GHC.Builtin.Types ( unboxedUnitTy )
@@ -736,7 +737,8 @@ specImports top_env (MkUD { ud_binds = dict_binds, ud_calls = calls })
= return ([], wrapDictBinds dict_binds [])
| otherwise
- = do { (_env, spec_rules, spec_binds) <- spec_imports top_env [] dict_binds calls
+ = do { let env_w_dict_bndrs = top_env `bringFloatedDictsIntoScope` dict_binds
+ ; (_env, spec_rules, spec_binds) <- spec_imports env_w_dict_bndrs [] dict_binds calls
-- Don't forget to wrap the specialized bindings with
-- bindings for the needed dictionaries.
@@ -752,6 +754,7 @@ specImports top_env (MkUD { ud_binds = dict_binds, ud_calls = calls })
-- | Specialise a set of calls to imported bindings
spec_imports :: SpecEnv -- Passed in so that all top-level Ids are in scope
+ ---In-scope set includes the FloatedDictBinds
-> [Id] -- Stack of imported functions being specialised
-- See Note [specImport call stack]
-> FloatedDictBinds -- Dict bindings, used /only/ for filterCalls
@@ -781,6 +784,7 @@ spec_imports env callers dict_binds calls
; return (env, rules1 ++ rules2, spec_binds1 ++ spec_binds2) }
spec_import :: SpecEnv -- Passed in so that all top-level Ids are in scope
+ ---In-scope set includes the FloatedDictBinds
-> [Id] -- Stack of imported functions being specialised
-- See Note [specImport call stack]
-> FloatedDictBinds -- Dict bindings, used /only/ for filterCalls
@@ -806,23 +810,35 @@ spec_import env callers dict_binds cis@(CIS fn _)
; eps_rules <- getExternalRuleBase
; let rule_env = se_rules env `updExternalPackageRules` eps_rules
--- ; debugTraceMsg (text "specImport1" <+> vcat [ppr fn, ppr good_calls
--- , ppr (getRules rule_env fn), ppr rhs])
+-- ; debugTraceMsg (text "specImport1" <+> vcat
+-- [ text "function:" <+> ppr fn
+-- , text "good calls:" <+> ppr good_calls
+-- , text "existing rules:" <+> ppr (getRules rule_env fn)
+-- , text "rhs:" <+> ppr rhs
+-- , text "dict_binds:" <+> ppr dict_binds ])
+
; (rules1, spec_pairs, MkUD { ud_binds = dict_binds1, ud_calls = new_calls })
- <- runSpecM $ specCalls True env dict_binds
- (getRules rule_env fn) good_calls fn rhs
+ <- runSpecM $ specCalls True env (getRules rule_env fn) good_calls fn rhs
; let spec_binds1 = [NonRec b r | (b,r) <- spec_pairs]
- -- After the rules kick in we may get recursion, but
- -- we rely on a global GlomBinds to sort that out later
+ -- After the rules kick in, via fireRewriteRules, we may get recursion,
+ -- but we rely on a global GlomBinds to sort that out later
-- See Note [Glom the bindings if imported functions are specialised]
+ -- Meanwhile, though, bring the binders into scope
new_subst = se_subst env `Core.extendSubstInScopeList` map fst spec_pairs
new_env = env { se_rules = rule_env `addLocalRules` rules1
, se_subst = new_subst }
+ `bringFloatedDictsIntoScope` dict_binds1
+
+ -- Now specialise any cascaded calls
+-- ; debugTraceMsg (text "specImport 2" <+> vcat
+-- [ text "function:" <+> ppr fn
+-- , text "rules1:" <+> ppr rules1
+-- , text "spec_binds1" <+> ppr spec_binds1
+-- , text "dict_binds1" <+> ppr dict_binds1
+-- , text "new_calls" <+> ppr new_calls ])
- -- Now specialise any cascaded calls
--- ; debugTraceMsg (text "specImport 2" <+> (ppr fn $$ ppr rules1 $$ ppr spec_binds1))
; (env, rules2, spec_binds2)
<- spec_imports new_env (fn:callers)
(dict_binds `thenFDBs` dict_binds1)
@@ -1561,10 +1577,11 @@ specDefn :: SpecEnv
specDefn env body_uds fn rhs
= do { let (body_uds_without_me, calls_for_me) = callsForMe fn body_uds
rules_for_me = idCoreRules fn
- dict_binds = ud_binds body_uds
+ -- Bring into scope the binders from the floated dicts
+ env_w_dict_bndrs = bringFloatedDictsIntoScope env (ud_binds body_uds)
- ; (rules, spec_defns, spec_uds) <- specCalls False env dict_binds
- rules_for_me calls_for_me fn rhs
+ ; (rules, spec_defns, spec_uds) <- specCalls False env_w_dict_bndrs
+ rules_for_me calls_for_me fn rhs
; return ( fn `addIdSpecialisations` rules
, spec_defns
@@ -1580,7 +1597,6 @@ specDefn env body_uds fn rhs
specCalls :: Bool -- True => specialising imported fn
-- False => specialising local fn
-> SpecEnv
- -> FloatedDictBinds -- Just so that we can extend the in-scope set
-> [CoreRule] -- Existing RULES for the fn
-> [CallInfo]
-> OutId -> InExpr
@@ -1594,7 +1610,7 @@ type SpecInfo = ( [CoreRule] -- Specialisation rules
, [(Id,CoreExpr)] -- Specialised definition
, UsageDetails ) -- Usage details from specialised RHSs
-specCalls spec_imp env dict_binds existing_rules calls_for_me fn rhs
+specCalls spec_imp env existing_rules calls_for_me fn rhs
-- The first case is the interesting one
| notNull calls_for_me -- And there are some calls to specialise
&& not (isNeverActive (idInlineActivation fn))
@@ -1610,8 +1626,11 @@ specCalls spec_imp env dict_binds existing_rules calls_for_me fn rhs
-- See Note [Inline specialisations] for why we do not
-- switch off specialisation for inline functions
- = -- pprTrace "specCalls: some" (ppr fn $$ ppr calls_for_me $$ ppr existing_rules) $
- foldlM spec_call ([], [], emptyUDs) calls_for_me
+ = do { -- debugTraceMsg (text "specCalls: some" <+> vcat
+ -- [ text "function" <+> ppr fn
+ -- , text "calls:" <+> ppr calls_for_me
+ -- , text "subst" <+> ppr (se_subst env) ])
+ ; foldlM spec_call ([], [], emptyUDs) calls_for_me }
| otherwise -- No calls or RHS doesn't fit our preconceptions
= warnPprTrace (not (exprIsTrivial rhs) && notNull calls_for_me && not (isClassOpId fn))
@@ -1639,9 +1658,6 @@ specCalls spec_imp env dict_binds existing_rules calls_for_me fn rhs
(rhs_bndrs, rhs_body) = collectBindersPushingCo rhs
-- See Note [Account for casts in binding]
- -- Bring into scope the binders from the floated dicts
- env_with_dict_bndrs = bringFloatedDictsIntoScope env dict_binds
-
already_covered :: SpecEnv -> [CoreRule] -> [CoreExpr] -> Bool
already_covered env new_rules args -- Note [Specialisations already covered]
= isJust (specLookupRule env fn args (beginPhase inl_act)
@@ -1667,22 +1683,22 @@ specCalls spec_imp env dict_binds existing_rules calls_for_me fn rhs
; ( useful, rhs_env2, leftover_bndrs
, rule_bndrs, rule_lhs_args
- , spec_bndrs1, dx_binds, spec_args) <- specHeader env_with_dict_bndrs
- rhs_bndrs all_call_args
-
--- ; pprTrace "spec_call" (vcat [ text "fun: " <+> ppr fn
--- , text "call info: " <+> ppr _ci
--- , text "useful: " <+> ppr useful
--- , text "rule_bndrs:" <+> ppr rule_bndrs
--- , text "lhs_args: " <+> ppr rule_lhs_args
--- , text "spec_bndrs1:" <+> ppr spec_bndrs1
--- , text "leftover_bndrs:" <+> pprIds leftover_bndrs
--- , text "spec_args: " <+> ppr spec_args
--- , text "dx_binds: " <+> ppr dx_binds
--- , text "rhs_body" <+> ppr rhs_body
--- , text "rhs_env2: " <+> ppr (se_subst rhs_env2)
--- , ppr dx_binds ]) $
--- return ()
+ , spec_bndrs1, dx_binds, spec_args) <- specHeader env rhs_bndrs all_call_args
+
+-- ; debugTraceMsg (text "spec_call" <+> vcat
+-- [ text "fun: " <+> ppr fn
+-- , text "call info: " <+> ppr _ci
+-- , text "useful: " <+> ppr useful
+-- , text "rule_bndrs:" <+> ppr rule_bndrs
+-- , text "lhs_args: " <+> ppr rule_lhs_args
+-- , text "spec_bndrs1:" <+> ppr spec_bndrs1
+-- , text "leftover_bndrs:" <+> pprIds leftover_bndrs
+-- , text "spec_args: " <+> ppr spec_args
+-- , text "dx_binds: " <+> ppr dx_binds
+-- , text "rhs_bndrs" <+> ppr rhs_bndrs
+-- , text "rhs_body" <+> ppr rhs_body
+-- , text "rhs_env2: " <+> ppr (se_subst rhs_env2)
+-- , ppr dx_binds ]
; if not useful -- No useful specialisation
|| already_covered rhs_env2 rules_acc rule_lhs_args
=====================================
docs/users_guide/9.8.1-notes.rst
=====================================
@@ -10,4 +10,74 @@ Compiler
~~~~~~~~
- Added a new warning :ghc-flag:`-Wterm-variable-capture` that helps to make code compatible with
- the future extension ``RequiredTypeArguments``.
\ No newline at end of file
+ the future extension ``RequiredTypeArguments``.
+=======
+
+GHCi
+~~~~
+
+
+Runtime system
+~~~~~~~~~~~~~~
+
+- On POSIX systems that support timerfd, RTS shutdown no longer has to wait for
+ the next RTS 'tick' to occur before continuing the shutdown process. See #22692.
+
+``base`` library
+~~~~~~~~~~~~~~~~
+
+
+``ghc-prim`` library
+~~~~~~~~~~~~~~~~~~~~
+
+``ghc`` library
+~~~~~~~~~~~~~~~
+
+``ghc-heap`` library
+~~~~~~~~~~~~~~~~~~~~
+
+
+Included libraries
+------------------
+
+The package database provided with this distribution also contains a number of
+packages other than GHC itself. See the changelogs provided with these packages
+for further change information.
+
+.. ghc-package-list::
+
+ libraries/array/array.cabal: Dependency of ``ghc`` library
+ libraries/base/base.cabal: Core library
+ libraries/binary/binary.cabal: Dependency of ``ghc`` library
+ libraries/bytestring/bytestring.cabal: Dependency of ``ghc`` library
+ libraries/Cabal/Cabal/Cabal.cabal: Dependency of ``ghc-pkg`` utility
+ libraries/Cabal/Cabal-syntax/Cabal-syntax.cabal: Dependency of ``ghc-pkg`` utility
+ libraries/containers/containers/containers.cabal: Dependency of ``ghc`` library
+ libraries/deepseq/deepseq.cabal: Dependency of ``ghc`` library
+ libraries/directory/directory.cabal: Dependency of ``ghc`` library
+ libraries/exceptions/exceptions.cabal: Dependency of ``ghc`` and ``haskeline`` library
+ libraries/filepath/filepath.cabal: Dependency of ``ghc`` library
+ compiler/ghc.cabal: The compiler itself
+ libraries/ghci/ghci.cabal: The REPL interface
+ libraries/ghc-boot/ghc-boot.cabal: Internal compiler library
+ libraries/ghc-boot-th/ghc-boot-th.cabal: Internal compiler library
+ libraries/ghc-compact/ghc-compact.cabal: Core library
+ libraries/ghc-heap/ghc-heap.cabal: GHC heap-walking library
+ libraries/ghc-prim/ghc-prim.cabal: Core library
+ libraries/haskeline/haskeline.cabal: Dependency of ``ghci`` executable
+ libraries/hpc/hpc.cabal: Dependency of ``hpc`` executable
+ libraries/integer-gmp/integer-gmp.cabal: Core library
+ libraries/libiserv/libiserv.cabal: Internal compiler library
+ libraries/mtl/mtl.cabal: Dependency of ``Cabal`` library
+ libraries/parsec/parsec.cabal: Dependency of ``Cabal`` library
+ libraries/pretty/pretty.cabal: Dependency of ``ghc`` library
+ libraries/process/process.cabal: Dependency of ``ghc`` library
+ libraries/stm/stm.cabal: Dependency of ``haskeline`` library
+ libraries/template-haskell/template-haskell.cabal: Core library
+ libraries/terminfo/terminfo.cabal: Dependency of ``haskeline`` library
+ libraries/text/text.cabal: Dependency of ``Cabal`` library
+ libraries/time/time.cabal: Dependency of ``ghc`` library
+ libraries/transformers/transformers.cabal: Dependency of ``ghc`` library
+ libraries/unix/unix.cabal: Dependency of ``ghc`` library
+ libraries/Win32/Win32.cabal: Dependency of ``ghc`` library
+ libraries/xhtml/xhtml.cabal: Dependency of ``haddock`` executable
=====================================
libraries/base/Data/Functor/Compose.hs
=====================================
@@ -33,7 +33,7 @@ import Data.Coerce (coerce)
import Data.Data (Data)
import Data.Type.Equality (TestEquality(..), (:~:)(..))
import GHC.Generics (Generic, Generic1)
-import Text.Read ()
+import Text.Read (Read(..), ReadPrec, readListDefault, readListPrecDefault)
infixr 9 `Compose`
@@ -55,9 +55,14 @@ deriving instance Eq (f (g a)) => Eq (Compose f g a)
-- | @since 4.18.0.0
deriving instance Ord (f (g a)) => Ord (Compose f g a)
-- | @since 4.18.0.0
-deriving instance Read (f (g a)) => Read (Compose f g a)
+instance Read (f (g a)) => Read (Compose f g a) where
+ readPrec = liftReadPrecCompose readPrec
+
+ readListPrec = readListPrecDefault
+ readList = readListDefault
-- | @since 4.18.0.0
-deriving instance Show (f (g a)) => Show (Compose f g a)
+instance Show (f (g a)) => Show (Compose f g a) where
+ showsPrec = liftShowsPrecCompose showsPrec
-- Instances of lifted Prelude classes
@@ -72,8 +77,8 @@ instance (Ord1 f, Ord1 g) => Ord1 (Compose f g) where
-- | @since 4.9.0.0
instance (Read1 f, Read1 g) => Read1 (Compose f g) where
- liftReadPrec rp rl = readData $
- readUnaryWith (liftReadPrec rp' rl') "Compose" Compose
+ liftReadPrec rp rl =
+ liftReadPrecCompose (liftReadPrec rp' rl')
where
rp' = liftReadPrec rp rl
rl' = liftReadListPrec rp rl
@@ -83,12 +88,20 @@ instance (Read1 f, Read1 g) => Read1 (Compose f g) where
-- | @since 4.9.0.0
instance (Show1 f, Show1 g) => Show1 (Compose f g) where
- liftShowsPrec sp sl d (Compose x) =
- showsUnaryWith (liftShowsPrec sp' sl') "Compose" d x
+ liftShowsPrec sp sl =
+ liftShowsPrecCompose (liftShowsPrec sp' sl')
where
sp' = liftShowsPrec sp sl
sl' = liftShowList sp sl
+-- The workhorse for Compose's Read and Read1 instances.
+liftReadPrecCompose :: ReadPrec (f (g a)) -> ReadPrec (Compose f g a)
+liftReadPrecCompose rp = readData $ readUnaryWith rp "Compose" Compose
+
+-- The workhorse for Compose's Show and Show1 instances.
+liftShowsPrecCompose :: (Int -> f (g a) -> ShowS) -> Int -> Compose f g a -> ShowS
+liftShowsPrecCompose sp d (Compose x) = showsUnaryWith sp "Compose" d x
+
-- Functor instances
-- | @since 4.9.0.0
=====================================
libraries/base/tests/T22816.hs
=====================================
@@ -0,0 +1,31 @@
+module Main (main) where
+
+import Data.Functor.Classes
+import Data.Functor.Compose
+import Text.ParserCombinators.ReadP as P
+import Text.ParserCombinators.ReadPrec (ReadPrec, lift, minPrec, readPrec_to_S)
+
+readEither' :: ReadPrec a -> String -> Either String a
+readEither' rp s =
+ case [ x | (x,"") <- readPrec_to_S read' minPrec s ] of
+ [x] -> Right x
+ [] -> Left "read1: no parse"
+ _ -> Left "read1: ambiguous parse"
+ where
+ read' =
+ do x <- rp
+ lift P.skipSpaces
+ return x
+
+-- | Like 'read', but tailored to 'Read1'.
+read1 :: (Read1 f, Read a) => String -> f a
+read1 s = either errorWithoutStackTrace id (readEither' readPrec1 s)
+
+exRead, exRead1 :: Compose Maybe Maybe Int
+exRead = read "Compose Nothing"
+exRead1 = read1 "Compose Nothing"
+
+main :: IO ()
+main = do
+ putStrLn $ showsPrec 0 exRead ""
+ putStrLn $ showsPrec1 0 exRead1 ""
=====================================
libraries/base/tests/T22816.stdout
=====================================
@@ -0,0 +1,2 @@
+Compose Nothing
+Compose Nothing
=====================================
libraries/base/tests/all.T
=====================================
@@ -286,6 +286,7 @@ test('T18642',
test('T19288', exit_code(1), compile_and_run, [''])
test('T19719', normal, compile_and_run, [''])
test('T20107', extra_run_opts('+RTS -M50M'), compile_and_run, ['-package bytestring'])
+test('T22816', normal, compile_and_run, [''])
test('trace', normal, compile_and_run, [''])
test('listThreads', js_broken(22261), compile_and_run, [''])
test('inits1tails1', normal, compile_and_run, [''])
=====================================
rts/posix/ticker/Pthread.c
=====================================
@@ -43,6 +43,7 @@
#include "Proftimer.h"
#include "Schedule.h"
#include "posix/Clock.h"
+#include <sys/poll.h>
#include <time.h>
#if HAVE_SYS_TIME_H
@@ -95,28 +96,53 @@ static OSThreadId thread;
// file descriptor for the timer (Linux only)
static int timerfd = -1;
+// pipe for signaling exit
+static int pipefds[2];
+
static void *itimer_thread_func(void *_handle_tick)
{
TickProc handle_tick = _handle_tick;
uint64_t nticks;
+ ssize_t r = 0;
+ struct pollfd pollfds[2];
+
+#if USE_TIMERFD_FOR_ITIMER
+ pollfds[0].fd = pipefds[0];
+ pollfds[0].events = POLLIN;
+ pollfds[1].fd = timerfd;
+ pollfds[1].events = POLLIN;
+#endif
// Relaxed is sufficient: If we don't see that exited was set in one iteration we will
// see it next time.
TSAN_ANNOTATE_BENIGN_RACE(&exited, "itimer_thread_func");
while (!RELAXED_LOAD(&exited)) {
if (USE_TIMERFD_FOR_ITIMER) {
- ssize_t r = read(timerfd, &nticks, sizeof(nticks));
- if ((r == 0) && (errno == 0)) {
- /* r == 0 is expected only for non-blocking fd (in which case
- * errno should be EAGAIN) but we use a blocking fd.
- *
- * Due to a kernel bug (cf https://lkml.org/lkml/2019/8/16/335)
- * on some platforms we could see r == 0 and errno == 0.
- */
- IF_DEBUG(scheduler, debugBelch("read(timerfd) returned 0 with errno=0. This is a known kernel bug. We just ignore it."));
+ if (poll(pollfds, 2, -1) == -1) {
+ sysErrorBelch("Ticker: poll failed: %s", strerror(errno));
}
- else if (r != sizeof(nticks) && errno != EINTR) {
- barf("Ticker: read(timerfd) failed with %s and returned %zd", strerror(errno), r);
+
+ // We check the pipe first, even though the timerfd may also have triggered.
+ if (pollfds[0].revents & POLLIN) {
+ // the pipe is ready for reading, the only possible reason is that we're exiting
+ exited = true; // set this again to make sure even RELAXED_LOAD will read the proper value
+ // no further action needed, skip ahead to handling the final tick and then stopping
+ }
+ else if (pollfds[1].revents & POLLIN) { // the timerfd is ready for reading
+ r = read(timerfd, &nticks, sizeof(nticks)); // this should never block now
+
+ if ((r == 0) && (errno == 0)) {
+ /* r == 0 is expected only for non-blocking fd (in which case
+ * errno should be EAGAIN) but we use a blocking fd.
+ *
+ * Due to a kernel bug (cf https://lkml.org/lkml/2019/8/16/335)
+ * on some platforms we could see r == 0 and errno == 0.
+ */
+ IF_DEBUG(scheduler, debugBelch("read(timerfd) returned 0 with errno=0. This is a known kernel bug. We just ignore it."));
+ }
+ else if (r != sizeof(nticks) && errno != EINTR) {
+ barf("Ticker: read(timerfd) failed with %s and returned %zd", strerror(errno), r);
+ }
}
} else {
if (rtsSleep(itimer_interval) != 0) {
@@ -138,8 +164,10 @@ static void *itimer_thread_func(void *_handle_tick)
}
}
- if (USE_TIMERFD_FOR_ITIMER)
+ if (USE_TIMERFD_FOR_ITIMER) {
close(timerfd);
+ }
+
return NULL;
}
@@ -185,6 +213,10 @@ initTicker (Time interval, TickProc handle_tick)
if (timerfd_settime(timerfd, 0, &it, NULL)) {
barf("timerfd_settime: %s", strerror(errno));
}
+
+ if (pipe(pipefds) < 0) {
+ barf("pipe: %s", strerror(errno));
+ }
#endif
/*
@@ -237,9 +269,21 @@ exitTicker (bool wait)
// wait for ticker to terminate if necessary
if (wait) {
+#if USE_TIMERFD_FOR_ITIMER
+ // write anything to the pipe to trigger poll() in the ticker thread
+ if (write(pipefds[1], "stop", 5) < 0) {
+ sysErrorBelch("Ticker: Failed to write to pipe: %s", strerror(errno));
+ }
+#endif
if (pthread_join(thread, NULL)) {
sysErrorBelch("Ticker: Failed to join: %s", strerror(errno));
}
+#if USE_TIMERFD_FOR_ITIMER
+ // These need to happen AFTER the ticker thread has finished to prevent a race condition
+ // where the ticker thread closes the read end of the pipe before we're done writing to it.
+ close(pipefds[0]);
+ close(pipefds[1]);
+#endif
closeMutex(&mutex);
closeCondition(&start_cond);
} else {
=====================================
testsuite/tests/simplCore/should_compile/T22715_2.hs
=====================================
@@ -0,0 +1,6 @@
+module T22715_2 where
+
+import T22715_2a
+
+debugTerminalKeys :: (forall m. CommandMonad m => m Char) -> Input IO Char
+debugTerminalKeys eval = runIdT eval
=====================================
testsuite/tests/simplCore/should_compile/T22715_2a.hs
=====================================
@@ -0,0 +1,29 @@
+{-# OPTIONS_GHC -Wno-missing-methods #-}
+
+module T22715_2a where
+
+newtype IdentityT m a = IdentityT (m a) deriving Functor
+newtype IdT m a = IdT {runIdT :: m a} deriving Functor
+
+class Functor m => SillyA m where
+ unused :: m a -> m a
+
+class SillyA m => SillyB m where
+ unused2 :: m a -> m a
+
+instance SillyA m => SillyA (IdentityT m) where
+instance SillyB m => SillyB (IdentityT m) where
+
+instance SillyA m => SillyA (IdT m) where
+instance SillyB m => SillyB (IdT m) where
+
+instance SillyA IO where
+instance SillyB IO where
+
+class Functor m => Special m
+instance Functor m => Special (IdT m)
+
+type Input m = IdentityT (IdentityT m)
+
+class (Special m, SillyB m) => CommandMonad m
+instance SillyB m => CommandMonad (IdT (Input m))
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -469,4 +469,4 @@ test('T22662', normal, compile, [''])
test('T22725', normal, compile, ['-O'])
test('T22502', normal, compile, ['-O'])
test('T22611', [when(wordsize(32), skip), grep_errmsg(r'\$salterF') ], compile, ['-O -ddump-simpl -dsuppress-uniques -dsuppress-all'])
-
+test('T22715_2', normal, multimod_compile, ['T22715_2', '-v0 -O -fspecialise-aggressively'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/46cc07d133309fdabf846eb2547998eec20fed1c...d9e4143cd1d2984a18d85763b3d64509f8bae6e8
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/46cc07d133309fdabf846eb2547998eec20fed1c...d9e4143cd1d2984a18d85763b3d64509f8bae6e8
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/20230125/cb54e047/attachment-0001.html>
More information about the ghc-commits
mailing list