From: Matt Birkholz Date: Sun, 5 Feb 2017 02:31:49 +0000 (-0700) Subject: Add primitives VALUES and CALL-WITH-VALUES. X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=f80f8a4628a6a4a13f6b23facbc8dc22643e82f1;p=mit-scheme.git Add primitives VALUES and CALL-WITH-VALUES. * microcode/hooks.c (Prim_values Prim_call_with_values): New. * microcode/returns.h (RC_MULTIPLE_VALUES): New return code. * microcode/interp.c: Interpret new return code. * runtime/conpar.scm: Parse new stack frame type. * runtime/boot.scm (values call-with-values with-values): Assign these bindings earlier in the boot. They are no longer inlined by the scode optimizer and cannot be assigned later. * runtime/global.scm: Remove old definitions. * runtime/runtime.pkg: Move declarations. * runtime/thread.scm (with-thread-events-blocked): Pass multiple values. * runtime/wind.scm (%execute-at-new-state-point): Pass multiple values. * compiler/base/cfg2.scm (cleanup-noop-nodes): Pass multiple values. * src/sf/usiexp.scm (values-expansion call-with-values-expansion): Remove. --- diff --git a/src/compiler/base/cfg2.scm b/src/compiler/base/cfg2.scm index a3129f431..d39d5bb3f 100644 --- a/src/compiler/base/cfg2.scm +++ b/src/compiler/base/cfg2.scm @@ -178,9 +178,10 @@ USA. (define (cleanup-noop-nodes thunk) (fluid-let ((*noop-nodes* '())) - (let ((value (thunk))) - (for-each snode-delete! *noop-nodes*) - value))) + (call-with-values thunk + (lambda value* + (for-each snode-delete! *noop-nodes*) + (apply values value*))))) (define (make-false-pcfg) (snode->pcfg-false (make-noop-node))) diff --git a/src/microcode/hooks.c b/src/microcode/hooks.c index 08316165f..eba399f47 100644 --- a/src/microcode/hooks.c +++ b/src/microcode/hooks.c @@ -113,6 +113,63 @@ Invokes PROCEDURE on the arguments in ARG-LIST.") } } +DEFINE_PRIMITIVE ("VALUES", Prim_values, 0, LEXPR, + "(VALUES . values)\n\ +Return zero or more values to the current continuation.") +{ + PRIMITIVE_HEADER (LEXPR); + { + unsigned long n_args = GET_LEXPR_ACTUALS; + unsigned long extra = 0; + +#ifdef CC_SUPPORT_P + if (return_to_interpreter == (STACK_REF (n_args))) + extra = 1; +#endif + + if (CHECK_RETURN_CODE (RC_MULTIPLE_VALUES, n_args+extra)) + { + SCHEME_OBJECT consumer = (CONT_EXP (n_args+extra)); + unsigned long n_words = CONTINUATION_SIZE+extra; + { + SCHEME_OBJECT * scan_from = (STACK_LOC (n_args)); + SCHEME_OBJECT * scan_end = (STACK_LOC (0)); + SCHEME_OBJECT * scan_to = (STACK_LOC (n_args + n_words)); + while (scan_from != scan_end) + (STACK_LOCATIVE_PUSH (scan_to)) = (STACK_LOCATIVE_PUSH (scan_from)); + stack_pointer = (STACK_LOC (n_words)); + } + assert (RETURN_CODE_P (STACK_REF (n_args))); + STACK_PUSH (consumer); + PUSH_APPLY_FRAME_HEADER (n_args); + PRIMITIVE_ABORT (PRIM_APPLY); + /*NOTREACHED*/ + PRIMITIVE_RETURN (UNSPECIFIC); + } + + PRIMITIVE_RETURN (n_args == 0 ? UNSPECIFIC : (ARG_REF(1))); + } +} + +DEFINE_PRIMITIVE ("CALL-WITH-VALUES", Prim_call_with_values, 2, 2, + "(CALL-WITH-VALUES PRODUCER CONSUMER)\n\ +Call PRODUCER and tail-apply its return values to CONSUMER.") +{ + PRIMITIVE_HEADER (2); + canonicalize_primitive_context (); + { + SCHEME_OBJECT producer = (STACK_POP ()); + STACK_PUSH (MAKE_RETURN_CODE (RC_MULTIPLE_VALUES)); + Will_Push (STACK_ENV_EXTRA_SLOTS + 1); + STACK_PUSH (producer); + PUSH_APPLY_FRAME_HEADER (0); + Pushed (); + PRIMITIVE_ABORT (PRIM_APPLY); + /*NOTREACHED*/ + PRIMITIVE_RETURN (UNSPECIFIC); + } +} + /* 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 diff --git a/src/microcode/interp.c b/src/microcode/interp.c index 33f09dd50..26eb32c7e 100644 --- a/src/microcode/interp.c +++ b/src/microcode/interp.c @@ -1162,6 +1162,17 @@ Interpret (int pop_return_p) } break; + case RC_MULTIPLE_VALUES: + /* Frame consists of the consumer already popped into EXP. */ + /* This is a normal return; tail-apply EXP to VAL. */ + Will_Push (STACK_ENV_EXTRA_SLOTS + 2); + STACK_PUSH (GET_VAL); + STACK_PUSH (GET_EXP); + PUSH_APPLY_FRAME_HEADER (1); + Pushed (); + SET_PRIMITIVE (SHARP_F); + goto internal_apply; + default: POP_RETURN_ERROR (ERR_INAPPLICABLE_CONTINUATION); } diff --git a/src/microcode/returns.h b/src/microcode/returns.h index 4e8388ef8..1e201e963 100644 --- a/src/microcode/returns.h +++ b/src/microcode/returns.h @@ -29,7 +29,7 @@ USA. #define RC_END_OF_COMPUTATION 0x00 #define RC_JOIN_STACKLETS 0x01 -/* unused 0x02 */ +#define RC_MULTIPLE_VALUES 0x02 #define RC_INTERNAL_APPLY 0x03 /* unused 0x04 */ #define RC_RESTORE_HISTORY 0x05 @@ -98,7 +98,7 @@ USA. { \ /* 0x00 */ "non-existent-continuation", \ /* 0x01 */ "join-stacklets", \ -/* 0x02 */ 0, \ +/* 0x02 */ "multiple-values", \ /* 0x03 */ "internal-apply", \ /* 0x04 */ 0, \ /* 0x05 */ "restore-history", \ diff --git a/src/runtime/boot.scm b/src/runtime/boot.scm index 3350632a8..7b44447b6 100644 --- a/src/runtime/boot.scm +++ b/src/runtime/boot.scm @@ -126,6 +126,12 @@ USA. ((ucode-primitive with-interrupt-mask) (fix:and limit-mask (get-interrupt-enables)) procedure)) + +(define values (ucode-primitive values -1)) + +(define call-with-values (ucode-primitive call-with-values 2)) + +(define with-values (ucode-primitive call-with-values 2)) (define (object-constant? object) ((ucode-primitive constant?) object)) diff --git a/src/runtime/conpar.scm b/src/runtime/conpar.scm index bf9b8fecd..a819bba2a 100644 --- a/src/runtime/conpar.scm +++ b/src/runtime/conpar.scm @@ -798,6 +798,7 @@ USA. (standard-frame 'NON-EXISTENT-CONTINUATION 2) (standard-frame 'POP-RETURN-ERROR 2) (standard-frame 'RESTORE-VALUE 2) + (standard-frame 'MULTIPLE-VALUES 2) (standard-frame 'RESTORE-DONT-COPY-HISTORY 4 parser/restore-history) (standard-frame 'RESTORE-HISTORY 4 parser/restore-history) diff --git a/src/runtime/global.scm b/src/runtime/global.scm index 1e32ddf14..84a786728 100644 --- a/src/runtime/global.scm +++ b/src/runtime/global.scm @@ -139,15 +139,6 @@ USA. (define bind-cell-contents! (object-component-binder cell-contents set-cell-contents!)) -(define (values . objects) - (lambda (receiver) - (apply receiver objects))) - -(define (call-with-values thunk receiver) - ((thunk) receiver)) - -(define with-values call-with-values) - (define (write-to-string object #!optional max) (if (or (default-object? max) (not max)) (with-output-to-string (lambda () (write object))) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 9ff8d529e..edcda198d 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -145,6 +145,7 @@ USA. guarantee-unparser-method ;; END deprecated bindings bracketed-unparser-method + call-with-values default-object default-object? gc-space-status @@ -168,8 +169,10 @@ USA. simple-unparser-method standard-unparser-method unparser-method? + values with-absolutely-no-interrupts with-limited-interrupts + with-values without-interrupts) (export (runtime) add-boot-init!)) @@ -457,7 +460,6 @@ USA. append-hook-to-list apply bind-cell-contents! - call-with-values cd cell-contents cell? @@ -558,11 +560,9 @@ USA. unspecific user-initial-environment user-initial-prompt - values wait-interval with-history-disabled with-interrupt-mask - with-values write-to-string) (import (runtime thread) with-obarray-lock) diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm index 13e32e45c..22f547e52 100644 --- a/src/runtime/thread.scm +++ b/src/runtime/thread.scm @@ -871,20 +871,20 @@ USA. (if thread (let ((block-events? (thread/block-events? thread))) (set-thread/block-events?! thread #t) - (let ((value - ((ucode-primitive with-stack-marker 3) - (lambda () - (set-interrupt-enables! interrupt-mask) - (let ((value (thunk))) - (set-interrupt-enables! interrupt-mask/gc-ok) - value)) - 'WITH-THREAD-EVENTS-BLOCKED - block-events?))) + (let ((value*)) + ((ucode-primitive with-stack-marker 3) + (lambda () + (set-interrupt-enables! interrupt-mask) + (call-with-values thunk + (lambda values** (set! value* values**))) + (set-interrupt-enables! interrupt-mask/gc-ok)) + 'WITH-THREAD-EVENTS-BLOCKED + block-events?) (let ((thread first-running-thread)) (if thread (set-thread/block-events?! thread block-events?))) (set-interrupt-enables! interrupt-mask) - value)) + (apply values value*))) (begin (set-interrupt-enables! interrupt-mask) (thunk)))))) diff --git a/src/runtime/wind.scm b/src/runtime/wind.scm index a48f00145..2f05954cb 100644 --- a/src/runtime/wind.scm +++ b/src/runtime/wind.scm @@ -83,10 +83,13 @@ USA. (set-state-point/from-nearer! old-root after) (set-state-space/nearest-point! space new-point)) old-root))))) - (let ((value - (with-stack-marker during %translate-to-state-point old-root))) + (let ((value*)) + (with-stack-marker + (lambda () + (call-with-values during (lambda value** (set! value* value**)))) + %translate-to-state-point old-root) (%translate-to-state-point old-root) - value))) + (apply values value*)))) (define (%translate-to-state-point point) (%without-interrupts diff --git a/src/sf/usiexp.scm b/src/sf/usiexp.scm index 96da1ae46..b7406d9a8 100644 --- a/src/sf/usiexp.scm +++ b/src/sf/usiexp.scm @@ -336,50 +336,6 @@ USA. ((null? rest) (constant/make (and expr (object/scode expr)) '())) (else (error "Improper list.")))) -(define (values-expansion expr operands block) - (let ((block (block/make block #t '()))) - (let ((variables - (map (lambda (position) - (variable/make&bind! - block - (string->uninterned-symbol - (string-append "value-" (number->string position))))) - (iota (length operands))))) - (combination/make - expr - block - (procedure/make - #f - block lambda-tag:let variables '() #f - (let ((block (block/make block #t '()))) - (let ((variable (variable/make&bind! block 'RECEIVER))) - (procedure/make - #f block lambda-tag:unnamed (list variable) '() #f - (declaration/make - #f - ;; The receiver is used only once, and all its operand - ;; expressions are effect-free, so integrating here is - ;; safe. - (declarations/parse block '((INTEGRATE-OPERATOR RECEIVER))) - (combination/make #f - block - (reference/make #f block variable) - (map (lambda (variable) - (reference/make #f block variable)) - variables))))))) - operands)))) - -(define (call-with-values-expansion expr operands block) - (if (and (pair? operands) - (pair? (cdr operands)) - (null? (cddr operands))) - (combination/make expr - block - (combination/make #f block (car operands) '()) - (cdr operands)) - #f)) - - ;;;; General CAR/CDR Encodings (define (call-to-car? expression) @@ -720,7 +676,6 @@ USA. cadddr caddr cadr - call-with-values car cdaaar cdaadr @@ -772,9 +727,7 @@ USA. string->symbol symbol? third - values weak-pair? - with-values zero?) (map car global-primitives))) @@ -806,7 +759,6 @@ USA. cadddr-expansion caddr-expansion cadr-expansion - call-with-values-expansion car-expansion cdaaar-expansion cdaadr-expansion @@ -858,9 +810,7 @@ USA. string->symbol-expansion symbol?-expansion third-expansion - values-expansion weak-pair?-expansion - call-with-values-expansion zero?-expansion) (map (lambda (p) (make-primitive-expander