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.

3 files changed, 14 insertions, 6 deletions

diff --git a/utils/deriveConstants/Main.hs b/utils/deriveConstants/Main.hs
index 4dd187cd52..65c3deb3e5 100644
--- a/utils/deriveConstants/Main.hs
+++ b/utils/deriveConstants/Main.hs
@@ -481,6 +481,12 @@ wanteds os = concat
           ,closureFieldGcptr C "StgAP_STACK" "fun"
           ,closurePayload    C "StgAP_STACK" "payload"
 
+          ,closureSize       C "StgContinuation"
+          ,closureField      C "StgContinuation" "apply_mask_frame"
+          ,closureField      C "StgContinuation" "mask_frame_offset"
+          ,closureField      C "StgContinuation" "stack_size"
+          ,closurePayload    C "StgContinuation" "stack"
+
           ,thunkSize C "StgSelector"
 
           ,closureFieldGcptr C "StgInd" "indirectee"
@@ -1005,4 +1011,3 @@ execute verbose prog args
       ec <- rawSystem prog args
       unless (ec == ExitSuccess) $
           die ("Executing " ++ show prog ++ " failed")
-
diff --git a/utils/genapply/Main.hs b/utils/genapply/Main.hs
index 7166968ddd..34d793236f 100644
--- a/utils/genapply/Main.hs
+++ b/utils/genapply/Main.hs
@@ -726,7 +726,8 @@ genApply regstatus args =
         text "     FUN_2_0,",
         text "     FUN_1_1,",
         text "     FUN_0_2,",
-        text "     FUN_STATIC: {",
+        text "     FUN_STATIC,",
+        text "     CONTINUATION: {",
         nest 4 (vcat [
           text "arity = TO_W_(StgFunInfoExtra_arity(%FUN_INFO(info)));",
           text "ASSERT(arity > 0);",
@@ -851,7 +852,8 @@ genApplyFast regstatus args =
           text "     FUN_2_0,",
           text "     FUN_1_1,",
           text "     FUN_0_2,",
-          text "     FUN_STATIC: {",
+          text "     FUN_STATIC,",
+          text "     CONTINUATION: {",
           nest 4 (vcat [
             text "arity = TO_W_(StgFunInfoExtra_arity(%GET_FUN_INFO(R1)));",
             text "ASSERT(arity > 0);",
diff --git a/utils/genprimopcode/Main.hs b/utils/genprimopcode/Main.hs
index 7fff343188..288ba325fb 100644
--- a/utils/genprimopcode/Main.hs
+++ b/utils/genprimopcode/Main.hs
@@ -298,8 +298,7 @@ gen_hs_source (Info defaults entries) =
            hdr (PrimVecTypeSpec { ty = TyApp (VecTyCon n _) _ }) = wrapOp n ++ ","
            hdr (PrimVecTypeSpec {})                              = error $ "Illegal type spec"
 
-           sec s = "\n-- * " ++ title s ++ "\n"
-                    ++ (unlines $ map ("-- " ++ ) $ lines $ "|" ++ desc s)
+           sec s = "\n{- * " ++ title s ++ "-}\n{-|" ++ desc s ++ "-}"
 
 
            ent   (Section {})         = []
@@ -313,7 +312,7 @@ gen_hs_source (Info defaults entries) =
              -- Doc comments
              [ case desc o ++ extra (opts o) of
                  "" -> []
-                 cmmt -> map ("-- " ++) $ lines $ "|" ++ cmmt
+                 cmmt -> lines ("{-|" ++ cmmt ++ "-}")
 
              -- Deprecations
              , [ d | Just n <- [getName o], d <- prim_deprecated (opts o) n ]
@@ -804,6 +803,8 @@ ppType (TyApp (TyCon "IOPort#") [x,y])   = "mkIOPortPrimTy " ++ ppType x
                                            ++ " " ++ ppType y
 ppType (TyApp (TyCon "TVar#") [x,y])     = "mkTVarPrimTy " ++ ppType x
                                            ++ " " ++ ppType y
+
+ppType (TyApp (TyCon "PromptTag#") [x])  = "mkPromptTagPrimTy " ++ ppType x
 ppType (TyApp (VecTyCon _ pptc) [])      = pptc
 
 ppType (TyUTup ts) = "(mkTupleTy Unboxed "