Skip to content
Browse files

Support MSVC 6.0 STL strings and vectors.

Incidentally support auto-detecting os type from symtables.
  • Loading branch information...
1 parent 153e11c commit 1d3646fa5f91150ec949d1548eaa630d23817664 @angavrilov committed Mar 27, 2012
Showing with 78 additions and 32 deletions.
  1. +13 −8 data-info/objects.lisp
  2. +1 −1 data-info/package.lisp
  3. +19 −14 data-info/type-context.lisp
  4. +17 −3 data-info/type-core.lisp
  5. +28 −6 data-info/type-stl.lisp
View
21 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)
View
2 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
))
View
33 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)))))
View
20 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
View
34 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)

0 comments on commit 1d3646f

Please sign in to comment.
Something went wrong with that request. Please try again.