Commit c75e91d2 authored by Liam Healy's avatar Liam Healy
Browse files

Remove grid to the gsd/c-array repository

The grid subdirectory is now the c-array system within the GSD
repository, as it has no GSL-dependent definitions and is potentially
useful on its own for other C libraries.  There is a bare minimum
mention of GSD in the documentation, which needs to be enhanced as it
is required for GSLL to compile/load.
parent e48ba0cb
;; A "marray" is an array in both GSL and CL
;; Liam Healy 2008-04-06 21:23:41EDT
;; Time-stamp: <2009-12-22 23:17:22EST marray.lisp>
;; Time-stamp: <2009-12-23 23:03:10EST marray.lisp>
(in-package :gsl)
......@@ -88,8 +88,9 @@
;; e.g. (data-class-name 'vector '(unsigned-byte 8))
;; -> VECTOR-UNSIGNED-BYTE-8
(if (member category '(vector matrix))
(intern (format nil "~a-~a" category (c-array:cl-single element-type))
:gsl)
(intern
(format nil "~a-~a" category (c-array:cl-single element-type :gsl))
:gsl)
category))
(defun data-defclass (category superclass)
......
......@@ -117,6 +117,8 @@ combination for which the following are supported:</p>
<li><a href="http://common-lisp.net/project/cl-utilities/">cl-utilities</a>
</li>
<li><a href="http://www.cliki.net/asdf">ASDF</a></li>
<li><a>GSD</a>, the <i>Grid Structured Data</i>; in particular,
the <code>c-array</code> system</li>
<li><a href="http://repo.or.cz/w/lisp-unit.git">lisp-unit</a>, <i>(Optional)</i> necessary
to run <code>gsll-tests</code>
</li>
......@@ -450,7 +452,7 @@ and arrays used internally or for function return.
<!-- Created: Feb 25 2005 -->
<!-- hhmts start -->
<small>
Time-stamp: <2009-12-07 22:51:15EST index.html>
Time-stamp: <2009-12-23 23:10:30EST index.html>
</small>
<!-- hhmts end -->
</div>
......
;; Complex number types
;; Liam Healy 2009-01-13 21:24:05EST complex-types.lisp
;; Time-stamp: <2009-12-06 22:05:59EST complex-types.lisp>
(in-package :c-array)
(export '(complex-double-c complex-float-c component-float-type component-type))
;;;;****************************************************************************
;;;; Complex types
;;;;****************************************************************************
#+fsbv
(fsbv:defcstruct
(complex-float-c :constructor complex :deconstructor (realpart imagpart))
(dat :float :count 2))
#-fsbv
(cffi:defcstruct complex-float-c (dat :float :count 2))
#+fsbv
(fsbv:defcstruct
(complex-double-c :constructor complex :deconstructor (realpart imagpart))
(dat :double :count 2))
#-fsbv
(cffi:defcstruct complex-double-c (dat :double :count 2))
#+long-double
(cffi:defcstruct complex-long-double-c
(dat :long-double :count 2))
(defun clean-type (type)
;; SBCL at least will specify limits on the type, e.g.
;; (type-of #C(1.0 2.0))
;; (COMPLEX (DOUBLE-FLOAT 1.0 2.0))
;; This cleans that up to make
;; (clean-type (type-of #C(1.0 2.0)))
;; (COMPLEX DOUBLE-FLOAT)
(if (and (subtypep type 'complex) (listp (second type)))
(list (first type) (first (second type)))
type))
(defun component-float-type (eltype)
"The type of the component of this type (complex)."
(if (subtypep eltype 'complex)
;; complex: use the component type
(second eltype)
eltype))
(defun component-type (eltype)
(cl-cffi (component-float-type eltype)))
;; Copy objects
;; Liam Healy 2009-12-21 10:16:04EST copy.lisp
;; Time-stamp: <2009-12-21 10:46:41EST copy.lisp>
;; $Id: $
(in-package :c-array)
(export
'(copy clone copy-to-destination copy-making-destination array-mismatch))
(defun copy (object &optional destination)
"Create a duplicate object."
(if destination
(copy-to-destination object destination)
(copy-making-destination object)))
;;; Could be part of copy when the second argument is optional?
(defgeneric clone (object)
(:documentation "Create a duplicate object."))
(defgeneric copy-making-destination (object)
(:documentation "Create new duplicate object."))
(defgeneric copy-to-destination (object destination)
;; This copies values into an existing object. Methods are defined
;; for non-array GSL objects that have _memcpy functions defined.
;; Defined for
;; random-number-generator, quasi-random-number-generator,
;; histogram, histogram2d, permutation, combination.
(:documentation "Copy contents into existing object."))
(define-condition array-mismatch (error)
()
(:report
(lambda (condition stream)
(declare (ignore condition))
(format stream "Arrays must be of equal size for copying.")))
(:documentation
"An error indicating that the two arrays do not have
the same dimensions."))
;; Get/set array or elements: cl-array, maref
;; Liam Healy 2009-12-21 09:40:27EST element-reference.lisp
;; Time-stamp: <2009-12-21 15:55:44EST element-reference.lisp>
(in-package :c-array)
(export '(cl-array))
;;; These functions handle the details of converting between the C
;;; representation of arrays and Common Lisp arrays. The function
;;; #'maref can be treated like #'aref for reading and setting
;;; elements, except that it is limited to two indices (vectors or
;;; matrices only) and requires a final argument with the element
;;; type when taking a C pointer as the first argument (only needed
;;; in the case of solve-minimize-fit for callbacks and some return
;;; values).
;;; Both these functions take one of the following class arguments for
;;; the array:
;;; - a foreign-array
;;; - a Common Lisp array
;;;;****************************************************************************
;;;; Get the entire array: cl-array
;;;;****************************************************************************
(defgeneric cl-array (object &optional array-rank element-type)
(:documentation
"The array as a CL native array. The object may be a foreign-array object,
or an ordinary CL array of one or two dimensions. Optional
arguments array-rank and element-type are used only for
pointers.")
(:method ((object foreign-array) &optional array-rank element-type)
(declare (ignore array-rank element-type))
#-native (copy-c-to-cl object)
(slot-value object 'grid:data))
(:method ((object array) &optional array-rank element-type)
;; For compatibility, work on CL arrays as well.
(declare (ignore array-rank element-type))
object))
;;;;****************************************************************************
;;;; Get or set elements of the array: gref, (setf gref)
;;;;****************************************************************************
(defmethod grid:gref ((object foreign-array) &rest indices)
#-native (copy-c-to-cl object)
(apply 'aref (grid:grid-data object) indices))
;;; Alternative to complete copy is to mark which elements have
;;; changed and just copy them. Is it worth it?
(defmethod (setf grid:gref) (value (object foreign-array) &rest indices)
(apply '(setf aref) value (grid:grid-data object) indices)
#-native (setf (c-invalid object) t))
;; Mapping of element type names
;; Liam Healy 2008-04-13 11:22:46EDT element-types.lisp
;; Time-stamp: <2009-12-07 22:51:13EST element-types.lisp>
;; $Id$
(in-package :c-array)
(export '(*array-element-types* *array-element-types-no-complex*
*float-complex-types* *float-types* *complex-types*
*double-types* element-types))
;;;;****************************************************************************
;;;; Common element type groups for generic functions
;;;;****************************************************************************
(defparameter *array-element-types*
(remove-duplicates (all-types *cstd-cl-type-mapping* t) :test 'equal)
"All the array element types supported.")
(defparameter *array-element-types-no-complex*
(remove-if (lambda (tp) (subtypep tp 'complex)) *array-element-types*)
"All the array element types supported except for complex types.")
(defparameter *float-complex-types*
(remove-if (lambda (tp) (subtypep tp 'integer)) *array-element-types*)
"All the float or complex array element types supported.")
(defparameter *float-types*
(remove-if-not (lambda (tp) (subtypep tp 'float)) *array-element-types*)
"All the float array element types.")
(defparameter *complex-types*
(remove-if-not (lambda (tp) (subtypep tp 'complex)) *array-element-types*)
"All the supported complex array element types.")
(defparameter *double-types*
(list 'double-float '(complex double-float))
"All the supported double float element types.")
(defun element-types (element-types)
"All the element types available of a given category."
(case element-types
((nil t) *array-element-types*)
(:no-complex *array-element-types-no-complex*)
(:float *float-types*)
(:complex *complex-types*)
(:float-complex *float-complex-types*)
(:doubles *double-types*)
(t element-types)))
;; Foreign (C or C-compatible) arrays
;; Liam Healy 2008-12-28 10:44:22EST foreign-array.lisp
;; Time-stamp: <2009-12-21 22:27:03EST foreign-array.lisp>
(in-package :c-array)
;;;;****************************************************************************
;;;; Object and methods
;;;;****************************************************************************
(export '(foreign-array dimensions total-size element-type element-size
*print-contents*))
#-native
(defgeneric (setf cl-invalid) (value object) ; do nothing
(:method (value (object t)) value))
#-native
(defgeneric (setf c-invalid) (value object) ; do nothing
(:method (value (object t)) value))
(defclass foreign-array (grid:grid)
(#-native
(c-pointer :accessor c-pointer :documentation "A pointer to the C array.")
(dimensions :reader dimensions)
(total-size :reader total-size)
(element-type :initarg :element-type :reader element-type)
(original-array :reader original-array)
(offset :reader offset)
#-native
(cl-invalid
:initform t :accessor cl-invalid
:documentation
"An indication of whether the Lisp object (slot 'data) agrees with the
C data. If NIL, they agree. If T, they disagree in an unspecified
way. If a list of index sets, those indices disagree and the remainder
are correct.")
#-native
(c-invalid
:initform t :accessor c-invalid
:documentation
"An indication of whether the C data agrees with the
Lisp object (slot 'data). If NIL, they agree. If T,
they disagree in an unspecified
way. If a list of index sets, those indices disagree and the remainder
are correct."))
(:documentation
"A superclass for arrays represented in C and CL."))
(defun foreign-array-specification (object dimensions)
"Create the grid specification for the object, with a possibly
different set of dimensions."
(let ((class
(or
(find-if (lambda (cl) (typep object cl))
grid:*grid-data-superclasses*)
(class-name (class-of object)))))
(list (cons class dimensions) (element-type object))))
;;; Allowable keys: :dimensions, :initial-contents, :initial-element.
(defmethod initialize-instance :after
((object foreign-array) &rest initargs
&key dimensions initial-contents initial-element)
(declare (ignore dimensions #+native initial-contents #+native initial-element))
(with-slots (grid:rank grid:affi grid:specification grid:data
dimensions original-array offset total-size)
object
(unless (and (slot-boundp object 'grid:data) grid:data)
(setf grid:data (apply #'make-ffa (element-type object) initargs)))
(setf dimensions (array-dimensions grid:data)
total-size (array-total-size grid:data)
grid:rank (length dimensions)
grid:specification
(foreign-array-specification object dimensions)
grid:affi (ignore-errors (affi:make-affi dimensions)))
#-native
(let ((cptr (cffi:foreign-alloc
(cl-cffi (element-type object))
:count (total-size object))))
(setf (c-pointer object) cptr)
(tg:finalize object (lambda () (cffi:foreign-free cptr))))
#-native
(setf (cl-invalid object) (not (or initial-contents initial-element)))
(multiple-value-bind (oa index-offset)
(find-original-array grid:data)
(setf original-array oa
offset
(* index-offset
(cffi:foreign-type-size (cl-cffi (element-type object))))))))
(defparameter *print-contents* t
"Print the contents of the foreign-array.")
(defmethod print-object ((object foreign-array) stream)
(print-unreadable-object (object stream :type t)
(if *print-contents*
(progn
#-native (copy-c-to-cl object)
(princ (grid:grid-data object) stream))
(format stream "dimensions ~a" (dimensions object)))))
(export '(dim0 dim1))
(defun dim0 (object)
"The first dimension of the object."
(first (dimensions object)))
(defun dim1 (object)
"The first dimension of the object."
(second (dimensions object)))
(defun element-size (object)
"The size of each element as stored in C."
(cffi:foreign-type-size (cl-cffi (element-type object))))
;;;;****************************************************************************
;;;; Syncronize C and CL
;;;;****************************************************************************
;;; For implementations with separate C and CL storage (non-native),
;;; the two arrays must match when one side has updated and the other
;;; side wishes to refer to the values. For native implementations,
;;; these don't do anything because they will always match.
;;; Called in defmfun expansion right before GSL function is entered.
#-native
(defun copy-cl-to-c (object)
"Copy the CL array to the C array."
(when (and (typep object 'mobject) (c-invalid object))
(copy-array-to-pointer
(slot-value object 'grid:data)
(c-pointer object)
(element-type object)
0
(total-size object))
(setf (c-invalid object) nil)))
;;; Called right before gref
#-native
(defun copy-c-to-cl (object)
"Copy the C array to the CL array."
(when (and (typep object 'mobject) (cl-invalid object))
(copy-array-from-pointer
(slot-value object 'grid:data)
(c-pointer object)
(element-type object)
0
(total-size object))
(setf (cl-invalid object) nil)))
#-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)))
(loop :repeat length
for array-index :from index-offset
for pointer-index :from 0 :by (if (subtypep lisp-type 'complex) 2 1)
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)
"Copy length elements from array (starting at index-offset) of type
lisp-type from the memory area that starts at pointer, coercing the
elements if necessary."
(let ((cffi-type (component-type lisp-type)))
(loop :repeat length
for pointer-index :from 0 :by (if (subtypep lisp-type 'complex) 2 1)
for array-index :from index-offset
do
(setf (row-major-aref array array-index)
(if (subtypep lisp-type 'complex)
(complex
(cffi:mem-aref pointer cffi-type pointer-index)
(cffi:mem-aref pointer cffi-type (1+ pointer-index)))
(cffi:mem-aref pointer cffi-type pointer-index))))))
;; Use the foreign-friendly arrays package.
;; Liam Healy 2008-03-22 15:40:08EDT
;; Time-stamp: <2009-12-21 08:34:21EST foreign-friendly.lisp>
;;; 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 :c-array)
(export '(make-ffa native-pointer-protect c-pointer))
;;;;****************************************************************************
;;;; Make arrays for possible foreign use
;;;;****************************************************************************
(defun make-ffa
(element-type
&key dimensions (initial-element nil initial-element-p)
(initial-contents nil initial-contents-p)
&allow-other-keys)
"Make an array of one or two dimensions for possible use in foreign code.
Syntax is similar to make-array, but note that element-type
is mandatory and limited to certain types."
(assert (member element-type *array-element-types* :test 'equal)
(element-type)
"Specified element-type must be one of *array-element-types*.")
(let* ((initial-matrix (listp (first initial-contents)))
(complex-initial-real
(and initial-contents-p
(subtypep element-type 'complex)
(typep
(if initial-matrix
(caar initial-contents)
(first initial-contents))
'real))))
(unless dimensions
(if initial-contents-p
(setf dimensions
(if initial-matrix
;; matrix
(list (length initial-contents)
(ceiling (length (first initial-contents))
(if complex-initial-real 2 1)))
;; vector
(ceiling (length initial-contents)
(if complex-initial-real 2 1))))
(error "dimensions must be specified if contents are not")))
(when (and initial-matrix initial-contents-p)
;; flatten matrix spec
(setf initial-contents (apply #'append initial-contents)))
(when complex-initial-real
(setf initial-contents (list-complex-from-real initial-contents)))
(apply 'make-ffa-1d
dimensions element-type
(append
(when initial-contents-p
(list :initial-contents initial-contents))
(when initial-element-p
(list :initial-element initial-element))))))
(defun list-complex-from-real (list)
"Collect a list of complex numbers from real components."
(assert (evenp (length list)) (list)
"Cannot collect reals into complex from an odd number of reals.")
(loop for (re im) on list by #'cddr collect (complex re im)))
(defun make-ffa-1d (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
one-dimensional array. Array is filled with initial-element or
initial-contents, coerced to the given type."
;; element-type is a type spec in CL form
(assert (or (atom dimensions) (and (listp dimensions) (car dimensions))))
(let* ((dimensions (if (atom dimensions) (list dimensions) dimensions))
(length (reduce #'* dimensions))
(array (cond
((and initial-element-p initial-contents-p)
(error "you can't supply both initial-element and ~
initial-contents"))
;; initial element given
(initial-element-p
(make-array length :element-type element-type
:initial-element (coerce initial-element
element-type)))
;; contents given, copy or coerce
(initial-contents
(when (listp (first initial-contents))
;; flatten list for matrices
(setf initial-contents (apply 'append initial-contents)))
(assert (= (length initial-contents) length))
(if (typep initial-contents (list 'vector element-type))
(copy-seq initial-contents)
(map (list 'vector element-type)
(lambda (x) (coerce x element-type)) initial-contents)))
;; neither
(t (make-array length :element-type element-type)))))
(if (cdr dimensions)
(make-array dimensions :element-type element-type
:displaced-to array)
array)))
;;;;****************************************************************************
;;;; Protect native pointers
;;;;****************************************************************************
;;; To be called by a defmfun expander
#+(and native sbcl)
(defun native-pointer-protect (array-symbols body)
"Wrap the body with a form that obtains the native pointer
and protects it during execution of the body."
;; http://www.sbcl.org/manual/Calling-Lisp-From-C.html
`(sb-sys:with-pinned-objects
,(mapcar (lambda (s) `(original-array ,s)) array-symbols)
,body))
#+(and native sbcl)
(defun c-pointer (marray)
"The pointer to the C array."
(cffi:inc-pointer
(sb-sys:vector-sap (original-array marray)) (offset marray)))
;;;;****************************************************************************
;;;; Pointer management
;;;;****************************************************************************
(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)))
;; Methods for grid functions
;; Liam Healy 2009-12-21 11:19:00EST methods.lisp
;; Time-stamp: <2009-12-21 21:56:38EST methods.lisp>
(in-package :c-array)
(defmethod grid:grid-rank ((object foreign-array))
(length (dimensions object)))
(defmethod grid:grid-dimensions ((object foreign-array))
(dimensions object))
(defmethod grid:make-grid-data
((type (eql 'foreign-array)) dimensions rest-spec
&key (initial-element nil initial-element-p))
(make-instance 'foreign-array
:dimensions dimensions
:element-type rest-spec
:initial-element initial-element))
;; Conversion of numbers C->CL
;; Liam Healy, Sun May 28 2006 - 22:04
;; Time-stamp: <2009-12-20 23:12:25EST number-conversion.lisp>
;; $Id$
(in-package :c-array)
(export '(complex-to-cl))
;;;;****************************************************************************
;;;; Built-in numerical types
;;;;****************************************************************************
(export '(dcref))
(defmacro dcref (double &optional (index 0))
"Reference C double(s)."
`(cffi:mem-aref ,double :double ,index))
;;;;****************************************************************************
;;;; Complex numbers
;;;;****************************************************************************
;;; GSL complex struct is defined in init/complex-types.lisp.
(defun complex-to-cl
(gsl-complex &optional (index 0) (complex-type 'complex-double-c))
"Make a CL complex number from the GSL pointer to a complex struct or
an array of complex structs and an index into the array."
(let ((carr (cffi:foreign-slot-value