Add native delimited continuations to the RTS

This patch implements GHC proposal 313, "Delimited continuation
primops", by adding native support for delimited continuations to the
GHC RTS.

All things considered, the patch is relatively small. It almost
exclusively consists of changes to the RTS; the compiler itself is
essentially unaffected. The primops come with fairly extensive Haddock
documentation, and an overview of the implementation strategy is given
in the Notes in rts/Continuation.c.

This first stab at the implementation prioritizes simplicity over
performance. Most notably, every continuation is always stored as a
single, contiguous chunk of stack. If one of these chunks is
particularly large, it can result in poor performance, as the current
implementation does not attempt to cleverly squeeze a subset of the
stack frames into the existing stack: it must fit all at once. If this
proves to be a performance issue in practice, a cleverer strategy would
be a worthwhile target for future improvements.

5 files changed, 214 insertions, 7 deletions

diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs
index f97103a90f..e714036cd4 100644
--- a/compiler/GHC/Builtin/Names.hs
+++ b/compiler/GHC/Builtin/Names.hs
@@ -1849,7 +1849,8 @@ statePrimTyConKey, stableNamePrimTyConKey, stableNameTyConKey,
     typeConKey, threadIdPrimTyConKey, bcoPrimTyConKey, ptrTyConKey,
     funPtrTyConKey, tVarPrimTyConKey, eqPrimTyConKey,
     eqReprPrimTyConKey, eqPhantPrimTyConKey,
-    compactPrimTyConKey, stackSnapshotPrimTyConKey :: Unique
+    compactPrimTyConKey, stackSnapshotPrimTyConKey,
+    promptTagPrimTyConKey :: Unique
 statePrimTyConKey                       = mkPreludeTyConUnique 50
 stableNamePrimTyConKey                  = mkPreludeTyConUnique 51
 stableNameTyConKey                      = mkPreludeTyConUnique 52
@@ -1878,6 +1879,7 @@ funPtrTyConKey                          = mkPreludeTyConUnique 78
 tVarPrimTyConKey                        = mkPreludeTyConUnique 79
 compactPrimTyConKey                     = mkPreludeTyConUnique 80
 stackSnapshotPrimTyConKey               = mkPreludeTyConUnique 81
+promptTagPrimTyConKey                   = mkPreludeTyConUnique 82
 
 eitherTyConKey :: Unique
 eitherTyConKey                          = mkPreludeTyConUnique 84
diff --git a/compiler/GHC/Builtin/Types/Prim.hs b/compiler/GHC/Builtin/Types/Prim.hs
index 2eec67613d..83d36af673 100644
--- a/compiler/GHC/Builtin/Types/Prim.hs
+++ b/compiler/GHC/Builtin/Types/Prim.hs
@@ -80,6 +80,7 @@ module GHC.Builtin.Types.Prim(
         weakPrimTyCon,                  mkWeakPrimTy,
         threadIdPrimTyCon,              threadIdPrimTy,
         stackSnapshotPrimTyCon,         stackSnapshotPrimTy,
+        promptTagPrimTyCon,             mkPromptTagPrimTy,
 
         int8PrimTyCon,          int8PrimTy, int8PrimTyConName,
         word8PrimTyCon,         word8PrimTy, word8PrimTyConName,
@@ -198,6 +199,7 @@ exposedPrimTyCons
     , word32PrimTyCon
     , word64PrimTyCon
     , stackSnapshotPrimTyCon
+    , promptTagPrimTyCon
 
     , tYPETyCon
     , funTyCon
@@ -231,7 +233,7 @@ charPrimTyConName, intPrimTyConName, int8PrimTyConName, int16PrimTyConName, int3
   stableNamePrimTyConName, compactPrimTyConName, bcoPrimTyConName,
   weakPrimTyConName, threadIdPrimTyConName,
   eqPrimTyConName, eqReprPrimTyConName, eqPhantPrimTyConName,
-  stackSnapshotPrimTyConName :: Name
+  stackSnapshotPrimTyConName, promptTagPrimTyConName :: Name
 charPrimTyConName             = mkPrimTc (fsLit "Char#") charPrimTyConKey charPrimTyCon
 intPrimTyConName              = mkPrimTc (fsLit "Int#") intPrimTyConKey  intPrimTyCon
 int8PrimTyConName             = mkPrimTc (fsLit "Int8#") int8PrimTyConKey int8PrimTyCon
@@ -269,6 +271,7 @@ stackSnapshotPrimTyConName    = mkPrimTc (fsLit "StackSnapshot#") stackSnapshotP
 bcoPrimTyConName              = mkPrimTc (fsLit "BCO") bcoPrimTyConKey bcoPrimTyCon
 weakPrimTyConName             = mkPrimTc (fsLit "Weak#") weakPrimTyConKey weakPrimTyCon
 threadIdPrimTyConName         = mkPrimTc (fsLit "ThreadId#") threadIdPrimTyConKey threadIdPrimTyCon
+promptTagPrimTyConName        = mkPrimTc (fsLit "PromptTag#") promptTagPrimTyConKey promptTagPrimTyCon
 
 {-
 ************************************************************************
@@ -1171,6 +1174,20 @@ threadIdPrimTyCon = pcPrimTyCon0 threadIdPrimTyConName unliftedRepTy
 {-
 ************************************************************************
 *                                                                      *
+   The ``prompt tag'' type
+*                                                                      *
+************************************************************************
+-}
+
+promptTagPrimTyCon :: TyCon
+promptTagPrimTyCon = pcPrimTyCon promptTagPrimTyConName [Representational] unliftedRepTy
+
+mkPromptTagPrimTy :: Type -> Type
+mkPromptTagPrimTy v = TyConApp promptTagPrimTyCon [v]
+
+{-
+************************************************************************
+*                                                                      *
 \subsection{SIMD vector types}
 *                                                                      *
 ************************************************************************
diff --git a/compiler/GHC/Builtin/primops.txt.pp b/compiler/GHC/Builtin/primops.txt.pp
index d46e5401fb..acd84c0926 100644
--- a/compiler/GHC/Builtin/primops.txt.pp
+++ b/compiler/GHC/Builtin/primops.txt.pp
@@ -2633,6 +2633,192 @@ primop  MaskStatus "getMaskingState#" GenPrimOp
    has_side_effects = True
 
 ------------------------------------------------------------------------
+section "Continuations"
+  { These operations provide access to first-class delimited continuations,
+    which allow a computation to access and manipulate portions of its
+    /current continuation/. Operationally, they are implemented by direct
+    manipulation of the RTS call stack, which may provide significant
+    performance gains relative to manual continuation-passing style (CPS) for
+    some programs.
+
+    Intuitively, the delimited control operators 'prompt#' and
+    'control0#' can be understood by analogy to 'catch#' and 'raiseIO#',
+    respectively:
+
+      * Like 'catch#', 'prompt#' does not do anything on its own, it
+        just /delimits/ a subcomputation (the source of the name "delimited
+        continuations").
+
+      * Like 'raiseIO#', 'control0#' aborts to the nearest enclosing
+        'prompt#' before resuming execution.
+
+    However, /unlike/ 'raiseIO#', 'control0#' does /not/ discard
+    the aborted computation: instead, it /captures/ it in a form that allows
+    it to be resumed later. In other words, 'control0#' does not
+    irreversibly abort the local computation before returning to the enclosing
+    'prompt#', it merely suspends it. All local context of the suspended
+    computation is packaged up and returned as an ordinary function that can be
+    invoked at a later point in time to /continue/ execution, which is why
+    the suspended computation is known as a /first-class continuation/.
+
+    In GHC, every continuation prompt is associated with exactly one
+    'PromptTag#'. Prompt tags are unique, opaque values created by
+    'newPromptTag#' that may only be compared for equality. Both 'prompt#'
+    and 'control0#' accept a 'PromptTag#' argument, and 'control0#'
+    captures the continuation up to the nearest enclosing use of 'prompt#'
+    /with the same tag/. This allows a program to control exactly which
+    prompt it will abort to by using different tags, similar to how a program
+    can control which 'catch' it will abort to by throwing different types
+    of exceptions. Additionally, 'PromptTag#' accepts a single type parameter,
+    which is used to relate the expected result type at the point of the
+    'prompt#' to the type of the continuation produced by 'control0#'.
+
+    == The gory details
+
+    The high-level explanation provided above should hopefully provide some
+    intuition for what these operations do, but it is not very precise; this
+    section provides a more thorough explanation.
+
+    The 'prompt#' operation morally has the following type:
+
+@
+'prompt#' :: 'PromptTag#' a -> IO a -> IO a
+@
+
+    If a computation @/m/@ never calls 'control0#', then
+    @'prompt#' /tag/ /m/@ is equivalent to just @/m/@, i.e. the 'prompt#' is
+    a no-op. This implies the following law:
+
+    \[
+    \mathtt{prompt\#}\ \mathit{tag}\ (\mathtt{pure}\ x) \equiv \mathtt{pure}\ x
+    \]
+
+    The 'control0#' operation morally has the following type:
+
+@
+'control0#' :: 'PromptTag#' a -> ((IO b -> IO a) -> IO a) -> IO b
+@
+
+    @'control0#' /tag/ /f/@ captures the current continuation up to the nearest
+    enclosing @'prompt#' /tag/@ and resumes execution from the point of the call
+    to 'prompt#', passing the captured continuation to @/f/@. To make that
+    somewhat more precise, we can say 'control0#' obeys the following law:
+
+    \[
+    \mathtt{prompt\#}\ \mathit{tag}\ (\mathtt{control0\#}\ tag\ f \mathbin{\mathtt{>>=}} k)
+      \equiv f\ (\lambda\ m \rightarrow m \mathbin{\mathtt{>>=}} k)
+    \]
+
+    However, this law does not fully describe the behavior of 'control0#',
+    as it does not account for situations where 'control0#' does not appear
+    immediately inside 'prompt#'. Capturing the semantics more precisely
+    requires some additional notational machinery; a common approach is to
+    use [reduction semantics](https://en.wikipedia.org/wiki/Operational_semantics#Reduction_semantics).
+    Assuming an appropriate definition of evaluation contexts \(E\), the
+    semantics of 'prompt#' and 'control0#' can be given as follows:
+
+    \[
+    \begin{aligned}
+    E[\mathtt{prompt\#}\ \mathit{tag}\ (\mathtt{pure}\ v)]
+      &\longrightarrow E[\mathtt{pure}\ v] \\[8pt]
+    E_1[\mathtt{prompt\#}\ \mathit{tag}\ E_2[\mathtt{control0\#}\ tag\ f]]
+      &\longrightarrow E_1[f\ (\lambda\ m \rightarrow E_2[m])] \\[-2pt]
+      \mathrm{where}\;\: \mathtt{prompt\#}\ \mathit{tag} &\not\in E_2
+    \end{aligned}
+    \]
+
+    A full treatment of the semantics and metatheory of delimited control is
+    well outside the scope of this documentation, but a good, thorough
+    overview (in Haskell) is provided in [A Monadic Framework for Delimited
+    Continuations](https://legacy.cs.indiana.edu/~dyb/pubs/monadicDC.pdf) by
+    Dybvig et al.
+
+    == Safety and invariants
+
+    Correct uses of 'control0#' must obey the following restrictions:
+
+    1. The behavior of 'control0#' is only well-defined within a /strict
+       'State#' thread/, such as those associated with @IO@ and strict @ST@
+       computations.
+
+    2. Furthermore, 'control0#' may only be called within the dynamic extent
+       of a 'prompt#' with a matching tag somewhere in the /current/ strict
+       'State#' thread. Effectively, this means that a matching prompt must
+       exist somewhere, and the captured continuation must /not/ contain any
+       uses of @unsafePerformIO@, @runST@, @unsafeInterleaveIO@, etc. For
+       example, the following program is ill-defined:
+
+        @
+        'prompt#' /tag/ $
+          evaluate (unsafePerformIO $ 'control0#' /tag/ /f/)
+        @
+
+        In this example, the use of 'prompt#' appears in a different 'State#'
+        thread from the use of 'control0#', so there is no valid prompt in
+        scope to capture up to.
+
+    3. Finally, 'control0#' may not be used within 'State#' threads associated
+       with an STM transaction (i.e. those introduced by 'atomically#').
+
+    If the runtime is able to detect that any of these invariants have been
+    violated in a way that would compromise internal invariants of the runtime,
+    'control0#' will fail by raising an exception. However, such violations
+    are only detected on a best-effort basis, as the bookkeeping necessary for
+    detecting /all/ illegal uses of 'control0#' would have significant overhead.
+    Therefore, although the operations are “safe” from the runtime’s point of
+    view (e.g. they will not compromise memory safety or clobber internal runtime
+    state), it is still ultimately the programmer’s responsibility to ensure
+    these invariants hold to guarantee predictable program behavior.
+
+    In a similar vein, since each captured continuation includes the full local
+    context of the suspended computation, it can safely be resumed arbitrarily
+    many times without violating any invariants of the runtime system. However,
+    use of these operations in an arbitrary 'IO' computation may be unsafe for
+    other reasons, as most 'IO' code is not written with reentrancy in mind. For
+    example, a computation suspended in the middle of reading a file will likely
+    finish reading it when it is resumed; further attempts to resume from the
+    same place would then fail because the file handle was already closed.
+
+    In other words, although the RTS ensures that a computation’s control state
+    and local variables are properly restored for each distinct resumption of
+    a continuation, it makes no attempt to duplicate any local state the
+    computation may have been using (and could not possibly do so in general).
+    Furthermore, it provides no mechanism for an arbitrary computation to
+    protect itself against unwanted reentrancy (i.e. there is no analogue to
+    Scheme’s @dynamic-wind@). For those reasons, manipulating the continuation
+    is only safe if the caller can be certain that doing so will not violate any
+    expectations or invariants of the enclosing computation. }
+------------------------------------------------------------------------
+
+primtype PromptTag# a
+
+primop  NewPromptTagOp "newPromptTag#" GenPrimOp
+        State# RealWorld -> (# State# RealWorld, PromptTag# a #)
+   with
+   out_of_line = True
+   has_side_effects = True
+
+primop  PromptOp "prompt#" GenPrimOp
+        PromptTag# a
+     -> (State# RealWorld -> (# State# RealWorld, a #))
+     -> State# RealWorld -> (# State# RealWorld, a #)
+   with
+   strictness = { \ _arity -> mkClosedDmdSig [topDmd, strictOnceApply1Dmd, topDmd] topDiv }
+   out_of_line = True
+   has_side_effects = True
+
+primop  Control0Op "control0#" GenPrimOp
+        PromptTag# a
+     -> (((State# RealWorld -> (# State# RealWorld, p #))
+          -> State# RealWorld -> (# State# RealWorld, a #))
+         -> State# RealWorld -> (# State# RealWorld, a #))
+     -> State# RealWorld -> (# State# RealWorld, p #)
+   with
+   strictness = { \ _arity -> mkClosedDmdSig [topDmd, lazyApply2Dmd, topDmd] topDiv }
+   out_of_line = True
+   has_side_effects = True
+
+------------------------------------------------------------------------
 section "STM-accessible Mutable Variables"
 ------------------------------------------------------------------------
 
diff --git a/compiler/GHC/Cmm/Parser.y b/compiler/GHC/Cmm/Parser.y
index 67ce361a02..ed47fa7a7f 100644
--- a/compiler/GHC/Cmm/Parser.y
+++ b/compiler/GHC/Cmm/Parser.y
@@ -492,15 +492,14 @@ info    :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
                                              , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },
                                 []) }
 
-        | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'
-                -- ptrs, nptrs, closure type, description, type, fun type
+        | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ',' INT ')'
+                -- ptrs, nptrs, closure type, description, type, arity, fun type
                 {% do
                       home_unit_id <- getHomeUnitId
                       liftP $ pure $ do
                         profile <- getProfile
                         let prof = profilingInfo profile $11 $13
-                            ty   = Fun 0 (ArgSpec (fromIntegral $15))
-                                  -- Arity zero, arg_type $15
+                            ty   = Fun (fromIntegral $15) (ArgSpec (fromIntegral $17))
                             rep = mkRTSRep (fromIntegral $9) $
                                       mkHeapRep profile False (fromIntegral $5)
                                                       (fromIntegral $7) ty
@@ -510,7 +509,7 @@ info    :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
                                              , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },
                                 []) }
                 -- we leave most of the fields zero here.  This is only used
-                -- to generate the BCO info table in the RTS at the moment.
+                -- to generate the BCO and CONTINUATION info tables in the RTS at the moment.
 
         | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
                 -- ptrs, nptrs, tag, closure type, description, type
diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs
index 1d482b0143..eb26b4a503 100644
--- a/compiler/GHC/StgToCmm/Prim.hs
+++ b/compiler/GHC/StgToCmm/Prim.hs
@@ -1568,6 +1568,9 @@ emitPrimOp cfg primop =
   MaskUninterruptibleOp -> alwaysExternal
   UnmaskAsyncExceptionsOp -> alwaysExternal
   MaskStatus -> alwaysExternal
+  NewPromptTagOp -> alwaysExternal
+  PromptOp -> alwaysExternal
+  Control0Op -> alwaysExternal
   AtomicallyOp -> alwaysExternal
   RetryOp -> alwaysExternal
   CatchRetryOp -> alwaysExternal