X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-alieneval.lisp;h=2b133cd7d3373543cbbec29f6fb849762afadf5a;hb=25fe91bf63fd473d9316675b0e0ca9be0079e9eb;hp=7a6e04195f20e5da8c70d844609d47b537fd68fc;hpb=adeddfb8570bb924b4899679912b4629008b7566;p=sbcl.git diff --git a/src/code/target-alieneval.lisp b/src/code/target-alieneval.lisp index 7a6e041..2b133cd 100644 --- a/src/code/target-alieneval.lisp +++ b/src/code/target-alieneval.lisp @@ -216,11 +216,11 @@ (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''." +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''." (let ((alien-type (if (alien-type-p type) type (parse-alien-type type env)))) @@ -228,18 +228,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 +251,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. @@ -587,37 +591,6 @@ (t (error "~S is not an alien function." alien))))) -(defun alien-funcall-stdcall (alien &rest args) - #!+sb-doc - "Call the foreign function ALIEN with the specified arguments. ALIEN's - type specifies the argument and result types." - (declare (type alien-value alien)) - (let ((type (alien-value-type alien))) - (typecase type - (alien-pointer-type - (apply #'alien-funcall-stdcall (deref alien) args)) - (alien-fun-type - (unless (= (length (alien-fun-type-arg-types type)) - (length args)) - (error "wrong number of arguments for ~S~%expected ~W, got ~W" - type - (length (alien-fun-type-arg-types type)) - (length args))) - (let ((stub (alien-fun-type-stub type))) - (unless stub - (setf stub - (let ((fun (gensym)) - (parms (make-gensym-list (length args)))) - (compile nil - `(lambda (,fun ,@parms) - (declare (optimize (sb!c::insert-step-conditions 0))) - (declare (type (alien ,type) ,fun)) - (alien-funcall-stdcall ,fun ,@parms))))) - (setf (alien-fun-type-stub type) stub)) - (apply stub alien args))) - (t - (error "~S is not an alien function." alien))))) - (defmacro define-alien-routine (name result-type &rest args &environment lexenv) @@ -828,6 +801,7 @@ ENTER-ALIEN-CALLBACK pulls the corresponsing trampoline out and calls it.") (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 @@ -895,6 +869,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) @@ -910,8 +889,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) @@ -958,8 +938,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? ;;;