Commit 19f82201 authored by lhealy's avatar lhealy Committed by Liam Healy

Changed how GSL objects are bound: #'letm has been modified so that it

uses function #'letm-expand and generic function #'letm-expansion.  
A method can be defined for each of those expansions, or the defgo
mechanism can still be used.  All existing GSL code compiles and
regression tests pass.  Created foreign-friendly.lisp to use the
ffa definitions, these can be defined in a letm; so far not otherwise
integrated into GSL.


git-svn-id: svn+ssh://common-lisp.net/project/gsll/svn/branches/ffa@45 af03a46b-e846-0410-96e5-d5653c316fd0
parent eef416b5
;; Expansions for GSL data objects
;; Liam Healy 2008-03-23 14:22:01EDT data-expansions.lisp
;; Time-stamp: <2008-03-23 18:06:22EDT data-expansions.lisp>
;; $Id: $
(in-package :gsl)
;;; Replace the data-go macro from data.lisp
(defmacro data-go (type matrixp)
"Define the letm function for data types."
)
;; Use the foreign-friendly arrays package.
;; Liam Healy 2008-03-22 15:40:08EDT ffa.lisp
;; Time-stamp: <2008-03-23 17:59:10EDT foreign-friendly.lisp>
;; $Id: $
;;; Use Papp's Foreign-friendly arrays
;;; http://www.princeton.edu/~tpapp/software.html
;;; Make a foreign-friendly array with #'make-array*,
;;; and/or use one in foreign code in a letm binding.
#|
There are five interrelated forms for these vectors:
Native vector
FFA objects made with with-ffa and used in with-pointer-to-array
C array of doubles
gsl-vector-c struct
GSLL class vector-double-float
When to use what:
GSL vectors gsl-vector-c used when GSL needs it.
FFA used when on SBCL
FFA used when C array needed and I don't want to make a
gsl-vector-c. So maybe a good idea is to always have ffa available,
and only optionally make it part of GSL vectors.
Start implementing bare C array, which I don't actually use yet in
GSLL except in sort-vector-smallest-index, sort-vector-largest-index.
This can be written and tested without interfering with current code.
Add an object c-double-float (by analogy to vector-double-float) to letm processing.
This will be set with standard aref; copy-array and the other things
defined in ffa will be usable.
|#
(in-package :gsl)
;;;;****************************************************************************
;;;; A direct C array
;;;;****************************************************************************
(export '(make-array*))
;; Note ffa does not have 64 bit integers yet.
(defun map-to-ffa-types (cl-type)
(first (rassoc cl-type ffa::*cffi-and-lisp-types* :test #'equal)))
(defun make-array*
(dimensions element-type
&key initial-element (initial-contents nil initial-contents-p))
"Make an array for possible use in foreign code.
Syntax is similar to make-array, but note that element-type
is mandatory and limited to certain types."
(if initial-contents-p
(ffa:make-ffa
dimensions (map-to-ffa-types element-type) :initial-contents initial-contents)
(ffa:make-ffa
dimensions (map-to-ffa-types element-type)
:initial-element
;; ffa objects to making an uninitialized array, seems like a bug
;; workaround to default set to -77
(or initial-element -77))))
(defparameter *foreign-array-directions*
'((:in . :copy-in) (:out . :copy-out) (:in-out . :copy-in-out)))
(defmacro with-c-data
((pointer array cl-element-type &optional (direction :in-out))
&body body)
"Use an array made with make-array* in foreign code. The pointer
is a symbol that will be bound to the foreign pointer."
(cl-utilities:once-only (array)
`(ffa:with-pointer-to-array
(,array
,pointer
(map-to-ffa-types ',cl-element-type)
(array-total-size ,array)
,(rest (assoc direction *foreign-array-directions*)))
,@body)))
(defmacro with-c-data
((pointer array cl-element-type &optional (direction :in-out))
&body body)
"Use an array made with make-array* in foreign code. The pointer
is either a symbol that will be bound to the foreign pointer, or
a list of (c-pointer cl-object) so that the CL object created
is also accessible."
(let ((cl-name (if (listp pointer) (second pointer) (gensym "ARRAY"))))
`(let ((,cl-name ,array))
(ffa:with-pointer-to-array
(,cl-name
,(if (listp pointer) (first pointer) pointer)
(map-to-ffa-types ',cl-element-type)
(array-total-size ,cl-name)
,(rest (assoc direction *foreign-array-directions*)))
,@body))))
;;;;****************************************************************************
;;;; Expand letm bindings
;;;;****************************************************************************
;;; Modify ffa's array-copy to take type argument
(defun array-copy (array &optional type)
"Copy the elements of array. Does not copy the elements itself
recursively, if you need that, use array-map."
(ffa:make-ffa (array-dimensions array)
(or type (array-element-type array))
:initial-contents (ffa:find-or-displace-to-flat-array array)))
(defun expand-direct-c (symbol cl-element-type init-or-spec body)
"Expand the form for a direct foreign array.
Argument 'symbol can be either a symbol or the a list of
two symbols; if the former, it will be bound to the foreign pointer; if
the latter, the first symbol will be bound to the foreign pointer and
the second to the corresponding CL array. The cl-element-type
is a CL element type, init-or-spec is either the
array dimensions or something made by make-array*."
(typecase init-or-spec
(array
`(with-c-data
(,symbol (array-copy ,init-or-spec ',cl-element-type) ,cl-element-type)
,@body))
((or list number)
`(with-c-data
(,symbol
(make-array* ,init-or-spec ',cl-element-type)
,cl-element-type)
,@body))
(t ; unknown at macro expansion time
(cl-utilities:once-only (init-or-spec)
`(with-c-data
(,symbol
(if (typep ,init-or-spec 'array)
,init-or-spec
(make-array* ,init-or-spec ',cl-element-type))
,cl-element-type)
,@body)))))
(defmethod letm-expansion (symbol (type (eql 'c-double-float)) args body)
(expand-direct-c symbol 'double-float (first args) body))
(arglist-only c-double-float
"A direct C vector or matrix of type double."
dimensions-or-init)
#|
;; Example
(letm ((a (c-double-float 3)) ((b cl-b) (c-double-float #(3 4 5 1 2))))
(format t "b: foreign pointer=~a~%" b)
(format t "a: foreign pointer=~a~%" a)
(values (aref cl-b 3) (dcref b 3)))
(LET ((#:ARRAY3416 (MAKE-ARRAY* 3 'DOUBLE-FLOAT)))
(FFA:WITH-POINTER-TO-ARRAY
(#:ARRAY3416 A (MAP-TO-FFA-TYPES 'DOUBLE-FLOAT)
(ARRAY-TOTAL-SIZE #:ARRAY3416) :COPY-IN-OUT)
(LET ((CL-B (ARRAY-COPY #(3 4 5 1 2) 'DOUBLE-FLOAT)))
(FFA:WITH-POINTER-TO-ARRAY
(CL-B B (MAP-TO-FFA-TYPES 'DOUBLE-FLOAT) (ARRAY-TOTAL-SIZE CL-B)
:COPY-IN-OUT)
(FORMAT T "b: foreign pointer=~a~%" B)
(FORMAT T "a: foreign pointer=~a~%" A) (VALUES (AREF CL-B 3) (DCREF B 3))))))
|#
;; Definition of GSL objects and ways to use them.
;; Liam Healy, Sun Dec 3 2006 - 10:21
;; Time-stamp: <2008-02-18 11:46:20EST gsl-objects.lisp>
;; Time-stamp: <2008-03-23 17:49:12EDT gsl-objects.lisp>
;; $Id$
(in-package :gsl)
;;; Each object has a defun named after it. This function is used
;;; only internally by #'letm, but it is exported so that
;;; arglist prompters such as slime's will show the arguments
;;; needed.
(defparameter *letm-expanded-object* nil)
(defvar *not-for-users* nil)
;;; There are numerous "GSL objects" which need to by manually
;;; memory-managed. The macro letm takes care of this.
;;; A method #'letm-expansion which eql specializes on the object name
;;; in the second argument is responsible for doing the expansion.
;;;
;;; Many GSL objects simply need to be allocated, optionally set, and
;;; then freed after the work has been done. To cover those cases,
;;; the macro #'defgo (and simpler macro #'defgo-s) is defined. The
;;; default #'letm-expansion assumes that the object has been defined
;;; with defgo or defgo-s. Their names are saved in
;;; *letm-expanded-object*.
;;;
;;; Each object has a defun named after it, with an arglist
;;; (and perhaps docstring) appropriate for when that form
;;; is a binding to a letm. This function shouldn't be called;
;;; it is defined and exported for the benefit of arglist
;;; displayers like slime.
(export 'letm)
(defmacro letm (bindings &body body)
"A macro to bind variables to GSL objects, possibly setting
initial values, and freeing them when done. The binding is as
in a let*; any bindings for non-GSL objects are done as in
a let*."
(let* (setters ; save setting forms
freers ; save freeing forms
assigns ; save global assignements
(*not-for-users* t))
;; Rewrite the bindings with allocators and push them on assigns
(dolist (b bindings)
(if (atom b)
(push b assigns)
(let ((defsymb (first b)) (defas (second b)))
(if (and (listp b) (listp defas)
(member (first defas) *letm-expanded-object*))
;; It is a GSL object
(destructuring-bind (allocator freer &optional setter assign)
(apply (first defas) (rest defas))
;; If there's a setting function, save the form
(when setter (push (funcall setter defsymb) setters))
;; Save the freeing form
(push `(,freer ,defsymb) freers)
;; Save the global assignments
(when assign (push (funcall assign) assigns))
;; Return the allocation form to be used in let
(push `(,defsymb ,allocator) assigns))
;; Not a GSL object, just define it with let
(push b assigns)))))
(if freers
;; There were GSL objects
`(let* (,@(reverse assigns))
;; put the body in an unwind-protect
(unwind-protect
(progn
,@(reverse setters) ; setting the objects
,@body)
,@freers)) ; freeing the objects
;; No GSL objects in the bindings, just make an ordinary let
`(let* (,@bindings) ,@body))))
(first (letm-expand bindings body)))
;;; It might be nice to have a letm* or something where one go is
;;; dependent on another's being initialized.
(defun letm-expand (bindings body)
(if (null bindings)
body
(let ((binding (first bindings)))
(if (and (listp binding) (listp (second binding)))
(destructuring-bind (symbol (object &rest arguments))
binding
`(,(letm-expansion
symbol
object
arguments
(letm-expand (rest bindings) body))))
;; binding value is an atom or not present
`((let (,binding)
,@(letm-expand (rest bindings) body)))))))
(defvar *not-for-users* nil)
(defparameter *letm-expanded-object* nil)
(defun not-for-users (form)
(unless *not-for-users*
(error "The form ~a should be placed in the binding of a letm."
form)))
(defmacro arglist-only (symbol docstring &rest arglist)
"Define objects to be used with letm bindings, but
make the function itself signal an error."
`(eval-when (:compile-toplevel :load-toplevel :execute)
(pushnew ',symbol *letm-expanded-object*)
(export ',symbol)
(defun ,symbol (,@arglist) ,docstring
(declare (ignorable ,@arglist))
(not-for-users (list ',symbol ,@arglist)))))
(defgeneric letm-expansion (symbol type args body)
;; The method that expands a defgo-created object.
(:method (symbol type args body)
(if (member type *letm-expanded-object*)
(let ((*not-for-users* t))
(destructuring-bind (allocator freer &optional setter assign)
(if type (apply type args) (list nil nil))
`(let* (,@(when assign (list (funcall assign)))
(,symbol ,allocator))
(unwind-protect
(progn
,@(when setter (list (funcall setter symbol)))
,@body)
(,freer ,symbol)))))
;; Not a GSL object; create a regular let form
`(let ((,symbol (,type ,@args)))
,@body))))
;;; General definition for object creation
(defmacro defgo (symbol arglist &body body)
"Define a GSL object to be bound in a letm.
......@@ -102,3 +117,50 @@
`((when settingp
(lambda (,symb)
`(,',set ,,symb ,,@(subseq (rest form) num-alloc-args))))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;OBSOLETE
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Old form
(defmacro letm-obsolete (bindings &body body)
"A macro to bind variables to GSL objects, possibly setting
initial values, and freeing them when done. The binding is as
in a let*; any bindings for non-GSL objects are done as in
a let*."
(let* (setters ; save setting forms
freers ; save freeing forms
assigns ; save global assignements
(*not-for-users* t))
;; Rewrite the bindings with allocators and push them on assigns
(dolist (b bindings)
(if (atom b)
(push b assigns)
(let ((defsymb (first b)) (defas (second b)))
(if (and (listp b) (listp defas)
(member (first defas) *letm-expanded-object*))
;; It is a GSL object
(destructuring-bind (allocator freer &optional setter assign)
(apply (first defas) (rest defas))
;; If there's a setting function, save the form
(when setter (push (funcall setter defsymb) setters))
;; Save the freeing form
(push `(,freer ,defsymb) freers)
;; Save the global assignments
(when assign (push (funcall assign) assigns))
;; Return the allocation form to be used in let
(push `(,defsymb ,allocator) assigns))
;; Not a GSL object, just define it with let
(push b assigns)))))
(if freers
;; There were GSL objects
`(let* (,@(reverse assigns))
;; put the body in an unwind-protect
(unwind-protect
(progn
,@(reverse setters) ; setting the objects
,@body)
,@freers)) ; freeing the objects
;; No GSL objects in the bindings, just make an ordinary let
`(let* (,@bindings) ,@body))))
;; Multivariate minimization.
;; Liam Healy <Tue Jan 8 2008 - 21:28>
;; Time-stamp: <2008-03-09 19:29:20EDT minimization-multi.lisp>
;; Time-stamp: <2008-03-23 17:50:49EDT minimization-multi.lisp>
;; $Id$
(in-package :gsl)
......@@ -345,10 +345,10 @@
parabaloid 2 parabaloid-derivative parabaloid-and-derivative)
(defun multimin-example-fletcher-reeves ()
(letm ((minimizer
(letm ((initial (vector-double-float #(5.0d0 7.0d0)))
(minimizer
(mfdfminimizer *conjugate-fletcher-reeves* 2 parabaloid
initial 0.01d0 1.0d-4))
(initial (vector-double-float #(5.0d0 7.0d0))))
initial 0.01d0 1.0d-4)))
(loop with status = T
for iter from 0 below 100
while status
......
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