X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fhost-alieneval.lisp;h=9c343d5b39d031a63d5d6c0c2ef53ac3a13d8fe6;hb=dc33d6a6b84f8338e603759cec8e25da29055d50;hp=5e1f3e5c041779335612f09f7229b4095395d8ca;hpb=ce02ab2ecd9c6ae2e570abd8c93ebf3be55bbdad;p=sbcl.git diff --git a/src/code/host-alieneval.lisp b/src/code/host-alieneval.lisp index 5e1f3e5..9c343d5 100644 --- a/src/code/host-alieneval.lisp +++ b/src/code/host-alieneval.lisp @@ -22,7 +22,7 @@ (defun guess-alignment (bits) (cond ((null bits) nil) - #!-x86 ((> bits 32) 64) + #!-(or x86 (and ppc darwin)) ((> bits 32) 64) ((> bits 16) 32) ((> bits 8) 16) ((> bits 1) 8) @@ -30,7 +30,7 @@ ;;;; ALIEN-TYPE-INFO stuff -(eval-when (:compile-toplevel :execute :load-toplevel) +(eval-when (#-sb-xc :compile-toplevel :execute :load-toplevel) (defstruct (alien-type-class (:copier nil)) (name nil :type symbol) @@ -85,7 +85,8 @@ ;;; We define a keyword "BOA" constructor so that we can reference the ;;; slot names in init forms. -(def!macro def-alien-type-class ((name &key include include-args) &rest slots) +(def!macro define-alien-type-class ((name &key include include-args) + &rest slots) (let ((defstruct-name (symbolicate "ALIEN-" name "-TYPE"))) (multiple-value-bind (include include-defstruct overrides) (etypecase include @@ -106,7 +107,7 @@ (create-alien-type-class-if-necessary ',name ',(or include 'root))) (def!struct (,defstruct-name (:include ,include-defstruct - (:class ',name) + (class ',name) ,@overrides) (:constructor ,(symbolicate "MAKE-" defstruct-name) @@ -114,10 +115,12 @@ ,@(mapcar (lambda (x) (if (atom x) x (car x))) slots) - ,@include-args))) + ,@include-args + ;; KLUDGE + &aux (alignment (or alignment (guess-alignment bits)))))) ,@slots))))) -(def!macro def-alien-type-method ((class method) lambda-list &rest body) +(def!macro define-alien-type-method ((class method) lambda-list &rest body) (let ((defun-name (symbolicate class "-" method "-METHOD"))) `(progn (defun ,defun-name ,lambda-list @@ -144,7 +147,7 @@ ;;; COMPILER-LET is no longer supported by ANSI or SBCL. Instead, we ;;; follow the suggestion in CLTL2 of using SYMBOL-MACROLET to achieve ;;; a similar effect. -(eval-when (:compile-toplevel :load-toplevel :execute) +(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) (defun auxiliary-type-definitions (env) (multiple-value-bind (result expanded-p) (sb!xc:macroexpand '&auxiliary-type-definitions& env) @@ -163,24 +166,16 @@ ,(let ((*new-auxiliary-types* nil)) ,@body))) -;;; FIXME: Now that *NEW-AUXILIARY-TYPES* is born initialized to NIL, -;;; we no longer need to make a distinction between this and -;;; %PARSE-ALIEN-TYPE. +;;; Parse TYPE as an alien type specifier and return the resultant +;;; ALIEN-TYPE structure. (defun parse-alien-type (type env) (declare (type (or sb!kernel:lexenv null) env)) - #!+sb-doc - "Parse the list structure TYPE as an alien type specifier and return - the resultant ALIEN-TYPE structure." - (%parse-alien-type type env)) - -(defun %parse-alien-type (type env) - (declare (type (or sb!kernel:lexenv null) env)) (if (consp type) (let ((translator (info :alien-type :translator (car type)))) (unless translator (error "unknown alien type: ~S" type)) (funcall translator type env)) - (case (info :alien-type :kind type) + (ecase (info :alien-type :kind type) (:primitive (let ((translator (info :alien-type :translator type))) (unless translator @@ -249,24 +244,23 @@ ;;;; alien type defining stuff -(def!macro def-alien-type-translator (name lambda-list &body body) - (let ((whole (gensym "WHOLE")) - (env (gensym "ENV")) - (defun-name (symbolicate "ALIEN-" name "-TYPE-TRANSLATOR"))) - (multiple-value-bind (body decls docs) - (sb!kernel:parse-defmacro lambda-list whole body name - 'def-alien-type-translator - :environment env) - `(eval-when (:compile-toplevel :load-toplevel :execute) - (defun ,defun-name (,whole ,env) - (declare (ignorable ,env)) - ,@decls - (block ,name - ,body)) - (%def-alien-type-translator ',name #',defun-name ,docs))))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defun %def-alien-type-translator (name translator docs) +(def!macro define-alien-type-translator (name lambda-list &body body) + (with-unique-names (whole env) + (let ((defun-name (symbolicate "ALIEN-" name "-TYPE-TRANSLATOR"))) + (multiple-value-bind (body decls docs) + (sb!kernel:parse-defmacro lambda-list whole body name + 'define-alien-type-translator + :environment env) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (defun ,defun-name (,whole ,env) + (declare (ignorable ,env)) + ,@decls + (block ,name + ,body)) + (%define-alien-type-translator ',name #',defun-name ,docs)))))) + +(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) + (defun %define-alien-type-translator (name translator docs) (declare (ignore docs)) (setf (info :alien-type :kind name) :primitive) (setf (info :alien-type :translator name) translator) @@ -275,7 +269,7 @@ (setf (fdocumentation name 'alien-type) docs) name)) -(def!macro def-alien-type (name type &environment env) +(def!macro define-alien-type (name type &environment env) #!+sb-doc "Define the alien type NAME to be equivalent to TYPE. Name may be NIL for STRUCT and UNION types, in which case the name is taken from the type @@ -286,11 +280,23 @@ ,@(when *new-auxiliary-types* `((%def-auxiliary-alien-types ',*new-auxiliary-types*))) ,@(when name - `((%def-alien-type ',name ',alien-type))))))) + `((%define-alien-type ',name ',alien-type))))))) +(def!macro def-alien-type (&rest rest) + (deprecation-warning 'def-alien-type 'define-alien-type) + `(define-alien-type ,@rest)) -(eval-when (:compile-toplevel :load-toplevel :execute) +(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) (defun %def-auxiliary-alien-types (types) (dolist (info types) + ;; Clear up the type we're about to define from the toplevel + ;; *new-auxiliary-types* (local scopes take care of themselves). + ;; Unless this is done we never actually get back the full type + ;; from INFO, since the *new-auxiliary-types* have precendence. + (setf *new-auxiliary-types* + (remove info *new-auxiliary-types* + :test (lambda (a b) + (and (eq (first a) (first b)) + (eq (second a) (second b)))))) (destructuring-bind (kind name defn) info (macrolet ((frob (kind) `(let ((old (info :alien-type ,kind name))) @@ -303,7 +309,7 @@ (:struct (frob :struct)) (:union (frob :union)) (:enum (frob :enum))))))) - (defun %def-alien-type (name new) + (defun %define-alien-type (name new) (ecase (info :alien-type :kind name) (:primitive (error "~S is a built-in alien type." name)) @@ -326,59 +332,60 @@ (def!struct (alien-type (:make-load-form-fun sb!kernel:just-dump-it-normally) - (:constructor make-alien-type (&key class bits alignment))) + (:constructor make-alien-type (&key class bits alignment + &aux (alignment (or alignment (guess-alignment bits)))))) (class 'root :type symbol) (bits nil :type (or null unsigned-byte)) - (alignment (guess-alignment bits) :type (or null unsigned-byte))) + (alignment nil :type (or null unsigned-byte))) (def!method print-object ((type alien-type) stream) (print-unreadable-object (type stream :type t) (prin1 (unparse-alien-type type) stream))) ;;;; the SAP type -(def-alien-type-class (system-area-pointer)) +(define-alien-type-class (system-area-pointer)) -(def-alien-type-translator system-area-pointer () +(define-alien-type-translator system-area-pointer () (make-alien-system-area-pointer-type - :bits #!-alpha sb!vm:word-bits #!+alpha 64)) + :bits #!-alpha sb!vm:n-word-bits #!+alpha 64)) -(def-alien-type-method (system-area-pointer :unparse) (type) +(define-alien-type-method (system-area-pointer :unparse) (type) (declare (ignore type)) 'system-area-pointer) -(def-alien-type-method (system-area-pointer :lisp-rep) (type) +(define-alien-type-method (system-area-pointer :lisp-rep) (type) (declare (ignore type)) 'system-area-pointer) -(def-alien-type-method (system-area-pointer :alien-rep) (type) +(define-alien-type-method (system-area-pointer :alien-rep) (type) (declare (ignore type)) 'system-area-pointer) -(def-alien-type-method (system-area-pointer :naturalize-gen) (type alien) +(define-alien-type-method (system-area-pointer :naturalize-gen) (type alien) (declare (ignore type)) alien) -(def-alien-type-method (system-area-pointer :deport-gen) (type object) +(define-alien-type-method (system-area-pointer :deport-gen) (type object) (declare (ignore type)) (/noshow "doing alien type method SYSTEM-AREA-POINTER :DEPORT-GEN" object) object) -(def-alien-type-method (system-area-pointer :extract-gen) (type sap offset) +(define-alien-type-method (system-area-pointer :extract-gen) (type sap offset) (declare (ignore type)) - `(sap-ref-sap ,sap (/ ,offset sb!vm:byte-bits))) + `(sap-ref-sap ,sap (/ ,offset sb!vm:n-byte-bits))) ;;;; the ALIEN-VALUE type -(def-alien-type-class (alien-value :include system-area-pointer)) +(define-alien-type-class (alien-value :include system-area-pointer)) -(def-alien-type-method (alien-value :lisp-rep) (type) +(define-alien-type-method (alien-value :lisp-rep) (type) (declare (ignore type)) nil) -(def-alien-type-method (alien-value :naturalize-gen) (type alien) +(define-alien-type-method (alien-value :naturalize-gen) (type alien) `(%sap-alien ,alien ',type)) -(def-alien-type-method (alien-value :deport-gen) (type value) +(define-alien-type-method (alien-value :deport-gen) (type value) (declare (ignore type)) (/noshow "doing alien type method ALIEN-VALUE :DEPORT-GEN" value) `(alien-sap ,value)) @@ -389,10 +396,10 @@ (def!struct (heap-alien-info (:make-load-form-fun sb!kernel:just-dump-it-normally)) ;; The type of this alien. - (type (required-argument) :type alien-type) + (type (missing-arg) :type alien-type) ;; The form to evaluate to produce the SAP pointing to where in the heap ;; it is. - (sap-form (required-argument))) + (sap-form (missing-arg))) (def!method print-object ((info heap-alien-info) stream) (print-unreadable-object (info stream :type t) (funcall (formatter "~S ~S") @@ -469,90 +476,90 @@ ;;;; default methods -(def-alien-type-method (root :unparse) (type) +(define-alien-type-method (root :unparse) (type) `( ,(type-of type))) -(def-alien-type-method (root :type=) (type1 type2) +(define-alien-type-method (root :type=) (type1 type2) (declare (ignore type1 type2)) t) -(def-alien-type-method (root :subtypep) (type1 type2) +(define-alien-type-method (root :subtypep) (type1 type2) (alien-type-= type1 type2)) -(def-alien-type-method (root :lisp-rep) (type) +(define-alien-type-method (root :lisp-rep) (type) (declare (ignore type)) nil) -(def-alien-type-method (root :alien-rep) (type) +(define-alien-type-method (root :alien-rep) (type) (declare (ignore type)) '*) -(def-alien-type-method (root :naturalize-gen) (type alien) +(define-alien-type-method (root :naturalize-gen) (type alien) (declare (ignore alien)) (error "cannot represent ~S typed aliens" type)) -(def-alien-type-method (root :deport-gen) (type object) +(define-alien-type-method (root :deport-gen) (type object) (declare (ignore object)) (error "cannot represent ~S typed aliens" type)) -(def-alien-type-method (root :extract-gen) (type sap offset) +(define-alien-type-method (root :extract-gen) (type sap offset) (declare (ignore sap offset)) (error "cannot represent ~S typed aliens" type)) -(def-alien-type-method (root :deposit-gen) (type sap offset value) +(define-alien-type-method (root :deposit-gen) (type sap offset value) `(setf ,(invoke-alien-type-method :extract-gen type sap offset) ,value)) -(def-alien-type-method (root :arg-tn) (type state) +(define-alien-type-method (root :arg-tn) (type state) (declare (ignore state)) (error "Aliens of type ~S cannot be passed as arguments to CALL-OUT." (unparse-alien-type type))) -(def-alien-type-method (root :result-tn) (type state) +(define-alien-type-method (root :result-tn) (type state) (declare (ignore state)) (error "Aliens of type ~S cannot be returned from CALL-OUT." (unparse-alien-type type))) ;;;; the INTEGER type -(def-alien-type-class (integer) +(define-alien-type-class (integer) (signed t :type (member t nil))) -(def-alien-type-translator signed (&optional (bits sb!vm:word-bits)) +(define-alien-type-translator signed (&optional (bits sb!vm:n-word-bits)) (make-alien-integer-type :bits bits)) -(def-alien-type-translator integer (&optional (bits sb!vm:word-bits)) +(define-alien-type-translator integer (&optional (bits sb!vm:n-word-bits)) (make-alien-integer-type :bits bits)) -(def-alien-type-translator unsigned (&optional (bits sb!vm:word-bits)) +(define-alien-type-translator unsigned (&optional (bits sb!vm:n-word-bits)) (make-alien-integer-type :bits bits :signed nil)) -(def-alien-type-method (integer :unparse) (type) +(define-alien-type-method (integer :unparse) (type) (list (if (alien-integer-type-signed type) 'signed 'unsigned) (alien-integer-type-bits type))) -(def-alien-type-method (integer :type=) (type1 type2) +(define-alien-type-method (integer :type=) (type1 type2) (and (eq (alien-integer-type-signed type1) (alien-integer-type-signed type2)) (= (alien-integer-type-bits type1) (alien-integer-type-bits type2)))) -(def-alien-type-method (integer :lisp-rep) (type) +(define-alien-type-method (integer :lisp-rep) (type) (list (if (alien-integer-type-signed type) 'signed-byte 'unsigned-byte) (alien-integer-type-bits type))) -(def-alien-type-method (integer :alien-rep) (type) +(define-alien-type-method (integer :alien-rep) (type) (list (if (alien-integer-type-signed type) 'signed-byte 'unsigned-byte) (alien-integer-type-bits type))) -(def-alien-type-method (integer :naturalize-gen) (type alien) +(define-alien-type-method (integer :naturalize-gen) (type alien) (declare (ignore type)) alien) -(def-alien-type-method (integer :deport-gen) (type value) +(define-alien-type-method (integer :deport-gen) (type value) (declare (ignore type)) value) -(def-alien-type-method (integer :extract-gen) (type sap offset) +(define-alien-type-method (integer :extract-gen) (type sap offset) (declare (type alien-integer-type type)) (let ((ref-fun (if (alien-integer-type-signed type) @@ -560,52 +567,52 @@ (8 'signed-sap-ref-8) (16 'signed-sap-ref-16) (32 'signed-sap-ref-32) - #!+alpha (64 'signed-sap-ref-64)) + (64 'signed-sap-ref-64)) (case (alien-integer-type-bits type) (8 'sap-ref-8) (16 'sap-ref-16) (32 'sap-ref-32) - #!+alpha (64 'sap-ref-64))))) + (64 'sap-ref-64))))) (if ref-fun - `(,ref-fun ,sap (/ ,offset sb!vm:byte-bits)) - (error "cannot extract ~D bit integers" + `(,ref-fun ,sap (/ ,offset sb!vm:n-byte-bits)) + (error "cannot extract ~W-bit integers" (alien-integer-type-bits type))))) ;;;; the BOOLEAN type -(def-alien-type-class (boolean :include integer :include-args (signed))) +(define-alien-type-class (boolean :include integer :include-args (signed))) ;;; FIXME: Check to make sure that we aren't attaching user-readable ;;; stuff to CL:BOOLEAN in any way which impairs ANSI compliance. -(def-alien-type-translator boolean (&optional (bits sb!vm:word-bits)) +(define-alien-type-translator boolean (&optional (bits sb!vm:n-word-bits)) (make-alien-boolean-type :bits bits :signed nil)) -(def-alien-type-method (boolean :unparse) (type) +(define-alien-type-method (boolean :unparse) (type) `(boolean ,(alien-boolean-type-bits type))) -(def-alien-type-method (boolean :lisp-rep) (type) +(define-alien-type-method (boolean :lisp-rep) (type) (declare (ignore type)) `(member t nil)) -(def-alien-type-method (boolean :naturalize-gen) (type alien) +(define-alien-type-method (boolean :naturalize-gen) (type alien) (declare (ignore type)) `(not (zerop ,alien))) -(def-alien-type-method (boolean :deport-gen) (type value) +(define-alien-type-method (boolean :deport-gen) (type value) (declare (ignore type)) `(if ,value 1 0)) ;;;; the ENUM type -(def-alien-type-class (enum :include (integer (:bits 32)) - :include-args (signed)) +(define-alien-type-class (enum :include (integer (bits 32)) + :include-args (signed)) name ; name of this enum (if any) - from ; alist from keywords to integers. - to ; alist or vector from integers to keywords. - kind ; Kind of from mapping, :vector or :alist. - offset) ; Offset to add to value for :vector from mapping. + from ; alist from symbols to integers + to ; alist or vector from integers to symbols + kind ; kind of from mapping, :VECTOR or :ALIST + offset) ; offset to add to value for :VECTOR from mapping -(def-alien-type-translator enum (&whole +(define-alien-type-translator enum (&whole type name &rest mappings &environment env) @@ -642,8 +649,8 @@ (values (first el) (second el)) (values el (1+ prev))) (setf prev val) - (unless (keywordp sym) - (error "The enumeration element ~S is not a keyword." sym)) + (unless (symbolp sym) + (error "The enumeration element ~S is not a symbol." sym)) (unless (integerp val) (error "The element value ~S is not an integer." val)) (unless (and max (> max val)) (setq max val)) @@ -665,7 +672,7 @@ ;; If range is at least 20% dense, use vector mapping. Crossover ;; point solely on basis of space would be 25%. Vector mapping ;; is always faster, so give the benefit of the doubt. - ((< 0.2 (/ (float (length from-alist)) (float (- max min)))) + ((< 0.2 (/ (float (length from-alist)) (float (1+ (- max min))))) ;; If offset is small and ignorable, ignore it to save time. (when (< 0 min 10) (setq min 0)) (let ((to (make-array (1+ (- max min))))) @@ -677,122 +684,110 @@ (t (make-alien-enum-type :name name :signed signed :from from-alist - :to (mapcar #'(lambda (x) (cons (cdr x) (car x))) + :to (mapcar (lambda (x) (cons (cdr x) (car x))) from-alist) :kind :alist)))))) -(def-alien-type-method (enum :unparse) (type) +(define-alien-type-method (enum :unparse) (type) `(enum ,(alien-enum-type-name type) ,@(let ((prev -1)) - (mapcar #'(lambda (mapping) - (let ((sym (car mapping)) - (value (cdr mapping))) - (prog1 - (if (= (1+ prev) value) - sym - `(,sym ,value)) - (setf prev value)))) + (mapcar (lambda (mapping) + (let ((sym (car mapping)) + (value (cdr mapping))) + (prog1 + (if (= (1+ prev) value) + sym + `(,sym ,value)) + (setf prev value)))) (alien-enum-type-from type))))) -(def-alien-type-method (enum :type=) (type1 type2) +(define-alien-type-method (enum :type=) (type1 type2) (and (eq (alien-enum-type-name type1) (alien-enum-type-name type2)) (equal (alien-enum-type-from type1) (alien-enum-type-from type2)))) -(def-alien-type-method (enum :lisp-rep) (type) +(define-alien-type-method (enum :lisp-rep) (type) `(member ,@(mapcar #'car (alien-enum-type-from type)))) -(def-alien-type-method (enum :naturalize-gen) (type alien) +(define-alien-type-method (enum :naturalize-gen) (type alien) (ecase (alien-enum-type-kind type) (:vector `(svref ',(alien-enum-type-to type) (+ ,alien ,(alien-enum-type-offset type)))) (:alist `(ecase ,alien - ,@(mapcar #'(lambda (mapping) - `(,(car mapping) ,(cdr mapping))) + ,@(mapcar (lambda (mapping) + `(,(car mapping) ',(cdr mapping))) (alien-enum-type-to type)))))) -(def-alien-type-method (enum :deport-gen) (type value) +(define-alien-type-method (enum :deport-gen) (type value) `(ecase ,value - ,@(mapcar #'(lambda (mapping) - `(,(car mapping) ,(cdr mapping))) + ,@(mapcar (lambda (mapping) + `(,(car mapping) ,(cdr mapping))) (alien-enum-type-from type)))) ;;;; the FLOAT types -(def-alien-type-class (float) - (type (required-argument) :type symbol)) +(define-alien-type-class (float) + (type (missing-arg) :type symbol)) -(def-alien-type-method (float :unparse) (type) +(define-alien-type-method (float :unparse) (type) (alien-float-type-type type)) -(def-alien-type-method (float :lisp-rep) (type) +(define-alien-type-method (float :lisp-rep) (type) (alien-float-type-type type)) -(def-alien-type-method (float :alien-rep) (type) +(define-alien-type-method (float :alien-rep) (type) (alien-float-type-type type)) -(def-alien-type-method (float :naturalize-gen) (type alien) +(define-alien-type-method (float :naturalize-gen) (type alien) (declare (ignore type)) alien) -(def-alien-type-method (float :deport-gen) (type value) +(define-alien-type-method (float :deport-gen) (type value) (declare (ignore type)) value) -(def-alien-type-class (single-float :include (float (:bits 32)) - :include-args (type))) +(define-alien-type-class (single-float :include (float (bits 32)) + :include-args (type))) -(def-alien-type-translator single-float () +(define-alien-type-translator single-float () (make-alien-single-float-type :type 'single-float)) -(def-alien-type-method (single-float :extract-gen) (type sap offset) +(define-alien-type-method (single-float :extract-gen) (type sap offset) (declare (ignore type)) - `(sap-ref-single ,sap (/ ,offset sb!vm:byte-bits))) + `(sap-ref-single ,sap (/ ,offset sb!vm:n-byte-bits))) -(def-alien-type-class (double-float :include (float (:bits 64)) - :include-args (type))) +(define-alien-type-class (double-float :include (float (bits 64)) + :include-args (type))) -(def-alien-type-translator double-float () +(define-alien-type-translator double-float () (make-alien-double-float-type :type 'double-float)) -(def-alien-type-method (double-float :extract-gen) (type sap offset) +(define-alien-type-method (double-float :extract-gen) (type sap offset) (declare (ignore type)) - `(sap-ref-double ,sap (/ ,offset sb!vm:byte-bits))) - -#!+long-float -(def-alien-type-class (long-float :include (float (:bits #!+x86 96 - #!+sparc 128)) - :include-args (type))) - -#!+long-float -(def-alien-type-translator long-float () - (make-alien-long-float-type :type 'long-float)) + `(sap-ref-double ,sap (/ ,offset sb!vm:n-byte-bits))) -#!+long-float -(def-alien-type-method (long-float :extract-gen) (type sap offset) - (declare (ignore type)) - `(sap-ref-long ,sap (/ ,offset sb!vm:byte-bits))) ;;;; the POINTER type -(def-alien-type-class (pointer :include (alien-value (:bits - #!-alpha sb!vm:word-bits - #!+alpha 64))) +(define-alien-type-class (pointer :include (alien-value (bits + #!-alpha + sb!vm:n-word-bits + #!+alpha 64))) (to nil :type (or alien-type null))) -(def-alien-type-translator * (to &environment env) +(define-alien-type-translator * (to &environment env) (make-alien-pointer-type :to (if (eq to t) nil (parse-alien-type to env)))) -(def-alien-type-method (pointer :unparse) (type) +(define-alien-type-method (pointer :unparse) (type) (let ((to (alien-pointer-type-to type))) `(* ,(if to (%unparse-alien-type to) t)))) -(def-alien-type-method (pointer :type=) (type1 type2) +(define-alien-type-method (pointer :type=) (type1 type2) (let ((to1 (alien-pointer-type-to type1)) (to2 (alien-pointer-type-to type2))) (if to1 @@ -801,7 +796,7 @@ nil) (null to2)))) -(def-alien-type-method (pointer :subtypep) (type1 type2) +(define-alien-type-method (pointer :subtypep) (type1 type2) (and (alien-pointer-type-p type2) (let ((to1 (alien-pointer-type-to type1)) (to2 (alien-pointer-type-to type2))) @@ -811,7 +806,7 @@ t) (null to2))))) -(def-alien-type-method (pointer :deport-gen) (type value) +(define-alien-type-method (pointer :deport-gen) (type value) (/noshow "doing alien type method POINTER :DEPORT-GEN" type value) (values ;; FIXME: old version, highlighted a bug in xc optimization @@ -835,56 +830,57 @@ ;;;; the MEM-BLOCK type -(def-alien-type-class (mem-block :include alien-value)) +(define-alien-type-class (mem-block :include alien-value)) -(def-alien-type-method (mem-block :extract-gen) (type sap offset) +(define-alien-type-method (mem-block :extract-gen) (type sap offset) (declare (ignore type)) - `(sap+ ,sap (/ ,offset sb!vm:byte-bits))) + `(sap+ ,sap (/ ,offset sb!vm:n-byte-bits))) -(def-alien-type-method (mem-block :deposit-gen) (type sap offset value) - (let ((bits (alien-mem-block-type-bits type))) - (unless bits +(define-alien-type-method (mem-block :deposit-gen) (type sap offset value) + (let ((bytes (truncate (alien-mem-block-type-bits type) sb!vm:n-byte-bits))) + (unless bytes (error "can't deposit aliens of type ~S (unknown size)" type)) - `(sb!kernel:system-area-copy ,value 0 ,sap ,offset ',bits))) + `(sb!kernel:system-area-ub8-copy ,value 0 ,sap ,offset ',bytes))) ;;;; the ARRAY type -(def-alien-type-class (array :include mem-block) - (element-type (required-argument) :type alien-type) - (dimensions (required-argument) :type list)) +(define-alien-type-class (array :include mem-block) + (element-type (missing-arg) :type alien-type) + (dimensions (missing-arg) :type list)) + +(define-alien-type-translator array (ele-type &rest dims &environment env) -(def-alien-type-translator array (ele-type &rest dims &environment env) (when dims (unless (typep (first dims) '(or index null)) (error "The first dimension is not a non-negative fixnum or NIL: ~S" (first dims))) - (let ((loser (find-if-not #'(lambda (x) (typep x 'index)) + (let ((loser (find-if-not (lambda (x) (typep x 'index)) (rest dims)))) (when loser (error "A dimension is not a non-negative fixnum: ~S" loser)))) - (let ((type (parse-alien-type ele-type env))) + (let ((parsed-ele-type (parse-alien-type ele-type env))) (make-alien-array-type - :element-type type + :element-type parsed-ele-type :dimensions dims - :alignment (alien-type-alignment type) - :bits (if (and (alien-type-bits type) + :alignment (alien-type-alignment parsed-ele-type) + :bits (if (and (alien-type-bits parsed-ele-type) (every #'integerp dims)) - (* (align-offset (alien-type-bits type) - (alien-type-alignment type)) + (* (align-offset (alien-type-bits parsed-ele-type) + (alien-type-alignment parsed-ele-type)) (reduce #'* dims)))))) -(def-alien-type-method (array :unparse) (type) +(define-alien-type-method (array :unparse) (type) `(array ,(%unparse-alien-type (alien-array-type-element-type type)) ,@(alien-array-type-dimensions type))) -(def-alien-type-method (array :type=) (type1 type2) +(define-alien-type-method (array :type=) (type1 type2) (and (equal (alien-array-type-dimensions type1) (alien-array-type-dimensions type2)) (alien-type-= (alien-array-type-element-type type1) (alien-array-type-element-type type2)))) -(def-alien-type-method (array :subtypep) (type1 type2) +(define-alien-type-method (array :subtypep) (type1 type2) (and (alien-array-type-p type2) (let ((dim1 (alien-array-type-dimensions type1)) (dim2 (alien-array-type-dimensions type2))) @@ -900,8 +896,8 @@ (def!struct (alien-record-field (:make-load-form-fun sb!kernel:just-dump-it-normally)) - (name (required-argument) :type symbol) - (type (required-argument) :type alien-type) + (name (missing-arg) :type symbol) + (type (missing-arg) :type alien-type) (bits nil :type (or unsigned-byte null)) (offset 0 :type unsigned-byte)) (def!method print-object ((field alien-record-field) stream) @@ -912,43 +908,47 @@ (alien-record-field-name field) (alien-record-field-bits field)))) -(def-alien-type-class (record :include mem-block) +(define-alien-type-class (record :include mem-block) (kind :struct :type (member :struct :union)) (name nil :type (or symbol null)) (fields nil :type list)) -(def-alien-type-translator struct (name &rest fields &environment env) +(define-alien-type-translator struct (name &rest fields &environment env) (parse-alien-record-type :struct name fields env)) -(def-alien-type-translator union (name &rest fields &environment env) +(define-alien-type-translator union (name &rest fields &environment env) (parse-alien-record-type :union name fields env)) +;;; FIXME: This is really pretty horrible: we avoid creating new +;;; ALIEN-RECORD-TYPE objects when a live one is flitting around the +;;; system already. This way forwrd-references sans fields get get +;;; "updated" for free to contain the field info. Maybe rename +;;; MAKE-ALIEN-RECORD-TYPE to %MAKE-ALIEN-RECORD-TYPE and use +;;; ENSURE-ALIEN-RECORD-TYPE instead. --NS 20040729 (defun parse-alien-record-type (kind name fields env) (declare (type (or sb!kernel:lexenv null) env)) (cond (fields (let* ((old (and name (auxiliary-alien-type kind name env))) (old-fields (and old (alien-record-type-fields old)))) - (cond (old-fields - ;; KLUDGE: We can't easily compare the new fields - ;; against the old fields, since the old fields have - ;; already been parsed into an internal - ;; representation, so we just punt, assuming that - ;; they're consistent. -- WHN 200000505 - #| - (unless (equal fields old-fields) - ;; FIXME: Perhaps this should be a warning, and we - ;; should overwrite the old definition and proceed? - (error "mismatch in fields for ~S~% old ~S~% new ~S" - name old-fields fields)) - |# - old) - (t - (let ((new (make-alien-record-type :name name - :kind kind))) - (when name - (setf (auxiliary-alien-type kind name env) new)) - (parse-alien-record-fields new fields env) - new))))) + ;; KLUDGE: We can't easily compare the new fields + ;; against the old fields, since the old fields have + ;; already been parsed into an internal + ;; representation, so we just punt, assuming that + ;; they're consistent. -- WHN 200000505 + #| + (unless (equal fields old-fields) + ;; FIXME: Perhaps this should be a warning, and we + ;; should overwrite the old definition and proceed? + (error "mismatch in fields for ~S~% old ~S~% new ~S" + name old-fields fields)) + |# + (if old-fields + old + (let ((type (or old (make-alien-record-type :name name :kind kind)))) + (when (and name (not old)) + (setf (auxiliary-alien-type kind name env) type)) + (parse-alien-record-fields type fields env) + type)))) (name (or (auxiliary-alien-type kind name env) (setf (auxiliary-alien-type kind name env) @@ -993,7 +993,7 @@ (setf (alien-record-type-bits result) (align-offset total-bits overall-alignment)))) -(def-alien-type-method (record :unparse) (type) +(define-alien-type-method (record :unparse) (type) `(,(case (alien-record-type-kind type) (:struct 'struct) (:union 'union) @@ -1001,110 +1001,90 @@ ,(alien-record-type-name type) ,@(unless (member type *record-types-already-unparsed* :test #'eq) (push type *record-types-already-unparsed*) - (mapcar #'(lambda (field) - `(,(alien-record-field-name field) - ,(%unparse-alien-type (alien-record-field-type field)) - ,@(if (alien-record-field-bits field) - (list (alien-record-field-bits field))))) + (mapcar (lambda (field) + `(,(alien-record-field-name field) + ,(%unparse-alien-type (alien-record-field-type field)) + ,@(if (alien-record-field-bits field) + (list (alien-record-field-bits field))))) (alien-record-type-fields type))))) -;;; Test the record fields. The depth is limiting in case of cyclic -;;; pointers. -(defun record-fields-match (fields1 fields2 depth) - (declare (type list fields1 fields2) - (type (mod 64) depth)) - (labels ((record-type-= (type1 type2 depth) - (and (eq (alien-record-type-name type1) - (alien-record-type-name type2)) - (eq (alien-record-type-kind type1) - (alien-record-type-kind type2)) - (= (length (alien-record-type-fields type1)) - (length (alien-record-type-fields type2))) - (record-fields-match (alien-record-type-fields type1) - (alien-record-type-fields type2) - (1+ depth)))) - (pointer-type-= (type1 type2 depth) - (let ((to1 (alien-pointer-type-to type1)) - (to2 (alien-pointer-type-to type2))) - (if to1 - (if to2 - (type-= to1 to2 (1+ depth)) - nil) - (null to2)))) - (type-= (type1 type2 depth) - (cond ((and (alien-pointer-type-p type1) - (alien-pointer-type-p type2)) - (or (> depth 10) - (pointer-type-= type1 type2 depth))) - ((and (alien-record-type-p type1) - (alien-record-type-p type2)) - (record-type-= type1 type2 depth)) - (t - (alien-type-= type1 type2))))) - (do ((fields1-rem fields1 (rest fields1-rem)) - (fields2-rem fields2 (rest fields2-rem))) - ((or (eq fields1-rem fields2-rem) - (endp fields1-rem) (endp fields2-rem)) - (eq fields1-rem fields2-rem)) - (let ((field1 (first fields1-rem)) - (field2 (first fields2-rem))) - (declare (type alien-record-field field1 field2)) - (unless (and (eq (alien-record-field-name field1) - (alien-record-field-name field2)) - (eql (alien-record-field-bits field1) - (alien-record-field-bits field2)) - (eql (alien-record-field-offset field1) - (alien-record-field-offset field2)) - (let ((field1 (alien-record-field-type field1)) - (field2 (alien-record-field-type field2))) - (type-= field1 field2 (1+ depth)))) - (return nil)))))) - -(def-alien-type-method (record :type=) (type1 type2) +;;; Test the record fields. Keep a hashtable table of already compared +;;; types to detect cycles. +(defun record-fields-match-p (field1 field2) + (and (eq (alien-record-field-name field1) + (alien-record-field-name field2)) + (eql (alien-record-field-bits field1) + (alien-record-field-bits field2)) + (eql (alien-record-field-offset field1) + (alien-record-field-offset field2)) + (alien-type-= (alien-record-field-type field1) + (alien-record-field-type field2)))) + +(defvar *alien-type-matches* nil + "A hashtable used to detect cycles while comparing record types.") + +(define-alien-type-method (record :type=) (type1 type2) (and (eq (alien-record-type-name type1) (alien-record-type-name type2)) (eq (alien-record-type-kind type1) (alien-record-type-kind type2)) - (= (length (alien-record-type-fields type1)) - (length (alien-record-type-fields type2))) - (record-fields-match (alien-record-type-fields type1) - (alien-record-type-fields type2) 0))) + (eql (alien-type-bits type1) + (alien-type-bits type2)) + (eql (alien-type-alignment type1) + (alien-type-alignment type2)) + (flet ((match-fields (&optional old) + (setf (gethash type1 *alien-type-matches*) (cons type2 old)) + (every #'record-fields-match-p + (alien-record-type-fields type1) + (alien-record-type-fields type2)))) + (if *alien-type-matches* + (let ((types (gethash type1 *alien-type-matches*))) + (or (memq type2 types) (match-fields types))) + (let ((*alien-type-matches* (make-hash-table :test #'eq))) + (match-fields)))))) -;;;; the FUNCTION and VALUES types +;;;; the FUNCTION and VALUES alien types +;;; not documented in CMU CL:-( +;;; +;;; reverse engineering observations: +;;; * seems to be set when translating return values +;;; * seems to enable the translation of (VALUES), which is the +;;; Lisp idiom for C's return type "void" (which is likely +;;; why it's set when when translating return values) (defvar *values-type-okay* nil) -(def-alien-type-class (function :include mem-block) - (result-type (required-argument) :type alien-type) - (arg-types (required-argument) :type list) +(define-alien-type-class (fun :include mem-block) + (result-type (missing-arg) :type alien-type) + (arg-types (missing-arg) :type list) (stub nil :type (or null function))) -(def-alien-type-translator function (result-type &rest arg-types - &environment env) - (make-alien-function-type +(define-alien-type-translator function (result-type &rest arg-types + &environment env) + (make-alien-fun-type :result-type (let ((*values-type-okay* t)) (parse-alien-type result-type env)) :arg-types (mapcar (lambda (arg-type) (parse-alien-type arg-type env)) arg-types))) -(def-alien-type-method (function :unparse) (type) - `(function ,(%unparse-alien-type (alien-function-type-result-type type)) +(define-alien-type-method (fun :unparse) (type) + `(function ,(%unparse-alien-type (alien-fun-type-result-type type)) ,@(mapcar #'%unparse-alien-type - (alien-function-type-arg-types type)))) + (alien-fun-type-arg-types type)))) -(def-alien-type-method (function :type=) (type1 type2) - (and (alien-type-= (alien-function-type-result-type type1) - (alien-function-type-result-type type2)) - (= (length (alien-function-type-arg-types type1)) - (length (alien-function-type-arg-types type2))) +(define-alien-type-method (fun :type=) (type1 type2) + (and (alien-type-= (alien-fun-type-result-type type1) + (alien-fun-type-result-type type2)) + (= (length (alien-fun-type-arg-types type1)) + (length (alien-fun-type-arg-types type2))) (every #'alien-type-= - (alien-function-type-arg-types type1) - (alien-function-type-arg-types type2)))) + (alien-fun-type-arg-types type1) + (alien-fun-type-arg-types type2)))) -(def-alien-type-class (values) - (values (required-argument) :type list)) +(define-alien-type-class (values) + (values (missing-arg) :type list)) -(def-alien-type-translator values (&rest values &environment env) +(define-alien-type-translator values (&rest values &environment env) (unless *values-type-okay* (error "cannot use values types here")) (let ((*values-type-okay* nil)) @@ -1112,11 +1092,11 @@ :values (mapcar (lambda (alien-type) (parse-alien-type alien-type env)) values)))) -(def-alien-type-method (values :unparse) (type) +(define-alien-type-method (values :unparse) (type) `(values ,@(mapcar #'%unparse-alien-type (alien-values-type-values type)))) -(def-alien-type-method (values :type=) (type1 type2) +(define-alien-type-method (values :type=) (type1 type2) (and (= (length (alien-values-type-values type1)) (length (alien-values-type-values type2))) (every #'alien-type-= @@ -1132,13 +1112,15 @@ (def!struct (local-alien-info (:make-load-form-fun sb!kernel:just-dump-it-normally) (:constructor make-local-alien-info - (&key type force-to-memory-p))) + (&key type force-to-memory-p + &aux (force-to-memory-p (or force-to-memory-p + (alien-array-type-p type) + (alien-record-type-p type)))))) ;; the type of the local alien - (type (required-argument) :type alien-type) - ;; T if this local alien must be forced into memory. Using the ADDR macro + (type (missing-arg) :type alien-type) + ;; Must this local alien be forced into memory? Using the ADDR macro ;; on a local alien will set this. - (force-to-memory-p (or (alien-array-type-p type) (alien-record-type-p type)) - :type (member t nil))) + (force-to-memory-p nil :type (member t nil))) (def!method print-object ((info local-alien-info) stream) (print-unreadable-object (info stream :type t) (format stream @@ -1148,7 +1130,7 @@ ;;;; the ADDR macro -(sb!kernel:defmacro-mundanely addr (expr &environment env) +(defmacro-mundanely addr (expr &environment env) #!+sb-doc "Return an Alien pointer to the data addressed by Expr, which must be a call to SLOT or DEREF, or a reference to an Alien variable."