[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 6 commits: base: Advertise linear time of readFloat

Marge Bot (@marge-bot) gitlab at gitlab.haskell.org
Tue Sep 19 08:54:38 UTC 2023



Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC


Commits:
7ca0240e by Ben Gamari at 2023-09-18T15:16:48-04:00
base: Advertise linear time of readFloat

As noted in #23538, `readFloat` has runtime that scales nonlinearly in
the size of its input. Consequently, its use on untrusted input can
be exploited as a denial-of-service vector. Point this out and suggest
use of `read` instead.

See #23538.

- - - - -
f3f58f13 by Simon Peyton Jones at 2023-09-18T15:17:24-04:00
Remove dead code GHC.CoreToStg.Prep.canFloat

This function never fires, so we can delete it: #23965.

- - - - -
ccab5b15 by Ben Gamari at 2023-09-18T15:18:02-04:00
base/changelog: Move fix for #23907 to 9.8.1 section

Since the fix was backported to 9.8.1

- - - - -
03515da0 by Matthew Pickering at 2023-09-19T04:54:14-04:00
Add aarch64 alpine bindist

This is dynamically linked and makes creating statically linked
executables more straightforward.

Fixes #23482

- - - - -
18496c5b by Matthew Pickering at 2023-09-19T04:54:14-04:00
Add aarch64-deb11 bindist

This adds a debian 11 release job for aarch64.

Fixes #22005

- - - - -
bf71651a by Alexis King at 2023-09-19T04:54:25-04:00
Don’t store the async exception masking state in CATCH frames

- - - - -


20 changed files:

- .gitlab/generate-ci/gen_ci.hs
- .gitlab/jobs.yaml
- .gitlab/rel_eng/fetch-gitlab-artifacts/fetch_gitlab.py
- compiler/GHC/CoreToStg/Prep.hs
- libraries/base/Numeric.hs
- libraries/base/changelog.md
- libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
- libraries/ghc-heap/GHC/Exts/Stack/Constants.hsc
- libraries/ghc-heap/GHC/Exts/Stack/Decode.hs
- libraries/ghc-heap/tests/stack_misc_closures.hs
- libraries/ghc-heap/tests/stack_misc_closures_c.c
- rts/Continuation.c
- rts/Exception.cmm
- rts/RaiseAsync.c
- rts/Schedule.c
- rts/include/rts/storage/Closures.h
- + testsuite/tests/rts/continuations/T23513.hs
- + testsuite/tests/rts/continuations/T23513.stdout
- testsuite/tests/rts/continuations/all.T
- utils/deriveConstants/Main.hs


Changes:

=====================================
.gitlab/generate-ci/gen_ci.hs
=====================================
@@ -114,7 +114,8 @@ data LinuxDistro
   | Ubuntu2004
   | Ubuntu1804
   | Centos7
-  | Alpine
+  | Alpine312
+  | Alpine318
   | AlpineWasm
   | Rocky8
   deriving (Eq)
@@ -293,7 +294,8 @@ distroName Fedora38  = "fedora38"
 distroName Ubuntu1804 = "ubuntu18_04"
 distroName Ubuntu2004 = "ubuntu20_04"
 distroName Centos7    = "centos7"
-distroName Alpine     = "alpine3_12"
+distroName Alpine312  = "alpine3_12"
+distroName Alpine318  = "alpine3_18"
 distroName AlpineWasm = "alpine3_17-wasm"
 distroName Rocky8     = "rocky8"
 
@@ -430,9 +432,7 @@ opsysVariables _ (Windows {}) =
           , "GHC_VERSION" =: "9.4.3" ]
 opsysVariables _ _ = mempty
 
-
-distroVariables :: LinuxDistro -> Variables
-distroVariables Alpine = mconcat
+alpineVariables = mconcat
   [ -- Due to #20266
     "CONFIGURE_ARGS" =: "--disable-ld-override"
   , "INSTALL_CONFIGURE_ARGS" =: "--disable-ld-override"
@@ -441,6 +441,11 @@ distroVariables Alpine = mconcat
     -- T10458, ghcilink002: due to #17869
   , "BROKEN_TESTS" =: "encoding004 T10458"
   ]
+
+
+distroVariables :: LinuxDistro -> Variables
+distroVariables Alpine312 = alpineVariables
+distroVariables Alpine318 = alpineVariables
 distroVariables Centos7 = mconcat [
   "HADRIAN_ARGS" =: "--docs=no-sphinx"
   ]
@@ -994,13 +999,15 @@ job_groups =
      , allowFailureGroup (onlyRule FreeBSDLabel (validateBuilds Amd64 FreeBSD13 vanilla))
      , fastCI (standardBuilds AArch64 Darwin)
      , fastCI (standardBuildsWithConfig AArch64 (Linux Debian10) (splitSectionsBroken vanilla))
+     , disableValidate (standardBuildsWithConfig AArch64 (Linux Debian11) (splitSectionsBroken vanilla))
      , disableValidate (validateBuilds AArch64 (Linux Debian10) llvm)
      , standardBuildsWithConfig I386 (Linux Debian10) (splitSectionsBroken vanilla)
      -- Fully static build, in theory usable on any linux distribution.
-     , fullyStaticBrokenTests (standardBuildsWithConfig Amd64 (Linux Alpine) (splitSectionsBroken static))
+     , fullyStaticBrokenTests (standardBuildsWithConfig Amd64 (Linux Alpine312) (splitSectionsBroken static))
      -- Dynamically linked build, suitable for building your own static executables on alpine
-     , disableValidate (standardBuildsWithConfig Amd64 (Linux Alpine) (splitSectionsBroken vanilla))
-     , fullyStaticBrokenTests (disableValidate (allowFailureGroup (standardBuildsWithConfig Amd64 (Linux Alpine) staticNativeInt)))
+     , disableValidate (standardBuildsWithConfig Amd64 (Linux Alpine312) (splitSectionsBroken vanilla))
+     , disableValidate (standardBuildsWithConfig AArch64 (Linux Alpine318) (splitSectionsBroken vanilla))
+     , fullyStaticBrokenTests (disableValidate (allowFailureGroup (standardBuildsWithConfig Amd64 (Linux Alpine312) staticNativeInt)))
      , validateBuilds Amd64 (Linux Debian11) (crossConfig "aarch64-linux-gnu" (Emulator "qemu-aarch64 -L /usr/aarch64-linux-gnu") Nothing)
      , validateBuilds Amd64 (Linux Debian11) (crossConfig "javascript-unknown-ghcjs" (Emulator "js-emulator") (Just "emconfigure")
         )


=====================================
.gitlab/jobs.yaml
=====================================
@@ -253,6 +253,71 @@
       "XZ_OPT": "-9"
     }
   },
+  "nightly-aarch64-linux-alpine3_18-validate": {
+    "after_script": [
+      ".gitlab/ci.sh save_cache",
+      ".gitlab/ci.sh save_test_output",
+      ".gitlab/ci.sh clean",
+      "cat ci_timings"
+    ],
+    "allow_failure": false,
+    "artifacts": {
+      "expire_in": "8 weeks",
+      "paths": [
+        "ghc-aarch64-linux-alpine3_18-validate.tar.xz",
+        "junit.xml",
+        "unexpected-test-output.tar.gz"
+      ],
+      "reports": {
+        "junit": "junit.xml"
+      },
+      "when": "always"
+    },
+    "cache": {
+      "key": "aarch64-linux-alpine3_18-$CACHE_REV",
+      "paths": [
+        "cabal-cache",
+        "toolchain"
+      ]
+    },
+    "dependencies": [],
+    "image": "registry.gitlab.haskell.org/ghc/ci-images/aarch64-linux-alpine3_18:$DOCKER_REV",
+    "needs": [
+      {
+        "artifacts": false,
+        "job": "hadrian-ghc-in-ghci"
+      }
+    ],
+    "rules": [
+      {
+        "if": "(\"true\" == \"true\") && ($RELEASE_JOB != \"yes\") && ($NIGHTLY)",
+        "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-alpine3_18-validate",
+      "BROKEN_TESTS": "encoding004 T10458",
+      "BUILD_FLAVOUR": "validate",
+      "CONFIGURE_ARGS": "--disable-ld-override --enable-strict-ghc-toolchain-check",
+      "HADRIAN_ARGS": "--docs=no-sphinx",
+      "INSTALL_CONFIGURE_ARGS": "--disable-ld-override",
+      "RUNTEST_ARGS": "",
+      "TEST_ENV": "aarch64-linux-alpine3_18-validate",
+      "XZ_OPT": "-9"
+    }
+  },
   "nightly-aarch64-linux-deb10-validate": {
     "after_script": [
       ".gitlab/ci.sh save_cache",
@@ -377,6 +442,68 @@
       "XZ_OPT": "-9"
     }
   },
+  "nightly-aarch64-linux-deb11-validate": {
+    "after_script": [
+      ".gitlab/ci.sh save_cache",
+      ".gitlab/ci.sh save_test_output",
+      ".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",
+        "unexpected-test-output.tar.gz"
+      ],
+      "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": "(\"true\" == \"true\") && ($RELEASE_JOB != \"yes\") && ($NIGHTLY)",
+        "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": "--enable-strict-ghc-toolchain-check",
+      "RUNTEST_ARGS": "",
+      "TEST_ENV": "aarch64-linux-deb11-validate",
+      "XZ_OPT": "-9"
+    }
+  },
   "nightly-i386-linux-deb10-validate": {
     "after_script": [
       ".gitlab/ci.sh save_cache",
@@ -2593,6 +2720,72 @@
       "XZ_OPT": "-9"
     }
   },
+  "release-aarch64-linux-alpine3_18-release+no_split_sections": {
+    "after_script": [
+      ".gitlab/ci.sh save_cache",
+      ".gitlab/ci.sh save_test_output",
+      ".gitlab/ci.sh clean",
+      "cat ci_timings"
+    ],
+    "allow_failure": false,
+    "artifacts": {
+      "expire_in": "1 year",
+      "paths": [
+        "ghc-aarch64-linux-alpine3_18-release+no_split_sections.tar.xz",
+        "junit.xml",
+        "unexpected-test-output.tar.gz"
+      ],
+      "reports": {
+        "junit": "junit.xml"
+      },
+      "when": "always"
+    },
+    "cache": {
+      "key": "aarch64-linux-alpine3_18-$CACHE_REV",
+      "paths": [
+        "cabal-cache",
+        "toolchain"
+      ]
+    },
+    "dependencies": [],
+    "image": "registry.gitlab.haskell.org/ghc/ci-images/aarch64-linux-alpine3_18:$DOCKER_REV",
+    "needs": [
+      {
+        "artifacts": false,
+        "job": "hadrian-ghc-in-ghci"
+      }
+    ],
+    "rules": [
+      {
+        "if": "(\"true\" == \"true\") && ($RELEASE_JOB == \"yes\") && ($NIGHTLY == null)",
+        "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-alpine3_18-release+no_split_sections",
+      "BROKEN_TESTS": "encoding004 T10458",
+      "BUILD_FLAVOUR": "release+no_split_sections",
+      "CONFIGURE_ARGS": "--disable-ld-override --enable-strict-ghc-toolchain-check",
+      "HADRIAN_ARGS": "--hash-unit-ids --docs=no-sphinx",
+      "IGNORE_PERF_FAILURES": "all",
+      "INSTALL_CONFIGURE_ARGS": "--disable-ld-override",
+      "RUNTEST_ARGS": "",
+      "TEST_ENV": "aarch64-linux-alpine3_18-release+no_split_sections",
+      "XZ_OPT": "-9"
+    }
+  },
   "release-aarch64-linux-deb10-release+no_split_sections": {
     "after_script": [
       ".gitlab/ci.sh save_cache",
@@ -2657,6 +2850,70 @@
       "XZ_OPT": "-9"
     }
   },
+  "release-aarch64-linux-deb11-release+no_split_sections": {
+    "after_script": [
+      ".gitlab/ci.sh save_cache",
+      ".gitlab/ci.sh save_test_output",
+      ".gitlab/ci.sh clean",
+      "cat ci_timings"
+    ],
+    "allow_failure": false,
+    "artifacts": {
+      "expire_in": "1 year",
+      "paths": [
+        "ghc-aarch64-linux-deb11-release+no_split_sections.tar.xz",
+        "junit.xml",
+        "unexpected-test-output.tar.gz"
+      ],
+      "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": "(\"true\" == \"true\") && ($RELEASE_JOB == \"yes\") && ($NIGHTLY == null)",
+        "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+no_split_sections",
+      "BUILD_FLAVOUR": "release+no_split_sections",
+      "CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
+      "HADRIAN_ARGS": "--hash-unit-ids",
+      "IGNORE_PERF_FAILURES": "all",
+      "RUNTEST_ARGS": "",
+      "TEST_ENV": "aarch64-linux-deb11-release+no_split_sections",
+      "XZ_OPT": "-9"
+    }
+  },
   "release-i386-linux-deb10-release+no_split_sections": {
     "after_script": [
       ".gitlab/ci.sh save_cache",


=====================================
.gitlab/rel_eng/fetch-gitlab-artifacts/fetch_gitlab.py
=====================================
@@ -39,6 +39,8 @@ def job_triple(job_name):
         'release-i386-linux-deb10-release': 'i386-deb10-linux',
         'release-armv7-linux-deb10-release': 'armv7-deb10-linux',
         'release-aarch64-linux-deb10-release': 'aarch64-deb10-linux',
+        'release-aarch64-linux-deb11-release': 'aarch64-deb11-linux',
+        'release-aarch64-linux-alpine_3_18-release': 'aarch64-alpine3_18-linux',
         'release-aarch64-darwin-release': 'aarch64-apple-darwin',
 
         'source-tarball': 'src',


=====================================
compiler/GHC/CoreToStg/Prep.hs
=====================================
@@ -657,9 +657,6 @@ cpePair top_lvl is_rec dmd is_unlifted env bndr rhs
       | allLazyTop floats
       = return (floats, rhs)
 
-      | Just floats <- canFloat floats rhs
-      = return floats
-
       | otherwise
       = dontFloat floats rhs
 
@@ -1954,32 +1951,6 @@ deFloatTop (Floats _ floats)
 
 ---------------------------------------------------------------------------
 
-canFloat :: Floats -> CpeRhs -> Maybe (Floats, CpeRhs)
-canFloat (Floats ok_to_spec fs) rhs
-  | OkToSpec <- ok_to_spec           -- Worth trying
-  , Just fs' <- go nilOL (fromOL fs)
-  = Just (Floats OkToSpec fs', rhs)
-  | otherwise
-  = Nothing
-  where
-    go :: OrdList FloatingBind -> [FloatingBind]
-       -> Maybe (OrdList FloatingBind)
-
-    go (fbs_out) [] = Just fbs_out
-
-    go fbs_out (fb@(FloatLet _) : fbs_in)
-      = go (fbs_out `snocOL` fb) fbs_in
-
-    go fbs_out (fb at FloatString{} : fbs_in)
-      -- See Note [ANF-ising literal string arguments]
-      = go (fbs_out `snocOL` fb) fbs_in
-
-    go fbs_out (ft at FloatTick{} : fbs_in)
-      = go (fbs_out `snocOL` ft) fbs_in
-
-    go _ (FloatCase{} : _) = Nothing
-
-
 wantFloatNested :: RecFlag -> Demand -> Bool -> Floats -> CpeRhs -> Bool
 wantFloatNested is_rec dmd rhs_is_unlifted floats rhs
   =  isEmptyFloats floats


=====================================
libraries/base/Numeric.hs
=====================================
@@ -117,6 +117,14 @@ readHex = readP_to_S L.readHexP
 
 -- | Reads an /unsigned/ 'RealFrac' value,
 -- expressed in decimal scientific notation.
+--
+-- Note that this function takes time linear in the magnitude of its input
+-- which can scale exponentially with input size (e.g. @"1e100000000"@ is a
+-- very large number while having a very small textual form).
+-- For this reason, users should take care to avoid using this function on
+-- untrusted input. Users needing to parse floating point values
+-- (e.g. 'Float') are encouraged to instead use 'read', which does
+-- not suffer from this issue.
 readFloat :: RealFrac a => ReadS a
 readFloat = readP_to_S readFloatP
 


=====================================
libraries/base/changelog.md
=====================================
@@ -4,7 +4,6 @@
   * Export `foldl'` from `Prelude` ([CLC proposal #167](https://github.com/haskell/core-libraries-committee/issues/167))
   * Add a `RULE` to `Prelude.lookup`, allowing it to participate in list fusion ([CLC proposal #174](https://github.com/haskell/core-libraries-committee/issues/175))
   * The `Enum Int64` and `Enum Word64` instances now use native operations on 32-bit platforms, increasing performance by up to 1.5x on i386 and up to 5.6x with the JavaScript backend. ([CLC proposal #187](https://github.com/haskell/core-libraries-committee/issues/187))
-  * Add rewrite rules for conversion between Int64/Word64 and Float/Double on 64-bit architectures ([CLC proposal #203](https://github.com/haskell/core-libraries-committee/issues/203)).
   * Update to [Unicode 15.1.0](https://www.unicode.org/versions/Unicode15.1.0/).
 
 ## 4.19.0.0 *TBA*
@@ -44,6 +43,7 @@
   * Deprecate `Data.List.NonEmpty.unzip` ([CLC proposal #86](https://github.com/haskell/core-libraries-committee/issues/86))
   * Fixed exponent overflow/underflow bugs in the `Read` instances for `Float` and `Double` ([CLC proposal #192](https://github.com/haskell/core-libraries-committee/issues/192))
   * Implement `copyBytes`, `fillBytes`, `moveBytes` and `stimes` for `Data.Array.Byte.ByteArray` using primops ([CLC proposal #188](https://github.com/haskell/core-libraries-committee/issues/188))
+  * Add rewrite rules for conversion between Int64/Word64 and Float/Double on 64-bit architectures ([CLC proposal #203](https://github.com/haskell/core-libraries-committee/issues/203)).
 
 ## 4.18.0.0 *March 2023*
   * Shipped with GHC 9.6.1


=====================================
libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
=====================================
@@ -412,7 +412,6 @@ data GenStackFrame b =
 
   | CatchFrame
       { info_tbl            :: !StgInfoTable
-      , exceptions_blocked  :: !Word
       , handler             :: !b
       }
 


=====================================
libraries/ghc-heap/GHC/Exts/Stack/Constants.hsc
=====================================
@@ -23,10 +23,6 @@ offsetStgCatchFrameHandler :: WordOffset
 offsetStgCatchFrameHandler = byteOffsetToWordOffset $
   (#const OFFSET_StgCatchFrame_handler) + (#size StgHeader)
 
-offsetStgCatchFrameExceptionsBlocked :: WordOffset
-offsetStgCatchFrameExceptionsBlocked = byteOffsetToWordOffset $
-  (#const OFFSET_StgCatchFrame_exceptions_blocked) + (#size StgHeader)
-
 sizeStgCatchFrame :: Int
 sizeStgCatchFrame = bytesToWords $
   (#const SIZEOF_StgCatchFrame_NoHdr) + (#size StgHeader)


=====================================
libraries/ghc-heap/GHC/Exts/Stack/Decode.hs
=====================================
@@ -331,12 +331,10 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do
                   updatee = updatee'
                 }
         CATCH_FRAME -> do
-          let exceptions_blocked' = getWord stackSnapshot# (index + offsetStgCatchFrameExceptionsBlocked)
-              handler' = getClosureBox stackSnapshot# (index + offsetStgCatchFrameHandler)
+          let handler' = getClosureBox stackSnapshot# (index + offsetStgCatchFrameHandler)
           pure $
             CatchFrame
               { info_tbl = info,
-                exceptions_blocked = exceptions_blocked',
                 handler = handler'
               }
         UNDERFLOW_FRAME -> do


=====================================
libraries/ghc-heap/tests/stack_misc_closures.hs
=====================================
@@ -113,11 +113,10 @@ main = do
     \case
       CatchFrame {..} -> do
         assertEqual (tipe info_tbl) CATCH_FRAME
-        assertEqual exceptions_blocked 1
         assertConstrClosure 1 handler
       e -> error $ "Wrong closure type: " ++ show e
   traceM "Test 4"
-  testSize any_catch_frame# 3
+  testSize any_catch_frame# 2
   traceM "Test 5"
   test any_catch_stm_frame# $
     \case


=====================================
libraries/ghc-heap/tests/stack_misc_closures_c.c
=====================================
@@ -25,7 +25,6 @@ void create_any_catch_frame(Capability *cap, StgStack *stack, StgWord w) {
   StgCatchFrame *catchF = (StgCatchFrame *)stack->sp;
   SET_HDR(catchF, &stg_catch_frame_info, CCS_SYSTEM);
   StgClosure *payload = rts_mkWord(cap, w);
-  catchF->exceptions_blocked = 1;
   catchF->handler = payload;
 }
 


=====================================
rts/Continuation.c
=====================================
@@ -374,12 +374,12 @@ StgClosure *captureContinuationAndAbort(Capability *cap, StgTSO *tso, StgPromptT
   //   1. We walk the stack to find the prompt frame to capture up to (if any).
   //
   //   2. If we successfully find a matching prompt, we proceed with the actual
-  //      by allocating space for the continuation, performing the necessary
-  //      copying, and unwinding the stack.
+  //      capture by allocating space for the continuation, performing the
+  //      necessary copying, and unwinding the stack.
   //
   // These variables are modified in Phase 1 to keep track of how far we had to
   // walk before finding the prompt frame. Afterwards, Phase 2 consults them to
-  // determine how to proceed with the actual capture.
+  // determine how to proceed.
 
   StgWord total_words = 0;
   bool in_first_chunk = true;


=====================================
rts/Exception.cmm
=====================================
@@ -393,16 +393,14 @@ stg_killMyself
  * kind of return to the activation record underneath us on the stack.
  */
 
-#define CATCH_FRAME_FIELDS(w_,p_,info_ptr,p1,p2,exceptions_blocked,handler)   \
+#define CATCH_FRAME_FIELDS(w_,p_,info_ptr,p1,p2,handler)   \
   w_ info_ptr,                                                          \
   PROF_HDR_FIELDS(w_,p1,p2)                                             \
-  w_ exceptions_blocked,                                                \
   p_ handler
 
 
 INFO_TABLE_RET(stg_catch_frame, CATCH_FRAME,
-               CATCH_FRAME_FIELDS(W_,P_,info_ptr, p1, p2,
-                                  exceptions_blocked,handler))
+               CATCH_FRAME_FIELDS(W_,P_,info_ptr, p1, p2,handler))
     return (P_ ret)
 {
     return (ret);
@@ -411,12 +409,7 @@ INFO_TABLE_RET(stg_catch_frame, CATCH_FRAME,
 stg_catchzh ( P_ io,      /* :: IO a */
               P_ handler  /* :: Exception -> IO a */ )
 {
-    W_ exceptions_blocked;
-
     STK_CHK_GEN();
-
-    exceptions_blocked =
-        TO_W_(StgTSO_flags(CurrentTSO)) & (TSO_BLOCKEX | TSO_INTERRUPTIBLE);
     TICK_CATCHF_PUSHED();
 
     /* Apply R1 to the realworld token */
@@ -424,8 +417,7 @@ stg_catchzh ( P_ io,      /* :: IO a */
     TICK_SLOW_CALL_fast_v();
 
     jump stg_ap_v_fast
-        (CATCH_FRAME_FIELDS(,,stg_catch_frame_info, CCCS, 0,
-                            exceptions_blocked, handler))
+        (CATCH_FRAME_FIELDS(,,stg_catch_frame_info, CCCS, 0, handler))
         (io);
 }
 
@@ -599,26 +591,28 @@ retry_pop_stack:
     frame = Sp;
     if (frame_type == CATCH_FRAME)
     {
+      // Note: if this branch is updated, there is a good chance that
+      // corresponding logic in `raiseAsync` must be updated to match!
+      // See Note [Apply the handler directly in raiseAsync] in RaiseAsync.c.
+
       Sp = Sp + SIZEOF_StgCatchFrame;
-      if ((StgCatchFrame_exceptions_blocked(frame) & TSO_BLOCKEX) == 0) {
+
+      W_ flags;
+      flags = TO_W_(StgTSO_flags(CurrentTSO));
+      if ((flags & TSO_BLOCKEX) == 0) {
           Sp_adj(-1);
           Sp(0) = stg_unmaskAsyncExceptionszh_ret_info;
       }
 
       /* Ensure that async exceptions are masked when running the handler.
-      */
-      StgTSO_flags(CurrentTSO) = %lobits32(
-          TO_W_(StgTSO_flags(CurrentTSO)) | TSO_BLOCKEX | TSO_INTERRUPTIBLE);
-
-      /* The interruptible state is inherited from the context of the
+       *
+       * The interruptible state is inherited from the context of the
        * catch frame, but note that TSO_INTERRUPTIBLE is only meaningful
        * if TSO_BLOCKEX is set.  (we got this wrong earlier, and #4988
        * was a symptom of the bug).
        */
-      if ((StgCatchFrame_exceptions_blocked(frame) &
-           (TSO_BLOCKEX | TSO_INTERRUPTIBLE)) == TSO_BLOCKEX) {
-          StgTSO_flags(CurrentTSO) = %lobits32(
-              TO_W_(StgTSO_flags(CurrentTSO)) & ~TSO_INTERRUPTIBLE);
+      if ((flags & (TSO_BLOCKEX | TSO_INTERRUPTIBLE)) != TSO_BLOCKEX) {
+        StgTSO_flags(CurrentTSO) = %lobits32(flags | TSO_BLOCKEX | TSO_INTERRUPTIBLE);
       }
     }
     else /* CATCH_STM_FRAME */


=====================================
rts/RaiseAsync.c
=====================================
@@ -951,44 +951,36 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception,
 
         case CATCH_FRAME:
             // If we find a CATCH_FRAME, and we've got an exception to raise,
-            // then build the THUNK raise(exception), and leave it on
-            // top of the CATCH_FRAME ready to enter.
-            //
+            // then set up the top of the stack to apply the handler;
+            // see Note [Apply the handler directly in raiseAsync].
         {
-            StgCatchFrame *cf = (StgCatchFrame *)frame;
-            StgThunk *raise;
-
             if (exception == NULL) break;
 
-            // we've got an exception to raise, so let's pass it to the
-            // handler in this frame.
-            //
-            raise = (StgThunk *)allocate(cap,sizeofW(StgThunk)+1);
-            TICK_ALLOC_SE_THK(sizeofW(StgThunk)+1,0);
-            SET_HDR(raise,&stg_raise_info,cf->header.prof.ccs);
-            raise->payload[0] = exception;
+            StgClosure *handler = ((StgCatchFrame *)frame)->handler;
 
-            // throw away the stack from Sp up to the CATCH_FRAME.
-            //
-            sp = frame - 1;
-
-            /* Ensure that async exceptions are blocked now, so we don't get
-             * a surprise exception before we get around to executing the
-             * handler.
-             */
-            tso->flags |= TSO_BLOCKEX;
-            if ((cf->exceptions_blocked & TSO_INTERRUPTIBLE) == 0) {
-                tso->flags &= ~TSO_INTERRUPTIBLE;
-            } else {
-                tso->flags |= TSO_INTERRUPTIBLE;
+            // Throw away the stack from Sp up to and including the CATCH_FRAME.
+            sp = frame + stack_frame_sizeW((StgClosure *)frame);
+
+            // Unmask async exceptions after running the handler, if necessary.
+            if ((tso->flags & TSO_BLOCKEX) == 0) {
+              sp--;
+              sp[0] = (W_)&stg_unmaskAsyncExceptionszh_ret_info;
             }
 
-            /* Put the newly-built THUNK on top of the stack, ready to execute
-             * when the thread restarts.
-             */
-            sp[0] = (W_)raise;
-            sp[-1] = (W_)&stg_enter_info;
-            stack->sp = sp-1;
+            // Ensure that async exceptions are masked while running the handler;
+            // see Note [Apply the handler directly in raiseAsync].
+            if ((tso->flags & (TSO_BLOCKEX | TSO_INTERRUPTIBLE)) != TSO_BLOCKEX) {
+              tso->flags |= TSO_BLOCKEX | TSO_INTERRUPTIBLE;
+            }
+
+            // Set up the top of the stack to apply the handler.
+            sp -= 4;
+            sp[0] = (W_)&stg_enter_info;
+            sp[1] = (W_)handler;
+            sp[2] = (W_)&stg_ap_pv_info;
+            sp[3] = (W_)exception;
+
+            stack->sp = sp;
             RELAXED_STORE(&tso->what_next, ThreadRunGHC);
             goto done;
         }
@@ -1080,6 +1072,15 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception,
         };
 
         default:
+            // see Note [Update async masking state on unwind] in Schedule.c
+            if (*frame == (W_)&stg_unmaskAsyncExceptionszh_ret_info) {
+                tso->flags &= ~(TSO_BLOCKEX | TSO_INTERRUPTIBLE);
+            } else if (*frame == (W_)&stg_maskAsyncExceptionszh_ret_info) {
+                tso->flags |= TSO_BLOCKEX | TSO_INTERRUPTIBLE;
+            } else if (*frame == (W_)&stg_maskUninterruptiblezh_ret_info) {
+                tso->flags |= TSO_BLOCKEX;
+                tso->flags &= ~TSO_INTERRUPTIBLE;
+            }
             break;
         }
 
@@ -1098,3 +1099,26 @@ done:
 
     return tso;
 }
+
+/* Note [Apply the handler directly in raiseAsync]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we encounter a `catch#` frame while unwinding the stack due to an
+async exception, we need to set up the stack to resume execution by
+invoking the exception handler. One natural way to do it would be to
+simply place a `raise#` thunk on the top of the stack, ready to be
+entered. This would effectively convert the asynchronous exception to
+a synchronous one at a point where it’s known to be safe to do so.
+
+However, there is a danger to this strategy: if async exceptions are
+currently unmasked, it becomes possible for a second async exception
+to be delivered before we enter the application of `raise#`, which
+would result in the first exception being lost. The easiest way to
+prevent this race from happening is to have `raiseAsync` set up the
+stack to apply the handler directly, effectively emulating the
+behavior of `raise#`, as this allows exceptions to be preemptively
+masked before returning. This means `raiseAsync` must also push a
+frame to unmask async exceptions after the handler returns if
+necessary, just as `raise#` does.
+
+This strategy results in some logical duplication, but it is correct,
+and the duplicated logic is small enough to be acceptable. */


=====================================
rts/Schedule.c
=====================================
@@ -3019,19 +3019,6 @@ raiseExceptionHelper (StgRegTable *reg, StgTSO *tso, StgClosure *exception)
     // thunks which are currently under evaluation.
     //
 
-    // OLD COMMENT (we don't have MIN_UPD_SIZE now):
-    // LDV profiling: stg_raise_info has THUNK as its closure
-    // type. Since a THUNK takes at least MIN_UPD_SIZE words in its
-    // payload, MIN_UPD_SIZE is more appropriate than 1.  It seems that
-    // 1 does not cause any problem unless profiling is performed.
-    // However, when LDV profiling goes on, we need to linearly scan
-    // small object pool, where raise_closure is stored, so we should
-    // use MIN_UPD_SIZE.
-    //
-    // raise_closure = (StgClosure *)RET_STGCALL1(P_,allocate,
-    //                                 sizeofW(StgClosure)+1);
-    //
-
     //
     // Walk up the stack, looking for the catch frame.  On the way,
     // we update any closures pointed to from update frames with the
@@ -3094,12 +3081,52 @@ raiseExceptionHelper (StgRegTable *reg, StgTSO *tso, StgClosure *exception)
         }
 
         default:
+            // see Note [Update async masking state on unwind]
+            if (*p == (StgWord)&stg_unmaskAsyncExceptionszh_ret_info) {
+                tso->flags &= ~(TSO_BLOCKEX | TSO_INTERRUPTIBLE);
+            } else if (*p == (StgWord)&stg_maskAsyncExceptionszh_ret_info) {
+                tso->flags |= TSO_BLOCKEX | TSO_INTERRUPTIBLE;
+            } else if (*p == (StgWord)&stg_maskUninterruptiblezh_ret_info) {
+                tso->flags |= TSO_BLOCKEX;
+                tso->flags &= ~TSO_INTERRUPTIBLE;
+            }
             p = next;
             continue;
         }
     }
 }
 
+/* Note [Update async masking state on unwind]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we raise an exception or capture a continuation, we unwind the
+stack by searching for an enclosing `catch#` or `prompt#` frame. If we
+unwind past frames intended to restore the async exception masking
+state, we must take care to reproduce their intended effect in order
+to ensure that async exceptions are properly unmasked or remasked.
+
+On paper, this seems as simple as updating `tso->flags` appropriately,
+but in fact there is one additional wrinkle: when async exceptions are
+*unmasked*, we must eagerly check for a pending async exception and
+raise it if necessary. This is not terribly involved, but it’s not
+trivial, either (see the definition of `stg_unmaskAsyncExceptionszh_ret`),
+so we’d prefer to avoid duplicating that logic in several places.
+
+Fortunately, when we’re unwinding the stack due to a raised exception,
+this detail is actually unimportant: `catch#` implicitly masks async
+exceptions while running the handler as we explicitly *don’t* want the
+thread to be interrupted before it has a chance to handle the
+exception. However, when capturing a continuation, we don’t have this
+luxury, so we take two different strategies:
+
+* When unwinding the stack due to a raised exception (synchonrous or
+  asynchronous), we just update `tso->flags` directly and take no
+  further action.
+
+* When unwinding the stack due to a continuation capture, we update
+  the masking state *indirectly* by pushing an appropriate frame onto
+  the stack before we return. This strategy is described at length
+  in Note [Continuations and async exception masking] in Continuation.c. */
+
 
 /* -----------------------------------------------------------------------------
    findRetryFrameHelper


=====================================
rts/include/rts/storage/Closures.h
=====================================
@@ -281,7 +281,6 @@ typedef struct {
 // Closure types: CATCH_FRAME
 typedef struct {
     StgHeader  header;
-    StgWord    exceptions_blocked;
     StgClosure *handler;
 } StgCatchFrame;
 


=====================================
testsuite/tests/rts/continuations/T23513.hs
=====================================
@@ -0,0 +1,36 @@
+-- This test checks that restoring a continuation that captures a CATCH frame
+-- properly adjusts the async exception masking state.
+
+import Control.Exception
+import Data.IORef
+
+import ContIO
+
+data E = E deriving (Show)
+instance Exception E
+
+printMaskingState :: IO ()
+printMaskingState = print =<< getMaskingState
+
+main :: IO ()
+main = do
+  tag <- newPromptTag
+  ref <- newIORef Nothing
+  mask_ $ prompt tag $
+    catch (control0 tag $ \k ->
+             writeIORef ref (Just k))
+          (\E -> printMaskingState)
+  Just k <- readIORef ref
+
+  let execute_test = do
+        k (printMaskingState *> throwIO E)
+        printMaskingState
+
+  putStrLn "initially unmasked:"
+  execute_test
+
+  putStrLn "\ninitially interruptibly masked:"
+  mask_ execute_test
+
+  putStrLn "\ninitially uninterruptibly masked:"
+  uninterruptibleMask_ execute_test


=====================================
testsuite/tests/rts/continuations/T23513.stdout
=====================================
@@ -0,0 +1,14 @@
+initially unmasked:
+Unmasked
+MaskedInterruptible
+Unmasked
+
+initially interruptibly masked:
+MaskedInterruptible
+MaskedInterruptible
+MaskedInterruptible
+
+initially uninterruptibly masked:
+MaskedUninterruptible
+MaskedUninterruptible
+MaskedUninterruptible


=====================================
testsuite/tests/rts/continuations/all.T
=====================================
@@ -7,3 +7,5 @@ test('cont_exn_masking', [extra_files(['ContIO.hs'])], multimod_compile_and_run,
 test('cont_missing_prompt_err', [extra_files(['ContIO.hs']), exit_code(1)], multimod_compile_and_run, ['cont_missing_prompt_err', ''])
 test('cont_nondet_handler', [extra_files(['ContIO.hs'])], multimod_compile_and_run, ['cont_nondet_handler', ''])
 test('cont_stack_overflow', [extra_files(['ContIO.hs'])], multimod_compile_and_run, ['cont_stack_overflow', '-with-rtsopts "-ki1k -kc2k -kb256"'])
+
+test('T23513', [extra_files(['ContIO.hs'])], multimod_compile_and_run, ['T23513', ''])


=====================================
utils/deriveConstants/Main.hs
=====================================
@@ -484,7 +484,6 @@ wanteds os = concat
           ,closureField Both "StgOrigThunkInfoFrame" "info_ptr"
 
           ,closureField C "StgCatchFrame" "handler"
-          ,closureField C "StgCatchFrame" "exceptions_blocked"
 
           ,structSize  C "StgRetFun"
           ,fieldOffset C "StgRetFun" "size"



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/90d64ea2fd54cca954e5c593ba7b439d9a28c930...bf71651ac018aa31bfe901ba77267d5e40e44977

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/90d64ea2fd54cca954e5c593ba7b439d9a28c930...bf71651ac018aa31bfe901ba77267d5e40e44977
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/20230919/75cc78a4/attachment-0001.html>


More information about the ghc-commits mailing list