From 30221c2f6a6384ddb6a3e8a9cc1f191f2791ce12 Mon Sep 17 00:00:00 2001
From: Matthias Benkard <code@mail.matthias.benkard.de>
Date: Fri, 15 Feb 2008 19:19:43 +0100
Subject: Improve automatic memory management facilities for structs and
 unions.

darcs-hash:dde4d60386792d18b97c858a681cfaf20ee4ebef
---
 Lisp/data-types.lisp | 63 ++++++++++++++++++++++++++++++++++++----------------
 1 file changed, 44 insertions(+), 19 deletions(-)

(limited to 'Lisp/data-types.lisp')

diff --git a/Lisp/data-types.lisp b/Lisp/data-types.lisp
index 4360ca5..6726f70 100644
--- a/Lisp/data-types.lisp
+++ b/Lisp/data-types.lisp
@@ -36,12 +36,7 @@
        ((pointer :type     c-pointer
                  :reader   pointer-to
                  :initarg  :pointer
-                 :initform (cffi:null-pointer))
-        (lisp-managed :type boolean
-                      :accessor foreign-value-lisp-managed-p
-                      :initarg :lisp-managed
-                      :initform nil
-                      :documentation "Whether we need to handle deallocation."))))
+                 :initform (cffi:null-pointer)))))
 
 
 (defmethod make-load-form ((instance c-pointer-wrapper) &optional environment)
@@ -230,12 +225,19 @@ an __exception__, you can simply send it the `self' message.
   __id__"))
 
 
-(defclass opaque-struct (c-pointer-wrapper)
+(defclass foreign-value (c-pointer-wrapper)
+     ((lisp-managed-cell :type (array boolean ())
+                         :accessor foreign-value-lisp-managed-cell-p
+                         :initarg :lisp-managed-cell
+                         :documentation "Whether we need to handle deallocation.")))
+
+
+(defclass opaque-struct (foreign-value)
   ((name :type (or null string)
          :accessor struct-name
          :initarg :name)))
 
-(defclass tagged-struct (c-pointer-wrapper)
+(defclass tagged-struct (foreign-value)
   ((name :type (or null string)
          :accessor struct-name
          :initarg :name)
@@ -246,7 +248,7 @@ an __exception__, you can simply send it the `self' message.
 
 (defclass tagged-union (tagged-struct) ())
 
-(defclass tagged-array (c-pointer-wrapper)
+(defclass tagged-array (foreign-value)
   ((element-type :type symbol
                  :accessor tagged-array-element-type
                  :initarg :element-type)
@@ -255,17 +257,40 @@ an __exception__, you can simply send it the `self' message.
    (typespec :accessor foreign-value-typespec)))
 
 
+(defgeneric foreign-value-lisp-managed-p (foreign-value))
+(defmethod foreign-value-lisp-managed-p ((foreign-value foreign-value))
+  (with-slots (lisp-managed-cell) foreign-value
+    (aref lisp-managed-cell)))
+
+
+(defgeneric (setf foreign-value-lisp-managed-p) (managedp foreign-value))
+(defmethod (setf foreign-value-lisp-managed-p)
+    (managedp (foreign-value foreign-value))
+  (with-slots (lisp-managed-cell) foreign-value
+    (setf (aref lisp-managed-cell) managedp)))
+
+
 (defun make-struct-wrapper (pointer typespec managedp)
-  (let ((new-wrapper (make-instance (ecase (typespec-primary-type typespec)
-                                      (struct 'tagged-struct)
-                                      (union 'tagged-union))
-                        :typespec typespec
-                        :pointer pointer
-                        :lisp-managed managedp)))
-    (when managedp
-      (trivial-garbage:finalize new-wrapper
-                                #'(lambda ()
-                                    (foreign-free pointer))))))
+  ;; We use a zero-dimensional array that the finaliser can close over
+  ;; so that it (the finaliser) can decide whether to garbage-collect
+  ;; the foreign data.
+  ;;
+  ;; Using the instance slot directly would be both easier and more
+  ;; transparent, of course, but it also wouldn't work, because during
+  ;; finalisation, the instance is not in a usable state anymore.
+  (let ((managedp-cell (make-array '() :element-type 'boolean
+                                       :initial-element managedp)))
+    (flet ((finaliser ()
+             (when (aref managedp-cell)
+               (foreign-free pointer))))
+      (let ((new-wrapper (make-instance (ecase (typespec-primary-type typespec)
+                                          (struct 'tagged-struct)
+                                          (union 'tagged-union))
+                            :typespec typespec
+                            :pointer pointer
+                            :lisp-managed-cell managedp-cell)))
+        (when managedp
+          (trivial-garbage:finalize new-wrapper #'finaliser))))))
 
 
 (defgeneric objcl-eql (obj1 obj2))
-- 
cgit v1.2.3