(defparameter *alien-callback-wrappers* (make-hash-table :test #'equal)
"Maps SPECIFIER to lisp wrappers.")
+;;; FIXME: This involves a call to both the compiler and assembler, so
+;;; should either be macroized to do more of the work at compile-time,
+;;; or perhaps named COMPILE-ALIEN, or somesuch.
+;;;
+;;; FIXME: It is also probably worth our while to optimize cases like
+;;; (alien-funcall spec 'symbol).
(defun alien-callback (specifier function &optional env)
- "Returns an SAP to an alien callback corresponding to the function and
-alien-ftype-specifier."
+ "Returns an alien-value with of alien type SPECIFIER, that can be passed to an
+alien function as a pointer to the FUNCTION."
(multiple-value-bind (result-type argument-types) (parse-alien-ftype specifier env)
(let ((key (cons specifier function)))
(or (gethash key *alien-callbacks*)
(setf (gethash key *alien-callbacks*)
(let* ((index (fill-pointer *alien-callback-trampolines*))
+ ;;; Aside from the INDEX this is known at
+ ;;; compile-time, which could be utilized by
+ ;;; having the two-stage assembler tramp &
+ ;;; wrapper mentioned in [1] above: only the
+ ;;; per-function tramp would need assembler at
+ ;;; runtime. Possibly we could even pregenerate
+ ;;; the code and just patch the index in later.
(assembler-wrapper (alien-callback-assembler-wrapper
index result-type argument-types))
+ ;;; For normal use-cases this at least could be
+ ;;; done at compile-time.
(lisp-wrapper (alien-callback-lisp-wrapper
specifier result-type argument-types env)))
(vector-push-extend
(%sap-alien (vector-sap assembler-wrapper)
(parse-alien-type specifier env))))))))
+(defun parse-callback-specification (result-type lambda-list)
+ (values
+ `(function ,result-type ,@(mapcar #'second lambda-list))
+ (mapcar #'first lambda-list)))
+
+;;; FIXME: This calls compiler every single time, which really sucks.
+;;;
+;;; The problem is that we need to return a pointer to the right closure,
+;;; even though the underlying function gets shared. What to do?
+;;;
+;;;
+(defmacro alien-lambda (result-type typed-lambda-list &body forms)
+ (multiple-value-bind (specifier lambda-list)
+ (parse-callback-specification result-type typed-lambda-list)
+ `(alien-callback ',specifier (lambda ,lambda-list ,@forms))))
+
+(defmacro define-alien-callback (name result-type typed-lambda-list &body forms)
+ "Defines #'NAME as a function with the given body and lambda-list, and NAME as
+the alien callback for that function with the given alien type."
+ (multiple-value-bind (specifier lambda-list)
+ (parse-callback-specification result-type typed-lambda-list)
+ `(progn
+ (defun ,name ,lambda-list ,@forms)
+ (defparameter ,name (alien-callback ',specifier #',name)))))
+
(defun alien-callback-lisp-wrapper (specifier result-type argument-types env)
(or (gethash specifier *alien-callback-wrappers*)
(setf (gethash specifier *alien-callback-wrappers*)
--- /dev/null
+;;;; package lock tests with side effects
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;;
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+(in-package :cl-user)
+
+(defun alien-callback (type fun)
+ (sb-alien-internals:alien-callback type fun))
+
+(defun thunk ()
+ (write-string "hi"))
+
+(defvar *thunk* (alien-callback '(function c-string) #'thunk))
+
+(assert (equal (with-output-to-string (*standard-output*)
+ (alien-funcall *thunk*))
+ "hi"))
+
+(defun add-two-ints (arg1 arg2)
+ (+ arg1 arg2))
+
+(defvar *add-two-ints* (alien-callback '(function int int int) 'add-two-ints))
+
+(assert (= (alien-funcall *add-two-ints* 555 444444) 444999))
+
+(define-alien-routine qsort void
+ (base (* t))
+ (nmemb int)
+ (size int)
+ (compar (function int (* double) (* double))))
+
+(sb-alien::define-alien-callback double*-cmp int ((arg1 (* double)) (arg2 (* double)))
+ (let ((a1 (deref arg1))
+ (a2 (deref arg2)))
+ (cond ((= a1 a2) 0)
+ ((< a1 a2) -1)
+ (t 1))))
+
+(let* ((vector (coerce '(0.1d0 0.5d0 0.2d0 1.2d0 1.5d0 2.5d0 0.0d0 0.1d0 0.2d0 0.3d0)
+ '(vector double-float)))
+ (sorted (sort (copy-seq vector) #'<)))
+ (gc :full t)
+ (sb-sys:with-pinned-objects (vector)
+ (qsort (sb-sys:vector-sap vector)
+ (length vector)
+ (alien-size double :bytes)
+ double*-cmp))
+ (assert (equalp vector sorted)))
+
+
+(sb-alien::define-alien-callback redefined-fun int ()
+ 0)
+
+(eval
+ '(sb-alien::define-alien-callback redefined-fun int ()
+ 42))
+
+(assert (= 42 (alien-funcall redefined-fun)))
+
+(sb-alien::define-alien-callback return-single float ((x float))
+ x)
+
+(sb-alien::define-alien-callback return-double double ((x double))
+ x)
+
+(defconstant spi (coerce pi 'single-float))
+
+(assert (= spi (alien-funcall return-single spi)))
+(assert (= pi (alien-funcall return-double pi)))
+
+(quit :unix-status 104)
projects / sbcl.git / commitdiff