May 2025 - ghc-commits

[Git][ghc/ghc][wip/T25974] 4 commits: Refactor mkTopLevImportedEnv out of mkTopLevEnv
by Serge S. Gulin (＠gulin.serge) 07 May '25

07 May '25

Serge S. Gulin pushed to branch wip/T25974 at Glasgow Haskell Compiler / GHC Commits: e46c6b18 by Rodrigo Mesquita at 2025-05-06T09:01:57-04:00 Refactor mkTopLevImportedEnv out of mkTopLevEnv This makes the code clearer and allows the top-level import context to be fetched directly from the HomeModInfo through the API (e.g. useful for the debugger). - - - - - 0ce0d263 by Rodrigo Mesquita at 2025-05-06T09:01:57-04:00 Export sizeOccEnv from GHC.Types.Name.Occurrence Counts the number of OccNames in an OccEnv - - - - - 165f98d8 by Simon Peyton Jones at 2025-05-06T09:02:39-04:00 Fix a bad untouchability bug im simplifyInfer This patch addresses #26004. The root cause was that simplifyInfer was willing to unify variables "far out". The fix, in runTcSWithEvBinds', is to initialise the inert set given-eq level with the current level. See (TGE6) in Note [Tracking Given equalities] in GHC.Tc.Solver.InertSet Two loosely related refactors: * Refactored approximateWCX to return just the free type variables of the un-quantified constraints. That avoids duplication of work (these free vars are needed in simplifyInfer) and makes it clearer that the constraints themselves are irrelevant. * A little local refactor of TcSMode, which reduces the number of parameters to runTcSWithEvBinds - - - - - eea552e1 by Serge S. Gulin at 2025-05-07T10:14:07+03:00 Add Wine support - - - - - 21 changed files: - .gitignore - .gitlab/ci.sh - .gitlab/generate-ci/gen_ci.hs - boot - compiler/GHC/HsToCore/Pmc/Solver/Types.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Tc/Solver.hs - compiler/GHC/Tc/Solver/InertSet.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Types/Constraint.hs - compiler/GHC/Types/Name/Occurrence.hs - configure.ac - hadrian/src/Builder.hs - hadrian/src/Rules/BinaryDist.hs - libraries/ghc-internal/src/GHC/Internal/Event/Windows.hsc - m4/find_merge_objects.m4 - m4/fp_setup_windows_toolchain.m4 - + testsuite/tests/typecheck/should_fail/T26004.hs - + testsuite/tests/typecheck/should_fail/T26004.stderr - testsuite/tests/typecheck/should_fail/T7453.stderr - testsuite/tests/typecheck/should_fail/all.T Changes: ===================================== .gitignore ===================================== @@ -256,3 +256,6 @@ ghc.nix/ # clangd .clangd dist-newstyle/ + +# .gitlab/ci.sh for HERMETIC=1 +cabal/* ===================================== .gitlab/ci.sh ===================================== @@ -75,6 +75,15 @@ Environment variables affecting both build systems: NIX_SYSTEM On Darwin, the target platform of the desired toolchain (either "x86-64-darwin" or "aarch-darwin") NO_BOOT Whether to run ./boot or not, used when testing the source dist + TOOLCHAIN_SOURCE Select a source of toolchain. Possible values: + - "env": Toolchains are included in the Docker image via environment + variables. Default for Linux. + - "nix": Toolchains are provided via .gitlab/darwin/toolchain.nix. + Default for Darwin. + - "extracted": + Toolchains will be downloaded and extracted through the + CI process. Default for other systems. Windows and FreeBSD + are included. Environment variables determining build configuration of Hadrian system: @@ -83,14 +92,14 @@ Environment variables determining build configuration of Hadrian system: This tests the "reinstall" configuration CROSS_EMULATOR The emulator to use for testing of cross-compilers. -Environment variables determining bootstrap toolchain (Linux): +Environment variables determining bootstrap toolchain (TOOLCHAIN_SOURCE=env): GHC Path of GHC executable to use for bootstrapping. CABAL Path of cabal-install executable to use for bootstrapping. ALEX Path of alex executable to use for bootstrapping. HAPPY Path of alex executable to use for bootstrapping. -Environment variables determining bootstrap toolchain (non-Linux): +Environment variables determining bootstrap toolchain (TOOLCHAIN_SOURCE=extracted): GHC_VERSION Which GHC version to fetch for bootstrapping. CABAL_INSTALL_VERSION @@ -135,7 +144,9 @@ function mingw_init() { case "$MSYSTEM" in CLANG64) target_triple="x86_64-unknown-mingw32" - boot_triple="x86_64-unknown-mingw32" # triple of bootstrap GHC + ;; + CLANGARM64) + target_triple="aarch64-unknown-mingw32" ;; *) fail "win32-init: Unknown MSYSTEM $MSYSTEM" @@ -150,10 +161,19 @@ function mingw_init() { MINGW_MOUNT_POINT="${MINGW_PREFIX}" PATH="$MINGW_MOUNT_POINT/bin:$PATH" - # We always use mingw64 Python to avoid path length issues like #17483. - export PYTHON="/mingw64/bin/python3" - # And need to use sphinx-build from the environment - export SPHINXBUILD="/mingw64/bin/sphinx-build.exe" + case "$MSYSTEM" in + CLANGARM64) + # At MSYS for ARM64 we force to use their special versions to speedup the compiler step + export PYTHON="/clangarm64/bin/python3" + export SPHINXBUILD="/clangarm64/bin/sphinx-build.exe" + ;; + *) + # We always use mingw64 Python to avoid path length issues like #17483. + export PYTHON="/mingw64/bin/python3" + # And need to use sphinx-build from the environment + export SPHINXBUILD="/mingw64/bin/sphinx-build.exe" + ;; + esac } # This will contain GHC's local native toolchain @@ -178,15 +198,21 @@ function show_tool() { } function set_toolchain_paths() { - case "$(uname -m)-$(uname)" in - # Linux toolchains are included in the Docker image - *-Linux) toolchain_source="env" ;; - # Darwin toolchains are provided via .gitlab/darwin/toolchain.nix - *-Darwin) toolchain_source="nix" ;; - *) toolchain_source="extracted" ;; - esac + if [ -z "${TOOLCHAIN_SOURCE:-}" ] + then + # Fallback to automatic detection which could not work for cases + # when cross compiler will be build at Windows environment + # and requires a special mingw compiler (not bundled) + case "$(uname -m)-$(uname)" in + # Linux toolchains are included in the Docker image + *-Linux) TOOLCHAIN_SOURCE="env" ;; + # Darwin toolchains are provided via .gitlab/darwin/toolchain.nix + *-Darwin) TOOLCHAIN_SOURCE="nix" ;; + *) TOOLCHAIN_SOURCE="extracted" ;; + esac + fi - case "$toolchain_source" in + case "$TOOLCHAIN_SOURCE" in extracted) # These are populated by setup_toolchain GHC="$toolchain/bin/ghc$exe" @@ -217,7 +243,7 @@ function set_toolchain_paths() { : ${HAPPY:=$(which happy)} : ${ALEX:=$(which alex)} ;; - *) fail "bad toolchain_source" + *) fail "bad TOOLCHAIN_SOURCE" esac export GHC @@ -247,7 +273,7 @@ function setup() { cp -Rf "$CABAL_CACHE"/* "$CABAL_DIR" fi - case $toolchain_source in + case $TOOLCHAIN_SOURCE in extracted) time_it "setup" setup_toolchain ;; *) ;; esac @@ -273,14 +299,37 @@ function setup() { } function fetch_ghc() { - if [ ! -e "$GHC" ]; then - local v="$GHC_VERSION" + local boot_triple_to_fetch + case "$(uname)" in + MSYS_*|MINGW*) + case "$MSYSTEM" in + CLANG64) + boot_triple_to_fetch="x86_64-unknown-mingw32" # triple of bootstrap GHC + ;; + *) + fail "win32-init: Unknown MSYSTEM $MSYSTEM" + ;; + esac + ;; + Darwin) + boot_triple_to_fetch="x86_64-apple-darwin" + ;; + FreeBSD) + boot_triple_to_fetch="x86_64-portbld-freebsd" + ;; + Linux) + ;; + *) fail "uname $(uname) is not supported by ghc boot fetch" ;; + esac + readonly boot_triple_to_fetch + + local -r v="$GHC_VERSION" if [[ -z "$v" ]]; then fail "neither GHC nor GHC_VERSION are not set" fi start_section "fetch GHC" - url="https://downloads.haskell.org/~ghc/${GHC_VERSION}/ghc-${GHC_VERSION}-${boot…" + url="https://downloads.haskell.org/~ghc/${GHC_VERSION}/ghc-${GHC_VERSION}-${boot…" info "Fetching GHC binary distribution from $url..." curl "$url" > ghc.tar.xz || fail "failed to fetch GHC binary distribution" $TAR -xJf ghc.tar.xz || fail "failed to extract GHC binary distribution" @@ -297,8 +346,6 @@ function fetch_ghc() { esac rm -Rf "ghc-${GHC_VERSION}" ghc.tar.xz end_section "fetch GHC" - fi - } function fetch_cabal() { @@ -349,7 +396,10 @@ function fetch_cabal() { # here. For Docker platforms this is done in the Docker image # build. function setup_toolchain() { + if [ ! -e "$GHC" ]; then fetch_ghc + fi + fetch_cabal cabal_update @@ -405,6 +455,17 @@ function configure() { if [[ -n "${target_triple:-}" ]]; then args+=("--target=$target_triple") fi + if [[ "${TOOLCHAIN_SOURCE:-}" =~ "extracted" ]]; then + # To extract something need download something first. + args+=("--enable-tarballs-autodownload") + else + # For Windows we should explicitly --enable-distro-toolchain + # if i.e. we decided to use TOOLCHAIN_SOURCE = env + case "$(uname)" in + MSYS_*|MINGW*) args+=("--enable-distro-toolchain") ;; + *) ;; + esac + fi if [[ -n "${ENABLE_NUMA:-}" ]]; then args+=("--enable-numa") else @@ -421,7 +482,6 @@ function configure() { # See https://stackoverflow.com/questions/7577052 for a rationale for the # args[@] symbol-soup below. run ${CONFIGURE_WRAPPER:-} ./configure \ - --enable-tarballs-autodownload \ "${args[@]+"${args[@]}"}" \ GHC="$GHC" \ || ( cat config.log; fail "configure failed" ) @@ -562,12 +622,35 @@ function install_bindist() { read -r -a args <<< "${INSTALL_CONFIGURE_ARGS:-}" if [[ "${CROSS_TARGET:-no_cross_target}" =~ "mingw" ]]; then - # We suppose that host target = build target. + # We assume that BUILD=HOST. # By the fact above it is clearly turning out which host value is # for currently built compiler. # The fix for #21970 will probably remove this if-branch. - local -r CROSS_HOST_GUESS=$($SHELL ./config.guess) - args+=( "--target=$CROSS_TARGET" "--host=$CROSS_HOST_GUESS" ) + # Modifications are needed due of reasons like See Note [Wide Triple Windows]. + + local -r cross_host_triple_guess_origin=$($SHELL ./config.guess) + + # We expect here to have (x86_64|aarch64) + local -r cross_host_triple_guess_arch=$(echo "${cross_host_triple_guess_origin}" | cut -d'-' -f1) + + # Expect to have (apple|unknown) + local -r cross_host_triple_guess_vendor=$(echo "${cross_host_triple_guess_origin}" \ + `# "pc" should be converted to unknown for all supported platforms by GHC` \ + | sed -e "s/-pc-/-unknown-/" | cut -d'-' -f2) + + # 3,4 because it might contain a dash, expect to have (linux-gnu|mingw32|darwin) + local -r cross_host_triple_guess_os=$(echo "${cross_host_triple_guess_origin}" | cut -d'-' -f3,4 \ + `# GHC treats mingw64 as mingw32, so, we need hide this difference` \ + | sed -e "s/mingw.*/mingw32/" \ + `# config.guess may return triple with a release number, i.e. for darwin: aarch64-apple-darwin24.4.0` \ + | sed -e "s/darwin.*/darwin/" \ + | sed -e "s/freebsd.*/freebsd/" \ + ) + + local -r cross_host_triple_guess="$cross_host_triple_guess_arch-$cross_host_triple_guess_vendor-$cross_host_triple_guess_os" + echo "Convert guessed triple ${cross_host_triple_guess_origin} to GHC-compatible: ${cross_host_triple_guess}" + + args+=( "--target=$CROSS_TARGET" "--host=$cross_host_triple_guess" ) # FIXME: The bindist configure script shouldn't need to be reminded of # the target platform. See #21970. @@ -946,10 +1029,12 @@ esac MAKE="make" TAR="tar" case "$(uname)" in - MSYS_*|MINGW*) mingw_init ;; - Darwin) boot_triple="x86_64-apple-darwin" ;; + MSYS_*|MINGW*) + mingw_init + ;; + Darwin) + ;; FreeBSD) - boot_triple="x86_64-portbld-freebsd" MAKE="gmake" TAR="gtar" ;; ===================================== .gitlab/generate-ci/gen_ci.hs ===================================== @@ -1302,17 +1302,21 @@ cross_jobs = [ . setVariable "WindresCmd" (llvm_prefix ++ "windres") . setVariable "LLVMAS" (llvm_prefix ++ "clang") . setVariable "LD" (llvm_prefix ++ "ld") + -- See Note [Empty MergeObjsCmd] -- Windows target require to make linker merge feature check disabled. . setVariable "MergeObjsCmd" "" + -- Note [Wide Triple Windows] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- LLVM MinGW Linux Toolchain expects to recieve "aarch64-w64-mingw32" -- as a triple but we use more common "aarch64-unknown-mingw32". - -- Due of this we need configure ld manually for clang beacause + -- Due of this we need configure ld manually for clang because -- it will use system's ld otherwise when --target will be specified to -- unexpected triple. . setVariable "CFLAGS" cflags . setVariable "CONF_CC_OPTS_STAGE2" cflags ) where llvm_prefix = "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-" + -- See Note [Windows Toolchain Standard Library Options] cflags = "-fuse-ld=" ++ llvm_prefix ++ "ld --rtlib=compiler-rt" winAarch64Config = (crossConfig "aarch64-unknown-mingw32" (Emulator "/opt/wine-arm64ec-msys2-deb12/bin/wine") Nothing) ===================================== boot ===================================== @@ -52,6 +52,8 @@ def autoreconf(): # Run autoreconf on everything that needs it. processes = {} if os.name == 'nt': + # Note [ACLOCAL_PATH for Windows] + # ~~~~~~~~~~~~~~~~~~~~~~~~~ # Get the normalized ACLOCAL_PATH for Windows # This is necessary since on Windows this will be a Windows # path, which autoreconf doesn't know doesn't know how to handle. ===================================== compiler/GHC/HsToCore/Pmc/Solver/Types.hs ===================================== @@ -64,7 +64,7 @@ import GHC.Builtin.Names import GHC.Builtin.Types import GHC.Builtin.Types.Prim import GHC.Tc.Solver.InertSet (InertSet, emptyInert) -import GHC.Tc.Utils.TcType (isStringTy) +import GHC.Tc.Utils.TcType (isStringTy, topTcLevel) import GHC.Types.CompleteMatch import GHC.Types.SourceText (SourceText(..), mkFractionalLit, FractionalLit , fractionalLitFromRational @@ -129,7 +129,7 @@ instance Outputable TyState where ppr (TySt n inert) = ppr n <+> ppr inert initTyState :: TyState -initTyState = TySt 0 emptyInert +initTyState = TySt 0 (emptyInert topTcLevel) -- | The term oracle state. Stores 'VarInfo' for encountered 'Id's. These -- entries are possibly shared when we figure out that two variables must be ===================================== compiler/GHC/Runtime/Eval.hs ===================================== @@ -23,7 +23,7 @@ module GHC.Runtime.Eval ( setupBreakpoint, back, forward, setContext, getContext, - mkTopLevEnv, + mkTopLevEnv, mkTopLevImportedEnv, getNamesInScope, getRdrNamesInScope, moduleIsInterpreted, @@ -836,29 +836,36 @@ mkTopLevEnv hsc_env modl Nothing -> pure $ Left "not a home module" Just details -> case mi_top_env (hm_iface details) of - (IfaceTopEnv exports imports) -> do - imports_env <- - runInteractiveHsc hsc_env - $ ioMsgMaybe $ hoistTcRnMessage $ runTcInteractive hsc_env - $ fmap (foldr plusGlobalRdrEnv emptyGlobalRdrEnv) - $ forM imports $ \iface_import -> do - let ImpUserSpec spec details = tcIfaceImport iface_import - iface <- loadInterfaceForModule (text "imported by GHCi") (is_mod spec) - pure $ case details of - ImpUserAll -> importsFromIface hsc_env iface spec Nothing - ImpUserEverythingBut ns -> importsFromIface hsc_env iface spec (Just ns) - ImpUserExplicit x _parents_of_implicits -> - -- TODO: Not quite right, is_explicit should refer to whether the user wrote A(..) or A(x,y). - -- It is only used for error messages. It seems dubious even to add an import context to these GREs as - -- they are not "imported" into the top-level scope of the REPL. I changed this for now so that - -- the test case produce the same output as before. - let spec' = ImpSpec { is_decl = spec, is_item = ImpSome { is_explicit = True, is_iloc = noSrcSpan } } - in mkGlobalRdrEnv $ gresFromAvails hsc_env (Just spec') x + (IfaceTopEnv exports _imports) -> do + imports_env <- mkTopLevImportedEnv hsc_env details let exports_env = mkGlobalRdrEnv $ gresFromAvails hsc_env Nothing (getDetOrdAvails exports) pure $ Right $ plusGlobalRdrEnv imports_env exports_env where hpt = hsc_HPT hsc_env +-- | Make the top-level environment with all bindings imported by this module. +-- Exported bindings from this module are not included in the result. +mkTopLevImportedEnv :: HscEnv -> HomeModInfo -> IO GlobalRdrEnv +mkTopLevImportedEnv hsc_env details = do + runInteractiveHsc hsc_env + $ ioMsgMaybe $ hoistTcRnMessage $ runTcInteractive hsc_env + $ fmap (foldr plusGlobalRdrEnv emptyGlobalRdrEnv) + $ forM imports $ \iface_import -> do + let ImpUserSpec spec details = tcIfaceImport iface_import + iface <- loadInterfaceForModule (text "imported by GHCi") (is_mod spec) + pure $ case details of + ImpUserAll -> importsFromIface hsc_env iface spec Nothing + ImpUserEverythingBut ns -> importsFromIface hsc_env iface spec (Just ns) + ImpUserExplicit x _parents_of_implicits -> + -- TODO: Not quite right, is_explicit should refer to whether the user wrote A(..) or A(x,y). + -- It is only used for error messages. It seems dubious even to add an import context to these GREs as + -- they are not "imported" into the top-level scope of the REPL. I changed this for now so that + -- the test case produce the same output as before. + let spec' = ImpSpec { is_decl = spec, is_item = ImpSome { is_explicit = True, is_iloc = noSrcSpan } } + in mkGlobalRdrEnv $ gresFromAvails hsc_env (Just spec') x + where + IfaceTopEnv _ imports = mi_top_env (hm_iface details) + -- | Get the interactive evaluation context, consisting of a pair of the -- set of modules from which we take the full top-level scope, and the set -- of modules from which we take just the exports respectively. ===================================== compiler/GHC/Tc/Solver.hs ===================================== @@ -915,21 +915,22 @@ simplifyInfer top_lvl rhs_tclvl infer_mode sigs name_taus wanteds ; let psig_theta = concatMap sig_inst_theta partial_sigs -- First do full-blown solving - -- NB: we must gather up all the bindings from doing - -- this solving; hence (runTcSWithEvBinds ev_binds_var). - -- And note that since there are nested implications, - -- calling solveWanteds will side-effect their evidence - -- bindings, so we can't just revert to the input - -- constraint. - + -- NB: we must gather up all the bindings from doing this solving; hence + -- (runTcSWithEvBinds ev_binds_var). And note that since there are + -- nested implications, calling solveWanteds will side-effect their + -- evidence bindings, so we can't just revert to the input constraint. + -- + -- See also Note [Inferring principal types] ; ev_binds_var <- TcM.newTcEvBinds ; psig_evs <- newWanteds AnnOrigin psig_theta ; wanted_transformed - <- setTcLevel rhs_tclvl $ - runTcSWithEvBinds ev_binds_var $ + <- runTcSWithEvBinds ev_binds_var $ + setTcLevelTcS rhs_tclvl $ solveWanteds (mkSimpleWC psig_evs `andWC` wanteds) + -- setLevelTcS: we do setLevel /inside/ the runTcS, so that + -- we initialise the InertSet inert_given_eq_lvl as far + -- out as possible, maximising oppportunities to unify -- psig_evs : see Note [Add signature contexts as wanteds] - -- See Note [Inferring principal types] -- Find quant_pred_candidates, the predicates that -- we'll consider quantifying over @@ -1430,13 +1431,15 @@ decideAndPromoteTyVars top_lvl rhs_tclvl infer_mode name_taus psigs wanted -- Step 1 of Note [decideAndPromoteTyVars] -- Get candidate constraints, decide which we can potentially quantify - (can_quant_cts, no_quant_cts) = approximateWCX wanted + -- The `no_quant_tvs` are free in constraints we can't quantify. + (can_quant_cts, no_quant_tvs) = approximateWCX False wanted can_quant = ctsPreds can_quant_cts - no_quant = ctsPreds no_quant_cts + can_quant_tvs = tyCoVarsOfTypes can_quant -- Step 2 of Note [decideAndPromoteTyVars] -- Apply the monomorphism restriction (post_mr_quant, mr_no_quant) = applyMR dflags infer_mode can_quant + mr_no_quant_tvs = tyCoVarsOfTypes mr_no_quant -- The co_var_tvs are tvs mentioned in the types of covars or -- coercion holes. We can't quantify over these covars, so we @@ -1448,30 +1451,33 @@ decideAndPromoteTyVars top_lvl rhs_tclvl infer_mode name_taus psigs wanted ++ tau_tys ++ post_mr_quant) co_var_tvs = closeOverKinds co_vars - -- outer_tvs are mentioned in `wanted, and belong to some outer level. + -- outer_tvs are mentioned in `wanted`, and belong to some outer level. -- We definitely can't quantify over them outer_tvs = outerLevelTyVars rhs_tclvl $ - tyCoVarsOfTypes can_quant `unionVarSet` tyCoVarsOfTypes no_quant + can_quant_tvs `unionVarSet` no_quant_tvs - -- Step 3 of Note [decideAndPromoteTyVars] + -- Step 3 of Note [decideAndPromoteTyVars], (a-c) -- Identify mono_tvs: the type variables that we must not quantify over + -- At top level we are much less keen to create mono tyvars, to avoid + -- spooky action at a distance. mono_tvs_without_mr - | is_top_level = outer_tvs - | otherwise = outer_tvs -- (a) - `unionVarSet` tyCoVarsOfTypes no_quant -- (b) - `unionVarSet` co_var_tvs -- (c) + | is_top_level = outer_tvs -- See (DP2) + | otherwise = outer_tvs -- (a) + `unionVarSet` no_quant_tvs -- (b) + `unionVarSet` co_var_tvs -- (c) + -- Step 3 of Note [decideAndPromoteTyVars], (d) mono_tvs_with_mr = -- Even at top level, we don't quantify over type variables -- mentioned in constraints that the MR tells us not to quantify -- See Note [decideAndPromoteTyVars] (DP2) - mono_tvs_without_mr `unionVarSet` tyCoVarsOfTypes mr_no_quant + mono_tvs_without_mr `unionVarSet` mr_no_quant_tvs -------------------------------------------------------------------- -- Step 4 of Note [decideAndPromoteTyVars] -- Use closeWrtFunDeps to find any other variables that are determined by mono_tvs - add_determined tvs = closeWrtFunDeps post_mr_quant tvs - `delVarSetList` psig_qtvs + add_determined tvs preds = closeWrtFunDeps preds tvs + `delVarSetList` psig_qtvs -- Why delVarSetList psig_qtvs? -- If the user has explicitly asked for quantification, then that -- request "wins" over the MR. @@ -1480,8 +1486,8 @@ decideAndPromoteTyVars top_lvl rhs_tclvl infer_mode name_taus psigs wanted -- (i.e. says "no" to isQuantifiableTv)? That's OK: explanation -- in Step 2 of Note [Deciding quantification]. - mono_tvs_with_mr_det = add_determined mono_tvs_with_mr - mono_tvs_without_mr_det = add_determined mono_tvs_without_mr + mono_tvs_with_mr_det = add_determined mono_tvs_with_mr post_mr_quant + mono_tvs_without_mr_det = add_determined mono_tvs_without_mr can_quant -------------------------------------------------------------------- -- Step 5 of Note [decideAndPromoteTyVars] @@ -1518,7 +1524,7 @@ decideAndPromoteTyVars top_lvl rhs_tclvl infer_mode name_taus psigs wanted , text "newly_mono_tvs =" <+> ppr newly_mono_tvs , text "can_quant =" <+> ppr can_quant , text "post_mr_quant =" <+> ppr post_mr_quant - , text "no_quant =" <+> ppr no_quant + , text "no_quant_tvs =" <+> ppr no_quant_tvs , text "mr_no_quant =" <+> ppr mr_no_quant , text "final_quant =" <+> ppr final_quant , text "co_vars =" <+> ppr co_vars ] @@ -1605,8 +1611,8 @@ The plan The body of z tries to unify the type of x (call it alpha[1]) with (beta[2] -> gamma[2]). This unification fails because alpha is untouchable, leaving [W] alpha[1] ~ (beta[2] -> gamma[2]) - We need to know not to quantify over beta or gamma, because they are in the - equality constraint with alpha. Actual test case: typecheck/should_compile/tc213 + We don't want to quantify over beta or gamma because they are fixed by alpha, + which is monomorphic. Actual test case: typecheck/should_compile/tc213 Another example. Suppose we have class C a b | a -> b @@ -1643,9 +1649,22 @@ Wrinkles promote type variables. But for bindings affected by the MR we have no choice but to promote. + An example is in #26004. + f w e = case e of + T1 -> let y = not w in False + T2 -> True + When generalising `f` we have a constraint + forall. (a ~ Bool) => alpha ~ Bool + where our provisional type for `f` is `f :: T alpha -> blah`. + In a /nested/ setting, we might simply not-generalise `f`, hoping to learn + about `alpha` from f's call sites (test T5266b is an example). But at top + level, to avoid spooky action at a distance. + Note [The top-level Any principle] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Key principle: we never want to show the programmer a type with `Any` in it. +Key principles: + * we never want to show the programmer a type with `Any` in it. + * avoid "spooky action at a distance" and silent defaulting Most /top level/ bindings have a type signature, so none of this arises. But where a top-level binding lacks a signature, we don't want to infer a type like @@ -1654,11 +1673,18 @@ and then subsequently default alpha[0]:=Any. Exposing `Any` to the user is bad bad bad. Better to report an error, which is what may well happen if we quantify over alpha instead. +Moreover, + * If (elsewhere in this module) we add a call to `f`, say (f True), then + `f` will get the type `Bool -> Int` + * If we add /another/ call, say (f 'x'), we will then get a type error. + * If we have no calls, the final exported type of `f` may get set by + defaulting, and might not be principal (#26004). + For /nested/ bindings, a monomorphic type like `f :: alpha[0] -> Int` is fine, because we can see all the call sites of `f`, and they will probably fix `alpha`. In contrast, we can't see all of (or perhaps any of) the calls of top-level (exported) functions, reducing the worries about "spooky action at a -distance". +distance". This also moves in the direction of `MonoLocalBinds`, which we like. Note [Do not quantify over constraints that determine a variable] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/Tc/Solver/InertSet.hs ===================================== @@ -374,20 +374,20 @@ instance Outputable InertSet where where dicts = bagToList (dictsToBag solved_dicts) -emptyInertCans :: InertCans -emptyInertCans +emptyInertCans :: TcLevel -> InertCans +emptyInertCans given_eq_lvl = IC { inert_eqs = emptyTyEqs , inert_funeqs = emptyFunEqs - , inert_given_eq_lvl = topTcLevel + , inert_given_eq_lvl = given_eq_lvl , inert_given_eqs = False , inert_dicts = emptyDictMap , inert_safehask = emptyDictMap , inert_insts = [] , inert_irreds = emptyBag } -emptyInert :: InertSet -emptyInert - = IS { inert_cans = emptyInertCans +emptyInert :: TcLevel -> InertSet +emptyInert given_eq_lvl + = IS { inert_cans = emptyInertCans given_eq_lvl , inert_cycle_breakers = emptyBag :| [] , inert_famapp_cache = emptyFunEqs , inert_solved_dicts = emptyDictMap } @@ -678,6 +678,23 @@ should update inert_given_eq_lvl? imply nominal ones. For example, if (G a ~R G b) and G's argument's role is nominal, then we can deduce a ~N b. +(TGE6) A subtle point is this: when initialising the solver, giving it + an empty InertSet, we must conservatively initialise `inert_given_lvl` + to the /current/ TcLevel. This matters when doing let-generalisation. + Consider #26004: + f w e = case e of + T1 -> let y = not w in False -- T1 is a GADT + T2 -> True + When let-generalising `y`, we will have (w :: alpha[1]) in the type + envt; and we are under GADT pattern match. So when we solve the + constraints from y's RHS, in simplifyInfer, we must NOT unify + alpha[1] := Bool + Since we don't know what enclosing equalities there are, we just + conservatively assume that there are some. + + This initialisation in done in `runTcSWithEvBinds`, which passes + the current TcLevl to `emptyInert`. + Historical note: prior to #24938 we also ignored Given equalities that did not mention an "outer" type variable. But that is wrong, as #24938 showed. Another example is immortalised in test LocalGivenEqs2 ===================================== compiler/GHC/Tc/Solver/Monad.hs ===================================== @@ -20,7 +20,7 @@ module GHC.Tc.Solver.Monad ( runTcSSpecPrag, failTcS, warnTcS, addErrTcS, wrapTcS, ctLocWarnTcS, runTcSEqualities, - nestTcS, nestImplicTcS, setEvBindsTcS, + nestTcS, nestImplicTcS, setEvBindsTcS, setTcLevelTcS, emitImplicationTcS, emitTvImplicationTcS, emitImplication, emitFunDepWanteds, @@ -947,8 +947,9 @@ added. This is initialised from the innermost implication constraint. -- | See Note [TcSMode] data TcSMode = TcSVanilla -- ^ Normal constraint solving + | TcSPMCheck -- ^ Used when doing patterm match overlap checks | TcSEarlyAbort -- ^ Abort early on insoluble constraints - | TcSSpecPrag -- ^ Fully solve all constraints + | TcSSpecPrag -- ^ Fully solve all constraints deriving (Eq) {- Note [TcSMode] @@ -957,6 +958,11 @@ The constraint solver can operate in different modes: * TcSVanilla: Normal constraint solving mode. This is the default. +* TcSPMCheck: Used by the pattern match overlap checker. + Like TcSVanilla, but the idea is that the returned InertSet will + later be resumed, so we do not want to restore type-equality cycles + See also Note [Type equality cycles] in GHC.Tc.Solver.Equality + * TcSEarlyAbort: Abort (fail in the monad) as soon as we come across an insoluble constraint. This is used to fail-fast when checking for hole-fits. See Note [Speeding up valid hole-fits]. @@ -1135,7 +1141,7 @@ runTcS tcs runTcSEarlyAbort :: TcS a -> TcM a runTcSEarlyAbort tcs = do { ev_binds_var <- TcM.newTcEvBinds - ; runTcSWithEvBinds' True TcSEarlyAbort ev_binds_var tcs } + ; runTcSWithEvBinds' TcSEarlyAbort ev_binds_var tcs } -- | Run the 'TcS' monad in 'TcSSpecPrag' mode, which either fully solves -- individual Wanted quantified constraints or leaves them alone. @@ -1143,7 +1149,7 @@ runTcSEarlyAbort tcs -- See Note [TcSSpecPrag]. runTcSSpecPrag :: EvBindsVar -> TcS a -> TcM a runTcSSpecPrag ev_binds_var tcs - = runTcSWithEvBinds' True TcSSpecPrag ev_binds_var tcs + = runTcSWithEvBinds' TcSSpecPrag ev_binds_var tcs {- Note [TcSSpecPrag] ~~~~~~~~~~~~~~~~~~~~~ @@ -1200,7 +1206,7 @@ runTcSEqualities thing_inside runTcSInerts :: InertSet -> TcS a -> TcM (a, InertSet) runTcSInerts inerts tcs = do ev_binds_var <- TcM.newTcEvBinds - runTcSWithEvBinds' False TcSVanilla ev_binds_var $ do + runTcSWithEvBinds' TcSPMCheck ev_binds_var $ do setInertSet inerts a <- tcs new_inerts <- getInertSet @@ -1209,21 +1215,23 @@ runTcSInerts inerts tcs = do runTcSWithEvBinds :: EvBindsVar -> TcS a -> TcM a -runTcSWithEvBinds = runTcSWithEvBinds' True TcSVanilla +runTcSWithEvBinds = runTcSWithEvBinds' TcSVanilla -runTcSWithEvBinds' :: Bool -- True <=> restore type equality cycles - -- Don't if you want to reuse the InertSet. - -- See also Note [Type equality cycles] - -- in GHC.Tc.Solver.Equality - -> TcSMode +runTcSWithEvBinds' :: TcSMode -> EvBindsVar -> TcS a -> TcM a -runTcSWithEvBinds' restore_cycles mode ev_binds_var tcs +runTcSWithEvBinds' mode ev_binds_var tcs = do { unified_var <- TcM.newTcRef 0 - ; step_count <- TcM.newTcRef 0 - ; inert_var <- TcM.newTcRef emptyInert - ; wl_var <- TcM.newTcRef emptyWorkList + ; step_count <- TcM.newTcRef 0 + + -- Make a fresh, empty inert set + -- Subtle point: see (TGE6) in Note [Tracking Given equalities] + -- in GHC.Tc.Solver.InertSet + ; tc_lvl <- TcM.getTcLevel + ; inert_var <- TcM.newTcRef (emptyInert tc_lvl) + + ; wl_var <- TcM.newTcRef emptyWorkList ; unif_lvl_var <- TcM.newTcRef Nothing ; let env = TcSEnv { tcs_ev_binds = ev_binds_var , tcs_unified = unified_var @@ -1240,9 +1248,13 @@ runTcSWithEvBinds' restore_cycles mode ev_binds_var tcs ; when (count > 0) $ csTraceTcM $ return (text "Constraint solver steps =" <+> int count) - ; when restore_cycles $ - do { inert_set <- TcM.readTcRef inert_var - ; restoreTyVarCycles inert_set } + -- Restore tyvar cycles: see Note [Type equality cycles] in + -- GHC.Tc.Solver.Equality + -- But /not/ in TCsPMCheck mode: see Note [TcSMode] + ; case mode of + TcSPMCheck -> return () + _ -> do { inert_set <- TcM.readTcRef inert_var + ; restoreTyVarCycles inert_set } #if defined(DEBUG) ; ev_binds <- TcM.getTcEvBindsMap ev_binds_var @@ -1284,6 +1296,10 @@ setEvBindsTcS :: EvBindsVar -> TcS a -> TcS a setEvBindsTcS ref (TcS thing_inside) = TcS $ \ env -> thing_inside (env { tcs_ev_binds = ref }) +setTcLevelTcS :: TcLevel -> TcS a -> TcS a +setTcLevelTcS lvl (TcS thing_inside) + = TcS $ \ env -> TcM.setTcLevel lvl (thing_inside env) + nestImplicTcS :: EvBindsVar -> TcLevel -> TcS a -> TcS a ===================================== compiler/GHC/Tc/Types/Constraint.hs ===================================== @@ -1743,24 +1743,21 @@ will be able to report a more informative error: ************************************************************************ -} -type ApproxWC = ( Bag Ct -- Free quantifiable constraints - , Bag Ct ) -- Free non-quantifiable constraints - -- due to shape, or enclosing equality +type ApproxWC = ( Bag Ct -- Free quantifiable constraints + , TcTyCoVarSet ) -- Free vars of non-quantifiable constraints + -- due to shape, or enclosing equality approximateWC :: Bool -> WantedConstraints -> Bag Ct approximateWC include_non_quantifiable cts - | include_non_quantifiable = quant `unionBags` no_quant - | otherwise = quant - where - (quant, no_quant) = approximateWCX cts + = fst (approximateWCX include_non_quantifiable cts) -approximateWCX :: WantedConstraints -> ApproxWC +approximateWCX :: Bool -> WantedConstraints -> ApproxWC -- The "X" means "extended"; -- we return both quantifiable and non-quantifiable constraints -- See Note [ApproximateWC] -- See Note [floatKindEqualities vs approximateWC] -approximateWCX wc - = float_wc False emptyVarSet wc (emptyBag, emptyBag) +approximateWCX include_non_quantifiable wc + = float_wc False emptyVarSet wc (emptyBag, emptyVarSet) where float_wc :: Bool -- True <=> there are enclosing equalities -> TcTyCoVarSet -- Enclosing skolem binders @@ -1786,17 +1783,23 @@ approximateWCX wc -- There can be (insoluble) Given constraints in wc_simple, -- there so that we get error reports for unreachable code -- See `given_insols` in GHC.Tc.Solver.Solve.solveImplication - | insolubleCt ct = acc - | tyCoVarsOfCt ct `intersectsVarSet` skol_tvs = acc - | otherwise - = case classifyPredType (ctPred ct) of + | insolubleCt ct = acc + | pred_tvs `intersectsVarSet` skol_tvs = acc + | include_non_quantifiable = add_to_quant + | is_quantifiable encl_eqs (ctPred ct) = add_to_quant + | otherwise = add_to_no_quant + where + pred = ctPred ct + pred_tvs = tyCoVarsOfType pred + add_to_quant = (ct `consBag` quant, no_quant) + add_to_no_quant = (quant, no_quant `unionVarSet` pred_tvs) + + is_quantifiable encl_eqs pred + = case classifyPredType pred of -- See the classification in Note [ApproximateWC] EqPred eq_rel ty1 ty2 - | not encl_eqs -- See Wrinkle (W1) - , quantify_equality eq_rel ty1 ty2 - -> add_to_quant - | otherwise - -> add_to_no_quant + | encl_eqs -> False -- encl_eqs: See Wrinkle (W1) + | otherwise -> quantify_equality eq_rel ty1 ty2 ClassPred cls tys | Just {} <- isCallStackPred cls tys @@ -1804,17 +1807,14 @@ approximateWCX wc -- the constraints bubble up to be solved from the outer -- context, or be defaulted when we reach the top-level. -- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence - -> add_to_no_quant + -> False | otherwise - -> add_to_quant -- See Wrinkle (W2) + -> True -- See Wrinkle (W2) - IrredPred {} -> add_to_quant -- See Wrinkle (W2) + IrredPred {} -> True -- See Wrinkle (W2) - ForAllPred {} -> add_to_no_quant -- Never quantify these - where - add_to_quant = (ct `consBag` quant, no_quant) - add_to_no_quant = (quant, ct `consBag` no_quant) + ForAllPred {} -> False -- Never quantify these -- See Note [Quantifying over equality constraints] quantify_equality NomEq ty1 ty2 = quant_fun ty1 || quant_fun ty2 @@ -1852,7 +1852,7 @@ We proceed by classifying the constraint: Wrinkle (W1) When inferring most-general types (in simplifyInfer), we - do *not* float an equality constraint if the implication binds + do *not* quantify over equality constraint if the implication binds equality constraints, because that defeats the OutsideIn story. Consider data T a where { TInt :: T Int; MkT :: T a } f TInt = 3::Int ===================================== compiler/GHC/Types/Name/Occurrence.hs ===================================== @@ -92,6 +92,7 @@ module GHC.Types.Name.Occurrence ( plusOccEnv, plusOccEnv_C, extendOccEnv_Acc, filterOccEnv, delListFromOccEnv, delFromOccEnv, alterOccEnv, minusOccEnv, minusOccEnv_C, minusOccEnv_C_Ns, + sizeOccEnv, pprOccEnv, forceOccEnv, intersectOccEnv_C, @@ -803,6 +804,10 @@ minusOccEnv_C_Ns f (MkOccEnv as) (MkOccEnv bs) = then Nothing else Just m +sizeOccEnv :: OccEnv a -> Int +sizeOccEnv (MkOccEnv as) = + nonDetStrictFoldUFM (\ m !acc -> acc + sizeUFM m) 0 as + instance Outputable a => Outputable (OccEnv a) where ppr x = pprOccEnv ppr x ===================================== configure.ac ===================================== @@ -658,12 +658,13 @@ GHC_LLVM_TARGET_SET_VAR AC_SUBST(LlvmTarget) dnl ** See whether cc supports --target=<triple> and set -dnl CONF_CC_OPTS_STAGE[012] accordingly. -FP_CC_SUPPORTS_TARGET([$CC_STAGE0], [CONF_CC_OPTS_STAGE0], [CONF_CXX_OPTS_STAGE0]) +dnl CONF_CC_OPTS_STAGE[12] accordingly. FP_CC_SUPPORTS_TARGET([$CC], [CONF_CC_OPTS_STAGE1], [CONF_CXX_OPTS_STAGE1]) FP_CC_SUPPORTS_TARGET([$CC], [CONF_CC_OPTS_STAGE2], [CONF_CXX_OPTS_STAGE2]) -FP_PROG_CC_LINKER_TARGET([$CC_STAGE0], [CONF_CC_OPTS_STAGE0], [CONF_GCC_LINKER_OPTS_STAGE0]) +# CONF_CC_OPTS_STAGE0 should be left as is because it is already configured +# by bootstrap compiler settings + FP_PROG_CC_LINKER_TARGET([$CC], [CONF_CC_OPTS_STAGE1], [CONF_GCC_LINKER_OPTS_STAGE1]) FP_PROG_CC_LINKER_TARGET([$CC], [CONF_CC_OPTS_STAGE2], [CONF_GCC_LINKER_OPTS_STAGE2]) ===================================== hadrian/src/Builder.hs ===================================== @@ -26,7 +26,7 @@ import Hadrian.Builder.Tar import Hadrian.Oracles.Path import Hadrian.Oracles.TextFile import Hadrian.Utilities -import Oracles.Setting (bashPath, targetStage) +import Oracles.Setting (bashPath, targetStage, isWinHost) import System.Exit import System.IO (stderr) @@ -327,8 +327,14 @@ instance H.Builder Builder where Ar Unpack _ -> cmd' [Cwd output] [path] buildArgs buildOptions Autoreconf dir -> do + isWin <- isWinHost + let aclocal_env = + -- It is generally assumed that you would use MinGW's compilers from within an MSYS shell. + -- See Note [ACLOCAL_PATH for Windows] + if isWin then [AddEnv "ACLOCAL_PATH" "/c/msys64/usr/share/aclocal/"] + else [] bash <- bashPath - cmd' [Cwd dir] [bash, path] buildArgs buildOptions + cmd' (Cwd dir `cons` aclocal_env) [bash, path] buildArgs buildOptions Configure dir -> do -- Inject /bin/bash into `libtool`, instead of /bin/sh, ===================================== hadrian/src/Rules/BinaryDist.hs ===================================== @@ -115,7 +115,12 @@ installTo relocatable prefix = do targetPlatform <- setting TargetPlatformFull let ghcVersionPretty = "ghc-" ++ version ++ "-" ++ targetPlatform bindistFilesDir = root -/- "bindist" -/- ghcVersionPretty - runBuilder (Configure bindistFilesDir) ["--prefix="++prefix] [] [] + win <- isWinTarget + -- See Note [Empty MergeObjsCmd] + let disabledMerge = + if win then ["MergeObjsCmd="] + else [] + runBuilder (Configure bindistFilesDir) (["--prefix="++prefix] ++ disabledMerge) [] [] let env = case relocatable of Relocatable -> [AddEnv "RelocatableBuild" "YES"] NotRelocatable -> [] @@ -232,7 +237,7 @@ bindistRules = do -- N.B. the ghc-pkg executable may be prefixed with a target triple -- (c.f. #20267). ghcPkgName <- programName (vanillaContext Stage1 ghcPkg) - cmd_ (bindistFilesDir -/- "bin" -/- ghcPkgName) ["recache"] + cmd_ (bindistFilesDir -/- "bin" -/- ghcPkgName <.> exe) ["recache"] ===================================== libraries/ghc-internal/src/GHC/Internal/Event/Windows.hsc ===================================== @@ -861,7 +861,9 @@ expirationTime mgr us = do -- The 'TimeoutCallback' will not be called more than once. -- -- Be careful not to exceed @maxBound :: Int@, which on 32-bit machines is only --- 2147483647 μs, less than 36 minutes. +-- 2147483647 microseconds, less than 36 minutes. +-- We can not use here utf/greek symbol due of: +-- _build/stage1/libraries/ghc-internal/build/GHC/Internal/Event/Windows.hs: commitBuffer: invalid argument (cannot encode character '\206') -- {-# NOINLINE registerTimeout #-} registerTimeout :: Manager -> Int -> TimeoutCallback -> IO TimeoutKey @@ -878,7 +880,9 @@ registerTimeout mgr@Manager{..} uSrelTime cb = do -- This has no effect if the timeout has already fired. -- -- Be careful not to exceed @maxBound :: Int@, which on 32-bit machines is only --- 2147483647 μs, less than 36 minutes. +-- 2147483647 microseconds, less than 36 minutes. +-- We can not use here utf/greek symbol due of: +-- _build/stage1/libraries/ghc-internal/build/GHC/Internal/Event/Windows.hs: commitBuffer: invalid argument (cannot encode character '\206') -- updateTimeout :: Manager -> TimeoutKey -> Seconds -> IO () updateTimeout mgr (TK key) relTime = do @@ -980,7 +984,7 @@ step maxDelay mgr@Manager{..} = do -- There are some unusual edge cases you need to deal with. The -- GetQueuedCompletionStatus function blocks a thread until there's -- work for it to do. Based on the return value, the number of bytes - -- and the overlapped structure, there’s a lot of possible "reasons" + -- and the overlapped structure, there's a lot of possible "reasons" -- for the function to have returned. Deciphering all the possible -- cases: -- ===================================== m4/find_merge_objects.m4 ===================================== @@ -33,6 +33,8 @@ AC_DEFUN([FIND_MERGE_OBJECTS],[ fi + # Note [Empty MergeObjsCmd] + # ~~~~~~~~~~~~~~~~~~~~~~~~~ # If MergeObjsCmd="" then we assume that the user is explicitly telling us that # they do not want to configure the MergeObjsCmd, this is particularly important for # the bundled windows toolchain. ===================================== m4/fp_setup_windows_toolchain.m4 ===================================== @@ -85,6 +85,8 @@ AC_DEFUN([FP_SETUP_WINDOWS_TOOLCHAIN],[ mingw_prefix="$1" mingw_install_prefix="$2" + # Note [Windows Toolchain Standard Library Options] + # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # Our Windows toolchain is based around Clang and LLD. We use compiler-rt # for the runtime, libc++ and libc++abi for the C++ standard library # implementation, and libunwind for C++ unwinding. ===================================== testsuite/tests/typecheck/should_fail/T26004.hs ===================================== @@ -0,0 +1,14 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NoMonoLocalBinds #-} + +module T26004 where + +data T a where + T1 :: T Bool + T2 :: T a + +-- This funcion should be rejected: +-- we should not infer a non-principal type for `f` +f w e = case e of + T1 -> let y = not w in False + T2 -> True ===================================== testsuite/tests/typecheck/should_fail/T26004.stderr ===================================== @@ -0,0 +1,17 @@ + +T26004.hs:13:21: error: [GHC-25897] + • Could not deduce ‘p ~ Bool’ + from the context: a ~ Bool + bound by a pattern with constructor: T1 :: T Bool, + in a case alternative + at T26004.hs:13:3-4 + ‘p’ is a rigid type variable bound by + the inferred type of f :: p -> T a -> Bool + at T26004.hs:(12,1)-(14,12) + • In the first argument of ‘not’, namely ‘w’ + In the expression: not w + In an equation for ‘y’: y = not w + • Relevant bindings include + w :: p (bound at T26004.hs:12:3) + f :: p -> T a -> Bool (bound at T26004.hs:12:1) + Suggested fix: Consider giving ‘f’ a type signature ===================================== testsuite/tests/typecheck/should_fail/T7453.stderr ===================================== @@ -1,8 +1,5 @@ - -T7453.hs:9:15: error: [GHC-25897] - • Couldn't match type ‘t’ with ‘p’ - Expected: Id t - Actual: Id p +T7453.hs:10:30: error: [GHC-25897] + • Couldn't match expected type ‘t’ with actual type ‘p’ ‘t’ is a rigid type variable bound by the type signature for: z :: forall t. Id t @@ -10,29 +7,17 @@ T7453.hs:9:15: error: [GHC-25897] ‘p’ is a rigid type variable bound by the inferred type of cast1 :: p -> a at T7453.hs:(7,1)-(10,30) - • In the expression: aux - In an equation for ‘z’: - z = aux - where - aux = Id v - In an equation for ‘cast1’: - cast1 v - = runId z - where - z :: Id t - z = aux - where - aux = Id v + • In the first argument of ‘Id’, namely ‘v’ + In the expression: Id v + In an equation for ‘aux’: aux = Id v • Relevant bindings include - aux :: Id p (bound at T7453.hs:10:21) + aux :: Id t (bound at T7453.hs:10:21) z :: Id t (bound at T7453.hs:9:11) v :: p (bound at T7453.hs:7:7) cast1 :: p -> a (bound at T7453.hs:7:1) -T7453.hs:15:15: error: [GHC-25897] - • Couldn't match type ‘t1’ with ‘p’ - Expected: () -> t1 - Actual: () -> p +T7453.hs:16:33: error: [GHC-25897] + • Couldn't match expected type ‘t1’ with actual type ‘p’ ‘t1’ is a rigid type variable bound by the type signature for: z :: forall t1. () -> t1 @@ -40,21 +25,11 @@ T7453.hs:15:15: error: [GHC-25897] ‘p’ is a rigid type variable bound by the inferred type of cast2 :: p -> t at T7453.hs:(13,1)-(16,33) - • In the expression: aux - In an equation for ‘z’: - z = aux - where - aux = const v - In an equation for ‘cast2’: - cast2 v - = z () - where - z :: () -> t - z = aux - where - aux = const v + • In the first argument of ‘const’, namely ‘v’ + In the expression: const v + In an equation for ‘aux’: aux = const v • Relevant bindings include - aux :: forall {b}. b -> p (bound at T7453.hs:16:21) + aux :: b -> t1 (bound at T7453.hs:16:21) z :: () -> t1 (bound at T7453.hs:15:11) v :: p (bound at T7453.hs:13:7) cast2 :: p -> t (bound at T7453.hs:13:1) @@ -86,3 +61,4 @@ T7453.hs:21:15: error: [GHC-25897] z :: t1 (bound at T7453.hs:21:11) v :: p (bound at T7453.hs:19:7) cast3 :: p -> t (bound at T7453.hs:19:1) + ===================================== testsuite/tests/typecheck/should_fail/all.T ===================================== @@ -735,3 +735,4 @@ test('T24938', normal, compile_fail, ['']) test('T25325', normal, compile_fail, ['']) test('T25004', normal, compile_fail, ['']) test('T25004k', normal, compile_fail, ['']) +test('T26004', normal, compile_fail, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4631de44afcc6e9ee839623a61c105… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4631de44afcc6e9ee839623a61c105… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/az/ghc-cpp] Process comments in CPP directives
by Alan Zimmerman (＠alanz) 06 May '25

06 May '25

Alan Zimmerman pushed to branch wip/az/ghc-cpp at Glasgow Haskell Compiler / GHC Commits: 4acbeff0 by Alan Zimmerman at 2025-05-06T22:42:27+01:00 Process comments in CPP directives - - - - - 9 changed files: - compiler/GHC/Parser/PreProcess/Lexer.x - compiler/GHC/Parser/PreProcess/ParsePP.hs - compiler/GHC/Parser/PreProcess/ParserM.hs - testsuite/tests/ghc-cpp/GhcCpp01.hs - testsuite/tests/ghc-cpp/GhcCpp01.stderr - utils/check-cpp/Lexer.x - utils/check-cpp/Main.hs - utils/check-cpp/ParsePP.hs - utils/check-cpp/ParserM.hs Changes: ===================================== compiler/GHC/Parser/PreProcess/Lexer.x ===================================== @@ -22,6 +22,8 @@ words :- <0> $white+ ; --------------------------------------- + <0> "//" .* { mkTv TComment } + <0> "/*" .* "*/" { mkTv TComment } <0> "{" { mkTv TOpenBrace } <0> "}" { mkTv TCloseBrace } <0> "[" { mkTv TOpenBracket } ===================================== compiler/GHC/Parser/PreProcess/ParsePP.hs ===================================== @@ -27,7 +27,7 @@ parseDirective s = case cppLex True s of Left e -> Left e Right toks -> - case toks of + case map deComment toks of (THash "#" : TIdentifier "define" : ts) -> cppDefine ts (THash "#" : TIdentifier "undef" : ts) -> Right $ cppUndef (map t_str ts) (THash "#" : TIdentifier "include" : ts) -> Right $ cppInclude (map t_str ts) @@ -112,6 +112,13 @@ cppLex sd s = case lexCppTokenStream s (init_state {scanning_directive = sd}) of Left err -> Left err Right (_inp, _st, toks) -> Right toks +-- Each comment is replaced with a space +-- https://timsong-cpp.github.io/cppwp/n4140/lex#phases-1.3 +deComment :: Token -> Token +deComment (TComment _) = TComment " " +deComment t = t + + -- --------------------------------------------------------------------- doATest :: String -> Either String CppDirective ===================================== compiler/GHC/Parser/PreProcess/ParserM.hs ===================================== @@ -91,6 +91,8 @@ init_state = data Token = TEOF {t_str :: String} + | -- https://timsong-cpp.github.io/cppwp/n4140/lex.comment + TComment {t_str :: String} | TIdentifier {t_str :: String} | TIdentifierLParen {t_str :: String} | TInteger {t_str :: String} ===================================== testsuite/tests/ghc-cpp/GhcCpp01.hs ===================================== @@ -18,13 +18,13 @@ y = 1 #endif #undef FOO -#ifdef FOO +#ifdef FOO /* Check for FOO */ complete junk! #endif -- nested undef #define AA -#if 0 +#if /* hard code for now */ 0 #undef AA #endif ===================================== testsuite/tests/ghc-cpp/GhcCpp01.stderr ===================================== @@ -217,13 +217,13 @@ - |#endif - |#undef FOO -- |#ifdef FOO +- |#ifdef FOO /* Check for FOO */ - |complete junk! - |#endif - |-- nested undef - |#define AA -- |#if 0 +- |#if /* hard code for now */ 0 - |#undef AA - |#endif ===================================== utils/check-cpp/Lexer.x ===================================== @@ -21,6 +21,8 @@ words :- <0> $white+ ; --------------------------------------- + <0> "//" .* { mkTv TComment } + <0> "/*" .* "*/" { mkTv TComment } <0> "{" { mkTv TOpenBrace } <0> "}" { mkTv TCloseBrace } <0> "[" { mkTv TOpenBracket } ===================================== utils/check-cpp/Main.hs ===================================== @@ -838,3 +838,18 @@ t36 = do , "#endif" , "" ] + +t37 :: IO () +t37 = do + dump + [ "{-# LANGUAGE GHC_CPP #-}" + , "module Example14 where" + , "" + , "foo =" + , "#if 1 /* and a comment */" + , " 'a'" + , "#else" + , " 'b'" + , "#endif" + , "" + ] ===================================== utils/check-cpp/ParsePP.hs ===================================== @@ -27,7 +27,7 @@ parseDirective s = case cppLex True s of Left e -> Left e Right toks -> - case toks of + case map deComment toks of (THash "#" : TIdentifier "define" : ts) -> cppDefine ts (THash "#" : TIdentifier "undef" : ts) -> Right $ cppUndef (map t_str ts) (THash "#" : TIdentifier "include" : ts) -> Right $ cppInclude (map t_str ts) @@ -112,6 +112,13 @@ cppLex sd s = case lexCppTokenStream s (init_state {scanning_directive = sd}) of Left err -> Left err Right (_inp, _st, toks) -> Right toks +-- Each comment is replaced with a space +-- https://timsong-cpp.github.io/cppwp/n4140/lex#phases-1.3 +deComment :: Token -> Token +deComment (TComment _) = TComment " " +deComment t = t + + -- --------------------------------------------------------------------- doATest :: String -> Either String CppDirective ===================================== utils/check-cpp/ParserM.hs ===================================== @@ -91,6 +91,8 @@ init_state = data Token = TEOF {t_str :: String} + | -- https://timsong-cpp.github.io/cppwp/n4140/lex.comment + TComment {t_str :: String} | TIdentifier {t_str :: String} | TIdentifierLParen {t_str :: String} | TInteger {t_str :: String} View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4acbeff0a067efe77bbb040baca3c1d… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4acbeff0a067efe77bbb040baca3c1d… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26003] Import wibble
by Simon Peyton Jones (＠simonpj) 06 May '25

06 May '25

Simon Peyton Jones pushed to branch wip/T26003 at Glasgow Haskell Compiler / GHC Commits: 8c87cacf by Simon Peyton Jones at 2025-05-06T22:01:41+01:00 Import wibble - - - - - 1 changed file: - compiler/GHC/Tc/Utils/TcMType.hs Changes: ===================================== compiler/GHC/Tc/Utils/TcMType.hs ===================================== @@ -110,7 +110,7 @@ import {-# SOURCE #-} GHC.Tc.Utils.Unify( unifyInvisibleType, tcSubMult ) import GHC.Tc.Types.Origin import GHC.Tc.Types.Constraint import GHC.Tc.Types.Evidence -import GHC.Tc.Types.CtLoc( CtLoc, ctLocOrigin ) +import GHC.Tc.Types.CtLoc( CtLoc ) import GHC.Tc.Utils.Monad -- TcType, amongst others import GHC.Tc.Utils.TcType import GHC.Tc.Errors.Types View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8c87cacff716efeaf6dba82fc749c37… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8c87cacff716efeaf6dba82fc749c37… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/az/ghc-cpp] 119 commits: Support for ARM64 Windows (LLVM-enabled) (fixes #24603)
by Alan Zimmerman (＠alanz) 06 May '25

06 May '25

Alan Zimmerman pushed to branch wip/az/ghc-cpp at Glasgow Haskell Compiler / GHC Commits: 9995c2b7 by Serge S. Gulin at 2025-05-04T17:13:36+03:00 Support for ARM64 Windows (LLVM-enabled) (fixes #24603) 1. Add Windows AArch64 cross-compilation support via CI jobs Introduce new CI configurations for cross-compiling to Windows ARM64 using Debian12Wine, FEX, and MSYS2. Configure toolchain variables for LLVM MinGW and Wine emulation in CI pipelines. 2. Adjust compiler and RTS for AArch64 Windows compatibility Reserve register `x18` on Windows and Darwin platforms in AArch64 codegen. Handle Windows-specific relocations and data sections in AArch64 assembler. Update PEi386 linker to recognize ARM64 binaries and support exception handling. Adjust LLVM target definitions and data layouts for new architectures. Update `ghc-toolchain` and build scripts to handle `TablesNextToCode` on Windows ARM64. 3. Enhance CI scripts and stability Modify `ci.sh` to handle mingw cross-targets, fixing GHC executable paths and test execution. Use `diff -w` in tests to ignore whitespace differences, improving cross-platform consistency. 4. Refactor and clean up code Remove redundant imports in hello.hs test. Improve error messages and checks for unsupported configurations in the driver. Add `EXDEV` error code to `errno.js`. Add async/sync flags to IO logs at `base.js`. Improve POSIX compatibility for file close at `base.js`: decrease indeterminism for mixed cases of async and sync code. 5. Update dependencies: `Cabal`, `Win32`, `directory`, `process`, `haskeline`, and `unix`. submodule Co-authored-by: Cheng Shao <terrorjack(a)type.dance> Co-authored-by: Dmitrii Egorov <egorov.d.i(a)icloud.com> Co-authored-by: Andrei Borzenkov <root(a)sandwitch.dev> - - - - - 50fa8165 by Javran Cheng at 2025-05-05T05:55:39-04:00 Suppress unused do-binding if discarded variable is Any or ZonkAny. Consider example (#25895): > do { forever (return ()); blah } where `forever :: forall a b. IO a -> IO b`. Nothing constrains `b`, so it will be instantiates with `Any` or `ZonkAny`. But we certainly don't want to complain about a discarded do-binding. Fixes #25895 - - - - - e46c6b18 by Rodrigo Mesquita at 2025-05-06T09:01:57-04:00 Refactor mkTopLevImportedEnv out of mkTopLevEnv This makes the code clearer and allows the top-level import context to be fetched directly from the HomeModInfo through the API (e.g. useful for the debugger). - - - - - 0ce0d263 by Rodrigo Mesquita at 2025-05-06T09:01:57-04:00 Export sizeOccEnv from GHC.Types.Name.Occurrence Counts the number of OccNames in an OccEnv - - - - - 165f98d8 by Simon Peyton Jones at 2025-05-06T09:02:39-04:00 Fix a bad untouchability bug im simplifyInfer This patch addresses #26004. The root cause was that simplifyInfer was willing to unify variables "far out". The fix, in runTcSWithEvBinds', is to initialise the inert set given-eq level with the current level. See (TGE6) in Note [Tracking Given equalities] in GHC.Tc.Solver.InertSet Two loosely related refactors: * Refactored approximateWCX to return just the free type variables of the un-quantified constraints. That avoids duplication of work (these free vars are needed in simplifyInfer) and makes it clearer that the constraints themselves are irrelevant. * A little local refactor of TcSMode, which reduces the number of parameters to runTcSWithEvBinds - - - - - 4bedc089 by Alan Zimmerman at 2025-05-06T18:07:57+01:00 GHC-CPP: first rough proof of concept Processes #define FOO #ifdef FOO x = 1 #endif Into [ITcppIgnored [L loc ITcppDefine] ,ITcppIgnored [L loc ITcppIfdef] ,ITvarid "x" ,ITequal ,ITinteger (IL {il_text = SourceText "1", il_neg = False, il_value = 1}) ,ITcppIgnored [L loc ITcppEndif] ,ITeof] In time, ITcppIgnored will be pushed into a comment - - - - - 58ef415b by Alan Zimmerman at 2025-05-06T18:07:57+01:00 Tidy up before re-visiting the continuation mechanic - - - - - 638a6fc3 by Alan Zimmerman at 2025-05-06T18:07:57+01:00 Switch preprocessor to continuation passing style Proof of concept, needs tidying up - - - - - cd688d33 by Alan Zimmerman at 2025-05-06T18:07:57+01:00 Small cleanup - - - - - 6a924b61 by Alan Zimmerman at 2025-05-06T18:07:57+01:00 Get rid of some cruft - - - - - 0ae29cce by Alan Zimmerman at 2025-05-06T18:07:58+01:00 Starting to integrate. Need to get the pragma recognised and set - - - - - 40767a46 by Alan Zimmerman at 2025-05-06T18:07:58+01:00 Make cppTokens extend to end of line, and process CPP comments - - - - - e5c0365b by Alan Zimmerman at 2025-05-06T18:07:58+01:00 Remove unused ITcppDefined - - - - - aa1b2743 by Alan Zimmerman at 2025-05-06T18:07:58+01:00 Allow spaces between # and keyword for preprocessor directive - - - - - 4116edcd by Alan Zimmerman at 2025-05-06T18:07:58+01:00 Process CPP continuation lines They are emited as separate ITcppContinue tokens. Perhaps the processing should be more like a comment, and keep on going to the end. BUT, the last line needs to be slurped as a whole. - - - - - 1927c7fb by Alan Zimmerman at 2025-05-06T18:07:58+01:00 Accumulate CPP continuations, process when ready Can be simplified further, we only need one CPP token - - - - - 163c0f61 by Alan Zimmerman at 2025-05-06T18:07:58+01:00 Simplify Lexer interface. Only ITcpp We transfer directive lines through it, then parse them from scratch in the preprocessor. - - - - - 38c83ad6 by Alan Zimmerman at 2025-05-06T18:07:58+01:00 Deal with directive on last line, with no trailing \n - - - - - 37b0f683 by Alan Zimmerman at 2025-05-06T18:07:58+01:00 Start parsing and processing the directives - - - - - da250161 by Alan Zimmerman at 2025-05-06T18:07:58+01:00 Prepare for processing include files - - - - - cae69ced by Alan Zimmerman at 2025-05-06T18:07:58+01:00 Move PpState into PreProcess And initParserState, initPragState too - - - - - d84e8056 by Alan Zimmerman at 2025-05-06T18:07:58+01:00 Process nested include files Also move PpState out of Lexer.x, so it is easy to evolve it in a ghci session, loading utils/check-cpp/Main.hs - - - - - 6c92a7f9 by Alan Zimmerman at 2025-05-06T18:07:58+01:00 Split into separate files - - - - - 7cd10d14 by Alan Zimmerman at 2025-05-06T18:07:58+01:00 Starting on expression parser. But it hangs. Time for Text.Parsec.Expr - - - - - bbd04cae by Alan Zimmerman at 2025-05-06T18:07:58+01:00 Start integrating the ghc-cpp work From https://github.com/alanz/ghc-cpp - - - - - 0eb187a4 by Alan Zimmerman at 2025-05-06T18:07:58+01:00 WIP - - - - - 940f5b55 by Alan Zimmerman at 2025-05-06T18:07:58+01:00 Fixup after rebase - - - - - d0a3d584 by Alan Zimmerman at 2025-05-06T18:07:59+01:00 WIP - - - - - efa9fe0a by Alan Zimmerman at 2025-05-06T18:07:59+01:00 Fixup after rebase, including all tests pass - - - - - fdb1ea18 by Alan Zimmerman at 2025-05-06T18:07:59+01:00 Change pragma usage to GHC_CPP from GhcCPP - - - - - 934145eb by Alan Zimmerman at 2025-05-06T18:07:59+01:00 Some comments - - - - - 540fade6 by Alan Zimmerman at 2025-05-06T18:07:59+01:00 Reformat - - - - - 12c8fab6 by Alan Zimmerman at 2025-05-06T18:07:59+01:00 Delete unused file - - - - - 27061919 by Alan Zimmerman at 2025-05-06T18:07:59+01:00 Rename module Parse to ParsePP - - - - - caf7e9bf by Alan Zimmerman at 2025-05-06T18:07:59+01:00 Clarify naming in the parser - - - - - fde7bd48 by Alan Zimmerman at 2025-05-06T18:07:59+01:00 WIP. Switching to alex/happy to be able to work in-tree Since Parsec is not available - - - - - 56fa02d5 by Alan Zimmerman at 2025-05-06T18:07:59+01:00 Layering is now correct - GHC lexer, emits CPP tokens - accumulated in Preprocessor state - Lexed by CPP lexer, CPP command extracted, tokens concated with spaces (to get rid of token pasting via comments) - if directive lexed and parsed by CPP lexer/parser, and evaluated - - - - - 69dac201 by Alan Zimmerman at 2025-05-06T18:07:59+01:00 First example working Loading Example1.hs into ghci, getting the right results ``` {-# LANGUAGE GHC_CPP #-} module Example1 where y = 3 x = "hello" "bye now" foo = putStrLn x ``` - - - - - 7a654916 by Alan Zimmerman at 2025-05-06T18:07:59+01:00 Rebase, and all tests pass except whitespace for generated parser - - - - - 0dcd84c5 by Alan Zimmerman at 2025-05-06T18:07:59+01:00 More plumbing. Ready for testing tomorrow. - - - - - f358cb54 by Alan Zimmerman at 2025-05-06T18:07:59+01:00 Proress. Renamed module State from Types And at first blush it seems to handle preprocessor scopes properly. - - - - - d0d5c285 by Alan Zimmerman at 2025-05-06T18:07:59+01:00 Insert basic GHC version macros into parser __GLASGOW_HASKELL__ __GLASGOW_HASKELL_FULL_VERSION__ __GLASGOW_HASKELL_PATCHLEVEL1__ __GLASGOW_HASKELL_PATCHLEVEL2__ - - - - - b7925c05 by Alan Zimmerman at 2025-05-06T18:07:59+01:00 Re-sync check-cpp for easy ghci work - - - - - 9d514f90 by Alan Zimmerman at 2025-05-06T18:07:59+01:00 Get rid of warnings - - - - - 0b5f458f by Alan Zimmerman at 2025-05-06T18:07:59+01:00 Rework macro processing, in check-cpp Macros kept at the top level, looked up via name, multiple arity versions per name can be stored - - - - - 009563f2 by Alan Zimmerman at 2025-05-06T18:07:59+01:00 WIP. Can crack arguments for #define Next step it to crack out args in an expansion - - - - - 143cf978 by Alan Zimmerman at 2025-05-06T18:07:59+01:00 WIP on arg parsing. - - - - - ab01dc26 by Alan Zimmerman at 2025-05-06T18:08:00+01:00 Progress. Still screwing up nested parens. - - - - - 23ff567d by Alan Zimmerman at 2025-05-06T18:08:00+01:00 Seems to work, but has redundant code - - - - - 8f91f5c3 by Alan Zimmerman at 2025-05-06T18:08:00+01:00 Remove redundant code - - - - - b2d68f7d by Alan Zimmerman at 2025-05-06T18:08:00+01:00 Reformat - - - - - b96ece80 by Alan Zimmerman at 2025-05-06T18:08:00+01:00 Expand args, single pass Still need to repeat until fixpoint - - - - - 28b5caeb by Alan Zimmerman at 2025-05-06T18:08:00+01:00 Fixed point expansion - - - - - 48e98b88 by Alan Zimmerman at 2025-05-06T18:08:00+01:00 Sync the playground to compiler - - - - - 7bd8b7dc by Alan Zimmerman at 2025-05-06T18:08:00+01:00 Working on dumping the GHC_CPP result But We need to keep the BufSpan in a comment - - - - - 9e9bb4d1 by Alan Zimmerman at 2025-05-06T18:08:00+01:00 Keep BufSpan in queued comments in GHC.Parser.Lexer - - - - - 1c269760 by Alan Zimmerman at 2025-05-06T18:08:00+01:00 Getting close to being able to print the combined tokens showing what is in and what is out - - - - - 4d8a2f36 by Alan Zimmerman at 2025-05-06T18:08:00+01:00 First implementation of dumpGhcCpp. Example output First dumps all macros in the state, then the source, showing which lines are in and which are out ------------------------------ - |#define FOO(A,B) A + B - |#define FOO(A,B,C) A + B + C - |#if FOO(1,FOO(3,4)) == 8 - |-- a comment |x = 1 - |#else - |x = 5 - |#endif - - - - - 18eb7796 by Alan Zimmerman at 2025-05-06T18:08:00+01:00 Clean up a bit - - - - - fc20f4ba by Alan Zimmerman at 2025-05-06T18:08:00+01:00 Add -ddump-ghc-cpp option and a test based on it - - - - - a82da455 by Alan Zimmerman at 2025-05-06T18:08:00+01:00 Restore Lexer.x rules, we need them for continuation lines - - - - - 912eaf11 by Alan Zimmerman at 2025-05-06T18:08:00+01:00 Lexer.x: trying to sort out the span for continuations - We need to match on \n at the end of the line - We cannot simply back up for it - - - - - c7000536 by Alan Zimmerman at 2025-05-06T18:08:00+01:00 Inserts predefined macros. But does not dump properly Because the cpp tokens have a trailing newline - - - - - ad1e7f9e by Alan Zimmerman at 2025-05-06T18:08:00+01:00 Remove unnecessary LExer rules We *need* the ones that explicitly match to the end of the line. - - - - - f4ea076a by Alan Zimmerman at 2025-05-06T18:08:00+01:00 Generate correct span for ITcpp Dump now works, except we do not render trailing `\` for continuation lines. This is good enough for use in test output. - - - - - 8afb04b8 by Alan Zimmerman at 2025-05-06T18:08:00+01:00 Reduce duplication in lexer - - - - - 63398f1f by Alan Zimmerman at 2025-05-06T18:08:00+01:00 Tweaks - - - - - 1ece4cbe by Alan Zimmerman at 2025-05-06T18:08:00+01:00 Insert min_version predefined macros into state The mechanism now works. Still need to flesh out the full set. - - - - - 6df6abba by Alan Zimmerman at 2025-05-06T18:08:00+01:00 Trying my alternative pragma syntax. It works, but dumpGhcCpp is broken, I suspect from the ITcpp token span update. - - - - - d7b5d614 by Alan Zimmerman at 2025-05-06T18:08:00+01:00 Pragma extraction now works, with both CPP and GHC_CPP For the following {-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 913 {-# LANGUAGE GHC_CPP #-} #endif We will enable GHC_CPP only - - - - - 043b4500 by Alan Zimmerman at 2025-05-06T18:08:01+01:00 Remove some tracing - - - - - 1166580a by Alan Zimmerman at 2025-05-06T18:08:01+01:00 Fix test exes for changes - - - - - fec971d7 by Alan Zimmerman at 2025-05-06T18:08:01+01:00 For GHC_CPP tests, normalise config-time-based macros - - - - - cbcf2a7f by Alan Zimmerman at 2025-05-06T18:08:01+01:00 WIP - - - - - bd7584c6 by Alan Zimmerman at 2025-05-06T18:08:01+01:00 WIP again. What is wrong? - - - - - c504b628 by Alan Zimmerman at 2025-05-06T18:08:01+01:00 Revert to dynflags for normal not pragma lexing - - - - - 0b66a723 by Alan Zimmerman at 2025-05-06T18:08:01+01:00 Working on getting check-exact to work properly - - - - - 7305118a by Alan Zimmerman at 2025-05-06T18:08:01+01:00 Passes CppCommentPlacement test - - - - - 4659e186 by Alan Zimmerman at 2025-05-06T18:08:01+01:00 Starting on exact printing with GHC_CPP While overriding normal CPP - - - - - 546a4023 by Alan Zimmerman at 2025-05-06T18:08:01+01:00 Correctly store CPP ignored tokens as comments By populating the lexeme string in it, based on the bufpos - - - - - 4bf8249b by Alan Zimmerman at 2025-05-06T18:08:01+01:00 WIP - - - - - 1fd04489 by Alan Zimmerman at 2025-05-06T18:08:01+01:00 Simplifying - - - - - ebaea51c by Alan Zimmerman at 2025-05-06T18:08:01+01:00 Update the active state logic - - - - - 55af33ef by Alan Zimmerman at 2025-05-06T18:08:01+01:00 Work the new logic into the mainline code - - - - - 761dfa38 by Alan Zimmerman at 2025-05-06T18:08:01+01:00 Process `defined` operator - - - - - c4930905 by Alan Zimmerman at 2025-05-06T18:08:01+01:00 Manage lexer state while skipping tokens There is very intricate layout-related state used when lexing. If a CPP directive blanks out some tokens, store this state when the blanking starts, and restore it when they are no longer being blanked. - - - - - 2cc75317 by Alan Zimmerman at 2025-05-06T18:08:01+01:00 Track the last token buffer index, for ITCppIgnored We need to attach the source being skipped in an ITCppIgnored token. We cannot simply use its BufSpan as an index into the underlying StringBuffer as it counts unicode chars, not bytes. So we update the lexer state to store the starting StringBuffer location for the last token, and use the already-stored length to extract the correct portion of the StringBuffer being parsed. - - - - - 567d16ec by Alan Zimmerman at 2025-05-06T18:08:01+01:00 Process the ! operator in GHC_CPP expressions - - - - - ff29b658 by Alan Zimmerman at 2025-05-06T18:08:01+01:00 Predefine a constant when GHC_CPP is being used. - - - - - 0d9b19fc by Alan Zimmerman at 2025-05-06T18:08:01+01:00 WIP - - - - - 79cfff97 by Alan Zimmerman at 2025-05-06T18:08:01+01:00 Skip lines directly in the lexer when required - - - - - 2509eea9 by Alan Zimmerman at 2025-05-06T18:08:01+01:00 Properly manage location when accepting tokens again - - - - - bbb1b32d by Alan Zimmerman at 2025-05-06T18:08:01+01:00 Seems to be working now, for Example9 - - - - - dab0aec6 by Alan Zimmerman at 2025-05-06T18:08:01+01:00 Remove tracing - - - - - d979e506 by Alan Zimmerman at 2025-05-06T18:08:02+01:00 Fix parsing '*' in block comments Instead of replacing them with '-' - - - - - 14a22493 by Alan Zimmerman at 2025-05-06T18:08:02+01:00 Keep the trailing backslash in a ITcpp token - - - - - 716c4ba1 by Alan Zimmerman at 2025-05-06T18:08:02+01:00 Deal with only enabling one section of a group. A group is an instance of a conditional introduced by #if/#ifdef/#ifndef, and ending at the final #endif, including intermediate #elsif sections - - - - - c6201bdd by Alan Zimmerman at 2025-05-06T18:08:02+01:00 Replace remaining identifiers with 0 when evaluating As per the spec - - - - - 3015e79a by Alan Zimmerman at 2025-05-06T18:08:02+01:00 Snapshot before rebase - - - - - 4f215d1d by Alan Zimmerman at 2025-05-06T18:08:02+01:00 Skip non-processed lines starting with # - - - - - 32888d20 by Alan Zimmerman at 2025-05-06T18:08:02+01:00 Export generateMacros so we can use it in ghc-exactprint - - - - - f047e6ca by Alan Zimmerman at 2025-05-06T18:08:02+01:00 Fix rebase - - - - - 0632f64b by Alan Zimmerman at 2025-05-06T18:08:02+01:00 Expose initParserStateWithMacrosString - - - - - f57786ae by Alan Zimmerman at 2025-05-06T18:08:02+01:00 Fix buggy lexer cppSkip It was skipping all lines, not just ones prefixed by # - - - - - b010c868 by Alan Zimmerman at 2025-05-06T18:08:02+01:00 Fix evaluation of && to use the correct operator - - - - - d31d438d by Alan Zimmerman at 2025-05-06T18:08:02+01:00 Deal with closing #-} at the start of a line - - - - - 56a08b1c by Alan Zimmerman at 2025-05-06T18:08:02+01:00 Add the MIN_VERSION_GLASGOW_HASKELL predefined macro - - - - - d9562b7a by Alan Zimmerman at 2025-05-06T18:08:02+01:00 Include MIN_VERSION_GLASGOW_HASKELL in GhcCpp01.stderr - - - - - a215a5ce by Alan Zimmerman at 2025-05-06T18:08:02+01:00 Use a strict map for macro defines - - - - - d645f573 by Alan Zimmerman at 2025-05-06T18:08:02+01:00 Process TIdentifierLParen Which only matters at the start of #define - - - - - 7da6441a by Alan Zimmerman at 2025-05-06T18:08:02+01:00 Do not provide TIdentifierLParen paren twice - - - - - 2042c1b0 by Alan Zimmerman at 2025-05-06T18:08:02+01:00 Handle whitespace between identifier and '(' for directive only - - - - - 33fec4ca by Alan Zimmerman at 2025-05-06T18:08:02+01:00 Expose some Lexer bitmap manipulation helpers - - - - - d9b4cf25 by Alan Zimmerman at 2025-05-06T18:08:02+01:00 Deal with line pragmas as tokens Blows up for dumpGhcCpp though - - - - - 079265e4 by Alan Zimmerman at 2025-05-06T18:08:02+01:00 Allow strings delimited by a single quote too - - - - - 0f7bad13 by Alan Zimmerman at 2025-05-06T18:08:02+01:00 Allow leading whitespace on cpp directives As per https://timsong-cpp.github.io/cppwp/n4140/cpp#1 - - - - - d8af2caf by Alan Zimmerman at 2025-05-06T18:08:02+01:00 Implement GHC_CPP undef - - - - - 9156970c by Alan Zimmerman at 2025-05-06T18:08:02+01:00 Sort out expansion of no-arg macros, in a context with args And make the expansion bottom out, in the case of recursion - - - - - 855c1461 by Alan Zimmerman at 2025-05-06T21:52:14+01:00 Fix GhcCpp01 test The LINE pragma stuff works in ghc-exactprint when specifically setting flag to emit ITline_pragma tokens - - - - - 129 changed files: - .gitlab-ci.yml - .gitlab/ci.sh - .gitlab/generate-ci/gen_ci.hs - .gitlab/hello.hs - .gitlab/jobs.yaml - compiler/CodeGen.Platform.h - compiler/GHC.hs - compiler/GHC/Builtin/Types.hs - compiler/GHC/Cmm/Lexer.x - compiler/GHC/Cmm/Parser.y - compiler/GHC/Cmm/Parser/Monad.hs - compiler/GHC/CmmToAsm/AArch64/CodeGen.hs - compiler/GHC/CmmToAsm/AArch64/Instr.hs - compiler/GHC/CmmToAsm/AArch64/Ppr.hs - compiler/GHC/CmmToAsm/Reg/Linear/AArch64.hs - compiler/GHC/Driver/Backpack.hs - compiler/GHC/Driver/Config/Parser.hs - compiler/GHC/Driver/Downsweep.hs - compiler/GHC/Driver/Flags.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Driver/Pipeline/Execute.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/Pmc/Solver/Types.hs - compiler/GHC/Parser.hs-boot - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/HaddockLex.x - compiler/GHC/Parser/Header.hs - compiler/GHC/Parser/Lexer.x - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Parser/PostProcess/Haddock.hs - + compiler/GHC/Parser/PreProcess.hs - + compiler/GHC/Parser/PreProcess/Eval.hs - + compiler/GHC/Parser/PreProcess/Lexer.x - + compiler/GHC/Parser/PreProcess/Macro.hs - + compiler/GHC/Parser/PreProcess/ParsePP.hs - + compiler/GHC/Parser/PreProcess/Parser.y - + compiler/GHC/Parser/PreProcess/ParserM.hs - + compiler/GHC/Parser/PreProcess/State.hs - compiler/GHC/Parser/Utils.hs - compiler/GHC/Platform/Regs.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/SysTools/Cpp.hs - compiler/GHC/Tc/Solver.hs - compiler/GHC/Tc/Solver/InertSet.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Types/Constraint.hs - compiler/GHC/Tc/Utils/TcType.hs - compiler/GHC/Types/Name/Occurrence.hs - compiler/ghc.cabal.in - docs/users_guide/debugging.rst - ghc/GHCi/UI.hs - hadrian/src/Oracles/Setting.hs - hadrian/src/Rules/BinaryDist.hs - hadrian/src/Rules/SourceDist.hs - hadrian/stack.yaml.lock - libraries/Cabal - libraries/Win32 - libraries/base/src/System/CPUTime/Windows.hsc - libraries/base/tests/perf/encodingAllocations.hs - libraries/directory - libraries/ghc-internal/jsbits/base.js - libraries/ghc-internal/jsbits/errno.js - libraries/ghc-internal/src/GHC/Internal/LanguageExtensions.hs - libraries/ghc-internal/src/GHC/Internal/System/Posix/Internals.hs - libraries/haskeline - libraries/process - libraries/unix - llvm-targets - m4/fp_cc_supports_target.m4 - m4/fptools_set_platform_vars.m4 - m4/ghc_tables_next_to_code.m4 - rts/StgCRun.c - rts/linker/PEi386.c - rts/win32/veh_excn.c - testsuite/tests/count-deps/CountDepsParser.stdout - testsuite/tests/driver/T4437.hs - testsuite/tests/ghc-api/T11579.hs - testsuite/tests/ghc-api/fixed-nodes/all.T - + testsuite/tests/ghc-cpp/GhcCpp01.hs - + testsuite/tests/ghc-cpp/GhcCpp01.stderr - + testsuite/tests/ghc-cpp/all.T - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/template-haskell-exports.stdout - + testsuite/tests/printer/CppCommentPlacement.hs - testsuite/tests/printer/T17697.stderr - + testsuite/tests/typecheck/should_fail/T26004.hs - + testsuite/tests/typecheck/should_fail/T26004.stderr - testsuite/tests/typecheck/should_fail/T7453.stderr - testsuite/tests/typecheck/should_fail/all.T - + utils/check-cpp/.ghci - + utils/check-cpp/.gitignore - + utils/check-cpp/Eval.hs - + utils/check-cpp/Example1.hs - + utils/check-cpp/Example10.hs - + utils/check-cpp/Example11.hs - + utils/check-cpp/Example12.hs - + utils/check-cpp/Example13.hs - + utils/check-cpp/Example2.hs - + utils/check-cpp/Example3.hs - + utils/check-cpp/Example4.hs - + utils/check-cpp/Example5.hs - + utils/check-cpp/Example6.hs - + utils/check-cpp/Example7.hs - + utils/check-cpp/Example8.hs - + utils/check-cpp/Example9.hs - + utils/check-cpp/Lexer.x - + utils/check-cpp/Macro.hs - + utils/check-cpp/Main.hs - + utils/check-cpp/ParsePP.hs - + utils/check-cpp/ParseSimulate.hs - + utils/check-cpp/Parser.y - + utils/check-cpp/ParserM.hs - + utils/check-cpp/PreProcess.hs - + utils/check-cpp/README.md - + utils/check-cpp/State.hs - + utils/check-cpp/run.sh - utils/check-exact/Main.hs - utils/check-exact/Parsers.hs - utils/check-exact/Preprocess.hs - utils/check-exact/Utils.hs - utils/ghc-toolchain/exe/Main.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs - utils/haddock/haddock-api/src/Haddock/Parser.hs - utils/haddock/haddock-api/src/Haddock/Types.hs - utils/hsc2hs - utils/llvm-targets/gen-data-layout.sh The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/da4937727ddded7261f0796b175140… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/da4937727ddded7261f0796b175140… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26003] 7 commits: Refactor mkTopLevImportedEnv out of mkTopLevEnv
by Simon Peyton Jones (＠simonpj) 06 May '25

06 May '25

Simon Peyton Jones pushed to branch wip/T26003 at Glasgow Haskell Compiler / GHC Commits: e46c6b18 by Rodrigo Mesquita at 2025-05-06T09:01:57-04:00 Refactor mkTopLevImportedEnv out of mkTopLevEnv This makes the code clearer and allows the top-level import context to be fetched directly from the HomeModInfo through the API (e.g. useful for the debugger). - - - - - 0ce0d263 by Rodrigo Mesquita at 2025-05-06T09:01:57-04:00 Export sizeOccEnv from GHC.Types.Name.Occurrence Counts the number of OccNames in an OccEnv - - - - - 165f98d8 by Simon Peyton Jones at 2025-05-06T09:02:39-04:00 Fix a bad untouchability bug im simplifyInfer This patch addresses #26004. The root cause was that simplifyInfer was willing to unify variables "far out". The fix, in runTcSWithEvBinds', is to initialise the inert set given-eq level with the current level. See (TGE6) in Note [Tracking Given equalities] in GHC.Tc.Solver.InertSet Two loosely related refactors: * Refactored approximateWCX to return just the free type variables of the un-quantified constraints. That avoids duplication of work (these free vars are needed in simplifyInfer) and makes it clearer that the constraints themselves are irrelevant. * A little local refactor of TcSMode, which reduces the number of parameters to runTcSWithEvBinds - - - - - 60da9ceb by Simon Peyton Jones at 2025-05-06T15:50:37+01:00 Wip on #26003 - - - - - a6eb78f7 by Simon Peyton Jones at 2025-05-06T15:50:37+01:00 Wibbles - - - - - e1cdf726 by Simon Peyton Jones at 2025-05-06T15:50:37+01:00 Further wibbles - - - - - 6cdf6491 by Simon Peyton Jones at 2025-05-06T15:50:37+01:00 Lots of tidying up - - - - - 41 changed files: - compiler/GHC/Core/Coercion.hs - compiler/GHC/Core/TyCo/Rep.hs - compiler/GHC/Core/TyCo/Tidy.hs - compiler/GHC/HsToCore/Pmc/Solver/Types.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Plugin.hs - compiler/GHC/Tc/Solver.hs - compiler/GHC/Tc/Solver/Default.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/Unify.hs - compiler/GHC/Tc/Zonk/TcType.hs - compiler/GHC/Types/Name/Occurrence.hs - testsuite/tests/dependent/should_fail/T11471.stderr - testsuite/tests/indexed-types/should_fail/T8227.stderr - testsuite/tests/indexed-types/should_fail/T9662.stderr - testsuite/tests/partial-sigs/should_fail/T14040a.stderr - testsuite/tests/partial-sigs/should_fail/T14584.stderr - testsuite/tests/polykinds/T14172.stderr - testsuite/tests/polykinds/T14846.stderr - testsuite/tests/rep-poly/RepPolyNPlusK.stderr - testsuite/tests/rep-poly/RepPolyRecordUpdate.stderr - testsuite/tests/rep-poly/RepPolyTuple.stderr - testsuite/tests/rep-poly/T13929.stderr - testsuite/tests/rep-poly/T14561b.stderr - testsuite/tests/rep-poly/T21906.stderr - testsuite/tests/rep-poly/UnliftedNewtypesCoerceFail.stderr - testsuite/tests/typecheck/no_skolem_info/T14040.stderr - testsuite/tests/typecheck/should_compile/T25266a.stderr - testsuite/tests/typecheck/should_fail/T16204c.stderr - + testsuite/tests/typecheck/should_fail/T26004.hs - + testsuite/tests/typecheck/should_fail/T26004.stderr - testsuite/tests/typecheck/should_fail/T7453.stderr - testsuite/tests/typecheck/should_fail/T7696.stderr - testsuite/tests/typecheck/should_fail/T8603.stderr - testsuite/tests/typecheck/should_fail/all.T - utils/hsc2hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c763d3a8dd1b069f1d8533a07649e8… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c763d3a8dd1b069f1d8533a07649e8… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Fix a bad untouchability bug im simplifyInfer
by Marge Bot (＠marge-bot) 06 May '25

06 May '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 165f98d8 by Simon Peyton Jones at 2025-05-06T09:02:39-04:00 Fix a bad untouchability bug im simplifyInfer This patch addresses #26004. The root cause was that simplifyInfer was willing to unify variables "far out". The fix, in runTcSWithEvBinds', is to initialise the inert set given-eq level with the current level. See (TGE6) in Note [Tracking Given equalities] in GHC.Tc.Solver.InertSet Two loosely related refactors: * Refactored approximateWCX to return just the free type variables of the un-quantified constraints. That avoids duplication of work (these free vars are needed in simplifyInfer) and makes it clearer that the constraints themselves are irrelevant. * A little local refactor of TcSMode, which reduces the number of parameters to runTcSWithEvBinds - - - - - 9 changed files: - compiler/GHC/HsToCore/Pmc/Solver/Types.hs - compiler/GHC/Tc/Solver.hs - compiler/GHC/Tc/Solver/InertSet.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Types/Constraint.hs - + testsuite/tests/typecheck/should_fail/T26004.hs - + testsuite/tests/typecheck/should_fail/T26004.stderr - testsuite/tests/typecheck/should_fail/T7453.stderr - testsuite/tests/typecheck/should_fail/all.T Changes: ===================================== compiler/GHC/HsToCore/Pmc/Solver/Types.hs ===================================== @@ -64,7 +64,7 @@ import GHC.Builtin.Names import GHC.Builtin.Types import GHC.Builtin.Types.Prim import GHC.Tc.Solver.InertSet (InertSet, emptyInert) -import GHC.Tc.Utils.TcType (isStringTy) +import GHC.Tc.Utils.TcType (isStringTy, topTcLevel) import GHC.Types.CompleteMatch import GHC.Types.SourceText (SourceText(..), mkFractionalLit, FractionalLit , fractionalLitFromRational @@ -129,7 +129,7 @@ instance Outputable TyState where ppr (TySt n inert) = ppr n <+> ppr inert initTyState :: TyState -initTyState = TySt 0 emptyInert +initTyState = TySt 0 (emptyInert topTcLevel) -- | The term oracle state. Stores 'VarInfo' for encountered 'Id's. These -- entries are possibly shared when we figure out that two variables must be ===================================== compiler/GHC/Tc/Solver.hs ===================================== @@ -915,21 +915,22 @@ simplifyInfer top_lvl rhs_tclvl infer_mode sigs name_taus wanteds ; let psig_theta = concatMap sig_inst_theta partial_sigs -- First do full-blown solving - -- NB: we must gather up all the bindings from doing - -- this solving; hence (runTcSWithEvBinds ev_binds_var). - -- And note that since there are nested implications, - -- calling solveWanteds will side-effect their evidence - -- bindings, so we can't just revert to the input - -- constraint. - + -- NB: we must gather up all the bindings from doing this solving; hence + -- (runTcSWithEvBinds ev_binds_var). And note that since there are + -- nested implications, calling solveWanteds will side-effect their + -- evidence bindings, so we can't just revert to the input constraint. + -- + -- See also Note [Inferring principal types] ; ev_binds_var <- TcM.newTcEvBinds ; psig_evs <- newWanteds AnnOrigin psig_theta ; wanted_transformed - <- setTcLevel rhs_tclvl $ - runTcSWithEvBinds ev_binds_var $ + <- runTcSWithEvBinds ev_binds_var $ + setTcLevelTcS rhs_tclvl $ solveWanteds (mkSimpleWC psig_evs `andWC` wanteds) + -- setLevelTcS: we do setLevel /inside/ the runTcS, so that + -- we initialise the InertSet inert_given_eq_lvl as far + -- out as possible, maximising oppportunities to unify -- psig_evs : see Note [Add signature contexts as wanteds] - -- See Note [Inferring principal types] -- Find quant_pred_candidates, the predicates that -- we'll consider quantifying over @@ -1430,13 +1431,15 @@ decideAndPromoteTyVars top_lvl rhs_tclvl infer_mode name_taus psigs wanted -- Step 1 of Note [decideAndPromoteTyVars] -- Get candidate constraints, decide which we can potentially quantify - (can_quant_cts, no_quant_cts) = approximateWCX wanted + -- The `no_quant_tvs` are free in constraints we can't quantify. + (can_quant_cts, no_quant_tvs) = approximateWCX False wanted can_quant = ctsPreds can_quant_cts - no_quant = ctsPreds no_quant_cts + can_quant_tvs = tyCoVarsOfTypes can_quant -- Step 2 of Note [decideAndPromoteTyVars] -- Apply the monomorphism restriction (post_mr_quant, mr_no_quant) = applyMR dflags infer_mode can_quant + mr_no_quant_tvs = tyCoVarsOfTypes mr_no_quant -- The co_var_tvs are tvs mentioned in the types of covars or -- coercion holes. We can't quantify over these covars, so we @@ -1448,30 +1451,33 @@ decideAndPromoteTyVars top_lvl rhs_tclvl infer_mode name_taus psigs wanted ++ tau_tys ++ post_mr_quant) co_var_tvs = closeOverKinds co_vars - -- outer_tvs are mentioned in `wanted, and belong to some outer level. + -- outer_tvs are mentioned in `wanted`, and belong to some outer level. -- We definitely can't quantify over them outer_tvs = outerLevelTyVars rhs_tclvl $ - tyCoVarsOfTypes can_quant `unionVarSet` tyCoVarsOfTypes no_quant + can_quant_tvs `unionVarSet` no_quant_tvs - -- Step 3 of Note [decideAndPromoteTyVars] + -- Step 3 of Note [decideAndPromoteTyVars], (a-c) -- Identify mono_tvs: the type variables that we must not quantify over + -- At top level we are much less keen to create mono tyvars, to avoid + -- spooky action at a distance. mono_tvs_without_mr - | is_top_level = outer_tvs - | otherwise = outer_tvs -- (a) - `unionVarSet` tyCoVarsOfTypes no_quant -- (b) - `unionVarSet` co_var_tvs -- (c) + | is_top_level = outer_tvs -- See (DP2) + | otherwise = outer_tvs -- (a) + `unionVarSet` no_quant_tvs -- (b) + `unionVarSet` co_var_tvs -- (c) + -- Step 3 of Note [decideAndPromoteTyVars], (d) mono_tvs_with_mr = -- Even at top level, we don't quantify over type variables -- mentioned in constraints that the MR tells us not to quantify -- See Note [decideAndPromoteTyVars] (DP2) - mono_tvs_without_mr `unionVarSet` tyCoVarsOfTypes mr_no_quant + mono_tvs_without_mr `unionVarSet` mr_no_quant_tvs -------------------------------------------------------------------- -- Step 4 of Note [decideAndPromoteTyVars] -- Use closeWrtFunDeps to find any other variables that are determined by mono_tvs - add_determined tvs = closeWrtFunDeps post_mr_quant tvs - `delVarSetList` psig_qtvs + add_determined tvs preds = closeWrtFunDeps preds tvs + `delVarSetList` psig_qtvs -- Why delVarSetList psig_qtvs? -- If the user has explicitly asked for quantification, then that -- request "wins" over the MR. @@ -1480,8 +1486,8 @@ decideAndPromoteTyVars top_lvl rhs_tclvl infer_mode name_taus psigs wanted -- (i.e. says "no" to isQuantifiableTv)? That's OK: explanation -- in Step 2 of Note [Deciding quantification]. - mono_tvs_with_mr_det = add_determined mono_tvs_with_mr - mono_tvs_without_mr_det = add_determined mono_tvs_without_mr + mono_tvs_with_mr_det = add_determined mono_tvs_with_mr post_mr_quant + mono_tvs_without_mr_det = add_determined mono_tvs_without_mr can_quant -------------------------------------------------------------------- -- Step 5 of Note [decideAndPromoteTyVars] @@ -1518,7 +1524,7 @@ decideAndPromoteTyVars top_lvl rhs_tclvl infer_mode name_taus psigs wanted , text "newly_mono_tvs =" <+> ppr newly_mono_tvs , text "can_quant =" <+> ppr can_quant , text "post_mr_quant =" <+> ppr post_mr_quant - , text "no_quant =" <+> ppr no_quant + , text "no_quant_tvs =" <+> ppr no_quant_tvs , text "mr_no_quant =" <+> ppr mr_no_quant , text "final_quant =" <+> ppr final_quant , text "co_vars =" <+> ppr co_vars ] @@ -1605,8 +1611,8 @@ The plan The body of z tries to unify the type of x (call it alpha[1]) with (beta[2] -> gamma[2]). This unification fails because alpha is untouchable, leaving [W] alpha[1] ~ (beta[2] -> gamma[2]) - We need to know not to quantify over beta or gamma, because they are in the - equality constraint with alpha. Actual test case: typecheck/should_compile/tc213 + We don't want to quantify over beta or gamma because they are fixed by alpha, + which is monomorphic. Actual test case: typecheck/should_compile/tc213 Another example. Suppose we have class C a b | a -> b @@ -1643,9 +1649,22 @@ Wrinkles promote type variables. But for bindings affected by the MR we have no choice but to promote. + An example is in #26004. + f w e = case e of + T1 -> let y = not w in False + T2 -> True + When generalising `f` we have a constraint + forall. (a ~ Bool) => alpha ~ Bool + where our provisional type for `f` is `f :: T alpha -> blah`. + In a /nested/ setting, we might simply not-generalise `f`, hoping to learn + about `alpha` from f's call sites (test T5266b is an example). But at top + level, to avoid spooky action at a distance. + Note [The top-level Any principle] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Key principle: we never want to show the programmer a type with `Any` in it. +Key principles: + * we never want to show the programmer a type with `Any` in it. + * avoid "spooky action at a distance" and silent defaulting Most /top level/ bindings have a type signature, so none of this arises. But where a top-level binding lacks a signature, we don't want to infer a type like @@ -1654,11 +1673,18 @@ and then subsequently default alpha[0]:=Any. Exposing `Any` to the user is bad bad bad. Better to report an error, which is what may well happen if we quantify over alpha instead. +Moreover, + * If (elsewhere in this module) we add a call to `f`, say (f True), then + `f` will get the type `Bool -> Int` + * If we add /another/ call, say (f 'x'), we will then get a type error. + * If we have no calls, the final exported type of `f` may get set by + defaulting, and might not be principal (#26004). + For /nested/ bindings, a monomorphic type like `f :: alpha[0] -> Int` is fine, because we can see all the call sites of `f`, and they will probably fix `alpha`. In contrast, we can't see all of (or perhaps any of) the calls of top-level (exported) functions, reducing the worries about "spooky action at a -distance". +distance". This also moves in the direction of `MonoLocalBinds`, which we like. Note [Do not quantify over constraints that determine a variable] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/Tc/Solver/InertSet.hs ===================================== @@ -374,20 +374,20 @@ instance Outputable InertSet where where dicts = bagToList (dictsToBag solved_dicts) -emptyInertCans :: InertCans -emptyInertCans +emptyInertCans :: TcLevel -> InertCans +emptyInertCans given_eq_lvl = IC { inert_eqs = emptyTyEqs , inert_funeqs = emptyFunEqs - , inert_given_eq_lvl = topTcLevel + , inert_given_eq_lvl = given_eq_lvl , inert_given_eqs = False , inert_dicts = emptyDictMap , inert_safehask = emptyDictMap , inert_insts = [] , inert_irreds = emptyBag } -emptyInert :: InertSet -emptyInert - = IS { inert_cans = emptyInertCans +emptyInert :: TcLevel -> InertSet +emptyInert given_eq_lvl + = IS { inert_cans = emptyInertCans given_eq_lvl , inert_cycle_breakers = emptyBag :| [] , inert_famapp_cache = emptyFunEqs , inert_solved_dicts = emptyDictMap } @@ -678,6 +678,23 @@ should update inert_given_eq_lvl? imply nominal ones. For example, if (G a ~R G b) and G's argument's role is nominal, then we can deduce a ~N b. +(TGE6) A subtle point is this: when initialising the solver, giving it + an empty InertSet, we must conservatively initialise `inert_given_lvl` + to the /current/ TcLevel. This matters when doing let-generalisation. + Consider #26004: + f w e = case e of + T1 -> let y = not w in False -- T1 is a GADT + T2 -> True + When let-generalising `y`, we will have (w :: alpha[1]) in the type + envt; and we are under GADT pattern match. So when we solve the + constraints from y's RHS, in simplifyInfer, we must NOT unify + alpha[1] := Bool + Since we don't know what enclosing equalities there are, we just + conservatively assume that there are some. + + This initialisation in done in `runTcSWithEvBinds`, which passes + the current TcLevl to `emptyInert`. + Historical note: prior to #24938 we also ignored Given equalities that did not mention an "outer" type variable. But that is wrong, as #24938 showed. Another example is immortalised in test LocalGivenEqs2 ===================================== compiler/GHC/Tc/Solver/Monad.hs ===================================== @@ -20,7 +20,7 @@ module GHC.Tc.Solver.Monad ( runTcSSpecPrag, failTcS, warnTcS, addErrTcS, wrapTcS, ctLocWarnTcS, runTcSEqualities, - nestTcS, nestImplicTcS, setEvBindsTcS, + nestTcS, nestImplicTcS, setEvBindsTcS, setTcLevelTcS, emitImplicationTcS, emitTvImplicationTcS, emitImplication, emitFunDepWanteds, @@ -947,8 +947,9 @@ added. This is initialised from the innermost implication constraint. -- | See Note [TcSMode] data TcSMode = TcSVanilla -- ^ Normal constraint solving + | TcSPMCheck -- ^ Used when doing patterm match overlap checks | TcSEarlyAbort -- ^ Abort early on insoluble constraints - | TcSSpecPrag -- ^ Fully solve all constraints + | TcSSpecPrag -- ^ Fully solve all constraints deriving (Eq) {- Note [TcSMode] @@ -957,6 +958,11 @@ The constraint solver can operate in different modes: * TcSVanilla: Normal constraint solving mode. This is the default. +* TcSPMCheck: Used by the pattern match overlap checker. + Like TcSVanilla, but the idea is that the returned InertSet will + later be resumed, so we do not want to restore type-equality cycles + See also Note [Type equality cycles] in GHC.Tc.Solver.Equality + * TcSEarlyAbort: Abort (fail in the monad) as soon as we come across an insoluble constraint. This is used to fail-fast when checking for hole-fits. See Note [Speeding up valid hole-fits]. @@ -1135,7 +1141,7 @@ runTcS tcs runTcSEarlyAbort :: TcS a -> TcM a runTcSEarlyAbort tcs = do { ev_binds_var <- TcM.newTcEvBinds - ; runTcSWithEvBinds' True TcSEarlyAbort ev_binds_var tcs } + ; runTcSWithEvBinds' TcSEarlyAbort ev_binds_var tcs } -- | Run the 'TcS' monad in 'TcSSpecPrag' mode, which either fully solves -- individual Wanted quantified constraints or leaves them alone. @@ -1143,7 +1149,7 @@ runTcSEarlyAbort tcs -- See Note [TcSSpecPrag]. runTcSSpecPrag :: EvBindsVar -> TcS a -> TcM a runTcSSpecPrag ev_binds_var tcs - = runTcSWithEvBinds' True TcSSpecPrag ev_binds_var tcs + = runTcSWithEvBinds' TcSSpecPrag ev_binds_var tcs {- Note [TcSSpecPrag] ~~~~~~~~~~~~~~~~~~~~~ @@ -1200,7 +1206,7 @@ runTcSEqualities thing_inside runTcSInerts :: InertSet -> TcS a -> TcM (a, InertSet) runTcSInerts inerts tcs = do ev_binds_var <- TcM.newTcEvBinds - runTcSWithEvBinds' False TcSVanilla ev_binds_var $ do + runTcSWithEvBinds' TcSPMCheck ev_binds_var $ do setInertSet inerts a <- tcs new_inerts <- getInertSet @@ -1209,21 +1215,23 @@ runTcSInerts inerts tcs = do runTcSWithEvBinds :: EvBindsVar -> TcS a -> TcM a -runTcSWithEvBinds = runTcSWithEvBinds' True TcSVanilla +runTcSWithEvBinds = runTcSWithEvBinds' TcSVanilla -runTcSWithEvBinds' :: Bool -- True <=> restore type equality cycles - -- Don't if you want to reuse the InertSet. - -- See also Note [Type equality cycles] - -- in GHC.Tc.Solver.Equality - -> TcSMode +runTcSWithEvBinds' :: TcSMode -> EvBindsVar -> TcS a -> TcM a -runTcSWithEvBinds' restore_cycles mode ev_binds_var tcs +runTcSWithEvBinds' mode ev_binds_var tcs = do { unified_var <- TcM.newTcRef 0 - ; step_count <- TcM.newTcRef 0 - ; inert_var <- TcM.newTcRef emptyInert - ; wl_var <- TcM.newTcRef emptyWorkList + ; step_count <- TcM.newTcRef 0 + + -- Make a fresh, empty inert set + -- Subtle point: see (TGE6) in Note [Tracking Given equalities] + -- in GHC.Tc.Solver.InertSet + ; tc_lvl <- TcM.getTcLevel + ; inert_var <- TcM.newTcRef (emptyInert tc_lvl) + + ; wl_var <- TcM.newTcRef emptyWorkList ; unif_lvl_var <- TcM.newTcRef Nothing ; let env = TcSEnv { tcs_ev_binds = ev_binds_var , tcs_unified = unified_var @@ -1240,9 +1248,13 @@ runTcSWithEvBinds' restore_cycles mode ev_binds_var tcs ; when (count > 0) $ csTraceTcM $ return (text "Constraint solver steps =" <+> int count) - ; when restore_cycles $ - do { inert_set <- TcM.readTcRef inert_var - ; restoreTyVarCycles inert_set } + -- Restore tyvar cycles: see Note [Type equality cycles] in + -- GHC.Tc.Solver.Equality + -- But /not/ in TCsPMCheck mode: see Note [TcSMode] + ; case mode of + TcSPMCheck -> return () + _ -> do { inert_set <- TcM.readTcRef inert_var + ; restoreTyVarCycles inert_set } #if defined(DEBUG) ; ev_binds <- TcM.getTcEvBindsMap ev_binds_var @@ -1284,6 +1296,10 @@ setEvBindsTcS :: EvBindsVar -> TcS a -> TcS a setEvBindsTcS ref (TcS thing_inside) = TcS $ \ env -> thing_inside (env { tcs_ev_binds = ref }) +setTcLevelTcS :: TcLevel -> TcS a -> TcS a +setTcLevelTcS lvl (TcS thing_inside) + = TcS $ \ env -> TcM.setTcLevel lvl (thing_inside env) + nestImplicTcS :: EvBindsVar -> TcLevel -> TcS a -> TcS a ===================================== compiler/GHC/Tc/Types/Constraint.hs ===================================== @@ -1743,24 +1743,21 @@ will be able to report a more informative error: ************************************************************************ -} -type ApproxWC = ( Bag Ct -- Free quantifiable constraints - , Bag Ct ) -- Free non-quantifiable constraints - -- due to shape, or enclosing equality +type ApproxWC = ( Bag Ct -- Free quantifiable constraints + , TcTyCoVarSet ) -- Free vars of non-quantifiable constraints + -- due to shape, or enclosing equality approximateWC :: Bool -> WantedConstraints -> Bag Ct approximateWC include_non_quantifiable cts - | include_non_quantifiable = quant `unionBags` no_quant - | otherwise = quant - where - (quant, no_quant) = approximateWCX cts + = fst (approximateWCX include_non_quantifiable cts) -approximateWCX :: WantedConstraints -> ApproxWC +approximateWCX :: Bool -> WantedConstraints -> ApproxWC -- The "X" means "extended"; -- we return both quantifiable and non-quantifiable constraints -- See Note [ApproximateWC] -- See Note [floatKindEqualities vs approximateWC] -approximateWCX wc - = float_wc False emptyVarSet wc (emptyBag, emptyBag) +approximateWCX include_non_quantifiable wc + = float_wc False emptyVarSet wc (emptyBag, emptyVarSet) where float_wc :: Bool -- True <=> there are enclosing equalities -> TcTyCoVarSet -- Enclosing skolem binders @@ -1786,17 +1783,23 @@ approximateWCX wc -- There can be (insoluble) Given constraints in wc_simple, -- there so that we get error reports for unreachable code -- See `given_insols` in GHC.Tc.Solver.Solve.solveImplication - | insolubleCt ct = acc - | tyCoVarsOfCt ct `intersectsVarSet` skol_tvs = acc - | otherwise - = case classifyPredType (ctPred ct) of + | insolubleCt ct = acc + | pred_tvs `intersectsVarSet` skol_tvs = acc + | include_non_quantifiable = add_to_quant + | is_quantifiable encl_eqs (ctPred ct) = add_to_quant + | otherwise = add_to_no_quant + where + pred = ctPred ct + pred_tvs = tyCoVarsOfType pred + add_to_quant = (ct `consBag` quant, no_quant) + add_to_no_quant = (quant, no_quant `unionVarSet` pred_tvs) + + is_quantifiable encl_eqs pred + = case classifyPredType pred of -- See the classification in Note [ApproximateWC] EqPred eq_rel ty1 ty2 - | not encl_eqs -- See Wrinkle (W1) - , quantify_equality eq_rel ty1 ty2 - -> add_to_quant - | otherwise - -> add_to_no_quant + | encl_eqs -> False -- encl_eqs: See Wrinkle (W1) + | otherwise -> quantify_equality eq_rel ty1 ty2 ClassPred cls tys | Just {} <- isCallStackPred cls tys @@ -1804,17 +1807,14 @@ approximateWCX wc -- the constraints bubble up to be solved from the outer -- context, or be defaulted when we reach the top-level. -- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence - -> add_to_no_quant + -> False | otherwise - -> add_to_quant -- See Wrinkle (W2) + -> True -- See Wrinkle (W2) - IrredPred {} -> add_to_quant -- See Wrinkle (W2) + IrredPred {} -> True -- See Wrinkle (W2) - ForAllPred {} -> add_to_no_quant -- Never quantify these - where - add_to_quant = (ct `consBag` quant, no_quant) - add_to_no_quant = (quant, ct `consBag` no_quant) + ForAllPred {} -> False -- Never quantify these -- See Note [Quantifying over equality constraints] quantify_equality NomEq ty1 ty2 = quant_fun ty1 || quant_fun ty2 @@ -1852,7 +1852,7 @@ We proceed by classifying the constraint: Wrinkle (W1) When inferring most-general types (in simplifyInfer), we - do *not* float an equality constraint if the implication binds + do *not* quantify over equality constraint if the implication binds equality constraints, because that defeats the OutsideIn story. Consider data T a where { TInt :: T Int; MkT :: T a } f TInt = 3::Int ===================================== testsuite/tests/typecheck/should_fail/T26004.hs ===================================== @@ -0,0 +1,14 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NoMonoLocalBinds #-} + +module T26004 where + +data T a where + T1 :: T Bool + T2 :: T a + +-- This funcion should be rejected: +-- we should not infer a non-principal type for `f` +f w e = case e of + T1 -> let y = not w in False + T2 -> True ===================================== testsuite/tests/typecheck/should_fail/T26004.stderr ===================================== @@ -0,0 +1,17 @@ + +T26004.hs:13:21: error: [GHC-25897] + • Could not deduce ‘p ~ Bool’ + from the context: a ~ Bool + bound by a pattern with constructor: T1 :: T Bool, + in a case alternative + at T26004.hs:13:3-4 + ‘p’ is a rigid type variable bound by + the inferred type of f :: p -> T a -> Bool + at T26004.hs:(12,1)-(14,12) + • In the first argument of ‘not’, namely ‘w’ + In the expression: not w + In an equation for ‘y’: y = not w + • Relevant bindings include + w :: p (bound at T26004.hs:12:3) + f :: p -> T a -> Bool (bound at T26004.hs:12:1) + Suggested fix: Consider giving ‘f’ a type signature ===================================== testsuite/tests/typecheck/should_fail/T7453.stderr ===================================== @@ -1,8 +1,5 @@ - -T7453.hs:9:15: error: [GHC-25897] - • Couldn't match type ‘t’ with ‘p’ - Expected: Id t - Actual: Id p +T7453.hs:10:30: error: [GHC-25897] + • Couldn't match expected type ‘t’ with actual type ‘p’ ‘t’ is a rigid type variable bound by the type signature for: z :: forall t. Id t @@ -10,29 +7,17 @@ T7453.hs:9:15: error: [GHC-25897] ‘p’ is a rigid type variable bound by the inferred type of cast1 :: p -> a at T7453.hs:(7,1)-(10,30) - • In the expression: aux - In an equation for ‘z’: - z = aux - where - aux = Id v - In an equation for ‘cast1’: - cast1 v - = runId z - where - z :: Id t - z = aux - where - aux = Id v + • In the first argument of ‘Id’, namely ‘v’ + In the expression: Id v + In an equation for ‘aux’: aux = Id v • Relevant bindings include - aux :: Id p (bound at T7453.hs:10:21) + aux :: Id t (bound at T7453.hs:10:21) z :: Id t (bound at T7453.hs:9:11) v :: p (bound at T7453.hs:7:7) cast1 :: p -> a (bound at T7453.hs:7:1) -T7453.hs:15:15: error: [GHC-25897] - • Couldn't match type ‘t1’ with ‘p’ - Expected: () -> t1 - Actual: () -> p +T7453.hs:16:33: error: [GHC-25897] + • Couldn't match expected type ‘t1’ with actual type ‘p’ ‘t1’ is a rigid type variable bound by the type signature for: z :: forall t1. () -> t1 @@ -40,21 +25,11 @@ T7453.hs:15:15: error: [GHC-25897] ‘p’ is a rigid type variable bound by the inferred type of cast2 :: p -> t at T7453.hs:(13,1)-(16,33) - • In the expression: aux - In an equation for ‘z’: - z = aux - where - aux = const v - In an equation for ‘cast2’: - cast2 v - = z () - where - z :: () -> t - z = aux - where - aux = const v + • In the first argument of ‘const’, namely ‘v’ + In the expression: const v + In an equation for ‘aux’: aux = const v • Relevant bindings include - aux :: forall {b}. b -> p (bound at T7453.hs:16:21) + aux :: b -> t1 (bound at T7453.hs:16:21) z :: () -> t1 (bound at T7453.hs:15:11) v :: p (bound at T7453.hs:13:7) cast2 :: p -> t (bound at T7453.hs:13:1) @@ -86,3 +61,4 @@ T7453.hs:21:15: error: [GHC-25897] z :: t1 (bound at T7453.hs:21:11) v :: p (bound at T7453.hs:19:7) cast3 :: p -> t (bound at T7453.hs:19:1) + ===================================== testsuite/tests/typecheck/should_fail/all.T ===================================== @@ -735,3 +735,4 @@ test('T24938', normal, compile_fail, ['']) test('T25325', normal, compile_fail, ['']) test('T25004', normal, compile_fail, ['']) test('T25004k', normal, compile_fail, ['']) +test('T26004', normal, compile_fail, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/165f98d86f59b783511f8015dc1e547… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/165f98d86f59b783511f8015dc1e547… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] 2 commits: Refactor mkTopLevImportedEnv out of mkTopLevEnv
by Marge Bot (＠marge-bot) 06 May '25

06 May '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: e46c6b18 by Rodrigo Mesquita at 2025-05-06T09:01:57-04:00 Refactor mkTopLevImportedEnv out of mkTopLevEnv This makes the code clearer and allows the top-level import context to be fetched directly from the HomeModInfo through the API (e.g. useful for the debugger). - - - - - 0ce0d263 by Rodrigo Mesquita at 2025-05-06T09:01:57-04:00 Export sizeOccEnv from GHC.Types.Name.Occurrence Counts the number of OccNames in an OccEnv - - - - - 2 changed files: - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Types/Name/Occurrence.hs Changes: ===================================== compiler/GHC/Runtime/Eval.hs ===================================== @@ -23,7 +23,7 @@ module GHC.Runtime.Eval ( setupBreakpoint, back, forward, setContext, getContext, - mkTopLevEnv, + mkTopLevEnv, mkTopLevImportedEnv, getNamesInScope, getRdrNamesInScope, moduleIsInterpreted, @@ -836,29 +836,36 @@ mkTopLevEnv hsc_env modl Nothing -> pure $ Left "not a home module" Just details -> case mi_top_env (hm_iface details) of - (IfaceTopEnv exports imports) -> do - imports_env <- - runInteractiveHsc hsc_env - $ ioMsgMaybe $ hoistTcRnMessage $ runTcInteractive hsc_env - $ fmap (foldr plusGlobalRdrEnv emptyGlobalRdrEnv) - $ forM imports $ \iface_import -> do - let ImpUserSpec spec details = tcIfaceImport iface_import - iface <- loadInterfaceForModule (text "imported by GHCi") (is_mod spec) - pure $ case details of - ImpUserAll -> importsFromIface hsc_env iface spec Nothing - ImpUserEverythingBut ns -> importsFromIface hsc_env iface spec (Just ns) - ImpUserExplicit x _parents_of_implicits -> - -- TODO: Not quite right, is_explicit should refer to whether the user wrote A(..) or A(x,y). - -- It is only used for error messages. It seems dubious even to add an import context to these GREs as - -- they are not "imported" into the top-level scope of the REPL. I changed this for now so that - -- the test case produce the same output as before. - let spec' = ImpSpec { is_decl = spec, is_item = ImpSome { is_explicit = True, is_iloc = noSrcSpan } } - in mkGlobalRdrEnv $ gresFromAvails hsc_env (Just spec') x + (IfaceTopEnv exports _imports) -> do + imports_env <- mkTopLevImportedEnv hsc_env details let exports_env = mkGlobalRdrEnv $ gresFromAvails hsc_env Nothing (getDetOrdAvails exports) pure $ Right $ plusGlobalRdrEnv imports_env exports_env where hpt = hsc_HPT hsc_env +-- | Make the top-level environment with all bindings imported by this module. +-- Exported bindings from this module are not included in the result. +mkTopLevImportedEnv :: HscEnv -> HomeModInfo -> IO GlobalRdrEnv +mkTopLevImportedEnv hsc_env details = do + runInteractiveHsc hsc_env + $ ioMsgMaybe $ hoistTcRnMessage $ runTcInteractive hsc_env + $ fmap (foldr plusGlobalRdrEnv emptyGlobalRdrEnv) + $ forM imports $ \iface_import -> do + let ImpUserSpec spec details = tcIfaceImport iface_import + iface <- loadInterfaceForModule (text "imported by GHCi") (is_mod spec) + pure $ case details of + ImpUserAll -> importsFromIface hsc_env iface spec Nothing + ImpUserEverythingBut ns -> importsFromIface hsc_env iface spec (Just ns) + ImpUserExplicit x _parents_of_implicits -> + -- TODO: Not quite right, is_explicit should refer to whether the user wrote A(..) or A(x,y). + -- It is only used for error messages. It seems dubious even to add an import context to these GREs as + -- they are not "imported" into the top-level scope of the REPL. I changed this for now so that + -- the test case produce the same output as before. + let spec' = ImpSpec { is_decl = spec, is_item = ImpSome { is_explicit = True, is_iloc = noSrcSpan } } + in mkGlobalRdrEnv $ gresFromAvails hsc_env (Just spec') x + where + IfaceTopEnv _ imports = mi_top_env (hm_iface details) + -- | Get the interactive evaluation context, consisting of a pair of the -- set of modules from which we take the full top-level scope, and the set -- of modules from which we take just the exports respectively. ===================================== compiler/GHC/Types/Name/Occurrence.hs ===================================== @@ -92,6 +92,7 @@ module GHC.Types.Name.Occurrence ( plusOccEnv, plusOccEnv_C, extendOccEnv_Acc, filterOccEnv, delListFromOccEnv, delFromOccEnv, alterOccEnv, minusOccEnv, minusOccEnv_C, minusOccEnv_C_Ns, + sizeOccEnv, pprOccEnv, forceOccEnv, intersectOccEnv_C, @@ -803,6 +804,10 @@ minusOccEnv_C_Ns f (MkOccEnv as) (MkOccEnv bs) = then Nothing else Just m +sizeOccEnv :: OccEnv a -> Int +sizeOccEnv (MkOccEnv as) = + nonDetStrictFoldUFM (\ m !acc -> acc + sizeUFM m) 0 as + instance Outputable a => Outputable (OccEnv a) where ppr x = pprOccEnv ppr x View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/50fa8165155cea820ec45e1bd77eb4… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/50fa8165155cea820ec45e1bd77eb4… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/9.10-metadata-fixes
by Zubin (＠wz1000) 06 May '25

06 May '25

Zubin pushed new branch wip/9.10-metadata-fixes at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/9.10-metadata-fixes You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/andreask/interpreter_primops] 9 commits: Fix infelicities in the Specialiser
by Andreas Klebinger (＠AndreasK) 06 May '25

06 May '25

Andreas Klebinger pushed to branch wip/andreask/interpreter_primops at Glasgow Haskell Compiler / GHC Commits: ce616f49 by Simon Peyton Jones at 2025-04-27T21:10:25+01:00 Fix infelicities in the Specialiser On the way to #23109 (unary classes) I discovered some infelicities (or maybe tiny bugs, I forget) in the type-class specialiser. I also tripped over #25965, an outright bug in the rule matcher Specifically: * Refactor: I enhanced `wantCallsFor`, whih previously always said `True`, to discard calls of class-ops, data constructors etc. This is a bit more efficient; and it means we don't need to worry about filtering them out later. * Fix: I tidied up some tricky logic that eliminated redundant specialisations. It wasn't working correctly. See the expanded Note [Specialisations already covered], and (MP3) in Note [Specialising polymorphic dictionaries]. See also the new top-level `alreadyCovered` function, which now goes via `GHC.Core.Rules.ruleLhsIsMoreSpecific` I also added a useful Note [The (CI-KEY) invariant] * Fix #25965: fixed a tricky bug in the `go_fam_fam` in `GHC.Core.Unify.uVarOrFam`, which allows matching to succeed without binding all type varibles. I enhanced Note [Apartness and type families] some more * #25703. This ticket "just works" with -fpolymorphic-specialisation; but I was surprised that it worked! In this MR I added documentation to Note [Interesting dictionary arguments] to explain; and tests to ensure it stays fixed. - - - - - 22d11fa8 by Simon Peyton Jones at 2025-04-28T18:05:19-04:00 Track rewriter sets more accurately in constraint solving The key change, which fixed #25440, is to call `recordRewriter` in GHC.Tc.Solver.Rewrite.rewrite_exact_fam_app. This missing call meant that we were secretly rewriting a Wanted with a Wanted, but not really noticing; and that led to a very bad error message, as you can see in the ticket. But of course that led me into rabbit hole of other refactoring around the RewriteSet code: * Improve Notes [Wanteds rewrite Wanteds] * Zonk the RewriterSet in `zonkCtEvidence` rather than only in GHC.Tc.Errors. This is tidier anyway (e.g. de-clutters debug output), and helps with the next point. * In GHC.Tc.Solver.Equality.inertsCanDischarge, don't replace a constraint with no rewriters with an equal constraint that has many. See See (CE4) in Note [Combining equalities] * Move zonkRewriterSet and friends from GHC.Tc.Zonk.Type into GHC.Tc.Zonk.TcType, where they properly belong. A handful of tests get better error messages. For some reason T24984 gets 12% less compiler allocation -- good Metric Decrease: T24984 - - - - - 6467d61e by Brandon Chinn at 2025-04-29T18:36:03-04:00 Fix lexing "\^\" (#25937) This broke in the refactor in !13128, where the old code parsed escape codes and collapsed string gaps at the same time, but the new code collapsed gaps first, then resolved escape codes. The new code used a naive heuristic to skip escaped backslashes, but didn't account for "\^\". - - - - - 99868a86 by Jens Petersen at 2025-04-29T18:36:44-04:00 hadrian: default selftest to disabled - - - - - aba2a4a5 by Zubin Duggal at 2025-04-30T06:35:59-04:00 get-win32-tarballs.py: List tarball files to be downloaded if we cannot find them Fixes #25929 - - - - - d99a617b by Ben Gamari at 2025-04-30T06:36:40-04:00 Move Data ModuleName instance to Language.Haskell.Syntax.Module.Name Fixes #25968. - - - - - 9995c2b7 by Serge S. Gulin at 2025-05-04T17:13:36+03:00 Support for ARM64 Windows (LLVM-enabled) (fixes #24603) 1. Add Windows AArch64 cross-compilation support via CI jobs Introduce new CI configurations for cross-compiling to Windows ARM64 using Debian12Wine, FEX, and MSYS2. Configure toolchain variables for LLVM MinGW and Wine emulation in CI pipelines. 2. Adjust compiler and RTS for AArch64 Windows compatibility Reserve register `x18` on Windows and Darwin platforms in AArch64 codegen. Handle Windows-specific relocations and data sections in AArch64 assembler. Update PEi386 linker to recognize ARM64 binaries and support exception handling. Adjust LLVM target definitions and data layouts for new architectures. Update `ghc-toolchain` and build scripts to handle `TablesNextToCode` on Windows ARM64. 3. Enhance CI scripts and stability Modify `ci.sh` to handle mingw cross-targets, fixing GHC executable paths and test execution. Use `diff -w` in tests to ignore whitespace differences, improving cross-platform consistency. 4. Refactor and clean up code Remove redundant imports in hello.hs test. Improve error messages and checks for unsupported configurations in the driver. Add `EXDEV` error code to `errno.js`. Add async/sync flags to IO logs at `base.js`. Improve POSIX compatibility for file close at `base.js`: decrease indeterminism for mixed cases of async and sync code. 5. Update dependencies: `Cabal`, `Win32`, `directory`, `process`, `haskeline`, and `unix`. submodule Co-authored-by: Cheng Shao <terrorjack(a)type.dance> Co-authored-by: Dmitrii Egorov <egorov.d.i(a)icloud.com> Co-authored-by: Andrei Borzenkov <root(a)sandwitch.dev> - - - - - 50fa8165 by Javran Cheng at 2025-05-05T05:55:39-04:00 Suppress unused do-binding if discarded variable is Any or ZonkAny. Consider example (#25895): > do { forever (return ()); blah } where `forever :: forall a b. IO a -> IO b`. Nothing constrains `b`, so it will be instantiates with `Any` or `ZonkAny`. But we certainly don't want to complain about a discarded do-binding. Fixes #25895 - - - - - 2229b15b by Andreas Klebinger at 2025-05-06T13:59:44+02:00 Interpreter: Add limited support for direct primop evaluation. This commit adds support for a number of primops directly to the interpreter. This avoids the indirection of going through the primop wrapper for those primops speeding interpretation of optimized code up massively. Code involving IntSet runs about 25% faster with optimized core and these changes. For core without breakpoints it's even more pronouced and I saw reductions in runtime by up to 50%. Running GHC itself in the interpreter was sped up by ~15% through this change. Additionally this comment does a few other related changes: testsuite: * Run foundation test in ghci and ghci-opt ways to test these primops. * Vastly expand the foundation test to cover all basic primops by comparing result with the result of calling the wrapper. Interpreter: * When pushing arguments for interpreted primops extend each argument to at least word with when pushing. This avoids some issues with big endian. We can revisit this if it causes performance issues. * Restructure the stack chunk check logic. There are now macros for read accesses which might cross stack chunk boundries and macros which omit the checks which are used when we statically know we access an address in the current stack chunk. - - - - - 95 changed files: - .gitlab-ci.yml - .gitlab/ci.sh - .gitlab/generate-ci/gen_ci.hs - .gitlab/hello.hs - .gitlab/jobs.yaml - compiler/CodeGen.Platform.h - compiler/GHC/Builtin/Types.hs - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/ByteCode/Asm.hs - compiler/GHC/ByteCode/Instr.hs - compiler/GHC/CmmToAsm/AArch64/CodeGen.hs - compiler/GHC/CmmToAsm/AArch64/Instr.hs - compiler/GHC/CmmToAsm/AArch64/Ppr.hs - compiler/GHC/CmmToAsm/Reg/Linear/AArch64.hs - compiler/GHC/Core/Coercion.hs - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Core/Rules.hs - compiler/GHC/Core/Unify.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/Parser/Errors/Types.hs - compiler/GHC/Parser/String.hs - compiler/GHC/Platform/Regs.hs - compiler/GHC/StgToByteCode.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Solver/Default.hs - compiler/GHC/Tc/Solver/Equality.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Solver/Rewrite.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/Tc/Zonk/Type.hs - compiler/GHC/Types/Basic.hs - compiler/GHC/Unit/Types.hs - compiler/Language/Haskell/Syntax/Module/Name.hs - hadrian/README.md - hadrian/hadrian.cabal - hadrian/src/Oracles/Setting.hs - hadrian/src/Rules/BinaryDist.hs - libraries/Cabal - libraries/Win32 - libraries/base/src/System/CPUTime/Windows.hsc - libraries/base/tests/perf/encodingAllocations.hs - libraries/directory - libraries/ghc-internal/jsbits/base.js - libraries/ghc-internal/jsbits/errno.js - libraries/ghc-internal/src/GHC/Internal/System/Posix/Internals.hs - libraries/haskeline - libraries/process - libraries/unix - llvm-targets - m4/fp_cc_supports_target.m4 - m4/fp_setup_windows_toolchain.m4 - m4/fptools_set_platform_vars.m4 - m4/ghc_tables_next_to_code.m4 - rts/Disassembler.c - rts/Interpreter.c - rts/StgCRun.c - rts/include/rts/Bytecodes.h - rts/linker/PEi386.c - rts/win32/veh_excn.c - testsuite/tests/codeGen/should_run/all.T - testsuite/tests/ghc-api/fixed-nodes/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/T3330c.stderr - testsuite/tests/indexed-types/should_fail/T4174.stderr - testsuite/tests/indexed-types/should_fail/T8227.stderr - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - 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_run/T25937.hs - + testsuite/tests/parser/should_run/T25937.stdout - testsuite/tests/parser/should_run/all.T - + testsuite/tests/parser/should_run/parser_unit_tests.hs - testsuite/tests/printer/T17697.stderr - + testsuite/tests/simplCore/should_compile/T25703.hs - + testsuite/tests/simplCore/should_compile/T25703.stderr - + testsuite/tests/simplCore/should_compile/T25703a.hs - + testsuite/tests/simplCore/should_compile/T25703a.stderr - + testsuite/tests/simplCore/should_compile/T25965.hs - testsuite/tests/simplCore/should_compile/all.T - testsuite/tests/typecheck/should_compile/T25266a.stderr - testsuite/tests/typecheck/should_fail/T18851.stderr - utils/genprimopcode/Main.hs - utils/genprimopcode/Syntax.hs - utils/ghc-toolchain/exe/Main.hs - utils/hsc2hs - utils/llvm-targets/gen-data-layout.sh The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/35ab30539e6928b8b99391faa3cd54… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/35ab30539e6928b8b99391faa3cd54… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/andreask/interpreter_primops] Interpreter: Add limited support for direct primop evaluation.
by Andreas Klebinger (＠AndreasK) 06 May '25

06 May '25

Andreas Klebinger pushed to branch wip/andreask/interpreter_primops at Glasgow Haskell Compiler / GHC Commits: 35ab3053 by Andreas Klebinger at 2025-05-06T13:59:15+02:00 Interpreter: Add limited support for direct primop evaluation. This commit adds support for a number of primops directly to the interpreter. This avoids the indirection of going through the primop wrapper for those primops speeding interpretation of optimized code up massively. Code involving IntSet runs about 25% faster with optimized core and these changes. For core without breakpoints it's even more pronouced and I saw reductions in runtime by up to 50%. Running GHC itself in the interpreter was sped up by ~15% through this change. Additionally this comment does a few other related changes: testsuite: * Run foundation test in ghci and ghci-opt ways to test these primops. * Vastly expand the foundation test to cover all basic primops by comparing result with the result of calling the wrapper. Interpreter: * When pushing arguments for interpreted primops extend each argument to at least word with when pushing. This avoids some issues with big endian. We can revisit this if it causes performance issues. * Restructure the stack chunk check logic. There are now macros for read accesses which might cross stack chunk boundries and macros which omit the checks which are used when we statically know we access an address in the current stack chunk. - - - - - 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 ===================================== @@ -732,6 +732,143 @@ assembleI platform i = case i of CCALL off m_addr i -> do np <- addr m_addr emit_ bci_CCALL [wOp off, Op np, SmallOp i] PRIMCALL -> emit_ bci_PRIMCALL [] + + OP_ADD w -> case w of + W64 -> emit_ bci_OP_ADD_64 [] + W32 -> emit_ bci_OP_ADD_32 [] + W16 -> emit_ bci_OP_ADD_16 [] + W8 -> emit_ bci_OP_ADD_08 [] + _ -> unsupported_width + OP_SUB w -> case w of + W64 -> emit_ bci_OP_SUB_64 [] + W32 -> emit_ bci_OP_SUB_32 [] + W16 -> emit_ bci_OP_SUB_16 [] + W8 -> emit_ bci_OP_SUB_08 [] + _ -> unsupported_width + OP_AND w -> case w of + W64 -> emit_ bci_OP_AND_64 [] + W32 -> emit_ bci_OP_AND_32 [] + W16 -> emit_ bci_OP_AND_16 [] + W8 -> emit_ bci_OP_AND_08 [] + _ -> unsupported_width + OP_XOR w -> case w of + W64 -> emit_ bci_OP_XOR_64 [] + W32 -> emit_ bci_OP_XOR_32 [] + W16 -> emit_ bci_OP_XOR_16 [] + W8 -> emit_ bci_OP_XOR_08 [] + _ -> unsupported_width + OP_OR w -> case w of + W64 -> emit_ bci_OP_OR_64 [] + W32 -> emit_ bci_OP_OR_32 [] + W16 -> emit_ bci_OP_OR_16 [] + W8 -> emit_ bci_OP_OR_08 [] + _ -> unsupported_width + OP_NOT w -> case w of + W64 -> emit_ bci_OP_NOT_64 [] + W32 -> emit_ bci_OP_NOT_32 [] + W16 -> emit_ bci_OP_NOT_16 [] + W8 -> emit_ bci_OP_NOT_08 [] + _ -> unsupported_width + OP_NEG w -> case w of + W64 -> emit_ bci_OP_NEG_64 [] + W32 -> emit_ bci_OP_NEG_32 [] + W16 -> emit_ bci_OP_NEG_16 [] + W8 -> emit_ bci_OP_NEG_08 [] + _ -> unsupported_width + OP_MUL w -> case w of + W64 -> emit_ bci_OP_MUL_64 [] + W32 -> emit_ bci_OP_MUL_32 [] + W16 -> emit_ bci_OP_MUL_16 [] + W8 -> emit_ bci_OP_MUL_08 [] + _ -> unsupported_width + OP_SHL w -> case w of + W64 -> emit_ bci_OP_SHL_64 [] + W32 -> emit_ bci_OP_SHL_32 [] + W16 -> emit_ bci_OP_SHL_16 [] + W8 -> emit_ bci_OP_SHL_08 [] + _ -> unsupported_width + OP_ASR w -> case w of + W64 -> emit_ bci_OP_ASR_64 [] + W32 -> emit_ bci_OP_ASR_32 [] + W16 -> emit_ bci_OP_ASR_16 [] + W8 -> emit_ bci_OP_ASR_08 [] + _ -> unsupported_width + OP_LSR w -> case w of + W64 -> emit_ bci_OP_LSR_64 [] + W32 -> emit_ bci_OP_LSR_32 [] + W16 -> emit_ bci_OP_LSR_16 [] + W8 -> emit_ bci_OP_LSR_08 [] + _ -> unsupported_width + + OP_NEQ w -> case w of + W64 -> emit_ bci_OP_NEQ_64 [] + W32 -> emit_ bci_OP_NEQ_32 [] + W16 -> emit_ bci_OP_NEQ_16 [] + W8 -> emit_ bci_OP_NEQ_08 [] + _ -> unsupported_width + OP_EQ w -> case w of + W64 -> emit_ bci_OP_EQ_64 [] + W32 -> emit_ bci_OP_EQ_32 [] + W16 -> emit_ bci_OP_EQ_16 [] + W8 -> emit_ bci_OP_EQ_08 [] + _ -> unsupported_width + + OP_U_LT w -> case w of + W64 -> emit_ bci_OP_U_LT_64 [] + W32 -> emit_ bci_OP_U_LT_32 [] + W16 -> emit_ bci_OP_U_LT_16 [] + W8 -> emit_ bci_OP_U_LT_08 [] + _ -> unsupported_width + OP_S_LT w -> case w of + W64 -> emit_ bci_OP_S_LT_64 [] + W32 -> emit_ bci_OP_S_LT_32 [] + W16 -> emit_ bci_OP_S_LT_16 [] + W8 -> emit_ bci_OP_S_LT_08 [] + _ -> unsupported_width + OP_U_GE w -> case w of + W64 -> emit_ bci_OP_U_GE_64 [] + W32 -> emit_ bci_OP_U_GE_32 [] + W16 -> emit_ bci_OP_U_GE_16 [] + W8 -> emit_ bci_OP_U_GE_08 [] + _ -> unsupported_width + OP_S_GE w -> case w of + W64 -> emit_ bci_OP_S_GE_64 [] + W32 -> emit_ bci_OP_S_GE_32 [] + W16 -> emit_ bci_OP_S_GE_16 [] + W8 -> emit_ bci_OP_S_GE_08 [] + _ -> unsupported_width + OP_U_GT w -> case w of + W64 -> emit_ bci_OP_U_GT_64 [] + W32 -> emit_ bci_OP_U_GT_32 [] + W16 -> emit_ bci_OP_U_GT_16 [] + W8 -> emit_ bci_OP_U_GT_08 [] + _ -> unsupported_width + OP_S_GT w -> case w of + W64 -> emit_ bci_OP_S_GT_64 [] + W32 -> emit_ bci_OP_S_GT_32 [] + W16 -> emit_ bci_OP_S_GT_16 [] + W8 -> emit_ bci_OP_S_GT_08 [] + _ -> unsupported_width + OP_U_LE w -> case w of + W64 -> emit_ bci_OP_U_LE_64 [] + W32 -> emit_ bci_OP_U_LE_32 [] + W16 -> emit_ bci_OP_U_LE_16 [] + W8 -> emit_ bci_OP_U_LE_08 [] + _ -> unsupported_width + OP_S_LE w -> case w of + W64 -> emit_ bci_OP_S_LE_64 [] + W32 -> emit_ bci_OP_S_LE_32 [] + W16 -> emit_ bci_OP_S_LE_16 [] + W8 -> emit_ bci_OP_S_LE_08 [] + _ -> unsupported_width + + OP_INDEX_ADDR w -> case w of + W64 -> emit_ bci_OP_INDEX_ADDR_64 [] + W32 -> emit_ bci_OP_INDEX_ADDR_32 [] + W16 -> emit_ bci_OP_INDEX_ADDR_16 [] + W8 -> emit_ bci_OP_INDEX_ADDR_08 [] + _ -> unsupported_width + BRK_FUN arr tick_mod tick_mod_id tickx info_mod info_mod_id infox cc -> do p1 <- ptr (BCOPtrBreakArray arr) tick_addr <- addr tick_mod @@ -753,6 +890,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,12 +14,15 @@ module GHC.ByteCode.Instr ( import GHC.Prelude import GHC.ByteCode.Types +import GHC.Cmm.Type (Width) import GHCi.RemoteTypes import GHCi.FFI (C_ffi_cif) 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 ) @@ -36,8 +39,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 @@ -220,6 +221,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 @@ -401,6 +435,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" @@ -509,6 +569,30 @@ bciStackUse RETURN{} = 1 -- pushes stg_ret_X for some X bciStackUse RETURN_TUPLE{} = 1 -- pushes stg_ret_t header bciStackUse CCALL{} = 0 bciStackUse PRIMCALL{} = 1 -- pushes stg_primcall +bciStackUse OP_ADD{} = 0 -- We overestimate, it's -1 actually ... +bciStackUse OP_SUB{} = 0 +bciStackUse OP_AND{} = 0 +bciStackUse OP_XOR{} = 0 +bciStackUse OP_OR{} = 0 +bciStackUse OP_NOT{} = 0 +bciStackUse OP_NEG{} = 0 +bciStackUse OP_MUL{} = 0 +bciStackUse OP_SHL{} = 0 +bciStackUse OP_ASR{} = 0 +bciStackUse OP_LSR{} = 0 + +bciStackUse OP_NEQ{} = 0 +bciStackUse OP_EQ{} = 0 +bciStackUse OP_S_LT{} = 0 +bciStackUse OP_S_GT{} = 0 +bciStackUse OP_S_LE{} = 0 +bciStackUse OP_S_GE{} = 0 +bciStackUse OP_U_LT{} = 0 +bciStackUse OP_U_GT{} = 0 +bciStackUse OP_U_LE{} = 0 +bciStackUse OP_U_GE{} = 0 +bciStackUse OP_INDEX_ADDR{} = 0 + bciStackUse SWIZZLE{} = 0 bciStackUse BRK_FUN{} = 0 ===================================== compiler/GHC/StgToByteCode.hs ===================================== @@ -58,6 +58,7 @@ import GHC.Builtin.Uniques import GHC.Data.FastString import GHC.Utils.Panic import GHC.Utils.Exception (evaluate) +import GHC.CmmToAsm.Config (platformWordWidth) import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, idPrimRepU, addIdReps, addArgReps, assertNonVoidIds, assertNonVoidStgArgs ) @@ -734,8 +735,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 @@ -830,6 +837,299 @@ doTailCall init_d s p fn args = do (final_d, more_push_code) <- push_seq (d + sz) args return (final_d, push_code `appOL` more_push_code) +doPrimOp :: Platform + -> PrimOp + -> StackDepth + -> Sequel + -> BCEnv + -> [StgArg] + -> Maybe (BcM BCInstrList) +doPrimOp platform op init_d s p args = + case op of + IntAddOp -> sizedPrimOp OP_ADD + Int64AddOp -> sizedPrimOp OP_ADD + Int32AddOp -> sizedPrimOp OP_ADD + Int16AddOp -> sizedPrimOp OP_ADD + Int8AddOp -> sizedPrimOp OP_ADD + WordAddOp -> sizedPrimOp OP_ADD + Word64AddOp -> sizedPrimOp OP_ADD + Word32AddOp -> sizedPrimOp OP_ADD + Word16AddOp -> sizedPrimOp OP_ADD + Word8AddOp -> sizedPrimOp OP_ADD + AddrAddOp -> sizedPrimOp OP_ADD + + IntMulOp -> sizedPrimOp OP_MUL + Int64MulOp -> sizedPrimOp OP_MUL + Int32MulOp -> sizedPrimOp OP_MUL + Int16MulOp -> sizedPrimOp OP_MUL + Int8MulOp -> sizedPrimOp OP_MUL + WordMulOp -> sizedPrimOp OP_MUL + Word64MulOp -> sizedPrimOp OP_MUL + Word32MulOp -> sizedPrimOp OP_MUL + Word16MulOp -> sizedPrimOp OP_MUL + Word8MulOp -> sizedPrimOp OP_MUL + + IntSubOp -> sizedPrimOp OP_SUB + WordSubOp -> sizedPrimOp OP_SUB + Int64SubOp -> sizedPrimOp OP_SUB + Int32SubOp -> sizedPrimOp OP_SUB + Int16SubOp -> sizedPrimOp OP_SUB + Int8SubOp -> sizedPrimOp OP_SUB + Word64SubOp -> sizedPrimOp OP_SUB + Word32SubOp -> sizedPrimOp OP_SUB + Word16SubOp -> sizedPrimOp OP_SUB + Word8SubOp -> sizedPrimOp OP_SUB + AddrSubOp -> sizedPrimOp OP_SUB + + IntAndOp -> sizedPrimOp OP_AND + WordAndOp -> sizedPrimOp OP_AND + Word64AndOp -> sizedPrimOp OP_AND + Word32AndOp -> sizedPrimOp OP_AND + Word16AndOp -> sizedPrimOp OP_AND + Word8AndOp -> sizedPrimOp OP_AND + + IntNotOp -> sizedPrimOp OP_NOT + WordNotOp -> sizedPrimOp OP_NOT + Word64NotOp -> sizedPrimOp OP_NOT + Word32NotOp -> sizedPrimOp OP_NOT + Word16NotOp -> sizedPrimOp OP_NOT + Word8NotOp -> sizedPrimOp OP_NOT + + IntXorOp -> sizedPrimOp OP_XOR + WordXorOp -> sizedPrimOp OP_XOR + Word64XorOp -> sizedPrimOp OP_XOR + Word32XorOp -> sizedPrimOp OP_XOR + Word16XorOp -> sizedPrimOp OP_XOR + Word8XorOp -> sizedPrimOp OP_XOR + + IntOrOp -> sizedPrimOp OP_OR + WordOrOp -> sizedPrimOp OP_OR + Word64OrOp -> sizedPrimOp OP_OR + Word32OrOp -> sizedPrimOp OP_OR + Word16OrOp -> sizedPrimOp OP_OR + Word8OrOp -> sizedPrimOp OP_OR + + WordSllOp -> sizedPrimOp OP_SHL + Word64SllOp -> sizedPrimOp OP_SHL + Word32SllOp -> sizedPrimOp OP_SHL + Word16SllOp -> sizedPrimOp OP_SHL + Word8SllOp -> sizedPrimOp OP_SHL + IntSllOp -> sizedPrimOp OP_SHL + Int64SllOp -> sizedPrimOp OP_SHL + Int32SllOp -> sizedPrimOp OP_SHL + Int16SllOp -> sizedPrimOp OP_SHL + Int8SllOp -> sizedPrimOp OP_SHL + + WordSrlOp -> sizedPrimOp OP_LSR + Word64SrlOp -> sizedPrimOp OP_LSR + Word32SrlOp -> sizedPrimOp OP_LSR + Word16SrlOp -> sizedPrimOp OP_LSR + Word8SrlOp -> sizedPrimOp OP_LSR + IntSrlOp -> sizedPrimOp OP_LSR + Int64SrlOp -> sizedPrimOp OP_LSR + Int32SrlOp -> sizedPrimOp OP_LSR + Int16SrlOp -> sizedPrimOp OP_LSR + Int8SrlOp -> sizedPrimOp OP_LSR + + IntSraOp -> sizedPrimOp OP_ASR + Int64SraOp -> sizedPrimOp OP_ASR + Int32SraOp -> sizedPrimOp OP_ASR + Int16SraOp -> sizedPrimOp OP_ASR + Int8SraOp -> sizedPrimOp OP_ASR + + + IntNeOp -> sizedPrimOp OP_NEQ + Int64NeOp -> sizedPrimOp OP_NEQ + Int32NeOp -> sizedPrimOp OP_NEQ + Int16NeOp -> sizedPrimOp OP_NEQ + Int8NeOp -> sizedPrimOp OP_NEQ + WordNeOp -> sizedPrimOp OP_NEQ + Word64NeOp -> sizedPrimOp OP_NEQ + Word32NeOp -> sizedPrimOp OP_NEQ + Word16NeOp -> sizedPrimOp OP_NEQ + Word8NeOp -> sizedPrimOp OP_NEQ + AddrNeOp -> sizedPrimOp OP_NEQ + + IntEqOp -> sizedPrimOp OP_EQ + Int64EqOp -> sizedPrimOp OP_EQ + Int32EqOp -> sizedPrimOp OP_EQ + Int16EqOp -> sizedPrimOp OP_EQ + Int8EqOp -> sizedPrimOp OP_EQ + WordEqOp -> sizedPrimOp OP_EQ + Word64EqOp -> sizedPrimOp OP_EQ + Word32EqOp -> sizedPrimOp OP_EQ + Word16EqOp -> sizedPrimOp OP_EQ + Word8EqOp -> sizedPrimOp OP_EQ + AddrEqOp -> sizedPrimOp OP_EQ + CharEqOp -> sizedPrimOp OP_EQ + + IntLtOp -> sizedPrimOp OP_S_LT + Int64LtOp -> sizedPrimOp OP_S_LT + Int32LtOp -> sizedPrimOp OP_S_LT + Int16LtOp -> sizedPrimOp OP_S_LT + Int8LtOp -> sizedPrimOp OP_S_LT + WordLtOp -> sizedPrimOp OP_U_LT + Word64LtOp -> sizedPrimOp OP_U_LT + Word32LtOp -> sizedPrimOp OP_U_LT + Word16LtOp -> sizedPrimOp OP_U_LT + Word8LtOp -> sizedPrimOp OP_U_LT + AddrLtOp -> sizedPrimOp OP_U_LT + CharLtOp -> sizedPrimOp OP_U_LT + + IntGeOp -> sizedPrimOp OP_S_GE + Int64GeOp -> sizedPrimOp OP_S_GE + Int32GeOp -> sizedPrimOp OP_S_GE + Int16GeOp -> sizedPrimOp OP_S_GE + Int8GeOp -> sizedPrimOp OP_S_GE + WordGeOp -> sizedPrimOp OP_U_GE + Word64GeOp -> sizedPrimOp OP_U_GE + Word32GeOp -> sizedPrimOp OP_U_GE + Word16GeOp -> sizedPrimOp OP_U_GE + Word8GeOp -> sizedPrimOp OP_U_GE + AddrGeOp -> sizedPrimOp OP_U_GE + CharGeOp -> sizedPrimOp OP_U_GE + + IntGtOp -> sizedPrimOp OP_S_GT + Int64GtOp -> sizedPrimOp OP_S_GT + Int32GtOp -> sizedPrimOp OP_S_GT + Int16GtOp -> sizedPrimOp OP_S_GT + Int8GtOp -> sizedPrimOp OP_S_GT + WordGtOp -> sizedPrimOp OP_U_GT + Word64GtOp -> sizedPrimOp OP_U_GT + Word32GtOp -> sizedPrimOp OP_U_GT + Word16GtOp -> sizedPrimOp OP_U_GT + Word8GtOp -> sizedPrimOp OP_U_GT + AddrGtOp -> sizedPrimOp OP_U_GT + CharGtOp -> sizedPrimOp OP_U_GT + + IntLeOp -> sizedPrimOp OP_S_LE + Int64LeOp -> sizedPrimOp OP_S_LE + Int32LeOp -> sizedPrimOp OP_S_LE + Int16LeOp -> sizedPrimOp OP_S_LE + Int8LeOp -> sizedPrimOp OP_S_LE + WordLeOp -> sizedPrimOp OP_U_LE + Word64LeOp -> sizedPrimOp OP_U_LE + Word32LeOp -> sizedPrimOp OP_U_LE + Word16LeOp -> sizedPrimOp OP_U_LE + Word8LeOp -> sizedPrimOp OP_U_LE + AddrLeOp -> sizedPrimOp OP_U_LE + CharLeOp -> sizedPrimOp OP_U_LE + + IntNegOp -> sizedPrimOp OP_NEG + Int64NegOp -> sizedPrimOp OP_NEG + Int32NegOp -> sizedPrimOp OP_NEG + Int16NegOp -> sizedPrimOp OP_NEG + Int8NegOp -> sizedPrimOp OP_NEG + + IntToWordOp -> mk_conv (platformWordWidth platform) + WordToIntOp -> mk_conv (platformWordWidth platform) + Int8ToWord8Op -> mk_conv W8 + Word8ToInt8Op -> mk_conv W8 + Int16ToWord16Op -> mk_conv W16 + Word16ToInt16Op -> mk_conv W16 + Int32ToWord32Op -> mk_conv W32 + Word32ToInt32Op -> mk_conv W32 + Int64ToWord64Op -> mk_conv W64 + Word64ToInt64Op -> mk_conv W64 + IntToAddrOp -> mk_conv (platformWordWidth platform) + AddrToIntOp -> mk_conv (platformWordWidth platform) + ChrOp -> mk_conv (platformWordWidth platform) -- Int# and Char# are rep'd the same + OrdOp -> mk_conv (platformWordWidth platform) + + -- 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 -> primOpWithRep (OP_INDEX_ADDR W64) W64 + + _ -> Nothing + where + primArg1Width :: StgArg -> Width + primArg1Width arg + | rep <- (stgArgRepU arg) + = case rep of + AddrRep -> platformWordWidth platform + IntRep -> platformWordWidth platform + WordRep -> platformWordWidth platform + + Int64Rep -> W64 + Word64Rep -> W64 + + Int32Rep -> W32 + Word32Rep -> W32 + + Int16Rep -> W16 + Word16Rep -> W16 + + Int8Rep -> W8 + Word8Rep -> W8 + + FloatRep -> unexpectedRep + DoubleRep -> unexpectedRep + + BoxedRep{} -> unexpectedRep + VecRep{} -> unexpectedRep + where + unexpectedRep = panic "doPrimOp: Unexpected argument rep" + + + -- TODO: The slides for the result need to be two words on 32bit for 64bit ops. + mkNReturn width + | W64 <- width = RETURN L -- L works for 64 bit on any platform + | otherwise = RETURN N -- <64bit width, fits in word on all platforms + + mkSlideWords width = if platformWordWidth platform < width then 2 else 1 + + -- Push args, execute primop, slide, return_N + -- Decides width of operation based on first argument. + sizedPrimOp op_inst = Just $ do + let width = primArg1Width (head args) + prim_code <- mkPrimOpCode init_d s p (op_inst width) $ args + let slide = mkSlideW (mkSlideWords width) (bytesToWords platform $ init_d - s) `snocOL` mkNReturn width + return $ prim_code `appOL` slide + + -- primOpWithRep op w => operation @op@ resulting in result @w@ wide. + primOpWithRep :: BCInstr -> Width -> Maybe (BcM (OrdList BCInstr)) + primOpWithRep op_inst width = Just $ do + prim_code <- mkPrimOpCode init_d s p op_inst $ args + + let slide = mkSlideW (mkSlideWords width) (bytesToWords platform $ init_d - s) `snocOL` mkNReturn width + return $ prim_code `appOL` slide + + -- Convert the argument to a result of width @target_width@ + mk_conv :: Width -> Maybe (BcM (OrdList BCInstr)) + mk_conv target_width = Just $ do + let width = primArg1Width (head args) + (push_code, _bytes) <- pushAtom init_d p (head args) + let slide = mkSlideW (mkSlideWords width) (bytesToWords platform $ init_d - s) `snocOL` mkNReturn target_width + return $ push_code `appOL` slide + +-- Push the arguments on the stack and emit the given instruction +-- Pushes at least one word per non void arg. +mkPrimOpCode + :: StackDepth + -> Sequel + -> BCEnv + -> BCInstr -- The operator + -> [StgArg] -- Args, in *reverse* order (must be fully applied) + -> BcM BCInstrList +mkPrimOpCode orig_d _ p op_inst args = app_code + where + app_code = do + profile <- getProfile + let _platform = profilePlatform profile + + do_pushery :: StackDepth -> [StgArg] -> BcM BCInstrList + do_pushery !d (arg : args) = do + (push,arg_bytes) <- pushAtom d p arg + more_push_code <- do_pushery (d + arg_bytes) args + return (push `appOL` more_push_code) + do_pushery !_d [] = do + return (unitOL op_inst) + + -- Push on the stack in the reverse order. + do_pushery orig_d (reverse args) + -- v. similar to CgStackery.findMatch, ToDo: merge findPushSeq :: [ArgRep] -> (BCInstr, Int, [ArgRep]) findPushSeq (P: P: P: P: P: P: rest) ===================================== rts/Disassembler.c ===================================== @@ -62,6 +62,26 @@ disInstr ( StgBCO *bco, int pc ) #error Cannot cope with WORD_SIZE_IN_BITS being nether 32 nor 64 #endif #define BCO_GET_LARGE_ARG ((instr & bci_FLAG_LARGE_ARGS) ? BCO_READ_NEXT_WORD : BCO_NEXT) +// For brevity +#define BELCH_INSTR_NAME(OP_NAME) \ + case bci_ ## OP_NAME: \ + debugBelch("OP_NAME\n"); \ + break + +#define BELCH_INSTR_NAME_ALL_SIZES(OP_NAME) \ + case bci_ ## OP_NAME ## _64: \ + debugBelch("#OP_NAME" "_64\n"); \ + break; \ + case bci_ ## OP_NAME ## _32: \ + debugBelch("#OP_NAME" "_32\n"); \ + break; \ + case bci_ ## OP_NAME ## _16: \ + debugBelch("#OP_NAME" "_16\n"); \ + break; \ + case bci_ ## OP_NAME ## _08: \ + debugBelch("#OP_NAME" "_08\n"); \ + break; + switch (instr & 0xff) { case bci_BRK_FUN: @@ -419,38 +439,20 @@ disInstr ( StgBCO *bco, int pc ) debugBelch("TESTEQ_P %d, fail to %d\n", instrs[pc], instrs[pc+1]); pc += 2; break; - case bci_CASEFAIL: - debugBelch("CASEFAIL\n" ); - break; + BELCH_INSTR_NAME(CASEFAIL); case bci_JMP: debugBelch("JMP to %d\n", instrs[pc]); pc += 1; break; - case bci_ENTER: - debugBelch("ENTER\n"); - break; + BELCH_INSTR_NAME(ENTER); + BELCH_INSTR_NAME(RETURN_P); + BELCH_INSTR_NAME(RETURN_N); + BELCH_INSTR_NAME(RETURN_F); + BELCH_INSTR_NAME(RETURN_D); + BELCH_INSTR_NAME(RETURN_L); + BELCH_INSTR_NAME(RETURN_V); + BELCH_INSTR_NAME(RETURN_T); - case bci_RETURN_P: - debugBelch("RETURN_P\n" ); - break; - case bci_RETURN_N: - debugBelch("RETURN_N\n" ); - break; - case bci_RETURN_F: - debugBelch("RETURN_F\n" ); - break; - case bci_RETURN_D: - debugBelch("RETURN_D\n" ); - break; - case bci_RETURN_L: - debugBelch("RETURN_L\n" ); - break; - case bci_RETURN_V: - debugBelch("RETURN_V\n" ); - break; - case bci_RETURN_T: - debugBelch("RETURN_T\n "); - break; case bci_BCO_NAME: { const char *name = (const char*) literals[instrs[pc]]; @@ -459,6 +461,33 @@ disInstr ( StgBCO *bco, int pc ) break; } + BELCH_INSTR_NAME_ALL_SIZES(OP_ADD); + BELCH_INSTR_NAME_ALL_SIZES(OP_SUB); + BELCH_INSTR_NAME_ALL_SIZES(OP_AND); + BELCH_INSTR_NAME_ALL_SIZES(OP_XOR); + BELCH_INSTR_NAME_ALL_SIZES(OP_OR); + BELCH_INSTR_NAME_ALL_SIZES(OP_NOT); + BELCH_INSTR_NAME_ALL_SIZES(OP_NEG); + BELCH_INSTR_NAME_ALL_SIZES(OP_MUL); + BELCH_INSTR_NAME_ALL_SIZES(OP_SHL); + BELCH_INSTR_NAME_ALL_SIZES(OP_ASR); + BELCH_INSTR_NAME_ALL_SIZES(OP_LSR); + + BELCH_INSTR_NAME_ALL_SIZES(OP_NEQ); + BELCH_INSTR_NAME_ALL_SIZES(OP_EQ); + + BELCH_INSTR_NAME_ALL_SIZES(OP_U_GT); + BELCH_INSTR_NAME_ALL_SIZES(OP_U_LE); + BELCH_INSTR_NAME_ALL_SIZES(OP_U_GE); + BELCH_INSTR_NAME_ALL_SIZES(OP_U_LT); + + BELCH_INSTR_NAME_ALL_SIZES(OP_S_GT); + BELCH_INSTR_NAME_ALL_SIZES(OP_S_LE); + BELCH_INSTR_NAME_ALL_SIZES(OP_S_GE); + BELCH_INSTR_NAME_ALL_SIZES(OP_S_LT); + + BELCH_INSTR_NAME_ALL_SIZES(OP_INDEX_ADDR); + default: barf("disInstr: unknown opcode %u", (unsigned int) instr); } ===================================== rts/Interpreter.c ===================================== @@ -178,23 +178,34 @@ See also Note [Width of parameters] for some more motivation. #define Sp_plusB(n) ((void *)((StgWord8*)Sp + (ptrdiff_t)(n))) #define Sp_minusB(n) ((void *)((StgWord8*)Sp - (ptrdiff_t)(n))) -#define Sp_plusW(n) (Sp_plusB((ptrdiff_t)(n) * (ptrdiff_t)sizeof(W_))) -#define Sp_minusW(n) (Sp_minusB((ptrdiff_t)(n) * (ptrdiff_t)sizeof(W_))) +#define Sp_plusW(n) ((void*)Sp_plusB((ptrdiff_t)(n) * (ptrdiff_t)sizeof(W_))) +#define Sp_plusW64(n) ((void*)Sp_plusB((ptrdiff_t)(n) * (ptrdiff_t)sizeof(StgWord64))) +#define Sp_minusW(n) ((void*)Sp_minusB((ptrdiff_t)(n) * (ptrdiff_t)sizeof(W_))) #define Sp_addB(n) (Sp = Sp_plusB(n)) #define Sp_subB(n) (Sp = Sp_minusB(n)) #define Sp_addW(n) (Sp = Sp_plusW(n)) +#define Sp_addW64(n) (Sp = Sp_plusW64(n)) #define Sp_subW(n) (Sp = Sp_minusW(n)) -#define SpW(n) (*(StgWord*)(Sp_plusW(n))) -#define SpB(n) (*(StgWord*)(Sp_plusB(n))) +// Assumes stack location is within stack chunk bounds +#define SpW(n) (*(StgWord*)(Sp_plusW(n))) +#define SpW64(n) (*(StgWord*)(Sp_plusW64(n))) -#define WITHIN_CAP_CHUNK_BOUNDS(n) WITHIN_CHUNK_BOUNDS(n, cap->r.rCurrentTSO->stackobj) +#define WITHIN_CAP_CHUNK_BOUNDS_W(n) WITHIN_CHUNK_BOUNDS_W(n, cap->r.rCurrentTSO->stackobj) -#define WITHIN_CHUNK_BOUNDS(n, s) \ - (RTS_LIKELY((StgWord*)(Sp_plusW(n)) < ((s)->stack + (s)->stack_size - sizeofW(StgUnderflowFrame)))) +#define WITHIN_CHUNK_BOUNDS_W(n, s) \ + (RTS_LIKELY(((StgWord*) Sp_plusW(n)) < ((s)->stack + (s)->stack_size - sizeofW(StgUnderflowFrame)))) +#define WDS_TO_W64(n) (n * sizeof(StgWord64) / sizeof(StgWord)) + +// Always safe to use - Return the value at the address +#define ReadSpW(n) (*((StgWord*) SafeSpWP(n))) +#define ReadSpW64(n) (*((StgWord64*) SafeSpWP(WDS_TO_W64(n)))) +// Perhaps confusingly this still reads a full word, merely the offset is in bytes. +#define ReadSpB(n) (*((StgWord*) SafeSpBP(n))) + /* Note [PUSH_L underflow] ~~~~~~~~~~~~~~~~~~~~~~~ BCOs can be nested, resulting in nested BCO stack frames where the inner most @@ -215,9 +226,9 @@ variables. If a stack overflow happens between the creation of the stack frame for BCO_1 and BCO_N the RTS might move BCO_N to a new stack chunk while leaving BCO_1 in place, invalidating a simple offset based reference to the outer stack frames. -Therefore `ReadSpW` first performs a bounds check to ensure that accesses onto +Therefore `SafeSpW` first performs a bounds check to ensure that accesses onto the stack will succeed. If the target address would not be a valid location for -the current stack chunk then `slow_spw` function is called, which dereferences +the current stack chunk then `slow_sp` function is called, which dereferences the underflow frame to adjust the offset before performing the lookup. ┌->--x | CHK_1 | @@ -229,13 +240,43 @@ the underflow frame to adjust the offset before performing the lookup. |---------| | PUSH_L <n> | BCO_ N | ->-┘ |---------| + +To keep things simpler all accesses to the stack which might go beyond the stack +chunk go through one of the ReadSP* or SafeSP* macros. +When writing to the stack there is no need for checks, we ensured we have space +in the current chunk ahead of time. So there we use SpW and it's variants which +omit the stack bounds check. + See ticket #25750 */ -#define ReadSpW(n) \ - ((WITHIN_CAP_CHUNK_BOUNDS(n)) ? SpW(n): slow_spw(Sp, cap->r.rCurrentTSO->stackobj, n)) +// Returns a pointer to the stack location. +// Returns a pointer to the stack location. +#define SafeSpWP(n) \ + ( ((WITHIN_CAP_CHUNK_BOUNDS_W(n)) ? Sp_plusW(n) : slow_spw(Sp, cap->r.rCurrentTSO->stackobj, n))) +#define SafeSpBP(off_w) \ + ( (WITHIN_CAP_CHUNK_BOUNDS_W((1+(off_w))/sizeof(StgWord))) ? \ + Sp_plusB(off_w) : \ + (void*)((ptrdiff_t)((ptrdiff_t)(off_w) % (ptrdiff_t)sizeof(StgWord)) + (StgWord8*)slow_spw(Sp, cap->r.rCurrentTSO->stackobj, (off_w)/sizeof(StgWord))) \ + ) + + + +/* Note [Interpreter subword primops] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general the interpreter stack is host-platform word aligned. +We keep with this convention when evaluating primops for simplicity. + +This means: + +* All arguments are pushed extended to word size. +* Results are written to the stack extended to word size. +The only exception are constructor allocations where we push unaligned subwords +on the stack which are cleaned up by the PACK instruction afterwards. + +*/ STATIC_INLINE StgPtr allocate_NONUPD (Capability *cap, int n_words) @@ -392,11 +433,12 @@ StgClosure * copyPAP (Capability *cap, StgPAP *oldpap) // See Note [PUSH_L underflow] for in which situations this // slow lookup is needed -static StgWord -slow_spw(void *Sp, StgStack *cur_stack, StgWord offset){ - // 1. If in range, access the item from the current stack chunk - if (WITHIN_CHUNK_BOUNDS(offset, cur_stack)) { - return SpW(offset); +// Returns a pointer to the stack location. +static void* +slow_spw(void *Sp, StgStack *cur_stack, StgWord offset_words){ + // 1. If in range, simply return ptr+offset_words pointing into the current stack chunk + if (WITHIN_CHUNK_BOUNDS_W(offset_words, cur_stack)) { + return Sp_plusW(offset_words); } // 2. Not in this stack chunk, so access the underflow frame. else { @@ -420,21 +462,19 @@ slow_spw(void *Sp, StgStack *cur_stack, StgWord offset){ // How many words were on the stack stackWords = (StgWord *)frame - (StgWord *) Sp; - ASSERT(offset > stackWords); + ASSERT(offset_words > stackWords); // Recursive, in the very unlikely case we have to traverse two // stack chunks. - return slow_spw(new_stack->sp, new_stack, offset-stackWords); + return slow_spw(new_stack->sp, new_stack, offset_words-stackWords); } // 2b. Access the element if there is no underflow frame, it must be right // at the top of the stack. else { // Not actually in the underflow case - return SpW(offset); + return Sp_plusW(offset_words); } - } - } // Compute the pointer tag for the constructor and tag the pointer; @@ -883,7 +923,7 @@ do_return_nonpointer: // get the offset of the header of the next stack frame offset = stack_frame_sizeW((StgClosure *)Sp); - switch (get_itbl((StgClosure*)(Sp_plusW(offset)))->type) { + switch (get_itbl((StgClosure*)(SafeSpWP(offset)))->type) { case RET_BCO: // Returning to an interpreted continuation: pop the return frame @@ -1236,9 +1276,9 @@ run_BCO: #endif bci = BCO_NEXT; - /* We use the high 8 bits for flags, only the highest of which is - * currently allocated */ - ASSERT((bci & 0xFF00) == (bci & 0x8000)); + /* We use the high 8 bits for flags. The highest of which is + * currently allocated to LARGE_ARGS */ + ASSERT((bci & 0xFF00) == (bci & ( bci_FLAG_LARGE_ARGS ))); switch (bci & 0xFF) { @@ -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,188 @@ run_BCO: RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding); } +// op :: ty -> ty +#define UN_SIZED_OP(op,ty) \ + { \ + if(sizeof(ty) == 8) { \ + ty r = op ((ty) ReadSpW64(0)); \ + SpW64(0) = (StgWord64) r; \ + } else { \ + ty r = op ((ty) ReadSpW(0)); \ + SpW(0) = (StgWord) r; \ + } \ + goto nextInsn; \ + } + +// op :: ty -> ty -> ty +#define SIZED_BIN_OP(op,ty) \ + { \ + if(sizeof(ty) == 8) { \ + ty r = ((ty) ReadSpW64(0)) op ((ty) ReadSpW64(1)); \ + Sp_addW64(1); \ + SpW64(0) = (StgWord64) r; \ + } else { \ + ty r = ((ty) ReadSpW(0)) op ((ty) ReadSpW(1)); \ + Sp_addW(1); \ + SpW(0) = (StgWord) r; \ + }; \ + goto nextInsn; \ + } + +// op :: ty -> Int -> ty +#define SIZED_BIN_OP_TY_INT(op,ty) \ +{ \ + if(sizeof(ty) > sizeof(StgWord)) { \ + ty r = ((ty) ReadSpW64(0)) op ((ty) ReadSpW(2)); \ + Sp_addW(1); \ + SpW64(0) = (StgWord64) r; \ + } else { \ + ty r = ((ty) ReadSpW(0)) op ((ty) ReadSpW(1)); \ + Sp_addW(1); \ + SpW(0) = (StgWord) r; \ + }; \ + goto nextInsn; \ +} + + case bci_OP_ADD_64: SIZED_BIN_OP(+, StgInt64) + case bci_OP_SUB_64: SIZED_BIN_OP(-, StgInt64) + case bci_OP_AND_64: SIZED_BIN_OP(&, StgInt64) + case bci_OP_XOR_64: SIZED_BIN_OP(^, StgInt64) + case bci_OP_OR_64: SIZED_BIN_OP(|, StgInt64) + case bci_OP_MUL_64: SIZED_BIN_OP(*, StgInt64) + case bci_OP_SHL_64: SIZED_BIN_OP_TY_INT(<<, StgWord64) + case bci_OP_LSR_64: SIZED_BIN_OP_TY_INT(>>, StgWord64) + case bci_OP_ASR_64: SIZED_BIN_OP_TY_INT(>>, StgInt64) + + case bci_OP_NEQ_64: SIZED_BIN_OP(!=, StgWord64) + case bci_OP_EQ_64: SIZED_BIN_OP(==, StgWord64) + case bci_OP_U_GT_64: SIZED_BIN_OP(>, StgWord64) + case bci_OP_U_GE_64: SIZED_BIN_OP(>=, StgWord64) + case bci_OP_U_LT_64: SIZED_BIN_OP(<, StgWord64) + case bci_OP_U_LE_64: SIZED_BIN_OP(<=, StgWord64) + + case bci_OP_S_GT_64: SIZED_BIN_OP(>, StgInt64) + case bci_OP_S_GE_64: SIZED_BIN_OP(>=, StgInt64) + case bci_OP_S_LT_64: SIZED_BIN_OP(<, StgInt64) + case bci_OP_S_LE_64: SIZED_BIN_OP(<=, StgInt64) + + case bci_OP_NOT_64: UN_SIZED_OP(~, StgWord64) + case bci_OP_NEG_64: UN_SIZED_OP(-, StgInt64) + + + case bci_OP_ADD_32: SIZED_BIN_OP(+, StgInt32) + case bci_OP_SUB_32: SIZED_BIN_OP(-, StgInt32) + case bci_OP_AND_32: SIZED_BIN_OP(&, StgInt32) + case bci_OP_XOR_32: SIZED_BIN_OP(^, StgInt32) + case bci_OP_OR_32: SIZED_BIN_OP(|, StgInt32) + case bci_OP_MUL_32: SIZED_BIN_OP(*, StgInt32) + case bci_OP_SHL_32: SIZED_BIN_OP_TY_INT(<<, StgWord32) + case bci_OP_LSR_32: SIZED_BIN_OP_TY_INT(>>, StgWord32) + case bci_OP_ASR_32: SIZED_BIN_OP_TY_INT(>>, StgInt32) + + case bci_OP_NEQ_32: SIZED_BIN_OP(!=, StgWord32) + case bci_OP_EQ_32: SIZED_BIN_OP(==, StgWord32) + case bci_OP_U_GT_32: SIZED_BIN_OP(>, StgWord32) + case bci_OP_U_GE_32: SIZED_BIN_OP(>=, StgWord32) + case bci_OP_U_LT_32: SIZED_BIN_OP(<, StgWord32) + case bci_OP_U_LE_32: SIZED_BIN_OP(<=, StgWord32) + + case bci_OP_S_GT_32: SIZED_BIN_OP(>, StgInt32) + case bci_OP_S_GE_32: SIZED_BIN_OP(>=, StgInt32) + case bci_OP_S_LT_32: SIZED_BIN_OP(<, StgInt32) + case bci_OP_S_LE_32: SIZED_BIN_OP(<=, StgInt32) + + case bci_OP_NOT_32: UN_SIZED_OP(~, StgWord32) + case bci_OP_NEG_32: UN_SIZED_OP(-, StgInt32) + + + case bci_OP_ADD_16: SIZED_BIN_OP(+, StgInt16) + case bci_OP_SUB_16: SIZED_BIN_OP(-, StgInt16) + case bci_OP_AND_16: SIZED_BIN_OP(&, StgInt16) + case bci_OP_XOR_16: SIZED_BIN_OP(^, StgInt16) + case bci_OP_OR_16: SIZED_BIN_OP(|, StgInt16) + case bci_OP_MUL_16: SIZED_BIN_OP(*, StgInt16) + case bci_OP_SHL_16: SIZED_BIN_OP_TY_INT(<<, StgWord16) + case bci_OP_LSR_16: SIZED_BIN_OP_TY_INT(>>, StgWord16) + case bci_OP_ASR_16: SIZED_BIN_OP_TY_INT(>>, StgInt16) + + case bci_OP_NEQ_16: SIZED_BIN_OP(!=, StgWord16) + case bci_OP_EQ_16: SIZED_BIN_OP(==, StgWord16) + case bci_OP_U_GT_16: SIZED_BIN_OP(>, StgWord16) + case bci_OP_U_GE_16: SIZED_BIN_OP(>=, StgWord16) + case bci_OP_U_LT_16: SIZED_BIN_OP(<, StgWord16) + case bci_OP_U_LE_16: SIZED_BIN_OP(<=, StgWord16) + + case bci_OP_S_GT_16: SIZED_BIN_OP(>, StgInt16) + case bci_OP_S_GE_16: SIZED_BIN_OP(>=, StgInt16) + case bci_OP_S_LT_16: SIZED_BIN_OP(<, StgInt16) + case bci_OP_S_LE_16: SIZED_BIN_OP(<=, StgInt16) + + case bci_OP_NOT_16: UN_SIZED_OP(~, StgWord16) + case bci_OP_NEG_16: UN_SIZED_OP(-, StgInt16) + + + case bci_OP_ADD_08: SIZED_BIN_OP(+, StgInt8) + case bci_OP_SUB_08: SIZED_BIN_OP(-, StgInt8) + case bci_OP_AND_08: SIZED_BIN_OP(&, StgInt8) + case bci_OP_XOR_08: SIZED_BIN_OP(^, StgInt8) + case bci_OP_OR_08: SIZED_BIN_OP(|, StgInt8) + case bci_OP_MUL_08: SIZED_BIN_OP(*, StgInt8) + case bci_OP_SHL_08: SIZED_BIN_OP_TY_INT(<<, StgWord8) + case bci_OP_LSR_08: SIZED_BIN_OP_TY_INT(>>, StgWord8) + case bci_OP_ASR_08: SIZED_BIN_OP_TY_INT(>>, StgInt8) + + case bci_OP_NEQ_08: SIZED_BIN_OP(!=, StgWord8) + case bci_OP_EQ_08: SIZED_BIN_OP(==, StgWord8) + case bci_OP_U_GT_08: SIZED_BIN_OP(>, StgWord8) + case bci_OP_U_GE_08: SIZED_BIN_OP(>=, StgWord8) + case bci_OP_U_LT_08: SIZED_BIN_OP(<, StgWord8) + case bci_OP_U_LE_08: SIZED_BIN_OP(<=, StgWord8) + + case bci_OP_S_GT_08: SIZED_BIN_OP(>, StgInt8) + case bci_OP_S_GE_08: SIZED_BIN_OP(>=, StgInt8) + case bci_OP_S_LT_08: SIZED_BIN_OP(<, StgInt8) + case bci_OP_S_LE_08: SIZED_BIN_OP(<=, StgInt8) + + case bci_OP_NOT_08: UN_SIZED_OP(~, StgWord8) + case bci_OP_NEG_08: UN_SIZED_OP(-, StgInt8) + + case bci_OP_INDEX_ADDR_64: + { + StgWord64* addr = (StgWord64*) SpW(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,31 @@ +{-# 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#Word + IO (\s -> case writeWordOffAddr# (byte_addr bytes) 0# val s of s2 -> (# s2,() #)) + putStrLn . flip showHex "" $ W64# (indexWord64OffAddr# (byte_addr bytes) 0#) + putStrLn . flip showHex "" $ W# (indexWordOffAddr# (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,5 @@ +1122334455667788 +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/35ab30539e6928b8b99391faa3cd546… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/35ab30539e6928b8b99391faa3cd546… You're receiving this email because of your account on gitlab.haskell.org.

1 0