Commit e5d0cfa7 authored by Liam Healy's avatar Liam Healy

Reorder block allocation, replace marray class

Set the contents of the block structure before using it in
alloc-from-block.  Replace the 'marray class with 'foreign-array.
Quote foreign struct slots.  Eliminate copy methods.  Now simple
operations like 'vector-reverse work.
parent e5d36a1b
;; Functions for both vectors and matrices.
;; Liam Healy 2008-04-26 20:48:44EDT both.lisp
;; Time-stamp: <2010-06-27 18:03:26EDT both.lisp>
;; Time-stamp: <2010-06-27 21:31:00EDT both.lisp>
;;
;; Copyright 2008, 2009 Liam M. Healy
;; Distributed under the terms of the GNU General Public License
......@@ -28,7 +28,7 @@
("gsl_" :category :type "_alloc_from_block")
((blockptr :pointer)
(0 sizet) ; offset
((size object) sizet) ; number of elements
((total-size object) sizet) ; number of elements
(1 sizet)) ; stride
:definition :generic
:c-return :pointer
......@@ -68,6 +68,8 @@
:c-return :void
:documentation "Set all elements to 0.")
#|
;;; These will be handled by grid functions/CFFI; do we need to use GSL's routines?
(defmfun grid:copy-to-destination
((source both) (destination both))
("gsl_" :category :type "_memcpy")
......@@ -86,6 +88,7 @@
:inputs (source)
:outputs (destination)
:return (destination))
|#
(defmfun swap ((a both) (b both))
("gsl_" :category :type "_swap")
......@@ -175,7 +178,7 @@
:documentation ; FDL
"Add the scalar complex x to all the elements of array a.")
(defmethod elt+ ((x float) (a marray))
(defmethod elt+ ((x float) (a foreign-array))
(elt+ a x))
(defmfun elt- ((a both) (b both))
......@@ -190,7 +193,7 @@
"Subtract the elements of b from the elements of a.
The two must have the same dimensions.")
(defmethod elt- ((a marray) (x float))
(defmethod elt- ((a foreign-array) (x float))
(elt+ a (- x)))
(defmfun elt* ((a vector) (b vector))
......@@ -235,7 +238,7 @@
:outputs (a)
:return (a))
(defmethod elt/ ((a marray) (x number))
(defmethod elt/ ((a foreign-array) (x number))
(elt* a (/ x)))
(defmfun elt* ((a both) (x float))
......@@ -262,7 +265,7 @@
:documentation ; FDL
"Multiply the elements of a by the scalar complex factor x.")
(defmethod elt* ((x float) (a marray))
(defmethod elt* ((x float) (a foreign-array))
(elt* a x))
;;;;****************************************************************************
......
;; A grid:foreign-array with added metadata for GSL.
;; Liam Healy 2008-04-06 21:23:41EDT
;; Time-stamp: <2010-06-27 18:27:37EDT foreign-array.lisp>
;; Time-stamp: <2010-06-27 21:49:36EDT foreign-array.lisp>
;;
;; Copyright 2008, 2009 Liam M. Healy
;; Distributed under the terms of the GNU General Public License
......@@ -32,7 +32,7 @@
;;; GSL free functions because they would free the C array data.
(defmacro metadata-slot (object name)
`(getf (foreign-metadata ,object) ,name))
`(getf (slot-value ,object 'grid:foreign-metadata) ,name))
(defun make-gsl-metadata (object)
"Make the necessary GSL metadata (mpointer and block-pointer)
......@@ -43,26 +43,26 @@
(unless (metadata-slot object 'mpointer)
(when (zerop (total-size object))
(error "Object ~a has zero total dimension." object))
(let* ((blockptr (cffi:foreign-alloc 'gsl-block-c)) ; check this result
;; it is not clear what foreign-alloc does if the alloc fails.
(array-struct (alloc-from-block object blockptr)))
(let ((blockptr (cffi:foreign-alloc 'gsl-block-c)))
(setf (cffi:foreign-slot-value blockptr 'gsl-block-c 'size)
(grid:total-size object)
(cffi:foreign-slot-value blockptr 'gsl-block-c 'data)
(foreign-pointer object)
(metadata-slot object 'block-pointer) blockptr
(metadata-slot object 'mpointer) array-struct
;; alloc-from-block automatically copies over the data pointer
;; from the block to the vector/matrix; we must do that manually here
(cffi:foreign-slot-value
array-struct
(if (typep object 'matrix) 'gsl-matrix-c 'gsl-vector-c) 'data)
(foreign-pointer object))
(tg:finalize object
(lambda ()
(cffi:foreign-free blockptr)
(cffi:foreign-free array-struct))))
(metadata-slot object 'mpointer)))
(metadata-slot object 'block-pointer) blockptr)
(let ((array-struct (alloc-from-block object blockptr)))
(setf
(metadata-slot object 'mpointer) array-struct
;; alloc-from-block automatically copies over the data pointer
;; from the block to the vector/matrix; we must do that manually here
(cffi:foreign-slot-value
array-struct
(if (typep object 'matrix) 'gsl-matrix-c 'gsl-vector-c) 'data)
(foreign-pointer object))
(tg:finalize object
(lambda ()
(cffi:foreign-free blockptr)
(cffi:foreign-free array-struct))))
(metadata-slot object 'mpointer))))
(defmethod mpointer ((object grid:foreign-array))
(or
......@@ -76,17 +76,15 @@
;;;;;;; There are >1400 calls to make-marray, write an emulation?
;;; This should probably be moved/renamed grid:make-foreign-array.
(export 'make-marray)
(defun make-marray
(element-type &rest keys &key dimensions initial-contents
&allow-other-keys)
(defun make-marray (element-type &rest keys &key dimensions &allow-other-keys)
"Make a GSLL array with the given element type,
:dimensions, and :initial-contents, :initial-element or :data."
(when (subtypep element-type 'grid:foreign-array)
(error "Can't take a class name here anymore, sorry.")
(apply
'grid:make-grid
`((grid:foreign-array ,@dimensions) element-type)
keys)))
(error "Can't take a class name here anymore, sorry."))
(apply
'grid:make-grid
`((grid:foreign-array ,@dimensions) element-type)
keys))
(defun make-marray-or-default
(default dimensions
......@@ -122,12 +120,12 @@
(grid:make-grid
(case category
(:vector
`((foreign-array ,(cffi:foreign-slot-value mpointer cstruct size))
`((foreign-array ,(cffi:foreign-slot-value mpointer cstruct 'size))
,element-type))
(:matrix
`((foreign-array
,(cffi:foreign-slot-value mpointer cstruct size0)
,(cffi:foreign-slot-value mpointer cstruct size1)))
,element-type))
,(cffi:foreign-slot-value mpointer cstruct 'size0)
,(cffi:foreign-slot-value mpointer cstruct 'size1))
,element-type)))
:foreign-pointer foreign-pointer
:foreign-metadata mpointer)))
;; Matrices
;; Liam Healy 2008-04-15 21:57:52EDT matrix.lisp
;; Time-stamp: <2010-06-27 18:03:26EDT matrix.lisp>
;; Time-stamp: <2010-06-27 21:27:22EDT matrix.lisp>
;;
;; Copyright 2008, 2009 Liam M. Healy
;; Distributed under the terms of the GNU General Public License
......@@ -36,16 +36,6 @@
collect (loop for j below dim1
collect (maref pointer i j element-type)))))
(defmethod grid:copy-to-destination
((object matrix) (pointer #.+foreign-pointer-class+))
(foreign-pointer-method
pointer
(loop for i below (dim0 object)
do (loop for j below (dim1 object)
do
(setf (maref pointer i j (element-type object))
(maref object i j))))))
;;;;****************************************************************************
;;;; Mathematical
;;;;****************************************************************************
......
;; Vectors
;; Liam Healy 2008-04-13 09:39:02EDT vector.lisp
;; Time-stamp: <2010-06-27 18:03:25EDT vector.lisp>
;; Time-stamp: <2010-06-27 21:09:42EDT vector.lisp>
;;
;; Copyright 2008, 2009 Liam M. Healy
;; Distributed under the terms of the GNU General Public License
......@@ -32,14 +32,6 @@
(loop for i below (cffi:foreign-slot-value pointer struct-type 'size)
collect (maref pointer i nil element-type)))
(defmethod grid:copy-to-destination
((object mvector) (pointer #.+foreign-pointer-class+))
(foreign-pointer-method
pointer
(loop for i below (dim0 object)
do (setf (maref pointer i nil (element-type object))
(maref object i)))))
;;;;****************************************************************************
;;;; Function definitions
;;;;****************************************************************************
......
;; Definition of GSLL system
;; Liam Healy
;; Time-stamp: <2010-06-27 17:57:19EDT gsll.asd>
;; Time-stamp: <2010-06-27 21:22:11EDT gsll.asd>
;;
;; Copyright 2006, 2007, 2008, 2009 Liam M. Healy
;; Distributed under the terms of the GNU General Public License
......@@ -70,20 +70,20 @@
((:file "mathematical")
#+fsbv
(:file "complex")))
#+(or)
(:module data
:depends-on (init)
:components
((cffi-grovel:grovel-file "array-structs")
(:file "marray" :depends-on ("array-structs"))
(:file "vector" :depends-on ("marray" "array-structs"))
(:file "matrix" :depends-on ("marray" "vector" "array-structs"))
(:file "maref" :depends-on ("marray" "vector" "matrix"))
(:file "both" :depends-on ("marray" "vector" "matrix"))
(:file "copy-cl")
(:file "array-tests" :depends-on ("both"))
(:file "permutation" :depends-on ("marray" "array-structs"))
(:file "combination" :depends-on ("marray" "array-structs"))))
(:file "foreign-array" :depends-on ("array-structs"))
(:file "vector" :depends-on ("foreign-array" "array-structs"))
(:file "matrix" :depends-on ("foreign-array" "vector" "array-structs"))
;(:file "maref" :depends-on ("foreign-array" "vector" "matrix"))
(:file "both" :depends-on ("foreign-array" "vector" "matrix"))
;(:file "copy-cl")
;(:file "array-tests" :depends-on ("both"))
;(:file "permutation" :depends-on ("foreign-array" "array-structs"))
;(:file "combination" :depends-on ("foreign-array" "array-structs"))
))
#+(or)
(:file "polynomial" :depends-on (init data))
#+(or)
......
;; Helpers for defining GSL functions on arrays
;; Liam Healy 2009-01-07 22:01:16EST defmfun-array.lisp
;; Time-stamp: <2010-06-27 18:03:21EDT defmfun-array.lisp>
;; Time-stamp: <2010-06-27 21:11:54EDT defmfun-array.lisp>
;;
;; Copyright 2009 Liam M. Healy
;; Distributed under the terms of the GNU General Public License
......@@ -164,7 +164,7 @@
(:component-float-type
(grid:number-class (grid:component-float-type element-type)))
(otherwise
(data-class-name
(grid:data-class-name
(if (and (eq (second arg) 'both) replace-both)
replace-both
(second arg))
......
;; Load GSL
;; Liam Healy Sat Mar 4 2006 - 18:53
;; Time-stamp: <2010-06-27 18:20:14EDT init.lisp>
;; Time-stamp: <2010-06-27 21:28:45EDT init.lisp>
;;
;; Copyright 2006, 2007, 2008, 2009 Liam M. Healy
;; Distributed under the terms of the GNU General Public License
......@@ -23,7 +23,8 @@
(:use :common-lisp :cffi)
(:import-from
:grid
#:cl-array #:dimensions #:total-size #:element-type #:dim0 #:dim1
#:cl-array #:dimensions #:total-size #:element-type
#:foreign-array #:matrix #:dim0 #:dim1
; #:copy #:clone
)
(:shadowing-import-from :grid #:foreign-pointer)
......
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