(defun guess-alignment (bits)
(cond ((null bits) nil)
- #!-(or x86 (and ppc darwin)) ((> bits 32) 64)
+ #!-(or (and x86 (not win32)) (and ppc darwin)) ((> bits 32) 64)
((> bits 16) 32)
((> bits 8) 16)
((> bits 1) 8)
(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))
(deposit-gen nil :type (or null function))
(naturalize-gen nil :type (or null function))
(deport-gen nil :type (or null function))
+ (deport-alloc-gen nil :type (or null function))
+ (deport-pin-p nil :type (or null function))
;; Cast?
(arg-tn nil :type (or null function))
(result-tn nil :type (or null function))
(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)
(:deposit-gen . alien-type-class-deposit-gen)
(:naturalize-gen . alien-type-class-naturalize-gen)
(:deport-gen . alien-type-class-deport-gen)
+ (:deport-alloc-gen . alien-type-class-deport-alloc-gen)
+ (:deport-pin-p . alien-type-class-deport-pin-p)
;; cast?
(:arg-tn . alien-type-class-arg-tn)
(:result-tn . alien-type-class-result-tn)))
(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)
`((%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)
;;;; 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)
(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)
(ignore ignore))
,form)))
+(defun compute-deport-alloc-lambda (type)
+ `(lambda (value ignore)
+ (declare (ignore ignore))
+ ,(invoke-alien-type-method :deport-alloc-gen type 'value)))
+
(defun compute-extract-lambda (type)
`(lambda (sap offset ignore)
(declare (type system-area-pointer sap)
(naturalize ,(invoke-alien-type-method :extract-gen type 'sap 'offset)
',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)
+ (loop for variable in variables
+ for type in types
+ when (invoke-alien-type-method :deport-pin-p type)
+ collect variable)))
+ (if pin-variables
+ `(with-pinned-objects ,pin-variables
+ ,@body)
+ `(progn
+ ,@body))))
+
(defun compute-deposit-lambda (type)
(declare (type alien-type type))
`(lambda (sap offset ignore value)
(declare (type system-area-pointer sap)
(type unsigned-byte offset)
(ignore ignore))
- (let ((value (deport value ',type)))
- ,(invoke-alien-type-method :deposit-gen type 'sap 'offset 'value)
- ;; Note: the reason we don't just return the pre-deported value
- ;; is because that would inhibit any (deport (naturalize ...))
- ;; optimizations that might have otherwise happen. Re-naturalizing
- ;; the value might cause extra consing, but is flushable, so probably
- ;; results in better code.
- (naturalize value ',type))))
+ (let ((alloc-tmp (deport-alloc value ',type)))
+ (maybe-with-pinned-objects (alloc-tmp) (,type)
+ (let ((value (deport alloc-tmp ',type)))
+ ,(invoke-alien-type-method :deposit-gen type 'sap 'offset 'value)
+ ;; Note: the reason we don't just return the pre-deported value
+ ;; is because that would inhibit any (deport (naturalize ...))
+ ;; optimizations that might have otherwise happen. Re-naturalizing
+ ;; the value might cause extra consing, but is flushable, so probably
+ ;; results in better code.
+ (naturalize value ',type))))))
(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))
\f
;;;; default methods
(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)
(declare (ignore object))
(error "cannot represent ~S typed aliens" type))
+(define-alien-type-method (root :deport-alloc-gen) (type object)
+ (declare (ignore type))
+ object)
+
+(define-alien-type-method (root :deport-pin-p) (type)
+ (declare (ignore type))
+ ;; Override this method to return T for classes which take a SAP to a
+ ;; GCable lisp object when deporting.
+ nil)
+
(define-alien-type-method (root :extract-gen) (type sap offset)
(declare (ignore sap offset))
(error "cannot represent ~S typed aliens" 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)
- (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)
(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)
(unless (and max (> max val)) (setq max val))
(unless (and min (< min val)) (setq min val))
(when (rassoc val from-alist)
- (warn "The element value ~S is used more than once." val))
+ (style-warn "The element value ~S is used more than once." val))
(when (assoc sym from-alist :test #'eq)
(error "The enumeration element ~S is used more than once." sym))
(push (cons sym val) from-alist)))
(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)
(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))))
\f
;;;; the ARRAY type
;;; 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))
(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)
\f
;;;; 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)
-
(define-alien-type-class (fun :include mem-block)
(result-type (missing-arg) :type alien-type)
(arg-types (missing-arg) :type list)