New call-clear primitive

core/bootstrap/primitives.factor

@@ -270,6 +270,7 @@ H{ } clone update-map set
     { "innermost-frame-quot" "kernel.private" }
     { "innermost-frame-scan" "kernel.private" }
     { "set-innermost-frame-quot" "kernel.private" }
+    { "call-clear" "kernel" }
 }
 dup length [ >r first2 r> make-primitive ] 2each
 

core/kernel/kernel-docs.factor

@@ -338,6 +338,11 @@ $nl
     { $code "2 [ 2 + 3 * ] call" "2 2 + 3 *" }
 } ;
 
+HELP: call-clear ( quot -- )
+{ $values { "quot" callable } }
+{ $description "Calls a quotation with an empty call stack. If the quotation returns, Factor will exit.." }
+{ $notes "Used to implement " { $link "threads" } "." } ;
+
 HELP: slip
 { $values { "quot" quotation } { "x" object } }
 { $description "Calls a quotation while hiding the top of the stack." } ;

core/threads/threads.factor

@@ -51,7 +51,7 @@ PRIVATE>
         >r schedule-thread r> [
             V{ } set-catchstack
             { } set-retainstack
-            [ print-error ] recover stop
+            [ [ print-error ] recover stop ] call-clear
         ] (throw)
     ] curry callcc0 ;
 

vm/errors.c

@@ -137,3 +137,9 @@ DEFINE_PRIMITIVE(throw)
 	uncurry(dpop());
 	throw_impl(dpop(),stack_chain->callstack_top);
 }
+
+DEFINE_PRIMITIVE(call_clear)
+{
+	uncurry(dpop());
+	throw_impl(dpop(),stack_chain->callstack_bottom);
+}

vm/errors.h

@@ -35,6 +35,7 @@ void not_implemented_error(void);
 F_FASTCALL void undefined_error(CELL word, F_STACK_FRAME *callstack_top);
 
 DECLARE_PRIMITIVE(throw);
+DECLARE_PRIMITIVE(call_clear);
 
 INLINE void type_check(CELL type, CELL tagged)
 {

vm/primitives.c

@@ -193,4 +193,5 @@ void *primitives[] = {
 	primitive_innermost_stack_frame_quot,
 	primitive_innermost_stack_frame_scan,
 	primitive_set_innermost_stack_frame_quot,
+	primitive_call_clear,
 };