Improved JIT compiler design; better REGISTER_ROOT/UNREGISTER_ROOT stuff

core/cpu/x86/bootstrap.factor

@@ -13,11 +13,11 @@ big-endian off
 : scan-save stack-reg 3 bootstrap-cells [+] ;
 
 [
-    ! arg0 0 MOV                                 ! load quotation
+    arg0 0 [] MOV                              ! load quotation
     arg1 arg0 quot-xt@ [+] MOV                 ! load XT
     arg0 arg0 quot-array@ [+] MOV              ! load array
     scan-reg arg0 scan@ [+] LEA                ! initialize scan pointer
-] rc-absolute-cell rt-literal 1 jit-setup jit-define
+] rc-absolute-cell rt-literal 2 jit-setup jit-define
 
 [
     stack-frame-size PUSH                      ! save stack frame size
@@ -30,27 +30,24 @@ big-endian off
 : advance-scan scan-reg bootstrap-cell ADD ;
 
 [
+    arg0 0 [] MOV                              ! load literal
     advance-scan
     ds-reg bootstrap-cell ADD                  ! increment datastack pointer
-    arg0 scan-reg [] MOV                       ! load literal
     ds-reg [] arg0 MOV                         ! store literal on datastack
-] f f f jit-push-literal jit-define
+] rc-absolute-cell rt-literal 2 jit-push-literal jit-define
-
-[
-    advance-scan
-    ds-reg bootstrap-cell ADD                  ! increment datastack pointer
-    arg0 scan-reg [] MOV                       ! load wrapper
-    arg0 dup wrapper@ [+] MOV                  ! load wrapper-obj slot
-    ds-reg [] arg0 MOV                         ! store literal on datastack
-] f f f jit-push-wrapper jit-define
 
 [
     arg1 stack-reg MOV                         ! pass callstack pointer as arg 2
-] f f f jit-word-primitive-jump jit-define
+    (JMP) drop                                 ! go
+] rc-relative rt-primitive 3 jit-word-primitive-jump jit-define
 
 [
+    advance-scan
     arg1 stack-reg bootstrap-cell neg [+] LEA  ! pass callstack pointer as arg 2
-] f f f jit-word-primitive-call jit-define
+    scan-save scan-reg MOV                     ! save scan pointer
+    (CALL) drop                                ! go
+    scan-reg scan-save MOV                     ! restore scan pointer
+] rc-relative rt-primitive 12 jit-word-primitive-call jit-define
 
 [
     arg0 scan-reg bootstrap-cell [+] MOV       ! load word
@@ -65,35 +62,25 @@ big-endian off
     scan-reg scan-save MOV                     ! restore scan pointer
 ] f f f jit-word-call jit-define
 
-: load-branch
+[
+    arg1 0 MOV                                 ! load addr of true quotation
     arg0 ds-reg [] MOV                         ! load boolean
     ds-reg bootstrap-cell SUB                  ! pop boolean
     arg0 \ f tag-number CMP                    ! compare it with f
-    arg0 scan-reg 2 bootstrap-cells [+] CMOVE  ! load false branch if equal
+    arg0 arg1 [] CMOVNE                        ! load true branch if not equal
-    arg0 scan-reg 1 bootstrap-cells [+] CMOVNE ! load true branch if not equal
+    arg0 arg1 bootstrap-cell [+] CMOVE         ! load false branch if equal
-    scan-reg 3 bootstrap-cells ADD             ! advance scan pointer
+    arg0 quot-xt@ [+] JMP                      ! jump to quotation-xt
-    arg0 quot-xt@ [+]                          ! load quotation-xt
+] rc-absolute-cell rt-literal 1 jit-if-jump jit-define
-    ;
-
-[
-    load-branch JMP
-] f f f jit-if-jump jit-define
-
-[
-    load-branch
-    scan-save scan-reg MOV                     ! save scan pointer
-    CALL                                       ! call quotation
-    scan-reg scan-save MOV                     ! restore scan pointer
-] f f f jit-if-call jit-define
 
 [
+    arg1 0 [] MOV                              ! load dispatch table
     arg0 ds-reg [] MOV                         ! load index
     fixnum>slot@                               ! turn it into an array offset
     ds-reg bootstrap-cell SUB                  ! pop index
-    arg0 scan-reg bootstrap-cell [+] ADD       ! compute quotation location
+    arg0 arg1 ADD                              ! compute quotation location
     arg0 arg0 array-start [+] MOV              ! load quotation
-    arg0 quot-xt@ [+] JMP                      ! jump to quotation-xt
+    arg0 quot-xt@ [+] JMP                      ! execute branch
-] f f f jit-dispatch jit-define
+] rc-absolute-cell rt-literal 2 jit-dispatch jit-define
 
 [
     stack-reg stack-frame-size bootstrap-cell - ADD ! unwind stack frame

core/generator/generator.factor

@@ -15,7 +15,7 @@ SYMBOL: compiled
 : begin-compiling ( word -- )
     f swap compiled get set-at ;
 
-: finish-compiling ( word literals words rel labels code profiler-prologue -- )
+: finish-compiling ( word literals words relocation labels code profiler-prologue -- )
     6array swap compiled get set-at ;
 
 : queue-compile ( word -- )
@@ -39,10 +39,10 @@ SYMBOL: compiled-stack-traces?
 
 t compiled-stack-traces? set-global
 
-: init-generator ( -- )
+: init-generator ( compiling -- )
     V{ } clone literal-table set
     V{ } clone word-table set
-    compiled-stack-traces? get compiling-word get f ?
+    compiled-stack-traces? get swap f ?
     literal-table get push ;
 
 : generate-1 ( word label node quot -- )

vm/callstack.c

@@ -205,7 +205,7 @@ DEFINE_PRIMITIVE(set_innermost_stack_frame_quot)
 	REGISTER_UNTAGGED(quot);
 
 	if(quot->compiledp == F)
-		jit_compile(quot);
+		jit_compile(tag_object(quot));
 
 	UNREGISTER_UNTAGGED(quot);
 	UNREGISTER_UNTAGGED(callstack);

vm/code_heap.c

@@ -258,9 +258,9 @@ F_COMPILED *add_compiled_block(
 	CELL code_format = compiled_code_format();
 
 	CELL code_length = align8(array_capacity(code) * code_format);
-	CELL rel_length = (relocation ? array_capacity(relocation) * sizeof(unsigned int) : 0);
+	CELL rel_length = array_capacity(relocation) * sizeof(unsigned int);
-	CELL words_length = (words ? array_capacity(words) * CELLS : 0);
+	CELL words_length = array_capacity(words) * CELLS;
-	CELL literals_length = (literals ? array_capacity(literals) * CELLS : 0);
+	CELL literals_length = array_capacity(literals) * CELLS;
 
 	REGISTER_UNTAGGED(code);
 	REGISTER_UNTAGGED(labels);
@@ -295,25 +295,16 @@ F_COMPILED *add_compiled_block(
 	here += code_length;
 
 	/* relation info */
-	if(relocation)
+	deposit_integers(here,relocation,sizeof(unsigned int));
-	{
+	here += rel_length;
-		deposit_integers(here,relocation,sizeof(unsigned int));
-		here += rel_length;
-	}
 
 	/* literals */
-	if(literals)
+	deposit_objects(here,literals);
-	{
+	here += literals_length;
-		deposit_objects(here,literals);
-		here += literals_length;
-	}
 
 	/* words */
-	if(words)
+	deposit_objects(here,words);
-	{
+	here += words_length;
-		deposit_objects(here,words);
-		here += words_length;
-	}
 
 	/* fixup labels */
 	if(labels)

vm/data_gc.c

@@ -126,6 +126,9 @@ void init_data_heap(CELL gens,
 {
 	set_data_heap(alloc_data_heap(gens,young_size,aging_size));
 
+	gc_locals_region = alloc_segment(getpagesize());
+	gc_locals = gc_locals_region->start - CELLS;
+
 	extra_roots_region = alloc_segment(getpagesize());
 	extra_roots = extra_roots_region->start - CELLS;
 
@@ -369,10 +372,9 @@ void collect_cards(void)
 /* Copy all tagged pointers in a range of memory */
 void collect_stack(F_SEGMENT *region, CELL top)
 {
-	CELL bottom = region->start;
+	CELL ptr = region->start;
-	CELL ptr;
 
-	for(ptr = bottom; ptr <= top; ptr += CELLS)
+	for(; ptr <= top; ptr += CELLS)
 		copy_handle((CELL*)ptr);
 }
 
@@ -398,6 +400,14 @@ void collect_callstack(F_CONTEXT *stacks)
 	iterate_callstack(top,bottom,collect_stack_frame);
 }
 
+void collect_gc_locals(void)
+{
+	CELL ptr = gc_locals_region->start;
+
+	for(; ptr <= gc_locals; ptr += CELLS)
+		copy_handle(*(CELL **)ptr);
+}
+
 /* Copy roots over at the start of GC, namely various constants, stacks,
 the user environment and extra roots registered with REGISTER_ROOT */
 void collect_roots(void)
@@ -407,6 +417,7 @@ void collect_roots(void)
 	copy_handle(&bignum_pos_one);
 	copy_handle(&bignum_neg_one);
 
+	collect_gc_locals();
 	collect_stack(extra_roots_region,extra_roots);
 
 	save_stacks();

vm/data_gc.h

@@ -228,14 +228,38 @@ void garbage_collection(volatile CELL gen,
 /* If a runtime function needs to call another function which potentially
 allocates memory, it must store any local variable references to Factor
 objects on the root stack */
+
+/* GC locals: stores addresses of pointers to objects. The GC updates these
+pointers, so you can do
+
+REGISTER_ROOT(some_local);
+
+... allocate memory ...
+
+foo(some_local);
+
+...
+
+UNREGISTER_ROOT(some_local); */
+F_SEGMENT *gc_locals_region;
+CELL gc_locals;
+
+DEFPUSHPOP(gc_local_,gc_locals)
+
+#define REGISTER_ROOT(obj) gc_local_push((CELL)&obj)
+#define UNREGISTER_ROOT(obj) \
+	{ \
+		if(gc_local_pop() != (CELL)&obj) \
+			critical_error("Mismatched REGISTER_ROOT/UNREGISTER_ROOT",0); \
+	}
+
+/* Extra roots: stores pointers to objects in the heap. Requires extra work
+(you have to unregister before accessing the object) but more flexible. */
 F_SEGMENT *extra_roots_region;
 CELL extra_roots;
 
 DEFPUSHPOP(root_,extra_roots)
 
-#define REGISTER_ROOT(obj) root_push(obj)
-#define UNREGISTER_ROOT(obj) obj = root_pop()
-
 #define REGISTER_UNTAGGED(obj) root_push(obj ? tag_object(obj) : 0)
 #define UNREGISTER_UNTAGGED(obj) obj = untag_object(root_pop())
 

vm/errors.c

@@ -23,7 +23,8 @@ void throw_error(CELL error, F_STACK_FRAME *callstack_top)
 		gc_off = false;
 
 		/* Reset local roots */
-		extra_roots = stack_chain->extra_roots;
+		gc_locals = gc_locals_region->start - CELLS;
+		extra_roots = extra_roots_region->start - CELLS;
 
 		/* If we had an underflow or overflow, stack pointers might be
 		out of bounds */
@@ -104,10 +105,14 @@ void memory_protection_error(CELL addr, F_STACK_FRAME *native_stack)
 		general_error(ERROR_RS_OVERFLOW,F,F,native_stack);
 	else if(in_page(addr, nursery->end, 0, 0))
 		critical_error("allot_object() missed GC check",0);
+	else if(in_page(addr, gc_locals_region->start, 0, -1))
+		critical_error("gc locals underflow",0);
+	else if(in_page(addr, gc_locals_region->end, 0, 0))
+		critical_error("gc locals overflow",0);
 	else if(in_page(addr, extra_roots_region->start, 0, -1))
-		critical_error("local root underflow",0);
+		critical_error("extra roots underflow",0);
 	else if(in_page(addr, extra_roots_region->end, 0, 0))
-		critical_error("local root overflow",0);
+		critical_error("extra roots overflow",0);
 	else
 		general_error(ERROR_MEMORY,allot_cell(addr),F,native_stack);
 }

vm/os-unix.c

@@ -94,6 +94,7 @@ DEFINE_PRIMITIVE(read_dir)
 {
 	DIR* dir = opendir(unbox_char_string());
 	GROWABLE_ARRAY(result);
+	REGISTER_ROOT(result);
 
 	if(dir != NULL)
 	{
@@ -101,18 +102,17 @@ DEFINE_PRIMITIVE(read_dir)
 
 		while((file = readdir(dir)) != NULL)
 		{
-			REGISTER_UNTAGGED(result);
 			CELL pair = parse_dir_entry(file);
-			UNREGISTER_UNTAGGED(result);
 			GROWABLE_ADD(result,pair);
 		}
 
 		closedir(dir);
 	}
 
+	UNREGISTER_ROOT(result);
 	GROWABLE_TRIM(result);
 
-	dpush(tag_object(result));
+	dpush(result);
 }
 
 DEFINE_PRIMITIVE(cwd)
@@ -131,19 +131,19 @@ DEFINE_PRIMITIVE(cd)
 DEFINE_PRIMITIVE(os_envs)
 {
 	GROWABLE_ARRAY(result);
+	REGISTER_ROOT(result);
 	char **env = environ;
 
 	while(*env)
 	{
-		REGISTER_UNTAGGED(result);
 		CELL string = tag_object(from_char_string(*env));
-		UNREGISTER_UNTAGGED(result);
 		GROWABLE_ADD(result,string);
 		env++;
 	}
 
+	UNREGISTER_ROOT(result);
 	GROWABLE_TRIM(result);
-	dpush(tag_object(result));
+	dpush(result);
 }
 
 F_SEGMENT *alloc_segment(CELL size)

vm/os-windows-nt.c

@@ -26,6 +26,7 @@ DEFINE_PRIMITIVE(cd)
 DEFINE_PRIMITIVE(os_envs)
 {
 	GROWABLE_ARRAY(result);
+	REGISTER_ROOT(result);
 
 	TCHAR *env = GetEnvironmentStrings();
 	TCHAR *finger = env;
@@ -38,9 +39,7 @@ DEFINE_PRIMITIVE(os_envs)
 		if(scan == finger)
 			break;
 
-		REGISTER_UNTAGGED(result);
 		CELL string = tag_object(from_u16_string(finger));
-		UNREGISTER_UNTAGGED(result);
 		GROWABLE_ADD(result,string);
 
 		finger = scan + 1;
@@ -48,8 +47,9 @@ DEFINE_PRIMITIVE(os_envs)
 
 	FreeEnvironmentStrings(env);
 
+	UNREGISTER_ROOT(result);
 	GROWABLE_TRIM(result);
-	dpush(tag_object(result));
+	dpush(result);
 }
 
 long exception_handler(PEXCEPTION_POINTERS pe)

vm/os-windows.c

@@ -173,25 +173,25 @@ DEFINE_PRIMITIVE(read_dir)
 	F_CHAR *path = unbox_u16_string();
 
 	GROWABLE_ARRAY(result);
+	REGISTER_ROOT(result);
 
 	if(INVALID_HANDLE_VALUE != (dir = FindFirstFile(path, &find_data)))
 	{
 		do
 		{
-			REGISTER_UNTAGGED(result);
 			CELL name = tag_object(from_u16_string(find_data.cFileName));
 			CELL dirp = tag_boolean(find_data.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY);
 			CELL pair = allot_array_2(name,dirp);
-			UNREGISTER_UNTAGGED(result);
 			GROWABLE_ADD(result,pair);
 		}
 		while (FindNextFile(dir, &find_data));
 		CloseHandle(dir);
 	}
 
+	UNREGISTER_ROOT(result);
 	GROWABLE_TRIM(result);
 
-	dpush(tag_object(result));
+	dpush(result);
 }
 
 F_SEGMENT *alloc_segment(CELL size)

vm/quotations.c

@@ -5,7 +5,7 @@ the second one is written in Factor and performs a lot of optimizations.
 See core/compiler/compiler.factor */
 bool jit_fast_if_p(F_ARRAY *array, CELL i)
 {
-	return (i + 3) <= array_capacity(array)
+	return (i + 3) == array_capacity(array)
 		&& type_of(array_nth(array,i)) == QUOTATION_TYPE
 		&& type_of(array_nth(array,i + 1)) == QUOTATION_TYPE
 		&& array_nth(array,i + 2) == userenv[JIT_IF_WORD];
@@ -14,6 +14,7 @@ bool jit_fast_if_p(F_ARRAY *array, CELL i)
 bool jit_fast_dispatch_p(F_ARRAY *array, CELL i)
 {
 	return (i + 2) == array_capacity(array)
+		&& type_of(array_nth(array,i)) == ARRAY_TYPE
 		&& array_nth(array,i + 1) == userenv[JIT_DISPATCH_WORD];
 }
 
@@ -22,10 +23,44 @@ F_ARRAY *code_to_emit(CELL name)
 	return untag_object(array_nth(untag_object(userenv[name]),0));
 }
 
-#define EMIT(name) { \
+F_REL rel_to_emit(CELL name, CELL code_format, CELL code_length,
-		REGISTER_UNTAGGED(array); \
+	CELL rel_argument, bool *rel_p)
+{
+	F_ARRAY *quadruple = untag_object(userenv[name]);
+	CELL rel_class = array_nth(quadruple,1);
+	CELL rel_type = array_nth(quadruple,2);
+	CELL offset = array_nth(quadruple,3);
+
+	F_REL rel;
+
+	if(rel_class == F)
+	{
+		*rel_p = false;
+		rel.type = 0;
+		rel.offset = 0;
+	}
+	else
+	{
+		*rel_p = true;
+		rel.type = to_fixnum(rel_type)
+			| (to_fixnum(rel_class) << 8)
+			| (rel_argument << 16);
+		rel.offset = code_length * code_format + to_fixnum(offset);
+	}
+
+	return rel;
+}
+
+#define EMIT(name,rel_argument) { \
+		bool rel_p; \
+		F_REL rel = rel_to_emit(name,code_format,code_count, \
+			rel_argument,&rel_p); \
+		if(rel_p) \
+		{ \
+			GROWABLE_ADD(relocation,allot_cell(rel.type)); \
+			GROWABLE_ADD(relocation,allot_cell(rel.offset)); \
+		} \
 		GROWABLE_APPEND(code,code_to_emit(name)); \
-		UNREGISTER_UNTAGGED(array); \
 	}
 
 bool jit_stack_frame_p(F_ARRAY *array)
@@ -52,32 +87,47 @@ void set_quot_xt(F_QUOTATION *quot, F_COMPILED *code)
 	quot->compiledp = T;
 }
 
-void jit_compile(F_QUOTATION *quot)
+/* Might GC */
+void jit_compile(CELL quot)
 {
-	F_ARRAY *array = untag_object(quot->array);
+	CELL code_format = compiled_code_format();
 
-	REGISTER_UNTAGGED(quot);
+	REGISTER_ROOT(quot);
+
+	CELL array = untag_quotation(quot)->array;
+	REGISTER_ROOT(array);
 
-	REGISTER_UNTAGGED(array);
 	GROWABLE_ARRAY(code);
-	UNREGISTER_UNTAGGED(array);
+	REGISTER_ROOT(code);
 
-	bool stack_frame = jit_stack_frame_p(array);
+	GROWABLE_ARRAY(relocation);
+	REGISTER_ROOT(relocation);
 
-	EMIT(JIT_SETUP);
+	GROWABLE_ARRAY(literals);
+	REGISTER_ROOT(literals);
+
+	GROWABLE_ARRAY(words);
+	REGISTER_ROOT(words);
+
+	GROWABLE_ADD(literals,quot);
+
+	bool stack_frame = jit_stack_frame_p(untag_object(array));
+
+	EMIT(JIT_SETUP,0);
 
 	if(stack_frame)
-		EMIT(JIT_PROLOG);
+		EMIT(JIT_PROLOG,0);
 
 	CELL i;
-	CELL length = array_capacity(array);
+	CELL length = array_capacity(untag_object(array));
 	bool tail_call = false;
 
 	for(i = 0; i < length; i++)
 	{
-		CELL obj = array_nth(array,i);
+		CELL obj = array_nth(untag_object(array),i);
 		F_WORD *word;
 		bool primitive_p;
+		F_WRAPPER *wrapper;
 
 		switch(type_of(obj))
 		{
@@ -91,57 +141,65 @@ void jit_compile(F_QUOTATION *quot)
 			if(i == length - 1)
 			{
 				if(stack_frame)
-					EMIT(JIT_EPILOG);
+					EMIT(JIT_EPILOG,0);
 
 				if(primitive_p)
-					EMIT(JIT_WORD_PRIMITIVE_JUMP);
+				{
-
+					EMIT(JIT_WORD_PRIMITIVE_JUMP,
-				EMIT(JIT_WORD_JUMP);
+						to_fixnum(word->def));
+				}
+				else
+					EMIT(JIT_WORD_JUMP,0);
 				tail_call = true;
 			}
 			else
 			{
 				if(primitive_p)
-					EMIT(JIT_WORD_PRIMITIVE_CALL);
+				{
-
+					EMIT(JIT_WORD_PRIMITIVE_CALL,
-				EMIT(JIT_WORD_CALL);
+						to_fixnum(word->def));
+				}
+				else
+					EMIT(JIT_WORD_CALL,0);
 			}
 			break;
 		case WRAPPER_TYPE:
-			EMIT(JIT_PUSH_WRAPPER);
+			wrapper = untag_object(obj);
+			GROWABLE_ADD(literals,wrapper->object);
+			EMIT(JIT_PUSH_LITERAL,literals_count - 1);
 			break;
 		case QUOTATION_TYPE:
-			if(jit_fast_if_p(array,i))
+			if(jit_fast_if_p(untag_object(array),i))
 			{
+				if(stack_frame)
+					EMIT(JIT_EPILOG,0);
+
+				GROWABLE_ADD(literals,array_nth(untag_object(array),i));
+				GROWABLE_ADD(literals,array_nth(untag_object(array),i + 1));
+				EMIT(JIT_IF_JUMP,literals_count - 2);
+
 				i += 2;
 
-				if(i == length - 1)
+				tail_call = true;
-				{
-					if(stack_frame)
-						EMIT(JIT_EPILOG);
-					EMIT(JIT_IF_JUMP);
-					tail_call = true;
-				}
-				else
-					EMIT(JIT_IF_CALL);
-
 				break;
 			}
 		case ARRAY_TYPE:
-			if(jit_fast_dispatch_p(array,i))
+			if(jit_fast_dispatch_p(untag_object(array),i))
 			{
-				i++;
-
 				if(stack_frame)
-					EMIT(JIT_EPILOG);
+					EMIT(JIT_EPILOG,0);
 
-				EMIT(JIT_DISPATCH);
+				GROWABLE_ADD(literals,array_nth(untag_object(array),i));
+				EMIT(JIT_DISPATCH,literals_count - 1);
+
+				i++;
 
 				tail_call = true;
 				break;
 			}
 		default:
-			EMIT(JIT_PUSH_LITERAL);
+			GROWABLE_ADD(literals,obj);
+			EMIT(JIT_PUSH_LITERAL,literals_count - 1);
 			break;
 		}
 	}
@@ -149,52 +207,44 @@ void jit_compile(F_QUOTATION *quot)
 	if(!tail_call)
 	{
 		if(stack_frame)
-			EMIT(JIT_EPILOG);
+			EMIT(JIT_EPILOG,0);
 
-		EMIT(JIT_RETURN);
+		EMIT(JIT_RETURN,0);
 	}
 
 	GROWABLE_TRIM(code);
+	GROWABLE_TRIM(relocation);
+	GROWABLE_TRIM(literals);
+	GROWABLE_TRIM(words);
 
-	UNREGISTER_UNTAGGED(quot);
+	F_COMPILED *compiled = add_compiled_block(
-	REGISTER_UNTAGGED(quot);
+		QUOTATION_TYPE,
+		0,
+		untag_object(code),
+		NULL,
+		untag_object(relocation),
+		untag_object(words),
+		untag_object(literals));
 
-	REGISTER_UNTAGGED(code);
-	F_ARRAY *literals = allot_array(ARRAY_TYPE,1,tag_object(quot));
-	UNREGISTER_UNTAGGED(code);
-
-	F_COMPILED *compiled = add_compiled_block(QUOTATION_TYPE,0,code,NULL,NULL,NULL,literals);
 	iterate_code_heap_step(compiled,finalize_code_block);
 
-	UNREGISTER_UNTAGGED(quot);
+	set_quot_xt(untag_object(quot),compiled);
-	set_quot_xt(quot,compiled);
+
+	UNREGISTER_ROOT(words);
+	UNREGISTER_ROOT(literals);
+	UNREGISTER_ROOT(relocation);
+	UNREGISTER_ROOT(code);
+	UNREGISTER_ROOT(array);
+	UNREGISTER_ROOT(quot);
 }
 
-F_FASTCALL CELL primitive_jit_compile(CELL tagged, F_STACK_FRAME *stack)
+F_FASTCALL CELL primitive_jit_compile(CELL quot, F_STACK_FRAME *stack)
 {
 	stack_chain->callstack_top = stack;
-	REGISTER_ROOT(tagged);
+	REGISTER_ROOT(quot);
-	jit_compile(untag_quotation(tagged));
+	jit_compile(quot);
-	UNREGISTER_ROOT(tagged);
+	UNREGISTER_ROOT(quot);
-	return tagged;
+	return quot;
-}
-
-XT quot_offset_to_pc(F_QUOTATION *quot, F_FIXNUM offset)
-{
-	if(offset != -1)
-		critical_error("Not yet implemented",0);
-
-	CELL xt = 0;
-
-	xt += array_capacity(code_to_emit(JIT_SETUP));
-
-	bool stack_frame = jit_stack_frame_p(untag_array(quot->array));
-	if(stack_frame)
-		xt += array_capacity(code_to_emit(JIT_PROLOG));
-
-	xt *= compiled_code_format();
-
-	return quot->xt + xt;
 }
 
 DEFINE_PRIMITIVE(curry)

vm/quotations.h

@@ -1,7 +1,6 @@
 void set_quot_xt(F_QUOTATION *quot, F_COMPILED *code);
-void jit_compile(F_QUOTATION *quot);
+void jit_compile(CELL quot);
-F_FASTCALL CELL primitive_jit_compile(CELL tagged, F_STACK_FRAME *stack);
+F_FASTCALL CELL primitive_jit_compile(CELL quot, F_STACK_FRAME *stack);
-XT quot_offset_to_pc(F_QUOTATION *quot, F_FIXNUM offset);
 void uncurry(CELL obj);
 DECLARE_PRIMITIVE(curry);
 DECLARE_PRIMITIVE(array_to_quotation);

vm/run.c

@@ -54,8 +54,6 @@ void nest_stacks(void)
 	new_stacks->datastack_region = alloc_segment(ds_size);
 	new_stacks->retainstack_region = alloc_segment(rs_size);
 
-	new_stacks->extra_roots = extra_roots;
-
 	new_stacks->next = stack_chain;
 	stack_chain = new_stacks;
 
@@ -76,8 +74,6 @@ void unnest_stacks(void)
 	userenv[CURRENT_CALLBACK_ENV] = stack_chain->current_callback_save;
 	userenv[CATCHSTACK_ENV] = stack_chain->catchstack_save;
 
-	extra_roots = stack_chain->extra_roots;
-
 	F_CONTEXT *old_stacks = stack_chain;
 	stack_chain = old_stacks->next;
 	free(old_stacks);

vm/run.h

@@ -183,9 +183,6 @@ typedef struct _F_CONTEXT {
 	CELL catchstack_save;
 	CELL current_callback_save;
 
-	/* saved extra_roots pointer on entry to callback */
-	CELL extra_roots;
-
 	struct _F_CONTEXT *next;
 } F_CONTEXT;
 

vm/types.h

@@ -194,7 +194,7 @@ DECLARE_PRIMITIVE(wrapper);
 /* Macros to simulate a vector in C */
 #define GROWABLE_ARRAY(result) \
 	CELL result##_count = 0; \
-	F_ARRAY *result = allot_array(ARRAY_TYPE,100,F)
+	CELL result = tag_object(allot_array(ARRAY_TYPE,100,F))
 
 INLINE F_ARRAY *growable_add(F_ARRAY *result, CELL elt, CELL *result_count)
 {
@@ -214,7 +214,7 @@ INLINE F_ARRAY *growable_add(F_ARRAY *result, CELL elt, CELL *result_count)
 }
 
 #define GROWABLE_ADD(result,elt) \
-	result = growable_add(result,elt,&result##_count)
+	result = tag_object(growable_add(untag_object(result),elt,&result##_count))
 
 INLINE F_ARRAY *growable_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_count)
 {
@@ -236,6 +236,7 @@ INLINE F_ARRAY *growable_append(F_ARRAY *result, F_ARRAY *elts, CELL *result_cou
 }
 
 #define GROWABLE_APPEND(result,elts) \
-	result = growable_append(result,elts,&result##_count)
+	result = tag_object(growable_append(untag_object(result),elts,&result##_count))
-	
+
-#define GROWABLE_TRIM(result) result = reallot_array(result,result##_count,F)
+#define GROWABLE_TRIM(result) \
+	result = tag_object(reallot_array(untag_object(result),result##_count,F))