Changeset 6041

Timestamp:

Mar 14, 2007, 11:32:59 PM (18 years ago)

Author:

Gary Byers

Message:

Lots of changes for "ordinally" typed pointers; hard to bootstrap.

File:

• branches/objc-gf/ccl/lib/foreign-types.lisp (modified) (14 diffs)

branches/objc-gf/ccl/lib/foreign-types.lisp

@@ -37 +37 @@
             (interface-dir-name d)
             (interface-dir-subdir d))))
-  
+
+;;; We can't reference foreign types early in the cold load,
+;;; but we want things like RLET to be able to set a pointer's
+;;; type based on the foreign-type's "ordinal".  We therefore
+;;; seem to have to arrange that certain types have fixed,
+;;; "canonical" ordinals.  I doubt if we need more than a handful
+;;; of these, but let's burn 100
+
+(defconstant max-canonical-foreign-type-ordinal 100)
+
 ;;; This is intended to try to encapsulate foreign type stuff, to
 ;;; ease cross-compilation (among other things.)
@@ -58 +67 @@
   (ff-call-struct-return-by-implicit-arg-function ())
   (callback-bindings-function ())
-  (callback-return-value-function ()))
+  (callback-return-value-function ())
+  (ordinal max-canonical-foreign-type-ordinal)
+  (ordinal-lock (make-lock))
+  (ordinal-types (make-hash-table :test #'eq :weak :key))
+  (pointer-types (make-hash-table :test #'equalp)))
+
 
 
@@ -91 +105 @@
       *host-ftd*)
 
+(defun next-foreign-type-ordinal (&optional (ftd *target-ftd*))
+  (with-lock-grabbed ((ftd-ordinal-lock ftd))
+    (incf (ftd-ordinal ftd))))
+
+
 (defmacro do-interface-dirs ((dir &optional (ftd '*target-ftd*)) &body body)
   `(do-dll-nodes  (,dir (ftd-dirlist ,ftd))
@@ -183 +202 @@
     (setf (gethash (make-keyword x) (ftd-translators ftd)) val))
 
+  (defun note-foreign-type-ordinal (type ftd)
+    (let* ((ordinal (and type (foreign-type-ordinal type))))
+      (when (and ordinal (not (eql 0 ordinal)))
+        (with-lock-grabbed ((ftd-ordinal-lock ftd))
+          (setf (gethash ordinal (ftd-ordinal-types ftd)) type)))))
+  
   (defun info-foreign-type-kind (x &optional (ftd *target-ftd*))
     (if (info-foreign-type-translator x)
@@ -193 +218 @@
     (gethash (make-keyword x) (ftd-definitions ftd)))
   (defun (setf info-foreign-type-definition) (val x &optional (ftd *target-ftd*))
+    (note-foreign-type-ordinal val ftd)
     (setf (gethash (make-keyword x) (ftd-definitions ftd)) val))
   (defun clear-info-foreign-type-definition (x &optional (ftd *target-ftd*))
@@ -200 +226 @@
     (gethash (make-keyword x) (ftd-struct-definitions ftd)))
   (defun (setf info-foreign-type-struct) (val x &optional (ftd *target-ftd*))
+    (note-foreign-type-ordinal val ftd)
     (setf (gethash (make-keyword x) (ftd-struct-definitions ftd)) val))
 
@@ -205 +232 @@
     (gethash (make-keyword x) (ftd-union-definitions ftd)))
   (defun (setf info-foreign-type-union) (val x  &optional (ftd *target-ftd*))
+    (note-foreign-type-ordinal val ftd)
     (setf (gethash (make-keyword x) (ftd-union-definitions ftd)) val))
 
@@ -210 +238 @@
     (gethash (make-keyword x) (ftd-enum-definitions ftd)))
   (defun (setf info-foreign-type-enum) (val x &optional (ftd *target-ftd*))
+    (note-foreign-type-ordinal val ftd)
     (setf (gethash (make-keyword x) (ftd-enum-definitions ftd)) val))
 
@@ -322 +351 @@
 
 (defstruct (foreign-type
-            (:constructor make-foreign-type (&key class bits alignment))
+            (:constructor make-foreign-type (&key class bits alignment ordinal))
             (:print-object
              (lambda (s out)
@@ -329 +358 @@
   (class 'root :type symbol)
   (bits nil :type (or null unsigned-byte))
-  (alignment (guess-alignment bits) :type (or null unsigned-byte)))
+  (alignment (guess-alignment bits) :type (or null unsigned-byte))
+  (ordinal (next-foreign-type-ordinal)))
 
 
@@ -602 +632 @@
 ;;;; Default methods.
 
-(defvar *void-foreign-type* (make-foreign-type :class 'root :bits 0 :alignment 0))
+(defvar *void-foreign-type* (make-foreign-type :class 'root :bits 0 :alignment 0 :ordinal 0))
 
 (def-foreign-type-method (root :unparse) (type)
@@ -1583 +1613 @@
           (accessors field-name))))))
 
+(defun canonicalize-foreign-type-ordinals (ftd)
+  (let* ((canonical-ordinal 0))          ; used for :VOID
+    (flet ((canonicalize-foreign-type-ordinal (spec)
+             (let* ((new-ordinal (incf canonical-ordinal)))
+               (when spec
+                 (let* ((type (parse-foreign-type spec))
+                        (old-ordinal (foreign-type-ordinal type)))
+                   (unless (eql new-ordinal old-ordinal)
+                     (remhash old-ordinal (ftd-ordinal-types ftd))
+                     (setf (foreign-type-ordinal type) new-ordinal)
+                     (note-foreign-type-ordinal type ftd))))
+               new-ordinal)))
+      (canonicalize-foreign-type-ordinal :signed)
+      (canonicalize-foreign-type-ordinal :unsigned)
+      (canonicalize-foreign-type-ordinal :long)
+      (canonicalize-foreign-type-ordinal :address)
+      (canonicalize-foreign-type-ordinal #-darwin-target
+                                         '(:struct :<D>l_info)
+                                         #+darwin-target nil)
+      (canonicalize-foreign-type-ordinal '(:struct :timespec))
+      (canonicalize-foreign-type-ordinal '(:struct :timeval))
+      (canonicalize-foreign-type-ordinal '(:struct :sockaddr_in))
+      (canonicalize-foreign-type-ordinal '(:struct :sockaddr_un))
+      (canonicalize-foreign-type-ordinal '(:struct :linger))
+      (canonicalize-foreign-type-ordinal '(:struct :hostent))
+      (canonicalize-foreign-type-ordinal '(:array :unsigned-long 3))
+      (canonicalize-foreign-type-ordinal '(:* :char))
+      (canonicalize-foreign-type-ordinal '(:struct :stat))
+      (canonicalize-foreign-type-ordinal '(:struct :passwd))
+      (canonicalize-foreign-type-ordinal #+darwin-target '(:struct :host_basic_info) #-darwin-target nil)
+      (canonicalize-foreign-type-ordinal '(:struct :in_addr))
+      (canonicalize-foreign-type-ordinal '(:struct :cdb-datum))
+      (canonicalize-foreign-type-ordinal '(:struct :dbm-constant)))))
+                    
 (defun install-standard-foreign-types (ftd)
   (let* ((*target-ftd* ftd)
@@ -1658 +1722 @@
                     (reduce #'* dims))))))
     (def-foreign-type-translator * (to)
-      (make-foreign-pointer-type
-       :to (if (eq to t) *void-foreign-type* (parse-foreign-type to))
-       :bits natural-word-size))
+      (let* ((to (if (eq to t) *void-foreign-type* (parse-foreign-type to))))
+        (or (gethash to (ftd-pointer-types *target-ftd*))
+            (setf (gethash to (ftd-pointer-types *target-ftd*))
+                  (make-foreign-pointer-type
+                   :to to
+                   :bits natural-word-size)))))
     (def-foreign-type-translator boolean (&optional (bits 32))
       (make-foreign-boolean-type :bits bits :signed nil))
@@ -1720 +1787 @@
                 (this (* t #|(struct :ucontext)|#))
                 (prev (* (struct  :xframe-list)))))
+    (canonicalize-foreign-type-ordinals ftd)
     ))