From: Chris Hanson Date: Tue, 9 Jul 2019 02:51:41 +0000 (-0400) Subject: Fix a bunch of problems caused by the call-with-values/values change. X-Git-Tag: mit-scheme-pucked-10.1.12~7^2~13 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=d41c8338f7eaaadcdd96b9cf20364bd76a3d7ed9;p=mit-scheme.git Fix a bunch of problems caused by the call-with-values/values change. First, SF was open-coding these, so that the compiled code wasn't using the new convention. This caused problems at the boundary between interpreted code and compiled code, and of course the compiled code was now incorrect. This is fixed but requires stuff in host-adapter to make it work. Second, eliminating the open-coding exposed a couple of places that would no longer initialize correctly during the cold load because they were initialized prior to the loading of the multiple-values procedures. This is fixed by rewriting those to not use multiple values and have been marked with comments. Finally, because the host-adapter file is now changing SF, SF must be loaded prior to loading the host adapter. There was one case in the make file that needed to be tweaked to make this guarantee. --- diff --git a/src/Makefile.in b/src/Makefile.in index de93851d2..2e966f312 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -118,8 +118,8 @@ TOOL_MIT_SCHEME = '$(MIT_SCHEME_EXE)' --batch-mode $(TOOL_COMPILER_HEAP) TOOL_COMPILER = $(TOOL_MIT_SCHEME) $(TOOL_COMPILER_BAND) $(TOOL_OPTIONS) \ $(TOOL_COMPILER_LOAD) --eval '(begin $(TOOL_COMPILER_SETTINGS))' -TOOL_SYNTAXER = $(TOOL_MIT_SCHEME) $(TOOL_SYNTAXER_BAND) $(TOOL_OPTIONS) \ - $(TOOL_SYNTAXER_LOAD) --eval '(begin $(TOOL_SYNTAXER_SETTINGS))' +TOOL_SYNTAXER = $(TOOL_MIT_SCHEME) $(TOOL_SYNTAXER_BAND) $(TOOL_SYNTAXER_LOAD) \ + $(TOOL_OPTIONS) --eval '(begin $(TOOL_SYNTAXER_SETTINGS))' TOOL_RUNTIME_ONLY = $(TOOL_MIT_SCHEME) $(TOOL_RUNTIME_ONLY_BAND) \ $(TOOL_OPTIONS) diff --git a/src/runtime/arith.scm b/src/runtime/arith.scm index b196ac646..42c616a17 100644 --- a/src/runtime/arith.scm +++ b/src/runtime/arith.scm @@ -68,9 +68,12 @@ USA. (object-type? (ucode-type big-flonum) object)) (define (flo:normalize x) - (let ((r ((ucode-primitive flonum-normalize 1) x))) + (let ((r (%flo:normalize x))) (values (car r) (cdr r)))) +(define-integrable (%flo:normalize x) + ((ucode-primitive flonum-normalize 1) x)) + (define-integrable flo:->integer flo:truncate->exact) @@ -1040,8 +1043,11 @@ USA. (else (flo:->rational x))))) (define (flo:->rational x) - (with-values (lambda () (flo:normalize x)) - (lambda (f e-p) +;;; Don't use multiple-values here because this gets called before they are +;;; defined. + (let ((p (%flo:normalize x))) + (let ((f (car p)) + (e-p (cdr p))) (let ((p flo:significand-digits-base-2)) (rat:* (flo:->integer (flo:denormalize f p)) (rat:expt 2 (int:- e-p p))))))) diff --git a/src/runtime/boot.scm b/src/runtime/boot.scm index 4315f4dfe..f97016b8b 100644 --- a/src/runtime/boot.scm +++ b/src/runtime/boot.scm @@ -450,10 +450,12 @@ USA. ;(guarantee thunk? thunk 'make-unforced-promise) (make-cell (make-cell (system-pair-cons (ucode-type delayed) #f thunk)))) -(define-integrable (%promise-parts promise) +;;; Don't use multiple-values here because this gets called before they are +;;; defined. +(define-integrable (%promise-parts promise k) (let ((p (cell-contents (cell-contents promise)))) - (values (system-pair-car p) - (system-pair-cdr p)))) + (k (system-pair-car p) + (system-pair-cdr p)))) (define (promise-forced? promise) (guarantee promise? promise 'promise-forced?) @@ -461,36 +463,38 @@ USA. (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)) + (%promise-parts promise + (lambda (forced? value) + (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) - (if (eq? promise* promise) - (error "Infinite recursion in promise:" promise)) - (without-interrupts - (lambda () - (let ((q (cell-contents promise))) - (if (not (system-pair-car (cell-contents q))) - (let ((q* (cell-contents promise*))) - ;; Reduce the chain of indirections by one link so - ;; that we don't accumulate space. - (set-cell-contents! q (cell-contents q*)) - ;; Point promise* at the same chain of - ;; indirections as promise so that forcing - ;; promise* will yield the same result. - (set-cell-contents! promise* q)))))) - (%force promise))))) + (%promise-parts promise + (lambda (forced? value) + (if forced? + value + (let ((promise* (value))) + (guarantee promise? promise* 'force) + (if (eq? promise* promise) + (error "Infinite recursion in promise:" promise)) + (without-interrupts + (lambda () + (let ((q (cell-contents promise))) + (if (not (system-pair-car (cell-contents q))) + (let ((q* (cell-contents promise*))) + ;; Reduce the chain of indirections by one link so + ;; that we don't accumulate space. + (set-cell-contents! q (cell-contents q*)) + ;; Point promise* at the same chain of + ;; indirections as promise so that forcing + ;; promise* will yield the same result. + (set-cell-contents! promise* q)))))) + (%force promise)))))) (define-print-method promise? (standard-print-method 'promise diff --git a/src/runtime/host-adapter.scm b/src/runtime/host-adapter.scm index 524f126d8..41f5c7b8c 100644 --- a/src/runtime/host-adapter.scm +++ b/src/runtime/host-adapter.scm @@ -50,4 +50,49 @@ USA. 'cref/object-root #!default)) + +(let ((env (->environment '(scode-optimizer expansion)))) + + (define (remove-at-index! index items setter) + (if (= index 0) + (setter (cdr items)) + (remove-at-index! (- index 1) + (cdr items) + (pair-setter items)))) + + (define (pair-setter pair) + (lambda (tail) + (set-cdr! pair tail))) + + (define (env-getter env name) + (lambda () + (environment-lookup env name))) + + (define (env-setter env name) + (lambda (tail) + (environment-assign! env name tail))) + + (let ((get-names (env-getter env 'usual-integrations/expansion-names)) + (set-names! (env-setter env 'usual-integrations/expansion-names)) + (get-vals (env-getter env 'usual-integrations/expansion-values)) + (set-vals! (env-setter env 'usual-integrations/expansion-values))) + + (define (remove-one name) + (let ((names (get-names))) + (let ((i + (list-index (lambda (name*) (eq? name* name)) + names))) + (remove-at-index! i names set-names!) + (remove-at-index! i (get-vals) set-vals!)))) + + (remove-one 'call-with-values) + (remove-one 'with-values) + (remove-one 'values) + + (environment-assign! env + 'usual-integrations/expansion-alist + (map cons + (get-names) + (get-vals))))) + unspecific \ No newline at end of file diff --git a/src/sf/usiexp.scm b/src/sf/usiexp.scm index 3690ad3ad..1760e80b0 100644 --- a/src/sf/usiexp.scm +++ b/src/sf/usiexp.scm @@ -327,50 +327,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 scode-lambda-name:let variables '() #f - (let ((block (block/make block #t '()))) - (let ((variable (variable/make&bind! block 'receiver))) - (procedure/make - #f block scode-lambda-name: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) @@ -776,7 +732,6 @@ USA. cadddr caddr cadr - call-with-values car cdaaar cdaadr @@ -827,9 +782,7 @@ USA. string->symbol symbol? third - values weak-pair? - with-values zero?) (map car global-primitives))) @@ -859,7 +812,6 @@ USA. cadddr-expansion caddr-expansion cadr-expansion - call-with-values-expansion car-expansion cdaaar-expansion cdaadr-expansion @@ -910,9 +862,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