[Git][ghc/ghc][ghc-9.8] 2 commits: DmdAnal: Make `prompt#` lazy (#25439)
Ben Gamari (@bgamari)
gitlab at gitlab.haskell.org
Thu Nov 14 00:58:54 UTC 2024
Ben Gamari pushed to branch ghc-9.8 at Glasgow Haskell Compiler / GHC
Commits:
74437b9a by Sebastian Graf at 2024-11-13T19:06:12-05:00
DmdAnal: Make `prompt#` lazy (#25439)
This applies the same treatment to `prompt#` as for `catch#`.
See `Note [Strictness for mask/unmask/catch/prompt]`.
Fixes #25439.
(cherry picked from commit 00d58ae18a7ce8db6b2d57261a08ba8c1c2549b5)
- - - - -
68cd09f6 by Ben Gamari at 2024-11-13T19:23:35-05:00
Mention fix of #25439 in release notes
- - - - -
5 changed files:
- compiler/GHC/Builtin/primops.txt.pp
- docs/users_guide/9.8.4-notes.rst
- + testsuite/tests/stranal/should_run/T25439.hs
- + testsuite/tests/stranal/should_run/T25439.stdout
- testsuite/tests/stranal/should_run/all.T
Changes:
=====================================
compiler/GHC/Builtin/primops.txt.pp
=====================================
@@ -2535,18 +2535,45 @@ primop CasMutVarOp "casMutVar#" GenPrimOp
section "Exceptions"
------------------------------------------------------------------------
--- Note [Strictness for mask/unmask/catch]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- Note [Strict IO wrappers]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~
-- Consider this example, which comes from GHC.IO.Handle.Internals:
--- wantReadableHandle3 f ma b st
+-- wantReadableHandle3 f mv b st
-- = case ... of
--- DEFAULT -> case ma of MVar a -> ...
--- 0# -> maskAsyncExceptions# (\st -> case ma of MVar a -> ...)
+-- DEFAULT -> case mv of MVar a -> ...
+-- 0# -> maskAsyncExceptions# (\st -> case mv of MVar a -> ...)
-- The outer case just decides whether to mask exceptions, but we don't want
--- thereby to hide the strictness in 'ma'! Hence the use of strictOnceApply1Dmd
--- in mask and unmask. But catch really is lazy in its first argument, see
--- #11555. So for IO actions 'ma' we often use a wrapper around it that is
--- head-strict in 'ma': GHC.IO.catchException.
+-- thereby to hide the strictness in `mv`! Hence the use of strictOnceApply1Dmd
+-- in mask#, unmask# and atomically# (where we use strictManyApply1Dmd to respect
+-- that it potentially calls its action multiple times).
+--
+-- Note [Strictness for catch-style primops]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- The catch#-style primops always call their action, just like outlined
+-- in Note [Strict IO wrappers].
+-- However, it is important that we give their first arg lazyApply1Dmd and not
+-- strictOnceApply1Dmd, like for mask#. Here is why. Consider a call
+--
+-- catch# act handler s
+--
+-- If `act = raiseIO# ...`, using strictOnceApply1Dmd for `act` would mean that
+-- the call forwards the dead-end flag from `act` (see Note [Dead ends] and
+-- Note [Precise exceptions and strictness analysis]).
+-- This would cause dead code elimination to discard the continuation of the
+-- catch# call, among other things. This first came up in #11555.
+--
+-- Hence catch# uses lazyApply1Dmd in order /not/ to forward the dead-end flag
+-- from `act`. (This is a bit brutal, but the language of strictness types is
+-- not expressive enough to give it a more precise semantics that is still
+-- sound.)
+-- For perf reasons we often (but not always) choose to use a wrapper around
+-- catch# that is head-strict in `act`: GHC.IO.catchException.
+--
+-- A similar caveat applies to prompt#, which can be seen as a
+-- generalisation of catch# as explained in GHC.Prim#continuations#.
+-- The reason is that even if `act` appears dead-ending (e.g., looping)
+-- `prompt# tag ma s` might return alright due to a (higher-order) use of
+-- `control0#` in `act`. This came up in #25439.
primop CatchOp "catch#" GenPrimOp
(State# RealWorld -> (# State# RealWorld, o #) )
@@ -2563,7 +2590,7 @@ primop CatchOp "catch#" GenPrimOp
strictness = { \ _arity -> mkClosedDmdSig [ lazyApply1Dmd
, lazyApply2Dmd
, topDmd] topDiv }
- -- See Note [Strictness for mask/unmask/catch]
+ -- See Note [Strictness for catch-style primops]
out_of_line = True
has_side_effects = True
@@ -2628,7 +2655,7 @@ primop MaskAsyncExceptionsOp "maskAsyncExceptions#" GenPrimOp
in continuation-style primops\" for details. }
with
strictness = { \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv }
- -- See Note [Strictness for mask/unmask/catch]
+ -- See Note [Strict IO wrappers]
out_of_line = True
has_side_effects = True
@@ -2643,6 +2670,7 @@ primop MaskUninterruptibleOp "maskUninterruptible#" GenPrimOp
in continuation-style primops\" for details. }
with
strictness = { \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv }
+ -- See Note [Strict IO wrappers]
out_of_line = True
has_side_effects = True
@@ -2657,7 +2685,7 @@ primop UnmaskAsyncExceptionsOp "unmaskAsyncExceptions#" GenPrimOp
in continuation-style primops\" for details. }
with
strictness = { \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv }
- -- See Note [Strictness for mask/unmask/catch]
+ -- See Note [Strict IO wrappers]
out_of_line = True
has_side_effects = True
@@ -2843,7 +2871,8 @@ primop PromptOp "prompt#" GenPrimOp
-> State# RealWorld -> (# State# RealWorld, a #)
{ See "GHC.Prim#continuations". }
with
- strictness = { \ _arity -> mkClosedDmdSig [topDmd, strictOnceApply1Dmd, topDmd] topDiv }
+ strictness = { \ _arity -> mkClosedDmdSig [topDmd, lazyApply1Dmd, topDmd] topDiv }
+ -- See Note [Strictness for catch-style primops]
out_of_line = True
has_side_effects = True
@@ -2870,7 +2899,7 @@ primop AtomicallyOp "atomically#" GenPrimOp
-> State# RealWorld -> (# State# RealWorld, v #)
with
strictness = { \ _arity -> mkClosedDmdSig [strictManyApply1Dmd,topDmd] topDiv }
- -- See Note [Strictness for mask/unmask/catch]
+ -- See Note [Strict IO wrappers]
out_of_line = True
has_side_effects = True
@@ -2899,7 +2928,7 @@ primop CatchRetryOp "catchRetry#" GenPrimOp
strictness = { \ _arity -> mkClosedDmdSig [ lazyApply1Dmd
, lazyApply1Dmd
, topDmd ] topDiv }
- -- See Note [Strictness for mask/unmask/catch]
+ -- See Note [Strictness for catch-style primops]
out_of_line = True
has_side_effects = True
@@ -2911,7 +2940,7 @@ primop CatchSTMOp "catchSTM#" GenPrimOp
strictness = { \ _arity -> mkClosedDmdSig [ lazyApply1Dmd
, lazyApply2Dmd
, topDmd ] topDiv }
- -- See Note [Strictness for mask/unmask/catch]
+ -- See Note [Strictness for catch-style primops]
out_of_line = True
has_side_effects = True
@@ -3586,6 +3615,7 @@ primop KeepAliveOp "keepAlive#" GenPrimOp
with
out_of_line = True
strictness = { \ _arity -> mkClosedDmdSig [topDmd, topDmd, strictOnceApply1Dmd] topDiv }
+ -- See Note [Strict IO wrappers]
------------------------------------------------------------------------
=====================================
docs/users_guide/9.8.4-notes.rst
=====================================
@@ -16,6 +16,8 @@ Compiler
- :ghc-flag:`-Wmissing-home-modules` now behaves correctly when multiple units
have expose the same module name (:ghc-ticket:`25122`).
+- Adjust the demand signature of the ``prompt#`` to avoid invalid optimisation of
+ non-terminating programs (:ghc-ticket:`25439`).
Packaging
---------
=====================================
testsuite/tests/stranal/should_run/T25439.hs
=====================================
@@ -0,0 +1,25 @@
+{-# LANGUAGE MagicHash, UnboxedTuples, BlockArguments #-}
+
+import Prelude hiding (break)
+import GHC.Exts (PromptTag#, newPromptTag#, prompt#, control0#)
+import GHC.IO (IO(..), unIO)
+import Control.Monad (forever)
+
+main :: IO ()
+main = do
+ putStrLn "before"
+ broken >>= putStrLn
+ putStrLn "after"
+
+broken :: IO String
+broken = do
+ loop \l -> do
+ break l "broken"
+
+{-# NOINLINE loop #-}
+loop :: (PromptTag# a -> IO ()) -> IO a
+loop f = IO \rw0 -> case newPromptTag# rw0 of
+ (# rw1, tag #) -> prompt# tag (unIO (forever (f tag))) rw1
+
+break :: PromptTag# a -> a -> IO b
+break tag x = IO (control0# tag \_ rw1 -> (# rw1, x #))
=====================================
testsuite/tests/stranal/should_run/T25439.stdout
=====================================
@@ -0,0 +1,3 @@
+before
+broken
+after
=====================================
testsuite/tests/stranal/should_run/all.T
=====================================
@@ -33,3 +33,4 @@ test('T22475b', normal, compile_and_run, [''])
# T22549: Do not strictify DFuns, otherwise we will <<loop>>
test('T22549', normal, compile_and_run, ['-fdicts-strict -fno-specialise'])
test('T23208', exit_code(1), multimod_compile_and_run, ['T23208_Lib', 'T23208'])
+test('T25439', normal, compile_and_run, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4e14b9f88135758054672c8773f5a5c451608f7b...68cd09f64448f2b1f9af7ca22ce6c26954bce643
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4e14b9f88135758054672c8773f5a5c451608f7b...68cd09f64448f2b1f9af7ca22ce6c26954bce643
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/20241113/e97d1d82/attachment-0001.html>
More information about the ghc-commits
mailing list