Changeset 10519


Ignore:
Timestamp:
Aug 22, 2008, 12:53:55 PM (11 years 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.

Location:
trunk/source
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/lib/db-io.lisp

    r9243 r10519  
    506506
    507507
     508(defstruct (ffi-transparent-union (:include ffi-mem-block)
     509                                  (:constructor
     510                                   make-ffi-transparent-union (&key
     511                                                               string name
     512                                                               &aux
     513                                                               (anon-global-id
     514                                                                (unless name
     515                                                                  (concatenate 'string
     516                                                                               *ffi-prefix*
     517                                                                               "-" string)))))))
    508518(defstruct (ffi-struct (:include ffi-mem-block)
    509519                       (:constructor
     
    541551(defun ffi-union-reference (u)
    542552  (or (ffi-union-name u) (ffi-union-anon-global-id u)))
     553
     554(defun ffi-transparent-union-reference (u)
     555  (or (ffi-transparent-union-name u) (ffi-transparent-union-anon-global-id u)))
    543556
    544557(defstruct (ffi-function (:include ffi-type))
     
    591604                          (if (eql ch #\u)
    592605                            `(:union ,name)
    593                             name)))
     606                            (if (eql ch #\U)
     607                              `(:transparent-union ,name)
     608                              name))))
    594609                      (cdr (assoc ch *arg-spec-encoding*)))))
    595610          (if result
     
    11001115  (defconstant encoded-type-anon-union-ref 17) ; <tag>
    11011116  (defconstant encoded-type-bitfield-marker 18) ; <nbits>
     1117  (defconstant encoded-type-named-transparent-union-ref 19) ; <name>
     1118  (defconstant encoded-type-anon-transparent-union-ref 20)  ;<tag>
    11021119  )
    11031120
     
    11451162        ,@(encode-ffi-field-list (ffi-union-fields u)))
    11461163      `(,(logior encoded-type-anon-union-ref alt-align-in-bytes-mask)
     1164        ,@(encode-ffi-field-list (ffi-union-fields u))))))
     1165
     1166(defun encode-ffi-transparent-union (u)
     1167  (let* ((name (ffi-transparent-union-name u))
     1168         (alt-align-in-bytes-mask (ash (or (ffi-transparent-union-alt-alignment-bits u)
     1169                                           0)
     1170                                       (- 5 3))))
     1171    (if name
     1172      `(,(logior encoded-type-named-transparent-union-ref alt-align-in-bytes-mask)
     1173        ,@(encode-name name)
     1174        ,@(encode-ffi-field-list (ffi-union-fields u)))
     1175      `(,(logior encoded-type-anon-transparent-union-ref alt-align-in-bytes-mask)
    11471176        ,@(encode-ffi-field-list (ffi-union-fields u))))))
    11481177
     
    12891318             (logior encoded-type-anon-union-ref alt-align-bytes-mask))
    12901319        ,@(encode-name (ffi-union-reference u)))))
     1320     (:transparent-union
     1321      (let* ((u (cadr spec))
     1322             (name (ffi-transparent-union-name u))
     1323             (alt-align-bytes-mask (ash (or (ffi-union-alt-alignment-bits u)
     1324                                            0)
     1325                                        (- 5 3)))            )
     1326      `(,(if name
     1327             (logior encoded-type-named-transparent-union-ref alt-align-bytes-mask)
     1328             (logior encoded-type-anon-transparent-union-ref alt-align-bytes-mask))
     1329        ,@(encode-name (ffi-transparent-union-reference u)))))
    12911330     (:typedef
    12921331      `(,encoded-type-named-type-ref ,@(encode-name (ffi-typedef-name (cadr spec)))))
     
    13401379                      `(#\l)
    13411380                      '(#\?)))))))))))
    1342     ((:struct :union)
    1343      `(,(if (eq (car spec) :struct)
    1344                 #\r
    1345                 #\u)
     1381    ((:struct :union :transparent-union)
     1382     `(,(ecase (car spec)
     1383          (:struct #\r)
     1384          (:union #\u)
     1385          (:transparent-union #\U))
    13461386           ,@(encode-name (ffi-struct-reference (cadr spec)))))
    13471387    (:typedef
     
    14401480  (db-write-byte-list cdbm (ffi-union-reference u) (encode-ffi-union u)))
    14411481
     1482(defun save-ffi-transparent-union (cdbm u)
     1483  (db-write-byte-list cdbm (ffi-transparent-union-reference u) (encode-ffi-transparent-union u)))
    14421484
    14431485
     
    16311673                                                     :name name)))
    16321674                 qq)))
    1633       ((#.encoded-type-anon-struct-ref #.encoded-type-anon-union-ref)
     1675      (#.encoded-type-named-transparent-union-ref
     1676       (multiple-value-bind (name qq) (%decode-name buf q)
     1677         (let* ((already (info-foreign-type-union name)))
     1678           (when already
     1679             (setf (foreign-record-type-kind already) :transparent-union))
     1680           (values (or already
     1681                     (setf (info-foreign-type-union name)
     1682                           (make-foreign-record-type :kind :transparent-union
     1683                                                     :name name)))
     1684                 qq))))
     1685      ((#.encoded-type-anon-struct-ref
     1686        #.encoded-type-anon-union-ref
     1687        #.encoded-type-anon-transparent-union-ref)
    16341688       (multiple-value-bind (tag qq) (%decode-name buf q t)
    16351689         (values (load-record tag) qq))))))
     
    17171771                       (setf (foreign-record-field-offset field) offset))
    17181772                     (setq total-bits (+ offset bits))))
    1719           (:union (setq total-bits (max total-bits bits))))))
     1773          ((:union :transparent-union) (setq total-bits (max total-bits bits))))))
    17201774    (setf (foreign-record-type-fields rtype) parsed-fields
    17211775          (foreign-record-type-alignment rtype) (or
     
    17381792    (multiple-value-bind (name q)
    17391793        (case rcode
    1740           ((#.encoded-type-anon-struct-ref #.encoded-type-anon-union-ref)
     1794          ((#.encoded-type-anon-struct-ref
     1795            #.encoded-type-anon-union-ref
     1796            #.encoded-type-anon-transparent-union-ref)
    17411797           (values nil (1+ p)))
    17421798          (t
     
    17511807               (or (info-foreign-type-union name)
    17521808                   (setf (info-foreign-type-union name)
    1753                          (make-foreign-record-type :kind :union :name name))))
     1809                         (make-foreign-record-type :kind
     1810                                                   (if (eql rcode encoded-type-named-union-ref)
     1811                                                     :union
     1812                                                     :transparent-union)
     1813                                                   :name name))))
    17541814             (make-foreign-record-type
    17551815              :kind (if (eql rcode encoded-type-anon-struct-ref)
    17561816                      :struct
    1757                       :union)
     1817                      (if (eql rcode encoded-type-anon-union-ref)
     1818                        :union
     1819                        :transparent-union))
    17581820              :name name)))
    17591821       (%decode-field-list buf q ftd)
  • trunk/source/lib/foreign-types.lisp

    r10443 r10519  
    10151015
    10161016(def-foreign-type-class (record :include mem-block)
    1017   (kind :struct :type (member :struct :union))
     1017  (kind :struct :type (member :struct :union :transparent-union))
    10181018  (name nil :type (or symbol null))
    10191019  (fields nil :type list)
     
    10331033                    (ecase kind
    10341034                      (:struct (info-foreign-type-struct name ftd))
    1035                       (:union (info-foreign-type-union name ftd)))
     1035                      ((:union :transparent-union) (info-foreign-type-union name ftd)))
    10361036                    (case kind
    10371037                      (:struct (setf (info-foreign-type-struct name ftd)
    10381038                                     (make-foreign-record-type :name name :kind :struct)))
    1039                       (:union  (setf (info-foreign-type-union name ftd)
    1040                                      (make-foreign-record-type :name name :kind :union)))))
     1039                      ((:union :transparent-union)
     1040                       (setf (info-foreign-type-union name ftd)
     1041                                     (make-foreign-record-type :name name :kind kind)))))
    10411042                   (make-foreign-record-type :kind kind))))
    10421043    (when fields
     
    11021103                 (setf (foreign-record-field-bits parsed-field) bits)
    11031104                 (setf total-bits (+ offset bits))))
    1104               (:union
     1105              ((:union :transparent-union)
    11051106               (setf total-bits (max total-bits bits)))))))
    11061107      (values (parsed-fields)
     
    11241125       (:struct :struct)
    11251126       (:union :union)
     1127       (:transparent-union :transparent-union)
    11261128       (t '???))
    11271129    ,(foreign-record-type-name type)
     
    17801782      (parse-foreign-record-type :union name fields))
    17811783
     1784    (def-foreign-type-translator transparent-union (name &rest fields)
     1785      (parse-foreign-record-type :transparent-union name fields))
     1786
    17821787    (def-foreign-type-translator array (ele-type &rest dims)
    17831788      (when dims
  • trunk/source/library/parse-ffi.lisp

    r10045 r10519  
    4444(defvar *ffi-unions*)
    4545(defvar *ffi-global-unions* nil)
     46(defvar *ffi-transparent-unions* nil)
     47(defvar *ffi-global-transparent-unions* nil)
    4648(defvar *ffi-structs*)
    4749(defvar *ffi-global-structs* nil)
     
    7375                            :name (unless (digit-char-p (schar string 0))
    7476                                    (escape-foreign-name string))))))
     77
     78(defun find-or-create-ffi-transparent-union (string)
     79  (or (gethash string *ffi-transparent-unions*)
     80      (setf (gethash string *ffi-transparent-unions*)
     81            (make-ffi-transparent-union :string string
     82                                        :name (unless (digit-char-p (schar string 0))
     83                                                (escape-foreign-name string))))))
    7584
    7685(defun find-or-create-ffi-objc-class (string)
     
    358367    (:struct-ref (list :struct (find-or-create-ffi-struct (cadr spec))))
    359368    (:union-ref (list :union (find-or-create-ffi-union (cadr spec))))
     369    (:transparent-union-ref
     370     (list :transparent-union (find-or-create-ffi-transparent-union (cadr spec))))
    360371    (:enum-ref `(:primitive :signed))
    361372    (:function `(:primitive (* t)))
     
    425436      union)))
    426437
     438(defun process-ffi-transparent-union (form)
     439  (destructuring-bind (source-info string fields &optional alignform)
     440      (cdr form)
     441    (declare (ignore source-info))
     442    (let* ((union (find-or-create-ffi-transparent-union string)))
     443      (setf (ffi-transparent-union-ordinal union) (incf *ffi-ordinal*))
     444      (when alignform
     445        (setf (ffi-transparent-union-alt-alignment-bits union) (cadr alignform)))
     446      (unless (ffi-transparent-union-fields union)
     447        (setf (ffi-transparent-union-fields union)
     448              (process-ffi-fieldlist fields)))
     449      union)))
     450
    427451(defun process-ffi-struct (form)
    428452  (destructuring-bind (source-info string fields &optional alignform)
     
    541565    (:struct (ensure-struct-defined (cadr spec)))
    542566    (:union (ensure-union-defined (cadr spec)))
     567    (:transparent-union (ensure-transparent-union-defined (cadr spec)))
    543568    (:pointer (ensure-referenced-type-defined (cadr spec)))
    544569    (:array (ensure-referenced-type-defined (caddr spec)))
     
    567592  (when *ffi-global-unions*
    568593    (setf (gethash (ffi-union-reference u) *ffi-global-unions*) u)))
     594
     595(defun record-global-transparent-union (u)
     596  (when *ffi-global-transparent-unions*
     597    (setf (gethash (ffi-transparent-union-reference u) *ffi-global-transparent-unions*) u)))
    569598
    570599(defun define-union-from-ffi-info (u)
     
    576605        (ensure-fields-defined fields)))))
    577606
     607(defun define-transparent-union-from-ffi-info (u)
     608  (unless (ffi-transparent-union-defined u)
     609    (setf (ffi-transparent-union-defined u) t)
     610    (record-global-transparent-union u)
     611    (when (ffi-transparent-union-name u)
     612      (let* ((fields (ffi-transparent-union-fields u)))
     613        (ensure-fields-defined fields)))))
     614
    578615(defun ensure-union-defined (u)
    579616  (let* ((name (ffi-union-name u)))
     
    581618      (define-union-from-ffi-info u)
    582619      (ensure-fields-defined (ffi-union-fields u)))))
     620
     621(defun ensure-transparent-union-defined (u)
     622  (let* ((name (ffi-transparent-union-name u)))
     623    (if name
     624      (define-transparent-union-from-ffi-info u)
     625      (ensure-fields-defined (ffi-transparent-union-fields u)))))
    583626
    584627(defun record-global-struct (s)
     
    610653    (let* ((target (ffi-typedef-type def)))
    611654      (unless (and (consp target)
    612                    (member (car target) '(:struct :union :primitive)))
     655                   (member (car target) '(:struct :union :transparent-union :primitive)))
    613656        (ensure-referenced-type-defined target)))))
    614657
     
    630673(defun ffi-record-type-p (typeref)
    631674  (case (car typeref)
    632     ((:struct :union) t)
     675    ((:struct :union :transparent-union) t)
    633676    (:typedef (ffi-record-type-p (ffi-typedef-type (cadr typeref))))
    634677    (t nil)))
     
    659702  (let* ((*ffi-typedefs* (make-hash-table :test 'string= :hash-function 'sxhash))
    660703         (*ffi-unions* (make-hash-table :test 'string= :hash-function 'sxhash))
     704         (*ffi-transparent-unions* (make-hash-table :test 'string= :hash-function 'sxhash))
    661705         (*ffi-structs* (make-hash-table :test 'string= :hash-function 'sxhash))
    662706         (*ffi-objc-classes* (make-hash-table :test 'string= :hash-function 'sxhash))
     
    691735                (:enum-ident (push (process-ffi-enum-ident form) defined-constants))
    692736                (:enum (process-ffi-enum form))
    693                 (:union (push (process-ffi-union form) defined-types)))))
     737                (:union (push (process-ffi-union form) defined-types))
     738                (:transparent-union (push (process-ffi-transparent-union form) defined-types)))))
    694739          (multiple-value-bind (new-constants new-macros)
    695740              (process-defined-macros defined-macros (reverse defined-constants) argument-macros)
     
    706751                (ffi-struct (define-struct-from-ffi-info x))
    707752                (ffi-union (define-union-from-ffi-info x))
     753                (ffi-transparent-union (define-transparent-union-from-ffi-info x))
    708754                (ffi-typedef (define-typedef-from-ffi-info x))
    709755                (ffi-objc-class (define-objc-class-from-ffi-info x))))
     
    725771         (*ffi-global-typedefs* (make-hash-table :test 'string= :hash-function 'sxhash))
    726772         (*ffi-global-unions* (make-hash-table :test 'string= :hash-function 'sxhash))
     773         (*ffi-global-transparent-unions* (make-hash-table :test 'string= :hash-function 'sxhash))
    727774         (*ffi-global-structs* (make-hash-table :test 'string= :hash-function 'sxhash))
    728775         (*ffi-global-objc-classes* (make-hash-table :test 'string= :hash-function 'sxhash))
     
    757804                   (save-ffi-union records-cdbm def))
    758805               *ffi-global-unions*)
     806      (maphash #'(lambda (name def)
     807                   (declare (ignore name))
     808                   (save-ffi-transparent-union records-cdbm def))
     809               *ffi-global-transparent-unions*)
     810                         
    759811      (maphash #'(lambda (name def)
    760812                   (declare (ignore name))
Note: See TracChangeset for help on using the changeset viewer.