diff --git a/data/data.lisp b/data/data.lisp index a7e7b7b74f37905eff7667194ea27aa9584f92b3..4f10bce7c36d4925c41c4528e5b07384f97edcb3 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-11 21:37:21EST data.lisp> +;; Time-stamp: <2008-11-15 19:46:51EST data.lisp> ;; $Id$ (in-package :gsl) @@ -190,30 +190,29 @@ within the body to the object. The argument init-or-spec is either the array dimensions or something made by make-array*." - (cl-utilities:with-unique-names (cptr eltype) + (with-unique-names (cptr eltype) `(macrolet - ;; #'els is a convenience macro to define the make-array* - ((a (&rest contents) - `(abody ',',(lookup-type type *class-element-type*) - ,@(mapcar (lambda (e) `(quote ,e)) contents))) - (a* (&rest contents) - `(abody ',',(lookup-type type *class-element-type*) - ,@contents))) - (let* ((,symbol (make-data ',type ,init-or-spec)) - (,eltype (element-type ,symbol))) - (ffa:with-pointer-to-array - ((cl-array ,symbol) - ,cptr - (component-type ,eltype) - (component-size ,symbol) - nil) ; we need to allow nil direction - (unwind-protect - (multiple-value-prog1 - (progn - (setf (c-pointer ,symbol) ,cptr) - ,@body) - ,@(when sync-exit `((copy-c-to-cl ,symbol)))) - (free-gsl-struct ,symbol))))))) + ;; #'els is a convenience macro to define the make-array* + ((a (&rest contents) + `(abody ',',(lookup-type type *class-element-type*) + ,@(mapcar (lambda (e) `(quote ,e)) contents))) + (a* (&rest contents) + `(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)))) + (free-gsl-struct ,symbol))))))) ;;;;**************************************************************************** ;;;; Syncronize C and CL @@ -254,27 +253,25 @@ (component-size object)) (setf cl-invalid nil))) -;;; My replacement for ffa's routines. I don't do coercions or checks -;;; on type as they are unnecessary, and I handle complex types. - #-native (defun copy-array-to-pointer (array pointer lisp-type index-offset length) "Copy length elements from array (starting at index-offset) of type lisp-type to the memory area that starts at pointer, coercing the elements if necessary." (let ((cffi-type (component-type lisp-type))) - (iter:iter - (iter:for pointer-index :from 0 - :below (if (subtypep lisp-type 'complex) (* 2 length) length) - :by (if (subtypep lisp-type 'complex) 2 1)) - (iter:for array-index :from index-offset) - (if (subtypep lisp-type 'complex) - (setf (cffi:mem-aref pointer cffi-type pointer-index) - (realpart (row-major-aref array array-index)) - (cffi:mem-aref pointer cffi-type (1+ pointer-index)) - (imagpart (row-major-aref array array-index))) - (setf (cffi:mem-aref pointer cffi-type pointer-index) - (row-major-aref array array-index)))))) + (loop + for pointer-index :from 0 + :below (if (subtypep lisp-type 'complex) (* 2 length) length) + :by (if (subtypep lisp-type 'complex) 2 1) + for array-index :from index-offset + do + (if (subtypep lisp-type 'complex) + (setf (cffi:mem-aref pointer cffi-type pointer-index) + (realpart (row-major-aref array array-index)) + (cffi:mem-aref pointer cffi-type (1+ pointer-index)) + (imagpart (row-major-aref array array-index))) + (setf (cffi:mem-aref pointer cffi-type pointer-index) + (row-major-aref array array-index)))))) #-native (defun copy-array-from-pointer (array pointer lisp-type index-offset length) @@ -282,15 +279,16 @@ lisp-type from the memory area that starts at pointer, coercing the elements if necessary." (let ((cffi-type (component-type lisp-type))) - (iter:iter - (iter:for pointer-index :from 0 - :below (if (subtypep lisp-type 'complex) (* 2 length) length) - :by (if (subtypep lisp-type 'complex) 2 1)) - (iter:for array-index :from index-offset) - (setf (row-major-aref array array-index) - (complex - (cffi:mem-aref pointer cffi-type pointer-index) - (cffi:mem-aref pointer cffi-type (1+ pointer-index))))))) + (loop + for pointer-index :from 0 + :below (if (subtypep lisp-type 'complex) (* 2 length) length) + :by (if (subtypep lisp-type 'complex) 2 1) + for array-index :from index-offset + do + (setf (row-major-aref array array-index) + (complex + (cffi:mem-aref pointer cffi-type pointer-index) + (cffi:mem-aref pointer cffi-type (1+ pointer-index))))))) ;;;;**************************************************************************** ;;;; C structures @@ -329,8 +327,9 @@ (defun free-gsl-struct (object) "Free the C structure(s) and memory for data." - ;; This should happen immediately after the with-pointer-to-array - ;; and substitutes for the GSL "_free" functions. + ;; This should happen immediately at the end of the + ;; with-pointer-to-array and substitutes for the GSL "_free" + ;; functions. (when (block-pointer object) (unless (eq (block-pointer object) (mpointer object)) (cffi:foreign-free (block-pointer object))) ; free the block struct diff --git a/data/foreign-friendly.lisp b/data/foreign-friendly.lisp index b4c1675e6a6e85e786f93d3b6065d048c5bb517b..0cff13681b0308b5390d769e6b37e299fcab0dc6 100644 --- a/data/foreign-friendly.lisp +++ b/data/foreign-friendly.lisp @@ -1,10 +1,12 @@ ;; Use the foreign-friendly arrays package. -;; Liam Healy 2008-03-22 15:40:08EDT ffa.lisp -;; Time-stamp: <2008-11-11 22:13:20EST foreign-friendly.lisp> +;; Liam Healy 2008-03-22 15:40:08EDT +;; Time-stamp: <2008-11-15 16:54:15EST foreign-friendly.lisp> ;; $Id$ -;;; Use Papp's Foreign-friendly arrays +;;; Foreign-friendly arrays (original implementation by Tamas Papp) ;;; http://www.princeton.edu/~tpapp/software.html +;;; The replacements here don't do coercions or checks +;;; on type as they are unnecessary, and handle complex types. (in-package :gsl) @@ -28,17 +30,16 @@ (if (and (subtypep element-type 'complex) (= (length initial-contents) (* 2 (if (listp dimensions) (apply #'* dimensions) dimensions)))) - (make-ffa* dimensions element-type + (make-ffa dimensions element-type :initial-contents (loop for (re im) on initial-contents by #'cddr collect (complex re im))) - (make-ffa* dimensions element-type :initial-contents initial-contents)) + (make-ffa dimensions element-type :initial-contents initial-contents)) (if initial-element-p - (make-ffa* dimensions element-type :initial-element initial-element) - (make-ffa* dimensions element-type)))) + (make-ffa dimensions element-type :initial-element initial-element) + (make-ffa dimensions element-type)))) -;;; From Tamas Papp's foreign-friendly arrays (FFA) -(defun make-ffa* (dimensions element-type &key +(defun make-ffa (dimensions element-type &key (initial-element 0 initial-element-p) (initial-contents nil initial-contents-p)) "Make an array that is either one-dimensional or displaced to a @@ -70,3 +71,62 @@ (make-array dimensions :element-type element-type :displaced-to array) array))) + +;;;;**************************************************************************** +;;;; 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) + (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) + (cffi:with-foreign-object (,pointer ,cffi-type ,length) + ,@body))))) + +#+sbcl +(defmacro pin-to-pointer ((array pointer cffi-type length index-offset) + &body body) + (declare (ignorable length)) + "Use SBCL's sb-sys:with-pinned-objects and sb-sys:vector-sap for +mapping an array to a memory location. NOTE: checking that cffi-type +matches the type of the array is the responsibility of the user of +this macro. The size of the array is checked. The array is required +to have rank one." + (once-only (array) + `(sb-sys:with-pinned-objects (,array) + ;;(assert (<= (+ ,index-offset ,length) (length ,array))) + (let ((,pointer + (cffi:inc-pointer + (sb-sys:vector-sap ,array) + (* ,index-offset (cffi:foreign-type-size ,cffi-type))))) + ,@body)))) + +(defun find-original-array (array) + "Find the original parent of a displaced array, return this and the +sum of displaced index offsets." + (let ((sum-of-offsets 0)) + (tagbody + check-displacement + (multiple-value-bind (displaced-to displaced-index-offset) + (array-displacement array) + (when displaced-to + (setf array displaced-to) + (incf sum-of-offsets displaced-index-offset) + (go check-displacement)))) + (values array sum-of-offsets))) diff --git a/data/matrix.lisp b/data/matrix.lisp index b49f0ae80ecb41ebd027045ef60f77ec60ef1b6e..229c11dbc2b29d59b39b4b59d77fe4ec34a02e6e 100644 --- a/data/matrix.lisp +++ b/data/matrix.lisp @@ -1,6 +1,6 @@ ;; Matrices -;; Liam Healy 2008-04-15 21:57:52EDT matrix-ffa.lisp -;; Time-stamp: <2008-11-08 22:33:17EST matrix.lisp> +;; Liam Healy 2008-04-15 21:57:52EDT matrix.lisp +;; Time-stamp: <2008-11-15 13:35:20EST matrix.lisp> ;; $Id$ (in-package :gsl) @@ -22,7 +22,7 @@ () (:documentation "GSL matrices.")) -;;; Define all the mvector subclasses that are supported by FFA +;;; Define all supported matrix subclasses #.(data-defclass 'matrix 'matrix) ;;;;**************************************************************************** diff --git a/data/vector.lisp b/data/vector.lisp index d137f1a6638aadb979093bc4ed4fc977f65a13bf..21c4b659175e8f8f01710ece91f19837ea42b054 100644 --- a/data/vector.lisp +++ b/data/vector.lisp @@ -1,6 +1,6 @@ ;; Vectors -;; Liam Healy 2008-04-13 09:39:02EDT vector-ffa.lisp -;; Time-stamp: <2008-11-08 21:08:10EST vector.lisp> +;; Liam Healy 2008-04-13 09:39:02EDT vector.lisp +;; Time-stamp: <2008-11-15 13:35:01EST vector.lisp> ;; $Id$ (in-package :gsl) @@ -21,7 +21,7 @@ () (:documentation "GSL vectors.")) -;;; Define all the mvector subclasses that are supported by FFA +;;; Define all supported mvector subclasses #.(data-defclass 'vector 'mvector) (defun make-vector-from-pointer ()) diff --git a/gsll.asd b/gsll.asd index 04a4ca329b082357c44b11194ded0f9366694105..1eda85496ad28bf3c159cf5cb0e6e58a133b7deb 100644 --- a/gsll.asd +++ b/gsll.asd @@ -1,6 +1,6 @@ ;; Definition of GSLL system ;; Liam Healy -;; Time-stamp: <2008-10-20 22:43:24EDT gsll.asd> +;; Time-stamp: <2008-11-15 13:41:12EST gsll.asd> ;; $Id$ (asdf:defsystem "gsll" @@ -9,7 +9,7 @@ :version "0" :author "Liam M. Healy" :licence "LLGPL v3, FDL" - :depends-on (cffi ffa) + :depends-on (cffi cl-utilities) :components ((:module init :components diff --git a/init/generate-tests.lisp b/init/generate-tests.lisp index b9f15868f605e8178b9655067cfcee7b6beeba6c..f87105a93e86a8644d45432cca6540ca1d1e294a 100644 --- a/init/generate-tests.lisp +++ b/init/generate-tests.lisp @@ -1,6 +1,6 @@ ;; Make tests and examples ;; Liam Healy 2008-09-07 21:00:48EDT generate-tests.lisp -;; Time-stamp: <2008-11-09 16:50:26EST generate-tests.lisp> +;; Time-stamp: <2008-11-15 13:29:28EST generate-tests.lisp> ;; $Id: $ ;;; Througout the GSLL interface definition files are #'save-test @@ -232,13 +232,14 @@ form)))) (defun generate-all-array-tests-body (element-types test) - (iter (for default-element-type in (element-types element-types)) - (declare (special default-element-type starting-element)) - (setf starting-element 0) - (collect - (stupid-code-walk-eval-some - test - '(array-default vector-default scalar-default))))) + (loop for det in (element-types element-types) + collect + (let ((default-element-type det)) + (declare (special default-element-type starting-element)) + (setf starting-element 0) + (stupid-code-walk-eval-some + test + '(array-default vector-default scalar-default))))) (defmacro generate-all-array-tests (name element-types test) `(save-test ,name ,@(generate-all-array-tests-body element-types test))) diff --git a/init/init.lisp b/init/init.lisp index 86e1058a1499a8904b1d62b76712392599bf3da2..8b87fc421e083d567131d62dc780e00baf106d97 100644 --- a/init/init.lisp +++ b/init/init.lisp @@ -1,11 +1,11 @@ ;; Load GSL ;; Liam Healy Sat Mar 4 2006 - 18:53 -;; Time-stamp: <2008-10-11 14:26:33EDT init.lisp> +;; Time-stamp: <2008-11-15 13:41:13EST init.lisp> ;; $Id$ (defpackage gsll (:nicknames :gsl) - (:use :common-lisp :cffi :iterate)) + (:use :common-lisp :cffi :cl-utilities)) (cffi:define-foreign-library libgslcblas (:darwin (:or "/opt/local/lib/libgslcblas.dylib" "/usr/local/lib/libgslcblas.dylib"))