From 9b1ed35df6b97df01ca41e8c1212a5448bc3ae57 Mon Sep 17 00:00:00 2001
From: Liam Healy <liam@thinkpad.local>
Date: Thu, 27 Nov 2008 23:12:40 -0500
Subject: [PATCH] Native arrays do not need wrapper

Native arrays are now completely dynamic, i.e., they are garbarge
collected and there is no need for any kind of wrapper, because the
with-pinned-objects is wrapped at the defmfun level.  Most tests pass
on SBCL, but there are still a number that fail.  The GSL parts are
always present; there is potentially unnecessary allocation of all
GSL-required structs at creation time, which might merit some
investigation for a more just-in-time creation procedure.  Potential
problems on non-native implementations completely uninvestigated.
---
 data/data.lisp             | 85 +++++++++++++++++++++-----------------
 data/foreign-friendly.lisp | 37 ++++++++++++++++-
 gsll.asd                   |  4 +-
 init/defmfun.lisp          | 11 +++--
 4 files changed, 93 insertions(+), 44 deletions(-)

diff --git a/data/data.lisp b/data/data.lisp
index 0f831693..b2e5ab0f 100644
--- a/data/data.lisp
+++ b/data/data.lisp
@@ -1,7 +1,7 @@
 ;; "Data" is bulk arrayed data, like vectors, matrices, permutations,
 ;; combinations, or histograms.
 ;; Liam Healy 2008-04-06 21:23:41EDT
-;; Time-stamp: <2008-11-23 08:55:31EST data.lisp>
+;; Time-stamp: <2008-11-27 22:58:31EST data.lisp>
 ;; $Id$
 
 (in-package :gsl)
@@ -16,11 +16,14 @@
 	     :documentation "A pointer to the GSL representation of the data.")
    (block-pointer :initform nil :accessor block-pointer
 		  :documentation "A pointer to the gsl-block-c.")
+   #-native
    (c-pointer :initarg :c-pointer :accessor c-pointer
 	      :documentation "A pointer to the C array.")
    (dimensions :initarg :dimensions :reader dimensions)
    (total-size :initarg :total-size :reader total-size)
    (element-type :initarg :element-type :reader element-type)
+   (original-array :initarg :original-array :reader original-array)
+   (offset :initarg :offset :reader offset)
    #-native
    (cl-invalid
     :initform t :accessor cl-invalid
@@ -44,6 +47,17 @@
 
 (export '(dimensions total-size element-type))
 
+(defmethod initialize-instance :after ((object gsl-data) &rest initargs)
+  (declare (ignore initargs))
+  (multiple-value-bind  (oa index-offset)
+      (find-original-array (cl-array object))
+    (with-slots (original-array offset) object
+      (setf original-array oa
+	    offset
+	    (* index-offset
+	       (cffi:foreign-type-size (cl-cffi (element-type object)))))))
+  (alloc-gsl-struct object))
+
 (defmethod print-object ((object gsl-data) stream)
   (print-unreadable-object (object stream :type t) 
     (copy-c-to-cl object)
@@ -113,8 +127,8 @@
   "Make the data object from the CL array make with make-array*."
   (make-instance class
 		 :cl-array array
-		 :mpointer nil	; this will be set by :before method below.
-		 :c-pointer nil		; this will be set by defmfun
+		 :mpointer nil ; this will be set by :before method below.
+		 #-native :c-pointer #-native nil ; this will be set by defmfun
 		 :dimensions (array-dimensions array)
 		 :total-size (array-total-size array)))
 
@@ -190,7 +204,7 @@
    within the body to the object.  The argument
    init-or-spec is either the
    array dimensions or something made by make-array*."
-  (with-unique-names (cptr eltype)
+  (with-unique-names (eltype)
     `(macrolet
 	 ;; #'els is a convenience macro to define the make-array*
 	 ((a (&rest contents)
@@ -200,18 +214,14 @@
 	    `(abody ',',(lookup-type type *class-element-type*)
 		    ,@contents)))
        (let* ((,symbol (make-data ',type ,init-or-spec))
-	      (,eltype (element-type ,symbol)))
-	 (with-pointer-to-array
-	     ((cl-array ,symbol)
-	      ,cptr
-	      (component-type ,eltype)
-	      (component-size ,symbol))
-	   (unwind-protect
-		(multiple-value-prog1
-		    (progn
-		      (setf (c-pointer ,symbol) ,cptr)
-		      ,@body)
-		  ,@(when sync-exit `((copy-c-to-cl ,symbol))))))))))
+	      ;;(,eltype (element-type ,symbol))
+	      )
+	 (unwind-protect
+	      (multiple-value-prog1
+		  (progn
+		    #-native (setf (c-pointer ,symbol) ,cptr)
+		    ,@body)
+		,@(when sync-exit `((copy-c-to-cl ,symbol)))))))))
 
 ;;;;****************************************************************************
 ;;;; Syncronize C and CL
@@ -305,27 +315,24 @@
   (data :pointer))
 
 (defun alloc-gsl-struct (object)
-  ;; Allocate the GSL structure; this should only be called from #'mpointer
+  "Allocate the GSL structure."
+  ;; Need to check that all allocations succeeded.
+  ;; This should only be called from #'mpointer
   ;; thus it will be created only when first needed.
-  (unless (c-pointer object) (error "No C array.")) ; safety while developing
-  (let ((blockptr (cffi:foreign-alloc 'gsl-block-c)))
-    (setf (block-pointer object)
-	  blockptr
-	  (cffi:foreign-slot-value blockptr 'gsl-block-c 'data)
-	  (c-pointer object)
-	  (cffi:foreign-slot-value blockptr 'gsl-block-c 'size)
-	  (total-size object))
-    (let ((array-struct (alloc-from-block object)))
-      (tg:finalize
-       object
-       (lambda ()
-	 (unless (eq blockptr array-struct)
-	   (cffi:foreign-free blockptr))
-	 (cffi:foreign-free array-struct)))
-      (setf (mpointer object) array-struct))))
-
-(defmethod mpointer :before ((object gsl-data))
-  "Make a GSL struct if there isn't one already."
-  (unless (slot-value object 'mpointer)
-    (alloc-gsl-struct object)
-    nil))
+  (unless (block-pointer object)
+    (let ((blockptr (cffi:foreign-alloc 'gsl-block-c)))
+      (setf (block-pointer object)
+	    blockptr
+	    (cffi:foreign-slot-value blockptr 'gsl-block-c 'size)
+	    (total-size object))
+      (setf
+       (cffi:foreign-slot-value (block-pointer object) 'gsl-block-c 'data)
+       (c-pointer object))
+      (let ((array-struct (alloc-from-block object)))
+	(tg:finalize
+	 object
+	 (lambda ()
+	   (unless (eq blockptr array-struct)
+	     (cffi:foreign-free blockptr))
+	   (cffi:foreign-free array-struct)))
+	(setf (mpointer object) array-struct)))))
diff --git a/data/foreign-friendly.lisp b/data/foreign-friendly.lisp
index 0cff1368..9febaea8 100644
--- a/data/foreign-friendly.lisp
+++ b/data/foreign-friendly.lisp
@@ -1,6 +1,6 @@
 ;; Use the foreign-friendly arrays package.
 ;; Liam Healy 2008-03-22 15:40:08EDT
-;; Time-stamp: <2008-11-15 16:54:15EST foreign-friendly.lisp>
+;; Time-stamp: <2008-11-27 22:59:29EST foreign-friendly.lisp>
 ;; $Id$
 
 ;;; Foreign-friendly arrays (original implementation by Tamas Papp)
@@ -72,10 +72,45 @@
 		    :displaced-to array)
 	array)))
 
+;;;;****************************************************************************
+;;;; Protect native pointers (supercedes "pointer management" below for native)
+;;;;****************************************************************************
+
+;;; To be called by a defmfun expander
+#+sbcl
+(defun native-pointer (array-symbols body)
+  "Wrap the body with a form that obtains the native pointer
+   and protects it during execution of the body."
+  (if array-symbols
+      ;; http://www.sbcl.org/manual/Calling-Lisp-From-C.html
+      `(sb-sys:with-pinned-objects
+	   ,(mapcar (lambda (s) `(original-array ,s)) array-symbols)
+	 ,body)
+      body))
+
+#+sbcl
+(defun c-pointer (gsl-data)
+  "The pointer to the C array."
+  (cffi:inc-pointer
+   (sb-sys:vector-sap (original-array gsl-data)) (offset gsl-data)))
+
 ;;;;****************************************************************************
 ;;;; Pointer management
 ;;;;****************************************************************************
 
+#+native
+(defmacro with-pointer-to-array ((array pointer cffi-type length)
+				 &body body)
+  (assert (symbolp pointer))
+  (once-only (array cffi-type)
+    (with-unique-names (original-array index-offset)
+      `(multiple-value-bind (,original-array ,index-offset)
+	   (find-original-array ,array)
+	 (pin-to-pointer (,original-array ,pointer ,cffi-type
+					  ,length ,index-offset)
+	   ,@body)))))
+
+
 #+native
 (defmacro with-pointer-to-array ((array pointer cffi-type length)
 				 &body body)
diff --git a/gsll.asd b/gsll.asd
index 0a45db07..8b0bea7a 100644
--- a/gsll.asd
+++ b/gsll.asd
@@ -1,6 +1,6 @@
 ;; Definition of GSLL system 
 ;; Liam Healy
-;; Time-stamp: <2008-11-22 17:13:51EST gsll.asd>
+;; Time-stamp: <2008-11-23 14:08:05EST gsll.asd>
 ;; $Id$
 
 (asdf:defsystem "gsll"
@@ -23,10 +23,12 @@
 	     (:file "defmfun" :depends-on (init element-types interface))
 	     (:file "callback" :depends-on (init))
 	     (:file "generate-examples" :depends-on (init))))
+   #+(or)
    (:module floating-point
 	    :depends-on (init)
 	    :components
 	    ((:file "ieee-modes")))
+   #+(or)
    (:file "mathematical" :depends-on (init))
    ;; complex numbers not necessary?  Just make a struct.
    (:module data
diff --git a/init/defmfun.lisp b/init/defmfun.lisp
index e0554460..61aaccd0 100644
--- a/init/defmfun.lisp
+++ b/init/defmfun.lisp
@@ -1,6 +1,6 @@
 ;; Macro for defining GSL functions.
 ;; Liam Healy 2008-04-16 20:49:50EDT defmfun.lisp
-;; Time-stamp: <2008-11-16 14:51:48EST defmfun.lisp>
+;; Time-stamp: <2008-11-23 14:09:12EST defmfun.lisp>
 ;; $Id$
 
 (in-package :gsl)
@@ -514,7 +514,7 @@
      (mapdown (eq body-maker 'body-optional-arg)))
   "A complete definition form, starting with defun, :method, or defmethod."
   (destructuring-bind
-	(&key documentation &allow-other-keys) key-args
+	(&key documentation inputs outputs &allow-other-keys) key-args
     `(,definition
 	 ,@(when (and name (not (defgeneric-method-p name)))
 		 (list name))
@@ -527,7 +527,12 @@
 				    (mapcar 'variables-used-in-c-arguments c-arguments))
 			     (variables-used-in-c-arguments c-arguments))))
        ,@(when documentation (list documentation))
-       ,(funcall body-maker name arglist gsl-name c-arguments key-args))))
+       #-native
+       ,(funcall body-maker name arglist gsl-name c-arguments key-args)
+       #+native
+       ,(native-pointer
+	 (union inputs outputs)
+	 (funcall body-maker name arglist gsl-name c-arguments key-args)))))
 
 (defun body-no-optional-arg (name arglist gsl-name c-arguments key-args)
   "Expand the body (computational part) of the defmfun."
-- 
GitLab