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..4d3812a 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,10 +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/interrupt-restart 4) -(define-integrable code/restore-regs 5) -(define-integrable code/apply-compiled 6) -(define-integrable code/continue-linking 7) +(define-integrable code/special-compiled/restore-continuation 4) (define (parser/special-compiled type elements state) (let ((code (vector-ref elements 1))) @@ -376,11 +367,12 @@ USA. type elements state)) ((fix:= code code/special-compiled/stack-marker) (parser/stack-marker type elements state)) - ((or (fix:= code code/special-compiled/compiled-code-bkpt) - (fix:= code code/interrupt-restart) - (fix:= code code/restore-regs) - (fix:= code code/apply-compiled) - (fix:= code code/continue-linking)) + ((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)) + ((fix:= code code/special-compiled/compiled-code-bkpt) (parse/standard-next type elements state #f #f)) (else (error "Unknown special compiled frame code:" code))))) @@ -472,19 +464,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 +527,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,27 +581,8 @@ USA. (if (not fsize) 5 (fix:+ 5 fsize)))) - ((fix:= code code/interrupt-restart) - (let ((homes-saved (object-datum (stream-ref stream 2))) - (regs-saved (object-datum (stream-ref stream 3)))) - ;; The first reg saved is _always_ the continuation, - ;; part of the next frame. - (fix:- (fix:+ - ;; Return code, reflect code, homes saved, regs saved, - ;; and entry point - 5 - (fix:+ homes-saved regs-saved)) - 1))) - ((fix:= code code/restore-regs) - (fix:+ 3 (object-datum (stream-ref stream 2)))) - ((fix:= code code/apply-compiled) - ;; Stream[2] is code entry point, [3] is frame size - (fix:+ 3 (object-datum (stream-ref stream 3)))) - ((fix:= code code/continue-linking) - ;; return code, reflect code, entry size, original count, - ;; block, environment, offset, last header offset,sections, - ;; return address - (fix:- 10 1)) + ((fix:= code code/special-compiled/restore-continuation) + 3) (else (lose))))) @@ -682,6 +680,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))