From 5e2cd4805275f3766e5019572b93c12930a0feac Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Mon, 28 May 2018 23:53:16 -0700 Subject: [PATCH] Refactor promises again, to support delay-force. This no longer uses scode DELAY expressions, which can be deleted after 9.3 is released. It does continue to use DELAYED objects for type convenience. --- src/runtime/boot.scm | 53 ++++++++++++++++++++++++++++++++++ src/runtime/framex.scm | 6 +--- src/runtime/host-adapter.scm | 12 ++++++++ src/runtime/microcode-data.scm | 48 +----------------------------- src/runtime/mit-macros.scm | 10 +++++++ src/runtime/mit-syntax.scm | 14 --------- src/runtime/runtime.pkg | 19 ++++++------ src/runtime/syntax-output.scm | 3 -- 8 files changed, 86 insertions(+), 79 deletions(-) diff --git a/src/runtime/boot.scm b/src/runtime/boot.scm index ad39b5260..e614ea6ec 100644 --- a/src/runtime/boot.scm +++ b/src/runtime/boot.scm @@ -431,6 +431,59 @@ USA. (write-string "object satisfying " port) (write predicate port))))) +;;;; Promises + +(define (promise? object) + (and (cell? object) + (object-type? (ucode-type delayed) (cell-contents object)))) + +(define (make-promise object) + (if (promise? object) + object + (make-cell (system-pair-cons (ucode-type delayed) #t object)))) + +(define (make-unforced-promise thunk) + ;(guarantee thunk? thunk 'make-unforced-promise) + (make-cell (system-pair-cons (ucode-type delayed) #f thunk))) + +(define (%promise-parts promise) + (without-interrupts + (lambda () + (let ((p (cell-contents promise))) + (values (system-pair-car p) + (system-pair-cdr p)))))) + +(define (promise-forced? promise) + (guarantee promise? promise 'promise-forced?) + (system-pair-car (cell-contents promise))) + +(define (promise-value promise) + (guarantee promise? promise 'promise-value) + (receive (forced? value) (%promise-parts promise) + (if (not forced?) + (error "Promise not yet forced:" promise)) + value)) + +(define (force promise) + (guarantee promise? promise 'force) + (%force promise)) + +(define (%force promise) + (receive (forced? value) (%promise-parts promise) + (if forced? + value + (let ((promise* (value))) + (guarantee promise? promise* 'force) + (without-interrupts + (lambda () + (let ((p (cell-contents promise))) + (if (not (system-pair-car p)) + (let ((p* (cell-contents promise*))) + (system-pair-set-car! p (system-pair-car p*)) + (system-pair-set-cdr! p (system-pair-cdr p*)) + (set-cell-contents! promise* p)))))) + (%force promise))))) + ;;;; Miscellany (define (object-constant? object) diff --git a/src/runtime/framex.scm b/src/runtime/framex.scm index e493faeb1..33d745a33 100644 --- a/src/runtime/framex.scm +++ b/src/runtime/framex.scm @@ -133,11 +133,7 @@ USA. (values (make-scode-combination (ucode-primitive force 1) (list (make-evaluated-object promise))) undefined-environment - (let ((expr (promise-expression promise))) - (case expr - ((|#[(runtime microcode-data)forced]|) undefined-expression) - ((|#[(runtime microcode-data)compiled]|) unknown-expression) - (else (validate-subexpression frame expr))))))) + undefined-expression))) (define ((method/application-frame index) frame) (values (make-scode-combination diff --git a/src/runtime/host-adapter.scm b/src/runtime/host-adapter.scm index dd447c6ea..109f84e69 100644 --- a/src/runtime/host-adapter.scm +++ b/src/runtime/host-adapter.scm @@ -89,6 +89,18 @@ USA. (list (cons 'name name) ...))))) env)) + (if (unbound? env 'delay-force) + (eval '(begin + (define-syntax delay-force + (syntax-rules () + ((delay-force expression) + (make-unforced-promise (lambda () expression))))) + (define-syntax delay + (syntax-rules () + ((delay expression) + (delay-force (make-promise expression)))))) + env)) + (if (unbound? env 'define-print-method) (eval '(define (define-print-method predicate print-method) unspecific) diff --git a/src/runtime/microcode-data.scm b/src/runtime/microcode-data.scm index bdeb69f86..06b5d52d4 100644 --- a/src/runtime/microcode-data.scm +++ b/src/runtime/microcode-data.scm @@ -256,50 +256,4 @@ contains constants derived from the source program. (filter-potentially-dangerous (cdr aux-list)) (cons (car aux-list) (filter-potentially-dangerous (cdr aux-list)))) - '()))) - -;;;; Promises - -(define-integrable (promise? object) - (object-type? (ucode-type delayed) object)) - -(define (make-promise object) - (if (promise? object) - object - (system-pair-cons (ucode-type delayed) #t object))) - -(define-integrable (%promise-forced? promise) - (eq? #t (system-pair-car promise))) - -(define (promise-forced? promise) - (guarantee promise? promise 'promise-forced?) - (%promise-forced? promise)) - -(define (promise-value promise) - (guarantee promise? promise 'promise-value) - (if (not (%promise-forced? promise)) - (error "Promise not yet forced:" promise)) - (system-pair-cdr promise)) - -(define (promise-expression promise) - (without-interrupts - (lambda () - (case (system-pair-car promise) - ((#t) '|#[(runtime microcode-data)forced]|) - ((0) '|#[(runtime microcode-data)compiled]|) - (else (system-pair-cdr promise)))))) - -(define (force promise) - (guarantee promise? promise 'force) - (without-interrupts - (lambda () - (case (system-pair-car promise) - ((#t) - (system-pair-cdr promise)) - ((0) ;compiled - (let ((result ((system-pair-cdr promise)))) - (system-pair-set-cdr! promise result) - (system-pair-set-car! promise #t) - result)) - (else ;interpreted - ((ucode-primitive force 1) promise)))))) \ No newline at end of file + '()))) \ No newline at end of file diff --git a/src/runtime/mit-macros.scm b/src/runtime/mit-macros.scm index 4ae0f6b59..74aaf0319 100644 --- a/src/runtime/mit-macros.scm +++ b/src/runtime/mit-macros.scm @@ -396,6 +396,16 @@ USA. (if (not condition) (begin form ...))))) +(define-syntax $delay-force + (syntax-rules () + ((delay-force expression) + (make-unforced-promise (lambda () expression))))) + +(define-syntax $delay + (syntax-rules () + ((delay expression) + (delay-force (make-promise expression))))) + (define $guard (spar-transformer->runtime (delay diff --git a/src/runtime/mit-syntax.scm b/src/runtime/mit-syntax.scm index fa030125c..5403f58c5 100644 --- a/src/runtime/mit-syntax.scm +++ b/src/runtime/mit-syntax.scm @@ -158,15 +158,6 @@ USA. (spar-push spar-arg:ctx) (spar* (spar-subform spar-push-classified)) (spar-match-null))))) - -(define $delay - (spar-classifier->runtime - (delay - (spar-call-with-values delay-item - (spar-subform) - (spar-push spar-arg:ctx) - (spar-subform spar-push-deferred-classified) - (spar-match-null))))) ;;;; Definitions @@ -454,11 +445,6 @@ USA. (lambda () (output/declaration (classify))))) -(define (delay-item ctx classify) - (expr-item ctx - (lambda () - (output/delay (compile-expr-item (classify)))))) - (define (if-item ctx predicate consequent alternative) (expr-item ctx (lambda () diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 7925f3654..bdc41fd0b 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -163,6 +163,7 @@ USA. define-print-method error:not-a error:not-a-list-of + force ;R7RS gc-space-status guarantee guarantee-list-of @@ -179,10 +180,15 @@ USA. interrupt-mask/gc-ok interrupt-mask/none interrupt-mask/timer-ok + make-promise ;R7RS + make-unforced-promise object-constant? object-pure? predicate->dispatch-tag predicate? + promise-forced? + promise-value + promise? ;R7RS register-predicate! set-dispatch-tag<=! set-predicate<=! @@ -806,17 +812,12 @@ USA. environment-extension-parent environment-extension-procedure environment-extension? - force ;R7RS interpreter-return-address? - make-promise ;R7RS make-return-address microcode-error microcode-return microcode-termination microcode-type - promise-forced? - promise-value - promise? ;R7RS return-address/code return-address/name return-address? @@ -824,9 +825,7 @@ USA. set-environment-extension-parent! stack-address->index stack-address-offset - stack-address?) - (export (runtime debugging-info) - promise-expression)) + stack-address?)) (define-package (runtime vector) (files "vector") @@ -4705,7 +4704,6 @@ USA. output/constant output/declaration output/definition - output/delay output/disjunction output/lambda output/let @@ -4741,7 +4739,6 @@ USA. (begin $begin) ;R7RS (declare $declare) (define-syntax $define-syntax) ;R7RS - (delay $delay) ;R7RS (else $else) ;R7RS (er-macro-transformer $er-macro-transformer) (if $if) ;R7RS @@ -4786,6 +4783,8 @@ USA. (define-integrable $define-integrable) (define-record-type $define-record-type) (define-values $define-values) ;R7RS + (delay $delay) ;R7RS + (delay-force $delay-force) ;R7RS (do $do) ;R7RS (fluid-let $fluid-let) (guard $guard) ;R7RS diff --git a/src/runtime/syntax-output.scm b/src/runtime/syntax-output.scm index f3e4316b9..985a0c70b 100644 --- a/src/runtime/syntax-output.scm +++ b/src/runtime/syntax-output.scm @@ -82,9 +82,6 @@ USA. (receive (required optional rest) (parse-mit-lambda-list lambda-list) (make-lambda* name required optional rest body))) -(define (output/delay expression) - (make-scode-delay expression)) - (define (output/unassigned-test name) (make-scode-unassigned? name)) -- 2.25.1