Re-implement callstack>array

vm/callstack.c

@@ -123,9 +123,20 @@ F_STACK_FRAME *frame_successor(F_STACK_FRAME *frame)
 
 CELL frame_scan(F_STACK_FRAME *frame)
 {
-	//XXX
 	if(frame_type(frame) == QUOTATION_TYPE)
-		return tag_fixnum(0); //UNAREF(UNTAG(frame->array),frame->scan));
+	{
+		CELL quot = frame_executing(frame);
+		if(quot == F)
+			return F;
+		else
+		{
+			XT return_addr = FRAME_RETURN_ADDRESS(frame);
+			XT quot_xt = (XT)(frame_code(frame) + 1);
+
+			return tag_fixnum(quot_code_offset_to_scan(
+				quot,(CELL)(return_addr - quot_xt)));
+		}
+	}
 	else
 		return F;
 }
@@ -214,14 +225,8 @@ DEFINE_PRIMITIVE(set_innermost_stack_frame_quot)
 	F_STACK_FRAME *inner = innermost_stack_frame(callstack);
 	type_check(QUOTATION_TYPE,frame_executing(inner));
 
-	//XXX
-
-	//CELL scan = inner->scan - inner->array;
 	CELL offset = FRAME_RETURN_ADDRESS(inner) - inner->xt;
 
-	//inner->array = quot->array;
-	//inner->scan = quot->array + scan;
-
 	inner->xt = quot->xt;
 
 	FRAME_RETURN_ADDRESS(inner) = quot->xt + offset;

vm/quotations.c

@@ -246,6 +246,108 @@ void jit_compile(CELL quot)
 	UNREGISTER_ROOT(quot);
 }
 
+/* Crappy code duplication. If C had closures (not just function pointers)
+it would be easy to get rid of, but I can't think of a good way to deal
+with it right now that doesn't involve lots of boilerplate that would be
+worse than the duplication itself (eg, putting all state in some global
+struct.) */
+#define COUNT(name,scan) \
+	{ \
+		if(offset == 0) return scan - 1; \
+		offset -= array_capacity(code_to_emit(name)) * code_format; \
+	}
+
+F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset)
+{
+	CELL code_format = compiled_code_format();
+
+	CELL array = untag_quotation(quot)->array;
+
+	bool stack_frame = jit_stack_frame_p(untag_object(array));
+
+	if(stack_frame)
+		COUNT(JIT_PROLOG,0)
+
+	CELL i;
+	CELL length = array_capacity(untag_object(array));
+	bool tail_call = false;
+
+	for(i = 0; i < length; i++)
+	{
+		CELL obj = array_nth(untag_object(array),i);
+		F_WORD *word;
+
+		switch(type_of(obj))
+		{
+		case WORD_TYPE:
+			word = untag_object(obj);
+
+			if(i == length - 1)
+			{
+				if(stack_frame)
+					COUNT(JIT_EPILOG,i);
+
+				if(type_of(word->def) == FIXNUM_TYPE)
+					COUNT(JIT_WORD_PRIMITIVE_JUMP,i)
+				else
+					COUNT(JIT_WORD_JUMP,i)
+
+				tail_call = true;
+			}
+			else
+			{
+				if(type_of(word->def) == FIXNUM_TYPE)
+					COUNT(JIT_WORD_PRIMITIVE_CALL,i)
+				else
+					COUNT(JIT_WORD_CALL,i)
+			}
+			break;
+		case WRAPPER_TYPE:
+			COUNT(JIT_PUSH_LITERAL,i)
+			break;
+		case QUOTATION_TYPE:
+			if(jit_fast_if_p(untag_object(array),i))
+			{
+				if(stack_frame)
+					COUNT(JIT_EPILOG,i)
+
+				i += 2;
+
+				COUNT(JIT_IF_JUMP,i)
+
+				tail_call = true;
+				break;
+			}
+		case ARRAY_TYPE:
+			if(jit_fast_dispatch_p(untag_object(array),i))
+			{
+				if(stack_frame)
+					COUNT(JIT_EPILOG,i)
+
+				i++;
+
+				COUNT(JIT_DISPATCH,i)
+
+				tail_call = true;
+				break;
+			}
+		default:
+			COUNT(JIT_PUSH_LITERAL,i)
+			break;
+		}
+	}
+
+	if(!tail_call)
+	{
+		if(stack_frame)
+			COUNT(JIT_EPILOG,length)
+
+		COUNT(JIT_RETURN,length)
+	}
+
+	return -1;
+}
+
 F_FASTCALL CELL primitive_jit_compile(CELL quot, F_STACK_FRAME *stack)
 {
 	stack_chain->callstack_top = stack;

vm/quotations.h

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