Commit bcf61476 authored by Liam Healy's avatar Liam Healy

Monte Carlo uses direct function callbacks

Direct function callbacks may now be used with GSL structs other than
'gsl-function, and will set the 'dimension slot as well by looking at
the arglist of the function sent.  This uses an #'arglist borrowed
from CLOCC:port.  Rewrite make-callbacks based on a hash table rather
than a generic function.  All the usualy tests pass.
SBCL 64:
TOTAL: 1259 assertions passed, 5 failed, 0 execution errors.
CCL 64:
TOTAL: 1260 assertions passed, 4 failed, 0 execution errors.
parent 3d57ef40
;; Monte Carlo Integration
;; Liam Healy Sat Feb 3 2007 - 17:42
;; Time-stamp: <2009-01-25 10:21:38EST monte-carlo.lisp>
;; Time-stamp: <2009-02-15 22:07:40EST monte-carlo.lisp>
;; $Id$
(in-package :gsl)
......@@ -30,13 +30,14 @@
(defmfun monte-carlo-integrate-plain
(function lower-limits upper-limits calls generator state)
"gsl_monte_plain_integrate"
((function :pointer)
((callback :pointer)
((c-pointer lower-limits) :pointer) ((c-pointer upper-limits) :pointer)
((dim0 lower-limits) sizet) (calls sizet)
((mpointer generator) :pointer)
((mpointer state) :pointer)
(result :double) (abserr :double))
:inputs (lower-limits upper-limits)
:callback-struct monte-function
:documentation ; FDL
"Uses the plain Monte Carlo algorithm to integrate the
function f over the hypercubic region defined by the
......@@ -105,13 +106,14 @@
(defmfun monte-carlo-integrate-miser
(function lower-limits upper-limits calls generator state)
"gsl_monte_miser_integrate"
((function :pointer)
((callback :pointer)
((c-pointer lower-limits) :pointer) ((c-pointer upper-limits) :pointer)
((dim0 lower-limits) sizet) (calls sizet)
((mpointer generator) :pointer)
((mpointer state) :pointer)
(result :double) (abserr :double))
:inputs (lower-limits upper-limits)
:callback-struct monte-function
:documentation ; FDL
"Uses the miser Monte Carlo algorithm to integrate the
function f over the hypercubic region defined by the
......@@ -190,13 +192,14 @@
(defmfun monte-carlo-integrate-vegas
(function lower-limits upper-limits calls generator state)
"gsl_monte_vegas_integrate"
((function :pointer)
((callback :pointer)
((c-pointer lower-limits) :pointer) ((c-pointer upper-limits) :pointer)
((dim0 lower-limits) sizet) (calls sizet)
((mpointer generator) :pointer)
((mpointer state) :pointer)
(result :double) (abserr :double))
:inputs (lower-limits upper-limits)
:callback-struct monte-function
:documentation ; FDL
"Uses the vegas Monte Carlo algorithm to integrate the
function f over the dim-dimensional hypercubic region
......@@ -220,48 +223,46 @@
(dimensions sizet)
(parameters :pointer))
(export 'make-monte-carlo-function)
(defmacro make-monte-carlo-function (name-or-lambda &optional (dimensions 1))
"Define the function for use in the Monte Carlo functions. The function
should be specified with either the name of a CL function already defined,
or as a lambda form. In the latter case, the number of dimensions need
not be specified, they will be computed."
`(make-single-function ,name-or-lambda :double :double monte-function
,dimensions nil nil))
(def-make-callbacks monte-carlo (function dimension)
`(defmcallback ,function
:double ((:double ,dimension))
nil
nil
,function))
;;;;****************************************************************************
;;;; Examples and unit test
;;;;****************************************************************************
;;; Example from Sec. 23.5
;;; This is a function that occurs in random walk studies.
(defparameter *monte-carlo-cb*
(make-monte-carlo-function
(lambda (x y z)
(* (/ (expt pi 3))
(/ (- 1 (* (cos x) (cos y) (cos z))))))))
(defun mcrw (x y z)
"Example function for Monte Carlo used in random walk studies."
(* (/ (expt pi 3))
(/ (- 1 (* (cos x) (cos y) (cos z))))))
(make-callbacks monte-carlo mcrw 3)
(defun random-walk-plain-example (&optional (nsamples 500000))
(let ((ws (make-monte-carlo-plain 3))
(lower #m(0.0d0 0.0d0 0.0d0))
(upper (make-marray 'double-float :initial-contents (list pi pi pi)))
(rng (make-random-number-generator *mt19937* 0)))
(monte-carlo-integrate-plain *monte-carlo-cb* lower upper nsamples rng ws)))
(monte-carlo-integrate-plain 'mcrw lower upper nsamples rng ws)))
(defun random-walk-miser-example (&optional (nsamples 500000))
(let ((ws (make-monte-carlo-miser 3))
(lower #m(0.0d0 0.0d0 0.0d0))
(upper (make-marray 'double-float :initial-contents (list pi pi pi)))
(rng (make-random-number-generator *mt19937* 0)))
(monte-carlo-integrate-miser *monte-carlo-cb* lower upper nsamples rng ws)))
(monte-carlo-integrate-miser 'mcrw lower upper nsamples rng ws)))
(defun random-walk-vegas-example (&optional (nsamples 500000))
(let ((ws (make-monte-carlo-vegas 3))
(lower #m(0.0d0 0.0d0 0.0d0))
(upper (make-marray 'double-float :initial-contents (list pi pi pi)))
(rng (make-random-number-generator *mt19937* 0)))
(monte-carlo-integrate-vegas *monte-carlo-cb* lower upper nsamples rng ws)))
(monte-carlo-integrate-vegas 'mcrw lower upper nsamples rng ws)))
(save-test monte-carlo
(random-walk-plain-example)
......
......@@ -299,29 +299,23 @@ area of memory.</p>
<h3>Passing functions</h3>
<p>
Functions that are passed to GSL functions (known as <i>callbacks</i>
in C) are defined with one of the following macros in GSLL, depending
on the application:
<ul>
<li><code>make-single-function</code>, used by numerical
integration, numerical differentiation, Chebyshev, one-dimensional
root solver without derivatives, one-dimensional minimizer;</li>
<li><code>make-monte-carlo-function</code>, used by Monte Carlo;</li>
<li><code>make-solver-functions</code>, used by the root
solvers;</li>
<li><code>make-fitting-functions</code>, used by nonlinear least squares;</li>
<li><code>make-minimization-functions</code>, used by
the multi-dimensional minimizer;</li>
<li><code>make-ode-functions</code>, used by ordinary differential
equation solvers;</li>
</ul>
in C) are defined by writing an ordinary CL function or functions and
then calling <code>make-callbacks</code> with arguments that
depend on the application. Functions or objects that require a
callback will accept the symbol representing the first or only function
defined in the <code>make-callbacks</code>. For example, after
defining an ordinary CL function <code>mcrw</code>,
<pre>
(make-callbacks monte-carlo mcrw 3)
(monte-carlo-integrate-plain 'mcrw lower upper nsamples rng ws)
</pre>
<p>
The function may be specified as the name of a CL function, or as a
lambda form. If the latter, the dimensions need not be specified in
<code>make-single-function</code>, <code>make-monte-carlo-function</code>,
or <code>make-solver-functions</code> for derivative-free solvers;
they will be computed from the arglist. Each of these macros will
return a foreign pointer that can be passed to the appropriate GSL
function that requires a function.
In some cases, the CL function can be written to accept and return
either scalars or arrays. See examples for numerical
integration, numerical differentiation, Chebyshev, root solvers,
minimizers, Monte Carlo, nonlinear least squares, and ordinary
differential equation solvers.
</p>
<h3>GSL objects</h3>
<p>
......@@ -388,7 +382,7 @@ and arrays used internally or for function return.
<!-- Created: Feb 25 2005 -->
<!-- hhmts start -->
<small>
Time-stamp: <2009-01-25 21:38:05EST index.html>
Time-stamp: <2009-02-15 22:17:52EST index.html>
</small>
<!-- hhmts end -->
</div>
......
;; Foreign callback functions.
;; Liam Healy
;; Time-stamp: <2009-02-15 18:42:55EST callback.lisp>
;; Time-stamp: <2009-02-15 22:39:08EST callback.lisp>
;; $Id$
(in-package :gsl)
......@@ -31,8 +31,6 @@
;;; desirable to read and set marrays, in which case :pointer is the
;;; right specification.
(export '(make-single-function undef-cbstruct))
;;;;****************************************************************************
;;;; Setting slots
;;;;****************************************************************************
......@@ -200,31 +198,6 @@
;; to return a void pointer which is apparently meaningless.
'((cffi:null-pointer)))))))
;;; To be deprecated
(defmacro defcbstruct
(functions &optional (structure 'gsl-function) additional-slots)
"Define a callback-related C struct used by GSL.
This struct is bound to a CL special with the specified name.
This macro can be used whenever a callback is defined and
placed in a struct that has no other functions defined."
(let ((name (make-symbol "CBSTRUCT"))
(fnlist
;; Make a list of (function slot-name ...) for each function.
(if (listp functions) functions (list `,functions 'function))))
`(let ((,name (cffi:foreign-alloc ',structure)))
;; Create the C structure and bind CL variable to it.
;; Set all the function slots.
,@(loop for (fn slot-name) on fnlist by #'cddr collect
`(set-slot-function ,name ',structure ',slot-name ',fn))
;; Set the parameters.
(set-parameters ,name ',structure)
;; Set any additional slots.
,@(loop for slot in additional-slots
collect
`(set-structure-slot
,name ',structure ',(first slot) ,(second slot)))
,name)))
(defun set-cbstruct (cbstruct struct slots-values function-slotnames)
"Make the slots in the foreign callback structure."
(loop for (slot-name function) on function-slotnames by #'cddr
......@@ -249,12 +222,6 @@
(mapcan 'list (dimension-names object) (dimensions object)))
(mapcan 'list (callback-labels object) (functions object))))
(defun undef-cbstruct (object)
"Free foreign callback function. It is not necessary to do this; think
of the memory taken by an unused foreign function as much
less than that used by an unused defun."
(cffi:foreign-free object))
(defmacro with-computed-dimensions
(dimensions-spec dimensions-used lambda-form &body body)
(cl-utilities:once-only (lambda-form)
......@@ -271,31 +238,6 @@
(length (second lambda-form))
dimensions))
;;; To be obsolete
(defmacro make-single-function
(name
&optional (return-type :double) (argument-type :double)
(structure 'gsl-function)
dimensions
(dimensions-return dimensions)
(marray t))
"Define a callback and optionally a related C struct used by GSL.
This struct is bound to a CL special with the specified name.
This macro can be used whenever a callback is defined and
placed in a struct that has no other functions defined."
;; I don't think structure=nil is ever used, but it is permissible
(with-unique-names (cbsymb)
(let ((dim (dimensions-from-lambda name dimensions)))
`(progn
(defmcallback ,cbsymb ,return-type
,(if dim `((,argument-type ,dim)) argument-type)
,(if dimensions-return `((:set ,argument-type ,dimensions-return)))
,marray ,name)
,@(when
structure
`((defcbstruct ,cbsymb ,structure
,(if dim `((dimensions ,dim))))))))))
;;;;****************************************************************************
;;;; Classes that include callback information
;;;;****************************************************************************
......@@ -355,14 +297,13 @@
(defgeneric make-callbacks-fn (class args)
(:documentation "Function to make forms that expand into defmcallback(s)."))
(eval-when (:compile-toplevel :load-toplevel)
(defvar *callback-table* (make-hash-table :size 20)))
(defmacro def-make-callbacks (class arglist &body body)
(with-unique-names (cls args)
`(eval-when (:compile-toplevel :load-toplevel)
(defmethod make-callbacks-fn
((,cls (eql ',class)) ,args)
(declare (ignore ,cls))
(destructuring-bind ,arglist ,args
,@body)))))
`(eval-when (:compile-toplevel :load-toplevel)
(setf (gethash ',class *callback-table*)
(lambda ,arglist ,@body))))
(def-make-callbacks single-function (function)
`(defmcallback ,function
......@@ -379,7 +320,7 @@
return answer as multiple values with #'values. If it is NIL, it will
be called with two arguments; it should read the values from the first
array and write the answer in the second array."
(make-callbacks-fn class args))
(apply (gethash class *callback-table*) args))
(defmethod print-object ((object callback-included) stream)
(print-unreadable-object (object stream :type t :identity t)
......@@ -403,12 +344,51 @@
(defun callback-remove-arg (list &optional key)
(remove +callback-argument-name+ list :key key))
;;; From CLOCC:port, with addition of openmcl
(defun arglist (fn)
"Return the signature of the function."
#+allegro (excl:arglist fn)
#+clisp (sys::arglist fn)
#+(or cmu scl)
(let ((f (coerce fn 'function)))
(typecase f
(STANDARD-GENERIC-FUNCTION (pcl:generic-function-lambda-list f))
(EVAL:INTERPRETED-FUNCTION (eval:interpreted-function-arglist f))
(FUNCTION (values (read-from-string (kernel:%function-arglist f))))))
#+cormanlisp (ccl:function-lambda-list
(typecase fn (symbol (fdefinition fn)) (t fn)))
#+gcl (let ((fn (etypecase fn
(symbol fn)
(function (si:compiled-function-name fn)))))
(get fn 'si:debug))
#+lispworks (lw:function-lambda-list fn)
#+lucid (lcl:arglist fn)
#+sbcl (progn (require :sb-introspect)
(let ((fun (find-symbol (symbol-name 'function-arglist) 'sb-introspect)))
(when fun
(funcall fun fn))))
#+openmcl (ccl:arglist fn)
#-(or allegro clisp cmu cormanlisp gcl lispworks lucid sbcl scl openmcl)
(error "No arglist function known."))
(defmacro callback-set-slots
(trigger-list struct-name function &optional dimension)
(trigger-list struct-name function)
"If the callback argument is on trigger-list, then return a form
that sets the slots in the GSL callback structure."
`(when (callback-arg-p ,trigger-list)
`(set-cbstruct ,',+callback-argument-name+ ',',struct-name
,',(when dimension `('dimension ,dimension))
(list 'function ,',function))))
(let ((setdim (not (eq function 'gsl-function))))
`(when (callback-arg-p ,trigger-list)
`(set-cbstruct ,',+callback-argument-name+ ',,struct-name
,',(when setdim
'(list 'dimensions (length (arglist function))))
(list 'function ,',function)))))
(defmacro callback-set-slots
(trigger-list struct-name function)
"If the callback argument is on trigger-list, then return a form
that sets the slots in the GSL callback structure."
`(let ((setdim (not (eq ,struct-name 'gsl-function))))
(when (callback-arg-p ,trigger-list)
`(set-cbstruct ,',+callback-argument-name+ ',,struct-name
,,'(when setdim
'(list 'dimensions (length (arglist function))))
(list 'function ,',function)))))
;; Helpers that define a single GSL function interface
;; Liam Healy 2009-01-07 22:02:20EST defmfun-single.lisp
;; Time-stamp: <2009-02-15 17:41:07EST defmfun-single.lisp>
;; Time-stamp: <2009-02-15 18:56:52EST defmfun-single.lisp>
;; $Id: $
(in-package :gsl)
......@@ -179,7 +179,7 @@
(mapcar #'wfo-declare allocated-decl)
'cffi:with-foreign-objects
`(,@before
,(callback-set-slots allocated gsl-function function)
,(callback-set-slots allocated callback-struct function)
(let ((,cret-name
(cffi:foreign-funcall
,gsl-name
......
;; Macro for defining GSL functions.
;; Liam Healy 2008-04-16 20:49:50EDT defmfun.lisp
;; Time-stamp: <2009-01-12 21:50:07EST defmfun.lisp>
;; Time-stamp: <2009-02-15 18:51:03EST defmfun.lisp>
;; $Id$
(in-package :gsl)
......@@ -74,12 +74,12 @@
(definition :function)
(export (not (member definition (list :method :methods))))
documentation inputs outputs before after enumeration qualifier
gsl-version switch)
gsl-version switch (callback-struct 'gsl-function))
,key-args
(declare (ignorable c-return return definition element-types
index export documentation inputs outputs
before after enumeration qualifier
gsl-version switch)
gsl-version switch callback-struct)
(special indexed-functions))
,@body))
......
;; Definition of GSL objects and ways to use them.
;; Liam Healy, Sun Dec 3 2006 - 10:21
;; Time-stamp: <2009-02-15 17:06:23EST mobject.lisp>
;; Time-stamp: <2009-02-15 21:53:46EST mobject.lisp>
;;; GSL objects are represented in GSLL as and instance of a 'mobject.
;;; The macro demobject takes care of defining the appropriate
......@@ -174,7 +174,7 @@
,@(when (callback-arg-p class-slots-instance)
(with-unique-names (cbs)
`((let ((,cbs (make-cbstruct-object object)))
(setf (slot-value object '#.+callback-argument-name+) ,cbs)
(setf (slot-value object ',+callback-argument-name+) ,cbs)
(tg:finalize object (lambda () (foreign-free ,cbs)))))))
;; There is an initialization step
,@(when initializerp
......
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