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