diff --git a/TODO.txt b/TODO.txt index 07432dffaa..6c0e9b85c0 100644 --- a/TODO.txt +++ b/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 diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 5049739043..f63cbeb7c6 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -206,6 +206,7 @@ call { "become" "kernel-internals" } { "array>vector" "vectors" } { "" "strings" } + { "xt-map" "kernel-internals" } } dup length 3 swap [ + ] map-with [ make-primitive ] 2each FORGET: make-primitive diff --git a/core/compiler/generator/generator.factor b/core/compiler/generator/generator.factor index 66d9da93ad..70063b148e 100644 --- a/core/compiler/generator/generator.factor +++ b/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 diff --git a/core/compiler/inference/known-words.factor b/core/compiler/inference/known-words.factor index fcc351da03..b815913a52 100644 --- a/core/compiler/inference/known-words.factor +++ b/core/compiler/inference/known-words.factor @@ -362,6 +362,8 @@ t over set-effect-terminated? \ { integer } { quotation } "inferred-effect" set-word-prop +\ xt-map { } { array } "inferred-effect" set-word-prop + ! Dynamic scope inference : if-tos-literal ( quot -- ) peek-d dup value? [ value-literal swap call ] [ 2drop ] if ; diff --git a/core/compiler/inference/words.factor b/core/compiler/inference/words.factor index 1aee571606..ff5a050ebc 100644 --- a/core/compiler/inference/words.factor +++ b/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 ; + : 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 ; diff --git a/core/debugger.factor b/core/debugger.factor index 843c493ac9..c8ce092dd2 100644 --- a/core/debugger.factor +++ b/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 ; - -: ( -- 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 ) - 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 [ - first2 [ word-xt. ] [ bare-xt. ] if* terpri - ] each ; + error-stack-trace get symbolic-stack-trace + [ first2 word-xt. ] each ; : :c ( -- ) error-continuation get continuation-call callstack. :trace ; diff --git a/vm/compiler.c b/vm/compiler.c index b8f3366499..06fbbba1d9 100644 --- a/vm/compiler.c +++ b/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)); +} diff --git a/vm/compiler.h b/vm/compiler.h index b794266bd6..5fc6b946a5 100644 --- a/vm/compiler.h +++ b/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); diff --git a/vm/factor.c b/vm/factor.c index a66cad0875..6a7474dc8f 100644 --- a/vm/factor.c +++ b/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) diff --git a/vm/primitives.c b/vm/primitives.c index 9c09975b12..65c5ce5d02 100644 --- a/vm/primitives.c +++ b/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) diff --git a/vm/run.h b/vm/run.h index 033c6389af..59f0864572 100644 --- a/vm/run.h +++ b/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,