callback.lisp 12.3 KB
Newer Older
1 2
;; Foreign callback functions.               
;; Liam Healy 
3
;; Time-stamp: <2009-01-22 22:36:00EST callback.lisp>
lhealy's avatar
lhealy committed
4
;; $Id$
5 6 7 8 9 10 11 12 13 14 15 16

(in-package :gsl)

;;; Callback functions are functions which are passed as data; to Lisp
;;; that means they are just functions, but C makes a distinction.
;;; They are needed by several GSL tasks.
;;; Functions that take one double-float and return one double-float
;;; and are defined using the gsl_function structure (see gsl_math.h)
;;; are called scalar functions.  They are used in 
;;; numerical-integration, numerical-differentiation, chebyshev and
;;; definitions to aid in creating and using them are provided here.
;;; The idea behind the definitions is that the boundary between the CL
17
;;; and C functions is a narrow as possible; #'defun-single is
18 19 20 21 22
;;; macro that allows one to define a function in Lisp and make
;;; use it in these GSL tasks.

;;; Other GSL tasks make use of callback functions with different
;;; characteristics.  Since they are specific to each of the tasks,
23 24 25 26 27 28 29 30 31 32 33
;;; they are defined with those tasks.  The macro #'defmcallback can
;;; specify that the CL function is to expect in arglist and return as
;;; multiple values scalar quantities that come from and will be bound
;;; to either marrays or C vectors.  This is done with a list of the
;;; type and size, e.g. (:double 3), and for setting :set, type size,
;;; e.g. (:set :double 3).  If the 'marray argument is nil, it will
;;; expand to read or set a C vector; if it is T, it will expand to
;;; read or set a marray.  This allows the user to define ordinary CL
;;; functions with scalars as input and output.  However, it may be
;;; desirable to read and set marrays, in which case :pointer is the
;;; right specification.
34 35

(export
36
 '(def-single-function undef-cbstruct defun-single
37
   with-c-double with-c-doubles))
38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67

;;;;****************************************************************************
;;;; Setting slots
;;;;****************************************************************************

(defun set-structure-slot (foreign-structure structure-name slot-name value)
  (setf (cffi:foreign-slot-value foreign-structure structure-name slot-name)
	value))

(defun set-slot-function (foreign-structure structure-name slot-name gsl-function)
  (set-structure-slot
   foreign-structure structure-name slot-name
   (cffi:get-callback gsl-function)))

(defun set-parameters (foreign-structure structure-name)
  "Set the parameters slot to null."
  (set-structure-slot foreign-structure structure-name
		      'parameters (cffi:null-pointer)))

;;;;****************************************************************************
;;;; The GSL struct for holding callbacks
;;;;****************************************************************************

(cffi:defcstruct gsl-function
  "Passing functions to GSL."
  ;; see /usr/include/gsl/gsl_math.h
  (function :pointer)
  (parameters :pointer))

;;;;****************************************************************************
68
;;;; Macros for defining a callback to wrap a CL function
69 70
;;;;****************************************************************************

71 72 73 74 75 76 77 78 79 80
;;; Callback functions are defined using demcallback by passing the
;;; name of the function and the argument list of types.  Arrays can
;;; be handled in one of two ways.  If they are declared :pointer, the
;;; CL function will be passed a C pointer, and it is responsible for
;;; reading or setting the array, with #'dcref or #'maref.  If they
;;; are declared (type size) then size scalars will be passed as
;;; arguments to the CL function, and if they are declared (:set type
;;; size), the CL function return size values, to which the array
;;; elements will be set.

81 82 83
;;; Usage example for scalar function (e.g. numerical-integration,
;;; numerical-differentiation, chebyshev, ntuple).  
;;; (defmcallback myfn :double :double)
84
;;; Usage example for vector function (e.g. roots-multi)
85 86 87 88
;;; (defmcallback myfn :pointer :int (:pointer))
;;; Usage example for function and derivative
;;; (defmcallback fdf :pointer :double (:pointer :pointer))
;;; (defmcallback fdf :success-failure :int (:pointer :pointer))
89 90 91 92 93 94 95 96
;;; Usage example for def-ode-functions
;;; (defmcallback vanderpol :success-failure (:double (:double 2) (:set :double 2)))
;;; or
;;; (defmcallback vanderpol :success-failure (:double :pointer :pointer))
;;; to read and set within the CL function with #'dcref.

;;; (callback-args '(:double (:double 2) (:set :double 2)))
;;; ((#:ARG1193 :DOUBLE) (#:ARG1194 :POINTER) (#:ARG1195 :POINTER))
97

98 99 100 101 102 103 104 105 106 107 108 109
(defun callback-args (types)
  "The arguments passed by GSL to the callback function."
  (mapcar (lambda (type)
	    (let ((symbol (gensym "ARG")))
	      (list symbol
		    (if (listp type)	; like (:double 3)
			:pointer	; C array
			type))))
	  (if (listp types) types (list types))))

;;; (embedded-clfunc-args '(:double (:double 2) (:set :double 2)) (callback-args '(:double (:double 2) (:set :double 2))))
;;; (#:ARG1244 (MEM-AREF #:ARG1245 ':DOUBLE 0) (MEM-AREF #:ARG1245 ':DOUBLE 1))
110 111

(defvar *setting-spec* '(:set))
112
(defun embedded-clfunc-args (types callback-args &optional marray)
113 114 115 116 117
  "The arguments passed to the CL function call embedded in the callback.
   If 'marray is T, then reference GSL arrays; otherwise reference raw
   C vectors.  A specification (:set ...) means that the CL function
   will define the array as multiple values; if the size is negative,
   then the opposite value will be used for marray."
118
  (loop for spec in types
119
     for (symbol nil) in callback-args
120
     append
121
     (unless (and (listp spec) (member (first spec) *setting-spec*))
122
       (if (listp spec)
123 124 125 126 127 128
	   (if (third spec)
	       ;; matrix, marrays only
	       (loop for i from 0 below (second spec)
		  append
		  (loop for j from 0 below (third spec)
		     collect
129
		     `(maref ,symbol ,i ,j ',(cffi-cl (first spec)))))
130
	       ;; vector, marray or C array
131 132
	       (loop for ind from 0 below (abs (second spec))
		  collect (if (if (minusp (second spec)) (not marray) marray)
133 134
			      `(maref ,symbol ,ind nil ',(cffi-cl (first spec)))
			      `(cffi:mem-aref ,symbol ',(first spec) ,ind))))
135 136
	   (list symbol)))))

137
(defun callback-set-mvb (form types callback-args &optional marray)
138 139 140 141
  "Create the multiple-value-bind form in the callback to set the return C arrays."
  (multiple-value-bind (settype setcba)
      (loop for cba in callback-args
	 for type in types
142
	 for setting = (and (listp type) (member (first type) *setting-spec*))
143 144 145 146 147
	 when setting
	 collect cba into setcba
	 when setting
	 collect type into settype
	 finally (return (values (mapcar 'rest settype) setcba)))
148
    (let* ((setvbls (embedded-clfunc-args settype setcba marray))
149 150 151 152
	   (count
	    (apply
	     '+
	     (mapcar (lambda (inds) (abs (apply '* (rest inds)))) settype)))
153 154 155 156 157 158 159 160 161
	   (mvbvbls (loop repeat count collect (gensym "SETCB"))))
      (if (zerop count)
	  form
	  `(multiple-value-bind ,mvbvbls
	       ,form
	     (setf ,@(loop for mvbvbl in mvbvbls
			for setvbl in setvbls
			append (list setvbl mvbvbl))))))))

162 163
(defmacro defmcallback
    (name &optional (return-type :double) (argument-types :double)
164
     additional-argument-types marray)
165 166 167 168 169
  "Define a callback function used by GSL; the GSL function will call
   it with an additional `parameters' argument that is ignored.  the
   argument-types is a single type or list of types of the argument(s)
   that appear before parameters, and the additional-argument-types
   (default none) is a single type or list of types of the argument(s)
170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189
   that appear after parameters.  The argument types are C types or
   a list of a C type and a length, indicating a C array of that type
   for which each element will be passed as a separate argument.
   The return-type is the type that should be returned to GSL.
   If :success-failure, a GSL_SUCCESS code (0) is always returned;
   if :pointer, a null pointer is returned."
  (let* ((atl (if (listp argument-types) argument-types (list argument-types)))
	 (aatl (if (listp additional-argument-types) additional-argument-types
		   (list additional-argument-types)))
	 (cbargs (callback-args atl))
	 (cbaddl (callback-args aatl)))
    `(cffi:defcallback ,name
	 ,(if (eq return-type :success-failure) :int return-type)
	 (,@cbargs (params :pointer) ,@cbaddl)
       ;; Parameters as C argument are always ignored, because we have
       ;; CL specials to do the same job.
       (declare (ignore params))
       ,(callback-set-mvb
	 `(,name
	   ,@(append
190 191
	      (embedded-clfunc-args atl cbargs marray)
	      (embedded-clfunc-args aatl cbaddl marray)))
192
	 (append atl aatl)
193 194
	 (append cbargs cbaddl)
	 marray)
195 196 197 198 199 200 201 202 203 204
       ,@(case
	  return-type
	  (:success-failure
	   ;; We always return success, because if there was a
	   ;; problem, a CL error would be signalled.
	   '(success))
	  (:pointer
	   ;; For unclear reasons, some GSL functions want callbacks
	   ;; to return a void pointer which is apparently meaningless.
	   '((cffi:null-pointer)))))))
205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230

(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
	 ;; Bind a CL special under this name to the C structure.
	 (if (listp functions) (first functions) functions))
	(fnlist
	 ;; Make a list of (function slot-name ...) for each function.
	 (if (listp functions) functions (list `,functions 'function))))
    `(progn
      ;; Create the C structure and bind CL variable to it.
      (defparameter ,name (cffi:foreign-alloc ',structure))
      ;; 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))))))
231

232 233 234 235 236 237 238 239
(defun undef-cbstruct (name)
  "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 (symbol-value name))
  (makunbound name))

(defmacro def-single-function
240 241 242
    (name
     &optional (return-type :double) (argument-type :double)
     (structure 'gsl-function)
243 244 245
     dimensions
     (dimensions-return dimensions)
     (marray t))
246 247 248 249
  "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."
250
  `(progn
251 252 253 254 255 256 257 258
     (defmcallback ,name ,return-type
       ,(if dimensions `((,argument-type ,dimensions)) argument-type)
       ,(if dimensions-return `((:set ,argument-type ,dimensions-return)))
       ,marray)
     ,@(when
	structure
	`((defcbstruct ,name ,structure
	    ,(if dimensions `((dimensions ,dimensions))))))))
259

260 261
;;; Combine a defun and def-single-function in one:
(defmacro defun-single (name arglist &body body)
262 263 264 265
  "Define a function of a scalar double-float argument returning
   a double-float in CL and C."
  `(progn
    (defun ,name ,arglist ,@body)
266
    (def-single-function ,name)))
267 268 269 270 271 272 273 274 275

;;;;****************************************************************************
;;;; Vector of doubles
;;;;****************************************************************************

;;; Unfortunately, because vectors must be copied between languages
;;; (even with vector-sap in callbacks, unless vector-sap can be
;;; setfed), there is no way to provide a function of a vector and
;;; have it work in both languages.  As a consolation the macro
276
;;; #'with-c-double is provided to make things easier.
277

278
(defmacro with-c-double
279 280 281 282 283
    ((c-vector &rest element-names) &body body)
  "Provide named access to each element of a C array of doubles, for either
   reading or setting."
  `(symbol-macrolet
    ,(loop for i from 0 for a in element-names
284
	   collect `(,a (dcref ,c-vector ,i)))
285
    ,@body))
286

287 288 289 290 291 292 293 294
(defmacro with-c-doubles
    ((&rest cvector-names) &body body)
  "Provide named access to each element of a C array of doubles, for either
   reading or setting."
  `(symbol-macrolet
    ,(loop for (c-vector . element-names) in cvector-names
	   append
	   (loop for i from 0 for a in element-names
295
		 collect `(,a (dcref ,c-vector ,i))))
296
    ,@body))