[bpt/guile.git] / module / oop / goops / dispatch.scm

;;;; 	Copyright (C) 1999, 2000, 2001, 2003, 2006 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later version.
;;;; 
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;
\f

;; There are circularities here; you can't import (oop goops compile)
;; before (oop goops). So when compiling, make sure that things are
;; kosher.
(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
  )

;;;
;;; 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 6)

(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 ... ENV FORMALS FORM1 ...) ...) GF)
;; (#@dispatch args N-SPECIALIZED HASHSET MASK
;;             #((TYPE1 ... ENV FORMALS FORM1 ...) ...)
;;             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 ((max-misses 0)
	(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
;;;

;; Backward compatibility
(define (lookup-create-cmethod gf args)
  (no-applicable-method (car args) (cadr args)))

(define (memoize-method! gf args exp)
  (if (not (slot-ref gf 'used-by))
      (slot-set! gf 'used-by '()))
  (let ((applicable ((if (eq? gf compute-applicable-methods)
			 %compute-applicable-methods
			 compute-applicable-methods)
		     gf args)))
    (cond (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))
	  ((null? args)
	   (lookup-create-cmethod no-applicable-method (list gf '())))
	  (else
	   ;; Mutate arglist to fit no-applicable-method
	   (set-cdr! args (list (cons (car args) (cdr args))))
	   (set-car! args gf)
	   (lookup-create-cmethod no-applicable-method 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
Commit	Line	Data
6e7d5622	1	;;;; Copyright (C) 1999, 2000, 2001, 2003, 2006 Free Software Foundation, Inc.
327d4dd3	2	;;;;
73be1d9e MV	3	;;;; This library is free software; you can redistribute it and/or
	4	;;;; modify it under the terms of the GNU Lesser General Public
	5	;;;; License as published by the Free Software Foundation; either
	6	;;;; version 2.1 of the License, or (at your option) any later version.
	7	;;;;
	8	;;;; This library is distributed in the hope that it will be useful,
14f1d9fe	9	;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
73be1d9e MV	10	;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	11	;;;; Lesser General Public License for more details.
	12	;;;;
	13	;;;; You should have received a copy of the GNU Lesser General Public
	14	;;;; License along with this library; if not, write to the Free Software
92205699	15	;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
327d4dd3	16	;;;;
14f1d9fe MD	17	\f
14f1d9fe MD	18
4631414e AW	19	;; There are circularities here; you can't import (oop goops compile)
	20	;; before (oop goops). So when compiling, make sure that things are
	21	;; kosher.
b15dea68	22	(eval-when (compile) (resolve-module '(oop goops)))
4631414e	23
14f1d9fe MD	24	(define-module (oop goops dispatch)
	25	:use-module (oop goops)
	26	:use-module (oop goops util)
	27	:use-module (oop goops compile)
1a179b03	28	:export (memoize-method!)
14f1d9fe MD	29	:no-backtrace
	30	)
	31
14f1d9fe MD	32	;;;
	33	;;; This file implements method memoization. It will finally be
	34	;;; implemented on C level in order to obtain fast generic function
	35	;;; application also during the first pass through the code.
	36	;;;
	37
	38	;;;
	39	;;; Constants
	40	;;;
	41
	42	(define hashsets 8)
8b958d72	43	(define hashset-index 6)
14f1d9fe MD	44
	45	(define hash-threshold 3)
	46	(define initial-hash-size 4) ;must be a power of 2 and >= hash-threshold
	47
	48	(define initial-hash-size-1 (- initial-hash-size 1))
	49
	50	(define the-list-of-no-method '(no-method))
	51
	52	;;;
	53	;;; Method cache
	54	;;;
	55
	56	;; (#@dispatch args N-SPECIALIZED #((TYPE1 ... ENV FORMALS FORM1 ...) ...) GF)
	57	;; (#@dispatch args N-SPECIALIZED HASHSET MASK
	58	;; #((TYPE1 ... ENV FORMALS FORM1 ...) ...)
	59	;; GF)
	60
	61	;;; Representation
	62
	63	;; non-hashed form
	64
	65	(define method-cache-entries cadddr)
	66
	67	(define (set-method-cache-entries! mcache entries)
	68	(set-car! (cdddr mcache) entries))
	69
	70	(define (method-cache-n-methods exp)
	71	(n-cache-methods (method-cache-entries exp)))
	72
	73	(define (method-cache-methods exp)
	74	(cache-methods (method-cache-entries exp)))
	75
	76	;; hashed form
	77
	78	(define (set-hashed-method-cache-hashset! exp hashset)
	79	(set-car! (cdddr exp) hashset))
	80
	81	(define (set-hashed-method-cache-mask! exp mask)
	82	(set-car! (cddddr exp) mask))
	83
	84	(define (hashed-method-cache-entries exp)
	85	(list-ref exp 5))
	86
	87	(define (set-hashed-method-cache-entries! exp entries)
	88	(set-car! (list-cdr-ref exp 5) entries))
	89
	90	;; either form
	91
	92	(define (method-cache-generic-function exp)
	93	(list-ref exp (if (method-cache-hashed? exp) 6 4)))
	94
	95	;;; Predicates
	96
	97	(define (method-cache-hashed? x)
	98	(integer? (cadddr x)))
	99
	100	(define max-non-hashed-index (- hash-threshold 2))
	101
	102	(define (passed-hash-threshold? exp)
	103	(and (> (vector-length (method-cache-entries exp)) max-non-hashed-index)
	104	(struct? (car (vector-ref (method-cache-entries exp)
	105	max-non-hashed-index)))))
	106
	107	;;; Converting a method cache to hashed form
108
109	(define (method-cache->hashed! exp)
110	(set-cdr! (cddr exp) (cons 0 (cons initial-hash-size-1 (cdddr exp))))
111	exp)
112
113	;;;
114	;;; Cache entries
115	;;;
116
117	(define (n-cache-methods entries)
118	(do ((i (- (vector-length entries) 1) (- i 1)))
119	((or (< i 0) (struct? (car (vector-ref entries i))))
120	(+ i 1))))
121
122	(define (cache-methods entries)
123	(do ((i (- (vector-length entries) 1) (- i 1))
124	(methods '() (let ((entry (vector-ref entries i)))
7d38f3d8	125	(if (or (not (pair? entry)) (struct? (car entry)))
14f1d9fe MD	126	(cons entry methods)
	127	methods))))
	128	((< i 0) methods)))
	129
	130	;;;
	131	;;; Method insertion
	132	;;;
	133
	134	(define (method-cache-insert! exp entry)
	135	(let* ((entries (method-cache-entries exp))
	136	(n (n-cache-methods entries)))
	137	(if (>= n (vector-length entries))
	138	;; grow cache
	139	(let ((new-entries (make-vector (* 2 (vector-length entries))
	140	the-list-of-no-method)))
	141	(do ((i 0 (+ i 1)))
	142	((= i n))
	143	(vector-set! new-entries i (vector-ref entries i)))
	144	(vector-set! new-entries n entry)
	145	(set-method-cache-entries! exp new-entries))
	146	(vector-set! entries n entry))))
	147
	148	(define (hashed-method-cache-insert! exp entry)
	149	(let* ((cache (hashed-method-cache-entries exp))
	150	(size (vector-length cache)))
	151	(let* ((entries (cons entry (cache-methods cache)))
	152	(size (if (<= (length entries) size)
	153	size
	154	;; larger size required
	155	(let ((new-size (* 2 size)))
	156	(set-hashed-method-cache-mask! exp (- new-size 1))
	157	new-size)))
	158	(min-misses size)
	159	(best #f))
	160	(do ((hashset 0 (+ 1 hashset)))
	161	((= hashset hashsets))
	162	(let* ((test-cache (make-vector size the-list-of-no-method))
	163	(misses (cache-try-hash! min-misses hashset test-cache entries)))
	164	(cond ((zero? misses)
	165	(set! min-misses 0)
	166	(set! best hashset)
	167	(set! cache test-cache)
	168	(set! hashset (- hashsets 1)))
	169	((< misses min-misses)
	170	(set! min-misses misses)
	171	(set! best hashset)
	172	(set! cache test-cache)))))
	173	(set-hashed-method-cache-hashset! exp best)
	174	(set-hashed-method-cache-entries! exp cache))))
	175
	176	;;;
	177	;;; Caching
	178	;;;
	179
14f1d9fe MD	180	(define (cache-hashval hashset entry)
	181	(let ((hashset-index (+ hashset-index hashset)))
	182	(do ((sum 0)
	183	(classes entry (cdr classes)))
05b37c17 AW	184	((not (and (pair? classes) (struct? (car classes))))
05b37c17 AW	185	sum)
14f1d9fe MD	186	(set! sum (+ sum (struct-ref (car classes) hashset-index))))))
	187
	188	(define (cache-try-hash! min-misses hashset cache entries)
	189	(let ((max-misses 0)
	190	(mask (- (vector-length cache) 1)))
80540f39 AW	191	(let outer ((in entries) (max-misses 0))
	192	(if (null? in)
	193	max-misses
	194	(let inner ((i (logand mask (cache-hashval hashset (car in))))
	195	(misses 0))
	196	(cond
	197	((and (pair? (vector-ref cache i))
	198	(eq? (car (vector-ref cache i)) 'no-method))
	199	(vector-set! cache i (car in))
	200	(outer (cdr in) (if (> misses max-misses) misses max-misses)))
	201	(else
	202	(let ((misses (+ 1 misses)))
	203	(if (>= misses min-misses)
	204	misses ;; this is a return, yo.
	205	(inner (logand mask (+ i 1)) misses))))))))))
14f1d9fe MD	206
	207	;;;
	208	;;; Memoization
	209	;;;
	210
	211	;; Backward compatibility
2ce560b9 AW	212	(define (lookup-create-cmethod gf args)
2ce560b9 AW	213	(no-applicable-method (car args) (cadr args)))
14f1d9fe	214
b39eac3a	215	(define (memoize-method! gf args exp)
14f1d9fe MD	216	(if (not (slot-ref gf 'used-by))
	217	(slot-set! gf 'used-by '()))
	218	(let ((applicable ((if (eq? gf compute-applicable-methods)
	219	%compute-applicable-methods
	220	compute-applicable-methods)
	221	gf args)))
	222	(cond (applicable
	223	;; fixme dispatch.scm needs rewriting Since the current
	224	;; code mutates the method cache, we have to work on a
	225	;; copy. Otherwise we might disturb another thread
	226	;; currently dispatching on the cache. (No need to copy
	227	;; the vector.)
	228	(let* ((new (list-copy exp))
	229	(res
	230	(cond ((method-cache-hashed? new)
	231	(method-cache-install! hashed-method-cache-insert!
	232	new args applicable))
	233	((passed-hash-threshold? new)
	234	(method-cache-install! hashed-method-cache-insert!
	235	(method-cache->hashed! new)
	236	args
	237	applicable))
	238	(else
	239	(method-cache-install! method-cache-insert!
	240	new args applicable)))))
	241	(set-cdr! (cdr exp) (cddr new))
	242	res))
	243	((null? args)
	244	(lookup-create-cmethod no-applicable-method (list gf '())))
	245	(else
	246	;; Mutate arglist to fit no-applicable-method
	247	(set-cdr! args (list (cons (car args) (cdr args))))
	248	(set-car! args gf)
	249	(lookup-create-cmethod no-applicable-method args)))))
	250
	251	(set-procedure-property! memoize-method! 'system-procedure #t)
	252
b39eac3a TTN	253	(define method-cache-install!
	254	(letrec ((first-n
	255	(lambda (ls n)
	256	(if (or (zero? n) (null? ls))
	257	'()
	258	(cons (car ls) (first-n (cdr ls) (- n 1)))))))
	259	(lambda (insert! exp args applicable)
	260	(let* ((specializers (method-specializers (car applicable)))
	261	(n-specializers
	262	(if (list? specializers)
	263	(length specializers)
	264	(+ 1 (slot-ref (method-cache-generic-function exp)
	265	'n-specialized)))))
	266	(let* ((types (map class-of (first-n args n-specializers)))
e177058b AW	267	(cmethod (compute-cmethod applicable types)))
	268	(insert! exp (append types cmethod)) ; entry = types + cmethod
	269	cmethod))))) ; cmethod