#label nodes are now reported in compiled stack traces

TODO.txt

@@ -27,8 +27,7 @@
 - inspector where slot values can be changed
 - compiled call traces:
   - should be independent of whenever the runtime was built with
-    -fomit-frame-pointer or not
-  - doesn't show #labels
+    -fomit-frame-pointer or not (ppc and amd64)
   - we don't know if signal handlers run with the same stack or not
 - use crc32 instead of modification date in reload-modules
 - models: don't do redundant work

core/bootstrap/primitives.factor

@@ -206,6 +206,7 @@ call
     { "become" "kernel-internals"           }
     { "array>vector" "vectors"              }
     { "<string>" "strings"                  }
+    { "xt-map" "kernel-internals"           }
 } dup length 3 swap [ + ] map-with [ make-primitive ] 2each
 
 FORGET: make-primitive

core/compiler/generator/generator.factor

@@ -39,17 +39,20 @@ UNION: #terminal
 : generate-code ( node quot -- )
     over stack-reserve %prologue call ; inline
 
-: init-generator ( -- )
+: init-generator ( word -- )
+    #! The first entry in the literal table is the word itself,
+    #! this is for compiled call traces
     V{ } clone relocation-table set
     V{ } clone literal-table set
     V{ } clone label-table set 
-    V{ } clone word-table set ;
+    V{ } clone word-table set
+    literal-table get push ;
 
 : generate-1 ( word node quot -- )
     #! Generate the code, then dump three vectors to pass to
     #! add-compiled-block.
     pick f save-xt [
-        init-generator
+        pick init-generator
         init-templates
         generate-code
         generate-labels

core/compiler/inference/known-words.factor

@@ -362,6 +362,8 @@ t over set-effect-terminated?
 
 \ <quotation> { integer } { quotation } <effect> "inferred-effect" set-word-prop
 
+\ xt-map { } { array } <effect> "inferred-effect" set-word-prop
+
 ! Dynamic scope inference
 : if-tos-literal ( quot -- )
     peek-d dup value? [ value-literal swap call ] [ 2drop ] if ;

core/compiler/inference/words.factor

@@ -48,10 +48,13 @@ TUPLE: no-effect word ;
 : add-recursive-state ( word label -- )
     2array recursive-state [ swap add ] change ;
 
+: block-label ( word -- newword )
+    word-name " - inlined" append f <word> ;
+
 : inline-block ( word -- node-block data )
     [
         copy-inference nest-node
-        gensym 2dup add-recursive-state
+        dup block-label 2dup add-recursive-state
         #label >r word-def infer-quot r>
         unnest-node
     ] make-hash ;

core/debugger.factor

@@ -20,22 +20,11 @@ IN: kernel-internals
     [ error-handler ] 5 setenv
     \ kernel-error 12 setenv ;
 
-: code-heap-start 17 getenv ;
-: code-heap-end 18 getenv ;
-
-: <xt-map> ( -- xtmap )
-    [
-        f code-heap-start 2array ,
-	    all-words [ compiled? ] subset
-	    [ dup word-xt 2array , ] each
-        f  code-heap-end 2array ,
-    ] { } make sort-values ;
-
 : find-xt ( xt xtmap -- word )
     [ second - ] binsearch* first ;
 
 : symbolic-stack-trace ( seq -- seq )
-    <xt-map> swap [ dup pick find-xt 2array ] map nip ;
+    xt-map 2 group swap [ dup rot find-xt 2array ] map-with ;
 
 IN: errors
 
@@ -61,15 +50,11 @@ M: string error. print ;
 
 : word-xt. ( xt word -- )
     "Compiled: " write dup pprint bl
-    "(offset " write word-xt - >hex write ")" write ;
-
-: bare-xt. ( xt -- )
-    "C code: " write xt. ;
+    "(offset " write word-xt - >hex write ")" print ;
 
 : :trace
-    error-stack-trace get symbolic-stack-trace <reversed> [
-        first2 [ word-xt. ] [ bare-xt. ] if* terpri
-    ] each ;
+    error-stack-trace get symbolic-stack-trace <reversed>
+    [ first2 word-xt. ] each ;
 
 : :c ( -- )
     error-continuation get continuation-call callstack. :trace ;

vm/compiler.c

@@ -292,3 +292,34 @@ void primitive_finalize_compile(void)
 		iterate_code_heap_step(xt_to_compiled(xt),finalize_code_block);
 	}
 }
+
+void primitive_xt_map(void)
+{
+	GROWABLE_ARRAY(array);
+	F_BLOCK *scan = (F_BLOCK *)compiling.base;
+
+	while(scan)
+	{
+		if(scan->status != B_FREE)
+		{
+			F_COMPILED *compiled = (F_COMPILED *)(scan + 1);
+			CELL code_start = (CELL)(compiled + 1);
+			CELL literal_start = code_start
+				+ compiled->code_length
+				+ compiled->reloc_length;
+
+			CELL word = get_literal(literal_start,0);
+			GROWABLE_ADD(array,word);
+			REGISTER_ARRAY(array);
+			CELL xt = allot_cell(code_start);
+			UNREGISTER_ARRAY(array);
+			GROWABLE_ADD(array,xt);
+		}
+
+		scan = next_block(&compiling,scan);
+	}
+
+	GROWABLE_TRIM(array);
+
+	dpush(tag_object(array));
+}

vm/compiler.h

@@ -42,3 +42,4 @@ void relocate_code_block(F_COMPILED *relocating, CELL code_start,
 	CELL reloc_start, CELL literal_start, CELL words_start, CELL words_end);
 void primitive_add_compiled_block(void);
 void primitive_finalize_compile(void);
+void primitive_xt_map(void);

vm/factor.c

@@ -25,8 +25,6 @@ void init_factor(const char* image,
 	userenv[GEN_ENV] = tag_fixnum(gen_count);
 	userenv[IMAGE_ENV] = tag_object(from_char_string(image));
 	userenv[CELL_SIZE_ENV] = tag_fixnum(sizeof(CELL));
-	userenv[CODE_HEAP_START_ENV] = allot_cell(compiling.base);
-	userenv[CODE_HEAP_END_ENV] = allot_cell(compiling.limit);
 }
 
 INLINE bool factor_arg(const char* str, const char* arg, CELL* value)

vm/primitives.c

@@ -173,7 +173,8 @@ void* primitives[] = {
 	primitive_clone,
 	primitive_become,
 	primitive_array_to_vector,
-	primitive_string
+	primitive_string,
+	primitive_xt_map
 };
 
 CELL primitive_to_xt(CELL primitive)

vm/run.h

@@ -12,24 +12,24 @@ CELL callframe_end;
 
 #define USER_ENV 32
 
-#define CELL_SIZE_ENV       1 /* sizeof(CELL) */
-#define NLX_VECTOR_ENV      2 /* non-local exit hook, used by library only */
-#define NAMESTACK_ENV       3 /* used by library only */
-#define GLOBAL_ENV          4
-#define BREAK_ENV           5
-#define CATCHSTACK_ENV      6 /* used by library only */
-#define CPU_ENV             7
-#define BOOT_ENV            8
-#define CALLCC_1_ENV        9 /* used by library only */
-#define ARGS_ENV            10
-#define OS_ENV              11
-#define ERROR_ENV           12 /* a marker consed onto kernel errors */
-#define IN_ENV              13
-#define OUT_ENV             14
-#define GEN_ENV             15 /* set to gen_count */
-#define IMAGE_ENV           16 /* image name */
-#define CODE_HEAP_START_ENV 17 /* start of code heap, used by :trace */
-#define CODE_HEAP_END_ENV   18 /* end of code heap, used by :trace */
+typedef enum {
+	CELL_SIZE_ENV      = 1, /* sizeof(CELL) */
+	NLX_VECTOR_ENV,         /* non-local exit hook, used by library only */
+	NAMESTACK_ENV,          /* used by library only */
+	GLOBAL_ENV,             
+	BREAK_ENV,              
+	CATCHSTACK_ENV,         /* used by library only */
+	CPU_ENV,                
+	BOOT_ENV,               
+	CALLCC_1_ENV,           /* used by library only */
+	ARGS_ENV,               
+	OS_ENV,                 
+	ERROR_ENV,              /* a marker consed onto kernel errors */
+	IN_ENV,                 
+	OUT_ENV,                
+	GEN_ENV,                /* set to gen_count */
+	IMAGE_ENV               /* image name */
+} F_ENVTYPE;
 
 /* TAGGED user environment data; see getenv/setenv prims */
 DLLEXPORT CELL userenv[USER_ENV];
@@ -151,7 +151,7 @@ void primitive_clone(void);
 /* Runtime errors */
 typedef enum
 {
-	ERROR_EXPIRED,
+	ERROR_EXPIRED = 0,
 	ERROR_IO,
 	ERROR_UNDEFINED_WORD,
 	ERROR_TYPE,