X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fhost-alieneval.lisp;h=1f554c654885971f3e871f88d2fbb18574067a8f;hb=8ea7b1a452fc87f91273c96bead8aa862bbc8b98;hp=92c529c49496531361c0b22c04c46ac4cb453561;hpb=7098f5fa693c5d5e57742cc1e91c0a04eba87dbb;p=sbcl.git

diff --git a/src/code/host-alieneval.lisp b/src/code/host-alieneval.lisp
index 92c529c..1f554c6 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
@@ -329,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)
@@ -358,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)
@@ -398,15 +404,27 @@
              (: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")
+    (funcall (formatter "~S ~S~@[ (data)~]")
              stream
-             (heap-alien-info-sap-form info)
-             (unparse-alien-type (heap-alien-info-type info)))))
+             (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)))
 
 ;;;; Interfaces to the different methods
 
@@ -462,10 +480,10 @@
 (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)
+         ;; 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)
@@ -478,7 +496,7 @@
 
 (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))
@@ -496,8 +514,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
 
@@ -515,8 +536,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)
@@ -582,10 +603,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)
@@ -658,8 +694,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)
@@ -773,7 +817,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)
@@ -869,13 +914,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
 
@@ -962,41 +1009,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))
@@ -1015,34 +1066,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)
@@ -1160,7 +1214,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)