From: Björn Lindqvist <bjourne@gmail.com>
Date: Thu, 9 Jul 2015 13:41:03 +0000 (+0200)
Subject: tools.image-analyzer.*: support for callstack reading
X-Git-Tag: unmaintained~2492
X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=f2a85d1b13169fef38f3ac61e620e62b3e7b4ba9

tools.image-analyzer.*: support for callstack reading
---

diff --git a/extra/tools/image-analyzer/data-heap-reader/data-heap-reader.factor b/extra/tools/image-analyzer/data-heap-reader/data-heap-reader.factor
index 67c5a3694b..0087dcd7a9 100644
--- a/extra/tools/image-analyzer/data-heap-reader/data-heap-reader.factor
+++ b/extra/tools/image-analyzer/data-heap-reader/data-heap-reader.factor
@@ -7,48 +7,51 @@ FROM: kernel => bi dup keep nip swap ;
 FROM: layouts => data-alignment ;
 FROM: math => + - * align neg shift ;
 
-: object-tag ( vm-object -- tag )
+: object-tag ( object -- tag )
     header>> 5 2 bit-range ;
 
 GENERIC: read-payload ( rel-base struct -- tuple )
 
-: remainder-padding ( payload-size vm-object -- n )
+: remainder-padding ( payload-size object -- n )
     class-heap-size + dup data-alignment get align swap - ;
 
-: seek-past-padding ( payload-size vm-object -- )
+: seek-past-padding ( payload-size object -- )
     remainder-padding seek-relative seek-input ;
 
-:: read-padded-payload ( count vm-object c-type -- payload )
+:: read-padded-payload ( count object c-type -- payload )
     count c-type heap-size * :> payload-size
     payload-size [
         c-type read-bytes>array
-    ] [ vm-object seek-past-padding ] bi ;
+    ] [ object seek-past-padding ] bi ;
 
-: read-array-payload ( vm-array -- payload )
+: read-array-payload ( array -- payload )
     [ capacity>> -4 shift ] keep cell read-padded-payload ;
 
-: read-char-payload ( n-bytes vm-object -- payload )
+: read-char-payload ( n-bytes object -- payload )
     char read-padded-payload ;
 
-: read-no-payload ( vm-object -- payload )
+: read-no-payload ( object -- payload )
     0 swap seek-past-padding { } ;
 
-: layout-address ( rel-base vm-tuple -- address )
+: layout-address ( rel-base tuple -- address )
     layout>> 15 unmask - neg ;
 
-M: array-payload read-payload ( rel-base vm-object -- payload )
+M: array-payload read-payload ( rel-base object -- payload )
     nip read-array-payload ;
 
-M: no-payload read-payload ( rel-base vm-object -- payload )
+M: no-payload read-payload ( rel-base object -- payload )
     nip read-no-payload ;
 
-M: byte-array read-payload ( rel-base vm-object -- payload )
+M: byte-array read-payload ( rel-base object -- payload )
     nip [ capacity>> -4 shift ] keep read-char-payload ;
 
-M: string read-payload ( rel-base vm-string -- payload )
+M: callstack read-payload ( rel-base object -- payload )
     nip [ length>> -4 shift ] keep read-char-payload ;
 
-M: tuple read-payload ( rel-base vm-tuple -- payload )
+M: string read-payload ( rel-base string -- payload )
+    nip [ length>> -4 shift ] keep read-char-payload ;
+
+M: tuple read-payload ( rel-base tuple -- payload )
     [
         [
             layout-address seek-absolute seek-input
@@ -56,10 +59,10 @@ M: tuple read-payload ( rel-base vm-tuple -- payload )
         ] save-io-excursion
     ] keep cell read-padded-payload ;
 
-: peek-read-object ( -- vm-base )
+: peek-read-object ( -- object )
     [ object read-struct ] save-io-excursion ;
 
-: (read-object) ( -- vm-object )
+: (read-object) ( -- object )
     peek-read-object object-tag tag>class read-struct ;
 
 : read-object ( rel-base -- object )
diff --git a/extra/tools/image-analyzer/vm/vm.factor b/extra/tools/image-analyzer/vm/vm.factor
index eea438ad8e..0f6f096913 100644
--- a/extra/tools/image-analyzer/vm/vm.factor
+++ b/extra/tools/image-analyzer/vm/vm.factor
@@ -39,6 +39,10 @@ STRUCT: byte-array
     { header cell }
     { capacity cell } ;
 
+STRUCT: callstack
+    { header cell }
+    { length cell } ;
+
 STRUCT: dll
     { header cell }
     { path cell }
@@ -111,6 +115,7 @@ UNION: array-payload
         { 7 tuple }
         { 8 wrapper }
         { 9 byte-array }
+        { 10 callstack }
         { 11 string }
         { 12 word }
         { 13 dll }