home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / runtime / gencache.scm < prev    next >
Text File  |  1999-01-02  |  18KB  |  511 lines
  1. ;;; -*-Scheme-*-
  2. ;;;
  3. ;;; $Id: gencache.scm,v 1.2 1999/01/02 06:11:34 cph Exp $
  4. ;;;
  5. ;;; Copyright (c) 1993-1999 Massachusetts Institute of Technology
  6. ;;;
  7. ;;; This program is free software; you can redistribute it and/or
  8. ;;; modify it under the terms of the GNU General Public License as
  9. ;;; published by the Free Software Foundation; either version 2 of the
  10. ;;; License, or (at your option) any later version.
  11. ;;;
  12. ;;; This program is distributed in the hope that it will be useful,
  13. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. ;;; General Public License for more details.
  16. ;;;
  17. ;;; You should have received a copy of the GNU General Public License
  18. ;;; along with this program; if not, write to the Free Software
  19. ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21. ;;;; Method Caches for Generic Dispatch
  22.  
  23. ;;; From "Efficient Method Dispatch in PCL", Gregor Kiczales and Luis
  24. ;;; Rodriguez, Proceedings of the 1990 ACM Conference on Lisp and
  25. ;;; Functional Programming.  Parts of this code are based on the
  26. ;;; September 16, 1992 PCL implementation.
  27.  
  28. (declare (usual-integrations)
  29.      (integrate-external "gentag"))
  30.  
  31. (define-structure (cache (constructor %make-cache))
  32.   (tag-index 0)
  33.   (mask 0 read-only #t)
  34.   (limit 0 read-only #t)
  35.   (n-tags 0 read-only #t)
  36.   (tags '#() read-only #t)
  37.   (values '#() read-only #t)
  38.   (overflow '()))
  39.  
  40. (define (new-cache n-tags)
  41.   (make-cache dispatch-tag-index-start n-tags 4))
  42.  
  43. (define (make-cache tag-index n-tags length)
  44.   ;; LENGTH is assumed to be a power of two.
  45.   (%make-cache tag-index
  46.            (fix:- length 1)
  47.            (cond ((fix:<= length 4) 1)
  48.              ((fix:<= length 16) 4)
  49.              (else 6))
  50.            n-tags
  51.            (make-vector length (make-list n-tags #f))
  52.            (make-vector length #f)
  53.            '()))
  54.  
  55. (define-integrable (cache-length cache)
  56.   (vector-length (cache-tags cache)))
  57.  
  58. (define-integrable (cache-line-tags cache line)
  59.   (vector-ref (cache-tags cache) line))
  60.  
  61. (define-integrable (set-cache-line-tags! cache line tags)
  62.   (vector-set! (cache-tags cache) line tags))
  63.  
  64. (define-integrable (cache-line-value cache line)
  65.   (vector-ref (cache-values cache) line))
  66.  
  67. (define-integrable (set-cache-line-value! cache line value)
  68.   (vector-set! (cache-values cache) line value))
  69.  
  70. (define-integrable (cache-next-line cache line)
  71.   (if (fix:= (fix:+ line 1) (cache-length cache))
  72.       0
  73.       (fix:+ line 1)))
  74.  
  75. (define-integrable (cache-line-separation cache line line*)
  76.   (let ((n (fix:- line* line)))
  77.     (if (fix:< n 0)
  78.     (fix:+ n (cache-length cache))
  79.     n)))
  80.  
  81. (define (probe-cache cache tags)
  82.   (let ((line (compute-primary-cache-line cache tags)))
  83.     (and line
  84.      (let ((limit (cache-limit cache)))
  85.        (letrec
  86.            ((search-lines
  87.          (lambda (line i)
  88.            (cond ((match (cache-line-tags cache line))
  89.               (cache-line-value cache line))
  90.              ((fix:= i limit)
  91.               (search-overflow (cache-overflow cache)))
  92.              (else
  93.               (search-lines (cache-next-line cache line)
  94.                     (fix:+ i 1))))))
  95.         (search-overflow
  96.          (lambda (overflow)
  97.            (and (not (null? overflow))
  98.             (if (match (caar overflow))
  99.                 (cdar overflow)
  100.                 (search-overflow (cdr overflow))))))
  101.         (match
  102.          (lambda (tags*)
  103.            (let loop ((w1 tags*) (w2 tags))
  104.              (and (eq? (system-pair-car w1) (system-pair-car w2))
  105.               (or (null? (system-pair-cdr w1))
  106.                   (loop (system-pair-cdr w1)
  107.                     (system-pair-cdr w2))))))))
  108.          (search-lines line 0))))))
  109.  
  110. (define (compute-primary-cache-line cache tags)
  111.   (let ((index (cache-tag-index cache))
  112.     (mask (cache-mask cache)))
  113.     (let loop ((tags tags) (line 0))
  114.       (cond ((null? tags)
  115.          line)
  116.         ((not (system-pair-car tags))
  117.          #f)
  118.         (else
  119.          (loop (system-pair-cdr tags)
  120.            (fix:and (fix:+ line
  121.                    (dispatch-tag-ref (system-pair-car tags)
  122.                              index))
  123.                 mask)))))))
  124.  
  125. (define (cache-entry-reusable? tags tags*)
  126.   ;; True iff TAGS is (1) empty, (2) contains a tag that is invalid,
  127.   ;; or (3) has the same tags as TAGS*.
  128.   (or (not tags)
  129.       (let loop ((tags tags) (tags* tags*))
  130.     (or (null? tags)
  131.         (not (system-pair-car tags))
  132.         (and (eq? (system-pair-car tags) (system-pair-car tags*))
  133.          (loop (system-pair-cdr tags) (system-pair-cdr tags*)))))))
  134.  
  135. (define (cache-count cache)
  136.   (let ((length (cache-length cache)))
  137.     (do ((line 0 (fix:+ line 1))
  138.      (count 0
  139.         (if (let ((tags (cache-line-tags cache line)))
  140.               (and tags
  141.                (let loop ((tags tags))
  142.                  (or (null? tags)
  143.                  (and (system-pair-car tags)
  144.                       (loop (system-pair-cdr tags)))))))
  145.             (fix:+ count 1)
  146.             count)))
  147.     ((fix:= line length) count))))
  148.  
  149. (declare (integrate-operator probe-cache-1))
  150. (define (probe-cache-1 cache w1)
  151.   (let ((line
  152.      (fix:and (dispatch-tag-ref w1 (cache-tag-index cache))
  153.           (cache-mask cache)))
  154.     (match
  155.      (lambda (tags)
  156.        (declare (integrate tags))
  157.        (eq? w1 (system-pair-car tags)))))
  158.     (declare (integrate line))
  159.     (declare (integrate-operator match))
  160.     (if (match (cache-line-tags cache line))
  161.     (cache-line-value cache line)
  162.     (let ((limit (cache-limit cache)))
  163.       (let search-lines ((line (cache-next-line cache line)) (i 0))
  164.         (cond ((fix:= i limit)
  165.            (let search-overflow ((entries (cache-overflow cache)))
  166.              (and (not (null? entries))
  167.               (if (match (caar entries))
  168.                   (cdar entries)
  169.                   (search-overflow (cdr entries))))))
  170.           ((and (cache-line-tags cache line)
  171.             (match (cache-line-tags cache line)))
  172.            (cache-line-value cache line))
  173.           (else
  174.            (search-lines (cache-next-line cache line)
  175.                  (fix:+ i 1)))))))))
  176.  
  177. (declare (integrate-operator probe-cache-2))
  178. (define (probe-cache-2 cache w1 w2)
  179.   (let ((line
  180.      (fix:and (fix:+ (dispatch-tag-ref w1 (cache-tag-index cache))
  181.              (dispatch-tag-ref w2 (cache-tag-index cache)))
  182.           (cache-mask cache)))
  183.     (match
  184.      (lambda (tags)
  185.        (declare (integrate tags))
  186.        (and (eq? w1 (system-pair-car tags))
  187.         (eq? w2 (system-pair-car (system-pair-cdr tags)))))))
  188.     (declare (integrate line))
  189.     (declare (integrate-operator match))
  190.     (if (and (cache-line-tags cache line)
  191.          (match (cache-line-tags cache line)))
  192.     (cache-line-value cache line)
  193.     (let ((limit (cache-limit cache)))
  194.       (let search-lines ((line (cache-next-line cache line)) (i 0))
  195.         (cond ((fix:= i limit)
  196.            (let search-overflow ((entries (cache-overflow cache)))
  197.              (and (not (null? entries))
  198.               (if (match (caar entries))
  199.                   (cdar entries)
  200.                   (search-overflow (cdr entries))))))
  201.           ((and (cache-line-tags cache line)
  202.             (match (cache-line-tags cache line)))
  203.            (cache-line-value cache line))
  204.           (else
  205.            (search-lines (cache-next-line cache line)
  206.                  (fix:+ i 1)))))))))
  207.  
  208. (declare (integrate-operator probe-cache-3))
  209. (define (probe-cache-3 cache w1 w2 w3)
  210.   (let ((line
  211.      (fix:and
  212.       (fix:+ (dispatch-tag-ref w1 (cache-tag-index cache))
  213.          (fix:+ (dispatch-tag-ref w2 (cache-tag-index cache))
  214.             (dispatch-tag-ref w3 (cache-tag-index cache))))
  215.       (cache-mask cache)))
  216.     (match
  217.      (lambda (tags)
  218.        (declare (integrate tags))
  219.        (and (eq? w1 (system-pair-car tags))
  220.         (eq? w2 (system-pair-car (system-pair-cdr tags)))
  221.         (eq? w3 (system-pair-car
  222.              (system-pair-cdr (system-pair-cdr tags))))))))
  223.     (declare (integrate line))
  224.     (declare (integrate-operator match))
  225.     (if (match (cache-line-tags cache line))
  226.     (cache-line-value cache line)
  227.     (let ((limit (cache-limit cache)))
  228.       (let search-lines ((line (cache-next-line cache line)) (i 0))
  229.         (cond ((fix:= i limit)
  230.            (let search-overflow ((entries (cache-overflow cache)))
  231.              (and (not (null? entries))
  232.               (if (match (caar entries))
  233.                   (cdar entries)
  234.                   (search-overflow (cdr entries))))))
  235.           ((and (cache-line-tags cache line)
  236.             (match (cache-line-tags cache line)))
  237.            (cache-line-value cache line))
  238.           (else
  239.            (search-lines (cache-next-line cache line)
  240.                  (fix:+ i 1)))))))))
  241.  
  242. (declare (integrate-operator probe-cache-4))
  243. (define (probe-cache-4 cache w1 w2 w3 w4)
  244.   (let ((line
  245.      (fix:and
  246.       (fix:+ (fix:+ (dispatch-tag-ref w1 (cache-tag-index cache))
  247.             (dispatch-tag-ref w2 (cache-tag-index cache)))
  248.          (fix:+ (dispatch-tag-ref w3 (cache-tag-index cache))
  249.             (dispatch-tag-ref w4 (cache-tag-index cache))))
  250.       (cache-mask cache)))
  251.     (match
  252.      (lambda (tags)
  253.        (declare (integrate tags))
  254.        (and (eq? w1 (system-pair-car tags))
  255.         (eq? w2 (system-pair-car (system-pair-cdr tags)))
  256.         (eq? w3 (system-pair-car
  257.              (system-pair-cdr (system-pair-cdr tags))))
  258.         (eq? w4 (system-pair-car
  259.              (system-pair-cdr
  260.               (system-pair-cdr (system-pair-cdr tags)))))))))
  261.     (declare (integrate line))
  262.     (declare (integrate-operator match))
  263.     (if (match (cache-line-tags cache line))
  264.     (cache-line-value cache line)
  265.     (let ((limit (cache-limit cache)))
  266.       (let search-lines ((line (cache-next-line cache line)) (i 0))
  267.         (cond ((fix:= i limit)
  268.            (let search-overflow ((entries (cache-overflow cache)))
  269.              (and (not (null? entries))
  270.               (if (match (caar entries))
  271.                   (cdar entries)
  272.                   (search-overflow (cdr entries))))))
  273.           ((and (cache-line-tags cache line)
  274.             (match (cache-line-tags cache line)))
  275.            (cache-line-value cache line))
  276.           (else
  277.            (search-lines (cache-next-line cache line)
  278.                  (fix:+ i 1)))))))))
  279.  
  280. (define (fill-cache cache tags value)
  281.   ;; TAGS must be converted to a weak list since it will be stored in
  282.   ;; the cache, and we don't want the cache to prevent the tags from
  283.   ;; being GCed.
  284.   (let ((tags (list->weak-list tags)))
  285.     (or (fill-cache-if-possible cache tags value)
  286.     (and (< (cache-count cache) (* (cache-length cache) .8))
  287.          (adjust-cache cache tags value))
  288.     (expand-cache cache tags value))))
  289.  
  290. (define (fill-cache-if-possible cache tags value)
  291.   (let ((primary (compute-primary-cache-line cache tags)))
  292.     (if primary
  293.     (let ((free (find-free-cache-line cache primary tags)))
  294.       (and free
  295.            (begin
  296.          (set-cache-line-tags! cache free tags)
  297.          (set-cache-line-value! cache free value)
  298.          cache)))
  299.     ;; TAGS contains an invalid tag.  Do nothing and return CACHE
  300.     ;; because the fill is no longer needed.  While other logic
  301.     ;; tries to eliminate this case, it can still happen when one
  302.     ;; of the tags is GCed during complex cache operations.
  303.     cache)))
  304.  
  305. (define (adjust-cache cache tags value)
  306.   ;; Try to rehash the cache.  If that fails, try rehashing with
  307.   ;; different tag indexes.  Fail only when all of the tag indexes
  308.   ;; have been tried and none has worked.
  309.   (let ((length (cache-length cache)))
  310.     (let ((new-cache
  311.        (make-cache (cache-tag-index cache)
  312.                (cache-n-tags cache)
  313.                length)))
  314.       (letrec
  315.       ((fill-lines
  316.         (lambda (line)
  317.           (cond ((fix:= line length)
  318.              (fill-overflow (cache-overflow cache)))
  319.             ((try-entry (cache-line-tags cache line)
  320.                 (cache-line-value cache line))
  321.              (fill-lines (fix:+ line 1)))
  322.             (else
  323.              (try-next-tag-index)))))
  324.        (fill-overflow
  325.         (lambda (entries)
  326.           (cond ((null? entries)
  327.              (or (fill-cache-if-possible new-cache tags value)
  328.              (try-next-tag-index)))
  329.             ((try-entry (caar entries) (cdar entries))
  330.              (fill-overflow (cdr entries)))
  331.             (else
  332.              (try-next-tag-index)))))
  333.        (try-entry
  334.         (lambda (tags* value)
  335.           (or (cache-entry-reusable? tags* tags)
  336.           (fill-cache-if-possible new-cache tags* value))))
  337.        (try-next-tag-index
  338.         (lambda ()
  339.           (let ((index
  340.              (next-dispatch-tag-index (cache-tag-index new-cache))))
  341.         (and index
  342.              (begin
  343.                (set-cache-tag-index! new-cache index)
  344.                (fill-lines 0)))))))
  345.     (fill-lines 0)))))
  346.  
  347. (define (expand-cache cache tags value)
  348.   ;; Create a new cache that is twice the length of CACHE, rehash the
  349.   ;; contents of CACHE into the new cache, and make the new entry.
  350.   ;; Permits overflows to occur in the new cache.
  351.   (let ((length (cache-length cache)))
  352.     (letrec
  353.     ((fill-lines
  354.       (lambda (new-cache line)
  355.         (if (fix:= line length)
  356.         (fill-overflow new-cache (cache-overflow cache))
  357.         (fill-lines (maybe-do-fill new-cache
  358.                        (cache-line-tags cache line)
  359.                        (cache-line-value cache line))
  360.                 (fix:+ line 1)))))
  361.      (fill-overflow
  362.       (lambda (new-cache overflow)
  363.         (if (null? overflow)
  364.         (do-fill new-cache tags value)
  365.         (fill-overflow (maybe-do-fill new-cache
  366.                           (caar overflow)
  367.                           (cdar overflow))
  368.                    (cdr overflow)))))
  369.      (maybe-do-fill
  370.       (lambda (cache tags* value)
  371.         (if (cache-entry-reusable? tags* tags)
  372.         cache
  373.         (do-fill cache tags* value))))
  374.      (do-fill
  375.       (lambda (cache tags value)
  376.         (let ((primary (compute-primary-cache-line cache tags)))
  377.           (if primary
  378.           (let ((free (find-free-cache-line cache primary tags)))
  379.             (if free
  380.             (begin
  381.               (set-cache-line-tags! cache free tags)
  382.               (set-cache-line-value! cache free value)
  383.               cache)
  384.             (or (adjust-cache cache tags value)
  385.                 (begin
  386.                   (set-cache-overflow!
  387.                    cache
  388.                    (cons (cons (cache-line-tags cache primary)
  389.                        (cache-line-value cache primary))
  390.                      (cache-overflow cache)))
  391.                   (set-cache-line-tags! cache primary tags)
  392.                   (set-cache-line-value! cache primary value)
  393.                   cache))))
  394.           cache)))))
  395.       (fill-lines (make-cache (cache-tag-index cache)
  396.                   (cache-n-tags cache)
  397.                   (fix:+ length length))
  398.           0))))
  399.  
  400. (define (find-free-cache-line cache primary tags)
  401.   ;; This procedure searches CACHE for a free line to hold an entry
  402.   ;; with the given PRIMARY cache number and TAGS.  Since the entry
  403.   ;; can only be stored within (CACHE-LIMIT CACHE) lines of PRIMARY,
  404.   ;; we either have to find a free line within that limit, or we have
  405.   ;; to find a line with a larger primary which can be displaced to
  406.   ;; another free line within *its* limit.
  407.   (if (cache-entry-reusable? (cache-line-tags cache primary) tags)
  408.       primary
  409.       (let ((limit (cache-limit cache)))
  410.     ;; Find a line for an entry whose primary cache number is P.
  411.     ;; LINES is the sequence of entries that is waiting to be
  412.     ;; displaced into the line if we find it.
  413.     (let pri-loop
  414.         ((line (cache-next-line cache primary))
  415.          (p primary)
  416.          (tags tags)
  417.          (lines '()))
  418.       (let sec-loop
  419.           ((line line)
  420.            (nsep (cache-line-separation cache p line)))
  421.         (cond ((fix:= line primary)
  422.            ;; We've scanned through the entire cache without
  423.            ;; finding a usable line.
  424.            #f)
  425.           ((let ((tags* (cache-line-tags cache line)))
  426.              (and (not (cache-entry-reusable? tags* tags))
  427.               (compute-primary-cache-line cache tags*)))
  428.            =>
  429.            (lambda (lp)
  430.              (let ((osep (cache-line-separation cache lp line)))
  431.                (cond ((fix:>= osep limit)
  432.                   ;; This line contains an entry that is
  433.                   ;; displaced to the limit.  [**** For
  434.                   ;; some reason I don't understand, this
  435.                   ;; terminates the search.]
  436.                   #f)
  437.                  ((or (fix:> nsep osep)
  438.                   (and (fix:= nsep osep)
  439.                        (= 0 (random 2))))
  440.                   ;; The entry we're trying to place is
  441.                   ;; further from its primary than the
  442.                   ;; entry currently stored in this line.
  443.                   ;; So now let's look for somewhere to
  444.                   ;; displace the entry in this line.
  445.                   (pri-loop (cache-next-line cache line)
  446.                     lp
  447.                     (cache-line-tags cache line)
  448.                     (cons line lines)))
  449.                  (else
  450.                   (sec-loop (cache-next-line cache line)
  451.                     (fix:+ nsep 1)))))))
  452.           (else
  453.            ;; Found a free line.  First perform all of the
  454.            ;; entry displacements, then return the subsequent
  455.            ;; free line.
  456.            (without-interrupts
  457.             (lambda ()
  458.               (let loop ((free-line line) (lines lines))
  459.             (if (null? lines)
  460.                 (begin
  461.                   (set-cache-line-tags! cache free-line #f)
  462.                   (set-cache-line-value! cache free-line #f)
  463.                   free-line)
  464.                 (let ((line (car lines)))
  465.                   (set-cache-line-tags!
  466.                    cache
  467.                    free-line
  468.                    (cache-line-tags cache line))
  469.                   (set-cache-line-value!
  470.                    cache
  471.                    free-line
  472.                    (cache-line-value cache line))
  473.                   (loop line (cdr lines))))))))))))))
  474.  
  475. (define (purge-cache-entries cache predicate)
  476.   (if (there-exists-a-cache-entry? cache predicate)
  477.       ;; Must rebuild cache since deletions are near-impossible.
  478.       (let loop
  479.       ((cache (new-cache (cache-n-tags cache)))
  480.        (alist (cache->alist cache)))
  481.     (if (null? alist)
  482.         cache
  483.         (loop (if (predicate (caar alist))
  484.               cache
  485.               (fill-cache cache (caar alist) (cdar alist)))
  486.           (cdr alist))))
  487.       cache))
  488.  
  489. (define (there-exists-a-cache-entry? cache predicate)
  490.   (let ((length (cache-length cache)))
  491.     (let loop ((line 0))
  492.       (and (not (fix:= line length))
  493.        (let ((tags (cache-line-tags cache line)))
  494.          (if (or (not tags)
  495.              (not (system-pair-car tags)))
  496.          (loop (fix:+ line 1))
  497.          (or (predicate (weak-list->list tags))
  498.              (loop (fix:+ line 1)))))))))
  499.  
  500. (define (cache->alist cache)
  501.   (let ((length (cache-length cache)))
  502.     (do ((line 0 (fix:+ line 1))
  503.      (alist '()
  504.         (let ((tags (cache-line-tags cache line)))
  505.           (if (or (not tags)
  506.               (not (system-pair-car tags)))
  507.               alist
  508.               (cons (cons (weak-list->list tags)
  509.                   (cache-line-value cache line))
  510.                 alist)))))
  511.     ((fix:= line length) alist))))