X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fhost-alieneval.lisp;h=9c343d5b39d031a63d5d6c0c2ef53ac3a13d8fe6;hb=8d490a4d6b9d7f156cf503826b3e3195e6f3ad39;hp=7bab89b392cc83dc677e35763a3f2fbea5198560;hpb=e29e584efdc110f14698801ad1004f9a34a3b448;p=sbcl.git diff --git a/src/code/host-alieneval.lisp b/src/code/host-alieneval.lisp index 7bab89b..9c343d5 100644 --- a/src/code/host-alieneval.lisp +++ b/src/code/host-alieneval.lisp @@ -607,8 +607,8 @@ (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 + 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 @@ -649,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)) @@ -672,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))))) @@ -718,7 +718,7 @@ (:alist `(ecase ,alien ,@(mapcar (lambda (mapping) - `(,(car mapping) ,(cdr mapping))) + `(,(car mapping) ',(cdr mapping))) (alien-enum-type-to type)))))) (define-alien-type-method (enum :deport-gen) (type value) @@ -837,10 +837,10 @@ `(sap+ ,sap (/ ,offset sb!vm:n-byte-bits))) (define-alien-type-method (mem-block :deposit-gen) (type sap offset value) - (let ((bits (alien-mem-block-type-bits type))) - (unless bits + (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 @@ -1008,67 +1008,40 @@ (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)))))) +;;; 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 alien types