Changeset 10519

Timestamp:

08/22/08 08:53:55 (3 months ago)

Author:

gb

Message:

Recognize "transparent unions" (unions with a specified attribute);
we treat them as a separate kind of foreign-record-type, but it'd
also work to treat them as unions with a bit set somewhere.

A transparent union is just like a union in all contexts except
the case where it's passed by value to a foreign function; in that
case, things behave as if the union's first field was passed. (For
this to work, all fields must be the same size and be of types
that're passed by the same calling conventions.)

Linux uses transparent unions for a few types in socket-related
functions (so we'll have to support them when we switch l1-sockets
to use foreign-function calls instead of syscalls.) Other platforms
don't seem to use them in their standard headers (but we should
probably support the concept, just in case.)

Getting information about transparent unions into the interface
database requires changes to the ffi translator; the changes
here (mostly) deal with encoding that info to and decoding it
from the .cdb files.

Files:

• trunk/source/lib/db-io.lisp (modified) (12 diffs)
• trunk/source/lib/foreign-types.lisp (modified) (5 diffs)
• trunk/source/library/parse-ffi.lisp (modified) (15 diffs)

trunk/source/lib/db-io.lisp

@@ -506 +506 @@
-
-
+(defstruct (ffi-transparent-union (:include ffi-mem-block)
+                                  (:constructor
+                                   make-ffi-transparent-union (&key
+                                                               string name
+                                                               &aux
+                                                               (anon-global-id
+                                                                (unless name
+                                                                  (concatenate 'string
+                                                                               *ffi-prefix*
+                                                                               "-" string)))))))
-(defstruct (ffi-struct (:include ffi-mem-block)
-                       (:constructor
@@ -541 +551 @@
-(defun ffi-union-reference (u)
-  (or (ffi-union-name u) (ffi-union-anon-global-id u)))
+
+(defun ffi-transparent-union-reference (u)
+  (or (ffi-transparent-union-name u) (ffi-transparent-union-anon-global-id u)))
-
-(defstruct (ffi-function (:include ffi-type))
@@ -591 +604 @@
-                          (if (eql ch #\u)
-                            `(:union ,name)
-
+
+
+
-                      (cdr (assoc ch *arg-spec-encoding*)))))
-          (if result
@@ -1100 +1115 @@
-  (defconstant encoded-type-anon-union-ref 17) ; <tag>
-  (defconstant encoded-type-bitfield-marker 18) ; <nbits>
+  (defconstant encoded-type-named-transparent-union-ref 19) ; <name>
+  (defconstant encoded-type-anon-transparent-union-ref 20)  ;<tag>
-  )
-
@@ -1145 +1162 @@
-        ,@(encode-ffi-field-list (ffi-union-fields u)))
-      `(,(logior encoded-type-anon-union-ref alt-align-in-bytes-mask)
+        ,@(encode-ffi-field-list (ffi-union-fields u))))))
+
+(defun encode-ffi-transparent-union (u)
+  (let* ((name (ffi-transparent-union-name u))
+         (alt-align-in-bytes-mask (ash (or (ffi-transparent-union-alt-alignment-bits u)
+                                           0)
+                                       (- 5 3))))
+    (if name
+      `(,(logior encoded-type-named-transparent-union-ref alt-align-in-bytes-mask)
+        ,@(encode-name name)
+        ,@(encode-ffi-field-list (ffi-union-fields u)))
+      `(,(logior encoded-type-anon-transparent-union-ref alt-align-in-bytes-mask)
-        ,@(encode-ffi-field-list (ffi-union-fields u))))))
-
@@ -1289 +1318 @@
-             (logior encoded-type-anon-union-ref alt-align-bytes-mask))
-        ,@(encode-name (ffi-union-reference u)))))
+     (:transparent-union
+      (let* ((u (cadr spec))
+             (name (ffi-transparent-union-name u))
+             (alt-align-bytes-mask (ash (or (ffi-union-alt-alignment-bits u)
+                                            0)
+                                        (- 5 3)))            )
+      `(,(if name
+             (logior encoded-type-named-transparent-union-ref alt-align-bytes-mask)
+             (logior encoded-type-anon-transparent-union-ref alt-align-bytes-mask))
+        ,@(encode-name (ffi-transparent-union-reference u)))))
-     (:typedef
-      `(,encoded-type-named-type-ref ,@(encode-name (ffi-typedef-name (cadr spec)))))
@@ -1340 +1379 @@
-                      `(#\l)
-                      '(#\?)))))))))))
-
-
-
-
+
+
+
+
+
-           ,@(encode-name (ffi-struct-reference (cadr spec)))))
-    (:typedef
@@ -1440 +1480 @@
-  (db-write-byte-list cdbm (ffi-union-reference u) (encode-ffi-union u)))
-
+(defun save-ffi-transparent-union (cdbm u)
+  (db-write-byte-list cdbm (ffi-transparent-union-reference u) (encode-ffi-transparent-union u)))
-
-
@@ -1631 +1673 @@
-                                                     :name name)))
-                 qq)))
-
+
+
+
+
+
+
+
+
+
+
+
+
+
-       (multiple-value-bind (tag qq) (%decode-name buf q t)
-         (values (load-record tag) qq))))))
@@ -1717 +1771 @@
-                       (setf (foreign-record-field-offset field) offset))
-                     (setq total-bits (+ offset bits))))
-:union
+(:union :transparent-union)
-    (setf (foreign-record-type-fields rtype) parsed-fields
-          (foreign-record-type-alignment rtype) (or
@@ -1738 +1792 @@
-    (multiple-value-bind (name q)
-        (case rcode
-
+
+
+
-           (values nil (1+ p)))
-          (t
@@ -1751 +1807 @@
-               (or (info-foreign-type-union name)
-                   (setf (info-foreign-type-union name)
-
+
+
+
+
+
-             (make-foreign-record-type
-              :kind (if (eql rcode encoded-type-anon-struct-ref)
-                      :struct
-
+
+
+
-              :name name)))
-       (%decode-field-list buf q ftd)

trunk/source/lib/foreign-types.lisp

@@ -1000 +1000 @@
-
-(def-foreign-type-class (record :include mem-block)
-
+ :transparent-union
-  (name nil :type (or symbol null))
-  (fields nil :type list)
@@ -1018 +1018 @@
-                    (ecase kind
-                      (:struct (info-foreign-type-struct name ftd))
-:union
+(:union :transparent-union)
-                    (case kind
-                      (:struct (setf (info-foreign-type-struct name ftd)
-                                     (make-foreign-record-type :name name :kind :struct)))
-
-
+
+
+
-                   (make-foreign-record-type :kind kind))))
-    (when fields
@@ -1087 +1088 @@
-                 (setf (foreign-record-field-bits parsed-field) bits)
-                 (setf total-bits (+ offset bits))))
-:union
+(:union :transparent-union)
-               (setf total-bits (max total-bits bits)))))))
-      (values (parsed-fields)
@@ -1109 +1110 @@
-       (:struct :struct)
-       (:union :union)
+       (:transparent-union :transparent-union)
-       (t '???))
-    ,(foreign-record-type-name type)
@@ -1762 +1764 @@
-      (parse-foreign-record-type :union name fields))
-
+    (def-foreign-type-translator transparent-union (name &rest fields)
+      (parse-foreign-record-type :transparent-union name fields))
+
-    (def-foreign-type-translator array (ele-type &rest dims)
-      (when dims

trunk/source/library/parse-ffi.lisp

@@ -44 +44 @@
-(defvar *ffi-unions*)
-(defvar *ffi-global-unions* nil)
+(defvar *ffi-transparent-unions* nil)
+(defvar *ffi-global-transparent-unions* nil)
-(defvar *ffi-structs*)
-(defvar *ffi-global-structs* nil)
@@ -73 +75 @@
-                            :name (unless (digit-char-p (schar string 0))
-                                    (escape-foreign-name string))))))
+
+(defun find-or-create-ffi-transparent-union (string)
+  (or (gethash string *ffi-transparent-unions*)
+      (setf (gethash string *ffi-transparent-unions*)
+            (make-ffi-transparent-union :string string
+                                        :name (unless (digit-char-p (schar string 0))
+                                                (escape-foreign-name string))))))
-
-(defun find-or-create-ffi-objc-class (string)
@@ -358 +367 @@
-    (:struct-ref (list :struct (find-or-create-ffi-struct (cadr spec))))
-    (:union-ref (list :union (find-or-create-ffi-union (cadr spec))))
+    (:transparent-union-ref
+     (list :transparent-union (find-or-create-ffi-transparent-union (cadr spec))))
-    (:enum-ref `(:primitive :signed))
-    (:function `(:primitive (* t)))
@@ -425 +436 @@
-      union)))
-
+(defun process-ffi-transparent-union (form)
+  (destructuring-bind (source-info string fields &optional alignform)
+      (cdr form)
+    (declare (ignore source-info))
+    (let* ((union (find-or-create-ffi-transparent-union string)))
+      (setf (ffi-transparent-union-ordinal union) (incf *ffi-ordinal*))
+      (when alignform
+        (setf (ffi-transparent-union-alt-alignment-bits union) (cadr alignform)))
+      (unless (ffi-transparent-union-fields union)
+        (setf (ffi-transparent-union-fields union)
+              (process-ffi-fieldlist fields)))
+      union)))
+
-(defun process-ffi-struct (form)
-  (destructuring-bind (source-info string fields &optional alignform)
@@ -541 +565 @@
-    (:struct (ensure-struct-defined (cadr spec)))
-    (:union (ensure-union-defined (cadr spec)))
+    (:transparent-union (ensure-transparent-union-defined (cadr spec)))
-    (:pointer (ensure-referenced-type-defined (cadr spec)))
-    (:array (ensure-referenced-type-defined (caddr spec)))
@@ -567 +592 @@
-  (when *ffi-global-unions*
-    (setf (gethash (ffi-union-reference u) *ffi-global-unions*) u)))
+
+(defun record-global-transparent-union (u)
+  (when *ffi-global-transparent-unions*
+    (setf (gethash (ffi-transparent-union-reference u) *ffi-global-transparent-unions*) u)))
-
-(defun define-union-from-ffi-info (u)
@@ -576 +605 @@
-        (ensure-fields-defined fields)))))
-
+(defun define-transparent-union-from-ffi-info (u)
+  (unless (ffi-transparent-union-defined u)
+    (setf (ffi-transparent-union-defined u) t)
+    (record-global-transparent-union u)
+    (when (ffi-transparent-union-name u)
+      (let* ((fields (ffi-transparent-union-fields u)))
+        (ensure-fields-defined fields)))))
+
-(defun ensure-union-defined (u)
-  (let* ((name (ffi-union-name u)))
@@ -581 +618 @@
-      (define-union-from-ffi-info u)
-      (ensure-fields-defined (ffi-union-fields u)))))
+
+(defun ensure-transparent-union-defined (u)
+  (let* ((name (ffi-transparent-union-name u)))
+    (if name
+      (define-transparent-union-from-ffi-info u)
+      (ensure-fields-defined (ffi-transparent-union-fields u)))))
-
-(defun record-global-struct (s)
@@ -610 +653 @@
-    (let* ((target (ffi-typedef-type def)))
-      (unless (and (consp target)
-
+transparent-union :
-        (ensure-referenced-type-defined target)))))
-
@@ -630 +673 @@
-(defun ffi-record-type-p (typeref)
-  (case (car typeref)
-
+ :transparent-union
-    (:typedef (ffi-record-type-p (ffi-typedef-type (cadr typeref))))
-    (t nil)))
@@ -659 +702 @@
-  (let* ((*ffi-typedefs* (make-hash-table :test 'string= :hash-function 'sxhash))
-         (*ffi-unions* (make-hash-table :test 'string= :hash-function 'sxhash))
+         (*ffi-transparent-unions* (make-hash-table :test 'string= :hash-function 'sxhash))
-         (*ffi-structs* (make-hash-table :test 'string= :hash-function 'sxhash))
-         (*ffi-objc-classes* (make-hash-table :test 'string= :hash-function 'sxhash)) 
@@ -691 +735 @@
-                (:enum-ident (push (process-ffi-enum-ident form) defined-constants))
-                (:enum (process-ffi-enum form))
-
+
+
-          (multiple-value-bind (new-constants new-macros)
-              (process-defined-macros defined-macros (reverse defined-constants) argument-macros)
@@ -706 +751 @@
-                (ffi-struct (define-struct-from-ffi-info x))
-                (ffi-union (define-union-from-ffi-info x))
+                (ffi-transparent-union (define-transparent-union-from-ffi-info x))
-                (ffi-typedef (define-typedef-from-ffi-info x))
-                (ffi-objc-class (define-objc-class-from-ffi-info x))))
@@ -725 +771 @@
-         (*ffi-global-typedefs* (make-hash-table :test 'string= :hash-function 'sxhash))
-         (*ffi-global-unions* (make-hash-table :test 'string= :hash-function 'sxhash))
+         (*ffi-global-transparent-unions* (make-hash-table :test 'string= :hash-function 'sxhash))
-         (*ffi-global-structs* (make-hash-table :test 'string= :hash-function 'sxhash))
-         (*ffi-global-objc-classes* (make-hash-table :test 'string= :hash-function 'sxhash))
@@ -757 +804 @@
-                   (save-ffi-union records-cdbm def))
-               *ffi-global-unions*)
+      (maphash #'(lambda (name def)
+                   (declare (ignore name))
+                   (save-ffi-transparent-union records-cdbm def))
+               *ffi-global-transparent-unions*)
+                         
-      (maphash #'(lambda (name def)
-                   (declare (ignore name))