(defun guess-alignment (bits)
(cond ((null bits) nil)
- #!-(or x86 (and ppc darwin)) ((> bits 32) 64)
- ((> bits 16) 32)
- ((> bits 8) 16)
- ((> bits 1) 8)
- (t 1)))
+ #!-(or (and x86 (not win32)) (and ppc darwin)) ((> bits 32) 64)
+ ((> bits 16) 32)
+ ((> bits 8) 16)
+ ((> bits 1) 8)
+ (t 1)))
\f
;;;; ALIEN-TYPE-INFO stuff
(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))))
+ (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)))))
+ (setf (alien-type-class-include old) include)
+ (setf (gethash name *alien-type-classes*)
+ (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)))
(defun method-slot (method)
(cdr (or (assoc method *method-slot-alist*)
- (error "no method ~S" method))))
+ (error "no method ~S" method))))
) ; EVAL-WHEN
;;; We define a keyword "BOA" constructor so that we can reference the
;;; slot names in init forms.
(def!macro define-alien-type-class ((name &key include include-args)
- &rest slots)
+ &rest slots)
(let ((defstruct-name (symbolicate "ALIEN-" name "-TYPE")))
(multiple-value-bind (include include-defstruct overrides)
- (etypecase include
- (null
- (values nil 'alien-type nil))
- (symbol
- (values
- include
- (symbolicate "ALIEN-" include "-TYPE")
- nil))
- (list
- (values
- (car include)
- (symbolicate "ALIEN-" (car include) "-TYPE")
- (cdr include))))
+ (etypecase include
+ (null
+ (values nil 'alien-type nil))
+ (symbol
+ (values
+ include
+ (alien-type-class-defstruct-name
+ (alien-type-class-or-lose include))
+ nil))
+ (list
+ (values
+ (car include)
+ (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)))
- (def!struct (,defstruct-name
- (:include ,include-defstruct
- (class ',name)
- ,@overrides)
- (:constructor
- ,(symbolicate "MAKE-" defstruct-name)
- (&key class bits alignment
- ,@(mapcar (lambda (x)
- (if (atom x) x (car x)))
- slots)
- ,@include-args
- ;; KLUDGE
- &aux (alignment (or alignment (guess-alignment bits))))))
- ,@slots)))))
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ (create-alien-type-class-if-necessary ',name ',defstruct-name
+ ',(or include 'root)))
+ (def!struct (,defstruct-name
+ (:include ,include-defstruct
+ (class ',name)
+ ,@overrides)
+ (:constructor
+ ,(symbolicate "MAKE-" defstruct-name)
+ (&key class bits alignment
+ ,@(mapcar (lambda (x)
+ (if (atom x) x (car x)))
+ slots)
+ ,@include-args
+ ;; KLUDGE
+ &aux (alignment (or alignment (guess-alignment bits))))))
+ ,@slots)))))
(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
- ,@body)
+ ,@body)
(setf (,(method-slot method) (alien-type-class-or-lose ',class))
- #',defun-name))))
+ #',defun-name))))
(def!macro invoke-alien-type-method (method type &rest args)
(let ((slot (method-slot method)))
(once-only ((type type))
`(funcall (do ((class (alien-type-class-or-lose (alien-type-class ,type))
- (alien-type-class-include class)))
- ((null class)
- (error "method ~S not defined for ~S"
- ',method (alien-type-class ,type)))
- (let ((fn (,slot class)))
- (when fn
- (return fn))))
- ,type ,@args))))
+ (alien-type-class-include class)))
+ ((null class)
+ (error "method ~S not defined for ~S"
+ ',method (alien-type-class ,type)))
+ (let ((fn (,slot class)))
+ (when fn
+ (return fn))))
+ ,type ,@args))))
\f
;;;; type parsing and unparsing
(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
- ;; NIL, but global symbol-macros make me vaguely queasy, so
- ;; I do it this way instead.
- nil))))
+ result
+ ;; This is like having the global symbol-macro definition be
+ ;; NIL, but global symbol-macros make me vaguely queasy, so
+ ;; I do it this way instead.
+ nil))))
;;; Process stuff in a new scope.
(def!macro with-auxiliary-alien-types (env &body body)
``(symbol-macrolet ((&auxiliary-type-definitions&
- ,(append *new-auxiliary-types*
- (auxiliary-type-definitions ,env))))
+ ,(append *new-auxiliary-types*
+ (auxiliary-type-definitions ,env))))
,(let ((*new-auxiliary-types* nil))
- ,@body)))
+ ,@body)))
;;; Parse TYPE as an alien type specifier and return the resultant
;;; ALIEN-TYPE structure.
(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))
+ (unless translator
+ (error "unknown alien type: ~S" type))
+ (funcall translator type env))
(ecase (info :alien-type :kind type)
- (:primitive
- (let ((translator (info :alien-type :translator type)))
- (unless translator
- (error "no translator for primitive alien type ~S" type))
- (funcall translator (list type) env)))
- (:defined
- (or (info :alien-type :definition type)
- (error "no definition for alien type ~S" type)))
- (:unknown
- (error "unknown alien type: ~S" type)))))
+ (:primitive
+ (let ((translator (info :alien-type :translator type)))
+ (unless translator
+ (error "no translator for primitive alien type ~S" type))
+ (funcall translator (list type) env)))
+ (:defined
+ (or (info :alien-type :definition type)
+ (error "no definition for alien type ~S" type)))
+ (:unknown
+ (error "unknown alien type: ~S" type)))))
(defun auxiliary-alien-type (kind name env)
(declare (type (or sb!kernel:lexenv null) env))
(flet ((aux-defn-matches (x)
- (and (eq (first x) kind) (eq (second x) name))))
+ (and (eq (first x) kind) (eq (second x) name))))
(let ((in-auxiliaries
- (or (find-if #'aux-defn-matches *new-auxiliary-types*)
- (find-if #'aux-defn-matches (auxiliary-type-definitions env)))))
+ (or (find-if #'aux-defn-matches *new-auxiliary-types*)
+ (find-if #'aux-defn-matches (auxiliary-type-definitions env)))))
(if in-auxiliaries
- (values (third in-auxiliaries) t)
- (ecase kind
- (:struct
- (info :alien-type :struct name))
- (:union
- (info :alien-type :union name))
- (:enum
- (info :alien-type :enum name)))))))
+ (values (third in-auxiliaries) t)
+ (ecase kind
+ (:struct
+ (info :alien-type :struct name))
+ (:union
+ (info :alien-type :union name))
+ (:enum
+ (info :alien-type :enum name)))))))
(defun (setf auxiliary-alien-type) (new-value kind name env)
(declare (type (or sb!kernel:lexenv null) env))
(flet ((aux-defn-matches (x)
- (and (eq (first x) kind) (eq (second x) name))))
+ (and (eq (first x) kind) (eq (second x) name))))
(when (find-if #'aux-defn-matches *new-auxiliary-types*)
(error "attempt to multiply define ~A ~S" kind name))
(when (find-if #'aux-defn-matches (auxiliary-type-definitions env))
(destructuring-bind (kind name defn) info
(declare (ignore defn))
(when (ecase kind
- (:struct
- (info :alien-type :struct name))
- (:union
- (info :alien-type :union name))
- (:enum
- (info :alien-type :enum name)))
- (error "attempt to shadow definition of ~A ~S" kind name)))))
+ (:struct
+ (info :alien-type :struct name))
+ (:union
+ (info :alien-type :union name))
+ (:enum
+ (info :alien-type :enum name)))
+ (error "attempt to shadow definition of ~A ~S" kind name)))))
(defun unparse-alien-type (type)
#!+sb-doc
(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))))))
+ (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)
(with-auxiliary-alien-types env
(let ((alien-type (parse-alien-type type env)))
`(eval-when (:compile-toplevel :load-toplevel :execute)
- ,@(when *new-auxiliary-types*
- `((%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))
+ ,@(when *new-auxiliary-types*
+ `((%def-auxiliary-alien-types ',*new-auxiliary-types*)))
+ ,@(when name
+ `((%define-alien-type ',name ',alien-type)))))))
(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)))
- (unless (or (null old) (alien-type-= old defn))
- (warn
- "redefining ~A ~S to be:~% ~S,~%was:~% ~S"
- kind name defn old))
- (setf (info :alien-type ,kind name) defn))))
- (ecase kind
- (:struct (frob :struct))
- (:union (frob :union))
- (:enum (frob :enum)))))))
+ (macrolet ((frob (kind)
+ `(let ((old (info :alien-type ,kind name)))
+ (unless (or (null old) (alien-type-= old defn))
+ (warn
+ "redefining ~A ~S to be:~% ~S,~%was:~% ~S"
+ kind name defn old))
+ (setf (info :alien-type ,kind name) defn))))
+ (ecase kind
+ (:struct (frob :struct))
+ (:union (frob :union))
+ (:enum (frob :enum)))))))
(defun %define-alien-type (name new)
(ecase (info :alien-type :kind name)
(:primitive
(error "~S is a built-in alien type." name))
(:defined
(let ((old (info :alien-type :definition name)))
- (unless (or (null old) (alien-type-= new old))
- (warn "redefining ~S to be:~% ~S,~%was~% ~S"
- name
- (unparse-alien-type new)
- (unparse-alien-type old)))))
+ (unless (or (null old) (alien-type-= new old))
+ (warn "redefining ~S to be:~% ~S,~%was~% ~S"
+ name
+ (unparse-alien-type new)
+ (unparse-alien-type old)))))
(:unknown))
(setf (info :alien-type :definition name) new)
(setf (info :alien-type :kind name) :defined)
;;;; 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)
- (:constructor make-alien-type (&key class bits alignment
- &aux (alignment (or alignment (guess-alignment bits))))))
+ (:make-load-form-fun sb!kernel:just-dump-it-normally)
+ (: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 nil :type (or null unsigned-byte)))
(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)
;;;
;;; Information describing a heap-allocated alien.
(def!struct (heap-alien-info
- (:make-load-form-fun sb!kernel:just-dump-it-normally))
+ (:make-load-form-fun sb!kernel:just-dump-it-normally))
;; The type of this alien.
(type (missing-arg) :type alien-type)
- ;; The form to evaluate to produce the SAP pointing to where in the heap
- ;; it is.
- (sap-form (missing-arg)))
+ ;; Its name.
+ (alien-name (missing-arg) :type simple-string)
+ ;; Data or code?
+ (datap (missing-arg) :type boolean))
(def!method print-object ((info heap-alien-info) stream)
(print-unreadable-object (info stream :type t)
- (funcall (formatter "~S ~S")
- stream
- (heap-alien-info-sap-form info)
- (unparse-alien-type (heap-alien-info-type info)))))
+ (funcall (formatter "~S ~S~@[ (data)~]")
+ stream
+ (heap-alien-info-alien-name info)
+ (unparse-alien-type (heap-alien-info-type info))
+ (heap-alien-info-datap info))))
+
+;;; The form to evaluate to produce the SAP pointing to where in the heap
+;;; it is.
+(defun heap-alien-info-sap-form (info)
+ `(foreign-symbol-sap ,(heap-alien-info-alien-name info)
+ ,(heap-alien-info-datap info)))
+
+(defun heap-alien-info-sap (info)
+ (foreign-symbol-sap (heap-alien-info-alien-name info)
+ (heap-alien-info-datap info)))
\f
;;;; Interfaces to the different methods
"Return T iff TYPE1 and TYPE2 describe equivalent alien types."
(or (eq type1 type2)
(and (eq (alien-type-class type1)
- (alien-type-class type2))
- (invoke-alien-type-method :type= type1 type2))))
+ (alien-type-class type2))
+ (invoke-alien-type-method :type= type1 type2))))
(defun alien-subtype-p (type1 type2)
#!+sb-doc
(invoke-alien-type-method :deport-gen type 'value)
`(lambda (value ignore)
(declare (type ,(or value-type
- (compute-lisp-rep-type type)
- `(alien ,type))
- value)
- (ignore ignore))
+ (compute-lisp-rep-type type)
+ `(alien ,type))
+ value)
+ (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)
- (type unsigned-byte offset)
- (ignore ignore))
+ (type unsigned-byte offset)
+ (ignore ignore))
(naturalize ,(invoke-alien-type-method :extract-gen type 'sap 'offset)
- ',type)))
+ ',type)))
+
+(def!macro maybe-with-pinned-objects (variables types &body body)
+ (declare (ignorable variables types))
+ (let ((pin-variables
+ ;; Only pin things on GENCGC, since on CHENEYGC it'd imply
+ ;; disabling the GC. Which is something we don't want to do
+ ;; every time we're calling to C.
+ #!+gencgc
+ (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)
+ `(lambda (value sap offset ignore)
(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))))
+ (type unsigned-byte offset)
+ (ignore ignore))
+ (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))
(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)))
+ (unparse-alien-type type)))
(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)))
+ (unparse-alien-type type)))
\f
;;;; the INTEGER type
(define-alien-type-method (integer :unparse) (type)
(list (if (alien-integer-type-signed type) 'signed 'unsigned)
- (alien-integer-type-bits type)))
+ (alien-integer-type-bits type)))
(define-alien-type-method (integer :type=) (type1 type2)
(and (eq (alien-integer-type-signed type1)
- (alien-integer-type-signed type2))
+ (alien-integer-type-signed type2))
(= (alien-integer-type-bits type1)
- (alien-integer-type-bits type2))))
+ (alien-integer-type-bits type2))))
(define-alien-type-method (integer :lisp-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)
- (list (if (alien-integer-type-signed type) 'signed-byte 'unsigned-byte)
- (alien-integer-type-bits type)))
-
+ (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)
(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)
- (case (alien-integer-type-bits type)
- (8 'signed-sap-ref-8)
- (16 'signed-sap-ref-16)
- (32 'signed-sap-ref-32)
- (64 'signed-sap-ref-64))
- (case (alien-integer-type-bits type)
- (8 'sap-ref-8)
- (16 'sap-ref-16)
- (32 'sap-ref-32)
- (64 'sap-ref-64)))))
+ (if (alien-integer-type-signed type)
+ (case (alien-integer-type-bits type)
+ (8 'signed-sap-ref-8)
+ (16 'signed-sap-ref-16)
+ (32 'signed-sap-ref-32)
+ (64 'signed-sap-ref-64))
+ (case (alien-integer-type-bits type)
+ (8 'sap-ref-8)
+ (16 'sap-ref-16)
+ (32 'sap-ref-32)
+ (64 'sap-ref-64)))))
(if ref-fun
- `(,ref-fun ,sap (/ ,offset sb!vm:n-byte-bits))
- (error "cannot extract ~W-bit integers"
- (alien-integer-type-bits type)))))
+ `(,ref-fun ,sap (/ ,offset sb!vm:n-byte-bits))
+ (error "cannot extract ~W-bit integers"
+ (alien-integer-type-bits type)))))
\f
;;;; the BOOLEAN type
`(member t nil))
(define-alien-type-method (boolean :naturalize-gen) (type alien)
- (declare (ignore type))
- `(not (zerop ,alien)))
+ (let ((bits (alien-boolean-type-bits type)))
+ (if (= bits sb!vm:n-word-bits)
+ `(not (zerop ,alien))
+ `(logtest ,alien ,(ldb (byte bits 0) -1)))))
(define-alien-type-method (boolean :deport-gen) (type value)
(declare (ignore type))
;;;; the ENUM type
(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
+ :include-args (signed))
+ name ; name of this enum (if any)
+ 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
(define-alien-type-translator enum (&whole
- type name
- &rest mappings
- &environment env)
+ type name
+ &rest mappings
+ &environment env)
(cond (mappings
- (let ((result (parse-enum name mappings)))
- (when name
- (multiple-value-bind (old old-p)
- (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))
- result))
- (name
- (multiple-value-bind (result found)
- (auxiliary-alien-type :enum name env)
- (unless found
- (error "unknown enum type: ~S" name))
- result))
- (t
- (error "empty enum type: ~S" type))))
+ (let ((result (parse-enum name mappings)))
+ (when name
+ (multiple-value-bind (old old-p)
+ (auxiliary-alien-type :enum name env)
+ (when old-p
+ (unless (alien-type-= result old)
+ (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)
+ (auxiliary-alien-type :enum name env)
+ (unless found
+ (error "unknown enum type: ~S" name))
+ result))
+ (t
+ (error "empty enum type: ~S" type))))
(defun parse-enum (name elements)
(when (null elements)
(error "An enumeration must contain at least one element."))
(let ((min nil)
- (max nil)
- (from-alist ())
- (prev -1))
+ (max nil)
+ (from-alist ())
+ (prev -1))
(declare (list from-alist))
(dolist (el elements)
(multiple-value-bind (sym val)
- (if (listp el)
- (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 (integerp val)
- (error "The element value ~S is not an integer." val))
- (unless (and max (> max val)) (setq max val))
- (unless (and min (< min val)) (setq min val))
- (when (rassoc val from-alist)
- (error "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)))
+ (if (listp el)
+ (values (first el) (second el))
+ (values el (1+ prev)))
+ (setf prev val)
+ (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))
+ (unless (and min (< min val)) (setq min val))
+ (when (rassoc val from-alist)
+ (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)))
(let* ((signed (minusp min))
- (min-bits (if signed
- (1+ (max (integer-length min)
- (integer-length max)))
- (integer-length max))))
+ (min-bits (if signed
+ (1+ (max (integer-length min)
+ (integer-length max)))
+ (integer-length max))))
(when (> min-bits 32)
- (error "can't represent enums needing more than 32 bits"))
+ (error "can't represent enums needing more than 32 bits"))
(setf from-alist (sort from-alist #'< :key #'cdr))
(cond
;; 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))))
- ;; 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)))))
- (dolist (el from-alist)
- (setf (svref to (- (cdr el) min)) (car el)))
- (make-alien-enum-type :name name :signed signed
- :from from-alist :to to :kind
- :vector :offset (- 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)))))
+ (dolist (el from-alist)
+ (setf (svref to (- (cdr el) min)) (car el)))
+ (make-alien-enum-type :name name :signed signed
+ :from from-alist :to to :kind
+ :vector :offset (- min))))
(t
- (make-alien-enum-type :name name :signed signed
- :from from-alist
- :to (mapcar (lambda (x) (cons (cdr x) (car x)))
- from-alist)
- :kind :alist))))))
+ (make-alien-enum-type :name name :signed signed
+ :from from-alist
+ :to (mapcar (lambda (x) (cons (cdr x) (car x)))
+ from-alist)
+ :kind :alist))))))
(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))))
- (alien-enum-type-from 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))))
+ (alien-enum-type-from type)))))
(define-alien-type-method (enum :type=) (type1 type2)
(and (eq (alien-enum-type-name type1)
- (alien-enum-type-name type2))
+ (alien-enum-type-name type2))
(equal (alien-enum-type-from type1)
- (alien-enum-type-from type2))))
+ (alien-enum-type-from type2))))
(define-alien-type-method (enum :lisp-rep) (type)
`(member ,@(mapcar #'car (alien-enum-type-from type))))
(ecase (alien-enum-type-kind type)
(:vector
`(svref ',(alien-enum-type-to type)
- (+ ,alien ,(alien-enum-type-offset type))))
+ (+ ,alien ,(alien-enum-type-offset type))))
(:alist
`(ecase ,alien
- ,@(mapcar (lambda (mapping)
- `(,(car mapping) ,(cdr mapping)))
- (alien-enum-type-to type))))))
+ ,@(mapcar (lambda (mapping)
+ `(,(car mapping) ',(cdr mapping)))
+ (alien-enum-type-to type))))))
(define-alien-type-method (enum :deport-gen) (type value)
`(ecase ,value
,@(mapcar (lambda (mapping)
- `(,(car mapping) ,(cdr mapping)))
- (alien-enum-type-from type))))
+ `(,(car mapping) ,(cdr mapping)))
+ (alien-enum-type-from type))))
\f
;;;; the FLOAT types
(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)
value)
(define-alien-type-class (single-float :include (float (bits 32))
- :include-args (type)))
+ :include-args (type)))
(define-alien-type-translator single-float ()
(make-alien-single-float-type :type 'single-float))
`(sap-ref-single ,sap (/ ,offset sb!vm:n-byte-bits)))
(define-alien-type-class (double-float :include (float (bits 64))
- :include-args (type)))
+ :include-args (type)))
(define-alien-type-translator double-float ()
(make-alien-double-float-type :type 'double-float))
(declare (ignore type))
`(sap-ref-double ,sap (/ ,offset sb!vm:n-byte-bits)))
-#!+long-float
-(define-alien-type-class (long-float :include (float (bits #!+x86 96
- #!+sparc 128))
- :include-args (type)))
-
-#!+long-float
-(define-alien-type-translator long-float ()
- (make-alien-long-float-type :type 'long-float))
-
-#!+long-float
-(define-alien-type-method (long-float :extract-gen) (type sap offset)
- (declare (ignore type))
- `(sap-ref-long ,sap (/ ,offset sb!vm:n-byte-bits)))
\f
;;;; the POINTER type
(define-alien-type-class (pointer :include (alien-value (bits
- #!-alpha
- sb!vm:n-word-bits
- #!+alpha 64)))
+ #!-alpha
+ sb!vm:n-word-bits
+ #!+alpha 64)))
(to nil :type (or alien-type null)))
(define-alien-type-translator * (to &environment env)
(define-alien-type-method (pointer :unparse) (type)
(let ((to (alien-pointer-type-to type)))
`(* ,(if to
- (%unparse-alien-type to)
- t))))
+ (%unparse-alien-type to)
+ t))))
(define-alien-type-method (pointer :type=) (type1 type2)
(let ((to1 (alien-pointer-type-to type1))
- (to2 (alien-pointer-type-to type2)))
+ (to2 (alien-pointer-type-to type2)))
(if to1
- (if to2
- (alien-type-= to1 to2)
- nil)
- (null to2))))
+ (if to2
+ (alien-type-= to1 to2)
+ nil)
+ (null to2))))
(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)))
- (if to1
- (if to2
- (alien-subtype-p to1 to2)
- t)
- (null to2)))))
+ (to2 (alien-pointer-type-to type2)))
+ (if to1
+ (if to2
+ (alien-subtype-p to1 to2)
+ t)
+ (null to2)))))
(define-alien-type-method (pointer :deport-gen) (type value)
(/noshow "doing alien type method POINTER :DEPORT-GEN" type value)
(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 ((bits (alien-mem-block-type-bits type)))
(unless bits
(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
+ (truncate ,offset sb!vm:n-byte-bits)
+ ',(truncate bits sb!vm:n-byte-bits))))
\f
;;;; the ARRAY type
(when dims
(unless (typep (first dims) '(or index null))
(error "The first dimension is not a non-negative fixnum or NIL: ~S"
- (first dims)))
+ (first dims)))
(let ((loser (find-if-not (lambda (x) (typep x 'index))
- (rest dims))))
+ (rest dims))))
(when loser
- (error "A dimension is not a non-negative fixnum: ~S" loser))))
-
+ (error "A dimension is not a non-negative fixnum: ~S" loser))))
+
(let ((parsed-ele-type (parse-alien-type ele-type env)))
(make-alien-array-type
:element-type parsed-ele-type
:dimensions dims
:alignment (alien-type-alignment parsed-ele-type)
:bits (if (and (alien-type-bits parsed-ele-type)
- (every #'integerp dims))
- (* (align-offset (alien-type-bits parsed-ele-type)
- (alien-type-alignment parsed-ele-type))
- (reduce #'* dims))))))
+ (every #'integerp dims))
+ (* (align-offset (alien-type-bits parsed-ele-type)
+ (alien-type-alignment parsed-ele-type))
+ (reduce #'* dims))))))
(define-alien-type-method (array :unparse) (type)
`(array ,(%unparse-alien-type (alien-array-type-element-type type))
- ,@(alien-array-type-dimensions type)))
+ ,@(alien-array-type-dimensions type)))
(define-alien-type-method (array :type=) (type1 type2)
(and (equal (alien-array-type-dimensions type1)
- (alien-array-type-dimensions type2))
+ (alien-array-type-dimensions type2))
(alien-type-= (alien-array-type-element-type type1)
- (alien-array-type-element-type type2))))
+ (alien-array-type-element-type 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)))
- (and (= (length dim1) (length dim2))
- (or (and dim2
- (null (car dim2))
- (equal (cdr dim1) (cdr dim2)))
- (equal dim1 dim2))
- (alien-subtype-p (alien-array-type-element-type type1)
- (alien-array-type-element-type type2))))))
+ (dim2 (alien-array-type-dimensions type2)))
+ (and (= (length dim1) (length dim2))
+ (or (and dim2
+ (null (car dim2))
+ (equal (cdr dim1) (cdr dim2)))
+ (equal dim1 dim2))
+ (alien-subtype-p (alien-array-type-element-type type1)
+ (alien-array-type-element-type type2))))))
\f
;;;; the RECORD type
(def!struct (alien-record-field
- (:make-load-form-fun sb!kernel:just-dump-it-normally))
+ (:make-load-form-fun sb!kernel:just-dump-it-normally))
(name (missing-arg) :type symbol)
(type (missing-arg) :type alien-type)
(bits nil :type (or unsigned-byte null))
(def!method print-object ((field alien-record-field) stream)
(print-unreadable-object (field stream :type t)
(format stream
- "~S ~S~@[:~D~]"
- (alien-record-field-type field)
- (alien-record-field-name field)
- (alien-record-field-bits field))))
+ "~S ~S~@[:~D~]"
+ (alien-record-field-type field)
+ (alien-record-field-name field)
+ (alien-record-field-bits field))))
(define-alien-type-class (record :include mem-block)
(kind :struct :type (member :struct :union))
(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 forward-references sans fields 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)))))
- (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))
+ (overall-alignment 1)
+ (parsed-fields nil))
(dolist (field fields)
- (destructuring-bind (var type &optional bits) field
- (declare (ignore bits))
- (let* ((field-type (parse-alien-type type env))
- (bits (alien-type-bits field-type))
- (alignment (alien-type-alignment field-type))
- (parsed-field
- (make-alien-record-field :type field-type
- :name var)))
- (push parsed-field parsed-fields)
- (when (null bits)
- (error "unknown size: ~S" (unparse-alien-type field-type)))
- (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)
- (: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))))
+ (destructuring-bind (var type &key alignment bits offset) field
+ (declare (ignore bits))
+ (let* ((field-type (parse-alien-type type env))
+ (bits (alien-type-bits field-type))
+ (parsed-field
+ (make-alien-record-field :type field-type
+ :name var)))
+ (unless alignment
+ (setf alignment (alien-type-alignment field-type)))
+ (push parsed-field parsed-fields)
+ (when (null bits)
+ (error "unknown size: ~S" (unparse-alien-type field-type)))
+ (when (null alignment)
+ (error "unknown alignment: ~S" (unparse-alien-type field-type)))
+ (setf overall-alignment (max overall-alignment alignment))
+ (ecase kind
+ (:struct
+ (let ((offset (or 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)))))))
+ (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)))))
- (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))))))
+ (push type *record-types-already-unparsed*)
+ (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 :bits (alien-record-field-bits field)))
+ ,@(when (alien-record-field-offset field)
+ (list :offset (alien-record-field-offset field)))))
+
+;;; 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))
+ (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)))
+ (alien-record-type-kind type2))
+ (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))))))
\f
;;;; the FUNCTION and VALUES alien types
-;;; not documented in CMU CL:-(
+;;; Calling-convention spec, typically one of predefined keywords.
+;;; Add or remove as needed for target platform. It makes sense to
+;;; support :cdecl everywhere.
+;;;
+;;; Null convention is supposed to be platform-specific most-universal
+;;; callout convention. For x86, SBCL calls foreign functions in a way
+;;; allowing them to be either stdcall or cdecl; null convention is
+;;; appropriate here, as it is for specifying callbacks that could be
+;;; accepted by foreign code both in cdecl and stdcall form.
+(def!type calling-convention () `(or null (member :stdcall :cdecl)))
+
+;;; Convention could be a values type class, stored at result-type.
+;;; However, it seems appropriate only for epilogue-related
+;;; conventions, those not influencing incoming arg passing.
;;;
-;;; 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)
+;;; As of x86's :stdcall and :cdecl, supported by now, both are
+;;; epilogue-related, but future extensions (like :fastcall and
+;;; miscellaneous non-x86 stuff) might affect incoming argument
+;;; translation as well.
(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)))
+ (stub nil :type (or null function))
+ (convention nil :type calling-convention))
+
+;;; KLUDGE: non-intrusive, backward-compatible way to allow calling
+;;; convention specification for function types is unobvious.
+;;;
+;;; By now, `RESULT-TYPE' is allowed, but not required, to be a list
+;;; starting with a convention keyword; its second item is a real
+;;; result-type in this case. If convention is ever to become a part
+;;; of result-type, such a syntax can be retained.
(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)))
+ &environment env)
+ (multiple-value-bind (bare-result-type calling-convention)
+ (typecase result-type
+ ((cons calling-convention *)
+ (values (second result-type) (first result-type)))
+ (t result-type))
+ (make-alien-fun-type
+ :convention calling-convention
+ :result-type (let ((*values-type-okay* t))
+ (parse-alien-type bare-result-type env))
+ :arg-types (mapcar (lambda (arg-type) (parse-alien-type arg-type env))
+ arg-types))))
(define-alien-type-method (fun :unparse) (type)
- `(function ,(%unparse-alien-type (alien-fun-type-result-type type))
- ,@(mapcar #'%unparse-alien-type
- (alien-fun-type-arg-types type))))
+ `(function ,(let ((result-type
+ (%unparse-alien-type (alien-fun-type-result-type type)))
+ (convention (alien-fun-type-convention type)))
+ (if convention (list convention result-type)
+ result-type))
+ ,@(mapcar #'%unparse-alien-type
+ (alien-fun-type-arg-types type))))
(define-alien-type-method (fun :type=) (type1 type2)
(and (alien-type-= (alien-fun-type-result-type type1)
- (alien-fun-type-result-type type2))
+ (alien-fun-type-result-type type2))
+ (eq (alien-fun-type-convention type1)
+ (alien-fun-type-convention type2))
(= (length (alien-fun-type-arg-types type1))
- (length (alien-fun-type-arg-types type2)))
+ (length (alien-fun-type-arg-types type2)))
(every #'alien-type-=
- (alien-fun-type-arg-types type1)
- (alien-fun-type-arg-types type2))))
+ (alien-fun-type-arg-types type1)
+ (alien-fun-type-arg-types type2))))
(define-alien-type-class (values)
(values (missing-arg) :type list))
(let ((*values-type-okay* nil))
(make-alien-values-type
:values (mapcar (lambda (alien-type) (parse-alien-type alien-type env))
- values))))
+ values))))
(define-alien-type-method (values :unparse) (type)
`(values ,@(mapcar #'%unparse-alien-type
- (alien-values-type-values type))))
+ (alien-values-type-values type))))
(define-alien-type-method (values :type=) (type1 type2)
(and (= (length (alien-values-type-values type1))
- (length (alien-values-type-values type2)))
+ (length (alien-values-type-values type2)))
(every #'alien-type-=
- (alien-values-type-values type1)
- (alien-values-type-values type2))))
+ (alien-values-type-values type1)
+ (alien-values-type-values type2))))
\f
;;;; a structure definition needed both in the target and in the
;;;; cross-compilation host
;;; these structures and LOCAL-ALIEN and friends communicate
;;; information about how that local alien is represented.
(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
- &aux (force-to-memory-p (or force-to-memory-p
- (alien-array-type-p type)
- (alien-record-type-p type))))))
+ (:make-load-form-fun sb!kernel:just-dump-it-normally)
+ (:constructor make-local-alien-info
+ (&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 (missing-arg) :type alien-type)
;; Must this local alien be forced into memory? Using the ADDR macro
(def!method print-object ((info local-alien-info) stream)
(print-unreadable-object (info stream :type t)
(format stream
- "~:[~;(forced to stack) ~]~S"
- (local-alien-info-force-to-memory-p info)
- (unparse-alien-type (local-alien-info-type info)))))
+ "~:[~;(forced to stack) ~]~S"
+ (local-alien-info-force-to-memory-p info)
+ (unparse-alien-type (local-alien-info-type info)))))
\f
;;;; the ADDR macro
#!+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)
- (slot
- (cons '%slot-addr (cdr form)))
- (deref
- (cons '%deref-addr (cdr form)))
- (%heap-alien
- (cons '%heap-alien-addr (cdr form)))
- (local-alien
- (let ((info (let ((info-arg (second form)))
- (and (consp info-arg)
- (eq (car info-arg) 'quote)
- (second info-arg)))))
- (unless (local-alien-info-p info)
- (error "Something is wrong, LOCAL-ALIEN-INFO not found: ~S"
- form))
- (setf (local-alien-info-force-to-memory-p info) t))
- (cons '%local-alien-addr (cdr form)))))
- (symbol
- (let ((kind (info :variable :kind form)))
- (when (eq kind :alien)
- `(%heap-alien-addr ',(info :variable :alien-info form))))))
- (error "~S is not a valid L-value." form))))
+ (cons
+ (case (car form)
+ (slot
+ (cons '%slot-addr (cdr form)))
+ (deref
+ (cons '%deref-addr (cdr form)))
+ (%heap-alien
+ (cons '%heap-alien-addr (cdr form)))
+ (local-alien
+ (let ((info (let ((info-arg (second form)))
+ (and (consp info-arg)
+ (eq (car info-arg) 'quote)
+ (second info-arg)))))
+ (unless (local-alien-info-p info)
+ (error "Something is wrong, LOCAL-ALIEN-INFO not found: ~S"
+ form))
+ (setf (local-alien-info-force-to-memory-p info) t))
+ (cons '%local-alien-addr (cdr form)))))
+ (symbol
+ (let ((kind (info :variable :kind form)))
+ (when (eq kind :alien)
+ `(%heap-alien-addr ',(info :variable :alien-info form))))))
+ (error "~S is not a valid L-value." form))))
(/show0 "host-alieneval.lisp end of file")