remove method cache management code from (oop goops dispatch)

* module/oop/goops/dispatch.scm: Remove old method cache things.

1 files changed, 7 insertions, 219 deletions

diff --git a/module/oop/goops/dispatch.scm b/module/oop/goops/dispatch.scm
index e08e642d4..9e97b5b71 100644
--- a/module/oop/goops/dispatch.scm
+++ b/module/oop/goops/dispatch.scm
@@ -22,12 +22,12 @@
 (eval-when (compile) (resolve-module '(oop goops)))
 
 (define-module (oop goops dispatch)
-  :use-module (oop goops)
-  :use-module (oop goops util)
-  :use-module (oop goops compile)
-  :export (memoize-method!)
-  :no-backtrace
-  )
+  #:use-module (oop goops)
+  #:use-module (oop goops util)
+  #:use-module (oop goops compile)
+  #:export (memoize-method!)
+  #:no-backtrace)
+
 
 (define *dispatch-module* (current-module))
 
@@ -253,180 +253,6 @@
 
 
 ;;;
-;;; This file implements method memoization.  It will finally be
-;;; implemented on C level in order to obtain fast generic function
-;;; application also during the first pass through the code.
-;;;
-
-;;;
-;;; Constants
-;;;
-
-(define hashsets 8)
-(define hashset-index 9)
-
-(define hash-threshold 3)
-(define initial-hash-size 4) ;must be a power of 2 and >= hash-threshold
-
-(define initial-hash-size-1 (- initial-hash-size 1))
-
-(define the-list-of-no-method '(no-method))
-
-;;;
-;;; Method cache
-;;;
-
-;; (#@dispatch args N-SPECIALIZED #((TYPE1 ... . CMETHOD) ...) GF)
-;; (#@dispatch args N-SPECIALIZED HASHSET MASK
-;;             #((TYPE1 ... . CMETHOD) ...)
-;;             GF)
-
-;;; Representation
-
-;; non-hashed form
-
-(define method-cache-entries cadddr)
-
-(define (set-method-cache-entries! mcache entries)
-  (set-car! (cdddr mcache) entries))
-
-(define (method-cache-n-methods exp)
-  (n-cache-methods (method-cache-entries exp)))
-
-(define (method-cache-methods exp)
-  (cache-methods (method-cache-entries exp)))
-
-;; hashed form
-
-(define (set-hashed-method-cache-hashset! exp hashset)
-  (set-car! (cdddr exp) hashset))
-
-(define (set-hashed-method-cache-mask! exp mask)
-  (set-car! (cddddr exp) mask))
-
-(define (hashed-method-cache-entries exp)
-  (list-ref exp 5))
-
-(define (set-hashed-method-cache-entries! exp entries)
-  (set-car! (list-cdr-ref exp 5) entries))
-
-;; either form
-
-(define (method-cache-generic-function exp)
-  (list-ref exp (if (method-cache-hashed? exp) 6 4)))
-
-;;; Predicates
-
-(define (method-cache-hashed? x)
-  (integer? (cadddr x)))
-
-(define max-non-hashed-index (- hash-threshold 2))
-
-(define (passed-hash-threshold? exp)
-  (and (> (vector-length (method-cache-entries exp)) max-non-hashed-index)
-       (struct? (car (vector-ref (method-cache-entries exp)
-				 max-non-hashed-index)))))
-
-;;; Converting a method cache to hashed form
-
-(define (method-cache->hashed! exp)
-  (set-cdr! (cddr exp) (cons 0 (cons initial-hash-size-1 (cdddr exp))))
-  exp)
-
-;;;
-;;; Cache entries
-;;;
-
-(define (n-cache-methods entries)
-  (do ((i (- (vector-length entries) 1) (- i 1)))
-      ((or (< i 0) (struct? (car (vector-ref entries i))))
-       (+ i 1))))
-
-(define (cache-methods entries)
-  (do ((i (- (vector-length entries) 1) (- i 1))
-       (methods '() (let ((entry (vector-ref entries i)))
-		      (if (or (not (pair? entry)) (struct? (car entry)))
-			  (cons entry methods)
-			  methods))))
-      ((< i 0) methods)))
-
-;;;
-;;; Method insertion
-;;;
-
-(define (method-cache-insert! exp entry)
-  (let* ((entries (method-cache-entries exp))
-	 (n (n-cache-methods entries)))
-    (if (>= n (vector-length entries))
-	;; grow cache
-	(let ((new-entries (make-vector (* 2 (vector-length entries))
-					the-list-of-no-method)))
-	  (do ((i 0 (+ i 1)))
-	      ((= i n))
-	    (vector-set! new-entries i (vector-ref entries i)))
-	  (vector-set! new-entries n entry)
-	  (set-method-cache-entries! exp new-entries))
-	(vector-set! entries n entry))))
-
-(define (hashed-method-cache-insert! exp entry)
-  (let* ((cache (hashed-method-cache-entries exp))
-	 (size (vector-length cache)))
-    (let* ((entries (cons entry (cache-methods cache)))
-	   (size (if (<= (length entries) size)
-		     size
-		     ;; larger size required
-		     (let ((new-size (* 2 size)))
-		       (set-hashed-method-cache-mask! exp (- new-size 1))
-		       new-size)))
-	   (min-misses size)
-	   (best #f))
-      (do ((hashset 0 (+ 1 hashset)))
-	  ((= hashset hashsets))
-	(let* ((test-cache (make-vector size the-list-of-no-method))
-	       (misses (cache-try-hash! min-misses hashset test-cache entries)))
-	  (cond ((zero? misses)
-		 (set! min-misses 0)
-		 (set! best hashset)
-		 (set! cache test-cache)
-		 (set! hashset (- hashsets 1)))
-		((< misses min-misses)
-		 (set! min-misses misses)
-		 (set! best hashset)
-		 (set! cache test-cache)))))
-      (set-hashed-method-cache-hashset! exp best)
-      (set-hashed-method-cache-entries! exp cache))))
-
-;;;
-;;; Caching
-;;;
-
-(define (cache-hashval hashset entry)
-  (let ((hashset-index (+ hashset-index hashset)))
-    (do ((sum 0)
-	 (classes entry (cdr classes)))
-	((not (and (pair? classes) (struct? (car classes))))
-         sum)
-      (set! sum (+ sum (struct-ref (car classes) hashset-index))))))
-
-(define (cache-try-hash! min-misses hashset cache entries)
-  (let ((mask (- (vector-length cache) 1)))
-    (let outer ((in entries) (max-misses 0))
-      (if (null? in)
-          max-misses
-          (let inner ((i (logand mask (cache-hashval hashset (car in))))
-                      (misses 0))
-            (cond
-             ((and (pair? (vector-ref cache i))
-                   (eq? (car (vector-ref cache i)) 'no-method))
-              (vector-set! cache i (car in))
-              (outer (cdr in) (if (> misses max-misses) misses max-misses)))
-             (else
-              (let ((misses (+ 1 misses)))
-                (if (>= misses min-misses)
-                    misses ;; this is a return, yo.
-                    (inner (logand mask (+ i 1)) misses))))))))))
-
-;;;
 ;;; Memoization
 ;;;
 
@@ -436,46 +262,8 @@
 			 compute-applicable-methods)
 		     gf args)))
     (cond (applicable
-           (memoize-effective-method! gf args applicable)
-    	   ;; *fixme* dispatch.scm needs rewriting Since the current
-	   ;; code mutates the method cache, we have to work on a
-	   ;; copy.  Otherwise we might disturb another thread
-	   ;; currently dispatching on the cache.  (No need to copy
-	   ;; the vector.)
-	   (let* ((new (list-copy exp))
-		  (res
-		   (cond ((method-cache-hashed? new)
-			  (method-cache-install! hashed-method-cache-insert!
-						 new args applicable))
-			 ((passed-hash-threshold? new)
-			  (method-cache-install! hashed-method-cache-insert!
-						 (method-cache->hashed! new)
-						 args
-						 applicable))
-			 (else
-			  (method-cache-install! method-cache-insert!
-						 new args applicable)))))
-	     (set-cdr! (cdr exp) (cddr new))
-	     res))
+           (memoize-effective-method! gf args applicable))
 	  (else
 	   (no-applicable-method gf args)))))
 
 (set-procedure-property! memoize-method! 'system-procedure #t)
-
-(define method-cache-install!
-  (letrec ((first-n
-	    (lambda (ls n)
-	      (if (or (zero? n) (null? ls))
-		  '()
-		  (cons (car ls) (first-n (cdr ls) (- n 1)))))))
-    (lambda (insert! exp args applicable)
-      (let* ((specializers (method-specializers (car applicable)))
-	     (n-specializers
-	      (if (list? specializers)
-		  (length specializers)
-		  (+ 1 (slot-ref (method-cache-generic-function exp)
-				 'n-specialized)))))
-	(let* ((types (map class-of (first-n args n-specializers)))
-	       (cmethod (compute-cmethod applicable types)))
-	  (insert! exp (append types cmethod)) ; entry = types + cmethod
-	  cmethod))))) ; cmethod