From 8781bfc20436b980b989c7abb4f73fa8216d8504 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Wed, 17 Jul 2019 19:28:36 -0400 Subject: [PATCH] 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. Manual cherry-pick of d41c8338f7eaaadcdd96b9cf20364bd76a3d7ed9. --- src/Makefile.in | 6 ++++- src/runtime/arith.scm | 12 ++++++--- src/runtime/boot.scm | 50 +++++++++++++++++++----------------- src/runtime/host-adapter.scm | 46 ++++++++++++++++++++++++++++++++- src/runtime/random.scm | 24 ++++++++--------- src/sf/usiexp.scm | 50 ------------------------------------ 6 files changed, 96 insertions(+), 92 deletions(-) diff --git a/src/Makefile.in b/src/Makefile.in index be14dc7c7..254232e63 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -90,6 +90,10 @@ HOST_COMPILER = '$(MIT_SCHEME_EXE)' --batch-mode $(HOST_COMPILER_HEAP) --no-init HOST_RUNTIME_ONLY = '$(MIT_SCHEME_EXE)' --batch-mode $(HOST_COMPILER_HEAP) \ --band runtime.com --no-init-file --load runtime/host-adapter.scm +HOST_SF_ONLY = '$(MIT_SCHEME_EXE)' --batch-mode $(HOST_COMPILER_HEAP) \ + --band runtime.com --no-init-file --eval '(load-option (quote sf))' \ + --load runtime/host-adapter.scm + # This rule is for LIARC. .SUFFIXES: .bld .pkd .c .pkd.c .bld.c: @@ -234,7 +238,7 @@ syntax-compiler: compile-sf echo ' (lambda ()' && \ echo ' $(SF_SETTINGS_CROSS)' && \ echo ' (load "compiler.sf")))') \ - | $(HOST_RUNTIME_ONLY) --eval '(load-option (quote SF))' + | $(HOST_SF_ONLY) .PHONY: compile-compiler compile-compiler: syntax-compiler diff --git a/src/runtime/arith.scm b/src/runtime/arith.scm index 60b24f774..280d2df73 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) @@ -937,8 +940,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 ecc79ac1f..f62cbca00 100644 --- a/src/runtime/boot.scm +++ b/src/runtime/boot.scm @@ -447,12 +447,12 @@ USA. ;(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)))))) +;;; Don't use multiple-values here because this gets called before they are +;;; defined. +(define-integrable (%promise-parts promise k) + (let ((p (cell-contents promise))) + (k (system-pair-car p) + (system-pair-cdr p)))) (define (promise-forced? promise) (guarantee promise? promise 'promise-forced?) @@ -460,30 +460,32 @@ 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) - (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))))) + (%promise-parts promise + (lambda (forced? value) + (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 diff --git a/src/runtime/host-adapter.scm b/src/runtime/host-adapter.scm index 6e65a631d..ede64f56d 100644 --- a/src/runtime/host-adapter.scm +++ b/src/runtime/host-adapter.scm @@ -163,4 +163,48 @@ USA. (error "MICROCODE-TYPE: Unknown name:" name))) env) (link-variables system-global-environment 'microcode-type - env 'microcode-type))))) \ No newline at end of file + env 'microcode-type))))) + +(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))))) \ No newline at end of file diff --git a/src/runtime/random.scm b/src/runtime/random.scm index 2b480543b..25155727b 100644 --- a/src/runtime/random.scm +++ b/src/runtime/random.scm @@ -114,19 +114,17 @@ USA. (define (large-random-integer m state) ;; This also uses the rejection method, but this time to select a ;; subset of B^N where N is the smallest integer s.t. (<= M B^N). - (receive (n b^n) - (let loop ((n 2) (b^n (int:* b b))) - (if (int:<= m b^n) - (values n b^n) - (loop (fix:+ n 1) (int:* b^n b)))) - (let ((scale-factor (int:quotient b^n m))) - (int:quotient (let ((limit (int:* scale-factor m))) - (let loop () - (let ((elt (int:large-random-element state n))) - (if (int:< elt limit) - elt - (loop))))) - scale-factor)))) + (let loop ((n 2) (b^n (int:* b b))) + (if (int:<= m b^n) + (let ((scale-factor (int:quotient b^n m))) + (int:quotient (let ((limit (int:* scale-factor m))) + (let loop () + (let ((elt (int:large-random-element state n))) + (if (int:< elt limit) + elt + (loop))))) + scale-factor)) + (loop (fix:+ n 1) (int:* b^n b))))) (define (int:large-random-element state n) (let loop ((i 1) (elt (int:random-element state))) diff --git a/src/sf/usiexp.scm b/src/sf/usiexp.scm index bfa51a59c..2ac4b06c8 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 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) @@ -720,7 +676,6 @@ USA. cadddr caddr cadr - call-with-values car cdaaar cdaadr @@ -770,9 +725,7 @@ USA. string->symbol symbol? third - values weak-pair? - with-values zero?) (map car global-primitives))) @@ -804,7 +757,6 @@ USA. cadddr-expansion caddr-expansion cadr-expansion - call-with-values-expansion car-expansion cdaaar-expansion cdaadr-expansion @@ -854,9 +806,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 -- 2.25.1