Commit c561b4d5 authored by Liam Healy's avatar Liam Healy

Removed dependence on FFA and iterate

By incorporating a few definitions modified from Tamas Papp's FFA
directly into GSLL, there is no dependence anymore on FFA separately.
With the conversion of a few definitions, the dependency on iterate
has therefore been eliminated also.  This compiles without errors or
warnings on SBCL.
parent 22f2a25f
;; "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
......
;; 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)))
;; 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)
;;;;****************************************************************************
......
;; 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 ())
......
;; 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
......
;; 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)))
......
;; 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"))
......
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