From: Taylor R Campbell <campbell@mumble.net>
Date: Sun, 10 Feb 2019 22:35:38 +0000 (+0000)
Subject: Convert multi-LETREC to internal definitions in dispatch-cache.scm.
X-Git-Tag: mit-scheme-pucked-10.1.10~6^2~7^2~15
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=b86773b0d850808d7379b3af2e8c6dce01665f1b;p=mit-scheme.git
Convert multi-LETREC to internal definitions in dispatch-cache.scm.
---
diff --git a/src/runtime/dispatch-cache.scm b/src/runtime/dispatch-cache.scm
index 7e4fc85f0..612b829e1 100644
--- a/src/runtime/dispatch-cache.scm
+++ b/src/runtime/dispatch-cache.scm
@@ -91,30 +91,26 @@ USA.
(let ((line (compute-primary-cache-line cache tags)))
(and line
(let ((limit (cache-limit cache)))
- (letrec
- ((search-lines
- (lambda (line i)
- (cond ((match (cache-line-tags cache line))
- (cache-line-value cache line))
- ((fix:= i limit)
- (search-overflow (cache-overflow cache)))
- (else
- (search-lines (cache-next-line cache line)
- (fix:+ i 1))))))
- (search-overflow
- (lambda (overflow)
- (and (not (null? overflow))
- (if (match (caar overflow))
- (cdar overflow)
- (search-overflow (cdr overflow))))))
- (match
- (lambda (tags*)
- (let loop ((w1 tags*) (w2 tags))
- (and (eq? (system-pair-car w1) (system-pair-car w2))
- (or (null? (system-pair-cdr w1))
- (loop (system-pair-cdr w1)
- (system-pair-cdr w2))))))))
- (search-lines line 0))))))
+ (define (search-lines line i)
+ (cond ((match (cache-line-tags cache line))
+ (cache-line-value cache line))
+ ((fix:= i limit)
+ (search-overflow (cache-overflow cache)))
+ (else
+ (search-lines (cache-next-line cache line)
+ (fix:+ i 1)))))
+ (define (search-overflow overflow)
+ (and (not (null? overflow))
+ (if (match (caar overflow))
+ (cdar overflow)
+ (search-overflow (cdr overflow)))))
+ (define (match tags*)
+ (let loop ((w1 tags*) (w2 tags))
+ (and (eq? (system-pair-car w1) (system-pair-car w2))
+ (or (null? (system-pair-cdr w1))
+ (loop (system-pair-cdr w1)
+ (system-pair-cdr w2))))))
+ (search-lines line 0)))))
(define (compute-primary-cache-line cache tags)
(let ((index (cache-tag-index cache))
@@ -320,90 +316,80 @@ USA.
(make-cache (cache-tag-index cache)
(cache-n-tags cache)
length)))
- (letrec
- ((fill-lines
- (lambda (line)
- (cond ((fix:= line length)
- (fill-overflow (cache-overflow cache)))
- ((try-entry (cache-line-tags cache line)
- (cache-line-value cache line))
- (fill-lines (fix:+ line 1)))
- (else
- (try-next-tag-index)))))
- (fill-overflow
- (lambda (entries)
- (cond ((null? entries)
- (or (fill-cache-if-possible new-cache tags value)
- (try-next-tag-index)))
- ((try-entry (caar entries) (cdar entries))
- (fill-overflow (cdr entries)))
- (else
- (try-next-tag-index)))))
- (try-entry
- (lambda (tags* value)
- (or (cache-entry-reusable? tags* tags)
- (fill-cache-if-possible new-cache tags* value))))
- (try-next-tag-index
- (lambda ()
- (let ((index (fix:+ (cache-tag-index new-cache) 1)))
- (and (fix:< index dispatch-tag-index-end)
- (begin
- (set-cache-tag-index! new-cache index)
- (fill-lines 0)))))))
- (fill-lines 0)))))
+ (define (fill-lines line)
+ (cond ((fix:= line length)
+ (fill-overflow (cache-overflow cache)))
+ ((try-entry (cache-line-tags cache line)
+ (cache-line-value cache line))
+ (fill-lines (fix:+ line 1)))
+ (else
+ (try-next-tag-index))))
+ (define (fill-overflow entries)
+ (cond ((null? entries)
+ (or (fill-cache-if-possible new-cache tags value)
+ (try-next-tag-index)))
+ ((try-entry (caar entries) (cdar entries))
+ (fill-overflow (cdr entries)))
+ (else
+ (try-next-tag-index))))
+ (define (try-entry tags* value)
+ (or (cache-entry-reusable? tags* tags)
+ (fill-cache-if-possible new-cache tags* value)))
+ (define (try-next-tag-index)
+ (let ((index (fix:+ (cache-tag-index new-cache) 1)))
+ (and (fix:< index dispatch-tag-index-end)
+ (begin
+ (set-cache-tag-index! new-cache index)
+ (fill-lines 0)))))
+ (fill-lines 0))))
(define (expand-cache cache tags value)
;; Create a new cache that is twice the length of CACHE, rehash the
;; contents of CACHE into the new cache, and make the new entry.
;; Permits overflows to occur in the new cache.
(let ((length (cache-length cache)))
- (letrec
- ((fill-lines
- (lambda (new-cache line)
- (if (fix:= line length)
- (fill-overflow new-cache (cache-overflow cache))
- (fill-lines (maybe-do-fill new-cache
- (cache-line-tags cache line)
- (cache-line-value cache line))
- (fix:+ line 1)))))
- (fill-overflow
- (lambda (new-cache overflow)
- (if (null? overflow)
- (do-fill new-cache tags value)
- (fill-overflow (maybe-do-fill new-cache
- (caar overflow)
- (cdar overflow))
- (cdr overflow)))))
- (maybe-do-fill
- (lambda (cache tags* value)
- (if (cache-entry-reusable? tags* tags)
- cache
- (do-fill cache tags* value))))
- (do-fill
- (lambda (cache tags value)
- (let ((primary (compute-primary-cache-line cache tags)))
- (if primary
- (let ((free (find-free-cache-line cache primary tags)))
- (if free
- (begin
- (set-cache-line-tags! cache free tags)
- (set-cache-line-value! cache free value)
- cache)
- (or (adjust-cache cache tags value)
- (begin
- (set-cache-overflow!
- cache
- (cons (cons (cache-line-tags cache primary)
- (cache-line-value cache primary))
- (cache-overflow cache)))
- (set-cache-line-tags! cache primary tags)
- (set-cache-line-value! cache primary value)
- cache))))
- cache)))))
- (fill-lines (make-cache (cache-tag-index cache)
- (cache-n-tags cache)
- (fix:+ length length))
- 0))))
+ (define (fill-lines new-cache line)
+ (if (fix:= line length)
+ (fill-overflow new-cache (cache-overflow cache))
+ (fill-lines (maybe-do-fill new-cache
+ (cache-line-tags cache line)
+ (cache-line-value cache line))
+ (fix:+ line 1))))
+ (define (fill-overflow new-cache overflow)
+ (if (null? overflow)
+ (do-fill new-cache tags value)
+ (fill-overflow (maybe-do-fill new-cache
+ (caar overflow)
+ (cdar overflow))
+ (cdr overflow))))
+ (define (maybe-do-fill cache tags* value)
+ (if (cache-entry-reusable? tags* tags)
+ cache
+ (do-fill cache tags* value)))
+ (define (do-fill cache tags value)
+ (let ((primary (compute-primary-cache-line cache tags)))
+ (if primary
+ (let ((free (find-free-cache-line cache primary tags)))
+ (if free
+ (begin
+ (set-cache-line-tags! cache free tags)
+ (set-cache-line-value! cache free value)
+ cache)
+ (or (adjust-cache cache tags value)
+ (begin
+ (set-cache-overflow!
+ cache
+ (cons (cons (cache-line-tags cache primary)
+ (cache-line-value cache primary))
+ (cache-overflow cache)))
+ (set-cache-line-tags! cache primary tags)
+ (set-cache-line-value! cache primary value)
+ cache))))
+ cache)))
+ (fill-lines (make-cache (cache-tag-index cache)
+ (cache-n-tags cache)
+ (fix:+ length length))
+ 0)))
(define (find-free-cache-line cache primary tags)
;; This procedure searches CACHE for a free line to hold an entry