Commit 9b1ed35d authored by Liam Healy's avatar Liam Healy

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.
parent 87723ec1
;; "Data" is bulk arrayed data, like vectors, matrices, permutations, ;; "Data" is bulk arrayed data, like vectors, matrices, permutations,
;; combinations, or histograms. ;; combinations, or histograms.
;; Liam Healy 2008-04-06 21:23:41EDT ;; 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$ ;; $Id$
(in-package :gsl) (in-package :gsl)
...@@ -16,11 +16,14 @@ ...@@ -16,11 +16,14 @@
:documentation "A pointer to the GSL representation of the data.") :documentation "A pointer to the GSL representation of the data.")
(block-pointer :initform nil :accessor block-pointer (block-pointer :initform nil :accessor block-pointer
:documentation "A pointer to the gsl-block-c.") :documentation "A pointer to the gsl-block-c.")
#-native
(c-pointer :initarg :c-pointer :accessor c-pointer (c-pointer :initarg :c-pointer :accessor c-pointer
:documentation "A pointer to the C array.") :documentation "A pointer to the C array.")
(dimensions :initarg :dimensions :reader dimensions) (dimensions :initarg :dimensions :reader dimensions)
(total-size :initarg :total-size :reader total-size) (total-size :initarg :total-size :reader total-size)
(element-type :initarg :element-type :reader element-type) (element-type :initarg :element-type :reader element-type)
(original-array :initarg :original-array :reader original-array)
(offset :initarg :offset :reader offset)
#-native #-native
(cl-invalid (cl-invalid
:initform t :accessor cl-invalid :initform t :accessor cl-invalid
...@@ -44,6 +47,17 @@ ...@@ -44,6 +47,17 @@
(export '(dimensions total-size element-type)) (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) (defmethod print-object ((object gsl-data) stream)
(print-unreadable-object (object stream :type t) (print-unreadable-object (object stream :type t)
(copy-c-to-cl object) (copy-c-to-cl object)
...@@ -113,8 +127,8 @@ ...@@ -113,8 +127,8 @@
"Make the data object from the CL array make with make-array*." "Make the data object from the CL array make with make-array*."
(make-instance class (make-instance class
:cl-array array :cl-array array
:mpointer nil ; this will be set by :before method below. :mpointer nil ; this will be set by :before method below.
:c-pointer nil ; this will be set by defmfun #-native :c-pointer #-native nil ; this will be set by defmfun
:dimensions (array-dimensions array) :dimensions (array-dimensions array)
:total-size (array-total-size array))) :total-size (array-total-size array)))
...@@ -190,7 +204,7 @@ ...@@ -190,7 +204,7 @@
within the body to the object. The argument within the body to the object. The argument
init-or-spec is either the init-or-spec is either the
array dimensions or something made by make-array*." array dimensions or something made by make-array*."
(with-unique-names (cptr eltype) (with-unique-names (eltype)
`(macrolet `(macrolet
;; #'els is a convenience macro to define the make-array* ;; #'els is a convenience macro to define the make-array*
((a (&rest contents) ((a (&rest contents)
...@@ -200,18 +214,14 @@ ...@@ -200,18 +214,14 @@
`(abody ',',(lookup-type type *class-element-type*) `(abody ',',(lookup-type type *class-element-type*)
,@contents))) ,@contents)))
(let* ((,symbol (make-data ',type ,init-or-spec)) (let* ((,symbol (make-data ',type ,init-or-spec))
(,eltype (element-type ,symbol))) ;;(,eltype (element-type ,symbol))
(with-pointer-to-array )
((cl-array ,symbol) (unwind-protect
,cptr (multiple-value-prog1
(component-type ,eltype) (progn
(component-size ,symbol)) #-native (setf (c-pointer ,symbol) ,cptr)
(unwind-protect ,@body)
(multiple-value-prog1 ,@(when sync-exit `((copy-c-to-cl ,symbol)))))))))
(progn
(setf (c-pointer ,symbol) ,cptr)
,@body)
,@(when sync-exit `((copy-c-to-cl ,symbol))))))))))
;;;;**************************************************************************** ;;;;****************************************************************************
;;;; Syncronize C and CL ;;;; Syncronize C and CL
...@@ -305,27 +315,24 @@ ...@@ -305,27 +315,24 @@
(data :pointer)) (data :pointer))
(defun alloc-gsl-struct (object) (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. ;; thus it will be created only when first needed.
(unless (c-pointer object) (error "No C array.")) ; safety while developing (unless (block-pointer object)
(let ((blockptr (cffi:foreign-alloc 'gsl-block-c))) (let ((blockptr (cffi:foreign-alloc 'gsl-block-c)))
(setf (block-pointer object) (setf (block-pointer object)
blockptr blockptr
(cffi:foreign-slot-value blockptr 'gsl-block-c 'data) (cffi:foreign-slot-value blockptr 'gsl-block-c 'size)
(c-pointer object) (total-size object))
(cffi:foreign-slot-value blockptr 'gsl-block-c 'size) (setf
(total-size object)) (cffi:foreign-slot-value (block-pointer object) 'gsl-block-c 'data)
(let ((array-struct (alloc-from-block object))) (c-pointer object))
(tg:finalize (let ((array-struct (alloc-from-block object)))
object (tg:finalize
(lambda () object
(unless (eq blockptr array-struct) (lambda ()
(cffi:foreign-free blockptr)) (unless (eq blockptr array-struct)
(cffi:foreign-free array-struct))) (cffi:foreign-free blockptr))
(setf (mpointer object) array-struct)))) (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))
;; Use the foreign-friendly arrays package. ;; Use the foreign-friendly arrays package.
;; Liam Healy 2008-03-22 15:40:08EDT ;; 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$ ;; $Id$
;;; Foreign-friendly arrays (original implementation by Tamas Papp) ;;; Foreign-friendly arrays (original implementation by Tamas Papp)
...@@ -72,10 +72,45 @@ ...@@ -72,10 +72,45 @@
:displaced-to array) :displaced-to array)
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 ;;;; 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 #+native
(defmacro with-pointer-to-array ((array pointer cffi-type length) (defmacro with-pointer-to-array ((array pointer cffi-type length)
&body body) &body body)
......
;; Definition of GSLL system ;; Definition of GSLL system
;; Liam Healy ;; Liam Healy
;; Time-stamp: <2008-11-22 17:13:51EST gsll.asd> ;; Time-stamp: <2008-11-23 14:08:05EST gsll.asd>
;; $Id$ ;; $Id$
(asdf:defsystem "gsll" (asdf:defsystem "gsll"
...@@ -23,10 +23,12 @@ ...@@ -23,10 +23,12 @@
(:file "defmfun" :depends-on (init element-types interface)) (:file "defmfun" :depends-on (init element-types interface))
(:file "callback" :depends-on (init)) (:file "callback" :depends-on (init))
(:file "generate-examples" :depends-on (init)))) (:file "generate-examples" :depends-on (init))))
#+(or)
(:module floating-point (:module floating-point
:depends-on (init) :depends-on (init)
:components :components
((:file "ieee-modes"))) ((:file "ieee-modes")))
#+(or)
(:file "mathematical" :depends-on (init)) (:file "mathematical" :depends-on (init))
;; complex numbers not necessary? Just make a struct. ;; complex numbers not necessary? Just make a struct.
(:module data (:module data
......
;; Macro for defining GSL functions. ;; Macro for defining GSL functions.
;; Liam Healy 2008-04-16 20:49:50EDT defmfun.lisp ;; 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$ ;; $Id$
(in-package :gsl) (in-package :gsl)
...@@ -514,7 +514,7 @@ ...@@ -514,7 +514,7 @@
(mapdown (eq body-maker 'body-optional-arg))) (mapdown (eq body-maker 'body-optional-arg)))
"A complete definition form, starting with defun, :method, or defmethod." "A complete definition form, starting with defun, :method, or defmethod."
(destructuring-bind (destructuring-bind
(&key documentation &allow-other-keys) key-args (&key documentation inputs outputs &allow-other-keys) key-args
`(,definition `(,definition
,@(when (and name (not (defgeneric-method-p name))) ,@(when (and name (not (defgeneric-method-p name)))
(list name)) (list name))
...@@ -527,7 +527,12 @@ ...@@ -527,7 +527,12 @@
(mapcar 'variables-used-in-c-arguments c-arguments)) (mapcar 'variables-used-in-c-arguments c-arguments))
(variables-used-in-c-arguments c-arguments)))) (variables-used-in-c-arguments c-arguments))))
,@(when documentation (list documentation)) ,@(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) (defun body-no-optional-arg (name arglist gsl-name c-arguments key-args)
"Expand the body (computational part) of the defmfun." "Expand the body (computational part) of the defmfun."
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment