Add code heap introspection primitive to VM, and make a code-blocks word in tools.memory that wraps a useful interface around this. Add a lookup-return-address word and use this in tools.disassembler.utils

basis/stack-checker/known-words/known-words.factor

@@ -523,6 +523,9 @@ M: bad-executable summary
 \ data-room { } { byte-array } define-primitive
 \ data-room make-flushable
 
+\ (code-blocks) { } { array } define-primitive
+\ (code-blocks)  make-flushable
+
 \ code-room { } { byte-array } define-primitive
 \ code-room  make-flushable
 

basis/tools/disassembler/udis/udis.factor

@@ -1,11 +1,10 @@
 ! Copyright (C) 2008, 2010 Slava Pestov, Jorge Acereda Macia.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: tools.disassembler namespaces combinators
+USING: tools.disassembler namespaces combinators alien
-alien alien.syntax alien.c-types lexer parser kernel
+alien.syntax alien.c-types lexer parser kernel sequences layouts
-sequences layouts math math.order alien.libraries
+math math.order alien.libraries math.parser system make fry
-math.parser system make fry arrays libc destructors
+arrays libc destructors tools.memory tools.disassembler.utils
-tools.disassembler.utils tools.disassembler.private splitting
+tools.disassembler.private splitting alien.data classes.struct ;
-alien.data classes.struct ;
 IN: tools.disassembler.udis
 
 <<
@@ -105,7 +104,7 @@ FUNCTION: char* ud_lookup_mnemonic ( int c ) ;
     dup UD_SYN_INTEL ud_set_syntax ;
 
 : with-ud ( quot: ( ud -- ) -- )
-    [ [ [ <ud> ] dip call ] with-destructors ] with-word-entry-points ; inline
+    [ [ [ <ud> ] dip call ] with-destructors ] with-code-blocks ; inline
 
 SINGLETON: udis-disassembler
 

basis/tools/disassembler/utils/utils.factor

@@ -1,43 +1,20 @@
-USING: accessors arrays binary-search kernel math math.order
+USING: accessors kernel math math.parser prettyprint sequences
-math.parser namespaces sequences sorting splitting vectors vocabs words ;
+splitting tools.memory ;
 IN: tools.disassembler.utils
 
-SYMBOL: word-entry-points
+: 0x ( str -- str' ) "0x" prepend ;
-SYMBOL: smallest-xt
-SYMBOL: greatest-xt
-
-: (word-entry-points) ( -- assoc )
-    vocabs [ words ] map concat [ [ word-code ] keep 3array ] map
-    [ first ] sort-with ;
 
 : complete-address ( n seq -- str )
-    [ first - ] [ third name>> ] bi
+    [ nip owner>> unparse-short ] [ entry-point>> - ] 2bi
-    over zero? [ nip ] [ swap 16 >base "0x" prepend "+" glue ] if ;
+    [ 16 >base 0x " + " glue ] unless-zero ;
 
-: search-xt ( n -- str/f )
+: search-xt ( addr -- str/f )
-    dup [ smallest-xt get < ] [ greatest-xt get > ] bi or [
+    dup lookup-return-address
-        drop f
+    dup [ complete-address ] [ 2drop f ] if ;
-    ] [
-        word-entry-points get over [ swap first <=> ] curry search nip
-        2dup second <= [
-            [ complete-address ] [ drop f ] if*
-        ] [
-            2drop f
-        ] if
-    ] if ;
 
 : resolve-xt ( str -- str' )
-    [ "0x" prepend ] [ 16 base> ] bi
+    [ 0x ] [ 16 base> ] bi
     [ search-xt [ " (" ")" surround append ] when* ] when* ;
 
 : resolve-call ( str -- str' )
     "0x" split1-last [ resolve-xt "0x" glue ] when* ;
-
-: with-word-entry-points ( quot -- )
-    [
-        (word-entry-points)
-        [ word-entry-points set ]
-        [ first first smallest-xt set ]
-        [ last second greatest-xt set ] tri
-        call
-    ] with-scope ; inline

basis/tools/memory/memory.factor

@@ -1,10 +1,11 @@
-! Copyright (C) 2005, 2009 Slava Pestov.
+! Copyright (C) 2005, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs classes classes.struct
+USING: accessors arrays assocs binary-search classes
-combinators combinators.smart continuations fry generalizations
+classes.struct combinators combinators.smart continuations fry
-generic grouping io io.styles kernel make math math.parser
+generalizations generic grouping io io.styles kernel make math
-math.statistics memory namespaces parser prettyprint sequences
+math.order math.parser math.statistics memory memory.private
-sorting splitting strings system vm words ;
+layouts namespaces parser prettyprint sequences sorting
+splitting strings system vm words hints hashtables ;
 IN: tools.memory
 
 <PRIVATE
@@ -195,3 +196,72 @@ PRIVATE>
         { "Code heap sweep time:" [ [ code-sweep-time>> ] map-sum nanos>string ] }
         { "Compaction time:" [ [ compaction-time>> ] map-sum nanos>string ] }
     } object-table. ;
+
+SINGLETONS: +unoptimized+ +optimized+ +profiling+ +pic+ ;
+
+TUPLE: code-block
+{ owner read-only }
+{ parameters read-only }
+{ relocation read-only }
+{ type read-only }
+{ size read-only }
+{ entry-point read-only } ;
+
+TUPLE: code-blocks { blocks sliced-groups } { cache hashtable } ;
+
+<PRIVATE
+
+: code-block-type ( n -- type )
+    { +unoptimized+ +optimized+ +profiling+ +pic+ } nth ;
+
+: <code-block> ( seq -- code-block )
+    6 firstn-unsafe {
+        [ ]
+        [ ]
+        [ ]
+        [ code-block-type ]
+        [ ]
+        [ tag-bits get shift ]
+    } spread code-block boa ; inline
+
+: <code-blocks> ( seq -- code-blocks )
+    6 <sliced-groups> H{ } clone \ code-blocks boa ;
+
+SYMBOL: code-heap-start
+SYMBOL: code-heap-end
+
+: in-code-heap? ( address -- ? )
+    code-heap-start get code-heap-end get between? ;
+
+: (lookup-return-address) ( addr seq -- code-block )
+    [ entry-point>> <=> ] with search nip ;
+
+HINTS: (lookup-return-address) code-blocks ;
+
+PRIVATE>
+
+M: code-blocks length blocks>> length ; inline
+
+FROM: sequences.private => nth-unsafe ;
+
+M: code-blocks nth-unsafe
+    [ cache>> ] [ blocks>> ] bi
+    '[ _ nth-unsafe <code-block> ] cache ; inline
+
+INSTANCE: code-blocks immutable-sequence
+
+: code-blocks ( -- blocks )
+    (code-blocks) <code-blocks> ;
+
+: with-code-blocks ( quot -- )
+    [
+        code-blocks
+        [ \ code-blocks set ]
+        [ first entry-point>> code-heap-start set ]
+        [ last [ entry-point>> ] [ size>> ] bi + code-heap-end set ] tri
+        call
+    ] with-scope ; inline
+
+: lookup-return-address ( addr -- code-block )
+    dup in-code-heap?
+    [ \ code-blocks get (lookup-return-address) ] [ drop f ] if ;

basis/tools/memory/summary.txt

@@ -1 +1 @@
-Heap introspection tools
+Data and code heap introspection tools

core/bootstrap/primitives.factor

@@ -506,6 +506,7 @@ tuple
     { "float>bignum" "math.private" "primitive_float_to_bignum" (( x -- y )) }
     { "float>fixnum" "math.private" "primitive_float_to_fixnum" (( x -- y )) }
     { "all-instances" "memory" "primitive_all_instances" (( -- array )) }
+    { "(code-blocks)" "memory.private" "primitive_code_blocks" (( -- array )) }
     { "code-room" "memory" "primitive_code_room" (( -- code-room )) }
     { "compact-gc" "memory" "primitive_compact_gc" (( -- )) }
     { "data-room" "memory" "primitive_data_room" (( -- data-room )) }

vm/arrays.cpp

@@ -60,6 +60,19 @@ void factor_vm::primitive_resize_array()
 	ctx->push(tag<array>(reallot_array(a.untagged(),capacity)));
 }
 
+cell factor_vm::std_vector_to_array(std::vector<cell> &elements)
+{
+	cell element_count = elements.size();
+	data_roots.push_back(data_root_range(&elements[0],element_count));
+
+	tagged<array> objects(allot_uninitialized_array<array>(element_count));
+	memcpy(objects->data(),&elements[0],element_count * sizeof(cell));
+
+	data_roots.pop_back();
+
+	return objects.value();
+}
+
 void growable_array::add(cell elt_)
 {
 	factor_vm *parent = elements.parent;

vm/code_heap.cpp

@@ -202,4 +202,40 @@ void factor_vm::primitive_strip_stack_traces()
 	each_code_block(stripper);
 }
 
+struct code_block_accumulator {
+	std::vector<cell> objects;
+
+	void operator()(code_block *compiled, cell size)
+	{
+		objects.push_back(compiled->owner);
+		objects.push_back(compiled->parameters);
+		objects.push_back(compiled->relocation);
+
+		objects.push_back(tag_fixnum(compiled->type()));
+		objects.push_back(tag_fixnum(compiled->size()));
+
+		/* Note: the entry point is always a multiple of the heap
+		alignment (16 bytes). We cannot allocate while iterating
+		through the code heap, so it is not possible to call allot_cell()
+		here. It is OK, however, to add it as if it were a fixnum, and
+		have library code shift it to the left by 4. */
+		cell entry_point = (cell)compiled->entry_point();
+		assert((entry_point & (data_alignment - 1)) == 0);
+		assert((entry_point & TAG_MASK) == FIXNUM_TYPE);
+		objects.push_back(entry_point);
+	}
+};
+
+cell factor_vm::code_blocks()
+{
+	code_block_accumulator accum;
+	each_code_block(accum);
+	return std_vector_to_array(accum.objects);
+}
+
+void factor_vm::primitive_code_blocks()
+{
+	ctx->push(code_blocks());
+}
+
 }

vm/data_heap.cpp

@@ -250,16 +250,7 @@ cell factor_vm::instances(cell type)
 {
 	object_accumulator accum(type);
 	each_object(accum);
-	cell object_count = accum.objects.size();
+	return std_vector_to_array(accum.objects);
-
-	data_roots.push_back(data_root_range(&accum.objects[0],object_count));
-
-	array *objects = allot_array(object_count,false_object);
-	memcpy(objects->data(),&accum.objects[0],object_count * sizeof(cell));
-
-	data_roots.pop_back();
-
-	return tag<array>(objects);
 }
 
 void factor_vm::primitive_all_instances()

vm/primitives.cpp

@@ -43,6 +43,7 @@ PRIMITIVE(callstack)
 PRIMITIVE(callstack_to_array)
 PRIMITIVE(check_datastack)
 PRIMITIVE(clone)
+PRIMITIVE(code_blocks)
 PRIMITIVE(code_room)
 PRIMITIVE(compact_gc)
 PRIMITIVE(compute_identity_hashcode)

vm/primitives.hpp

@@ -39,6 +39,7 @@ DECLARE_PRIMITIVE(callstack)
 DECLARE_PRIMITIVE(callstack_to_array)
 DECLARE_PRIMITIVE(check_datastack)
 DECLARE_PRIMITIVE(clone)
+DECLARE_PRIMITIVE(code_blocks)
 DECLARE_PRIMITIVE(code_room)
 DECLARE_PRIMITIVE(compact_gc)
 DECLARE_PRIMITIVE(compute_identity_hashcode)

vm/vm.hpp

@@ -348,13 +348,14 @@ struct factor_vm
 	void primitive_die();
 
 	//arrays
+	inline void set_array_nth(array *array, cell slot, cell value);
 	array *allot_array(cell capacity, cell fill_);
 	void primitive_array();
 	cell allot_array_1(cell obj_);
 	cell allot_array_2(cell v1_, cell v2_);
 	cell allot_array_4(cell v1_, cell v2_, cell v3_, cell v4_);
 	void primitive_resize_array();
-	inline void set_array_nth(array *array, cell slot, cell value);
+	cell std_vector_to_array(std::vector<cell> &elements);
 
 	//strings
 	cell string_nth(const string *str, cell index);
@@ -521,11 +522,11 @@ struct factor_vm
 	code_block *add_code_block(code_block_type type, cell code_, cell labels_, cell owner_, cell relocation_, cell parameters_, cell literals_);
 
 	//code heap
-	inline void check_code_pointer(cell ptr)
+	inline void check_code_pointer(cell ptr) { }
+
+	template<typename Iterator> void each_code_block(Iterator &iter)
 	{
-	#ifdef FACTOR_DEBUG
+		code->allocator->iterate(iter);
-		//assert(in_code_heap_p(ptr));
-	#endif
 	}
 
 	void init_code_heap(cell size);
@@ -536,11 +537,8 @@ struct factor_vm
 	code_heap_room code_room();
 	void primitive_code_room();
 	void primitive_strip_stack_traces();
-
+	cell code_blocks();
-	template<typename Iterator> void each_code_block(Iterator &iter)
+	void primitive_code_blocks();
-	{
-		code->allocator->iterate(iter);
-	}
 
 	//callbacks
 	void init_callbacks(cell size);