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,
;; 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)
......@@ -114,7 +128,7 @@
(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
#-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))
;;(,eltype (element-type ,symbol))
)
(unwind-protect
(multiple-value-prog1
(progn
(setf (c-pointer ,symbol) ,cptr)
#-native (setf (c-pointer ,symbol) ,cptr)
,@body)
,@(when sync-exit `((copy-c-to-cl ,symbol))))))))))
,@(when sync-exit `((copy-c-to-cl ,symbol)))))))))
;;;;****************************************************************************
;;;; Syncronize C and CL
......@@ -305,16 +315,19 @@
(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
(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 'data)
(c-pointer object)
(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
......@@ -322,10 +335,4 @@
(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))
(setf (mpointer object) array-struct)))))
;; 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)
......
;; 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
......
;; 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."
......
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