[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 9 commits: dataToTag#: Skip runtime tag check if argument is infered tagged
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Mon Aug 8 21:19:35 UTC 2022
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
742292e4 by Andreas Klebinger at 2022-08-08T16:46:37-04:00
dataToTag#: Skip runtime tag check if argument is infered tagged
This addresses one part of #21710.
- - - - -
1504a93e by Cheng Shao at 2022-08-08T16:47:14-04:00
rts: remove redundant stg_traceCcszh
This out-of-line primop has no Haskell wrapper and hasn't been used
anywhere in the tree. Furthermore, the code gets in the way of !7632, so
it should be garbage collected.
- - - - -
a52de3cb by Andreas Klebinger at 2022-08-08T16:47:50-04:00
Document a divergence from the report in parsing function lhss.
GHC is happy to parse `(f) x y = x + y` when it should be a parse error
based on the Haskell report. Seems harmless enough so we won't fix it
but it's documented now.
Fixes #19788
- - - - -
5765e133 by Ben Gamari at 2022-08-08T16:48:25-04:00
gitlab-ci: Add release job for aarch64/debian 11
- - - - -
29da2923 by Ben Gamari at 2022-08-08T17:19:14-04:00
gitlab-ci: Introduce validation job for aarch64 cross-compilation
Begins to address #11958.
- - - - -
9839ea34 by Ben Gamari at 2022-08-08T17:19:14-04:00
Bump process submodule
- - - - -
6c702af0 by Ben Gamari at 2022-08-08T17:19:15-04:00
gitlab-ci: Add basic support for cross-compiler testiing
Here we add a simple qemu-based test for cross-compilers.
- - - - -
b5511288 by Ben Gamari at 2022-08-08T17:19:15-04:00
rts: Ensure that Array# card arrays are initialized
In #19143 I noticed that newArray# failed to initialize the card table
of newly-allocated arrays. However, embarrassingly, I then only fixed
the issue in newArrayArray# and, in so doing, introduced the potential
for an integer underflow on zero-length arrays (#21962).
Here I fix the issue in newArray#, this time ensuring that we do not
underflow in pathological cases.
Fixes #19143.
- - - - -
37ece3c6 by Ben Gamari at 2022-08-08T17:19:15-04:00
testsuite: Add test for #21962
- - - - -
17 changed files:
- .gitlab-ci.yml
- .gitlab/ci.sh
- .gitlab/gen_ci.hs
- .gitlab/jobs.yaml
- compiler/GHC/Stg/InferTags/Rewrite.hs
- compiler/GHC/StgToCmm/Expr.hs
- docs/users_guide/bugs.rst
- libraries/process
- rts/PrimOps.cmm
- rts/RtsSymbols.c
- rts/include/Cmm.h
- rts/include/stg/MiscClosures.h
- + testsuite/tests/array/should_run/T21962.hs
- testsuite/tests/array/should_run/all.T
- + testsuite/tests/codeGen/should_compile/T21710a.hs
- + testsuite/tests/codeGen/should_compile/T21710a.stderr
- testsuite/tests/codeGen/should_compile/all.T
Changes:
=====================================
.gitlab-ci.yml
=====================================
@@ -2,7 +2,7 @@ variables:
GIT_SSL_NO_VERIFY: "1"
# Commit of ghc/ci-images repository from which to pull Docker images
- DOCKER_REV: 58d08589371e78829a3279c6f8b1241e155d7f70
+ DOCKER_REV: 9e4c540d9e4972a36291dfdf81f079f37d748890
# Sequential version number of all cached things.
# Bump to invalidate GitLab CI cache.
=====================================
.gitlab/ci.sh
=====================================
@@ -93,6 +93,7 @@ Environment variables determining build configuration of Hadrian system:
BUILD_FLAVOUR Which flavour to build.
REINSTALL_GHC Build and test a reinstalled "stage3" ghc built using cabal-install
This tests the "reinstall" configuration
+ CROSS_EMULATOR The emulator to use for testing of cross-compilers.
Environment variables determining bootstrap toolchain (Linux):
@@ -564,15 +565,38 @@ function make_install_destdir() {
fi
info "merging file tree from $destdir to $instdir"
cp -a "$destdir/$instdir"/* "$instdir"/
- "$instdir"/bin/ghc-pkg recache
+ "$instdir"/bin/${cross_prefix}ghc-pkg recache
}
-function test_hadrian() {
- if [ -n "${CROSS_TARGET:-}" ]; then
- info "Can't test cross-compiled build."
- return
- fi
+# install the binary distribution in directory $1 to $2.
+function install_bindist() {
+ local bindist="$1"
+ local instdir="$2"
+ pushd "$bindist"
+ case "$(uname)" in
+ MSYS_*|MINGW*)
+ mkdir -p "$instdir"
+ cp -a * "$instdir"
+ ;;
+ *)
+ read -r -a args <<< "${INSTALL_CONFIGURE_ARGS:-}"
+
+ # FIXME: The bindist configure script shouldn't need to be reminded of
+ # the target platform. See #21970.
+ if [ -n "${CROSS_TARGET:-}" ]; then
+ args+=( "--target=$CROSS_TARGET" "--host=$CROSS_TARGET" )
+ fi
+ run ./configure \
+ --prefix="$instdir" \
+ "${args[@]+"${args[@]}"}"
+ make_install_destdir "$TOP"/destdir "$instdir"
+ ;;
+ esac
+ popd
+}
+
+function test_hadrian() {
check_msys2_deps _build/stage1/bin/ghc --version
check_release_build
@@ -593,7 +617,21 @@ function test_hadrian() {
fi
- if [[ -n "${REINSTALL_GHC:-}" ]]; then
+ if [ -n "${CROSS_TARGET:-}" ]; then
+ if [ -n "${CROSS_EMULATOR:-}" ]; then
+ local instdir="$TOP/_build/install"
+ local test_compiler="$instdir/bin/${cross_prefix}ghc$exe"
+ install_bindist _build/bindist/ghc-*/ "$instdir"
+ echo 'main = putStrLn "hello world"' > hello.hs
+ echo "hello world" > expected
+ run "$test_compiler" hello.hs
+ $CROSS_EMULATOR ./hello > actual
+ run diff expected actual
+ else
+ info "Cannot test cross-compiled build without CROSS_EMULATOR being set."
+ return
+ fi
+ elif [[ -n "${REINSTALL_GHC:-}" ]]; then
run_hadrian \
test \
--test-root-dirs=testsuite/tests/stage1 \
@@ -602,20 +640,9 @@ function test_hadrian() {
--test-root-dirs=testsuite/tests/typecheck \
"runtest.opts+=${RUNTEST_ARGS:-}" || fail "hadrian cabal-install test"
else
- cd _build/bindist/ghc-*/
- case "$(uname)" in
- MSYS_*|MINGW*)
- mkdir -p "$TOP"/_build/install
- cp -a * "$TOP"/_build/install
- ;;
- *)
- read -r -a args <<< "${INSTALL_CONFIGURE_ARGS:-}"
- run ./configure --prefix="$TOP"/_build/install "${args[@]+"${args[@]}"}"
- make_install_destdir "$TOP"/destdir "$TOP"/_build/install
- ;;
- esac
- cd ../../../
- test_compiler="$TOP/_build/install/bin/ghc$exe"
+ local instdir="$TOP/_build/install"
+ local test_compiler="$instdir/bin/ghc$exe"
+ install_bindist _build/bindist/ghc-*/ "$instdir"
if [[ "${WINDOWS_HOST}" == "no" ]]; then
run_hadrian \
@@ -779,6 +806,9 @@ esac
if [ -n "${CROSS_TARGET:-}" ]; then
info "Cross-compiling for $CROSS_TARGET..."
target_triple="$CROSS_TARGET"
+ cross_prefix="$target_triple-"
+else
+ cross_prefix=""
fi
echo "Branch name ${CI_MERGE_REQUEST_SOURCE_BRANCH_NAME:-}"
=====================================
.gitlab/gen_ci.hs
=====================================
@@ -116,6 +116,8 @@ data BuildConfig
, llvmBootstrap :: Bool
, withAssertions :: Bool
, withNuma :: Bool
+ , crossTarget :: Maybe String
+ , crossEmulator :: Maybe String
, fullyStatic :: Bool
, tablesNextToCode :: Bool
, threadSanitiser :: Bool
@@ -126,6 +128,7 @@ configureArgsStr :: BuildConfig -> String
configureArgsStr bc = intercalate " " $
["--enable-unregisterised"| unregisterised bc ]
++ ["--disable-tables-next-to-code" | not (tablesNextToCode bc) ]
+ ++ ["--with-intree-gmp" | Just _ <- pure (crossTarget bc) ]
-- Compute the hadrian flavour from the BuildConfig
mkJobFlavour :: BuildConfig -> Flavour
@@ -156,6 +159,8 @@ vanilla = BuildConfig
, llvmBootstrap = False
, withAssertions = False
, withNuma = False
+ , crossTarget = Nothing
+ , crossEmulator = Nothing
, fullyStatic = False
, tablesNextToCode = True
, threadSanitiser = False
@@ -186,6 +191,14 @@ static = vanilla { fullyStatic = True }
staticNativeInt :: BuildConfig
staticNativeInt = static { bignumBackend = Native }
+crossConfig :: String -- ^ target triple
+ -> Maybe String -- ^ emulator for testing
+ -> BuildConfig
+crossConfig triple emulator =
+ vanilla { crossTarget = Just triple
+ , crossEmulator = emulator
+ }
+
llvm :: BuildConfig
llvm = vanilla { llvmBootstrap = True }
@@ -252,6 +265,7 @@ testEnv arch opsys bc = intercalate "-" $
++ ["unreg" | unregisterised bc ]
++ ["numa" | withNuma bc ]
++ ["no_tntc" | not (tablesNextToCode bc) ]
+ ++ ["cross_"++triple | Just triple <- pure $ crossTarget bc ]
++ [flavourString (mkJobFlavour bc)]
-- | The hadrian flavour string we are going to use for this build
@@ -597,7 +611,8 @@ job arch opsys buildConfig = (jobName, Job {..})
, "BUILD_FLAVOUR" =: flavourString jobFlavour
, "BIGNUM_BACKEND" =: bignumString (bignumBackend buildConfig)
, "CONFIGURE_ARGS" =: configureArgsStr buildConfig
-
+ , maybe M.empty ("CROSS_TARGET" =:) (crossTarget buildConfig)
+ , maybe M.empty ("CROSS_EMULATOR" =:) (crossEmulator buildConfig)
, if withNuma buildConfig then "ENABLE_NUMA" =: "1" else M.empty
]
@@ -769,10 +784,12 @@ jobs = M.fromList $ concatMap flattenJobGroup $
, allowFailureGroup (addValidateRule FreeBSDTag (standardBuilds Amd64 FreeBSD))
, standardBuilds AArch64 Darwin
, standardBuilds AArch64 (Linux Debian10)
+ , disableValidate (standardBuilds AArch64 (Linux Debian11))
, allowFailureGroup (disableValidate (standardBuilds ARMv7 (Linux Debian10)))
, standardBuilds I386 (Linux Debian9)
, allowFailureGroup (standardBuildsWithConfig Amd64 (Linux Alpine) static)
, disableValidate (allowFailureGroup (standardBuildsWithConfig Amd64 (Linux Alpine) staticNativeInt))
+ , validateBuilds Amd64 (Linux Debian11) (crossConfig "aarch64-linux-gnu" (Just "qemu-aarch64 -L /usr/aarch64-linux-gnu"))
]
where
=====================================
.gitlab/jobs.yaml
=====================================
@@ -120,6 +120,64 @@
"TEST_ENV": "aarch64-linux-deb10-validate"
}
},
+ "aarch64-linux-deb11-validate": {
+ "after_script": [
+ ".gitlab/ci.sh save_cache",
+ ".gitlab/ci.sh clean",
+ "cat ci_timings"
+ ],
+ "allow_failure": false,
+ "artifacts": {
+ "expire_in": "2 weeks",
+ "paths": [
+ "ghc-aarch64-linux-deb11-validate.tar.xz",
+ "junit.xml"
+ ],
+ "reports": {
+ "junit": "junit.xml"
+ },
+ "when": "always"
+ },
+ "cache": {
+ "key": "aarch64-linux-deb11-$CACHE_REV",
+ "paths": [
+ "cabal-cache",
+ "toolchain"
+ ]
+ },
+ "dependencies": [],
+ "image": "registry.gitlab.haskell.org/ghc/ci-images/aarch64-linux-deb11:$DOCKER_REV",
+ "needs": [
+ {
+ "artifacts": false,
+ "job": "hadrian-ghc-in-ghci"
+ }
+ ],
+ "rules": [
+ {
+ "if": "($CI_MERGE_REQUEST_LABELS !~ /.*fast-ci.*/) && ($RELEASE_JOB != \"yes\") && ($NIGHTLY == null) && (\"true\" == \"true\") && (\"true\" == \"true\") && (\"disabled\" != \"disabled\")",
+ "when": "on_success"
+ }
+ ],
+ "script": [
+ "sudo chown ghc:ghc -R .",
+ ".gitlab/ci.sh setup",
+ ".gitlab/ci.sh configure",
+ ".gitlab/ci.sh build_hadrian",
+ ".gitlab/ci.sh test_hadrian"
+ ],
+ "stage": "full-build",
+ "tags": [
+ "aarch64-linux"
+ ],
+ "variables": {
+ "BIGNUM_BACKEND": "gmp",
+ "BIN_DIST_NAME": "ghc-aarch64-linux-deb11-validate",
+ "BUILD_FLAVOUR": "validate",
+ "CONFIGURE_ARGS": "",
+ "TEST_ENV": "aarch64-linux-deb11-validate"
+ }
+ },
"armv7-linux-deb10-validate": {
"after_script": [
".gitlab/ci.sh save_cache",
@@ -358,6 +416,65 @@
"XZ_OPT": "-9"
}
},
+ "nightly-aarch64-linux-deb11-validate": {
+ "after_script": [
+ ".gitlab/ci.sh save_cache",
+ ".gitlab/ci.sh clean",
+ "cat ci_timings"
+ ],
+ "allow_failure": false,
+ "artifacts": {
+ "expire_in": "8 weeks",
+ "paths": [
+ "ghc-aarch64-linux-deb11-validate.tar.xz",
+ "junit.xml"
+ ],
+ "reports": {
+ "junit": "junit.xml"
+ },
+ "when": "always"
+ },
+ "cache": {
+ "key": "aarch64-linux-deb11-$CACHE_REV",
+ "paths": [
+ "cabal-cache",
+ "toolchain"
+ ]
+ },
+ "dependencies": [],
+ "image": "registry.gitlab.haskell.org/ghc/ci-images/aarch64-linux-deb11:$DOCKER_REV",
+ "needs": [
+ {
+ "artifacts": false,
+ "job": "hadrian-ghc-in-ghci"
+ }
+ ],
+ "rules": [
+ {
+ "if": "($CI_MERGE_REQUEST_LABELS !~ /.*fast-ci.*/) && ($RELEASE_JOB != \"yes\") && ($NIGHTLY) && (\"true\" == \"true\") && (\"true\" == \"true\") && (\"true\" == \"true\")",
+ "when": "on_success"
+ }
+ ],
+ "script": [
+ "sudo chown ghc:ghc -R .",
+ ".gitlab/ci.sh setup",
+ ".gitlab/ci.sh configure",
+ ".gitlab/ci.sh build_hadrian",
+ ".gitlab/ci.sh test_hadrian"
+ ],
+ "stage": "full-build",
+ "tags": [
+ "aarch64-linux"
+ ],
+ "variables": {
+ "BIGNUM_BACKEND": "gmp",
+ "BIN_DIST_NAME": "ghc-aarch64-linux-deb11-validate",
+ "BUILD_FLAVOUR": "validate",
+ "CONFIGURE_ARGS": "",
+ "TEST_ENV": "aarch64-linux-deb11-validate",
+ "XZ_OPT": "-9"
+ }
+ },
"nightly-armv7-linux-deb10-validate": {
"after_script": [
".gitlab/ci.sh save_cache",
@@ -1261,6 +1378,67 @@
"XZ_OPT": "-9"
}
},
+ "nightly-x86_64-linux-deb11-cross_aarch64-linux-gnu-validate": {
+ "after_script": [
+ ".gitlab/ci.sh save_cache",
+ ".gitlab/ci.sh clean",
+ "cat ci_timings"
+ ],
+ "allow_failure": false,
+ "artifacts": {
+ "expire_in": "8 weeks",
+ "paths": [
+ "ghc-x86_64-linux-deb11-cross_aarch64-linux-gnu-validate.tar.xz",
+ "junit.xml"
+ ],
+ "reports": {
+ "junit": "junit.xml"
+ },
+ "when": "always"
+ },
+ "cache": {
+ "key": "x86_64-linux-deb11-$CACHE_REV",
+ "paths": [
+ "cabal-cache",
+ "toolchain"
+ ]
+ },
+ "dependencies": [],
+ "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb11:$DOCKER_REV",
+ "needs": [
+ {
+ "artifacts": false,
+ "job": "hadrian-ghc-in-ghci"
+ }
+ ],
+ "rules": [
+ {
+ "if": "($CI_MERGE_REQUEST_LABELS !~ /.*fast-ci.*/) && ($RELEASE_JOB != \"yes\") && ($NIGHTLY) && (\"true\" == \"true\") && (\"true\" == \"true\") && (\"true\" == \"true\")",
+ "when": "on_success"
+ }
+ ],
+ "script": [
+ "sudo chown ghc:ghc -R .",
+ ".gitlab/ci.sh setup",
+ ".gitlab/ci.sh configure",
+ ".gitlab/ci.sh build_hadrian",
+ ".gitlab/ci.sh test_hadrian"
+ ],
+ "stage": "full-build",
+ "tags": [
+ "x86_64-linux"
+ ],
+ "variables": {
+ "BIGNUM_BACKEND": "gmp",
+ "BIN_DIST_NAME": "ghc-x86_64-linux-deb11-cross_aarch64-linux-gnu-validate",
+ "BUILD_FLAVOUR": "validate",
+ "CONFIGURE_ARGS": "--with-intree-gmp",
+ "CROSS_EMULATOR": "qemu-aarch64 -L /usr/aarch64-linux-gnu",
+ "CROSS_TARGET": "aarch64-linux-gnu",
+ "TEST_ENV": "x86_64-linux-deb11-cross_aarch64-linux-gnu-validate",
+ "XZ_OPT": "-9"
+ }
+ },
"nightly-x86_64-linux-deb11-validate": {
"after_script": [
".gitlab/ci.sh save_cache",
@@ -1864,6 +2042,66 @@
"XZ_OPT": "-9"
}
},
+ "release-aarch64-linux-deb11-release": {
+ "after_script": [
+ ".gitlab/ci.sh save_cache",
+ ".gitlab/ci.sh clean",
+ "cat ci_timings"
+ ],
+ "allow_failure": false,
+ "artifacts": {
+ "expire_in": "1 year",
+ "paths": [
+ "ghc-aarch64-linux-deb11-release.tar.xz",
+ "junit.xml"
+ ],
+ "reports": {
+ "junit": "junit.xml"
+ },
+ "when": "always"
+ },
+ "cache": {
+ "key": "aarch64-linux-deb11-$CACHE_REV",
+ "paths": [
+ "cabal-cache",
+ "toolchain"
+ ]
+ },
+ "dependencies": [],
+ "image": "registry.gitlab.haskell.org/ghc/ci-images/aarch64-linux-deb11:$DOCKER_REV",
+ "needs": [
+ {
+ "artifacts": false,
+ "job": "hadrian-ghc-in-ghci"
+ }
+ ],
+ "rules": [
+ {
+ "if": "($CI_MERGE_REQUEST_LABELS !~ /.*fast-ci.*/) && ($RELEASE_JOB == \"yes\") && ($NIGHTLY == null) && (\"true\" == \"true\") && (\"true\" == \"true\") && (\"true\" == \"true\")",
+ "when": "on_success"
+ }
+ ],
+ "script": [
+ "sudo chown ghc:ghc -R .",
+ ".gitlab/ci.sh setup",
+ ".gitlab/ci.sh configure",
+ ".gitlab/ci.sh build_hadrian",
+ ".gitlab/ci.sh test_hadrian"
+ ],
+ "stage": "full-build",
+ "tags": [
+ "aarch64-linux"
+ ],
+ "variables": {
+ "BIGNUM_BACKEND": "gmp",
+ "BIN_DIST_NAME": "ghc-aarch64-linux-deb11-release",
+ "BUILD_FLAVOUR": "release",
+ "CONFIGURE_ARGS": "",
+ "IGNORE_PERF_FAILURES": "all",
+ "TEST_ENV": "aarch64-linux-deb11-release",
+ "XZ_OPT": "-9"
+ }
+ },
"release-armv7-linux-deb10-release": {
"after_script": [
".gitlab/ci.sh save_cache",
@@ -3680,6 +3918,66 @@
"TSAN_OPTIONS": "suppressions=$CI_PROJECT_DIR/rts/.tsan-suppressions"
}
},
+ "x86_64-linux-deb11-cross_aarch64-linux-gnu-validate": {
+ "after_script": [
+ ".gitlab/ci.sh save_cache",
+ ".gitlab/ci.sh clean",
+ "cat ci_timings"
+ ],
+ "allow_failure": false,
+ "artifacts": {
+ "expire_in": "2 weeks",
+ "paths": [
+ "ghc-x86_64-linux-deb11-cross_aarch64-linux-gnu-validate.tar.xz",
+ "junit.xml"
+ ],
+ "reports": {
+ "junit": "junit.xml"
+ },
+ "when": "always"
+ },
+ "cache": {
+ "key": "x86_64-linux-deb11-$CACHE_REV",
+ "paths": [
+ "cabal-cache",
+ "toolchain"
+ ]
+ },
+ "dependencies": [],
+ "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb11:$DOCKER_REV",
+ "needs": [
+ {
+ "artifacts": false,
+ "job": "hadrian-ghc-in-ghci"
+ }
+ ],
+ "rules": [
+ {
+ "if": "($CI_MERGE_REQUEST_LABELS !~ /.*fast-ci.*/) && ($RELEASE_JOB != \"yes\") && ($NIGHTLY == null) && (\"true\" == \"true\") && (\"true\" == \"true\") && (\"true\" == \"true\")",
+ "when": "on_success"
+ }
+ ],
+ "script": [
+ "sudo chown ghc:ghc -R .",
+ ".gitlab/ci.sh setup",
+ ".gitlab/ci.sh configure",
+ ".gitlab/ci.sh build_hadrian",
+ ".gitlab/ci.sh test_hadrian"
+ ],
+ "stage": "full-build",
+ "tags": [
+ "x86_64-linux"
+ ],
+ "variables": {
+ "BIGNUM_BACKEND": "gmp",
+ "BIN_DIST_NAME": "ghc-x86_64-linux-deb11-cross_aarch64-linux-gnu-validate",
+ "BUILD_FLAVOUR": "validate",
+ "CONFIGURE_ARGS": "--with-intree-gmp",
+ "CROSS_EMULATOR": "qemu-aarch64 -L /usr/aarch64-linux-gnu",
+ "CROSS_TARGET": "aarch64-linux-gnu",
+ "TEST_ENV": "x86_64-linux-deb11-cross_aarch64-linux-gnu-validate"
+ }
+ },
"x86_64-linux-deb11-validate": {
"after_script": [
".gitlab/ci.sh save_cache",
=====================================
compiler/GHC/Stg/InferTags/Rewrite.hs
=====================================
@@ -20,6 +20,7 @@ where
import GHC.Prelude
+import GHC.Builtin.PrimOps ( PrimOp(..) )
import GHC.Types.Id
import GHC.Types.Name
import GHC.Types.Unique.Supply
@@ -346,6 +347,19 @@ fvArgs args = do
type IsScrut = Bool
+rewriteArgs :: [StgArg] -> RM [StgArg]
+rewriteArgs = mapM rewriteArg
+rewriteArg :: StgArg -> RM StgArg
+rewriteArg (StgVarArg v) = StgVarArg <$!> rewriteId v
+rewriteArg (lit at StgLitArg{}) = return lit
+
+-- Attach a tagSig if it's tagged
+rewriteId :: Id -> RM Id
+rewriteId v = do
+ is_tagged <- isTagged v
+ if is_tagged then return $! setIdTagSig v (TagSig TagProper)
+ else return v
+
rewriteExpr :: IsScrut -> InferStgExpr -> RM TgStgExpr
rewriteExpr _ (e at StgCase {}) = rewriteCase e
rewriteExpr _ (e at StgLet {}) = rewriteLet e
@@ -355,8 +369,11 @@ rewriteExpr _ e@(StgConApp {}) = rewriteConApp e
rewriteExpr isScrut e@(StgApp {}) = rewriteApp isScrut e
rewriteExpr _ (StgLit lit) = return $! (StgLit lit)
+rewriteExpr _ (StgOpApp op@(StgPrimOp DataToTagOp) args res_ty) = do
+ (StgOpApp op) <$!> rewriteArgs args <*> pure res_ty
rewriteExpr _ (StgOpApp op args res_ty) = return $! (StgOpApp op args res_ty)
+
rewriteCase :: InferStgExpr -> RM TgStgExpr
rewriteCase (StgCase scrut bndr alt_type alts) =
withBinder NotTopLevel bndr $
@@ -415,6 +432,7 @@ rewriteApp True (StgApp f []) = do
-- isTagged looks at more than the result of our analysis.
-- So always update here if useful.
let f' = if f_tagged
+ -- TODO: We might consisder using a subst env instead of setting the sig only for select places.
then setIdTagSig f (TagSig TagProper)
else f
return $! StgApp f' []
=====================================
compiler/GHC/StgToCmm/Expr.hs
=====================================
@@ -76,6 +76,8 @@ cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) =
-- dataToTag# :: a -> Int#
-- See Note [dataToTag# magic] in GHC.Core.Opt.ConstantFold
+-- TODO: There are some more optimization ideas for this code path
+-- in #21710
cgExpr (StgOpApp (StgPrimOp DataToTagOp) [StgVarArg a] _res_ty) = do
platform <- getPlatform
emitComment (mkFastString "dataToTag#")
@@ -92,15 +94,7 @@ cgExpr (StgOpApp (StgPrimOp DataToTagOp) [StgVarArg a] _res_ty) = do
-- the constructor index is too large to fit in the pointer and therefore
-- we must look in the info table. See Note [Tagging big families].
- slow_path <- getCode $ do
- tmp <- newTemp (bWord platform)
- _ <- withSequel (AssignTo [tmp] False) (cgIdApp a [])
- profile <- getProfile
- align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig
- emitAssign (CmmLocal result_reg)
- $ getConstrTag profile align_check (cmmUntag platform (CmmReg (CmmLocal tmp)))
-
- fast_path <- getCode $ do
+ (fast_path :: CmmAGraph) <- getCode $ do
-- Return the constructor index from the pointer tag
return_ptr_tag <- getCode $ do
emitAssign (CmmLocal result_reg)
@@ -113,8 +107,22 @@ cgExpr (StgOpApp (StgPrimOp DataToTagOp) [StgVarArg a] _res_ty) = do
$ getConstrTag profile align_check (cmmUntag platform amode)
emit =<< mkCmmIfThenElse' is_too_big_tag return_info_tag return_ptr_tag (Just False)
-
- emit =<< mkCmmIfThenElse' is_tagged fast_path slow_path (Just True)
+ -- If we know the argument is already tagged there is no need to generate code to evaluate it
+ -- so we skip straight to the fast path. If we don't know if there is a tag we take the slow
+ -- path which evaluates the argument before fetching the tag.
+ case (idTagSig_maybe a) of
+ Just sig
+ | isTaggedSig sig
+ -> emit fast_path
+ _ -> do
+ slow_path <- getCode $ do
+ tmp <- newTemp (bWord platform)
+ _ <- withSequel (AssignTo [tmp] False) (cgIdApp a [])
+ profile <- getProfile
+ align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig
+ emitAssign (CmmLocal result_reg)
+ $ getConstrTag profile align_check (cmmUntag platform (CmmReg (CmmLocal tmp)))
+ emit =<< mkCmmIfThenElse' is_tagged fast_path slow_path (Just True)
emitReturn [CmmReg $ CmmLocal result_reg]
=====================================
docs/users_guide/bugs.rst
=====================================
@@ -115,6 +115,10 @@ Lexical syntax
varid → small {idchar} ⟨reservedid⟩
conid → large {idchar}
+- GHC allows redundant parantheses around the function name in the `funlhs` part of declarations.
+ That is GHC will succeed in parsing a declaration like `((f)) x = <rhs>` for any number
+ of parantheses around `f`.
+
.. _infelicities-syntax:
Context-free syntax
=====================================
libraries/process
=====================================
@@ -1 +1 @@
-Subproject commit 7a7431a0ef586c0f1e602e382398b988c699dfc2
+Subproject commit b95e5fbdeb74e0cc36b6878b60f9807bd0001fa8
=====================================
rts/PrimOps.cmm
=====================================
@@ -350,6 +350,11 @@ stg_newArrayzh ( W_ n /* words */, gcptr init )
StgMutArrPtrs_ptrs(arr) = n;
StgMutArrPtrs_size(arr) = size;
+ /* Ensure that the card array is initialized */
+ if (n != 0) {
+ setCardsValue(arr, 0, n, 0);
+ }
+
// Initialise all elements of the array with the value in R2
p = arr + SIZEOF_StgMutArrPtrs;
for:
@@ -2801,21 +2806,6 @@ stg_getApStackValzh ( P_ ap_stack, W_ offset )
}
}
-// Write the cost center stack of the first argument on stderr; return
-// the second. Possibly only makes sense for already evaluated
-// things?
-stg_traceCcszh ( P_ obj, P_ ret )
-{
- W_ ccs;
-
-#if defined(PROFILING)
- ccs = StgHeader_ccs(UNTAG(obj));
- ccall fprintCCS_stderr(ccs "ptr");
-#endif
-
- jump stg_ap_0_fast(ret);
-}
-
stg_getSparkzh ()
{
W_ spark;
=====================================
rts/RtsSymbols.c
=====================================
@@ -1015,7 +1015,6 @@ extern char **environ;
SymI_HasProto(stopTimer) \
SymI_HasProto(n_capabilities) \
SymI_HasProto(enabled_capabilities) \
- SymI_HasDataProto(stg_traceCcszh) \
SymI_HasDataProto(stg_traceEventzh) \
SymI_HasDataProto(stg_traceMarkerzh) \
SymI_HasDataProto(stg_traceBinaryEventzh) \
=====================================
rts/include/Cmm.h
=====================================
@@ -870,10 +870,11 @@
/*
* Set the cards in the array pointed to by arr for an
* update to n elements, starting at element dst_off to value (0 to indicate
- * clean, 1 to indicate dirty).
+ * clean, 1 to indicate dirty). n must be non-zero.
*/
#define setCardsValue(arr, dst_off, n, value) \
W_ __start_card, __end_card, __cards, __dst_cards_p; \
+ ASSERT(n != 0); \
__dst_cards_p = (arr) + SIZEOF_StgMutArrPtrs + WDS(StgMutArrPtrs_ptrs(arr)); \
__start_card = mutArrPtrCardDown(dst_off); \
__end_card = mutArrPtrCardDown((dst_off) + (n) - 1); \
=====================================
rts/include/stg/MiscClosures.h
=====================================
@@ -566,7 +566,6 @@ RTS_FUN_DECL(stg_numSparkszh);
RTS_FUN_DECL(stg_noDuplicatezh);
-RTS_FUN_DECL(stg_traceCcszh);
RTS_FUN_DECL(stg_clearCCSzh);
RTS_FUN_DECL(stg_traceEventzh);
RTS_FUN_DECL(stg_traceBinaryEventzh);
=====================================
testsuite/tests/array/should_run/T21962.hs
=====================================
@@ -0,0 +1,11 @@
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE MagicHash #-}
+
+module Main where
+
+import GHC.IO
+import GHC.Exts
+
+main :: IO ()
+main = do
+ IO $ \s0 -> case newArray# 0# () s0 of (# s1, arr #) -> (# s1, () #)
=====================================
testsuite/tests/array/should_run/all.T
=====================================
@@ -23,3 +23,4 @@ test('arr017', when(fast(), skip), compile_and_run, [''])
test('arr018', when(fast(), skip), compile_and_run, [''])
test('arr019', normal, compile_and_run, [''])
test('arr020', normal, compile_and_run, [''])
+test('T21962', normal, compile_and_run, [''])
=====================================
testsuite/tests/codeGen/should_compile/T21710a.hs
=====================================
@@ -0,0 +1,15 @@
+{-# LANGUAGE MagicHash, UnboxedTuples #-}
+{-# OPTIONS_GHC -O #-}
+
+module M where
+
+import GHC.Exts
+
+data E = A | B | C | D | E
+
+foo x =
+ case x of
+ A -> 2#
+ B -> 42#
+ -- In this branch we already now `x` is evaluated, so we shouldn't generate an extra `call` for it.
+ _ -> dataToTag# x
=====================================
testsuite/tests/codeGen/should_compile/T21710a.stderr
=====================================
@@ -0,0 +1,446 @@
+
+==================== Output Cmm ====================
+[section ""cstring" . M.$tc'E2_bytes" {
+ M.$tc'E2_bytes:
+ I8[] "'E"
+ }]
+
+
+
+==================== Output Cmm ====================
+[section ""cstring" . M.$tc'D2_bytes" {
+ M.$tc'D2_bytes:
+ I8[] "'D"
+ }]
+
+
+
+==================== Output Cmm ====================
+[section ""cstring" . M.$tc'C2_bytes" {
+ M.$tc'C2_bytes:
+ I8[] "'C"
+ }]
+
+
+
+==================== Output Cmm ====================
+[section ""cstring" . M.$tc'B2_bytes" {
+ M.$tc'B2_bytes:
+ I8[] "'B"
+ }]
+
+
+
+==================== Output Cmm ====================
+[section ""cstring" . M.$tc'A3_bytes" {
+ M.$tc'A3_bytes:
+ I8[] "'A"
+ }]
+
+
+
+==================== Output Cmm ====================
+[section ""cstring" . M.$tcE2_bytes" {
+ M.$tcE2_bytes:
+ I8[] "E"
+ }]
+
+
+
+==================== Output Cmm ====================
+[section ""cstring" . M.$trModule2_bytes" {
+ M.$trModule2_bytes:
+ I8[] "M"
+ }]
+
+
+
+==================== Output Cmm ====================
+[section ""cstring" . M.$trModule4_bytes" {
+ M.$trModule4_bytes:
+ I8[] "main"
+ }]
+
+
+
+==================== Output Cmm ====================
+[M.foo_entry() { // [R2]
+ { info_tbls: [(cBa,
+ label: block_cBa_info
+ rep: StackRep []
+ srt: Nothing),
+ (cBi,
+ label: M.foo_info
+ rep: HeapRep static { Fun {arity: 1 fun_type: ArgSpec 5} }
+ srt: Nothing)]
+ stack_info: arg_space: 8
+ }
+ {offset
+ cBi: // global
+ if ((Sp + -8) < SpLim) (likely: False) goto cBj; else goto cBk; // CmmCondBranch
+ cBj: // global
+ R1 = M.foo_closure; // CmmAssign
+ call (stg_gc_fun)(R2, R1) args: 8, res: 0, upd: 8; // CmmCall
+ cBk: // global
+ I64[Sp - 8] = cBa; // CmmStore
+ R1 = R2; // CmmAssign
+ Sp = Sp - 8; // CmmAssign
+ if (R1 & 7 != 0) goto cBa; else goto cBb; // CmmCondBranch
+ cBb: // global
+ call (I64[R1])(R1) returns to cBa, args: 8, res: 8, upd: 8; // CmmCall
+ cBa: // global
+ _cBh::P64 = R1 & 7; // CmmAssign
+ if (_cBh::P64 != 1) goto uBz; else goto cBf; // CmmCondBranch
+ uBz: // global
+ if (_cBh::P64 != 2) goto cBe; else goto cBg; // CmmCondBranch
+ cBe: // global
+ // dataToTag#
+ _cBn::P64 = R1 & 7; // CmmAssign
+ if (_cBn::P64 == 7) (likely: False) goto cBs; else goto cBr; // CmmCondBranch
+ cBs: // global
+ _cBo::I64 = %MO_UU_Conv_W32_W64(I32[I64[R1 & (-8)] - 4]); // CmmAssign
+ goto cBq; // CmmBranch
+ cBr: // global
+ _cBo::I64 = _cBn::P64 - 1; // CmmAssign
+ goto cBq; // CmmBranch
+ cBq: // global
+ R1 = _cBo::I64; // CmmAssign
+ Sp = Sp + 8; // CmmAssign
+ call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall
+ cBg: // global
+ R1 = 42; // CmmAssign
+ Sp = Sp + 8; // CmmAssign
+ call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall
+ cBf: // global
+ R1 = 2; // CmmAssign
+ Sp = Sp + 8; // CmmAssign
+ call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall
+ }
+ },
+ section ""data" . M.foo_closure" {
+ M.foo_closure:
+ const M.foo_info;
+ }]
+
+
+
+==================== Output Cmm ====================
+[section ""data" . M.$trModule3_closure" {
+ M.$trModule3_closure:
+ const GHC.Types.TrNameS_con_info;
+ const M.$trModule4_bytes;
+ }]
+
+
+
+==================== Output Cmm ====================
+[section ""data" . M.$trModule1_closure" {
+ M.$trModule1_closure:
+ const GHC.Types.TrNameS_con_info;
+ const M.$trModule2_bytes;
+ }]
+
+
+
+==================== Output Cmm ====================
+[section ""data" . M.$trModule_closure" {
+ M.$trModule_closure:
+ const GHC.Types.Module_con_info;
+ const M.$trModule3_closure+1;
+ const M.$trModule1_closure+1;
+ const 3;
+ }]
+
+
+
+==================== Output Cmm ====================
+[section ""data" . M.$tcE1_closure" {
+ M.$tcE1_closure:
+ const GHC.Types.TrNameS_con_info;
+ const M.$tcE2_bytes;
+ }]
+
+
+
+==================== Output Cmm ====================
+[section ""data" . M.$tcE_closure" {
+ M.$tcE_closure:
+ const GHC.Types.TyCon_con_info;
+ const M.$trModule_closure+1;
+ const M.$tcE1_closure+1;
+ const GHC.Types.krep$*_closure+5;
+ const 10475418246443540865;
+ const 12461417314693222409;
+ const 0;
+ const 3;
+ }]
+
+
+
+==================== Output Cmm ====================
+[section ""data" . M.$tc'A1_closure" {
+ M.$tc'A1_closure:
+ const GHC.Types.KindRepTyConApp_con_info;
+ const M.$tcE_closure+1;
+ const GHC.Types.[]_closure+1;
+ const 3;
+ }]
+
+
+
+==================== Output Cmm ====================
+[section ""data" . M.$tc'A2_closure" {
+ M.$tc'A2_closure:
+ const GHC.Types.TrNameS_con_info;
+ const M.$tc'A3_bytes;
+ }]
+
+
+
+==================== Output Cmm ====================
+[section ""data" . M.$tc'A_closure" {
+ M.$tc'A_closure:
+ const GHC.Types.TyCon_con_info;
+ const M.$trModule_closure+1;
+ const M.$tc'A2_closure+1;
+ const M.$tc'A1_closure+1;
+ const 10991425535368257265;
+ const 3459663971500179679;
+ const 0;
+ const 3;
+ }]
+
+
+
+==================== Output Cmm ====================
+[section ""data" . M.$tc'B1_closure" {
+ M.$tc'B1_closure:
+ const GHC.Types.TrNameS_con_info;
+ const M.$tc'B2_bytes;
+ }]
+
+
+
+==================== Output Cmm ====================
+[section ""data" . M.$tc'B_closure" {
+ M.$tc'B_closure:
+ const GHC.Types.TyCon_con_info;
+ const M.$trModule_closure+1;
+ const M.$tc'B1_closure+1;
+ const M.$tc'A1_closure+1;
+ const 13038863156169552918;
+ const 13430333535161531545;
+ const 0;
+ const 3;
+ }]
+
+
+
+==================== Output Cmm ====================
+[section ""data" . M.$tc'C1_closure" {
+ M.$tc'C1_closure:
+ const GHC.Types.TrNameS_con_info;
+ const M.$tc'C2_bytes;
+ }]
+
+
+
+==================== Output Cmm ====================
+[section ""data" . M.$tc'C_closure" {
+ M.$tc'C_closure:
+ const GHC.Types.TyCon_con_info;
+ const M.$trModule_closure+1;
+ const M.$tc'C1_closure+1;
+ const M.$tc'A1_closure+1;
+ const 8482817676735632621;
+ const 8146597712321241387;
+ const 0;
+ const 3;
+ }]
+
+
+
+==================== Output Cmm ====================
+[section ""data" . M.$tc'D1_closure" {
+ M.$tc'D1_closure:
+ const GHC.Types.TrNameS_con_info;
+ const M.$tc'D2_bytes;
+ }]
+
+
+
+==================== Output Cmm ====================
+[section ""data" . M.$tc'D_closure" {
+ M.$tc'D_closure:
+ const GHC.Types.TyCon_con_info;
+ const M.$trModule_closure+1;
+ const M.$tc'D1_closure+1;
+ const M.$tc'A1_closure+1;
+ const 7525207739284160575;
+ const 13746130127476219356;
+ const 0;
+ const 3;
+ }]
+
+
+
+==================== Output Cmm ====================
+[section ""data" . M.$tc'E1_closure" {
+ M.$tc'E1_closure:
+ const GHC.Types.TrNameS_con_info;
+ const M.$tc'E2_bytes;
+ }]
+
+
+
+==================== Output Cmm ====================
+[section ""data" . M.$tc'E_closure" {
+ M.$tc'E_closure:
+ const GHC.Types.TyCon_con_info;
+ const M.$trModule_closure+1;
+ const M.$tc'E1_closure+1;
+ const M.$tc'A1_closure+1;
+ const 6748545530683684316;
+ const 10193016702094081137;
+ const 0;
+ const 3;
+ }]
+
+
+
+==================== Output Cmm ====================
+[section ""data" . M.A_closure" {
+ M.A_closure:
+ const M.A_con_info;
+ }]
+
+
+
+==================== Output Cmm ====================
+[section ""data" . M.B_closure" {
+ M.B_closure:
+ const M.B_con_info;
+ }]
+
+
+
+==================== Output Cmm ====================
+[section ""data" . M.C_closure" {
+ M.C_closure:
+ const M.C_con_info;
+ }]
+
+
+
+==================== Output Cmm ====================
+[section ""data" . M.D_closure" {
+ M.D_closure:
+ const M.D_con_info;
+ }]
+
+
+
+==================== Output Cmm ====================
+[section ""data" . M.E_closure" {
+ M.E_closure:
+ const M.E_con_info;
+ }]
+
+
+
+==================== Output Cmm ====================
+[section ""relreadonly" . M.E_closure_tbl" {
+ M.E_closure_tbl:
+ const M.A_closure+1;
+ const M.B_closure+2;
+ const M.C_closure+3;
+ const M.D_closure+4;
+ const M.E_closure+5;
+ }]
+
+
+
+==================== Output Cmm ====================
+[M.A_con_entry() { // []
+ { info_tbls: [(cC5,
+ label: M.A_con_info
+ rep: HeapRep 1 nonptrs { Con {tag: 0 descr:"main:M.A"} }
+ srt: Nothing)]
+ stack_info: arg_space: 8
+ }
+ {offset
+ cC5: // global
+ R1 = R1 + 1; // CmmAssign
+ call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall
+ }
+ }]
+
+
+
+==================== Output Cmm ====================
+[M.B_con_entry() { // []
+ { info_tbls: [(cCa,
+ label: M.B_con_info
+ rep: HeapRep 1 nonptrs { Con {tag: 1 descr:"main:M.B"} }
+ srt: Nothing)]
+ stack_info: arg_space: 8
+ }
+ {offset
+ cCa: // global
+ R1 = R1 + 2; // CmmAssign
+ call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall
+ }
+ }]
+
+
+
+==================== Output Cmm ====================
+[M.C_con_entry() { // []
+ { info_tbls: [(cCf,
+ label: M.C_con_info
+ rep: HeapRep 1 nonptrs { Con {tag: 2 descr:"main:M.C"} }
+ srt: Nothing)]
+ stack_info: arg_space: 8
+ }
+ {offset
+ cCf: // global
+ R1 = R1 + 3; // CmmAssign
+ call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall
+ }
+ }]
+
+
+
+==================== Output Cmm ====================
+[M.D_con_entry() { // []
+ { info_tbls: [(cCk,
+ label: M.D_con_info
+ rep: HeapRep 1 nonptrs { Con {tag: 3 descr:"main:M.D"} }
+ srt: Nothing)]
+ stack_info: arg_space: 8
+ }
+ {offset
+ cCk: // global
+ R1 = R1 + 4; // CmmAssign
+ call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall
+ }
+ }]
+
+
+
+==================== Output Cmm ====================
+[M.E_con_entry() { // []
+ { info_tbls: [(cCp,
+ label: M.E_con_info
+ rep: HeapRep 1 nonptrs { Con {tag: 4 descr:"main:M.E"} }
+ srt: Nothing)]
+ stack_info: arg_space: 8
+ }
+ {offset
+ cCp: // global
+ R1 = R1 + 5; // CmmAssign
+ call (P64[Sp])(R1) args: 8, res: 0, upd: 8; // CmmCall
+ }
+ }]
+
+
=====================================
testsuite/tests/codeGen/should_compile/all.T
=====================================
@@ -108,3 +108,4 @@ test('T18614', normal, compile, [''])
test('mk-big-obj',
[unless(opsys('mingw32'), skip), pre_cmd('$PYTHON mk-big-obj.py > mk-big-obj.c')],
multimod_compile, ['mk-big-obj.c', '-c -v0 -no-hs-main'])
+test('T21710a', [ only_ways(['optasm']), when(wordsize(32), skip), grep_errmsg('(call)',[1]) ], compile, ['-ddump-cmm -dno-typeable-binds'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5076c99beaf8d935937718d8d10037596ce5af2e...37ece3c67a9a75717d1f5be942d1f831df64994a
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5076c99beaf8d935937718d8d10037596ce5af2e...37ece3c67a9a75717d1f5be942d1f831df64994a
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20220808/d7863206/attachment-0001.html>
More information about the ghc-commits
mailing list