tools.image-analyzer.*: new word for removing the tag bits

extra/tools/image-analyzer/data-heap-reader/data-heap-reader.factor

@@ -71,7 +71,7 @@ GENERIC: read-payload ( rel-base struct -- tuple )
     0 swap seek-past-padding { } ;
 
 : layout-address ( rel-base tuple -- address )
-    layout>> 15 unmask - neg ;
+    layout>> untag - neg ;
 
 M: array-payload read-payload ( rel-base object -- payload )
     nip read-array-payload ;

extra/tools/image-analyzer/gc-info/gc-info-tests.factor

@@ -26,13 +26,15 @@ QUALIFIED: opencl
     [ gc-map-needed? ] filter ;
 
 : tally-gc-maps ( gc-maps -- seq/f )
-    [ f ] [ {
+    [ f ] [
-        [ [ scrub-d>> length ] map supremum ]
+        {
-        [ [ scrub-r>> length ] map supremum ]
+            [ [ scrub-d>> length ] map supremum ]
-        [ [ gc-root-offsets ] map largest-spill-slot ]
+            [ [ scrub-r>> length ] map supremum ]
-        [ [ derived-root-offsets ] map [ keys ] map largest-spill-slot ]
+            [ [ gc-root-offsets ] map largest-spill-slot ]
-        [ length ]
+            [ [ derived-root-offsets ] map [ keys ] map largest-spill-slot ]
-    } cleave 5 narray ] if-empty ;
+            [ length ]
+        } cleave 5 narray
+    ] if-empty ;
 
 ! Like word>gc-info but uses the compiler
 : word>gc-info-expected ( word -- seq/f )
@@ -87,7 +89,6 @@ QUALIFIED: opencl
     [ [ word>gc-info-expected ] [ word>gc-info ] bi same-gc-info? ] reject
 ] unit-test
 
-
 ! Originally from llvm.types, but llvm moved to unmaintained
 TYPEDEF: void* LLVMTypeRef
 TYPEDEF: void* LLVMTypeHandleRef
@@ -102,7 +103,7 @@ FUNCTION: void LLVMDisposeTypeHandle ( LLVMTypeHandleRef TypeHandle )
 
 ! base-pointer-groups
 { t } [
-    \ resolve-types
+\ resolve-types
     [ base-pointer-groups-expected ] [ base-pointer-groups-decoded ] bi =
 ] unit-test
 
@@ -147,3 +148,7 @@ FUNCTION: void LLVMDisposeTypeHandle ( LLVMTypeHandleRef TypeHandle )
 { t } [
     \ opencl:cl-queue-kernel deterministic-gc-info?
 ] unit-test
+
+
+
+! TODO: try on 32 bit \ feedback-format:

extra/tools/image-analyzer/graphviz/graphviz.factor

@@ -1,9 +1,9 @@
-! Copyright (C) 2013 Björn Lindqvist
+! Copyright (C) 2015 - 2016 Björn Lindqvist
 ! See http://factorcode.org/license.txt for BSD license
 USING: accessors alien.strings assocs classes fry graphviz
-graphviz.attributes graphviz.notation math.bitwise sequences
+graphviz.attributes graphviz.notation math.bitwise sequences sets
-sets system tools.image-analyzer.references tools.image-analyzer.vm
+system tools.image-analyzer.references tools.image-analyzer.utils
-vocabs.parser ;
+tools.image-analyzer.vm vocabs.parser ;
 IN: tools.image-analyzer.graphviz
 FROM: arrays => 1array 2array ;
 FROM: byte-arrays => >byte-array ;
@@ -63,7 +63,7 @@ CONSTANT: node-colors {
 
 : add-root-node ( graph ptr index -- graph )
     over 15 mask 1 <= [ 2drop ] [
-        [ swap 15 unmask add-edge ] keep <root-node> add
+        [ swap untag add-edge ] keep <root-node> add
     ] if ;
 
 : add-root-nodes ( graph image -- graph )

extra/tools/image-analyzer/references/references.factor

@@ -1,18 +1,21 @@
-! Copyright (C) 2013 Björn Lindqvist
+! Copyright (C) 2015 Björn Lindqvist
 ! See http://factorcode.org/license.txt for BSD license
 !
 ! Tools to follow references in the loaded image.
 USING: accessors arrays byte-arrays fry kernel layouts math
-math.bitwise math.order sequences sets slots.syntax
+math.bitwise sequences slots.syntax tools.image-analyzer.relocations
-tools.image-analyzer.relocations ;
+tools.image-analyzer.utils ;
 IN: tools.image-analyzer.references
 QUALIFIED-WITH: tools.image-analyzer.vm vm
 
 ! Edges in the heap
 GENERIC: pointers ( heap heap-node struct -- seq )
 
+: find-heap-node* ( heap untagged-ptr -- node )
+    '[ address>> _ = ] find nip ;
+
 : find-heap-node ( heap ptr -- node )
-    15 unmask '[ address>> _ = ] find nip ;
+    untag find-heap-node* ;
 
 : load-relocations ( heap code-block -- seq )
     relocation>> find-heap-node payload>> >byte-array byte-array>relocations
@@ -47,4 +50,4 @@ M: object pointers ( heap heap-node struct -- seq )
     3drop { } ;
 
 : collect-pointers ( heap heap-node -- seq )
-    dup object>> pointers [ 1 <= ] reject [ 15 unmask ] map ;
+    dup object>> pointers [ 1 <= ] reject [ untag ] map ;

extra/tools/image-analyzer/utils/utils.factor

@@ -1,8 +1,11 @@
-USING: accessors alien alien.c-types alien.data arrays bit-arrays classes
+USING: accessors alien alien.c-types alien.data arrays bit-arrays
-continuations destructors fry io io.streams.throwing kernel locals
+classes continuations destructors fry io io.streams.throwing kernel
-math namespaces sequences words ;
+locals math math.bitwise namespaces sequences words ;
 IN: tools.image-analyzer.utils
 
+: untag ( ptr -- ptr' )
+    15 unmask ;
+
 : class-heap-size ( instance -- n )
     class-of heap-size ;