X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-alieneval.lisp;h=e8de84dac42d15104b43da215f841ea2bc45ec01;hb=50305b602c3953440af716137a56f50cd204375d;hp=b59b99eb6d4ed7cac6e454992645ef3cdbaeaf37;hpb=1bdc658b910e7dcc76f606b2c7c9c64012b6ee11;p=sbcl.git diff --git a/src/code/target-alieneval.lisp b/src/code/target-alieneval.lisp index b59b99e..e8de84d 100644 --- a/src/code/target-alieneval.lisp +++ b/src/code/target-alieneval.lisp @@ -97,12 +97,16 @@ :EXTERN No alien is allocated, but VAR is established as a local name for the external alien given by EXTERNAL-NAME." + (/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)) binding + (/show symbol type opt1 opt2) (let ((alien-type (parse-alien-type type env))) + (/show alien-type) (multiple-value-bind (allocation initial-value) (if opt2p (values opt1 opt2) @@ -113,6 +117,7 @@ (values opt1 nil)) (t (values :local opt1)))) + (/show allocation initial-value) (setf body (ecase allocation #+nil @@ -128,6 +133,7 @@ `((setq ,symbol ,initial-value))) ,@body))))) (:extern + (/show ":EXTERN case") (let ((info (make-heap-alien-info :type alien-type :sap-form `(foreign-symbol-address @@ -136,9 +142,11 @@ ((,symbol (%heap-alien ',info))) ,@body)))) (:local + (/show ":LOCAL case") (let ((var (gensym)) (initval (if initial-value (gensym))) (info (make-local-alien-info :type alien-type))) + (/show var initval info) `((let ((,var (make-local-alien ',info)) ,@(when initial-value `((,initval ,initial-value)))) @@ -150,7 +158,9 @@ `((setq ,symbol ,initval))) ,@body) (dispose-local-alien ',info ,var)))))))))))) + (/show "revised" body) (verify-local-auxiliaries-okay) + (/show "back from VERIFY-LOCAL-AUXILIARIES-OK, returning") `(symbol-macrolet ((&auxiliary-type-definitions& ,(append *new-auxiliary-types* (auxiliary-type-definitions env)))) @@ -158,8 +168,6 @@ ;;;; runtime C values that don't correspond directly to Lisp types -;;; ALIEN-VALUE -;;; ;;; Note: The DEFSTRUCT for ALIEN-VALUE lives in a separate file ;;; 'cause it has to be real early in the cold-load order. #!-sb-fluid (declaim (freeze-type alien-value)) @@ -244,15 +252,16 @@ ;;; system area pointer to it. #!-sb-fluid (declaim (inline %make-alien)) (defun %make-alien (bits) - (declare (type index bits) (optimize-interface (safety 2))) - (alien-funcall (extern-alien "malloc" (function system-area-pointer unsigned)) + (declare (type index bits)) + (alien-funcall (extern-alien "malloc" + (function system-area-pointer unsigned)) (ash (the index (+ bits 7)) -3))) #!-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''." + by MAKE-ALIEN or malloc(3)." (alien-funcall (extern-alien "free" (function (values) system-area-pointer)) (alien-sap alien)) nil) @@ -265,7 +274,7 @@ (type symbol slot)) (or (find slot (alien-record-type-fields type) :key #'alien-record-field-name) - (error "There is no slot named ~S in ~S" slot type))) + (error "There is no slot named ~S in ~S." slot type))) ;;; Extract the value from the named slot from the record ALIEN. If ;;; ALIEN is actually a pointer, then DEREF it first. @@ -316,13 +325,14 @@ (let* ((field (slot-or-lose type slot)) (offset (alien-record-field-offset field)) (field-type (alien-record-field-type field))) - (%sap-alien (sap+ (alien-sap alien) (/ offset sb!vm:byte-bits)) + (%sap-alien (sap+ (alien-sap alien) (/ offset sb!vm:n-byte-bits)) (make-alien-pointer-type :to field-type))))))) ;;;; the DEREF operator -;;; Does most of the work of the different DEREF methods. Returns two values: -;;; the type and the offset (in bits) of the refered to alien. +;;; This function does most of the work of the different DEREF +;;; methods. It returns two values: the type and the offset (in bits) +;;; of the referred-to alien. (defun deref-guts (alien indices) (declare (type alien-value alien) (type list indices) @@ -389,7 +399,7 @@ (type list indices) (optimize (inhibit-warnings 3))) (multiple-value-bind (target-type offset) (deref-guts alien indices) - (%sap-alien (sap+ (alien-value-sap alien) (/ offset sb!vm:byte-bits)) + (%sap-alien (sap+ (alien-value-sap alien) (/ offset sb!vm:n-byte-bits)) (make-alien-pointer-type :to target-type)))) ;;;; accessing heap alien variables @@ -450,12 +460,10 @@ (values nil nil (list value) - (if sb!c:*converting-for-interpreter* - `(%set-local-alien ',info ,alien ,value) - `(if (%local-alien-forced-to-memory-p ',info) - (%set-local-alien ',info ,alien ,value) - (setf ,alien - (deport ,value ',(local-alien-info-type info))))) + `(if (%local-alien-forced-to-memory-p ',info) + (%set-local-alien ',info ,alien ,value) + (setf ,alien + (deport ,value ',(local-alien-info-type info)))) whole))) (defun %local-alien-forced-to-memory-p (info) @@ -483,15 +491,15 @@ (defun %cast (alien target-type) (declare (type alien-value alien) (type alien-type target-type) - (optimize-interface (safety 2)) + (optimize (safety 2)) (optimize (inhibit-warnings 3))) (if (or (alien-pointer-type-p target-type) (alien-array-type-p target-type) - (alien-function-type-p target-type)) + (alien-fun-type-p target-type)) (let ((alien-type (alien-value-type alien))) (if (or (alien-pointer-type-p alien-type) (alien-array-type-p alien-type) - (alien-function-type-p alien-type)) + (alien-fun-type-p alien-type)) (naturalize (alien-value-sap alien) target-type) (error "~S cannot be casted." alien))) (error "cannot cast to alien type ~S" (unparse-alien-type target-type)))) @@ -508,8 +516,8 @@ (values (ceiling bits (ecase units (:bits 1) - (:bytes sb!vm:byte-bits) - (:words sb!vm:word-bits)))) + (:bytes sb!vm:n-byte-bits) + (:words sb!vm:n-word-bits)))) (error "unknown size for alien type ~S" (unparse-alien-type alien-type))))) @@ -550,14 +558,14 @@ (typecase type (alien-pointer-type (apply #'alien-funcall (deref alien) args)) - (alien-function-type - (unless (= (length (alien-function-type-arg-types type)) + (alien-fun-type + (unless (= (length (alien-fun-type-arg-types type)) (length args)) (error "wrong number of arguments for ~S~%expected ~D, got ~D" type - (length (alien-function-type-arg-types type)) + (length (alien-fun-type-arg-types type)) (length args))) - (let ((stub (alien-function-type-stub type))) + (let ((stub (alien-fun-type-stub type))) (unless stub (setf stub (let ((fun (gensym)) @@ -566,28 +574,30 @@ `(lambda (,fun ,@parms) (declare (type (alien ,type) ,fun)) (alien-funcall ,fun ,@parms))))) - (setf (alien-function-type-stub type) stub)) + (setf (alien-fun-type-stub type) stub)) (apply stub alien args))) (t (error "~S is not an alien function." alien))))) -(defmacro def-alien-routine (name result-type &rest args &environment env) +(defmacro def-alien-routine (name result-type &rest args &environment lexenv) #!+sb-doc - "Def-C-Routine Name Result-Type - {(Arg-Name Arg-Type [Style])}* + "DEF-ALIEN-ROUTINE Name Result-Type {(Arg-Name Arg-Type [Style])}* - Define a foreign interface function for the routine with the specified Name, - which may be either a string, symbol or 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. + Define a foreign interface function for the routine with the specified NAME. + Also automatically DECLAIM the FTYPE of the defined function. - The remaining forms specifiy 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 - say that the argument is passed. + 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 + 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. @@ -599,14 +609,15 @@ to arrays, records or functions. :COPY - Similar to :IN, except that the argument values are stored in on - the stack, and a pointer to the object is passed instead of - the values themselves. + 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 - 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." + 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) (arg-types) (alien-vars) @@ -620,7 +631,7 @@ (unless (eq style :out) (lisp-args name)) (when (and (member style '(:out :in-out)) - (typep (parse-alien-type type env) + (typep (parse-alien-type type lexenv) 'alien-pointer-type)) (error "can't use :OUT or :IN-OUT on pointer-like type:~% ~S" type)) @@ -635,21 +646,32 @@ (alien-args `(addr ,name)))) (when (or (eq style :out) (eq style :in-out)) (results name))))) - `(defun ,lisp-name ,(lisp-args) - ,@(docs) - (with-alien - ((,lisp-name (function ,result-type ,@(arg-types)) - :extern ,alien-name) - ,@(alien-vars)) - ,(if (alien-values-type-p result-type) - (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)))))))) + `(progn + + ;; The theory behind this automatic DECLAIM is that (1) if + ;; you're calling C, static typing is what you're doing + ;; anyway, and (2) such a declamation can be (especially for + ;; alien values) both messy to do by hand and very important + ;; for performance of later code which uses the return value. + (declaim (ftype (function (mapcar (constantly t) ',args) + (alien ,result-type)) + ,lisp-name)) + + (defun ,lisp-name ,(lisp-args) + ,@(docs) + (with-alien + ((,lisp-name (function ,result-type ,@(arg-types)) + :extern ,alien-name) + ,@(alien-vars)) + ,(if (alien-values-type-p result-type) + (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))))))))) (defun alien-typep (object type) #!+sb-doc