X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-alieneval.lisp;h=2b133cd7d3373543cbbec29f6fb849762afadf5a;hb=25fe91bf63fd473d9316675b0e0ca9be0079e9eb;hp=70fb7bb2737dc6a28da0adc9b1eb73906e7e76d9;hpb=7fb597b585fc715537ea644f7d84440eca217ca1;p=sbcl.git diff --git a/src/code/target-alieneval.lisp b/src/code/target-alieneval.lisp index 70fb7bb..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,14 +801,15 @@ 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 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))) + spec 'args-sap offset)) + do (incf offset (alien-callback-argument-bytes spec env))) ,(flet ((store (spec) (if spec `(setf (deref (sap-alien res-sap (* ,spec))) @@ -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? ;;;