X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fhost-alieneval.lisp;h=0009b68fbd379867d74dce737a3a8da7fb0ab137;hb=a7a4ca961ef0f587a2549bd9433eef7ddb845ab7;hp=328cff652bfa2991c0a6f9057da8aecd95ec637b;hpb=6fa968aaa8051da23cc3153a1c0e67addbea85f6;p=sbcl.git diff --git a/src/code/host-alieneval.lisp b/src/code/host-alieneval.lisp index 328cff6..0009b68 100644 --- a/src/code/host-alieneval.lisp +++ b/src/code/host-alieneval.lisp @@ -34,6 +34,7 @@ (defstruct (alien-type-class (:copier nil)) (name nil :type symbol) + (defstruct-name nil :type symbol) (include nil :type (or null alien-type-class)) (unparse nil :type (or null function)) (type= nil :type (or null function)) @@ -57,13 +58,15 @@ (or (gethash name *alien-type-classes*) (error "no alien type class ~S" name))) -(defun create-alien-type-class-if-necessary (name include) +(defun create-alien-type-class-if-necessary (name defstruct-name include) (let ((old (gethash name *alien-type-classes*)) (include (and include (alien-type-class-or-lose include)))) (if old (setf (alien-type-class-include old) include) (setf (gethash name *alien-type-classes*) - (make-alien-type-class :name name :include include))))) + (make-alien-type-class :name name + :defstruct-name defstruct-name + :include include))))) (defparameter *method-slot-alist* '((:unparse . alien-type-class-unparse) @@ -99,16 +102,19 @@ (symbol (values include - (symbolicate "ALIEN-" include "-TYPE") + (alien-type-class-defstruct-name + (alien-type-class-or-lose include)) nil)) (list (values (car include) - (symbolicate "ALIEN-" (car include) "-TYPE") + (alien-type-class-defstruct-name + (alien-type-class-or-lose (car include))) (cdr include)))) `(progn (eval-when (:compile-toplevel :load-toplevel :execute) - (create-alien-type-class-if-necessary ',name ',(or include 'root))) + (create-alien-type-class-if-necessary ',name ',defstruct-name + ',(or include 'root))) (def!struct (,defstruct-name (:include ,include-defstruct (class ',name) @@ -154,7 +160,7 @@ (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) + (%macroexpand '&auxiliary-type-definitions& env) (if expanded-p result ;; This is like having the global symbol-macro definition be @@ -285,9 +291,6 @@ `((%def-auxiliary-alien-types ',*new-auxiliary-types*))) ,@(when name `((%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 (#-sb-xc :compile-toplevel :load-toplevel :execute) (defun %def-auxiliary-alien-types (types) @@ -332,7 +335,7 @@ ;;;; the root alien type (eval-when (:compile-toplevel :load-toplevel :execute) - (create-alien-type-class-if-necessary 'root nil)) + (create-alien-type-class-if-necessary 'root 'alien-type nil)) (def!struct (alien-type (:make-load-form-fun sb!kernel:just-dump-it-normally) @@ -361,8 +364,8 @@ (declare (ignore type)) 'system-area-pointer) -(define-alien-type-method (system-area-pointer :alien-rep) (type) - (declare (ignore type)) +(define-alien-type-method (system-area-pointer :alien-rep) (type context) + (declare (ignore type context)) 'system-area-pointer) (define-alien-type-method (system-area-pointer :naturalize-gen) (type alien) @@ -463,15 +466,16 @@ ',type))) (def!macro maybe-with-pinned-objects (variables types &body body) + (declare (ignorable variables types)) (let ((pin-variables ;; Only pin things on x86/x86-64, since on non-conservative ;; gcs it'd imply disabling the GC. Which is something we ;; don't want to do every time we're calling to C. - #+(or x86 x86-64) + #!+(or x86 x86-64) (loop for variable in variables - for type in types - when (invoke-alien-type-method :deport-pin-p type) - collect variable))) + for type in types + when (invoke-alien-type-method :deport-pin-p type) + collect variable))) (if pin-variables `(with-pinned-objects ,pin-variables ,@body) @@ -498,8 +502,11 @@ (defun compute-lisp-rep-type (type) (invoke-alien-type-method :lisp-rep type)) -(defun compute-alien-rep-type (type) - (invoke-alien-type-method :alien-rep type)) +;;; CONTEXT is either :NORMAL (the default) or :RESULT (alien function +;;; return values). See the :ALIEN-REP method for INTEGER for +;;; details. +(defun compute-alien-rep-type (type &optional (context :normal)) + (invoke-alien-type-method :alien-rep type context)) ;;;; default methods @@ -517,8 +524,8 @@ (declare (ignore type)) nil) -(define-alien-type-method (root :alien-rep) (type) - (declare (ignore type)) +(define-alien-type-method (root :alien-rep) (type context) + (declare (ignore type context)) '*) (define-alien-type-method (root :naturalize-gen) (type alien) @@ -584,10 +591,25 @@ (list (if (alien-integer-type-signed type) 'signed-byte 'unsigned-byte) (alien-integer-type-bits 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))) - +(define-alien-type-method (integer :alien-rep) (type context) + ;; When returning integer values that are narrower than a machine + ;; register from a function, some platforms leave the higher bits of + ;; the register uninitialized. On those platforms, we use an + ;; alien-rep of the full register width when checking for purposes + ;; of return values and override the naturalize method to perform + ;; the sign extension (in compiler/target/c-call.lisp). + (ecase context + ((:normal #!-(or x86 x86-64) :result) + (list (if (alien-integer-type-signed type) 'signed-byte 'unsigned-byte) + (alien-integer-type-bits type))) + #!+(or x86 x86-64) + (:result + (list (if (alien-integer-type-signed type) 'signed-byte 'unsigned-byte) + sb!vm:n-word-bits)))) + +;;; As per the comment in the :ALIEN-REP method above, this is defined +;;; elsewhere for x86oids. +#!-(or x86 x86-64) (define-alien-type-method (integer :naturalize-gen) (type alien) (declare (ignore type)) alien) @@ -660,8 +682,16 @@ (auxiliary-alien-type :enum name env) (when old-p (unless (alien-type-= result old) - (warn "redefining alien enum ~S" name)))) - (setf (auxiliary-alien-type :enum name env) result)) + (cerror "Continue, clobbering the old definition" + "Incompatible alien enum type definition: ~S" name) + (setf (alien-type-from old) (alien-type-from result) + (alien-type-to old) (alien-type-to result) + (alien-type-kind old) (alien-type-kind result) + (alien-type-offset old) (alien-type-offset result) + (alien-type-signed old) (alien-type-signed result))) + (setf result old)) + (unless old-p + (setf (auxiliary-alien-type :enum name env) result)))) result)) (name (multiple-value-bind (result found) @@ -775,7 +805,8 @@ (define-alien-type-method (float :lisp-rep) (type) (alien-float-type-type type)) -(define-alien-type-method (float :alien-rep) (type) +(define-alien-type-method (float :alien-rep) (type context) + (declare (ignore context)) (alien-float-type-type type)) (define-alien-type-method (float :naturalize-gen) (type alien) @@ -871,13 +902,15 @@ (define-alien-type-method (mem-block :extract-gen) (type sap offset) (declare (ignore type)) - `(sap+ ,sap (/ ,offset sb!vm:n-byte-bits))) + `(sap+ ,sap (truncate ,offset sb!vm:n-byte-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 + (let ((bits (alien-mem-block-type-bits type))) + (unless bits (error "can't deposit aliens of type ~S (unknown size)" type)) - `(sb!kernel:system-area-ub8-copy ,value 0 ,sap ,offset ',bytes))) + `(sb!kernel:system-area-ub8-copy ,value 0 ,sap + (truncate ,offset sb!vm:n-byte-bits) + ',(truncate bits sb!vm:n-byte-bits)))) ;;;; the ARRAY type @@ -964,41 +997,45 @@ ;;; 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)))) - ;; 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) - (make-alien-record-type :name name :kind kind)))) - (t - (make-alien-record-type :kind kind)))) - -;;; This is used by PARSE-ALIEN-TYPE to parse the fields of struct and -;;; union types. RESULT holds the record type we are paring the fields -;;; of, and FIELDS is the list of field specifications. -(defun parse-alien-record-fields (result fields env) - (declare (type alien-record-type result) - (type list fields)) + (flet ((frob-type (type new-fields alignment bits) + (setf (alien-record-type-fields type) new-fields + (alien-record-type-alignment type) alignment + (alien-record-type-bits type) bits))) + (cond (fields + (multiple-value-bind (new-fields alignment bits) + (parse-alien-record-fields kind fields env) + (let* ((old (and name (auxiliary-alien-type kind name env))) + (old-fields (and old (alien-record-type-fields old)))) + (when (and old-fields + (notevery #'record-fields-match-p old-fields new-fields)) + (cerror "Continue, clobbering the old definition." + "Incompatible alien record type definition~%Old: ~S~%New: ~S" + (unparse-alien-type old) + `(,(unparse-alien-record-kind kind) + ,name + ,@(mapcar #'unparse-alien-record-field new-fields))) + (frob-type old new-fields alignment bits)) + (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)) + (frob-type type new-fields alignment bits) + type))))) + (name + (or (auxiliary-alien-type kind name env) + (setf (auxiliary-alien-type kind name env) + (make-alien-record-type :name name :kind kind)))) + (t + (make-alien-record-type :kind kind))))) + +;;; This is used by PARSE-ALIEN-TYPE to parse the fields of struct and union +;;; types. KIND is the kind we are paring the fields of, and FIELDS is the +;;; list of field specifications. +;;; +;;; Result is a list of field objects, overall alignment, and number of bits +(defun parse-alien-record-fields (kind fields env) + (declare (type list fields)) (let ((total-bits 0) (overall-alignment 1) (parsed-fields nil)) @@ -1017,34 +1054,37 @@ (when (null alignment) (error "unknown alignment: ~S" (unparse-alien-type field-type))) (setf overall-alignment (max overall-alignment alignment)) - (ecase (alien-record-type-kind result) + (ecase kind (:struct (let ((offset (align-offset total-bits alignment))) (setf (alien-record-field-offset parsed-field) offset) (setf total-bits (+ offset bits)))) (:union (setf total-bits (max total-bits bits))))))) - (let ((new (nreverse parsed-fields))) - (setf (alien-record-type-fields result) new)) - (setf (alien-record-type-alignment result) overall-alignment) - (setf (alien-record-type-bits result) - (align-offset total-bits overall-alignment)))) + (values (nreverse parsed-fields) + overall-alignment + (align-offset total-bits overall-alignment)))) (define-alien-type-method (record :unparse) (type) - `(,(case (alien-record-type-kind type) - (:struct 'struct) - (:union 'union) - (t '???)) + `(,(unparse-alien-record-kind (alien-record-type-kind type)) ,(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 #'unparse-alien-record-field (alien-record-type-fields type))))) +(defun unparse-alien-record-kind (kind) + (case kind + (:struct 'struct) + (:union 'union) + (t '???))) + +(defun unparse-alien-record-field (field) + `(,(alien-record-field-name field) + ,(%unparse-alien-type (alien-record-field-type field)) + ,@(when (alien-record-field-bits field) + (list (alien-record-field-bits field))))) + ;;; Test the record fields. Keep a hashtable table of already compared ;;; types to detect cycles. (defun record-fields-match-p (field1 field2) @@ -1162,7 +1202,7 @@ #!+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." - (let ((form (sb!xc:macroexpand expr env))) + (let ((form (%macroexpand expr env))) (or (typecase form (cons (case (car form)