From 873ad896e1fdae26bef0cbf7011a012f68bbc072 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Wed, 15 Jun 2005 17:06:29 +0000 Subject: [PATCH] 0.9.1.43: more callback work * trivial implementations of DEFINE-ALIEN-CALLBACK and ALIEN-LAMBDA. D-A-C is essentially OK, A-L sucks in any number of ways. * tests --- src/code/target-alieneval.lisp | 44 +++++++++++++++++++++- tests/callback.impure.lisp | 80 ++++++++++++++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 3 files changed, 123 insertions(+), 3 deletions(-) create mode 100644 tests/callback.impure.lisp diff --git a/src/code/target-alieneval.lisp b/src/code/target-alieneval.lisp index 5e93461..a6c5afe 100644 --- a/src/code/target-alieneval.lisp +++ b/src/code/target-alieneval.lisp @@ -767,16 +767,31 @@ (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 @@ -786,6 +801,31 @@ alien-ftype-specifier." (%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*) diff --git a/tests/callback.impure.lisp b/tests/callback.impure.lisp new file mode 100644 index 0000000..360224b --- /dev/null +++ b/tests/callback.impure.lisp @@ -0,0 +1,80 @@ +;;;; 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) diff --git a/version.lisp-expr b/version.lisp-expr index edae304..7be7e18 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.9.1.42" +"0.9.1.43" -- 1.7.10.4