X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-alieneval.lisp;h=e95abe384056faa773a79256cd39788d8b7a269d;hb=4255b37e50876702d2563f3418a44a3f5bf8a2e8;hp=822dd7d0ca1175b4d82efe82ed6f611ffd78640c;hpb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;p=sbcl.git diff --git a/src/code/target-alieneval.lisp b/src/code/target-alieneval.lisp index 822dd7d..e95abe3 100644 --- a/src/code/target-alieneval.lisp +++ b/src/code/target-alieneval.lisp @@ -61,16 +61,11 @@ ',alien-name ',alien-type)))))) -(defmacro def-alien-variable (&rest rest) - (deprecation-warning 'def-alien-variable 'define-alien-variable) - `(define-alien-variable ,@rest)) - ;;; Do the actual work of DEFINE-ALIEN-VARIABLE. (eval-when (:compile-toplevel :load-toplevel :execute) (defun %define-alien-variable (lisp-name alien-name type) (setf (info :variable :kind lisp-name) :alien) (setf (info :variable :where-from lisp-name) :defined) - (clear-info :variable :constant-value lisp-name) (setf (info :variable :alien-info lisp-name) (make-heap-alien-info :type type :sap-form `(foreign-symbol-sap ',alien-name t))))) @@ -95,19 +90,20 @@ ALLOCATION should be one of: :LOCAL (the default) The alien is allocated on the stack, and has dynamic extent. - :STATIC - The alien is allocated on the heap, and has infinite extent. The alien - is allocated at load time, so the same piece of memory is used each time - this form executes. :EXTERN No alien is allocated, but VAR is established as a local name for the external alien given by EXTERNAL-NAME." + ;; FIXME: + ;; :STATIC + ;; The alien is allocated on the heap, and has infinite extent. The alien + ;; is allocated at load time, so the same piece of memory is used each time + ;; this form executes. (/show "entering WITH-ALIEN" bindings) (with-auxiliary-alien-types env (dolist (binding (reverse bindings)) (/show binding) (destructuring-bind - (symbol type &optional (opt1 nil opt1p) (opt2 nil opt2p)) + (symbol type &optional (opt1 nil opt1p) (opt2 nil opt2p)) binding (/show symbol type opt1 opt2) (let* ((alien-type (parse-alien-type type env)) @@ -134,10 +130,10 @@ `((let ((,sap (load-time-value (%make-alien ...)))) (declare (type system-area-pointer ,sap)) (symbol-macrolet - ((,symbol (sap-alien ,sap ,type))) - ,@(when initial-value - `((setq ,symbol ,initial-value))) - ,@body))))) + ((,symbol (sap-alien ,sap ,type))) + ,@(when initial-value + `((setq ,symbol ,initial-value))) + ,@body))))) (:extern (/show0 ":EXTERN case") (let ((info (make-heap-alien-info @@ -145,31 +141,49 @@ :sap-form `(foreign-symbol-sap ',initial-value ,datap)))) `((symbol-macrolet - ((,symbol (%heap-alien ',info))) - ,@body)))) + ((,symbol (%heap-alien ',info))) + ,@body)))) (:local (/show0 ":LOCAL case") - (let ((var (gensym)) - (initval (if initial-value (gensym))) - (info (make-local-alien-info :type alien-type))) + (let* ((var (sb!xc:gensym "VAR")) + (initval (if initial-value (sb!xc:gensym "INITVAL"))) + (info (make-local-alien-info :type alien-type)) + (inner-body + `((note-local-alien-type ',info ,var) + (symbol-macrolet ((,symbol (local-alien ',info ,var))) + ,@(when initial-value + `((setq ,symbol ,initval))) + ,@body))) + (body-forms + (if initial-value + `((let ((,initval ,initial-value)) + ,@inner-body)) + inner-body))) (/show var initval info) - `((let ((,var (make-local-alien ',info)) - ,@(when initial-value - `((,initval ,initial-value)))) - (note-local-alien-type ',info ,var) - (multiple-value-prog1 - (symbol-macrolet - ((,symbol (local-alien ',info ,var))) - ,@(when initial-value - `((setq ,symbol ,initval))) - ,@body) - (dispose-local-alien ',info ,var)))))))))))) + #!+(or x86 x86-64) + `((let ((,var (make-local-alien ',info))) + ,@body-forms)) + ;; FIXME: This version is less efficient then it needs to be, since + ;; it could just save and restore the number-stack pointer once, + ;; instead of doing multiple decrements if there are multiple bindings. + #!-(or x86 x86-64) + `((let (,var) + (unwind-protect + (progn + (setf ,var (make-local-alien ',info)) + (let ((,var ,var)) + ,@body-forms)) + (dispose-local-alien ',info ,var)))))))))))) (/show "revised" body) (verify-local-auxiliaries-okay) (/show0 "back from VERIFY-LOCAL-AUXILIARIES-OK, returning") `(symbol-macrolet ((&auxiliary-type-definitions& ,(append *new-auxiliary-types* (auxiliary-type-definitions env)))) + #!+(or x86 x86-64) + (let ((sb!vm::*alien-stack* sb!vm::*alien-stack*)) + ,@body) + #!-(or x86 x86-64) ,@body))) ;;;; runtime C values that don't correspond directly to Lisp types @@ -215,12 +229,38 @@ (defmacro make-alien (type &optional size &environment env) #!+sb-doc - "Allocate an alien of type TYPE and return an alien pointer to it. If SIZE - is supplied, how it is interpreted depends on TYPE. If TYPE is an array - type, SIZE is used as the first dimension for the allocated array. If TYPE - is not an array, then SIZE is the number of elements to allocate. The - memory is allocated using ``malloc'', so it can be passed to foreign - functions which use ``free''." + "Allocate an alien of type TYPE in foreign heap, and return an alien +pointer to it. The allocated memory is not initialized, and may +contain garbage. The memory is allocated using malloc(3), so it can be +passed to foreign functions which use free(3), or released using +FREE-ALIEN. + +For alien stack allocation, see macro WITH-ALIEN. + +The TYPE argument is not evaluated. If SIZE is supplied, how it is +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. + + If supplied, SIZE is used as the first dimension for the array. + + * When TYPE is any other foreign type, then an object for that + type is allocated, and a pointer to it is returned. So + (make-alien int) returns a (* int). + + If SIZE is specified, then a block of that many objects is + allocated, with the result pointing to the first one. + +Examples: + + (defvar *foo* (make-alien (array char 10))) + (type-of *foo*) ; => (alien (* (array (signed 8) 10))) + (setf (deref (deref foo) 0) 10) ; => 10 + + (make-alien char 12) ; => (alien (* (signed 8))) +" (let ((alien-type (if (alien-type-p type) type (parse-alien-type type env)))) @@ -228,18 +268,18 @@ (if (alien-array-type-p alien-type) (let ((dims (alien-array-type-dimensions alien-type))) (cond - (size - (unless dims - (error - "cannot override the size of zero-dimensional arrays")) - (when (constantp size) - (setf alien-type (copy-alien-array-type alien-type)) - (setf (alien-array-type-dimensions alien-type) - (cons (eval size) (cdr dims))))) - (dims - (setf size (car dims))) - (t - (setf size 1))) + (size + (unless dims + (error + "cannot override the size of zero-dimensional arrays")) + (when (constantp size) + (setf alien-type (copy-alien-array-type alien-type)) + (setf (alien-array-type-dimensions alien-type) + (cons (constant-form-value size) (cdr dims))))) + (dims + (setf size (car dims))) + (t + (setf size 1))) (values `(* ,size ,@(cdr dims)) (alien-array-type-element-type alien-type))) (values (or size 1) alien-type)) @@ -251,9 +291,13 @@ (unless alignment (error "The alignment of ~S is unknown." (unparse-alien-type element-type))) - `(%sap-alien (%make-alien (* ,(align-offset bits alignment) - ,size-expr)) - ',(make-alien-pointer-type :to alien-type)))))) + ;; This is the one place where the %SAP-ALIEN note is quite + ;; undesirable, in most uses of MAKE-ALIEN the %SAP-ALIEN + ;; cannot be optimized away. + `(locally (declare (muffle-conditions compiler-note)) + (%sap-alien (%make-alien (* ,(align-offset bits alignment) + ,size-expr)) + ',(make-alien-pointer-type :to alien-type))))))) ;;; Allocate a block of memory at least BITS bits long and return a ;;; system area pointer to it. @@ -267,11 +311,51 @@ #!-sb-fluid (declaim (inline free-alien)) (defun free-alien (alien) #!+sb-doc - "Dispose of the storage pointed to by ALIEN. ALIEN must have been allocated - by MAKE-ALIEN or malloc(3)." + "Dispose of the storage pointed to by ALIEN. The ALIEN must have been +allocated by MAKE-ALIEN, MAKE-ALIEN-STRING or malloc(3)." (alien-funcall (extern-alien "free" (function (values) system-area-pointer)) (alien-sap alien)) nil) + +(declaim (type (sfunction * system-area-pointer) %make-alien-string)) +(defun %make-alien-string (string &key (start 0) end + (external-format :default) + (null-terminate t)) + ;; FIXME: This is slow. We want a function to get the length of the + ;; encoded string so we can allocate the foreign memory first and + ;; encode directly there. + (let* ((octets (string-to-octets string + :start start :end end + :external-format external-format + :null-terminate null-terminate)) + (count (length octets)) + (buf (%make-alien (* 8 count)))) + (sb!kernel:copy-ub8-to-system-area octets 0 buf 0 count) + buf)) + +(defun make-alien-string (string &rest rest + &key (start 0) end + (external-format :default) + (null-terminate t)) + "Copy part of STRING delimited by START and END into freshly +allocated foreign memory, freeable using free(3) or FREE-ALIEN. +Returns the allocated string as a (* CHAR) alien, and the number of +bytes allocated as secondary value. + +The string is encoded using EXTERNAL-FORMAT. If NULL-TERMINATE is +true (the default), the alien string is terminated by an additional +null byte. +" + (declare (ignore start end external-format null-terminate)) + (multiple-value-bind (sap bytes) + (apply #'%make-alien-string string rest) + (values (%sap-alien sap (parse-alien-type '(* char) nil)) + bytes))) + +(define-compiler-macro make-alien-string (&rest args) + `(multiple-value-bind (sap bytes) (%make-alien-string ,@args) + (values (%sap-alien sap ',(parse-alien-type '(* char) nil)) + bytes))) ;;;; the SLOT operator @@ -442,7 +526,8 @@ (lambda () (alien-funcall (extern-alien "free" (function (values) system-area-pointer)) - alien-sap))) + alien-sap)) + :dont-save t) alien)) (defun note-local-alien-type (info alien) @@ -459,6 +544,8 @@ (define-setf-expander local-alien (&whole whole info alien) (let ((value (gensym)) + (info-var (gensym)) + (alloc-tmp (gensym)) (info (if (and (consp info) (eq (car info) 'quote)) (second info) @@ -469,8 +556,10 @@ (list value) `(if (%local-alien-forced-to-memory-p ',info) (%set-local-alien ',info ,alien ,value) - (setf ,alien - (deport ,value ',(local-alien-info-type info)))) + (let* ((,info-var ',(local-alien-info-type info)) + (,alloc-tmp (deport-alloc ,value ,info-var))) + (maybe-with-pinned-objects (,alloc-tmp) (,(local-alien-info-type info)) + (setf ,alien (deport ,alloc-tmp ,info-var))))) whole))) (defun %local-alien-forced-to-memory-p (info) @@ -530,28 +619,38 @@ ;;;; NATURALIZE, DEPORT, EXTRACT-ALIEN-VALUE, DEPOSIT-ALIEN-VALUE +(defun coerce-to-interpreted-function (lambda-form) + (let (#!+sb-eval + (*evaluator-mode* :interpret)) + (coerce lambda-form 'function))) + (defun naturalize (alien type) (declare (type alien-type type)) - (funcall (coerce (compute-naturalize-lambda type) 'function) + (funcall (coerce-to-interpreted-function (compute-naturalize-lambda type)) alien type)) (defun deport (value type) (declare (type alien-type type)) - (funcall (coerce (compute-deport-lambda type) 'function) + (funcall (coerce-to-interpreted-function (compute-deport-lambda type)) + value type)) + +(defun deport-alloc (value type) + (declare (type alien-type type)) + (funcall (coerce-to-interpreted-function (compute-deport-alloc-lambda type)) value type)) (defun extract-alien-value (sap offset type) (declare (type system-area-pointer sap) (type unsigned-byte offset) (type alien-type type)) - (funcall (coerce (compute-extract-lambda type) 'function) + (funcall (coerce-to-interpreted-function (compute-extract-lambda type)) sap offset type)) (defun deposit-alien-value (sap offset type value) (declare (type system-area-pointer sap) (type unsigned-byte offset) (type alien-type type)) - (funcall (coerce (compute-deposit-lambda type) 'function) + (funcall (coerce-to-interpreted-function (compute-deposit-lambda type)) sap offset type value)) ;;;; ALIEN-FUNCALL, DEFINE-ALIEN-ROUTINE @@ -575,7 +674,7 @@ (let ((stub (alien-fun-type-stub type))) (unless stub (setf stub - (let ((fun (gensym)) + (let ((fun (sb!xc:gensym "FUN")) (parms (make-gensym-list (length args)))) (compile nil `(lambda (,fun ,@parms) @@ -690,29 +789,11 @@ ((,lisp-name (function ,result-type ,@(arg-types)) :extern ,alien-name) ,@(alien-vars)) - #-nil - (values (alien-funcall ,lisp-name ,@(alien-args)) - ,@(results)) - #+nil - (if (alien-values-type-p result-type) - ;; FIXME: RESULT-TYPE is a type specifier, so it - ;; cannot be of type ALIEN-VALUES-TYPE. Also note, - ;; that if RESULT-TYPE is VOID, then this code - ;; disagrees with the computation of the return type - ;; and with all usages of this macro. -- APD, - ;; 2002-03-02 - (let ((temps (make-gensym-list - (length - (alien-values-type-values result-type))))) - `(multiple-value-bind ,temps - (alien-funcall ,lisp-name ,@(alien-args)) - (values ,@temps ,@(results)))) - (values (alien-funcall ,lisp-name ,@(alien-args)) - ,@(results))))))))) - -(defmacro def-alien-routine (&rest rest) - (deprecation-warning 'def-alien-routine 'define-alien-routine) - `(define-alien-routine ,@rest)) + ,@(if (eq 'void result-type) + `((alien-funcall ,lisp-name ,@(alien-args)) + (values nil ,@(results))) + `((values (alien-funcall ,lisp-name ,@(alien-args)) + ,@(results)))))))))) (defun alien-typep (object type) #!+sb-doc @@ -774,6 +855,7 @@ ENTER-ALIEN-CALLBACK pulls the corresponsing trampoline out and calls it.") (vector-push-extend (alien-callback-lisp-trampoline wrapper function) *alien-callback-trampolines*) + ;; Assembler-wrapper is static, so sap-taking is safe. (let ((sap (vector-sap assembler-wrapper))) (push (cons sap (make-callback-info :specifier specifier :function function @@ -792,34 +874,45 @@ ENTER-ALIEN-CALLBACK pulls the corresponsing trampoline out and calls it.") (argument-names arguments) (argument-specs (cddr specifier))) `(lambda (args-pointer result-pointer function) + ;; FIXME: the saps are not gc safe (let ((args-sap (int-sap (sb!kernel:get-lisp-obj-address args-pointer))) (res-sap (int-sap (sb!kernel:get-lisp-obj-address result-pointer)))) + (declare (ignorable args-sap res-sap)) (with-alien ,(loop + with offset = 0 for spec in argument-specs - for offset = 0 ; FIXME: Should this not be AND OFFSET ...? - then (+ offset (alien-callback-argument-bytes spec env)) collect `(,(pop argument-names) ,spec :local ,(alien-callback-accessor-form - spec 'args-sap offset))) - ,(flet ((store (spec) + spec 'args-sap offset)) + do (incf offset (alien-callback-argument-bytes spec env))) + ,(flet ((store (spec real-type) (if spec `(setf (deref (sap-alien res-sap (* ,spec))) - (funcall function ,@arguments)) + ,(if real-type + `(the ,real-type + (funcall function ,@arguments)) + `(funcall function ,@arguments))) `(funcall function ,@arguments)))) (cond ((alien-void-type-p result-type) - (store nil)) + (store nil nil)) ((alien-integer-type-p result-type) + ;; Integer types should be padded out to a full + ;; register width, to comply with most ABI calling + ;; conventions, but should be typechecked on the + ;; declared type width, hence the following: (if (alien-integer-type-signed result-type) (store `(signed - ,(alien-type-word-aligned-bits result-type))) + ,(alien-type-word-aligned-bits result-type)) + `(signed-byte ,(alien-type-bits result-type))) (store `(unsigned - ,(alien-type-word-aligned-bits result-type))))) + ,(alien-type-word-aligned-bits result-type)) + `(unsigned-byte ,(alien-type-bits result-type))))) (t - (store (unparse-alien-type result-type))))))) + (store (unparse-alien-type result-type) nil)))))) (values)))) (defun invalid-alien-callback (&rest arguments) @@ -837,7 +930,8 @@ 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 (parse-alien-type result-type env) + (values (let ((*values-type-okay* t)) + (parse-alien-type result-type env)) (mapcar (lambda (spec) (parse-alien-type spec env)) argument-types)))) @@ -852,7 +946,8 @@ ENTER-ALIEN-CALLBACK pulls the corresponsing trampoline out and calls it.") (let ((type (parse-alien-type spec env))) (if (or (alien-integer-type-p type) (alien-float-type-p type) - (alien-pointer-type-p type)) + (alien-pointer-type-p type) + (alien-system-area-pointer-type-p type)) (ceiling (alien-type-word-aligned-bits type) sb!vm:n-byte-bits) (error "Unsupported callback argument type: ~A" type)))) @@ -861,6 +956,11 @@ ENTER-ALIEN-CALLBACK pulls the corresponsing trampoline out and calls it.") return arguments)) +;;; To ensure that callback wrapper functions continue working even +;;; if #'ENTER-ALIEN-CALLBACK moves in memory, access to it is indirected +;;; through the *ENTER-ALIEN-CALLBACK* static symbol. -- JES, 2006-01-01 +(defvar *enter-alien-callback* #'enter-alien-callback) + ;;;; interface (not public, yet) for alien callbacks (defmacro alien-callback (specifier function &environment env) @@ -876,8 +976,9 @@ one." ,function (or (gethash ',specifier *alien-callback-wrappers*) (setf (gethash ',specifier *alien-callback-wrappers*) - ,(alien-callback-lisp-wrapper-lambda - specifier result-type argument-types env)))) + (compile nil + ',(alien-callback-lisp-wrapper-lambda + specifier result-type argument-types env))))) ',(parse-alien-type specifier env)))) (defun alien-callback-p (alien) @@ -924,8 +1025,8 @@ callback signal an error." (setf (callback-info-function info) nil) t))) -;;; FIXME: This calls assembles a new callback for every closure, -;;; which suck hugely. ...not that I can think of an obvious +;;; FIXME: This call assembles a new callback for every closure, +;;; which sucks hugely. ...not that I can think of an obvious ;;; solution. Possibly maybe we could write a generalized closure ;;; callback analogous to closure_tramp, and share the actual wrapper? ;;;