Support MSVC 6.0 STL strings and vectors.

Incidentally support auto-detecting os type from symtables.

data-info/objects.lisp

@@ -24,8 +24,8 @@
    (is-code? nil :accessor t)
    (global nil :accessor t)))
 
-(defun get-executable-hashes (executable)
-  (loop for image in (all-images-of executable)
+(defun get-executable-hashes (images)
+  (loop for image in images
      for md5 = (md5-hash-of image)
      and ts = (binary-timestamp-of image)
      and reloc = (relocation-offset-of image)
@@ -35,9 +35,14 @@
 (defmethod initialize-instance :after ((mirror object-memory-mirror) &key)
   (awhen (process-of mirror)
     (setf (executable-hashes-of mirror)
-          (get-executable-hashes (executable-of mirror)))
-    (when (typep (origin-of (main-image-of (executable-of it)))
-                 'pe-executable-image)
+          (get-executable-hashes (all-images-of (executable-of mirror))))
+    ;; detect type from symtables
+    (rebuild-addr-table mirror
+                        (get-executable-hashes (list (main-image-of (executable-of mirror)))))
+    ;; detect type from executable type
+    (when (and (null (os-type-of mirror))
+               (typep (origin-of (main-image-of (executable-of it)))
+                      'pe-executable-image))
       (setf (os-type-of mirror) $windows))))
 
 (defun precompute-globals (mirror)
@@ -222,9 +227,9 @@
                (is-code? vinfo)
                (section-of tinfo)
                (not (is-code? tinfo)))
-      (if (eq (os-type-of context) $windows)
-          $tptr.pTypeDescriptor.name
-          $tptr.class_name))))
+      (typecase (os-context-of context)
+        (os-context/windows $tptr.pTypeDescriptor.name)
+        (os-context/linux $tptr.class_name)))))
 
 (defun detect-garbage (mirror value)
   (awhen (garbage-word-of mirror)

data-info/package.lisp

@@ -106,7 +106,7 @@
            #:find-stl-strings #:find-memory-strings
            #:begin-find-changes #:update-find-changes #:get-found-changes
            #:verify-object-sizes
-           #:os-type-of #:garbage-word-of
+           #:os-type-of #:os-context-of #:garbage-word-of
            #:export-csv
            ))
 

data-info/type-context.lisp

@@ -14,7 +14,7 @@
    (global-address-table (make-hash-table :test #'equal) :reader t)
    (executable-hashes nil :accessor t)
    (data-definition-files nil :accessor t)
-   (os-context (assoc-value *known-os-contexts* $linux) :accessor t)))
+   (os-context (make-instance 'os-context) :accessor t)))
 
 (defmethod os-type-of ((context type-context))
   (os-type-of (os-context-of context)))
@@ -192,11 +192,13 @@
   (:method (context (type class-type))
     (let ((name (or (original-name-of type)
                     (get-$-field-name (type-name-of type)))))
-      (ecase (os-type-of context)
-        ($windows (or (windows-mangling-of type)
-                      (format nil ".?AV~A@@" name)))
-        ($linux (or (linux-mangling-of type)
-                    (format nil "~A~A" (length name) name)))))))
+      (etypecase (os-context-of context)
+        (os-context/windows
+         (or (windows-mangling-of type)
+             (format nil ".?AV~A@@" name)))
+        (os-context/linux
+         (or (linux-mangling-of type)
+             (format nil "~A~A" (length name) name)))))))
 
 (defun compute-stable-subset (obj-list dep-table)
   (let ((ssubset (make-hash-table))
@@ -222,14 +224,18 @@
             (setf (gethash name hash) def)
             (format t "Would update ~A~%" (get-$-field-name name)))))
 
-(defun rebuild-addr-table (ctx table symtables hashes)
+(defun rebuild-addr-table (ctx hashes &aux (table (global-address-table-of ctx)))
   (clrhash table)
-  (dolist (entry symtables)
+  (dolist (entry *known-symtables*)
     (let ((symtab (cdr entry)))
-      (awhen (aand (equal (os-type-of ctx) (os-type-of symtab))
+      (awhen (aand (or (null (os-type-of ctx))
+                       (equal (os-type-of ctx) (os-type-of symtab)))
                    (loop for ct in (constraints-of symtab)
                       when (assoc-value hashes (value-of ct) :test #'equal)
                       return it))
+        (when (null (os-type-of ctx))
+          (format t "Detected OS type as ~A" (os-type-of symtab))
+          (setf (os-type-of ctx) (os-type-of symtab)))
         (dolist (element (elements-of symtab))
           (etypecase element
             (global-address
@@ -251,6 +257,10 @@
                              (same-pairs (processed-globals-of context) *known-globals*)))
            (ssubset (compute-stable-subset same-objs (strong-dep-table-of context)))
            (changed? nil))
+      ;; Update symbols
+      (when (< (last-symtables-version-of context) *known-symtables-version*)
+        (rebuild-addr-table context (executable-hashes-of context))
+        (setf (last-symtables-version-of context) *known-symtables-version*))
       ;; Update manglings
       (setf (known-classes-of context)
             (loop for (name . type) in *known-types*
@@ -276,11 +286,6 @@
                 (setf changed? t)
                 (lookup-global-in-context context name)))
         (setf (last-globals-version-of context) *known-globals-version*))
-      ;; Update symbols
-      (when (< (last-symtables-version-of context) *known-symtables-version*)
-        (rebuild-addr-table context (global-address-table-of context)
-                            *known-symtables* (executable-hashes-of context))
-        (setf (last-symtables-version-of context) *known-symtables-version*))
       ;; Finalize
       (clrhash (vtable-class-cache-of context)))))
 

data-info/type-core.lisp

@@ -201,19 +201,33 @@
 (def (class e) os-context/windows (os-context)
   ())
 
+(def (class e) os-context/msvc6 (os-context)
+  ())
+
+(def (class e) os-context/msvc2010 (os-context)
+  ())
+
+(def (class e) os-context/windows/msvc6 (os-context/msvc6 os-context/windows)
+  ())
+
+(def (class e) os-context/windows/msvc2010 (os-context/msvc2010 os-context/windows)
+  ())
+
 (defgeneric os-type-of (context)
   (:method ((ctx os-context)) nil)
   (:method ((ctx os-context/linux)) $linux)
-  (:method ((ctx os-context/windows)) $windows))
+  (:method ((ctx os-context/windows)) $windows)
+  (:method ((ctx os-context/windows/msvc6)) $windows-msvc6))
 
 (defgeneric os-context-of (context)
   (:method ((ctx os-context)) ctx))
 
 (defparameter *known-os-contexts*
   (macrolet ((ctx (name type)
                `(cons ,name (make-instance ',type))))
-    (list (ctx $windows os-context/windows)
-          (ctx $linux os-context/linux/gcc))))
+    (list (ctx $windows os-context/windows/msvc2010)
+          (ctx $linux os-context/linux/gcc)
+          (ctx $windows-msvc6 os-context/windows/msvc6))))
 
 ;; Type layout
 

data-info/type-stl.lisp

@@ -9,16 +9,22 @@
 (def (class* eas) stl-string/linux (stl-string ptr-string)
   ())
 
-(def (class* eas) stl-string/windows (stl-string)
+(def (class* eas) stl-string/msvc2010 (stl-string)
   ())
 
-(defmethod substitute-type-class ((context os-context/windows) (str stl-string))
-  (change-class str 'stl-string/windows))
+(def (class* eas) stl-string/msvc6 (stl-string)
+  ())
+
+(defmethod substitute-type-class ((context os-context/msvc2010) (str stl-string))
+  (change-class str 'stl-string/msvc2010))
+
+(defmethod substitute-type-class ((context os-context/msvc6) (str stl-string))
+  (change-class str 'stl-string/msvc6))
 
 (defmethod substitute-type-class ((context os-context/linux) (str stl-string))
   (change-class str 'stl-string/linux))
 
-(defmethod compute-effective-fields (context (type stl-string/windows))
+(defmethod compute-effective-fields (context (type stl-string/msvc2010))
   (list (make-instance 'compound :is-union t
                        :fields (list
                                 (make-instance 'static-string :name $buffer :size 16)
@@ -27,9 +33,18 @@
         (make-instance 'int32_t :name $capacity)
         (make-instance 'padding :name $pad :size 4)))
 
-(defmethod %memory-ref-$ ((type stl-string/windows) ref (key (eql t)))
+(defmethod %memory-ref-$ ((type stl-string/msvc2010) ref (key (eql t)))
   (if (< $ref.capacity 16) $ref.buffer $ref.ptr.value))
 
+(defmethod compute-effective-fields (context (type stl-string/msvc6))
+  (list (make-instance 'padding :name $pad :size 4)
+        (make-instance 'pointer :name $ptr :type-name $static-string)
+        (make-instance 'int32_t :name $length)
+        (make-instance 'int32_t :name $capacity)))
+
+(defmethod %memory-ref-$ ((type stl-string/msvc6) ref (key (eql t)))
+  $ref.ptr.value)
+
 ;; STL vector
 
 (defmethod compute-effective-fields ((context os-context/linux) (type stl-vector))
@@ -38,13 +53,20 @@
    (make-instance 'pointer :name $end)
    (make-instance 'pointer :name $block-end)))
 
-(defmethod compute-effective-fields ((context os-context/windows) (type stl-vector))
+(defmethod compute-effective-fields ((context os-context/msvc2010) (type stl-vector))
   (list
    (make-instance 'pointer :name $start)
    (make-instance 'pointer :name $end)
    (make-instance 'pointer :name $block-end)
    (make-instance 'padding :name $pad :size 4 :alignment 4)))
 
+(defmethod compute-effective-fields ((context os-context/msvc6) (type stl-vector))
+  (list
+   (make-instance 'padding :name $pad :size 4 :alignment 4)
+   (make-instance 'pointer :name $start)
+   (make-instance 'pointer :name $end)
+   (make-instance 'pointer :name $block-end)))
+
 (defun stl-vector-dimensions (ref elt-size &key (size-bias 0) size-override)
   (let* ((s $ref.start)
          (e $ref.end)