JIT improvements; simpler 'current XT' relocation logic

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
+growable namespaces.private assocs words generator command-line
-generator command-line vocabs io prettyprint libc definitions ;
+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? [
+"cpu." cpu append require
-    f compiled-stack-traces? set-global
-] when
 
 nl
 "Compiling some words to speed up bootstrap..." write

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

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 ;
 

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

core/generator/fixup/fixup.factor

@@ -69,7 +69,6 @@ SYMBOL: label-table
 : rt-literal   2 ;
 : rt-dispatch  3 ;
 : rt-xt        4 ;
-: rt-xt-profiling 5 ;
 : 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 ;

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." } ;

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?
+: compiled-stack-traces? ( -- ? ) 36 getenv ;
-
-t compiled-stack-traces? set-global
 
 : 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 [

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)));
+		return (CELL)untag_word(get(CREF(words_start,REL_ARGUMENT(rel))))->xt;
-		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);
 	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

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 */
+	/* reserved */
-	RT_XT_PROFILING,
+	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);

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;
@@ -146,6 +148,8 @@ void init_factor_from_args(F_CHAR *image, int argc, F_CHAR **argv, bool embedded
 			p.image = argv[i] + 3;
 		else if(STRCMP(argv[i],STR_FORMAT("-console")) == 0)
 			p.console = true;
+		else if(STRCMP(argv[i],STR_FORMAT("-no-stack-traces")) == 0)
+			p.stack_traces = false;
 	}
 
 	init_factor(&p);

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);

vm/quotations.c

@@ -119,8 +119,7 @@ void jit_compile(CELL quot)
 	GROWABLE_ARRAY(words);
 	REGISTER_ROOT(words);
 
-	GROWABLE_ADD(literals,quot);
+	GROWABLE_ADD(literals,stack_traces_p() ? quot : F);
-	GROWABLE_ADD(words,quot);
 
 	bool stack_frame = jit_stack_frame_p(untag_object(array));
 

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;