diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor index 902c406158..26783f6e47 100755 --- a/core/bootstrap/compiler/compiler.factor +++ b/core/bootstrap/compiler/compiler.factor @@ -4,15 +4,17 @@ USING: compiler cpu.architecture vocabs.loader system sequences namespaces parser kernel kernel.private classes classes.private arrays hashtables vectors tuples sbufs inference.dataflow hashtables.private sequences.private math tuples.private -growable namespaces.private alien.remote-control assocs words -generator command-line vocabs io prettyprint libc definitions ; +growable namespaces.private assocs words generator command-line +vocabs io prettyprint libc definitions ; IN: bootstrap.compiler -"cpu." cpu append require +! Don't bring this in when deploying, since it will store a +! reference to 'eval' in a global variable +"deploy-vocab" get [ + "alien.remote-control" require +] unless -"-no-stack-traces" cli-args member? [ - f compiled-stack-traces? set-global -] when +"cpu." cpu append require nl "Compiling some words to speed up bootstrap..." write diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index 841f1ab280..c91c48450e 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -45,7 +45,7 @@ IN: bootstrap.stage2 run-bootstrap-init - "Compiling remaining words..." print + "Compiling remaining words..." print flush all-words [ compiled? not ] subset recompile-hook get call ] with-compiler-errors diff --git a/core/cpu/x86/architecture/architecture.factor b/core/cpu/x86/architecture/architecture.factor index 5195981657..733d756157 100755 --- a/core/cpu/x86/architecture/architecture.factor +++ b/core/cpu/x86/architecture/architecture.factor @@ -45,7 +45,7 @@ M: x86-backend stack-frame ( n -- i ) 3 cells + 16 align cell - ; M: x86-backend %save-word-xt ( -- ) - xt-reg 0 MOV rc-absolute-cell rel-current-word ; + xt-reg 0 MOV rc-absolute-cell rel-this ; : factor-area-size 4 cells ; diff --git a/core/cpu/x86/bootstrap.factor b/core/cpu/x86/bootstrap.factor index eded516ef2..def182afe7 100755 --- a/core/cpu/x86/bootstrap.factor +++ b/core/cpu/x86/bootstrap.factor @@ -28,7 +28,7 @@ big-endian off stack-frame-size PUSH ! save stack frame size 0 PUSH ! push XT arg1 PUSH ! alignment -] rc-absolute-cell rt-xt 6 jit-prolog jit-define +] rc-absolute-cell rt-label 6 jit-prolog jit-define [ arg0 0 [] MOV ! load literal diff --git a/core/generator/fixup/fixup.factor b/core/generator/fixup/fixup.factor index 393d0749ad..78dd3f73df 100755 --- a/core/generator/fixup/fixup.factor +++ b/core/generator/fixup/fixup.factor @@ -64,13 +64,12 @@ SYMBOL: label-table rot rc-absolute-ppc-2/2 = or or ; ! Relocation types -: rt-primitive 0 ; -: rt-dlsym 1 ; -: rt-literal 2 ; -: rt-dispatch 3 ; -: rt-xt 4 ; -: rt-xt-profiling 5 ; -: rt-label 6 ; +: rt-primitive 0 ; +: rt-dlsym 1 ; +: rt-literal 2 ; +: rt-dispatch 3 ; +: rt-xt 4 ; +: rt-label 6 ; TUPLE: label-fixup label class ; @@ -133,6 +132,9 @@ SYMBOL: word-table : rel-literal ( literal class -- ) >r add-literal r> rt-literal rel-fixup ; +: rel-this ( class -- ) + 0 swap rt-label rel-fixup ; + : init-fixup ( -- ) V{ } clone relocation-table set V{ } clone label-table set ; diff --git a/core/generator/generator-docs.factor b/core/generator/generator-docs.factor index e5595f7817..029749180e 100755 --- a/core/generator/generator-docs.factor +++ b/core/generator/generator-docs.factor @@ -28,7 +28,8 @@ HELP: compiling-label { $var-description "The label currently being compiled, set by " { $link generate-1 } "." } ; HELP: compiled-stack-traces? -{ $var-description "If set to true, compiled code blocks will retain what word they were compiled from. This information is used by " { $link :c } " to display call stack traces after an error is thrown from compiled code. This variable is on by default; the deployment tool switches it off to save some space in the deployed image." } ; +{ $values { "?" "a boolean" } } +{ $description "Iftrue, compiled code blocks will retain what word they were compiled from. This information is used by " { $link :c } " to display call stack traces after an error is thrown from compiled code. This is on by default; the deployment tool switches it off to save some space in the deployed image." } ; HELP: literal-table { $var-description "Holds a vector of literal objects referenced from the currently compiling word. If " { $link compiled-stack-traces? } " is on, " { $link init-generator } " ensures that the first entry is the word being compiled." } ; diff --git a/core/generator/generator.factor b/core/generator/generator.factor index a33b0650ef..888cbdccaf 100755 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -36,14 +36,12 @@ SYMBOL: compiling-label ! Label of current word, after prologue, makes recursion faster SYMBOL: current-label-start -SYMBOL: compiled-stack-traces? - -t compiled-stack-traces? set-global +: compiled-stack-traces? ( -- ? ) 36 getenv ; : init-generator ( compiling -- ) V{ } clone literal-table set V{ } clone word-table set - compiled-stack-traces? get swap f ? + compiled-stack-traces? swap f ? literal-table get push ; : generate-1 ( word label node quot -- ) @@ -153,10 +151,6 @@ M: #if generate-node with-template generate-if ; -: rel-current-word ( class -- ) - compiling-label get add-word - swap rt-xt-profiling rel-fixup ; - ! #dispatch : dispatch-branch ( node word -- label ) gensym [ diff --git a/vm/code_heap.c b/vm/code_heap.c index 9619e0f640..ecce29229f 100755 --- a/vm/code_heap.c +++ b/vm/code_heap.c @@ -40,10 +40,6 @@ void *get_rel_symbol(F_REL *rel, CELL literals_start) INLINE CELL compute_code_rel(F_REL *rel, CELL code_start, CELL literals_start, CELL words_start) { - CELL obj; - F_WORD *word; - F_QUOTATION *quot; - switch(REL_TYPE(rel)) { case RT_PRIMITIVE: @@ -55,22 +51,7 @@ INLINE CELL compute_code_rel(F_REL *rel, case RT_DISPATCH: return CREF(words_start,REL_ARGUMENT(rel)); case RT_XT: - obj = get(CREF(words_start,REL_ARGUMENT(rel))); - switch(type_of(obj)) - { - case WORD_TYPE: - word = untag_object(obj); - return (CELL)word->xt; - case QUOTATION_TYPE: - quot = untag_object(obj); - return (CELL)quot->xt; - default: - critical_error("Bad parameter to rt-xt relocation",obj); - return -1; /* Can't happen */ - } - case RT_XT_PROFILING: - word = untag_word(get(CREF(words_start,REL_ARGUMENT(rel)))); - return (CELL)(word->code + 1); + return (CELL)untag_word(get(CREF(words_start,REL_ARGUMENT(rel))))->xt; case RT_LABEL: return code_start + REL_ARGUMENT(rel); default: @@ -211,6 +192,11 @@ void deposit_objects(CELL here, F_ARRAY *array) memcpy((void*)here,array + 1,array_capacity(array) * CELLS); } +bool stack_traces_p(void) +{ + return to_boolean(userenv[STACK_TRACES_ENV]); +} + CELL compiled_code_format(void) { return untag_fixnum_fast(userenv[JIT_CODE_FORMAT]); @@ -349,7 +335,9 @@ DEFINE_PRIMITIVE(modify_code_heap) if(data == F) { REGISTER_UNTAGGED(alist); + REGISTER_UNTAGGED(word); default_word_code(word); + UNREGISTER_UNTAGGED(word); UNREGISTER_UNTAGGED(alist); } else diff --git a/vm/code_heap.h b/vm/code_heap.h index 4169a0df2f..e741cf1a75 100755 --- a/vm/code_heap.h +++ b/vm/code_heap.h @@ -9,8 +9,8 @@ typedef enum { RT_DISPATCH, /* a compiled word reference */ RT_XT, - /* a compiled word reference, pointing at the profiling prologue */ - RT_XT_PROFILING, + /* reserved */ + RT_RESERVED, /* a local label */ RT_LABEL } F_RELTYPE; @@ -69,5 +69,6 @@ F_COMPILED *add_compiled_block( F_ARRAY *literals); CELL compiled_code_format(void); +bool stack_traces_p(void); DECLARE_PRIMITIVE(modify_code_heap); diff --git a/vm/factor.c b/vm/factor.c index 105fec17e9..d8fdad4dfd 100755 --- a/vm/factor.c +++ b/vm/factor.c @@ -27,6 +27,7 @@ void default_parameters(F_PARAMETERS *p) p->secure_gc = false; p->fep = false; p->console = false; + p->stack_traces = true; } /* Do some initialization that we do once only */ @@ -96,6 +97,7 @@ void init_factor(F_PARAMETERS *p) userenv[CPU_ENV] = tag_object(from_char_string(FACTOR_CPU_STRING)); userenv[OS_ENV] = tag_object(from_char_string(FACTOR_OS_STRING)); userenv[CELL_SIZE_ENV] = tag_fixnum(sizeof(CELL)); + userenv[STACK_TRACES_ENV] = tag_boolean(p->stack_traces); /* We can GC now */ gc_off = false; @@ -145,7 +147,9 @@ void init_factor_from_args(F_CHAR *image, int argc, F_CHAR **argv, bool embedded else if(STRNCMP(argv[i],STR_FORMAT("-i="),3) == 0) p.image = argv[i] + 3; else if(STRCMP(argv[i],STR_FORMAT("-console")) == 0) - p.console = true ; + p.console = true; + else if(STRCMP(argv[i],STR_FORMAT("-no-stack-traces")) == 0) + p.stack_traces = false; } init_factor(&p); diff --git a/vm/image.h b/vm/image.h index 3774263031..a57d1f5539 100755 --- a/vm/image.h +++ b/vm/image.h @@ -33,6 +33,7 @@ typedef struct { bool secure_gc; bool fep; bool console; + bool stack_traces; } F_PARAMETERS; void load_image(F_PARAMETERS *p); diff --git a/vm/quotations.c b/vm/quotations.c index 1010eaf0b0..b1948fa8a8 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -119,8 +119,7 @@ void jit_compile(CELL quot) GROWABLE_ARRAY(words); REGISTER_ROOT(words); - GROWABLE_ADD(literals,quot); - GROWABLE_ADD(words,quot); + GROWABLE_ADD(literals,stack_traces_p() ? quot : F); bool stack_frame = jit_stack_frame_p(untag_object(array)); diff --git a/vm/run.h b/vm/run.h index dcb3e76bb5..6f2caa0c14 100755 --- a/vm/run.h +++ b/vm/run.h @@ -48,6 +48,8 @@ typedef enum { JIT_RETURN, JIT_PROFILING, + STACK_TRACES_ENV = 36, + UNDEFINED_ENV = 37, /* default quotation for undefined words */ STAGE2_ENV = 39 /* have we bootstrapped? */ } F_ENVTYPE;