diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor index 4e06980bab..44c68d32f0 100755 --- a/core/bootstrap/compiler/compiler.factor +++ b/core/bootstrap/compiler/compiler.factor @@ -33,7 +33,7 @@ global [ { "compiler" } add-use ] bind delegate - underlying2 + underlying find-pair-next namestack* diff --git a/core/compiler/compiler-docs.factor b/core/compiler/compiler-docs.factor old mode 100644 new mode 100755 index ff82505102..b7e96a33ff --- a/core/compiler/compiler-docs.factor +++ b/core/compiler/compiler-docs.factor @@ -11,7 +11,6 @@ ARTICLE: "compiler-usage" "Calling the optimizing compiler" "Three utility words for bulk compilation:" { $subsection compile-batch } { $subsection compile-vocabs } -{ $subsection compile-all } "Bulk compilation saves compile warnings and errors in a global variable, instead of printing them as they arise:" { $subsection compile-errors } "The warnings and errors can be viewed later:" @@ -113,9 +112,6 @@ HELP: recompile { $description "Recompiles words whose compiled definitions have become out of date as a result of dependent words being redefined." } ; HELP: compile-all -{ $description "Compiles all words which have not been compiled yet." } ; - -HELP: recompile-all { $description "Recompiles all words." } ; HELP: changed-words diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor old mode 100644 new mode 100755 index cd6fb979f0..42de8225c9 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -8,14 +8,13 @@ IN: compiler M: object inference-error-major? drop t ; : compile-error ( word error -- ) - batch-mode get [ - 2array compile-errors get push + compile-errors get [ + >r 2array r> push ] [ - "quiet" get [ drop ] [ print-error flush ] if drop - ] if ; + "quiet" get [ 2drop ] [ print-error flush drop ] if + ] if* ; : begin-batch ( -- ) - batch-mode on V{ } clone compile-errors set-global ; : compile-error. ( pair -- ) @@ -37,7 +36,6 @@ M: object inference-error-major? drop t ; : :warnings (:warnings) [ compile-error. ] each ; : end-batch ( -- ) - batch-mode off "quiet" get [ "Compile finished." print nl @@ -48,6 +46,9 @@ M: object inference-error-major? drop t ; nl ] unless ; +: with-compile-errors ( quot -- ) + [ begin-batch call end-batch ] with-scope ; inline + : compile ( word -- ) H{ } clone [ compiled-xts [ (compile) ] with-variable @@ -56,15 +57,10 @@ M: object inference-error-major? drop t ; : compile-failed ( word error -- ) dupd compile-error dup update-xt unchanged-word ; -: forget-errors ( seq -- ) - [ f "no-effect" set-word-prop ] each ; - : (compile-batch) ( words -- ) H{ } clone [ compiled-xts [ - [ - [ (compile) ] [ compile-failed ] recover - ] each + [ [ (compile) ] [ compile-failed ] recover ] each ] with-variable ] keep [ swap add* ] { } assoc>map modify-code-heap ; @@ -72,16 +68,11 @@ M: object inference-error-major? drop t ; dup empty? [ drop ] [ - dup begin-batch - dup forget-errors - (compile-batch) - end-batch + [ (compile-batch) ] with-compile-errors ] if ; : compile-vocabs ( seq -- ) [ words ] map concat compile-batch ; -: compile-all ( -- ) vocabs compile-vocabs ; - : compile-quot ( quot -- word ) define-temp dup compile ; : compile-1 ( quot -- ) compile-quot execute ; @@ -91,5 +82,8 @@ M: object inference-error-major? drop t ; dup keys compile-batch clear-assoc ] when* ; -: recompile-all ( -- ) - all-words [ changed-word ] each recompile ; +: forget-errors ( seq -- ) + [ f "no-effect" set-word-prop ] each ; + +: compile-all ( -- ) + all-words dup forget-errors [ changed-word ] each recompile ; diff --git a/core/cpu/x86/architecture/architecture.factor b/core/cpu/x86/architecture/architecture.factor index ac26705664..d059afe9f2 100755 --- a/core/cpu/x86/architecture/architecture.factor +++ b/core/cpu/x86/architecture/architecture.factor @@ -102,7 +102,7 @@ M: x86-backend %jump-t ( label -- ) ! x86, this is redundant. "scratch" operand HEX: ffffffff MOV rc-absolute-cell rel-dispatch "n" operand "n" operand "scratch" operand [+] MOV - "n" operand compiled-header-size ADD ; + "n" operand dup word-xt-offset [+] MOV ; : dispatch-template ( word-table# quot -- ) [ diff --git a/core/memory/memory-tests.factor b/core/memory/memory-tests.factor old mode 100644 new mode 100755 index 98d2779c1e..f543c08744 --- a/core/memory/memory-tests.factor +++ b/core/memory/memory-tests.factor @@ -4,6 +4,8 @@ IN: temporary TUPLE: testing x y z ; +[ save-image-and-exit ] unit-test-fails + [ ] [ num-types get [ type>class [ diff --git a/vm/code_gc.c b/vm/code_gc.c index 24fd0b1ab2..8ae3ea5eda 100755 --- a/vm/code_gc.c +++ b/vm/code_gc.c @@ -264,18 +264,6 @@ void collect_literals(void) iterate_code_heap(collect_literals_step); } -/* Mark all XTs referenced from a code block */ -void mark_sweep_step(F_COMPILED *compiled, CELL code_start, - CELL reloc_start, CELL literals_start, CELL words_start, CELL words_end) -{ - F_COMPILED **start = (F_COMPILED **)words_start; - F_COMPILED **end = (F_COMPILED **)words_end; - F_COMPILED **iter = start; - - while(iter < end) - recursive_mark(compiled_to_block(*iter++)); -} - /* Mark all XTs and literals referenced from a word XT */ void recursive_mark(F_BLOCK *block) { @@ -391,14 +379,14 @@ void forward_object_xts(void) F_WORD *word = untag_object(obj); if(word->compiledp != F) - set_word_xt(word,forward_xt(word->code)); + word->code = forward_xt(word->code); } else if(type_of(obj) == QUOTATION_TYPE) { F_QUOTATION *quot = untag_object(obj); if(quot->compiledp != F) - set_quot_xt(quot,forward_xt(quot->code)); + quot->code = forward_xt(quot->code); } else if(type_of(obj) == CALLSTACK_TYPE) { @@ -411,33 +399,33 @@ void forward_object_xts(void) gc_off = false; } -void compaction_code_block_fixup(F_COMPILED *compiled, CELL code_start, - CELL reloc_start, CELL literals_start, CELL words_start, CELL words_end) +/* Set the XT fields now that the heap has been compacted */ +void fixup_object_xts(void) { - F_COMPILED **iter = (F_COMPILED **)words_start; - F_COMPILED **end = (F_COMPILED **)words_end; + begin_scan(); - while(iter < end) + CELL obj; + + while((obj = next_object()) != F) { - *iter = forward_xt(*iter); - iter++; - } -} - -void forward_block_xts(void) -{ - F_BLOCK *scan = first_block(&code_heap); - - while(scan) - { - if(scan->status == B_ALLOCATED) + if(type_of(obj) == WORD_TYPE) { - iterate_code_heap_step(block_to_compiled(scan), - compaction_code_block_fixup); - } + F_WORD *word = untag_object(obj); - scan = next_block(&code_heap,scan); + if(word->compiledp != F) + set_word_xt(word,word->code); + } + else if(type_of(obj) == QUOTATION_TYPE) + { + F_QUOTATION *quot = untag_object(obj); + + if(quot->compiledp != F) + set_quot_xt(quot,quot->code); + } } + + /* End the heap scan */ + gc_off = false; } void compact_heap(F_HEAP *heap) @@ -450,7 +438,6 @@ void compact_heap(F_HEAP *heap) if(scan->status == B_ALLOCATED && scan != scan->forwarding) memcpy(scan->forwarding,scan,scan->size); - scan = next; } } @@ -465,19 +452,20 @@ void compact_code_heap(void) code_gc(); fprintf(stderr,"*** Code heap compaction...\n"); + fflush(stderr); /* Figure out where the code heap blocks are going to end up */ CELL size = compute_heap_forwarding(&code_heap); - /* Update word and quotation XTs to point to the new locations */ + /* Update word and quotation code pointers */ forward_object_xts(); - /* Update code block XTs to point to the new locations */ - forward_block_xts(); - /* Actually perform the compaction */ compact_heap(&code_heap); + /* Update word and quotation XTs */ + fixup_object_xts(); + /* Now update the free list; there will be a single free block at the end */ build_free_list(&code_heap,size); diff --git a/vm/code_heap.c b/vm/code_heap.c old mode 100644 new mode 100755 index da5f2a39ce..8f79078862 --- a/vm/code_heap.c +++ b/vm/code_heap.c @@ -317,6 +317,9 @@ F_COMPILED *add_compiled_block( void set_word_xt(F_WORD *word, F_COMPILED *compiled) { + if(compiled->type != WORD_TYPE) + critical_error("bad param to set_word_xt",(CELL)compiled); + word->code = compiled; word->xt = (XT)(compiled + 1); diff --git a/vm/data_gc.h b/vm/data_gc.h old mode 100644 new mode 100755 index cb0b6fbad3..ae11c5746a --- a/vm/data_gc.h +++ b/vm/data_gc.h @@ -239,9 +239,6 @@ DEFPUSHPOP(root_,extra_roots) #define REGISTER_UNTAGGED(obj) root_push(obj ? tag_object(obj) : 0) #define UNREGISTER_UNTAGGED(obj) obj = untag_object(root_pop()) -#define REGISTER_STRING(obj) REGISTER_UNTAGGED(obj) -#define UNREGISTER_STRING(obj) UNREGISTER_UNTAGGED(obj) - /* We ignore strings which point outside the data heap, but we might be given a char* which points inside the data heap, in which case it is a root, for example if we call unbox_char_string() the result is placed in a byte array */ diff --git a/vm/image.c b/vm/image.c index 32158fddbd..d5ee02cca0 100755 --- a/vm/image.c +++ b/vm/image.c @@ -150,6 +150,10 @@ DEFINE_PRIMITIVE(save_image) DEFINE_PRIMITIVE(save_image_and_exit) { + F_CHAR *path = unbox_native_string(); + + REGISTER_C_STRING(path); + /* strip out userenv data which is set on startup anyway */ CELL i; for(i = 0; i < FIRST_SAVE_ENV; i++) @@ -158,8 +162,10 @@ DEFINE_PRIMITIVE(save_image_and_exit) /* do a full GC + code heap compaction */ compact_code_heap(); + UNREGISTER_C_STRING(path); + /* Save the image */ - save_image(unbox_native_string()); + save_image(path); /* now exit; we cannot continue executing like this */ exit(0); diff --git a/vm/quotations.c b/vm/quotations.c index 174c5fdbea..97baf2afe9 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -39,6 +39,9 @@ bool jit_stack_frame_p(F_ARRAY *array) void set_quot_xt(F_QUOTATION *quot, F_COMPILED *code) { + if(code->type != QUOTATION_TYPE) + critical_error("bad param to set_word_xt",(CELL)code); + quot->code = code; quot->xt = (XT)(code + 1); quot->compiledp = T; diff --git a/vm/types.c b/vm/types.c old mode 100644 new mode 100755 index a62dfb3125..272625f000 --- a/vm/types.c +++ b/vm/types.c @@ -285,9 +285,9 @@ F_STRING* reallot_string(F_STRING* string, CELL capacity, u16 fill) if(capacity < to_copy) to_copy = capacity; - REGISTER_STRING(string); + REGISTER_UNTAGGED(string); F_STRING *new_string = allot_string_internal(capacity); - UNREGISTER_STRING(string); + UNREGISTER_UNTAGGED(string); memcpy(new_string + 1,string + 1,to_copy * CHARS); fill_string(new_string,to_copy,capacity,fill); @@ -381,9 +381,9 @@ F_BYTE_ARRAY *allot_c_string(CELL capacity, CELL size) F_BYTE_ARRAY *_c_str; \ if(check && !check_string(s,sizeof(type))) \ general_error(ERROR_C_STRING,tag_object(s),F,NULL); \ - REGISTER_STRING(s); \ + REGISTER_UNTAGGED(s); \ _c_str = allot_c_string(capacity,sizeof(type)); \ - UNREGISTER_STRING(s); \ + UNREGISTER_UNTAGGED(s); \ type *c_str = (type*)(_c_str + 1); \ type##_string_to_memory(s,c_str); \ c_str[capacity] = 0; \