diff options
29 files changed, 345 insertions, 165 deletions
diff --git a/compiler/coreSyn/CorePrep.hs b/compiler/coreSyn/CorePrep.hs index 6757f7aac9..4a5891a013 100644 --- a/compiler/coreSyn/CorePrep.hs +++ b/compiler/coreSyn/CorePrep.hs @@ -1141,6 +1141,7 @@ and now we do NOT want eta expansion to give Instead CoreArity.etaExpand gives f = /\a -> \y -> let s = h 3 in g s y + -} cpeEtaExpand :: Arity -> CpeRhs -> CpeRhs @@ -1161,6 +1162,8 @@ get to a partial application: ==> case x of { p -> map f } -} +-- When updating this function, make sure it lines up with +-- CoreUtils.tryEtaReduce! tryEtaReducePrep :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr tryEtaReducePrep bndrs expr@(App _ _) | ok_to_eta_reduce f @@ -1180,25 +1183,14 @@ tryEtaReducePrep bndrs expr@(App _ _) ok bndr (Var arg) = bndr == arg ok _ _ = False - -- We can't eta reduce something which must be saturated. + -- We can't eta reduce something which must be saturated. ok_to_eta_reduce (Var f) = not (hasNoBinding f) ok_to_eta_reduce _ = False -- Safe. ToDo: generalise -tryEtaReducePrep bndrs (Let bind@(NonRec _ r) body) - | not (any (`elemVarSet` fvs) bndrs) - = case tryEtaReducePrep bndrs body of - Just e -> Just (Let bind e) - Nothing -> Nothing - where - fvs = exprFreeVars r - --- NB: do not attempt to eta-reduce across ticks --- Otherwise we risk reducing --- \x. (Tick (Breakpoint {x}) f x) --- ==> Tick (breakpoint {x}) f --- which is bogus (#17228) --- tryEtaReducePrep bndrs (Tick tickish e) --- = fmap (mkTick tickish) $ tryEtaReducePrep bndrs e + +tryEtaReducePrep bndrs (Tick tickish e) + | tickishFloatable tickish + = fmap (mkTick tickish) $ tryEtaReducePrep bndrs e tryEtaReducePrep _ _ = Nothing diff --git a/compiler/coreSyn/CoreUtils.hs b/compiler/coreSyn/CoreUtils.hs index 1ca5a6b438..16f4a00341 100644 --- a/compiler/coreSyn/CoreUtils.hs +++ b/compiler/coreSyn/CoreUtils.hs @@ -2379,6 +2379,8 @@ But the simplifier pushes those casts outwards, so we don't need to address that here. -} +-- When updating this function, make sure to update +-- CorePrep.tryEtaReducePrep as well! tryEtaReduce :: [Var] -> CoreExpr -> Maybe CoreExpr tryEtaReduce bndrs body = go (reverse bndrs) body (mkRepReflCo (exprType body)) diff --git a/compiler/main/Packages.hs b/compiler/main/Packages.hs index f5a8c964b3..baed7f5ec1 100644 --- a/compiler/main/Packages.hs +++ b/compiler/main/Packages.hs @@ -428,9 +428,11 @@ extendPackageConfigMap (PackageConfigMap pkg_map closure) new_pkgs -- | Looks up the package with the given id in the package state, panicing if it is -- not found -getPackageDetails :: DynFlags -> UnitId -> PackageConfig +getPackageDetails :: HasDebugCallStack => DynFlags -> UnitId -> PackageConfig getPackageDetails dflags pid = - expectJust "getPackageDetails" (lookupPackage dflags pid) + case lookupPackage dflags pid of + Just config -> config + Nothing -> pprPanic "getPackageDetails" (ppr pid) lookupInstalledPackage :: DynFlags -> InstalledUnitId -> Maybe PackageConfig lookupInstalledPackage dflags uid = lookupInstalledPackage' (pkgIdMap (pkgState dflags)) uid @@ -438,10 +440,11 @@ lookupInstalledPackage dflags uid = lookupInstalledPackage' (pkgIdMap (pkgState lookupInstalledPackage' :: PackageConfigMap -> InstalledUnitId -> Maybe PackageConfig lookupInstalledPackage' (PackageConfigMap db _) uid = lookupUDFM db uid -getInstalledPackageDetails :: DynFlags -> InstalledUnitId -> PackageConfig +getInstalledPackageDetails :: HasDebugCallStack => DynFlags -> InstalledUnitId -> PackageConfig getInstalledPackageDetails dflags uid = - expectJust "getInstalledPackageDetails" $ - lookupInstalledPackage dflags uid + case lookupInstalledPackage dflags uid of + Just config -> config + Nothing -> pprPanic "getInstalledPackageDetails" (ppr uid) -- | Get a list of entries from the package database. NB: be careful with -- this function, although all packages in this map are "visible", this diff --git a/compiler/main/SysTools/Tasks.hs b/compiler/main/SysTools/Tasks.hs index 5b0cb1cfa2..96a5b291da 100644 --- a/compiler/main/SysTools/Tasks.hs +++ b/compiler/main/SysTools/Tasks.hs @@ -127,10 +127,9 @@ runCc mLanguage dflags args = traceToolCommand dflags "cc" $ do Nothing -> ([], userOpts_c) Just language -> ([Option "-x", Option languageName], opts) where - s = settings dflags (languageName, opts) = case language of - LangC -> ("c", sOpt_c s ++ userOpts_c) - LangCxx -> ("c++", sOpt_cxx s ++ userOpts_cxx) + LangC -> ("c", userOpts_c) + LangCxx -> ("c++", userOpts_cxx) LangObjc -> ("objective-c", userOpts_c) LangObjcxx -> ("objective-c++", userOpts_cxx) LangAsm -> ("assembler", []) diff --git a/compiler/stgSyn/StgFVs.hs b/compiler/stgSyn/StgFVs.hs index edfc94ed2d..ad02642aa9 100644 --- a/compiler/stgSyn/StgFVs.hs +++ b/compiler/stgSyn/StgFVs.hs @@ -70,12 +70,12 @@ args env = mkFreeVarSet env . mapMaybe f binding :: Env -> DIdSet -> StgBinding -> (CgStgBinding, DIdSet) binding env body_fv (StgNonRec bndr r) = (StgNonRec bndr r', fvs) where - -- See Note [Tacking local binders] + -- See Note [Tracking local binders] (r', rhs_fvs) = rhs env r fvs = delDVarSet body_fv bndr `unionDVarSet` rhs_fvs binding env body_fv (StgRec pairs) = (StgRec pairs', fvs) where - -- See Note [Tacking local binders] + -- See Note [Tracking local binders] bndrs = map fst pairs (rhss, rhs_fvss) = mapAndUnzip (rhs env . snd) pairs pairs' = zip bndrs rhss @@ -93,7 +93,7 @@ expr env = go go (StgCase scrut bndr ty alts) = (StgCase scrut' bndr ty alts', fvs) where (scrut', scrut_fvs) = go scrut - -- See Note [Tacking local binders] + -- See Note [Tracking local binders] (alts', alt_fvss) = mapAndUnzip (alt (addLocals [bndr] env)) alts alt_fvs = unionDVarSets alt_fvss fvs = delDVarSet (unionDVarSet scrut_fvs alt_fvs) bndr @@ -108,7 +108,7 @@ expr env = go go_bind dc bind body = (dc bind' body', fvs) where - -- See Note [Tacking local binders] + -- See Note [Tracking local binders] env' = addLocals (boundIds bind) env (body', body_fvs) = expr env' body (bind', fvs) = binding env' body_fvs bind @@ -117,7 +117,7 @@ rhs :: Env -> StgRhs -> (CgStgRhs, DIdSet) rhs env (StgRhsClosure _ ccs uf bndrs body) = (StgRhsClosure fvs ccs uf bndrs body', fvs) where - -- See Note [Tacking local binders] + -- See Note [Tracking local binders] (body', body_fvs) = expr (addLocals bndrs env) body fvs = delDVarSetList body_fvs bndrs rhs env (StgRhsCon ccs dc as) = (StgRhsCon ccs dc as, args env as) @@ -125,6 +125,6 @@ rhs env (StgRhsCon ccs dc as) = (StgRhsCon ccs dc as, args env as) alt :: Env -> StgAlt -> (CgStgAlt, DIdSet) alt env (con, bndrs, e) = ((con, bndrs, e'), fvs) where - -- See Note [Tacking local binders] + -- See Note [Tracking local binders] (e', rhs_fvs) = expr (addLocals bndrs env) e fvs = delDVarSetList rhs_fvs bndrs diff --git a/configure.ac b/configure.ac index 5e6f7d8723..59541f002f 100644 --- a/configure.ac +++ b/configure.ac @@ -13,7 +13,7 @@ dnl # see what flags are available. (Better yet, read the documentation!) # -AC_INIT([The Glorious Glasgow Haskell Compilation System], [8.10.0], [glasgow-haskell-bugs@haskell.org], [ghc-AC_PACKAGE_VERSION]) +AC_INIT([The Glorious Glasgow Haskell Compilation System], [8.11.0], [glasgow-haskell-bugs@haskell.org], [ghc-AC_PACKAGE_VERSION]) # Set this to YES for a released version, otherwise NO : ${RELEASE=NO} diff --git a/docs/users_guide/8.10.1-notes.rst b/docs/users_guide/8.10.1-notes.rst index d9b48d95e0..e5ed23ca3e 100644 --- a/docs/users_guide/8.10.1-notes.rst +++ b/docs/users_guide/8.10.1-notes.rst @@ -222,6 +222,10 @@ Runtime system out-of-the-box compatibility with OpenBSD and macOS Catalina (see :ghc-ticket:`17353`) +- The RTS API now exposes :ref:`an interface <event_log_output_api>` to + configure ``EventLogWriters``, allowing eventlog data to fed to sinks other + than ``.eventlog`` files. + Template Haskell ~~~~~~~~~~~~~~~~ diff --git a/docs/users_guide/runtime_control.rst b/docs/users_guide/runtime_control.rst index 7ebb9eb207..1f4b766400 100644 --- a/docs/users_guide/runtime_control.rst +++ b/docs/users_guide/runtime_control.rst @@ -174,6 +174,8 @@ e.g., on stack overflow. The hooks for these are as follows: The message printed if ``malloc`` fails. +.. _event_log_output_api: + Event log output ################ @@ -190,7 +192,7 @@ Furthermore GHC lets you specify the way event log data (see :rts-flag:`-l .. c:member:: bool writeEventLog(void *eventlog, size_t eventlog_size) - Hands buffered event log data to your event log writer. + Hands buffered event log data to your event log writer. Return true on success. Required for a custom :c:type:`EventLogWriter`. .. c:member:: void flushEventLog(void) @@ -202,6 +204,24 @@ Furthermore GHC lets you specify the way event log data (see :rts-flag:`-l Called when event logging is about to stop. This can be ``NULL``. +To use an :c:type:`EventLogWriter` the RTS API provides the following functions: + +.. c:func:: enum EventLogStatus eventLogStatus(void) + + Query whether the current runtime system supports the eventlog (e.g. whether + the current executable was linked with :ghc-flag:`-eventlog`) and, if it + is supported, whether it is currently logging. + +.. c:func:: bool startEventLogging(const EventLogWriter *writer) + + Start logging events to the given :c:type:`EventLogWriter`. Returns true on + success or false is another writer has already been configured. + +.. c:func:: void endEventLogging() + + Tear down the active :c:type:`EventLogWriter`. + + .. _rts-options-misc: Miscellaneous RTS options diff --git a/includes/rts/EventLogWriter.h b/includes/rts/EventLogWriter.h index 5eececd20e..4975b72b07 100644 --- a/includes/rts/EventLogWriter.h +++ b/includes/rts/EventLogWriter.h @@ -23,7 +23,7 @@ typedef struct { // Initialize an EventLogWriter (may be NULL) void (* initEventLogWriter) (void); - // Write a series of events + // Write a series of events returning true on success. bool (* writeEventLog) (void *eventlog, size_t eventlog_size); // Flush possibly existing buffers (may be NULL) @@ -38,3 +38,29 @@ typedef struct { * a file `program.eventlog`. */ extern const EventLogWriter FileEventLogWriter; + +enum EventLogStatus { + /* The runtime system wasn't compiled with eventlog support. */ + EVENTLOG_NOT_SUPPORTED, + /* An EventLogWriter has not yet been configured */ + EVENTLOG_NOT_CONFIGURED, + /* An EventLogWriter has been configured and is running. */ + EVENTLOG_RUNNING, +}; + +/* + * Query whether the current runtime system supports eventlogging. + */ +enum EventLogStatus eventLogStatus(void); + +/* + * Initialize event logging using the given EventLogWriter. + * Returns true on success or false if an EventLogWriter is already configured + * or eventlogging isn't supported by the runtime. + */ +bool startEventLogging(const EventLogWriter *writer); + +/* + * Stop event logging and destroy the current EventLogWriter. + */ +void endEventLogging(void); diff --git a/includes/rts/SpinLock.h b/includes/rts/SpinLock.h index 037975268e..9f09099e2e 100644 --- a/includes/rts/SpinLock.h +++ b/includes/rts/SpinLock.h @@ -23,34 +23,33 @@ #if defined(THREADED_RTS) -#if defined(PROF_SPIN) typedef struct SpinLock_ { StgWord lock; +#if defined(PROF_SPIN) StgWord64 spin; // incremented every time we spin in ACQUIRE_SPIN_LOCK StgWord64 yield; // incremented every time we yield in ACQUIRE_SPIN_LOCK -} SpinLock; -#else -typedef StgWord SpinLock; #endif - -#if defined(PROF_SPIN) +} SpinLock; // PROF_SPIN enables counting the number of times we spin on a lock +#if defined(PROF_SPIN) +#define IF_PROF_SPIN(x) x +#else +#define IF_PROF_SPIN(x) +#endif // acquire spin lock INLINE_HEADER void ACQUIRE_SPIN_LOCK(SpinLock * p) { - StgWord32 r = 0; - uint32_t i; do { - for (i = 0; i < SPIN_COUNT; i++) { - r = cas((StgVolatilePtr)&(p->lock), 1, 0); + for (uint32_t i = 0; i < SPIN_COUNT; i++) { + StgWord32 r = cas((StgVolatilePtr)&(p->lock), 1, 0); if (r != 0) return; - p->spin++; + IF_PROF_SPIN(p->spin++); busy_wait_nop(); } - p->yield++; + IF_PROF_SPIN(p->yield++); yieldThread(); } while (1); } @@ -67,43 +66,10 @@ INLINE_HEADER void initSpinLock(SpinLock * p) { write_barrier(); p->lock = 1; - p->spin = 0; - p->yield = 0; + IF_PROF_SPIN(p->spin = 0); + IF_PROF_SPIN(p->yield = 0); } -#else - -// acquire spin lock -INLINE_HEADER void ACQUIRE_SPIN_LOCK(SpinLock * p) -{ - StgWord32 r = 0; - uint32_t i; - do { - for (i = 0; i < SPIN_COUNT; i++) { - r = cas((StgVolatilePtr)p, 1, 0); - if (r != 0) return; - busy_wait_nop(); - } - yieldThread(); - } while (1); -} - -// release spin lock -INLINE_HEADER void RELEASE_SPIN_LOCK(SpinLock * p) -{ - write_barrier(); - (*p) = 1; -} - -// init spin lock -INLINE_HEADER void initSpinLock(SpinLock * p) -{ - write_barrier(); - (*p) = 1; -} - -#endif /* PROF_SPIN */ - #else /* !THREADED_RTS */ // Using macros here means we don't have to ensure the argument is in scope diff --git a/libraries/base/GHC/Natural.hs b/libraries/base/GHC/Natural.hs index 93c67b6c7a..e65b41a7e2 100644 --- a/libraries/base/GHC/Natural.hs +++ b/libraries/base/GHC/Natural.hs @@ -147,6 +147,9 @@ data Natural = NatS# GmpLimb# -- ^ in @[0, maxBound::Word]@ , Ord -- ^ @since 4.8.0.0 ) +zero, one :: Natural +zero = NatS# 0## +one = NatS# 1## -- | Test whether all internal invariants are satisfied by 'Natural' value -- @@ -162,12 +165,12 @@ isValidNatural (NatJ# bn) = isTrue# (isValidBigNat# bn) && isTrue# (sizeofBigNat# bn ># 1#) signumNatural :: Natural -> Natural -signumNatural (NatS# 0##) = NatS# 0## -signumNatural _ = NatS# 1## +signumNatural (NatS# 0##) = zero +signumNatural _ = one -- {-# CONSTANT_FOLDED signumNatural #-} negateNatural :: Natural -> Natural -negateNatural (NatS# 0##) = NatS# 0## +negateNatural (NatS# 0##) = zero negateNatural _ = underflowError -- {-# CONSTANT_FOLDED negateNatural #-} @@ -183,8 +186,8 @@ naturalFromInteger _ = underflowError gcdNatural :: Natural -> Natural -> Natural gcdNatural (NatS# 0##) y = y gcdNatural x (NatS# 0##) = x -gcdNatural (NatS# 1##) _ = NatS# 1## -gcdNatural _ (NatS# 1##) = NatS# 1## +gcdNatural (NatS# 1##) _ = one +gcdNatural _ (NatS# 1##) = one gcdNatural (NatJ# x) (NatJ# y) = bigNatToNatural (gcdBigNat x y) gcdNatural (NatJ# x) (NatS# y) = NatS# (gcdBigNatWord x y) gcdNatural (NatS# x) (NatJ# y) = NatS# (gcdBigNatWord y x) @@ -192,18 +195,20 @@ gcdNatural (NatS# x) (NatS# y) = NatS# (gcdWord x y) -- | Compute least common multiple. lcmNatural :: Natural -> Natural -> Natural -lcmNatural (NatS# 0##) _ = NatS# 0## -lcmNatural _ (NatS# 0##) = NatS# 0## -lcmNatural (NatS# 1##) y = y -lcmNatural x (NatS# 1##) = x -lcmNatural x y = (x `quotNatural` (gcdNatural x y)) `timesNatural` y +-- Make sure we are strict in all arguments (#17499) +lcmNatural (NatS# 0##) !_ = zero +lcmNatural _ (NatS# 0##) = zero +lcmNatural (NatS# 1##) y = y +lcmNatural x (NatS# 1##) = x +lcmNatural x y = (x `quotNatural` (gcdNatural x y)) `timesNatural` y ---------------------------------------------------------------------------- quotRemNatural :: Natural -> Natural -> (Natural, Natural) -quotRemNatural _ (NatS# 0##) = divZeroError -quotRemNatural n (NatS# 1##) = (n,NatS# 0##) -quotRemNatural n@(NatS# _) (NatJ# _) = (NatS# 0##, n) +-- Make sure we are strict in all arguments (#17499) +quotRemNatural !_ (NatS# 0##) = divZeroError +quotRemNatural n (NatS# 1##) = (n,zero) +quotRemNatural n@(NatS# _) (NatJ# _) = (zero, n) quotRemNatural (NatS# n) (NatS# d) = case quotRemWord# n d of (# q, r #) -> (NatS# q, NatS# r) quotRemNatural (NatJ# n) (NatS# d) = case quotRemBigNatWord n d of @@ -213,21 +218,23 @@ quotRemNatural (NatJ# n) (NatJ# d) = case quotRemBigNat n d of -- {-# CONSTANT_FOLDED quotRemNatural #-} quotNatural :: Natural -> Natural -> Natural -quotNatural _ (NatS# 0##) = divZeroError -quotNatural n (NatS# 1##) = n -quotNatural (NatS# _) (NatJ# _) = NatS# 0## -quotNatural (NatS# n) (NatS# d) = NatS# (quotWord# n d) -quotNatural (NatJ# n) (NatS# d) = bigNatToNatural (quotBigNatWord n d) -quotNatural (NatJ# n) (NatJ# d) = bigNatToNatural (quotBigNat n d) +-- Make sure we are strict in all arguments (#17499) +quotNatural !_ (NatS# 0##) = divZeroError +quotNatural n (NatS# 1##) = n +quotNatural (NatS# _) (NatJ# _) = zero +quotNatural (NatS# n) (NatS# d) = NatS# (quotWord# n d) +quotNatural (NatJ# n) (NatS# d) = bigNatToNatural (quotBigNatWord n d) +quotNatural (NatJ# n) (NatJ# d) = bigNatToNatural (quotBigNat n d) -- {-# CONSTANT_FOLDED quotNatural #-} remNatural :: Natural -> Natural -> Natural -remNatural _ (NatS# 0##) = divZeroError -remNatural _ (NatS# 1##) = NatS# 0## -remNatural n@(NatS# _) (NatJ# _) = n -remNatural (NatS# n) (NatS# d) = NatS# (remWord# n d) -remNatural (NatJ# n) (NatS# d) = NatS# (remBigNatWord n d) -remNatural (NatJ# n) (NatJ# d) = bigNatToNatural (remBigNat n d) +-- Make sure we are strict in all arguments (#17499) +remNatural !_ (NatS# 0##) = divZeroError +remNatural _ (NatS# 1##) = zero +remNatural n@(NatS# _) (NatJ# _) = n +remNatural (NatS# n) (NatS# d) = NatS# (remWord# n d) +remNatural (NatJ# n) (NatS# d) = NatS# (remBigNatWord n d) +remNatural (NatJ# n) (NatJ# d) = bigNatToNatural (remBigNat n d) -- {-# CONSTANT_FOLDED remNatural #-} -- | @since 4.X.0.0 @@ -278,7 +285,7 @@ popCountNatural (NatJ# bn) = I# (popCountBigNat bn) shiftLNatural :: Natural -> Int -> Natural shiftLNatural n (I# 0#) = n -shiftLNatural (NatS# 0##) _ = NatS# 0## +shiftLNatural (NatS# 0##) _ = zero shiftLNatural (NatS# 1##) (I# i#) = bitNatural i# shiftLNatural (NatS# w) (I# i#) = bigNatToNatural (shiftLBigNat (wordToBigNat w) i#) @@ -289,7 +296,7 @@ shiftLNatural (NatJ# bn) (I# i#) shiftRNatural :: Natural -> Int -> Natural shiftRNatural n (I# 0#) = n shiftRNatural (NatS# w) (I# i#) - | isTrue# (i# >=# WORD_SIZE_IN_BITS#) = NatS# 0## + | isTrue# (i# >=# WORD_SIZE_IN_BITS#) = zero | True = NatS# (w `uncheckedShiftRL#` i#) shiftRNatural (NatJ# bn) (I# i#) = bigNatToNatural (shiftRBigNat bn i#) -- {-# CONSTANT_FOLDED shiftRNatural #-} @@ -311,8 +318,9 @@ plusNatural (NatJ# x) (NatJ# y) = NatJ# (plusBigNat x y) -- | 'Natural' multiplication timesNatural :: Natural -> Natural -> Natural -timesNatural _ (NatS# 0##) = NatS# 0## -timesNatural (NatS# 0##) _ = NatS# 0## +-- Make sure we are strict in all arguments (#17499) +timesNatural !_ (NatS# 0##) = zero +timesNatural (NatS# 0##) _ = zero timesNatural x (NatS# 1##) = x timesNatural (NatS# 1##) y = y timesNatural (NatS# x) (NatS# y) = case timesWord2# x y of @@ -342,7 +350,8 @@ minusNatural (NatJ# x) (NatJ# y) -- -- @since 4.8.0.0 minusNaturalMaybe :: Natural -> Natural -> Maybe Natural -minusNaturalMaybe x (NatS# 0##) = Just x +-- Make sure we are strict in all arguments (#17499) +minusNaturalMaybe !x (NatS# 0##) = Just x minusNaturalMaybe (NatS# x) (NatS# y) = case subWordC# x y of (# l, 0# #) -> Just (NatS# l) _ -> Nothing @@ -575,11 +584,12 @@ naturalToWordMaybe (Natural i) -- @since 4.8.0.0 powModNatural :: Natural -> Natural -> Natural -> Natural #if defined(MIN_VERSION_integer_gmp) -powModNatural _ _ (NatS# 0##) = divZeroError -powModNatural _ _ (NatS# 1##) = NatS# 0## -powModNatural _ (NatS# 0##) _ = NatS# 1## -powModNatural (NatS# 0##) _ _ = NatS# 0## -powModNatural (NatS# 1##) _ _ = NatS# 1## +-- Make sure we are strict in all arguments (#17499) +powModNatural !_ !_ (NatS# 0##) = divZeroError +powModNatural _ _ (NatS# 1##) = zero +powModNatural _ (NatS# 0##) _ = one +powModNatural (NatS# 0##) _ _ = zero +powModNatural (NatS# 1##) _ _ = one powModNatural (NatS# b) (NatS# e) (NatS# m) = NatS# (powModWord b e m) powModNatural b e (NatS# m) = NatS# (powModBigNatWord (naturalToBigNat b) (naturalToBigNat e) m) diff --git a/libraries/base/changelog.md b/libraries/base/changelog.md index 69fd172bf1..fa0d2d4e95 100644 --- a/libraries/base/changelog.md +++ b/libraries/base/changelog.md @@ -1,7 +1,7 @@ # Changelog for [`base` package](http://hackage.haskell.org/package/base) ## 4.15.0.0 *TBA* - * Add `IsList` instance for `ZipList`. + * TODO ## 4.14.0.0 *TBA* * Bundled with GHC 8.10.1 @@ -46,6 +46,8 @@ * Add a `Data` instance to `WrappedArrow`, `WrappedMonad`, and `ZipList`. + * Add `IsList` instance for `ZipList`. + ## 4.13.0.0 *July 2019* * Bundled with GHC 8.8.1 diff --git a/libraries/base/tests/T17499.hs b/libraries/base/tests/T17499.hs new file mode 100644 index 0000000000..512140c1b0 --- /dev/null +++ b/libraries/base/tests/T17499.hs @@ -0,0 +1,16 @@ +import Numeric.Natural + +import Control.Exception (evaluate) + +newtype Mod a = Mod a deriving (Show) + +instance Integral a => Num (Mod a) where + Mod a * Mod b = Mod (a * b `mod` 10000000019) + fromInteger n = Mod (fromInteger n `mod` 10000000019) + +main :: IO () +main = do + -- Should not allocate more compared to Integer + -- _ <- evaluate $ product $ map Mod [(1 :: Integer) .. 1000000] + _ <- evaluate $ product $ map Mod [(1 :: Natural) .. 1000000] + return () diff --git a/libraries/base/tests/all.T b/libraries/base/tests/all.T index 32dfaecf31..e5130d0348 100644 --- a/libraries/base/tests/all.T +++ b/libraries/base/tests/all.T @@ -253,3 +253,4 @@ test('T15349', [exit_code(1), expect_broken_for(15349, ['ghci'])], compile_and_r test('T16111', exit_code(1), compile_and_run, ['']) test('T16943a', normal, compile_and_run, ['']) test('T16943b', normal, compile_and_run, ['']) +test('T17499', collect_stats('bytes allocated',5), compile_and_run, ['-O -w']) diff --git a/rts/Trace.c b/rts/Trace.c index 8e44716eb0..b35be3c1e7 100644 --- a/rts/Trace.c +++ b/rts/Trace.c @@ -40,21 +40,12 @@ int TRACE_cap; static Mutex trace_utx; #endif -static bool eventlog_enabled; - /* --------------------------------------------------------------------------- Starting up / shutting down the tracing facilities --------------------------------------------------------------------------- */ -static const EventLogWriter *getEventLogWriter(void) -{ - return rtsConfig.eventlog_writer; -} - void initTracing (void) { - const EventLogWriter *eventlog_writer = getEventLogWriter(); - #if defined(THREADED_RTS) initMutex(&trace_utx); #endif @@ -95,15 +86,14 @@ void initTracing (void) TRACE_spark_full || TRACE_user; - eventlog_enabled = RtsFlags.TraceFlags.tracing == TRACE_EVENTLOG && - eventlog_writer != NULL; - /* Note: we can have any of the TRACE_* flags turned on even when eventlog_enabled is off. In the DEBUG way we may be tracing to stderr. */ + initEventLogging(); - if (eventlog_enabled) { - initEventLogging(eventlog_writer); + if (RtsFlags.TraceFlags.tracing == TRACE_EVENTLOG + && rtsConfig.eventlog_writer != NULL) { + startEventLogging(rtsConfig.eventlog_writer); } } @@ -121,17 +111,10 @@ void freeTracing (void) } } +// Used to reset tracing in a forked child void resetTracing (void) { - const EventLogWriter *eventlog_writer; - eventlog_writer = getEventLogWriter(); - - if (eventlog_enabled) { - abortEventLogging(); // abort eventlog inherited from parent - if (eventlog_writer != NULL) { - initEventLogging(eventlog_writer); // child starts its own eventlog - } - } + restartEventLogging(); } void flushTrace (void) diff --git a/rts/eventlog/EventLog.c b/rts/eventlog/EventLog.c index 5f22af5bfc..e3597cd73c 100644 --- a/rts/eventlog/EventLog.c +++ b/rts/eventlog/EventLog.c @@ -26,7 +26,9 @@ #include <unistd.h> #endif -static const EventLogWriter *event_log_writer; +bool eventlog_enabled; + +static const EventLogWriter *event_log_writer = NULL; #define EVENT_LOG_SIZE 2 * (1024 * 1024) // 2MB @@ -516,16 +518,22 @@ postHeaderEvents(void) postInt32(&eventBuf, EVENT_DATA_BEGIN); } -void -initEventLogging(const EventLogWriter *ev_writer) +static uint32_t +get_n_capabilities(void) { - uint32_t n_caps; +#if defined(THREADED_RTS) + // XXX n_capabilities may not have been initialized yet + return (n_capabilities != 0) ? n_capabilities : RtsFlags.ParFlags.nCapabilities; +#else + return 1; +#endif +} +void +initEventLogging() +{ init_event_types(); - event_log_writer = ev_writer; - initEventLogWriter(); - int num_descs = sizeof(EventDesc) / sizeof(char*); if (num_descs != NUM_GHC_EVENT_TAGS) { barf("EventDesc array has the wrong number of elements (%d, NUM_GHC_EVENT_TAGS=%d)", @@ -542,18 +550,28 @@ initEventLogging(const EventLogWriter *ev_writer) * Use a single buffer to store the header with event types, then flush * the buffer so all buffers are empty for writing events. */ -#if defined(THREADED_RTS) - // XXX n_capabilities hasn't been initialized yet - n_caps = RtsFlags.ParFlags.nCapabilities; -#else - n_caps = 1; -#endif - moreCapEventBufs(0, n_caps); + moreCapEventBufs(0, get_n_capabilities()); initEventsBuf(&eventBuf, EVENT_LOG_SIZE, (EventCapNo)(-1)); #if defined(THREADED_RTS) initMutex(&eventBufMutex); #endif +} + +enum EventLogStatus +eventLogStatus(void) +{ + if (eventlog_enabled) { + return EVENTLOG_RUNNING; + } else { + return EVENTLOG_NOT_CONFIGURED; + } +} + +static bool +startEventLogging_(void) +{ + initEventLogWriter(); postHeaderEvents(); @@ -564,14 +582,42 @@ initEventLogging(const EventLogWriter *ev_writer) */ printAndClearEventBuf(&eventBuf); - for (uint32_t c = 0; c < n_caps; ++c) { + for (uint32_t c = 0; c < get_n_capabilities(); ++c) { postBlockMarker(&capEventBuf[c]); } + return true; +} + +bool +startEventLogging(const EventLogWriter *ev_writer) +{ + if (eventlog_enabled || event_log_writer) { + return false; + } + + eventlog_enabled = true; + event_log_writer = ev_writer; + return startEventLogging_(); +} + +// Called during forkProcess in the child to restart the eventlog writer. +void +restartEventLogging(void) +{ + freeEventLogging(); + stopEventLogWriter(); + initEventLogging(); // allocate new per-capability buffers + if (event_log_writer != NULL) { + startEventLogging_(); // child starts its own eventlog + } } void endEventLogging(void) { + if (!eventlog_enabled) + return; + // Flush all events remaining in the buffers. for (uint32_t c = 0; c < n_capabilities; ++c) { printAndClearEventBuf(&capEventBuf[c]); @@ -586,6 +632,8 @@ endEventLogging(void) printAndClearEventBuf(&eventBuf); stopEventLogWriter(); + event_log_writer = NULL; + eventlog_enabled = false; } void @@ -626,13 +674,6 @@ freeEventLogging(void) } } -void -abortEventLogging(void) -{ - freeEventLogging(); - stopEventLogWriter(); -} - /* * Post an event message to the capability's eventlog buffer. * If the buffer is full, prints out the buffer and clears it. @@ -1440,7 +1481,7 @@ void printAndClearEventBuf (EventsBuf *ebuf) size_t elog_size = ebuf->pos - ebuf->begin; if (!writeEventLog(ebuf->begin, elog_size)) { debugBelch( - "printAndClearEventLog: could not flush event log" + "printAndClearEventLog: could not flush event log\n" ); resetEventsBuf(ebuf); return; @@ -1524,4 +1565,17 @@ void postEventType(EventsBuf *eb, EventType *et) postInt32(eb, EVENT_ET_END); } +#else + +enum EventLogStatus eventLogStatus(void) +{ + return EVENTLOG_NOT_SUPPORTED; +} + +bool startEventLogging(const EventLogWriter *writer STG_UNUSED) { + return false; +} + +void endEventLogging(void) {} + #endif /* TRACING */ diff --git a/rts/eventlog/EventLog.h b/rts/eventlog/EventLog.h index 5bd3b5dadb..eca76619cd 100644 --- a/rts/eventlog/EventLog.h +++ b/rts/eventlog/EventLog.h @@ -22,8 +22,10 @@ */ extern char *EventTagDesc[]; -void initEventLogging(const EventLogWriter *writer); -void endEventLogging(void); +extern bool eventlog_enabled; + +void initEventLogging(void); +void restartEventLogging(void); void freeEventLogging(void); void abortEventLogging(void); // #4512 - after fork child needs to abort void flushEventLog(void); // event log inherited from parent diff --git a/rts/eventlog/EventLogWriter.c b/rts/eventlog/EventLogWriter.c index 4b486926a7..b19e617a4c 100644 --- a/rts/eventlog/EventLogWriter.c +++ b/rts/eventlog/EventLogWriter.c @@ -122,6 +122,7 @@ stopEventLogFileWriter(void) { if (event_log_file != NULL) { fclose(event_log_file); + event_log_file = NULL; } } diff --git a/testsuite/tests/ffi/should_run/T17471.hs b/testsuite/tests/ffi/should_run/T17471.hs new file mode 100644 index 0000000000..bcaebc59cd --- /dev/null +++ b/testsuite/tests/ffi/should_run/T17471.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module Main where + +import Foreign.C.Types + +foreign import ccall "foo" foo :: IO CInt + +main :: IO () +main = foo >>= print diff --git a/testsuite/tests/ffi/should_run/T17471.stdout b/testsuite/tests/ffi/should_run/T17471.stdout new file mode 100644 index 0000000000..d00491fd7e --- /dev/null +++ b/testsuite/tests/ffi/should_run/T17471.stdout @@ -0,0 +1 @@ +1 diff --git a/testsuite/tests/ffi/should_run/T17471_c.c b/testsuite/tests/ffi/should_run/T17471_c.c new file mode 100644 index 0000000000..64a9445a62 --- /dev/null +++ b/testsuite/tests/ffi/should_run/T17471_c.c @@ -0,0 +1,7 @@ +int foo() { +#if defined(FOO) + return 1; +#else + return 0; +#endif +} diff --git a/testsuite/tests/ffi/should_run/all.T b/testsuite/tests/ffi/should_run/all.T index d379191548..a0984a28fe 100644 --- a/testsuite/tests/ffi/should_run/all.T +++ b/testsuite/tests/ffi/should_run/all.T @@ -213,3 +213,6 @@ test('PrimFFIWord16', [omit_ways(['ghci'])], compile_and_run, ['PrimFFIWord16_c. test('T493', [omit_ways(['ghci'])], compile_and_run, ['T493_c.c']) test('UnliftedNewtypesByteArrayOffset', [omit_ways(['ghci'])], compile_and_run, ['UnliftedNewtypesByteArrayOffset_c.c']) + +test('T17471', [omit_ways(['ghci'])], compile_and_run, + ['T17471_c.c -optc-D -optcFOO']) diff --git a/testsuite/tests/numeric/should_compile/T14465.stdout b/testsuite/tests/numeric/should_compile/T14465.stdout index df97060635..b7c88c40ac 100644 --- a/testsuite/tests/numeric/should_compile/T14465.stdout +++ b/testsuite/tests/numeric/should_compile/T14465.stdout @@ -72,7 +72,7 @@ minusOne NatS# ds1 -> case ds1 of { __DEFAULT -> GHC.Natural.underflowError @ Natural; - 0## -> GHC.Natural.lcmNatural1 + 0## -> GHC.Natural.zero }; NatJ# ipv -> GHC.Natural.underflowError @ Natural } diff --git a/testsuite/tests/rts/InitEventLogging.hs b/testsuite/tests/rts/InitEventLogging.hs new file mode 100644 index 0000000000..1ec1e65028 --- /dev/null +++ b/testsuite/tests/rts/InitEventLogging.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +-- Test that the startEventLog interface works as expected. +main :: IO () +main = do + putStrLn "Starting eventlog..." + c_init_eventlog + putStrLn "done" + +foreign import ccall unsafe "init_eventlog" + c_init_eventlog :: IO () diff --git a/testsuite/tests/rts/InitEventLogging.stdout b/testsuite/tests/rts/InitEventLogging.stdout new file mode 100644 index 0000000000..7cbab8fe59 --- /dev/null +++ b/testsuite/tests/rts/InitEventLogging.stdout @@ -0,0 +1,8 @@ +Starting eventlog... +done +init +write +write +write +write +stop diff --git a/testsuite/tests/rts/InitEventLogging_c.c b/testsuite/tests/rts/InitEventLogging_c.c new file mode 100644 index 0000000000..47e4520fc4 --- /dev/null +++ b/testsuite/tests/rts/InitEventLogging_c.c @@ -0,0 +1,33 @@ +#include <stdio.h> +#include <Rts.h> + +void test_init(void) { + printf("init\n"); +} + +bool test_write(void *eventlog, size_t eventlog_size) { + printf("write\n"); + return true; +} + +void test_flush(void) { + printf("flush\n"); +} + +void test_stop(void) { + printf("stop\n"); +} + +const EventLogWriter writer = { + .initEventLogWriter = test_init, + .writeEventLog = test_write, + .flushEventLog = test_flush, + .stopEventLogWriter = test_stop +}; + +void init_eventlog(void) { + if (!startEventLogging(&writer)) { + printf("failed to start eventlog\n"); + } +} + diff --git a/testsuite/tests/rts/all.T b/testsuite/tests/rts/all.T index bd634d1e56..0bbddfba3e 100644 --- a/testsuite/tests/rts/all.T +++ b/testsuite/tests/rts/all.T @@ -406,3 +406,6 @@ test('T13676', [when(opsys('darwin') or opsys('mingw32'), expect_broken(17447)), extra_files(['T13676.hs'])], ghci_script, ['T13676.script']) +test('InitEventLogging', + [only_ways(['normal']), extra_run_opts('+RTS -RTS')], + compile_and_run, ['-eventlog InitEventLogging_c.c']) diff --git a/testsuite/tests/simplCore/should_compile/T17429.hs b/testsuite/tests/simplCore/should_compile/T17429.hs new file mode 100644 index 0000000000..bd01c140ff --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T17429.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeFamilies #-} + +module T17429 + ( zoomAcceptor + ) where + +type Zoom m = ( m ~ Emitter Int ) + +zoomAcceptor :: Zoom m => Emitter w a -> m w +zoomAcceptor = fmap id . zoomEmitter + +zoomEmitter :: Emitter w a -> Emitter b w +zoomEmitter (Emitter go) = + Emitter $ const ([], fst $ go ()) + +newtype Emitter w a = Emitter (() -> ([w], [a])) + +instance Functor (Emitter w) where + fmap f (Emitter go) = Emitter mapped + where + {-# INLINE mapped #-} + mapped _ = fmap f <$> go () diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T index 5867a11a29..7146b76e6d 100644 --- a/testsuite/tests/simplCore/should_compile/all.T +++ b/testsuite/tests/simplCore/should_compile/all.T @@ -311,3 +311,4 @@ test('T17140', test('T17409', normal, makefile_test, ['T17409']) +test('T17429', normal, compile, ['-dcore-lint -O2']) |