Skip to content
Snippets Groups Projects
Commit 8d2ef1de authored by Liam Healy's avatar Liam Healy
Browse files

Define fsbv:defcfun for efficiency

For FSBV calls, define fsbv:defcfun in the defmfun expansion, then in
the fsbv:foreign-funcall, refer to the symbol function name rather
than string function name.  This tells FSBV to use the prepared
closure associated with that function by the fsbv:defcfun, meaning
that the definitions in that lexical environment are reused.

Fix conditionalization for #'conjugate-rank-1-update in blas2.lisp.

Test results:
SBCL 64 #+fsbv
TOTAL: 1522 assertions passed, 5 failed, 0 execution errors.
CCL 64 #+fsbv
TOTAL: 1522 assertions passed, 5 failed, 0 execution errors.
SBCL 64 #-fsbv
TOTAL: 1502 assertions passed, 5 failed, 0 execution errors.
CCL 64 #-fsbv
TOTAL: 1502 assertions passed, 5 failed, 0 execution errors.
parent 8a08f552
No related branches found
No related tags found
No related merge requests found
;; Expand the body of a defmfun ;; Expand the body of a defmfun
;; Liam Healy 2009-04-13 22:07:13EDT body-expand.lisp ;; Liam Healy 2009-04-13 22:07:13EDT body-expand.lisp
;; Time-stamp: <2009-05-03 10:03:03EDT body-expand.lisp> ;; Time-stamp: <2009-05-03 16:31:28EDT body-expand.lisp>
;; $Id: $ ;; $Id: $
(in-package :gsl) (in-package :gsl)
...@@ -53,6 +53,35 @@ ...@@ -53,6 +53,35 @@
"System FSBV is not present, so function ~a cannot be used." "System FSBV is not present, so function ~a cannot be used."
,function-name)) ,function-name))
#+fsbv
(defun make-defcfun-for-fsbv (gsl-name ff-args)
"Make a fsbv:defcfun form so that function will be prepped."
(multiple-value-bind (args return-type)
(fsbv:defcfun-args-from-ff-args ff-args)
(let ((gsl-name-symbol (make-symbol gsl-name))
(symbargs
(mapcar (lambda (st) (make-st (gensym "ARG") (st-type st)))
args)))
(values
`(fsbv:defcfun (,gsl-name-symbol gsl-name) ,return-type
"Function definition generated for FSBV prepping; will actually
be called by fsbv:foreign-funcall"
,@symbargs)
gsl-name-symbol))))
(defun ffexpand (pass-by-value-p gsl-name args)
"Expand the foreign funcall."
(if pass-by-value-p
#+fsbv
(multiple-value-bind (form symbol)
(make-defcfun-for-fsbv gsl-name args)
(declare (special fsbv-functions))
(push form fsbv-functions)
`(fsbv:foreign-funcall ,symbol ,@args))
#-fsbv
`(no-fsbv-error no-fsbv-error ,@args)
`(cffi:foreign-funcall ,gsl-name ,@args)))
(defun body-expand (name arglist gsl-name c-arguments key-args) (defun body-expand (name arglist gsl-name c-arguments key-args)
"Expand the body (computational part) of the defmfun." "Expand the body (computational part) of the defmfun."
(with-defmfun-key-args key-args (with-defmfun-key-args key-args
...@@ -96,19 +125,17 @@ ...@@ -96,19 +125,17 @@
,@(callback-set-slots ,@(callback-set-slots
cbinfo callback-dynamic-variables callback-dynamic) cbinfo callback-dynamic-variables callback-dynamic)
(let ((,(st-symbol creturn-st) (let ((,(st-symbol creturn-st)
(,(if (some 'identity pbv) ,(ffexpand (some 'identity pbv)
#+fsbv 'fsbv:foreign-funcall gsl-name
#-fsbv 'no-fsbv-error (append
'cffi:foreign-funcall) (mappend
,gsl-name (lambda (arg)
,@(mappend (list (cond
(lambda (arg) ((member (st-symbol arg) allocated-return) :pointer)
(list (cond (t (st-type arg)))
((member (st-symbol arg) allocated-return) :pointer) (st-symbol arg)))
(t (st-type arg))) (mapcar 'st-pointer-generic-pointer c-arguments))
(st-symbol arg))) (list(st-type creturn-st))))))
(mapcar 'st-pointer-generic-pointer c-arguments))
,(st-type creturn-st))))
,@(case c-return ,@(case c-return
(:void `((declare (ignore ,(st-symbol creturn-st))))) (:void `((declare (ignore ,(st-symbol creturn-st)))))
(:error-code ; fill in arguments (:error-code ; fill in arguments
......
;; Macro for defining GSL functions. ;; Macro for defining GSL functions.
;; Liam Healy 2008-04-16 20:49:50EDT defmfun.lisp ;; Liam Healy 2008-04-16 20:49:50EDT defmfun.lisp
;; Time-stamp: <2009-04-04 22:00:20EDT defmfun.lisp> ;; Time-stamp: <2009-05-03 15:38:45EDT defmfun.lisp>
;; $Id$ ;; $Id$
(in-package :gsl) (in-package :gsl)
...@@ -84,7 +84,7 @@ ...@@ -84,7 +84,7 @@
index export documentation inputs outputs index export documentation inputs outputs
before after enumeration qualifier before after enumeration qualifier
gsl-version switch cbinfo callback-dynamic callback-object) gsl-version switch cbinfo callback-dynamic callback-object)
(special indexed-functions callback-dynamic-variables)) (special indexed-functions callback-dynamic-variables #+fsbv fsbv-functions))
,@body)) ,@body))
(defun optional-args-to-switch-gsl-functions (arglist gsl-name) (defun optional-args-to-switch-gsl-functions (arglist gsl-name)
...@@ -97,9 +97,9 @@ ...@@ -97,9 +97,9 @@
(listp (first gsl-name))))) (listp (first gsl-name)))))
(defun expand-defmfun-wrap (name arglist gsl-name c-arguments key-args) (defun expand-defmfun-wrap (name arglist gsl-name c-arguments key-args)
(let (indexed-functions callback-dynamic-variables) (let (indexed-functions callback-dynamic-variables #+fsbv fsbv-functions)
;; workaround for compiler errors that don't see 'indexed-function is used ;; workaround for compiler errors that don't see 'indexed-function is used
(declare (ignorable indexed-functions callback-dynamic-variables)) (declare (ignorable indexed-functions callback-dynamic-variables #+fsbv fsbv-functions))
(with-defmfun-key-args key-args (with-defmfun-key-args key-args
(setf indexed-functions (list) (setf indexed-functions (list)
callback-dynamic-variables callback-dynamic-variables
...@@ -119,7 +119,8 @@ ...@@ -119,7 +119,8 @@
(make-symbol-cardinals (make-symbol-cardinals
(list name 'dynfn) num-callbacks :gsl) (list name 'dynfn) num-callbacks :gsl)
(make-symbol-cardinals (make-symbol-cardinals
(list name 'cbfn) num-callbacks :gsl)))))) (list name 'cbfn) num-callbacks :gsl)))))
#+fsbv fsbv-functions #+fsbv (list))
(wrap-index-export (wrap-index-export
(cond (cond
((eq definition :generic) ((eq definition :generic)
...@@ -156,6 +157,8 @@ ...@@ -156,6 +157,8 @@
cbinfo cbinfo
(second callback-dynamic-variables) (second callback-dynamic-variables)
(first callback-dynamic-variables)) (first callback-dynamic-variables))
#+fsbv
,@fsbv-functions
,@index-export)))) ,@index-export))))
;;;;**************************************************************************** ;;;;****************************************************************************
......
;; BLAS level 2, Matrix-vector operations ;; BLAS level 2, Matrix-vector operations
;; Liam Healy, Wed Apr 26 2006 - 21:08 ;; Liam Healy, Wed Apr 26 2006 - 21:08
;; Time-stamp: <2009-05-03 11:31:55EDT blas2.lisp> ;; Time-stamp: <2009-05-03 12:38:28EDT blas2.lisp>
;; $Id$ ;; $Id$
(in-package :gsl) (in-package :gsl)
...@@ -201,12 +201,13 @@ ...@@ -201,12 +201,13 @@
:documentation ; FDL :documentation ; FDL
"The rank-1 update A = alpha x y^T + A of the matrix A.") "The rank-1 update A = alpha x y^T + A of the matrix A.")
#+fsbv
(defmfun conjugate-rank-1-update (alpha (x vector) (y vector) (A matrix)) (defmfun conjugate-rank-1-update (alpha (x vector) (y vector) (A matrix))
("gsl_blas_" :type "gerc") ("gsl_blas_" :type "gerc")
((alpha :element-c-type) ((mpointer A) :pointer) ((alpha :element-c-type) ((mpointer A) :pointer)
((mpointer x) :pointer) ((mpointer y) :pointer)) ((mpointer x) :pointer) ((mpointer y) :pointer))
:definition :generic :definition :generic
:element-types #+fsbv :float-complex #-fsbv :float :element-types :complex
:inputs (x y A) :inputs (x y A)
:outputs (A) :outputs (A)
:documentation ; FDL :documentation ; FDL
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment