From 8bd5aa38b12526fa3de7544c585c6eb065d4f569 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Jan=20Dvo=C5=99=C3=A1k?= <mordae@anilinux.org>
Date: Thu, 17 Jul 2014 12:14:05 +0200
Subject: [PATCH] allow mixing exceptions with ffi/unsafe/alloc
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

Use call-as-atomic that can handle exceptions instead of dynamic-winding
start-atomic and end-atomic. Exceptions can be found in the functions's
result wrapper such as:

    (define-lib find-some-object
                (_fun (name : _string/utf-8)
                      (object : (_ptr o _some-object-pointer))
                      --> (result : _int)
                      --> (begin
                            (when (negative? result)
                              (error 'find-some-object "unknown name"))
                            object))
                #:wrap (allocator free-some-object))

Signed-off-by: Jan Dvořák <mordae@anilinux.org>
---
 .../scribblings/foreign/alloc.scrbl           | 14 ++---
 racket/collects/ffi/unsafe/alloc.rkt          | 58 +++++++++----------
 2 files changed, 33 insertions(+), 39 deletions(-)

diff --git a/pkgs/racket-pkgs/racket-doc/scribblings/foreign/alloc.scrbl b/pkgs/racket-pkgs/racket-doc/scribblings/foreign/alloc.scrbl
index b5e3d587db..329f1b9af2 100644
--- a/pkgs/racket-pkgs/racket-doc/scribblings/foreign/alloc.scrbl
+++ b/pkgs/racket-pkgs/racket-doc/scribblings/foreign/alloc.scrbl
@@ -15,9 +15,9 @@ Produces a procedure that behaves like @racket[alloc], but the result
 of @racket[alloc] is given a finalizer that calls @racket[dealloc] on
 the result if it is not otherwise freed through a deallocator (as
 designated with @racket[deallocator]). In addition, @racket[alloc] is
-called in atomic mode (see @racket[start-atomic]); its result is
+called in @tech{atomic mode} (see @racket[call-as-atomic]); its result is
 received and registered in atomic mode, so that the result is reliably
-freed.
+freed as long as no exception is raised.
 
 The @racket[dealloc] procedure itself need not be specifically
 designated a deallocator (via @racket[deallocator]). If a deallocator
@@ -31,11 +31,11 @@ is called explicitly, it need not be the same as @racket[dealloc].}
 )]{
 
 Produces a procedure that behaves like @racket[dealloc]. The
-@racket[dealloc] procedure is called in atomic mode (see
-@racket[start-atomic]), and the reference count on one of its
+@racket[dealloc] procedure is called in @tech{atomic mode} (see
+@racket[call-as-atomic]), and the reference count on one of its
 arguments is decremented; if the reference count reaches zero, no
 finalizer associated by an @racket[allocator]- or
-@racket[referencer]-wrapped procedure is invoked when the value
+@racket[retainer]-wrapped procedure is invoked when the value
 becomes inaccessible.
 
 The optional @racket[get-arg] procedure determines which of
@@ -53,11 +53,11 @@ The @racket[releaser] procedure is a synonym for
          procedure?]{
 
 Produces a procedure that behaves like @racket[retain]. The procedure
-is called in atomic mode (see @racket[start-atomic]), and the
+is called in @tech{atomic mode} (see @racket[call-as-atomic]), and the
 reference count on one of its arguments is incremented, with
 @racket[release] recorded as the corresponding release procedure to be
 called by the finalizer on the retained object (unless some
-deallocator, as wrapped by @racket[deallocate], is explicitly called
+deallocator, as wrapped by @racket[deallocator], is explicitly called
 first).
 
 The optional @racket[get-arg] procedure determines which of
diff --git a/racket/collects/ffi/unsafe/alloc.rkt b/racket/collects/ffi/unsafe/alloc.rkt
index 107e910b62..5ca44e88e0 100644
--- a/racket/collects/ffi/unsafe/alloc.rkt
+++ b/racket/collects/ffi/unsafe/alloc.rkt
@@ -18,46 +18,40 @@
 
 (define ((allocator d) proc)
   (rename
-   (lambda args
-     (dynamic-wind
-         start-atomic
-         (lambda ()
-           (let ([v (apply proc args)])
-             (when v
-               (hash-set! allocated v (list d))
-               (register-finalizer v deallocate))
-             v))
-         end-atomic))
-   proc))
+    (lambda args
+      (call-as-atomic
+        (lambda ()
+          (let ([v (apply proc args)])
+            (when v
+              (hash-set! allocated v (list d))
+              (register-finalizer v deallocate))
+            v))))
+    proc))
 
 (define ((deallocator [get-arg car]) proc)
   (rename
-   (lambda args
-     (dynamic-wind
-         start-atomic
-         (lambda ()
-           (apply proc args)
-           (let ([v (get-arg args)])
-             (let ([ds (hash-ref allocated v #f)])
-               (when ds
-                 (if (null? (cdr ds))
-                     (hash-remove! allocated v)
-                     (hash-set! allocated v (cdr ds)))))))
-         end-atomic))
+    (lambda args
+      (call-as-atomic
+        (lambda ()
+         (apply proc args)
+         (let ([v (get-arg args)])
+           (let ([ds (hash-ref allocated v #f)])
+             (when ds
+               (if (null? (cdr ds))
+                   (hash-remove! allocated v)
+                   (hash-set! allocated v (cdr ds)))))))))
    proc))
 
 (define ((retainer d [get-arg car]) proc)
   (rename
    (lambda args
-     (dynamic-wind
-         start-atomic
-         (lambda ()
-	   (begin0
-	    (apply proc args)
-	    (let ([v (get-arg args)])
-	      (let ([ds (hash-ref allocated v null)])
-		(hash-set! allocated v (cons d ds))))))
-         end-atomic))
+     (call-as-atomic
+       (lambda ()
+         (begin0
+           (apply proc args)
+           (let ([v (get-arg args)])
+             (let ([ds (hash-ref allocated v null)])
+               (hash-set! allocated v (cons d ds))))))))
    proc))
 
 (define (rename new orig)