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.
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:
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
(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)
(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)))))))
;(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?)
(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))))))
\f
;;;; Miscellany
(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
(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)))
((null? rest) (constant/make (and expr (object/scode expr)) '()))
(else (error "Improper list."))))
\f
-(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))
-
-\f
;;;; General CAR/CDR Encodings
(define (call-to-car? expression)
cadddr
caddr
cadr
- call-with-values
car
cdaaar
cdaadr
string->symbol
symbol?
third
- values
weak-pair?
- with-values
zero?)
(map car global-primitives)))
\f
cadddr-expansion
caddr-expansion
cadr-expansion
- call-with-values-expansion
car-expansion
cdaaar-expansion
cdaadr-expansion
string->symbol-expansion
symbol?-expansion
third-expansion
- values-expansion
weak-pair?-expansion
- call-with-values-expansion
zero?-expansion)
(map (lambda (p)
(make-primitive-expander
projects / mit-scheme.git / commitdiff