[Git][ghc/ghc][wip/supersven/riscv-fix-switch-jump-tables] 16 commits: driver: Use ModuleGraph for oneshot and --make mode
by Sven Tennie (＠supersven) 23 Apr '25
by Sven Tennie (＠supersven) 23 Apr '25
23 Apr '25
Sven Tennie pushed to branch wip/supersven/riscv-fix-switch-jump-tables at Glasgow Haskell Compiler / GHC
Commits:
d47bf776 by Matthew Pickering at 2025-04-14T16:44:41+01:00
driver: Use ModuleGraph for oneshot and --make mode
This patch uses the `hsc_mod_graph` field for both oneshot and --make
mode. Therefore, if part of the compiler requires usage of the module
graph, you do so in a uniform way for the two different modes.
The `ModuleGraph` describes the relationship between the modules in the
home package and units in external packages. The `ModuleGraph` can be
queried when information about the transitive closure of a package is
needed. For example, the primary use of the ModuleGraph from within the
compiler is in the loader, which needs to know the transitive closure of
a module so it can load all the relevant objects for evaluation.
In --make mode, downsweep computes the ModuleGraph before any
compilation starts.
In oneshot mode, a thunk is created at the start of compilation, which
when forced will compute the module graph beneath the current module.
The thunk is only forced at the moment when the user uses Template
Haskell.
Finally, there are some situations where we need to discover what
dependencies to load but haven't loaded a module graph at all. In this
case, there is a fallback which computes the transitive closure on the
fly and doesn't cache the result. Presumably if you are going to call
getLinkDeps a lot, you would compute the right ModuleGraph before you
started.
Importantly, this removes the ExternalModuleGraph abstraction. This was quite
awkward to work with since it stored information about the home package
inside the EPS.
This patch will also be very useful when implementing explicit level
imports, which requires more significant use of the module graph in
order to determine which level instances are available at.
Towards #25795
-------------------------
Metric Decrease:
MultiLayerModulesTH_Make
MultiLayerModulesTH_OneShot
-------------------------
- - - - -
395e0ad1 by sheaf at 2025-04-16T12:33:26-04:00
base: remove .Internal modules (e.g. GHC.TypeLits)
This commit removes the following internal modules from base,
as per CLC proposal 217:
- GHC.TypeNats.Internal
- GHC.TypeLits.Internal
- GHC.ExecutionStack.Internal
Fixes #25007
- - - - -
e0f3ff11 by Patrick at 2025-04-17T04:31:12-04:00
Refactor Handling of Multiple Default Declarations
Fixes: #25912, #25914, #25934
Previously, GHC discarded all loaded defaults (tcg_default) when local
defaults were encountered during typechecking. According to the
exportable-named-default proposal (sections 2.4.2 and 2.4.3), local
defaults should be merged into tcg_default, retaining any defaults
already present while overriding where necessary.
Key Changes:
* Introduce DefaultProvenance to track the origin of default declarations
(local, imported, or built-in), replacing the original cd_module
in ClassDefaults with cd_provenance :: DefaultProvenance.
* Rename tcDefaults to tcDefaultDecls, limiting its responsibility to only
converting renamed class defaults into ClassDefaults.
* Add extendDefaultEnvWithLocalDefaults to merge local defaults into the
environment, with proper duplication checks:
- Duplicate local defaults for a class trigger an error.
- Local defaults override imported or built-in defaults.
* Update and add related notes: Note [Builtin class defaults],
Note [DefaultProvenance].
* Add regression tests: T25912, T25914, T25934.
Thanks sam and simon for the help on this patch.
Co-authored-by: sheaf <sam.derbyshire(a)gmail.com>
- - - - -
386f1854 by Teo Camarasu at 2025-04-17T04:31:55-04:00
template-haskell: Remove `addrToByteArrayName` and `addrToByteArray`
These were part of the implementation of the `Lift ByteArray` instance and were errornously exported because this module lacked an explicit export list. They have no usages on Hackage.
Resolves #24782
- - - - -
b96e2f77 by Sylvain Henry at 2025-04-18T20:46:33-04:00
RTS: remove target info and fix host info (#24058)
The RTS isn't a compiler, hence it doesn't have a target and we remove
the reported target info displayed by "+RTS --info". We also fix the
host info displayed by "+RTS --info": the host of the RTS is the
RTS-building compiler's target, not the compiler's host (wrong when
doing cross-compilation).
- - - - -
6d9965f4 by Sylvain Henry at 2025-04-18T20:46:33-04:00
RTS: remove build info
As per the discussion in !13967, there is no reason to tag the RTS with
information about the build platform.
- - - - -
d52e9b3f by Vladislav Zavialov at 2025-04-18T20:47:15-04:00
Diagnostics: remove the KindMismatch constructor (#25957)
The KindMismatch constructor was only used as an intermediate
representation in pretty-printing.
Its removal addresses a problem detected by the "codes" test case:
[GHC-89223] is untested (constructor = KindMismatch)
In a concious deviation from the usual procedure, the error code
GHC-89223 is removed entirely rather than marked as Outdated.
The reason is that it never was user-facing in the first place.
- - - - -
e2f2f9d0 by Vladislav Zavialov at 2025-04-20T10:53:39-04:00
Add name for -Wunusable-unpack-pragmas
This warning had no name or flag and was triggered unconditionally.
Now it is part of -Wdefault.
In GHC.Tc.TyCl.tcTyClGroupsPass's strict mode, we now have to
force-enable this warning to ensure that detection of flawed groups
continues to work even if the user disables the warning with the
-Wno-unusable-unpack-pragmas option. Test case: T3990c
Also, the misnamed BackpackUnpackAbstractType is now called
UnusableUnpackPragma.
- - - - -
6caa6508 by Adam Gundry at 2025-04-20T10:54:22-04:00
Fix specialisation of incoherent instances (fixes #25883)
GHC normally assumes that class constraints are canonical, meaning that
the specialiser is allowed to replace one dictionary argument with another
provided that they have the same type. The `-fno-specialise-incoherents`
flag alters INCOHERENT instance definitions so that they will prevent
specialisation in some cases, by inserting `nospec`.
This commit fixes a bug in 7124e4ad76d98f1fc246ada4fd7bf64413ff2f2e, which
treated some INCOHERENT instance matches as if `-fno-specialise-incoherents`
was in effect, thereby unnecessarily preventing specialisation. In addition
it updates the relevant `Note [Rules for instance lookup]` and adds a new
`Note [Canonicity for incoherent matches]`.
- - - - -
0426fd6c by Adam Gundry at 2025-04-20T10:54:23-04:00
Add regression test for #23429
- - - - -
eec96527 by Adam Gundry at 2025-04-20T10:54:23-04:00
user's guide: update specification of overlapping/incoherent instances
The description of the instance resolution algorithm in the user's
guide was slightly out of date, because it mentioned in-scope given
constraints only at the end, whereas the implementation checks for
their presence before any of the other steps.
This also adds a warning to the user's guide about the impact of
incoherent instances on specialisation, and more clearly documents
some of the other effects of `-XIncoherentInstances`.
- - - - -
a00eeaec by Matthew Craven at 2025-04-20T10:55:03-04:00
Fix bytecode generation for `tagToEnum# <LITERAL>`
Fixes #25975.
- - - - -
2e204269 by Andreas Klebinger at 2025-04-22T12:20:41+02:00
Simplifier: Constant fold invald tagToEnum# calls to bottom expr.
When applying tagToEnum# to a out-of-range value it's best to simply
constant fold it to a bottom expression. That potentially allows more
dead code elimination and makes debugging easier.
Fixes #25976
- - - - -
7250fc0c by Matthew Pickering at 2025-04-22T16:24:04-04:00
Move -fno-code note into Downsweep module
This note was left behind when all the code which referred to it was
moved into the GHC.Driver.Downsweep module
- - - - -
d2dc89b4 by Matthew Pickering at 2025-04-22T16:24:04-04:00
Apply editing notes to Note [-fno-code mode] suggested by sheaf
These notes were suggested in https://gitlab.haskell.org/ghc/ghc/-/merge_requests/14241
- - - - -
7a6d5536 by Sven Tennie at 2025-04-23T11:16:46+02:00
RV64: Introduce J instruction (non-local jumps) and don't deallocate stack slots for J_TBL (#25738)
J_TBL result in local jumps, there should not deallocate stack slots
(see Note [extra spill slots].)
J is for non-local jumps, these may need to deallocate stack slots.
- - - - -
103 changed files:
- compiler/GHC/CmmToAsm/RV64/CodeGen.hs
- compiler/GHC/CmmToAsm/RV64/Instr.hs
- compiler/GHC/CmmToAsm/RV64/Ppr.hs
- compiler/GHC/Core/InstEnv.hs
- compiler/GHC/Core/Opt/ConstantFold.hs
- compiler/GHC/Driver/Downsweep.hs
- compiler/GHC/Driver/Env.hs
- compiler/GHC/Driver/Env/Types.hs
- compiler/GHC/Driver/Errors/Ppr.hs
- compiler/GHC/Driver/Errors/Types.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/MakeAction.hs
- + compiler/GHC/Driver/Messager.hs
- compiler/GHC/Driver/Pipeline.hs-boot
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Linker/Deps.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Runtime/Loader.hs
- compiler/GHC/StgToByteCode.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Gen/Default.hs
- compiler/GHC/Tc/Gen/Export.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/Solver/Dict.hs
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/Tc/Utils/Env.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Types/DefaultEnv.hs
- compiler/GHC/Types/Error/Codes.hs
- compiler/GHC/Unit/External.hs
- compiler/GHC/Unit/Finder.hs
- − compiler/GHC/Unit/Module/External/Graph.hs
- compiler/GHC/Unit/Module/Graph.hs
- compiler/GHC/Unit/Module/ModNodeKey.hs
- compiler/ghc.cabal.in
- configure.ac
- docs/users_guide/9.14.1-notes.rst
- docs/users_guide/exts/instances.rst
- docs/users_guide/using-warnings.rst
- hadrian/src/Settings/Packages.hs
- libraries/base/base.cabal.in
- libraries/base/changelog.md
- − libraries/base/src/GHC/ExecutionStack/Internal.hs
- − libraries/base/src/GHC/TypeLits/Internal.hs
- − libraries/base/src/GHC/TypeNats/Internal.hs
- libraries/template-haskell/Language/Haskell/TH/Syntax.hs
- libraries/template-haskell/changelog.md
- rts/RtsUtils.c
- testsuite/ghc-config/ghc-config.hs
- + testsuite/tests/bytecode/T25975.hs
- + testsuite/tests/bytecode/T25975.stdout
- testsuite/tests/bytecode/all.T
- + testsuite/tests/default/T25912.hs
- + testsuite/tests/default/T25912.stdout
- + testsuite/tests/default/T25912_helper.hs
- + testsuite/tests/default/T25914.hs
- + testsuite/tests/default/T25934.hs
- testsuite/tests/default/all.T
- testsuite/tests/default/default-fail03.stderr
- testsuite/tests/diagnostic-codes/codes.stdout
- + testsuite/tests/ghc-api/fixed-nodes/InterfaceModuleGraph.hs
- + testsuite/tests/ghc-api/fixed-nodes/InterfaceModuleGraph.stdout
- testsuite/tests/ghc-api/fixed-nodes/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/interface-stability/template-haskell-exports.stdout
- testsuite/tests/linters/notes.stdout
- testsuite/tests/module/mod58.stderr
- testsuite/tests/plugins/defaulting-plugin/DefaultLifted.hs
- testsuite/tests/simplCore/should_compile/Makefile
- testsuite/tests/simplCore/should_compile/T23307c.stderr
- + testsuite/tests/simplCore/should_compile/T25883.hs
- + testsuite/tests/simplCore/should_compile/T25883.substr-simpl
- + testsuite/tests/simplCore/should_compile/T25883b.hs
- + testsuite/tests/simplCore/should_compile/T25883b.substr-simpl
- + testsuite/tests/simplCore/should_compile/T25883c.hs
- + testsuite/tests/simplCore/should_compile/T25883c.substr-simpl
- + testsuite/tests/simplCore/should_compile/T25883d.hs
- + testsuite/tests/simplCore/should_compile/T25883d.stderr
- + testsuite/tests/simplCore/should_compile/T25883d_import.hs
- + testsuite/tests/simplCore/should_compile/T25976.hs
- + testsuite/tests/simplCore/should_compile/T3990c.hs
- + testsuite/tests/simplCore/should_compile/T3990c.stdout
- testsuite/tests/simplCore/should_compile/all.T
- testsuite/tests/simplCore/should_fail/T25672.stderr
- + testsuite/tests/simplCore/should_run/T23429.hs
- + testsuite/tests/simplCore/should_run/T23429.stdout
- testsuite/tests/simplCore/should_run/all.T
- testsuite/tests/typecheck/should_compile/T7050.stderr
- testsuite/tests/typecheck/should_fail/T3966.stderr
- + testsuite/tests/typecheck/should_fail/T3966b.hs
- + testsuite/tests/typecheck/should_fail/T3966b.stderr
- testsuite/tests/typecheck/should_fail/all.T
- testsuite/tests/unboxedsums/unpack_sums_5.stderr
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0f976bb84be8649ab5baf6d8476f06…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0f976bb84be8649ab5baf6d8476f06…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/andreask/interpreter_primops] Interpreter: Add limited support for direct primop evaluation.
by Andreas Klebinger (＠AndreasK) 23 Apr '25
by Andreas Klebinger (＠AndreasK) 23 Apr '25
23 Apr '25
Andreas Klebinger pushed to branch wip/andreask/interpreter_primops at Glasgow Haskell Compiler / GHC
Commits:
cb7afe6e by Andreas Klebinger at 2025-04-23T10:41:55+02:00
Interpreter: Add limited support for direct primop evaluation.
This commit adds support for a number of primops directly
to the interpreter. This avoids the indirection of going
through the primop wrapper for those primops speeding interpretation
of optimized code up massively.
Code involving IntSet runs about 25% faster with optimized core and these
changes. For core without breakpoints it's even more pronouced and I
saw reductions in runtime by up to 50%.
Running GHC itself in the interpreter was sped up by ~15% through this
change.
Additionally this comment does a few other related changes:
testsuite:
* Run foundation test in ghci and ghci-opt ways to test these
primops.
* Vastly expand the foundation test to cover all basic primops
by comparing result with the result of calling the wrapper.
Interpreter:
* When pushing arguments for interpreted primops extend each argument to
at least word with when pushing. This avoids some issues with big
endian. We can revisit this if it causes performance issues.
* Restructure the stack chunk check logic. There are now macros for
read accesses which might cross stack chunk boundries and macros which
omit the checks which are used when we statically know we access an
address in the current stack chunk.
- - - - -
12 changed files:
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/ByteCode/Asm.hs
- compiler/GHC/ByteCode/Instr.hs
- compiler/GHC/StgToByteCode.hs
- rts/Disassembler.c
- rts/Interpreter.c
- rts/include/rts/Bytecodes.h
- testsuite/tests/numeric/should_run/all.T
- testsuite/tests/numeric/should_run/foundation.hs
- testsuite/tests/numeric/should_run/foundation.stdout
- utils/genprimopcode/Main.hs
- utils/genprimopcode/Syntax.hs
Changes:
=====================================
compiler/GHC/Builtin/primops.txt.pp
=====================================
@@ -147,6 +147,7 @@ defaults
fixity = Nothing
vector = []
deprecated_msg = {} -- A non-empty message indicates deprecation
+ div_like = False -- Second argument expected to be non zero - used for tests
-- Note [When do out-of-line primops go in primops.txt.pp]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -296,14 +297,18 @@ primop Int8MulOp "timesInt8#" GenPrimOp Int8# -> Int8# -> Int8#
primop Int8QuotOp "quotInt8#" GenPrimOp Int8# -> Int8# -> Int8#
with
effect = CanFail
+ div_like = True
primop Int8RemOp "remInt8#" GenPrimOp Int8# -> Int8# -> Int8#
with
effect = CanFail
+ div_like = True
+
primop Int8QuotRemOp "quotRemInt8#" GenPrimOp Int8# -> Int8# -> (# Int8#, Int8# #)
with
effect = CanFail
+ div_like = True
primop Int8SllOp "uncheckedShiftLInt8#" GenPrimOp Int8# -> Int# -> Int8#
primop Int8SraOp "uncheckedShiftRAInt8#" GenPrimOp Int8# -> Int# -> Int8#
@@ -342,14 +347,17 @@ primop Word8MulOp "timesWord8#" GenPrimOp Word8# -> Word8# -> Word8#
primop Word8QuotOp "quotWord8#" GenPrimOp Word8# -> Word8# -> Word8#
with
effect = CanFail
+ div_like = True
primop Word8RemOp "remWord8#" GenPrimOp Word8# -> Word8# -> Word8#
with
effect = CanFail
+ div_like = True
primop Word8QuotRemOp "quotRemWord8#" GenPrimOp Word8# -> Word8# -> (# Word8#, Word8# #)
with
effect = CanFail
+ div_like = True
primop Word8AndOp "andWord8#" GenPrimOp Word8# -> Word8# -> Word8#
with commutable = True
@@ -400,14 +408,17 @@ primop Int16MulOp "timesInt16#" GenPrimOp Int16# -> Int16# -> Int16#
primop Int16QuotOp "quotInt16#" GenPrimOp Int16# -> Int16# -> Int16#
with
effect = CanFail
+ div_like = True
primop Int16RemOp "remInt16#" GenPrimOp Int16# -> Int16# -> Int16#
with
effect = CanFail
+ div_like = True
primop Int16QuotRemOp "quotRemInt16#" GenPrimOp Int16# -> Int16# -> (# Int16#, Int16# #)
with
effect = CanFail
+ div_like = True
primop Int16SllOp "uncheckedShiftLInt16#" GenPrimOp Int16# -> Int# -> Int16#
primop Int16SraOp "uncheckedShiftRAInt16#" GenPrimOp Int16# -> Int# -> Int16#
@@ -446,14 +457,17 @@ primop Word16MulOp "timesWord16#" GenPrimOp Word16# -> Word16# -> Word16#
primop Word16QuotOp "quotWord16#" GenPrimOp Word16# -> Word16# -> Word16#
with
effect = CanFail
+ div_like = True
primop Word16RemOp "remWord16#" GenPrimOp Word16# -> Word16# -> Word16#
with
effect = CanFail
+ div_like = True
primop Word16QuotRemOp "quotRemWord16#" GenPrimOp Word16# -> Word16# -> (# Word16#, Word16# #)
with
effect = CanFail
+ div_like = True
primop Word16AndOp "andWord16#" GenPrimOp Word16# -> Word16# -> Word16#
with commutable = True
@@ -504,14 +518,17 @@ primop Int32MulOp "timesInt32#" GenPrimOp Int32# -> Int32# -> Int32#
primop Int32QuotOp "quotInt32#" GenPrimOp Int32# -> Int32# -> Int32#
with
effect = CanFail
+ div_like = True
primop Int32RemOp "remInt32#" GenPrimOp Int32# -> Int32# -> Int32#
with
effect = CanFail
+ div_like = True
primop Int32QuotRemOp "quotRemInt32#" GenPrimOp Int32# -> Int32# -> (# Int32#, Int32# #)
with
effect = CanFail
+ div_like = True
primop Int32SllOp "uncheckedShiftLInt32#" GenPrimOp Int32# -> Int# -> Int32#
primop Int32SraOp "uncheckedShiftRAInt32#" GenPrimOp Int32# -> Int# -> Int32#
@@ -550,14 +567,17 @@ primop Word32MulOp "timesWord32#" GenPrimOp Word32# -> Word32# -> Word32#
primop Word32QuotOp "quotWord32#" GenPrimOp Word32# -> Word32# -> Word32#
with
effect = CanFail
+ div_like = True
primop Word32RemOp "remWord32#" GenPrimOp Word32# -> Word32# -> Word32#
with
effect = CanFail
+ div_like = True
primop Word32QuotRemOp "quotRemWord32#" GenPrimOp Word32# -> Word32# -> (# Word32#, Word32# #)
with
effect = CanFail
+ div_like = True
primop Word32AndOp "andWord32#" GenPrimOp Word32# -> Word32# -> Word32#
with commutable = True
@@ -608,10 +628,12 @@ primop Int64MulOp "timesInt64#" GenPrimOp Int64# -> Int64# -> Int64#
primop Int64QuotOp "quotInt64#" GenPrimOp Int64# -> Int64# -> Int64#
with
effect = CanFail
+ div_like = True
primop Int64RemOp "remInt64#" GenPrimOp Int64# -> Int64# -> Int64#
with
effect = CanFail
+ div_like = True
primop Int64SllOp "uncheckedIShiftL64#" GenPrimOp Int64# -> Int# -> Int64#
primop Int64SraOp "uncheckedIShiftRA64#" GenPrimOp Int64# -> Int# -> Int64#
@@ -650,10 +672,12 @@ primop Word64MulOp "timesWord64#" GenPrimOp Word64# -> Word64# -> Word64#
primop Word64QuotOp "quotWord64#" GenPrimOp Word64# -> Word64# -> Word64#
with
effect = CanFail
+ div_like = True
primop Word64RemOp "remWord64#" GenPrimOp Word64# -> Word64# -> Word64#
with
effect = CanFail
+ div_like = True
primop Word64AndOp "and64#" GenPrimOp Word64# -> Word64# -> Word64#
with commutable = True
@@ -737,6 +761,7 @@ primop IntQuotOp "quotInt#" GenPrimOp
zero.
}
with effect = CanFail
+ div_like = True
primop IntRemOp "remInt#" GenPrimOp
Int# -> Int# -> Int#
@@ -744,11 +769,13 @@ primop IntRemOp "remInt#" GenPrimOp
behavior is undefined if the second argument is zero.
}
with effect = CanFail
+ div_like = True
primop IntQuotRemOp "quotRemInt#" GenPrimOp
Int# -> Int# -> (# Int#, Int# #)
{Rounds towards zero.}
with effect = CanFail
+ div_like = True
primop IntAndOp "andI#" GenPrimOp Int# -> Int# -> Int#
{Bitwise "and".}
@@ -886,19 +913,23 @@ primop WordMul2Op "timesWord2#" GenPrimOp
primop WordQuotOp "quotWord#" GenPrimOp Word# -> Word# -> Word#
with effect = CanFail
+ div_like = True
primop WordRemOp "remWord#" GenPrimOp Word# -> Word# -> Word#
with effect = CanFail
+ div_like = True
primop WordQuotRemOp "quotRemWord#" GenPrimOp
Word# -> Word# -> (# Word#, Word# #)
with effect = CanFail
+ div_like = True
primop WordQuotRem2Op "quotRemWord2#" GenPrimOp
Word# -> Word# -> Word# -> (# Word#, Word# #)
{ Takes high word of dividend, then low word of dividend, then divisor.
Requires that high word < divisor.}
with effect = CanFail
+ div_like = True
primop WordAndOp "and#" GenPrimOp Word# -> Word# -> Word#
with commutable = True
@@ -4166,6 +4197,7 @@ primop VecQuotOp "quot#" GenPrimOp
Do not expect high performance. }
with effect = CanFail
vector = INT_VECTOR_TYPES
+ div_like = True
primop VecRemOp "rem#" GenPrimOp
VECTOR -> VECTOR -> VECTOR
@@ -4175,6 +4207,8 @@ primop VecRemOp "rem#" GenPrimOp
Do not expect high performance. }
with effect = CanFail
vector = INT_VECTOR_TYPES
+ div_like = True
+
primop VecNegOp "negate#" GenPrimOp
VECTOR -> VECTOR
=====================================
compiler/GHC/ByteCode/Asm.hs
=====================================
@@ -732,6 +732,143 @@ assembleI platform i = case i of
CCALL off m_addr i -> do np <- addr m_addr
emit_ bci_CCALL [wOp off, Op np, SmallOp i]
PRIMCALL -> emit_ bci_PRIMCALL []
+
+ OP_ADD w -> case w of
+ W64 -> emit_ bci_OP_ADD_64 []
+ W32 -> emit_ bci_OP_ADD_32 []
+ W16 -> emit_ bci_OP_ADD_16 []
+ W8 -> emit_ bci_OP_ADD_08 []
+ _ -> unsupported_width
+ OP_SUB w -> case w of
+ W64 -> emit_ bci_OP_SUB_64 []
+ W32 -> emit_ bci_OP_SUB_32 []
+ W16 -> emit_ bci_OP_SUB_16 []
+ W8 -> emit_ bci_OP_SUB_08 []
+ _ -> unsupported_width
+ OP_AND w -> case w of
+ W64 -> emit_ bci_OP_AND_64 []
+ W32 -> emit_ bci_OP_AND_32 []
+ W16 -> emit_ bci_OP_AND_16 []
+ W8 -> emit_ bci_OP_AND_08 []
+ _ -> unsupported_width
+ OP_XOR w -> case w of
+ W64 -> emit_ bci_OP_XOR_64 []
+ W32 -> emit_ bci_OP_XOR_32 []
+ W16 -> emit_ bci_OP_XOR_16 []
+ W8 -> emit_ bci_OP_XOR_08 []
+ _ -> unsupported_width
+ OP_OR w -> case w of
+ W64 -> emit_ bci_OP_OR_64 []
+ W32 -> emit_ bci_OP_OR_32 []
+ W16 -> emit_ bci_OP_OR_16 []
+ W8 -> emit_ bci_OP_OR_08 []
+ _ -> unsupported_width
+ OP_NOT w -> case w of
+ W64 -> emit_ bci_OP_NOT_64 []
+ W32 -> emit_ bci_OP_NOT_32 []
+ W16 -> emit_ bci_OP_NOT_16 []
+ W8 -> emit_ bci_OP_NOT_08 []
+ _ -> unsupported_width
+ OP_NEG w -> case w of
+ W64 -> emit_ bci_OP_NEG_64 []
+ W32 -> emit_ bci_OP_NEG_32 []
+ W16 -> emit_ bci_OP_NEG_16 []
+ W8 -> emit_ bci_OP_NEG_08 []
+ _ -> unsupported_width
+ OP_MUL w -> case w of
+ W64 -> emit_ bci_OP_MUL_64 []
+ W32 -> emit_ bci_OP_MUL_32 []
+ W16 -> emit_ bci_OP_MUL_16 []
+ W8 -> emit_ bci_OP_MUL_08 []
+ _ -> unsupported_width
+ OP_SHL w -> case w of
+ W64 -> emit_ bci_OP_SHL_64 []
+ W32 -> emit_ bci_OP_SHL_32 []
+ W16 -> emit_ bci_OP_SHL_16 []
+ W8 -> emit_ bci_OP_SHL_08 []
+ _ -> unsupported_width
+ OP_ASR w -> case w of
+ W64 -> emit_ bci_OP_ASR_64 []
+ W32 -> emit_ bci_OP_ASR_32 []
+ W16 -> emit_ bci_OP_ASR_16 []
+ W8 -> emit_ bci_OP_ASR_08 []
+ _ -> unsupported_width
+ OP_LSR w -> case w of
+ W64 -> emit_ bci_OP_LSR_64 []
+ W32 -> emit_ bci_OP_LSR_32 []
+ W16 -> emit_ bci_OP_LSR_16 []
+ W8 -> emit_ bci_OP_LSR_08 []
+ _ -> unsupported_width
+
+ OP_NEQ w -> case w of
+ W64 -> emit_ bci_OP_NEQ_64 []
+ W32 -> emit_ bci_OP_NEQ_32 []
+ W16 -> emit_ bci_OP_NEQ_16 []
+ W8 -> emit_ bci_OP_NEQ_08 []
+ _ -> unsupported_width
+ OP_EQ w -> case w of
+ W64 -> emit_ bci_OP_EQ_64 []
+ W32 -> emit_ bci_OP_EQ_32 []
+ W16 -> emit_ bci_OP_EQ_16 []
+ W8 -> emit_ bci_OP_EQ_08 []
+ _ -> unsupported_width
+
+ OP_U_LT w -> case w of
+ W64 -> emit_ bci_OP_U_LT_64 []
+ W32 -> emit_ bci_OP_U_LT_32 []
+ W16 -> emit_ bci_OP_U_LT_16 []
+ W8 -> emit_ bci_OP_U_LT_08 []
+ _ -> unsupported_width
+ OP_S_LT w -> case w of
+ W64 -> emit_ bci_OP_S_LT_64 []
+ W32 -> emit_ bci_OP_S_LT_32 []
+ W16 -> emit_ bci_OP_S_LT_16 []
+ W8 -> emit_ bci_OP_S_LT_08 []
+ _ -> unsupported_width
+ OP_U_GE w -> case w of
+ W64 -> emit_ bci_OP_U_GE_64 []
+ W32 -> emit_ bci_OP_U_GE_32 []
+ W16 -> emit_ bci_OP_U_GE_16 []
+ W8 -> emit_ bci_OP_U_GE_08 []
+ _ -> unsupported_width
+ OP_S_GE w -> case w of
+ W64 -> emit_ bci_OP_S_GE_64 []
+ W32 -> emit_ bci_OP_S_GE_32 []
+ W16 -> emit_ bci_OP_S_GE_16 []
+ W8 -> emit_ bci_OP_S_GE_08 []
+ _ -> unsupported_width
+ OP_U_GT w -> case w of
+ W64 -> emit_ bci_OP_U_GT_64 []
+ W32 -> emit_ bci_OP_U_GT_32 []
+ W16 -> emit_ bci_OP_U_GT_16 []
+ W8 -> emit_ bci_OP_U_GT_08 []
+ _ -> unsupported_width
+ OP_S_GT w -> case w of
+ W64 -> emit_ bci_OP_S_GT_64 []
+ W32 -> emit_ bci_OP_S_GT_32 []
+ W16 -> emit_ bci_OP_S_GT_16 []
+ W8 -> emit_ bci_OP_S_GT_08 []
+ _ -> unsupported_width
+ OP_U_LE w -> case w of
+ W64 -> emit_ bci_OP_U_LE_64 []
+ W32 -> emit_ bci_OP_U_LE_32 []
+ W16 -> emit_ bci_OP_U_LE_16 []
+ W8 -> emit_ bci_OP_U_LE_08 []
+ _ -> unsupported_width
+ OP_S_LE w -> case w of
+ W64 -> emit_ bci_OP_S_LE_64 []
+ W32 -> emit_ bci_OP_S_LE_32 []
+ W16 -> emit_ bci_OP_S_LE_16 []
+ W8 -> emit_ bci_OP_S_LE_08 []
+ _ -> unsupported_width
+
+ OP_INDEX_ADDR w -> case w of
+ W64 -> emit_ bci_OP_INDEX_ADDR_64 []
+ W32 -> emit_ bci_OP_INDEX_ADDR_32 []
+ W16 -> emit_ bci_OP_INDEX_ADDR_16 []
+ W8 -> emit_ bci_OP_INDEX_ADDR_08 []
+ _ -> unsupported_width
+
BRK_FUN arr tick_mod tickx info_mod infox cc ->
do p1 <- ptr (BCOPtrBreakArray arr)
tick_addr <- addr tick_mod
@@ -750,6 +887,7 @@ assembleI platform i = case i of
where
+ unsupported_width = panic "GHC.ByteCode.Asm: Unsupported Width"
emit_ = emit word_size
literal :: Literal -> m Word
=====================================
compiler/GHC/ByteCode/Instr.hs
=====================================
@@ -37,6 +37,7 @@ import GHC.Stg.Syntax
import GHCi.BreakArray (BreakArray)
import Language.Haskell.Syntax.Module.Name (ModuleName)
import GHC.Types.Unique
+import GHC.Cmm.Type (Width)
-- ----------------------------------------------------------------------------
-- Bytecode instructions
@@ -219,6 +220,39 @@ data BCInstr
| PRIMCALL
+ -- Primops - The actual interpreter instructions are flattened into 64/32/16/8 wide
+ -- instructions. But for generating code it's handy to have the width as argument
+ -- to avoid duplication.
+ | OP_ADD !Width
+ | OP_SUB !Width
+ | OP_AND !Width
+ | OP_XOR !Width
+ | OP_MUL !Width
+ | OP_SHL !Width
+ | OP_ASR !Width
+ | OP_LSR !Width
+ | OP_OR !Width
+
+ | OP_NOT !Width
+ | OP_NEG !Width
+
+ | OP_NEQ !Width
+ | OP_EQ !Width
+
+ | OP_U_LT !Width
+ | OP_U_GE !Width
+ | OP_U_GT !Width
+ | OP_U_LE !Width
+
+ | OP_S_LT !Width
+ | OP_S_GE !Width
+ | OP_S_GT !Width
+ | OP_S_LE !Width
+
+ -- Always puts at least a machine word on the stack, with the low part of the stack containing the result.
+ -- We zero extend the result we put on the stack.
+ | OP_INDEX_ADDR !Width
+
-- For doing magic ByteArray passing to foreign calls
| SWIZZLE !WordOff -- to the ptr N words down the stack,
!Int -- add M
@@ -398,6 +432,32 @@ instance Outputable BCInstr where
0x2 -> text "(unsafe)"
_ -> empty)
ppr PRIMCALL = text "PRIMCALL"
+
+ ppr (OP_ADD w) = text "OP_ADD_" <> ppr w
+ ppr (OP_SUB w) = text "OP_SUB_" <> ppr w
+ ppr (OP_AND w) = text "OP_AND_" <> ppr w
+ ppr (OP_XOR w) = text "OP_XOR_" <> ppr w
+ ppr (OP_OR w) = text "OP_OR_" <> ppr w
+ ppr (OP_NOT w) = text "OP_NOT_" <> ppr w
+ ppr (OP_NEG w) = text "OP_NEG_" <> ppr w
+ ppr (OP_MUL w) = text "OP_MUL_" <> ppr w
+ ppr (OP_SHL w) = text "OP_SHL_" <> ppr w
+ ppr (OP_ASR w) = text "OP_ASR_" <> ppr w
+ ppr (OP_LSR w) = text "OP_LSR_" <> ppr w
+
+ ppr (OP_EQ w) = text "OP_EQ_" <> ppr w
+ ppr (OP_NEQ w) = text "OP_NEQ_" <> ppr w
+ ppr (OP_S_LT w) = text "OP_S_LT_" <> ppr w
+ ppr (OP_S_GE w) = text "OP_S_GE_" <> ppr w
+ ppr (OP_S_GT w) = text "OP_S_GT_" <> ppr w
+ ppr (OP_S_LE w) = text "OP_S_LE_" <> ppr w
+ ppr (OP_U_LT w) = text "OP_U_LT_" <> ppr w
+ ppr (OP_U_GE w) = text "OP_U_GE_" <> ppr w
+ ppr (OP_U_GT w) = text "OP_U_GT_" <> ppr w
+ ppr (OP_U_LE w) = text "OP_U_LE_" <> ppr w
+
+ ppr (OP_INDEX_ADDR w) = text "OP_INDEX_ADDR_" <> ppr w
+
ppr (SWIZZLE stkoff n) = text "SWIZZLE " <+> text "stkoff" <+> ppr stkoff
<+> text "by" <+> ppr n
ppr ENTER = text "ENTER"
@@ -506,6 +566,30 @@ bciStackUse RETURN{} = 1 -- pushes stg_ret_X for some X
bciStackUse RETURN_TUPLE{} = 1 -- pushes stg_ret_t header
bciStackUse CCALL{} = 0
bciStackUse PRIMCALL{} = 1 -- pushes stg_primcall
+bciStackUse OP_ADD{} = 0 -- We overestimate, it's -1 actually ...
+bciStackUse OP_SUB{} = 0
+bciStackUse OP_AND{} = 0
+bciStackUse OP_XOR{} = 0
+bciStackUse OP_OR{} = 0
+bciStackUse OP_NOT{} = 0
+bciStackUse OP_NEG{} = 0
+bciStackUse OP_MUL{} = 0
+bciStackUse OP_SHL{} = 0
+bciStackUse OP_ASR{} = 0
+bciStackUse OP_LSR{} = 0
+
+bciStackUse OP_NEQ{} = 0
+bciStackUse OP_EQ{} = 0
+bciStackUse OP_S_LT{} = 0
+bciStackUse OP_S_GT{} = 0
+bciStackUse OP_S_LE{} = 0
+bciStackUse OP_S_GE{} = 0
+bciStackUse OP_U_LT{} = 0
+bciStackUse OP_U_GT{} = 0
+bciStackUse OP_U_LE{} = 0
+bciStackUse OP_U_GE{} = 0
+bciStackUse OP_INDEX_ADDR{} = 0
+
bciStackUse SWIZZLE{} = 0
bciStackUse BRK_FUN{} = 0
=====================================
compiler/GHC/StgToByteCode.hs
=====================================
@@ -58,6 +58,7 @@ import GHC.Builtin.Uniques
import GHC.Data.FastString
import GHC.Utils.Panic
import GHC.Utils.Exception (evaluate)
+import GHC.CmmToAsm.Config (platformWordWidth)
import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, idPrimRepU,
addIdReps, addArgReps,
assertNonVoidIds, assertNonVoidStgArgs )
@@ -733,8 +734,14 @@ schemeT d s p (StgOpApp (StgFCallOp (CCall ccall_spec) _ty) args result_ty)
then generateCCall d s p ccall_spec result_ty args
else unsupportedCConvException
-schemeT d s p (StgOpApp (StgPrimOp op) args _ty)
- = doTailCall d s p (primOpId op) (reverse args)
+schemeT d s p (StgOpApp (StgPrimOp op) args _ty) = do
+ profile <- getProfile
+ let platform = profilePlatform profile
+ case doPrimOp platform op d s p args of
+ -- Can we do this right in the interpreter?
+ Just prim_code -> prim_code
+ -- Otherwise we have to do a call to the primop wrapper instead :(
+ _ -> doTailCall d s p (primOpId op) (reverse args)
schemeT d s p (StgOpApp (StgPrimCallOp (PrimCall label unit)) args result_ty)
= generatePrimCall d s p label (Just unit) result_ty args
@@ -829,6 +836,298 @@ doTailCall init_d s p fn args = do
(final_d, more_push_code) <- push_seq (d + sz) args
return (final_d, push_code `appOL` more_push_code)
+doPrimOp :: Platform
+ -> PrimOp
+ -> StackDepth
+ -> Sequel
+ -> BCEnv
+ -> [StgArg]
+ -> Maybe (BcM BCInstrList)
+doPrimOp platform op init_d s p args =
+ case op of
+ IntAddOp -> sizedPrimOp OP_ADD
+ Int64AddOp -> sizedPrimOp OP_ADD
+ Int32AddOp -> sizedPrimOp OP_ADD
+ Int16AddOp -> sizedPrimOp OP_ADD
+ Int8AddOp -> sizedPrimOp OP_ADD
+ WordAddOp -> sizedPrimOp OP_ADD
+ Word64AddOp -> sizedPrimOp OP_ADD
+ Word32AddOp -> sizedPrimOp OP_ADD
+ Word16AddOp -> sizedPrimOp OP_ADD
+ Word8AddOp -> sizedPrimOp OP_ADD
+ AddrAddOp -> sizedPrimOp OP_ADD
+
+ IntMulOp -> sizedPrimOp OP_MUL
+ Int64MulOp -> sizedPrimOp OP_MUL
+ Int32MulOp -> sizedPrimOp OP_MUL
+ Int16MulOp -> sizedPrimOp OP_MUL
+ Int8MulOp -> sizedPrimOp OP_MUL
+ WordMulOp -> sizedPrimOp OP_MUL
+ Word64MulOp -> sizedPrimOp OP_MUL
+ Word32MulOp -> sizedPrimOp OP_MUL
+ Word16MulOp -> sizedPrimOp OP_MUL
+ Word8MulOp -> sizedPrimOp OP_MUL
+
+ IntSubOp -> sizedPrimOp OP_SUB
+ WordSubOp -> sizedPrimOp OP_SUB
+ Int64SubOp -> sizedPrimOp OP_SUB
+ Int32SubOp -> sizedPrimOp OP_SUB
+ Int16SubOp -> sizedPrimOp OP_SUB
+ Int8SubOp -> sizedPrimOp OP_SUB
+ Word64SubOp -> sizedPrimOp OP_SUB
+ Word32SubOp -> sizedPrimOp OP_SUB
+ Word16SubOp -> sizedPrimOp OP_SUB
+ Word8SubOp -> sizedPrimOp OP_SUB
+ AddrSubOp -> sizedPrimOp OP_SUB
+
+ IntAndOp -> sizedPrimOp OP_AND
+ WordAndOp -> sizedPrimOp OP_AND
+ Word64AndOp -> sizedPrimOp OP_AND
+ Word32AndOp -> sizedPrimOp OP_AND
+ Word16AndOp -> sizedPrimOp OP_AND
+ Word8AndOp -> sizedPrimOp OP_AND
+
+ IntNotOp -> sizedPrimOp OP_NOT
+ WordNotOp -> sizedPrimOp OP_NOT
+ Word64NotOp -> sizedPrimOp OP_NOT
+ Word32NotOp -> sizedPrimOp OP_NOT
+ Word16NotOp -> sizedPrimOp OP_NOT
+ Word8NotOp -> sizedPrimOp OP_NOT
+
+ IntXorOp -> sizedPrimOp OP_XOR
+ WordXorOp -> sizedPrimOp OP_XOR
+ Word64XorOp -> sizedPrimOp OP_XOR
+ Word32XorOp -> sizedPrimOp OP_XOR
+ Word16XorOp -> sizedPrimOp OP_XOR
+ Word8XorOp -> sizedPrimOp OP_XOR
+
+ IntOrOp -> sizedPrimOp OP_OR
+ WordOrOp -> sizedPrimOp OP_OR
+ Word64OrOp -> sizedPrimOp OP_OR
+ Word32OrOp -> sizedPrimOp OP_OR
+ Word16OrOp -> sizedPrimOp OP_OR
+ Word8OrOp -> sizedPrimOp OP_OR
+
+ WordSllOp -> sizedPrimOp OP_SHL
+ Word64SllOp -> sizedPrimOp OP_SHL
+ Word32SllOp -> sizedPrimOp OP_SHL
+ Word16SllOp -> sizedPrimOp OP_SHL
+ Word8SllOp -> sizedPrimOp OP_SHL
+ IntSllOp -> sizedPrimOp OP_SHL
+ Int64SllOp -> sizedPrimOp OP_SHL
+ Int32SllOp -> sizedPrimOp OP_SHL
+ Int16SllOp -> sizedPrimOp OP_SHL
+ Int8SllOp -> sizedPrimOp OP_SHL
+
+ WordSrlOp -> sizedPrimOp OP_LSR
+ Word64SrlOp -> sizedPrimOp OP_LSR
+ Word32SrlOp -> sizedPrimOp OP_LSR
+ Word16SrlOp -> sizedPrimOp OP_LSR
+ Word8SrlOp -> sizedPrimOp OP_LSR
+ IntSrlOp -> sizedPrimOp OP_LSR
+ Int64SrlOp -> sizedPrimOp OP_LSR
+ Int32SrlOp -> sizedPrimOp OP_LSR
+ Int16SrlOp -> sizedPrimOp OP_LSR
+ Int8SrlOp -> sizedPrimOp OP_LSR
+
+ IntSraOp -> sizedPrimOp OP_ASR
+ Int64SraOp -> sizedPrimOp OP_ASR
+ Int32SraOp -> sizedPrimOp OP_ASR
+ Int16SraOp -> sizedPrimOp OP_ASR
+ Int8SraOp -> sizedPrimOp OP_ASR
+
+
+ IntNeOp -> sizedPrimOp OP_NEQ
+ Int64NeOp -> sizedPrimOp OP_NEQ
+ Int32NeOp -> sizedPrimOp OP_NEQ
+ Int16NeOp -> sizedPrimOp OP_NEQ
+ Int8NeOp -> sizedPrimOp OP_NEQ
+ WordNeOp -> sizedPrimOp OP_NEQ
+ Word64NeOp -> sizedPrimOp OP_NEQ
+ Word32NeOp -> sizedPrimOp OP_NEQ
+ Word16NeOp -> sizedPrimOp OP_NEQ
+ Word8NeOp -> sizedPrimOp OP_NEQ
+ AddrNeOp -> sizedPrimOp OP_NEQ
+
+ IntEqOp -> sizedPrimOp OP_EQ
+ Int64EqOp -> sizedPrimOp OP_EQ
+ Int32EqOp -> sizedPrimOp OP_EQ
+ Int16EqOp -> sizedPrimOp OP_EQ
+ Int8EqOp -> sizedPrimOp OP_EQ
+ WordEqOp -> sizedPrimOp OP_EQ
+ Word64EqOp -> sizedPrimOp OP_EQ
+ Word32EqOp -> sizedPrimOp OP_EQ
+ Word16EqOp -> sizedPrimOp OP_EQ
+ Word8EqOp -> sizedPrimOp OP_EQ
+ AddrEqOp -> sizedPrimOp OP_EQ
+ CharEqOp -> sizedPrimOp OP_EQ
+
+ IntLtOp -> sizedPrimOp OP_S_LT
+ Int64LtOp -> sizedPrimOp OP_S_LT
+ Int32LtOp -> sizedPrimOp OP_S_LT
+ Int16LtOp -> sizedPrimOp OP_S_LT
+ Int8LtOp -> sizedPrimOp OP_S_LT
+ WordLtOp -> sizedPrimOp OP_U_LT
+ Word64LtOp -> sizedPrimOp OP_U_LT
+ Word32LtOp -> sizedPrimOp OP_U_LT
+ Word16LtOp -> sizedPrimOp OP_U_LT
+ Word8LtOp -> sizedPrimOp OP_U_LT
+ AddrLtOp -> sizedPrimOp OP_U_LT
+ CharLtOp -> sizedPrimOp OP_U_LT
+
+ IntGeOp -> sizedPrimOp OP_S_GE
+ Int64GeOp -> sizedPrimOp OP_S_GE
+ Int32GeOp -> sizedPrimOp OP_S_GE
+ Int16GeOp -> sizedPrimOp OP_S_GE
+ Int8GeOp -> sizedPrimOp OP_S_GE
+ WordGeOp -> sizedPrimOp OP_U_GE
+ Word64GeOp -> sizedPrimOp OP_U_GE
+ Word32GeOp -> sizedPrimOp OP_U_GE
+ Word16GeOp -> sizedPrimOp OP_U_GE
+ Word8GeOp -> sizedPrimOp OP_U_GE
+ AddrGeOp -> sizedPrimOp OP_U_GE
+ CharGeOp -> sizedPrimOp OP_U_GE
+
+ IntGtOp -> sizedPrimOp OP_S_GT
+ Int64GtOp -> sizedPrimOp OP_S_GT
+ Int32GtOp -> sizedPrimOp OP_S_GT
+ Int16GtOp -> sizedPrimOp OP_S_GT
+ Int8GtOp -> sizedPrimOp OP_S_GT
+ WordGtOp -> sizedPrimOp OP_U_GT
+ Word64GtOp -> sizedPrimOp OP_U_GT
+ Word32GtOp -> sizedPrimOp OP_U_GT
+ Word16GtOp -> sizedPrimOp OP_U_GT
+ Word8GtOp -> sizedPrimOp OP_U_GT
+ AddrGtOp -> sizedPrimOp OP_U_GT
+ CharGtOp -> sizedPrimOp OP_U_GT
+
+ IntLeOp -> sizedPrimOp OP_S_LE
+ Int64LeOp -> sizedPrimOp OP_S_LE
+ Int32LeOp -> sizedPrimOp OP_S_LE
+ Int16LeOp -> sizedPrimOp OP_S_LE
+ Int8LeOp -> sizedPrimOp OP_S_LE
+ WordLeOp -> sizedPrimOp OP_U_LE
+ Word64LeOp -> sizedPrimOp OP_U_LE
+ Word32LeOp -> sizedPrimOp OP_U_LE
+ Word16LeOp -> sizedPrimOp OP_U_LE
+ Word8LeOp -> sizedPrimOp OP_U_LE
+ AddrLeOp -> sizedPrimOp OP_U_LE
+ CharLeOp -> sizedPrimOp OP_U_LE
+
+ IntNegOp -> sizedPrimOp OP_NEG
+ Int64NegOp -> sizedPrimOp OP_NEG
+ Int32NegOp -> sizedPrimOp OP_NEG
+ Int16NegOp -> sizedPrimOp OP_NEG
+ Int8NegOp -> sizedPrimOp OP_NEG
+
+ IntToWordOp -> mk_conv (platformWordWidth platform)
+ WordToIntOp -> mk_conv (platformWordWidth platform)
+ Int8ToWord8Op -> mk_conv W8
+ Word8ToInt8Op -> mk_conv W8
+ Int16ToWord16Op -> mk_conv W16
+ Word16ToInt16Op -> mk_conv W16
+ Int32ToWord32Op -> mk_conv W32
+ Word32ToInt32Op -> mk_conv W32
+ Int64ToWord64Op -> mk_conv W64
+ Word64ToInt64Op -> mk_conv W64
+ IntToAddrOp -> mk_conv (platformWordWidth platform)
+ AddrToIntOp -> mk_conv (platformWordWidth platform)
+ ChrOp -> mk_conv (platformWordWidth platform) -- Int# and Char# are rep'd the same
+ OrdOp -> mk_conv (platformWordWidth platform)
+
+ IndexOffAddrOp_Word8 -> primOpWithRep (OP_INDEX_ADDR W8) W8
+ IndexOffAddrOp_Word16 -> primOpWithRep (OP_INDEX_ADDR W16) W16
+ IndexOffAddrOp_Word32 -> primOpWithRep (OP_INDEX_ADDR W32) W32
+ IndexOffAddrOp_Word64 -> primOpWithRep (OP_INDEX_ADDR W64) W64
+
+ _ -> Nothing
+ where
+ primArg1Width :: StgArg -> Width
+ primArg1Width arg
+ | rep <- (stgArgRepU arg)
+ = case rep of
+ AddrRep -> platformWordWidth platform
+ IntRep -> platformWordWidth platform
+ WordRep -> platformWordWidth platform
+
+ Int64Rep -> W64
+ Word64Rep -> W64
+
+ Int32Rep -> W32
+ Word32Rep -> W32
+
+ Int16Rep -> W16
+ Word16Rep -> W16
+
+ Int8Rep -> W8
+ Word8Rep -> W8
+
+ FloatRep -> unexpectedRep
+ DoubleRep -> unexpectedRep
+
+ BoxedRep{} -> unexpectedRep
+ VecRep{} -> unexpectedRep
+ where
+ unexpectedRep = panic "doPrimOp: Unexpected argument rep"
+
+
+ -- TODO: The slides for the result need to be two words on 32bit for 64bit ops.
+ mkNReturn width
+ | W64 <- width = RETURN L -- L works for 64 bit on any platform
+ | otherwise = RETURN N -- <64bit width, fits in word on all platforms
+
+ mkSlideWords width = if platformWordWidth platform < width then 2 else 1
+
+ -- Push args, execute primop, slide, return_N
+ -- Decides width of operation based on first argument.
+ sizedPrimOp op_inst = Just $ do
+ let width = primArg1Width (head args)
+ prim_code <- mkPrimOpCode init_d s p (op_inst width) $ args
+ let slide = mkSlideW (mkSlideWords width) (bytesToWords platform $ init_d - s) `snocOL` mkNReturn width
+ return $ prim_code `appOL` slide
+
+ -- primOpWithRep op w => operation @op@ resulting in result @w@ wide.
+ primOpWithRep :: BCInstr -> Width -> Maybe (BcM (OrdList BCInstr))
+ primOpWithRep op_inst width = Just $ do
+ prim_code <- mkPrimOpCode init_d s p op_inst $ args
+
+ let slide = mkSlideW (mkSlideWords width) (bytesToWords platform $ init_d - s) `snocOL` mkNReturn width
+ return $ prim_code `appOL` slide
+
+ -- Convert the argument to a result of width @target_width@
+ mk_conv :: Width -> Maybe (BcM (OrdList BCInstr))
+ mk_conv target_width = Just $ do
+ let width = primArg1Width (head args)
+ (push_code, _bytes) <- pushAtom init_d p (head args)
+ let slide = mkSlideW (mkSlideWords width) (bytesToWords platform $ init_d - s) `snocOL` mkNReturn target_width
+ return $ push_code `appOL` slide
+
+-- Push the arguments on the stack and emit the given instruction
+-- Pushes at least one word per non void arg.
+mkPrimOpCode
+ :: StackDepth
+ -> Sequel
+ -> BCEnv
+ -> BCInstr -- The operator
+ -> [StgArg] -- Args, in *reverse* order (must be fully applied)
+ -> BcM BCInstrList
+mkPrimOpCode orig_d _ p op_inst args = app_code
+ where
+ app_code = do
+ profile <- getProfile
+ let _platform = profilePlatform profile
+
+ do_pushery :: StackDepth -> [StgArg] -> BcM BCInstrList
+ do_pushery !d (arg : args) = do
+ (push,arg_bytes) <- pushAtom d p arg
+ more_push_code <- do_pushery (d + arg_bytes) args
+ return (push `appOL` more_push_code)
+ do_pushery !_d [] = do
+ return (unitOL op_inst)
+
+ -- Push on the stack in the reverse order.
+ do_pushery orig_d (reverse args)
+
-- v. similar to CgStackery.findMatch, ToDo: merge
findPushSeq :: [ArgRep] -> (BCInstr, Int, [ArgRep])
findPushSeq (P: P: P: P: P: P: rest)
=====================================
rts/Disassembler.c
=====================================
@@ -62,6 +62,26 @@ disInstr ( StgBCO *bco, int pc )
#error Cannot cope with WORD_SIZE_IN_BITS being nether 32 nor 64
#endif
#define BCO_GET_LARGE_ARG ((instr & bci_FLAG_LARGE_ARGS) ? BCO_READ_NEXT_WORD : BCO_NEXT)
+// For brevity
+#define BELCH_INSTR_NAME(OP_NAME) \
+ case bci_ ## OP_NAME: \
+ debugBelch("OP_NAME\n"); \
+ break
+
+#define BELCH_INSTR_NAME_ALL_SIZES(OP_NAME) \
+ case bci_ ## OP_NAME ## _64: \
+ debugBelch("#OP_NAME" "_64\n"); \
+ break; \
+ case bci_ ## OP_NAME ## _32: \
+ debugBelch("#OP_NAME" "_32\n"); \
+ break; \
+ case bci_ ## OP_NAME ## _16: \
+ debugBelch("#OP_NAME" "_16\n"); \
+ break; \
+ case bci_ ## OP_NAME ## _08: \
+ debugBelch("#OP_NAME" "_08\n"); \
+ break;
+
switch (instr & 0xff) {
case bci_BRK_FUN:
@@ -419,38 +439,20 @@ disInstr ( StgBCO *bco, int pc )
debugBelch("TESTEQ_P %d, fail to %d\n", instrs[pc],
instrs[pc+1]);
pc += 2; break;
- case bci_CASEFAIL:
- debugBelch("CASEFAIL\n" );
- break;
+ BELCH_INSTR_NAME(CASEFAIL);
case bci_JMP:
debugBelch("JMP to %d\n", instrs[pc]);
pc += 1; break;
- case bci_ENTER:
- debugBelch("ENTER\n");
- break;
+ BELCH_INSTR_NAME(ENTER);
+ BELCH_INSTR_NAME(RETURN_P);
+ BELCH_INSTR_NAME(RETURN_N);
+ BELCH_INSTR_NAME(RETURN_F);
+ BELCH_INSTR_NAME(RETURN_D);
+ BELCH_INSTR_NAME(RETURN_L);
+ BELCH_INSTR_NAME(RETURN_V);
+ BELCH_INSTR_NAME(RETURN_T);
- case bci_RETURN_P:
- debugBelch("RETURN_P\n" );
- break;
- case bci_RETURN_N:
- debugBelch("RETURN_N\n" );
- break;
- case bci_RETURN_F:
- debugBelch("RETURN_F\n" );
- break;
- case bci_RETURN_D:
- debugBelch("RETURN_D\n" );
- break;
- case bci_RETURN_L:
- debugBelch("RETURN_L\n" );
- break;
- case bci_RETURN_V:
- debugBelch("RETURN_V\n" );
- break;
- case bci_RETURN_T:
- debugBelch("RETURN_T\n ");
- break;
case bci_BCO_NAME: {
const char *name = (const char*) literals[instrs[pc]];
@@ -459,6 +461,33 @@ disInstr ( StgBCO *bco, int pc )
break;
}
+ BELCH_INSTR_NAME_ALL_SIZES(OP_ADD);
+ BELCH_INSTR_NAME_ALL_SIZES(OP_SUB);
+ BELCH_INSTR_NAME_ALL_SIZES(OP_AND);
+ BELCH_INSTR_NAME_ALL_SIZES(OP_XOR);
+ BELCH_INSTR_NAME_ALL_SIZES(OP_OR);
+ BELCH_INSTR_NAME_ALL_SIZES(OP_NOT);
+ BELCH_INSTR_NAME_ALL_SIZES(OP_NEG);
+ BELCH_INSTR_NAME_ALL_SIZES(OP_MUL);
+ BELCH_INSTR_NAME_ALL_SIZES(OP_SHL);
+ BELCH_INSTR_NAME_ALL_SIZES(OP_ASR);
+ BELCH_INSTR_NAME_ALL_SIZES(OP_LSR);
+
+ BELCH_INSTR_NAME_ALL_SIZES(OP_NEQ);
+ BELCH_INSTR_NAME_ALL_SIZES(OP_EQ);
+
+ BELCH_INSTR_NAME_ALL_SIZES(OP_U_GT);
+ BELCH_INSTR_NAME_ALL_SIZES(OP_U_LE);
+ BELCH_INSTR_NAME_ALL_SIZES(OP_U_GE);
+ BELCH_INSTR_NAME_ALL_SIZES(OP_U_LT);
+
+ BELCH_INSTR_NAME_ALL_SIZES(OP_S_GT);
+ BELCH_INSTR_NAME_ALL_SIZES(OP_S_LE);
+ BELCH_INSTR_NAME_ALL_SIZES(OP_S_GE);
+ BELCH_INSTR_NAME_ALL_SIZES(OP_S_LT);
+
+ BELCH_INSTR_NAME_ALL_SIZES(OP_INDEX_ADDR);
+
default:
barf("disInstr: unknown opcode %u", (unsigned int) instr);
}
=====================================
rts/Interpreter.c
=====================================
@@ -178,23 +178,34 @@ See also Note [Width of parameters] for some more motivation.
#define Sp_plusB(n) ((void *)((StgWord8*)Sp + (ptrdiff_t)(n)))
#define Sp_minusB(n) ((void *)((StgWord8*)Sp - (ptrdiff_t)(n)))
-#define Sp_plusW(n) (Sp_plusB((ptrdiff_t)(n) * (ptrdiff_t)sizeof(W_)))
-#define Sp_minusW(n) (Sp_minusB((ptrdiff_t)(n) * (ptrdiff_t)sizeof(W_)))
+#define Sp_plusW(n) ((void*)Sp_plusB((ptrdiff_t)(n) * (ptrdiff_t)sizeof(W_)))
+#define Sp_plusW64(n) ((void*)Sp_plusB((ptrdiff_t)(n) * (ptrdiff_t)sizeof(StgWord64)))
+#define Sp_minusW(n) ((void*)Sp_minusB((ptrdiff_t)(n) * (ptrdiff_t)sizeof(W_)))
#define Sp_addB(n) (Sp = Sp_plusB(n))
#define Sp_subB(n) (Sp = Sp_minusB(n))
#define Sp_addW(n) (Sp = Sp_plusW(n))
+#define Sp_addW64(n) (Sp = Sp_plusW64(n))
#define Sp_subW(n) (Sp = Sp_minusW(n))
-#define SpW(n) (*(StgWord*)(Sp_plusW(n)))
-#define SpB(n) (*(StgWord*)(Sp_plusB(n)))
+// Assumes stack location is within stack chunk bounds
+#define SpW(n) (*(StgWord*)(Sp_plusW(n)))
+#define SpW64(n) (*(StgWord*)(Sp_plusW64(n)))
-#define WITHIN_CAP_CHUNK_BOUNDS(n) WITHIN_CHUNK_BOUNDS(n, cap->r.rCurrentTSO->stackobj)
+#define WITHIN_CAP_CHUNK_BOUNDS_W(n) WITHIN_CHUNK_BOUNDS_W(n, cap->r.rCurrentTSO->stackobj)
-#define WITHIN_CHUNK_BOUNDS(n, s) \
- (RTS_LIKELY((StgWord*)(Sp_plusW(n)) < ((s)->stack + (s)->stack_size - sizeofW(StgUnderflowFrame))))
+#define WITHIN_CHUNK_BOUNDS_W(n, s) \
+ (RTS_LIKELY(((StgWord*) Sp_plusW(n)) < ((s)->stack + (s)->stack_size - sizeofW(StgUnderflowFrame))))
+#define WDS_TO_W64(n) (n * sizeof(StgWord64) / sizeof(StgWord))
+
+// Always safe to use - Return the value at the address
+#define ReadSpW(n) (*((StgWord*) SafeSpWP(n)))
+#define ReadSpW64(n) (*((StgWord64*) SafeSpWP(WDS_TO_W64(n))))
+// Perhaps confusingly this still reads a full word, merely the offset is in bytes.
+#define ReadSpB(n) (*((StgWord*) SafeSpBP(n)))
+
/* Note [PUSH_L underflow]
~~~~~~~~~~~~~~~~~~~~~~~
BCOs can be nested, resulting in nested BCO stack frames where the inner most
@@ -215,9 +226,9 @@ variables. If a stack overflow happens between the creation of the stack frame
for BCO_1 and BCO_N the RTS might move BCO_N to a new stack chunk while leaving
BCO_1 in place, invalidating a simple offset based reference to the outer stack
frames.
-Therefore `ReadSpW` first performs a bounds check to ensure that accesses onto
+Therefore `SafeSpW` first performs a bounds check to ensure that accesses onto
the stack will succeed. If the target address would not be a valid location for
-the current stack chunk then `slow_spw` function is called, which dereferences
+the current stack chunk then `slow_sp` function is called, which dereferences
the underflow frame to adjust the offset before performing the lookup.
┌->--x | CHK_1 |
@@ -229,13 +240,43 @@ the underflow frame to adjust the offset before performing the lookup.
|---------| | PUSH_L <n>
| BCO_ N | ->-┘
|---------|
+
+To keep things simpler all accesses to the stack which might go beyond the stack
+chunk go through one of the ReadSP* or SafeSP* macros.
+When writing to the stack there is no need for checks, we ensured we have space
+in the current chunk ahead of time. So there we use SpW and it's variants which
+omit the stack bounds check.
+
See ticket #25750
*/
-#define ReadSpW(n) \
- ((WITHIN_CAP_CHUNK_BOUNDS(n)) ? SpW(n): slow_spw(Sp, cap->r.rCurrentTSO->stackobj, n))
+// Returns a pointer to the stack location.
+// Returns a pointer to the stack location.
+#define SafeSpWP(n) \
+ ( ((WITHIN_CAP_CHUNK_BOUNDS_W(n)) ? Sp_plusW(n) : slow_spw(Sp, cap->r.rCurrentTSO->stackobj, n)))
+#define SafeSpBP(off_w) \
+ ( (WITHIN_CAP_CHUNK_BOUNDS_W((1+(off_w))/sizeof(StgWord))) ? \
+ Sp_plusB(off_w) : \
+ (void*)((ptrdiff_t)((ptrdiff_t)(off_w) % (ptrdiff_t)sizeof(StgWord)) + (StgWord8*)slow_spw(Sp, cap->r.rCurrentTSO->stackobj, (off_w)/sizeof(StgWord))) \
+ )
+
+
+
+/* Note [Interpreter subword primops]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In general the interpreter stack is host-platform word aligned.
+We keep with this convention when evaluating primops for simplicity.
+
+This means:
+
+* All arguments are pushed extended to word size.
+* Results are written to the stack extended to word size.
+The only exception are constructor allocations where we push unaligned subwords
+on the stack which are cleaned up by the PACK instruction afterwards.
+
+*/
STATIC_INLINE StgPtr
allocate_NONUPD (Capability *cap, int n_words)
@@ -392,11 +433,12 @@ StgClosure * copyPAP (Capability *cap, StgPAP *oldpap)
// See Note [PUSH_L underflow] for in which situations this
// slow lookup is needed
-static StgWord
-slow_spw(void *Sp, StgStack *cur_stack, StgWord offset){
- // 1. If in range, access the item from the current stack chunk
- if (WITHIN_CHUNK_BOUNDS(offset, cur_stack)) {
- return SpW(offset);
+// Returns a pointer to the stack location.
+static void*
+slow_spw(void *Sp, StgStack *cur_stack, StgWord offset_words){
+ // 1. If in range, simply return ptr+offset_words pointing into the current stack chunk
+ if (WITHIN_CHUNK_BOUNDS_W(offset_words, cur_stack)) {
+ return Sp_plusW(offset_words);
}
// 2. Not in this stack chunk, so access the underflow frame.
else {
@@ -420,21 +462,19 @@ slow_spw(void *Sp, StgStack *cur_stack, StgWord offset){
// How many words were on the stack
stackWords = (StgWord *)frame - (StgWord *) Sp;
- ASSERT(offset > stackWords);
+ ASSERT(offset_words > stackWords);
// Recursive, in the very unlikely case we have to traverse two
// stack chunks.
- return slow_spw(new_stack->sp, new_stack, offset-stackWords);
+ return slow_spw(new_stack->sp, new_stack, offset_words-stackWords);
}
// 2b. Access the element if there is no underflow frame, it must be right
// at the top of the stack.
else {
// Not actually in the underflow case
- return SpW(offset);
+ return Sp_plusW(offset_words);
}
-
}
-
}
// Compute the pointer tag for the constructor and tag the pointer;
@@ -883,7 +923,7 @@ do_return_nonpointer:
// get the offset of the header of the next stack frame
offset = stack_frame_sizeW((StgClosure *)Sp);
- switch (get_itbl((StgClosure*)(Sp_plusW(offset)))->type) {
+ switch (get_itbl((StgClosure*)(SafeSpWP(offset)))->type) {
case RET_BCO:
// Returning to an interpreted continuation: pop the return frame
@@ -1236,9 +1276,9 @@ run_BCO:
#endif
bci = BCO_NEXT;
- /* We use the high 8 bits for flags, only the highest of which is
- * currently allocated */
- ASSERT((bci & 0xFF00) == (bci & 0x8000));
+ /* We use the high 8 bits for flags. The highest of which is
+ * currently allocated to LARGE_ARGS */
+ ASSERT((bci & 0xFF00) == (bci & ( bci_FLAG_LARGE_ARGS )));
switch (bci & 0xFF) {
@@ -1421,41 +1461,41 @@ run_BCO:
case bci_PUSH8: {
W_ off = BCO_GET_LARGE_ARG;
Sp_subB(1);
- *(StgWord8*)Sp = (StgWord8) *(StgWord*)(Sp_plusB(off+1));
+ *(StgWord8*)Sp = (StgWord8) (ReadSpB(off+1));
goto nextInsn;
}
case bci_PUSH16: {
W_ off = BCO_GET_LARGE_ARG;
Sp_subB(2);
- *(StgWord16*)Sp = (StgWord16) *(StgWord*)(Sp_plusB(off+2));
+ *(StgWord16*)Sp = (StgWord16) (ReadSpB(off+2));
goto nextInsn;
}
case bci_PUSH32: {
W_ off = BCO_GET_LARGE_ARG;
Sp_subB(4);
- *(StgWord32*)Sp = (StgWord32) *(StgWord*)(Sp_plusB(off+4));
+ *(StgWord32*)Sp = (StgWord32) (ReadSpB(off+4));
goto nextInsn;
}
case bci_PUSH8_W: {
W_ off = BCO_GET_LARGE_ARG;
- *(StgWord*)(Sp_minusW(1)) = (StgWord) ((StgWord8) *(StgWord*)(Sp_plusB(off)));
+ *(StgWord*)(Sp_minusW(1)) = (StgWord) ((StgWord8) (ReadSpB(off)));
Sp_subW(1);
goto nextInsn;
}
case bci_PUSH16_W: {
W_ off = BCO_GET_LARGE_ARG;
- *(StgWord*)(Sp_minusW(1)) = (StgWord) ((StgWord16) *(StgWord*)(Sp_plusB(off)));
+ *(StgWord*)(Sp_minusW(1)) = (StgWord) ((StgWord16) (ReadSpB(off)));
Sp_subW(1);
goto nextInsn;
}
case bci_PUSH32_W: {
W_ off = BCO_GET_LARGE_ARG;
- *(StgWord*)(Sp_minusW(1)) = (StgWord) ((StgWord32) *(StgWord*)(Sp_plusB(off)));
+ *(StgWord*)(Sp_minusW(1)) = (StgWord) ((StgWord32) (ReadSpB(off)));
Sp_subW(1);
goto nextInsn;
}
@@ -1945,7 +1985,7 @@ run_BCO:
case bci_TESTLT_I64: {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
- StgInt64 stackInt = (*(StgInt64*)Sp);
+ StgInt64 stackInt = ReadSpW64(0);
if (stackInt >= BCO_LITI64(discr))
bciPtr = failto;
goto nextInsn;
@@ -1991,7 +2031,7 @@ run_BCO:
case bci_TESTEQ_I64: {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
- StgInt64 stackInt = (*(StgInt64*)Sp);
+ StgInt64 stackInt = ReadSpW64(0);
if (stackInt != BCO_LITI64(discr)) {
bciPtr = failto;
}
@@ -2040,7 +2080,7 @@ run_BCO:
case bci_TESTLT_W64: {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
- StgWord64 stackWord = (*(StgWord64*)Sp);
+ StgWord64 stackWord = ReadSpW64(0);
if (stackWord >= BCO_LITW64(discr))
bciPtr = failto;
goto nextInsn;
@@ -2086,7 +2126,7 @@ run_BCO:
case bci_TESTEQ_W64: {
int discr = BCO_GET_LARGE_ARG;
int failto = BCO_GET_LARGE_ARG;
- StgWord64 stackWord = (*(StgWord64*)Sp);
+ StgWord64 stackWord = ReadSpW64(0);
if (stackWord != BCO_LITW64(discr)) {
bciPtr = failto;
}
@@ -2223,7 +2263,7 @@ run_BCO:
case bci_SWIZZLE: {
W_ stkoff = BCO_GET_LARGE_ARG;
StgInt n = BCO_GET_LARGE_ARG;
- (*(StgInt*)(Sp_plusW(stkoff))) += n;
+ (*(StgInt*)(SafeSpWP(stkoff))) += n;
goto nextInsn;
}
@@ -2233,6 +2273,186 @@ run_BCO:
RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding);
}
+// op :: ty -> ty
+#define UN_SIZED_OP(op,ty) \
+ { \
+ if(sizeof(ty) == 8) { \
+ ty r = op ((ty) ReadSpW64(0)); \
+ SpW64(0) = (StgWord64) r; \
+ } else { \
+ ty r = op ((ty) ReadSpW(0)); \
+ SpW(0) = (StgWord) r; \
+ } \
+ goto nextInsn; \
+ }
+
+// op :: ty -> ty -> ty
+#define SIZED_BIN_OP(op,ty) \
+ { \
+ if(sizeof(ty) == 8) { \
+ ty r = ((ty) ReadSpW64(0)) op ((ty) ReadSpW64(1)); \
+ Sp_addW64(1); \
+ SpW64(0) = (StgWord64) r; \
+ } else { \
+ ty r = ((ty) ReadSpW(0)) op ((ty) ReadSpW(1)); \
+ Sp_addW(1); \
+ SpW(0) = (StgWord) r; \
+ }; \
+ goto nextInsn; \
+ }
+
+// op :: ty -> Int -> ty
+#define SIZED_BIN_OP_TY_INT(op,ty) \
+{ \
+ if(sizeof(ty) > sizeof(StgWord)) { \
+ ty r = ((ty) ReadSpW64(0)) op ((ty) ReadSpW(2)); \
+ Sp_addW(1); \
+ SpW64(0) = (StgWord64) r; \
+ } else { \
+ ty r = ((ty) ReadSpW(0)) op ((ty) ReadSpW(1)); \
+ Sp_addW(1); \
+ SpW(0) = (StgWord) r; \
+ }; \
+ goto nextInsn; \
+}
+
+ case bci_OP_ADD_64: SIZED_BIN_OP(+, StgInt64)
+ case bci_OP_SUB_64: SIZED_BIN_OP(-, StgInt64)
+ case bci_OP_AND_64: SIZED_BIN_OP(&, StgInt64)
+ case bci_OP_XOR_64: SIZED_BIN_OP(^, StgInt64)
+ case bci_OP_OR_64: SIZED_BIN_OP(|, StgInt64)
+ case bci_OP_MUL_64: SIZED_BIN_OP(*, StgInt64)
+ case bci_OP_SHL_64: SIZED_BIN_OP_TY_INT(<<, StgWord64)
+ case bci_OP_LSR_64: SIZED_BIN_OP_TY_INT(>>, StgWord64)
+ case bci_OP_ASR_64: SIZED_BIN_OP_TY_INT(>>, StgInt64)
+
+ case bci_OP_NEQ_64: SIZED_BIN_OP(!=, StgWord64)
+ case bci_OP_EQ_64: SIZED_BIN_OP(==, StgWord64)
+ case bci_OP_U_GT_64: SIZED_BIN_OP(>, StgWord64)
+ case bci_OP_U_GE_64: SIZED_BIN_OP(>=, StgWord64)
+ case bci_OP_U_LT_64: SIZED_BIN_OP(<, StgWord64)
+ case bci_OP_U_LE_64: SIZED_BIN_OP(<=, StgWord64)
+
+ case bci_OP_S_GT_64: SIZED_BIN_OP(>, StgInt64)
+ case bci_OP_S_GE_64: SIZED_BIN_OP(>=, StgInt64)
+ case bci_OP_S_LT_64: SIZED_BIN_OP(<, StgInt64)
+ case bci_OP_S_LE_64: SIZED_BIN_OP(<=, StgInt64)
+
+ case bci_OP_NOT_64: UN_SIZED_OP(~, StgWord64)
+ case bci_OP_NEG_64: UN_SIZED_OP(-, StgInt64)
+
+
+ case bci_OP_ADD_32: SIZED_BIN_OP(+, StgInt32)
+ case bci_OP_SUB_32: SIZED_BIN_OP(-, StgInt32)
+ case bci_OP_AND_32: SIZED_BIN_OP(&, StgInt32)
+ case bci_OP_XOR_32: SIZED_BIN_OP(^, StgInt32)
+ case bci_OP_OR_32: SIZED_BIN_OP(|, StgInt32)
+ case bci_OP_MUL_32: SIZED_BIN_OP(*, StgInt32)
+ case bci_OP_SHL_32: SIZED_BIN_OP_TY_INT(<<, StgWord32)
+ case bci_OP_LSR_32: SIZED_BIN_OP_TY_INT(>>, StgWord32)
+ case bci_OP_ASR_32: SIZED_BIN_OP_TY_INT(>>, StgInt32)
+
+ case bci_OP_NEQ_32: SIZED_BIN_OP(!=, StgWord32)
+ case bci_OP_EQ_32: SIZED_BIN_OP(==, StgWord32)
+ case bci_OP_U_GT_32: SIZED_BIN_OP(>, StgWord32)
+ case bci_OP_U_GE_32: SIZED_BIN_OP(>=, StgWord32)
+ case bci_OP_U_LT_32: SIZED_BIN_OP(<, StgWord32)
+ case bci_OP_U_LE_32: SIZED_BIN_OP(<=, StgWord32)
+
+ case bci_OP_S_GT_32: SIZED_BIN_OP(>, StgInt32)
+ case bci_OP_S_GE_32: SIZED_BIN_OP(>=, StgInt32)
+ case bci_OP_S_LT_32: SIZED_BIN_OP(<, StgInt32)
+ case bci_OP_S_LE_32: SIZED_BIN_OP(<=, StgInt32)
+
+ case bci_OP_NOT_32: UN_SIZED_OP(~, StgWord32)
+ case bci_OP_NEG_32: UN_SIZED_OP(-, StgInt32)
+
+
+ case bci_OP_ADD_16: SIZED_BIN_OP(+, StgInt16)
+ case bci_OP_SUB_16: SIZED_BIN_OP(-, StgInt16)
+ case bci_OP_AND_16: SIZED_BIN_OP(&, StgInt16)
+ case bci_OP_XOR_16: SIZED_BIN_OP(^, StgInt16)
+ case bci_OP_OR_16: SIZED_BIN_OP(|, StgInt16)
+ case bci_OP_MUL_16: SIZED_BIN_OP(*, StgInt16)
+ case bci_OP_SHL_16: SIZED_BIN_OP_TY_INT(<<, StgWord16)
+ case bci_OP_LSR_16: SIZED_BIN_OP_TY_INT(>>, StgWord16)
+ case bci_OP_ASR_16: SIZED_BIN_OP_TY_INT(>>, StgInt16)
+
+ case bci_OP_NEQ_16: SIZED_BIN_OP(!=, StgWord16)
+ case bci_OP_EQ_16: SIZED_BIN_OP(==, StgWord16)
+ case bci_OP_U_GT_16: SIZED_BIN_OP(>, StgWord16)
+ case bci_OP_U_GE_16: SIZED_BIN_OP(>=, StgWord16)
+ case bci_OP_U_LT_16: SIZED_BIN_OP(<, StgWord16)
+ case bci_OP_U_LE_16: SIZED_BIN_OP(<=, StgWord16)
+
+ case bci_OP_S_GT_16: SIZED_BIN_OP(>, StgInt16)
+ case bci_OP_S_GE_16: SIZED_BIN_OP(>=, StgInt16)
+ case bci_OP_S_LT_16: SIZED_BIN_OP(<, StgInt16)
+ case bci_OP_S_LE_16: SIZED_BIN_OP(<=, StgInt16)
+
+ case bci_OP_NOT_16: UN_SIZED_OP(~, StgWord16)
+ case bci_OP_NEG_16: UN_SIZED_OP(-, StgInt16)
+
+
+ case bci_OP_ADD_08: SIZED_BIN_OP(+, StgInt8)
+ case bci_OP_SUB_08: SIZED_BIN_OP(-, StgInt8)
+ case bci_OP_AND_08: SIZED_BIN_OP(&, StgInt8)
+ case bci_OP_XOR_08: SIZED_BIN_OP(^, StgInt8)
+ case bci_OP_OR_08: SIZED_BIN_OP(|, StgInt8)
+ case bci_OP_MUL_08: SIZED_BIN_OP(*, StgInt8)
+ case bci_OP_SHL_08: SIZED_BIN_OP_TY_INT(<<, StgWord8)
+ case bci_OP_LSR_08: SIZED_BIN_OP_TY_INT(>>, StgWord8)
+ case bci_OP_ASR_08: SIZED_BIN_OP_TY_INT(>>, StgInt8)
+
+ case bci_OP_NEQ_08: SIZED_BIN_OP(!=, StgWord8)
+ case bci_OP_EQ_08: SIZED_BIN_OP(==, StgWord8)
+ case bci_OP_U_GT_08: SIZED_BIN_OP(>, StgWord8)
+ case bci_OP_U_GE_08: SIZED_BIN_OP(>=, StgWord8)
+ case bci_OP_U_LT_08: SIZED_BIN_OP(<, StgWord8)
+ case bci_OP_U_LE_08: SIZED_BIN_OP(<=, StgWord8)
+
+ case bci_OP_S_GT_08: SIZED_BIN_OP(>, StgInt8)
+ case bci_OP_S_GE_08: SIZED_BIN_OP(>=, StgInt8)
+ case bci_OP_S_LT_08: SIZED_BIN_OP(<, StgInt8)
+ case bci_OP_S_LE_08: SIZED_BIN_OP(<=, StgInt8)
+
+ case bci_OP_NOT_08: UN_SIZED_OP(~, StgWord8)
+ case bci_OP_NEG_08: UN_SIZED_OP(-, StgInt8)
+
+ case bci_OP_INDEX_ADDR_64:
+ {
+ StgWord64* addr = (StgWord64*) SpW(1);
+ StgWord offset = (StgWord) SpW(0);
+ if(sizeof(StgPtr) == sizeof(StgWord64)) {
+ Sp_addW(1);
+ }
+ SpW64(0) = *(addr+offset);
+ goto nextInsn;
+ }
+
+ case bci_OP_INDEX_ADDR_32:
+ {
+ StgWord32* addr = (StgWord32*) SpW(1);
+ StgWord offset = (StgWord) SpW(0);
+ Sp_addW(1);
+ SpW(0) = (StgWord) *(addr+offset);
+ goto nextInsn;
+ }
+ case bci_OP_INDEX_ADDR_16:
+ {
+ StgWord16* addr = (StgWord16*) SpW(0);
+ SpW(0) = (StgWord) *addr;
+ goto nextInsn;
+ }
+ case bci_OP_INDEX_ADDR_08:
+ {
+ StgWord8* addr = (StgWord8*) SpW(1);
+ StgWord offset = (StgWord) SpW(0);
+ Sp_addW(1);
+ SpW(0) = (StgWord) *(addr+offset);
+ goto nextInsn;
+ }
+
case bci_CCALL: {
void *tok;
W_ stk_offset = BCO_GET_LARGE_ARG;
=====================================
rts/include/rts/Bytecodes.h
=====================================
@@ -114,6 +114,107 @@
#define bci_BCO_NAME 88
+#define bci_OP_ADD_64 90
+#define bci_OP_SUB_64 91
+#define bci_OP_AND_64 92
+#define bci_OP_XOR_64 93
+#define bci_OP_NOT_64 94
+#define bci_OP_NEG_64 95
+#define bci_OP_MUL_64 96
+#define bci_OP_SHL_64 97
+#define bci_OP_ASR_64 98
+#define bci_OP_LSR_64 99
+#define bci_OP_OR_64 100
+
+#define bci_OP_NEQ_64 110
+#define bci_OP_EQ_64 111
+#define bci_OP_U_GE_64 112
+#define bci_OP_U_GT_64 113
+#define bci_OP_U_LT_64 114
+#define bci_OP_U_LE_64 115
+#define bci_OP_S_GE_64 116
+#define bci_OP_S_GT_64 117
+#define bci_OP_S_LT_64 118
+#define bci_OP_S_LE_64 119
+
+
+#define bci_OP_ADD_32 130
+#define bci_OP_SUB_32 131
+#define bci_OP_AND_32 132
+#define bci_OP_XOR_32 133
+#define bci_OP_NOT_32 134
+#define bci_OP_NEG_32 135
+#define bci_OP_MUL_32 136
+#define bci_OP_SHL_32 137
+#define bci_OP_ASR_32 138
+#define bci_OP_LSR_32 139
+#define bci_OP_OR_32 140
+
+#define bci_OP_NEQ_32 150
+#define bci_OP_EQ_32 151
+#define bci_OP_U_GE_32 152
+#define bci_OP_U_GT_32 153
+#define bci_OP_U_LT_32 154
+#define bci_OP_U_LE_32 155
+#define bci_OP_S_GE_32 156
+#define bci_OP_S_GT_32 157
+#define bci_OP_S_LT_32 158
+#define bci_OP_S_LE_32 159
+
+
+#define bci_OP_ADD_16 170
+#define bci_OP_SUB_16 171
+#define bci_OP_AND_16 172
+#define bci_OP_XOR_16 173
+#define bci_OP_NOT_16 174
+#define bci_OP_NEG_16 175
+#define bci_OP_MUL_16 176
+#define bci_OP_SHL_16 177
+#define bci_OP_ASR_16 178
+#define bci_OP_LSR_16 179
+#define bci_OP_OR_16 180
+
+#define bci_OP_NEQ_16 190
+#define bci_OP_EQ_16 191
+#define bci_OP_U_GE_16 192
+#define bci_OP_U_GT_16 193
+#define bci_OP_U_LT_16 194
+#define bci_OP_U_LE_16 195
+#define bci_OP_S_GE_16 196
+#define bci_OP_S_GT_16 197
+#define bci_OP_S_LT_16 198
+#define bci_OP_S_LE_16 199
+
+
+#define bci_OP_ADD_08 200
+#define bci_OP_SUB_08 201
+#define bci_OP_AND_08 202
+#define bci_OP_XOR_08 203
+#define bci_OP_NOT_08 204
+#define bci_OP_NEG_08 205
+#define bci_OP_MUL_08 206
+#define bci_OP_SHL_08 207
+#define bci_OP_ASR_08 208
+#define bci_OP_LSR_08 209
+#define bci_OP_OR_08 210
+
+#define bci_OP_NEQ_08 220
+#define bci_OP_EQ_08 221
+#define bci_OP_U_GE_08 222
+#define bci_OP_U_GT_08 223
+#define bci_OP_U_LT_08 224
+#define bci_OP_U_LE_08 225
+#define bci_OP_S_GE_08 226
+#define bci_OP_S_GT_08 227
+#define bci_OP_S_LT_08 228
+#define bci_OP_S_LE_08 229
+
+#define bci_OP_INDEX_ADDR_08 240
+#define bci_OP_INDEX_ADDR_16 241
+#define bci_OP_INDEX_ADDR_32 242
+#define bci_OP_INDEX_ADDR_64 243
+
+
/* If you need to go past 255 then you will run into the flags */
/* If you need to go below 0x0100 then you will run into the instructions */
=====================================
testsuite/tests/numeric/should_run/all.T
=====================================
@@ -82,7 +82,7 @@ test('IntegerToFloat', normal, compile_and_run, [''])
test('T20291', normal, compile_and_run, [''])
test('T22282', normal, compile_and_run, [''])
test('T22671', js_fragile(24259), compile_and_run, [''])
-test('foundation', [when(js_arch(), run_timeout_multiplier(2)), js_fragile(24259)], compile_and_run, ['-O -package transformers'])
+test('foundation', [when(js_arch(), run_timeout_multiplier(2)), js_fragile(24259), extra_ways(['optasm','ghci','ghci-opt'])], compile_and_run, ['-package transformers -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
=====================================
@@ -1,3 +1,15 @@
+{- PARTS OF THIS FILE ARE SEMI-AUTOGENERATED.
+ You can re-generate them by invoking the genprimops utility with --foundation-tests
+ and then integrating the output in this file.
+
+ This test compares the results of various primops between the
+ pre-compiled version (primop wrapper) and the implementation of
+ whatever the test is run with.
+
+ This is particularly helpful when testing the interpreter as it allows us to
+ compare the result of the primop wrappers with the results of interpretation.
+-}
+
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
@@ -5,6 +17,9 @@
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE UnboxedTuples #-}
module Main
( main
) where
@@ -16,6 +31,7 @@ import Data.Typeable
import Data.Proxy
import GHC.Int
import GHC.Word
+import GHC.Word
import Data.Function
import GHC.Prim
import Control.Monad.Reader
@@ -26,6 +42,13 @@ import Foreign.Ptr
import Data.List (intercalate)
import Data.IORef
import Unsafe.Coerce
+import GHC.Types
+import Data.Char
+import Data.Semigroup
+import System.Exit
+
+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)
@@ -98,6 +121,17 @@ 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
+
instance Arbitrary Natural where
arbitrary = integralDownsize . (`mod` 10000) . abs <$> arbitraryInt64
@@ -126,6 +160,13 @@ instance Arbitrary Int16 where
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)
@@ -134,7 +175,7 @@ word64ToWord :: Word64 -> Word
word64ToWord (W64# i) = W# (word64ToWord# i)
-data RunS = RunS { depth :: Int, rg :: LCGGen }
+data RunS = RunS { depth :: Int, rg :: LCGGen, context :: [String] }
newtype LCGGen = LCGGen { randomWord64 :: IO Word64 }
@@ -148,43 +189,75 @@ newLCGGen LCGParams{..} = do
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 ()
+ 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 = 100
loop iterations iterations
where
- loop iterations 0 = putMsg ("Passed " ++ show iterations ++ " iterations")
+ 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
- if res then loop iterations (n-1)
- else putMsg ("With arguments " ++ intercalate ", " ss)
+ 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 = local (\s -> s { depth = depth s + 1 })
-runTestInternal :: Test -> ReaderT RunS IO ()
+nest c = local (\s -> s { depth = depth s + 1, context = c : context s })
+
+runTestInternal :: Test -> ReaderT RunS IO Result
runTestInternal (Group name tests) = do
- putMsg ("Group " ++ name)
- nest (mapM_ runTestInternal tests)
+ let label = ("Group " ++ name)
+ putMsg label
+ nest label (mconcat <$> mapM runTestInternal tests)
runTestInternal (Property name p) = do
- putMsg ("Running " ++ name)
- nest $ runProperty (property p)
+ let label = ("Running " ++ name)
+ putMsg label
+ nest label $ 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)
+ res <- runReaderT (runTestInternal t) (RunS 0 h [])
+ case res of
+ Success -> return ()
+ Failure tests -> do
+ 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
-------------------------------------------------------------------------------
@@ -228,9 +301,8 @@ testMultiplicative _ = Group "Multiplicative"
testDividible :: forall a . (Show a, Eq a, Integral a, Num a, Arbitrary a, Typeable a)
=> Proxy a -> Test
testDividible _ = Group "Divisible"
- [ Property "(x `div` y) * y + (x `mod` y) == x" $ \(a :: a) b ->
- if b == 0 then True === True
- else a === (a `div` b) * b + (a `mod` b)
+ [ Property "(x `div` y) * y + (x `mod` y) == x" $ \(a :: a) (NonZero b) ->
+ a === (a `div` b) * b + (a `mod` b)
]
testOperatorPrecedence :: forall a . (Show a, Eq a, Prelude.Num a, Integral a, Num a, Arbitrary a, Typeable a)
@@ -272,6 +344,590 @@ testNumberRefs = Group "ALL"
, testNumber "Word32" (Proxy :: Proxy Word32)
, testNumber "Word64" (Proxy :: Proxy Word64)
]
+{-
+test_binop :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) a r'
+ (b :: TYPE r1) (r :: TYPE r2) . String -> (a -> b) -> (r -> r')
+ -> (b -> b -> r)
+ -> (b -> b -> r)
+ -> Test
+test_binop name unwrap wrap primop wrapper =
+-}
+-- #define TEST_BINOP(name, unwrap, wrap, primop, wrapper) Property name $ \l r -> wrap (primop (unwrap l) (unwrap r)) === wrap (wrapper (unwrap l) (unwrap r))
+
+wInt# :: Int# -> Int
+wInt# = I#
+
+uInt# :: Int -> Int#
+uInt# (I# x) = x
+
+wWord#:: Word# -> Word
+wWord#= W#
+
+uWord# (W# w) = w
+uWord8# (W8# w) = w
+uWord16# (W16# w) = w
+uWord32# (W32# w) = w
+uWord64# (W64# w) = w
+uChar# (C# c) = c
+uInt8# (I8# w) = w
+uInt16# (I16# w) = w
+uInt32# (I32# w) = w
+uInt64# (I64# w) = w
+
+wWord8# = W8#
+wWord16# = W16#
+wWord32# = W32#
+wWord64# = W64#
+wChar# = C#
+wInt8# = I8#
+wInt16# = I16#
+wInt32# = I32#
+wInt64# = I64#
+
+#define WTUP2(f, g, x) (case x of (# a, b #) -> (f a, g b))
+#define WTUP3(f, g, h, x) (case x of (# a, b, c #) -> (f a, g b, h c))
+
+
+class TestPrimop f where
+ testPrimop :: String -> f -> f -> Test
+
+ testPrimopDivLike :: String -> f -> f -> Test
+ testPrimopDivLike _ _ _ = error "Div testing not supported for this type."
+
+{-
+instance TestPrimop (Int# -> Int# -> Int#) where
+ testPrimop s l r = Property s $ \(uInt -> a1) (uInt -> a2) -> (wInt (l a1 a2)) === wInt (r a1 a2)
+
+instance TestPrimop (Word# -> Word# -> Int#) where
+ testPrimop s l r = Property s $ \(uWord -> a1) (uWord -> a2) -> (wInt (l a1 a2)) === wInt (r a1 a2)
+
+instance TestPrimop (Word# -> Int#) where
+ testPrimop s l r = Property s $ \(uWord -> a1) -> (wInt (l a1)) === wInt (r a1)
+
+instance TestPrimop (Word# -> Int# -> Word#) where
+ testPrimop s l r = Property s $ \(uWord -> a1) (uInt -> a2) -> (wWord (l a1 a2)) === wWord (r a1 a2)
+ -}
+
+
+twoNonZero :: (a -> a -> b) -> a -> NonZero a -> b
+twoNonZero f x (NonZero y) = f x y
+
+main = runTests (Group "ALL" [testNumberRefs, testPrimops])
+
+-- Test an interpreted primop vs a compiled primop
+testPrimops = Group "primop"
+ [ testPrimop "gtChar#" Primop.gtChar# Wrapper.gtChar#
+ , testPrimop "geChar#" Primop.geChar# Wrapper.geChar#
+ , testPrimop "eqChar#" Primop.eqChar# Wrapper.eqChar#
+ , testPrimop "neChar#" Primop.neChar# Wrapper.neChar#
+ , testPrimop "ltChar#" Primop.ltChar# Wrapper.ltChar#
+ , testPrimop "leChar#" Primop.leChar# Wrapper.leChar#
+ , testPrimop "ord#" Primop.ord# Wrapper.ord#
+ , testPrimop "int8ToInt#" Primop.int8ToInt# Wrapper.int8ToInt#
+ , testPrimop "intToInt8#" Primop.intToInt8# Wrapper.intToInt8#
+ , testPrimop "negateInt8#" Primop.negateInt8# Wrapper.negateInt8#
+ , testPrimop "plusInt8#" Primop.plusInt8# Wrapper.plusInt8#
+ , testPrimop "subInt8#" Primop.subInt8# Wrapper.subInt8#
+ , testPrimop "timesInt8#" Primop.timesInt8# Wrapper.timesInt8#
+ , testPrimopDivLike "quotInt8#" Primop.quotInt8# Wrapper.quotInt8#
+ , testPrimopDivLike "remInt8#" Primop.remInt8# Wrapper.remInt8#
+ , testPrimopDivLike "quotRemInt8#" Primop.quotRemInt8# Wrapper.quotRemInt8#
+ , testPrimop "uncheckedShiftLInt8#" Primop.uncheckedShiftLInt8# Wrapper.uncheckedShiftLInt8#
+ , testPrimop "uncheckedShiftRAInt8#" Primop.uncheckedShiftRAInt8# Wrapper.uncheckedShiftRAInt8#
+ , testPrimop "uncheckedShiftRLInt8#" Primop.uncheckedShiftRLInt8# Wrapper.uncheckedShiftRLInt8#
+ , testPrimop "int8ToWord8#" Primop.int8ToWord8# Wrapper.int8ToWord8#
+ , testPrimop "eqInt8#" Primop.eqInt8# Wrapper.eqInt8#
+ , testPrimop "geInt8#" Primop.geInt8# Wrapper.geInt8#
+ , testPrimop "gtInt8#" Primop.gtInt8# Wrapper.gtInt8#
+ , testPrimop "leInt8#" Primop.leInt8# Wrapper.leInt8#
+ , testPrimop "ltInt8#" Primop.ltInt8# Wrapper.ltInt8#
+ , testPrimop "neInt8#" Primop.neInt8# Wrapper.neInt8#
+ , testPrimop "word8ToWord#" Primop.word8ToWord# Wrapper.word8ToWord#
+ , testPrimop "wordToWord8#" Primop.wordToWord8# Wrapper.wordToWord8#
+ , testPrimop "plusWord8#" Primop.plusWord8# Wrapper.plusWord8#
+ , testPrimop "subWord8#" Primop.subWord8# Wrapper.subWord8#
+ , testPrimop "timesWord8#" Primop.timesWord8# Wrapper.timesWord8#
+ , testPrimopDivLike "quotWord8#" Primop.quotWord8# Wrapper.quotWord8#
+ , testPrimopDivLike "remWord8#" Primop.remWord8# Wrapper.remWord8#
+ , testPrimopDivLike "quotRemWord8#" Primop.quotRemWord8# Wrapper.quotRemWord8#
+ , testPrimop "andWord8#" Primop.andWord8# Wrapper.andWord8#
+ , testPrimop "orWord8#" Primop.orWord8# Wrapper.orWord8#
+ , testPrimop "xorWord8#" Primop.xorWord8# Wrapper.xorWord8#
+ , testPrimop "notWord8#" Primop.notWord8# Wrapper.notWord8#
+ , testPrimop "uncheckedShiftLWord8#" Primop.uncheckedShiftLWord8# Wrapper.uncheckedShiftLWord8#
+ , testPrimop "uncheckedShiftRLWord8#" Primop.uncheckedShiftRLWord8# Wrapper.uncheckedShiftRLWord8#
+ , testPrimop "word8ToInt8#" Primop.word8ToInt8# Wrapper.word8ToInt8#
+ , testPrimop "eqWord8#" Primop.eqWord8# Wrapper.eqWord8#
+ , testPrimop "geWord8#" Primop.geWord8# Wrapper.geWord8#
+ , testPrimop "gtWord8#" Primop.gtWord8# Wrapper.gtWord8#
+ , testPrimop "leWord8#" Primop.leWord8# Wrapper.leWord8#
+ , testPrimop "ltWord8#" Primop.ltWord8# Wrapper.ltWord8#
+ , testPrimop "neWord8#" Primop.neWord8# Wrapper.neWord8#
+ , testPrimop "int16ToInt#" Primop.int16ToInt# Wrapper.int16ToInt#
+ , testPrimop "intToInt16#" Primop.intToInt16# Wrapper.intToInt16#
+ , testPrimop "negateInt16#" Primop.negateInt16# Wrapper.negateInt16#
+ , testPrimop "plusInt16#" Primop.plusInt16# Wrapper.plusInt16#
+ , testPrimop "subInt16#" Primop.subInt16# Wrapper.subInt16#
+ , testPrimop "timesInt16#" Primop.timesInt16# Wrapper.timesInt16#
+ , testPrimopDivLike "quotInt16#" Primop.quotInt16# Wrapper.quotInt16#
+ , testPrimopDivLike "remInt16#" Primop.remInt16# Wrapper.remInt16#
+ , testPrimopDivLike "quotRemInt16#" Primop.quotRemInt16# Wrapper.quotRemInt16#
+ , testPrimop "uncheckedShiftLInt16#" Primop.uncheckedShiftLInt16# Wrapper.uncheckedShiftLInt16#
+ , testPrimop "uncheckedShiftRAInt16#" Primop.uncheckedShiftRAInt16# Wrapper.uncheckedShiftRAInt16#
+ , testPrimop "uncheckedShiftRLInt16#" Primop.uncheckedShiftRLInt16# Wrapper.uncheckedShiftRLInt16#
+ , testPrimop "int16ToWord16#" Primop.int16ToWord16# Wrapper.int16ToWord16#
+ , testPrimop "eqInt16#" Primop.eqInt16# Wrapper.eqInt16#
+ , testPrimop "geInt16#" Primop.geInt16# Wrapper.geInt16#
+ , testPrimop "gtInt16#" Primop.gtInt16# Wrapper.gtInt16#
+ , testPrimop "leInt16#" Primop.leInt16# Wrapper.leInt16#
+ , testPrimop "ltInt16#" Primop.ltInt16# Wrapper.ltInt16#
+ , testPrimop "neInt16#" Primop.neInt16# Wrapper.neInt16#
+ , testPrimop "word16ToWord#" Primop.word16ToWord# Wrapper.word16ToWord#
+ , testPrimop "wordToWord16#" Primop.wordToWord16# Wrapper.wordToWord16#
+ , testPrimop "plusWord16#" Primop.plusWord16# Wrapper.plusWord16#
+ , testPrimop "subWord16#" Primop.subWord16# Wrapper.subWord16#
+ , testPrimop "timesWord16#" Primop.timesWord16# Wrapper.timesWord16#
+ , testPrimopDivLike "quotWord16#" Primop.quotWord16# Wrapper.quotWord16#
+ , testPrimopDivLike "remWord16#" Primop.remWord16# Wrapper.remWord16#
+ , testPrimopDivLike "quotRemWord16#" Primop.quotRemWord16# Wrapper.quotRemWord16#
+ , testPrimop "andWord16#" Primop.andWord16# Wrapper.andWord16#
+ , testPrimop "orWord16#" Primop.orWord16# Wrapper.orWord16#
+ , testPrimop "xorWord16#" Primop.xorWord16# Wrapper.xorWord16#
+ , testPrimop "notWord16#" Primop.notWord16# Wrapper.notWord16#
+ , testPrimop "uncheckedShiftLWord16#" Primop.uncheckedShiftLWord16# Wrapper.uncheckedShiftLWord16#
+ , testPrimop "uncheckedShiftRLWord16#" Primop.uncheckedShiftRLWord16# Wrapper.uncheckedShiftRLWord16#
+ , testPrimop "word16ToInt16#" Primop.word16ToInt16# Wrapper.word16ToInt16#
+ , testPrimop "eqWord16#" Primop.eqWord16# Wrapper.eqWord16#
+ , testPrimop "geWord16#" Primop.geWord16# Wrapper.geWord16#
+ , testPrimop "gtWord16#" Primop.gtWord16# Wrapper.gtWord16#
+ , testPrimop "leWord16#" Primop.leWord16# Wrapper.leWord16#
+ , testPrimop "ltWord16#" Primop.ltWord16# Wrapper.ltWord16#
+ , testPrimop "neWord16#" Primop.neWord16# Wrapper.neWord16#
+ , testPrimop "int32ToInt#" Primop.int32ToInt# Wrapper.int32ToInt#
+ , testPrimop "intToInt32#" Primop.intToInt32# Wrapper.intToInt32#
+ , testPrimop "negateInt32#" Primop.negateInt32# Wrapper.negateInt32#
+ , testPrimop "plusInt32#" Primop.plusInt32# Wrapper.plusInt32#
+ , testPrimop "subInt32#" Primop.subInt32# Wrapper.subInt32#
+ , testPrimop "timesInt32#" Primop.timesInt32# Wrapper.timesInt32#
+ , testPrimopDivLike "quotInt32#" Primop.quotInt32# Wrapper.quotInt32#
+ , testPrimopDivLike "remInt32#" Primop.remInt32# Wrapper.remInt32#
+ , testPrimopDivLike "quotRemInt32#" Primop.quotRemInt32# Wrapper.quotRemInt32#
+ , testPrimop "uncheckedShiftLInt32#" Primop.uncheckedShiftLInt32# Wrapper.uncheckedShiftLInt32#
+ , testPrimop "uncheckedShiftRAInt32#" Primop.uncheckedShiftRAInt32# Wrapper.uncheckedShiftRAInt32#
+ , testPrimop "uncheckedShiftRLInt32#" Primop.uncheckedShiftRLInt32# Wrapper.uncheckedShiftRLInt32#
+ , testPrimop "int32ToWord32#" Primop.int32ToWord32# Wrapper.int32ToWord32#
+ , testPrimop "eqInt32#" Primop.eqInt32# Wrapper.eqInt32#
+ , testPrimop "geInt32#" Primop.geInt32# Wrapper.geInt32#
+ , testPrimop "gtInt32#" Primop.gtInt32# Wrapper.gtInt32#
+ , testPrimop "leInt32#" Primop.leInt32# Wrapper.leInt32#
+ , testPrimop "ltInt32#" Primop.ltInt32# Wrapper.ltInt32#
+ , testPrimop "neInt32#" Primop.neInt32# Wrapper.neInt32#
+ , testPrimop "word32ToWord#" Primop.word32ToWord# Wrapper.word32ToWord#
+ , testPrimop "wordToWord32#" Primop.wordToWord32# Wrapper.wordToWord32#
+ , testPrimop "plusWord32#" Primop.plusWord32# Wrapper.plusWord32#
+ , testPrimop "subWord32#" Primop.subWord32# Wrapper.subWord32#
+ , testPrimop "timesWord32#" Primop.timesWord32# Wrapper.timesWord32#
+ , testPrimopDivLike "quotWord32#" Primop.quotWord32# Wrapper.quotWord32#
+ , testPrimopDivLike "remWord32#" Primop.remWord32# Wrapper.remWord32#
+ , testPrimopDivLike "quotRemWord32#" Primop.quotRemWord32# Wrapper.quotRemWord32#
+ , testPrimop "andWord32#" Primop.andWord32# Wrapper.andWord32#
+ , testPrimop "orWord32#" Primop.orWord32# Wrapper.orWord32#
+ , testPrimop "xorWord32#" Primop.xorWord32# Wrapper.xorWord32#
+ , testPrimop "notWord32#" Primop.notWord32# Wrapper.notWord32#
+ , testPrimop "uncheckedShiftLWord32#" Primop.uncheckedShiftLWord32# Wrapper.uncheckedShiftLWord32#
+ , testPrimop "uncheckedShiftRLWord32#" Primop.uncheckedShiftRLWord32# Wrapper.uncheckedShiftRLWord32#
+ , testPrimop "word32ToInt32#" Primop.word32ToInt32# Wrapper.word32ToInt32#
+ , testPrimop "eqWord32#" Primop.eqWord32# Wrapper.eqWord32#
+ , testPrimop "geWord32#" Primop.geWord32# Wrapper.geWord32#
+ , testPrimop "gtWord32#" Primop.gtWord32# Wrapper.gtWord32#
+ , testPrimop "leWord32#" Primop.leWord32# Wrapper.leWord32#
+ , testPrimop "ltWord32#" Primop.ltWord32# Wrapper.ltWord32#
+ , testPrimop "neWord32#" Primop.neWord32# Wrapper.neWord32#
+ , testPrimop "int64ToInt#" Primop.int64ToInt# Wrapper.int64ToInt#
+ , testPrimop "intToInt64#" Primop.intToInt64# Wrapper.intToInt64#
+ , testPrimop "negateInt64#" Primop.negateInt64# Wrapper.negateInt64#
+ , testPrimop "plusInt64#" Primop.plusInt64# Wrapper.plusInt64#
+ , testPrimop "subInt64#" Primop.subInt64# Wrapper.subInt64#
+ , testPrimop "timesInt64#" Primop.timesInt64# Wrapper.timesInt64#
+ , testPrimopDivLike "quotInt64#" Primop.quotInt64# Wrapper.quotInt64#
+ , testPrimopDivLike "remInt64#" Primop.remInt64# Wrapper.remInt64#
+ , testPrimop "uncheckedIShiftL64#" Primop.uncheckedIShiftL64# Wrapper.uncheckedIShiftL64#
+ , testPrimop "uncheckedIShiftRA64#" Primop.uncheckedIShiftRA64# Wrapper.uncheckedIShiftRA64#
+ , testPrimop "uncheckedIShiftRL64#" Primop.uncheckedIShiftRL64# Wrapper.uncheckedIShiftRL64#
+ , testPrimop "int64ToWord64#" Primop.int64ToWord64# Wrapper.int64ToWord64#
+ , testPrimop "eqInt64#" Primop.eqInt64# Wrapper.eqInt64#
+ , testPrimop "geInt64#" Primop.geInt64# Wrapper.geInt64#
+ , testPrimop "gtInt64#" Primop.gtInt64# Wrapper.gtInt64#
+ , testPrimop "leInt64#" Primop.leInt64# Wrapper.leInt64#
+ , testPrimop "ltInt64#" Primop.ltInt64# Wrapper.ltInt64#
+ , testPrimop "neInt64#" Primop.neInt64# Wrapper.neInt64#
+ , testPrimop "word64ToWord#" Primop.word64ToWord# Wrapper.word64ToWord#
+ , testPrimop "wordToWord64#" Primop.wordToWord64# Wrapper.wordToWord64#
+ , testPrimop "plusWord64#" Primop.plusWord64# Wrapper.plusWord64#
+ , testPrimop "subWord64#" Primop.subWord64# Wrapper.subWord64#
+ , testPrimop "timesWord64#" Primop.timesWord64# Wrapper.timesWord64#
+ , testPrimopDivLike "quotWord64#" Primop.quotWord64# Wrapper.quotWord64#
+ , testPrimopDivLike "remWord64#" Primop.remWord64# Wrapper.remWord64#
+ , testPrimop "and64#" Primop.and64# Wrapper.and64#
+ , testPrimop "or64#" Primop.or64# Wrapper.or64#
+ , testPrimop "xor64#" Primop.xor64# Wrapper.xor64#
+ , testPrimop "not64#" Primop.not64# Wrapper.not64#
+ , testPrimop "uncheckedShiftL64#" Primop.uncheckedShiftL64# Wrapper.uncheckedShiftL64#
+ , testPrimop "uncheckedShiftRL64#" Primop.uncheckedShiftRL64# Wrapper.uncheckedShiftRL64#
+ , testPrimop "word64ToInt64#" Primop.word64ToInt64# Wrapper.word64ToInt64#
+ , testPrimop "eqWord64#" Primop.eqWord64# Wrapper.eqWord64#
+ , testPrimop "geWord64#" Primop.geWord64# Wrapper.geWord64#
+ , testPrimop "gtWord64#" Primop.gtWord64# Wrapper.gtWord64#
+ , testPrimop "leWord64#" Primop.leWord64# Wrapper.leWord64#
+ , testPrimop "ltWord64#" Primop.ltWord64# Wrapper.ltWord64#
+ , testPrimop "neWord64#" Primop.neWord64# Wrapper.neWord64#
+ , testPrimop "+#" (Primop.+#) (Wrapper.+#)
+ , testPrimop "-#" (Primop.-#) (Wrapper.-#)
+ , testPrimop "*#" (Primop.*#) (Wrapper.*#)
+ , testPrimop "timesInt2#" Primop.timesInt2# Wrapper.timesInt2#
+ , testPrimop "mulIntMayOflo#" Primop.mulIntMayOflo# Wrapper.mulIntMayOflo#
+ , testPrimopDivLike "quotInt#" Primop.quotInt# Wrapper.quotInt#
+ , testPrimopDivLike "remInt#" Primop.remInt# Wrapper.remInt#
+ , testPrimopDivLike "quotRemInt#" Primop.quotRemInt# Wrapper.quotRemInt#
+ , testPrimop "andI#" Primop.andI# Wrapper.andI#
+ , testPrimop "orI#" Primop.orI# Wrapper.orI#
+ , testPrimop "xorI#" Primop.xorI# Wrapper.xorI#
+ , testPrimop "notI#" Primop.notI# Wrapper.notI#
+ , testPrimop "negateInt#" Primop.negateInt# Wrapper.negateInt#
+ , testPrimop "addIntC#" Primop.addIntC# Wrapper.addIntC#
+ , testPrimop "subIntC#" Primop.subIntC# Wrapper.subIntC#
+ , testPrimop ">#" (Primop.>#) (Wrapper.>#)
+ , testPrimop ">=#" (Primop.>=#) (Wrapper.>=#)
+ , testPrimop "==#" (Primop.==#) (Wrapper.==#)
+ , testPrimop "/=#" (Primop./=#) (Wrapper./=#)
+ , testPrimop "<#" (Primop.<#) (Wrapper.<#)
+ , testPrimop "<=#" (Primop.<=#) (Wrapper.<=#)
+ , testPrimop "chr#" Primop.chr# Wrapper.chr#
+ , testPrimop "int2Word#" Primop.int2Word# Wrapper.int2Word#
+ , testPrimop "uncheckedIShiftL#" Primop.uncheckedIShiftL# Wrapper.uncheckedIShiftL#
+ , testPrimop "uncheckedIShiftRA#" Primop.uncheckedIShiftRA# Wrapper.uncheckedIShiftRA#
+ , testPrimop "uncheckedIShiftRL#" Primop.uncheckedIShiftRL# Wrapper.uncheckedIShiftRL#
+ , testPrimop "plusWord#" Primop.plusWord# Wrapper.plusWord#
+ , testPrimop "addWordC#" Primop.addWordC# Wrapper.addWordC#
+ , testPrimop "subWordC#" Primop.subWordC# Wrapper.subWordC#
+ , testPrimop "plusWord2#" Primop.plusWord2# Wrapper.plusWord2#
+ , testPrimop "minusWord#" Primop.minusWord# Wrapper.minusWord#
+ , testPrimop "timesWord#" Primop.timesWord# Wrapper.timesWord#
+ , testPrimop "timesWord2#" Primop.timesWord2# Wrapper.timesWord2#
+ , testPrimopDivLike "quotWord#" Primop.quotWord# Wrapper.quotWord#
+ , testPrimopDivLike "remWord#" Primop.remWord# Wrapper.remWord#
+ , testPrimopDivLike "quotRemWord#" Primop.quotRemWord# Wrapper.quotRemWord#
+ , testPrimop "and#" Primop.and# Wrapper.and#
+ , testPrimop "or#" Primop.or# Wrapper.or#
+ , testPrimop "xor#" Primop.xor# Wrapper.xor#
+ , testPrimop "not#" Primop.not# Wrapper.not#
+ , testPrimop "uncheckedShiftL#" Primop.uncheckedShiftL# Wrapper.uncheckedShiftL#
+ , testPrimop "uncheckedShiftRL#" Primop.uncheckedShiftRL# Wrapper.uncheckedShiftRL#
+ , testPrimop "word2Int#" Primop.word2Int# Wrapper.word2Int#
+ , testPrimop "gtWord#" Primop.gtWord# Wrapper.gtWord#
+ , testPrimop "geWord#" Primop.geWord# Wrapper.geWord#
+ , testPrimop "eqWord#" Primop.eqWord# Wrapper.eqWord#
+ , testPrimop "neWord#" Primop.neWord# Wrapper.neWord#
+ , testPrimop "ltWord#" Primop.ltWord# Wrapper.ltWord#
+ , testPrimop "leWord#" Primop.leWord# Wrapper.leWord#
+ , testPrimop "popCnt8#" Primop.popCnt8# Wrapper.popCnt8#
+ , testPrimop "popCnt16#" Primop.popCnt16# Wrapper.popCnt16#
+ , testPrimop "popCnt32#" Primop.popCnt32# Wrapper.popCnt32#
+ , testPrimop "popCnt64#" Primop.popCnt64# Wrapper.popCnt64#
+ , testPrimop "popCnt#" Primop.popCnt# Wrapper.popCnt#
+ , testPrimop "pdep8#" Primop.pdep8# Wrapper.pdep8#
+ , testPrimop "pdep16#" Primop.pdep16# Wrapper.pdep16#
+ , testPrimop "pdep32#" Primop.pdep32# Wrapper.pdep32#
+ , testPrimop "pdep64#" Primop.pdep64# Wrapper.pdep64#
+ , testPrimop "pdep#" Primop.pdep# Wrapper.pdep#
+ , testPrimop "pext8#" Primop.pext8# Wrapper.pext8#
+ , testPrimop "pext16#" Primop.pext16# Wrapper.pext16#
+ , testPrimop "pext32#" Primop.pext32# Wrapper.pext32#
+ , testPrimop "pext64#" Primop.pext64# Wrapper.pext64#
+ , testPrimop "pext#" Primop.pext# Wrapper.pext#
+ , testPrimop "clz8#" Primop.clz8# Wrapper.clz8#
+ , testPrimop "clz16#" Primop.clz16# Wrapper.clz16#
+ , testPrimop "clz32#" Primop.clz32# Wrapper.clz32#
+ , testPrimop "clz64#" Primop.clz64# Wrapper.clz64#
+ , testPrimop "clz#" Primop.clz# Wrapper.clz#
+ , testPrimop "ctz8#" Primop.ctz8# Wrapper.ctz8#
+ , testPrimop "ctz16#" Primop.ctz16# Wrapper.ctz16#
+ , testPrimop "ctz32#" Primop.ctz32# Wrapper.ctz32#
+ , testPrimop "ctz64#" Primop.ctz64# Wrapper.ctz64#
+ , testPrimop "ctz#" Primop.ctz# Wrapper.ctz#
+ , testPrimop "byteSwap16#" Primop.byteSwap16# Wrapper.byteSwap16#
+ , testPrimop "byteSwap32#" Primop.byteSwap32# Wrapper.byteSwap32#
+ , testPrimop "byteSwap64#" Primop.byteSwap64# Wrapper.byteSwap64#
+ , testPrimop "byteSwap#" Primop.byteSwap# Wrapper.byteSwap#
+ , testPrimop "bitReverse8#" Primop.bitReverse8# Wrapper.bitReverse8#
+ , testPrimop "bitReverse16#" Primop.bitReverse16# Wrapper.bitReverse16#
+ , testPrimop "bitReverse32#" Primop.bitReverse32# Wrapper.bitReverse32#
+ , testPrimop "bitReverse64#" Primop.bitReverse64# Wrapper.bitReverse64#
+ , testPrimop "bitReverse#" Primop.bitReverse# Wrapper.bitReverse#
+ , testPrimop "narrow8Int#" Primop.narrow8Int# Wrapper.narrow8Int#
+ , testPrimop "narrow16Int#" Primop.narrow16Int# Wrapper.narrow16Int#
+ , testPrimop "narrow32Int#" Primop.narrow32Int# Wrapper.narrow32Int#
+ , testPrimop "narrow8Word#" Primop.narrow8Word# Wrapper.narrow8Word#
+ , testPrimop "narrow16Word#" Primop.narrow16Word# Wrapper.narrow16Word#
+ , testPrimop "narrow32Word#" Primop.narrow32Word# Wrapper.narrow32Word#
+ ]
+
+instance TestPrimop (Char# -> Char# -> Int#) where
+ testPrimop s l r = Property s $ \ (uChar#-> x0) (uChar#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
+
+instance TestPrimop (Char# -> Int#) where
+ testPrimop s l r = Property s $ \ (uChar#-> x0) -> wInt# (l x0) === wInt# (r x0)
+
+instance TestPrimop (Int# -> Int# -> Int#) where
+ testPrimop s l r = Property s $ \ (uInt#-> x0) (uInt#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt#-> x0) (uInt#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
+
+instance TestPrimop (Int# -> Int# -> (# Int#,Int# #)) where
+ testPrimop s l r = Property s $ \ (uInt#-> x0) (uInt#-> x1) -> WTUP2(wInt#,wInt#, (l x0 x1)) === WTUP2(wInt#,wInt#, (r x0 x1))
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt#-> x0) (uInt#-> x1) -> WTUP2(wInt#,wInt#, (l x0 x1)) === WTUP2(wInt#,wInt#, (r x0 x1))
+
+instance TestPrimop (Int# -> Int# -> (# Int#,Int#,Int# #)) where
+ testPrimop s l r = Property s $ \ (uInt#-> x0) (uInt#-> x1) -> WTUP3(wInt#,wInt#,wInt#, (l x0 x1)) === WTUP3(wInt#,wInt#,wInt#, (r x0 x1))
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt#-> x0) (uInt#-> x1) -> WTUP3(wInt#,wInt#,wInt#, (l x0 x1)) === WTUP3(wInt#,wInt#,wInt#, (r x0 x1))
+
+instance TestPrimop (Int# -> Char#) where
+ testPrimop s l r = Property s $ \ (uInt#-> x0) -> wChar# (l x0) === wChar# (r x0)
+
+instance TestPrimop (Int# -> Int#) where
+ testPrimop s l r = Property s $ \ (uInt#-> x0) -> wInt# (l x0) === wInt# (r x0)
+
+instance TestPrimop (Int# -> Int16#) where
+ testPrimop s l r = Property s $ \ (uInt#-> x0) -> wInt16# (l x0) === wInt16# (r x0)
+
+instance TestPrimop (Int# -> Int32#) where
+ testPrimop s l r = Property s $ \ (uInt#-> x0) -> wInt32# (l x0) === wInt32# (r x0)
+
+instance TestPrimop (Int# -> Int64#) where
+ testPrimop s l r = Property s $ \ (uInt#-> x0) -> wInt64# (l x0) === wInt64# (r x0)
+
+instance TestPrimop (Int# -> Int8#) where
+ testPrimop s l r = Property s $ \ (uInt#-> x0) -> wInt8# (l x0) === wInt8# (r x0)
+
+instance TestPrimop (Int# -> Word#) where
+ testPrimop s l r = Property s $ \ (uInt#-> x0) -> wWord# (l x0) === wWord# (r x0)
+
+instance TestPrimop (Int16# -> Int# -> Int16#) where
+ testPrimop s l r = Property s $ \ (uInt16#-> x0) (uInt#-> x1) -> wInt16# (l x0 x1) === wInt16# (r x0 x1)
+
+instance TestPrimop (Int16# -> Int16# -> Int#) where
+ testPrimop s l r = Property s $ \ (uInt16#-> x0) (uInt16#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt16#-> x0) (uInt16#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
+
+instance TestPrimop (Int16# -> Int16# -> Int16#) where
+ testPrimop s l r = Property s $ \ (uInt16#-> x0) (uInt16#-> x1) -> wInt16# (l x0 x1) === wInt16# (r x0 x1)
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt16#-> x0) (uInt16#-> x1) -> wInt16# (l x0 x1) === wInt16# (r x0 x1)
+
+instance TestPrimop (Int16# -> Int16# -> (# Int16#,Int16# #)) where
+ testPrimop s l r = Property s $ \ (uInt16#-> x0) (uInt16#-> x1) -> WTUP2(wInt16#,wInt16#, (l x0 x1)) === WTUP2(wInt16#,wInt16#, (r x0 x1))
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt16#-> x0) (uInt16#-> x1) -> WTUP2(wInt16#,wInt16#, (l x0 x1)) === WTUP2(wInt16#,wInt16#, (r x0 x1))
+
+instance TestPrimop (Int16# -> Int#) where
+ testPrimop s l r = Property s $ \ (uInt16#-> x0) -> wInt# (l x0) === wInt# (r x0)
+
+instance TestPrimop (Int16# -> Int16#) where
+ testPrimop s l r = Property s $ \ (uInt16#-> x0) -> wInt16# (l x0) === wInt16# (r x0)
+
+instance TestPrimop (Int16# -> Word16#) where
+ testPrimop s l r = Property s $ \ (uInt16#-> x0) -> wWord16# (l x0) === wWord16# (r x0)
+
+instance TestPrimop (Int32# -> Int# -> Int32#) where
+ testPrimop s l r = Property s $ \ (uInt32#-> x0) (uInt#-> x1) -> wInt32# (l x0 x1) === wInt32# (r x0 x1)
+
+instance TestPrimop (Int32# -> Int32# -> Int#) where
+ testPrimop s l r = Property s $ \ (uInt32#-> x0) (uInt32#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt32#-> x0) (uInt32#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
+
+instance TestPrimop (Int32# -> Int32# -> Int32#) where
+ testPrimop s l r = Property s $ \ (uInt32#-> x0) (uInt32#-> x1) -> wInt32# (l x0 x1) === wInt32# (r x0 x1)
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt32#-> x0) (uInt32#-> x1) -> wInt32# (l x0 x1) === wInt32# (r x0 x1)
+
+instance TestPrimop (Int32# -> Int32# -> (# Int32#,Int32# #)) where
+ testPrimop s l r = Property s $ \ (uInt32#-> x0) (uInt32#-> x1) -> WTUP2(wInt32#,wInt32#, (l x0 x1)) === WTUP2(wInt32#,wInt32#, (r x0 x1))
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt32#-> x0) (uInt32#-> x1) -> WTUP2(wInt32#,wInt32#, (l x0 x1)) === WTUP2(wInt32#,wInt32#, (r x0 x1))
+
+instance TestPrimop (Int32# -> Int#) where
+ testPrimop s l r = Property s $ \ (uInt32#-> x0) -> wInt# (l x0) === wInt# (r x0)
+
+instance TestPrimop (Int32# -> Int32#) where
+ testPrimop s l r = Property s $ \ (uInt32#-> x0) -> wInt32# (l x0) === wInt32# (r x0)
+
+instance TestPrimop (Int32# -> Word32#) where
+ testPrimop s l r = Property s $ \ (uInt32#-> x0) -> wWord32# (l x0) === wWord32# (r x0)
+
+instance TestPrimop (Int64# -> Int# -> Int64#) where
+ testPrimop s l r = Property s $ \ (uInt64#-> x0) (uInt#-> x1) -> wInt64# (l x0 x1) === wInt64# (r x0 x1)
+
+instance TestPrimop (Int64# -> Int64# -> Int#) where
+ testPrimop s l r = Property s $ \ (uInt64#-> x0) (uInt64#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt64#-> x0) (uInt64#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
+
+instance TestPrimop (Int64# -> Int64# -> Int64#) where
+ testPrimop s l r = Property s $ \ (uInt64#-> x0) (uInt64#-> x1) -> wInt64# (l x0 x1) === wInt64# (r x0 x1)
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt64#-> x0) (uInt64#-> x1) -> wInt64# (l x0 x1) === wInt64# (r x0 x1)
+
+instance TestPrimop (Int64# -> Int#) where
+ testPrimop s l r = Property s $ \ (uInt64#-> x0) -> wInt# (l x0) === wInt# (r x0)
+
+instance TestPrimop (Int64# -> Int64#) where
+ testPrimop s l r = Property s $ \ (uInt64#-> x0) -> wInt64# (l x0) === wInt64# (r x0)
+
+instance TestPrimop (Int64# -> Word64#) where
+ testPrimop s l r = Property s $ \ (uInt64#-> x0) -> wWord64# (l x0) === wWord64# (r x0)
+
+instance TestPrimop (Int8# -> Int# -> Int8#) where
+ testPrimop s l r = Property s $ \ (uInt8#-> x0) (uInt#-> x1) -> wInt8# (l x0 x1) === wInt8# (r x0 x1)
+
+instance TestPrimop (Int8# -> Int8# -> Int#) where
+ testPrimop s l r = Property s $ \ (uInt8#-> x0) (uInt8#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt8#-> x0) (uInt8#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
+
+instance TestPrimop (Int8# -> Int8# -> Int8#) where
+ testPrimop s l r = Property s $ \ (uInt8#-> x0) (uInt8#-> x1) -> wInt8# (l x0 x1) === wInt8# (r x0 x1)
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt8#-> x0) (uInt8#-> x1) -> wInt8# (l x0 x1) === wInt8# (r x0 x1)
+
+instance TestPrimop (Int8# -> Int8# -> (# Int8#,Int8# #)) where
+ testPrimop s l r = Property s $ \ (uInt8#-> x0) (uInt8#-> x1) -> WTUP2(wInt8#,wInt8#, (l x0 x1)) === WTUP2(wInt8#,wInt8#, (r x0 x1))
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt8#-> x0) (uInt8#-> x1) -> WTUP2(wInt8#,wInt8#, (l x0 x1)) === WTUP2(wInt8#,wInt8#, (r x0 x1))
+
+instance TestPrimop (Int8# -> Int#) where
+ testPrimop s l r = Property s $ \ (uInt8#-> x0) -> wInt# (l x0) === wInt# (r x0)
+
+instance TestPrimop (Int8# -> Int8#) where
+ testPrimop s l r = Property s $ \ (uInt8#-> x0) -> wInt8# (l x0) === wInt8# (r x0)
+
+instance TestPrimop (Int8# -> Word8#) where
+ testPrimop s l r = Property s $ \ (uInt8#-> x0) -> wWord8# (l x0) === wWord8# (r x0)
+
+instance TestPrimop (Word# -> Int# -> Word#) where
+ testPrimop s l r = Property s $ \ (uWord#-> x0) (uInt#-> x1) -> wWord# (l x0 x1) === wWord# (r x0 x1)
+
+instance TestPrimop (Word# -> Word# -> Int#) where
+ testPrimop s l r = Property s $ \ (uWord#-> x0) (uWord#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord#-> x0) (uWord#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
+
+instance TestPrimop (Word# -> Word# -> Word#) where
+ testPrimop s l r = Property s $ \ (uWord#-> x0) (uWord#-> x1) -> wWord# (l x0 x1) === wWord# (r x0 x1)
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord#-> x0) (uWord#-> x1) -> wWord# (l x0 x1) === wWord# (r x0 x1)
+
+instance TestPrimop (Word# -> Word# -> (# Word#,Int# #)) where
+ testPrimop s l r = Property s $ \ (uWord#-> x0) (uWord#-> x1) -> WTUP2(wWord#,wInt#, (l x0 x1)) === WTUP2(wWord#,wInt#, (r x0 x1))
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord#-> x0) (uWord#-> x1) -> WTUP2(wWord#,wInt#, (l x0 x1)) === WTUP2(wWord#,wInt#, (r x0 x1))
+
+instance TestPrimop (Word# -> Word# -> (# Word#,Word# #)) where
+ testPrimop s l r = Property s $ \ (uWord#-> x0) (uWord#-> x1) -> WTUP2(wWord#,wWord#, (l x0 x1)) === WTUP2(wWord#,wWord#, (r x0 x1))
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord#-> x0) (uWord#-> x1) -> WTUP2(wWord#,wWord#, (l x0 x1)) === WTUP2(wWord#,wWord#, (r x0 x1))
+
+instance TestPrimop (Word# -> Int#) where
+ testPrimop s l r = Property s $ \ (uWord#-> x0) -> wInt# (l x0) === wInt# (r x0)
+
+instance TestPrimop (Word# -> Word#) where
+ testPrimop s l r = Property s $ \ (uWord#-> x0) -> wWord# (l x0) === wWord# (r x0)
+
+instance TestPrimop (Word# -> Word16#) where
+ testPrimop s l r = Property s $ \ (uWord#-> x0) -> wWord16# (l x0) === wWord16# (r x0)
+
+instance TestPrimop (Word# -> Word32#) where
+ testPrimop s l r = Property s $ \ (uWord#-> x0) -> wWord32# (l x0) === wWord32# (r x0)
+
+instance TestPrimop (Word# -> Word64#) where
+ testPrimop s l r = Property s $ \ (uWord#-> x0) -> wWord64# (l x0) === wWord64# (r x0)
+
+instance TestPrimop (Word# -> Word8#) where
+ testPrimop s l r = Property s $ \ (uWord#-> x0) -> wWord8# (l x0) === wWord8# (r x0)
+
+instance TestPrimop (Word16# -> Int# -> Word16#) where
+ testPrimop s l r = Property s $ \ (uWord16#-> x0) (uInt#-> x1) -> wWord16# (l x0 x1) === wWord16# (r x0 x1)
+
+instance TestPrimop (Word16# -> Word16# -> Int#) where
+ testPrimop s l r = Property s $ \ (uWord16#-> x0) (uWord16#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord16#-> x0) (uWord16#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
+
+instance TestPrimop (Word16# -> Word16# -> Word16#) where
+ testPrimop s l r = Property s $ \ (uWord16#-> x0) (uWord16#-> x1) -> wWord16# (l x0 x1) === wWord16# (r x0 x1)
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord16#-> x0) (uWord16#-> x1) -> wWord16# (l x0 x1) === wWord16# (r x0 x1)
+
+instance TestPrimop (Word16# -> Word16# -> (# Word16#,Word16# #)) where
+ testPrimop s l r = Property s $ \ (uWord16#-> x0) (uWord16#-> x1) -> WTUP2(wWord16#,wWord16#, (l x0 x1)) === WTUP2(wWord16#,wWord16#, (r x0 x1))
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord16#-> x0) (uWord16#-> x1) -> WTUP2(wWord16#,wWord16#, (l x0 x1)) === WTUP2(wWord16#,wWord16#, (r x0 x1))
+
+instance TestPrimop (Word16# -> Int16#) where
+ testPrimop s l r = Property s $ \ (uWord16#-> x0) -> wInt16# (l x0) === wInt16# (r x0)
+
+instance TestPrimop (Word16# -> Word#) where
+ testPrimop s l r = Property s $ \ (uWord16#-> x0) -> wWord# (l x0) === wWord# (r x0)
+
+instance TestPrimop (Word16# -> Word16#) where
+ testPrimop s l r = Property s $ \ (uWord16#-> x0) -> wWord16# (l x0) === wWord16# (r x0)
+
+instance TestPrimop (Word32# -> Int# -> Word32#) where
+ testPrimop s l r = Property s $ \ (uWord32#-> x0) (uInt#-> x1) -> wWord32# (l x0 x1) === wWord32# (r x0 x1)
+
+instance TestPrimop (Word32# -> Word32# -> Int#) where
+ testPrimop s l r = Property s $ \ (uWord32#-> x0) (uWord32#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord32#-> x0) (uWord32#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
+
+instance TestPrimop (Word32# -> Word32# -> Word32#) where
+ testPrimop s l r = Property s $ \ (uWord32#-> x0) (uWord32#-> x1) -> wWord32# (l x0 x1) === wWord32# (r x0 x1)
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord32#-> x0) (uWord32#-> x1) -> wWord32# (l x0 x1) === wWord32# (r x0 x1)
+
+instance TestPrimop (Word32# -> Word32# -> (# Word32#,Word32# #)) where
+ testPrimop s l r = Property s $ \ (uWord32#-> x0) (uWord32#-> x1) -> WTUP2(wWord32#,wWord32#, (l x0 x1)) === WTUP2(wWord32#,wWord32#, (r x0 x1))
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord32#-> x0) (uWord32#-> x1) -> WTUP2(wWord32#,wWord32#, (l x0 x1)) === WTUP2(wWord32#,wWord32#, (r x0 x1))
+
+instance TestPrimop (Word32# -> Int32#) where
+ testPrimop s l r = Property s $ \ (uWord32#-> x0) -> wInt32# (l x0) === wInt32# (r x0)
+
+instance TestPrimop (Word32# -> Word#) where
+ testPrimop s l r = Property s $ \ (uWord32#-> x0) -> wWord# (l x0) === wWord# (r x0)
+
+instance TestPrimop (Word32# -> Word32#) where
+ testPrimop s l r = Property s $ \ (uWord32#-> x0) -> wWord32# (l x0) === wWord32# (r x0)
+
+instance TestPrimop (Word64# -> Int# -> Word64#) where
+ testPrimop s l r = Property s $ \ (uWord64#-> x0) (uInt#-> x1) -> wWord64# (l x0 x1) === wWord64# (r x0 x1)
+
+instance TestPrimop (Word64# -> Word64# -> Int#) where
+ testPrimop s l r = Property s $ \ (uWord64#-> x0) (uWord64#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord64#-> x0) (uWord64#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
+
+instance TestPrimop (Word64# -> Word64# -> Word64#) where
+ testPrimop s l r = Property s $ \ (uWord64#-> x0) (uWord64#-> x1) -> wWord64# (l x0 x1) === wWord64# (r x0 x1)
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord64#-> x0) (uWord64#-> x1) -> wWord64# (l x0 x1) === wWord64# (r x0 x1)
+
+instance TestPrimop (Word64# -> Int64#) where
+ testPrimop s l r = Property s $ \ (uWord64#-> x0) -> wInt64# (l x0) === wInt64# (r x0)
+
+instance TestPrimop (Word64# -> Word#) where
+ testPrimop s l r = Property s $ \ (uWord64#-> x0) -> wWord# (l x0) === wWord# (r x0)
+
+instance TestPrimop (Word64# -> Word64#) where
+ testPrimop s l r = Property s $ \ (uWord64#-> x0) -> wWord64# (l x0) === wWord64# (r x0)
+
+instance TestPrimop (Word8# -> Int# -> Word8#) where
+ testPrimop s l r = Property s $ \ (uWord8#-> x0) (uInt#-> x1) -> wWord8# (l x0 x1) === wWord8# (r x0 x1)
+
+instance TestPrimop (Word8# -> Word8# -> Int#) where
+ testPrimop s l r = Property s $ \ (uWord8#-> x0) (uWord8#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord8#-> x0) (uWord8#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1)
+
+instance TestPrimop (Word8# -> Word8# -> Word8#) where
+ testPrimop s l r = Property s $ \ (uWord8#-> x0) (uWord8#-> x1) -> wWord8# (l x0 x1) === wWord8# (r x0 x1)
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord8#-> x0) (uWord8#-> x1) -> wWord8# (l x0 x1) === wWord8# (r x0 x1)
+
+instance TestPrimop (Word8# -> Word8# -> (# Word8#,Word8# #)) where
+ testPrimop s l r = Property s $ \ (uWord8#-> x0) (uWord8#-> x1) -> WTUP2(wWord8#,wWord8#, (l x0 x1)) === WTUP2(wWord8#,wWord8#, (r x0 x1))
+ testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uWord8#-> x0) (uWord8#-> x1) -> WTUP2(wWord8#,wWord8#, (l x0 x1)) === WTUP2(wWord8#,wWord8#, (r x0 x1))
+
+instance TestPrimop (Word8# -> Int8#) where
+ testPrimop s l r = Property s $ \ (uWord8#-> x0) -> wInt8# (l x0) === wInt8# (r x0)
+instance TestPrimop (Word8# -> Word#) where
+ testPrimop s l r = Property s $ \ (uWord8#-> x0) -> wWord# (l x0) === wWord# (r x0)
-main = runTests testNumberRefs
+instance TestPrimop (Word8# -> Word8#) where
+ testPrimop s l r = Property s $ \ (uWord8#-> x0) -> wWord8# (l x0) === wWord8# (r x0)
=====================================
testsuite/tests/numeric/should_run/foundation.stdout
=====================================
@@ -1,540 +1,1050 @@
Group ALL
- Group Int
- Group Integral
- Running FromIntegral(Integer(a)) == a
- Passed 100 iterations
- Group Property
- Running Eq
- Passed 100 iterations
- Running Show
- Passed 100 iterations
- Running Ord
- Passed 100 iterations
- Running <
- Passed 100 iterations
- Group Additive
- Running a + azero == a
- Passed 100 iterations
- Running azero + a == a
- Passed 100 iterations
- Running a + b == b + a
- Passed 100 iterations
- Group Multiplicative
- Running a * 1 == a
- Passed 100 iterations
- Running 1 * a == a
- Passed 100 iterations
- Running multiplication commutative
- Passed 100 iterations
- Running a * b == Integer(a) * Integer(b)
- Passed 100 iterations
- Group Divisible
- Running (x `div` y) * y + (x `mod` y) == x
- Passed 100 iterations
- Group Precedence
- Running + and - (1)
- Passed 100 iterations
- Running + and - (2)
- Passed 100 iterations
- Running + and * (1)
- Passed 100 iterations
- Running + and * (2)
- Passed 100 iterations
- Running - and * (1)
- Passed 100 iterations
- Running - and * (2)
- Passed 100 iterations
- Running * and ^ (1)
- Passed 100 iterations
- Running * and ^ (2)
- Passed 100 iterations
- Group Int8
- Group Integral
- Running FromIntegral(Integer(a)) == a
- Passed 100 iterations
- Group Property
- Running Eq
- Passed 100 iterations
- Running Show
- Passed 100 iterations
- Running Ord
- Passed 100 iterations
- Running <
- Passed 100 iterations
- Group Additive
- Running a + azero == a
- Passed 100 iterations
- Running azero + a == a
- Passed 100 iterations
- Running a + b == b + a
- Passed 100 iterations
- Group Multiplicative
- Running a * 1 == a
- Passed 100 iterations
- Running 1 * a == a
- Passed 100 iterations
- Running multiplication commutative
- Passed 100 iterations
- Running a * b == Integer(a) * Integer(b)
- Passed 100 iterations
- Group Divisible
- Running (x `div` y) * y + (x `mod` y) == x
- Passed 100 iterations
- Group Precedence
- Running + and - (1)
- Passed 100 iterations
- Running + and - (2)
- Passed 100 iterations
- Running + and * (1)
- Passed 100 iterations
- Running + and * (2)
- Passed 100 iterations
- Running - and * (1)
- Passed 100 iterations
- Running - and * (2)
- Passed 100 iterations
- Running * and ^ (1)
- Passed 100 iterations
- Running * and ^ (2)
- Passed 100 iterations
- Group Int16
- Group Integral
- Running FromIntegral(Integer(a)) == a
- Passed 100 iterations
- Group Property
- Running Eq
- Passed 100 iterations
- Running Show
- Passed 100 iterations
- Running Ord
- Passed 100 iterations
- Running <
- Passed 100 iterations
- Group Additive
- Running a + azero == a
- Passed 100 iterations
- Running azero + a == a
- Passed 100 iterations
- Running a + b == b + a
- Passed 100 iterations
- Group Multiplicative
- Running a * 1 == a
- Passed 100 iterations
- Running 1 * a == a
- Passed 100 iterations
- Running multiplication commutative
- Passed 100 iterations
- Running a * b == Integer(a) * Integer(b)
- Passed 100 iterations
- Group Divisible
- Running (x `div` y) * y + (x `mod` y) == x
- Passed 100 iterations
- Group Precedence
- Running + and - (1)
- Passed 100 iterations
- Running + and - (2)
- Passed 100 iterations
- Running + and * (1)
- Passed 100 iterations
- Running + and * (2)
- Passed 100 iterations
- Running - and * (1)
- Passed 100 iterations
- Running - and * (2)
- Passed 100 iterations
- Running * and ^ (1)
- Passed 100 iterations
- Running * and ^ (2)
- Passed 100 iterations
- Group Int32
- Group Integral
- Running FromIntegral(Integer(a)) == a
- Passed 100 iterations
- Group Property
- Running Eq
- Passed 100 iterations
- Running Show
- Passed 100 iterations
- Running Ord
- Passed 100 iterations
- Running <
- Passed 100 iterations
- Group Additive
- Running a + azero == a
- Passed 100 iterations
- Running azero + a == a
- Passed 100 iterations
- Running a + b == b + a
- Passed 100 iterations
- Group Multiplicative
- Running a * 1 == a
- Passed 100 iterations
- Running 1 * a == a
- Passed 100 iterations
- Running multiplication commutative
- Passed 100 iterations
- Running a * b == Integer(a) * Integer(b)
- Passed 100 iterations
- Group Divisible
- Running (x `div` y) * y + (x `mod` y) == x
- Passed 100 iterations
- Group Precedence
- Running + and - (1)
- Passed 100 iterations
- Running + and - (2)
- Passed 100 iterations
- Running + and * (1)
- Passed 100 iterations
- Running + and * (2)
- Passed 100 iterations
- Running - and * (1)
- Passed 100 iterations
- Running - and * (2)
- Passed 100 iterations
- Running * and ^ (1)
- Passed 100 iterations
- Running * and ^ (2)
- Passed 100 iterations
- Group Int64
- Group Integral
- Running FromIntegral(Integer(a)) == a
- Passed 100 iterations
- Group Property
- Running Eq
- Passed 100 iterations
- Running Show
- Passed 100 iterations
- Running Ord
- Passed 100 iterations
- Running <
- Passed 100 iterations
- Group Additive
- Running a + azero == a
- Passed 100 iterations
- Running azero + a == a
- Passed 100 iterations
- Running a + b == b + a
- Passed 100 iterations
- Group Multiplicative
- Running a * 1 == a
- Passed 100 iterations
- Running 1 * a == a
- Passed 100 iterations
- Running multiplication commutative
- Passed 100 iterations
- Running a * b == Integer(a) * Integer(b)
- Passed 100 iterations
- Group Divisible
- Running (x `div` y) * y + (x `mod` y) == x
- Passed 100 iterations
- Group Precedence
- Running + and - (1)
- Passed 100 iterations
- Running + and - (2)
- Passed 100 iterations
- Running + and * (1)
- Passed 100 iterations
- Running + and * (2)
- Passed 100 iterations
- Running - and * (1)
- Passed 100 iterations
- Running - and * (2)
- Passed 100 iterations
- Running * and ^ (1)
- Passed 100 iterations
- Running * and ^ (2)
- Passed 100 iterations
- Group Integer
- Group Integral
- Running FromIntegral(Integer(a)) == a
- Passed 100 iterations
- Group Property
- Running Eq
- Passed 100 iterations
- Running Show
- Passed 100 iterations
- Running Ord
- Passed 100 iterations
- Running <
- Passed 100 iterations
- Group Additive
- Running a + azero == a
- Passed 100 iterations
- Running azero + a == a
- Passed 100 iterations
- Running a + b == b + a
- Passed 100 iterations
- Group Multiplicative
- Running a * 1 == a
- Passed 100 iterations
- Running 1 * a == a
- Passed 100 iterations
- Running multiplication commutative
- Passed 100 iterations
- Running a * b == Integer(a) * Integer(b)
- Passed 100 iterations
- Group Divisible
- Running (x `div` y) * y + (x `mod` y) == x
- Passed 100 iterations
- Group Precedence
- Running + and - (1)
- Passed 100 iterations
- Running + and - (2)
- Passed 100 iterations
- Running + and * (1)
- Passed 100 iterations
- Running + and * (2)
- Passed 100 iterations
- Running - and * (1)
- Passed 100 iterations
- Running - and * (2)
- Passed 100 iterations
- Running * and ^ (1)
- Passed 100 iterations
- Running * and ^ (2)
- Passed 100 iterations
- Group Word
- Group Integral
- Running FromIntegral(Integer(a)) == a
- Passed 100 iterations
- Group Property
- Running Eq
- Passed 100 iterations
- Running Show
- Passed 100 iterations
- Running Ord
- Passed 100 iterations
- Running <
- Passed 100 iterations
- Group Additive
- Running a + azero == a
- Passed 100 iterations
- Running azero + a == a
- Passed 100 iterations
- Running a + b == b + a
- Passed 100 iterations
- Group Multiplicative
- Running a * 1 == a
- Passed 100 iterations
- Running 1 * a == a
- Passed 100 iterations
- Running multiplication commutative
- Passed 100 iterations
- Running a * b == Integer(a) * Integer(b)
- Passed 100 iterations
- Group Divisible
- Running (x `div` y) * y + (x `mod` y) == x
- Passed 100 iterations
- Group Precedence
- Running + and - (1)
- Passed 100 iterations
- Running + and - (2)
- Passed 100 iterations
- Running + and * (1)
- Passed 100 iterations
- Running + and * (2)
- Passed 100 iterations
- Running - and * (1)
- Passed 100 iterations
- Running - and * (2)
- Passed 100 iterations
- Running * and ^ (1)
- Passed 100 iterations
- Running * and ^ (2)
- Passed 100 iterations
- Group Word8
- Group Integral
- Running FromIntegral(Integer(a)) == a
- Passed 100 iterations
- Group Property
- Running Eq
- Passed 100 iterations
- Running Show
- Passed 100 iterations
- Running Ord
- Passed 100 iterations
- Running <
- Passed 100 iterations
- Group Additive
- Running a + azero == a
- Passed 100 iterations
- Running azero + a == a
- Passed 100 iterations
- Running a + b == b + a
- Passed 100 iterations
- Group Multiplicative
- Running a * 1 == a
- Passed 100 iterations
- Running 1 * a == a
- Passed 100 iterations
- Running multiplication commutative
- Passed 100 iterations
- Running a * b == Integer(a) * Integer(b)
- Passed 100 iterations
- Group Divisible
- Running (x `div` y) * y + (x `mod` y) == x
- Passed 100 iterations
- Group Precedence
- Running + and - (1)
- Passed 100 iterations
- Running + and - (2)
- Passed 100 iterations
- Running + and * (1)
- Passed 100 iterations
- Running + and * (2)
- Passed 100 iterations
- Running - and * (1)
- Passed 100 iterations
- Running - and * (2)
- Passed 100 iterations
- Running * and ^ (1)
- Passed 100 iterations
- Running * and ^ (2)
- Passed 100 iterations
- Group Word16
- Group Integral
- Running FromIntegral(Integer(a)) == a
- Passed 100 iterations
- Group Property
- Running Eq
- Passed 100 iterations
- Running Show
- Passed 100 iterations
- Running Ord
- Passed 100 iterations
- Running <
- Passed 100 iterations
- Group Additive
- Running a + azero == a
- Passed 100 iterations
- Running azero + a == a
- Passed 100 iterations
- Running a + b == b + a
- Passed 100 iterations
- Group Multiplicative
- Running a * 1 == a
- Passed 100 iterations
- Running 1 * a == a
- Passed 100 iterations
- Running multiplication commutative
- Passed 100 iterations
- Running a * b == Integer(a) * Integer(b)
- Passed 100 iterations
- Group Divisible
- Running (x `div` y) * y + (x `mod` y) == x
- Passed 100 iterations
- Group Precedence
- Running + and - (1)
- Passed 100 iterations
- Running + and - (2)
- Passed 100 iterations
- Running + and * (1)
- Passed 100 iterations
- Running + and * (2)
- Passed 100 iterations
- Running - and * (1)
- Passed 100 iterations
- Running - and * (2)
- Passed 100 iterations
- Running * and ^ (1)
- Passed 100 iterations
- Running * and ^ (2)
- Passed 100 iterations
- Group Word32
- Group Integral
- Running FromIntegral(Integer(a)) == a
- Passed 100 iterations
- Group Property
- Running Eq
- Passed 100 iterations
- Running Show
- Passed 100 iterations
- Running Ord
- Passed 100 iterations
- Running <
- Passed 100 iterations
- Group Additive
- Running a + azero == a
- Passed 100 iterations
- Running azero + a == a
- Passed 100 iterations
- Running a + b == b + a
- Passed 100 iterations
- Group Multiplicative
- Running a * 1 == a
- Passed 100 iterations
- Running 1 * a == a
- Passed 100 iterations
- Running multiplication commutative
- Passed 100 iterations
- Running a * b == Integer(a) * Integer(b)
- Passed 100 iterations
- Group Divisible
- Running (x `div` y) * y + (x `mod` y) == x
- Passed 100 iterations
- Group Precedence
- Running + and - (1)
- Passed 100 iterations
- Running + and - (2)
- Passed 100 iterations
- Running + and * (1)
- Passed 100 iterations
- Running + and * (2)
- Passed 100 iterations
- Running - and * (1)
- Passed 100 iterations
- Running - and * (2)
- Passed 100 iterations
- Running * and ^ (1)
- Passed 100 iterations
- Running * and ^ (2)
- Passed 100 iterations
- Group Word64
- Group Integral
- Running FromIntegral(Integer(a)) == a
- Passed 100 iterations
- Group Property
- Running Eq
- Passed 100 iterations
- Running Show
- Passed 100 iterations
- Running Ord
- Passed 100 iterations
- Running <
- Passed 100 iterations
- Group Additive
- Running a + azero == a
- Passed 100 iterations
- Running azero + a == a
- Passed 100 iterations
- Running a + b == b + a
- Passed 100 iterations
- Group Multiplicative
- Running a * 1 == a
- Passed 100 iterations
- Running 1 * a == a
- Passed 100 iterations
- Running multiplication commutative
- Passed 100 iterations
- Running a * b == Integer(a) * Integer(b)
- Passed 100 iterations
- Group Divisible
- Running (x `div` y) * y + (x `mod` y) == x
- Passed 100 iterations
- Group Precedence
- Running + and - (1)
- Passed 100 iterations
- Running + and - (2)
- Passed 100 iterations
- Running + and * (1)
- Passed 100 iterations
- Running + and * (2)
- Passed 100 iterations
- Running - and * (1)
- Passed 100 iterations
- Running - and * (2)
- Passed 100 iterations
- Running * and ^ (1)
- Passed 100 iterations
- Running * and ^ (2)
- Passed 100 iterations
+ Group ALL
+ Group Int
+ Group Integral
+ Running FromIntegral(Integer(a)) == a
+ Passed 100 iterations
+ Group Property
+ Running Eq
+ Passed 100 iterations
+ Running Show
+ Passed 100 iterations
+ Running Ord
+ Passed 100 iterations
+ Running <
+ Passed 100 iterations
+ Group Additive
+ Running a + azero == a
+ Passed 100 iterations
+ Running azero + a == a
+ Passed 100 iterations
+ Running a + b == b + a
+ Passed 100 iterations
+ Group Multiplicative
+ Running a * 1 == a
+ Passed 100 iterations
+ Running 1 * a == a
+ Passed 100 iterations
+ Running multiplication commutative
+ Passed 100 iterations
+ Running a * b == Integer(a) * Integer(b)
+ Passed 100 iterations
+ Group Divisible
+ Running (x `div` y) * y + (x `mod` y) == x
+ Passed 100 iterations
+ Group Precedence
+ Running + and - (1)
+ Passed 100 iterations
+ Running + and - (2)
+ Passed 100 iterations
+ Running + and * (1)
+ Passed 100 iterations
+ Running + and * (2)
+ Passed 100 iterations
+ Running - and * (1)
+ Passed 100 iterations
+ Running - and * (2)
+ Passed 100 iterations
+ Running * and ^ (1)
+ Passed 100 iterations
+ Running * and ^ (2)
+ Passed 100 iterations
+ Group Int8
+ Group Integral
+ Running FromIntegral(Integer(a)) == a
+ Passed 100 iterations
+ Group Property
+ Running Eq
+ Passed 100 iterations
+ Running Show
+ Passed 100 iterations
+ Running Ord
+ Passed 100 iterations
+ Running <
+ Passed 100 iterations
+ Group Additive
+ Running a + azero == a
+ Passed 100 iterations
+ Running azero + a == a
+ Passed 100 iterations
+ Running a + b == b + a
+ Passed 100 iterations
+ Group Multiplicative
+ Running a * 1 == a
+ Passed 100 iterations
+ Running 1 * a == a
+ Passed 100 iterations
+ Running multiplication commutative
+ Passed 100 iterations
+ Running a * b == Integer(a) * Integer(b)
+ Passed 100 iterations
+ Group Divisible
+ Running (x `div` y) * y + (x `mod` y) == x
+ Passed 100 iterations
+ Group Precedence
+ Running + and - (1)
+ Passed 100 iterations
+ Running + and - (2)
+ Passed 100 iterations
+ Running + and * (1)
+ Passed 100 iterations
+ Running + and * (2)
+ Passed 100 iterations
+ Running - and * (1)
+ Passed 100 iterations
+ Running - and * (2)
+ Passed 100 iterations
+ Running * and ^ (1)
+ Passed 100 iterations
+ Running * and ^ (2)
+ Passed 100 iterations
+ Group Int16
+ Group Integral
+ Running FromIntegral(Integer(a)) == a
+ Passed 100 iterations
+ Group Property
+ Running Eq
+ Passed 100 iterations
+ Running Show
+ Passed 100 iterations
+ Running Ord
+ Passed 100 iterations
+ Running <
+ Passed 100 iterations
+ Group Additive
+ Running a + azero == a
+ Passed 100 iterations
+ Running azero + a == a
+ Passed 100 iterations
+ Running a + b == b + a
+ Passed 100 iterations
+ Group Multiplicative
+ Running a * 1 == a
+ Passed 100 iterations
+ Running 1 * a == a
+ Passed 100 iterations
+ Running multiplication commutative
+ Passed 100 iterations
+ Running a * b == Integer(a) * Integer(b)
+ Passed 100 iterations
+ Group Divisible
+ Running (x `div` y) * y + (x `mod` y) == x
+ Passed 100 iterations
+ Group Precedence
+ Running + and - (1)
+ Passed 100 iterations
+ Running + and - (2)
+ Passed 100 iterations
+ Running + and * (1)
+ Passed 100 iterations
+ Running + and * (2)
+ Passed 100 iterations
+ Running - and * (1)
+ Passed 100 iterations
+ Running - and * (2)
+ Passed 100 iterations
+ Running * and ^ (1)
+ Passed 100 iterations
+ Running * and ^ (2)
+ Passed 100 iterations
+ Group Int32
+ Group Integral
+ Running FromIntegral(Integer(a)) == a
+ Passed 100 iterations
+ Group Property
+ Running Eq
+ Passed 100 iterations
+ Running Show
+ Passed 100 iterations
+ Running Ord
+ Passed 100 iterations
+ Running <
+ Passed 100 iterations
+ Group Additive
+ Running a + azero == a
+ Passed 100 iterations
+ Running azero + a == a
+ Passed 100 iterations
+ Running a + b == b + a
+ Passed 100 iterations
+ Group Multiplicative
+ Running a * 1 == a
+ Passed 100 iterations
+ Running 1 * a == a
+ Passed 100 iterations
+ Running multiplication commutative
+ Passed 100 iterations
+ Running a * b == Integer(a) * Integer(b)
+ Passed 100 iterations
+ Group Divisible
+ Running (x `div` y) * y + (x `mod` y) == x
+ Passed 100 iterations
+ Group Precedence
+ Running + and - (1)
+ Passed 100 iterations
+ Running + and - (2)
+ Passed 100 iterations
+ Running + and * (1)
+ Passed 100 iterations
+ Running + and * (2)
+ Passed 100 iterations
+ Running - and * (1)
+ Passed 100 iterations
+ Running - and * (2)
+ Passed 100 iterations
+ Running * and ^ (1)
+ Passed 100 iterations
+ Running * and ^ (2)
+ Passed 100 iterations
+ Group Int64
+ Group Integral
+ Running FromIntegral(Integer(a)) == a
+ Passed 100 iterations
+ Group Property
+ Running Eq
+ Passed 100 iterations
+ Running Show
+ Passed 100 iterations
+ Running Ord
+ Passed 100 iterations
+ Running <
+ Passed 100 iterations
+ Group Additive
+ Running a + azero == a
+ Passed 100 iterations
+ Running azero + a == a
+ Passed 100 iterations
+ Running a + b == b + a
+ Passed 100 iterations
+ Group Multiplicative
+ Running a * 1 == a
+ Passed 100 iterations
+ Running 1 * a == a
+ Passed 100 iterations
+ Running multiplication commutative
+ Passed 100 iterations
+ Running a * b == Integer(a) * Integer(b)
+ Passed 100 iterations
+ Group Divisible
+ Running (x `div` y) * y + (x `mod` y) == x
+ Passed 100 iterations
+ Group Precedence
+ Running + and - (1)
+ Passed 100 iterations
+ Running + and - (2)
+ Passed 100 iterations
+ Running + and * (1)
+ Passed 100 iterations
+ Running + and * (2)
+ Passed 100 iterations
+ Running - and * (1)
+ Passed 100 iterations
+ Running - and * (2)
+ Passed 100 iterations
+ Running * and ^ (1)
+ Passed 100 iterations
+ Running * and ^ (2)
+ Passed 100 iterations
+ Group Integer
+ Group Integral
+ Running FromIntegral(Integer(a)) == a
+ Passed 100 iterations
+ Group Property
+ Running Eq
+ Passed 100 iterations
+ Running Show
+ Passed 100 iterations
+ Running Ord
+ Passed 100 iterations
+ Running <
+ Passed 100 iterations
+ Group Additive
+ Running a + azero == a
+ Passed 100 iterations
+ Running azero + a == a
+ Passed 100 iterations
+ Running a + b == b + a
+ Passed 100 iterations
+ Group Multiplicative
+ Running a * 1 == a
+ Passed 100 iterations
+ Running 1 * a == a
+ Passed 100 iterations
+ Running multiplication commutative
+ Passed 100 iterations
+ Running a * b == Integer(a) * Integer(b)
+ Passed 100 iterations
+ Group Divisible
+ Running (x `div` y) * y + (x `mod` y) == x
+ Passed 100 iterations
+ Group Precedence
+ Running + and - (1)
+ Passed 100 iterations
+ Running + and - (2)
+ Passed 100 iterations
+ Running + and * (1)
+ Passed 100 iterations
+ Running + and * (2)
+ Passed 100 iterations
+ Running - and * (1)
+ Passed 100 iterations
+ Running - and * (2)
+ Passed 100 iterations
+ Running * and ^ (1)
+ Passed 100 iterations
+ Running * and ^ (2)
+ Passed 100 iterations
+ Group Word
+ Group Integral
+ Running FromIntegral(Integer(a)) == a
+ Passed 100 iterations
+ Group Property
+ Running Eq
+ Passed 100 iterations
+ Running Show
+ Passed 100 iterations
+ Running Ord
+ Passed 100 iterations
+ Running <
+ Passed 100 iterations
+ Group Additive
+ Running a + azero == a
+ Passed 100 iterations
+ Running azero + a == a
+ Passed 100 iterations
+ Running a + b == b + a
+ Passed 100 iterations
+ Group Multiplicative
+ Running a * 1 == a
+ Passed 100 iterations
+ Running 1 * a == a
+ Passed 100 iterations
+ Running multiplication commutative
+ Passed 100 iterations
+ Running a * b == Integer(a) * Integer(b)
+ Passed 100 iterations
+ Group Divisible
+ Running (x `div` y) * y + (x `mod` y) == x
+ Passed 100 iterations
+ Group Precedence
+ Running + and - (1)
+ Passed 100 iterations
+ Running + and - (2)
+ Passed 100 iterations
+ Running + and * (1)
+ Passed 100 iterations
+ Running + and * (2)
+ Passed 100 iterations
+ Running - and * (1)
+ Passed 100 iterations
+ Running - and * (2)
+ Passed 100 iterations
+ Running * and ^ (1)
+ Passed 100 iterations
+ Running * and ^ (2)
+ Passed 100 iterations
+ Group Word8
+ Group Integral
+ Running FromIntegral(Integer(a)) == a
+ Passed 100 iterations
+ Group Property
+ Running Eq
+ Passed 100 iterations
+ Running Show
+ Passed 100 iterations
+ Running Ord
+ Passed 100 iterations
+ Running <
+ Passed 100 iterations
+ Group Additive
+ Running a + azero == a
+ Passed 100 iterations
+ Running azero + a == a
+ Passed 100 iterations
+ Running a + b == b + a
+ Passed 100 iterations
+ Group Multiplicative
+ Running a * 1 == a
+ Passed 100 iterations
+ Running 1 * a == a
+ Passed 100 iterations
+ Running multiplication commutative
+ Passed 100 iterations
+ Running a * b == Integer(a) * Integer(b)
+ Passed 100 iterations
+ Group Divisible
+ Running (x `div` y) * y + (x `mod` y) == x
+ Passed 100 iterations
+ Group Precedence
+ Running + and - (1)
+ Passed 100 iterations
+ Running + and - (2)
+ Passed 100 iterations
+ Running + and * (1)
+ Passed 100 iterations
+ Running + and * (2)
+ Passed 100 iterations
+ Running - and * (1)
+ Passed 100 iterations
+ Running - and * (2)
+ Passed 100 iterations
+ Running * and ^ (1)
+ Passed 100 iterations
+ Running * and ^ (2)
+ Passed 100 iterations
+ Group Word16
+ Group Integral
+ Running FromIntegral(Integer(a)) == a
+ Passed 100 iterations
+ Group Property
+ Running Eq
+ Passed 100 iterations
+ Running Show
+ Passed 100 iterations
+ Running Ord
+ Passed 100 iterations
+ Running <
+ Passed 100 iterations
+ Group Additive
+ Running a + azero == a
+ Passed 100 iterations
+ Running azero + a == a
+ Passed 100 iterations
+ Running a + b == b + a
+ Passed 100 iterations
+ Group Multiplicative
+ Running a * 1 == a
+ Passed 100 iterations
+ Running 1 * a == a
+ Passed 100 iterations
+ Running multiplication commutative
+ Passed 100 iterations
+ Running a * b == Integer(a) * Integer(b)
+ Passed 100 iterations
+ Group Divisible
+ Running (x `div` y) * y + (x `mod` y) == x
+ Passed 100 iterations
+ Group Precedence
+ Running + and - (1)
+ Passed 100 iterations
+ Running + and - (2)
+ Passed 100 iterations
+ Running + and * (1)
+ Passed 100 iterations
+ Running + and * (2)
+ Passed 100 iterations
+ Running - and * (1)
+ Passed 100 iterations
+ Running - and * (2)
+ Passed 100 iterations
+ Running * and ^ (1)
+ Passed 100 iterations
+ Running * and ^ (2)
+ Passed 100 iterations
+ Group Word32
+ Group Integral
+ Running FromIntegral(Integer(a)) == a
+ Passed 100 iterations
+ Group Property
+ Running Eq
+ Passed 100 iterations
+ Running Show
+ Passed 100 iterations
+ Running Ord
+ Passed 100 iterations
+ Running <
+ Passed 100 iterations
+ Group Additive
+ Running a + azero == a
+ Passed 100 iterations
+ Running azero + a == a
+ Passed 100 iterations
+ Running a + b == b + a
+ Passed 100 iterations
+ Group Multiplicative
+ Running a * 1 == a
+ Passed 100 iterations
+ Running 1 * a == a
+ Passed 100 iterations
+ Running multiplication commutative
+ Passed 100 iterations
+ Running a * b == Integer(a) * Integer(b)
+ Passed 100 iterations
+ Group Divisible
+ Running (x `div` y) * y + (x `mod` y) == x
+ Passed 100 iterations
+ Group Precedence
+ Running + and - (1)
+ Passed 100 iterations
+ Running + and - (2)
+ Passed 100 iterations
+ Running + and * (1)
+ Passed 100 iterations
+ Running + and * (2)
+ Passed 100 iterations
+ Running - and * (1)
+ Passed 100 iterations
+ Running - and * (2)
+ Passed 100 iterations
+ Running * and ^ (1)
+ Passed 100 iterations
+ Running * and ^ (2)
+ Passed 100 iterations
+ Group Word64
+ Group Integral
+ Running FromIntegral(Integer(a)) == a
+ Passed 100 iterations
+ Group Property
+ Running Eq
+ Passed 100 iterations
+ Running Show
+ Passed 100 iterations
+ Running Ord
+ Passed 100 iterations
+ Running <
+ Passed 100 iterations
+ Group Additive
+ Running a + azero == a
+ Passed 100 iterations
+ Running azero + a == a
+ Passed 100 iterations
+ Running a + b == b + a
+ Passed 100 iterations
+ Group Multiplicative
+ Running a * 1 == a
+ Passed 100 iterations
+ Running 1 * a == a
+ Passed 100 iterations
+ Running multiplication commutative
+ Passed 100 iterations
+ Running a * b == Integer(a) * Integer(b)
+ Passed 100 iterations
+ Group Divisible
+ Running (x `div` y) * y + (x `mod` y) == x
+ Passed 100 iterations
+ Group Precedence
+ Running + and - (1)
+ Passed 100 iterations
+ Running + and - (2)
+ Passed 100 iterations
+ Running + and * (1)
+ Passed 100 iterations
+ Running + and * (2)
+ Passed 100 iterations
+ Running - and * (1)
+ Passed 100 iterations
+ Running - and * (2)
+ Passed 100 iterations
+ Running * and ^ (1)
+ Passed 100 iterations
+ Running * and ^ (2)
+ Passed 100 iterations
+ Group primop
+ Running gtChar#
+ Passed 100 iterations
+ Running geChar#
+ Passed 100 iterations
+ Running eqChar#
+ Passed 100 iterations
+ Running neChar#
+ Passed 100 iterations
+ Running ltChar#
+ Passed 100 iterations
+ Running leChar#
+ Passed 100 iterations
+ Running ord#
+ Passed 100 iterations
+ Running int8ToInt#
+ Passed 100 iterations
+ Running intToInt8#
+ Passed 100 iterations
+ Running negateInt8#
+ Passed 100 iterations
+ Running plusInt8#
+ Passed 100 iterations
+ Running subInt8#
+ Passed 100 iterations
+ Running timesInt8#
+ Passed 100 iterations
+ Running quotInt8#
+ Passed 100 iterations
+ Running remInt8#
+ Passed 100 iterations
+ Running quotRemInt8#
+ Passed 100 iterations
+ Running uncheckedShiftLInt8#
+ Passed 100 iterations
+ Running uncheckedShiftRAInt8#
+ Passed 100 iterations
+ Running uncheckedShiftRLInt8#
+ Passed 100 iterations
+ Running int8ToWord8#
+ Passed 100 iterations
+ Running eqInt8#
+ Passed 100 iterations
+ Running geInt8#
+ Passed 100 iterations
+ Running gtInt8#
+ Passed 100 iterations
+ Running leInt8#
+ Passed 100 iterations
+ Running ltInt8#
+ Passed 100 iterations
+ Running neInt8#
+ Passed 100 iterations
+ Running word8ToWord#
+ Passed 100 iterations
+ Running wordToWord8#
+ Passed 100 iterations
+ Running plusWord8#
+ Passed 100 iterations
+ Running subWord8#
+ Passed 100 iterations
+ Running timesWord8#
+ Passed 100 iterations
+ Running quotWord8#
+ Passed 100 iterations
+ Running remWord8#
+ Passed 100 iterations
+ Running quotRemWord8#
+ Passed 100 iterations
+ Running andWord8#
+ Passed 100 iterations
+ Running orWord8#
+ Passed 100 iterations
+ Running xorWord8#
+ Passed 100 iterations
+ Running notWord8#
+ Passed 100 iterations
+ Running uncheckedShiftLWord8#
+ Passed 100 iterations
+ Running uncheckedShiftRLWord8#
+ Passed 100 iterations
+ Running word8ToInt8#
+ Passed 100 iterations
+ Running eqWord8#
+ Passed 100 iterations
+ Running geWord8#
+ Passed 100 iterations
+ Running gtWord8#
+ Passed 100 iterations
+ Running leWord8#
+ Passed 100 iterations
+ Running ltWord8#
+ Passed 100 iterations
+ Running neWord8#
+ Passed 100 iterations
+ Running int16ToInt#
+ Passed 100 iterations
+ Running intToInt16#
+ Passed 100 iterations
+ Running negateInt16#
+ Passed 100 iterations
+ Running plusInt16#
+ Passed 100 iterations
+ Running subInt16#
+ Passed 100 iterations
+ Running timesInt16#
+ Passed 100 iterations
+ Running quotInt16#
+ Passed 100 iterations
+ Running remInt16#
+ Passed 100 iterations
+ Running quotRemInt16#
+ Passed 100 iterations
+ Running uncheckedShiftLInt16#
+ Passed 100 iterations
+ Running uncheckedShiftRAInt16#
+ Passed 100 iterations
+ Running uncheckedShiftRLInt16#
+ Passed 100 iterations
+ Running int16ToWord16#
+ Passed 100 iterations
+ Running eqInt16#
+ Passed 100 iterations
+ Running geInt16#
+ Passed 100 iterations
+ Running gtInt16#
+ Passed 100 iterations
+ Running leInt16#
+ Passed 100 iterations
+ Running ltInt16#
+ Passed 100 iterations
+ Running neInt16#
+ Passed 100 iterations
+ Running word16ToWord#
+ Passed 100 iterations
+ Running wordToWord16#
+ Passed 100 iterations
+ Running plusWord16#
+ Passed 100 iterations
+ Running subWord16#
+ Passed 100 iterations
+ Running timesWord16#
+ Passed 100 iterations
+ Running quotWord16#
+ Passed 100 iterations
+ Running remWord16#
+ Passed 100 iterations
+ Running quotRemWord16#
+ Passed 100 iterations
+ Running andWord16#
+ Passed 100 iterations
+ Running orWord16#
+ Passed 100 iterations
+ Running xorWord16#
+ Passed 100 iterations
+ Running notWord16#
+ Passed 100 iterations
+ Running uncheckedShiftLWord16#
+ Passed 100 iterations
+ Running uncheckedShiftRLWord16#
+ Passed 100 iterations
+ Running word16ToInt16#
+ Passed 100 iterations
+ Running eqWord16#
+ Passed 100 iterations
+ Running geWord16#
+ Passed 100 iterations
+ Running gtWord16#
+ Passed 100 iterations
+ Running leWord16#
+ Passed 100 iterations
+ Running ltWord16#
+ Passed 100 iterations
+ Running neWord16#
+ Passed 100 iterations
+ Running int32ToInt#
+ Passed 100 iterations
+ Running intToInt32#
+ Passed 100 iterations
+ Running negateInt32#
+ Passed 100 iterations
+ Running plusInt32#
+ Passed 100 iterations
+ Running subInt32#
+ Passed 100 iterations
+ Running timesInt32#
+ Passed 100 iterations
+ Running quotInt32#
+ Passed 100 iterations
+ Running remInt32#
+ Passed 100 iterations
+ Running quotRemInt32#
+ Passed 100 iterations
+ Running uncheckedShiftLInt32#
+ Passed 100 iterations
+ Running uncheckedShiftRAInt32#
+ Passed 100 iterations
+ Running uncheckedShiftRLInt32#
+ Passed 100 iterations
+ Running int32ToWord32#
+ Passed 100 iterations
+ Running eqInt32#
+ Passed 100 iterations
+ Running geInt32#
+ Passed 100 iterations
+ Running gtInt32#
+ Passed 100 iterations
+ Running leInt32#
+ Passed 100 iterations
+ Running ltInt32#
+ Passed 100 iterations
+ Running neInt32#
+ Passed 100 iterations
+ Running word32ToWord#
+ Passed 100 iterations
+ Running wordToWord32#
+ Passed 100 iterations
+ Running plusWord32#
+ Passed 100 iterations
+ Running subWord32#
+ Passed 100 iterations
+ Running timesWord32#
+ Passed 100 iterations
+ Running quotWord32#
+ Passed 100 iterations
+ Running remWord32#
+ Passed 100 iterations
+ Running quotRemWord32#
+ Passed 100 iterations
+ Running andWord32#
+ Passed 100 iterations
+ Running orWord32#
+ Passed 100 iterations
+ Running xorWord32#
+ Passed 100 iterations
+ Running notWord32#
+ Passed 100 iterations
+ Running uncheckedShiftLWord32#
+ Passed 100 iterations
+ Running uncheckedShiftRLWord32#
+ Passed 100 iterations
+ Running word32ToInt32#
+ Passed 100 iterations
+ Running eqWord32#
+ Passed 100 iterations
+ Running geWord32#
+ Passed 100 iterations
+ Running gtWord32#
+ Passed 100 iterations
+ Running leWord32#
+ Passed 100 iterations
+ Running ltWord32#
+ Passed 100 iterations
+ Running neWord32#
+ Passed 100 iterations
+ Running int64ToInt#
+ Passed 100 iterations
+ Running intToInt64#
+ Passed 100 iterations
+ Running negateInt64#
+ Passed 100 iterations
+ Running plusInt64#
+ Passed 100 iterations
+ Running subInt64#
+ Passed 100 iterations
+ Running timesInt64#
+ Passed 100 iterations
+ Running quotInt64#
+ Passed 100 iterations
+ Running remInt64#
+ Passed 100 iterations
+ Running uncheckedIShiftL64#
+ Passed 100 iterations
+ Running uncheckedIShiftRA64#
+ Passed 100 iterations
+ Running uncheckedIShiftRL64#
+ Passed 100 iterations
+ Running int64ToWord64#
+ Passed 100 iterations
+ Running eqInt64#
+ Passed 100 iterations
+ Running geInt64#
+ Passed 100 iterations
+ Running gtInt64#
+ Passed 100 iterations
+ Running leInt64#
+ Passed 100 iterations
+ Running ltInt64#
+ Passed 100 iterations
+ Running neInt64#
+ Passed 100 iterations
+ Running word64ToWord#
+ Passed 100 iterations
+ Running wordToWord64#
+ Passed 100 iterations
+ Running plusWord64#
+ Passed 100 iterations
+ Running subWord64#
+ Passed 100 iterations
+ Running timesWord64#
+ Passed 100 iterations
+ Running quotWord64#
+ Passed 100 iterations
+ Running remWord64#
+ Passed 100 iterations
+ Running and64#
+ Passed 100 iterations
+ Running or64#
+ Passed 100 iterations
+ Running xor64#
+ Passed 100 iterations
+ Running not64#
+ Passed 100 iterations
+ Running uncheckedShiftL64#
+ Passed 100 iterations
+ Running uncheckedShiftRL64#
+ Passed 100 iterations
+ Running word64ToInt64#
+ Passed 100 iterations
+ Running eqWord64#
+ Passed 100 iterations
+ Running geWord64#
+ Passed 100 iterations
+ Running gtWord64#
+ Passed 100 iterations
+ Running leWord64#
+ Passed 100 iterations
+ Running ltWord64#
+ Passed 100 iterations
+ Running neWord64#
+ Passed 100 iterations
+ Running +#
+ Passed 100 iterations
+ Running -#
+ Passed 100 iterations
+ Running *#
+ Passed 100 iterations
+ Running timesInt2#
+ Passed 100 iterations
+ Running mulIntMayOflo#
+ Passed 100 iterations
+ Running quotInt#
+ Passed 100 iterations
+ Running remInt#
+ Passed 100 iterations
+ Running quotRemInt#
+ Passed 100 iterations
+ Running andI#
+ Passed 100 iterations
+ Running orI#
+ Passed 100 iterations
+ Running xorI#
+ Passed 100 iterations
+ Running notI#
+ Passed 100 iterations
+ Running negateInt#
+ Passed 100 iterations
+ Running addIntC#
+ Passed 100 iterations
+ Running subIntC#
+ Passed 100 iterations
+ Running >#
+ Passed 100 iterations
+ Running >=#
+ Passed 100 iterations
+ Running ==#
+ Passed 100 iterations
+ Running /=#
+ Passed 100 iterations
+ Running <#
+ Passed 100 iterations
+ Running <=#
+ Passed 100 iterations
+ Running chr#
+ Passed 100 iterations
+ Running int2Word#
+ Passed 100 iterations
+ Running uncheckedIShiftL#
+ Passed 100 iterations
+ Running uncheckedIShiftRA#
+ Passed 100 iterations
+ Running uncheckedIShiftRL#
+ Passed 100 iterations
+ Running plusWord#
+ Passed 100 iterations
+ Running addWordC#
+ Passed 100 iterations
+ Running subWordC#
+ Passed 100 iterations
+ Running plusWord2#
+ Passed 100 iterations
+ Running minusWord#
+ Passed 100 iterations
+ Running timesWord#
+ Passed 100 iterations
+ Running timesWord2#
+ Passed 100 iterations
+ Running quotWord#
+ Passed 100 iterations
+ Running remWord#
+ Passed 100 iterations
+ Running quotRemWord#
+ Passed 100 iterations
+ Running and#
+ Passed 100 iterations
+ Running or#
+ Passed 100 iterations
+ Running xor#
+ Passed 100 iterations
+ Running not#
+ Passed 100 iterations
+ Running uncheckedShiftL#
+ Passed 100 iterations
+ Running uncheckedShiftRL#
+ Passed 100 iterations
+ Running word2Int#
+ Passed 100 iterations
+ Running gtWord#
+ Passed 100 iterations
+ Running geWord#
+ Passed 100 iterations
+ Running eqWord#
+ Passed 100 iterations
+ Running neWord#
+ Passed 100 iterations
+ Running ltWord#
+ Passed 100 iterations
+ Running leWord#
+ Passed 100 iterations
+ Running popCnt8#
+ Passed 100 iterations
+ Running popCnt16#
+ Passed 100 iterations
+ Running popCnt32#
+ Passed 100 iterations
+ Running popCnt64#
+ Passed 100 iterations
+ Running popCnt#
+ Passed 100 iterations
+ Running pdep8#
+ Passed 100 iterations
+ Running pdep16#
+ Passed 100 iterations
+ Running pdep32#
+ Passed 100 iterations
+ Running pdep64#
+ Passed 100 iterations
+ Running pdep#
+ Passed 100 iterations
+ Running pext8#
+ Passed 100 iterations
+ Running pext16#
+ Passed 100 iterations
+ Running pext32#
+ Passed 100 iterations
+ Running pext64#
+ Passed 100 iterations
+ Running pext#
+ Passed 100 iterations
+ Running clz8#
+ Passed 100 iterations
+ Running clz16#
+ Passed 100 iterations
+ Running clz32#
+ Passed 100 iterations
+ Running clz64#
+ Passed 100 iterations
+ Running clz#
+ Passed 100 iterations
+ Running ctz8#
+ Passed 100 iterations
+ Running ctz16#
+ Passed 100 iterations
+ Running ctz32#
+ Passed 100 iterations
+ Running ctz64#
+ Passed 100 iterations
+ Running ctz#
+ Passed 100 iterations
+ Running byteSwap16#
+ Passed 100 iterations
+ Running byteSwap32#
+ Passed 100 iterations
+ Running byteSwap64#
+ Passed 100 iterations
+ Running byteSwap#
+ Passed 100 iterations
+ Running bitReverse8#
+ Passed 100 iterations
+ Running bitReverse16#
+ Passed 100 iterations
+ Running bitReverse32#
+ Passed 100 iterations
+ Running bitReverse64#
+ Passed 100 iterations
+ Running bitReverse#
+ Passed 100 iterations
+ Running narrow8Int#
+ Passed 100 iterations
+ Running narrow16Int#
+ Passed 100 iterations
+ Running narrow32Int#
+ Passed 100 iterations
+ Running narrow8Word#
+ Passed 100 iterations
+ Running narrow16Word#
+ Passed 100 iterations
+ Running narrow32Word#
+ Passed 100 iterations
=====================================
utils/genprimopcode/Main.hs
=====================================
@@ -1,3 +1,4 @@
+{-# OPTIONS_GHC -Wno-x-partial #-}
------------------------------------------------------------------
-- A primop-table mangling program --
--
@@ -10,11 +11,12 @@ import Parser
import Syntax
import Data.Char
-import Data.List (union, intersperse, intercalate, nub)
-import Data.Maybe ( catMaybes )
+import Data.List (union, intersperse, intercalate, nub, sort)
+import Data.Maybe ( catMaybes, mapMaybe )
import System.Environment ( getArgs )
import System.IO ( hSetEncoding, stdin, stdout, utf8 )
+
vecOptions :: Entry -> [(String,String,Int)]
vecOptions i =
concat [vecs | OptionVector vecs <- opts i]
@@ -204,6 +206,9 @@ main = getArgs >>= \args ->
"--wired-in-deprecations"
-> putStr (gen_wired_in_deprecations p_o_specs)
+ "--foundation-tests"
+ -> putStr (gen_foundation_tests p_o_specs)
+
_ -> error "Should not happen, known_args out of sync?"
)
@@ -229,7 +234,8 @@ known_args
"--make-haskell-source",
"--make-latex-doc",
"--wired-in-docs",
- "--wired-in-deprecations"
+ "--wired-in-deprecations",
+ "--foundation-tests"
]
------------------------------------------------------------------
@@ -679,6 +685,92 @@ gen_wired_in_deprecations (Info _ entries)
| otherwise = Nothing
+gen_foundation_tests :: Info -> String
+gen_foundation_tests (Info _ entries)
+ = "tests =\n [ "
+ ++ intercalate "\n , " (catMaybes $ map mkTest entries)
+ ++ "\n ]\n"
+ ++ "\n" ++ intercalate "\n" (map mkInstances testable_tys)
+ where
+ testable_tys = nub (sort (mapMaybe (\po -> ty po <$ mkTest po) entries))
+
+ mkInstances inst_ty =
+ let test_lambda = "\\ " ++ intercalate " " (zipWith mkArg [0::Int ..] (arg_tys)) ++ " -> " ++ mk_body "l" ++ " === " ++ mk_body "r"
+ in unlines $
+ [ "instance TestPrimop (" ++ pprTy inst_ty ++ ") where"
+ , " testPrimop s l r = Property s $ " ++ test_lambda ]
+ ++ (if mb_divable_tys
+ then [" testPrimopDivLike s l r = Property s $ twoNonZero $ " ++ test_lambda]
+ else [])
+ where
+ arg_tys = args inst_ty
+ -- eg Int -> Int -> a
+ mb_divable_tys = case arg_tys of
+ [ty1,ty2] -> ty1 == ty2 && ty1 `elem` divableTyCons
+ _ -> False
+
+ mk_body s = res_ty inst_ty (" (" ++ s ++ " " ++ intercalate " " vs ++ ")")
+
+ vs = zipWith (\n _ -> "x" ++ show n) [0::Int ..] (arg_tys)
+
+ mkArg n t = "(" ++ unwrapper t ++ "-> x" ++ show n ++ ")"
+
+
+ wrapper s = "w" ++ s
+ unwrapper s = "u" ++ s
+
+
+ args (TyF (TyApp (TyCon c) []) t2) = c : args t2
+ args (TyApp {}) = []
+ args (TyUTup {}) = []
+ -- If you hit this you will need to handle the foundation tests to handle the
+ -- type it failed on.
+ args arg_ty = error ("Unexpected primop type:" ++ pprTy arg_ty)
+
+ res_ty (TyF _ t2) x = res_ty t2 x
+ res_ty (TyApp (TyCon c) []) x = wrapper c ++ x
+ res_ty (TyUTup tup_tys) x =
+ let wtup = case length tup_tys of
+ 2 -> "WTUP2"
+ 3 -> "WTUP3"
+ -- Only handles primops returning unboxed tuples up to 3 args currently
+ _ -> error "Unexpected primop result type"
+ in wtup ++"(" ++ intercalate "," (map (\a -> res_ty a "") tup_tys ++ [x]) ++ ")"
+ -- If you hit this you will need to handle the foundation tests to handle the
+ -- type it failed on.
+ res_ty unexpected_ty x = error ("Unexpected primop result type:" ++ pprTy unexpected_ty ++ "," ++ x)
+
+
+ wrap qual nm | isLower (head nm) = qual ++ "." ++ nm
+ | otherwise = "(" ++ qual ++ "." ++ nm ++ ")"
+ mkTest po
+ | Just poName <- getName po
+ , is_primop po
+ , not $ is_vector po
+ , poName /= "tagToEnum#"
+ , poName /= "quotRemWord2#"
+ , (testable (ty po))
+ = let testPrimOpHow = if is_divLikeOp po
+ then "testPrimopDivLike"
+ else "testPrimop"
+ in Just $ intercalate " " [testPrimOpHow, "\"" ++ poName ++ "\"", wrap "Primop" poName, wrap "Wrapper" poName]
+ | otherwise = Nothing
+
+
+
+ testable (TyF t1 t2) = testable t1 && testable t2
+ testable (TyC _ t2) = testable t2
+ testable (TyApp tc tys) = testableTyCon tc && all testable tys
+ testable (TyVar _a) = False
+ testable (TyUTup tys) = all testable tys
+
+ testableTyCon (TyCon c) =
+ c `elem` ["Int#", "Word#", "Word8#", "Word16#", "Word32#", "Word64#"
+ , "Int8#", "Int16#", "Int32#", "Int64#", "Char#"]
+ testableTyCon _ = False
+ divableTyCons = ["Int#", "Word#", "Word8#", "Word16#", "Word32#", "Word64#"
+ ,"Int8#", "Int16#", "Int32#", "Int64#"]
+
------------------------------------------------------------------
-- Create PrimOpInfo text from PrimOpSpecs -----------------------
------------------------------------------------------------------
=====================================
utils/genprimopcode/Syntax.hs
=====================================
@@ -53,6 +53,19 @@ is_primtype :: Entry -> Bool
is_primtype (PrimTypeSpec {}) = True
is_primtype _ = False
+is_divLikeOp :: Entry -> Bool
+is_divLikeOp entry = case entry of
+ PrimOpSpec{} -> has_div_like
+ PseudoOpSpec{} -> has_div_like
+ PrimVecOpSpec{} -> has_div_like
+ PrimTypeSpec{} -> False
+ PrimVecTypeSpec{} -> False
+ Section{} -> False
+ where
+ has_div_like = case lookup_attrib "div_like" (opts entry) of
+ Just (OptionTrue{}) -> True
+ _ -> False
+
-- a binding of property to value
data Option
= OptionFalse String -- name = False
@@ -78,7 +91,7 @@ data Ty
| TyVar TyVar
| TyUTup [Ty] -- unboxed tuples; just a TyCon really,
-- but convenient like this
- deriving (Eq,Show)
+ deriving (Eq,Show, Ord)
type TyVar = String
type TyVarBinder = String
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cb7afe6e2fef9c63c464dfe9c3f1593…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cb7afe6e2fef9c63c464dfe9c3f1593…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/T23298-test] 4 commits: Simplifier: Constant fold invald tagToEnum# calls to bottom expr.
by Simon Peyton Jones (＠simonpj) 23 Apr '25
by Simon Peyton Jones (＠simonpj) 23 Apr '25
23 Apr '25
Simon Peyton Jones pushed to branch wip/T23298-test at Glasgow Haskell Compiler / GHC
Commits:
2e204269 by Andreas Klebinger at 2025-04-22T12:20:41+02:00
Simplifier: Constant fold invald tagToEnum# calls to bottom expr.
When applying tagToEnum# to a out-of-range value it's best to simply
constant fold it to a bottom expression. That potentially allows more
dead code elimination and makes debugging easier.
Fixes #25976
- - - - -
7250fc0c by Matthew Pickering at 2025-04-22T16:24:04-04:00
Move -fno-code note into Downsweep module
This note was left behind when all the code which referred to it was
moved into the GHC.Driver.Downsweep module
- - - - -
d2dc89b4 by Matthew Pickering at 2025-04-22T16:24:04-04:00
Apply editing notes to Note [-fno-code mode] suggested by sheaf
These notes were suggested in https://gitlab.haskell.org/ghc/ghc/-/merge_requests/14241
- - - - -
90ee5634 by Simon Peyton Jones at 2025-04-23T08:58:22+01:00
Test for #23298
- - - - -
8 changed files:
- compiler/GHC/Core/Opt/ConstantFold.hs
- compiler/GHC/Driver/Downsweep.hs
- compiler/GHC/Driver/Make.hs
- + testsuite/tests/gadt/T23298.hs
- + testsuite/tests/gadt/T23298.stderr
- testsuite/tests/gadt/all.T
- + testsuite/tests/simplCore/should_compile/T25976.hs
- testsuite/tests/simplCore/should_compile/all.T
Changes:
=====================================
compiler/GHC/Core/Opt/ConstantFold.hs
=====================================
@@ -69,7 +69,6 @@ import GHC.Cmm.MachOp ( FMASign(..) )
import GHC.Cmm.Type ( Width(..) )
import GHC.Data.FastString
-import GHC.Data.Maybe ( orElse )
import GHC.Utils.Outputable
import GHC.Utils.Misc
@@ -1997,6 +1996,14 @@ because we don't expect the user to call tagToEnum# at all; we merely
generate calls in derived instances of Enum. So we compromise: a
rewrite rule rewrites a bad instance of tagToEnum# to an error call,
and emits a warning.
+
+We also do something similar if we can see that the argument of tagToEnum is out
+of bounds, e.g. `tagToEnum# 99# :: Bool`.
+Replacing this with an error expression is better for two reasons:
+* It allow us to eliminate more dead code in cases like `case tagToEnum# 99# :: Bool of ...`
+* Should we actually end up executing the relevant code at runtime the user will
+ see a meaningful error message, instead of a segfault or incorrect result.
+See #25976.
-}
tagToEnumRule :: RuleM CoreExpr
@@ -2008,9 +2015,13 @@ tagToEnumRule = do
Just (tycon, tc_args) | isEnumerationTyCon tycon -> do
let tag = fromInteger i
correct_tag dc = (dataConTagZ dc) == tag
- (dc:rest) <- return $ filter correct_tag (tyConDataCons_maybe tycon `orElse` [])
- massert (null rest)
- return $ mkTyApps (Var (dataConWorkId dc)) tc_args
+ Just dataCons <- pure $ tyConDataCons_maybe tycon
+ case filter correct_tag dataCons of
+ (dc:rest) -> do
+ massert (null rest)
+ pure $ mkTyApps (Var (dataConWorkId dc)) tc_args
+ -- Literal is out of range, e.g. tagToEnum @Bool #4
+ [] -> pure $ mkImpossibleExpr ty "tagToEnum: Argument out of range"
-- See Note [tagToEnum#]
_ -> warnPprTrace True "tagToEnum# on non-enumeration type" (ppr ty) $
=====================================
compiler/GHC/Driver/Downsweep.hs
=====================================
@@ -947,6 +947,71 @@ enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph = do
hostFullWays
in dflags_c
+{- Note [-fno-code mode]
+~~~~~~~~~~~~~~~~~~~~~~~~
+GHC offers the flag -fno-code for the purpose of parsing and typechecking a
+program without generating object files. This is intended to be used by tooling
+and IDEs to provide quick feedback on any parser or type errors as cheaply as
+possible.
+
+When GHC is invoked with -fno-code, no object files or linked output will be
+generated. As many errors and warnings as possible will be generated, as if
+-fno-code had not been passed. The session DynFlags will have
+backend == NoBackend.
+
+-fwrite-interface
+~~~~~~~~~~~~~~~~
+Whether interface files are generated in -fno-code mode is controlled by the
+-fwrite-interface flag. The -fwrite-interface flag is a no-op if -fno-code is
+not also passed. Recompilation avoidance requires interface files, so passing
+-fno-code without -fwrite-interface should be avoided. If -fno-code were
+re-implemented today, there would be no need for -fwrite-interface as it
+would considered always on; this behaviour is as it is for backwards compatibility.
+
+================================================================
+IN SUMMARY: ALWAYS PASS -fno-code AND -fwrite-interface TOGETHER
+================================================================
+
+Template Haskell
+~~~~~~~~~~~~~~~~
+A module using Template Haskell may invoke an imported function from inside a
+splice. This will cause the type-checker to attempt to execute that code, which
+would fail if no object files had been generated. See #8025. To rectify this,
+during the downsweep we patch the DynFlags in the ModSummary of any home module
+that is imported by a module that uses Template Haskell to generate object
+code.
+
+The flavour of the generated code depends on whether `-fprefer-byte-code` is enabled
+or not in the module which needs the code generation. If the module requires byte-code then
+dependencies will generate byte-code, otherwise they will generate object files.
+In the case where some modules require byte-code and some object files, both are
+generated by enabling `-fbyte-code-and-object-code`, the test "fat015" tests these
+configurations.
+
+The object files (and interface files if -fwrite-interface is disabled) produced
+for Template Haskell are written to temporary files.
+
+Note that since Template Haskell can run arbitrary IO actions, -fno-code mode
+is no more secure than running without it.
+
+Potential TODOS:
+~~~~~
+* Remove -fwrite-interface and have interface files always written in -fno-code
+ mode
+* Both .o and .dyn_o files are generated for template haskell, but we only need
+ .dyn_o. Fix it.
+* In make mode, a message like
+ Compiling A (A.hs, /tmp/ghc_123.o)
+ is shown if downsweep enabled object code generation for A. Perhaps we should
+ show "nothing" or "temporary object file" instead. Note that one
+ can currently use -keep-tmp-files and inspect the generated file with the
+ current behaviour.
+* Offer a -no-codedir command line option, and write what were temporary
+ object files there. This would speed up recompilation.
+* Use existing object files (if they are up to date) instead of always
+ generating temporary ones.
+-}
+
-- | Populate the Downsweep cache with the root modules.
mkRootMap
:: [ModuleNodeInfo]
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -1246,70 +1246,6 @@ addSptEntries hsc_env mlinkable =
, spt <- bc_spt_entries bco
]
-{- Note [-fno-code mode]
-~~~~~~~~~~~~~~~~~~~~~~~~
-GHC offers the flag -fno-code for the purpose of parsing and typechecking a
-program without generating object files. This is intended to be used by tooling
-and IDEs to provide quick feedback on any parser or type errors as cheaply as
-possible.
-
-When GHC is invoked with -fno-code no object files or linked output will be
-generated. As many errors and warnings as possible will be generated, as if
--fno-code had not been passed. The session DynFlags will have
-backend == NoBackend.
-
--fwrite-interface
-~~~~~~~~~~~~~~~~
-Whether interface files are generated in -fno-code mode is controlled by the
--fwrite-interface flag. The -fwrite-interface flag is a no-op if -fno-code is
-not also passed. Recompilation avoidance requires interface files, so passing
--fno-code without -fwrite-interface should be avoided. If -fno-code were
-re-implemented today, -fwrite-interface would be discarded and it would be
-considered always on; this behaviour is as it is for backwards compatibility.
-
-================================================================
-IN SUMMARY: ALWAYS PASS -fno-code AND -fwrite-interface TOGETHER
-================================================================
-
-Template Haskell
-~~~~~~~~~~~~~~~~
-A module using template haskell may invoke an imported function from inside a
-splice. This will cause the type-checker to attempt to execute that code, which
-would fail if no object files had been generated. See #8025. To rectify this,
-during the downsweep we patch the DynFlags in the ModSummary of any home module
-that is imported by a module that uses template haskell, to generate object
-code.
-
-The flavour of the generated code depends on whether `-fprefer-byte-code` is enabled
-or not in the module which needs the code generation. If the module requires byte-code then
-dependencies will generate byte-code, otherwise they will generate object files.
-In the case where some modules require byte-code and some object files, both are
-generated by enabling `-fbyte-code-and-object-code`, the test "fat015" tests these
-configurations.
-
-The object files (and interface files if -fwrite-interface is disabled) produced
-for template haskell are written to temporary files.
-
-Note that since template haskell can run arbitrary IO actions, -fno-code mode
-is no more secure than running without it.
-
-Potential TODOS:
-~~~~~
-* Remove -fwrite-interface and have interface files always written in -fno-code
- mode
-* Both .o and .dyn_o files are generated for template haskell, but we only need
- .dyn_o. Fix it.
-* In make mode, a message like
- Compiling A (A.hs, /tmp/ghc_123.o)
- is shown if downsweep enabled object code generation for A. Perhaps we should
- show "nothing" or "temporary object file" instead. Note that one
- can currently use -keep-tmp-files and inspect the generated file with the
- current behaviour.
-* Offer a -no-codedir command line option, and write what were temporary
- object files there. This would speed up recompilation.
-* Use existing object files (if they are up to date) instead of always
- generating temporary ones.
--}
-- Note [When source is considered modified]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
testsuite/tests/gadt/T23298.hs
=====================================
@@ -0,0 +1,25 @@
+{-# LANGUAGE GADTs #-}
+module T23298 where
+
+import Data.Kind (Type)
+
+type HList :: Type -> Type
+data HList a where
+ HCons :: HList x -> HList (Maybe x)
+
+eq :: HList a -> Bool
+eq x = case x of
+ HCons ms -> True
+
+go (HCons x) = go x
+
+{- go :: HList alpha -> beta
+
+Under HCons
+ [G] alpha ~ Maybe x
+ [W] HList x ~ HList alpha
+==>
+ [W] x ~ alpha
+==>
+ [W] x ~ Maybe x
+-}
=====================================
testsuite/tests/gadt/T23298.stderr
=====================================
@@ -0,0 +1,12 @@
+ T23298.hs:14:16: error: [GHC-25897]
+ • Couldn't match type ‘x’ with ‘Maybe x’
+ Expected: HList x -> t
+ Actual: HList a -> t
+ ‘x’ is a rigid type variable bound by
+ a pattern with constructor:
+ HCons :: forall x. HList x -> HList (Maybe x),
+ in an equation for ‘go’
+ at T23298.hs:14:5-11
+ • In the expression: go x
+ In an equation for ‘go’: go (HCons x) = go x
+ • Relevant bindings include x :: HList x (bound at T23298.hs:14:11)
=====================================
testsuite/tests/gadt/all.T
=====================================
@@ -131,3 +131,4 @@ test('T19847a', normalise_version('base'), compile, ['-ddump-types'])
test('T19847b', normal, compile, [''])
test('T23022', normal, compile, ['-dcore-lint'])
test('T23023', normal, compile_fail, ['-O -dcore-lint']) # todo: move this test?
+test('T23298', normal, compile_fail, [''])
=====================================
testsuite/tests/simplCore/should_compile/T25976.hs
=====================================
@@ -0,0 +1,10 @@
+{-# LANGUAGE MagicHash #-}
+
+module T25976 where
+
+import GHC.PrimOps (tagToEnum#)
+
+-- Spoiler - it's all dead code since tagToEnum 3# is undefined
+main = case (tagToEnum# 4# :: Bool) of
+ True -> print "Dead Code"
+ False -> print "Dead Code"
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -541,3 +541,5 @@ test('T25883', normal, compile_grep_core, [''])
test('T25883b', normal, compile_grep_core, [''])
test('T25883c', normal, compile_grep_core, [''])
test('T25883d', [extra_files(['T25883d_import.hs'])], multimod_compile_filter, ['T25883d', '-O -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques', r'grep -e "y ="'])
+
+test('T25976', [grep_errmsg('Dead Code')], compile, ['-O -ddump-simpl -dsuppress-uniques -dno-typeable-binds'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2fd9a3da0a21c8d09a3ddf8865880b…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2fd9a3da0a21c8d09a3ddf8865880b…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
Simon Peyton Jones pushed to branch wip/T20264 at Glasgow Haskell Compiler / GHC
Commits:
dde6593d by Simon Peyton Jones at 2025-04-22T23:42:54+01:00
Add IfaceExtTyVar
- - - - -
6 changed files:
- compiler/GHC/CoreToIface.hs
- compiler/GHC/Iface/Ext/Utils.hs
- compiler/GHC/Iface/Rename.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Iface/Type.hs
- compiler/GHC/IfaceToCore.hs
Changes:
=====================================
compiler/GHC/CoreToIface.hs
=====================================
@@ -183,7 +183,11 @@ toIfaceTypeX :: VarSet -> Type -> IfaceType
-- Synonyms are retained in the interface type
toIfaceTypeX fr (TyVarTy tv) -- See Note [Free TyVars and CoVars in IfaceType] in GHC.Iface.Type
| tv `elemVarSet` fr = IfaceFreeTyVar tv
+ | isExternalName nm = IfaceExtTyVar nm
| otherwise = IfaceTyVar (toIfaceTyVar tv)
+ where
+ nm = tyVarName tv
+
toIfaceTypeX fr ty@(AppTy {}) =
-- Flatten as many argument AppTys as possible, then turn them into an
-- IfaceAppArgs list.
=====================================
compiler/GHC/Iface/Ext/Utils.hs
=====================================
@@ -164,7 +164,7 @@ hieTypeToIface = foldType go
where
go (HTyVarTy n) = IfaceTyVar $ (mkIfLclName (occNameFS $ getOccName n))
go (HAppTy a b) = IfaceAppTy a (hieToIfaceArgs b)
- go (HLitTy l) = IfaceLitTy l
+ go (HLitTy l) = IfaceLitTy l
go (HForAllTy ((n,k),af) t) = let b = (mkIfLclName (occNameFS $ getOccName n), k)
in IfaceForAllTy (Bndr (IfaceTvBndr b) af) t
go (HFunTy w a b) = IfaceFunTy visArgTypeLike w a b
=====================================
compiler/GHC/Iface/Rename.hs
=====================================
@@ -718,7 +718,8 @@ rnIfaceIdDetails details
rnIfaceType :: Rename IfaceType
rnIfaceType (IfaceFreeTyVar n) = pure (IfaceFreeTyVar n)
-rnIfaceType (IfaceTyVar n) = pure (IfaceTyVar n)
+rnIfaceType (IfaceExtTyVar n) = pure (IfaceExtTyVar n)
+rnIfaceType (IfaceTyVar n) = pure (IfaceTyVar n)
rnIfaceType (IfaceAppTy t1 t2)
= IfaceAppTy <$> rnIfaceType t1 <*> rnIfaceAppArgs t2
rnIfaceType (IfaceLitTy l) = return (IfaceLitTy l)
=====================================
compiler/GHC/Iface/Syntax.hs
=====================================
@@ -2068,8 +2068,9 @@ freeNamesIfAppArgs (IA_Arg t _ ts) = freeNamesIfType t &&& freeNamesIfAppArgs ts
freeNamesIfAppArgs IA_Nil = emptyNameSet
freeNamesIfType :: IfaceType -> NameSet
-freeNamesIfType (IfaceFreeTyVar _) = emptyNameSet
-freeNamesIfType (IfaceTyVar _) = emptyNameSet
+freeNamesIfType (IfaceFreeTyVar {}) = emptyNameSet
+freeNamesIfType (IfaceTyVar {}) = emptyNameSet
+freeNamesIfType (IfaceExtTyVar {}) = emptyNameSet
freeNamesIfType (IfaceAppTy s t) = freeNamesIfType s &&& freeNamesIfAppArgs t
freeNamesIfType (IfaceTyConApp tc ts) = freeNamesIfTc tc &&& freeNamesIfAppArgs ts
freeNamesIfType (IfaceTupleTy _ _ ts) = freeNamesIfAppArgs ts
=====================================
compiler/GHC/Iface/Type.hs
=====================================
@@ -177,6 +177,7 @@ type IfaceKind = IfaceType
data IfaceType
= IfaceFreeTyVar TyVar -- See Note [Free TyVars and CoVars in IfaceType]
| IfaceTyVar IfLclName -- Type/coercion variable only, not tycon
+ | IfaceExtTyVar IfExtName -- Imported or top-level external tyvar
| IfaceLitTy IfaceTyLit
| IfaceAppTy IfaceType IfaceAppArgs
-- See Note [Suppressing invisible arguments] for
@@ -701,6 +702,7 @@ ifTypeIsVarFree :: IfaceType -> Bool
ifTypeIsVarFree ty = go ty
where
go (IfaceTyVar {}) = False
+ go (IfaceExtTyVar {}) = False
go (IfaceFreeTyVar {}) = False
go (IfaceAppTy fun args) = go fun && go_args args
go (IfaceFunTy _ w arg res) = go w && go arg && go res
@@ -723,6 +725,7 @@ visibleTypeVarOccurencies = go
(<>) = Set.union
go (IfaceTyVar var) = Set.singleton var
+ go (IfaceExtTyVar {}) = mempty
go (IfaceFreeTyVar {}) = mempty
go (IfaceAppTy fun args) = go fun <> go_args args
go (IfaceFunTy _ w arg res) = go w <> go arg <> go res
@@ -758,7 +761,8 @@ substIfaceType :: IfaceTySubst -> IfaceType -> IfaceType
substIfaceType env ty
= go ty
where
- go (IfaceFreeTyVar tv) = IfaceFreeTyVar tv
+ go ty@(IfaceFreeTyVar tv) = ty
+ go ty@(IfaceExtTyVar tv) = ty
go (IfaceTyVar tv) = substIfaceTyVar env tv
go (IfaceAppTy t ts) = IfaceAppTy (go t) (substIfaceAppArgs env ts)
go (IfaceFunTy af w t1 t2) = IfaceFunTy af (go w) (go t1) (go t2)
@@ -1143,8 +1147,9 @@ ppr_ty :: PprPrec -> IfaceType -> SDoc
ppr_ty ctxt_prec ty
| not (isIfaceRhoType ty) = ppr_sigma ShowForAllMust ctxt_prec ty
ppr_ty _ (IfaceForAllTy {}) = panic "ppr_ty" -- Covered by not.isIfaceRhoType
-ppr_ty _ (IfaceFreeTyVar tyvar) = ppr tyvar -- This is the main reason for IfaceFreeTyVar!
-ppr_ty _ (IfaceTyVar tyvar) = ppr tyvar -- See Note [Free TyVars and CoVars in IfaceType]
+ppr_ty _ (IfaceFreeTyVar tyvar) = ppr tyvar -- This is the main reason for IfaceFreeTyVar!
+ppr_ty _ (IfaceTyVar tyvar) = ppr tyvar -- See Note [Free TyVars and CoVars in IfaceType]
+ppr_ty _ (IfaceExtTyVar tyvar) = ppr tyvar
ppr_ty ctxt_prec (IfaceTyConApp tc tys) = pprTyTcApp ctxt_prec tc tys
ppr_ty ctxt_prec (IfaceTupleTy i p tys) = ppr_tuple ctxt_prec i p tys -- always fully saturated
ppr_ty _ (IfaceLitTy n) = pprIfaceTyLit n
@@ -1320,7 +1325,7 @@ defaultIfaceTyVarsOfKind def_rep def_mult ty = go emptyFsEnv True ty
= IfaceForAllTy (go_ifacebndr subs bndr) (go subs rank1 ty)
go subs _ ty@(IfaceTyVar tv) = case lookupFsEnv subs (ifLclNameFS tv) of
- Just s -> s
+ Just s -> s
Nothing -> ty
go _ _ ty@(IfaceFreeTyVar tv)
@@ -1343,6 +1348,8 @@ defaultIfaceTyVarsOfKind def_rep def_mult ty = go emptyFsEnv True ty
| otherwise
= ty
+ go _ _ ty@(IfaceExtTyVar {}) = ty
+
go subs _ (IfaceTyConApp tc tc_args)
= IfaceTyConApp tc (go_args subs tc_args)
@@ -2366,6 +2373,9 @@ putIfaceType bh (IfaceTupleTy s i tys)
= do { putByte bh 8; put_ bh s; put_ bh i; put_ bh tys }
putIfaceType bh (IfaceLitTy n)
= do { putByte bh 9; put_ bh n }
+putIfaceType bh (IfaceExtTyVar tv) = do
+ putByte bh 10
+ put_ bh tv
-- | Deserialises an 'IfaceType' from the given 'ReadBinHandle'.
--
@@ -2397,8 +2407,10 @@ getIfaceType bh = do
8 -> do { s <- get bh; i <- get bh; tys <- get bh
; return (IfaceTupleTy s i tys) }
- _ -> do n <- get bh
+ 9 -> do n <- get bh
return (IfaceLitTy n)
+ _ -> do n <- get bh
+ return (IfaceExtTyVar n)
instance Binary IfLclName where
put_ bh = put_ bh . ifLclNameFS
@@ -2586,6 +2598,7 @@ instance NFData IfaceType where
rnf = \case
IfaceFreeTyVar f1 -> f1 `seq` ()
IfaceTyVar f1 -> rnf f1
+ IfaceExtTyVar f1 -> rnf f1
IfaceLitTy f1 -> rnf f1
IfaceAppTy f1 f2 -> rnf f1 `seq` rnf f2
IfaceFunTy f1 f2 f3 f4 -> rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -1502,6 +1502,7 @@ tcIfaceType :: IfaceType -> IfL Type
tcIfaceType = go
where
go (IfaceTyVar n) = TyVarTy <$> tcIfaceTyVar n
+ go (IfaceExtTyVar n) = TyVarTy <$> tcIfaceExtTyVar n
go (IfaceFreeTyVar n) = pprPanic "tcIfaceType:IfaceFreeTyVar" (ppr n)
go (IfaceLitTy l) = LitTy <$> tcIfaceTyLit l
go (IfaceFunTy flag w t1 t2) = FunTy flag <$> tcIfaceType w <*> go t1 <*> go t2
@@ -2144,6 +2145,13 @@ tcIfaceGlobal name
-- the constructor (A and B) means that GHC will always typecheck
-- this expression *after* typechecking T.
+tcIfaceExtTyVar :: Name -> IfL TyVar
+tcIfaceExtTyVar name
+ = do { thing <- tcIfaceGlobal name
+ ; case thing of
+ ATyVar tv -> return tv
+ _ -> pprPanic "tcIfaceExtTyVar" (ppr thing) }
+
tcIfaceTyCon :: IfaceTyCon -> IfL TyCon
tcIfaceTyCon (IfaceTyCon name _info)
= do { thing <- tcIfaceGlobal name
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/dde6593d45bf3090cfc0ccdb1fe0169…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/dde6593d45bf3090cfc0ccdb1fe0169…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/T20264] Missing case in tyThingEntityInfo
by Simon Peyton Jones (＠simonpj) 22 Apr '25
by Simon Peyton Jones (＠simonpj) 22 Apr '25
22 Apr '25
Simon Peyton Jones pushed to branch wip/T20264 at Glasgow Haskell Compiler / GHC
Commits:
c7a75ca9 by Simon Peyton Jones at 2025-04-22T22:20:00+01:00
Missing case in tyThingEntityInfo
- - - - -
1 changed file:
- compiler/GHC/Iface/Ext/Types.hs
Changes:
=====================================
compiler/GHC/Iface/Ext/Types.hs
=====================================
@@ -867,11 +867,13 @@ idEntityInfo vid = S.fromList $ [EntityTypeVariable | isTyVar vid] <> [EntityFun
-- | Get the `EntityInfo` for a `TyThing`
tyThingEntityInfo :: TyThing -> S.Set EntityInfo
tyThingEntityInfo ty = case ty of
- AnId vid -> idEntityInfo vid
+ AnId vid -> idEntityInfo vid
+ ATyVar {} -> S.singleton EntityTypeVariable
AConLike con -> case con of
RealDataCon _ -> S.singleton EntityDataConstructor
PatSynCon _ -> S.singleton EntityPatternSynonym
- ATyCon tyCon -> S.fromList $ [EntityTypeSynonym | isTypeSynonymTyCon tyCon] <> [EntityTypeFamily | isFamilyTyCon tyCon]
+ ATyCon tyCon -> S.fromList $ [EntityTypeSynonym | isTypeSynonymTyCon tyCon]
+ <> [EntityTypeFamily | isFamilyTyCon tyCon]
<> [EntityTypeClass | isClassTyCon tyCon] <> [EntityTypeConstructor]
ACoAxiom _ -> S.empty
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c7a75ca92dfa4b8bd73d289a8851e8c…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c7a75ca92dfa4b8bd73d289a8851e8c…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/T25965] 4 commits: Simplifier: Constant fold invald tagToEnum# calls to bottom expr.
by Simon Peyton Jones (＠simonpj) 22 Apr '25
by Simon Peyton Jones (＠simonpj) 22 Apr '25
22 Apr '25
Simon Peyton Jones pushed to branch wip/T25965 at Glasgow Haskell Compiler / GHC
Commits:
2e204269 by Andreas Klebinger at 2025-04-22T12:20:41+02:00
Simplifier: Constant fold invald tagToEnum# calls to bottom expr.
When applying tagToEnum# to a out-of-range value it's best to simply
constant fold it to a bottom expression. That potentially allows more
dead code elimination and makes debugging easier.
Fixes #25976
- - - - -
7250fc0c by Matthew Pickering at 2025-04-22T16:24:04-04:00
Move -fno-code note into Downsweep module
This note was left behind when all the code which referred to it was
moved into the GHC.Driver.Downsweep module
- - - - -
d2dc89b4 by Matthew Pickering at 2025-04-22T16:24:04-04:00
Apply editing notes to Note [-fno-code mode] suggested by sheaf
These notes were suggested in https://gitlab.haskell.org/ghc/ghc/-/merge_requests/14241
- - - - -
04f7475e by Simon Peyton Jones at 2025-04-22T22:13:27+01:00
Fix infelicities in the Specialiser
On the way to #23109 (unary classes) I discovered some infelicities
(or maybe tiny bugs, I forget) in the type-class specialiser.
I also tripped over #25965, an outright bug in the rule matcher
Specifically:
* Refactor: I enhanced `wantCallsFor`, whih previously always said
`True`, to discard calls of class-ops, data constructors etc. This is
a bit more efficient; and it means we don't need to worry about
filtering them out later.
* Fix: I tidied up some tricky logic that eliminated redundant
specialisations. It wasn't working correctly. See the expanded
Note [Specialisations already covered], and
(MP3) in Note [Specialising polymorphic dictionaries].
See also the new top-level `alreadyCovered`
function, which now goes via `GHC.Core.Rules.ruleLhsIsMoreSpecific`
I also added a useful Note [The (CI-KEY) invariant]
* Fix #25965: fixed a tricky bug in the `go_fam_fam` in
`GHC.Core.Unify.uVarOrFam`, which allows matching to succeed
without binding all type varibles.
I enhanced Note [Apartness and type families] some more
* #25703. This ticket "just works" with -fpolymorphic-specialisation;
but I was surprised that it worked! In this MR I added documentation
to Note [Interesting dictionary arguments] to explain; and tests to
ensure it stays fixed.
- - - - -
15 changed files:
- compiler/GHC/Core/Opt/ConstantFold.hs
- compiler/GHC/Core/Opt/Specialise.hs
- compiler/GHC/Core/Rules.hs
- compiler/GHC/Core/Unify.hs
- compiler/GHC/Driver/Downsweep.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Tc/Solver/Equality.hs
- compiler/GHC/Types/Basic.hs
- + testsuite/tests/simplCore/should_compile/T25703.hs
- + testsuite/tests/simplCore/should_compile/T25703.stderr
- + testsuite/tests/simplCore/should_compile/T25703a.hs
- + testsuite/tests/simplCore/should_compile/T25703a.stderr
- + testsuite/tests/simplCore/should_compile/T25965.hs
- + testsuite/tests/simplCore/should_compile/T25976.hs
- testsuite/tests/simplCore/should_compile/all.T
Changes:
=====================================
compiler/GHC/Core/Opt/ConstantFold.hs
=====================================
@@ -69,7 +69,6 @@ import GHC.Cmm.MachOp ( FMASign(..) )
import GHC.Cmm.Type ( Width(..) )
import GHC.Data.FastString
-import GHC.Data.Maybe ( orElse )
import GHC.Utils.Outputable
import GHC.Utils.Misc
@@ -1997,6 +1996,14 @@ because we don't expect the user to call tagToEnum# at all; we merely
generate calls in derived instances of Enum. So we compromise: a
rewrite rule rewrites a bad instance of tagToEnum# to an error call,
and emits a warning.
+
+We also do something similar if we can see that the argument of tagToEnum is out
+of bounds, e.g. `tagToEnum# 99# :: Bool`.
+Replacing this with an error expression is better for two reasons:
+* It allow us to eliminate more dead code in cases like `case tagToEnum# 99# :: Bool of ...`
+* Should we actually end up executing the relevant code at runtime the user will
+ see a meaningful error message, instead of a segfault or incorrect result.
+See #25976.
-}
tagToEnumRule :: RuleM CoreExpr
@@ -2008,9 +2015,13 @@ tagToEnumRule = do
Just (tycon, tc_args) | isEnumerationTyCon tycon -> do
let tag = fromInteger i
correct_tag dc = (dataConTagZ dc) == tag
- (dc:rest) <- return $ filter correct_tag (tyConDataCons_maybe tycon `orElse` [])
- massert (null rest)
- return $ mkTyApps (Var (dataConWorkId dc)) tc_args
+ Just dataCons <- pure $ tyConDataCons_maybe tycon
+ case filter correct_tag dataCons of
+ (dc:rest) -> do
+ massert (null rest)
+ pure $ mkTyApps (Var (dataConWorkId dc)) tc_args
+ -- Literal is out of range, e.g. tagToEnum @Bool #4
+ [] -> pure $ mkImpossibleExpr ty "tagToEnum: Argument out of range"
-- See Note [tagToEnum#]
_ -> warnPprTrace True "tagToEnum# on non-enumeration type" (ppr ty) $
=====================================
compiler/GHC/Core/Opt/Specialise.hs
=====================================
@@ -1243,14 +1243,15 @@ specExpr env (Let bind body)
-- Note [Fire rules in the specialiser]
fireRewriteRules :: SpecEnv -> InExpr -> [OutExpr] -> (InExpr, [OutExpr])
fireRewriteRules env (Var f) args
- | Just (rule, expr) <- specLookupRule env f args InitialPhase (getRules (se_rules env) f)
+ | let rules = getRules (se_rules env) f
+ , Just (rule, expr) <- specLookupRule env f args activeInInitialPhase rules
, let rest_args = drop (ruleArity rule) args -- See Note [Extra args in the target]
zapped_subst = Core.zapSubst (se_subst env)
expr' = simpleOptExprWith defaultSimpleOpts zapped_subst expr
-- simplOptExpr needed because lookupRule returns
-- (\x y. rhs) arg1 arg2
- , (fun, args) <- collectArgs expr'
- = fireRewriteRules env fun (args++rest_args)
+ , (fun', args') <- collectArgs expr'
+ = fireRewriteRules env fun' (args'++rest_args)
fireRewriteRules _ fun args = (fun, args)
--------------
@@ -1620,7 +1621,7 @@ specCalls :: Bool -- True => specialising imported fn
-- This function checks existing rules, and does not create
-- duplicate ones. So the caller does not need to do this filtering.
--- See 'already_covered'
+-- See `alreadyCovered`
type SpecInfo = ( [CoreRule] -- Specialisation rules
, [(Id,CoreExpr)] -- Specialised definition
@@ -1644,15 +1645,13 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
= -- pprTrace "specCalls: some" (vcat
-- [ text "function" <+> ppr fn
- -- , text "calls:" <+> ppr calls_for_me
- -- , text "subst" <+> ppr (se_subst env) ]) $
+ -- , text "calls:" <+> ppr calls_for_me
+ -- , text "subst" <+> ppr (se_subst env) ]) $
foldlM spec_call ([], [], emptyUDs) calls_for_me
| otherwise -- No calls or RHS doesn't fit our preconceptions
- = warnPprTrace (not (exprIsTrivial rhs) && notNull calls_for_me && not (isClassOpId fn))
+ = warnPprTrace (not (exprIsTrivial rhs) && notNull calls_for_me)
"Missed specialisation opportunity for" (ppr fn $$ trace_doc) $
- -- isClassOpId: class-op Ids never inline; we specialise them
- -- through fireRewriteRules. So don't complain about missed opportunities
-- Note [Specialisation shape]
-- pprTrace "specCalls: none" (ppr fn <+> ppr calls_for_me) $
return ([], [], emptyUDs)
@@ -1664,6 +1663,10 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
fn_unf = realIdUnfolding fn -- Ignore loop-breaker-ness here
inl_prag = idInlinePragma fn
inl_act = inlinePragmaActivation inl_prag
+ is_active = isActive (beginPhase inl_act) :: Activation -> Bool
+ -- is_active: inl_act is the activation we are going to put in the new
+ -- SPEC rule; so we want to see if it is covered by another rule with
+ -- that same activation.
is_local = isLocalId fn
is_dfun = isDFunId fn
dflags = se_dflags env
@@ -1674,16 +1677,6 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
(rhs_bndrs, rhs_body) = collectBindersPushingCo rhs
-- See Note [Account for casts in binding]
- already_covered :: SpecEnv -> [CoreRule] -> [CoreExpr] -> Bool
- already_covered env new_rules args -- Note [Specialisations already covered]
- = isJust (specLookupRule env fn args (beginPhase inl_act)
- (new_rules ++ existing_rules))
- -- Rules: we look both in the new_rules (generated by this invocation
- -- of specCalls), and in existing_rules (passed in to specCalls)
- -- inl_act: is the activation we are going to put in the new SPEC
- -- rule; so we want to see if it is covered by another rule with
- -- that same activation.
-
----------------------------------------------------------
-- Specialise to one particular call pattern
spec_call :: SpecInfo -- Accumulating parameter
@@ -1717,8 +1710,12 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
-- , ppr dx_binds ]) $
-- return ()
+ ; let all_rules = rules_acc ++ existing_rules
+ -- all_rules: we look both in the rules_acc (generated by this invocation
+ -- of specCalls), and in existing_rules (passed in to specCalls)
; if not useful -- No useful specialisation
- || already_covered rhs_env2 rules_acc rule_lhs_args
+ || alreadyCovered rhs_env2 rule_bndrs fn rule_lhs_args is_active all_rules
+ -- See (SC1) in Note [Specialisations already covered]
then return spec_acc
else
do { -- Run the specialiser on the specialised RHS
@@ -1780,7 +1777,7 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
spec_fn_details
= case idDetails fn of
JoinId join_arity _ -> JoinId (join_arity - join_arity_decr) Nothing
- DFunId is_nt -> DFunId is_nt
+ DFunId unary -> DFunId unary
_ -> VanillaId
; spec_fn <- newSpecIdSM (idName fn) spec_fn_ty spec_fn_details spec_fn_info
@@ -1804,6 +1801,8 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
, ppr spec_fn <+> dcolon <+> ppr spec_fn_ty
, ppr rhs_bndrs, ppr call_args
, ppr spec_rule
+ , text "acc" <+> ppr rules_acc
+ , text "existing" <+> ppr existing_rules
]
; -- pprTrace "spec_call: rule" _rule_trace_doc
@@ -1812,19 +1811,35 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
, spec_uds `thenUDs` uds_acc
) } }
+alreadyCovered :: SpecEnv
+ -> [Var] -> Id -> [CoreExpr] -- LHS of possible new rule
+ -> (Activation -> Bool) -- Which rules are active
+ -> [CoreRule] -> Bool
+-- Note [Specialisations already covered] esp (SC2)
+alreadyCovered env bndrs fn args is_active rules
+ = case specLookupRule env fn args is_active rules of
+ Nothing -> False
+ Just (rule, _)
+ | isAutoRule rule -> -- Discard identical rules
+ -- We know that (fn args) is an instance of RULE
+ -- Check if RULE is an instance of (fn args)
+ ruleLhsIsMoreSpecific in_scope bndrs args rule
+ | otherwise -> True -- User rules dominate
+ where
+ in_scope = substInScopeSet (se_subst env)
+
-- Convenience function for invoking lookupRule from Specialise
-- The SpecEnv's InScopeSet should include all the Vars in the [CoreExpr]
specLookupRule :: SpecEnv -> Id -> [CoreExpr]
- -> CompilerPhase -- Look up rules as if we were in this phase
+ -> (Activation -> Bool) -- Which rules are active
-> [CoreRule] -> Maybe (CoreRule, CoreExpr)
-specLookupRule env fn args phase rules
+specLookupRule env fn args is_active rules
= lookupRule ropts in_scope_env is_active fn args rules
where
dflags = se_dflags env
in_scope = substInScopeSet (se_subst env)
in_scope_env = ISE in_scope (whenActiveUnfoldingFun is_active)
ropts = initRuleOpts dflags
- is_active = isActive phase
{- Note [Specialising DFuns]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2323,21 +2338,24 @@ This plan is implemented in the Rec case of specBindItself.
Note [Specialisations already covered]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We obviously don't want to generate two specialisations for the same
-argument pattern. There are two wrinkles
-
-1. We do the already-covered test in specDefn, not when we generate
-the CallInfo in mkCallUDs. We used to test in the latter place, but
-we now iterate the specialiser somewhat, and the Id at the call site
-might therefore not have all the RULES that we can see in specDefn
-
-2. What about two specialisations where the second is an *instance*
-of the first? If the more specific one shows up first, we'll generate
-specialisations for both. If the *less* specific one shows up first,
-we *don't* currently generate a specialisation for the more specific
-one. (See the call to lookupRule in already_covered.) Reasons:
- (a) lookupRule doesn't say which matches are exact (bad reason)
- (b) if the earlier specialisation is user-provided, it's
- far from clear that we should auto-specialise further
+argument pattern. Wrinkles
+
+(SC1) We do the already-covered test in specDefn, not when we generate
+ the CallInfo in mkCallUDs. We used to test in the latter place, but
+ we now iterate the specialiser somewhat, and the Id at the call site
+ might therefore not have all the RULES that we can see in specDefn
+
+(SC2) What about two specialisations where the second is an *instance*
+ of the first? It's a bit arbitrary, but here's what we do:
+ * If the existing one is user-specified, via a SPECIALISE pragma, we
+ suppress the further specialisation.
+ * If the existing one is auto-generated, we generate a second RULE
+ for the more specialised version.
+ The latter is important because we don't want the accidental order
+ of calls to determine what specialisations we generate.
+
+(SC3) Annoyingly, we /also/ eliminate duplicates in `filterCalls`.
+ See (MP3) in Note [Specialising polymorphic dictionaries]
Note [Auto-specialisation and RULES]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2800,12 +2818,10 @@ non-dictionary bindings too.
Note [Specialising polymorphic dictionaries]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
Note June 2023: This has proved to be quite a tricky optimisation to get right
see (#23469, #23109, #21229, #23445) so it is now guarded by a flag
`-fpolymorphic-specialisation`.
-
Consider
class M a where { foo :: a -> Int }
@@ -2845,11 +2861,26 @@ Here are the moving parts:
function.
(MP3) If we have f :: forall m. Monoid m => blah, and two calls
- (f @(Endo b) (d :: Monoid (Endo b))
- (f @(Endo (c->c)) (d :: Monoid (Endo (c->c)))
+ (f @(Endo b) (d1 :: Monoid (Endo b))
+ (f @(Endo (c->c)) (d2 :: Monoid (Endo (c->c)))
we want to generate a specialisation only for the first. The second
is just a substitution instance of the first, with no greater specialisation.
- Hence the call to `remove_dups` in `filterCalls`.
+ Hence the use of `removeDupCalls` in `filterCalls`.
+
+ You might wonder if `d2` might be more specialised than `d1`; but no.
+ This `removeDupCalls` thing is at the definition site of `f`, and both `d1`
+ and `d2` are in scope. So `d1` is simply more polymorphic than `d2`, but
+ is just as specialised.
+
+ This distinction is sadly lost once we build a RULE, so `alreadyCovered`
+ can't be so clever. E.g if we have an existing RULE
+ forall @a (d1:Ord Int) (d2: Eq a). f @a @Int d1 d2 = ...
+ and a putative new rule
+ forall (d1:Ord Int) (d2: Eq Int). f @Int @Int d1 d2 = ...
+ we /don't/ want the existing rule to subsume the new one.
+
+ So we sadly put up with having two rather different places where we
+ eliminate duplicates: `alreadyCovered` and `removeDupCalls`.
All this arose in #13873, in the unexpected form that a SPECIALISE
pragma made the program slower! The reason was that the specialised
@@ -2947,16 +2978,29 @@ data CallInfoSet = CIS Id (Bag CallInfo)
-- The list of types and dictionaries is guaranteed to
-- match the type of f
-- The Bag may contain duplicate calls (i.e. f @T and another f @T)
- -- These dups are eliminated by already_covered in specCalls
+ -- These dups are eliminated by alreadyCovered in specCalls
data CallInfo
- = CI { ci_key :: [SpecArg] -- All arguments
+ = CI { ci_key :: [SpecArg] -- Arguments of the call
+ -- See Note [The (CI-KEY) invariant]
+
, ci_fvs :: IdSet -- Free Ids of the ci_key call
-- /not/ including the main id itself, of course
-- NB: excluding tyvars:
-- See Note [Specialising polymorphic dictionaries]
}
+{- Note [The (CI-KEY) invariant]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Invariant (CI-KEY):
+ In the `ci_key :: [SpecArg]` field of `CallInfo`,
+ * The list is non-empty
+ * The least element is always a `SpecDict`
+
+In this way the RULE has as few args as possible, which broadens its
+applicability, since rules only fire when saturated.
+-}
+
type DictExpr = CoreExpr
ciSetFilter :: (CallInfo -> Bool) -> CallInfoSet -> CallInfoSet
@@ -3045,10 +3089,7 @@ mkCallUDs' env f args
ci_key :: [SpecArg]
ci_key = dropWhileEndLE (not . isSpecDict) $
zipWith mk_spec_arg args pis
- -- Drop trailing args until we get to a SpecDict
- -- In this way the RULE has as few args as possible,
- -- which broadens its applicability, since rules only
- -- fire when saturated
+ -- Establish (CI-KEY): drop trailing args until we get to a SpecDict
mk_spec_arg :: OutExpr -> PiTyBinder -> SpecArg
mk_spec_arg arg (Named bndr)
@@ -3086,34 +3127,76 @@ site, so we only look through ticks that RULE matching looks through
-}
wantCallsFor :: SpecEnv -> Id -> Bool
-wantCallsFor _env _f = True
- -- We could reduce the size of the UsageDetails by being less eager
- -- about collecting calls for LocalIds: there is no point for
- -- ones that are lambda-bound. We can't decide this by looking at
- -- the (absence of an) unfolding, because unfoldings for local
- -- functions are discarded by cloneBindSM, so no local binder will
- -- have an unfolding at this stage. We'd have to keep a candidate
- -- set of let-binders.
- --
- -- Not many lambda-bound variables have dictionary arguments, so
- -- this would make little difference anyway.
- --
- -- For imported Ids we could check for an unfolding, but we have to
- -- do so anyway in canSpecImport, and it seems better to have it
- -- all in one place. So we simply collect usage info for imported
- -- overloaded functions.
-
-{- Note [Interesting dictionary arguments]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider this
- \a.\d:Eq a. let f = ... in ...(f d)...
-There really is not much point in specialising f wrt the dictionary d,
-because the code for the specialised f is not improved at all, because
-d is lambda-bound. We simply get junk specialisations.
-
-What is "interesting"? Just that it has *some* structure. But what about
-variables? We look in the variable's /unfolding/. And that means
-that we must be careful to ensure that dictionaries have unfoldings,
+-- See Note [wantCallsFor]
+wantCallsFor _env f
+ = case idDetails f of
+ RecSelId {} -> False
+ DataConWorkId {} -> False
+ DataConWrapId {} -> False
+ ClassOpId {} -> False
+ PrimOpId {} -> False
+ FCallId {} -> False
+ TickBoxOpId {} -> False
+ CoVarId {} -> False
+
+ DFunId {} -> True
+ VanillaId {} -> True
+ JoinId {} -> True
+ WorkerLikeId {} -> True
+ RepPolyId {} -> True
+
+{- Note [wantCallsFor]
+~~~~~~~~~~~~~~~~~~~~~~
+`wantCallsFor env f` says whether the Specialiser should collect calls for
+function `f`; other thing being equal, the fewer calls we collect the better. It
+is False for things we can't specialise:
+
+* ClassOpId: never inline and we don't have a defn to specialise; we specialise
+ them through fireRewriteRules.
+* PrimOpId: are never overloaded
+* Data constructors: we never specialise them
+
+We could reduce the size of the UsageDetails by being less eager about
+collecting calls for some LocalIds: there is no point for ones that are
+lambda-bound. We can't decide this by looking at the (absence of an) unfolding,
+because unfoldings for local functions are discarded by cloneBindSM, so no local
+binder will have an unfolding at this stage. We'd have to keep a candidate set
+of let-binders.
+
+Not many lambda-bound variables have dictionary arguments, so this would make
+little difference anyway.
+
+For imported Ids we could check for an unfolding, but we have to do so anyway in
+canSpecImport, and it seems better to have it all in one place. So we simply
+collect usage info for imported overloaded functions.
+
+Note [Interesting dictionary arguments]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In `mkCallUDs` we only use `SpecDict` for dictionaries of which
+`interestingDict` holds. Otherwise we use `UnspecArg`. Two reasons:
+
+* Consider this
+ \a.\d:Eq a. let f = ... in ...(f d)...
+ There really is not much point in specialising f wrt the dictionary d,
+ because the code for the specialised f is not improved at all, because
+ d is lambda-bound. We simply get junk specialisations.
+
+* Consider this (#25703):
+ f :: (Eq a, Show b) => a -> b -> INt
+ goo :: forall x. (Eq x) => x -> blah
+ goo @x (d:Eq x) (arg:x) = ...(f @x @Int d $fShowInt)...
+ If we built a `ci_key` with a (SpecDict d) for `d`, we would end up
+ discarding the call at the `\d`. But if we use `UnspecArg` for that
+ uninteresting `d`, we'll get a `ci_key` of
+ f @x @Int UnspecArg (SpecDict $fShowInt)
+ and /that/ can float out to f's definition and specialise nicely.
+ Hooray. (NB: the call can float only if `-fpolymorphic-specialisation`
+ is on; otherwise it'll be trapped by the `\@x -> ...`.)(
+
+What is "interesting"? (See `interestingDict`.) Just that it has *some*
+structure. But what about variables? We look in the variable's /unfolding/.
+And that means that we must be careful to ensure that dictionaries /have/
+unfoldings,
* cloneBndrSM discards non-Stable unfoldings
* specBind updates the unfolding after specialisation
@@ -3159,7 +3242,7 @@ Now `f` turns into:
meth @a dc ....
When we specialise `f`, at a=Int say, that superclass selection can
-nfire (via rewiteClassOps), but that info (that 'dc' is now a
+fire (via rewiteClassOps), but that info (that 'dc' is now a
particular dictionary `C`, of type `C Int`) must be available to
the call `meth @a dc`, so that we can fire the `meth` class-op, and
thence specialise `wombat`.
@@ -3286,7 +3369,11 @@ dumpUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, OrdList DictBind)
-- Used at a lambda or case binder; just dump anything mentioning the binder
dumpUDs bndrs uds@(MkUD { ud_binds = orig_dbs, ud_calls = orig_calls })
| null bndrs = (uds, nilOL) -- Common in case alternatives
- | otherwise = -- pprTrace "dumpUDs" (ppr bndrs $$ ppr free_uds $$ ppr dump_dbs) $
+ | otherwise = -- pprTrace "dumpUDs" (vcat
+ -- [ text "bndrs" <+> ppr bndrs
+ -- , text "uds" <+> ppr uds
+ -- , text "free_uds" <+> ppr free_uds
+ -- , text "dump-dbs" <+> ppr dump_dbs ]) $
(free_uds, dump_dbs)
where
free_uds = uds { ud_binds = free_dbs, ud_calls = free_calls }
@@ -3325,20 +3412,17 @@ callsForMe fn uds@MkUD { ud_binds = orig_dbs, ud_calls = orig_calls }
calls_for_me = case lookupDVarEnv orig_calls fn of
Nothing -> []
Just cis -> filterCalls cis orig_dbs
- -- filterCalls: drop calls that (directly or indirectly)
- -- refer to fn. See Note [Avoiding loops (DFuns)]
----------------------
filterCalls :: CallInfoSet -> FloatedDictBinds -> [CallInfo]
--- Remove dominated calls (Note [Specialising polymorphic dictionaries])
--- and loopy DFuns (Note [Avoiding loops (DFuns)])
+-- Remove
+-- (a) dominated calls: (MP3) in Note [Specialising polymorphic dictionaries]
+-- (b) loopy DFuns: Note [Avoiding loops (DFuns)]
filterCalls (CIS fn call_bag) (FDB { fdb_binds = dbs })
- | isDFunId fn -- Note [Avoiding loops (DFuns)] applies only to DFuns
- = filter ok_call de_dupd_calls
- | otherwise -- Do not apply it to non-DFuns
- = de_dupd_calls -- See Note [Avoiding loops (non-DFuns)]
+ | isDFunId fn = filter ok_call de_dupd_calls -- Deals with (b)
+ | otherwise = de_dupd_calls
where
- de_dupd_calls = remove_dups call_bag
+ de_dupd_calls = removeDupCalls call_bag -- Deals with (a)
dump_set = foldl' go (unitVarSet fn) dbs
-- This dump-set could also be computed by splitDictBinds
@@ -3352,10 +3436,10 @@ filterCalls (CIS fn call_bag) (FDB { fdb_binds = dbs })
ok_call (CI { ci_fvs = fvs }) = fvs `disjointVarSet` dump_set
-remove_dups :: Bag CallInfo -> [CallInfo]
+removeDupCalls :: Bag CallInfo -> [CallInfo]
-- Calls involving more generic instances beat more specific ones.
-- See (MP3) in Note [Specialising polymorphic dictionaries]
-remove_dups calls = foldr add [] calls
+removeDupCalls calls = foldr add [] calls
where
add :: CallInfo -> [CallInfo] -> [CallInfo]
add ci [] = [ci]
@@ -3364,12 +3448,20 @@ remove_dups calls = foldr add [] calls
| otherwise = ci2 : add ci1 cis
beats_or_same :: CallInfo -> CallInfo -> Bool
+-- (beats_or_same ci1 ci2) is True if specialising on ci1 subsumes ci2
+-- That is: ci1's types are less specialised than ci2
+-- ci1 specialises on the same dict args as ci2
beats_or_same (CI { ci_key = args1 }) (CI { ci_key = args2 })
= go args1 args2
where
- go [] _ = True
+ go [] [] = True
go (arg1:args1) (arg2:args2) = go_arg arg1 arg2 && go args1 args2
- go (_:_) [] = False
+
+ -- If one or the other runs dry, the other must still have a SpecDict
+ -- because of the (CI-KEY) invariant. So neither subsumes the other;
+ -- one is more specialised (faster code) but the other is more generally
+ -- applicable.
+ go _ _ = False
go_arg (SpecType ty1) (SpecType ty2) = isJust (tcMatchTy ty1 ty2)
go_arg UnspecType UnspecType = True
=====================================
compiler/GHC/Core/Rules.hs
=====================================
@@ -9,7 +9,7 @@
-- The 'CoreRule' datatype itself is declared elsewhere.
module GHC.Core.Rules (
-- ** Looking up rules
- lookupRule, matchExprs,
+ lookupRule, matchExprs, ruleLhsIsMoreSpecific,
-- ** RuleBase, RuleEnv
RuleBase, RuleEnv(..), mkRuleEnv, emptyRuleEnv,
@@ -587,8 +587,8 @@ findBest :: InScopeSet -> (Id, [CoreExpr])
findBest _ _ (rule,ans) [] = (rule,ans)
findBest in_scope target (rule1,ans1) ((rule2,ans2):prs)
- | isMoreSpecific in_scope rule1 rule2 = findBest in_scope target (rule1,ans1) prs
- | isMoreSpecific in_scope rule2 rule1 = findBest in_scope target (rule2,ans2) prs
+ | ruleIsMoreSpecific in_scope rule1 rule2 = findBest in_scope target (rule1,ans1) prs
+ | ruleIsMoreSpecific in_scope rule2 rule1 = findBest in_scope target (rule2,ans2) prs
| debugIsOn = let pp_rule rule
= ifPprDebug (ppr rule)
(doubleQuotes (ftext (ruleName rule)))
@@ -603,15 +603,25 @@ findBest in_scope target (rule1,ans1) ((rule2,ans2):prs)
where
(fn,args) = target
-isMoreSpecific :: InScopeSet -> CoreRule -> CoreRule -> Bool
--- The call (rule1 `isMoreSpecific` rule2)
+ruleIsMoreSpecific :: InScopeSet -> CoreRule -> CoreRule -> Bool
+-- The call (rule1 `ruleIsMoreSpecific` rule2)
-- sees if rule2 can be instantiated to look like rule1
--- See Note [isMoreSpecific]
-isMoreSpecific _ (BuiltinRule {}) _ = False
-isMoreSpecific _ (Rule {}) (BuiltinRule {}) = True
-isMoreSpecific in_scope (Rule { ru_bndrs = bndrs1, ru_args = args1 })
- (Rule { ru_bndrs = bndrs2, ru_args = args2 })
- = isJust (matchExprs in_scope_env bndrs2 args2 args1)
+-- See Note [ruleIsMoreSpecific]
+ruleIsMoreSpecific in_scope rule1 rule2
+ = case rule1 of
+ BuiltinRule {} -> False
+ Rule { ru_bndrs = bndrs1, ru_args = args1 }
+ -> ruleLhsIsMoreSpecific in_scope bndrs1 args1 rule2
+
+ruleLhsIsMoreSpecific :: InScopeSet
+ -> [Var] -> [CoreExpr] -- LHS of a possible new rule
+ -> CoreRule -- An existing rule
+ -> Bool -- New one is more specific
+ruleLhsIsMoreSpecific in_scope bndrs1 args1 rule2
+ = case rule2 of
+ BuiltinRule {} -> True
+ Rule { ru_bndrs = bndrs2, ru_args = args2 }
+ -> isJust (matchExprs in_scope_env bndrs2 args2 args1)
where
full_in_scope = in_scope `extendInScopeSetList` bndrs1
in_scope_env = ISE full_in_scope noUnfoldingFun
@@ -620,9 +630,9 @@ isMoreSpecific in_scope (Rule { ru_bndrs = bndrs1, ru_args = args1 })
noBlackList :: Activation -> Bool
noBlackList _ = False -- Nothing is black listed
-{- Note [isMoreSpecific]
+{- Note [ruleIsMoreSpecific]
~~~~~~~~~~~~~~~~~~~~~~~~
-The call (rule1 `isMoreSpecific` rule2)
+The call (rule1 `ruleIsMoreSpecific` rule2)
sees if rule2 can be instantiated to look like rule1.
Wrinkle:
@@ -825,7 +835,7 @@ bound on the LHS:
The rule looks like
forall (a::*) (d::Eq Char) (x :: Foo a Char).
- f (Foo a Char) d x = True
+ f @(Foo a Char) d x = True
Matching the rule won't bind 'a', and legitimately so. We fudge by
pretending that 'a' is bound to (Any :: *).
=====================================
compiler/GHC/Core/Unify.hs
=====================================
@@ -331,35 +331,57 @@ Wrinkles
`DontBindMe`, the unifier must return `SurelyApart`, not `MaybeApart`. See
`go_fam` in `uVarOrFam`
-(ATF6) You might think that when /matching/ the um_fam_env will always be empty,
- because type-class-instance and type-family-instance heads can't include type
- families. E.g. instance C (F a) where ... -- Illegal
-
- But you'd be wrong: when "improving" type family constraint we may have a
- type family on the LHS of a match. Consider
+(ATF6) When /matching/ can we ever have a type-family application on the LHS, in
+ the template? You might think not, because type-class-instance and
+ type-family-instance heads can't include type families. E.g.
+ instance C (F a) where ... -- Illegal
+
+ But you'd be wrong: even when matching, we can see type families in the LHS template:
+ * In `checkValidClass`, in `check_dm` we check that the default method has the
+ right type, using matching, both ways. And that type may have type-family
+ applications in it. Example in test CoOpt_Singletons.
+
+ * In the specialiser: see the call to `tcMatchTy` in
+ `GHC.Core.Opt.Specialise.beats_or_same`
+
+ * With -fpolymorphic-specialsation, we might get a specialiation rule like
+ RULE forall a (d :: Eq (Maybe (F a))) .
+ f @(Maybe (F a)) d = ...
+ See #25965.
+
+ * A user-written RULE could conceivably have a type-family application
+ in the template. It might not be a good rule, but I don't think we currently
+ check for this.
+
+ In all these cases we are only interested in finding a substitution /for
+ type variables/ that makes the match work. So we simply want to recurse into
+ the arguments of the type family. E.g.
+ Template: forall a. Maybe (F a)
+ Target: Mabybe (F Int)
+ We want to succeed with substitution [a :-> Int]. See (ATF9).
+
+ Conclusion: where we enter via `tcMatchTy`, `tcMatchTys`, `tc_match_tys`,
+ etc, we always end up in `tc_match_tys_x`. There we invoke the unifier
+ but we do not distinguish between `SurelyApart` and `MaybeApart`. So in
+ these cases we can set `um_bind_fam_fun` to `neverBindFam`.
+
+(ATF7) There is one other, very special case of matching where we /do/ want to
+ bind type families in `um_fam_env`, namely in GHC.Tc.Solver.Equality, the call
+ to `tcUnifyTyForInjectivity False` in `improve_injective_wanted_top`.
+ Consider
+ of a match. Consider
type family G6 a = r | r -> a
type instance G6 [a] = [G a]
type instance G6 Bool = Int
- and the Wanted constraint [W] G6 alpha ~ [Int]. We /match/ each type instance
- RHS against [Int]! So we try
- [G a] ~ [Int]
+ and suppose we haev a Wanted constraint
+ [W] G6 alpha ~ [Int]
+. According to Section 5.2 of "Injective type families for Haskell", we /match/
+ the RHS each type instance [Int]. So we try
+ Template: [G a] Target: [Int]
and we want to succeed with MaybeApart, so that we can generate the improvement
- constraint [W] alpha ~ [beta] where beta is fresh.
- See Section 5.2 of "Injective type families for Haskell".
-
- A second place that we match with type-fams on the LHS is in `checkValidClass`.
- In `check_dm` we check that the default method has the right type, using matching,
- both ways. And that type may have type-family applications in it. Example in
- test CoOpt_Singletons.
-
-(ATF7) You might think that (ATF6) is a very special case, and in /other/ uses of
- matching, where we enter via `tc_match_tys_x` we will never see a type-family
- in the template. But actually we do see that case in the specialiser: see
- the call to `tcMatchTy` in `GHC.Core.Opt.Specialise.beats_or_same`
-
- Also: a user-written RULE could conceivably have a type-family application
- in the template. It might not be a good rule, but I don't think we currently
- check for this.
+ constraint
+ [W] alpha ~ [beta]
+ where beta is fresh. We do this by binding [G a :-> Int]
(ATF8) The treatment of type families is governed by
um_bind_fam_fun :: BindFamFun
@@ -399,6 +421,8 @@ Wrinkles
Key point: when decomposing (F tys1 ~ F tys2), we should /also/ extend the
type-family substitution.
+ (ATF11-1) All this cleverness only matters when unifying, not when matching
+
(ATF12) There is a horrid exception for the injectivity check. See (UR1) in
in Note [Specification of unification].
@@ -595,7 +619,7 @@ tc_match_tys_x :: HasDebugCallStack
-> [Type]
-> Maybe Subst
tc_match_tys_x bind_tv match_kis (Subst in_scope id_env tv_env cv_env) tys1 tys2
- = case tc_unify_tys alwaysBindFam -- (ATF7) in Note [Apartness and type families]
+ = case tc_unify_tys neverBindFam -- (ATF7) in Note [Apartness and type families]
bind_tv
False -- Matching, not unifying
False -- Not an injectivity check
@@ -1857,6 +1881,7 @@ uVarOrFam env ty1 ty2 kco
= go_fam_fam tc1 tys1 tys2 kco
-- Now check if we can bind the (F tys) to the RHS
+ -- This can happen even when matching: see (ATF7)
| BindMe <- um_bind_fam_fun env tc1 tys1 rhs
= -- ToDo: do we need an occurs check here?
do { extendFamEnv tc1 tys1 rhs
@@ -1881,11 +1906,6 @@ uVarOrFam env ty1 ty2 kco
-- go_fam_fam: LHS and RHS are both saturated type-family applications,
-- for the same type-family F
go_fam_fam tc tys1 tys2 kco
- | tcEqTyConAppArgs tys1 tys2
- -- Detect (F tys ~ F tys); otherwise we'd build an infinite substitution
- = return ()
-
- | otherwise
-- Decompose (F tys1 ~ F tys2): (ATF9)
-- Use injectivity information of F: (ATF10)
-- But first bind the type-fam if poss: (ATF11)
@@ -1902,13 +1922,19 @@ uVarOrFam env ty1 ty2 kco
(inj_tys1, noninj_tys1) = partitionByList inj tys1
(inj_tys2, noninj_tys2) = partitionByList inj tys2
- bind_fam_if_poss | BindMe <- um_bind_fam_fun env tc tys1 rhs1
- = extendFamEnv tc tys1 rhs1
- | um_unif env
- , BindMe <- um_bind_fam_fun env tc tys2 rhs2
- = extendFamEnv tc tys2 rhs2
- | otherwise
- = return ()
+ bind_fam_if_poss
+ | not (um_unif env) -- Not when matching (ATF11-1)
+ = return ()
+ | tcEqTyConAppArgs tys1 tys2 -- Detect (F tys ~ F tys);
+ = return () -- otherwise we'd build an infinite substitution
+ | BindMe <- um_bind_fam_fun env tc tys1 rhs1
+ = extendFamEnv tc tys1 rhs1
+ | um_unif env
+ , BindMe <- um_bind_fam_fun env tc tys2 rhs2
+ = extendFamEnv tc tys2 rhs2
+ | otherwise
+ = return ()
+
rhs1 = mkTyConApp tc tys2 `mkCastTy` mkSymCo kco
rhs2 = mkTyConApp tc tys1 `mkCastTy` kco
@@ -1993,7 +2019,7 @@ data UMState = UMState
-- in um_foralls; i.e. variables bound by foralls inside the types being unified
-- When /matching/ um_fam_env is usually empty; but not quite always.
- -- See (ATF6) and (ATF7) of Note [Apartness and type families]
+ -- See (ATF7) of Note [Apartness and type families]
newtype UM a
= UM' { unUM :: UMState -> UnifyResultM (UMState, a) }
=====================================
compiler/GHC/Driver/Downsweep.hs
=====================================
@@ -947,6 +947,71 @@ enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph = do
hostFullWays
in dflags_c
+{- Note [-fno-code mode]
+~~~~~~~~~~~~~~~~~~~~~~~~
+GHC offers the flag -fno-code for the purpose of parsing and typechecking a
+program without generating object files. This is intended to be used by tooling
+and IDEs to provide quick feedback on any parser or type errors as cheaply as
+possible.
+
+When GHC is invoked with -fno-code, no object files or linked output will be
+generated. As many errors and warnings as possible will be generated, as if
+-fno-code had not been passed. The session DynFlags will have
+backend == NoBackend.
+
+-fwrite-interface
+~~~~~~~~~~~~~~~~
+Whether interface files are generated in -fno-code mode is controlled by the
+-fwrite-interface flag. The -fwrite-interface flag is a no-op if -fno-code is
+not also passed. Recompilation avoidance requires interface files, so passing
+-fno-code without -fwrite-interface should be avoided. If -fno-code were
+re-implemented today, there would be no need for -fwrite-interface as it
+would considered always on; this behaviour is as it is for backwards compatibility.
+
+================================================================
+IN SUMMARY: ALWAYS PASS -fno-code AND -fwrite-interface TOGETHER
+================================================================
+
+Template Haskell
+~~~~~~~~~~~~~~~~
+A module using Template Haskell may invoke an imported function from inside a
+splice. This will cause the type-checker to attempt to execute that code, which
+would fail if no object files had been generated. See #8025. To rectify this,
+during the downsweep we patch the DynFlags in the ModSummary of any home module
+that is imported by a module that uses Template Haskell to generate object
+code.
+
+The flavour of the generated code depends on whether `-fprefer-byte-code` is enabled
+or not in the module which needs the code generation. If the module requires byte-code then
+dependencies will generate byte-code, otherwise they will generate object files.
+In the case where some modules require byte-code and some object files, both are
+generated by enabling `-fbyte-code-and-object-code`, the test "fat015" tests these
+configurations.
+
+The object files (and interface files if -fwrite-interface is disabled) produced
+for Template Haskell are written to temporary files.
+
+Note that since Template Haskell can run arbitrary IO actions, -fno-code mode
+is no more secure than running without it.
+
+Potential TODOS:
+~~~~~
+* Remove -fwrite-interface and have interface files always written in -fno-code
+ mode
+* Both .o and .dyn_o files are generated for template haskell, but we only need
+ .dyn_o. Fix it.
+* In make mode, a message like
+ Compiling A (A.hs, /tmp/ghc_123.o)
+ is shown if downsweep enabled object code generation for A. Perhaps we should
+ show "nothing" or "temporary object file" instead. Note that one
+ can currently use -keep-tmp-files and inspect the generated file with the
+ current behaviour.
+* Offer a -no-codedir command line option, and write what were temporary
+ object files there. This would speed up recompilation.
+* Use existing object files (if they are up to date) instead of always
+ generating temporary ones.
+-}
+
-- | Populate the Downsweep cache with the root modules.
mkRootMap
:: [ModuleNodeInfo]
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -1246,70 +1246,6 @@ addSptEntries hsc_env mlinkable =
, spt <- bc_spt_entries bco
]
-{- Note [-fno-code mode]
-~~~~~~~~~~~~~~~~~~~~~~~~
-GHC offers the flag -fno-code for the purpose of parsing and typechecking a
-program without generating object files. This is intended to be used by tooling
-and IDEs to provide quick feedback on any parser or type errors as cheaply as
-possible.
-
-When GHC is invoked with -fno-code no object files or linked output will be
-generated. As many errors and warnings as possible will be generated, as if
--fno-code had not been passed. The session DynFlags will have
-backend == NoBackend.
-
--fwrite-interface
-~~~~~~~~~~~~~~~~
-Whether interface files are generated in -fno-code mode is controlled by the
--fwrite-interface flag. The -fwrite-interface flag is a no-op if -fno-code is
-not also passed. Recompilation avoidance requires interface files, so passing
--fno-code without -fwrite-interface should be avoided. If -fno-code were
-re-implemented today, -fwrite-interface would be discarded and it would be
-considered always on; this behaviour is as it is for backwards compatibility.
-
-================================================================
-IN SUMMARY: ALWAYS PASS -fno-code AND -fwrite-interface TOGETHER
-================================================================
-
-Template Haskell
-~~~~~~~~~~~~~~~~
-A module using template haskell may invoke an imported function from inside a
-splice. This will cause the type-checker to attempt to execute that code, which
-would fail if no object files had been generated. See #8025. To rectify this,
-during the downsweep we patch the DynFlags in the ModSummary of any home module
-that is imported by a module that uses template haskell, to generate object
-code.
-
-The flavour of the generated code depends on whether `-fprefer-byte-code` is enabled
-or not in the module which needs the code generation. If the module requires byte-code then
-dependencies will generate byte-code, otherwise they will generate object files.
-In the case where some modules require byte-code and some object files, both are
-generated by enabling `-fbyte-code-and-object-code`, the test "fat015" tests these
-configurations.
-
-The object files (and interface files if -fwrite-interface is disabled) produced
-for template haskell are written to temporary files.
-
-Note that since template haskell can run arbitrary IO actions, -fno-code mode
-is no more secure than running without it.
-
-Potential TODOS:
-~~~~~
-* Remove -fwrite-interface and have interface files always written in -fno-code
- mode
-* Both .o and .dyn_o files are generated for template haskell, but we only need
- .dyn_o. Fix it.
-* In make mode, a message like
- Compiling A (A.hs, /tmp/ghc_123.o)
- is shown if downsweep enabled object code generation for A. Perhaps we should
- show "nothing" or "temporary object file" instead. Note that one
- can currently use -keep-tmp-files and inspect the generated file with the
- current behaviour.
-* Offer a -no-codedir command line option, and write what were temporary
- object files there. This would speed up recompilation.
-* Use existing object files (if they are up to date) instead of always
- generating temporary ones.
--}
-- Note [When source is considered modified]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Tc/Solver/Equality.hs
=====================================
@@ -3017,6 +3017,7 @@ improve_wanted_top_fun_eqs fam_tc lhs_tys rhs_ty
improve_injective_wanted_top :: FamInstEnvs -> [Bool] -> TyCon -> [TcType] -> Xi -> TcS [TypeEqn]
-- Interact with top-level instance declarations
+-- See Section 5.2 in the Injective Type Families paper
improve_injective_wanted_top fam_envs inj_args fam_tc lhs_tys rhs_ty
= concatMapM do_one branches
where
@@ -3035,6 +3036,7 @@ improve_injective_wanted_top fam_envs inj_args fam_tc lhs_tys rhs_ty
do_one branch@(CoAxBranch { cab_tvs = branch_tvs, cab_lhs = branch_lhs_tys, cab_rhs = branch_rhs })
| let in_scope1 = in_scope `extendInScopeSetList` branch_tvs
, Just subst <- tcUnifyTyForInjectivity False in_scope1 branch_rhs rhs_ty
+ -- False: matching, not unifying
= do { let inSubst tv = tv `elemVarEnv` getTvSubstEnv subst
unsubstTvs = filterOut inSubst branch_tvs
-- The order of unsubstTvs is important; it must be
=====================================
compiler/GHC/Types/Basic.hs
=====================================
@@ -85,7 +85,7 @@ module GHC.Types.Basic (
CompilerPhase(..), PhaseNum, beginPhase, nextPhase, laterPhase,
Activation(..), isActive, competesWith,
- isNeverActive, isAlwaysActive, activeInFinalPhase,
+ isNeverActive, isAlwaysActive, activeInFinalPhase, activeInInitialPhase,
activateAfterInitial, activateDuringFinal, activeAfter,
RuleMatchInfo(..), isConLike, isFunLike,
=====================================
testsuite/tests/simplCore/should_compile/T25703.hs
=====================================
@@ -0,0 +1,7 @@
+module T25703 where
+
+f :: (Eq a, Show b) => a -> b -> Int
+f x y = f x y
+
+goo :: forall x. (Eq x) => x -> Int
+goo arg = f arg (3::Int)
=====================================
testsuite/tests/simplCore/should_compile/T25703.stderr
=====================================
@@ -0,0 +1,2 @@
+Rule fired: SPEC f @_ @Int (T25703)
+Rule fired: SPEC f @_ @Int (T25703)
=====================================
testsuite/tests/simplCore/should_compile/T25703a.hs
=====================================
@@ -0,0 +1,69 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+
+{-# OPTIONS_GHC -O2 -fspecialise-aggressively #-}
+
+-- This pragma is just here to pretend that the function body of 'foo' is huge
+-- and should never be inlined.
+{-# OPTIONS_GHC -funfolding-use-threshold=-200 #-}
+
+module T25703a where
+
+import Data.Kind
+import Data.Type.Equality
+import Data.Proxy
+import GHC.TypeNats
+
+-- Pretend this is some big dictionary that absolutely must get
+-- specialised away for performance reasons.
+type C :: Nat -> Constraint
+class C i where
+ meth :: Proxy i -> Double
+instance C 0 where
+ meth _ = 0.1
+instance C 1 where
+ meth _ = 1.1
+instance C 2 where
+ meth _ = 2.1
+
+{-# INLINEABLE foo #-}
+foo :: forall a (n :: Nat) (m :: Nat)
+ . ( Eq a, C n, C m )
+ => a -> ( Proxy n, Proxy m ) -> Int -> Double
+-- Pretend this is a big complicated function, too big to inline,
+-- for which we absolutely must specialise away the 'C n', 'C m'
+-- dictionaries for performance reasons.
+foo a b c
+ = if a == a
+ then meth @n Proxy + fromIntegral c
+ else 2 * meth @m Proxy
+
+-- Runtime dispatch to a specialisation of 'foo'
+foo_spec :: forall a (n :: Nat) (m :: Nat)
+ . ( Eq a, KnownNat n, KnownNat m )
+ => a -> ( Proxy n, Proxy m ) -> Int -> Double
+foo_spec a b c
+ | Just Refl <- sameNat @n @0 Proxy Proxy
+ , Just Refl <- sameNat @m @0 Proxy Proxy
+ = foo @a @0 @0 a b c
+ | Just Refl <- sameNat @n @0 Proxy Proxy
+ , Just Refl <- sameNat @m @1 Proxy Proxy
+ = foo @a @0 @1 a b c
+ | Just Refl <- sameNat @n @1 Proxy Proxy
+ , Just Refl <- sameNat @m @1 Proxy Proxy
+ = foo @a @1 @1 a b c
+ | Just Refl <- sameNat @n @0 Proxy Proxy
+ , Just Refl <- sameNat @m @2 Proxy Proxy
+ = foo @a @0 @2 a b c
+ | Just Refl <- sameNat @n @1 Proxy Proxy
+ , Just Refl <- sameNat @m @2 Proxy Proxy
+ = foo @a @1 @2 a b c
+ | Just Refl <- sameNat @n @2 Proxy Proxy
+ , Just Refl <- sameNat @m @2 Proxy Proxy
+ = foo @a @2 @2 a b c
+ | otherwise
+ = error $ unlines
+ [ "f: no specialisation"
+ , "n: " ++ show (natVal @n Proxy)
+ , "m: " ++ show (natVal @m Proxy)
+ ]
=====================================
testsuite/tests/simplCore/should_compile/T25703a.stderr
=====================================
@@ -0,0 +1,6 @@
+Rule fired: SPEC foo @_ @2 @2 (T25703a)
+Rule fired: SPEC foo @_ @1 @2 (T25703a)
+Rule fired: SPEC foo @_ @0 @2 (T25703a)
+Rule fired: SPEC foo @_ @1 @1 (T25703a)
+Rule fired: SPEC foo @_ @0 @1 (T25703a)
+Rule fired: SPEC foo @_ @0 @0 (T25703a)
=====================================
testsuite/tests/simplCore/should_compile/T25965.hs
=====================================
@@ -0,0 +1,18 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -O -fpolymorphic-specialisation #-}
+
+module Foo where
+
+type family F a
+
+data T a = T1
+
+instance Eq (T a) where { (==) x y = False }
+
+foo :: Eq a => a -> Bool
+foo x | x==x = True
+ | otherwise = foo x
+
+bar :: forall b. b -> T (F b) -> Bool
+bar y x = foo x
+
=====================================
testsuite/tests/simplCore/should_compile/T25976.hs
=====================================
@@ -0,0 +1,10 @@
+{-# LANGUAGE MagicHash #-}
+
+module T25976 where
+
+import GHC.PrimOps (tagToEnum#)
+
+-- Spoiler - it's all dead code since tagToEnum 3# is undefined
+main = case (tagToEnum# 4# :: Bool) of
+ True -> print "Dead Code"
+ False -> print "Dead Code"
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -541,3 +541,10 @@ test('T25883', normal, compile_grep_core, [''])
test('T25883b', normal, compile_grep_core, [''])
test('T25883c', normal, compile_grep_core, [''])
test('T25883d', [extra_files(['T25883d_import.hs'])], multimod_compile_filter, ['T25883d', '-O -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques', r'grep -e "y ="'])
+
+test('T25976', [grep_errmsg('Dead Code')], compile, ['-O -ddump-simpl -dsuppress-uniques -dno-typeable-binds'])
+
+test('T25965', normal, compile, ['-O'])
+test('T25703', [grep_errmsg(r'SPEC')], compile, ['-O -fpolymorphic-specialisation -ddump-rule-firings'])
+test('T25703a', [grep_errmsg(r'SPEC')], compile, ['-O -fpolymorphic-specialisation -ddump-rule-firings'])
+
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5c97630788324493974f1cb712c7b0…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5c97630788324493974f1cb712c7b0…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/T24603] Bisect attempt for ghc js backend
by Serge S. Gulin (＠gulin.serge) 22 Apr '25
by Serge S. Gulin (＠gulin.serge) 22 Apr '25
22 Apr '25
Serge S. Gulin pushed to branch wip/T24603 at Glasgow Haskell Compiler / GHC
Commits:
e51544af by Serge S. Gulin at 2025-04-22T23:51:48+03:00
Bisect attempt for ghc js backend
submodule
- - - - -
2 changed files:
- libraries/Cabal
- libraries/ghc-internal/jsbits/base.js
Changes:
=====================================
libraries/Cabal
=====================================
@@ -1 +1 @@
-Subproject commit 703582f80f6d7f0c914ef4b885affcfc7b7b6ec8
+Subproject commit 26f1cd7a3a01ad5c5bdfd8a240654e9233bc298a
=====================================
libraries/ghc-internal/jsbits/base.js
=====================================
@@ -1,7 +1,7 @@
//#OPTIONS: CPP
#include "HsBaseConfig.h"
-// #define GHCJS_TRACE_IO 1
+#define GHCJS_TRACE_IO 1
#ifdef GHCJS_TRACE_IO
function h$logIO() { h$log.apply(h$log, arguments); }
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e51544af137e6236ec6632f8d8ea182…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e51544af137e6236ec6632f8d8ea182…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] 2 commits: Move -fno-code note into Downsweep module
by Marge Bot (＠marge-bot) 22 Apr '25
by Marge Bot (＠marge-bot) 22 Apr '25
22 Apr '25
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
7250fc0c by Matthew Pickering at 2025-04-22T16:24:04-04:00
Move -fno-code note into Downsweep module
This note was left behind when all the code which referred to it was
moved into the GHC.Driver.Downsweep module
- - - - -
d2dc89b4 by Matthew Pickering at 2025-04-22T16:24:04-04:00
Apply editing notes to Note [-fno-code mode] suggested by sheaf
These notes were suggested in https://gitlab.haskell.org/ghc/ghc/-/merge_requests/14241
- - - - -
2 changed files:
- compiler/GHC/Driver/Downsweep.hs
- compiler/GHC/Driver/Make.hs
Changes:
=====================================
compiler/GHC/Driver/Downsweep.hs
=====================================
@@ -947,6 +947,71 @@ enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph = do
hostFullWays
in dflags_c
+{- Note [-fno-code mode]
+~~~~~~~~~~~~~~~~~~~~~~~~
+GHC offers the flag -fno-code for the purpose of parsing and typechecking a
+program without generating object files. This is intended to be used by tooling
+and IDEs to provide quick feedback on any parser or type errors as cheaply as
+possible.
+
+When GHC is invoked with -fno-code, no object files or linked output will be
+generated. As many errors and warnings as possible will be generated, as if
+-fno-code had not been passed. The session DynFlags will have
+backend == NoBackend.
+
+-fwrite-interface
+~~~~~~~~~~~~~~~~
+Whether interface files are generated in -fno-code mode is controlled by the
+-fwrite-interface flag. The -fwrite-interface flag is a no-op if -fno-code is
+not also passed. Recompilation avoidance requires interface files, so passing
+-fno-code without -fwrite-interface should be avoided. If -fno-code were
+re-implemented today, there would be no need for -fwrite-interface as it
+would considered always on; this behaviour is as it is for backwards compatibility.
+
+================================================================
+IN SUMMARY: ALWAYS PASS -fno-code AND -fwrite-interface TOGETHER
+================================================================
+
+Template Haskell
+~~~~~~~~~~~~~~~~
+A module using Template Haskell may invoke an imported function from inside a
+splice. This will cause the type-checker to attempt to execute that code, which
+would fail if no object files had been generated. See #8025. To rectify this,
+during the downsweep we patch the DynFlags in the ModSummary of any home module
+that is imported by a module that uses Template Haskell to generate object
+code.
+
+The flavour of the generated code depends on whether `-fprefer-byte-code` is enabled
+or not in the module which needs the code generation. If the module requires byte-code then
+dependencies will generate byte-code, otherwise they will generate object files.
+In the case where some modules require byte-code and some object files, both are
+generated by enabling `-fbyte-code-and-object-code`, the test "fat015" tests these
+configurations.
+
+The object files (and interface files if -fwrite-interface is disabled) produced
+for Template Haskell are written to temporary files.
+
+Note that since Template Haskell can run arbitrary IO actions, -fno-code mode
+is no more secure than running without it.
+
+Potential TODOS:
+~~~~~
+* Remove -fwrite-interface and have interface files always written in -fno-code
+ mode
+* Both .o and .dyn_o files are generated for template haskell, but we only need
+ .dyn_o. Fix it.
+* In make mode, a message like
+ Compiling A (A.hs, /tmp/ghc_123.o)
+ is shown if downsweep enabled object code generation for A. Perhaps we should
+ show "nothing" or "temporary object file" instead. Note that one
+ can currently use -keep-tmp-files and inspect the generated file with the
+ current behaviour.
+* Offer a -no-codedir command line option, and write what were temporary
+ object files there. This would speed up recompilation.
+* Use existing object files (if they are up to date) instead of always
+ generating temporary ones.
+-}
+
-- | Populate the Downsweep cache with the root modules.
mkRootMap
:: [ModuleNodeInfo]
=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -1246,70 +1246,6 @@ addSptEntries hsc_env mlinkable =
, spt <- bc_spt_entries bco
]
-{- Note [-fno-code mode]
-~~~~~~~~~~~~~~~~~~~~~~~~
-GHC offers the flag -fno-code for the purpose of parsing and typechecking a
-program without generating object files. This is intended to be used by tooling
-and IDEs to provide quick feedback on any parser or type errors as cheaply as
-possible.
-
-When GHC is invoked with -fno-code no object files or linked output will be
-generated. As many errors and warnings as possible will be generated, as if
--fno-code had not been passed. The session DynFlags will have
-backend == NoBackend.
-
--fwrite-interface
-~~~~~~~~~~~~~~~~
-Whether interface files are generated in -fno-code mode is controlled by the
--fwrite-interface flag. The -fwrite-interface flag is a no-op if -fno-code is
-not also passed. Recompilation avoidance requires interface files, so passing
--fno-code without -fwrite-interface should be avoided. If -fno-code were
-re-implemented today, -fwrite-interface would be discarded and it would be
-considered always on; this behaviour is as it is for backwards compatibility.
-
-================================================================
-IN SUMMARY: ALWAYS PASS -fno-code AND -fwrite-interface TOGETHER
-================================================================
-
-Template Haskell
-~~~~~~~~~~~~~~~~
-A module using template haskell may invoke an imported function from inside a
-splice. This will cause the type-checker to attempt to execute that code, which
-would fail if no object files had been generated. See #8025. To rectify this,
-during the downsweep we patch the DynFlags in the ModSummary of any home module
-that is imported by a module that uses template haskell, to generate object
-code.
-
-The flavour of the generated code depends on whether `-fprefer-byte-code` is enabled
-or not in the module which needs the code generation. If the module requires byte-code then
-dependencies will generate byte-code, otherwise they will generate object files.
-In the case where some modules require byte-code and some object files, both are
-generated by enabling `-fbyte-code-and-object-code`, the test "fat015" tests these
-configurations.
-
-The object files (and interface files if -fwrite-interface is disabled) produced
-for template haskell are written to temporary files.
-
-Note that since template haskell can run arbitrary IO actions, -fno-code mode
-is no more secure than running without it.
-
-Potential TODOS:
-~~~~~
-* Remove -fwrite-interface and have interface files always written in -fno-code
- mode
-* Both .o and .dyn_o files are generated for template haskell, but we only need
- .dyn_o. Fix it.
-* In make mode, a message like
- Compiling A (A.hs, /tmp/ghc_123.o)
- is shown if downsweep enabled object code generation for A. Perhaps we should
- show "nothing" or "temporary object file" instead. Note that one
- can currently use -keep-tmp-files and inspect the generated file with the
- current behaviour.
-* Offer a -no-codedir command line option, and write what were temporary
- object files there. This would speed up recompilation.
-* Use existing object files (if they are up to date) instead of always
- generating temporary ones.
--}
-- Note [When source is considered modified]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2e2042693ace5f7e857315b40750f0…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2e2042693ace5f7e857315b40750f0…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] Simplifier: Constant fold invald tagToEnum# calls to bottom expr.
by Marge Bot (＠marge-bot) 22 Apr '25
by Marge Bot (＠marge-bot) 22 Apr '25
22 Apr '25
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
2e204269 by Andreas Klebinger at 2025-04-22T12:20:41+02:00
Simplifier: Constant fold invald tagToEnum# calls to bottom expr.
When applying tagToEnum# to a out-of-range value it's best to simply
constant fold it to a bottom expression. That potentially allows more
dead code elimination and makes debugging easier.
Fixes #25976
- - - - -
3 changed files:
- compiler/GHC/Core/Opt/ConstantFold.hs
- + testsuite/tests/simplCore/should_compile/T25976.hs
- testsuite/tests/simplCore/should_compile/all.T
Changes:
=====================================
compiler/GHC/Core/Opt/ConstantFold.hs
=====================================
@@ -69,7 +69,6 @@ import GHC.Cmm.MachOp ( FMASign(..) )
import GHC.Cmm.Type ( Width(..) )
import GHC.Data.FastString
-import GHC.Data.Maybe ( orElse )
import GHC.Utils.Outputable
import GHC.Utils.Misc
@@ -1997,6 +1996,14 @@ because we don't expect the user to call tagToEnum# at all; we merely
generate calls in derived instances of Enum. So we compromise: a
rewrite rule rewrites a bad instance of tagToEnum# to an error call,
and emits a warning.
+
+We also do something similar if we can see that the argument of tagToEnum is out
+of bounds, e.g. `tagToEnum# 99# :: Bool`.
+Replacing this with an error expression is better for two reasons:
+* It allow us to eliminate more dead code in cases like `case tagToEnum# 99# :: Bool of ...`
+* Should we actually end up executing the relevant code at runtime the user will
+ see a meaningful error message, instead of a segfault or incorrect result.
+See #25976.
-}
tagToEnumRule :: RuleM CoreExpr
@@ -2008,9 +2015,13 @@ tagToEnumRule = do
Just (tycon, tc_args) | isEnumerationTyCon tycon -> do
let tag = fromInteger i
correct_tag dc = (dataConTagZ dc) == tag
- (dc:rest) <- return $ filter correct_tag (tyConDataCons_maybe tycon `orElse` [])
- massert (null rest)
- return $ mkTyApps (Var (dataConWorkId dc)) tc_args
+ Just dataCons <- pure $ tyConDataCons_maybe tycon
+ case filter correct_tag dataCons of
+ (dc:rest) -> do
+ massert (null rest)
+ pure $ mkTyApps (Var (dataConWorkId dc)) tc_args
+ -- Literal is out of range, e.g. tagToEnum @Bool #4
+ [] -> pure $ mkImpossibleExpr ty "tagToEnum: Argument out of range"
-- See Note [tagToEnum#]
_ -> warnPprTrace True "tagToEnum# on non-enumeration type" (ppr ty) $
=====================================
testsuite/tests/simplCore/should_compile/T25976.hs
=====================================
@@ -0,0 +1,10 @@
+{-# LANGUAGE MagicHash #-}
+
+module T25976 where
+
+import GHC.PrimOps (tagToEnum#)
+
+-- Spoiler - it's all dead code since tagToEnum 3# is undefined
+main = case (tagToEnum# 4# :: Bool) of
+ True -> print "Dead Code"
+ False -> print "Dead Code"
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -541,3 +541,5 @@ test('T25883', normal, compile_grep_core, [''])
test('T25883b', normal, compile_grep_core, [''])
test('T25883c', normal, compile_grep_core, [''])
test('T25883d', [extra_files(['T25883d_import.hs'])], multimod_compile_filter, ['T25883d', '-O -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques', r'grep -e "y ="'])
+
+test('T25976', [grep_errmsg('Dead Code')], compile, ['-O -ddump-simpl -dsuppress-uniques -dno-typeable-binds'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2e2042693ace5f7e857315b40750f02…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2e2042693ace5f7e857315b40750f02…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
Simon Peyton Jones pushed to branch wip/T20264 at Glasgow Haskell Compiler / GHC
Commits:
384b62be by Simon Peyton Jones at 2025-04-22T20:20:55+01:00
Wibble unsed var
- - - - -
1 changed file:
- compiler/GHC/Core/FVs.hs
Changes:
=====================================
compiler/GHC/Core/FVs.hs
=====================================
@@ -656,7 +656,7 @@ stableUnfoldingFVs unf
| otherwise = Nothing
unfoldingFVs :: Unfolding -> FV
-unfoldingFVs (CoreUnfolding { uf_tmpl = rhs, uf_src = src })
+unfoldingFVs (CoreUnfolding { uf_tmpl = rhs })
= exprFVs rhs
unfoldingFVs (DFunUnfolding { df_bndrs = bndrs, df_args = args })
= FV.delFVs (mkVarSet bndrs) $ exprsFVs args
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/384b62be6287cc270220ad6174898de…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/384b62be6287cc270220ad6174898de…
You're receiving this email because of your account on gitlab.haskell.org.
1
0