Cheng Shao deleted branch wip/libffi-3.4.8 at Glasgow Haskell Compiler / GHC
--
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] Implement -Wpattern-namespace-specifier (#25900)
by Marge Bot (＠marge-bot) 21 May '25
by Marge Bot (＠marge-bot) 21 May '25
21 May '25
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
b1212fbf by Vladislav Zavialov at 2025-05-21T16:01:33-04:00
Implement -Wpattern-namespace-specifier (#25900)
In accordance with GHC Proposal #581 "Namespace-specified imports",
section 2.3 "Deprecate use of pattern in import/export lists", the
`pattern` namespace specifier is now deprecated.
Test cases: T25900 T25900_noext
- - - - -
56 changed files:
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Errors/Ppr.hs
- compiler/GHC/Parser/Errors/Types.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Types/Error/Codes.hs
- compiler/GHC/Types/Hint.hs
- compiler/GHC/Types/Hint/Ppr.hs
- docs/users_guide/9.14.1-notes.rst
- docs/users_guide/using-warnings.rst
- hadrian/src/Flavour.hs
- libraries/ghc-internal/src/GHC/Internal/Data/Typeable/Internal.hs
- libraries/ghc-internal/src/GHC/Internal/Type/Reflection.hs
- libraries/ghc-internal/src/GHC/Internal/TypeLits.hs
- libraries/ghc-internal/src/GHC/Internal/TypeNats.hs
- testsuite/tests/callarity/unittest/CallArity1.hs
- testsuite/tests/ghci/scripts/ghci024.stdout
- testsuite/tests/ghci/scripts/ghci024.stdout-mingw32
- + testsuite/tests/parser/should_compile/T25900.hs
- + testsuite/tests/parser/should_compile/T25900.stderr
- + testsuite/tests/parser/should_compile/T25900_noext.hs
- + testsuite/tests/parser/should_compile/T25900_noext.stderr
- testsuite/tests/parser/should_compile/all.T
- testsuite/tests/patsyn/should_compile/ImpExp_Exp.hs
- testsuite/tests/patsyn/should_compile/T11959.hs
- testsuite/tests/patsyn/should_compile/T11959.stderr
- testsuite/tests/patsyn/should_compile/T11959Lib.hs
- testsuite/tests/patsyn/should_compile/T13350/boolean/Boolean.hs
- testsuite/tests/patsyn/should_compile/T22521.hs
- testsuite/tests/patsyn/should_compile/T9857.hs
- testsuite/tests/patsyn/should_compile/export.hs
- testsuite/tests/pmcheck/complete_sigs/T25115a.hs
- testsuite/tests/pmcheck/should_compile/T11822.hs
- testsuite/tests/polykinds/T14270.hs
- testsuite/tests/rename/should_compile/T12548.hs
- testsuite/tests/rename/should_fail/T25056.stderr
- testsuite/tests/rename/should_fail/T25056a.hs
- testsuite/tests/simplCore/should_compile/T15186.hs
- testsuite/tests/simplCore/should_compile/T15186A.hs
- testsuite/tests/typecheck/should_compile/TypeRepCon.hs
- testsuite/tests/warnings/should_compile/DataToTagWarnings.hs
- testsuite/tests/warnings/should_compile/T14794a.hs
- testsuite/tests/warnings/should_compile/T14794a.stderr
- testsuite/tests/warnings/should_compile/T14794b.hs
- testsuite/tests/warnings/should_compile/T14794b.stderr
- testsuite/tests/warnings/should_compile/T14794c.hs
- testsuite/tests/warnings/should_compile/T14794c.stderr
- testsuite/tests/warnings/should_compile/T14794d.hs
- testsuite/tests/warnings/should_compile/T14794d.stderr
- testsuite/tests/warnings/should_compile/T14794e.hs
- testsuite/tests/warnings/should_compile/T14794e.stderr
- testsuite/tests/warnings/should_compile/T14794f.hs
- testsuite/tests/warnings/should_compile/T14794f.stderr
- testsuite/tests/wcompat-warnings/Template.hs
- + testsuite/tests/wcompat-warnings/WCompatWarningsOn.stderr
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b1212fbfaf7884077386b08a4fedc1d…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b1212fbfaf7884077386b08a4fedc1d…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] Don't fail when ghcversion.h can't be found (#26018)
by Marge Bot (＠marge-bot) 21 May '25
by Marge Bot (＠marge-bot) 21 May '25
21 May '25
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
6d058a69 by Andrea Bedini at 2025-05-21T16:00:51-04:00
Don't fail when ghcversion.h can't be found (#26018)
If ghcversion.h can't be found, don't try to include it. This happens
when there is no rts package in the package db and when -ghcversion-file
argument isn't passed.
Co-authored-by: Syvlain Henry <sylvain(a)haskus.fr>
- - - - -
4 changed files:
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/SysTools/Cpp.hs
- testsuite/tests/driver/Makefile
- testsuite/tests/driver/all.T
Changes:
=====================================
compiler/GHC/Driver/Pipeline/Execute.hs
=====================================
@@ -478,7 +478,7 @@ runCcPhase cc_phase pipe_env hsc_env location input_fn = do
-- very weakly typed, being derived from C--.
["-fno-strict-aliasing"]
- ghcVersionH <- getGhcVersionPathName dflags unit_env
+ ghcVersionH <- getGhcVersionIncludeFlags dflags unit_env
withAtomicRename output_fn $ \temp_outputFilename ->
GHC.SysTools.runCc (phaseForeignLanguage cc_phase) logger tmpfs dflags (
@@ -525,7 +525,7 @@ runCcPhase cc_phase pipe_env hsc_env location input_fn = do
else [])
++ verbFlags
++ cc_opt
- ++ [ "-include", ghcVersionH ]
+ ++ ghcVersionH
++ framework_paths
++ include_paths
++ pkg_extra_cc_opts
=====================================
compiler/GHC/SysTools/Cpp.hs
=====================================
@@ -7,6 +7,7 @@ module GHC.SysTools.Cpp
( doCpp
, CppOpts(..)
, getGhcVersionPathName
+ , getGhcVersionIncludeFlags
, applyCDefs
, offsetIncludePaths
)
@@ -31,7 +32,6 @@ import GHC.Utils.TmpFs
import GHC.Utils.Panic
import Data.Version
-import Data.List (intercalate)
import Data.Maybe
import Control.Monad
@@ -124,10 +124,10 @@ doCpp logger tmpfs dflags unit_env opts input_fn output_fn = do
[homeUnitEnv_dflags . ue_findHomeUnitEnv uid $ unit_env | uid <- ue_transitiveHomeDeps (ue_currentUnit unit_env) unit_env]
dep_pkg_extra_inputs = [offsetIncludePaths fs (includePaths fs) | fs <- home_pkg_deps]
- let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []
+ let include_paths_global = map ("-I" ++)
(includePathsGlobal cmdline_include_paths ++ pkg_include_dirs
++ concatMap includePathsGlobal dep_pkg_extra_inputs)
- let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []
+ let include_paths_quote = map ("-iquote" ++)
(includePathsQuote cmdline_include_paths ++
includePathsQuoteImplicit cmdline_include_paths)
let include_paths = include_paths_quote ++ include_paths_global
@@ -178,8 +178,7 @@ doCpp logger tmpfs dflags unit_env opts input_fn output_fn = do
let asserts_def = [ "-D__GLASGOW_HASKELL_ASSERTS_IGNORED__" | gopt Opt_IgnoreAsserts dflags]
-- Default CPP defines in Haskell source
- ghcVersionH <- getGhcVersionPathName dflags unit_env
- let hsSourceCppOpts = [ "-include", ghcVersionH ]
+ ghcVersionH <- getGhcVersionIncludeFlags dflags unit_env
-- MIN_VERSION macros
let uids = explicitUnits unit_state
@@ -202,7 +201,7 @@ doCpp logger tmpfs dflags unit_env opts input_fn output_fn = do
cpp_prog ( map GHC.SysTools.Option verbFlags
++ map GHC.SysTools.Option include_paths
- ++ map GHC.SysTools.Option hsSourceCppOpts
+ ++ map GHC.SysTools.Option ghcVersionH
++ map GHC.SysTools.Option target_defs
++ map GHC.SysTools.Option backend_defs
++ map GHC.SysTools.Option th_defs
@@ -265,28 +264,32 @@ generateMacros prefix name version =
_ -> error "take3"
(major1,major2,minor) = take3 $ map show (versionBranch version) ++ repeat "0"
+getGhcVersionIncludeFlags :: DynFlags -> UnitEnv -> IO [String]
+getGhcVersionIncludeFlags dflags unit_env =
+ getGhcVersionPathName dflags unit_env >>= \case
+ Nothing -> pure []
+ Just path -> pure [ "-include", path ]
-- | Find out path to @ghcversion.h@ file
-getGhcVersionPathName :: DynFlags -> UnitEnv -> IO FilePath
-getGhcVersionPathName dflags unit_env = do
- let candidates = case ghcVersionFile dflags of
- -- the user has provided an explicit `ghcversion.h` file to use.
- Just path -> [path]
- -- otherwise, try to find it in the rts' include-dirs.
- -- Note: only in the RTS include-dirs! not all preload units less we may
- -- use a wrong file. See #25106 where a globally installed
- -- /usr/include/ghcversion.h file was used instead of the one provided
- -- by the rts.
- Nothing -> case lookupUnitId (ue_homeUnitState unit_env) rtsUnitId of
- Nothing -> []
- Just info -> (</> "ghcversion.h") <$> collectIncludeDirs [info]
-
- found <- filterM doesFileExist candidates
- case found of
- [] -> throwGhcExceptionIO (InstallationError
- ("ghcversion.h missing; tried: "
- ++ intercalate ", " candidates))
- (x:_) -> return x
+getGhcVersionPathName :: DynFlags -> UnitEnv -> IO (Maybe FilePath)
+getGhcVersionPathName dflags unit_env = case ghcVersionFile dflags of
+ -- the user has provided an explicit `ghcversion.h` file to use.
+ Just path -> doesFileExist path >>= \case
+ True -> return (Just path)
+ False -> throwGhcExceptionIO (InstallationError ("ghcversion.h not found in: " ++ path))
+ -- otherwise, try to find it in the rts' include-dirs.
+ -- Note: only in the RTS include-dirs! not all preload units less we may
+ -- use a wrong file. See #25106 where a globally installed
+ -- /usr/include/ghcversion.h file was used instead of the one provided
+ -- by the rts.
+ Nothing -> case lookupUnitId (ue_homeUnitState unit_env) rtsUnitId of
+ Nothing -> pure Nothing
+ Just info -> do
+ let candidates = (</> "ghcversion.h") <$> collectIncludeDirs [info]
+ found <- filterM doesFileExist candidates
+ case found of
+ [] -> pure Nothing
+ (x:_) -> pure (Just x)
applyCDefs :: DefunctionalizedCDefs -> Logger -> DynFlags -> IO [String]
applyCDefs NoCDefs _ _ = return []
=====================================
testsuite/tests/driver/Makefile
=====================================
@@ -813,3 +813,8 @@ T23339B:
T25382:
"$(TEST_HC)" $(TEST_HC_OPTS) -c T25382.hs
"$(TEST_HC)" $(TEST_HC_OPTS) T25382.o -o main
+
+# Test we can compile C code with an empty package DB
+T26018:
+ touch foo.c
+ "$(TEST_HC)" $(TEST_HC_OPTS) -c foo.c -clear-package-db
=====================================
testsuite/tests/driver/all.T
=====================================
@@ -331,3 +331,4 @@ test('T24286', [cxx_src, unless(have_profiling(), skip), extra_files(['T24286.cp
test('T24839', [unless(arch('x86_64') or arch('aarch64'), skip), extra_files(["t24839_sub.S"])], compile_and_run, ['t24839_sub.S'])
test('t25150', [extra_files(["t25150"])], multimod_compile, ['Main.hs', '-v0 -working-dir t25150/dir a.c'])
test('T25382', normal, makefile_test, [])
+test('T26018', req_c, makefile_test, [])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6d058a6948ab62deab69d7249a91cf4…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6d058a6948ab62deab69d7249a91cf4…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
21 May '25
Rodrigo Mesquita pushed to branch wip/romes/top-level-bcos-tag at Glasgow Haskell Compiler / GHC
Commits:
0784224f by Rodrigo Mesquita at 2025-05-21T18:56:32+01:00
More docs
- - - - -
3 changed files:
- compiler/GHC/ByteCode/Types.hs
- rts/Interpreter.c
- rts/StgMiscClosures.cmm
Changes:
=====================================
compiler/GHC/ByteCode/Types.hs
=====================================
@@ -173,11 +173,80 @@ newtype AddrPtr = AddrPtr (RemotePtr ())
--------------------------------------------------------------------------------
Note [Case continuation BCOs]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Consider the following stack with a BCO stack frame at the top:
+
+ (an StgBCO)
+ | ... | +---> +---------[1]--+
+ +------------------+ | | info_tbl_ptr | ------+
+ | OTHER FRAME | | +--------------+ |
+ +------------------+ | | StgArrBytes* | <--- the byte code
+ | ... | | +--------------+ |
+ +------------------+ | | ... | |
+ | fvs1 | | |
+ +------------------+ | |
+ | ... | | (StgInfoTable) |
+ +------------------+ | +----------+ <---+
+ | args1 | | | ... |
+ +------------------+ | +----------+
+ | some StgBCO* | -----+ | type=BCO |
+ +------------------+ +----------+
+ Sp | stg_apply_interp | -----+ | ... |
+ +------------------+ |
+ |
+ | (StgInfoTable)
+ +----> +--------------+
+ | ... |
+ +--------------+
+ | type=RET_BCO |
+ +--------------+
+ | ... |
+
+
+The code for a BCO heap object makes use of arguments and free variables which
+can typically be found within the BCO stack frame. In the code, these variables
+are referenced via a statically known stack offset (tracked using `BCEnv` in
+`StgToByteCode`).
+
+However, in /case continuation/ BCOs, the code may additionally refer to free
+variables that are outside of the BCO's stack frame. Instead, some free
+variables of a case continuation BCO may only be found in the stack frame of a
+parent BCO:
+
+ f x y = case x of ... -> ... y ...
+
+ ==>
+
+ <ParentBCOFrame>
+ ...
+ <CaseContinuationBCOFrame>
+
+Similarly, references to these non-local/out-of-frame variables are done in
+terms of stack offsets, but they rely on the position of another frame to be fixed.
+(See Note [PUSH_L underflow] for more information about references to previous frames and nested BCOs)
+
+TODO
+
+to arguments or free variables in
+the stack using a stack pointer offset .
+
+A BCO closure is typically headed by the stg_BCO info table pointer.
+...
+
+A BCO can be constructed using the stg_BCO info table, OR using the stg
Does the BCO code depend on stack-pointer-relative offsets?
... why
... example
+
+...
+
+ <parentBCOFrame>
+ ...
+ <inserted>
+ ...
+ <childBCOFrame>
+
-}
data UnlinkedBCO
=====================================
rts/Interpreter.c
=====================================
@@ -203,14 +203,14 @@ PUSH_L instruction.
|---------|
| BCO_1 | -<-┐
-|---------|
+|---------| |
......... |
|---------| | PUSH_L <n>
| BCO_N | ->-┘
|---------|
Here BCO_N is syntactically nested within the code for BCO_1 and will result
-in code that references the prior stack frame of BCO_1 for some of it's local
+in code that references the prior stack frame of BCO_1 for some of its local
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
@@ -524,14 +524,35 @@ interpretBCO (Capability* cap)
//
// We have a BCO application to perform. Stack looks like:
//
- // | .... |
- // +---------------+
- // | arg1 |
- // +---------------+
- // | BCO |
- // +---------------+
- // Sp | RET_BCO |
- // +---------------+
+ //
+ // (an StgBCO)
+ // +---> +---------[1]--+
+ // | | stg_BCO_info | ------+
+ // | +--------------+ |
+ // | | StgArrBytes* | <--- the byte code
+ // | ... | | +--------------+ |
+ // +------------------+ | | ... | |
+ // | fvs1 | | |
+ // +------------------+ | |
+ // | ... | | (StgInfoTable) |
+ // +------------------+ | +----------+ <---+
+ // | args1 | | | ... |
+ // +------------------+ | +----------+
+ // | some StgBCO* | -----+ | type=BCO |
+ // +------------------+ +----------+
+ // Sp | stg_apply_interp | -----+ | ... |
+ // +------------------+ |
+ // |
+ // | (StgInfoTable)
+ // +----> +--------------+
+ // | ... |
+ // +--------------+
+ // | type=RET_BCO |
+ // +--------------+
+ // | ... |
+ //
+ // [1] An StgBCO's info table pointer may also be stg_CASE_CONT_BCO_info.
+ // See Note [Case continuation BCOs].
//
else if (SpW(0) == (W_)&stg_apply_interp_info) {
obj = UNTAG_CLOSURE((StgClosure *)ReadSpW(1));
=====================================
rts/StgMiscClosures.cmm
=====================================
@@ -469,6 +469,7 @@ INFO_TABLE_RET( stg_dead_thread, RET_SMALL,
non-local variables in its code (using a stack offset) and those that do not.
Only case-continuation BCOs should use non-local variables.
Otherwise, `stg_BCO` and `stg_CASE_CONT_BCO` behave the same.
+ See Note [Case continuation BCOs].
------------------------------------------------------------------------- */
INFO_TABLE_FUN( stg_BCO, 3, 0, BCO, "BCO", "BCO", 0, ARG_BCO )
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0784224fbcd1c7a7c16b9812b1e4445…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0784224fbcd1c7a7c16b9812b1e4445…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/andreask/spec_tyfams] Specialise: Improve specialisation by refactoring interestingDict
by Andreas Klebinger (＠AndreasK) 21 May '25
by Andreas Klebinger (＠AndreasK) 21 May '25
21 May '25
Andreas Klebinger pushed to branch wip/andreask/spec_tyfams at Glasgow Haskell Compiler / GHC
Commits:
072c0547 by Andreas Klebinger at 2025-05-21T19:21:32+02:00
Specialise: Improve specialisation by refactoring interestingDict
This MR addresses #26051, which concerns missed type-class specialisation.
The main payload of the MR is to completely refactor the key function
`interestingDict` in GHC.Core.Opt.Specialise
The main change is that we now also look at the structure of the
dictionary we consider specializing on, rather than only the type.
See the big `Note [Interesting dictionary arguments]`
- - - - -
15 changed files:
- compiler/GHC/Core/Opt/Specialise.hs
- compiler/GHC/Core/Predicate.hs
- compiler/GHC/Tc/Solver.hs
- compiler/GHC/Tc/Solver/Dict.hs
- compiler/GHC/Tc/Solver/InertSet.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Utils/TcType.hs
- + testsuite/tests/perf/should_run/SpecTyFamRun.hs
- + testsuite/tests/perf/should_run/SpecTyFamRun.stdout
- + testsuite/tests/perf/should_run/SpecTyFam_Import.hs
- testsuite/tests/perf/should_run/all.T
- + testsuite/tests/simplCore/should_compile/T26051.hs
- + testsuite/tests/simplCore/should_compile/T26051.stderr
- + testsuite/tests/simplCore/should_compile/T26051_Import.hs
- testsuite/tests/simplCore/should_compile/all.T
Changes:
=====================================
compiler/GHC/Core/Opt/Specialise.hs
=====================================
@@ -1,3 +1,5 @@
+{-# LANGUAGE MultiWayIf #-}
+
{-
(c) The GRASP/AQUA Project, Glasgow University, 1993-1998
@@ -14,9 +16,9 @@ import GHC.Driver.Config.Diagnostic
import GHC.Driver.Config.Core.Rules ( initRuleOpts )
import GHC.Core.Type hiding( substTy, substCo, extendTvSubst, zapSubst )
-import GHC.Core.Multiplicity
-import GHC.Core.SimpleOpt( defaultSimpleOpts, simpleOptExprWith )
+import GHC.Core.SimpleOpt( defaultSimpleOpts, simpleOptExprWith, exprIsConApp_maybe )
import GHC.Core.Predicate
+import GHC.Core.Class( classMethods )
import GHC.Core.Coercion( Coercion )
import GHC.Core.Opt.Monad
import qualified GHC.Core.Subst as Core
@@ -26,12 +28,12 @@ import GHC.Core.Make ( mkLitRubbish )
import GHC.Core.Unify ( tcMatchTy )
import GHC.Core.Rules
import GHC.Core.Utils ( exprIsTrivial, exprIsTopLevelBindable
- , mkCast, exprType
+ , mkCast, exprType, exprIsHNF
, stripTicksTop, mkInScopeSetBndrs )
import GHC.Core.FVs
import GHC.Core.TyCo.FVs ( tyCoVarsOfTypeList )
import GHC.Core.Opt.Arity( collectBindersPushingCo )
--- import GHC.Core.Ppr( pprIds )
+import GHC.Core.Ppr( pprIds )
import GHC.Builtin.Types ( unboxedUnitTy )
@@ -64,8 +66,11 @@ import GHC.Unit.Module.ModGuts
import GHC.Core.Unfold
import Data.List( partition )
--- import Data.List.NonEmpty ( NonEmpty (..) )
import GHC.Core.Subst (substTickish)
+import GHC.Core.TyCon (tyConClass_maybe)
+import GHC.Core.DataCon (dataConTyCon)
+
+import Control.Monad
{-
************************************************************************
@@ -1585,9 +1590,9 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
-- switch off specialisation for inline functions
= -- pprTrace "specCalls: some" (vcat
- -- [ text "function" <+> ppr fn
- -- , text "calls:" <+> ppr calls_for_me
- -- , text "subst" <+> ppr (se_subst env) ]) $
+ -- [ text "function" <+> ppr fn
+ -- , text "calls:" <+> ppr calls_for_me
+ -- , text "subst" <+> ppr (se_subst env) ]) $
foldlM spec_call ([], [], emptyUDs) calls_for_me
| otherwise -- No calls or RHS doesn't fit our preconceptions
@@ -1635,21 +1640,21 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
, rule_bndrs, rule_lhs_args
, spec_bndrs1, dx_binds, spec_args) <- specHeader env rhs_bndrs all_call_args
--- ; pprTrace "spec_call" (vcat
--- [ text "fun: " <+> ppr fn
--- , text "call info: " <+> ppr _ci
--- , text "useful: " <+> ppr useful
--- , text "rule_bndrs:" <+> ppr rule_bndrs
--- , text "lhs_args: " <+> ppr rule_lhs_args
--- , text "spec_bndrs1:" <+> ppr spec_bndrs1
--- , text "leftover_bndrs:" <+> pprIds leftover_bndrs
--- , text "spec_args: " <+> ppr spec_args
--- , text "dx_binds: " <+> ppr dx_binds
--- , text "rhs_bndrs" <+> ppr rhs_bndrs
--- , text "rhs_body" <+> ppr rhs_body
--- , text "rhs_env2: " <+> ppr (se_subst rhs_env2)
--- , ppr dx_binds ]) $
--- return ()
+ ; when False $ pprTrace "spec_call" (vcat
+ [ text "fun: " <+> ppr fn
+ , text "call info: " <+> ppr _ci
+ , text "useful: " <+> ppr useful
+ , text "rule_bndrs:" <+> ppr rule_bndrs
+ , text "lhs_args: " <+> ppr rule_lhs_args
+ , text "spec_bndrs1:" <+> ppr spec_bndrs1
+ , text "leftover_bndrs:" <+> pprIds leftover_bndrs
+ , text "spec_args: " <+> ppr spec_args
+ , text "dx_binds: " <+> ppr dx_binds
+ , text "rhs_bndrs" <+> ppr rhs_bndrs
+ , text "rhs_body" <+> ppr rhs_body
+ , text "rhs_env2: " <+> ppr (se_subst rhs_env2)
+ , ppr dx_binds ]) $
+ return ()
; let all_rules = rules_acc ++ existing_rules
-- all_rules: we look both in the rules_acc (generated by this invocation
@@ -3043,30 +3048,15 @@ mkCallUDs' env f args
-- For "invisibleFunArg", which are the type-class dictionaries,
-- we decide on a case by case basis if we want to specialise
-- on this argument; if so, SpecDict, if not UnspecArg
- mk_spec_arg arg (Anon pred af)
+ mk_spec_arg arg (Anon _pred af)
| isInvisibleFunArg af
- , interestingDict arg (scaledThing pred)
+ , interestingDict env arg
+ -- , interestingDict arg (scaledThing pred)
-- See Note [Interesting dictionary arguments]
= SpecDict arg
| otherwise = UnspecArg
-{-
-Note [Ticks on applications]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Ticks such as source location annotations can sometimes make their way
-onto applications (see e.g. #21697). So if we see something like
-
- App (Tick _ f) e
-
-we need to descend below the tick to find what the real function being
-applied is.
-
-The resulting RULE also has to be able to match this annotated use
-site, so we only look through ticks that RULE matching looks through
-(see Note [Tick annotations in RULE matching] in GHC.Core.Rules).
--}
-
wantCallsFor :: SpecEnv -> Id -> Bool
-- See Note [wantCallsFor]
wantCallsFor _env f
@@ -3086,8 +3076,60 @@ wantCallsFor _env f
WorkerLikeId {} -> True
RepPolyId {} -> True
-{- Note [wantCallsFor]
-~~~~~~~~~~~~~~~~~~~~~~
+interestingDict :: SpecEnv -> CoreExpr -> Bool
+-- This is a subtle and important function
+-- See Note [Interesting dictionary arguments]
+interestingDict env (Var v) -- See (ID3) and (ID5)
+ | Just rhs <- maybeUnfoldingTemplate (idUnfolding v)
+ -- might fail for loop breaker dicts but that seems fine.
+ = interestingDict env rhs
+
+interestingDict env arg -- Main Plan: use exprIsConApp_maybe
+ | Cast inner_arg _ <- arg -- See (ID5)
+ = if | isConstraintKind $ typeKind $ exprType inner_arg
+ -- If coercions were always homo-kinded, we'd know
+ -- that this would be the only case
+ -> interestingDict env inner_arg
+
+ -- Check for an implicit parameter at the top
+ | Just (cls,_) <- getClassPredTys_maybe arg_ty
+ , isIPClass cls -- See (ID4)
+ -> False
+
+ -- Otherwise we are unwrapping a unary type class
+ | otherwise
+ -> exprIsHNF arg -- See (ID7)
+
+ | Just (_, _, data_con, _tys, args) <- exprIsConApp_maybe in_scope_env arg
+ , Just cls <- tyConClass_maybe (dataConTyCon data_con)
+ , not_ip_like -- See (ID4)
+ = if null (classMethods cls) -- See (ID6)
+ then any (interestingDict env) args
+ else True
+
+ | otherwise
+ = not (exprIsTrivial arg) && not_ip_like -- See (ID8)
+ where
+ arg_ty = exprType arg
+ not_ip_like = not (couldBeIPLike arg_ty)
+ in_scope_env = ISE (substInScopeSet $ se_subst env) realIdUnfolding
+
+{- Note [Ticks on applications]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Ticks such as source location annotations can sometimes make their way
+onto applications (see e.g. #21697). So if we see something like
+
+ App (Tick _ f) e
+
+we need to descend below the tick to find what the real function being
+applied is.
+
+The resulting RULE also has to be able to match this annotated use
+site, so we only look through ticks that RULE matching looks through
+(see Note [Tick annotations in RULE matching] in GHC.Core.Rules).
+
+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:
@@ -3113,44 +3155,91 @@ 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
- See Note [Update unfolding after specialisation]
-* bindAuxiliaryDict adds an unfolding for an aux dict
- see Note [Specialisation modulo dictionary selectors]
-* specCase adds unfoldings for the new bindings it creates
-
-We accidentally lost accurate tracking of local variables for a long
-time, because cloned variables didn't have unfoldings. But makes a
-massive difference in a few cases, eg #5113. For nofib as a
-whole it's only a small win: 2.2% improvement in allocation for ansi,
-1.2% for bspt, but mostly 0.0! Average 0.1% increase in binary size.
+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"? Our Main Plan is to use `exprIsConApp_maybe` to see
+if the argument is a dictionary constructor applied to some arguments, in which
+case we can clearly specialise. But there are wrinkles:
+
+(ID1) Note that we look at the argument /term/, not its /type/. Suppose the
+ argument is
+ (% d1, d2 %) |> co
+ where co :: (% Eq [a], Show [a] %) ~ F Int a, and `F` is a type family.
+ Then its type (F Int a) looks very un-informative, but the term is super
+ helpful. See #19747 (where missing this point caused a 70x slow down)
+ and #7785.
+
+(ID2) Note that the Main Plan works fine for an argument that is a DFun call,
+ e.g. $fOrdList $dOrdInt
+ because `exprIsConApp_maybe` cleverly deals with DFunId applications. Good!
+
+(ID3) For 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
+ See Note [Update unfolding after specialisation]
+ * bindAuxiliaryDict adds an unfolding for an aux dict
+ see Note [Specialisation modulo dictionary selectors]
+ * specCase adds unfoldings for the new bindings it creates
+
+ We accidentally lost accurate tracking of local variables for a long
+ time, because cloned variables didn't have unfoldings. But makes a
+ massive difference in a few cases, eg #5113. For nofib as a
+ whole it's only a small win: 2.2% improvement in allocation for ansi,
+ 1.2% for bspt, but mostly 0.0! Average 0.1% increase in binary size.
+
+(ID4) We must be very careful not to specialise on a "dictionary" that is, or contains
+ an implicit parameter, because implicit parameters are emphatically not singleton
+ types. See #25999:
+ useImplicit :: (?i :: Int) => Int
+ useImplicit = ?i + 1
+
+ foo = let ?i = 1 in (useImplicit, let ?i = 2 in useImplicit)
+ Both calls to `useImplicit` are at type `?i::Int`, but they pass different values.
+ We must not specialise on implicit parameters! Hence the call to `couldBeIPLike`.
+
+(ID5) Suppose the argument is (e |> co). Can we rely on `exprIsConApp_maybe` to deal
+ with the coercion. No! That only works if (co :: C t1 ~ C t2) with the same type
+ constructor at the top of both sides. But see the example in (ID1), where that
+ is not true. For thes same reason, we can't rely on `exprIsConApp_maybe` to look
+ through unfoldings (because there might be a cast inside), hence dealing with
+ expandable unfoldings in `interestingDict` directly.
+
+(ID6) The Main Plan says that it's worth specialising if the argument is an application
+ of a dictionary contructor. But what if the dictionary has no methods? Then we
+ gain nothing by specialising, unless the /superclasses/ are interesting. A case
+ in point is constraint tuples (% d1, .., dn %); a constraint N-tuple is a class
+ with N superclasses and no methods.
+
+(ID7) A unary (single-method) class is currently represented by (meth |> co). We
+ will unwrap the cast (see (ID5)) and then want to reply "yes" if the method
+ has any struture. We rather arbitrarily use `exprIsHNF` for this. (We plan a
+ new story for unary classes, see #23109, and this special case will become
+ irrelevant.)
+
+(ID8) Sadly, if `exprIsConApp_maybe` says Nothing, we still want to treat a
+ non-trivial argument as interesting. In T19695 we have this:
+ askParams :: Monad m => blah
+ mhelper :: MonadIO m => blah
+ mhelper (d:MonadIO m) = ...(askParams @m ($p1 d))....
+ where `$p1` is the superclass selector for `MonadIO`. Now, if `mhelper` is
+ specialised at `Handler` we'll get this call in the specialised `$smhelper`:
+ askParams @Handler ($p1 $fMonadIOHandler)
+ and we /definitely/ want to specialise that, even though the argument isn't
+ visibly a dictionary application. In fact the specialiser fires the superclass
+ selector rule (see Note [Fire rules in the specialiser]), so we get
+ askParams @Handler ($cp1MonadIO $fMonadIOIO)
+ but it /still/ doesn't look like a dictionary application.
+
+ Conclusion: we optimistically assume that any non-trivial argument is worth
+ specialising on.
+
+ So why do the `exprIsConApp_maybe` and `Cast` stuff? Because we want to look
+ under type-family casts (ID1) and constraint tuples (ID6).
Note [Update unfolding after specialisation]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -3178,6 +3267,7 @@ Consider (#21848)
Now `f` turns into:
f @a @b (dd :: D a) (ds :: Show b) a b
+
= let dc :: D a = %p1 dd -- Superclass selection
in meth @a dc ....
meth @a dc ....
@@ -3193,27 +3283,6 @@ in the NonRec case of specBind. (This is too exotic to trouble with
the Rec case.)
-}
-interestingDict :: CoreExpr -> Type -> Bool
--- A dictionary argument is interesting if it has *some* structure,
--- see Note [Interesting dictionary arguments]
--- NB: "dictionary" arguments include constraints of all sorts,
--- including equality constraints; hence the Coercion case
--- To make this work, we need to ensure that dictionaries have
--- unfoldings in them.
-interestingDict arg arg_ty
- | not (typeDeterminesValue arg_ty) = False -- See Note [Type determines value]
- | otherwise = go arg
- where
- go (Var v) = hasSomeUnfolding (idUnfolding v)
- || isDataConWorkId v
- go (Type _) = False
- go (Coercion _) = False
- go (App fn (Type _)) = go fn
- go (App fn (Coercion _)) = go fn
- go (Tick _ a) = go a
- go (Cast e _) = go e
- go _ = True
-
thenUDs :: UsageDetails -> UsageDetails -> UsageDetails
thenUDs (MkUD {ud_binds = db1, ud_calls = calls1})
(MkUD {ud_binds = db2, ud_calls = calls2})
=====================================
compiler/GHC/Core/Predicate.hs
=====================================
@@ -24,7 +24,7 @@ module GHC.Core.Predicate (
classMethodTy, classMethodInstTy,
-- Implicit parameters
- isIPLikePred, mentionsIP, isIPTyCon, isIPClass,
+ couldBeIPLike, mightMentionIP, isIPTyCon, isIPClass,
isCallStackTy, isCallStackPred, isCallStackPredTy,
isExceptionContextPred, isExceptionContextTy,
isIPPred_maybe,
@@ -126,9 +126,12 @@ isDictTy ty = isClassPred pred
where
(_, pred) = splitInvisPiTys ty
+-- | Is the type *guaranteed* to determine the value?
+--
+-- Might say No even if the type does determine the value. (See the Note)
typeDeterminesValue :: Type -> Bool
-- See Note [Type determines value]
-typeDeterminesValue ty = isDictTy ty && not (isIPLikePred ty)
+typeDeterminesValue ty = isDictTy ty && not (couldBeIPLike ty)
getClassPredTys :: HasDebugCallStack => PredType -> (Class, [Type])
getClassPredTys ty = case getClassPredTys_maybe ty of
@@ -171,6 +174,10 @@ So we treat implicit params just like ordinary arguments for the
purposes of specialisation. Note that we still want to specialise
functions with implicit params if they have *other* dicts which are
class params; see #17930.
+
+It's also not always possible to infer that a type determines the value
+if type families are in play. See #19747 for one such example.
+
-}
-- --------------------- Equality predicates ---------------------------------
@@ -421,44 +428,44 @@ isCallStackTy ty
| otherwise
= False
--- --------------------- isIPLike and mentionsIP --------------------------
+-- --------------------- couldBeIPLike and mightMentionIP --------------------------
-- See Note [Local implicit parameters]
-isIPLikePred :: Type -> Bool
+couldBeIPLike :: Type -> Bool
-- Is `pred`, or any of its superclasses, an implicit parameter?
-- See Note [Local implicit parameters]
-isIPLikePred pred =
- mentions_ip_pred initIPRecTc (const True) (const True) pred
-
-mentionsIP :: (Type -> Bool) -- ^ predicate on the string
- -> (Type -> Bool) -- ^ predicate on the type
- -> Class
- -> [Type] -> Bool
--- ^ @'mentionsIP' str_cond ty_cond cls tys@ returns @True@ if:
+couldBeIPLike pred
+ = might_mention_ip1 initIPRecTc (const True) (const True) pred
+
+mightMentionIP :: (Type -> Bool) -- ^ predicate on the string
+ -> (Type -> Bool) -- ^ predicate on the type
+ -> Class
+ -> [Type] -> Bool
+-- ^ @'mightMentionIP' str_cond ty_cond cls tys@ returns @True@ if:
--
-- - @cls tys@ is of the form @IP str ty@, where @str_cond str@ and @ty_cond ty@
-- are both @True@,
-- - or any superclass of @cls tys@ has this property.
--
-- See Note [Local implicit parameters]
-mentionsIP = mentions_ip initIPRecTc
+mightMentionIP = might_mention_ip initIPRecTc
-mentions_ip :: RecTcChecker -> (Type -> Bool) -> (Type -> Bool) -> Class -> [Type] -> Bool
-mentions_ip rec_clss str_cond ty_cond cls tys
+might_mention_ip :: RecTcChecker -> (Type -> Bool) -> (Type -> Bool) -> Class -> [Type] -> Bool
+might_mention_ip rec_clss str_cond ty_cond cls tys
| Just (str_ty, ty) <- isIPPred_maybe cls tys
= str_cond str_ty && ty_cond ty
| otherwise
- = or [ mentions_ip_pred rec_clss str_cond ty_cond (classMethodInstTy sc_sel_id tys)
+ = or [ might_mention_ip1 rec_clss str_cond ty_cond (classMethodInstTy sc_sel_id tys)
| sc_sel_id <- classSCSelIds cls ]
-mentions_ip_pred :: RecTcChecker -> (Type -> Bool) -> (Type -> Bool) -> Type -> Bool
-mentions_ip_pred rec_clss str_cond ty_cond ty
+might_mention_ip1 :: RecTcChecker -> (Type -> Bool) -> (Type -> Bool) -> Type -> Bool
+might_mention_ip1 rec_clss str_cond ty_cond ty
| Just (cls, tys) <- getClassPredTys_maybe ty
, let tc = classTyCon cls
, Just rec_clss' <- if isTupleTyCon tc then Just rec_clss
else checkRecTc rec_clss tc
- = mentions_ip rec_clss' str_cond ty_cond cls tys
+ = might_mention_ip rec_clss' str_cond ty_cond cls tys
| otherwise
= False -- Includes things like (D []) where D is
-- a Constraint-ranged family; #7785
@@ -471,7 +478,7 @@ initIPRecTc = setRecTcMaxBound 1 initRecTc
See also wrinkle (SIP1) in Note [Shadowing of implicit parameters] in
GHC.Tc.Solver.Dict.
-The function isIPLikePred tells if this predicate, or any of its
+The function couldBeIPLike tells if this predicate, or any of its
superclasses, is an implicit parameter.
Why are implicit parameters special? Unlike normal classes, we can
@@ -479,7 +486,7 @@ have local instances for implicit parameters, in the form of
let ?x = True in ...
So in various places we must be careful not to assume that any value
of the right type will do; we must carefully look for the innermost binding.
-So isIPLikePred checks whether this is an implicit parameter, or has
+So couldBeIPLike checks whether this is an implicit parameter, or has
a superclass that is an implicit parameter.
Several wrinkles
@@ -520,16 +527,16 @@ Small worries (Sept 20):
think nothing does.
* I'm a little concerned about type variables; such a variable might
be instantiated to an implicit parameter. I don't think this
- matters in the cases for which isIPLikePred is used, and it's pretty
+ matters in the cases for which couldBeIPLike is used, and it's pretty
obscure anyway.
* The superclass hunt stops when it encounters the same class again,
but in principle we could have the same class, differently instantiated,
and the second time it could have an implicit parameter
I'm going to treat these as problems for another day. They are all exotic.
-Note [Using typesAreApart when calling mentionsIP]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We call 'mentionsIP' in two situations:
+Note [Using typesAreApart when calling mightMentionIP]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We call 'mightMentionIP' in two situations:
(1) to check that a predicate does not contain any implicit parameters
IP str ty, for a fixed literal str and any type ty,
=====================================
compiler/GHC/Tc/Solver.hs
=====================================
@@ -1914,7 +1914,7 @@ growThetaTyVars theta tcvs
| otherwise = transCloVarSet mk_next seed_tcvs
where
seed_tcvs = tcvs `unionVarSet` tyCoVarsOfTypes ips
- (ips, non_ips) = partition isIPLikePred theta
+ (ips, non_ips) = partition couldBeIPLike theta
-- See Note [Inheriting implicit parameters]
mk_next :: VarSet -> VarSet -- Maps current set to newly-grown ones
=====================================
compiler/GHC/Tc/Solver/Dict.hs
=====================================
@@ -749,7 +749,7 @@ shortCutSolver dflags ev_w ev_i
-- programs should typecheck regardless of whether we take this step or
-- not. See Note [Shortcut solving]
- , not (isIPLikePred (ctEvPred ev_w)) -- Not for implicit parameters (#18627)
+ , not (couldBeIPLike (ctEvPred ev_w)) -- Not for implicit parameters (#18627)
, not (xopt LangExt.IncoherentInstances dflags)
-- If IncoherentInstances is on then we cannot rely on coherence of proofs
=====================================
compiler/GHC/Tc/Solver/InertSet.hs
=====================================
@@ -2040,10 +2040,10 @@ solveOneFromTheOther ct_i ct_w
is_wsc_orig_w = isWantedSuperclassOrigin orig_w
different_level_strategy -- Both Given
- | isIPLikePred pred = if lvl_w `strictlyDeeperThan` lvl_i then KeepWork else KeepInert
- | otherwise = if lvl_w `strictlyDeeperThan` lvl_i then KeepInert else KeepWork
+ | couldBeIPLike pred = if lvl_w `strictlyDeeperThan` lvl_i then KeepWork else KeepInert
+ | otherwise = if lvl_w `strictlyDeeperThan` lvl_i then KeepInert else KeepWork
-- See Note [Replacement vs keeping] part (1)
- -- For the isIPLikePred case see Note [Shadowing of implicit parameters]
+ -- For the couldBeIPLike case see Note [Shadowing of implicit parameters]
-- in GHC.Tc.Solver.Dict
same_level_strategy -- Both Given
=====================================
compiler/GHC/Tc/Solver/Monad.hs
=====================================
@@ -401,8 +401,8 @@ updInertDicts dict_ct@(DictCt { di_cls = cls, di_ev = ev, di_tys = tys })
-- an implicit parameter (?str :: ty) for the given 'str' and any type 'ty'?
does_not_mention_ip_for :: Type -> DictCt -> Bool
does_not_mention_ip_for str_ty (DictCt { di_cls = cls, di_tys = tys })
- = not $ mentionsIP (not . typesAreApart str_ty) (const True) cls tys
- -- See Note [Using typesAreApart when calling mentionsIP]
+ = not $ mightMentionIP (not . typesAreApart str_ty) (const True) cls tys
+ -- See Note [Using typesAreApart when calling mightMentionIP]
-- in GHC.Core.Predicate
updInertIrreds :: IrredCt -> TcS ()
@@ -534,7 +534,7 @@ updSolvedDicts what dict_ct@(DictCt { di_cls = cls, di_tys = tys, di_ev = ev })
= do { is_callstack <- is_tyConTy isCallStackTy callStackTyConName
; is_exceptionCtx <- is_tyConTy isExceptionContextTy exceptionContextTyConName
; let contains_callstack_or_exceptionCtx =
- mentionsIP
+ mightMentionIP
(const True)
-- NB: the name of the call-stack IP is irrelevant
-- e.g (?foo :: CallStack) counts!
@@ -552,9 +552,9 @@ updSolvedDicts what dict_ct@(DictCt { di_cls = cls, di_tys = tys, di_ev = ev })
-- Return a predicate that decides whether a type is CallStack
-- or ExceptionContext, accounting for e.g. type family reduction, as
- -- per Note [Using typesAreApart when calling mentionsIP].
+ -- per Note [Using typesAreApart when calling mightMentionIP].
--
- -- See Note [Using isCallStackTy in mentionsIP].
+ -- See Note [Using isCallStackTy in mightMentionIP].
is_tyConTy :: (Type -> Bool) -> Name -> TcS (Type -> Bool)
is_tyConTy is_eq tc_name
= do { (mb_tc, _) <- wrapTcS $ TcM.tryTc $ TcM.tcLookupTyCon tc_name
@@ -582,14 +582,14 @@ in a different context!
See also Note [Shadowing of implicit parameters], which deals with a similar
problem with Given implicit parameter constraints.
-Note [Using isCallStackTy in mentionsIP]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [Using isCallStackTy in mightMentionIP]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
To implement Note [Don't add HasCallStack constraints to the solved set],
we need to check whether a constraint contains a HasCallStack or HasExceptionContext
constraint. We do this using the 'mentionsIP' function, but as per
-Note [Using typesAreApart when calling mentionsIP] we don't want to simply do:
+Note [Using typesAreApart when calling mightMentionIP] we don't want to simply do:
- mentionsIP
+ mightMentionIP
(const True) -- (ignore the implicit parameter string)
(isCallStackTy <||> isExceptionContextTy)
=====================================
compiler/GHC/Tc/Utils/TcType.hs
=====================================
@@ -155,7 +155,7 @@ module GHC.Tc.Utils.TcType (
mkTyConTy, mkTyVarTy, mkTyVarTys,
mkTyCoVarTy, mkTyCoVarTys,
- isClassPred, isEqPred, isIPLikePred, isEqClassPred,
+ isClassPred, isEqPred, couldBeIPLike, isEqClassPred,
isEqualityClass, mkClassPred,
tcSplitQuantPredTy, tcSplitDFunTy, tcSplitDFunHead, tcSplitMethodTy,
isRuntimeRepVar, isFixedRuntimeRepKind,
@@ -1819,7 +1819,7 @@ pickCapturedPreds
pickCapturedPreds qtvs theta
= filter captured theta
where
- captured pred = isIPLikePred pred || (tyCoVarsOfType pred `intersectsVarSet` qtvs)
+ captured pred = couldBeIPLike pred || (tyCoVarsOfType pred `intersectsVarSet` qtvs)
-- Superclasses
=====================================
testsuite/tests/perf/should_run/SpecTyFamRun.hs
=====================================
@@ -0,0 +1,15 @@
+{-# OPTIONS_GHC -fspecialise-aggressively #-}
+{-# OPTIONS_GHC -fno-spec-constr #-}
+module Main(main) where
+
+import SpecTyFam_Import (specMe, MaybeShowNum)
+import GHC.Exts
+
+-- We want to see a specialization of `specMe` which doesn't take a dictionary at runtime.
+
+{-# NOINLINE foo #-}
+foo :: Int -> (String,Int)
+-- We want specMe to be specialized, but not inlined
+foo x = specMe True x
+
+main = print $ sum $ map (snd . foo) [1..1000 :: Int]
=====================================
testsuite/tests/perf/should_run/SpecTyFamRun.stdout
=====================================
@@ -0,0 +1 @@
+500500
=====================================
testsuite/tests/perf/should_run/SpecTyFam_Import.hs
=====================================
@@ -0,0 +1,13 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE BangPatterns #-}
+
+module SpecTyFam_Import (specMe, MaybeShowNum) where
+
+import Data.Kind
+
+type family MaybeShowNum a n :: Constraint where
+ MaybeShowNum a n = (Show a, Num n)
+
+{-# INLINABLE specMe #-}
+specMe :: (Integral n, MaybeShowNum a n) => a -> n -> (String,n)
+specMe s !n = (show s, n+1 `div` 2)
=====================================
testsuite/tests/perf/should_run/all.T
=====================================
@@ -423,3 +423,12 @@ test('ByteCodeAsm',
],
compile_and_run,
['-package ghc'])
+
+# Check that $s$wspecMe doesn't have any dictionary args after specialization in addition to perf stats
+# See also #19747
+test('SpecTyFamRun', [ grep_errmsg(r'foo')
+ , extra_files(['SpecTyFam_Import.hs'])
+ , only_ways(['optasm'])
+ , collect_stats('bytes allocated', 5)],
+ multimod_compile_and_run,
+ ['SpecTyFamRun', '-O2'])
=====================================
testsuite/tests/simplCore/should_compile/T26051.hs
=====================================
@@ -0,0 +1,15 @@
+{-# OPTIONS_GHC -fspecialise-aggressively #-}
+{-# OPTIONS_GHC -fno-spec-constr #-}
+
+module SpecTyFam(main, foo) where
+
+import SpecTyFam_Import (specMe, MaybeShowNum)
+import GHC.Exts
+
+-- We want to see a specialization of `specMe` which doesn't take a dictionary at runtime.
+
+{-# OPAQUE foo #-}
+foo :: Int -> (String,Int)
+foo x = specMe True x
+
+main = print $ sum $ map (snd . foo) [1..1000 :: Int]
=====================================
testsuite/tests/simplCore/should_compile/T26051.stderr
=====================================
@@ -0,0 +1,78 @@
+[1 of 2] Compiling SpecTyFam_Import ( SpecTyFam_Import.hs, SpecTyFam_Import.o )
+
+==================== Specialise ====================
+Result size of Specialise = {terms: 31, types: 39, coercions: 8, joins: 0/1}
+
+-- RHS size: {terms: 30, types: 27, coercions: 8, joins: 0/1}
+specMe [InlPrag=INLINABLE] :: forall n a. (Integral n, MaybeShowNum a n) => a -> n -> (String, n)
+[LclIdX,
+ Arity=4,
+ Unf=Unf{Src=StableUser, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [30 0 0 20] 260 10
+ Tmpl= \ (@n) (@a) ($dIntegral [Occ=Once1] :: Integral n) (irred :: MaybeShowNum a n) (eta [Occ=Once1] :: a) (eta [Occ=Once1] :: n) ->
+ let {
+ $dNum :: Num n
+ [LclId, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=False, ConLike=False, WorkFree=False, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+ $dNum = GHC.Internal.Classes.$p1CTuple2 @(Show a) @(Num n) (irred `cast` (Sub (SpecTyFam_Import.D:R:MaybeShowNum[0] <a>_N <n>_N) :: MaybeShowNum a n ~R# (Show a, Num n))) } in
+ case eta of n [Occ=Once1] { __DEFAULT -> (show @a (GHC.Internal.Classes.$p0CTuple2 @(Show a) @(Num n) (irred `cast` (Sub (SpecTyFam_Import.D:R:MaybeShowNum[0] <a>_N <n>_N) :: MaybeShowNum a n ~R# (Show a, Num n)))) eta, + @n $dNum n (div @n $dIntegral (fromInteger @n $dNum (GHC.Internal.Bignum.Integer.IS 1#)) (fromInteger @n $dNum (GHC.Internal.Bignum.Integer.IS 2#)))) }}]
+specMe
+ = \ (@n) (@a) ($dIntegral :: Integral n) (irred :: MaybeShowNum a n) (eta :: a) (eta :: n) ->
+ let {
+ $dNum :: Num n
+ [LclId, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=False, ConLike=False, WorkFree=False, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+ $dNum = GHC.Internal.Classes.$p1CTuple2 @(Show a) @(Num n) (irred `cast` (Sub (SpecTyFam_Import.D:R:MaybeShowNum[0] <a>_N <n>_N) :: MaybeShowNum a n ~R# (Show a, Num n))) } in
+ case eta of n { __DEFAULT -> (show @a (GHC.Internal.Classes.$p0CTuple2 @(Show a) @(Num n) (irred `cast` (Sub (SpecTyFam_Import.D:R:MaybeShowNum[0] <a>_N <n>_N) :: MaybeShowNum a n ~R# (Show a, Num n)))) eta, + @n $dNum n (div @n $dIntegral (fromInteger @n $dNum (GHC.Internal.Bignum.Integer.IS 1#)) (fromInteger @n $dNum (GHC.Internal.Bignum.Integer.IS 2#)))) }
+
+
+
+[2 of 2] Compiling SpecTyFam ( SpecTyFam.hs, SpecTyFam.o )
+
+==================== Specialise ====================
+Result size of Specialise = {terms: 84, types: 86, coercions: 13, joins: 0/1}
+
+Rec {
+-- RHS size: {terms: 3, types: 4, coercions: 0, joins: 0/0}
+$dCTuple2 :: (Show Bool, Num Int)
+[LclId, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+$dCTuple2 = (GHC.Internal.Show.$fShowBool, GHC.Internal.Num.$fNumInt)
+
+-- RHS size: {terms: 19, types: 9, coercions: 0, joins: 0/1}
+$s$wspecMe [InlPrag=INLINABLE[2]] :: Bool -> Int -> (# String, Int #)
+[LclId, Arity=2]
+$s$wspecMe
+ = \ (eta [Occ=Once1] :: Bool) (eta1 [Occ=Once1] :: Int) ->
+ let {
+ $dNum :: Num Int
+ [LclId, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=True)}]
+ $dNum = GHC.Internal.Num.$fNumInt } in
+ case eta1 of n1 [Occ=Once1] { __DEFAULT -> (# GHC.Internal.Show.$fShowBool_$cshow eta, GHC.Internal.Num.$fNumInt_$c+ n1 (GHC.Internal.Real.$fIntegralInt_$cdiv (GHC.Internal.Num.$fNumInt_$cfromInteger (GHC.Internal.Bignum.Integer.IS 1#)) (GHC.Internal.Num.$fNumInt_$cfromInteger (GHC.Internal.Bignum.Integer.IS 2#))) #) }
+
+-- RHS size: {terms: 12, types: 13, coercions: 5, joins: 0/0}
+$sspecMe [InlPrag=INLINABLE[2]] :: Bool -> Int -> (String, Int)
+[LclId,
+ Arity=2,
+ Unf=Unf{Src=StableSystem, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False)
+ Tmpl= \ (eta [Occ=Once1] :: Bool) (eta1 [Occ=Once1] :: Int) -> case SpecTyFam_Import.$wspecMe @Int @Bool GHC.Internal.Real.$fIntegralInt ($dCTuple2 `cast` (Sub (Sym (SpecTyFam_Import.D:R:MaybeShowNum[0] <Bool>_N <Int>_N)) :: (Show Bool, Num Int) ~R# MaybeShowNum Bool Int)) eta eta1 of { (# ww [Occ=Once1], ww1 [Occ=Once1] #) -> (ww, ww1) }}]
+$sspecMe = \ (eta [Occ=Once1] :: Bool) (eta1 [Occ=Once1] :: Int) -> case SpecTyFam_Import.$wspecMe @Int @Bool GHC.Internal.Real.$fIntegralInt ($dCTuple2 `cast` (Sub (Sym (SpecTyFam_Import.D:R:MaybeShowNum[0] <Bool>_N <Int>_N)) :: (Show Bool, Num Int) ~R# MaybeShowNum Bool Int)) eta eta1 of { (# ww [Occ=Once1], ww1 [Occ=Once1] #) -> (ww, ww1) }
+end Rec }
+
+-- RHS size: {terms: 6, types: 3, coercions: 5, joins: 0/0}
+foo [InlPrag=OPAQUE] :: Int -> (String, Int)
+[LclIdX, Arity=1, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [0] 50 0}]
+foo = \ (x :: Int) -> specMe @Int @Bool GHC.Internal.Real.$fIntegralInt ($dCTuple2 `cast` (Sub (Sym (SpecTyFam_Import.D:R:MaybeShowNum[0] <Bool>_N <Int>_N)) :: (Show Bool, Num Int) ~R# MaybeShowNum Bool Int)) GHC.Internal.Types.True x
+
+-- RHS size: {terms: 37, types: 26, coercions: 0, joins: 0/0}
+main :: State# RealWorld -> (# State# RealWorld, () #)
+[LclId, Arity=1, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [0] 301 0}]
+main = \ (eta [OS=OneShot] :: State# RealWorld) -> GHC.Internal.IO.Handle.Text.hPutStr2 GHC.Internal.IO.Handle.FD.stdout (case GHC.Internal.Enum.eftIntFB @(Int -> Int) (GHC.Internal.Base.mapFB @Int @(Int -> Int) @Int (\ (ds :: Int) (ds1 [OS=OneShot] :: Int -> Int) (v [OS=OneShot] :: Int) -> case v of { I# ipv -> ds1 (case ds of { I# y -> GHC.Internal.Types.I# (+# ipv y) }) }) (\ (x :: Int) -> case foo x of { (_ [Occ=Dead], y) -> y })) (breakpoint @Int) 1# 1000# (GHC.Internal.Types.I# 0#) of { I# n -> GHC.Internal.Show.itos n (GHC.Internal.Types.[] @Char) }) GHC.Internal.Types.True eta
+
+-- RHS size: {terms: 1, types: 0, coercions: 3, joins: 0/0}
+main :: IO ()
+[LclIdX, Arity=1, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=True)}]
+main = main `cast` (Sym (GHC.Internal.Types.N:IO <()>_R) :: (State# RealWorld -> (# State# RealWorld, () #)) ~R# IO ())
+
+
+------ Local rules for imported ids --------
+"SPEC/SpecTyFam $wspecMe @Int @Bool" [2] forall ($dIntegral :: Integral Int) (irred :: MaybeShowNum Bool Int). SpecTyFam_Import.$wspecMe @Int @Bool $dIntegral irred = $s$wspecMe
+"SPEC/SpecTyFam specMe @Int @Bool" [2] forall ($dIntegral :: Integral Int) (irred :: MaybeShowNum Bool Int). specMe @Int @Bool $dIntegral irred = $sspecMe
+
+
=====================================
testsuite/tests/simplCore/should_compile/T26051_Import.hs
=====================================
@@ -0,0 +1,14 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE ImplicitParams #-}
+
+module T26051_Import (specMe, MaybeShowNum) where
+
+import Data.Kind
+
+type family MaybeShowNum a n :: Constraint where
+ MaybeShowNum a n = (Show a, Num n)
+
+{-# INLINABLE specMe #-}
+specMe :: (Integral n, MaybeShowNum a n) => a -> n -> (String,n)
+specMe s !n = (show s, n+1 `div` 2)
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -548,3 +548,9 @@ 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'])
+# Check that $s$wspecMe doesn't have any dictionary args after specialization in addition to perf stats
+test('T26051', [ grep_errmsg(r'\$wspecMe')
+ , extra_files(['T26051_Import.hs'])
+ , only_ways(['optasm'])],
+ multimod_compile,
+ ['T26051', '-O2 -ddump-spec -dsuppress-uniques -dno-typeable-binds -dppr-cols=1000'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/072c054793e9ebbec2ce73c52c79bcd…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/072c054793e9ebbec2ce73c52c79bcd…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
21 May '25
Ben Gamari pushed to branch wip/T25716 at Glasgow Haskell Compiler / GHC
Commits:
20d21586 by Ben Gamari at 2025-05-21T12:21:36-04:00
configure: Drop probing of ld.gold
As noted in #25716, `gold` has been dropped from binutils-2.44.
Fixes #25716.
- - - - -
2 changed files:
- m4/find_ld.m4
- utils/ghc-toolchain/src/GHC/Toolchain/Tools/Link.hs
Changes:
=====================================
m4/find_ld.m4
=====================================
@@ -21,14 +21,7 @@ AC_DEFUN([FIND_LD],[
return
fi
- case $CPU in
- i386)
- # We refuse to use ld.gold on i386 due to #23579, which we don't
- # have a good autoconf check for.
- linkers="ld.lld ld" ;;
- *)
- linkers="ld.lld ld.gold ld" ;;
- esac
+ linkers="ld.lld ld"
# Manually iterate over possible names since we want to ensure that, e.g.,
# if ld.lld is installed but gcc doesn't support -fuse-ld=lld, that we
=====================================
utils/ghc-toolchain/src/GHC/Toolchain/Tools/Link.hs
=====================================
@@ -91,7 +91,7 @@ findLinkFlags enableOverride cc ccLink
-- executable exists before trying cc.
do _ <- findProgram (linker ++ " linker") emptyProgOpt ["ld."++linker]
prog <$ checkLinkWorks cc prog
- | linker <- ["lld", "gold", "bfd"]
+ | linker <- ["lld", "bfd"]
, let prog = over _prgFlags (++["-fuse-ld="++linker]) ccLink
]
<|> (ccLink <$ checkLinkWorks cc ccLink)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/20d215863e7e7da36aa03252e40a751…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/20d215863e7e7da36aa03252e40a751…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/andreask/spec_tyfams] 21 commits: Allow the 'data' keyword in import/export lists (#25899)
by Andreas Klebinger (＠AndreasK) 21 May '25
by Andreas Klebinger (＠AndreasK) 21 May '25
21 May '25
Andreas Klebinger pushed to branch wip/andreask/spec_tyfams at Glasgow Haskell Compiler / GHC
Commits:
fd64667d by Vladislav Zavialov at 2025-05-20T03:25:08-04:00
Allow the 'data' keyword in import/export lists (#25899)
This patch introduces the 'data' namespace specifier in import and
export lists. The intended use is to import data constructors without
their parent type constructors, e.g.
import Data.Proxy as D (data Proxy)
type DP = D.Proxy -- promoted data constructor
Additionally, it is possible to use 'data' to explicitly qualify any
data constructors or terms, incl. operators and field selectors
import Prelude (Semigroup(data (<>)))
import Data.Function (data (&))
import Data.Monoid (data Dual, data getDual)
x = Dual "Hello" <> Dual "World" & getDual
The implementation mostly builds on top of the existing logic for the
'type' and 'pattern' namespace specifiers, plus there are a few tweaks
to how we generate suggestions in error messages.
- - - - -
acc86753 by Ben Gamari at 2025-05-20T03:25:51-04:00
compiler: Use field selectors when creating BCOs
This makes it easier to grep for these fields.
- - - - -
60a55fd7 by Ben Gamari at 2025-05-20T03:25:51-04:00
compiler: Clarify BCO size
Previously the semantics and size of StgBCO was a bit unclear.
Specifically, the `size` field was documented to contain the size of the
bitmap whereas it was actually the size of the closure *and* bitmap.
Additionally, it was not as clear as it could be that the bitmap was a
full StgLargeBitmap with its own `size` field.
- - - - -
ac9fb269 by Simon Peyton Jones at 2025-05-20T09:19:04-04:00
Track rewriter sets more accurately in constraint solving
This MR addresses #26003, by refactoring the arcane
intricacies of Note [Equalities with incompatible kinds].
NB: now retitled to
Note [Equalities with heterogeneous kinds].
and the main Note for this MR.
In particular:
* Abandon invariant (COERCION-HOLE) in Note [Unification preconditions] in
GHC.Tc.Utils.Unify.
* Abandon invariant (TyEq:CH)) in Note [Canonical equalities] in
GHC.Tc.Types.Constraint.
* Instead: add invariant (REWRITERS) to Note [Unification preconditions]:
unify only if the constraint has an empty rewriter set.
Implementation:
* In canEqCanLHSFinish_try_unification, skip trying unification if there is a
non-empty rewriter set.
* To do this, make sure the rewriter set is zonked; do so in selectNextWorkItem,
which also deals with prioritisation.
* When a coercion hole is filled, kick out inert equalities that have that hole
as a rewriter. It might now be unlocked and available to unify.
* Remove the ad-hoc `ch_hetero_kind` field of `CoercionHole`.
* In `selectNextWorkItem`, priorities equalities withan empty rewriter set.
* Defaulting: see (DE6) in Note [Defaulting equalities]
and Note [Limited defaulting in the ambiguity check]
* Concreteness checks: there is some extra faff to try to get decent
error messages when the FRR (representation-polymorphism) checks
fail. In partiular, add a "When unifying..." explanation when the
representation-polymorphism check arose from another constraint.
- - - - -
86406f48 by Cheng Shao at 2025-05-20T09:19:47-04:00
rts: fix rts_clearMemory logic when sanity checks are enabled
This commit fixes an RTS assertion failure when invoking
rts_clearMemory with +RTS -DS. -DS implies -DZ which asserts that free
blocks contain 0xaa as the designated garbage value. Also adds the
sanity way to rts_clearMemory test to prevent future regression.
Closes #26011.
ChatGPT Codex automatically diagnosed the issue and proposed the
initial patch in a single shot, given a GHC checkout and the following
prompt:
---
Someone is reporting the following error when attempting to use `rts_clearMemory` with the RTS option `-DS`:
```
test.wasm: internal error: ASSERTION FAILED: file rts/sm/Storage.c, line 1216
(GHC version 9.12.2.20250327 for wasm32_unknown_wasi)
Please report this as a GHC bug: https://www.haskell.org/ghc/reportabug
```
What's the culprit? How do I look into this issue?
---
I manually reviewed & revised the patch, tested and submitted it.
- - - - -
7147370b by Cheng Shao at 2025-05-20T17:22:19-04:00
compiler: do not allocate strings in bytecode assembler
This patch refactors the compiler to avoid allocating iserv buffers
for BCONPtrStr at assemble-time. Now BCONPtrStr ByteStrings are
recorded as a part of CompiledByteCode, and actual allocation only
happens at link-time. This refactoring is necessary for adding
bytecode serialization functionality, as explained by the revised
comments in this commit.
- - - - -
a67db612 by Cheng Shao at 2025-05-20T17:22:19-04:00
compiler: make bc_strs serializable
This commit makes the bc_strs field in CompiledByteCode serializable;
similar to previous commit, we preserve the ByteString directly and
defer the actual allocation to link-time, as mentioned in updated
comment.
- - - - -
5faf34ef by Cheng Shao at 2025-05-20T17:22:19-04:00
compiler: make bc_itbls serializable
This commit makes bc_itbls in CompiledByteCode serializable. A
dedicated ConInfoTable datatype has been added in ghci which is the
recipe for dynamically making a datacon's info table, containing the
payload of the MkConInfoTable iserv message.
- - - - -
2abaf8c1 by Cheng Shao at 2025-05-20T17:22:19-04:00
compiler: remove FFIInfo bookkeeping in BCO
This commit removes the bc_ffis field from CompiledByteCode
completely, as well as all the related bookkeeping logic in
GHC.StgToByteCode. bc_ffis is actually *unused* in the rest of GHC
codebase! It is merely a list of FFIInfo, which is just a remote
pointer of the libffi ffi_cif struct; once we allocate the ffi_cif
struct and put its pointer in a CCALL instruction, we'll never free it
anyway. So there is no point of bookkeeping.
- - - - -
adb9e4d2 by Cheng Shao at 2025-05-20T17:22:19-04:00
compiler: make FFIInfo serializable in BCO
This commit makes all the FFIInfo needed in CCALL instructions
serializable. Previously, when doing STG to BCO lowering, we would
allocate a libffi ffi_cif struct and keep its remote pointer as
FFIInfo; but actually we can just keep the type signature as FFIInfo
and defer the actual allocation to link-time.
- - - - -
200f401b by Cheng Shao at 2025-05-20T17:22:19-04:00
ghci: remove redundant NewBreakModule message
This commit removes the redundant NewBreakModule message from ghci: it
just allocates two strings! This functionality can be implemented with
existing MallocStrings in one iserv call.
- - - - -
ddaadca6 by Cheng Shao at 2025-05-20T17:22:19-04:00
compiler: make breakpoint module name and unit id serializable
This commit makes breakpoint module name and unit id serializable, in
BRK_FUN instructions as well as ModBreaks. We can simply keep the
module name and unit ids, and defer the buffer allocation to link
time.
- - - - -
a0fde202 by Cheng Shao at 2025-05-20T17:22:19-04:00
compiler: remove unused newModule
This commit removes the now unused newModule function from GHC.
- - - - -
68c8f140 by Cheng Shao at 2025-05-20T17:22:19-04:00
compiler: add BCONPtrFS for interned top level string literals in BCO
This commit adds BCONPtrFS as a BCO non-pointer literal kind, which
has the same semantics of BCONPtrStr, except it contains a FastString
instead of a ByteString. By using BCONPtrFS to represent top level
string literals that are already FastString in the compilation
pipeline, we enjoy the FastString interning logic and avoid allocating
a bunch of redundant ByteStrings for the same FastStrings, especially
when we lower the BRK_FUN instruction.
- - - - -
f2b532bc by Peng Fan at 2025-05-20T17:23:15-04:00
hadrian: enable GHCi for loongarch64
- - - - -
8ded2330 by kwxm at 2025-05-20T17:24:07-04:00
Fix bugs in `integerRecipMod` and `integerPowMod`
This fixes #26017.
* `integerRecipMod x 1` now returns `(# 1 | #)` for all x; previously it
incorrectly returned `(# | () #)`, indicating failure.
* `integerPowMod 0 e m` now returns `(# | () #)` for e<0 and m>1, indicating
failure; previously it incorrectly returned `(# 0 | #)`.
- - - - -
c9abb87c by Andreas Klebinger at 2025-05-20T17:24:50-04:00
Specialise: Don't float out constraint components.
It was fairly complex to do so and it doesn't seem to improve anything.
Nofib allocations were unaffected as well.
See also Historical Note [Floating dictionaries out of cases]
- - - - -
202b201c by Andreas Klebinger at 2025-05-21T10:16:14-04: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.
- - - - -
67a177b4 by sheaf at 2025-05-21T10:17:04-04:00
QuickLook: do a shape test before unifying
This commit ensures we do a shape test before unifying. This ensures
we don't try to unify a TyVarTv with a non-tyvar, e.g.
alpha[tyv] := Int
On the way, we refactor simpleUnifyCheck:
1. Move the checkTopShape check into simpleUnifyCheck
2. Refactors simpleUnifyCheck to return a value of the new type
SimpleUnifyResult type. Now, simpleUnifyCheck returns "can unify",
"cannot unify" or "dunno" (with "cannot unify" being the new result
it can return). Now:
- touchabilityTest is included; it it fails we return "cannot unify"
- checkTopShape now returns "cannot unify" instead of "dunno" upon failure
3. Move the call to simpleUnifyCheck out of checkTouchableTyVarEq.
After that, checkTouchableTyVarEq becames a simple call to
checkTyEqRhs, so we inline it.
This allows the logic in canEqCanLHSFinish_try_unification to be simplified.
In particular, we now avoid calling 'checkTopShape' twice.
Two further changes suggested by Simon were also implemented:
- In canEqCanLHSFinish, if checkTyEqRhs returns PuFail with
'do_not_prevent_rewriting', we now **continue with this constraint**.
This allows us to use the constraint for rewriting.
- checkTyEqRhs now has a top-level check to avoid flattening a tyfam app
in a top-level equality of the form alpha ~ F tys, as this is
going around in circles. This simplifies the implementation without
any change in behaviour.
Fixes #25950
Fixes #26030
- - - - -
4020972c by sheaf at 2025-05-21T10:17:04-04:00
FixedRuntimeRepError: omit unhelpful explanation
This commit tweaks the FixedRuntimeRepError case of pprTcSolverReportMsg,
to avoid including an explanation which refers to a type variable that
appears nowhere else.
For example, the old error message could look like the following:
The pattern binding does not have a fixed runtime representation.
Its type is:
T :: TYPE R
Cannot unify ‘R’ with the type variable ‘c0’
because the former is not a concrete ‘RuntimeRep’.
With this commit, we now omit the last two lines, because the concrete
type variable (here 'c0') does not appear in the type displayed to the
user (here 'T :: TYPE R').
- - - - -
8b289b41 by Andreas Klebinger at 2025-05-21T17:32:13+02:00
Specialise: Improve specialisation by refactoring interestingDict
This MR addresses #26051, which concerns missed type-class specialisation.
The main payload of the MR is to completely refactor the key function
`interestingDict` in GHC.Core.Opt.Specialise
The main change is that we now also look at the structure of the
dictionary we consider specializing on, rather than only the type.
See the big `Note [Interesting dictionary arguments]`
- - - - -
158 changed files:
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/ByteCode/Asm.hs
- compiler/GHC/ByteCode/InfoTable.hs
- compiler/GHC/ByteCode/Instr.hs
- compiler/GHC/ByteCode/Linker.hs
- compiler/GHC/ByteCode/Types.hs
- compiler/GHC/Core/Coercion.hs
- compiler/GHC/Core/Opt/Specialise.hs
- compiler/GHC/Core/Predicate.hs
- compiler/GHC/Core/TyCo/Rep.hs
- compiler/GHC/Core/TyCo/Tidy.hs
- compiler/GHC/Hs/ImpExp.hs
- compiler/GHC/HsToCore/Breakpoints.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Runtime/Interpreter.hs
- compiler/GHC/StgToByteCode.hs
- compiler/GHC/Tc/Errors.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Export.hs
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/Plugin.hs
- compiler/GHC/Tc/Solver.hs
- compiler/GHC/Tc/Solver/Default.hs
- compiler/GHC/Tc/Solver/Dict.hs
- compiler/GHC/Tc/Solver/Equality.hs
- compiler/GHC/Tc/Solver/InertSet.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Types/Constraint.hs
- compiler/GHC/Tc/Utils/TcMType.hs
- compiler/GHC/Tc/Utils/TcType.hs
- compiler/GHC/Tc/Utils/Unify.hs
- compiler/GHC/Tc/Zonk/TcType.hs
- compiler/GHC/Types/Error/Codes.hs
- compiler/GHC/Types/Hint.hs
- compiler/GHC/Types/Hint/Ppr.hs
- compiler/Language/Haskell/Syntax/Extension.hs
- compiler/Language/Haskell/Syntax/ImpExp.hs
- docs/users_guide/9.14.1-notes.rst
- docs/users_guide/exts/explicit_namespaces.rst
- docs/users_guide/exts/pattern_synonyms.rst
- hadrian/src/Oracles/Flag.hs
- libraries/base/changelog.md
- libraries/ghc-internal/src/GHC/Internal/Bignum/Integer.hs
- libraries/ghci/GHCi/Message.hs
- libraries/ghci/GHCi/Run.hs
- rts/Disassembler.c
- rts/Interpreter.c
- rts/PrimOps.cmm
- rts/include/rts/Bytecodes.h
- rts/include/rts/storage/Closures.h
- rts/sm/Storage.h
- testsuite/tests/bytecode/T22376/all.T
- testsuite/tests/codeGen/should_run/all.T
- testsuite/tests/dependent/should_fail/T11471.stderr
- testsuite/tests/diagnostic-codes/codes.stdout
- testsuite/tests/ffi/should_run/all.T
- + testsuite/tests/ghci/all.T
- + testsuite/tests/ghci/ghci-mem-primops.hs
- + testsuite/tests/ghci/ghci-mem-primops.script
- + testsuite/tests/ghci/ghci-mem-primops.stdout
- testsuite/tests/indexed-types/should_fail/T8227.stderr
- testsuite/tests/indexed-types/should_fail/T9662.stderr
- + testsuite/tests/lib/integer/T26017.hs
- + testsuite/tests/lib/integer/T26017.stdout
- testsuite/tests/lib/integer/all.T
- testsuite/tests/lib/integer/integerRecipMod.hs
- testsuite/tests/lib/integer/integerRecipMod.stdout
- testsuite/tests/module/T21826.stderr
- testsuite/tests/numeric/should_run/all.T
- testsuite/tests/numeric/should_run/foundation.hs
- testsuite/tests/numeric/should_run/foundation.stdout
- testsuite/tests/partial-sigs/should_fail/T14040a.stderr
- testsuite/tests/partial-sigs/should_fail/T14584.stderr
- testsuite/tests/perf/should_run/ByteCodeAsm.hs
- + testsuite/tests/perf/should_run/SpecTyFamRun.hs
- + testsuite/tests/perf/should_run/SpecTyFamRun.stdout
- + testsuite/tests/perf/should_run/SpecTyFam_Import.hs
- testsuite/tests/perf/should_run/all.T
- testsuite/tests/polykinds/T14172.stderr
- testsuite/tests/polykinds/T14846.stderr
- testsuite/tests/rename/should_compile/T22581d.stdout
- + testsuite/tests/rename/should_compile/T25899a.hs
- + testsuite/tests/rename/should_compile/T25899b.hs
- + testsuite/tests/rename/should_compile/T25899c.hs
- + testsuite/tests/rename/should_compile/T25899c_helper.hs
- + testsuite/tests/rename/should_compile/T25899d.script
- + testsuite/tests/rename/should_compile/T25899d.stdout
- testsuite/tests/rename/should_compile/all.T
- testsuite/tests/rename/should_fail/T22581a.stderr
- testsuite/tests/rename/should_fail/T22581b.stderr
- + testsuite/tests/rename/should_fail/T25899e1.hs
- + testsuite/tests/rename/should_fail/T25899e1.stderr
- + testsuite/tests/rename/should_fail/T25899e2.hs
- + testsuite/tests/rename/should_fail/T25899e2.stderr
- + testsuite/tests/rename/should_fail/T25899e3.hs
- + testsuite/tests/rename/should_fail/T25899e3.stderr
- + testsuite/tests/rename/should_fail/T25899e_helper.hs
- + testsuite/tests/rename/should_fail/T25899f.hs
- + testsuite/tests/rename/should_fail/T25899f.stderr
- + testsuite/tests/rename/should_fail/T25899f_helper.hs
- testsuite/tests/rename/should_fail/all.T
- testsuite/tests/rep-poly/RepPolyArgument.stderr
- testsuite/tests/rep-poly/RepPolyBackpack1.stderr
- testsuite/tests/rep-poly/RepPolyBinder.stderr
- testsuite/tests/rep-poly/RepPolyDoBind.stderr
- testsuite/tests/rep-poly/RepPolyDoBody1.stderr
- testsuite/tests/rep-poly/RepPolyDoBody2.stderr
- testsuite/tests/rep-poly/RepPolyLeftSection2.stderr
- testsuite/tests/rep-poly/RepPolyMagic.stderr
- testsuite/tests/rep-poly/RepPolyMcBind.stderr
- testsuite/tests/rep-poly/RepPolyMcBody.stderr
- testsuite/tests/rep-poly/RepPolyMcGuard.stderr
- testsuite/tests/rep-poly/RepPolyNPlusK.stderr
- testsuite/tests/rep-poly/RepPolyPatBind.stderr
- testsuite/tests/rep-poly/RepPolyRecordUpdate.stderr
- testsuite/tests/rep-poly/RepPolyRightSection.stderr
- testsuite/tests/rep-poly/RepPolyRule1.stderr
- testsuite/tests/rep-poly/RepPolyTuple.stderr
- testsuite/tests/rep-poly/RepPolyTuple4.stderr
- testsuite/tests/rep-poly/RepPolyTupleSection.stderr
- testsuite/tests/rep-poly/RepPolyWrappedVar.stderr
- testsuite/tests/rep-poly/T11473.stderr
- testsuite/tests/rep-poly/T12709.stderr
- testsuite/tests/rep-poly/T12973.stderr
- testsuite/tests/rep-poly/T13233.stderr
- testsuite/tests/rep-poly/T13929.stderr
- testsuite/tests/rep-poly/T14561.stderr
- testsuite/tests/rep-poly/T14561b.stderr
- testsuite/tests/rep-poly/T17817.stderr
- testsuite/tests/rep-poly/T19615.stderr
- testsuite/tests/rep-poly/T19709b.stderr
- testsuite/tests/rep-poly/T21906.stderr
- testsuite/tests/rep-poly/T23903.stderr
- testsuite/tests/rep-poly/UnliftedNewtypesCoerceFail.stderr
- + testsuite/tests/simplCore/should_compile/T26051.hs
- + testsuite/tests/simplCore/should_compile/T26051.stderr
- + testsuite/tests/simplCore/should_compile/T26051_Import.hs
- testsuite/tests/simplCore/should_compile/all.T
- testsuite/tests/simplCore/should_compile/simpl017.stderr
- testsuite/tests/typecheck/no_skolem_info/T14040.stderr
- testsuite/tests/typecheck/should_compile/T25266a.stderr
- + testsuite/tests/typecheck/should_compile/T26030.hs
- testsuite/tests/typecheck/should_compile/all.T
- testsuite/tests/typecheck/should_fail/T16204c.stderr
- + testsuite/tests/typecheck/should_fail/T25950.hs
- + testsuite/tests/typecheck/should_fail/T25950.stderr
- testsuite/tests/typecheck/should_fail/T7696.stderr
- testsuite/tests/typecheck/should_fail/T8603.stderr
- testsuite/tests/typecheck/should_fail/all.T
- utils/check-exact/ExactPrint.hs
- utils/genprimopcode/Main.hs
- utils/genprimopcode/Syntax.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/be412c3ea2868c38e5c0198e19b89d…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/be412c3ea2868c38e5c0198e19b89d…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: Interpreter: Add limited support for direct primop evaluation.
by Marge Bot (＠marge-bot) 21 May '25
by Marge Bot (＠marge-bot) 21 May '25
21 May '25
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
202b201c by Andreas Klebinger at 2025-05-21T10:16:14-04: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.
- - - - -
67a177b4 by sheaf at 2025-05-21T10:17:04-04:00
QuickLook: do a shape test before unifying
This commit ensures we do a shape test before unifying. This ensures
we don't try to unify a TyVarTv with a non-tyvar, e.g.
alpha[tyv] := Int
On the way, we refactor simpleUnifyCheck:
1. Move the checkTopShape check into simpleUnifyCheck
2. Refactors simpleUnifyCheck to return a value of the new type
SimpleUnifyResult type. Now, simpleUnifyCheck returns "can unify",
"cannot unify" or "dunno" (with "cannot unify" being the new result
it can return). Now:
- touchabilityTest is included; it it fails we return "cannot unify"
- checkTopShape now returns "cannot unify" instead of "dunno" upon failure
3. Move the call to simpleUnifyCheck out of checkTouchableTyVarEq.
After that, checkTouchableTyVarEq becames a simple call to
checkTyEqRhs, so we inline it.
This allows the logic in canEqCanLHSFinish_try_unification to be simplified.
In particular, we now avoid calling 'checkTopShape' twice.
Two further changes suggested by Simon were also implemented:
- In canEqCanLHSFinish, if checkTyEqRhs returns PuFail with
'do_not_prevent_rewriting', we now **continue with this constraint**.
This allows us to use the constraint for rewriting.
- checkTyEqRhs now has a top-level check to avoid flattening a tyfam app
in a top-level equality of the form alpha ~ F tys, as this is
going around in circles. This simplifies the implementation without
any change in behaviour.
Fixes #25950
Fixes #26030
- - - - -
4020972c by sheaf at 2025-05-21T10:17:04-04:00
FixedRuntimeRepError: omit unhelpful explanation
This commit tweaks the FixedRuntimeRepError case of pprTcSolverReportMsg,
to avoid including an explanation which refers to a type variable that
appears nowhere else.
For example, the old error message could look like the following:
The pattern binding does not have a fixed runtime representation.
Its type is:
T :: TYPE R
Cannot unify ‘R’ with the type variable ‘c0’
because the former is not a concrete ‘RuntimeRep’.
With this commit, we now omit the last two lines, because the concrete
type variable (here 'c0') does not appear in the type displayed to the
user (here 'T :: TYPE R').
- - - - -
7a78ed7d by Andrea Bedini at 2025-05-21T11:20:16-04:00
Don't fail when ghcversion.h can't be found (#26018)
If ghcversion.h can't be found, don't try to include it. This happens
when there is no rts package in the package db and when -ghcversion-file
argument isn't passed.
Co-authored-by: Syvlain Henry <sylvain(a)haskus.fr>
- - - - -
f4a8ce34 by Vladislav Zavialov at 2025-05-21T11:20:17-04:00
Implement -Wpattern-namespace-specifier (#25900)
In accordance with GHC Proposal #581 "Namespace-specified imports",
section 2.3 "Deprecate use of pattern in import/export lists", the
`pattern` namespace specifier is now deprecated.
Test cases: T25900 T25900_noext
- - - - -
92 changed files:
- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/ByteCode/Asm.hs
- compiler/GHC/ByteCode/Instr.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Errors/Ppr.hs
- compiler/GHC/Parser/Errors/Types.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/StgToByteCode.hs
- compiler/GHC/SysTools/Cpp.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Solver/Equality.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Types/Constraint.hs
- compiler/GHC/Tc/Utils/Unify.hs
- compiler/GHC/Types/Error/Codes.hs
- compiler/GHC/Types/Hint.hs
- compiler/GHC/Types/Hint/Ppr.hs
- docs/users_guide/9.14.1-notes.rst
- docs/users_guide/using-warnings.rst
- hadrian/src/Flavour.hs
- libraries/ghc-internal/src/GHC/Internal/Data/Typeable/Internal.hs
- libraries/ghc-internal/src/GHC/Internal/Type/Reflection.hs
- libraries/ghc-internal/src/GHC/Internal/TypeLits.hs
- libraries/ghc-internal/src/GHC/Internal/TypeNats.hs
- rts/Disassembler.c
- rts/Interpreter.c
- rts/include/rts/Bytecodes.h
- testsuite/tests/callarity/unittest/CallArity1.hs
- testsuite/tests/codeGen/should_run/all.T
- testsuite/tests/driver/Makefile
- testsuite/tests/driver/all.T
- + testsuite/tests/ghci/all.T
- + testsuite/tests/ghci/ghci-mem-primops.hs
- + testsuite/tests/ghci/ghci-mem-primops.script
- + testsuite/tests/ghci/ghci-mem-primops.stdout
- testsuite/tests/ghci/scripts/ghci024.stdout
- testsuite/tests/ghci/scripts/ghci024.stdout-mingw32
- testsuite/tests/numeric/should_run/all.T
- testsuite/tests/numeric/should_run/foundation.hs
- testsuite/tests/numeric/should_run/foundation.stdout
- + testsuite/tests/parser/should_compile/T25900.hs
- + testsuite/tests/parser/should_compile/T25900.stderr
- + testsuite/tests/parser/should_compile/T25900_noext.hs
- + testsuite/tests/parser/should_compile/T25900_noext.stderr
- testsuite/tests/parser/should_compile/all.T
- testsuite/tests/patsyn/should_compile/ImpExp_Exp.hs
- testsuite/tests/patsyn/should_compile/T11959.hs
- testsuite/tests/patsyn/should_compile/T11959.stderr
- testsuite/tests/patsyn/should_compile/T11959Lib.hs
- testsuite/tests/patsyn/should_compile/T13350/boolean/Boolean.hs
- testsuite/tests/patsyn/should_compile/T22521.hs
- testsuite/tests/patsyn/should_compile/T9857.hs
- testsuite/tests/patsyn/should_compile/export.hs
- testsuite/tests/pmcheck/complete_sigs/T25115a.hs
- testsuite/tests/pmcheck/should_compile/T11822.hs
- testsuite/tests/polykinds/T14270.hs
- testsuite/tests/rename/should_compile/T12548.hs
- testsuite/tests/rename/should_fail/T25056.stderr
- testsuite/tests/rename/should_fail/T25056a.hs
- testsuite/tests/rep-poly/RepPolyTuple4.stderr
- testsuite/tests/rep-poly/T19709b.stderr
- testsuite/tests/rep-poly/T23903.stderr
- testsuite/tests/simplCore/should_compile/T15186.hs
- testsuite/tests/simplCore/should_compile/T15186A.hs
- testsuite/tests/simplCore/should_compile/simpl017.stderr
- + testsuite/tests/typecheck/should_compile/T26030.hs
- testsuite/tests/typecheck/should_compile/TypeRepCon.hs
- testsuite/tests/typecheck/should_compile/all.T
- + testsuite/tests/typecheck/should_fail/T25950.hs
- + testsuite/tests/typecheck/should_fail/T25950.stderr
- testsuite/tests/typecheck/should_fail/all.T
- testsuite/tests/warnings/should_compile/DataToTagWarnings.hs
- testsuite/tests/warnings/should_compile/T14794a.hs
- testsuite/tests/warnings/should_compile/T14794a.stderr
- testsuite/tests/warnings/should_compile/T14794b.hs
- testsuite/tests/warnings/should_compile/T14794b.stderr
- testsuite/tests/warnings/should_compile/T14794c.hs
- testsuite/tests/warnings/should_compile/T14794c.stderr
- testsuite/tests/warnings/should_compile/T14794d.hs
- testsuite/tests/warnings/should_compile/T14794d.stderr
- testsuite/tests/warnings/should_compile/T14794e.hs
- testsuite/tests/warnings/should_compile/T14794e.stderr
- testsuite/tests/warnings/should_compile/T14794f.hs
- testsuite/tests/warnings/should_compile/T14794f.stderr
- testsuite/tests/wcompat-warnings/Template.hs
- + testsuite/tests/wcompat-warnings/WCompatWarningsOn.stderr
- utils/genprimopcode/Main.hs
- utils/genprimopcode/Syntax.hs
The diff was not included because it is too large.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/09778e029f3b2edfeece0a54be8408…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/09778e029f3b2edfeece0a54be8408…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] 2 commits: QuickLook: do a shape test before unifying
by Marge Bot (＠marge-bot) 21 May '25
by Marge Bot (＠marge-bot) 21 May '25
21 May '25
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
67a177b4 by sheaf at 2025-05-21T10:17:04-04:00
QuickLook: do a shape test before unifying
This commit ensures we do a shape test before unifying. This ensures
we don't try to unify a TyVarTv with a non-tyvar, e.g.
alpha[tyv] := Int
On the way, we refactor simpleUnifyCheck:
1. Move the checkTopShape check into simpleUnifyCheck
2. Refactors simpleUnifyCheck to return a value of the new type
SimpleUnifyResult type. Now, simpleUnifyCheck returns "can unify",
"cannot unify" or "dunno" (with "cannot unify" being the new result
it can return). Now:
- touchabilityTest is included; it it fails we return "cannot unify"
- checkTopShape now returns "cannot unify" instead of "dunno" upon failure
3. Move the call to simpleUnifyCheck out of checkTouchableTyVarEq.
After that, checkTouchableTyVarEq becames a simple call to
checkTyEqRhs, so we inline it.
This allows the logic in canEqCanLHSFinish_try_unification to be simplified.
In particular, we now avoid calling 'checkTopShape' twice.
Two further changes suggested by Simon were also implemented:
- In canEqCanLHSFinish, if checkTyEqRhs returns PuFail with
'do_not_prevent_rewriting', we now **continue with this constraint**.
This allows us to use the constraint for rewriting.
- checkTyEqRhs now has a top-level check to avoid flattening a tyfam app
in a top-level equality of the form alpha ~ F tys, as this is
going around in circles. This simplifies the implementation without
any change in behaviour.
Fixes #25950
Fixes #26030
- - - - -
4020972c by sheaf at 2025-05-21T10:17:04-04:00
FixedRuntimeRepError: omit unhelpful explanation
This commit tweaks the FixedRuntimeRepError case of pprTcSolverReportMsg,
to avoid including an explanation which refers to a type variable that
appears nowhere else.
For example, the old error message could look like the following:
The pattern binding does not have a fixed runtime representation.
Its type is:
T :: TYPE R
Cannot unify ‘R’ with the type variable ‘c0’
because the former is not a concrete ‘RuntimeRep’.
With this commit, we now omit the last two lines, because the concrete
type variable (here 'c0') does not appear in the type displayed to the
user (here 'T :: TYPE R').
- - - - -
15 changed files:
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Solver/Equality.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Types/Constraint.hs
- compiler/GHC/Tc/Utils/Unify.hs
- testsuite/tests/rep-poly/RepPolyTuple4.stderr
- testsuite/tests/rep-poly/T19709b.stderr
- testsuite/tests/rep-poly/T23903.stderr
- testsuite/tests/simplCore/should_compile/simpl017.stderr
- + testsuite/tests/typecheck/should_compile/T26030.hs
- testsuite/tests/typecheck/should_compile/all.T
- + testsuite/tests/typecheck/should_fail/T25950.hs
- + testsuite/tests/typecheck/should_fail/T25950.stderr
- testsuite/tests/typecheck/should_fail/all.T
Changes:
=====================================
compiler/GHC/Tc/Errors/Ppr.hs
=====================================
@@ -4043,9 +4043,13 @@ pprTcSolverReportMsg _ (FixedRuntimeRepError frr_origs) =
Nothing -> empty
Just o -> other_context o
, case mb_not_conc of
- Nothing -> empty
- Just (conc_tv, not_conc) ->
- unsolved_concrete_eq_explanation conc_tv not_conc ]
+ Just (conc_tv, not_conc)
+ | conc_tv `elemVarSet` tyCoVarsOfType ty
+ -- Only show this message if 'conc_tv' appears somewhere
+ -- in the type, otherwise it's not helpful.
+ -> unsolved_concrete_eq_explanation conc_tv not_conc
+ _ -> empty
+ ]
-- Don't print out the type (only the kind), if the type includes
-- a confusing cast, unless the user passed -fprint-explicit-coercions.
=====================================
compiler/GHC/Tc/Gen/App.hs
=====================================
@@ -2066,18 +2066,22 @@ qlUnify ty1 ty2
= go_flexi1 kappa ty2
go_flexi1 kappa ty2 -- ty2 is zonked
- | -- See Note [QuickLook unification] (UQL1)
- simpleUnifyCheck UC_QuickLook kappa ty2
- = do { co <- unifyKind (Just (TypeThing ty2)) ty2_kind kappa_kind
- -- unifyKind: see (UQL2) in Note [QuickLook unification]
- -- and (MIV2) in Note [Monomorphise instantiation variables]
- ; let ty2' = mkCastTy ty2 co
- ; traceTc "qlUnify:update" $
- ppr kappa <+> text ":=" <+> ppr ty2
- ; liftZonkM $ writeMetaTyVar kappa ty2' }
-
- | otherwise
- = return () -- Occurs-check or forall-bound variable
+ = do { cur_lvl <- getTcLevel
+ -- See Note [Unification preconditions], (UNTOUCHABLE) wrinkles
+ -- Here we are in the TcM monad, which does not track enclosing
+ -- Given equalities; so for quick-look unification we conservatively
+ -- treat /any/ level outside this one as untouchable. Hence cur_lvl.
+ ; case simpleUnifyCheck UC_QuickLook cur_lvl kappa ty2 of
+ SUC_CanUnify ->
+ do { co <- unifyKind (Just (TypeThing ty2)) ty2_kind kappa_kind
+ -- unifyKind: see (UQL2) in Note [QuickLook unification]
+ -- and (MIV2) in Note [Monomorphise instantiation variables]
+ ; let ty2' = mkCastTy ty2 co
+ ; traceTc "qlUnify:update" $
+ ppr kappa <+> text ":=" <+> ppr ty2
+ ; liftZonkM $ writeMetaTyVar kappa ty2' }
+ _ -> return () -- e.g. occurs-check or forall-bound variable
+ }
where
kappa_kind = tyVarKind kappa
ty2_kind = typeKind ty2
=====================================
compiler/GHC/Tc/Solver/Equality.hs
=====================================
@@ -1,5 +1,6 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
module GHC.Tc.Solver.Equality(
@@ -1888,81 +1889,102 @@ canEqCanLHSFinish_try_unification ev eq_rel swapped lhs rhs
| CtWanted wev <- ev -- See Note [Do not unify Givens]
, NomEq <- eq_rel -- See Note [Do not unify representational equalities]
, wantedCtHasNoRewriters wev -- See Note [Unify only if the rewriter set is empty]
- , TyVarLHS tv <- lhs
- = do { given_eq_lvl <- getInnermostGivenEqLevel
- ; if not (touchabilityAndShapeTest given_eq_lvl tv rhs)
- then if | Just can_rhs <- canTyFamEqLHS_maybe rhs
- -> swapAndFinish ev eq_rel swapped (mkTyVarTy tv) can_rhs
- -- See Note [Orienting TyVarLHS/TyFamLHS]
-
- | otherwise
- -> canEqCanLHSFinish_no_unification ev eq_rel swapped lhs rhs
- else
-
- -- We have a touchable unification variable on the left
- do { check_result <- checkTouchableTyVarEq ev tv rhs
- ; case check_result of {
- PuFail reason
+ , TyVarLHS lhs_tv <- lhs
+ = do { given_eq_lvl <- getInnermostGivenEqLevel
+ ; case simpleUnifyCheck UC_Solver given_eq_lvl lhs_tv rhs of
+ SUC_CanUnify ->
+ unify lhs_tv (mkReflRedn Nominal rhs)
+ SUC_CannotUnify
| Just can_rhs <- canTyFamEqLHS_maybe rhs
- -> swapAndFinish ev eq_rel swapped (mkTyVarTy tv) can_rhs
- -- Swap back: see Note [Orienting TyVarLHS/TyFamLHS]
-
- | reason `cterHasOnlyProblems` do_not_prevent_rewriting
- -> canEqCanLHSFinish_no_unification ev eq_rel swapped lhs rhs
-
+ -> swap_and_finish lhs_tv can_rhs -- See Note [Orienting TyVarLHS/TyFamLHS]
| otherwise
- -> tryIrredInstead reason ev eq_rel swapped lhs rhs ;
-
- PuOK _ rhs_redn ->
-
- -- Success: we can solve by unification
- do { -- In the common case where rhs_redn is Refl, we don't need to rewrite
- -- the evidence, even if swapped=IsSwapped. Suppose the original was
- -- [W] co : Int ~ alpha
- -- We unify alpha := Int, and set co := <Int>. No need to
- -- swap to co = sym co'
- -- co' = <Int>
- new_ev <- if isReflCo (reductionCoercion rhs_redn)
- then return ev
- else rewriteEqEvidence emptyRewriterSet ev swapped
- (mkReflRedn Nominal (mkTyVarTy tv)) rhs_redn
-
- ; let tv_ty = mkTyVarTy tv
- final_rhs = reductionReducedType rhs_redn
-
- ; traceTcS "Sneaky unification:" $
- vcat [text "Unifies:" <+> ppr tv <+> text ":=" <+> ppr final_rhs,
- text "Coercion:" <+> pprEq tv_ty final_rhs,
- text "Left Kind is:" <+> ppr (typeKind tv_ty),
- text "Right Kind is:" <+> ppr (typeKind final_rhs) ]
-
- -- Update the unification variable itself
- ; unifyTyVar tv final_rhs
-
- -- Provide Refl evidence for the constraint
- -- Ignore 'swapped' because it's Refl!
- ; setEvBindIfWanted new_ev EvCanonical $
- evCoercion (mkNomReflCo final_rhs)
-
- -- Kick out any constraints that can now be rewritten
- ; kickOutAfterUnification [tv]
-
- ; return (Stop new_ev (text "Solved by unification")) }}}}
-
+ -> finish_no_unify
+ SUC_NotSure ->
+ -- We have a touchable unification variable on the left,
+ -- and the top-shape check succeeded. These are both guaranteed
+ -- by the fact that simpleUnifyCheck did not return SUC_CannotUnify.
+ do { let flags = unifyingLHSMetaTyVar_TEFTask ev lhs_tv
+ ; check_result <- wrapTcS (checkTyEqRhs flags rhs)
+ ; case check_result of
+ PuOK cts rhs_redn ->
+ do { emitWork cts
+ ; unify lhs_tv rhs_redn }
+ PuFail reason
+ | Just can_rhs <- canTyFamEqLHS_maybe rhs
+ -> swap_and_finish lhs_tv can_rhs -- See Note [Orienting TyVarLHS/TyFamLHS]
+ | reason `cterHasOnlyProblems` do_not_prevent_rewriting
+ ->
+ -- ContinueWith, to allow using this constraint for
+ -- rewriting (e.g. alpha[2] ~ beta[3]).
+ do { let role = eqRelRole eq_rel
+ ; new_ev <- rewriteEqEvidence emptyRewriterSet ev swapped
+ (mkReflRedn role (canEqLHSType lhs))
+ (mkReflRedn role rhs)
+ ; continueWith $ Right $
+ EqCt { eq_ev = new_ev, eq_eq_rel = eq_rel
+ , eq_lhs = lhs , eq_rhs = rhs }
+ }
+ | otherwise
+ -> try_irred reason
+ }
+ }
-- Otherwise unification is off the table
| otherwise
- = canEqCanLHSFinish_no_unification ev eq_rel swapped lhs rhs
+ = finish_no_unify
where
- -- Some problems prevent /unification/ but not /rewriting/
- -- Skolem-escape: if we have [W] alpha[2] ~ Maybe b[3]
- -- we can't unify (skolem-escape); but it /is/ canonical,
- -- and hence we /can/ use it for rewriting
- -- Concrete-ness: alpha[conc] ~ b[sk]
- -- We can use it to rewrite; we still have to solve the original
- do_not_prevent_rewriting :: CheckTyEqResult
- do_not_prevent_rewriting = cteProblem cteSkolemEscape S.<>
- cteProblem cteConcrete
+ -- We can't unify, but this equality can go in the inert set
+ -- and be used to rewrite other constraints.
+ finish_no_unify =
+ canEqCanLHSFinish_no_unification ev eq_rel swapped lhs rhs
+
+ -- We can't unify, and this equality should not be used to rewrite
+ -- other constraints (e.g. because it has an occurs check).
+ -- So add it to the inert Irreds.
+ try_irred reason =
+ tryIrredInstead reason ev eq_rel swapped lhs rhs
+
+ -- We can't unify as-is, and want to flip the equality around.
+ -- Example: alpha ~ F tys, flip it around to become the canonical
+ -- equality f tys ~ alpha.
+ swap_and_finish tv can_rhs =
+ swapAndFinish ev eq_rel swapped (mkTyVarTy tv) can_rhs
+
+ -- We can unify; go ahead and do so.
+ unify tv rhs_redn =
+
+ do { -- In the common case where rhs_redn is Refl, we don't need to rewrite
+ -- the evidence, even if swapped=IsSwapped. Suppose the original was
+ -- [W] co : Int ~ alpha
+ -- We unify alpha := Int, and set co := <Int>. No need to
+ -- swap to co = sym co'
+ -- co' = <Int>
+ new_ev <- if isReflCo (reductionCoercion rhs_redn)
+ then return ev
+ else rewriteEqEvidence emptyRewriterSet ev swapped
+ (mkReflRedn Nominal (mkTyVarTy tv)) rhs_redn
+
+ ; let tv_ty = mkTyVarTy tv
+ final_rhs = reductionReducedType rhs_redn
+
+ ; traceTcS "Sneaky unification:" $
+ vcat [text "Unifies:" <+> ppr tv <+> text ":=" <+> ppr final_rhs,
+ text "Coercion:" <+> pprEq tv_ty final_rhs,
+ text "Left Kind is:" <+> ppr (typeKind tv_ty),
+ text "Right Kind is:" <+> ppr (typeKind final_rhs) ]
+
+ -- Update the unification variable itself
+ ; unifyTyVar tv final_rhs
+
+ -- Provide Refl evidence for the constraint
+ -- Ignore 'swapped' because it's Refl!
+ ; setEvBindIfWanted new_ev EvCanonical $
+ evCoercion (mkNomReflCo final_rhs)
+
+ -- Kick out any constraints that can now be rewritten
+ ; kickOutAfterUnification [tv]
+
+ ; return (Stop new_ev (text "Solved by unification")) }
---------------------------
-- Unification is off the table
@@ -1989,6 +2011,17 @@ canEqCanLHSFinish_no_unification ev eq_rel swapped lhs rhs
-- -> swapAndFinish ev eq_rel swapped lhs_ty can_rhs
-- | otherwise
+ | reason `cterHasOnlyProblems` do_not_prevent_rewriting
+ -> do { let role = eqRelRole eq_rel
+ ; new_ev <- rewriteEqEvidence emptyRewriterSet ev swapped
+ (mkReflRedn role (canEqLHSType lhs))
+ (mkReflRedn role rhs)
+ ; continueWith $ Right $
+ EqCt { eq_ev = new_ev, eq_eq_rel = eq_rel
+ , eq_lhs = lhs , eq_rhs = rhs }
+ }
+
+ | otherwise
-> tryIrredInstead reason ev eq_rel swapped lhs rhs
PuOK _ rhs_redn
@@ -2005,6 +2038,18 @@ canEqCanLHSFinish_no_unification ev eq_rel swapped lhs rhs
, eq_lhs = lhs
, eq_rhs = reductionReducedType rhs_redn } } }
+-- | Some problems prevent /unification/ but not /rewriting/:
+--
+-- Skolem-escape: if we have [W] alpha[2] ~ Maybe b[3]
+-- we can't unify (skolem-escape); but it /is/ canonical,
+-- and hence we /can/ use it for rewriting
+--
+-- Concrete-ness: alpha[conc] ~ b[sk]
+-- We can use it to rewrite; we still have to solve the original
+do_not_prevent_rewriting :: CheckTyEqResult
+do_not_prevent_rewriting = cteProblem cteSkolemEscape S.<>
+ cteProblem cteConcrete
+
----------------------
swapAndFinish :: CtEvidence -> EqRel -> SwapFlag
-> TcType -> CanEqLHS -- ty ~ F tys
@@ -2297,8 +2342,9 @@ and we turn this into
[W] Arg alpha ~ cbv1
[W] Res alpha ~ cbv2
-where cbv1 and cbv2 are fresh TauTvs. This is actually done by `break_wanted`
-in `GHC.Tc.Solver.Monad.checkTouchableTyVarEq`.
+where cbv1 and cbv2 are fresh TauTvs. This is actually done within checkTyEqRhs,
+called within canEqCanLHSFinish_try_unification, which will use the BreakWanted
+FamAppBreaker.
Why TauTvs? See [Why TauTvs] below.
@@ -2307,7 +2353,7 @@ directly instead of calling wrapUnifierTcS. (Otherwise, we'd end up
unifying cbv1 and cbv2 immediately, achieving nothing.) Next, we
unify alpha := cbv1 -> cbv2, having eliminated the occurs check. This
unification happens immediately following a successful call to
-checkTouchableTyVarEq, in canEqCanLHSFinish_try_unification.
+checkTyEqRhs, in canEqCanLHSFinish_try_unification.
Now, we're here (including further context from our original example,
from the top of the Note):
=====================================
compiler/GHC/Tc/Solver/Monad.hs
=====================================
@@ -129,7 +129,7 @@ module GHC.Tc.Solver.Monad (
pprEq,
-- Enforcing invariants for type equalities
- checkTypeEq, checkTouchableTyVarEq
+ checkTypeEq
) where
import GHC.Prelude
@@ -228,8 +228,6 @@ import GHC.Data.Graph.Directed
import qualified Data.Set as Set
import GHC.Unit.Module.Graph
-import GHC.Data.Maybe
-
{- *********************************************************************
* *
SolverStage and StopOrContinue
@@ -2416,81 +2414,31 @@ wrapUnifierX ev role do_unifications
************************************************************************
-}
-checkTouchableTyVarEq
- :: CtEvidence
- -> TcTyVar -- A touchable meta-tyvar
- -> TcType -- The RHS
- -> TcS (PuResult () Reduction)
--- Used for Nominal, Wanted equalities, with a touchable meta-tyvar on LHS
--- If checkTouchableTyVarEq tv ty = PuOK cts redn
--- then we can unify
--- tv := ty |> redn
--- with extra wanteds 'cts'
--- If it returns (PuFail reason) we can't unify, and the reason explains why.
-checkTouchableTyVarEq ev lhs_tv rhs
- | simpleUnifyCheck UC_Solver lhs_tv rhs -- An (optional) short-cut
- = do { traceTcS "checkTouchableTyVarEq: simple-check wins" (ppr lhs_tv $$ ppr rhs)
- ; return (pure (mkReflRedn Nominal rhs)) }
-
- | otherwise
- = do { traceTcS "checkTouchableTyVarEq {" (ppr lhs_tv $$ ppr rhs)
- ; check_result <- wrapTcS (check_rhs rhs)
- ; traceTcS "checkTouchableTyVarEq }" (ppr lhs_tv $$ ppr check_result)
- ; case check_result of
- PuFail reason -> return (PuFail reason)
- PuOK cts redn -> do { emitWork cts
- ; return (pure redn) } }
-
- where
- lhs_tv_info = metaTyVarInfo lhs_tv -- lhs_tv should be a meta-tyvar
-
- is_concrete_lhs_tv = isJust $ concreteInfo_maybe lhs_tv_info
-
- check_rhs rhs
- -- Crucial special case for alpha ~ F tys
- -- We don't want to flatten that (F tys)!
- | Just (TyFamLHS tc tys) <- canTyFamEqLHS_maybe rhs
- = if is_concrete_lhs_tv
- then return $ PuFail (cteProblem cteConcrete)
- else recurseIntoFamTyConApp flags tc tys
- | otherwise
- = checkTyEqRhs flags rhs
-
- flags = unifyingLHSMetaTyVar_TEFTask ev lhs_tv
-
-------------------------
checkTypeEq :: CtEvidence -> EqRel -> CanEqLHS -> TcType
-> TcS (PuResult () Reduction)
-- Used for general CanEqLHSs, ones that do
-- not have a touchable type variable on the LHS (i.e. not unifying)
-checkTypeEq ev eq_rel lhs rhs
- | isGiven ev
- = do { traceTcS "checkTypeEq {" (vcat [ text "lhs:" <+> ppr lhs
- , text "rhs:" <+> ppr rhs ])
- ; check_result <- wrapTcS (check_given_rhs rhs)
- ; traceTcS "checkTypeEq }" (ppr check_result)
- ; case check_result of
- PuFail reason -> return (PuFail reason)
- PuOK prs redn -> do { new_givens <- mapBagM mk_new_given prs
- ; emitWork new_givens
- ; updInertSet (addCycleBreakerBindings prs)
- ; return (pure redn) } }
-
- | otherwise -- Wanted
- = do { check_result <- wrapTcS (checkTyEqRhs wanted_flags rhs)
- ; case check_result of
- PuFail reason -> return (PuFail reason)
- PuOK cts redn -> do { emitWork cts
- ; return (pure redn) } }
+checkTypeEq ev eq_rel lhs rhs =
+ case ev of
+ CtGiven {} ->
+ do { traceTcS "checkTypeEq {" (vcat [ text "lhs:" <+> ppr lhs
+ , text "rhs:" <+> ppr rhs ])
+ ; check_result <- wrapTcS (checkTyEqRhs given_flags rhs)
+ ; traceTcS "checkTypeEq }" (ppr check_result)
+ ; case check_result of
+ PuFail reason -> return (PuFail reason)
+ PuOK prs redn -> do { new_givens <- mapBagM mk_new_given prs
+ ; emitWork new_givens
+ ; updInertSet (addCycleBreakerBindings prs)
+ ; return (pure redn) } }
+ CtWanted {} ->
+ do { check_result <- wrapTcS (checkTyEqRhs wanted_flags rhs)
+ ; case check_result of
+ PuFail reason -> return (PuFail reason)
+ PuOK cts redn -> do { emitWork cts
+ ; return (pure redn) } }
where
- check_given_rhs :: TcType -> TcM (PuResult (TcTyVar,TcType) Reduction)
- check_given_rhs rhs
- -- See Note [Special case for top-level of Given equality]
- | Just (TyFamLHS tc tys) <- canTyFamEqLHS_maybe rhs
- = recurseIntoFamTyConApp given_flags tc tys
- | otherwise
- = checkTyEqRhs given_flags rhs
-
+ wanted_flags :: TyEqFlags TcM Ct
wanted_flags = notUnifying_TEFTask occ_prob lhs
-- checkTypeEq deals only with the non-unifying case
@@ -2532,31 +2480,6 @@ restoreTyVarCycles is
(a ~R# b a) is soluble if b later turns out to be Identity
So we treat this as a "soluble occurs check".
-Note [Special case for top-level of Given equality]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We take care when examining
- [G] F ty ~ G (...(F ty)...)
-where both sides are TyFamLHSs. We don't want to flatten that RHS to
- [G] F ty ~ cbv
- [G] G (...(F ty)...) ~ cbv
-Instead we'd like to say "occurs-check" and swap LHS and RHS, which yields a
-canonical constraint
- [G] G (...(F ty)...) ~ F ty
-That tends to rewrite a big type to smaller one. This happens in T15703,
-where we had:
- [G] Pure g ~ From1 (To1 (Pure g))
-Making a loop breaker and rewriting left to right just makes much bigger
-types than swapping it over.
-
-(We might hope to have swapped it over before getting to checkTypeEq,
-but better safe than sorry.)
-
-NB: We never see a TyVarLHS here, such as
- [G] a ~ F tys here
-because we'd have swapped it to
- [G] F tys ~ a
-in canEqCanLHS2, before getting to checkTypeEq.
-
Note [Don't cycle-break Wanteds when not unifying]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consdier
=====================================
compiler/GHC/Tc/Types/Constraint.hs
=====================================
@@ -279,10 +279,10 @@ We thus perform an occurs-check. There is, of course, some subtlety:
* For type variables, the occurs-check looks deeply including kinds of
type variables. This is because a CEqCan over a meta-variable is
- also used to inform unification, in
- GHC.Tc.Solver.Monad.checkTouchableTyVarEq. If the LHS appears
- anywhere in the RHS, at all, unification will create an infinite
- structure which is bad.
+ also used to inform unification, via `checkTyEqRhs`, called in
+ `canEqCanLHSFinish_try_unification`.
+ If the LHS appears anywhere in the RHS, at all, unification will create
+ an infinite structure, which is bad.
* For type family applications, the occurs-check is shallow; it looks
only in places where we might rewrite. (Specifically, it does not
=====================================
compiler/GHC/Tc/Utils/Unify.hs
=====================================
@@ -29,7 +29,7 @@ module GHC.Tc.Utils.Unify (
-- Various unifications
unifyType, unifyKind, unifyInvisibleType, unifyExpectedType,
unifyExprType, unifyTypeAndEmit, promoteTcType,
- swapOverTyVars, touchabilityAndShapeTest, checkTopShape, lhsPriority,
+ swapOverTyVars, touchabilityTest, checkTopShape, lhsPriority,
UnifyEnv(..), updUEnvLoc, setUEnvRole,
uType,
mightEqualLater,
@@ -55,7 +55,7 @@ module GHC.Tc.Utils.Unify (
TyEqFamApp(..), FamAppBreaker(..),
checkPromoteFreeVars,
- simpleUnifyCheck, UnifyCheckCaller(..),
+ simpleUnifyCheck, UnifyCheckCaller(..), SimpleUnifyResult(..),
fillInferResult,
) where
@@ -2482,10 +2482,9 @@ uUnfilledVar2 :: UnifyEnv -- Precondition: u_role==Nominal
uUnfilledVar2 env@(UE { u_defer = def_eq_ref }) swapped tv1 ty2
= do { cur_lvl <- getTcLevel
-- See Note [Unification preconditions], (UNTOUCHABLE) wrinkles
- -- Here we don't know about given equalities here; so we treat
+ -- Here we don't know about given equalities; so we treat
-- /any/ level outside this one as untouchable. Hence cur_lvl.
- ; if not (touchabilityAndShapeTest cur_lvl tv1 ty2
- && simpleUnifyCheck UC_OnTheFly tv1 ty2)
+ ; if simpleUnifyCheck UC_OnTheFly cur_lvl tv1 ty2 /= SUC_CanUnify
then not_ok_so_defer cur_lvl
else
do { def_eqs <- readTcRef def_eq_ref -- Capture current state of def_eqs
@@ -2530,8 +2529,8 @@ uUnfilledVar2 env@(UE { u_defer = def_eq_ref }) swapped tv1 ty2
do { traceTc "uUnfilledVar2 not ok" $
vcat [ text "tv1:" <+> ppr tv1
, text "ty2:" <+> ppr ty2
- , text "simple-unify-chk:" <+> ppr (simpleUnifyCheck UC_OnTheFly tv1 ty2)
- , text "touchability:" <+> ppr (touchabilityAndShapeTest cur_lvl tv1 ty2)]
+ , text "simple-unify-chk:" <+> ppr (simpleUnifyCheck UC_OnTheFly cur_lvl tv1 ty2)
+ ]
-- Occurs check or an untouchable: just defer
-- NB: occurs check isn't necessarily fatal:
-- eg tv1 occurred in type family parameter
@@ -2590,9 +2589,8 @@ lhsPriority tv
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Question: given a homogeneous equality (alpha ~# ty), when is it OK to
unify alpha := ty?
-
-This note only applied to /homogeneous/ equalities, in which both
-sides have the same kind.
+(This note only applies to /homogeneous/ equalities, in which both
+sides have the same kind.)
There are five reasons not to unify:
@@ -2688,7 +2686,7 @@ Needless to say, all there are wrinkles:
* In the constraint solver, we track where Given equalities occur
and use that to guard unification in
- GHC.Tc.Utils.Unify.touchabilityAndShapeTest. More details in
+ GHC.Tc.Utils.Unify.touchabilityTest. More details in
Note [Tracking Given equalities] in GHC.Tc.Solver.InertSet
Historical note: in the olden days (pre 2021) the constraint solver
@@ -2929,12 +2927,34 @@ data UnifyCheckCaller
= UC_OnTheFly -- Called from the on-the-fly unifier
| UC_QuickLook -- Called from Quick Look
| UC_Solver -- Called from constraint solver
- | UC_Defaulting -- Called when doing top-level defaulting
-simpleUnifyCheck :: UnifyCheckCaller -> TcTyVar -> TcType -> Bool
--- simpleUnifyCheck does a fast check: True <=> unification is OK
--- If it says 'False' then unification might still be OK, but
--- it'll take more work to do -- use the full checkTypeEq
+-- | The result type of 'simpleUnifyCheck'.
+data SimpleUnifyResult
+ -- | Definitely cannot unify (untouchable variable or incompatible top-shape)
+ = SUC_CannotUnify
+ -- | The variable is touchable and the top-shape test passed, but
+ -- it may or may not be OK to unify
+ | SUC_NotSure
+ -- | Definitely OK to unify
+ | SUC_CanUnify
+ deriving stock (Eq, Ord, Show)
+instance Semigroup SimpleUnifyResult where
+ no@SUC_CannotUnify <> _ = no
+ SUC_CanUnify <> r = r
+ _ <> no@SUC_CannotUnify = no
+ r <> SUC_CanUnify = r
+ ns@SUC_NotSure <> SUC_NotSure = ns
+
+instance Outputable SimpleUnifyResult where
+ ppr = \case
+ SUC_CannotUnify -> text "SUC_CannotUnify"
+ SUC_NotSure -> text "SUC_NotSure"
+ SUC_CanUnify -> text "SUC_CanUnify"
+
+simpleUnifyCheck :: UnifyCheckCaller -> TcLevel -> TcTyVar -> TcType -> SimpleUnifyResult
+-- ^ A fast check for unification. May return "not sure", in which case
+-- unification might still be OK, but it'll take more work to do
+-- (use the full 'checkTypeEq').
--
-- * Rejects if lhs_tv occurs in rhs_ty (occurs check)
-- * Rejects foralls unless
@@ -2945,9 +2965,17 @@ simpleUnifyCheck :: UnifyCheckCaller -> TcTyVar -> TcType -> Bool
-- * Does a level-check for type variables, to avoid skolem escape
--
-- This function is pretty heavily used, so it's optimised not to allocate
-simpleUnifyCheck caller lhs_tv rhs
- = go rhs
+simpleUnifyCheck caller given_eq_lvl lhs_tv rhs
+ | not $ touchabilityTest given_eq_lvl lhs_tv
+ = SUC_CannotUnify
+ | not $ checkTopShape lhs_info rhs
+ = SUC_CannotUnify
+ | rhs_is_ok rhs
+ = SUC_CanUnify
+ | otherwise
+ = SUC_NotSure
where
+ lhs_info = metaTyVarInfo lhs_tv
!(occ_in_ty, occ_in_co) = mkOccFolders (tyVarName lhs_tv)
@@ -2967,33 +2995,32 @@ simpleUnifyCheck caller lhs_tv rhs
UC_Solver -> True
UC_QuickLook -> True
UC_OnTheFly -> False
- UC_Defaulting -> True
- go (TyVarTy tv)
+ rhs_is_ok (TyVarTy tv)
| lhs_tv == tv = False
| tcTyVarLevel tv `strictlyDeeperThan` lhs_tv_lvl = False
| lhs_tv_is_concrete, not (isConcreteTyVar tv) = False
| occ_in_ty $! (tyVarKind tv) = False
| otherwise = True
- go (FunTy {ft_af = af, ft_mult = w, ft_arg = a, ft_res = r})
+ rhs_is_ok (FunTy {ft_af = af, ft_mult = w, ft_arg = a, ft_res = r})
| not forall_ok, isInvisibleFunArg af = False
- | otherwise = go w && go a && go r
+ | otherwise = rhs_is_ok w && rhs_is_ok a && rhs_is_ok r
- go (TyConApp tc tys)
+ rhs_is_ok (TyConApp tc tys)
| lhs_tv_is_concrete, not (isConcreteTyCon tc) = False
| not forall_ok, not (isTauTyCon tc) = False
| not fam_ok, not (isFamFreeTyCon tc) = False
- | otherwise = all go tys
+ | otherwise = all rhs_is_ok tys
- go (ForAllTy (Bndr tv _) ty)
- | forall_ok = go (tyVarKind tv) && (tv == lhs_tv || go ty)
+ rhs_is_ok (ForAllTy (Bndr tv _) ty)
+ | forall_ok = rhs_is_ok (tyVarKind tv) && (tv == lhs_tv || rhs_is_ok ty)
| otherwise = False
- go (AppTy t1 t2) = go t1 && go t2
- go (CastTy ty co) = not (occ_in_co co) && go ty
- go (CoercionTy co) = not (occ_in_co co)
- go (LitTy {}) = True
+ rhs_is_ok (AppTy t1 t2) = rhs_is_ok t1 && rhs_is_ok t2
+ rhs_is_ok (CastTy ty co) = not (occ_in_co co) && rhs_is_ok ty
+ rhs_is_ok (CoercionTy co) = not (occ_in_co co)
+ rhs_is_ok (LitTy {}) = True
mkOccFolders :: Name -> (TcType -> Bool, TcCoercion -> Bool)
@@ -3078,8 +3105,13 @@ We must jolly well use that reductionReduced type, even though the
reductionCoercion is Refl. See `canEqCanLHSFinish_no_unification`.
-}
-data PuResult a b = PuFail CheckTyEqResult
- | PuOK (Bag a) b
+data PuResult a b
+ -- | Pure unifier failure.
+ --
+ -- Invariant: the CheckTyEqResult is not 'cteOK'; that it, it specifies a problem.
+ = PuFail CheckTyEqResult
+ -- | Pure unifier success.
+ | PuOK (Bag a) b
deriving stock (Functor, Foldable, Traversable)
instance Applicative (PuResult a) where
@@ -3414,15 +3446,15 @@ famAppBreaker (BreakWanted ev lhs_tv) fam_app
; return (PuOK (singleCt (mkNonCanonical $ CtWanted new_ev))
(mkReduction (HoleCo hole) new_tv_ty)) } }
where
+ fam_app_kind = typeKind fam_app
(lhs_tv_info, lhs_tv_lvl) =
case tcTyVarDetails lhs_tv of
MetaTv { mtv_info = info, mtv_tclvl = lvl } -> (info,lvl)
-- lhs_tv should be a meta-tyvar
- _ -> pprPanic "checkTouchableTyVarEq" (ppr lhs_tv)
- fam_app_kind = typeKind fam_app
- -- See Detail (7) of the Note
+ _ -> pprPanic "famAppBreaker BreakWanted: lhs_tv is not a meta-tyvar"
+ (ppr lhs_tv)
cb_loc = updateCtLocOrigin (ctEvLoc ev) CycleBreakerOrigin
-
+ -- CycleBreakerOrigin: see Detail (7) of Note [Type equality cycles]
instance Outputable (TyEqFlags m a) where
ppr = \case
@@ -3492,12 +3524,95 @@ famAppArgFlags flags = case flags of
-> LC_Check { lc_lvlc = lvl, lc_lenient = False }
lc -> lc
+{- Note [checkTyEqRhs]
+~~~~~~~~~~~~~~~~~~~~~~
+The key function `checkTyEqRhs ty_eq_flags rhs` is called on the
+RHS of a type equality
+ lhs ~ rhs
+and checks to see if `rhs` satisfies, or can be made to satisfy,
+invariants described by `ty_eq_flags`. It can succeded or fail; in
+the latter case it returns a `CheckTyEqResult` that describes why it
+failed.
+
+When `lhs` is a touchable type variable, so unification might happen, then
+`checkTyEqRhs` enforces the unification preconditions of Note [Unification preconditions].
+
+Notably, it can check for things like:
+ * Insoluble occurs check
+ e.g. alpha[tau] ~ [alpha]
+ or F Int ~ [F Int]
+ * Potentially-soluble occurs check
+ e.g. alpha[tau] ~ [F alpha beta]
+ * Impredicativity error:
+ e.g. alpha[tau] ~ (forall a. a->a)
+ * Skolem escape
+ e.g alpha[1] ~ (b[sk:2], Int)
+ * Concreteness error
+ e.g. alpha[conc] ~ r[sk]
+
+Its specific behaviour is governed by the `TyEqFlags` that are passed
+to it; see Note [TyEqFlags].
+
+Note, however, that `checkTyEqRhs` specifically does /not/ check for:
+ * Touchability of the LHS (in the case of a unification variable)
+ * Shape of the LHS (e.g. we can't unify Int with a TyVarTv)
+These things are checked by `simpleUnifyCheck`.
+-}
+
+
+-- | Perform the checks specified by the 'TyEqFlags' on the RHS, in order to
+-- enforce the unification preconditions of Note [Unification preconditions].
+--
+-- See Note [checkTyEqRhs].
checkTyEqRhs :: forall m a
. Monad m
=> TyEqFlags m a
-> TcType -- Already zonked
-> m (PuResult a Reduction)
-checkTyEqRhs flags ty
+checkTyEqRhs flags rhs
+ -- Crucial special case for a top-level equality of the form 'alpha ~ F tys'.
+ -- We don't want to flatten that (F tys), as this gets us right back to where
+ -- we started!
+ --
+ -- See also Note [Special case for top-level of Given equality]
+ | Just (TyFamLHS tc tys) <- canTyFamEqLHS_maybe rhs
+ , not $ tefConcrete flags
+ = recurseIntoFamTyConApp flags tc tys
+ | otherwise
+ = check_ty_eq_rhs flags rhs
+
+{- Note [Special case for top-level of Given equality]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We take care when examining
+ [G] F ty ~ G (...(F ty)...)
+where both sides are TyFamLHSs. We don't want to flatten that RHS to
+ [G] F ty ~ cbv
+ [G] G (...(F ty)...) ~ cbv
+Instead we'd like to say "occurs-check" and swap LHS and RHS, which yields a
+canonical constraint
+ [G] G (...(F ty)...) ~ F ty
+That tends to rewrite a big type to smaller one. This happens in T15703,
+where we had:
+ [G] Pure g ~ From1 (To1 (Pure g))
+Making a loop breaker and rewriting left to right just makes much bigger
+types than swapping it over.
+
+(We might hope to have swapped it over before getting to checkTypeEq,
+but better safe than sorry.)
+
+NB: We never see a TyVarLHS here, such as
+ [G] a ~ F tys here
+because we'd have swapped it to
+ [G] F tys ~ a
+in canEqCanLHS2, before getting to checkTypeEq.
+-}
+
+check_ty_eq_rhs :: forall m a
+ . Monad m
+ => TyEqFlags m a
+ -> TcType -- Already zonked
+ -> m (PuResult a Reduction)
+check_ty_eq_rhs flags ty
= case ty of
LitTy {} -> return $ okCheckRefl ty
TyConApp tc tys -> checkTyConApp flags ty tc tys
@@ -3510,16 +3625,16 @@ checkTyEqRhs flags ty
| isInvisibleFunArg af -- e.g. Num a => blah
-> return $ PuFail impredicativeProblem -- Not allowed (TyEq:F)
| otherwise
- -> do { w_res <- checkTyEqRhs flags w
- ; a_res <- checkTyEqRhs flags a
- ; r_res <- checkTyEqRhs flags r
+ -> do { w_res <- check_ty_eq_rhs flags w
+ ; a_res <- check_ty_eq_rhs flags a
+ ; r_res <- check_ty_eq_rhs flags r
; return (mkFunRedn Nominal af <$> w_res <*> a_res <*> r_res) }
- AppTy fun arg -> do { fun_res <- checkTyEqRhs flags fun
- ; arg_res <- checkTyEqRhs flags arg
+ AppTy fun arg -> do { fun_res <- check_ty_eq_rhs flags fun
+ ; arg_res <- check_ty_eq_rhs flags arg
; return (mkAppRedn <$> fun_res <*> arg_res) }
- CastTy ty co -> do { ty_res <- checkTyEqRhs flags ty
+ CastTy ty co -> do { ty_res <- check_ty_eq_rhs flags ty
; co_res <- checkCo flags co
; return (mkCastRedn1 Nominal ty <$> co_res <*> ty_res) }
@@ -3527,7 +3642,7 @@ checkTyEqRhs flags ty
; return (mkReflCoRedn Nominal <$> co_res) }
ForAllTy {} -> return $ PuFail impredicativeProblem -- Not allowed (TyEq:F)
-{-# INLINEABLE checkTyEqRhs #-}
+{-# INLINEABLE check_ty_eq_rhs #-}
-------------------
checkCo :: Monad m => TyEqFlags m a -> Coercion -> m (PuResult a Coercion)
@@ -3702,14 +3817,14 @@ checkTyConApp flags tc_app tc tys
else do { let (fun_args, extra_args) = splitAt (tyConArity tc) tys
fun_app = mkTyConApp tc fun_args
; fun_res <- checkFamApp flags fun_app tc fun_args
- ; extra_res <- mapCheck (checkTyEqRhs flags) extra_args
+ ; extra_res <- mapCheck (check_ty_eq_rhs flags) extra_args
; return (mkAppRedns <$> fun_res <*> extra_res) }
| Just ty' <- rewriterView tc_app
-- e.g. S a where type S a = F [a]
-- or type S a = Int
-- See Note [Forgetful synonyms in checkTyConApp]
- = checkTyEqRhs flags ty'
+ = check_ty_eq_rhs flags ty'
| not (isTauTyCon tc)
= return $ PuFail impredicativeProblem
@@ -3727,7 +3842,7 @@ recurseIntoTyConApp :: Monad m
-> TyCon -> [TcType]
-> m (PuResult a Reduction)
recurseIntoTyConApp flags tc tys
- = do { tys_res <- mapCheck (checkTyEqRhs flags) tys
+ = do { tys_res <- mapCheck (check_ty_eq_rhs flags) tys
; return (mkTyConAppRedn Nominal tc <$> tys_res) }
recurseIntoFamTyConApp :: Monad m
@@ -3888,7 +4003,7 @@ checkTyVar flags occ_tv
-- unfilled meta-tyvar, we need to ensure that the kind of
-- 'occ_tv' is concrete. Test cases: T23051, T23176.
; let occ_kind = tyVarKind occ_tv
- ; kind_result <- checkTyEqRhs flags occ_kind
+ ; kind_result <- check_ty_eq_rhs flags occ_kind
; for kind_result $ \ kind_redn ->
do { let kind_co = reductionCoercion kind_redn
new_kind = reductionReducedType kind_redn
@@ -4010,16 +4125,15 @@ promote_meta_tyvar info dest_lvl occ_tv
-------------------------
-touchabilityAndShapeTest :: TcLevel -> TcTyVar -> TcType -> Bool
--- This is the key test for untouchability:
+touchabilityTest :: TcLevel -> TcTyVar -> Bool
+-- ^ This is the key test for untouchability:
-- See Note [Unification preconditions] in GHC.Tc.Utils.Unify
-- and Note [Solve by unification] in GHC.Tc.Solver.Equality
--- True <=> touchability and shape are OK
-touchabilityAndShapeTest given_eq_lvl tv rhs
- | MetaTv { mtv_info = info, mtv_tclvl = tv_lvl } <- tcTyVarDetails tv
- , tv_lvl `deeperThanOrSame` given_eq_lvl
- , checkTopShape info rhs
- = True
+--
+-- @True@ <=> the variable is touchable
+touchabilityTest given_eq_lvl tv
+ | MetaTv { mtv_tclvl = tv_lvl } <- tcTyVarDetails tv
+ = tv_lvl `deeperThanOrSame` given_eq_lvl
| otherwise
= False
=====================================
testsuite/tests/rep-poly/RepPolyTuple4.stderr
=====================================
@@ -6,8 +6,6 @@ RepPolyTuple4.hs:8:7: error: [GHC-55287]
When unifying:
• a0 -> b0 -> (# a0, b0 #)
• a -> a -> (# a, a #)
- Cannot unify ‘r’ with the type variable ‘w1’
- because the former is not a concrete ‘RuntimeRep’.
• The second component of the unboxed tuple
does not have a fixed runtime representation.
Its type is:
@@ -15,8 +13,6 @@ RepPolyTuple4.hs:8:7: error: [GHC-55287]
When unifying:
• a0 -> b0 -> (# a0, b0 #)
• a -> a -> (# a, a #)
- Cannot unify ‘r’ with the type variable ‘w0’
- because the former is not a concrete ‘RuntimeRep’.
• In the expression: (#,#) @_ @_
In an equation for ‘bar’: bar = (#,#) @_ @_
=====================================
testsuite/tests/rep-poly/T19709b.stderr
=====================================
@@ -2,11 +2,8 @@ T19709b.hs:11:15: error: [GHC-55287]
• The argument ‘(error @Any "e2")’ of ‘levfun’
does not have a fixed runtime representation.
Its type is:
- a1 :: TYPE r0
- When unifying:
- • a0
- • a1
- Cannot unify ‘Any’ with the type variable ‘r0’
+ a1 :: TYPE c0
+ Cannot unify ‘Any’ with the type variable ‘c0’
because the former is not a concrete ‘RuntimeRep’.
• In the first argument of ‘levfun’, namely ‘(error @Any "e2")’
In the first argument of ‘seq’, namely ‘levfun (error @Any "e2")’
=====================================
testsuite/tests/rep-poly/T23903.stderr
=====================================
@@ -2,11 +2,8 @@ T23903.hs:21:1: error: [GHC-55287]
• The first pattern in the equation for ‘f’
does not have a fixed runtime representation.
Its type is:
- t0 :: TYPE cx0
- When unifying:
- • t0 -> ()
- • a #-> ()
- Cannot unify ‘Rep a’ with the type variable ‘cx0’
+ t0 :: TYPE c0
+ Cannot unify ‘Rep a’ with the type variable ‘c0’
because the former is not a concrete ‘RuntimeRep’.
• The equation for ‘f’ has one visible argument,
but its type ‘a #-> ()’ has none
=====================================
testsuite/tests/simplCore/should_compile/simpl017.stderr
=====================================
@@ -1,20 +1,25 @@
-simpl017.hs:55:12: error: [GHC-46956]
- • Couldn't match type ‘v0’ with ‘v’
- Expected: [E m i] -> E' v m a
- Actual: [E m i] -> E' v0 m a
- because type variable ‘v’ would escape its scope
- This (rigid, skolem) type variable is bound by
- a type expected by the context:
- forall v. [E m i] -> E' v m a
- at simpl017.hs:55:12
- • In the first argument of ‘return’, namely ‘f’
- In a stmt of a 'do' block: return f
+simpl017.hs:55:5: error: [GHC-83865]
+ • Couldn't match type: [E m i] -> E' v0 m a
+ with: forall v. [E m i] -> E' v m a
+ Expected: m (forall v. [E m i] -> E' v m a)
+ Actual: m ([E m i] -> E' v0 m a)
+ • In a stmt of a 'do' block: return f
In the first argument of ‘E’, namely
‘(do let ix :: [E m i] -> m i
ix [i] = runE i
{-# INLINE f #-}
....
return f)’
+ In the expression:
+ E (do let ix :: [E m i] -> m i
+ ix [i] = runE i
+ {-# INLINE f #-}
+ ....
+ return f)
• Relevant bindings include
f :: [E m i] -> E' v0 m a (bound at simpl017.hs:54:9)
+ ix :: [E m i] -> m i (bound at simpl017.hs:52:9)
+ a :: arr i a (bound at simpl017.hs:50:11)
+ liftArray :: arr i a -> E m (forall v. [E m i] -> E' v m a)
+ (bound at simpl017.hs:50:1)
=====================================
testsuite/tests/typecheck/should_compile/T26030.hs
=====================================
@@ -0,0 +1,25 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE GADTs #-}
+
+-- This program was rejected by GHC 9.12 due to a bug with
+-- unification in QuickLook.
+module T26030 where
+
+import Data.Kind
+
+type S :: Type -> Type
+data S a where
+ S1 :: S Bool
+ S2 :: S Char
+
+type F :: Type -> Type
+type family F a where
+ F Bool = Bool
+ F Char = Char
+
+foo :: forall a. S a -> IO (F a)
+foo sa1 = do
+ () <- return ()
+ case sa1 of
+ S1 -> return $ False
+ S2 -> return 'x'
=====================================
testsuite/tests/typecheck/should_compile/all.T
=====================================
@@ -887,6 +887,7 @@ test('T21909b', normal, compile, [''])
test('T21443', normal, compile, [''])
test('T22194', normal, compile, [''])
test('T25744', normal, compile, [''])
+test('T26030', normal, compile, [''])
test('QualifiedRecordUpdate',
[ extra_files(['QualifiedRecordUpdate_aux.hs']) ]
, multimod_compile, ['QualifiedRecordUpdate', '-v0'])
=====================================
testsuite/tests/typecheck/should_fail/T25950.hs
=====================================
@@ -0,0 +1,6 @@
+{-# LANGUAGE PartialTypeSignatures #-}
+
+module T25950 where
+
+fails :: _ => a
+fails = id $ ()
=====================================
testsuite/tests/typecheck/should_fail/T25950.stderr
=====================================
@@ -0,0 +1,9 @@
+T25950.hs:6:9: error: [GHC-25897]
+ • Couldn't match expected type ‘a’ with actual type ‘()’
+ ‘a’ is a rigid type variable bound by
+ the inferred type of fails :: a
+ at T25950.hs:5:1-15
+ • In the expression: id $ ()
+ In an equation for ‘fails’: fails = id $ ()
+ • Relevant bindings include fails :: a (bound at T25950.hs:6:1)
+
=====================================
testsuite/tests/typecheck/should_fail/all.T
=====================================
@@ -726,6 +726,7 @@ test('T17594c', normal, compile_fail, [''])
test('T17594d', normal, compile_fail, [''])
test('T17594g', normal, compile_fail, [''])
+test('T25950', normal, compile_fail, [''])
test('T24470a', normal, compile_fail, [''])
test('T24553', normal, compile_fail, [''])
test('T23739b', normal, compile_fail, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/202b201c968de68f864f4c8abbfec7…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/202b201c968de68f864f4c8abbfec7…
You're receiving this email because of your account on gitlab.haskell.org.
1
0
[Git][ghc/ghc][master] Interpreter: Add limited support for direct primop evaluation.
by Marge Bot (＠marge-bot) 21 May '25
by Marge Bot (＠marge-bot) 21 May '25
21 May '25
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
202b201c by Andreas Klebinger at 2025-05-21T10:16:14-04: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.
- - - - -
17 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/codeGen/should_run/all.T
- + testsuite/tests/ghci/all.T
- + testsuite/tests/ghci/ghci-mem-primops.hs
- + testsuite/tests/ghci/ghci-mem-primops.script
- + testsuite/tests/ghci/ghci-mem-primops.stdout
- 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
=====================================
@@ -705,6 +705,143 @@ assembleI platform i = case i of
CCALL off ffi i -> do np <- lit1 $ BCONPtrFFIInfo ffi
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 tick_mod_id tickx info_mod info_mod_id infox cc ->
do p1 <- ptr (BCOPtrBreakArray arr)
tick_addr <- lit1 $ BCONPtrFS $ moduleNameFS tick_mod
@@ -726,6 +863,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
=====================================
@@ -14,11 +14,14 @@ module GHC.ByteCode.Instr (
import GHC.Prelude
import GHC.ByteCode.Types
+import GHC.Cmm.Type (Width)
import GHCi.RemoteTypes
import GHC.StgToCmm.Layout ( ArgRep(..) )
import GHC.Utils.Outputable
+import GHC.Unit.Types (UnitId)
import GHC.Types.Name
import GHC.Types.Literal
+import GHC.Types.Unique
import GHC.Core.DataCon
import GHC.Builtin.PrimOps
import GHC.Runtime.Heap.Layout ( StgWord )
@@ -35,8 +38,6 @@ import GHC.Stack.CCS (CostCentre)
import GHC.Stg.Syntax
import GHCi.BreakArray (BreakArray)
import Language.Haskell.Syntax.Module.Name (ModuleName)
-import GHC.Types.Unique
-import GHC.Unit.Types (UnitId)
-- ----------------------------------------------------------------------------
-- Bytecode instructions
@@ -217,6 +218,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.
+ -- We zero extend the result we put on the stack according to host byte order.
+ | 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
@@ -397,6 +431,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"
@@ -505,6 +565,31 @@ 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 )
@@ -560,8 +561,7 @@ returnUnboxedTuple d s p es = do
-- Compile code to apply the given expression to the remaining args
-- on the stack, returning a HNF.
-schemeE
- :: StackDepth -> Sequel -> BCEnv -> CgStgExpr -> BcM BCInstrList
+schemeE :: StackDepth -> Sequel -> BCEnv -> CgStgExpr -> BcM BCInstrList
schemeE d s p (StgLit lit) = returnUnliftedAtom d s p (StgLitArg lit)
schemeE d s p (StgApp x [])
| isUnliftedType (idType x) = returnUnliftedAtom d s p (StgVarArg x)
@@ -712,8 +712,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
@@ -808,6 +814,300 @@ 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 -> only64bit $ sizedPrimOp OP_ADD
+ Int32AddOp -> sizedPrimOp OP_ADD
+ Int16AddOp -> sizedPrimOp OP_ADD
+ Int8AddOp -> sizedPrimOp OP_ADD
+ WordAddOp -> sizedPrimOp OP_ADD
+ Word64AddOp -> only64bit $ sizedPrimOp OP_ADD
+ Word32AddOp -> sizedPrimOp OP_ADD
+ Word16AddOp -> sizedPrimOp OP_ADD
+ Word8AddOp -> sizedPrimOp OP_ADD
+ AddrAddOp -> sizedPrimOp OP_ADD
+
+ IntMulOp -> sizedPrimOp OP_MUL
+ Int64MulOp -> only64bit $ sizedPrimOp OP_MUL
+ Int32MulOp -> sizedPrimOp OP_MUL
+ Int16MulOp -> sizedPrimOp OP_MUL
+ Int8MulOp -> sizedPrimOp OP_MUL
+ WordMulOp -> sizedPrimOp OP_MUL
+ Word64MulOp -> only64bit $ sizedPrimOp OP_MUL
+ Word32MulOp -> sizedPrimOp OP_MUL
+ Word16MulOp -> sizedPrimOp OP_MUL
+ Word8MulOp -> sizedPrimOp OP_MUL
+
+ IntSubOp -> sizedPrimOp OP_SUB
+ WordSubOp -> sizedPrimOp OP_SUB
+ Int64SubOp -> only64bit $ sizedPrimOp OP_SUB
+ Int32SubOp -> sizedPrimOp OP_SUB
+ Int16SubOp -> sizedPrimOp OP_SUB
+ Int8SubOp -> sizedPrimOp OP_SUB
+ Word64SubOp -> only64bit $ 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 -> only64bit $ sizedPrimOp OP_AND
+ Word32AndOp -> sizedPrimOp OP_AND
+ Word16AndOp -> sizedPrimOp OP_AND
+ Word8AndOp -> sizedPrimOp OP_AND
+
+ IntNotOp -> sizedPrimOp OP_NOT
+ WordNotOp -> sizedPrimOp OP_NOT
+ Word64NotOp -> only64bit $ sizedPrimOp OP_NOT
+ Word32NotOp -> sizedPrimOp OP_NOT
+ Word16NotOp -> sizedPrimOp OP_NOT
+ Word8NotOp -> sizedPrimOp OP_NOT
+
+ IntXorOp -> sizedPrimOp OP_XOR
+ WordXorOp -> sizedPrimOp OP_XOR
+ Word64XorOp -> only64bit $ sizedPrimOp OP_XOR
+ Word32XorOp -> sizedPrimOp OP_XOR
+ Word16XorOp -> sizedPrimOp OP_XOR
+ Word8XorOp -> sizedPrimOp OP_XOR
+
+ IntOrOp -> sizedPrimOp OP_OR
+ WordOrOp -> sizedPrimOp OP_OR
+ Word64OrOp -> only64bit $ sizedPrimOp OP_OR
+ Word32OrOp -> sizedPrimOp OP_OR
+ Word16OrOp -> sizedPrimOp OP_OR
+ Word8OrOp -> sizedPrimOp OP_OR
+
+ WordSllOp -> sizedPrimOp OP_SHL
+ Word64SllOp -> only64bit $ sizedPrimOp OP_SHL -- check 32bit platform
+ Word32SllOp -> sizedPrimOp OP_SHL
+ Word16SllOp -> sizedPrimOp OP_SHL
+ Word8SllOp -> sizedPrimOp OP_SHL
+ IntSllOp -> sizedPrimOp OP_SHL
+ Int64SllOp -> only64bit $ sizedPrimOp OP_SHL
+ Int32SllOp -> sizedPrimOp OP_SHL
+ Int16SllOp -> sizedPrimOp OP_SHL
+ Int8SllOp -> sizedPrimOp OP_SHL
+
+ WordSrlOp -> sizedPrimOp OP_LSR
+ Word64SrlOp -> only64bit $ sizedPrimOp OP_LSR
+ Word32SrlOp -> sizedPrimOp OP_LSR
+ Word16SrlOp -> sizedPrimOp OP_LSR
+ Word8SrlOp -> sizedPrimOp OP_LSR
+ IntSrlOp -> sizedPrimOp OP_LSR
+ Int64SrlOp -> only64bit $ sizedPrimOp OP_LSR -- check 32bit platform
+ Int32SrlOp -> sizedPrimOp OP_LSR
+ Int16SrlOp -> sizedPrimOp OP_LSR
+ Int8SrlOp -> sizedPrimOp OP_LSR
+
+ IntSraOp -> sizedPrimOp OP_ASR
+ Int64SraOp -> only64bit $ sizedPrimOp OP_ASR -- check 32bit platform
+ Int32SraOp -> sizedPrimOp OP_ASR
+ Int16SraOp -> sizedPrimOp OP_ASR
+ Int8SraOp -> sizedPrimOp OP_ASR
+
+
+ IntNeOp -> sizedPrimOp OP_NEQ
+ Int64NeOp -> only64bit $ sizedPrimOp OP_NEQ
+ Int32NeOp -> sizedPrimOp OP_NEQ
+ Int16NeOp -> sizedPrimOp OP_NEQ
+ Int8NeOp -> sizedPrimOp OP_NEQ
+ WordNeOp -> sizedPrimOp OP_NEQ
+ Word64NeOp -> only64bit $ sizedPrimOp OP_NEQ
+ Word32NeOp -> sizedPrimOp OP_NEQ
+ Word16NeOp -> sizedPrimOp OP_NEQ
+ Word8NeOp -> sizedPrimOp OP_NEQ
+ AddrNeOp -> sizedPrimOp OP_NEQ
+
+ IntEqOp -> sizedPrimOp OP_EQ
+ Int64EqOp -> only64bit $ sizedPrimOp OP_EQ
+ Int32EqOp -> sizedPrimOp OP_EQ
+ Int16EqOp -> sizedPrimOp OP_EQ
+ Int8EqOp -> sizedPrimOp OP_EQ
+ WordEqOp -> sizedPrimOp OP_EQ
+ Word64EqOp -> only64bit $ 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 -> only64bit $ 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 -> only64bit $ 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 -> only64bit $ 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 -> only64bit $ 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 -> only64bit $ 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 -> only64bit $ 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 -> only64bit $ 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 -> only64bit $ 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 -> only64bit $ 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 -> only64bit $ mk_conv W64
+ Word64ToInt64Op -> only64bit $ 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)
+
+ -- Memory primops, expand the ghci-mem-primops test if you add more.
+ 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 -> only64bit $ primOpWithRep (OP_INDEX_ADDR W64) W64
+
+ _ -> Nothing
+ where
+ only64bit = if platformWordWidth platform == W64 then id else const Nothing
+ 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 result_width = Just $ do
+ prim_code <- mkPrimOpCode init_d s p op_inst $ args
+ let slide = mkSlideW (mkSlideWords result_width) (bytesToWords platform $ init_d - s) `snocOL` mkNReturn result_width
+ return $ prim_code `appOL` slide
+
+ -- Coerce the argument, requires them to be the same size
+ mk_conv :: Width -> Maybe (BcM (OrdList BCInstr))
+ mk_conv target_width = Just $ do
+ let width = primArg1Width (head args)
+ massert (width == target_width)
+ (push_code, _bytes) <- pushAtom init_d p (head args)
+ let slide = mkSlideW (mkSlideWords target_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,35 @@ 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 W64_TO_WDS(n) ((n * sizeof(StgWord64) / sizeof(StgWord)))
+
+// Always safe to use - Return the value at the address
+#define ReadSpW(n) (*((StgWord*) SafeSpWP(n)))
+//Argument is offset in multiples of word64
+#define ReadSpW64(n) (*((StgWord64*) SafeSpWP(W64_TO_WDS(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 +227,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,14 +241,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.
+#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) {
@@ -1429,41 +1469,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;
}
@@ -1953,7 +1993,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;
@@ -1999,7 +2039,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;
}
@@ -2048,7 +2088,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;
@@ -2094,7 +2134,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;
}
@@ -2231,7 +2271,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;
}
@@ -2241,6 +2281,203 @@ 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; \
+}
+
+// op :: ty -> ty -> Int
+#define SIZED_BIN_OP_TY_TY_INT(op,ty) \
+{ \
+ if(sizeof(ty) > sizeof(StgWord)) { \
+ ty r = ((ty) ReadSpW64(0)) op ((ty) ReadSpW64(1)); \
+ Sp_addW(3); \
+ SpW(0) = (StgWord) 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_TY_TY_INT(!=, StgWord64)
+ case bci_OP_EQ_64: SIZED_BIN_OP_TY_TY_INT(==, StgWord64)
+ case bci_OP_U_GT_64: SIZED_BIN_OP_TY_TY_INT(>, StgWord64)
+ case bci_OP_U_GE_64: SIZED_BIN_OP_TY_TY_INT(>=, StgWord64)
+ case bci_OP_U_LT_64: SIZED_BIN_OP_TY_TY_INT(<, StgWord64)
+ case bci_OP_U_LE_64: SIZED_BIN_OP_TY_TY_INT(<=, StgWord64)
+
+ case bci_OP_S_GT_64: SIZED_BIN_OP_TY_TY_INT(>, StgInt64)
+ case bci_OP_S_GE_64: SIZED_BIN_OP_TY_TY_INT(>=, StgInt64)
+ case bci_OP_S_LT_64: SIZED_BIN_OP_TY_TY_INT(<, StgInt64)
+ case bci_OP_S_LE_64: SIZED_BIN_OP_TY_TY_INT(<=, 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_TY_TY_INT(!=, StgWord32)
+ case bci_OP_EQ_32: SIZED_BIN_OP_TY_TY_INT(==, StgWord32)
+ case bci_OP_U_GT_32: SIZED_BIN_OP_TY_TY_INT(>, StgWord32)
+ case bci_OP_U_GE_32: SIZED_BIN_OP_TY_TY_INT(>=, StgWord32)
+ case bci_OP_U_LT_32: SIZED_BIN_OP_TY_TY_INT(<, StgWord32)
+ case bci_OP_U_LE_32: SIZED_BIN_OP_TY_TY_INT(<=, StgWord32)
+
+ case bci_OP_S_GT_32: SIZED_BIN_OP_TY_TY_INT(>, StgInt32)
+ case bci_OP_S_GE_32: SIZED_BIN_OP_TY_TY_INT(>=, StgInt32)
+ case bci_OP_S_LT_32: SIZED_BIN_OP_TY_TY_INT(<, StgInt32)
+ case bci_OP_S_LE_32: SIZED_BIN_OP_TY_TY_INT(<=, 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_TY_TY_INT(!=, StgWord16)
+ case bci_OP_EQ_16: SIZED_BIN_OP_TY_TY_INT(==, StgWord16)
+ case bci_OP_U_GT_16: SIZED_BIN_OP_TY_TY_INT(>, StgWord16)
+ case bci_OP_U_GE_16: SIZED_BIN_OP_TY_TY_INT(>=, StgWord16)
+ case bci_OP_U_LT_16: SIZED_BIN_OP_TY_TY_INT(<, StgWord16)
+ case bci_OP_U_LE_16: SIZED_BIN_OP_TY_TY_INT(<=, 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_TY_TY_INT(!=, StgWord8)
+ case bci_OP_EQ_08: SIZED_BIN_OP_TY_TY_INT(==, StgWord8)
+ case bci_OP_U_GT_08: SIZED_BIN_OP_TY_TY_INT(>, StgWord8)
+ case bci_OP_U_GE_08: SIZED_BIN_OP_TY_TY_INT(>=, StgWord8)
+ case bci_OP_U_LT_08: SIZED_BIN_OP_TY_TY_INT(<, StgWord8)
+ case bci_OP_U_LE_08: SIZED_BIN_OP_TY_TY_INT(<=, StgWord8)
+
+ case bci_OP_S_GT_08: SIZED_BIN_OP_TY_TY_INT(>, StgInt8)
+ case bci_OP_S_GE_08: SIZED_BIN_OP_TY_TY_INT(>=, StgInt8)
+ case bci_OP_S_LT_08: SIZED_BIN_OP_TY_TY_INT(<, StgInt8)
+ case bci_OP_S_LE_08: SIZED_BIN_OP_TY_TY_INT(<=, 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(0);
+ StgInt offset = (StgInt) SpW(1);
+ if(sizeof(StgPtr) == sizeof(StgWord64)) {
+ Sp_addW(1);
+ }
+ SpW64(0) = *(addr+offset);
+ goto nextInsn;
+ }
+
+ case bci_OP_INDEX_ADDR_32:
+ {
+ StgWord32* addr = (StgWord32*) SpW(0);
+ StgInt offset = (StgInt) SpW(1);
+ Sp_addW(1);
+ SpW(0) = (StgWord) *(addr+offset);
+ goto nextInsn;
+ }
+ case bci_OP_INDEX_ADDR_16:
+ {
+ StgWord16* addr = (StgWord16*) SpW(0);
+ StgInt offset = (StgInt) SpW(1);
+ Sp_addW(1);
+ SpW(0) = (StgWord) *(addr+offset);
+ goto nextInsn;
+ }
+ case bci_OP_INDEX_ADDR_08:
+ {
+ StgWord8* addr = (StgWord8*) SpW(0);
+ StgInt offset = (StgInt) SpW(1);
+ 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/codeGen/should_run/all.T
=====================================
@@ -226,7 +226,7 @@ test('T20640b', normal, compile_and_run, [''])
test('T22296',[only_ways(llvm_ways)
,unless(arch('x86_64') or arch('aarch64'), skip)],compile_and_run,[''])
test('T22798', normal, compile_and_run, ['-fregs-graph'])
-test('CheckBoundsOK', normal, compile_and_run, ['-fcheck-prim-bounds'])
+test('CheckBoundsOK', normal, compile_and_run, ['-fcheck-prim-bounds -funoptimized-core-for-interpreter -O'])
test('OrigThunkInfo', normal, compile_and_run, ['-forig-thunk-info'])
test('T24809', req_profiling, compile_and_run, ['-forig-thunk-info -prof'])
=====================================
testsuite/tests/ghci/all.T
=====================================
@@ -0,0 +1,2 @@
+test('ghci-mem-primops', [ extra_ways(['ghci-opt']), only_ways(['ghci', 'ghci-opt']),
+ extra_hc_opts('-fno-unoptimized-core-for-interpreter -O')], ghci_script, ['ghci-mem-primops.script'])
=====================================
testsuite/tests/ghci/ghci-mem-primops.hs
=====================================
@@ -0,0 +1,30 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE ExtendedLiterals #-}
+
+module Main where
+
+-- Test memory primops interpreted in interpreter, extend if you add more.
+import GHC.Word
+import GHC.PrimOps
+import GHC.IO
+import Numeric (showHex)
+
+data Bytes = Bytes { byte_addr :: Addr# }
+
+bytes :: Bytes
+bytes = Bytes "\0\1\2\3\4\5\6\7\8\0"#
+
+main = do
+ let val = 0x1122334455667788#Word64
+ IO (\s -> case writeWord64OffAddr# (byte_addr bytes) 0# val s of s2 -> (# s2,() #))
+ putStrLn . flip showHex "" $ W64# (indexWord64OffAddr# (byte_addr bytes) 0#)
+
+ IO (\s -> case writeWord32OffAddr# (byte_addr bytes) 0# 0x11223344#Word32 s of s2 -> (# s2,() #))
+ putStrLn . flip showHex "" $ W32# (indexWord32OffAddr# (byte_addr bytes) 0#)
+
+ IO (\s -> case writeWord16OffAddr# (byte_addr bytes) 0# 0x1122#Word16 s of s2 -> (# s2,() #))
+ putStrLn . flip showHex "" $ W16# (indexWord16OffAddr# (byte_addr bytes) 0#)
+
+ IO (\s -> case writeWord8OffAddr# (byte_addr bytes) 0# 0x11#Word8 s of s2 -> (# s2,() #))
+ putStrLn . flip showHex "" $ W8# (indexWord8OffAddr# (byte_addr bytes) 0#)
\ No newline at end of file
=====================================
testsuite/tests/ghci/ghci-mem-primops.script
=====================================
@@ -0,0 +1,2 @@
+:l ghci-mem-primops
+:main
\ No newline at end of file
=====================================
testsuite/tests/ghci/ghci-mem-primops.stdout
=====================================
@@ -0,0 +1,4 @@
+1122334455667788
+11223344
+1122
+11
=====================================
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/202b201c968de68f864f4c8abbfec71…
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/202b201c968de68f864f4c8abbfec71…
You're receiving this email because of your account on gitlab.haskell.org.
1
0