Ignore:
Timestamp:
Mar 17, 2007, 7:08:56 AM (13 years ago)
Author:
gb
Message:

Revert out of some of the changes that led to Trac bug #2.

Try hard to preserve identity of named foreign-record-types; check for field
redefinition earlier.

Use PARSE-FOREIGN-TYPE in load form for FOREIGN-RECORD-TYPE, so that we
go through the same interning (of named types) and field compatibility
checking. Move some of the FOREIGN-RECORD-TYPE definitions later in
the load order, since it's never really worked (doesn't enhance cross-compilation
to define them inside INSTALL-STANDARD-FOREIGN-TYPES, and since we now need
to be able to call PARSE-FOREIGN-TYPE, which can't work that early.
(Actually, it might work to call PARSE-FOREIGN-TYPE to define structure types
at load time, rather than dealing with the strange type constants introduced
in the expansion of DEF-FOREIGN-TYPE.)

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/objc-gf/ccl/lib/foreign-types.lisp

    r6043 r6052  
    7070  (ordinal max-canonical-foreign-type-ordinal)
    7171  (ordinal-lock (make-lock))
    72   (ordinal-types (make-hash-table :test #'eq :weak :key))
    73   (pointer-types (make-hash-table :test #'equalp))
    74   (array-types (make-hash-table :test #'equalp)))
     72  (ordinal-types (make-hash-table :test #'eq :weak :value))
     73  (pointer-types (make-hash-table :test #'eq))
     74  (array-types (make-hash-table :test #'equal)))
    7575
    7676
     
    197197
    198198  (defvar *foreign-type-classes* (make-hash-table :test #'eq))
    199  
     199
    200200  (defun info-foreign-type-translator (x &optional (ftd *target-ftd*))
    201201    (gethash (make-keyword x) (ftd-translators ftd)))
     
    210210 
    211211  (defun info-foreign-type-kind (x &optional (ftd *target-ftd*))
    212     (if (info-foreign-type-translator x)
     212    (if (info-foreign-type-translator x ftd)
    213213      :primitive
    214214      (or (gethash (make-keyword x) (ftd-kind-info ftd)) :unknown)))
     
    423423
    424424(defun auxiliary-foreign-type (kind name &optional (ftd *target-ftd*))
    425   (or
    426    (ecase kind
    427      (:struct
    428       (info-foreign-type-struct name ftd))
    429      (:union
    430       (info-foreign-type-union name ftd))
    431      (:enum
    432       (info-foreign-type-enum name ftd)))
    433    (flet ((aux-defn-matches (x)
    434             (and (eq (first x) kind) (eq (second x) name))))
    435      (let ((in-auxiliaries
    436             (or (find-if #'aux-defn-matches *new-auxiliary-types*)
    437                 (find-if #'aux-defn-matches *auxiliary-type-definitions*))))
    438        (if in-auxiliaries
    439          (values (third in-auxiliaries) t))))))
     425  (declare (ignore ftd))
     426  (flet ((aux-defn-matches (x)
     427           (and (eq (first x) kind) (eq (second x) name))))
     428    (let ((in-auxiliaries
     429           (or (find-if #'aux-defn-matches *new-auxiliary-types*)
     430               (find-if #'aux-defn-matches *auxiliary-type-definitions*))))
     431      (if in-auxiliaries
     432        (values (third in-auxiliaries) t)))))
    440433
    441434(defun %set-auxiliary-foreign-type (kind name defn &optional (ftd *target-ftd*))
     435  (declare (ignore ftd))
    442436  (flet ((aux-defn-matches (x)
    443437           (and (eq (first x) kind) (eq (second x) name))))
     
    447441      (error "Attempt to shadow definition of ~A ~S." kind name)))
    448442  (push (list kind name defn) *new-auxiliary-types*)
    449   (ecase kind
    450     (:struct
    451      (setf (info-foreign-type-struct name ftd) defn))
    452     (:union
    453      (setf (info-foreign-type-union name ftd) defn))
    454     (:enum
    455      (setf (info-foreign-type-enum name ftd) defn)))
    456443  defn)
    457444
     
    689676
    690677(defvar *unsigned-integer-types*
    691   (let* ((a (make-array 33)))
    692     (dotimes (i 33 a)
     678  (let* ((a (make-array 65)))
     679    (dotimes (i 65 a)
    693680      (setf (svref a i) (make-foreign-integer-type :signed nil
    694681                                                   :bits i
     
    699686
    700687(defvar *signed-integer-types*
    701   (let* ((a (make-array 33)))
    702     (dotimes (i 33 a)
     688  (let* ((a (make-array 65)))
     689    (dotimes (i 65 a)
    703690      (setf (svref a i) (make-foreign-integer-type :signed t
    704691                                                   :bits i
     
    709696         
    710697
    711 (defvar *bool-type* (make-foreign-integer-type :bits 8 :signed #+darwinppc-target t #-darwinppc-target nil))
     698(defvar *bool-type* (make-foreign-integer-type :bits 8 :signed #+darwin-target t #-darwin-target nil))
    712699
    713700                                                 
     
    922909   `(etypecase ,value
    923910      (null
    924        (int-sap 0))
     911       (%int-to-ptr 0))
    925912      (macptr
    926913       ,value)
     
    1012999  (alt-align nil :type (or unsigned-byte null)))
    10131000
    1014 
    1015 (defun parse-foreign-record-type (kind name fields)
    1016   (if fields
    1017     (let* ((old (and name (auxiliary-foreign-type kind name)))
    1018            (result (or old
    1019                        (make-foreign-record-type :name name :kind kind))))
    1020       (when (and name (not (eq old result)))
    1021         (setf (auxiliary-foreign-type kind name) result))
    1022       (parse-foreign-record-fields result fields)
    1023       result)
     1001(defmethod make-load-form ((r foreign-record-type) &optional environment)
     1002  (declare (ignore environment))
     1003  `(parse-foreign-type ',(unparse-foreign-type r)))
     1004
     1005
     1006(defun parse-foreign-record-type (kind name fields &optional (ftd *target-ftd*))
     1007  (let* ((result (if name
     1008                   (or
     1009                    (ecase kind
     1010                      (:struct (info-foreign-type-struct name ftd))
     1011                      (:union (info-foreign-type-union name ftd)))
     1012                    (case kind
     1013                      (:struct (setf (info-foreign-type-struct name ftd)
     1014                                     (make-foreign-record-type :name name :kind :struct)))
     1015                      (:union  (setf (info-foreign-type-union name ftd)
     1016                                     (make-foreign-record-type :name name :kind :union)))))
     1017                   (make-foreign-record-type :kind kind))))
     1018    (when fields
     1019      (multiple-value-bind (parsed-fields alignment bits)
     1020          (parse-field-list fields kind (foreign-record-type-alt-align result))
     1021        (let* ((old-fields (foreign-record-type-fields result)))
     1022          (setf (foreign-record-type-fields result) parsed-fields
     1023                (foreign-record-type-alignment result) alignment
     1024                (foreign-record-type-bits result) bits)
     1025          (when old-fields
     1026            (unless (record-fields-match old-fields parsed-fields 5)
     1027              (warn "Redefining ~a ~s fields to be:~%~s~%were~%~s"
     1028                    kind name parsed-fields old-fields))))))
    10241029    (if name
    1025       (or (auxiliary-foreign-type kind name)
    1026           (setf (auxiliary-foreign-type kind name)
    1027                 (make-foreign-record-type :name name :kind kind)))
    1028       (make-foreign-record-type :kind kind))))
     1030      (unless (eq (auxiliary-foreign-type kind name) result)
     1031        (setf (auxiliary-foreign-type kind name) result)))
     1032    result))
    10291033
    10301034;;; PARSE-FOREIGN-RECORD-FIELDS -- internal
     
    10331037;;; types.  RESULT holds the record type we are paring the fields of,
    10341038;;; and FIELDS is the list of field specifications.
    1035 ;;;
     1039;;;
     1040(defun parse-field-list (fields kind &optional alt-alignment)
     1041  (collect ((parsed-fields))
     1042    (let* ((total-bits 0)
     1043           (overall-alignment 1)
     1044           (first-field-p t)
     1045           (attributes (ftd-attributes *target-ftd*))
     1046           (poweropen-alignment (getf attributes :poweropen-alignment)))
     1047         
     1048      (dolist (field fields)
     1049        (destructuring-bind (var type &optional bits) field
     1050          (declare (ignore bits))
     1051          (let* ((field-type (parse-foreign-type type))
     1052                 (bits (ensure-foreign-type-bits field-type))
     1053                 (natural-alignment (foreign-type-alignment field-type))
     1054                 (alignment (if alt-alignment
     1055                              (min natural-alignment alt-alignment)
     1056                              (if poweropen-alignment
     1057                                (if first-field-p
     1058                                  (progn
     1059                                    (setq first-field-p nil)
     1060                                    natural-alignment)
     1061                                  (min 32 natural-alignment))
     1062                                natural-alignment)))
     1063                 (parsed-field
     1064                  (make-foreign-record-field :type field-type
     1065                                             :name var)))
     1066            (parsed-fields parsed-field)
     1067            (when (null bits)
     1068              (error "Unknown size: ~S"
     1069                     (unparse-foreign-type field-type)))
     1070            (when (null alignment)
     1071              (error "Unknown alignment: ~S"
     1072                     (unparse-foreign-type field-type)))
     1073            (setf overall-alignment (max overall-alignment (if (< alignment 8) 32 alignment)))
     1074            (ecase kind
     1075              (:struct
     1076               (let ((offset (align-offset total-bits alignment)))
     1077                 (setf (foreign-record-field-offset parsed-field) offset)
     1078                 (setf (foreign-record-field-bits parsed-field) bits)
     1079                 (setf total-bits (+ offset bits))))
     1080              (:union
     1081               (setf total-bits (max total-bits bits)))))))
     1082      (values (parsed-fields)
     1083              (or alt-alignment overall-alignment)
     1084              (align-offset total-bits (or alt-alignment overall-alignment))))))
     1085           
     1086
     1087
    10361088(defun parse-foreign-record-fields (result fields)
    10371089  (declare (type foreign-record-type result)
    10381090           (type list fields))
    1039   (let* ((total-bits 0)
    1040          (overall-alignment 1)
    1041          (parsed-fields nil)
    1042          (first-field-p t)
    1043          (alt-alignment (foreign-record-type-alt-align result))
    1044          (attributes (ftd-attributes *target-ftd*))
    1045          (poweropen-alignment (getf attributes :poweropen-alignment)))
    1046          
    1047     (dolist (field fields)
    1048       (destructuring-bind (var type &optional bits) field
    1049         (declare (ignore bits))
    1050         (let* ((field-type (parse-foreign-type type))
    1051                (bits (ensure-foreign-type-bits field-type))
    1052                (natural-alignment (foreign-type-alignment field-type))
    1053                (alignment (if alt-alignment
    1054                             (min natural-alignment alt-alignment)
    1055                             (if poweropen-alignment
    1056                               (if first-field-p
    1057                                 (progn
    1058                                   (setq first-field-p nil)
    1059                                   natural-alignment)
    1060                                 (min 32 natural-alignment))
    1061                               natural-alignment)))
    1062                (parsed-field
    1063                 (make-foreign-record-field :type field-type
    1064                                            :name var)))
    1065           (push parsed-field parsed-fields)
    1066           (when (null bits)
    1067             (error "Unknown size: ~S"
    1068                    (unparse-foreign-type field-type)))
    1069           (when (null alignment)
    1070             (error "Unknown alignment: ~S"
    1071                    (unparse-foreign-type field-type)))
    1072           (setf overall-alignment (max overall-alignment (if (< alignment 8) 32 alignment)))
    1073           (ecase (foreign-record-type-kind result)
    1074             (:struct
    1075              (let ((offset (align-offset total-bits alignment)))
    1076                (setf (foreign-record-field-offset parsed-field) offset)
    1077                (setf (foreign-record-field-bits parsed-field) bits)
    1078                (setf total-bits (+ offset bits))))
    1079             (:union
    1080              (setf total-bits (max total-bits bits)))))))
    1081     (let ((new (nreverse parsed-fields)))
    1082       (setf (foreign-record-type-fields result) new))
    1083     (setf (foreign-record-type-alignment result) (or alt-alignment
    1084                                                      overall-alignment))
    1085     (setf (foreign-record-type-bits result)
    1086           (align-offset total-bits (or alt-alignment overall-alignment)))))
     1091  (multiple-value-bind (parsed-fields alignment bits)
     1092      (parse-field-list fields (foreign-record-type-kind result) (foreign-record-type-alt-align result))
     1093    (setf (foreign-record-type-fields result) parsed-fields
     1094          (foreign-record-type-alignment result) alignment
     1095          (foreign-record-type-bits result) bits)))
     1096
    10871097
    10881098(def-foreign-type-method (record :unparse) (type)
     
    14151425           (container (fv.container fv)))
    14161426      (if addr
     1427        #+32-bit-target
    14171428        (format out " (#x~8,'0x) " (logand #xffffffff (%ptr-to-int addr)))
     1429        #+64-bit-target
     1430                (format out " (#x~168,'0x) " (logand #xfffffffffffffffff (%ptr-to-int addr)))
    14181431        (format out " {unresolved} "))
    14191432      (when (and container (or (not (typep container 'macptr))
     
    16141627          (accessors field-name))))))
    16151628
     1629
    16161630(defun canonicalize-foreign-type-ordinals (ftd)
    16171631  (let* ((canonical-ordinal 0))          ; used for :VOID
     
    16311645      (canonicalize-foreign-type-ordinal :address)
    16321646      (canonicalize-foreign-type-ordinal #-darwin-target
    1633                                          '(:struct :<D>l_info)
     1647                                         :<D>l_info
    16341648                                         #+darwin-target nil)
    16351649      (canonicalize-foreign-type-ordinal '(:struct :timespec))
     
    16461660      (canonicalize-foreign-type-ordinal '(:struct :in_addr))
    16471661      (canonicalize-foreign-type-ordinal '(:struct :cdb-datum))
    1648       (canonicalize-foreign-type-ordinal '(:struct :dbm-constant)))))
    1649                    
     1662      (canonicalize-foreign-type-ordinal '(:struct :dbm-constant))
     1663      (canonicalize-foreign-type-ordinal '(:* (:struct :hostent)))
     1664      )))
     1665
    16501666(defun install-standard-foreign-types (ftd)
    16511667  (let* ((*target-ftd* ftd)
    16521668         (natural-word-size (getf (ftd-attributes ftd) :bits-per-word)))
     1669
    16531670    (def-foreign-type-translator signed (&optional (bits 32))
    1654       (if (<= bits 32)
     1671      (if (<= bits 64)
    16551672        (svref *signed-integer-types* bits)
    16561673        (make-foreign-integer-type :bits bits)))
     
    16581675
    16591676    (def-foreign-type-translator integer (&optional (bits 32))
    1660       (if (<= bits 32)
     1677      (if (<= bits 64)
    16611678        (svref *signed-integer-types* bits)
    16621679        (make-foreign-integer-type :bits bits)))
    16631680
    16641681    (def-foreign-type-translator unsigned (&optional (bits 32))
    1665       (if (<= bits 32)
     1682      (if (<= bits 64)
    16661683        (svref *unsigned-integer-types* bits)
    16671684        (make-foreign-integer-type :bits bits :signed nil)))
     
    16961713                      (parse-foreign-type result-type))
    16971714       :arg-types (mapcar #'parse-foreign-type arg-types)))
     1715
    16981716    (def-foreign-type-translator struct (name &rest fields)
    16991717      (parse-foreign-record-type :struct name fields))
     
    17131731       
    17141732      (let* ((type (parse-foreign-type ele-type))
    1715             (pair (cons type dims)))
     1733             (pair (cons type dims)))
    17161734        (declare (dynamic-extent pair))
     1735        (ensure-foreign-type-bits type)
    17171736        (or (gethash pair (ftd-array-types *target-ftd*))
    17181737            (setf (gethash (cons type dims) (ftd-array-types *target-ftd*))
     
    17271746                                            (foreign-type-alignment type))
    17281747                              (reduce #'* dims))))))))
     1748
    17291749    (def-foreign-type-translator * (to)
    17301750      (let* ((to (if (eq to t) *void-foreign-type* (parse-foreign-type to))))
     1751        (ensure-foreign-type-bits to)
    17311752        (or (gethash to (ftd-pointer-types *target-ftd*))
    17321753            (setf (gethash to (ftd-pointer-types *target-ftd*))
     
    17341755                   :to to
    17351756                   :bits natural-word-size)))))
     1757   
    17361758    (def-foreign-type-translator boolean (&optional (bits 32))
    17371759      (make-foreign-boolean-type :bits bits :signed nil))
     1760
    17381761    (def-foreign-type signed-char (signed 8))
    17391762    (def-foreign-type signed-byte (signed 8))
     
    17681791      (%def-foreign-type :signed-long signed-long-type ftd)
    17691792      (%def-foreign-type :unsigned-long unsigned-long-type ftd))
    1770     ;;
    1771     ;; Defining the handful of foreign structures that are used
    1772     ;; to build OpenMCL here ensures that all backends see appropriate
    1773     ;; definitions of them.
    1774     ;;
    1775     (def-foreign-type nil
    1776         (struct :cdb-datum
    1777                 (:data (* t))
    1778                 (:size (:unsigned 32))))
    1779     (def-foreign-type nil
    1780         (:struct :dbm-constant
    1781                  (:class (:unsigned 32))
    1782                  (:pad (:unsigned 32))
    1783                  (:value
    1784                   (:union nil
    1785                           (:s32 (:signed 32))
    1786                           (:u32 (:unsigned 32))
    1787                           (:single-float :float)
    1788                           (:double-float :double)))))
    1789     ;; This matches the xframe-list struct definition in
    1790     ;; "ccl:lisp-kernel;constants.h"
    1791     (def-foreign-type nil
    1792         (struct :xframe-list
    1793                 (this (* t #|(struct :ucontext)|#))
    1794                 (prev (* (struct  :xframe-list)))))
    1795     (canonicalize-foreign-type-ordinals ftd)
    17961793    ))
    17971794
    17981795
    1799 (install-standard-foreign-types *host-ftd*)
    1800 
     1796
     1797
     1798
     1799
Note: See TracChangeset for help on using the changeset viewer.