From 16fb2be1dcd844e923b86314942127585e99d8b2 Mon Sep 17 00:00:00 2001
From: Jeremie Lasalle Ratelle <lasallej@iro.umontreal.ca>
Date: Fri, 15 Oct 2010 20:39:09 +0000
Subject: [PATCH] with-continuation-checkpoints

---
 lib/_thread.scm |  186 +++++++++++++++++++++++++++++++++----------------------
 1 files changed, 111 insertions(+), 75 deletions(-)

diff --git a/lib/_thread.scm b/lib/_thread.scm
index 27f9da6..3e303e0 100644
--- a/lib/_thread.scm
+++ b/lib/_thread.scm
@@ -2769,22 +2769,24 @@
 (define-prim (##dynamic-wind before thunk after)
   (##continuation-capture
    (lambda (cont)
-     (before)
-     (let* ((dynwind
-             (macro-denv-dynwind
-              (macro-thread-denv (macro-current-thread))))
-            (new-dynwind
-             (macro-make-dynwind
-              (##fixnum.+ (macro-dynwind-level dynwind) 1)
-              before
-              after
-              cont))
-            (results ;; may get bound to a multiple-values object
-             (macro-dynamic-bind dynwind
-              new-dynwind
-              thunk)))
-       (after)
-       results))))
+     (let ((dyn-before (lambda (exit restart) (before)))
+           (dyn-after  (lambda (exit restart) (after))))
+       (before)
+       (let* ((dynwind
+                (macro-denv-dynwind
+                  (macro-thread-denv (macro-current-thread))))
+              (new-dynwind
+                (macro-make-dynwind
+                  (##fixnum.+ (macro-dynwind-level dynwind) 1)
+                  dyn-before
+                  dyn-after
+                  cont))
+              (results ;; may get bound to a multiple-values object
+                (macro-dynamic-bind dynwind
+                                    new-dynwind
+                                    thunk)))
+         (after)
+         results)))))
 
 (define-prim (dynamic-wind before thunk after)
   (macro-force-vars (before thunk after)
@@ -2793,6 +2795,30 @@
         (macro-check-procedure after 3 (dynamic-wind before thunk after)
           (##dynamic-wind before thunk after))))))
 
+(define-prim (##with-continuation-checkpoints before thunk after)
+  (##continuation-capture
+    (lambda (cont)
+      (before cont #f)
+      (let* ((dynwind
+               (macro-denv-dynwind
+                 (macro-thread-denv (macro-current-thread))))
+             (new-dynwind
+               (macro-make-dynwind
+                 (##fixnum.+ (macro-dynwind-level dynwind) 1)
+                 before
+                 after
+                 cont))
+             (results (macro-dynamic-bind dynwind new-dynwind thunk)))
+        (after cont #f)
+        results))))
+
+(define-prim (with-continuation-checkpoints before thunk after)
+  (macro-force-vars (before thunk after)
+    (macro-check-procedure before 1 (with-continuation-checkpoints before thunk after)
+      (macro-check-procedure thunk 2 (with-continuation-checkpoints before thunk after)
+        (macro-check-procedure after 3 (with-continuation-checkpoints before thunk after)
+          (##with-continuation-checkpoints before thunk after))))))
+
 (define-prim (##procedure->continuation proc)
   (##declare (not interrupts-enabled))
   (##closure-ref proc 1))
@@ -2886,70 +2912,74 @@
      (##declare (not interrupts-enabled))
      (##continuation-return-no-winding cont results))))
 
-(define-prim (##continuation-unwind-wind src dst continue)
+(define-prim (##continuation-unwind-wind src dst continue restart)
 
   (define (unwind-src src dst continue) ;; src level > dst level
-    (##continuation-graft-no-winding
-     (macro-dynwind-cont src)
-     (lambda ()
-       ((macro-dynwind-after src))
-       (let ((new-src
-              (macro-denv-dynwind
-               (macro-continuation-denv (macro-dynwind-cont src)))))
-         (cond ((##fixnum.< (macro-dynwind-level dst)
-                            (macro-dynwind-level new-src))
-                (unwind-src new-src dst continue))
-               ((and (##not (##eq? new-src dst))
-                     (##fixnum.< 0 (macro-dynwind-level new-src)))
-                (unwind-src-wind-dst new-src dst continue))
-               (else
-                (continue)))))))
+    (let ((cont (macro-dynwind-cont src)))
+      (##continuation-graft-no-winding
+        cont
+        (lambda ()
+          ((macro-dynwind-after src) cont restart)
+          (let ((new-src
+                  (macro-denv-dynwind
+                    (macro-continuation-denv cont))))
+            (cond ((##fixnum.< (macro-dynwind-level dst)
+                               (macro-dynwind-level new-src))
+                   (unwind-src new-src dst continue))
+                  ((and (##not (##eq? new-src dst))
+                        (##fixnum.< 0 (macro-dynwind-level new-src)))
+                   (unwind-src-wind-dst new-src dst continue))
+                  (else
+                   (continue))))))))
 
   (define (wind-dst src dst continue) ;; src level < dst level
-    (let* ((new-dst
-            (macro-denv-dynwind
-             (macro-continuation-denv (macro-dynwind-cont dst))))
-           (new-continue
-            (lambda ()
-              (##continuation-graft-no-winding
-               (macro-dynwind-cont dst)
-               (lambda ()
-                 ((macro-dynwind-before dst))
-                 (continue))))))
-      (cond ((##fixnum.< (macro-dynwind-level src)
-                         (macro-dynwind-level new-dst))
-             (wind-dst src new-dst new-continue))
-            ((and (##not (##eq? src new-dst))
-                  (##fixnum.< 0 (macro-dynwind-level new-dst)))
-             (unwind-src-wind-dst src new-dst new-continue))
-            (else
-             (new-continue)))))
-
-  (define (unwind-src-wind-dst src dst continue) ;; src level = dst level
-    (##continuation-graft-no-winding
-     (macro-dynwind-cont src)
-     (lambda ()
-       ((macro-dynwind-after src))
-       (let* ((new-src
-               (macro-denv-dynwind
-                (macro-continuation-denv (macro-dynwind-cont src))))
-              (new-dst
+    (let ((cont (macro-dynwind-cont dst)))
+      (let* ((new-dst
                (macro-denv-dynwind
-                (macro-continuation-denv (macro-dynwind-cont dst))))
-              (new-continue
+                 (macro-continuation-denv cont)))
+             (new-continue
                (lambda ()
                  (##continuation-graft-no-winding
-                  (macro-dynwind-cont dst)
-                  (lambda ()
-                    ((macro-dynwind-before dst))
-                    (continue))))))
-         (if (and (##not (##eq? new-src new-dst))
-                  (##not (##fixnum.= (macro-dynwind-level new-src) 0)))
-           (unwind-src-wind-dst
-            new-src
-            new-dst
-            (lambda () (new-continue)))
-           (new-continue))))))
+                   cont
+                   (lambda ()
+                     ((macro-dynwind-before dst) cont restart)
+                     (continue))))))
+        (cond ((##fixnum.< (macro-dynwind-level src)
+                           (macro-dynwind-level new-dst))
+               (wind-dst src new-dst new-continue))
+              ((and (##not (##eq? src new-dst))
+                    (##fixnum.< 0 (macro-dynwind-level new-dst)))
+               (unwind-src-wind-dst src new-dst new-continue))
+              (else
+               (new-continue))))))
+
+  (define (unwind-src-wind-dst src dst continue) ;; src level = dst level
+    (let ((src-cont (macro-dynwind-cont src))
+          (dst-cont (macro-dynwind-cont dst)))
+      (##continuation-graft-no-winding
+        src-cont
+        (lambda ()
+          ((macro-dynwind-after src) src-cont restart)
+          (let* ((new-src
+                   (macro-denv-dynwind
+                     (macro-continuation-denv src-cont)))
+                 (new-dst
+                   (macro-denv-dynwind
+                     (macro-continuation-denv dst-cont)))
+                 (new-continue
+                   (lambda ()
+                     (##continuation-graft-no-winding
+                       dst-cont
+                       (lambda ()
+                         ((macro-dynwind-before dst) dst-cont restart)
+                         (continue))))))
+            (if (and (##not (##eq? new-src new-dst))
+                     (##not (##fixnum.= (macro-dynwind-level new-src) 0)))
+                (unwind-src-wind-dst
+                  new-src
+                  new-dst
+                  (lambda () (new-continue)))
+              (new-continue)))))))
 
   (let ((src-level
          (macro-dynwind-level src))
@@ -2982,6 +3012,9 @@
                                   (##cons arg3
                                           others)))))
              (##continuation-graft-no-winding cont ##apply proc args)))))
+  
+  (define (restart)
+    (##continuation-graft-aux cont proc arg1 arg2 arg3 others))
 
   (let* ((src
           (macro-denv-dynwind
@@ -2993,7 +3026,7 @@
             (and (##fixnum.= (macro-dynwind-level src) 0)
                  (##fixnum.= (macro-dynwind-level dst) 0)))
         (continue)
-        (##continuation-unwind-wind src dst (lambda () (continue))))))
+        (##continuation-unwind-wind src dst (lambda () (continue)) (lambda () (restart))))))
 
 (define-prim (##continuation-graft
               cont
@@ -3042,6 +3075,9 @@
                               (##cons val3
                                       others))))
              (macro-subtype-boxvalues))))))
+  
+  (define (restart)
+    (##continuation-return-aux cont val1 val2 val3 others))
 
   (let* ((src
           (macro-denv-dynwind
@@ -3053,7 +3089,7 @@
             (and (##fixnum.= (macro-dynwind-level src) 0)
                  (##fixnum.= (macro-dynwind-level dst) 0)))
         (continue)
-        (##continuation-unwind-wind src dst (lambda () (continue))))))
+        (##continuation-unwind-wind src dst (lambda () (continue)) (lambda () (restart))))))
 
 (define-prim (##continuation-return
               cont
-- 
1.7.3-rc1

