[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 7 commits: rts/linker: Resolve iconv_* on FreeBSD
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Tue Aug 9 23:21:04 UTC 2022
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
66d2e927 by Ben Gamari at 2022-08-09T13:46:48-04:00
rts/linker: Resolve iconv_* on FreeBSD
FreeBSD's libiconv includes an implementation of the
iconv_* functions in libc. Unfortunately these can
only be resolved using dlvsym, which is how the RTS linker
usually resolves such functions. To fix this we include an ad-hoc
special case for iconv_*.
Fixes #20354.
- - - - -
5d66a0ce by Ben Gamari at 2022-08-09T13:46:48-04:00
system-cxx-std-lib: Add support for FreeBSD libcxxrt
- - - - -
ea90e61d by Ben Gamari at 2022-08-09T13:46:48-04:00
gitlab-ci: Bump to use freebsd13 runners
- - - - -
d71a2051 by sheaf at 2022-08-09T13:47:28-04:00
Fix size_up_alloc to account for UnliftedDatatypes
The size_up_alloc function mistakenly considered any type that isn't
lifted to not allocate anything, which is wrong. What we want instead
is to check the type isn't boxed. This accounts for (BoxedRep Unlifted).
Fixes #21939
- - - - -
414b8125 by John Ericson at 2022-08-09T19:20:36-04:00
Relax instances for Functor combinators; put superclass on Class1 to make non-breaking
The first change makes the `Eq`, `Ord`, `Show`, and `Read` instances for
`Sum`, `Product`, and `Compose` match those for `:+:`, `:*:`, and `:.:`.
These have the proper flexible contexts that are exactly what the
instance needs:
For example, instead of
```haskell
instance (Eq1 f, Eq1 g, Eq a) => Eq (Compose f g a) where
(==) = eq1
```
we do
```haskell
deriving instance Eq (f (g a)) => Eq (Compose f g a)
```
But, that change alone is rather breaking, because until now `Eq (f a)`
and `Eq1 f` (and respectively the other classes and their `*1`
equivalents too) are *incomparable* constraints. This has always been an
annoyance of working with the `*1` classes, and now it would rear it's
head one last time as an pesky migration.
Instead, we give the `*1` classes superclasses, like so:
```haskell
(forall a. Eq a => Eq (f a)) => Eq1 f
```
along with some laws that canonicity is preserved, like:
```haskell
liftEq (==) = (==)
```
and likewise for `*2` classes:
```haskell
(forall a. Eq a => Eq1 (f a)) => Eq2 f
```
and laws:
```haskell
liftEq2 (==) = liftEq1
```
The `*1` classes also have default methods using the `*2` classes where
possible.
What this means, as explained in the docs, is that `*1` classes really
are generations of the regular classes, indicating that the methods can
be split into a canonical lifting combined with a canonical inner, with
the super class "witnessing" the laws[1] in a fashion.
Circling back to the pragmatics of migrating, note that the superclass
means evidence for the old `Sum`, `Product`, and `Compose` instances is
(more than) sufficient, so breakage is less likely --- as long no
instances are "missing", existing polymorphic code will continue to
work.
Breakage can occur when a datatype implements the `*1` class but not the
corresponding regular class, but this is almost certainly an oversight.
For example, containers made that mistake for `Tree` and `Ord`, which I
fixed in https://github.com/haskell/containers/pull/761, but fixing the
issue by adding `Ord1` was extremely *un*controversial.
`Generically1` was also missing `Eq`, `Ord`, `Read,` and `Show`
instances. It is unlikely this would have been caught without
implementing this change.
-----
[1]: In fact, someday, when the laws are part of the language and not
only documentation, we might be able to drop the superclass field of the
dictionary by using the laws to recover the superclass in an
instance-agnostic manner, e.g. with a *non*-overloaded function with
type:
```haskell
DictEq1 f -> DictEq a -> DictEq (f a)
```
But I don't wish to get into optomizations now, just demonstrate the
close relationship between the law and the superclass.
Bump haddock submodule because of test output changing.
- - - - -
caa68a42 by Douglas Wilson at 2022-08-09T19:20:39-04:00
testsuite: 21651 add test for closeFdWith + setNumCapabilities
This bug does not affect windows, which does not use the
base module GHC.Event.Thread.
- - - - -
55c4d9fc by Douglas Wilson at 2022-08-09T19:20:39-04:00
base: Fix races in IOManager (setNumCapabilities,closeFdWith)
Fix for #21651
Fixes three bugs:
- writes to eventManager should be atomic. It is accessed concurrently by ioManagerCapabilitiesChanged and closeFdWith.
- The race in closeFdWith described in the ticket.
- A race in getSystemEventManager where it accesses the 'IOArray' in
'eventManager' before 'ioManagerCapabilitiesChanged' has written to
'eventManager', causing an Array Index exception. The fix here is to
'yield' and retry.
- - - - -
16 changed files:
- .gitlab/ci.sh
- .gitlab/gen_ci.hs
- .gitlab/jobs.yaml
- compiler/GHC/Core/Unfold.hs
- libraries/base/Data/Functor/Classes.hs
- libraries/base/Data/Functor/Compose.hs
- libraries/base/Data/Functor/Product.hs
- libraries/base/Data/Functor/Sum.hs
- libraries/base/GHC/Event/Thread.hs
- libraries/base/GHC/Generics.hs
- m4/fp_find_cxx_std_lib.m4
- rts/Linker.c
- + testsuite/tests/concurrent/should_run/T21651.hs
- + testsuite/tests/concurrent/should_run/T21651.stdout
- testsuite/tests/concurrent/should_run/all.T
- utils/haddock
Changes:
=====================================
.gitlab/ci.sh
=====================================
@@ -207,6 +207,9 @@ function set_toolchain_paths() {
CABAL="$toolchain/bin/cabal$exe"
HAPPY="$toolchain/bin/happy$exe"
ALEX="$toolchain/bin/alex$exe"
+ if [ "$(uname)" = "FreeBSD" ]; then
+ GHC=/usr/local/bin/ghc
+ fi
;;
nix)
if [[ ! -f toolchain.sh ]]; then
@@ -288,7 +291,7 @@ function fetch_ghc() {
cp -r ghc-${GHC_VERSION}*/* "$toolchain"
;;
*)
- pushd "ghc-${GHC_VERSION}*"
+ pushd ghc-${GHC_VERSION}*
./configure --prefix="$toolchain"
"$MAKE" install
popd
@@ -326,9 +329,7 @@ function fetch_cabal() {
local base_url="https://downloads.haskell.org/~cabal/cabal-install-$v/"
case "$(uname)" in
Darwin) cabal_url="$base_url/cabal-install-$v-x86_64-apple-darwin17.7.0.tar.xz" ;;
- FreeBSD)
- #cabal_url="$base_url/cabal-install-$v-x86_64-portbld-freebsd.tar.xz" ;;
- cabal_url="http://home.smart-cactus.org/~ben/ghc/cabal-install-3.0.0.0-x86_64-portbld-freebsd.tar.xz" ;;
+ FreeBSD) cabal_url="$base_url/cabal-install-$v-x86_64-freebsd13.tar.xz" ;;
*) fail "don't know where to fetch cabal-install for $(uname)"
esac
echo "Fetching cabal-install from $cabal_url"
=====================================
.gitlab/gen_ci.hs
=====================================
@@ -92,7 +92,7 @@ names of jobs to update these other places.
data Opsys
= Linux LinuxDistro
| Darwin
- | FreeBSD
+ | FreeBSD13
| Windows deriving (Eq)
data LinuxDistro
@@ -223,7 +223,7 @@ runnerTag arch (Linux distro) =
runnerTag AArch64 Darwin = "aarch64-darwin"
runnerTag Amd64 Darwin = "x86_64-darwin-m1"
runnerTag Amd64 Windows = "new-x86_64-windows"
-runnerTag Amd64 FreeBSD = "x86_64-freebsd"
+runnerTag Amd64 FreeBSD13 = "x86_64-freebsd13"
tags :: Arch -> Opsys -> BuildConfig -> [String]
tags arch opsys _bc = [runnerTag arch opsys] -- Tag for which runners we can use
@@ -242,7 +242,7 @@ distroName Alpine = "alpine3_12"
opsysName :: Opsys -> String
opsysName (Linux distro) = "linux-" ++ distroName distro
opsysName Darwin = "darwin"
-opsysName FreeBSD = "freebsd"
+opsysName FreeBSD13 = "freebsd13"
opsysName Windows = "windows"
archName :: Arch -> String
@@ -313,7 +313,7 @@ type Variables = M.MonoidalMap String [String]
a =: b = M.singleton a [b]
opsysVariables :: Arch -> Opsys -> Variables
-opsysVariables _ FreeBSD = mconcat
+opsysVariables _ FreeBSD13 = mconcat
[ -- N.B. we use iconv from ports as I see linker errors when we attempt
-- to use the "native" iconv embedded in libc as suggested by the
-- porting guide [1].
@@ -321,7 +321,7 @@ opsysVariables _ FreeBSD = mconcat
"CONFIGURE_ARGS" =: "--with-gmp-includes=/usr/local/include --with-gmp-libraries=/usr/local/lib --with-iconv-includes=/usr/local/include --with-iconv-libraries=/usr/local/lib"
, "HADRIAN_ARGS" =: "--docs=no-sphinx"
, "GHC_VERSION" =: "9.2.2"
- , "CABAL_INSTALL_VERSION" =: "3.2.0.0"
+ , "CABAL_INSTALL_VERSION" =: "3.6.2.0"
]
opsysVariables ARMv7 (Linux distro) =
distroVariables distro <>
@@ -489,12 +489,12 @@ instance ToJSON OnOffRules where
-- | A Rule corresponds to some condition which must be satisifed in order to
-- run the job.
-data Rule = FastCI -- ^ Run this job when the fast-ci label is set
- | ReleaseOnly -- ^ Only run this job in a release pipeline
- | Nightly -- ^ Only run this job in the nightly pipeline
- | LLVMBackend -- ^ Only run this job when the "LLVM backend" label is present
- | FreeBSDTag -- ^ Only run this job when the "FreeBSD" label is set.
- | Disable -- ^ Don't run this job.
+data Rule = FastCI -- ^ Run this job when the fast-ci label is set
+ | ReleaseOnly -- ^ Only run this job in a release pipeline
+ | Nightly -- ^ Only run this job in the nightly pipeline
+ | LLVMBackend -- ^ Only run this job when the "LLVM backend" label is present
+ | FreeBSDLabel -- ^ Only run this job when the "FreeBSD" label is set.
+ | Disable -- ^ Don't run this job.
deriving (Bounded, Enum, Ord, Eq)
-- A constant evaluating to True because gitlab doesn't support "true" in the
@@ -512,8 +512,8 @@ ruleString On FastCI = true
ruleString Off FastCI = "$CI_MERGE_REQUEST_LABELS !~ /.*fast-ci.*/"
ruleString On LLVMBackend = "$CI_MERGE_REQUEST_LABELS =~ /.*LLVM backend.*/"
ruleString Off LLVMBackend = true
-ruleString On FreeBSDTag = "$CI_MERGE_REQUEST_LABELS =~ /.*FreeBSD.*/"
-ruleString Off FreeBSDTag = true
+ruleString On FreeBSDLabel = "$CI_MERGE_REQUEST_LABELS =~ /.*FreeBSD.*/"
+ruleString Off FreeBSDLabel = true
ruleString On ReleaseOnly = "$RELEASE_JOB == \"yes\""
ruleString Off ReleaseOnly = "$RELEASE_JOB != \"yes\""
ruleString On Nightly = "$NIGHTLY"
@@ -781,7 +781,7 @@ jobs = M.fromList $ concatMap flattenJobGroup $
, fastCI (standardBuilds Amd64 Windows)
, disableValidate (standardBuildsWithConfig Amd64 Windows nativeInt)
, standardBuilds Amd64 Darwin
- , allowFailureGroup (addValidateRule FreeBSDTag (standardBuilds Amd64 FreeBSD))
+ , allowFailureGroup (addValidateRule FreeBSDLabel (standardBuilds Amd64 FreeBSD13))
, standardBuilds AArch64 Darwin
, standardBuilds AArch64 (Linux Debian10)
, disableValidate (standardBuilds AArch64 (Linux Debian11))
=====================================
.gitlab/jobs.yaml
=====================================
@@ -658,7 +658,7 @@
"ac_cv_func_utimensat": "no"
}
},
- "nightly-x86_64-freebsd-validate": {
+ "nightly-x86_64-freebsd13-validate": {
"after_script": [
".gitlab/ci.sh save_cache",
".gitlab/ci.sh clean",
@@ -668,7 +668,7 @@
"artifacts": {
"expire_in": "8 weeks",
"paths": [
- "ghc-x86_64-freebsd-validate.tar.xz",
+ "ghc-x86_64-freebsd13-validate.tar.xz",
"junit.xml"
],
"reports": {
@@ -677,7 +677,7 @@
"when": "always"
},
"cache": {
- "key": "x86_64-freebsd-$CACHE_REV",
+ "key": "x86_64-freebsd13-$CACHE_REV",
"paths": [
"cabal-cache",
"toolchain"
@@ -705,17 +705,17 @@
],
"stage": "full-build",
"tags": [
- "x86_64-freebsd"
+ "x86_64-freebsd13"
],
"variables": {
"BIGNUM_BACKEND": "gmp",
- "BIN_DIST_NAME": "ghc-x86_64-freebsd-validate",
+ "BIN_DIST_NAME": "ghc-x86_64-freebsd13-validate",
"BUILD_FLAVOUR": "validate",
- "CABAL_INSTALL_VERSION": "3.2.0.0",
+ "CABAL_INSTALL_VERSION": "3.6.2.0",
"CONFIGURE_ARGS": "--with-gmp-includes=/usr/local/include --with-gmp-libraries=/usr/local/lib --with-iconv-includes=/usr/local/include --with-iconv-libraries=/usr/local/lib ",
"GHC_VERSION": "9.2.2",
"HADRIAN_ARGS": "--docs=no-sphinx",
- "TEST_ENV": "x86_64-freebsd-validate",
+ "TEST_ENV": "x86_64-freebsd13-validate",
"XZ_OPT": "-9"
}
},
@@ -2288,7 +2288,7 @@
"ac_cv_func_utimensat": "no"
}
},
- "release-x86_64-freebsd-release": {
+ "release-x86_64-freebsd13-release": {
"after_script": [
".gitlab/ci.sh save_cache",
".gitlab/ci.sh clean",
@@ -2298,7 +2298,7 @@
"artifacts": {
"expire_in": "1 year",
"paths": [
- "ghc-x86_64-freebsd-release.tar.xz",
+ "ghc-x86_64-freebsd13-release.tar.xz",
"junit.xml"
],
"reports": {
@@ -2307,7 +2307,7 @@
"when": "always"
},
"cache": {
- "key": "x86_64-freebsd-$CACHE_REV",
+ "key": "x86_64-freebsd13-$CACHE_REV",
"paths": [
"cabal-cache",
"toolchain"
@@ -2335,18 +2335,18 @@
],
"stage": "full-build",
"tags": [
- "x86_64-freebsd"
+ "x86_64-freebsd13"
],
"variables": {
"BIGNUM_BACKEND": "gmp",
- "BIN_DIST_NAME": "ghc-x86_64-freebsd-release",
+ "BIN_DIST_NAME": "ghc-x86_64-freebsd13-release",
"BUILD_FLAVOUR": "release",
- "CABAL_INSTALL_VERSION": "3.2.0.0",
+ "CABAL_INSTALL_VERSION": "3.6.2.0",
"CONFIGURE_ARGS": "--with-gmp-includes=/usr/local/include --with-gmp-libraries=/usr/local/lib --with-iconv-includes=/usr/local/include --with-iconv-libraries=/usr/local/lib ",
"GHC_VERSION": "9.2.2",
"HADRIAN_ARGS": "--docs=no-sphinx",
"IGNORE_PERF_FAILURES": "all",
- "TEST_ENV": "x86_64-freebsd-release",
+ "TEST_ENV": "x86_64-freebsd13-release",
"XZ_OPT": "-9"
}
},
@@ -3208,7 +3208,7 @@
"ac_cv_func_utimensat": "no"
}
},
- "x86_64-freebsd-validate": {
+ "x86_64-freebsd13-validate": {
"after_script": [
".gitlab/ci.sh save_cache",
".gitlab/ci.sh clean",
@@ -3218,7 +3218,7 @@
"artifacts": {
"expire_in": "2 weeks",
"paths": [
- "ghc-x86_64-freebsd-validate.tar.xz",
+ "ghc-x86_64-freebsd13-validate.tar.xz",
"junit.xml"
],
"reports": {
@@ -3227,7 +3227,7 @@
"when": "always"
},
"cache": {
- "key": "x86_64-freebsd-$CACHE_REV",
+ "key": "x86_64-freebsd13-$CACHE_REV",
"paths": [
"cabal-cache",
"toolchain"
@@ -3255,17 +3255,17 @@
],
"stage": "full-build",
"tags": [
- "x86_64-freebsd"
+ "x86_64-freebsd13"
],
"variables": {
"BIGNUM_BACKEND": "gmp",
- "BIN_DIST_NAME": "ghc-x86_64-freebsd-validate",
+ "BIN_DIST_NAME": "ghc-x86_64-freebsd13-validate",
"BUILD_FLAVOUR": "validate",
- "CABAL_INSTALL_VERSION": "3.2.0.0",
+ "CABAL_INSTALL_VERSION": "3.6.2.0",
"CONFIGURE_ARGS": "--with-gmp-includes=/usr/local/include --with-gmp-libraries=/usr/local/lib --with-iconv-includes=/usr/local/include --with-iconv-libraries=/usr/local/lib ",
"GHC_VERSION": "9.2.2",
"HADRIAN_ARGS": "--docs=no-sphinx",
- "TEST_ENV": "x86_64-freebsd-validate"
+ "TEST_ENV": "x86_64-freebsd13-validate"
}
},
"x86_64-linux-alpine3_12-int_native-validate+fully_static": {
=====================================
compiler/GHC/Core/Unfold.hs
=====================================
@@ -580,10 +580,9 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr
------------
-- Cost to allocate binding with given binder
size_up_alloc bndr
- | isTyVar bndr -- Doesn't exist at runtime
- || isJoinId bndr -- Not allocated at all
- || isUnliftedType (idType bndr) -- Doesn't live in heap
- -- OK to call isUnliftedType: binders have a fixed RuntimeRep (search for FRRBinder)
+ | isTyVar bndr -- Doesn't exist at runtime
+ || isJoinId bndr -- Not allocated at all
+ || not (isBoxedType (idType bndr)) -- Doesn't live in heap
= 0
| otherwise
= 10
=====================================
libraries/base/Data/Functor/Classes.hs
=====================================
@@ -1,7 +1,10 @@
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE Safe #-}
+{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE QuantifiedConstraints #-}
-----------------------------------------------------------------------------
-- |
-- Module : Data.Functor.Classes
@@ -91,8 +94,18 @@ import Text.Show (showListWith)
-- | Lifting of the 'Eq' class to unary type constructors.
--
+-- Any instance should be subject to the following law that canonicity
+-- is preserved:
+--
+-- @liftEq (==)@ = @(==)@
+--
+-- This class therefore represents the generalization of 'Eq' by
+-- decomposing its main method into a canonical lifting on a canonical
+-- inner method, so that the lifting can be reused for other arguments
+-- than the canonical one.
+--
-- @since 4.9.0.0
-class Eq1 f where
+class (forall a. Eq a => Eq (f a)) => Eq1 f where
-- | Lift an equality test through the type constructor.
--
-- The function will usually be applied to an equality function,
@@ -102,6 +115,10 @@ class Eq1 f where
--
-- @since 4.9.0.0
liftEq :: (a -> b -> Bool) -> f a -> f b -> Bool
+ default liftEq
+ :: (f ~ f' c, Eq2 f', Eq c)
+ => (a -> b -> Bool) -> f a -> f b -> Bool
+ liftEq = liftEq2 (==)
-- | Lift the standard @('==')@ function through the type constructor.
--
@@ -111,8 +128,18 @@ eq1 = liftEq (==)
-- | Lifting of the 'Ord' class to unary type constructors.
--
+-- Any instance should be subject to the following law that canonicity
+-- is preserved:
+--
+-- @liftCompare compare@ = 'compare'
+--
+-- This class therefore represents the generalization of 'Ord' by
+-- decomposing its main method into a canonical lifting on a canonical
+-- inner method, so that the lifting can be reused for other arguments
+-- than the canonical one.
+--
-- @since 4.9.0.0
-class (Eq1 f) => Ord1 f where
+class (Eq1 f, forall a. Ord a => Ord (f a)) => Ord1 f where
-- | Lift a 'compare' function through the type constructor.
--
-- The function will usually be applied to a comparison function,
@@ -122,6 +149,10 @@ class (Eq1 f) => Ord1 f where
--
-- @since 4.9.0.0
liftCompare :: (a -> b -> Ordering) -> f a -> f b -> Ordering
+ default liftCompare
+ :: (f ~ f' c, Ord2 f', Ord c)
+ => (a -> b -> Ordering) -> f a -> f b -> Ordering
+ liftCompare = liftCompare2 compare
-- | Lift the standard 'compare' function through the type constructor.
--
@@ -131,6 +162,22 @@ compare1 = liftCompare compare
-- | Lifting of the 'Read' class to unary type constructors.
--
+-- Any instance should be subject to the following laws that canonicity
+-- is preserved:
+--
+-- @liftReadsPrec readsPrec readList@ = 'readsPrec'
+--
+-- @liftReadList readsPrec readList@ = 'readList'
+--
+-- @liftReadPrec readPrec readListPrec@ = 'readPrec'
+--
+-- @liftReadListPrec readPrec readListPrec@ = 'readListPrec'
+--
+-- This class therefore represents the generalization of 'Read' by
+-- decomposing it's methods into a canonical lifting on a canonical
+-- inner method, so that the lifting can be reused for other arguments
+-- than the canonical one.
+--
-- Both 'liftReadsPrec' and 'liftReadPrec' exist to match the interface
-- provided in the 'Read' type class, but it is recommended to implement
-- 'Read1' instances using 'liftReadPrec' as opposed to 'liftReadsPrec', since
@@ -145,7 +192,7 @@ compare1 = liftCompare compare
-- For more information, refer to the documentation for the 'Read' class.
--
-- @since 4.9.0.0
-class Read1 f where
+class (forall a. Read a => Read (f a)) => Read1 f where
{-# MINIMAL liftReadsPrec | liftReadPrec #-}
-- | 'readsPrec' function for an application of the type constructor
@@ -219,14 +266,30 @@ liftReadListPrecDefault rp rl = list (liftReadPrec rp rl)
-- | Lifting of the 'Show' class to unary type constructors.
--
+-- Any instance should be subject to the following laws that canonicity
+-- is preserved:
+--
+-- @liftShowsPrec showsPrec showList@ = 'showsPrec'
+--
+-- @liftShowList showsPrec showList@ = 'showList'
+--
+-- This class therefore represents the generalization of 'Show' by
+-- decomposing it's methods into a canonical lifting on a canonical
+-- inner method, so that the lifting can be reused for other arguments
+-- than the canonical one.
+--
-- @since 4.9.0.0
-class Show1 f where
+class (forall a. Show a => Show (f a)) => Show1 f where
-- | 'showsPrec' function for an application of the type constructor
-- based on 'showsPrec' and 'showList' functions for the argument type.
--
-- @since 4.9.0.0
liftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) ->
Int -> f a -> ShowS
+ default liftShowsPrec
+ :: (f ~ f' b, Show2 f', Show b)
+ => (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
+ liftShowsPrec = liftShowsPrec2 showsPrec showList
-- | 'showList' function for an application of the type constructor
-- based on 'showsPrec' and 'showList' functions for the argument type.
@@ -248,7 +311,7 @@ showsPrec1 = liftShowsPrec showsPrec showList
-- | Lifting of the 'Eq' class to binary type constructors.
--
-- @since 4.9.0.0
-class Eq2 f where
+class (forall a. Eq a => Eq1 (f a)) => Eq2 f where
-- | Lift equality tests through the type constructor.
--
-- The function will usually be applied to equality functions,
@@ -268,7 +331,7 @@ eq2 = liftEq2 (==) (==)
-- | Lifting of the 'Ord' class to binary type constructors.
--
-- @since 4.9.0.0
-class (Eq2 f) => Ord2 f where
+class (Eq2 f, forall a. Ord a => Ord1 (f a)) => Ord2 f where
-- | Lift 'compare' functions through the type constructor.
--
-- The function will usually be applied to comparison functions,
@@ -302,7 +365,7 @@ compare2 = liftCompare2 compare compare
-- For more information, refer to the documentation for the 'Read' class.
--
-- @since 4.9.0.0
-class Read2 f where
+class (forall a. Read a => Read1 (f a)) => Read2 f where
{-# MINIMAL liftReadsPrec2 | liftReadPrec2 #-}
-- | 'readsPrec' function for an application of the type constructor
@@ -385,7 +448,7 @@ liftReadListPrec2Default rp1 rl1 rp2 rl2 = list (liftReadPrec2 rp1 rl1 rp2 rl2)
-- | Lifting of the 'Show' class to binary type constructors.
--
-- @since 4.9.0.0
-class Show2 f where
+class (forall a. Show a => Show1 (f a)) => Show2 f where
-- | 'showsPrec' function for an application of the type constructor
-- based on 'showsPrec' and 'showList' functions for the argument types.
--
=====================================
libraries/base/Data/Functor/Compose.hs
=====================================
@@ -5,6 +5,7 @@
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE StandaloneDeriving #-}
-----------------------------------------------------------------------------
-- |
@@ -32,7 +33,7 @@ import Data.Coerce (coerce)
import Data.Data (Data)
import Data.Type.Equality (TestEquality(..), (:~:)(..))
import GHC.Generics (Generic, Generic1)
-import Text.Read (Read(..), readListDefault, readListPrecDefault)
+import Text.Read ()
infixr 9 `Compose`
@@ -47,6 +48,17 @@ newtype Compose f g a = Compose { getCompose :: f (g a) }
, Monoid -- ^ @since 4.16.0.0
)
+-- Instances of Prelude classes
+
+-- | @since 4.17.0.0
+deriving instance Eq (f (g a)) => Eq (Compose f g a)
+-- | @since 4.17.0.0
+deriving instance Ord (f (g a)) => Ord (Compose f g a)
+-- | @since 4.17.0.0
+deriving instance Read (f (g a)) => Read (Compose f g a)
+-- | @since 4.17.0.0
+deriving instance Show (f (g a)) => Show (Compose f g a)
+
-- Instances of lifted Prelude classes
-- | @since 4.9.0.0
@@ -77,27 +89,6 @@ instance (Show1 f, Show1 g) => Show1 (Compose f g) where
sp' = liftShowsPrec sp sl
sl' = liftShowList sp sl
--- Instances of Prelude classes
-
--- | @since 4.9.0.0
-instance (Eq1 f, Eq1 g, Eq a) => Eq (Compose f g a) where
- (==) = eq1
-
--- | @since 4.9.0.0
-instance (Ord1 f, Ord1 g, Ord a) => Ord (Compose f g a) where
- compare = compare1
-
--- | @since 4.9.0.0
-instance (Read1 f, Read1 g, Read a) => Read (Compose f g a) where
- readPrec = readPrec1
-
- readListPrec = readListPrecDefault
- readList = readListDefault
-
--- | @since 4.9.0.0
-instance (Show1 f, Show1 g, Show a) => Show (Compose f g a) where
- showsPrec = showsPrec1
-
-- Functor instances
-- | @since 4.9.0.0
=====================================
libraries/base/Data/Functor/Product.hs
=====================================
@@ -2,6 +2,7 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE Safe #-}
+{-# LANGUAGE StandaloneDeriving #-}
-----------------------------------------------------------------------------
-- |
-- Module : Data.Functor.Product
@@ -28,7 +29,7 @@ import Control.Monad.Zip (MonadZip(mzipWith))
import Data.Data (Data)
import Data.Functor.Classes
import GHC.Generics (Generic, Generic1)
-import Text.Read (Read(..), readListDefault, readListPrecDefault)
+import Text.Read ()
-- | Lifted product of functors.
data Product f g a = Pair (f a) (g a)
@@ -37,6 +38,15 @@ data Product f g a = Pair (f a) (g a)
, Generic1 -- ^ @since 4.9.0.0
)
+-- | @since 4.17.0.0
+deriving instance (Eq (f a), Eq (g a)) => Eq (Product f g a)
+-- | @since 4.17.0.0
+deriving instance (Ord (f a), Ord (g a)) => Ord (Product f g a)
+-- | @since 4.17.0.0
+deriving instance (Read (f a), Read (g a)) => Read (Product f g a)
+-- | @since 4.17.0.0
+deriving instance (Show (f a), Show (g a)) => Show (Product f g a)
+
-- | @since 4.9.0.0
instance (Eq1 f, Eq1 g) => Eq1 (Product f g) where
liftEq eq (Pair x1 y1) (Pair x2 y2) = liftEq eq x1 x2 && liftEq eq y1 y2
@@ -59,25 +69,6 @@ instance (Show1 f, Show1 g) => Show1 (Product f g) where
liftShowsPrec sp sl d (Pair x y) =
showsBinaryWith (liftShowsPrec sp sl) (liftShowsPrec sp sl) "Pair" d x y
--- | @since 4.9.0.0
-instance (Eq1 f, Eq1 g, Eq a) => Eq (Product f g a)
- where (==) = eq1
-
--- | @since 4.9.0.0
-instance (Ord1 f, Ord1 g, Ord a) => Ord (Product f g a) where
- compare = compare1
-
--- | @since 4.9.0.0
-instance (Read1 f, Read1 g, Read a) => Read (Product f g a) where
- readPrec = readPrec1
-
- readListPrec = readListPrecDefault
- readList = readListDefault
-
--- | @since 4.9.0.0
-instance (Show1 f, Show1 g, Show a) => Show (Product f g a) where
- showsPrec = showsPrec1
-
-- | @since 4.9.0.0
instance (Functor f, Functor g) => Functor (Product f g) where
fmap f (Pair x y) = Pair (fmap f x) (fmap f y)
=====================================
libraries/base/Data/Functor/Sum.hs
=====================================
@@ -2,6 +2,7 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE Safe #-}
+{-# LANGUAGE StandaloneDeriving #-}
-----------------------------------------------------------------------------
-- |
-- Module : Data.Functor.Sum
@@ -25,7 +26,7 @@ import Control.Applicative ((<|>))
import Data.Data (Data)
import Data.Functor.Classes
import GHC.Generics (Generic, Generic1)
-import Text.Read (Read(..), readListDefault, readListPrecDefault)
+import Text.Read ()
-- | Lifted sum of functors.
data Sum f g a = InL (f a) | InR (g a)
@@ -34,6 +35,15 @@ data Sum f g a = InL (f a) | InR (g a)
, Generic1 -- ^ @since 4.9.0.0
)
+-- | @since 4.17.0.0
+deriving instance (Eq (f a), Eq (g a)) => Eq (Sum f g a)
+-- | @since 4.17.0.0
+deriving instance (Ord (f a), Ord (g a)) => Ord (Sum f g a)
+-- | @since 4.17.0.0
+deriving instance (Read (f a), Read (g a)) => Read (Sum f g a)
+-- | @since 4.17.0.0
+deriving instance (Show (f a), Show (g a)) => Show (Sum f g a)
+
-- | @since 4.9.0.0
instance (Eq1 f, Eq1 g) => Eq1 (Sum f g) where
liftEq eq (InL x1) (InL x2) = liftEq eq x1 x2
@@ -64,22 +74,6 @@ instance (Show1 f, Show1 g) => Show1 (Sum f g) where
liftShowsPrec sp sl d (InR y) =
showsUnaryWith (liftShowsPrec sp sl) "InR" d y
--- | @since 4.9.0.0
-instance (Eq1 f, Eq1 g, Eq a) => Eq (Sum f g a) where
- (==) = eq1
--- | @since 4.9.0.0
-instance (Ord1 f, Ord1 g, Ord a) => Ord (Sum f g a) where
- compare = compare1
--- | @since 4.9.0.0
-instance (Read1 f, Read1 g, Read a) => Read (Sum f g a) where
- readPrec = readPrec1
-
- readListPrec = readListPrecDefault
- readList = readListDefault
--- | @since 4.9.0.0
-instance (Show1 f, Show1 g, Show a) => Show (Sum f g a) where
- showsPrec = showsPrec1
-
-- | @since 4.9.0.0
instance (Functor f, Functor g) => Functor (Sum f g) where
fmap f (InL x) = InL (fmap f x)
=====================================
libraries/base/GHC/Event/Thread.hs
=====================================
@@ -18,7 +18,7 @@ module GHC.Event.Thread
-- TODO: Use new Windows I/O manager
import Control.Exception (finally, SomeException, toException)
import Data.Foldable (forM_, mapM_, sequence_)
-import Data.IORef (IORef, newIORef, readIORef, writeIORef)
+import Data.IORef (IORef, newIORef, readIORef, writeIORef, atomicWriteIORef)
import Data.Maybe (fromMaybe)
import Data.Tuple (snd)
import Foreign.C.Error (eBADF, errnoToIOError)
@@ -29,7 +29,8 @@ import GHC.List (zipWith, zipWith3)
import GHC.Conc.Sync (TVar, ThreadId, ThreadStatus(..), atomically, forkIO,
labelThread, modifyMVar_, withMVar, newTVar, sharedCAF,
getNumCapabilities, threadCapability, myThreadId, forkOn,
- threadStatus, writeTVar, newTVarIO, readTVar, retry,throwSTM,STM)
+ threadStatus, writeTVar, newTVarIO, readTVar, retry,
+ throwSTM, STM, yield)
import GHC.IO (mask_, uninterruptibleMask_, onException)
import GHC.IO.Exception (ioError)
import GHC.IOArray (IOArray, newIOArray, readIOArray, writeIOArray,
@@ -41,6 +42,7 @@ import GHC.Event.Manager (Event, EventManager, evtRead, evtWrite, loop,
new, registerFd, unregisterFd_)
import qualified GHC.Event.Manager as M
import qualified GHC.Event.TimerManager as TM
+import GHC.Ix (inRange)
import GHC.Num ((-), (+))
import GHC.Real (fromIntegral)
import GHC.Show (showSignedInt)
@@ -98,22 +100,44 @@ threadWaitWrite = threadWait evtWrite
closeFdWith :: (Fd -> IO ()) -- ^ Action that performs the close.
-> Fd -- ^ File descriptor to close.
-> IO ()
-closeFdWith close fd = do
- eventManagerArray <- readIORef eventManager
- let (low, high) = boundsIOArray eventManagerArray
- mgrs <- flip mapM [low..high] $ \i -> do
- Just (_,!mgr) <- readIOArray eventManagerArray i
- return mgr
- -- 'takeMVar', and 'M.closeFd_' might block, although for a very short time.
- -- To make 'closeFdWith' safe in presence of asynchronous exceptions we have
- -- to use uninterruptible mask.
- uninterruptibleMask_ $ do
- tables <- flip mapM mgrs $ \mgr -> takeMVar $ M.callbackTableVar mgr fd
- cbApps <- zipWithM (\mgr table -> M.closeFd_ mgr table fd) mgrs tables
- close fd `finally` sequence_ (zipWith3 finish mgrs tables cbApps)
+closeFdWith close fd = close_loop
where
finish mgr table cbApp = putMVar (M.callbackTableVar mgr fd) table >> cbApp
zipWithM f xs ys = sequence (zipWith f xs ys)
+ -- The array inside 'eventManager' can be swapped out at any time, see
+ -- 'ioManagerCapabilitiesChanged'. See #21651. We detect this case by
+ -- checking the array bounds before and after. When such a swap has
+ -- happened we cleanup and try again
+ close_loop = do
+ eventManagerArray <- readIORef eventManager
+ let ema_bounds@(low, high) = boundsIOArray eventManagerArray
+ mgrs <- flip mapM [low..high] $ \i -> do
+ Just (_,!mgr) <- readIOArray eventManagerArray i
+ return mgr
+
+ -- 'takeMVar', and 'M.closeFd_' might block, although for a very short time.
+ -- To make 'closeFdWith' safe in presence of asynchronous exceptions we have
+ -- to use uninterruptible mask.
+ join $ uninterruptibleMask_ $ do
+ tables <- flip mapM mgrs $ \mgr -> takeMVar $ M.callbackTableVar mgr fd
+ new_ema_bounds <- boundsIOArray `fmap` readIORef eventManager
+ -- Here we exploit Note [The eventManager Array]
+ if new_ema_bounds /= ema_bounds
+ then do
+ -- the array has been modified.
+ -- mgrs still holds the right EventManagers, by the Note.
+ -- new_ema_bounds must be larger than ema_bounds, by the note.
+ -- return the MVars we took and try again
+ sequence_ $ zipWith (\mgr table -> finish mgr table (pure ())) mgrs tables
+ pure close_loop
+ else do
+ -- We surely have taken all the appropriate MVars. Even if the array
+ -- has been swapped, our mgrs is still correct.
+ -- Remove the Fd from all callback tables, close the Fd, and run all
+ -- callbacks.
+ cbApps <- zipWithM (\mgr table -> M.closeFd_ mgr table fd) mgrs tables
+ close fd `finally` sequence_ (zipWith3 finish mgrs tables cbApps)
+ pure (pure ())
threadWait :: Event -> Fd -> IO ()
threadWait evt fd = mask_ $ do
@@ -177,10 +201,24 @@ threadWaitWriteSTM = threadWaitSTM evtWrite
getSystemEventManager :: IO (Maybe EventManager)
getSystemEventManager = do
t <- myThreadId
- (cap, _) <- threadCapability t
eventManagerArray <- readIORef eventManager
- mmgr <- readIOArray eventManagerArray cap
- return $ fmap snd mmgr
+ let r = boundsIOArray eventManagerArray
+ (cap, _) <- threadCapability t
+ -- It is possible that we've just increased the number of capabilities and the
+ -- new EventManager has not yet been constructed by
+ -- 'ioManagerCapabilitiesChanged'. We expect this to happen very rarely.
+ -- T21561 exercises this.
+ -- Two options to proceed:
+ -- 1) return the EventManager for capability 0. This is guaranteed to exist,
+ -- and "shouldn't" cause any correctness issues.
+ -- 2) Busy wait, with or without a call to 'yield'. This can't deadlock,
+ -- because we must be on a brand capability and there must be a call to
+ -- 'ioManagerCapabilitiesChanged' pending.
+ --
+ -- We take the second option, with the yield, judging it the most robust.
+ if not (inRange r cap)
+ then yield >> getSystemEventManager
+ else fmap snd `fmap` readIOArray eventManagerArray cap
getSystemEventManager_ :: IO EventManager
getSystemEventManager_ = do
@@ -191,6 +229,22 @@ getSystemEventManager_ = do
foreign import ccall unsafe "getOrSetSystemEventThreadEventManagerStore"
getOrSetSystemEventThreadEventManagerStore :: Ptr a -> IO (Ptr a)
+-- Note [The eventManager Array]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- A mutable array holding the current EventManager for each capability
+-- An entry is Nothing only while the eventmanagers are initialised, see
+-- 'startIOManagerThread' and 'ioManagerCapabilitiesChanged'.
+-- The 'ThreadId' at array position 'cap' will have been 'forkOn'ed capabality
+-- 'cap'.
+-- The array will be swapped with newer arrays when the number of capabilities
+-- changes(via 'setNumCapabilities'). However:
+-- * the size of the arrays will never decrease; and
+-- * The 'EventManager's in the array are not replaced with other
+-- 'EventManager' constructors.
+--
+-- This is a similar strategy as the rts uses for it's
+-- capabilities array (n_capabilities is the size of the array,
+-- enabled_capabilities' is the number of active capabilities).
eventManager :: IORef (IOArray Int (Maybe (ThreadId, EventManager)))
eventManager = unsafePerformIO $ do
numCaps <- getNumCapabilities
@@ -351,7 +405,9 @@ ioManagerCapabilitiesChanged =
startIOManagerThread new_eventManagerArray
-- update the event manager array reference:
- writeIORef eventManager new_eventManagerArray
+ atomicWriteIORef eventManager new_eventManagerArray
+ -- We need an atomic write here because 'eventManager' is accessed
+ -- unsynchronized in 'getSystemEventManager' and 'closeFdWith'
else when (new_n_caps > numEnabled) $
forM_ [numEnabled..new_n_caps-1] $ \i -> do
Just (_,mgr) <- readIOArray eventManagerArray i
=====================================
libraries/base/GHC/Generics.hs
=====================================
@@ -1480,6 +1480,15 @@ type Generically1 :: forall k. (k -> Type) -> (k -> Type)
newtype Generically1 f a where
Generically1 :: forall {k} f a. f a -> Generically1 @k f a
+-- | @since 4.17.0.0
+instance (Generic1 f, Eq (Rep1 f a)) => Eq (Generically1 f a) where
+ Generically1 x == Generically1 y = from1 x == from1 y
+ Generically1 x /= Generically1 y = from1 x /= from1 y
+
+-- | @since 4.17.0.0
+instance (Generic1 f, Ord (Rep1 f a)) => Ord (Generically1 f a) where
+ Generically1 x `compare` Generically1 y = from1 x `compare` from1 y
+
-- | @since 4.17.0.0
instance (Generic1 f, Functor (Rep1 f)) => Functor (Generically1 f) where
fmap :: (a -> a') -> (Generically1 f a -> Generically1 f a')
=====================================
m4/fp_find_cxx_std_lib.m4
=====================================
@@ -18,10 +18,44 @@ unknown
#endif
EOF
AC_MSG_CHECKING([C++ standard library flavour])
- if "$CXX" -E actest.cpp -o actest.out; then
- if grep "libc++" actest.out >/dev/null; then
- CXX_STD_LIB_LIBS="c++ c++abi"
- p="`"$CXX" --print-file-name libc++.so`"
+ if ! "$CXX" -E actest.cpp -o actest.out; then
+ rm -f actest.cpp actest.out
+ AC_MSG_ERROR([Failed to compile test program])
+ fi
+
+ dnl Identify standard library type
+ if grep "libc++" actest.out >/dev/null; then
+ CXX_STD_LIB_FLAVOUR="c++"
+ AC_MSG_RESULT([libc++])
+ elif grep "libstdc++" actest.out >/dev/null; then
+ CXX_STD_LIB_FLAVOUR="stdc++"
+ AC_MSG_RESULT([libstdc++])
+ else
+ rm -f actest.cpp actest.out
+ AC_MSG_ERROR([Unknown C++ standard library implementation.])
+ fi
+ rm -f actest.cpp actest.out
+
+ dnl -----------------------------------------
+ dnl Figure out how to link...
+ dnl -----------------------------------------
+ cat >actest.cpp <<-EOF
+#include <iostream>
+int main(int argc, char** argv) {
+ std::cout << "hello world\n";
+ return 0;
+}
+EOF
+ if ! "$CXX" -c actest.cpp; then
+ AC_MSG_ERROR([Failed to compile test object])
+ fi
+
+ try_libs() {
+ dnl Try to link a plain object with CC manually
+ AC_MSG_CHECKING([for linkage against '${3}'])
+ if "$CC" -o actest actest.o ${1} 2>/dev/null; then
+ CXX_STD_LIB_LIBS="${3}"
+ p="`"$CXX" --print-file-name ${2}`"
d="`dirname "$p"`"
dnl On some platforms (e.g. Windows) the C++ standard library
dnl can be found in the system search path. In this case $CXX
@@ -31,24 +65,25 @@ EOF
if test "$d" = "."; then d=""; fi
CXX_STD_LIB_LIB_DIRS="$d"
CXX_STD_LIB_DYN_LIB_DIRS="$d"
- AC_MSG_RESULT([libc++])
- elif grep "libstdc++" actest.out >/dev/null; then
- CXX_STD_LIB_LIBS="stdc++"
- p="`"$CXX" --print-file-name libstdc++.so`"
- d="`dirname "$p"`"
- if test "$d" = "."; then d=""; fi
- CXX_STD_LIB_LIB_DIRS="$d"
- CXX_STD_LIB_DYN_LIB_DIRS="$d"
- AC_MSG_RESULT([libstdc++])
+ AC_MSG_RESULT([success])
+ true
else
- rm -f actest.cpp actest.out
- AC_MSG_ERROR([Unknown C++ standard library implementation.])
+ AC_MSG_RESULT([failed])
+ false
fi
- rm -f actest.cpp actest.out
- else
- rm -f actest.cpp actest.out
- AC_MSG_ERROR([Failed to compile test program])
- fi
+ }
+ case $CXX_STD_LIB_FLAVOUR in
+ c++)
+ try_libs "-lc++ -lc++abi" "libc++.so" "c++ c++abi" || \
+ try_libs "-lc++ -lcxxrt" "libc++.so" "c++ cxxrt" ||
+ AC_MSG_ERROR([Failed to find C++ standard library]) ;;
+ stdc++)
+ try_libs "-lstdc++" "libstdc++.so" "stdc++" || \
+ try_libs "-lstdc++ -lsupc++" "libstdc++.so" "stdc++ supc++" || \
+ AC_MSG_ERROR([Failed to find C++ standard library]) ;;
+ esac
+
+ rm -f actest.cpp actest.o actest
fi
AC_SUBST([CXX_STD_LIB_LIBS])
=====================================
rts/Linker.c
=====================================
@@ -80,6 +80,33 @@
#if defined(dragonfly_HOST_OS)
#include <sys/tls.h>
#endif
+
+/*
+ * Note [iconv and FreeBSD]
+ * ~~~~~~~~~~~~~~~~~~~~~~~~
+ *
+ * On FreeBSD libc.so provides an implementation of the iconv_* family of
+ * functions. However, due to their implementation, these symbols cannot be
+ * resolved via dlsym(); rather, they can only be resolved using the
+ * explicitly-versioned dlvsym().
+ *
+ * This is problematic for the RTS linker since we may be asked to load
+ * an object that depends upon iconv. To handle this we include a set of
+ * fallback cases for these functions, allowing us to resolve them to the
+ * symbols provided by the libc against which the RTS is linked.
+ *
+ * See #20354.
+ */
+
+#if defined(freebsd_HOST_OS)
+extern void iconvctl();
+extern void iconv_open_into();
+extern void iconv_open();
+extern void iconv_close();
+extern void iconv_canonicalize();
+extern void iconv();
+#endif
+
/*
Note [runtime-linker-support]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -637,6 +664,10 @@ internal_dlsym(const char *symbol) {
}
RELEASE_LOCK(&dl_mutex);
+ IF_DEBUG(linker, debugBelch("internal_dlsym: looking for symbol '%s' in special cases\n", symbol));
+# define SPECIAL_SYMBOL(sym) \
+ if (strcmp(symbol, #sym) == 0) return (void*)&sym;
+
# if defined(HAVE_SYS_STAT_H) && defined(linux_HOST_OS) && defined(__GLIBC__)
// HACK: GLIBC implements these functions with a great deal of trickery where
// they are either inlined at compile time to their corresponding
@@ -646,18 +677,28 @@ internal_dlsym(const char *symbol) {
// We borrow the approach that the LLVM JIT uses to resolve these
// symbols. See http://llvm.org/PR274 and #7072 for more info.
- IF_DEBUG(linker, debugBelch("internal_dlsym: looking for symbol '%s' in GLIBC special cases\n", symbol));
+ SPECIAL_SYMBOL(stat);
+ SPECIAL_SYMBOL(fstat);
+ SPECIAL_SYMBOL(lstat);
+ SPECIAL_SYMBOL(stat64);
+ SPECIAL_SYMBOL(fstat64);
+ SPECIAL_SYMBOL(lstat64);
+ SPECIAL_SYMBOL(atexit);
+ SPECIAL_SYMBOL(mknod);
+# endif
- if (strcmp(symbol, "stat") == 0) return (void*)&stat;
- if (strcmp(symbol, "fstat") == 0) return (void*)&fstat;
- if (strcmp(symbol, "lstat") == 0) return (void*)&lstat;
- if (strcmp(symbol, "stat64") == 0) return (void*)&stat64;
- if (strcmp(symbol, "fstat64") == 0) return (void*)&fstat64;
- if (strcmp(symbol, "lstat64") == 0) return (void*)&lstat64;
- if (strcmp(symbol, "atexit") == 0) return (void*)&atexit;
- if (strcmp(symbol, "mknod") == 0) return (void*)&mknod;
+ // See Note [iconv and FreeBSD]
+# if defined(freebsd_HOST_OS)
+ SPECIAL_SYMBOL(iconvctl);
+ SPECIAL_SYMBOL(iconv_open_into);
+ SPECIAL_SYMBOL(iconv_open);
+ SPECIAL_SYMBOL(iconv_close);
+ SPECIAL_SYMBOL(iconv_canonicalize);
+ SPECIAL_SYMBOL(iconv);
# endif
+#undef SPECIAL_SYMBOL
+
// we failed to find the symbol
return NULL;
}
=====================================
testsuite/tests/concurrent/should_run/T21651.hs
=====================================
@@ -0,0 +1,124 @@
+{-# LANGUAGE MagicHash, UnboxedTuples #-}
+
+-- This test is adapted from setnumcapabilities001.
+
+import GHC.Conc hiding (threadWaitRead, threadWaitWrite)
+import GHC.Exts
+import GHC.IO.Encoding
+import System.Environment
+import System.IO
+import Control.Monad
+import Text.Printf
+import Data.Time.Clock
+import Control.DeepSeq
+
+import System.Posix.IO
+import System.Posix.Types
+import Control.Concurrent
+import Control.Exception
+
+passTheParcel :: Int -> IO (IO ())
+passTheParcel n = do
+ pipes@(p1 : rest) <- forM [0..n-1] $ \_ -> createPipe
+ rs@((_,tid1) : _) <- forM (pipes `zip` (rest ++ [p1])) $ \((readfd, _), (_, writefd)) -> do
+ let
+ read = fdRead readfd $ fromIntegral 1
+ write = fdWrite writefd
+ mv <- newEmptyMVar
+ tid <- forkIO $ let
+ loop = flip catch (\(x :: IOException) -> pure ()) $ forever $ do
+ threadWaitRead readfd
+ (s, _) <- read
+ threadWaitWrite writefd
+ write s
+ cleanup = do
+ closeFdWith closeFd readfd
+ closeFdWith closeFd writefd
+ putMVar mv ()
+ in loop `finally` cleanup
+ pure (mv, tid)
+
+ let
+ cleanup = do
+ killThread tid1
+ forM_ rs $ \(mv, _) -> takeMVar mv
+
+ fdWrite (snd p1) "a"
+ pure cleanup
+
+
+main = do
+ setLocaleEncoding latin1 -- fdRead and fdWrite depend on the current locale
+ [n,q,t,z] <- fmap (fmap read) getArgs
+ cleanup_ptp <- passTheParcel z
+ t <- forkIO $ do
+ forM_ (cycle ([n,n-1..1] ++ [2..n-1])) $ \m -> do
+ setNumCapabilities m
+ threadDelay t
+ printf "%d\n" (nqueens q)
+ cleanup_ptp
+ killThread t
+ -- If we don't kill the child thread, it might be about to
+ -- call setNumCapabilities() in C when the main thread exits,
+ -- and chaos can ensue. See #12038
+
+nqueens :: Int -> Int
+nqueens nq = length (pargen 0 [])
+ where
+ safe :: Int -> Int -> [Int] -> Bool
+ safe x d [] = True
+ safe x d (q:l) = x /= q && x /= q+d && x /= q-d && safe x (d+1) l
+
+ gen :: [[Int]] -> [[Int]]
+ gen bs = [ (q:b) | b <- bs, q <- [1..nq], safe q 1 b ]
+
+ pargen :: Int -> [Int] -> [[Int]]
+ pargen n b
+ | n >= threshold = iterate gen [b] !! (nq - n)
+ | otherwise = concat bs
+ where bs = map (pargen (n+1)) (gen [b]) `using` parList rdeepseq
+
+ threshold = 3
+
+using :: a -> Strategy a -> a
+x `using` strat = runEval (strat x)
+
+type Strategy a = a -> Eval a
+
+newtype Eval a = Eval (State# RealWorld -> (# State# RealWorld, a #))
+
+runEval :: Eval a -> a
+runEval (Eval x) = case x realWorld# of (# _, a #) -> a
+
+instance Functor Eval where
+ fmap = liftM
+
+instance Applicative Eval where
+ pure x = Eval $ \s -> (# s, x #)
+ (<*>) = ap
+
+instance Monad Eval where
+ return = pure
+ Eval x >>= k = Eval $ \s -> case x s of
+ (# s', a #) -> case k a of
+ Eval f -> f s'
+
+parList :: Strategy a -> Strategy [a]
+parList strat = traverse (rparWith strat)
+
+rpar :: Strategy a
+rpar x = Eval $ \s -> spark# x s
+
+rseq :: Strategy a
+rseq x = Eval $ \s -> seq# x s
+
+rparWith :: Strategy a -> Strategy a
+rparWith s a = do l <- rpar r; return (case l of Lift x -> x)
+ where r = case s a of
+ Eval f -> case f realWorld# of
+ (# _, a' #) -> Lift a'
+
+data Lift a = Lift a
+
+rdeepseq :: NFData a => Strategy a
+rdeepseq x = do rseq (rnf x); return x
=====================================
testsuite/tests/concurrent/should_run/T21651.stdout
=====================================
@@ -0,0 +1 @@
+14200
=====================================
testsuite/tests/concurrent/should_run/all.T
=====================================
@@ -218,12 +218,20 @@ test('conc067', ignore_stdout, compile_and_run, [''])
test('conc068', [ omit_ways(concurrent_ways), exit_code(1) ], compile_and_run, [''])
test('setnumcapabilities001',
- [ only_ways(['threaded1','threaded2', 'nonmoving_thr']),
+ [ only_ways(['threaded1','threaded2', 'nonmoving_thr', 'profthreaded']),
extra_run_opts('8 12 2000'),
when(have_thread_sanitizer(), expect_broken(18808)),
req_smp ],
compile_and_run, [''])
+test('T21651',
+ [ only_ways(['threaded1','threaded2', 'nonmoving_thr', 'profthreaded']),
+ when(opsys('mingw32'),skip), # uses POSIX pipes
+ when(opsys('darwin'),extra_run_opts('8 12 2000 100')),
+ unless(opsys('darwin'),extra_run_opts('8 12 2000 200')), # darwin runners complain of too many open files
+ req_smp ],
+ compile_and_run, [''])
+
test('hs_try_putmvar001',
[
when(opsys('mingw32'),skip), # uses pthread APIs in the C code
=====================================
utils/haddock
=====================================
@@ -1 +1 @@
-Subproject commit 7bd04379ada2d9ff1c406d258629f8abdf617b30
+Subproject commit 50bad2e761b57efd77fa8924866f3964f1e59f01
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6156ec32e3ea9b55072d175cd8cf8856f867d268...55c4d9fc0a94e383da6460eab9d766dcf2878227
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6156ec32e3ea9b55072d175cd8cf8856f867d268...55c4d9fc0a94e383da6460eab9d766dcf2878227
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/20220809/76a6b91c/attachment-0001.html>
More information about the ghc-commits
mailing list