X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-alieneval.lisp;h=14782074151717016c17b89bf3f1374cd1789845;hb=a160917364f85b38dc0826a5e3dcef87e3c4c62c;hp=5d0036a285a33f649f3827e954ede4edec225261;hpb=04c502ea9374372b1cd5d350aa95af4829fbae22;p=sbcl.git diff --git a/src/code/target-alieneval.lisp b/src/code/target-alieneval.lisp index 5d0036a..1478207 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 (gensym)) + (initval (if initial-value (gensym))) + (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 @@ -446,7 +460,8 @@ allocated using ``malloc'', so it can be passed to foreign functions which use (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) @@ -708,29 +723,11 @@ allocated using ``malloc'', so it can be passed to foreign functions which use ((,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 @@ -792,6 +789,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