X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-alieneval.lisp;h=bc990abacf3dc22d2fd3211cac9680e31325d536;hb=b14a61c6af3e3005c94e633e727177346240066e;hp=aa7922fb9039dfc7ebf8cc1fb2febcbd0b9add23;hpb=1e9b2eeb4d8d07e6282dc6a747661134ccda8f4c;p=sbcl.git diff --git a/src/code/target-alieneval.lisp b/src/code/target-alieneval.lisp index aa7922f..bc990ab 100644 --- a/src/code/target-alieneval.lisp +++ b/src/code/target-alieneval.lisp @@ -35,22 +35,32 @@ ;;; guess the other. (eval-when (:compile-toplevel :load-toplevel :execute) (defun pick-lisp-and-alien-names (name) - (etypecase name - (string - (values (guess-lisp-name-from-alien-name name) name)) - (symbol - (values name (guess-alien-name-from-lisp-name name))) - (list - (unless (proper-list-of-length-p name 2) - (error "badly formed alien name")) - (values (cadr name) (car name)))))) + (flet ((oops () + (error "~@<~:IMalformed alien name. Acceptable formats are:~ + ~:@_ (\"alien_name\" LISP-NAME)~ + ~:@_ FOO-BAR - equivalent to (\"foo_bar\" FOO-BAR)~ + ~:@_ \"foo_bar\" - equivalent to (\"foo_bar\" FOO-BAR)~:@>"))) + (etypecase name + (string + (values (guess-lisp-name-from-alien-name name) + (coerce name 'simple-string))) + (symbol + (values name (guess-alien-name-from-lisp-name name))) + (list + (unless (and (proper-list-of-length-p name 2) + (symbolp (second name)) + (stringp (first name))) + (oops)) + (values (second name) (coerce (first name) 'simple-string))) + (t + (oops)))))) (defmacro define-alien-variable (name type &environment env) #!+sb-doc - "Define NAME as an external alien variable of type TYPE. NAME should be - a list of a string holding the alien name and a symbol to use as the Lisp - name. If NAME is just a symbol or string, then the other name is guessed - from the one supplied." + "Define NAME as an external alien variable of type TYPE. NAME should +be a list of a string holding the alien name and a symbol to use as +the Lisp name. If NAME is just a symbol or string, then the other name +is guessed from the one supplied." (multiple-value-bind (lisp-name alien-name) (pick-lisp-and-alien-names name) (with-auxiliary-alien-types env (let ((alien-type (parse-alien-type type env))) @@ -68,20 +78,27 @@ (setf (info :variable :where-from lisp-name) :defined) (setf (info :variable :alien-info lisp-name) (make-heap-alien-info :type type - :sap-form `(foreign-symbol-sap ',alien-name t))))) + :alien-name alien-name + :datap t)))) + +(defun alien-value (symbol) + #!+sb-doc + "Returns the value of the alien variable bound to SYMBOL. Signals an +error if SYMBOL is not bound to an alien variable, or if the alien +variable is undefined." + (%heap-alien (or (info :variable :alien-info symbol) + (error 'unbound-variable :name symbol)))) (defmacro extern-alien (name type &environment env) #!+sb-doc - "Access the alien variable named NAME, assuming it is of type TYPE. This - is SETFable." + "Access the alien variable named NAME, assuming it is of type TYPE. +This is SETFable." (let* ((alien-name (etypecase name (symbol (guess-alien-name-from-lisp-name name)) (string name))) (alien-type (parse-alien-type type env)) (datap (not (alien-fun-type-p alien-type)))) - `(%heap-alien ',(make-heap-alien-info - :type alien-type - :sap-form `(foreign-symbol-sap ',alien-name ,datap))))) + `(%alien-value (foreign-symbol-sap ,alien-name ,datap) 0 ',alien-type))) (defmacro with-alien (bindings &body body &environment env) #!+sb-doc @@ -136,13 +153,11 @@ ,@body))))) (:extern (/show0 ":EXTERN case") - (let ((info (make-heap-alien-info - :type alien-type - :sap-form `(foreign-symbol-sap ',initial-value - ,datap)))) - `((symbol-macrolet - ((,symbol (%heap-alien ',info))) - ,@body)))) + `((symbol-macrolet + ((,symbol + (%alien-value + (foreign-symbol-sap ,initial-value ,datap) 0 ,alien-type))) + ,@body))) (:local (/show0 ":LOCAL case") (let* ((var (sb!xc:gensym "VAR")) @@ -242,7 +257,7 @@ interpreted depends on TYPE: * When TYPE is a foreign array type, an array of that type is allocated, and a pointer to it is returned. Note that you - must use DEREF to first access the arrey through the pointer. + must use DEREF to first access the array through the pointer. If supplied, SIZE is used as the first dimension for the array. @@ -391,9 +406,9 @@ null byte. (slot (deref alien) slot)) (alien-record-type (let ((field (slot-or-lose type slot))) - (extract-alien-value (alien-value-sap alien) - (alien-record-field-offset field) - (alien-record-field-type field))))))) + (%alien-value (alien-value-sap alien) + (alien-record-field-offset field) + (alien-record-field-type field))))))) ;;; Deposit the value in the specified slot of the record ALIEN. If ;;; the ALIEN is really a pointer, DEREF it first. The compiler uses @@ -408,10 +423,10 @@ null byte. (%set-slot (deref alien) slot value)) (alien-record-type (let ((field (slot-or-lose type slot))) - (deposit-alien-value (alien-value-sap alien) - (alien-record-field-offset field) - (alien-record-field-type field) - value)))))) + (setf (%alien-value (alien-value-sap alien) + (alien-record-field-offset field) + (alien-record-field-type field)) + value)))))) ;;; Compute the address of the specified slot and return a pointer to it. (defun %slot-addr (alien slot) @@ -474,26 +489,26 @@ null byte. ;;; Dereference the alien and return the results. (defun deref (alien &rest indices) #!+sb-doc - "De-reference an Alien pointer or array. If an array, the indices are used + "Dereference an Alien pointer or array. If an array, the indices are used as the indices of the array element to access. If a pointer, one index can optionally be specified, giving the equivalent of C pointer arithmetic." (declare (type alien-value alien) (type list indices) (optimize (inhibit-warnings 3))) (multiple-value-bind (target-type offset) (deref-guts alien indices) - (extract-alien-value (alien-value-sap alien) - offset - target-type))) + (%alien-value (alien-value-sap alien) + offset + target-type))) (defun %set-deref (alien value &rest indices) (declare (type alien-value alien) (type list indices) (optimize (inhibit-warnings 3))) (multiple-value-bind (target-type offset) (deref-guts alien indices) - (deposit-alien-value (alien-value-sap alien) - offset - target-type - value))) + (setf (%alien-value (alien-value-sap alien) + offset + target-type) + value))) (defun %deref-addr (alien &rest indices) (declare (type alien-value alien) @@ -508,22 +523,22 @@ null byte. (defun %heap-alien (info) (declare (type heap-alien-info info) (optimize (inhibit-warnings 3))) - (extract-alien-value (eval (heap-alien-info-sap-form info)) - 0 - (heap-alien-info-type info))) + (%alien-value (heap-alien-info-sap info) + 0 + (heap-alien-info-type info))) (defun %set-heap-alien (info value) (declare (type heap-alien-info info) (optimize (inhibit-warnings 3))) - (deposit-alien-value (eval (heap-alien-info-sap-form info)) - 0 - (heap-alien-info-type info) - value)) + (setf (%alien-value (heap-alien-info-sap info) + 0 + (heap-alien-info-type info)) + value)) (defun %heap-alien-addr (info) (declare (type heap-alien-info info) (optimize (inhibit-warnings 3))) - (%sap-alien (eval (heap-alien-info-sap-form info)) + (%sap-alien (heap-alien-info-sap info) (make-alien-pointer-type :to (heap-alien-info-type info)))) ;;;; accessing local aliens @@ -649,26 +664,26 @@ null byte. (funcall (coerce-to-interpreted-function (compute-deport-alloc-lambda type)) value type)) -(defun extract-alien-value (sap offset type) +(defun %alien-value (sap offset type) (declare (type system-area-pointer sap) (type unsigned-byte offset) (type alien-type type)) (funcall (coerce-to-interpreted-function (compute-extract-lambda type)) sap offset type)) -(defun deposit-alien-value (sap offset type value) +(defun (setf %alien-value) (value sap offset type) (declare (type system-area-pointer sap) (type unsigned-byte offset) (type alien-type type)) (funcall (coerce-to-interpreted-function (compute-deposit-lambda type)) - sap offset type value)) + value sap offset type)) ;;;; ALIEN-FUNCALL, DEFINE-ALIEN-ROUTINE (defun alien-funcall (alien &rest args) #!+sb-doc "Call the foreign function ALIEN with the specified arguments. ALIEN's - type specifies the argument and result types." +type specifies the argument and result types." (declare (type alien-value alien)) (let ((type (alien-value-type alien))) (typecase type @@ -702,41 +717,41 @@ null byte. #!+sb-doc "DEFINE-ALIEN-ROUTINE Name Result-Type {(Arg-Name Arg-Type [Style])}* - Define a foreign interface function for the routine with the specified NAME. - Also automatically DECLAIM the FTYPE of the defined function. - - NAME may be either a string, a symbol, or a list of the form (string symbol). - - RETURN-TYPE is the alien type for the function return value. VOID may be - used to specify a function with no result. - - The remaining forms specify individual arguments that are passed to the - routine. ARG-NAME is a symbol that names the argument, primarily for - documentation. ARG-TYPE is the C type of the argument. STYLE specifies the - way that the argument is passed. - - :IN - An :IN argument is simply passed by value. The value to be passed is - obtained from argument(s) to the interface function. No values are - returned for :In arguments. This is the default mode. - - :OUT - The specified argument type must be a pointer to a fixed sized object. - A pointer to a preallocated object is passed to the routine, and the - the object is accessed on return, with the value being returned from - the interface function. :OUT and :IN-OUT cannot be used with pointers - to arrays, records or functions. - - :COPY - This is similar to :IN, except that the argument values are stored - on the stack, and a pointer to the object is passed instead of - the value itself. - - :IN-OUT - This is a combination of :OUT and :COPY. A pointer to the argument is - passed, with the object being initialized from the supplied argument - and the return value being determined by accessing the object on - return." +Define a foreign interface function for the routine with the specified NAME. +Also automatically DECLAIM the FTYPE of the defined function. + +NAME may be either a string, a symbol, or a list of the form (string symbol). + +RETURN-TYPE is the alien type for the function return value. VOID may be +used to specify a function with no result. + +The remaining forms specify individual arguments that are passed to the +routine. ARG-NAME is a symbol that names the argument, primarily for +documentation. ARG-TYPE is the C type of the argument. STYLE specifies the +way that the argument is passed. + +:IN + An :IN argument is simply passed by value. The value to be passed is + obtained from argument(s) to the interface function. No values are + returned for :In arguments. This is the default mode. + +:OUT + The specified argument type must be a pointer to a fixed sized object. + A pointer to a preallocated object is passed to the routine, and the + the object is accessed on return, with the value being returned from + the interface function. :OUT and :IN-OUT cannot be used with pointers + to arrays, records or functions. + +:COPY + This is similar to :IN, except that the argument values are stored + on the stack, and a pointer to the object is passed instead of + the value itself. + +:IN-OUT + This is a combination of :OUT and :COPY. A pointer to the argument is + passed, with the object being initialized from the supplied argument + and the return value being determined by accessing the object on + return." (multiple-value-bind (lisp-name alien-name) (pick-lisp-and-alien-names name) (collect ((docs) (lisp-args) (lisp-arg-types) @@ -814,6 +829,10 @@ null byte. (and (alien-value-p object) (alien-subtype-p (alien-value-type object) type))))) +(defun alien-value-typep (object type) + (when (alien-value-p object) + (alien-subtype-p (alien-value-type object) type))) + ;;;; ALIEN CALLBACKS ;;;; ;;;; See "Foreign Linkage / Callbacks" in the SBCL Internals manual. @@ -841,15 +860,17 @@ memoization: we don't create new callbacks if one pointing to the correct function with the same specifier already exists.") (defvar *alien-callback-wrappers* (make-hash-table :test #'equal) - "Cache of existing lisp weappers, indexed with SPECIFER. Used for memoization: + "Cache of existing lisp wrappers, indexed with SPECIFER. Used for memoization: we don't create new wrappers if one for the same specifier already exists.") (defvar *alien-callback-trampolines* (make-array 32 :fill-pointer 0 :adjustable t) "Lisp trampoline store: assembler wrappers contain indexes to this, and -ENTER-ALIEN-CALLBACK pulls the corresponsing trampoline out and calls it.") +ENTER-ALIEN-CALLBACK pulls the corresponding trampoline out and calls it.") -(defun %alien-callback-sap (specifier result-type argument-types function wrapper) - (let ((key (cons specifier function))) +(defun %alien-callback-sap (specifier result-type argument-types function wrapper + &optional call-type) + (declare #!-x86 (ignore call-type)) + (let ((key (list specifier function))) (or (gethash key *alien-callbacks*) (setf (gethash key *alien-callbacks*) (let* ((index (fill-pointer *alien-callback-trampolines*)) @@ -860,8 +881,17 @@ ENTER-ALIEN-CALLBACK pulls the corresponsing trampoline out and calls it.") ;; 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))) + (assembler-wrapper + (alien-callback-assembler-wrapper + index result-type argument-types + #!+x86 + (if (eq call-type :stdcall) + (ceiling + (apply #'+ + (mapcar 'alien-type-word-aligned-bits + argument-types)) + 8) + 0)))) (vector-push-extend (alien-callback-lisp-trampoline wrapper function) *alien-callback-trampolines*) @@ -940,11 +970,17 @@ ENTER-ALIEN-CALLBACK pulls the corresponsing trampoline out and calls it.") (destructuring-bind (function result-type &rest argument-types) specifier (aver (eq 'function function)) - (values (let ((*values-type-okay* t)) - (parse-alien-type result-type env)) - (mapcar (lambda (spec) - (parse-alien-type spec env)) - argument-types)))) + (multiple-value-bind (bare-result-type calling-convention) + (typecase result-type + ((cons calling-convention *) + (values (second result-type) (first result-type))) + (t result-type)) + (values (let ((*values-type-okay* t)) + (parse-alien-type bare-result-type env)) + (mapcar (lambda (spec) + (parse-alien-type spec env)) + argument-types) + calling-convention)))) (defun alien-void-type-p (type) (and (alien-values-type-p type) (not (alien-values-type-values type)))) @@ -980,7 +1016,8 @@ SPECIFIER and FUNCTION already exists, it is returned instead of consing a new one." ;; Pull out as much work as is convenient to macro-expansion time, specifically ;; everything that can be done given just the SPECIFIER and ENV. - (multiple-value-bind (result-type argument-types) (parse-alien-ftype specifier env) + (multiple-value-bind (result-type argument-types call-type) + (parse-alien-ftype specifier env) `(%sap-alien (%alien-callback-sap ',specifier ',result-type ',argument-types ,function @@ -988,7 +1025,8 @@ one." (setf (gethash ',specifier *alien-callback-wrappers*) (compile nil ',(alien-callback-lisp-wrapper-lambda - specifier result-type argument-types env))))) + specifier result-type argument-types env)))) + ,call-type) ',(parse-alien-type specifier env)))) (defun alien-callback-p (alien)