[Git][ghc/ghc][wip/jeltsch/text-read-implementation-into-base] 9 commits: configure: bump LlvmMaxVersion to 23
by Wolfgang Jeltsch (＠jeltsch) 25 Apr '26
by Wolfgang Jeltsch (＠jeltsch) 25 Apr '26
25 Apr '26
Wolfgang Jeltsch pushed to branch wip/jeltsch/text-read-implementation-into-base at Glasgow Haskell Compiler / GHC
Commits:
cc9cc6d5 by Cheng Shao at 2026-04-23T09:40:46+00:00
configure: bump LlvmMaxVersion to 23
This patch bumps `LlvmMaxVersion` to 23 to support LLVM 22.x releases.
- - - - -
2ea7ef8e by Cheng Shao at 2026-04-23T09:46:26+00:00
changelog: add llvm 22.x support
- - - - -
5574ee10 by Cheng Shao at 2026-04-24T08:24:30-04:00
compiler: avoid unused temporary `appendFS` operands
This patch fixes unused temporary `appendFS` operands in the codebase
that are retained in the `FastString` table after concatenation.
Rewrite rules are added so that if an operand is
`fsLit`/`mkFastString`, the `appendFS` application is rewritten to
append the `ShortByteString` operands first. The patch also fixes
`sconcat` behavior to align with `mconcat` for the same reason. Fixes #27205.
- - - - -
4ed78760 by mangoiv at 2026-04-24T08:25:13-04:00
contributing: adjust MR template to be less verbose
- MR template only shows text that is relevant for submissiong
- MR template was rewritten so it's readable from a user's and reviewer's
perspective
Resolves #27165
Co-Authored-By: @sheaf
- - - - -
87db83e2 by Cheng Shao at 2026-04-24T14:37:21-04:00
ci: bump freebsd boot ghc to 9.10.3
This commit bumps freebsd boot ghc to 9.10.3 to align with other
platforms and prevent outdated boot libs in boot ghc to block the
freebsd job.
- - - - -
17e3a0b7 by Cheng Shao at 2026-04-24T14:37:21-04:00
compiler: improve Binary instance of Array
This patch improves the `Binary` instance of `Array`:
- We no longer allocate intermediate lists. When serializing an
`Array`, we iterate over the elements directly; when deserializing
it, we allocate the result `Array` and fill it in a loop.
- Now we only serialize the array bounds tuple; the length field is
not needed.
Closes #27109.
- - - - -
2d30f7d3 by sheaf at 2026-04-24T14:38:23-04:00
Vendor mini-QuickCheck for testsuite
This commit extracts the vendored QuickCheck implementation from the
foundation testsuite to make it more broadly available in the GHC
testsuite, and makes use of it in the simd006 test (which also used
a vendored QuickCheck implementation).
On the way, we update the linear congruential generator to avoid the
shortcoming of only generating 31 bit large numbers.
Fixes #25990 and #25969.
- - - - -
a3786627 by Wolfgang Jeltsch at 2026-04-25T15:22:55+03:00
Move code that uses `GHC.Internal.Text.Read` into `base`
This contribution serves to remove all dependencies on
`GHC.Internal.Text.Read` from within `ghc-internal`, so that the
implementation of `Text.Read` and ultimately more reading-related code
can be moved to `base` as well.
The following things are moved from `ghc-internal` to `base`:
* I/O-related `Read` instances
* Most of the `Numeric` implementation
* The instance `Read ByteOrder`
* The `parseVersion` operation
* The `readConstr` operation
Metric Increase:
LinkableUsage01
T12425
T13035
- - - - -
ae2be0b0 by Wolfgang Jeltsch at 2026-04-25T15:23:26+03:00
Move the `Text.Read` implementation into `base`
- - - - -
41 changed files:
- .gitlab/generate-ci/gen_ci.hs
- .gitlab/jobs.yaml
- .gitlab/merge_request_templates/Default.md
- + changelog.d/binary-array-no-list
- + changelog.d/llvm-22
- compiler/GHC/Data/FastString.hs
- compiler/GHC/Utils/Binary.hs
- configure.ac
- libraries/base/src/Data/Data.hs
- libraries/base/src/Data/Functor/Classes.hs
- libraries/base/src/Data/Functor/Compose.hs
- libraries/base/src/Data/Version.hs
- libraries/base/src/GHC/ByteOrder.hs
- libraries/base/src/Numeric.hs
- libraries/base/src/Prelude.hs
- libraries/base/src/System/IO.hs
- libraries/base/src/Text/Printf.hs
- libraries/base/src/Text/Read.hs
- libraries/ghc-internal/ghc-internal.cabal.in
- libraries/ghc-internal/src/GHC/Internal/Data/Data.hs
- libraries/ghc-internal/src/GHC/Internal/Data/Version.hs
- libraries/ghc-internal/src/GHC/Internal/IO/Device.hs
- libraries/ghc-internal/src/GHC/Internal/IO/Handle/Types.hs
- libraries/ghc-internal/src/GHC/Internal/IO/IOMode.hs
- libraries/ghc-internal/src/GHC/Internal/Numeric.hs
- libraries/ghc-internal/src/GHC/Internal/Read.hs
- − libraries/ghc-internal/src/GHC/Internal/Text/Read.hs
- testsuite/driver/testlib.py
- + testsuite/tests/MiniQuickCheck.hs
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
- testsuite/tests/numeric/should_run/all.T
- testsuite/tests/numeric/should_run/foundation.hs
- testsuite/tests/plugins/plugins09.stdout
- testsuite/tests/plugins/plugins10.stdout
- testsuite/tests/plugins/plugins11.stdout
- testsuite/tests/plugins/static-plugins.stdout
- testsuite/tests/simd/should_run/all.T
- testsuite/tests/simd/should_run/simd006.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4f78be3f31090461c4933e2d0ee706…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4f78be3f31090461c4933e2d0ee706…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/jeltsch/text-read-uncovering] 8 commits: configure: bump LlvmMaxVersion to 23
by Wolfgang Jeltsch (＠jeltsch) 25 Apr '26
by Wolfgang Jeltsch (＠jeltsch) 25 Apr '26
25 Apr '26
Wolfgang Jeltsch pushed to branch wip/jeltsch/text-read-uncovering at Glasgow Haskell Compiler / GHC
Commits:
cc9cc6d5 by Cheng Shao at 2026-04-23T09:40:46+00:00
configure: bump LlvmMaxVersion to 23
This patch bumps `LlvmMaxVersion` to 23 to support LLVM 22.x releases.
- - - - -
2ea7ef8e by Cheng Shao at 2026-04-23T09:46:26+00:00
changelog: add llvm 22.x support
- - - - -
5574ee10 by Cheng Shao at 2026-04-24T08:24:30-04:00
compiler: avoid unused temporary `appendFS` operands
This patch fixes unused temporary `appendFS` operands in the codebase
that are retained in the `FastString` table after concatenation.
Rewrite rules are added so that if an operand is
`fsLit`/`mkFastString`, the `appendFS` application is rewritten to
append the `ShortByteString` operands first. The patch also fixes
`sconcat` behavior to align with `mconcat` for the same reason. Fixes #27205.
- - - - -
4ed78760 by mangoiv at 2026-04-24T08:25:13-04:00
contributing: adjust MR template to be less verbose
- MR template only shows text that is relevant for submissiong
- MR template was rewritten so it's readable from a user's and reviewer's
perspective
Resolves #27165
Co-Authored-By: @sheaf
- - - - -
87db83e2 by Cheng Shao at 2026-04-24T14:37:21-04:00
ci: bump freebsd boot ghc to 9.10.3
This commit bumps freebsd boot ghc to 9.10.3 to align with other
platforms and prevent outdated boot libs in boot ghc to block the
freebsd job.
- - - - -
17e3a0b7 by Cheng Shao at 2026-04-24T14:37:21-04:00
compiler: improve Binary instance of Array
This patch improves the `Binary` instance of `Array`:
- We no longer allocate intermediate lists. When serializing an
`Array`, we iterate over the elements directly; when deserializing
it, we allocate the result `Array` and fill it in a loop.
- Now we only serialize the array bounds tuple; the length field is
not needed.
Closes #27109.
- - - - -
2d30f7d3 by sheaf at 2026-04-24T14:38:23-04:00
Vendor mini-QuickCheck for testsuite
This commit extracts the vendored QuickCheck implementation from the
foundation testsuite to make it more broadly available in the GHC
testsuite, and makes use of it in the simd006 test (which also used
a vendored QuickCheck implementation).
On the way, we update the linear congruential generator to avoid the
shortcoming of only generating 31 bit large numbers.
Fixes #25990 and #25969.
- - - - -
a3786627 by Wolfgang Jeltsch at 2026-04-25T15:22:55+03:00
Move code that uses `GHC.Internal.Text.Read` into `base`
This contribution serves to remove all dependencies on
`GHC.Internal.Text.Read` from within `ghc-internal`, so that the
implementation of `Text.Read` and ultimately more reading-related code
can be moved to `base` as well.
The following things are moved from `ghc-internal` to `base`:
* I/O-related `Read` instances
* Most of the `Numeric` implementation
* The instance `Read ByteOrder`
* The `parseVersion` operation
* The `readConstr` operation
Metric Increase:
LinkableUsage01
T12425
T13035
- - - - -
35 changed files:
- .gitlab/generate-ci/gen_ci.hs
- .gitlab/jobs.yaml
- .gitlab/merge_request_templates/Default.md
- + changelog.d/binary-array-no-list
- + changelog.d/llvm-22
- compiler/GHC/Data/FastString.hs
- compiler/GHC/Utils/Binary.hs
- configure.ac
- libraries/base/src/Data/Data.hs
- libraries/base/src/Data/Version.hs
- libraries/base/src/GHC/ByteOrder.hs
- libraries/base/src/Numeric.hs
- libraries/base/src/System/IO.hs
- libraries/base/src/Text/Printf.hs
- libraries/ghc-internal/src/GHC/Internal/Data/Data.hs
- libraries/ghc-internal/src/GHC/Internal/Data/Version.hs
- libraries/ghc-internal/src/GHC/Internal/IO/Device.hs
- libraries/ghc-internal/src/GHC/Internal/IO/Handle/Types.hs
- libraries/ghc-internal/src/GHC/Internal/IO/IOMode.hs
- libraries/ghc-internal/src/GHC/Internal/Numeric.hs
- libraries/ghc-internal/src/GHC/Internal/Read.hs
- testsuite/driver/testlib.py
- + testsuite/tests/MiniQuickCheck.hs
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
- testsuite/tests/numeric/should_run/all.T
- testsuite/tests/numeric/should_run/foundation.hs
- testsuite/tests/plugins/plugins09.stdout
- testsuite/tests/plugins/plugins10.stdout
- testsuite/tests/plugins/plugins11.stdout
- testsuite/tests/plugins/static-plugins.stdout
- testsuite/tests/simd/should_run/all.T
- testsuite/tests/simd/should_run/simd006.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/63fb22911a86569c2c97e742e9b671…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/63fb22911a86569c2c97e742e9b671…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/supersven/interpreter-flags] 17 commits: NCG: Implement constant folding for vector simd ops (Issue #25030)
by Sven Tennie (＠supersven) 25 Apr '26
by Sven Tennie (＠supersven) 25 Apr '26
25 Apr '26
Sven Tennie pushed to branch wip/supersven/interpreter-flags at Glasgow Haskell Compiler / GHC
Commits:
72d6dc74 by aparker at 2026-04-20T20:15:44-04:00
NCG: Implement constant folding for vector simd ops (Issue #25030)
- - - - -
b9cab907 by sheaf at 2026-04-20T20:15:44-04:00
Mark some SIMD tests as broken on i386 optllvm
As seen in #25498, several SIMD tests are broken on i386 in the optllvm
way. This commit marks them as "expect_broken".
- - - - -
76528cc3 by Wolfgang Jeltsch at 2026-04-20T20:16:25-04:00
Move most of the `System.IO` implementation into `base`
This involves a rewrite of the `combine` helper function to avoid the
use of `last`, which would now be flagged as an error.
Metric Decrease:
LinkableUsage01
T3294
Metric Increase:
T12227
T12707
T5642
- - - - -
04d143c0 by Luite Stegeman at 2026-04-21T14:05:33-04:00
rts: add a few missing i386 relocations in the rts linker
- - - - -
014087e7 by Luite Stegeman at 2026-04-21T14:05:34-04:00
CodeOutput: Fix finalizers on multiple platforms
- ELF platforms: emit .fini_array section
- wasm32/Darwin: emit initializer with __cxa_atexit call
- Windows: use -Wl,--whole-archive to prevent dropping finalizer symbols
- rts linker: fix crash/assertion failure unloading objects with finalizers
fixes #27072
- - - - -
915bba6f by Simon Jakobi at 2026-04-21T14:06:16-04:00
Add regression test for #10531
Closes #10531.
- - - - -
86a646a6 by Andreas Klebinger at 2026-04-22T13:00:05-04:00
Revert use of generic instances for compiler time perf reasons.
Revert "Derive Semigroup/Monoid for instances believed could be derived in #25871"
This reverts commit 11a04cbb221cc404fe00d65d7c951558ede4caa9.
Revert "add Ghc.Data.Pair deriving"
This reverts commit 15d9ce449e1be8c01b89fd39bdf1e700ea7d1dce.
- - - - -
bc9ee1cf by Wen Kokke at 2026-04-22T13:00:51-04:00
hadrian: Fix docs to remove static flavour
In 638f6548, the static flavour was turned into into the fully_static
flavour transformer. However, this commit did not update flavours.md.
- - - - -
cc9cc6d5 by Cheng Shao at 2026-04-23T09:40:46+00:00
configure: bump LlvmMaxVersion to 23
This patch bumps `LlvmMaxVersion` to 23 to support LLVM 22.x releases.
- - - - -
2ea7ef8e by Cheng Shao at 2026-04-23T09:46:26+00:00
changelog: add llvm 22.x support
- - - - -
5574ee10 by Cheng Shao at 2026-04-24T08:24:30-04:00
compiler: avoid unused temporary `appendFS` operands
This patch fixes unused temporary `appendFS` operands in the codebase
that are retained in the `FastString` table after concatenation.
Rewrite rules are added so that if an operand is
`fsLit`/`mkFastString`, the `appendFS` application is rewritten to
append the `ShortByteString` operands first. The patch also fixes
`sconcat` behavior to align with `mconcat` for the same reason. Fixes #27205.
- - - - -
4ed78760 by mangoiv at 2026-04-24T08:25:13-04:00
contributing: adjust MR template to be less verbose
- MR template only shows text that is relevant for submissiong
- MR template was rewritten so it's readable from a user's and reviewer's
perspective
Resolves #27165
Co-Authored-By: @sheaf
- - - - -
87db83e2 by Cheng Shao at 2026-04-24T14:37:21-04:00
ci: bump freebsd boot ghc to 9.10.3
This commit bumps freebsd boot ghc to 9.10.3 to align with other
platforms and prevent outdated boot libs in boot ghc to block the
freebsd job.
- - - - -
17e3a0b7 by Cheng Shao at 2026-04-24T14:37:21-04:00
compiler: improve Binary instance of Array
This patch improves the `Binary` instance of `Array`:
- We no longer allocate intermediate lists. When serializing an
`Array`, we iterate over the elements directly; when deserializing
it, we allocate the result `Array` and fill it in a loop.
- Now we only serialize the array bounds tuple; the length field is
not needed.
Closes #27109.
- - - - -
2d30f7d3 by sheaf at 2026-04-24T14:38:23-04:00
Vendor mini-QuickCheck for testsuite
This commit extracts the vendored QuickCheck implementation from the
foundation testsuite to make it more broadly available in the GHC
testsuite, and makes use of it in the simd006 test (which also used
a vendored QuickCheck implementation).
On the way, we update the linear congruential generator to avoid the
shortcoming of only generating 31 bit large numbers.
Fixes #25990 and #25969.
- - - - -
d9e74378 by Sven Tennie at 2026-04-25T14:15:15+02:00
ghc: Distinguish between having an interpreter and having an internal one
Actually, these are related but different things:
- ghc can run an interpreter (either internal or external)
- ghc is compiled with an internal interpreter
Splitting the logic solves compiler warnings and expresses the intent
better.
- - - - -
62458eda by Sven Tennie at 2026-04-25T14:15:15+02:00
WIP
- - - - -
90 changed files:
- .gitlab/generate-ci/gen_ci.hs
- .gitlab/jobs.yaml
- .gitlab/merge_request_templates/Default.md
- + changelog.d/T19174.md
- + changelog.d/binary-array-no-list
- + changelog.d/fix-finalizers-27072
- + changelog.d/llvm-22
- + changelog.d/simd_constant_folding
- compiler/GHC/Cmm/Opt.hs
- compiler/GHC/CmmToAsm/X86/CodeGen.hs
- compiler/GHC/CmmToLlvm/CodeGen.hs
- compiler/GHC/Data/FastString.hs
- compiler/GHC/Data/Pair.hs
- compiler/GHC/Driver/CodeOutput.hs
- compiler/GHC/Hs/Type.hs
- compiler/GHC/HsToCore/Pmc.hs
- compiler/GHC/HsToCore/Pmc/Solver/Types.hs
- compiler/GHC/Linker/Executable.hs
- compiler/GHC/Parser/PostProcess/Haddock.hs
- compiler/GHC/Tc/Utils/TcMType.hs
- compiler/GHC/Types/ForeignStubs.hs
- compiler/GHC/Types/Unique/DSet.hs
- compiler/GHC/Utils/Binary.hs
- compiler/GHC/Utils/Misc.hs
- compiler/GHC/Utils/Ppr/Colour.hs
- configure.ac
- ghc/GHC/Driver/Session/Mode.hs
- ghc/GHCi/UI.hs
- ghc/Main.hs
- ghc/ghc-bin.cabal.in
- hadrian/doc/flavours.md
- hadrian/src/Settings/Packages.hs
- libraries/base/src/Control/Concurrent.hs
- libraries/base/src/GHC/IO/Handle.hs
- libraries/base/src/Prelude.hs
- libraries/base/src/System/IO.hs
- libraries/base/src/Text/Printf.hs
- libraries/ghc-internal/src/GHC/Internal/System/IO.hs
- rts/Linker.c
- rts/LinkerInternals.h
- rts/linker/Elf.c
- testsuite/driver/testlib.py
- + testsuite/tests/MiniQuickCheck.hs
- + testsuite/tests/codeGen/should_run/T27072d.hs
- + testsuite/tests/codeGen/should_run/T27072d.stdout
- + testsuite/tests/codeGen/should_run/T27072d_c.c
- + testsuite/tests/codeGen/should_run/T27072d_check.c
- + testsuite/tests/codeGen/should_run/T27072w.hs
- + testsuite/tests/codeGen/should_run/T27072w.stdout
- + testsuite/tests/codeGen/should_run/T27072w_c.c
- testsuite/tests/codeGen/should_run/all.T
- + testsuite/tests/driver/T10531/A.hs
- + testsuite/tests/driver/T10531/B.hs
- + testsuite/tests/driver/T10531/C.hs
- + testsuite/tests/driver/T10531/Makefile
- + testsuite/tests/driver/T10531/all.T
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
- testsuite/tests/numeric/should_run/all.T
- testsuite/tests/numeric/should_run/foundation.hs
- + testsuite/tests/rts/linker/T27072/Lib.c
- + testsuite/tests/rts/linker/T27072/Makefile
- + testsuite/tests/rts/linker/T27072/T27072.stdout
- + testsuite/tests/rts/linker/T27072/all.T
- + testsuite/tests/rts/linker/T27072/main.c
- + testsuite/tests/simd/should_run/Makefile
- + testsuite/tests/simd/should_run/T25030.hs
- + testsuite/tests/simd/should_run/T25030.stdout
- testsuite/tests/simd/should_run/all.T
- testsuite/tests/simd/should_run/simd006.hs
- testsuite/tests/th/all.T
- testsuite/tests/typecheck/should_compile/T9497a.stderr
- testsuite/tests/typecheck/should_compile/holes.stderr
- testsuite/tests/typecheck/should_compile/holes3.stderr
- testsuite/tests/typecheck/should_compile/valid_hole_fits.stderr
- testsuite/tests/typecheck/should_fail/T9497d.stderr
- testsuite/tests/typecheck/should_run/T9497a-run.stderr
- testsuite/tests/typecheck/should_run/T9497b-run.stderr
- testsuite/tests/typecheck/should_run/T9497c-run.stderr
- utils/haddock/html-test/ref/Bug1004.html
- utils/haddock/html-test/ref/Bug973.html
- utils/haddock/html-test/ref/ConstructorPatternExport.html
- utils/haddock/html-test/ref/DefaultSignatures.html
- utils/haddock/html-test/ref/Hash.html
- utils/haddock/html-test/ref/PatternSyns.html
- utils/haddock/html-test/ref/PatternSyns2.html
- utils/haddock/html-test/ref/QuasiExpr.html
- utils/haddock/html-test/ref/Test.html
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a20a80855ed86dadf801974473b45a…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a20a80855ed86dadf801974473b45a…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/supersven/libDir-setting] WIP: Move pkg recaching to end
by Sven Tennie (＠supersven) 25 Apr '26
by Sven Tennie (＠supersven) 25 Apr '26
25 Apr '26
Sven Tennie pushed to branch wip/supersven/libDir-setting at Glasgow Haskell Compiler / GHC
Commits:
2d61f92b by Sven Tennie at 2026-04-25T12:55:32+02:00
WIP: Move pkg recaching to end
- - - - -
1 changed file:
- hadrian/src/Rules/BinaryDist.hs
Changes:
=====================================
hadrian/src/Rules/BinaryDist.hs
=====================================
@@ -232,17 +232,6 @@ bindistRules = do
copyDirectory (rtsIncludeDir) bindistFilesDir
when windowsHost $ createGhcii (bindistFilesDir -/- "bin")
- -- Call ghc-pkg recache, after copying so the package.cache is
- -- accurate, then it's on the distributor to use `cp -a` to install
- -- a relocatable bindist.
- --
- -- N.B. the ghc-pkg executable may be prefixed with a target triple
- -- (c.f. #20267).
- ghcPkgName <- programName (vanillaContext Stage1 ghcPkg)
- cmd_ (bindistFilesDir -/- "bin" -/- ghcPkgName) ["recache"]
-
-
-
-- TODO: we should only embed the docs that have been generated
-- depending on the current settings (flavours' "ghcDocs" field and
-- "--docs=.." command-line flag)
@@ -280,6 +269,15 @@ bindistRules = do
whenM (liftIO (IO.doesDirectoryExist (root -/- "manpage"))) $ do
copyDirectory (root -/- "manpage") bindistFilesDir
+ -- Call ghc-pkg recache at the very end, after all file operations.
+ -- This ensures package.cache has the most recent timestamp, which is
+ -- important on Windows where 'cp -a' preserves timestamps.
+ --
+ -- N.B. the ghc-pkg executable may be prefixed with a target triple
+ -- (c.f. #20267).
+ ghcPkgName <- programName (vanillaContext Stage1 ghcPkg)
+ cmd_ (bindistFilesDir -/- "bin" -/- ghcPkgName) ["recache"]
+
-- We then 'need' all the files necessary to configure and install
-- (as in, './configure [...] && make install') this build on some
-- other machine.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2d61f92b1007b6a6a2d7c9529a40f1d…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2d61f92b1007b6a6a2d7c9529a40f1d…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/fendor/hpc-bc-support] 2 commits: Make HPC work with bytecode interpreter
by Hannes Siebenhandl (＠fendor) 25 Apr '26
by Hannes Siebenhandl (＠fendor) 25 Apr '26
25 Apr '26
Hannes Siebenhandl pushed to branch wip/fendor/hpc-bc-support at Glasgow Haskell Compiler / GHC
Commits:
c701a9f9 by fendor at 2026-04-25T12:32:34+02:00
Make HPC work with bytecode interpreter
Add support to generate .tix files from bytecode objects and the
bytecode interpreter.
Conceptually, we insert HPC ticks into the bytecode similar to how we insert
breakpoints.
HPC and breakpoints do not share the same tick array but we use a separate
tick-array for hpc/breakpoint ticks during bytecode generation.
We teach the bytecode interpreter to handle hpc ticks.
The implementation is quite trivial, simply increment the counter in the
global hpc_ticks array for the respective module.
This hpc_ticks array is generated as part of the `CStub`, so we can rely
on it existing.
A tricky bit is "registering" a bytecode object for HPC instrumentation.
In the compiled case, this is achieved via CStub and initializer/finalizers
`.init` sections which are called when the executable is run.
After the initializers have been invoked, which is before `hs_init_ghc`,
we then call `startup_hpc` in `hs_init_ghc` iff any modules were "registered"
for hpc instrumentation via `hs_hpc_module`.
Since bytecode objects are loaded after starting up GHCi, this workflow
doesn't work for supporting `hpc` and the `hpc` run-time is never
started, even if a module is added for instrumentation.
We fix this issue by employing the same technique as is for `SptEntry`s:
* We introduce a new field to `CompiledByteCode`, called `ByteCodeHpcInfo`
which contains enough information to call `hs_hpc_module`, allowing us to
register the module for `hpc` instrumentation`.
* After registering the module, we unconditionally call `startupHpc`, to make
sure the .tix file is written.
Calling `startupHpc` multiple times is safe.
Calling `hs_hpc_module` multiple times for the same module is also safe.
If we didn't register the hpc module in this way, evaluating a bytecode object
instrumented with `-fhpc` without registering it in the `hpc` run-time will
simply not generate any `.tix` files for this bytecode object.
However, this shouldn't happen if everything is set up correctly.
Closes #27036
- - - - -
6447e5e0 by fendor at 2026-04-25T12:32:34+02:00
WIP: undo -fhpc removal from Session.hs
- - - - -
52 changed files:
- + changelog.d/bytecode-interpreter-hpc-support
- compiler/GHC/ByteCode/Asm.hs
- compiler/GHC/ByteCode/Binary.hs
- compiler/GHC/ByteCode/Instr.hs
- compiler/GHC/ByteCode/Types.hs
- compiler/GHC/Driver/Backend.hs
- compiler/GHC/Driver/CodeOutput.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/HsToCore.hs
- compiler/GHC/HsToCore/Coverage.hs
- compiler/GHC/HsToCore/Ticks.hs
- compiler/GHC/Iface/Tidy.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Runtime/Interpreter.hs
- compiler/GHC/StgToByteCode.hs
- compiler/GHC/Types/HpcInfo.hs
- compiler/GHC/Unit/Module/ModGuts.hs
- + libraries/ghci/GHCi/Coverage.hs
- libraries/ghci/GHCi/Message.hs
- libraries/ghci/GHCi/Run.hs
- libraries/ghci/ghci.cabal.in
- rts/Disassembler.c
- rts/Hpc.c
- rts/Interpreter.c
- rts/include/rts/Bytecodes.h
- testsuite/tests/hpc/Makefile
- testsuite/tests/hpc/T17073.stdout → testsuite/tests/hpc/T17073a.stdout
- + testsuite/tests/hpc/T17073b.stdout
- testsuite/tests/hpc/T20568.stdout → testsuite/tests/hpc/T20568a.stdout
- + testsuite/tests/hpc/T20568b.stdout
- testsuite/tests/hpc/all.T
- testsuite/tests/hpc/fork/Makefile
- testsuite/tests/hpc/function/Makefile
- testsuite/tests/hpc/function/test.T
- + testsuite/tests/hpc/function/tough1.stderr
- + testsuite/tests/hpc/function/tough1.stdout
- testsuite/tests/hpc/function2/test.T
- + testsuite/tests/hpc/function2/tough3.script
- + testsuite/tests/hpc/ghc_ghci/BytecodeMain.hs
- testsuite/tests/hpc/ghc_ghci/Makefile
- + testsuite/tests/hpc/ghc_ghci/hpc_ghc_ghci_bytecode.stdout
- + testsuite/tests/hpc/ghc_ghci/hpc_ghci01.stdout
- + testsuite/tests/hpc/ghc_ghci/hpc_ghci02.stdout
- testsuite/tests/hpc/ghc_ghci/test.T
- testsuite/tests/hpc/simple/Makefile
- + testsuite/tests/hpc/simple/hpc002.hs
- + testsuite/tests/hpc/simple/hpc002.stdout
- + testsuite/tests/hpc/simple/hpc003.hs
- + testsuite/tests/hpc/simple/hpc003.script
- + testsuite/tests/hpc/simple/hpc003.stdout
- testsuite/tests/hpc/simple/test.T
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/cf7f0d4afc7116936deb1618ca4cf1…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/cf7f0d4afc7116936deb1618ca4cf1…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Ensure TcM plugins are only initialised once
by Marge Bot (＠marge-bot) 25 Apr '26
by Marge Bot (＠marge-bot) 25 Apr '26
25 Apr '26
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
6c9b1ab7 by sheaf at 2026-04-25T06:18:44-04:00
Ensure TcM plugins are only initialised once
This commit ensures we keep TcM plugins (typechecker plugins,
defaulting plugins and hole fit plugins) running all the way through
desugaring, instead of stopping them at the end of typechecking.
To do this, the "stop" actions of TcPlugin and DefaultingPlugin are
split into two: one for the "post-typecheck" action, and one for the
final shutdown action (after desugaring).
This allows the plugins to be invoked by the pattern match checker
(during desugaring) without having to be repeatedly re-initialised and
stopped, fixing #26839.
In the process, this commit modifies 'initTc' and 'initTcInteractive',
adding an extra argument that describes whether to start/stop the 'TcM'
plugins.
See Note [Stop TcM plugins after desugaring] for an overview.
- - - - -
2979daad by sheaf at 2026-04-25T06:18:49-04:00
Hadrian: add --keep-response-files
This commit adds a Hadrian flag that allows response files to be
retained. This is useful for debugging a failing Hadrian command line.
- - - - -
d66e74df by sheaf at 2026-04-25T06:18:54-04:00
hadrian/build-cabal.bat: fix build on Windows
Commit 8cb99552f6 introduced a warning for a missing package index.
However, the logic was faulty on Windows: the piping was broken, and
"remote-repo-cache:" was being interpreted as a (malformed) drive letter,
leading to the error:
The filename, directory name, or volume label syntax is incorrect.
This commit fixes that by using a temporary file instead of piping.
- - - - -
6f22b036 by Simon Peyton Jones at 2026-04-25T06:18:55-04:00
Fix assertion check in checkResultTy
As #27210 shows, the assertion was a little bit too eager.
I refactored a bit by moving some code from GHC.Tc.Gen.App
to GHC.Tc.Utils.Unify; see the new function tcSubTypeApp,
which replaces tcSubTypeDS
- - - - -
70 changed files:
- + changelog.d/hadrian-response-files.md
- + changelog.d/tcplugin_init.md
- + changelog.d/tcplugins-pmc.md
- + changelog.d/typecheckModule-API.md
- + changelog.d/withTcPlugins.md
- compiler/GHC.hs
- compiler/GHC/Driver/Env/Types.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Pipeline.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/Driver/Pipeline/Monad.hs
- compiler/GHC/Driver/Pipeline/Phases.hs
- compiler/GHC/HsToCore.hs
- compiler/GHC/HsToCore/Monad.hs
- compiler/GHC/HsToCore/Types.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/Runtime/Heap/Inspect.hs
- compiler/GHC/Runtime/Loader.hs
- compiler/GHC/Tc/Errors/Hole.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/Solver/Default.hs
- compiler/GHC/Tc/Solver/Rewrite.hs
- compiler/GHC/Tc/Solver/Solve.hs
- compiler/GHC/Tc/Types.hs
- compiler/GHC/Tc/Utils/Backpack.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Tc/Utils/Unify.hs
- docs/users_guide/extending_ghc.rst
- ghc/GHCi/UI/Info.hs
- hadrian/build-cabal.bat
- hadrian/src/Builder.hs
- hadrian/src/CommandLine.hs
- hadrian/src/Hadrian/Builder/Ar.hs
- hadrian/src/Hadrian/Utilities.hs
- testsuite/tests/ghc-api/T26910.hs
- testsuite/tests/ghc-api/T6145.hs
- testsuite/tests/ghci/should_run/tc-plugin-ghci/TcPluginGHCi.hs
- testsuite/tests/plugins/defaulting-plugin/DefaultInterference.hs
- testsuite/tests/plugins/defaulting-plugin/DefaultInvalid.hs
- testsuite/tests/plugins/defaulting-plugin/DefaultLifted.hs
- testsuite/tests/plugins/defaulting-plugin/DefaultMultiParam.hs
- testsuite/tests/plugins/echo-plugin/Echo.hs
- testsuite/tests/quasiquotation/T7918.hs
- testsuite/tests/tcplugins/Common.hs
- testsuite/tests/tcplugins/RewritePerfPlugin.hs
- testsuite/tests/tcplugins/T11462_Plugin.hs
- testsuite/tests/tcplugins/T11525_Plugin.hs
- testsuite/tests/tcplugins/T26395_Plugin.hs
- + testsuite/tests/tcplugins/TcPlugin_InitStop_Ghci.hs
- + testsuite/tests/tcplugins/TcPlugin_InitStop_Ghci.script
- + testsuite/tests/tcplugins/TcPlugin_InitStop_Ghci.stderr
- + testsuite/tests/tcplugins/TcPlugin_InitStop_Ghci.stdout
- + testsuite/tests/tcplugins/TcPlugin_InitStop_NoCode.hs
- + testsuite/tests/tcplugins/TcPlugin_InitStop_NoCode.hs-boot
- + testsuite/tests/tcplugins/TcPlugin_InitStop_NoCode.stderr
- + testsuite/tests/tcplugins/TcPlugin_InitStop_NoCode_aux.hs
- + testsuite/tests/tcplugins/TcPlugin_InitStop_Warn.hs
- + testsuite/tests/tcplugins/TcPlugin_InitStop_Warn.stderr
- testsuite/tests/tcplugins/all.T
- + testsuite/tests/tcplugins/tc-plugin-initstop/Makefile
- + testsuite/tests/tcplugins/tc-plugin-initstop/Setup.hs
- + testsuite/tests/tcplugins/tc-plugin-initstop/TcPlugin_InitStop_Plugin.hs
- + testsuite/tests/tcplugins/tc-plugin-initstop/tc-plugin-initstop.cabal
- + testsuite/tests/typecheck/should_fail/T27210.hs
- + testsuite/tests/typecheck/should_fail/T27210.stderr
- testsuite/tests/typecheck/should_fail/all.T
- testsuite/tests/wasm/should_run/control-flow/LoadCmmGroup.hs
- utils/haddock/haddock-api/src/Haddock/Interface/AttachInstances.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a5dd655506906a5dfba6c5c2dea675…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a5dd655506906a5dfba6c5c2dea675…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Ensure TcM plugins are only initialised once
by Marge Bot (＠marge-bot) 25 Apr '26
by Marge Bot (＠marge-bot) 25 Apr '26
25 Apr '26
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
330e29f2 by sheaf at 2026-04-25T01:57:08-04:00
Ensure TcM plugins are only initialised once
This commit ensures we keep TcM plugins (typechecker plugins,
defaulting plugins and hole fit plugins) running all the way through
desugaring, instead of stopping them at the end of typechecking.
To do this, the "stop" actions of TcPlugin and DefaultingPlugin are
split into two: one for the "post-typecheck" action, and one for the
final shutdown action (after desugaring).
This allows the plugins to be invoked by the pattern match checker
(during desugaring) without having to be repeatedly re-initialised and
stopped, fixing #26839.
In the process, this commit modifies 'initTc' and 'initTcInteractive',
adding an extra argument that describes whether to start/stop the 'TcM'
plugins.
See Note [Stop TcM plugins after desugaring] for an overview.
- - - - -
303a2e39 by sheaf at 2026-04-25T01:57:13-04:00
Hadrian: add --keep-response-files
This commit adds a Hadrian flag that allows response files to be
retained. This is useful for debugging a failing Hadrian command line.
- - - - -
bec4565a by sheaf at 2026-04-25T01:57:19-04:00
hadrian/build-cabal.bat: fix build on Windows
Commit 8cb99552f6 introduced a warning for a missing package index.
However, the logic was faulty on Windows: the piping was broken, and
"remote-repo-cache:" was being interpreted as a (malformed) drive letter,
leading to the error:
The filename, directory name, or volume label syntax is incorrect.
This commit fixes that by using a temporary file instead of piping.
- - - - -
a5dd6555 by Simon Peyton Jones at 2026-04-25T01:57:19-04:00
Fix assertion check in checkResultTy
As #27210 shows, the assertion was a little bit too eager.
I refactored a bit by moving some code from GHC.Tc.Gen.App
to GHC.Tc.Utils.Unify; see the new function tcSubTypeApp,
which replaces tcSubTypeDS
- - - - -
70 changed files:
- + changelog.d/hadrian-response-files.md
- + changelog.d/tcplugin_init.md
- + changelog.d/tcplugins-pmc.md
- + changelog.d/typecheckModule-API.md
- + changelog.d/withTcPlugins.md
- compiler/GHC.hs
- compiler/GHC/Driver/Env/Types.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Pipeline.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/Driver/Pipeline/Monad.hs
- compiler/GHC/Driver/Pipeline/Phases.hs
- compiler/GHC/HsToCore.hs
- compiler/GHC/HsToCore/Monad.hs
- compiler/GHC/HsToCore/Types.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/Runtime/Heap/Inspect.hs
- compiler/GHC/Runtime/Loader.hs
- compiler/GHC/Tc/Errors/Hole.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/Solver/Default.hs
- compiler/GHC/Tc/Solver/Rewrite.hs
- compiler/GHC/Tc/Solver/Solve.hs
- compiler/GHC/Tc/Types.hs
- compiler/GHC/Tc/Utils/Backpack.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Tc/Utils/Unify.hs
- docs/users_guide/extending_ghc.rst
- ghc/GHCi/UI/Info.hs
- hadrian/build-cabal.bat
- hadrian/src/Builder.hs
- hadrian/src/CommandLine.hs
- hadrian/src/Hadrian/Builder/Ar.hs
- hadrian/src/Hadrian/Utilities.hs
- testsuite/tests/ghc-api/T26910.hs
- testsuite/tests/ghc-api/T6145.hs
- testsuite/tests/ghci/should_run/tc-plugin-ghci/TcPluginGHCi.hs
- testsuite/tests/plugins/defaulting-plugin/DefaultInterference.hs
- testsuite/tests/plugins/defaulting-plugin/DefaultInvalid.hs
- testsuite/tests/plugins/defaulting-plugin/DefaultLifted.hs
- testsuite/tests/plugins/defaulting-plugin/DefaultMultiParam.hs
- testsuite/tests/plugins/echo-plugin/Echo.hs
- testsuite/tests/quasiquotation/T7918.hs
- testsuite/tests/tcplugins/Common.hs
- testsuite/tests/tcplugins/RewritePerfPlugin.hs
- testsuite/tests/tcplugins/T11462_Plugin.hs
- testsuite/tests/tcplugins/T11525_Plugin.hs
- testsuite/tests/tcplugins/T26395_Plugin.hs
- + testsuite/tests/tcplugins/TcPlugin_InitStop_Ghci.hs
- + testsuite/tests/tcplugins/TcPlugin_InitStop_Ghci.script
- + testsuite/tests/tcplugins/TcPlugin_InitStop_Ghci.stderr
- + testsuite/tests/tcplugins/TcPlugin_InitStop_Ghci.stdout
- + testsuite/tests/tcplugins/TcPlugin_InitStop_NoCode.hs
- + testsuite/tests/tcplugins/TcPlugin_InitStop_NoCode.hs-boot
- + testsuite/tests/tcplugins/TcPlugin_InitStop_NoCode.stderr
- + testsuite/tests/tcplugins/TcPlugin_InitStop_NoCode_aux.hs
- + testsuite/tests/tcplugins/TcPlugin_InitStop_Warn.hs
- + testsuite/tests/tcplugins/TcPlugin_InitStop_Warn.stderr
- testsuite/tests/tcplugins/all.T
- + testsuite/tests/tcplugins/tc-plugin-initstop/Makefile
- + testsuite/tests/tcplugins/tc-plugin-initstop/Setup.hs
- + testsuite/tests/tcplugins/tc-plugin-initstop/TcPlugin_InitStop_Plugin.hs
- + testsuite/tests/tcplugins/tc-plugin-initstop/tc-plugin-initstop.cabal
- + testsuite/tests/typecheck/should_fail/T27210.hs
- + testsuite/tests/typecheck/should_fail/T27210.stderr
- testsuite/tests/typecheck/should_fail/all.T
- testsuite/tests/wasm/should_run/control-flow/LoadCmmGroup.hs
- utils/haddock/haddock-api/src/Haddock/Interface/AttachInstances.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3faedf5027d0902bac0e4771d18c2c…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3faedf5027d0902bac0e4771d18c2c…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/T27210] Fix assertion check in checkResultTy
by Simon Peyton Jones (＠simonpj) 24 Apr '26
by Simon Peyton Jones (＠simonpj) 24 Apr '26
24 Apr '26
Simon Peyton Jones pushed to branch wip/T27210 at Glasgow Haskell Compiler / GHC
Commits:
9dfe39c2 by Simon Peyton Jones at 2026-04-24T22:56:54+01:00
Fix assertion check in checkResultTy
As #27210 shows, the assertion was a little bit too eager.
I refactored a bit by moving some code from GHC.Tc.Gen.App
to GHC.Tc.Utils.Unify; see the new function tcSubTypeApp,
which replaces tcSubTypeDS
- - - - -
6 changed files:
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Utils/Unify.hs
- + testsuite/tests/typecheck/should_fail/T27210.hs
- + testsuite/tests/typecheck/should_fail/T27210.stderr
- testsuite/tests/typecheck/should_fail/all.T
Changes:
=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -458,45 +458,9 @@ checkResultTy :: HsExpr GhcRn
-- expose foralls, but maybe not /deeply/ instantiated
-> ExpRhoType -- Expected type; this is deeply skolemised
-> TcM HsWrapper
-checkResultTy rn_expr (tc_fun,_) _ app_res_rho (Infer inf_res)
- = do { ds_flag <- getDeepSubsumptionFlag_DataConHead tc_fun
- -- Why the "DataConHead" bit? See (IIR5) in
- -- Note [Instantiation of InferResult] in GHC.Tc.Utils.Unify.
- ; fillInferResult ds_flag (exprCtOrigin rn_expr) app_res_rho inf_res }
-
-checkResultTy rn_expr (tc_fun, fun_loc) inst_args app_res_rho (Check res_ty)
--- Unify with expected type from the context
--- See Note [Unify with expected type before typechecking arguments]
---
--- Match up app_res_rho: the result type of rn_expr
--- with res_ty: the expected result type
+checkResultTy rn_expr (tc_fun, fun_loc) inst_args app_res_rho res_ty
= perhaps_add_res_ty_ctxt $
- do { ds_flag <- getDeepSubsumptionFlag_DataConHead tc_fun
- ; traceTc "checkResultTy {" $
- vcat [ text "tc_fun:" <+> ppr tc_fun
- , text "app_res_rho:" <+> ppr app_res_rho
- , text "res_ty:" <+> ppr res_ty
- , text "ds_flag:" <+> ppr ds_flag ]
- ; case ds_flag of
- Shallow -> -- No deep subsumption
- -- app_res_rho and res_ty are both rho-types,
- -- so with simple subsumption we can just unify them
- -- No need to zonk; the unifier does that
- do { co <- unifyExprType rn_expr app_res_rho res_ty
- ; traceTc "checkResultTy 1 }" (ppr co)
- ; return (mkWpCastN co) }
-
- Deep ds_reason -> -- Deep subsumption
- -- Even though both app_res_rho and res_ty are rho-types,
- -- they may have nested polymorphism, so if deep subsumption
- -- is on we must call tcSubType.
- do { wrap <- tcSubTypeDS tc_fun ds_reason rn_expr app_res_rho res_ty
- ; traceTc "checkResultTy 2 }" $
- vcat [ text "app_res_rho:" <+> ppr app_res_rho
- , text "res_ty:" <+> ppr res_ty
- , text "wrap:" <+> ppr wrap
- ]
- ; return wrap } }
+ tcSubTypeApp rn_expr tc_fun app_res_rho res_ty
where
-- perhaps_add_res_ty_ctxt: Inside an expansion, the addFunResCtxt stuff is
-- more confusing than helpful because the function at the head isn't in
@@ -506,7 +470,7 @@ checkResultTy rn_expr (tc_fun, fun_loc) inst_args app_res_rho (Check res_ty)
| isGeneratedSrcSpan fun_loc
= thing_inside
| otherwise
- = addFunResCtxt tc_fun inst_args app_res_rho (mkCheckExpType res_ty) $
+ = addFunResCtxt tc_fun inst_args app_res_rho res_ty $
thing_inside
----------------
=====================================
compiler/GHC/Tc/Gen/Head.hs
=====================================
@@ -791,10 +791,9 @@ nonBidirectionalErr = TcRnPatSynNotBidirectional
{- Note [Typechecking data constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-As per Note [Polymorphisation of linear fields] in
-GHC.Core.Multiplicity, when we use a data constructor as a term, we want to
-consider its field to have polymorphic multiplicities. That is,
-Note [Data constructors are linear by default] says:
+As per Note [Polymorphisation of linear fields] in GHC.Core.Multiplicity, when
+we use a data constructor as a term, we want to consider its field to have
+polymorphic multiplicities. Note [Data constructors are linear by default] says:
Just :: a. a %1 -> Maybe a
=====================================
compiler/GHC/Tc/Utils/Unify.hs
=====================================
@@ -11,7 +11,7 @@
module GHC.Tc.Utils.Unify (
-- Full-blown subsumption
tcWrapResult, tcWrapResultO, tcWrapResultMono,
- tcSubType, tcSubTypeSigma, tcSubTypePat, tcSubTypeDS, tcSubTypeHoleFit,
+ tcSubType, tcSubTypeSigma, tcSubTypePat, tcSubTypeApp, tcSubTypeHoleFit,
addSubTypeCtxt,
tcSubTypeAmbiguity, tcSubMult,
checkConstraints, checkTvConstraints,
@@ -1488,24 +1488,62 @@ tcSubTypePat _ _ (Infer inf_res) ty_expected
---------------
--- | A subtype check that performs deep subsumption.
--- See also 'tcSubTypeMono', for when no instantiation is required.
-tcSubTypeDS :: HsExpr GhcTc -- ^ App head (for error messages only)
- -> DeepSubsumptionDepth
- -> HsExpr GhcRn
- -> TcRhoType -- ^ Actual type; a rho-type, not a sigma-type
- -> TcRhoType -- ^ Expected type
- -- DeepSubsumption <=> when checking, this type
- -- is deeply skolemised
- -> TcM HsWrapper
--- Only one call site, in GHC.Tc.Gen.App.checkResultTy
-tcSubTypeDS tc_fun ds_depth rn_expr act_rho exp_rho
- = do { wrap <- tc_sub_type_deep (Just tc_fun, Top) ds_depth
- (unifyExprType rn_expr)
- (exprCtOrigin rn_expr)
- GenSigCtxt act_rho exp_rho
+-- | Connect up the inferred type of an application with the expected type.
+-- This is usually just a unification, but with deep subsumption there is more to do.
+tcSubTypeApp :: HsExpr GhcRn
+ -> HsExpr GhcTc -- Head
+ -> TcRhoType -- Inferred type of the application; zonked to
+ -- expose foralls, but maybe not /deeply/ instantiated
+ -> ExpRhoType -- Expected type; this is deeply skolemised
+ -> TcM HsWrapper
+tcSubTypeApp rn_expr tc_fun app_res_rho (Infer inf_res)
+ = do { ds_flag <- getDeepSubsumptionFlag_DataConHead tc_fun
+ -- Why the "DataConHead" bit? See (IIR5) in
+ -- Note [Instantiation of InferResult] in GHC.Tc.Utils.Unify.
+ ; fillInferResult ds_flag (exprCtOrigin rn_expr) app_res_rho inf_res }
+
+tcSubTypeApp rn_expr tc_fun app_res_rho (Check exp_rho)
+ = do { ds_flag <- getDeepSubsumptionFlag_DataConHead tc_fun
+ ; traceTc "tcSubTypeApp {" $
+ vcat [ text "tc_fun:" <+> ppr tc_fun
+ , text "app_res_rho:" <+> ppr app_res_rho
+ , text "exp_rho:" <+> ppr exp_rho
+ , text "ds_flag:" <+> ppr ds_flag ]
+ ; wrap <- case ds_flag of
+ Shallow -- No deep subsumption
+ -- app_res_rho and res_ty are both rho-types,
+ -- so with simple subsumption we can just unify them
+ -- No need to zonk; the unifier does that
+ -> do { co <- unifyExprType rn_expr app_res_rho exp_rho
+ ; return (mkWpCastN co) }
+
+ Deep ds_depth -- Deep subsumption is ON
+ -- Even though both app_res_rho and res_ty are rho-types,
+ -- they may have nested polymorphism, so if deep subsumption
+ -- is on we must call tcSubType.
+ -> tc_sub_type_deep (Just tc_fun, Top) ds_depth
+ (unifyExprType rn_expr)
+ (exprCtOrigin rn_expr)
+ GenSigCtxt app_res_rho exp_rho
+
+ ; traceTc "tcSubTypeApp }" $
+ vcat [ text "tc_fun:" <+> ppr tc_fun
+ , text "wrap:" <+> ppr wrap ]
+
; return (mkWpSubType wrap) }
+-- | Variant of 'getDeepSubsumptionFlag' which enables a top-level subsumption
+-- in order to implement the plan of Note [Typechecking data constructors].
+getDeepSubsumptionFlag_DataConHead :: HsExpr GhcTc -> TcM DeepSubsumptionFlag
+getDeepSubsumptionFlag_DataConHead app_head
+ = do { user_ds <- xoptM LangExt.DeepSubsumption
+ ; return $ if | user_ds
+ -> Deep DeepSub
+ | XExpr (ConLikeTc (RealDataCon {})) <- app_head
+ -> Deep TopSub
+ | otherwise
+ -> Shallow }
+
---------------
-- | Checks that the 'actual' type is more polymorphic than the 'expected' type.
@@ -2104,18 +2142,6 @@ getDeepSubsumptionFlag =
else return Shallow
}
--- | Variant of 'getDeepSubsumptionFlag' which enables a top-level subsumption
--- in order to implement the plan of Note [Typechecking data constructors].
-getDeepSubsumptionFlag_DataConHead :: HsExpr GhcTc -> TcM DeepSubsumptionFlag
-getDeepSubsumptionFlag_DataConHead app_head
- = do { user_ds <- xoptM LangExt.DeepSubsumption
- ; return $ if | user_ds
- -> Deep DeepSub
- | XExpr (ConLikeTc (RealDataCon {})) <- app_head
- -> Deep TopSub
- | otherwise
- -> Shallow }
-
-- | 'tc_sub_type_deep' is where the actual work happens for deep subsumption.
--
@@ -2132,11 +2158,7 @@ tc_sub_type_deep :: HasDebugCallStack
-> TcRhoType -- ^ Expected; deeply skolemised
-> TcM HsWrapper
tc_sub_type_deep fun_pos@(tc_fun, pos) ds_depth unify inst_orig ctxt ty_actual ty_expected
- = assertPpr (isDeeplySkolemised ty_expected)
- (vcat [ text "tc_sub_type_deep: expected type is not a deep rho type"
- , text "ty_expected:" <+> ppr ty_expected
- , text "ty_actual:" <+> ppr ty_actual
- ]) $
+ = assert_precondition $
do { traceTc "tc_sub_type_deep" $
vcat [ text "ty_actual =" <+> ppr ty_actual
, text "ty_expected =" <+> ppr ty_expected ]
@@ -2250,6 +2272,27 @@ tc_sub_type_deep fun_pos@(tc_fun, pos) ds_depth unify inst_orig ctxt ty_actual t
where
given_orig = GivenOrigin (SigSkol GenSigCtxt exp_arg [])
+ -- Assertion check.
+ -- If DeepSubsumption is on (ds_depth = Deep DeepSub) then `exp_rho`
+ -- should already be deeply skolemised; the assertion checks this
+ -- But if DeepSubsumption is NOT on, but there is a data constructor at the
+ -- head, we must still call `tc_sub_type_deep` (for the multiplicity arrows)
+ -- Hence ds_flag = Deep TopSub, but `exp_rho` will only be /top-level/ skolemised
+ -- So we can only check for top-level skolemisation (`isRhoTy`)
+ -- Example of the latter (see #27210), with -XNoDeepSubsumption
+ -- foo :: forall a. a -> forall b. b -> (a,b)
+ -- foo = (,)
+ -- We will only shallowly-skolemise the expected type
+ assert_precondition = assertPpr ty_expected_is_ok $
+ vcat [ text "tc_sub_type_deep: expected type is not a deep rho type"
+ , text "ty_expected:" <+> ppr ty_expected
+ , text "ty_actual:" <+> ppr ty_actual ]
+ ty_expected_is_ok
+ = case ds_depth of
+ TopSub -> True
+ DeepSub -> isDeeplySkolemised ty_expected
+
+
-- | Whether to do deep subsumption when recurring inside arguments.
recurInArgumentDSFlag :: DeepSubsumptionDepth -> DeepSubsumptionFlag
recurInArgumentDSFlag = \case
@@ -5145,5 +5188,3 @@ lookupCycleBreakerVar cbv (IS { inert_cycle_breakers = cbvs_stack })
= tyfam_app
| otherwise
= pprPanic "lookupCycleBreakerVar found an unbound cycle breaker" (ppr cbv $$ ppr cbvs_stack)
-
---------------------------------------------------------------------------------
=====================================
testsuite/tests/typecheck/should_fail/T27210.hs
=====================================
@@ -0,0 +1,11 @@
+{-# LANGUAGE RankNTypes, ExistentialQuantification #-}
+
+-- NB: No deep subsumption
+
+module T27210 where
+
+data Parser a
+ = forall x. BindP (Parser x) (x -> Parser a)
+
+oneM :: Parser a -> ( forall x. (a -> Parser x) -> Parser x )
+oneM = BindP
=====================================
testsuite/tests/typecheck/should_fail/T27210.stderr
=====================================
@@ -0,0 +1,9 @@
+T27210.hs:11:8: error: [GHC-83865]
+ • Couldn't match expected type: forall x.
+ (a -> Parser x) -> Parser x
+ with actual type: (a -> Parser a0) -> Parser a0
+ • In the expression: BindP
+ In an equation for ‘oneM’: oneM = BindP
+ • Relevant bindings include
+ oneM :: Parser a -> forall x. (a -> Parser x) -> Parser x
+ (bound at T27210.hs:11:1)
=====================================
testsuite/tests/typecheck/should_fail/all.T
=====================================
@@ -758,3 +758,4 @@ test('T23162d', normal, compile, [''])
test('T26823', normal, compile_fail, [''])
test('T26861', normal, compile_fail, [''])
test('T26862', normal, compile_fail, [''])
+test('T27210', normal, compile_fail, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9dfe39c244870557732dd0330bf2c22…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9dfe39c244870557732dd0330bf2c22…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: ci: bump freebsd boot ghc to 9.10.3
by Marge Bot (＠marge-bot) 24 Apr '26
by Marge Bot (＠marge-bot) 24 Apr '26
24 Apr '26
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
87db83e2 by Cheng Shao at 2026-04-24T14:37:21-04:00
ci: bump freebsd boot ghc to 9.10.3
This commit bumps freebsd boot ghc to 9.10.3 to align with other
platforms and prevent outdated boot libs in boot ghc to block the
freebsd job.
- - - - -
17e3a0b7 by Cheng Shao at 2026-04-24T14:37:21-04:00
compiler: improve Binary instance of Array
This patch improves the `Binary` instance of `Array`:
- We no longer allocate intermediate lists. When serializing an
`Array`, we iterate over the elements directly; when deserializing
it, we allocate the result `Array` and fill it in a loop.
- Now we only serialize the array bounds tuple; the length field is
not needed.
Closes #27109.
- - - - -
2d30f7d3 by sheaf at 2026-04-24T14:38:23-04:00
Vendor mini-QuickCheck for testsuite
This commit extracts the vendored QuickCheck implementation from the
foundation testsuite to make it more broadly available in the GHC
testsuite, and makes use of it in the simd006 test (which also used
a vendored QuickCheck implementation).
On the way, we update the linear congruential generator to avoid the
shortcoming of only generating 31 bit large numbers.
Fixes #25990 and #25969.
- - - - -
a83c69ee by sheaf at 2026-04-24T15:11:17-04:00
Hadrian: add --keep-response-files
This commit adds a Hadrian flag that allows response files to be
retained. This is useful for debugging a failing Hadrian command line.
- - - - -
3faedf50 by sheaf at 2026-04-24T15:11:22-04:00
hadrian/build-cabal.bat: fix build on Windows
Commit 8cb99552f6 introduced a warning for a missing package index.
However, the logic was faulty on Windows: the piping was broken, and
"remote-repo-cache:" was being interpreted as a (malformed) drive letter,
leading to the error:
The filename, directory name, or volume label syntax is incorrect.
This commit fixes that by using a temporary file instead of piping.
- - - - -
16 changed files:
- .gitlab/generate-ci/gen_ci.hs
- .gitlab/jobs.yaml
- + changelog.d/binary-array-no-list
- + changelog.d/hadrian-response-files.md
- compiler/GHC/Utils/Binary.hs
- hadrian/build-cabal.bat
- hadrian/src/Builder.hs
- hadrian/src/CommandLine.hs
- hadrian/src/Hadrian/Builder/Ar.hs
- hadrian/src/Hadrian/Utilities.hs
- testsuite/driver/testlib.py
- + testsuite/tests/MiniQuickCheck.hs
- testsuite/tests/numeric/should_run/all.T
- testsuite/tests/numeric/should_run/foundation.hs
- testsuite/tests/simd/should_run/all.T
- testsuite/tests/simd/should_run/simd006.hs
Changes:
=====================================
.gitlab/generate-ci/gen_ci.hs
=====================================
@@ -445,7 +445,7 @@ opsysVariables _ FreeBSD14 = mconcat
-- Prefer to use the system's clang-based toolchain and not gcc
, "CC" =: "cc"
, "CXX" =: "c++"
- , "FETCH_GHC_VERSION" =: "9.10.1"
+ , "FETCH_GHC_VERSION" =: "9.10.3"
, "CABAL_INSTALL_VERSION" =: "3.14.2.0"
]
opsysVariables arch (Linux distro) = distroVariables arch distro
=====================================
.gitlab/jobs.yaml
=====================================
@@ -1721,7 +1721,7 @@
"CC": "cc",
"CONFIGURE_ARGS": "--with-iconv-includes=/usr/local/include --with-iconv-libraries=/usr/local/lib --with-system-libffi --with-ffi-includes=/usr/local/include --with-ffi-libraries=/usr/local/lib --with-gmp-includes=/usr/local/include --with-gmp-libraries=/usr/local/lib --enable-strict-ghc-toolchain-check",
"CXX": "c++",
- "FETCH_GHC_VERSION": "9.10.1",
+ "FETCH_GHC_VERSION": "9.10.3",
"INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
"RUNTEST_ARGS": "",
"TEST_ENV": "x86_64-freebsd14-validate",
@@ -4543,7 +4543,7 @@
"CC": "cc",
"CONFIGURE_ARGS": "--with-iconv-includes=/usr/local/include --with-iconv-libraries=/usr/local/lib --with-system-libffi --with-ffi-includes=/usr/local/include --with-ffi-libraries=/usr/local/lib --with-gmp-includes=/usr/local/include --with-gmp-libraries=/usr/local/lib --enable-strict-ghc-toolchain-check",
"CXX": "c++",
- "FETCH_GHC_VERSION": "9.10.1",
+ "FETCH_GHC_VERSION": "9.10.3",
"IGNORE_PERF_FAILURES": "all",
"INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
"RUNTEST_ARGS": "",
@@ -5643,7 +5643,7 @@
"CC": "cc",
"CONFIGURE_ARGS": "--with-iconv-includes=/usr/local/include --with-iconv-libraries=/usr/local/lib --with-system-libffi --with-ffi-includes=/usr/local/include --with-ffi-libraries=/usr/local/lib --with-gmp-includes=/usr/local/include --with-gmp-libraries=/usr/local/lib --enable-strict-ghc-toolchain-check",
"CXX": "c++",
- "FETCH_GHC_VERSION": "9.10.1",
+ "FETCH_GHC_VERSION": "9.10.3",
"INSTALL_CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
"RUNTEST_ARGS": "",
"TEST_ENV": "x86_64-freebsd14-validate"
=====================================
changelog.d/binary-array-no-list
=====================================
@@ -0,0 +1,13 @@
+section: compiler
+synopsis: Reduce allocations when (de)serialising `Array` in the `ghc` library.
+issues: #27109
+mrs: !15805
+
+description: {
+ The `ghc` library's `Binary` instance for `Array` was changed to
+ avoid allocating an intermediate list and to omit a redundant length
+ field during (de)serialisation.
+
+ This should only affect the `ghc` library's (de)serialisation code paths,
+ primarily when parsing HIE files and bytecode objects.
+}
=====================================
changelog.d/hadrian-response-files.md
=====================================
@@ -0,0 +1,9 @@
+section: packaging
+synopsis: Add a flag to tell Hadrian to keep response files
+issues: #27184
+mrs: !15906
+description:
+ Hadrian can now be instructed to keep response files with the new
+ --keep-response-files command line flag. This is helpful when debugging a
+ build failure, as it allows re-running the failing command line invocation
+ without an error due to a missing response file.
=====================================
compiler/GHC/Utils/Binary.hs
=====================================
@@ -142,6 +142,8 @@ import Control.DeepSeq
import Control.Monad ( when, (<$!>), unless, forM_, void )
import Foreign hiding (bit, setBit, clearBit, shiftL, shiftR, void)
import Data.Array
+import Data.Array.Base (unsafeFreezeIOArray)
+import Data.Array.IArray (traverseArray_)
import Data.Array.IO
import Data.Array.Unsafe
import qualified Data.Binary as Binary
@@ -970,11 +972,12 @@ instance Binary a => Binary (NonEmpty a) where
instance (Ix a, Binary a, Binary b) => Binary (Array a b) where
put_ bh arr = do
put_ bh $ bounds arr
- put_ bh $ elems arr
+ traverseArray_ (put_ bh) arr
+
get bh = do
- bounds <- get bh
- xs <- get bh
- return $ listArray bounds xs
+ (l, u) <- get bh
+ marr <- newGenArray (l, u) $ \_ -> get bh
+ unsafeFreezeIOArray marr
instance Binary a => Binary (SmallArray a) where
put_ bh sa = do
=====================================
hadrian/build-cabal.bat
=====================================
@@ -39,7 +39,9 @@ if %CABMAJOR% lss 3 (
exit /B 2
)
-for /F "tokens=*" %%a in ('"%CABAL%" --with-compiler=%GHC% path --output-format=key-value 2^>NUL ^| findstr /B "remote-repo-cache:"') do set REMOTE_REPO_CACHE=%%a
+"%CABAL%" --with-compiler=%GHC% path --output-format=key-value > "%TEMP%\ghc_cabal_path.txt" 2>NUL
+for /F "tokens=*" %%a in ('findstr /B "remote-repo-cache:" "%TEMP%\ghc_cabal_path.txt"') do set REMOTE_REPO_CACHE=%%a
+del "%TEMP%\ghc_cabal_path.txt" 2>NUL
set REMOTE_REPO_CACHE=%REMOTE_REPO_CACHE:remote-repo-cache: =%
if not exist "%REMOTE_REPO_CACHE%\hackage.haskell.org" (
echo Please run 'cabal update' first
=====================================
hadrian/src/Builder.hs
=====================================
@@ -389,15 +389,13 @@ runHaddock :: FilePath -- ^ path to @haddock@
-> [String]
-> [FilePath] -- ^ input file paths
-> Action ()
-runHaddock haddockPath flagArgs fileInputs = withTempFile $ \tmp -> do
+runHaddock haddockPath flagArgs fileInputs = withResponseFile $ \tmp -> do
writeFile' tmp $ escapeArgs fileInputs
cmd [haddockPath] flagArgs ('@' : tmp)
runGhcWithResponse :: FilePath -> [String] -> [FilePath] -> Action ()
-runGhcWithResponse ghcPath flagArgs fileInputs = withTempFile $ \tmp -> do
-
+runGhcWithResponse ghcPath flagArgs fileInputs = withResponseFile $ \tmp -> do
writeFile' tmp $ escapeArgs fileInputs
-
-- We can't put the flags in a response file, because some flags
-- require empty arguments (such as the -dep-suffix flag), but
-- that isn't supported yet due to #26560.
=====================================
hadrian/src/CommandLine.hs
=====================================
@@ -3,7 +3,8 @@ module CommandLine (
lookupBignum,
cmdBignum, cmdBignumCheck, cmdProgressInfo, cmdCompleteSetting,
cmdDocsArgs, cmdUnitIdHash, lookupBuildRoot, TestArgs(..), TestSpeed(..), defaultTestArgs,
- cmdPrefix, cmdChangelogVersion, DocArgs(..), defaultDocArgs
+ cmdPrefix, cmdChangelogVersion, DocArgs(..), defaultDocArgs,
+ cmdKeepResponseFiles
) where
import Data.Either
@@ -11,7 +12,7 @@ import qualified Data.HashMap.Strict as Map
import Data.List.Extra
import Development.Shake hiding (Normal)
import Flavour (DocTargets, DocTarget(..))
-import Hadrian.Utilities hiding (buildRoot)
+import Hadrian.Utilities hiding (buildRoot, keepResponseFiles)
import Settings.Parser
import System.Console.GetOpt
import System.Environment
@@ -37,6 +38,7 @@ data CommandLineArgs = CommandLineArgs
, testArgs :: TestArgs
, docsArgs :: DocArgs
, docTargets :: DocTargets
+ , keepResponseFiles :: Bool
, prefix :: Maybe FilePath
, changelogVersion :: Maybe String
, completeStg :: Maybe String }
@@ -58,6 +60,7 @@ defaultCommandLineArgs = CommandLineArgs
, testArgs = defaultTestArgs
, docsArgs = defaultDocArgs
, docTargets = Set.fromList [minBound..maxBound]
+ , keepResponseFiles = False
, prefix = Nothing
, changelogVersion = Nothing
, completeStg = Nothing }
@@ -143,6 +146,9 @@ readFreeze1 = Right $ \flags -> flags { freeze1 = True }
readFreeze2 = Right $ \flags -> flags { freeze1 = True, freeze2 = True }
readSkipDepends = Right $ \flags -> flags { skipDepends = True }
+readKeepResponseFiles :: Either String (CommandLineArgs -> CommandLineArgs)
+readKeepResponseFiles = Right $ \flags -> flags { keepResponseFiles = True }
+
readUnitIdHash :: Either String (CommandLineArgs -> CommandLineArgs)
readUnitIdHash = Right $ \flags ->
trace "--hash-unit-ids is deprecated. It is enabled by release flavour or +hash_unit_ids flavour transformer" $
@@ -301,6 +307,8 @@ optDescrs =
"Progress info style (None, Brief, Normal or Unicorn)."
, Option [] ["docs"] (ReqArg readDocsArg "TARGET")
"Strip down docs targets (none, no-haddocks, no-sphinx[-{html, pdfs, man}]."
+ , Option ['r'] ["keep-response-files"] (NoArg readKeepResponseFiles)
+ "Keep response files created during the build (for debugging)."
, Option ['k'] ["keep-test-files"] (NoArg readTestKeepFiles)
"Keep all the files generated when running the testsuite."
, Option [] ["test-compiler"] (ReqArg readTestCompiler "TEST_COMPILER")
@@ -377,11 +385,12 @@ cmdLineArgsMap = do
else return []
let allSettings = cliSettings ++ fileSettings
- return $ insertExtra (progressInfo args) -- Accessed by Hadrian.Utilities
- $ insertExtra (buildRoot args) -- Accessed by Hadrian.Utilities
- $ insertExtra (testArgs args) -- Accessed by Settings.Builders.RunTest
- $ insertExtra (docsArgs args) -- Accessed by Rules.Documentation
- $ insertExtra allSettings -- Accessed by Settings
+ return $ insertExtra (progressInfo args) -- Accessed by Hadrian.Utilities
+ $ insertExtra (buildRoot args) -- Accessed by Hadrian.Utilities
+ $ insertExtra (KeepResponseFiles $ keepResponseFiles args) -- Accessed by Hadrian.Utilities
+ $ insertExtra (testArgs args) -- Accessed by Settings.Builders.RunTest
+ $ insertExtra (docsArgs args) -- Accessed by Rules.Documentation
+ $ insertExtra allSettings -- Accessed by Settings
$ insertExtra args Map.empty
cmdLineArgs :: Action CommandLineArgs
@@ -423,6 +432,9 @@ cmdBignum = bignum <$> cmdLineArgs
cmdBignumCheck :: Action Bool
cmdBignumCheck = bignumCheck <$> cmdLineArgs
+cmdKeepResponseFiles :: Action Bool
+cmdKeepResponseFiles = keepResponseFiles <$> cmdLineArgs
+
cmdProgressInfo :: Action ProgressInfo
cmdProgressInfo = progressInfo <$> cmdLineArgs
=====================================
hadrian/src/Hadrian/Builder/Ar.hs
=====================================
@@ -40,7 +40,7 @@ runAr :: FilePath -- ^ path to @ar@
-> [FilePath] -- ^ input file paths
-> [CmdOption] -- ^ Additional options
-> Action ()
-runAr arPath flagArgs fileArgs buildOptions = withTempFile $ \tmp -> do
+runAr arPath flagArgs fileArgs buildOptions = withResponseFile $ \tmp -> do
writeFile' tmp $ unwords fileArgs
cmd [arPath] flagArgs ('@' : tmp) buildOptions
=====================================
hadrian/src/Hadrian/Utilities.hs
=====================================
@@ -14,6 +14,7 @@ module Hadrian.Utilities (
-- * Paths
BuildRoot (..), buildRoot, buildRootRules, isGeneratedSource,
+ KeepResponseFiles (..), keepResponseFiles, withResponseFile,
-- * File system operations
copyFile, copyFileUntracked, createFileLink, fixFile,
@@ -48,6 +49,7 @@ import Development.Shake hiding (Normal)
import Development.Shake.Classes
import Development.Shake.FilePath
import System.Environment (lookupEnv)
+import System.IO (hClose, openTempFile)
import qualified Data.ByteString as BS
import qualified Control.Exception.Base as IO
@@ -317,6 +319,29 @@ buildRootRules = do
isGeneratedSource :: FilePath -> Action Bool
isGeneratedSource file = buildRoot <&> (`isPrefixOf` file)
+newtype KeepResponseFiles = KeepResponseFiles Bool deriving (Eq, Show)
+
+-- | Whether to retain response files after the build action that created them
+-- completes. Mainly useful for debugging.
+keepResponseFiles :: Action Bool
+keepResponseFiles = do
+ KeepResponseFiles keep <- userSetting (KeepResponseFiles False)
+ return keep
+
+-- | Run an action with a response file path.
+--
+-- With @--keep-response-files@, the file is left on disk.
+withResponseFile :: (FilePath -> Action a) -> Action a
+withResponseFile action = do
+ keep <- keepResponseFiles
+ if keep
+ then do
+ (tmp, h) <- liftIO $ openTempFile "." "hadrian-rsp"
+ liftIO $ hClose h
+ putInfo $ "Keeping response file: " ++ tmp
+ action tmp
+ else withTempFile action
+
-- | Link a file tracking the link target. Create the target directory if
-- missing.
createFileLink :: FilePath -> FilePath -> Action ()
=====================================
testsuite/driver/testlib.py
=====================================
@@ -13,6 +13,7 @@ import time
import datetime
import copy
import glob
+import random
import sys
from math import ceil, trunc, floor, log
from pathlib import Path, PurePath
@@ -648,6 +649,11 @@ def extra_files(files):
def _extra_files(name, opts, files):
opts.extra_files.extend(files)
+def mini_quickcheck(name, opts):
+ miniqc = os.path.relpath(config.top / 'tests' / 'MiniQuickCheck.hs', opts.srcdir)
+ opts.extra_files.extend([miniqc])
+ opts.extra_run_opts += ' ' + str(random.getrandbits(64))
+
# Record the size of a specific file
def collect_size ( deviation, path ):
return collect_size_func(deviation, lambda: path)
=====================================
testsuite/tests/MiniQuickCheck.hs
=====================================
@@ -0,0 +1,395 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralisedNewtypeDeriving #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeFamilies #-}
+
+-- | A minimal QuickCheck-like property testing framework for use in the GHC
+-- test suite.
+--
+-- We vendor this package to avoid depending on the real QuickCheck package,
+-- as the latter (or one of its dependencies) may not build with the GHC version
+-- being tested.
+module MiniQuickCheck
+ ( -- * QuickCheck generator
+ Gen(..)
+
+ -- * QuickCheck typeclasses
+ , Arbitrary(..)
+ , IsProperty(..)
+
+ -- * QuickCheck properties
+ , PropertyCheck(..)
+ , PropertyTestArg(..)
+ , Property(..)
+ , forAll
+ , (===)
+ , propertyCompare
+ , propertyAnd
+ , getCheck
+
+ -- * QuickCheck test tree
+ , Test(..)
+
+ -- * Running QuickCheck tests
+ , Result(..)
+ , Iterations(..)
+ , runTestsMain
+ , runTests
+ , runTestInternal
+
+ -- * QuickCheck primitive generators
+ , arbitraryInt64
+ , arbitraryWord64
+ , integralDownsize
+ , wordDownsize
+
+ -- * QuickCheck newtypes
+ , NonZero(..)
+ , nonZero
+ , BoundedShiftAmount(..)
+ , BoundedBy(..)
+ ) where
+
+-- base
+import Control.Monad.IO.Class
+ ( liftIO )
+import Data.Bits
+ ( (.|.), shiftL, shiftR
+ , FiniteBits, finiteBitSize
+ )
+import Data.Int
+ ( Int8, Int16, Int32, Int64 )
+import Data.IORef
+ ( newIORef, atomicModifyIORef' )
+import Data.Kind
+ ( Type )
+import Data.List
+ ( intercalate )
+import Data.Proxy
+ ( Proxy(..) )
+import Data.Word
+ ( Word8, Word16, Word32, Word64 )
+import GHC.TypeNats
+ ( Nat, KnownNat, natVal )
+import Numeric.Natural
+ ( Natural )
+import System.Environment
+ ( getArgs )
+import System.Exit
+ ( die, exitFailure )
+import Text.Read
+ ( readMaybe )
+
+-- transformers
+import Control.Monad.Trans.Reader
+ ( ReaderT, runReaderT, ask, local )
+import Control.Monad.Trans.State.Strict
+ ( State, state, runState )
+
+--------------------------------------------------------------------------------
+-- Core framework
+
+newtype Gen a = Gen { runGen :: State Word64 a }
+ deriving newtype ( Functor, Applicative, Monad )
+
+class Arbitrary a where
+ arbitrary :: Gen a
+
+class IsProperty p where
+ property :: p -> Property
+
+data PropertyCheck
+ = PropertyBinaryOp Bool String String String
+ | PropertyAnd PropertyCheck PropertyCheck
+
+instance IsProperty PropertyCheck where
+ property check = Prop (pure (PropertyEOA check))
+
+data PropertyTestArg
+ = PropertyEOA PropertyCheck
+ | PropertyArg String PropertyTestArg
+
+getCheck :: PropertyTestArg -> ([String], PropertyCheck)
+getCheck (PropertyEOA pc) = ([], pc)
+getCheck (PropertyArg s pta) = let (ss, pc) = getCheck pta in (s:ss, pc)
+
+data Property = Prop { unProp :: Gen PropertyTestArg }
+
+instance (Show a, Arbitrary a, IsProperty prop) => IsProperty (a -> prop) where
+ property p = forAll arbitrary p
+
+-- | Run a generator for a value of the given type and add it as an argument
+-- to the property test.
+forAll :: (Show a, IsProperty prop) => Gen a -> (a -> prop) -> Property
+forAll generator tst = Prop $ do
+ a <- generator
+ augment a <$> unProp (property (tst a))
+ where
+ augment a arg = PropertyArg (show a) arg
+
+-- | Build a @PropertyCheck@ by comparing two values with a named predicate.
+propertyCompare :: Show a => String -> (a -> a -> Bool) -> a -> a -> PropertyCheck
+propertyCompare s f a b = PropertyBinaryOp (f a b) s (show a) (show b)
+
+-- | Check that two values are equal (by '==').
+(===) :: (Show a, Eq a) => a -> a -> PropertyCheck
+(===) = propertyCompare "==" (==)
+infix 4 ===
+
+-- | Conjunction of two property checks.
+propertyAnd :: PropertyCheck -> PropertyCheck -> PropertyCheck
+propertyAnd = PropertyAnd
+
+--------------------------------------------------------------------------------
+-- Test tree
+
+-- | A named test or group of tests.
+data Test where
+ Group :: String -> [Test] -> Test
+ Property :: IsProperty prop => String -> prop -> Test
+
+--------------------------------------------------------------------------------
+-- Test runner
+
+newtype Iterations = Iterations { nbIterations :: Word }
+ deriving newtype ( Show, Eq, Ord )
+
+-- | Outcome of running a test suite.
+data Result = Success | Failure [[String]]
+
+instance Semigroup Result where
+ Success <> y = y
+ x <> Success = x
+ Failure xs <> Failure ys = Failure (xs ++ ys)
+
+instance Monoid Result where
+ mempty = Success
+
+data RunS = RunS
+ { depth :: Int
+ , currentSeed :: Word64
+ , context :: [String]
+ }
+
+putMsg :: String -> ReaderT RunS IO ()
+putMsg s = do
+ n <- depth <$> ask
+ liftIO . putStrLn $ replicate (n * 2) ' ' ++ s
+
+nest :: String -> ReaderT RunS IO a -> ReaderT RunS IO a
+nest c = local (\s -> s { depth = depth s + 1, context = c : context s })
+
+runPropertyCheck :: PropertyCheck -> ReaderT RunS IO Result
+runPropertyCheck (PropertyBinaryOp ok desc s1 s2) =
+ if ok
+ then return Success
+ else do
+ ctx <- context <$> ask
+ let msg = "Failure: " ++ s1 ++ " " ++ desc ++ " " ++ s2
+ putMsg msg
+ return (Failure [msg : ctx])
+runPropertyCheck (PropertyAnd a b) =
+ (<>) <$> runPropertyCheck a <*> runPropertyCheck b
+
+runProperty :: Iterations -> Property -> ReaderT RunS IO Result
+runProperty (Iterations iters) (Prop p) = do
+ startingSeed <- currentSeed <$> ask
+ loop iters startingSeed
+ where
+ loop 0 _ = do
+ putMsg ("Passed " ++ show iters ++ " iterations")
+ return Success
+ loop n s = do
+ let (pt, s') = runState (runGen p) s
+ (ss, pc) = getCheck pt
+ res <- runPropertyCheck pc
+ case res of
+ Success -> loop (n - 1) s'
+ Failure msgs -> do
+ let msg = "With arguments " ++ intercalate ", " ss ++ " (Seed: " ++ show s ++ ")"
+ putMsg msg
+ return (Failure (map (msg :) msgs))
+
+-- | Run a single 'Test', accumulating all failures.
+runTestInternal :: Iterations -> Test -> ReaderT RunS IO Result
+runTestInternal iters (Group name tests) = do
+ let label = "Group " ++ name
+ putMsg label
+ env <- ask
+ nest label $ do
+ -- Compute initial seed for each test in the group, based on the
+ -- index of the test in the group.
+ let runOne idx t = do
+ let !s = snd $ stepLCG (currentSeed env + fromIntegral idx)
+ local (\e -> e { currentSeed = s }) (runTestInternal iters t)
+ mconcat <$> traverse (uncurry runOne) (zip [1..] tests)
+
+runTestInternal iters (Property name p) = do
+ let label = "Running " ++ name
+ putMsg label
+ nest label (runProperty iters (property p))
+
+showStack :: Int -> [String] -> String
+showStack _ [] = ""
+showStack n (s:ss) = replicate n ' ' ++ s ++ "\n" ++ showStack (n + 2) ss
+
+-- | Standard @main@ entry point for tests using 'MiniQuickCheck'.
+--
+-- Reads a 'Word64' seed from the first command-line argument, then
+-- delegates to 'runTests'.
+runTestsMain :: Iterations -> Test -> IO ()
+runTestsMain iters t = do
+ args <- getArgs
+ seed <- case args of
+ [arg] -> case readMaybe arg of
+ Just s -> pure s
+ Nothing -> die $ "Invalid seed: " ++ show arg
+ _ -> die "Usage: <test-name> <seed>"
+ runTests iters seed t
+
+runTests :: Iterations -> Word64 -> Test -> IO ()
+runTests iters seed t = do
+ res <- runReaderT (runTestInternal iters t) (RunS 0 seed [])
+ case res of
+ Success -> return ()
+ Failure tests -> do
+ putStrLn $ "Seed: " ++ show seed
+ putStrLn $ "These tests failed:\n"
+ ++ intercalate "\n" (map (showStack 0 . reverse) tests)
+ exitFailure
+
+--------------------------------------------------------------------------------
+-- Random number generation (linear congruences)
+
+-- Constants from Knuth's MMIX
+
+lcgMultiplier :: Word64
+lcgMultiplier = 6364136223846793005
+lcgIncrement :: Word64
+lcgIncrement = 1442695040888963407
+
+-- | Pure step function for the linear congruential generator
+stepLCG :: Word64 -> (Word64, Word64)
+stepLCG s =
+ let s' = s * lcgMultiplier + lcgIncrement
+ in (s', s')
+
+--------------------------------------------------------------------------------
+-- Primitive generators
+
+-- | Generate a uniformly random 'Word64'.
+arbitraryWord64 :: Gen Word64
+arbitraryWord64 = Gen $ state stepLCG
+
+-- | Generate a uniformly random 'Int64' (bit-reinterpretation of a Word64).
+arbitraryInt64 :: Gen Int64
+arbitraryInt64 = fromIntegral <$> arbitraryWord64
+
+-- | Shrink a random 'Int64' down to a smaller integral type.
+integralDownsize :: (Integral a, FiniteBits a) => Int64 -> a
+integralDownsize = wordDownsize . fromIntegral
+
+-- | Shrink a random 'Word64' down to a smaller integral type.
+wordDownsize :: forall a. (Integral a, FiniteBits a) => Word64 -> a
+wordDownsize w =
+ fromIntegral (w `shiftR` (64 - finiteBitSize (undefined :: a)))
+ -- take the higher bits (more random with our LCG)
+
+--------------------------------------------------------------------------------
+-- Basic Arbitrary instances
+
+instance Arbitrary Bool where
+ arbitrary = ( == 1 ) . ( `shiftR` 63 ) <$> arbitraryWord64
+
+instance Arbitrary Word64 where
+ arbitrary = arbitraryWord64
+instance Arbitrary Word32 where
+ arbitrary = wordDownsize <$> arbitraryWord64
+instance Arbitrary Word16 where
+ arbitrary = wordDownsize <$> arbitraryWord64
+instance Arbitrary Word8 where
+ arbitrary = wordDownsize <$> arbitraryWord64
+instance Arbitrary Word where
+ arbitrary = fromIntegral <$> arbitraryWord64
+
+instance Arbitrary Int64 where
+ arbitrary = arbitraryInt64
+instance Arbitrary Int32 where
+ arbitrary = integralDownsize <$> arbitraryInt64
+instance Arbitrary Int16 where
+ arbitrary = integralDownsize <$> arbitraryInt64
+instance Arbitrary Int8 where
+ arbitrary = integralDownsize <$> arbitraryInt64
+instance Arbitrary Int where
+ arbitrary = fromIntegral <$> arbitraryInt64
+
+-- | Generates a natural number with at most 192 bits set.
+instance Arbitrary Natural where
+ arbitrary = do
+ cx <- ( `shiftR` 62 ) <$> arbitraryWord64
+ n1 <- fromIntegral <$> arbitraryWord64
+ n2 <- fromIntegral <$> arbitraryWord64
+ n3 <- fromIntegral <$> arbitraryWord64
+
+ pure $ case cx of
+ 0 -> n1
+ 1 -> (n1 `shiftL` 64) .|. n2
+ _ -> (n1 `shiftL` 128) .|. (n2 `shiftL` 64) .|. n3
+
+-- | Generates an integer with at most 192 bits set.
+instance Arbitrary Integer where
+ arbitrary = do
+ nat <- arbitrary @Natural
+ neg <- arbitrary @Bool
+
+ pure $
+ if neg
+ then negate (fromIntegral nat)
+ else fromIntegral nat
+
+instance Arbitrary Char where
+ arbitrary = do
+ let high = fromIntegral (fromEnum (maxBound :: Char)) :: Word
+ x <- arbitrary
+ return (toEnum . fromIntegral $ x `mod` (high + 1))
+
+--------------------------------------------------------------------------------
+-- Useful newtypes for different Arbitrary instances
+
+-- | Wrapper for non-zero values.
+newtype NonZero a = NonZero { getNonZero :: a }
+ deriving (Eq, Ord, Bounded, Show)
+
+-- | Generator that rejects zero values.
+nonZero :: (Arbitrary a, Num a, Eq a) => Gen (NonZero a)
+nonZero = do
+ x <- arbitrary
+ if x == 0 then nonZero else pure (NonZero x)
+
+instance (Arbitrary a, Num a, Eq a) => Arbitrary (NonZero a) where
+ arbitrary = nonZero
+
+-- | Shift amount bounded to @[0, finiteBitSize - 1]@.
+newtype BoundedShiftAmount a = BoundedShiftAmount { getBoundedShiftAmount :: Int }
+ deriving (Eq, Ord, Show)
+
+instance FiniteBits a => Arbitrary (BoundedShiftAmount a) where
+ arbitrary = do
+ x <- arbitrary
+ let w = finiteBitSize (undefined :: a)
+ pure $ BoundedShiftAmount (abs x `mod` w)
+
+-- | @a `BoundedBy` n@ represents numbers with maximum absolute value @n@ (inclusive).
+type BoundedBy :: Type -> Nat -> Type
+newtype BoundedBy a n = BoundedBy { getBoundedBy :: a }
+ deriving (Eq, Ord, Show)
+
+instance
+ forall n a
+ . ( KnownNat n, Integral a, Arbitrary a )
+ => Arbitrary ( a `BoundedBy` n ) where
+ arbitrary = BoundedBy . (`rem` (n + 1)) <$> arbitrary
+ where
+ n :: a
+ n = fromIntegral $ natVal @n Proxy
=====================================
testsuite/tests/numeric/should_run/all.T
=====================================
@@ -3,8 +3,6 @@
# extra run flags
# expected process return value, if not zero
-import random
-
# some bugs only surface with -O, omitting optasm may cause them to
# slip into releases! (e.g. #26711)
setTestOpts(when(have_ncg(), extra_ways(['optasm'])))
@@ -89,7 +87,14 @@ test('T20291', normal, compile_and_run, [''])
test('T22282', normal, compile_and_run, [''])
test('T22671', js_fragile(24259), compile_and_run, [''])
# the high run timeout multiplier exists because of timeouts with the wasm backend
-test('foundation', [run_timeout_multiplier(4), js_fragile(24259), extra_ways(['optasm','ghci','ghci-opt']), extra_run_opts(str(random.getrandbits(64)))], compile_and_run, ['-fno-break-points'])
+test('foundation',
+ [ mini_quickcheck
+ , run_timeout_multiplier(4)
+ , js_fragile(24259)
+ , extra_ways(['optasm','ghci','ghci-opt'])
+ ]
+ , multimod_compile_and_run
+ , ['foundation', '-fno-break-points'])
test('T24066', normal, compile_and_run, [''])
test('div01', normal, compile_and_run, [''])
test('T24245', normal, compile_and_run, [''])
=====================================
testsuite/tests/numeric/should_run/foundation.hs
=====================================
@@ -23,252 +23,20 @@ module Main
( main
) where
-import Data.Array.Byte
-import Data.Bits (Bits((.&.), bit), FiniteBits, finiteBitSize)
-import Data.Word
+import Data.Bits (Bits((.&.), bit))
+import Data.Function (on)
import Data.Int
-import GHC.Natural
import Data.Typeable
+import Data.Word
import GHC.Int
-import GHC.Word
-import Data.Function
+import GHC.Natural
import GHC.Prim
-import Control.Monad.Reader
-import Data.List (intercalate)
-import System.Environment (getArgs)
-import Text.Read (readMaybe)
-import Unsafe.Coerce
import GHC.Types
-import Data.Char
-import System.Exit
-
+import GHC.Word
import qualified GHC.Internal.PrimopWrappers as Wrapper
-import qualified GHC.Internal.Prim as Primop
-
-newtype Gen a = Gen { runGen :: (ReaderT LCGGen IO a) }
- deriving newtype (Functor, Applicative, Monad)
-
-class Arbitrary a where
- arbitrary :: Gen a
-
-class IsProperty p where
- property :: p -> Property
+import qualified GHC.Internal.Prim as Primop
-data PropertyCheck = PropertyBinaryOp Bool String String String
- | PropertyAnd PropertyCheck PropertyCheck
-
-instance IsProperty PropertyCheck where
- property check = Prop $ pure (PropertyEOA check)
-
-data PropertyTestArg = PropertyEOA PropertyCheck
- | PropertyArg String PropertyTestArg
-
-getCheck :: PropertyTestArg -> ([String], PropertyCheck)
-getCheck (PropertyEOA pc) = ([], pc)
-getCheck (PropertyArg s pta ) = let (ss, pc) = getCheck pta in (s:ss, pc)
-
-data Property = Prop { unProp :: Gen PropertyTestArg }
-
-instance (Show a, Arbitrary a, IsProperty prop) => IsProperty (a -> prop) where
- property p = forAll arbitrary p
-
--- | Running a generator for a specific type under a property
-forAll :: (Show a, IsProperty prop) => Gen a -> (a -> prop) -> Property
-forAll generator tst = Prop $ do
- a <- generator
- augment a <$> unProp (property (tst a))
- where
- augment a arg = PropertyArg (show a) arg
-
--- | A property that check for equality of its 2 members.
-propertyCompare :: (Show a) => String -> (a -> a -> Bool) -> a -> a -> PropertyCheck
-propertyCompare s f a b =
- let sa = show a
- sb = show b
- in PropertyBinaryOp (a `f` b) s sa sb
-
-(===) :: (Show a, Eq a) => a -> a -> PropertyCheck
-(===) = propertyCompare "==" (==)
-infix 4 ===
-
-propertyAnd = PropertyAnd
-
-
-data Test where
- Group :: String -> [Test] -> Test
- Property :: IsProperty prop => String -> prop -> Test
-
-
-arbitraryInt64 :: Gen Int64
-arbitraryInt64 = Gen $ do
- h <- ask
- W64# w <- liftIO (randomWord64 h)
- return (I64# (unsafeCoerce# w))
-
-integralDownsize :: (Integral a) => Int64 -> a
-integralDownsize = fromIntegral
-
-wordDownsize :: (Integral a) => Word64 -> a
-wordDownsize = fromIntegral
-
-arbitraryWord64 :: Gen Word64
-arbitraryWord64 = Gen $ do
- h <- ask
- liftIO (randomWord64 h)
-
-nonZero :: (Arbitrary a, Num a, Eq a) => Gen (NonZero a)
-nonZero = do
- x <- arbitrary
- if x == 0 then nonZero else pure $ NonZero x
-
-newtype NonZero a = NonZero { getNonZero :: a }
- deriving (Eq,Ord,Bounded,Show)
-
-instance (Arbitrary a, Num a, Eq a) => Arbitrary (NonZero a) where
- arbitrary = nonZero
-
--- | A newtype for shift amounts that are bounded by @wordSize - 1@
-newtype BoundedShiftAmount a = BoundedShiftAmount {getBoundedShiftAmount :: Int}
- deriving (Eq, Ord, Show)
-
-instance (FiniteBits a) => Arbitrary (BoundedShiftAmount a) where
- arbitrary = do
- x <- arbitrary
- let widthBits = finiteBitSize (undefined :: a)
- pure $ BoundedShiftAmount (abs x `mod` widthBits)
-
-instance Arbitrary Natural where
- arbitrary = integralDownsize . (`mod` 10000) . abs <$> arbitraryInt64
-
--- Bounded by Int64
-instance Arbitrary Integer where
- arbitrary = fromIntegral <$> arbitraryInt64
-
-instance Arbitrary Int where
- arbitrary = int64ToInt <$> arbitraryInt64
-instance Arbitrary Word where
- arbitrary = word64ToWord <$> arbitraryWord64
-instance Arbitrary Word64 where
- arbitrary = arbitraryWord64
-instance Arbitrary Word32 where
- arbitrary = wordDownsize <$> arbitraryWord64
-instance Arbitrary Word16 where
- arbitrary = wordDownsize <$> arbitraryWord64
-instance Arbitrary Word8 where
- arbitrary = wordDownsize <$> arbitraryWord64
-instance Arbitrary Int64 where
- arbitrary = arbitraryInt64
-instance Arbitrary Int32 where
- arbitrary = integralDownsize <$> arbitraryInt64
-instance Arbitrary Int16 where
- arbitrary = integralDownsize <$> arbitraryInt64
-instance Arbitrary Int8 where
- arbitrary = integralDownsize <$> arbitraryInt64
-
-instance Arbitrary Char where
- arbitrary = do
- let high = fromIntegral $ fromEnum (maxBound :: Char) :: Word
- (x::Word) <- arbitrary
- let x' = mod x high
- return (chr $ fromIntegral x')
-
-int64ToInt :: Int64 -> Int
-int64ToInt (I64# i) = I# (int64ToInt# i)
-
-
-word64ToWord :: Word64 -> Word
-word64ToWord (W64# i) = W# (word64ToWord# i)
-
-
-data RunS = RunS { depth :: Int, rg :: LCGGen, context :: [String] }
-
-newtype LCGGen = LCGGen { randomWord64 :: IO Word64 }
-
-data LCGParams = LCGParams { seed :: Word64, a :: Word64, c :: Word64, m :: Word64 }
-
-newLCGGen :: LCGParams -> IO LCGGen
-newLCGGen LCGParams {seed = W64# seed#, ..} = do
- MutableByteArray mba# <- IO $ \s0 -> case newByteArray# 8# s0 of
- (# s1, mba# #) -> case writeWord64Array# mba# 0# seed# s1 of
- s2 -> (# s2, MutableByteArray mba# #)
- pure $ LCGGen $ IO $ \s0 -> case readWord64Array# mba# 0# s0 of
- (# s1, old_val# #) ->
- let old_val = W64# old_val#
- !new_val@(W64# new_val#) = (old_val * a + c) `mod` m
- in case writeWord64Array# mba# 0# new_val# s1 of
- s2 -> (# s2, new_val #)
-
-runPropertyCheck (PropertyBinaryOp res desc s1 s2) =
- if res then return Success
- else do
- ctx <- context <$> ask
- let msg = "Failure: " ++ s1 ++ desc ++ s2
- putMsg msg
- return (Failure [msg : ctx])
-runPropertyCheck (PropertyAnd a1 a2) = (<>) <$> runPropertyCheck a1 <*> runPropertyCheck a2
-
-runProperty :: Property -> ReaderT RunS IO Result
-runProperty (Prop p) = do
- let iterations = 1000 :: Int
- loop iterations iterations
- where
- loop iterations 0 = do
- putMsg ("Passed " ++ show iterations ++ " iterations")
- return Success
- loop iterations n = do
- h <- rg <$> ask
- p <- liftIO (runReaderT (runGen p) h)
- let (ss, pc) = getCheck p
- res <- runPropertyCheck pc
- case res of
- Success -> loop iterations (n-1)
- Failure msgs -> do
- let msg = ("With arguments " ++ intercalate ", " ss)
- putMsg msg
- return (Failure (map (msg :) msgs))
-
-data Result = Success | Failure [[String]]
-
-instance Semigroup Result where
- Success <> x = x
- x <> Success = x
- (Failure xs) <> (Failure ys) = Failure (xs ++ ys)
-
-instance Monoid Result where
- mempty = Success
-
-putMsg s = do
- n <- depth <$> ask
- liftIO . putStrLn $ replicate (n * 2) ' ' ++ s
-
-
-nest c = local (\s -> s { depth = depth s + 1, context = c : context s })
-
-runTestInternal :: Test -> ReaderT RunS IO Result
-runTestInternal (Group name tests) = do
- let label = ("Group " ++ name)
- putMsg label
- nest label (mconcat <$> mapM runTestInternal tests)
-runTestInternal (Property name p) = do
- let label = ("Running " ++ name)
- putMsg label
- nest label $ runProperty (property p)
-
-
-runTests :: Word64 -> Test -> IO ()
-runTests seed t = do
- -- These params are the same ones as glibc uses.
- h <- newLCGGen (LCGParams { seed, m = 2 ^ (31 :: Int), a = 1103515245, c = 12345 })
- res <- runReaderT (runTestInternal t) (RunS 0 h [])
- case res of
- Success -> return ()
- Failure tests -> do
- putStrLn $ "Seed: " ++ show seed
- putStrLn $ "These tests failed: \n" ++ intercalate " \n" (map (showStack 0 . reverse) tests)
- exitFailure
-
-showStack _ [] = ""
-showStack n (s:ss) = replicate n ' ' ++ s ++ "\n" ++ showStack (n + 2) ss
+import MiniQuickCheck
-------------------------------------------------------------------------------
@@ -325,8 +93,11 @@ testOperatorPrecedence _ = Group "Precedence"
, Property "+ and * (2)" $ \(a :: a) (b :: a) (c :: a) -> (a * b + c) === ((a * b) + c)
, Property "- and * (1)" $ \(a :: a) (b :: a) (c :: a) -> (a - b * c) === (a - (b * c))
, Property "- and * (2)" $ \(a :: a) (b :: a) (c :: a) -> (a * b - c) === ((a * b) - c)
- , Property "* and ^ (1)" $ \(a :: a) (b :: Natural) (c :: a) -> (a ^ b * c) === ((a ^ b) * c)
- , Property "* and ^ (2)" $ \(a :: a) (c :: Natural) (b :: a) -> (a * b ^ c) === (a * (b ^ c))
+
+ -- Bound the exponent to avoid OOM errors e.g.
+ -- GNU MP: Cannot allocate memory (size=4294938656)
+ , Property "* and ^ (1)" $ \(a :: a) (BoundedBy b :: Natural `BoundedBy` 100) (c :: a) -> (a ^ b * c) === ((a ^ b) * c)
+ , Property "* and ^ (2)" $ \(a :: a) (BoundedBy c :: Natural `BoundedBy` 100) (b :: a) -> (a * b ^ c) === (a * (b ^ c))
]
@@ -454,19 +225,8 @@ instance TestPrimop LowerBitsAreDefined where
twoNonZero :: (a -> a -> b) -> a -> NonZero a -> b
twoNonZero f x (NonZero y) = f x y
-getSeedFromArgs :: IO Word64
-getSeedFromArgs = do
- args <- getArgs
- case args of
- [arg] -> case readMaybe arg of
- Just seed -> pure seed
- Nothing -> die $ "Invalid seed (expected Word64): " ++ show arg
- _ -> die "Usage: foundation <seed>"
-
main :: IO ()
-main = do
- seed <- getSeedFromArgs
- runTests seed (Group "ALL" [testNumberRefs, testPrimops])
+main = runTestsMain (Iterations 1000) (Group "ALL" [testNumberRefs, testPrimops])
-- Test an interpreted primop vs a compiled primop
testPrimops = Group "primop"
=====================================
testsuite/tests/simd/should_run/all.T
=====================================
@@ -80,7 +80,7 @@ test('simd002', [], compile_and_run, [''])
test('simd003', [], compile_and_run, [''])
test('simd004', [], compile_and_run, ['-O2'])
test('simd005', [], compile_and_run, [''])
-test('simd006', [], compile_and_run, [''])
+test('simd006', [mini_quickcheck], multimod_compile_and_run, ['simd006', ''])
test('simd007', [], compile_and_run, [''])
test('simd008', [], compile_and_run, [''])
test('simd009', [ req_th
=====================================
testsuite/tests/simd/should_run/simd006.hs
=====================================
@@ -1,161 +1,79 @@
-{-# LANGUAGE MagicHash #-}
-{-# LANGUAGE UnboxedTuples #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
-{-# LANGUAGE MagicHash #-}
-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
--- QuickCheck testing for SIMD operations
+-- QuickCheck-like property tests for SIMD vector operations.
-module Main
- ( main
- ) where
+module Main (main) where
-import Data.Word
-import Data.Int
-import GHC.Natural
import Data.Coerce
-import Data.Typeable
-import Data.Proxy
-import GHC.Int
-import GHC.Word
-import Data.Function
+import Data.Word
import GHC.Prim
-import Control.Monad.Reader
-import System.IO
-import Foreign.Marshal.Alloc
-import Foreign.Storable
-import Foreign.Ptr
-import Data.List (intercalate)
-import Data.IORef
-import Unsafe.Coerce
import GHC.Exts
import GHC.Float
( castFloatToWord32 , castWord32ToFloat
, castDoubleToWord64, castWord64ToDouble
)
+import MiniQuickCheck
+--------------------------------------------------------------------------------
+-- Scalar wrappers that use bit-equality to test for equality.
-newtype Gen a = Gen { runGen :: (ReaderT LCGGen IO a) }
- deriving newtype (Functor, Applicative, Monad)
-
-class Arbitrary a where
- arbitrary :: Gen a
-
-class IsProperty p where
- property :: p -> Property
-
-data PropertyCheck = PropertyBinaryOp Bool String String String
- | PropertyAnd PropertyCheck PropertyCheck
-
-instance IsProperty PropertyCheck where
- property check = Prop $ pure (PropertyEOA check)
-
-data PropertyTestArg = PropertyEOA PropertyCheck
- | PropertyArg String PropertyTestArg
-
-getCheck :: PropertyTestArg -> ([String], PropertyCheck)
-getCheck (PropertyEOA pc) = ([], pc)
-getCheck (PropertyArg s pta ) = let (ss, pc) = getCheck pta in (s:ss, pc)
-
-data Property = Prop { unProp :: Gen PropertyTestArg }
-
-instance (Show a, Arbitrary a, IsProperty prop) => IsProperty (a -> prop) where
- property p = forAll arbitrary p
-
--- | Running a generator for a specific type under a property
-forAll :: (Show a, IsProperty prop) => Gen a -> (a -> prop) -> Property
-forAll generator tst = Prop $ do
- a <- generator
- augment a <$> unProp (property (tst a))
- where
- augment a arg = PropertyArg (show a) arg
-
--- | A property that check for equality of its 2 members.
-propertyCompare :: (Show a) => String -> (a -> a -> Bool) -> a -> a -> PropertyCheck
-propertyCompare s f a b =
- let sa = show a
- sb = show b
- in PropertyBinaryOp (a `f` b) s sa sb
-
-(===) :: (Show a, Eq a) => a -> a -> PropertyCheck
-(===) = propertyCompare "==" (==)
-infix 4 ===
-
-propertyAnd = PropertyAnd
-
-
-data Test where
- Group :: String -> [Test] -> Test
- Property :: IsProperty prop => String -> prop -> Test
-
+newtype FloatNT = FloatNT Float
+ deriving newtype (Show, Num)
-arbitraryInt64 :: Gen Int64
-arbitraryInt64 = Gen $ do
- h <- ask
- W64# w <- liftIO (randomWord64 h)
- return (I64# (unsafeCoerce# w))
+instance Eq FloatNT where
+ FloatNT f1 == FloatNT f2 = castFloatToWord32 f1 == castFloatToWord32 f2
-integralDownsize :: (Integral a) => Int64 -> a
-integralDownsize = fromIntegral
+instance Arbitrary FloatNT where
+ arbitrary = FloatNT . castWord32ToFloat <$> arbitrary
-wordDownsize :: (Integral a) => Word64 -> a
-wordDownsize = fromIntegral
+newtype DoubleNT = DoubleNT Double
+ deriving newtype (Show, Num)
-arbitraryWord64 :: Gen Word64
-arbitraryWord64 = Gen $ do
- h <- ask
- liftIO (randomWord64 h)
+instance Eq DoubleNT where
+ DoubleNT d1 == DoubleNT d2 = castDoubleToWord64 d1 == castDoubleToWord64 d2
+instance Arbitrary DoubleNT where
+ arbitrary = DoubleNT . castWord64ToDouble <$> arbitrary
-instance Arbitrary Word64 where
- arbitrary = arbitraryWord64
-instance Arbitrary Word32 where
- arbitrary = wordDownsize <$> arbitraryWord64
+--------------------------------------------------------------------------------
+-- Min/max for the types under test
class HasMinMax a where
mini, maxi :: a -> a -> a
+
instance HasMinMax FloatNT where
mini (FloatNT (F# f1)) (FloatNT (F# f2)) = FloatNT (F# (minFloat# f1 f2))
maxi (FloatNT (F# f1)) (FloatNT (F# f2)) = FloatNT (F# (maxFloat# f1 f2))
+
instance HasMinMax DoubleNT where
mini (DoubleNT (D# d1)) (DoubleNT (D# d2)) = DoubleNT (D# (minDouble# d1 d2))
maxi (DoubleNT (D# d1)) (DoubleNT (D# d2)) = DoubleNT (D# (maxDouble# d1 d2))
-newtype FloatNT = FloatNT Float
- deriving newtype (Show, Num)
-instance Eq FloatNT where
- FloatNT f1 == FloatNT f2 =
- castFloatToWord32 f1 == castFloatToWord32 f2
-instance Arbitrary FloatNT where
- arbitrary = FloatNT . castWord32ToFloat <$> arbitrary
-newtype DoubleNT = DoubleNT Double
- deriving newtype (Show, Num)
-instance Eq DoubleNT where
- DoubleNT d1 == DoubleNT d2 =
- castDoubleToWord64 d1 == castDoubleToWord64 d2
-instance Arbitrary DoubleNT where
- arbitrary = DoubleNT . castWord64ToDouble <$> arbitrary
-
+--------------------------------------------------------------------------------
+-- SIMD vector types
data FloatX4 = FX4# FloatX4#
+
instance Show FloatX4 where
- show (FX4# f) = case (unpackFloatX4# f) of
- (# a, b, c, d #) -> show ((F# a), (F# b), (F# c), (F# d))
+ show (FX4# f) = case unpackFloatX4# f of
+ (# a, b, c, d #) -> show (F# a, F# b, F# c, F# d)
+
instance Eq FloatX4 where
- (FX4# a) == (FX4# b)
- = case (unpackFloatX4# a) of
+ FX4# a == FX4# b
+ = case unpackFloatX4# a of
(# a1, a2, a3, a4 #) ->
- case (unpackFloatX4# b) of
- (# b1, b2, b3, b4 #) -> FloatNT (F# a1) == FloatNT (F# b1) &&
- FloatNT (F# a2) == FloatNT (F# b2) &&
- FloatNT (F# a3) == FloatNT (F# b3) &&
- FloatNT (F# a4) == FloatNT (F# b4)
+ case unpackFloatX4# b of
+ (# b1, b2, b3, b4 #) ->
+ FloatNT (F# a1) == FloatNT (F# b1) &&
+ FloatNT (F# a2) == FloatNT (F# b2) &&
+ FloatNT (F# a3) == FloatNT (F# b3) &&
+ FloatNT (F# a4) == FloatNT (F# b4)
+
instance Arbitrary FloatX4 where
arbitrary = do
FloatNT (F# f1) <- arbitrary
@@ -163,52 +81,59 @@ instance Arbitrary FloatX4 where
FloatNT (F# f3) <- arbitrary
FloatNT (F# f4) <- arbitrary
return $ FX4# (packFloatX4# (# f1, f2, f3, f4 #))
+
instance Num FloatX4 where
- FX4# x + FX4# y =
- FX4# ( x `plusFloatX4#` y )
- FX4# x - FX4# y =
- FX4# ( x `minusFloatX4#` y )
- negate ( FX4# x ) = FX4# ( negateFloatX4# x )
- FX4# x * FX4# y =
- FX4# ( x `timesFloatX4#` y )
- abs = error "no"
- signum = error "no"
- fromInteger = error "no"
+ FX4# x + FX4# y = FX4# (x `plusFloatX4#` y)
+ FX4# x - FX4# y = FX4# (x `minusFloatX4#` y)
+ negate (FX4# x) = FX4# (negateFloatX4# x)
+ FX4# x * FX4# y = FX4# (x `timesFloatX4#` y)
+ abs = error "FloatX4: no abs"
+ signum = error "FloatX4: no signum"
+ fromInteger = error "FloatX4: no fromInteger"
+
instance HasMinMax FloatX4 where
mini (FX4# a) (FX4# b) = FX4# (minFloatX4# a b)
maxi (FX4# a) (FX4# b) = FX4# (maxFloatX4# a b)
+--------------------------------------------------------------------------------
+
data DoubleX2 = DX2# DoubleX2#
+
instance Show DoubleX2 where
- show (DX2# d) = case (unpackDoubleX2# d) of
- (# a, b #) -> show ((D# a), (D# b))
+ show (DX2# d) = case unpackDoubleX2# d of
+ (# a, b #) -> show (D# a, D# b)
+
instance Eq DoubleX2 where
- (DX2# a) == (DX2# b)
- = case (unpackDoubleX2# a) of
+ DX2# a == DX2# b
+ = case unpackDoubleX2# a of
(# a1, a2 #) ->
- case (unpackDoubleX2# b) of
- (# b1, b2 #) -> DoubleNT (D# a1) == DoubleNT (D# b1) &&
- DoubleNT (D# a2) == DoubleNT (D# b2)
+ case unpackDoubleX2# b of
+ (# b1, b2 #) ->
+ DoubleNT (D# a1) == DoubleNT (D# b1) &&
+ DoubleNT (D# a2) == DoubleNT (D# b2)
+
instance Arbitrary DoubleX2 where
arbitrary = do
DoubleNT (D# d1) <- arbitrary
DoubleNT (D# d2) <- arbitrary
return $ DX2# (packDoubleX2# (# d1, d2 #))
+
instance Num DoubleX2 where
- DX2# x + DX2# y =
- DX2# ( x `plusDoubleX2#` y )
- DX2# x - DX2# y =
- DX2# ( x `minusDoubleX2#` y )
- negate ( DX2# x ) = DX2# ( negateDoubleX2# x )
- DX2# x * DX2# y =
- DX2# ( x `timesDoubleX2#` y )
- abs = error "no"
- signum = error "no"
- fromInteger = error "no"
+ DX2# x + DX2# y = DX2# (x `plusDoubleX2#` y)
+ DX2# x - DX2# y = DX2# (x `minusDoubleX2#` y)
+ negate (DX2# x) = DX2# (negateDoubleX2# x)
+ DX2# x * DX2# y = DX2# (x `timesDoubleX2#` y)
+ abs = error "DoubleX2: no abs"
+ signum = error "DoubleX2: no signum"
+ fromInteger = error "DoubleX2: no fromInteger"
+
instance HasMinMax DoubleX2 where
mini (DX2# a) (DX2# b) = DX2# (minDoubleX2# a b)
maxi (DX2# a) (DX2# b) = DX2# (maxDoubleX2# a b)
+--------------------------------------------------------------------------------
+-- Expression language for generating random expressions over vector types.
+
data Expr a where
Lit :: a -> Expr a
Add :: Expr a -> Expr a -> Expr a
@@ -218,11 +143,12 @@ data Expr a where
Min :: Expr a -> Expr a -> Expr a
Max :: Expr a -> Expr a -> Expr a
deriving (Show, Eq)
+
fmapExpr :: (a -> b) -> Expr a -> Expr b
-fmapExpr f (Lit a) = Lit (f a)
+fmapExpr f (Lit a) = Lit (f a)
fmapExpr f (Add a b) = Add (fmapExpr f a) (fmapExpr f b)
fmapExpr f (Sub a b) = Sub (fmapExpr f a) (fmapExpr f b)
-fmapExpr f (Neg a) = Neg (fmapExpr f a)
+fmapExpr f (Neg a) = Neg (fmapExpr f a)
fmapExpr f (Mul a b) = Mul (fmapExpr f a) (fmapExpr f b)
fmapExpr f (Min a b) = Min (fmapExpr f a) (fmapExpr f b)
fmapExpr f (Max a b) = Max (fmapExpr f a) (fmapExpr f b)
@@ -240,75 +166,16 @@ instance Arbitrary a => Arbitrary (Expr a) where
_ -> Lit <$> arbitrary
eval :: (Num a, HasMinMax a) => Expr a -> a
-eval (Lit a) = a
+eval (Lit a) = a
eval (Add a b) = eval a + eval b
eval (Sub a b) = eval a - eval b
-eval (Neg a) = negate (eval a)
+eval (Neg a) = negate (eval a)
eval (Mul a b) = eval a * eval b
eval (Min a b) = mini (eval a) (eval b)
eval (Max a b) = maxi (eval a) (eval b)
-int64ToInt :: Int64 -> Int
-int64ToInt (I64# i) = I# (int64ToInt# i)
-
-
-word64ToWord :: Word64 -> Word
-word64ToWord (W64# i) = W# (word64ToWord# i)
-
-
-data RunS = RunS { depth :: Int, rg :: LCGGen }
-
-newtype LCGGen = LCGGen { randomWord64 :: IO Word64 }
-
-data LCGParams = LCGParams { seed :: Word64, a :: Word64, c :: Word64, m :: Word64 }
-
-newLCGGen :: LCGParams -> IO LCGGen
-newLCGGen LCGParams{..} = do
- var <- newIORef (fromIntegral seed)
- return $ LCGGen $ do
- atomicModifyIORef' var (\old_v -> let new_val = (old_v * a + c) `mod` m in (new_val, new_val))
-
-
-runPropertyCheck (PropertyBinaryOp res desc s1 s2) =
- if res then return True else (putMsg ("Failure: " ++ s1 ++ desc ++ s2) >> return False)
-runPropertyCheck (PropertyAnd a1 a2) = (&&) <$> runPropertyCheck a1 <*> runPropertyCheck a2
-
-runProperty :: Property -> ReaderT RunS IO ()
-runProperty (Prop p) = do
- let iterations = 100
- loop iterations iterations
- where
- loop iterations 0 = putMsg ("Passed " ++ show iterations ++ " iterations")
- loop iterations n = do
- h <- rg <$> ask
- p <- liftIO (runReaderT (runGen p) h)
- let (ss, pc) = getCheck p
- res <- runPropertyCheck pc
- if res then loop iterations (n-1)
- else putMsg ("With arguments " ++ intercalate ", " ss)
-
-putMsg s = do
- n <- depth <$> ask
- liftIO . putStrLn $ replicate (n * 2) ' ' ++ s
-
-nest = local (\s -> s { depth = depth s + 1 })
-
-runTestInternal :: Test -> ReaderT RunS IO ()
-runTestInternal (Group name tests) = do
- putMsg ("Group " ++ name)
- nest (mapM_ runTestInternal tests)
-runTestInternal (Property name p) = do
- putMsg ("Running " ++ name)
- nest $ runProperty (property p)
-
-
-runTests :: Test -> IO ()
-runTests t = do
- -- These params are the same ones as glibc uses.
- h <- newLCGGen (LCGParams { seed = 1238123213, m = 2^31, a = 1103515245, c = 12345 })
- runReaderT (runTestInternal t) (RunS 0 h)
-
--------------------------------------------------------------------------------
+--------------------------------------------------------------------------------
+-- Test groups
testFloatX4 :: Test
testFloatX4 = Group "FloatX4"
@@ -324,15 +191,12 @@ testFloatX4 = Group "FloatX4"
unpack :: FloatX4 -> ( FloatNT, FloatNT, FloatNT, FloatNT )
unpack (FX4# f) = case unpackFloatX4# f of
(# f1, f2, f3, f4 #) -> coerce ( F# f1, F# f2, F# f3, F# f4 )
+
get1, get2, get3, get4 :: FloatX4 -> FloatNT
- get1 (FX4# f) = case unpackFloatX4# f of
- (# f1, _, _, _ #) -> FloatNT (F# f1)
- get2 (FX4# f) = case unpackFloatX4# f of
- (# _, f2, _, _ #) -> FloatNT (F# f2)
- get3 (FX4# f) = case unpackFloatX4# f of
- (# _, _, f3, _ #) -> FloatNT (F# f3)
- get4 (FX4# f) = case unpackFloatX4# f of
- (# _, _, _, f4 #) -> FloatNT (F# f4)
+ get1 (FX4# f) = case unpackFloatX4# f of (# f1, _, _, _ #) -> FloatNT (F# f1)
+ get2 (FX4# f) = case unpackFloatX4# f of (# _, f2, _, _ #) -> FloatNT (F# f2)
+ get3 (FX4# f) = case unpackFloatX4# f of (# _, _, f3, _ #) -> FloatNT (F# f3)
+ get4 (FX4# f) = case unpackFloatX4# f of (# _, _, _, f4 #) -> FloatNT (F# f4)
testDoubleX2 :: Test
testDoubleX2 = Group "DoubleX2"
@@ -346,16 +210,15 @@ testDoubleX2 = Group "DoubleX2"
unpack :: DoubleX2 -> ( DoubleNT, DoubleNT )
unpack (DX2# d) = case unpackDoubleX2# d of
(# d1, d2 #) -> coerce ( D# d1, D# d2 )
+
get1, get2 :: DoubleX2 -> DoubleNT
get1 (DX2# d) = case unpackDoubleX2# d of
- (# d1, _ #) -> DoubleNT (D# d1)
+ (# d1, _ #) -> DoubleNT (D# d1)
get2 (DX2# d) = case unpackDoubleX2# d of
- (# _, d2 #) -> DoubleNT (D# d2)
+ (# _, d2 #) -> DoubleNT (D# d2)
testSIMD :: Test
-testSIMD = Group "ALL"
- [ testFloatX4
- , testDoubleX2
- ]
+testSIMD = Group "ALL" [testFloatX4, testDoubleX2]
-main = runTests testSIMD
+main :: IO ()
+main = runTestsMain (Iterations 100) testSIMD
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e45b55221bd2c04f8fe34438deafeb…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e45b55221bd2c04f8fe34438deafeb…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
24 Apr '26
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
2d30f7d3 by sheaf at 2026-04-24T14:38:23-04:00
Vendor mini-QuickCheck for testsuite
This commit extracts the vendored QuickCheck implementation from the
foundation testsuite to make it more broadly available in the GHC
testsuite, and makes use of it in the simd006 test (which also used
a vendored QuickCheck implementation).
On the way, we update the linear congruential generator to avoid the
shortcoming of only generating 31 bit large numbers.
Fixes #25990 and #25969.
- - - - -
6 changed files:
- testsuite/driver/testlib.py
- + testsuite/tests/MiniQuickCheck.hs
- testsuite/tests/numeric/should_run/all.T
- testsuite/tests/numeric/should_run/foundation.hs
- testsuite/tests/simd/should_run/all.T
- testsuite/tests/simd/should_run/simd006.hs
Changes:
=====================================
testsuite/driver/testlib.py
=====================================
@@ -13,6 +13,7 @@ import time
import datetime
import copy
import glob
+import random
import sys
from math import ceil, trunc, floor, log
from pathlib import Path, PurePath
@@ -648,6 +649,11 @@ def extra_files(files):
def _extra_files(name, opts, files):
opts.extra_files.extend(files)
+def mini_quickcheck(name, opts):
+ miniqc = os.path.relpath(config.top / 'tests' / 'MiniQuickCheck.hs', opts.srcdir)
+ opts.extra_files.extend([miniqc])
+ opts.extra_run_opts += ' ' + str(random.getrandbits(64))
+
# Record the size of a specific file
def collect_size ( deviation, path ):
return collect_size_func(deviation, lambda: path)
=====================================
testsuite/tests/MiniQuickCheck.hs
=====================================
@@ -0,0 +1,395 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralisedNewtypeDeriving #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeFamilies #-}
+
+-- | A minimal QuickCheck-like property testing framework for use in the GHC
+-- test suite.
+--
+-- We vendor this package to avoid depending on the real QuickCheck package,
+-- as the latter (or one of its dependencies) may not build with the GHC version
+-- being tested.
+module MiniQuickCheck
+ ( -- * QuickCheck generator
+ Gen(..)
+
+ -- * QuickCheck typeclasses
+ , Arbitrary(..)
+ , IsProperty(..)
+
+ -- * QuickCheck properties
+ , PropertyCheck(..)
+ , PropertyTestArg(..)
+ , Property(..)
+ , forAll
+ , (===)
+ , propertyCompare
+ , propertyAnd
+ , getCheck
+
+ -- * QuickCheck test tree
+ , Test(..)
+
+ -- * Running QuickCheck tests
+ , Result(..)
+ , Iterations(..)
+ , runTestsMain
+ , runTests
+ , runTestInternal
+
+ -- * QuickCheck primitive generators
+ , arbitraryInt64
+ , arbitraryWord64
+ , integralDownsize
+ , wordDownsize
+
+ -- * QuickCheck newtypes
+ , NonZero(..)
+ , nonZero
+ , BoundedShiftAmount(..)
+ , BoundedBy(..)
+ ) where
+
+-- base
+import Control.Monad.IO.Class
+ ( liftIO )
+import Data.Bits
+ ( (.|.), shiftL, shiftR
+ , FiniteBits, finiteBitSize
+ )
+import Data.Int
+ ( Int8, Int16, Int32, Int64 )
+import Data.IORef
+ ( newIORef, atomicModifyIORef' )
+import Data.Kind
+ ( Type )
+import Data.List
+ ( intercalate )
+import Data.Proxy
+ ( Proxy(..) )
+import Data.Word
+ ( Word8, Word16, Word32, Word64 )
+import GHC.TypeNats
+ ( Nat, KnownNat, natVal )
+import Numeric.Natural
+ ( Natural )
+import System.Environment
+ ( getArgs )
+import System.Exit
+ ( die, exitFailure )
+import Text.Read
+ ( readMaybe )
+
+-- transformers
+import Control.Monad.Trans.Reader
+ ( ReaderT, runReaderT, ask, local )
+import Control.Monad.Trans.State.Strict
+ ( State, state, runState )
+
+--------------------------------------------------------------------------------
+-- Core framework
+
+newtype Gen a = Gen { runGen :: State Word64 a }
+ deriving newtype ( Functor, Applicative, Monad )
+
+class Arbitrary a where
+ arbitrary :: Gen a
+
+class IsProperty p where
+ property :: p -> Property
+
+data PropertyCheck
+ = PropertyBinaryOp Bool String String String
+ | PropertyAnd PropertyCheck PropertyCheck
+
+instance IsProperty PropertyCheck where
+ property check = Prop (pure (PropertyEOA check))
+
+data PropertyTestArg
+ = PropertyEOA PropertyCheck
+ | PropertyArg String PropertyTestArg
+
+getCheck :: PropertyTestArg -> ([String], PropertyCheck)
+getCheck (PropertyEOA pc) = ([], pc)
+getCheck (PropertyArg s pta) = let (ss, pc) = getCheck pta in (s:ss, pc)
+
+data Property = Prop { unProp :: Gen PropertyTestArg }
+
+instance (Show a, Arbitrary a, IsProperty prop) => IsProperty (a -> prop) where
+ property p = forAll arbitrary p
+
+-- | Run a generator for a value of the given type and add it as an argument
+-- to the property test.
+forAll :: (Show a, IsProperty prop) => Gen a -> (a -> prop) -> Property
+forAll generator tst = Prop $ do
+ a <- generator
+ augment a <$> unProp (property (tst a))
+ where
+ augment a arg = PropertyArg (show a) arg
+
+-- | Build a @PropertyCheck@ by comparing two values with a named predicate.
+propertyCompare :: Show a => String -> (a -> a -> Bool) -> a -> a -> PropertyCheck
+propertyCompare s f a b = PropertyBinaryOp (f a b) s (show a) (show b)
+
+-- | Check that two values are equal (by '==').
+(===) :: (Show a, Eq a) => a -> a -> PropertyCheck
+(===) = propertyCompare "==" (==)
+infix 4 ===
+
+-- | Conjunction of two property checks.
+propertyAnd :: PropertyCheck -> PropertyCheck -> PropertyCheck
+propertyAnd = PropertyAnd
+
+--------------------------------------------------------------------------------
+-- Test tree
+
+-- | A named test or group of tests.
+data Test where
+ Group :: String -> [Test] -> Test
+ Property :: IsProperty prop => String -> prop -> Test
+
+--------------------------------------------------------------------------------
+-- Test runner
+
+newtype Iterations = Iterations { nbIterations :: Word }
+ deriving newtype ( Show, Eq, Ord )
+
+-- | Outcome of running a test suite.
+data Result = Success | Failure [[String]]
+
+instance Semigroup Result where
+ Success <> y = y
+ x <> Success = x
+ Failure xs <> Failure ys = Failure (xs ++ ys)
+
+instance Monoid Result where
+ mempty = Success
+
+data RunS = RunS
+ { depth :: Int
+ , currentSeed :: Word64
+ , context :: [String]
+ }
+
+putMsg :: String -> ReaderT RunS IO ()
+putMsg s = do
+ n <- depth <$> ask
+ liftIO . putStrLn $ replicate (n * 2) ' ' ++ s
+
+nest :: String -> ReaderT RunS IO a -> ReaderT RunS IO a
+nest c = local (\s -> s { depth = depth s + 1, context = c : context s })
+
+runPropertyCheck :: PropertyCheck -> ReaderT RunS IO Result
+runPropertyCheck (PropertyBinaryOp ok desc s1 s2) =
+ if ok
+ then return Success
+ else do
+ ctx <- context <$> ask
+ let msg = "Failure: " ++ s1 ++ " " ++ desc ++ " " ++ s2
+ putMsg msg
+ return (Failure [msg : ctx])
+runPropertyCheck (PropertyAnd a b) =
+ (<>) <$> runPropertyCheck a <*> runPropertyCheck b
+
+runProperty :: Iterations -> Property -> ReaderT RunS IO Result
+runProperty (Iterations iters) (Prop p) = do
+ startingSeed <- currentSeed <$> ask
+ loop iters startingSeed
+ where
+ loop 0 _ = do
+ putMsg ("Passed " ++ show iters ++ " iterations")
+ return Success
+ loop n s = do
+ let (pt, s') = runState (runGen p) s
+ (ss, pc) = getCheck pt
+ res <- runPropertyCheck pc
+ case res of
+ Success -> loop (n - 1) s'
+ Failure msgs -> do
+ let msg = "With arguments " ++ intercalate ", " ss ++ " (Seed: " ++ show s ++ ")"
+ putMsg msg
+ return (Failure (map (msg :) msgs))
+
+-- | Run a single 'Test', accumulating all failures.
+runTestInternal :: Iterations -> Test -> ReaderT RunS IO Result
+runTestInternal iters (Group name tests) = do
+ let label = "Group " ++ name
+ putMsg label
+ env <- ask
+ nest label $ do
+ -- Compute initial seed for each test in the group, based on the
+ -- index of the test in the group.
+ let runOne idx t = do
+ let !s = snd $ stepLCG (currentSeed env + fromIntegral idx)
+ local (\e -> e { currentSeed = s }) (runTestInternal iters t)
+ mconcat <$> traverse (uncurry runOne) (zip [1..] tests)
+
+runTestInternal iters (Property name p) = do
+ let label = "Running " ++ name
+ putMsg label
+ nest label (runProperty iters (property p))
+
+showStack :: Int -> [String] -> String
+showStack _ [] = ""
+showStack n (s:ss) = replicate n ' ' ++ s ++ "\n" ++ showStack (n + 2) ss
+
+-- | Standard @main@ entry point for tests using 'MiniQuickCheck'.
+--
+-- Reads a 'Word64' seed from the first command-line argument, then
+-- delegates to 'runTests'.
+runTestsMain :: Iterations -> Test -> IO ()
+runTestsMain iters t = do
+ args <- getArgs
+ seed <- case args of
+ [arg] -> case readMaybe arg of
+ Just s -> pure s
+ Nothing -> die $ "Invalid seed: " ++ show arg
+ _ -> die "Usage: <test-name> <seed>"
+ runTests iters seed t
+
+runTests :: Iterations -> Word64 -> Test -> IO ()
+runTests iters seed t = do
+ res <- runReaderT (runTestInternal iters t) (RunS 0 seed [])
+ case res of
+ Success -> return ()
+ Failure tests -> do
+ putStrLn $ "Seed: " ++ show seed
+ putStrLn $ "These tests failed:\n"
+ ++ intercalate "\n" (map (showStack 0 . reverse) tests)
+ exitFailure
+
+--------------------------------------------------------------------------------
+-- Random number generation (linear congruences)
+
+-- Constants from Knuth's MMIX
+
+lcgMultiplier :: Word64
+lcgMultiplier = 6364136223846793005
+lcgIncrement :: Word64
+lcgIncrement = 1442695040888963407
+
+-- | Pure step function for the linear congruential generator
+stepLCG :: Word64 -> (Word64, Word64)
+stepLCG s =
+ let s' = s * lcgMultiplier + lcgIncrement
+ in (s', s')
+
+--------------------------------------------------------------------------------
+-- Primitive generators
+
+-- | Generate a uniformly random 'Word64'.
+arbitraryWord64 :: Gen Word64
+arbitraryWord64 = Gen $ state stepLCG
+
+-- | Generate a uniformly random 'Int64' (bit-reinterpretation of a Word64).
+arbitraryInt64 :: Gen Int64
+arbitraryInt64 = fromIntegral <$> arbitraryWord64
+
+-- | Shrink a random 'Int64' down to a smaller integral type.
+integralDownsize :: (Integral a, FiniteBits a) => Int64 -> a
+integralDownsize = wordDownsize . fromIntegral
+
+-- | Shrink a random 'Word64' down to a smaller integral type.
+wordDownsize :: forall a. (Integral a, FiniteBits a) => Word64 -> a
+wordDownsize w =
+ fromIntegral (w `shiftR` (64 - finiteBitSize (undefined :: a)))
+ -- take the higher bits (more random with our LCG)
+
+--------------------------------------------------------------------------------
+-- Basic Arbitrary instances
+
+instance Arbitrary Bool where
+ arbitrary = ( == 1 ) . ( `shiftR` 63 ) <$> arbitraryWord64
+
+instance Arbitrary Word64 where
+ arbitrary = arbitraryWord64
+instance Arbitrary Word32 where
+ arbitrary = wordDownsize <$> arbitraryWord64
+instance Arbitrary Word16 where
+ arbitrary = wordDownsize <$> arbitraryWord64
+instance Arbitrary Word8 where
+ arbitrary = wordDownsize <$> arbitraryWord64
+instance Arbitrary Word where
+ arbitrary = fromIntegral <$> arbitraryWord64
+
+instance Arbitrary Int64 where
+ arbitrary = arbitraryInt64
+instance Arbitrary Int32 where
+ arbitrary = integralDownsize <$> arbitraryInt64
+instance Arbitrary Int16 where
+ arbitrary = integralDownsize <$> arbitraryInt64
+instance Arbitrary Int8 where
+ arbitrary = integralDownsize <$> arbitraryInt64
+instance Arbitrary Int where
+ arbitrary = fromIntegral <$> arbitraryInt64
+
+-- | Generates a natural number with at most 192 bits set.
+instance Arbitrary Natural where
+ arbitrary = do
+ cx <- ( `shiftR` 62 ) <$> arbitraryWord64
+ n1 <- fromIntegral <$> arbitraryWord64
+ n2 <- fromIntegral <$> arbitraryWord64
+ n3 <- fromIntegral <$> arbitraryWord64
+
+ pure $ case cx of
+ 0 -> n1
+ 1 -> (n1 `shiftL` 64) .|. n2
+ _ -> (n1 `shiftL` 128) .|. (n2 `shiftL` 64) .|. n3
+
+-- | Generates an integer with at most 192 bits set.
+instance Arbitrary Integer where
+ arbitrary = do
+ nat <- arbitrary @Natural
+ neg <- arbitrary @Bool
+
+ pure $
+ if neg
+ then negate (fromIntegral nat)
+ else fromIntegral nat
+
+instance Arbitrary Char where
+ arbitrary = do
+ let high = fromIntegral (fromEnum (maxBound :: Char)) :: Word
+ x <- arbitrary
+ return (toEnum . fromIntegral $ x `mod` (high + 1))
+
+--------------------------------------------------------------------------------
+-- Useful newtypes for different Arbitrary instances
+
+-- | Wrapper for non-zero values.
+newtype NonZero a = NonZero { getNonZero :: a }
+ deriving (Eq, Ord, Bounded, Show)
+
+-- | Generator that rejects zero values.
+nonZero :: (Arbitrary a, Num a, Eq a) => Gen (NonZero a)
+nonZero = do
+ x <- arbitrary
+ if x == 0 then nonZero else pure (NonZero x)
+
+instance (Arbitrary a, Num a, Eq a) => Arbitrary (NonZero a) where
+ arbitrary = nonZero
+
+-- | Shift amount bounded to @[0, finiteBitSize - 1]@.
+newtype BoundedShiftAmount a = BoundedShiftAmount { getBoundedShiftAmount :: Int }
+ deriving (Eq, Ord, Show)
+
+instance FiniteBits a => Arbitrary (BoundedShiftAmount a) where
+ arbitrary = do
+ x <- arbitrary
+ let w = finiteBitSize (undefined :: a)
+ pure $ BoundedShiftAmount (abs x `mod` w)
+
+-- | @a `BoundedBy` n@ represents numbers with maximum absolute value @n@ (inclusive).
+type BoundedBy :: Type -> Nat -> Type
+newtype BoundedBy a n = BoundedBy { getBoundedBy :: a }
+ deriving (Eq, Ord, Show)
+
+instance
+ forall n a
+ . ( KnownNat n, Integral a, Arbitrary a )
+ => Arbitrary ( a `BoundedBy` n ) where
+ arbitrary = BoundedBy . (`rem` (n + 1)) <$> arbitrary
+ where
+ n :: a
+ n = fromIntegral $ natVal @n Proxy
=====================================
testsuite/tests/numeric/should_run/all.T
=====================================
@@ -3,8 +3,6 @@
# extra run flags
# expected process return value, if not zero
-import random
-
# some bugs only surface with -O, omitting optasm may cause them to
# slip into releases! (e.g. #26711)
setTestOpts(when(have_ncg(), extra_ways(['optasm'])))
@@ -89,7 +87,14 @@ test('T20291', normal, compile_and_run, [''])
test('T22282', normal, compile_and_run, [''])
test('T22671', js_fragile(24259), compile_and_run, [''])
# the high run timeout multiplier exists because of timeouts with the wasm backend
-test('foundation', [run_timeout_multiplier(4), js_fragile(24259), extra_ways(['optasm','ghci','ghci-opt']), extra_run_opts(str(random.getrandbits(64)))], compile_and_run, ['-fno-break-points'])
+test('foundation',
+ [ mini_quickcheck
+ , run_timeout_multiplier(4)
+ , js_fragile(24259)
+ , extra_ways(['optasm','ghci','ghci-opt'])
+ ]
+ , multimod_compile_and_run
+ , ['foundation', '-fno-break-points'])
test('T24066', normal, compile_and_run, [''])
test('div01', normal, compile_and_run, [''])
test('T24245', normal, compile_and_run, [''])
=====================================
testsuite/tests/numeric/should_run/foundation.hs
=====================================
@@ -23,252 +23,20 @@ module Main
( main
) where
-import Data.Array.Byte
-import Data.Bits (Bits((.&.), bit), FiniteBits, finiteBitSize)
-import Data.Word
+import Data.Bits (Bits((.&.), bit))
+import Data.Function (on)
import Data.Int
-import GHC.Natural
import Data.Typeable
+import Data.Word
import GHC.Int
-import GHC.Word
-import Data.Function
+import GHC.Natural
import GHC.Prim
-import Control.Monad.Reader
-import Data.List (intercalate)
-import System.Environment (getArgs)
-import Text.Read (readMaybe)
-import Unsafe.Coerce
import GHC.Types
-import Data.Char
-import System.Exit
-
+import GHC.Word
import qualified GHC.Internal.PrimopWrappers as Wrapper
-import qualified GHC.Internal.Prim as Primop
-
-newtype Gen a = Gen { runGen :: (ReaderT LCGGen IO a) }
- deriving newtype (Functor, Applicative, Monad)
-
-class Arbitrary a where
- arbitrary :: Gen a
-
-class IsProperty p where
- property :: p -> Property
+import qualified GHC.Internal.Prim as Primop
-data PropertyCheck = PropertyBinaryOp Bool String String String
- | PropertyAnd PropertyCheck PropertyCheck
-
-instance IsProperty PropertyCheck where
- property check = Prop $ pure (PropertyEOA check)
-
-data PropertyTestArg = PropertyEOA PropertyCheck
- | PropertyArg String PropertyTestArg
-
-getCheck :: PropertyTestArg -> ([String], PropertyCheck)
-getCheck (PropertyEOA pc) = ([], pc)
-getCheck (PropertyArg s pta ) = let (ss, pc) = getCheck pta in (s:ss, pc)
-
-data Property = Prop { unProp :: Gen PropertyTestArg }
-
-instance (Show a, Arbitrary a, IsProperty prop) => IsProperty (a -> prop) where
- property p = forAll arbitrary p
-
--- | Running a generator for a specific type under a property
-forAll :: (Show a, IsProperty prop) => Gen a -> (a -> prop) -> Property
-forAll generator tst = Prop $ do
- a <- generator
- augment a <$> unProp (property (tst a))
- where
- augment a arg = PropertyArg (show a) arg
-
--- | A property that check for equality of its 2 members.
-propertyCompare :: (Show a) => String -> (a -> a -> Bool) -> a -> a -> PropertyCheck
-propertyCompare s f a b =
- let sa = show a
- sb = show b
- in PropertyBinaryOp (a `f` b) s sa sb
-
-(===) :: (Show a, Eq a) => a -> a -> PropertyCheck
-(===) = propertyCompare "==" (==)
-infix 4 ===
-
-propertyAnd = PropertyAnd
-
-
-data Test where
- Group :: String -> [Test] -> Test
- Property :: IsProperty prop => String -> prop -> Test
-
-
-arbitraryInt64 :: Gen Int64
-arbitraryInt64 = Gen $ do
- h <- ask
- W64# w <- liftIO (randomWord64 h)
- return (I64# (unsafeCoerce# w))
-
-integralDownsize :: (Integral a) => Int64 -> a
-integralDownsize = fromIntegral
-
-wordDownsize :: (Integral a) => Word64 -> a
-wordDownsize = fromIntegral
-
-arbitraryWord64 :: Gen Word64
-arbitraryWord64 = Gen $ do
- h <- ask
- liftIO (randomWord64 h)
-
-nonZero :: (Arbitrary a, Num a, Eq a) => Gen (NonZero a)
-nonZero = do
- x <- arbitrary
- if x == 0 then nonZero else pure $ NonZero x
-
-newtype NonZero a = NonZero { getNonZero :: a }
- deriving (Eq,Ord,Bounded,Show)
-
-instance (Arbitrary a, Num a, Eq a) => Arbitrary (NonZero a) where
- arbitrary = nonZero
-
--- | A newtype for shift amounts that are bounded by @wordSize - 1@
-newtype BoundedShiftAmount a = BoundedShiftAmount {getBoundedShiftAmount :: Int}
- deriving (Eq, Ord, Show)
-
-instance (FiniteBits a) => Arbitrary (BoundedShiftAmount a) where
- arbitrary = do
- x <- arbitrary
- let widthBits = finiteBitSize (undefined :: a)
- pure $ BoundedShiftAmount (abs x `mod` widthBits)
-
-instance Arbitrary Natural where
- arbitrary = integralDownsize . (`mod` 10000) . abs <$> arbitraryInt64
-
--- Bounded by Int64
-instance Arbitrary Integer where
- arbitrary = fromIntegral <$> arbitraryInt64
-
-instance Arbitrary Int where
- arbitrary = int64ToInt <$> arbitraryInt64
-instance Arbitrary Word where
- arbitrary = word64ToWord <$> arbitraryWord64
-instance Arbitrary Word64 where
- arbitrary = arbitraryWord64
-instance Arbitrary Word32 where
- arbitrary = wordDownsize <$> arbitraryWord64
-instance Arbitrary Word16 where
- arbitrary = wordDownsize <$> arbitraryWord64
-instance Arbitrary Word8 where
- arbitrary = wordDownsize <$> arbitraryWord64
-instance Arbitrary Int64 where
- arbitrary = arbitraryInt64
-instance Arbitrary Int32 where
- arbitrary = integralDownsize <$> arbitraryInt64
-instance Arbitrary Int16 where
- arbitrary = integralDownsize <$> arbitraryInt64
-instance Arbitrary Int8 where
- arbitrary = integralDownsize <$> arbitraryInt64
-
-instance Arbitrary Char where
- arbitrary = do
- let high = fromIntegral $ fromEnum (maxBound :: Char) :: Word
- (x::Word) <- arbitrary
- let x' = mod x high
- return (chr $ fromIntegral x')
-
-int64ToInt :: Int64 -> Int
-int64ToInt (I64# i) = I# (int64ToInt# i)
-
-
-word64ToWord :: Word64 -> Word
-word64ToWord (W64# i) = W# (word64ToWord# i)
-
-
-data RunS = RunS { depth :: Int, rg :: LCGGen, context :: [String] }
-
-newtype LCGGen = LCGGen { randomWord64 :: IO Word64 }
-
-data LCGParams = LCGParams { seed :: Word64, a :: Word64, c :: Word64, m :: Word64 }
-
-newLCGGen :: LCGParams -> IO LCGGen
-newLCGGen LCGParams {seed = W64# seed#, ..} = do
- MutableByteArray mba# <- IO $ \s0 -> case newByteArray# 8# s0 of
- (# s1, mba# #) -> case writeWord64Array# mba# 0# seed# s1 of
- s2 -> (# s2, MutableByteArray mba# #)
- pure $ LCGGen $ IO $ \s0 -> case readWord64Array# mba# 0# s0 of
- (# s1, old_val# #) ->
- let old_val = W64# old_val#
- !new_val@(W64# new_val#) = (old_val * a + c) `mod` m
- in case writeWord64Array# mba# 0# new_val# s1 of
- s2 -> (# s2, new_val #)
-
-runPropertyCheck (PropertyBinaryOp res desc s1 s2) =
- if res then return Success
- else do
- ctx <- context <$> ask
- let msg = "Failure: " ++ s1 ++ desc ++ s2
- putMsg msg
- return (Failure [msg : ctx])
-runPropertyCheck (PropertyAnd a1 a2) = (<>) <$> runPropertyCheck a1 <*> runPropertyCheck a2
-
-runProperty :: Property -> ReaderT RunS IO Result
-runProperty (Prop p) = do
- let iterations = 1000 :: Int
- loop iterations iterations
- where
- loop iterations 0 = do
- putMsg ("Passed " ++ show iterations ++ " iterations")
- return Success
- loop iterations n = do
- h <- rg <$> ask
- p <- liftIO (runReaderT (runGen p) h)
- let (ss, pc) = getCheck p
- res <- runPropertyCheck pc
- case res of
- Success -> loop iterations (n-1)
- Failure msgs -> do
- let msg = ("With arguments " ++ intercalate ", " ss)
- putMsg msg
- return (Failure (map (msg :) msgs))
-
-data Result = Success | Failure [[String]]
-
-instance Semigroup Result where
- Success <> x = x
- x <> Success = x
- (Failure xs) <> (Failure ys) = Failure (xs ++ ys)
-
-instance Monoid Result where
- mempty = Success
-
-putMsg s = do
- n <- depth <$> ask
- liftIO . putStrLn $ replicate (n * 2) ' ' ++ s
-
-
-nest c = local (\s -> s { depth = depth s + 1, context = c : context s })
-
-runTestInternal :: Test -> ReaderT RunS IO Result
-runTestInternal (Group name tests) = do
- let label = ("Group " ++ name)
- putMsg label
- nest label (mconcat <$> mapM runTestInternal tests)
-runTestInternal (Property name p) = do
- let label = ("Running " ++ name)
- putMsg label
- nest label $ runProperty (property p)
-
-
-runTests :: Word64 -> Test -> IO ()
-runTests seed t = do
- -- These params are the same ones as glibc uses.
- h <- newLCGGen (LCGParams { seed, m = 2 ^ (31 :: Int), a = 1103515245, c = 12345 })
- res <- runReaderT (runTestInternal t) (RunS 0 h [])
- case res of
- Success -> return ()
- Failure tests -> do
- putStrLn $ "Seed: " ++ show seed
- putStrLn $ "These tests failed: \n" ++ intercalate " \n" (map (showStack 0 . reverse) tests)
- exitFailure
-
-showStack _ [] = ""
-showStack n (s:ss) = replicate n ' ' ++ s ++ "\n" ++ showStack (n + 2) ss
+import MiniQuickCheck
-------------------------------------------------------------------------------
@@ -325,8 +93,11 @@ testOperatorPrecedence _ = Group "Precedence"
, Property "+ and * (2)" $ \(a :: a) (b :: a) (c :: a) -> (a * b + c) === ((a * b) + c)
, Property "- and * (1)" $ \(a :: a) (b :: a) (c :: a) -> (a - b * c) === (a - (b * c))
, Property "- and * (2)" $ \(a :: a) (b :: a) (c :: a) -> (a * b - c) === ((a * b) - c)
- , Property "* and ^ (1)" $ \(a :: a) (b :: Natural) (c :: a) -> (a ^ b * c) === ((a ^ b) * c)
- , Property "* and ^ (2)" $ \(a :: a) (c :: Natural) (b :: a) -> (a * b ^ c) === (a * (b ^ c))
+
+ -- Bound the exponent to avoid OOM errors e.g.
+ -- GNU MP: Cannot allocate memory (size=4294938656)
+ , Property "* and ^ (1)" $ \(a :: a) (BoundedBy b :: Natural `BoundedBy` 100) (c :: a) -> (a ^ b * c) === ((a ^ b) * c)
+ , Property "* and ^ (2)" $ \(a :: a) (BoundedBy c :: Natural `BoundedBy` 100) (b :: a) -> (a * b ^ c) === (a * (b ^ c))
]
@@ -454,19 +225,8 @@ instance TestPrimop LowerBitsAreDefined where
twoNonZero :: (a -> a -> b) -> a -> NonZero a -> b
twoNonZero f x (NonZero y) = f x y
-getSeedFromArgs :: IO Word64
-getSeedFromArgs = do
- args <- getArgs
- case args of
- [arg] -> case readMaybe arg of
- Just seed -> pure seed
- Nothing -> die $ "Invalid seed (expected Word64): " ++ show arg
- _ -> die "Usage: foundation <seed>"
-
main :: IO ()
-main = do
- seed <- getSeedFromArgs
- runTests seed (Group "ALL" [testNumberRefs, testPrimops])
+main = runTestsMain (Iterations 1000) (Group "ALL" [testNumberRefs, testPrimops])
-- Test an interpreted primop vs a compiled primop
testPrimops = Group "primop"
=====================================
testsuite/tests/simd/should_run/all.T
=====================================
@@ -80,7 +80,7 @@ test('simd002', [], compile_and_run, [''])
test('simd003', [], compile_and_run, [''])
test('simd004', [], compile_and_run, ['-O2'])
test('simd005', [], compile_and_run, [''])
-test('simd006', [], compile_and_run, [''])
+test('simd006', [mini_quickcheck], multimod_compile_and_run, ['simd006', ''])
test('simd007', [], compile_and_run, [''])
test('simd008', [], compile_and_run, [''])
test('simd009', [ req_th
=====================================
testsuite/tests/simd/should_run/simd006.hs
=====================================
@@ -1,161 +1,79 @@
-{-# LANGUAGE MagicHash #-}
-{-# LANGUAGE UnboxedTuples #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
-{-# LANGUAGE MagicHash #-}
-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
--- QuickCheck testing for SIMD operations
+-- QuickCheck-like property tests for SIMD vector operations.
-module Main
- ( main
- ) where
+module Main (main) where
-import Data.Word
-import Data.Int
-import GHC.Natural
import Data.Coerce
-import Data.Typeable
-import Data.Proxy
-import GHC.Int
-import GHC.Word
-import Data.Function
+import Data.Word
import GHC.Prim
-import Control.Monad.Reader
-import System.IO
-import Foreign.Marshal.Alloc
-import Foreign.Storable
-import Foreign.Ptr
-import Data.List (intercalate)
-import Data.IORef
-import Unsafe.Coerce
import GHC.Exts
import GHC.Float
( castFloatToWord32 , castWord32ToFloat
, castDoubleToWord64, castWord64ToDouble
)
+import MiniQuickCheck
+--------------------------------------------------------------------------------
+-- Scalar wrappers that use bit-equality to test for equality.
-newtype Gen a = Gen { runGen :: (ReaderT LCGGen IO a) }
- deriving newtype (Functor, Applicative, Monad)
-
-class Arbitrary a where
- arbitrary :: Gen a
-
-class IsProperty p where
- property :: p -> Property
-
-data PropertyCheck = PropertyBinaryOp Bool String String String
- | PropertyAnd PropertyCheck PropertyCheck
-
-instance IsProperty PropertyCheck where
- property check = Prop $ pure (PropertyEOA check)
-
-data PropertyTestArg = PropertyEOA PropertyCheck
- | PropertyArg String PropertyTestArg
-
-getCheck :: PropertyTestArg -> ([String], PropertyCheck)
-getCheck (PropertyEOA pc) = ([], pc)
-getCheck (PropertyArg s pta ) = let (ss, pc) = getCheck pta in (s:ss, pc)
-
-data Property = Prop { unProp :: Gen PropertyTestArg }
-
-instance (Show a, Arbitrary a, IsProperty prop) => IsProperty (a -> prop) where
- property p = forAll arbitrary p
-
--- | Running a generator for a specific type under a property
-forAll :: (Show a, IsProperty prop) => Gen a -> (a -> prop) -> Property
-forAll generator tst = Prop $ do
- a <- generator
- augment a <$> unProp (property (tst a))
- where
- augment a arg = PropertyArg (show a) arg
-
--- | A property that check for equality of its 2 members.
-propertyCompare :: (Show a) => String -> (a -> a -> Bool) -> a -> a -> PropertyCheck
-propertyCompare s f a b =
- let sa = show a
- sb = show b
- in PropertyBinaryOp (a `f` b) s sa sb
-
-(===) :: (Show a, Eq a) => a -> a -> PropertyCheck
-(===) = propertyCompare "==" (==)
-infix 4 ===
-
-propertyAnd = PropertyAnd
-
-
-data Test where
- Group :: String -> [Test] -> Test
- Property :: IsProperty prop => String -> prop -> Test
-
+newtype FloatNT = FloatNT Float
+ deriving newtype (Show, Num)
-arbitraryInt64 :: Gen Int64
-arbitraryInt64 = Gen $ do
- h <- ask
- W64# w <- liftIO (randomWord64 h)
- return (I64# (unsafeCoerce# w))
+instance Eq FloatNT where
+ FloatNT f1 == FloatNT f2 = castFloatToWord32 f1 == castFloatToWord32 f2
-integralDownsize :: (Integral a) => Int64 -> a
-integralDownsize = fromIntegral
+instance Arbitrary FloatNT where
+ arbitrary = FloatNT . castWord32ToFloat <$> arbitrary
-wordDownsize :: (Integral a) => Word64 -> a
-wordDownsize = fromIntegral
+newtype DoubleNT = DoubleNT Double
+ deriving newtype (Show, Num)
-arbitraryWord64 :: Gen Word64
-arbitraryWord64 = Gen $ do
- h <- ask
- liftIO (randomWord64 h)
+instance Eq DoubleNT where
+ DoubleNT d1 == DoubleNT d2 = castDoubleToWord64 d1 == castDoubleToWord64 d2
+instance Arbitrary DoubleNT where
+ arbitrary = DoubleNT . castWord64ToDouble <$> arbitrary
-instance Arbitrary Word64 where
- arbitrary = arbitraryWord64
-instance Arbitrary Word32 where
- arbitrary = wordDownsize <$> arbitraryWord64
+--------------------------------------------------------------------------------
+-- Min/max for the types under test
class HasMinMax a where
mini, maxi :: a -> a -> a
+
instance HasMinMax FloatNT where
mini (FloatNT (F# f1)) (FloatNT (F# f2)) = FloatNT (F# (minFloat# f1 f2))
maxi (FloatNT (F# f1)) (FloatNT (F# f2)) = FloatNT (F# (maxFloat# f1 f2))
+
instance HasMinMax DoubleNT where
mini (DoubleNT (D# d1)) (DoubleNT (D# d2)) = DoubleNT (D# (minDouble# d1 d2))
maxi (DoubleNT (D# d1)) (DoubleNT (D# d2)) = DoubleNT (D# (maxDouble# d1 d2))
-newtype FloatNT = FloatNT Float
- deriving newtype (Show, Num)
-instance Eq FloatNT where
- FloatNT f1 == FloatNT f2 =
- castFloatToWord32 f1 == castFloatToWord32 f2
-instance Arbitrary FloatNT where
- arbitrary = FloatNT . castWord32ToFloat <$> arbitrary
-newtype DoubleNT = DoubleNT Double
- deriving newtype (Show, Num)
-instance Eq DoubleNT where
- DoubleNT d1 == DoubleNT d2 =
- castDoubleToWord64 d1 == castDoubleToWord64 d2
-instance Arbitrary DoubleNT where
- arbitrary = DoubleNT . castWord64ToDouble <$> arbitrary
-
+--------------------------------------------------------------------------------
+-- SIMD vector types
data FloatX4 = FX4# FloatX4#
+
instance Show FloatX4 where
- show (FX4# f) = case (unpackFloatX4# f) of
- (# a, b, c, d #) -> show ((F# a), (F# b), (F# c), (F# d))
+ show (FX4# f) = case unpackFloatX4# f of
+ (# a, b, c, d #) -> show (F# a, F# b, F# c, F# d)
+
instance Eq FloatX4 where
- (FX4# a) == (FX4# b)
- = case (unpackFloatX4# a) of
+ FX4# a == FX4# b
+ = case unpackFloatX4# a of
(# a1, a2, a3, a4 #) ->
- case (unpackFloatX4# b) of
- (# b1, b2, b3, b4 #) -> FloatNT (F# a1) == FloatNT (F# b1) &&
- FloatNT (F# a2) == FloatNT (F# b2) &&
- FloatNT (F# a3) == FloatNT (F# b3) &&
- FloatNT (F# a4) == FloatNT (F# b4)
+ case unpackFloatX4# b of
+ (# b1, b2, b3, b4 #) ->
+ FloatNT (F# a1) == FloatNT (F# b1) &&
+ FloatNT (F# a2) == FloatNT (F# b2) &&
+ FloatNT (F# a3) == FloatNT (F# b3) &&
+ FloatNT (F# a4) == FloatNT (F# b4)
+
instance Arbitrary FloatX4 where
arbitrary = do
FloatNT (F# f1) <- arbitrary
@@ -163,52 +81,59 @@ instance Arbitrary FloatX4 where
FloatNT (F# f3) <- arbitrary
FloatNT (F# f4) <- arbitrary
return $ FX4# (packFloatX4# (# f1, f2, f3, f4 #))
+
instance Num FloatX4 where
- FX4# x + FX4# y =
- FX4# ( x `plusFloatX4#` y )
- FX4# x - FX4# y =
- FX4# ( x `minusFloatX4#` y )
- negate ( FX4# x ) = FX4# ( negateFloatX4# x )
- FX4# x * FX4# y =
- FX4# ( x `timesFloatX4#` y )
- abs = error "no"
- signum = error "no"
- fromInteger = error "no"
+ FX4# x + FX4# y = FX4# (x `plusFloatX4#` y)
+ FX4# x - FX4# y = FX4# (x `minusFloatX4#` y)
+ negate (FX4# x) = FX4# (negateFloatX4# x)
+ FX4# x * FX4# y = FX4# (x `timesFloatX4#` y)
+ abs = error "FloatX4: no abs"
+ signum = error "FloatX4: no signum"
+ fromInteger = error "FloatX4: no fromInteger"
+
instance HasMinMax FloatX4 where
mini (FX4# a) (FX4# b) = FX4# (minFloatX4# a b)
maxi (FX4# a) (FX4# b) = FX4# (maxFloatX4# a b)
+--------------------------------------------------------------------------------
+
data DoubleX2 = DX2# DoubleX2#
+
instance Show DoubleX2 where
- show (DX2# d) = case (unpackDoubleX2# d) of
- (# a, b #) -> show ((D# a), (D# b))
+ show (DX2# d) = case unpackDoubleX2# d of
+ (# a, b #) -> show (D# a, D# b)
+
instance Eq DoubleX2 where
- (DX2# a) == (DX2# b)
- = case (unpackDoubleX2# a) of
+ DX2# a == DX2# b
+ = case unpackDoubleX2# a of
(# a1, a2 #) ->
- case (unpackDoubleX2# b) of
- (# b1, b2 #) -> DoubleNT (D# a1) == DoubleNT (D# b1) &&
- DoubleNT (D# a2) == DoubleNT (D# b2)
+ case unpackDoubleX2# b of
+ (# b1, b2 #) ->
+ DoubleNT (D# a1) == DoubleNT (D# b1) &&
+ DoubleNT (D# a2) == DoubleNT (D# b2)
+
instance Arbitrary DoubleX2 where
arbitrary = do
DoubleNT (D# d1) <- arbitrary
DoubleNT (D# d2) <- arbitrary
return $ DX2# (packDoubleX2# (# d1, d2 #))
+
instance Num DoubleX2 where
- DX2# x + DX2# y =
- DX2# ( x `plusDoubleX2#` y )
- DX2# x - DX2# y =
- DX2# ( x `minusDoubleX2#` y )
- negate ( DX2# x ) = DX2# ( negateDoubleX2# x )
- DX2# x * DX2# y =
- DX2# ( x `timesDoubleX2#` y )
- abs = error "no"
- signum = error "no"
- fromInteger = error "no"
+ DX2# x + DX2# y = DX2# (x `plusDoubleX2#` y)
+ DX2# x - DX2# y = DX2# (x `minusDoubleX2#` y)
+ negate (DX2# x) = DX2# (negateDoubleX2# x)
+ DX2# x * DX2# y = DX2# (x `timesDoubleX2#` y)
+ abs = error "DoubleX2: no abs"
+ signum = error "DoubleX2: no signum"
+ fromInteger = error "DoubleX2: no fromInteger"
+
instance HasMinMax DoubleX2 where
mini (DX2# a) (DX2# b) = DX2# (minDoubleX2# a b)
maxi (DX2# a) (DX2# b) = DX2# (maxDoubleX2# a b)
+--------------------------------------------------------------------------------
+-- Expression language for generating random expressions over vector types.
+
data Expr a where
Lit :: a -> Expr a
Add :: Expr a -> Expr a -> Expr a
@@ -218,11 +143,12 @@ data Expr a where
Min :: Expr a -> Expr a -> Expr a
Max :: Expr a -> Expr a -> Expr a
deriving (Show, Eq)
+
fmapExpr :: (a -> b) -> Expr a -> Expr b
-fmapExpr f (Lit a) = Lit (f a)
+fmapExpr f (Lit a) = Lit (f a)
fmapExpr f (Add a b) = Add (fmapExpr f a) (fmapExpr f b)
fmapExpr f (Sub a b) = Sub (fmapExpr f a) (fmapExpr f b)
-fmapExpr f (Neg a) = Neg (fmapExpr f a)
+fmapExpr f (Neg a) = Neg (fmapExpr f a)
fmapExpr f (Mul a b) = Mul (fmapExpr f a) (fmapExpr f b)
fmapExpr f (Min a b) = Min (fmapExpr f a) (fmapExpr f b)
fmapExpr f (Max a b) = Max (fmapExpr f a) (fmapExpr f b)
@@ -240,75 +166,16 @@ instance Arbitrary a => Arbitrary (Expr a) where
_ -> Lit <$> arbitrary
eval :: (Num a, HasMinMax a) => Expr a -> a
-eval (Lit a) = a
+eval (Lit a) = a
eval (Add a b) = eval a + eval b
eval (Sub a b) = eval a - eval b
-eval (Neg a) = negate (eval a)
+eval (Neg a) = negate (eval a)
eval (Mul a b) = eval a * eval b
eval (Min a b) = mini (eval a) (eval b)
eval (Max a b) = maxi (eval a) (eval b)
-int64ToInt :: Int64 -> Int
-int64ToInt (I64# i) = I# (int64ToInt# i)
-
-
-word64ToWord :: Word64 -> Word
-word64ToWord (W64# i) = W# (word64ToWord# i)
-
-
-data RunS = RunS { depth :: Int, rg :: LCGGen }
-
-newtype LCGGen = LCGGen { randomWord64 :: IO Word64 }
-
-data LCGParams = LCGParams { seed :: Word64, a :: Word64, c :: Word64, m :: Word64 }
-
-newLCGGen :: LCGParams -> IO LCGGen
-newLCGGen LCGParams{..} = do
- var <- newIORef (fromIntegral seed)
- return $ LCGGen $ do
- atomicModifyIORef' var (\old_v -> let new_val = (old_v * a + c) `mod` m in (new_val, new_val))
-
-
-runPropertyCheck (PropertyBinaryOp res desc s1 s2) =
- if res then return True else (putMsg ("Failure: " ++ s1 ++ desc ++ s2) >> return False)
-runPropertyCheck (PropertyAnd a1 a2) = (&&) <$> runPropertyCheck a1 <*> runPropertyCheck a2
-
-runProperty :: Property -> ReaderT RunS IO ()
-runProperty (Prop p) = do
- let iterations = 100
- loop iterations iterations
- where
- loop iterations 0 = putMsg ("Passed " ++ show iterations ++ " iterations")
- loop iterations n = do
- h <- rg <$> ask
- p <- liftIO (runReaderT (runGen p) h)
- let (ss, pc) = getCheck p
- res <- runPropertyCheck pc
- if res then loop iterations (n-1)
- else putMsg ("With arguments " ++ intercalate ", " ss)
-
-putMsg s = do
- n <- depth <$> ask
- liftIO . putStrLn $ replicate (n * 2) ' ' ++ s
-
-nest = local (\s -> s { depth = depth s + 1 })
-
-runTestInternal :: Test -> ReaderT RunS IO ()
-runTestInternal (Group name tests) = do
- putMsg ("Group " ++ name)
- nest (mapM_ runTestInternal tests)
-runTestInternal (Property name p) = do
- putMsg ("Running " ++ name)
- nest $ runProperty (property p)
-
-
-runTests :: Test -> IO ()
-runTests t = do
- -- These params are the same ones as glibc uses.
- h <- newLCGGen (LCGParams { seed = 1238123213, m = 2^31, a = 1103515245, c = 12345 })
- runReaderT (runTestInternal t) (RunS 0 h)
-
--------------------------------------------------------------------------------
+--------------------------------------------------------------------------------
+-- Test groups
testFloatX4 :: Test
testFloatX4 = Group "FloatX4"
@@ -324,15 +191,12 @@ testFloatX4 = Group "FloatX4"
unpack :: FloatX4 -> ( FloatNT, FloatNT, FloatNT, FloatNT )
unpack (FX4# f) = case unpackFloatX4# f of
(# f1, f2, f3, f4 #) -> coerce ( F# f1, F# f2, F# f3, F# f4 )
+
get1, get2, get3, get4 :: FloatX4 -> FloatNT
- get1 (FX4# f) = case unpackFloatX4# f of
- (# f1, _, _, _ #) -> FloatNT (F# f1)
- get2 (FX4# f) = case unpackFloatX4# f of
- (# _, f2, _, _ #) -> FloatNT (F# f2)
- get3 (FX4# f) = case unpackFloatX4# f of
- (# _, _, f3, _ #) -> FloatNT (F# f3)
- get4 (FX4# f) = case unpackFloatX4# f of
- (# _, _, _, f4 #) -> FloatNT (F# f4)
+ get1 (FX4# f) = case unpackFloatX4# f of (# f1, _, _, _ #) -> FloatNT (F# f1)
+ get2 (FX4# f) = case unpackFloatX4# f of (# _, f2, _, _ #) -> FloatNT (F# f2)
+ get3 (FX4# f) = case unpackFloatX4# f of (# _, _, f3, _ #) -> FloatNT (F# f3)
+ get4 (FX4# f) = case unpackFloatX4# f of (# _, _, _, f4 #) -> FloatNT (F# f4)
testDoubleX2 :: Test
testDoubleX2 = Group "DoubleX2"
@@ -346,16 +210,15 @@ testDoubleX2 = Group "DoubleX2"
unpack :: DoubleX2 -> ( DoubleNT, DoubleNT )
unpack (DX2# d) = case unpackDoubleX2# d of
(# d1, d2 #) -> coerce ( D# d1, D# d2 )
+
get1, get2 :: DoubleX2 -> DoubleNT
get1 (DX2# d) = case unpackDoubleX2# d of
- (# d1, _ #) -> DoubleNT (D# d1)
+ (# d1, _ #) -> DoubleNT (D# d1)
get2 (DX2# d) = case unpackDoubleX2# d of
- (# _, d2 #) -> DoubleNT (D# d2)
+ (# _, d2 #) -> DoubleNT (D# d2)
testSIMD :: Test
-testSIMD = Group "ALL"
- [ testFloatX4
- , testDoubleX2
- ]
+testSIMD = Group "ALL" [testFloatX4, testDoubleX2]
-main = runTests testSIMD
+main :: IO ()
+main = runTestsMain (Iterations 100) testSIMD
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2d30f7d3400bdaa7760bfea2501ab30…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2d30f7d3400bdaa7760bfea2501ab30…
You're receiving this email because of your account on gitlab.haskell.org.
1
0