I was trying to evaluate a recurring integral when I ran into what I
think a design flaw in the callbacks implementation. Consider the
following code:
(integration-qag (lambda (x)
(integration-qag (lambda(y)
(* (sin x) y))
0d0 1d0 :gauss41))
0d0 pi :gauss41)
The result of the integration should be 1, but I get 4.93. Digging
through the code, I figured out that callbacks are implemented in the
following way:
1. During the GSLL compilation, a callback is defined via the
CFFI:DEFCALLBACK macro.
2. The GSLL wrapper function assigns the function to be called to a
dynamic variable and calls the underlying GSL function.
3. The GSL function calls the CFFI callback.
4. The CFFI callback calls the value stored in the dynamic variable.
The relevant part of the GSLL wrapper function is generated by
BODY-EXPAND. Here is a simplified version of the code generated for
INTEGRATION-QAG:
(defun integration-qag (function ...)
(declare (special integration-qag-dynfn0))
(setf integration-qag-dynfn0 function)
(foreign-funcall "gsl_integration_qag" ...))
The problem here is that if the function passed as a parameter to the
GSLL function calls the same GSLL function again, as in the example
above, the dynamic variable value is overwritten during the second call,
and then the first GSL function ends up calling the second callback all
the time. Seemingly, this can be fixed by binding instead of assigning
the dynamic variable, i.e., by making BODY-EXPAND to generate code like
this:
(defun integration-qag (function ...)
(let ((integration-qag-dynfn0 function))
(declare (special integration-qag-dynfn0))
(foreign-funcall "gsl_integration_qag" ...)))
In this case the value of INTEGRATION-QAG-DYNFN0 is restored upon
leaving the LET form. However, having patched the code this way, I broke
callbacks introduced via the DEFMOBJECT macro. In this case the
assignment happens in the REINITIALIZE-INSTANCE method specialized on
this object, which is usually called in the construction phase. As an
example, consider NONLINEAR-LEAST-SQUARES-EXAMPLE. The assignment is
made during the call to MAKE-NONLINEAR-FDFFIT, however the callback is
executed during the call to ITERATE. I think that the binding should be
performed in ITERATE, as soon as it is needed. ITERATE receives an
instance of an object subclassed from CALLBACK-INCLUDED, hence it has
access both to the functions to be called (the FUNCALLABLES slot of
CALLBACK-INCLUDED) and the callback specification (the CBINFO slot). But
I don't know what would be the best way to implement it. One possibility
is to loop through function parameters in BODY-EXPAND and figure out
which are instances of CALLBACK-INCLUDED. That will work only for
methods, and only for the specialized parameters. Is it sufficient?
Other approaches I can think of would require changing the DEFMFUN
interface to specify which parameters should be used to construct the
bindings. What solution would you propose? I can make a patch for it if
you don't think that the changes are too drastic to trust not an
upstream developer.
You may find my partial patch in the attachement.
>From 99b09a87ed1a0f42a45496aa7f38f29624cf82e6 Mon Sep 17 00:00:00 2001
From: Eugene Zhemchugov <[email protected]>
Date: Fri, 9 Jan 2015 20:38:12 +0300
Subject: [PATCH] Fix recurring callbacks (partial)
Use binding instead of assignment for dynamic variables in the callbacks
implementation. This way recursive calls to functions utilizing
callbacks can be performed, however, the current implementation breaks
when a callback is stored in an object.
---
calculus/numerical-integration.lisp | 5 ++-
init/body-expand.lisp | 81 +++++++++++++++++++------------------
init/defmfun-single.lisp | 3 +-
tests/numerical-integration.lisp | 11 ++++-
4 files changed, 56 insertions(+), 44 deletions(-)
diff --git a/calculus/numerical-integration.lisp b/calculus/numerical-integration.lisp
index f4c79d9..167aff8 100644
--- a/calculus/numerical-integration.lisp
+++ b/calculus/numerical-integration.lisp
@@ -369,4 +369,7 @@
'integration-test-f454
(grid:copy-to (vector 0.0d0 1.0d0 (sqrt 2.0d0) 3.0d0))
0.0d0 1.0d-3 1000)
- (integration-QAWc 'integration-test-f459 -1.0d0 5.0d0 0.0d0 0.0d0 1.0d-3 1000))
+ (integration-QAWc 'integration-test-f459 -1.0d0 5.0d0 0.0d0 0.0d0 1.0d-3 1000)
+ (integration-QAG (lambda (x)
+ (integration-QAG (lambda (y) (* (sin x) y)) 0d0 1d0 :gauss41))
+ 0d0 pi :gauss41))
diff --git a/init/body-expand.lisp b/init/body-expand.lisp
index 34e1602..d2db213 100644
--- a/init/body-expand.lisp
+++ b/init/body-expand.lisp
@@ -71,50 +71,53 @@
(callback-remove-arg allocated-return cbinfo 'grid:st-symbol))
outputs
(unless (eq c-return :void)
- (list (grid:st-symbol creturn-st))))))
+ (list (grid:st-symbol creturn-st)))))
+ (specials (first callback-dynamic-variables)))
(wrap-letlike
allocated-return
(mapcar (lambda (d) (wfo-declare d cbinfo))
allocated-return)
'cffi:with-foreign-objects
- `(,@(append
- (callback-symbol-set
- callback-dynamic cbinfo (first callback-dynamic-variables))
- before
- (when callback-object (callback-set-dynamic callback-object arglist)))
- ,@(callback-set-slots
- cbinfo callback-dynamic-variables callback-dynamic)
- (let ((,(grid:st-symbol creturn-st)
- (cffi:foreign-funcall
- ,gsl-name
- ,@(append
- (mappend
- (lambda (arg)
- (list (cond
- ((member (grid:st-symbol arg)
- allocated-return)
- :pointer)
- (t (grid:st-type arg)))
- (grid:st-symbol arg)))
- (mapcar 'grid:st-pointer-generic-pointer
- c-arguments))
- (list (grid:st-type creturn-st))))))
- ,@(case c-return
- (:void `((declare (ignore ,(grid:st-symbol creturn-st)))))
- (:error-code ; fill in arguments
- `((check-gsl-status ,(grid:st-symbol creturn-st)
- ',(or (defgeneric-method-p name) name)))))
- ,@(when (eq (grid:st-type creturn-st) :pointer)
- `((check-null-pointer
- ,(grid:st-symbol creturn-st)
- ,@'('memory-allocation-failure "No memory allocated."))))
- ,@after
- ,(values-unless-singleton
- (defmfun-return
- c-return (grid:st-symbol creturn-st) clret
- allocated-return
- return return-supplied-p
- enumeration outputs))))))))
+ `((let ,specials
+ ,(when specials `(declare (special ,@specials)))
+ ,@(append
+ (callback-symbol-set
+ callback-dynamic cbinfo (first callback-dynamic-variables))
+ before
+ (when callback-object (callback-set-dynamic callback-object arglist)))
+ ,@(callback-set-slots
+ cbinfo callback-dynamic-variables callback-dynamic)
+ (let ((,(grid:st-symbol creturn-st)
+ (cffi:foreign-funcall
+ ,gsl-name
+ ,@(append
+ (mappend
+ (lambda (arg)
+ (list (cond
+ ((member (grid:st-symbol arg)
+ allocated-return)
+ :pointer)
+ (t (grid:st-type arg)))
+ (grid:st-symbol arg)))
+ (mapcar 'grid:st-pointer-generic-pointer
+ c-arguments))
+ (list (grid:st-type creturn-st))))))
+ ,@(case c-return
+ (:void `((declare (ignore ,(grid:st-symbol creturn-st)))))
+ (:error-code ; fill in arguments
+ `((check-gsl-status ,(grid:st-symbol creturn-st)
+ ',(or (defgeneric-method-p name) name)))))
+ ,@(when (eq (grid:st-type creturn-st) :pointer)
+ `((check-null-pointer
+ ,(grid:st-symbol creturn-st)
+ ,@'('memory-allocation-failure "No memory allocated."))))
+ ,@after
+ ,(values-unless-singleton
+ (defmfun-return
+ c-return (grid:st-symbol creturn-st) clret
+ allocated-return
+ return return-supplied-p
+ enumeration outputs)))))))))
(defun defmfun-return
(c-return cret-name clret allocated return return-supplied-p enumeration outputs)
diff --git a/init/defmfun-single.lisp b/init/defmfun-single.lisp
index 3e1db2c..4cb076d 100644
--- a/init/defmfun-single.lisp
+++ b/init/defmfun-single.lisp
@@ -102,8 +102,7 @@
(when auxstart
(apply
'append
- (mapcar 'rest (remove-if 'atom auxstart)))))))))))
- (first callback-dynamic-variables))
+ (mapcar 'rest (remove-if 'atom auxstart))))))))))))
,@(when documentation (list documentation))
,(funcall body-maker name arglist gsl-name c-arguments key-args))
`(,defn
diff --git a/tests/numerical-integration.lisp b/tests/numerical-integration.lisp
index 7f1e0a8..6f22224 100644
--- a/tests/numerical-integration.lisp
+++ b/tests/numerical-integration.lisp
@@ -232,5 +232,12 @@
(LIST -0.08994400695837003d0 1.18529017636488d-6)
(MULTIPLE-VALUE-LIST
(INTEGRATION-QAWC 'INTEGRATION-TEST-F459 -1.0d0 5.0d0
- 0.0d0 0.0d0 0.001d0 1000)))))
-
+ 0.0d0 0.0d0 0.001d0 1000))))
+ (LISP-UNIT:ASSERT-NUMERICAL-EQUAL (LIST 1.0d0 1.1102230246251565d-14)
+ (MULTIPLE-VALUE-LIST
+ (INTEGRATION-QAG
+ (LAMBDA (X)
+ (INTEGRATION-QAG
+ (LAMBDA (Y) (* (SIN X) Y)) 0.0d0 1.0d0
+ :GAUSS41))
+ 0.0d0 PI :GAUSS41))))
--
1.8.3.1
_______________________________________________
Gsll-devel mailing list
[email protected]
http://mailman.common-lisp.net/cgi-bin/mailman/listinfo/gsll-devel
