The attached patch[*] makes the ctak benchmark (v8/src/bench/ctak.scm)
faster by a factor of more than twenty when compiled, by making CWCC
avoid aborting to the interpreter when called from compiled code. The
patch changes both the microcode and the runtime, although the patched
runtime should run on old microcodes; I changed the runtime only to
make it more tolerant of variation in the microcode's continuation
data structures. If this looks good, I'll commit it, but not until it
has been reviewed and/or tested more thoroughly -- details below.
[*] Apply cwcc.patch with `patch -p1 < /path/to/cwcc.patch' from the
top level of the Git repository.
I have only lightly tested this patch, but it works well enough to run
Edwin, ctak, and some other random CWCC craziness. Here are three
issues that I'm concerned about, because I have focussed more on
making it work in real code than on verifying these properties:
1. I don't know whether the patch keeps the interpreter history data
structures consistent. In particular, in making the stack parser a
little more tolerant of variation in the microcode's data
structures, I changed its behaviour concerning history a little
bit, because it was not obvious how to preserve the original
behaviour. I seldom use the interpreter history anyway, so I
shouldn't recognize a change in its behaviour immediately if there
were one.
2. I don't know whether the patch preserves proper tail recursion.
The old code had a comment about an `optimization', which was
actually needed in order to preserve proper tail recursion,
although when mixing compiled and interpreted code, CWCC failed to
do so anyway. For example, the following should be an infinite
loop that runs in a constant amount of space, bounded by the size
of the continuation of its caller:
(let* ((interpreted-receiver (lambda (receiver) (lambda (k) (receiver k))))
(compiled-receiver (compile-procedure interpreted-receiver)))
(let loop ()
(call-with-current-continuation
(interpreted-receiver
(lambda (k)
k
(call-with-current-continuation
(compiled-receiver (lambda (k) k (loop)))))))))
With the old code, running this in the interpreter overflows the
heap. With the patch, it doesn't.
3. I am not sure whether the stack parser is still correct, or in fact
whether it was correct before. For example, the procedure
STACK-FRAME/SKIP-NON-SUBPROBLEMS has a funny clause for the case
when STACK-FRAME is a stack marker frame:
(let loop ((stack-frame stack-frame))
(let ((stack-frame (stack-frame/next stack-frame)))
(and stack-frame
(if (stack-frame/subproblem? stack-frame)
(stack-frame/next-subproblem stack-frame)
(loop stack-frame)))))
Thus it appears to skip the first subproblem after a stack marker
frame. After an earlier version of the patch, the stack parser
behaved strangely, until I changed the second instance of
(STACK-FRAME/NEXT-SUBPROBLEM STACK-FRAME) to be simply STACK-FRAME.
Moreover, making this change caused the frame for the continuation
of (WITH-INTERRUPT-MASK ...) in
((compile-procedure
(lambda ()
(foo (bar (with-interrupt-mask interrupt-mask/all
(lambda (i)
(+ 3 (car i))))))))),
to appear as expected, while the current version of Scheme omits
it.
Also, I'm not sure that conpar.scm's CONTINUATION-RETURN-ADDRESS is
needed any longer, probably as of the v15 microcode, or perhaps as
of the elimination of non-reentrant CWCC. For that matter, it
appears to be computed specifically under the assumption that CWCC
is not properly tail-recursive. Its value in a current version of
Scheme is some compiled return address internal to conpar.scm which
will presumably never turn up in any continuation except during the
cold load when INITIALIZE-SPECIAL-FRAMES! is called.
(In the process of patching conpar.scm, I removed some vestiges of
v8 code, which probably doesn't affect anyone. Interested parties
may find those vestiges still in v8/src/runtime/conpar.scm.)
diff --git a/src/microcode/cmpint.c b/src/microcode/cmpint.c
index 52e0c6e..5cb0868 100644
--- a/src/microcode/cmpint.c
+++ b/src/microcode/cmpint.c
@@ -71,7 +71,8 @@ typedef enum
REFLECT_CODE_INTERNAL_APPLY,
REFLECT_CODE_RESTORE_INTERRUPT_MASK,
REFLECT_CODE_STACK_MARKER,
- REFLECT_CODE_CC_BKPT
+ REFLECT_CODE_CC_BKPT,
+ REFLECT_CODE_RESTORE_CONTROL_POINT,
} reflect_code_t;
#define PUSH_REFLECTION(code) do \
@@ -1495,6 +1496,74 @@ apply_compiled_from_primitive (unsigned long n_args,
SCHEME_OBJECT procedure)
PUSH_REFLECTION (REFLECT_CODE_INTERNAL_APPLY);
}
}
+
+void
+setup_compiled_control_point (void)
+{
+ /* The number of objects we push here must match the definition of
+ COMPILED_CODE_POINT_OVERHEAD in cmpint.h. Pushing
+ RC_REENTER_COMPILED_CODE enables the interpreter to unpack the
+ control point without needing to check the stack for a compiled
+ return address; restore_compiled_control_point just skips it. */
+
+ STACK_PUSH (ULONG_TO_FIXNUM (GET_INT_MASK)); /* 1 */
+ PUSH_REFLECTION (REFLECT_CODE_RESTORE_INTERRUPT_MASK); /* 2 */
+ SAVE_LAST_RETURN_CODE (RC_REENTER_COMPILED_CODE); /* 2 */
+}
+
+static void
+restore_compiled_control_point (void)
+{
+ unpack_control_point (STACK_POP ());
+ RESTORE_CONT ();
+ assert (GET_RC == RC_REENTER_COMPILED_CODE);
+ RESTORE_LAST_RETURN_CODE ();
+}
+
+void
+setup_compiled_control_point_restoration (SCHEME_OBJECT control_point)
+{
+ /* The JOIN-STACKLETS return code serves no functional purpose; it
+ is pushed to appease the stack parsers (both the runtime's in
+ conpar.scm and the microcode's in debug.c) and the last return
+ code abstraction, which requires that some interpreter return
+ code be on the stack at all times. */
+
+ /* FIXME: Update the stack parsers, and figure out what to do about
+ the last return code. */
+
+ SET_RC (RC_JOIN_STACKLETS);
+ SET_EXP (control_point);
+ SAVE_CONT ();
+ last_return_code = (STACK_LOC (CONTINUATION_RETURN_CODE));
+ STACK_PUSH (control_point);
+ PUSH_REFLECTION (REFLECT_CODE_RESTORE_CONTROL_POINT);
+}
+
+SCHEME_OBJECT
+reuse_compiled_control_point (long return_address_offset)
+{
+ return
+ ((((STACK_REF (return_address_offset)) == reflect_to_interface)
+ && ((OBJECT_DATUM (STACK_REF (return_address_offset + 1)))
+ == REFLECT_CODE_RESTORE_CONTROL_POINT))
+ ? (STACK_REF (return_address_offset + 2))
+ : SHARP_F);
+}
+
+void
+compiled_catch (SCHEME_OBJECT procedure, SCHEME_OBJECT control_point)
+{
+ STACK_PUSH (control_point);
+ setup_compiled_invocation_from_primitive (procedure, 1);
+}
+
+void
+compiled_throw (SCHEME_OBJECT thunk, SCHEME_OBJECT control_point)
+{
+ setup_compiled_control_point_restoration (control_point);
+ setup_compiled_invocation_from_primitive (thunk, 0);
+}
void
compiled_with_interrupt_mask (unsigned long old_mask,
@@ -2108,6 +2177,10 @@ DEFINE_TRAMPOLINE (comutil_reflect_to_interface)
RETURN_TO_SCHEME (addr);
}
+ case REFLECT_CODE_RESTORE_CONTROL_POINT:
+ restore_compiled_control_point ();
+ INVOKE_RETURN_ADDRESS ();
+
default:
STACK_PUSH (code);
RETURN_TO_C (ERR_EXTERNAL_RETURN);
diff --git a/src/microcode/cmpint.h b/src/microcode/cmpint.h
index 2c92fc8..221bad4 100644
--- a/src/microcode/cmpint.h
+++ b/src/microcode/cmpint.h
@@ -388,10 +388,21 @@ extern long apply_compiled_procedure (void);
extern long return_to_compiled_code (void);
extern void apply_compiled_from_primitive (unsigned long, SCHEME_OBJECT);
+extern void compiled_catch (SCHEME_OBJECT, SCHEME_OBJECT);
+extern void compiled_throw (SCHEME_OBJECT, SCHEME_OBJECT);
extern void compiled_with_interrupt_mask
(unsigned long, SCHEME_OBJECT, unsigned long);
extern void compiled_with_stack_marker (SCHEME_OBJECT);
+/* This is the number of objects that setup_compiled_control_point
+ pushes onto the stack. */
+
+#define COMPILED_CONTROL_POINT_OVERHEAD 5
+
+extern SCHEME_OBJECT reuse_compiled_control_point (long);
+extern void setup_compiled_control_point (void);
+extern void setup_compiled_control_point_restoration (SCHEME_OBJECT);
+
extern void compiler_initialize (bool);
extern void compiler_reset (SCHEME_OBJECT);
diff --git a/src/microcode/hooks.c b/src/microcode/hooks.c
index 7354509..dfdc525 100644
--- a/src/microcode/hooks.c
+++ b/src/microcode/hooks.c
@@ -113,6 +113,79 @@ Invokes PROCEDURE on the arguments in ARG-LIST.")
}
}
+static SCHEME_OBJECT
+setup_catch (long frame_size,
+ long control_point_overhead,
+ SCHEME_OBJECT (*reuse_control_point) (long),
+ void (*setup_control_point) (void),
+ void (*setup_restoration) (SCHEME_OBJECT))
+{
+ SCHEME_OBJECT control_point = ((*reuse_control_point) (frame_size));
+ SCHEME_OBJECT *scan;
+
+ if (control_point != SHARP_F)
+ {
+ POP_PRIMITIVE_FRAME (frame_size);
+ return (control_point);
+ }
+
+ control_point
+ = (allocate_control_point
+ ((control_point_overhead + (STACK_N_PUSHED - frame_size)), true));
+
+ /* Edit the stack only after the allocation, which requires the
+ stack to be intact in case it triggers a garbage collection. */
+
+ POP_PRIMITIVE_FRAME (frame_size);
+ (*setup_control_point) ();
+ scan = (control_point_start (control_point));
+ while (STACK_N_PUSHED > 0)
+ (*scan++) = (STACK_POP ());
+
+#ifdef ENABLE_DEBUGGING_TOOLS
+ if (STACK_N_PUSHED != 0)
+ Microcode_Termination (TERM_BAD_STACK);
+#endif
+
+ CLEAR_INTERRUPT (INT_Stack_Overflow);
+ STACK_RESET ();
+ (*setup_restoration) (control_point);
+ return (control_point);
+}
+
+static SCHEME_OBJECT
+reuse_interpreted_control_point (long frame_size)
+{
+ if (((STACK_LOC (frame_size + CONTINUATION_SIZE)) == STACK_BOTTOM)
+ && (CHECK_RETURN_CODE (RC_JOIN_STACKLETS, frame_size))
+ && (CONTROL_POINT_P (CONT_EXP (frame_size))))
+ {
+ SCHEME_OBJECT control_point = (CONT_EXP (1));
+ history_register = (OBJECT_ADDRESS (READ_DUMMY_HISTORY ()));
+ return (control_point);
+ }
+
+ return (SHARP_F);
+}
+
+#define INTERPRETED_CONTROL_POINT_OVERHEAD (CONTINUATION_SIZE + HISTORY_SIZE)
+
+static void
+setup_interpreted_control_point (void)
+{
+ SAVE_HISTORY (RC_RESTORE_HISTORY);
+ preserve_interrupt_mask ();
+ prev_restore_history_offset = 0;
+}
+
+static void
+setup_interpreted_control_point_restoration (SCHEME_OBJECT control_point)
+{
+ SET_RC (RC_JOIN_STACKLETS);
+ SET_EXP (control_point);
+ SAVE_CONT ();
+}
+
/* CALL-WITH-CURRENT-CONTINUATION creates a control point (a pointer
to the current stack) and passes it to PROCEDURE as its only
argument. The inverse operation, typically called THROW, is
@@ -126,57 +199,42 @@ DEFINE_PRIMITIVE ("CALL-WITH-CURRENT-CONTINUATION",
Prim_catch, 1, 1,
Invoke PROCEDURE with a copy of the current control stack.")
{
PRIMITIVE_HEADER (1);
- canonicalize_primitive_context ();
{
+ long frame_size = 1;
SCHEME_OBJECT procedure = (ARG_REF (1));
- SCHEME_OBJECT cp;
+ SCHEME_OBJECT control_point;
- /* Optimization: if the current stack consists only of an
- RC_JOIN_STACKLETS frame, there's no need to create a new
- control point. */
-
- if (((STACK_LOC (1 + CONTINUATION_SIZE)) == STACK_BOTTOM)
- && (CHECK_RETURN_CODE (RC_JOIN_STACKLETS, 1))
- && (CONTROL_POINT_P (CONT_EXP (1))))
+#ifdef CC_SUPPORT_P
+ if ((CC_ENTRY_P (procedure)) && (CC_ENTRY_P (STACK_REF (1))))
{
- cp = (CONT_EXP (1));
- history_register = (OBJECT_ADDRESS (READ_DUMMY_HISTORY ()));
- POP_PRIMITIVE_FRAME (1);
- STACK_RESET ();
+ control_point
+ = (setup_catch
+ (frame_size,
+ COMPILED_CONTROL_POINT_OVERHEAD,
+ (&reuse_compiled_control_point),
+ (&setup_compiled_control_point),
+ (&setup_compiled_control_point_restoration)));
+ compiled_catch (procedure, control_point);
+ UN_POP_PRIMITIVE_FRAME (1);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
- else
- {
- cp = (allocate_control_point ((CONTINUATION_SIZE
- + HISTORY_SIZE
- + (STACK_N_PUSHED - 1)),
- true));
- POP_PRIMITIVE_FRAME (1);
-
- SAVE_HISTORY (RC_RESTORE_HISTORY);
- preserve_interrupt_mask ();
- prev_restore_history_offset = 0;
- {
- SCHEME_OBJECT * scan = (control_point_start (cp));
- while (STACK_N_PUSHED > 0)
- (*scan++) = (STACK_POP ());
- }
-#ifdef ENABLE_DEBUGGING_TOOLS
- if (STACK_N_PUSHED != 0)
- Microcode_Termination (TERM_BAD_STACK);
#endif
- CLEAR_INTERRUPT (INT_Stack_Overflow);
- STACK_RESET ();
- SET_RC (RC_JOIN_STACKLETS);
- SET_EXP (cp);
- SAVE_CONT ();
- }
+ canonicalize_primitive_context ();
- STACK_PUSH (cp);
+ control_point
+ = (setup_catch
+ (frame_size,
+ INTERPRETED_CONTROL_POINT_OVERHEAD,
+ (&reuse_interpreted_control_point),
+ (&setup_interpreted_control_point),
+ (&setup_interpreted_control_point_restoration)));
+ STACK_PUSH (control_point);
STACK_PUSH (procedure);
PUSH_APPLY_FRAME_HEADER (1);
+ PRIMITIVE_ABORT (PRIM_APPLY);
}
- PRIMITIVE_ABORT (PRIM_APPLY);
+
/*NOTREACHED*/
PRIMITIVE_RETURN (UNSPECIFIC);
}
@@ -192,6 +250,15 @@ Invoke PROCEDURE with a copy of the current control
stack.")
that restores control-point when THUNK returns, and sets up
an apply frame for THUNK. */
+static void
+setup_throw (void)
+{
+ stack_pointer = STACK_BOTTOM;
+ /* We've discarded the history with the stack contents. */
+ prev_restore_history_offset = 0;
+ CLEAR_INTERRUPT (INT_Stack_Overflow);
+}
+
DEFINE_PRIMITIVE ("WITHIN-CONTROL-POINT", Prim_within_control_point, 2, 2,
"(CONTROL-POINT THUNK)\n\
Invoke THUNK with CONTROL-POINT as its control stack.")
@@ -199,20 +266,30 @@ Invoke THUNK with CONTROL-POINT as its control stack.")
SCHEME_OBJECT control_point, thunk;
PRIMITIVE_HEADER (2);
- canonicalize_primitive_context();
CHECK_ARG (1, CONTROL_POINT_P);
control_point = (ARG_REF (1));
thunk = (ARG_REF (2));
- stack_pointer = STACK_BOTTOM;
- /* We've discarded the history with the stack contents. */
- prev_restore_history_offset = 0;
- CLEAR_INTERRUPT (INT_Stack_Overflow);
+#ifdef CC_SUPPORT_P
+ {
+ if ((CC_ENTRY_P (thunk))
+ && (RETURN_CODE_P (* (control_point_start (control_point))))
+ && (RC_REENTER_COMPILED_CODE
+ == (OBJECT_DATUM (* (control_point_start (control_point))))))
+ {
+ setup_throw ();
+ compiled_throw (thunk, control_point);
+ UN_POP_PRIMITIVE_FRAME (2);
+ PRIMITIVE_RETURN (UNSPECIFIC);
+ }
+ }
+#endif
+
+ canonicalize_primitive_context ();
+ setup_throw ();
Will_Push (CONTINUATION_SIZE);
- SET_EXP (control_point);
- SET_RC (RC_JOIN_STACKLETS);
- SAVE_CONT ();
+ setup_interpreted_control_point_restoration (control_point);
Pushed ();
Will_Push (STACK_ENV_EXTRA_SLOTS + 1);
diff --git a/src/runtime/conpar.scm b/src/runtime/conpar.scm
index e37438f..6d84807 100644
--- a/src/runtime/conpar.scm
+++ b/src/runtime/conpar.scm
@@ -59,7 +59,7 @@ USA.
(define (stack-frame/reductions stack-frame)
(let ((history (stack-frame/history stack-frame)))
- (if (eq? history undefined-history)
+ (if (or (not history) (eq? history undefined-history))
'()
(history-reductions history))))
@@ -132,7 +132,7 @@ USA.
(let ((stack-frame (stack-frame/next stack-frame)))
(and stack-frame
(if (stack-frame/subproblem? stack-frame)
- (stack-frame/next-subproblem stack-frame)
+ stack-frame
(loop stack-frame))))))
(else
(let ((stack-frame (stack-frame/next stack-frame)))
@@ -182,16 +182,10 @@ USA.
(make-parser-state
dynamic-state
block-thread-events?
- (control-point/interrupt-mask control-point)
- (let ((history
- (history-transform (control-point/history control-point))))
- (if (and (stream-pair? element-stream)
- (eq? return-address/reenter-compiled-code
- (stream-car element-stream)))
- history
- (history-superproblem history)))
- (control-point/previous-history-offset control-point)
- (control-point/previous-history-control-point control-point)
+ #f
+ #f
+ #f
+ #f
element-stream
(control-point/n-elements control-point)
(control-point/next-control-point control-point)
@@ -293,7 +287,7 @@ USA.
(make-parser-state (parser-state/dynamic-state state)
(parser-state/block-thread-events? state)
(parser-state/interrupt-mask state)
- (if (or force-pop? history-subproblem?)
+ (if (and history (or force-pop? history-subproblem?))
(history-superproblem history)
history)
previous-history-offset
@@ -360,6 +354,7 @@ USA.
(define-integrable code/special-compiled/restore-interrupt-mask 1)
(define-integrable code/special-compiled/stack-marker 2)
(define-integrable code/special-compiled/compiled-code-bkpt 3)
+(define-integrable code/special-compiled/restore-continuation 4)
(define-integrable code/interrupt-restart 4)
(define-integrable code/restore-regs 5)
(define-integrable code/apply-compiled 6)
@@ -376,6 +371,11 @@ USA.
type elements state))
((fix:= code code/special-compiled/stack-marker)
(parser/stack-marker type elements state))
+ ((fix:= code code/special-compiled/restore-continuation)
+ (parse-control-point (vector-ref elements 2)
+ (parser-state/dynamic-state state)
+ (parser-state/block-thread-events? state)
+ #f))
((or (fix:= code code/special-compiled/compiled-code-bkpt)
(fix:= code code/interrupt-restart)
(fix:= code code/restore-regs)
@@ -472,19 +472,42 @@ USA.
(with-values (lambda () (unparse/stack-frame stack-frame))
(lambda (element-stream next-control-point)
(make-control-point
- (stack-frame/interrupt-mask stack-frame)
- (let ((history (stack-frame/history stack-frame)))
- (if (eq? history undefined-history)
- (fixed-objects-item 'DUMMY-HISTORY)
- (history-untransform history)))
- (stack-frame/previous-history-offset stack-frame)
- (stack-frame/previous-history-control-point stack-frame)
- (if (stack-frame/compiled-code? stack-frame)
- (cons-stream return-address/reenter-compiled-code
- (cons-stream #f element-stream))
- element-stream)
+ (maybe-cons-restore-interrupt-mask
+ stack-frame
+ (maybe-cons-restore-history
+ stack-frame
+ (maybe-cons-reenter-compiled-code stack-frame element-stream)))
next-control-point))))
+(define (maybe-cons-restore-interrupt-mask stack-frame element-stream)
+ (let ((interrupt-mask (stack-frame/interrupt-mask stack-frame)))
+ (if (exact-integer? interrupt-mask)
+ (cons-stream return-address/restore-interrupt-mask
+ (cons-stream interrupt-mask element-stream))
+ element-stream)))
+
+(define (maybe-cons-restore-history stack-frame element-stream)
+ (let ((history (stack-frame/history stack-frame)))
+ (if history
+ (cons-stream
+ return-address/restore-history
+ (cons-stream
+ (if (eq? history undefined-history)
+ (fixed-objects-item 'DUMMY-HISTORY)
+ (history-untransform history))
+ (cons-stream
+ (stack-frame/previous-history-offset stack-frame)
+ (cons-stream
+ (stack-frame/previous-history-control-point stack-frame)
+ element-stream))))
+ element-stream)))
+
+(define (maybe-cons-reenter-compiled-code stack-frame element-stream)
+ (if (stack-frame/compiled-code? stack-frame)
+ (cons-stream return-address/reenter-compiled-code
+ (cons-stream #f element-stream))
+ element-stream))
+
(define (unparse/stack-frame stack-frame)
(if (eq? (stack-frame/return-address stack-frame)
return-address/join-stacklets)
@@ -512,6 +535,8 @@ USA.
(define return-address/join-stacklets)
(define return-address/reenter-compiled-code)
+(define return-address/restore-interrupt-mask)
+(define return-address/restore-history)
;;;; Special Frame Lengths
@@ -564,6 +589,8 @@ USA.
(if (not fsize)
5
(fix:+ 5 fsize))))
+ ((fix:= code code/special-compiled/restore-continuation)
+ 3)
((fix:= code code/interrupt-restart)
(let ((homes-saved (object-datum (stream-ref stream 2)))
(regs-saved (object-datum (stream-ref stream 3))))
@@ -682,6 +709,10 @@ USA.
(make-return-address (microcode-return 'JOIN-STACKLETS)))
(set! return-address/reenter-compiled-code
(make-return-address (microcode-return 'REENTER-COMPILED-CODE)))
+ (set! return-address/restore-interrupt-mask
+ (make-return-address (microcode-return 'RESTORE-INTERRUPT-MASK)))
+ (set! return-address/restore-history
+ (make-return-address (microcode-return 'RESTORE-HISTORY)))
(set! stack-frame-types (make-stack-frame-types))
(set! stack-frame-type/hardware-trap
(microcode-return/name->type 'HARDWARE-TRAP))
diff --git a/src/runtime/contin.scm b/src/runtime/contin.scm
index fdb4a60..09b4019 100644
--- a/src/runtime/contin.scm
+++ b/src/runtime/contin.scm
@@ -31,11 +31,10 @@ USA.
(define (call-with-current-continuation receiver)
((ucode-primitive call-with-current-continuation 1)
(lambda (control-point)
- (let ((k
- (make-continuation control-point
- (get-dynamic-state)
- (get-thread-event-block))))
- (%within-continuation k #f (lambda () (receiver k)))))))
+ (receiver
+ (make-continuation control-point
+ (get-dynamic-state)
+ (get-thread-event-block))))))
(define (within-continuation k thunk)
(guarantee-continuation k 'WITHIN-CONTINUATION)
diff --git a/src/runtime/cpoint.scm b/src/runtime/cpoint.scm
index 380c0eb..a5deacd 100644
--- a/src/runtime/cpoint.scm
+++ b/src/runtime/cpoint.scm
@@ -31,18 +31,6 @@ USA.
(define-integrable (control-point? object)
(object-type? (ucode-type control-point) object))
-(define-integrable (control-point/interrupt-mask control-point)
- (control-point-ref control-point 1))
-
-(define-integrable (control-point/history control-point)
- (control-point-ref control-point 3))
-
-(define-integrable (control-point/previous-history-offset control-point)
- (control-point-ref control-point 4))
-
-(define-integrable (control-point/previous-history-control-point control-point)
- (control-point-ref control-point 5))
-
(define-integrable (control-point-ref control-point index)
(system-vector-ref control-point (control-point-index index)))
@@ -50,7 +38,7 @@ USA.
(fix:+ 2 index))
(define-integrable first-element-index
- (control-point-index 6))
+ (control-point-index 0))
#|
@@ -99,12 +87,7 @@ USA.
(system-vector-ref control-point
(fix:- (system-vector-length control-point) 1))))
-(define (make-control-point interrupt-mask
- history
- previous-history-offset
- previous-history-control-point
- element-stream
- next-control-point)
+(define (make-control-point element-stream next-control-point)
(let ((result
(make-vector (+ first-element-index
(stream-length element-stream)
@@ -119,12 +102,6 @@ USA.
;; when "stacklets" were used.
(assign #f)
(assign (make-non-pointer-object 0))
- (assign (ucode-return-address restore-interrupt-mask))
- (assign interrupt-mask)
- (assign (ucode-return-address restore-history))
- (assign history)
- (assign previous-history-offset)
- (assign previous-history-control-point)
(stream-for-each (lambda (element)
(assign (unmap-reference-trap element)))
element-stream)
diff --git a/src/runtime/error.scm b/src/runtime/error.scm
index ef654f2..e492518 100644
--- a/src/runtime/error.scm
+++ b/src/runtime/error.scm
@@ -594,6 +594,7 @@ USA.
(default-handler condition)))))))
(define (standard-error-handler condition)
+ ((ucode-primitive debugging-printer) "Help!\n")
(let ((hook standard-error-hook))
(if hook
(fluid-let ((standard-error-hook #f))
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 046cb36..63b2e03 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -1245,12 +1245,8 @@ USA.
(parent (runtime))
(export ()
control-point/element-stream
- control-point/history
- control-point/interrupt-mask
control-point/n-elements
control-point/next-control-point
- control-point/previous-history-control-point
- control-point/previous-history-offset
control-point?
make-control-point))
_______________________________________________
MIT-Scheme-devel mailing list
[email protected]
http://lists.gnu.org/mailman/listinfo/mit-scheme-devel
