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.

10 files changed, 127 insertions, 0 deletions

diff --git a/testsuite/tests/rts/continuations/ContIO.hs b/testsuite/tests/rts/continuations/ContIO.hs
new file mode 100644
index 0000000000..5e55cc26d7
--- /dev/null
+++ b/testsuite/tests/rts/continuations/ContIO.hs
@@ -0,0 +1,28 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+
+-- | This module just wraps the continuation primops so they can be used in
+-- 'IO'. This isn't provided anywhere in @base@ because it's still very unsafe!
+module ContIO where
+
+import GHC.Prim
+import GHC.Types
+
+data PromptTag a = PromptTag (PromptTag# a)
+
+newPromptTag :: IO (PromptTag a)
+newPromptTag = IO (\s -> case newPromptTag# s of
+  (# s', tag #) -> (# s, PromptTag tag #))
+
+prompt :: PromptTag a -> IO a -> IO a
+prompt (PromptTag tag) (IO m) = IO (prompt# tag m)
+
+control0 :: PromptTag a -> ((IO b -> IO a) -> IO a) -> IO b
+control0 (PromptTag tag) f =
+  IO (control0# tag (\k -> case f (\(IO a) -> IO (k a)) of IO b -> b))
+
+reset :: PromptTag a -> IO a -> IO a
+reset = prompt
+
+shift :: PromptTag a -> ((IO b -> IO a) -> IO a) -> IO b
+shift tag f = control0 tag (\k -> reset tag (f (\m -> reset tag (k m))))
diff --git a/testsuite/tests/rts/continuations/all.T b/testsuite/tests/rts/continuations/all.T
new file mode 100644
index 0000000000..fb6b6f2ce1
--- /dev/null
+++ b/testsuite/tests/rts/continuations/all.T
@@ -0,0 +1,4 @@
+test('cont_simple_shift', [extra_files(['ContIO.hs'])], multimod_compile_and_run, ['cont_simple_shift', ''])
+test('cont_exn_masking', [extra_files(['ContIO.hs'])], multimod_compile_and_run, ['cont_exn_masking', ''])
+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', ''])
diff --git a/testsuite/tests/rts/continuations/cont_exn_masking.hs b/testsuite/tests/rts/continuations/cont_exn_masking.hs
new file mode 100644
index 0000000000..d3c9790692
--- /dev/null
+++ b/testsuite/tests/rts/continuations/cont_exn_masking.hs
@@ -0,0 +1,17 @@
+-- This test verifies that the async exception masking state is captured and
+-- restored appropriately during continuation capture and restore.
+
+import Control.Exception
+import ContIO
+
+main :: IO ()
+main = do
+  tag <- newPromptTag
+  uninterruptibleMask $ \unmaskUninterruptible ->
+    prompt tag $ unmaskUninterruptible $
+    mask $ \unmaskInterruptible ->
+    control0 tag $ \k -> do
+      print =<< getMaskingState -- should be MaskedUninterruptible
+      unmaskInterruptible $ do
+        k (print =<< getMaskingState) -- should be MaskedInterruptible
+        print =<< getMaskingState -- should be Unmasked
diff --git a/testsuite/tests/rts/continuations/cont_exn_masking.stdout b/testsuite/tests/rts/continuations/cont_exn_masking.stdout
new file mode 100644
index 0000000000..04b17f772d
--- /dev/null
+++ b/testsuite/tests/rts/continuations/cont_exn_masking.stdout
@@ -0,0 +1,3 @@
+MaskedUninterruptible
+MaskedInterruptible
+Unmasked
diff --git a/testsuite/tests/rts/continuations/cont_missing_prompt_err.hs b/testsuite/tests/rts/continuations/cont_missing_prompt_err.hs
new file mode 100644
index 0000000000..b48510417d
--- /dev/null
+++ b/testsuite/tests/rts/continuations/cont_missing_prompt_err.hs
@@ -0,0 +1,9 @@
+import ContIO
+
+main :: IO ()
+main = do
+  tag1 <- newPromptTag
+  tag2 <- newPromptTag
+  prompt tag1 $
+    control0 tag2 $ \k -> -- should error: no such prompt on the stack!
+      k (pure ())
diff --git a/testsuite/tests/rts/continuations/cont_missing_prompt_err.stderr b/testsuite/tests/rts/continuations/cont_missing_prompt_err.stderr
new file mode 100644
index 0000000000..0138fedd5c
--- /dev/null
+++ b/testsuite/tests/rts/continuations/cont_missing_prompt_err.stderr
@@ -0,0 +1 @@
+cont_missing_prompt_err: GHC.Exts.control0#: no matching prompt in the current continuation
diff --git a/testsuite/tests/rts/continuations/cont_nondet_handler.hs b/testsuite/tests/rts/continuations/cont_nondet_handler.hs
new file mode 100644
index 0000000000..8c4e75754a
--- /dev/null
+++ b/testsuite/tests/rts/continuations/cont_nondet_handler.hs
@@ -0,0 +1,47 @@
+{-# LANGUAGE LambdaCase #-}
+
+-- This implements a (very) simple API along the lines of those used by
+-- algebraic effect systems, and it uses a distinct prompt tag to identify each
+-- handler. This is not the approach taken by real effect systems for various
+-- reasons, but it's a decent, minimal exercise of the continuations API.
+
+import Control.Applicative
+import ContIO
+
+data HandlerTag f where
+  HandlerTag :: PromptTag a
+             -> (forall b. f b -> (b -> IO a) -> IO a)
+             -> HandlerTag f
+
+send :: HandlerTag f -> f b -> IO b
+send (HandlerTag tag f) v = control0 tag $ \k -> f v (prompt tag . k . pure)
+
+handle :: (HandlerTag f -> IO a)
+       -> (forall b. f b -> (b -> IO a) -> IO a)
+       -> IO a
+handle f g = do
+  tag <- newPromptTag
+  prompt tag $ f (HandlerTag tag g)
+
+data NonDet a where
+  Choice :: NonDet Bool
+
+handleNonDet :: (HandlerTag NonDet -> IO a) -> IO [a]
+handleNonDet f = handle (fmap (:[]) . f) $ \Choice k ->
+  liftA2 (++) (k True) (k False)
+
+amb :: HandlerTag NonDet -> a -> a -> IO a
+amb tag a b = send tag Choice >>= \case
+  True  -> pure a
+  False -> pure b
+
+example :: IO [[(Integer, Char)]]
+example =
+  handleNonDet $ \tag1 ->
+  handleNonDet $ \tag2 -> do
+    x <- amb tag2  1   2
+    y <- amb tag1 'a' 'b'
+    pure (x, y)
+
+main :: IO ()
+main = print =<< example
diff --git a/testsuite/tests/rts/continuations/cont_nondet_handler.stdout b/testsuite/tests/rts/continuations/cont_nondet_handler.stdout
new file mode 100644
index 0000000000..6c6aaa387c
--- /dev/null
+++ b/testsuite/tests/rts/continuations/cont_nondet_handler.stdout
@@ -0,0 +1 @@
+[[(1,'a'),(2,'a')],[(1,'a'),(2,'b')],[(1,'b'),(2,'a')],[(1,'b'),(2,'b')]]
diff --git a/testsuite/tests/rts/continuations/cont_simple_shift.hs b/testsuite/tests/rts/continuations/cont_simple_shift.hs
new file mode 100644
index 0000000000..72280b5cf6
--- /dev/null
+++ b/testsuite/tests/rts/continuations/cont_simple_shift.hs
@@ -0,0 +1,16 @@
+-- This test is a very simple exercise of continuation capture and restore.
+
+import ContIO
+
+example :: IO [Integer]
+example = do
+  tag <- newPromptTag
+  reset tag $ do
+    n <- shift tag $ \k -> do
+      a <- k (pure 2)
+      b <- k (pure 3)
+      pure (a ++ b)
+    pure [n]
+
+main :: IO ()
+main = print =<< example
diff --git a/testsuite/tests/rts/continuations/cont_simple_shift.stdout b/testsuite/tests/rts/continuations/cont_simple_shift.stdout
new file mode 100644
index 0000000000..057d00e585
--- /dev/null
+++ b/testsuite/tests/rts/continuations/cont_simple_shift.stdout
@@ -0,0 +1 @@
+[2,3]