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

;;;; 	Copyright (C) 1999, 2000, 2001 Free Software Foundation, Inc.
;;;; 
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2, or (at your option)
;;;; any later version.
;;;; 
;;;; This program 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 General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING.  If not, write to
;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
;;;; Boston, MA 02111-1307 USA
;;;;
;;;; As a special exception, the Free Software Foundation gives permission
;;;; for additional uses of the text contained in its release of GUILE.
;;;;
;;;; The exception is that, if you link the GUILE library with other files
;;;; to produce an executable, this does not by itself cause the
;;;; resulting executable to be covered by the GNU General Public License.
;;;; Your use of that executable is in no way restricted on account of
;;;; linking the GUILE library code into it.
;;;;
;;;; This exception does not however invalidate any other reasons why
;;;; the executable file might be covered by the GNU General Public License.
;;;;
;;;; This exception applies only to the code released by the
;;;; Free Software Foundation under the name GUILE.  If you copy
;;;; code from other Free Software Foundation releases into a copy of
;;;; GUILE, as the General Public License permits, the exception does
;;;; not apply to the code that you add in this way.  To avoid misleading
;;;; anyone as to the status of such modified files, you must delete
;;;; this exception notice from them.
;;;;
;;;; If you write modifications of your own for GUILE, it is your choice
;;;; whether to permit this exception to apply to your modifications.
;;;; If you do not wish that, delete this exception notice.
;;;; 
\f

(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 (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 environment? pair?)

(define (cache-hashval hashset entry)
  (let ((hashset-index (+ hashset-index hashset)))
    (do ((sum 0)
	 (classes entry (cdr classes)))
	((environment? (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)))
    (catch 'misses
	   (lambda ()
	     (do ((ls entries (cdr ls))
		  (misses 0 0))
		 ((null? ls) max-misses)
	       (do ((i (logand mask (cache-hashval hashset (car ls)))
		       (logand mask (+ i 1))))
		   ((not (struct? (car (vector-ref cache i))))
		    (vector-set! cache i (car ls)))
		 (set! misses (+ 1 misses))
		 (if (>= misses min-misses)
		     (throw 'misses misses)))
	       (if (> misses max-misses)
		   (set! max-misses misses))))
	   (lambda (key misses)
	     misses))))

;;;
;;; Memoization
;;;

;; Backward compatibility
(if (not (defined? 'lookup-create-cmethod))
    (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)))
	       (entry+cmethod (compute-entry-with-cmethod applicable types)))
	  (insert! exp (car entry+cmethod)) ; entry = types + cmethod
	  (cdr entry+cmethod) ; cmethod
	  )))))
Commit	Line	Data
1a179b03	1	;;;; Copyright (C) 1999, 2000, 2001 Free Software Foundation, Inc.
14f1d9fe MD	2	;;;;
	3	;;;; This program is free software; you can redistribute it and/or modify
	4	;;;; it under the terms of the GNU General Public License as published by
	5	;;;; the Free Software Foundation; either version 2, or (at your option)
	6	;;;; any later version.
	7	;;;;
	8	;;;; This program is distributed in the hope that it will be useful,
	9	;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	10	;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	11	;;;; GNU General Public License for more details.
	12	;;;;
	13	;;;; You should have received a copy of the GNU General Public License
	14	;;;; along with this software; see the file COPYING. If not, write to
	15	;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
	16	;;;; Boston, MA 02111-1307 USA
c22adbeb MV	17	;;;;
	18	;;;; As a special exception, the Free Software Foundation gives permission
	19	;;;; for additional uses of the text contained in its release of GUILE.
	20	;;;;
	21	;;;; The exception is that, if you link the GUILE library with other files
	22	;;;; to produce an executable, this does not by itself cause the
	23	;;;; resulting executable to be covered by the GNU General Public License.
	24	;;;; Your use of that executable is in no way restricted on account of
	25	;;;; linking the GUILE library code into it.
	26	;;;;
	27	;;;; This exception does not however invalidate any other reasons why
	28	;;;; the executable file might be covered by the GNU General Public License.
	29	;;;;
	30	;;;; This exception applies only to the code released by the
	31	;;;; Free Software Foundation under the name GUILE. If you copy
	32	;;;; code from other Free Software Foundation releases into a copy of
	33	;;;; GUILE, as the General Public License permits, the exception does
	34	;;;; not apply to the code that you add in this way. To avoid misleading
	35	;;;; anyone as to the status of such modified files, you must delete
	36	;;;; this exception notice from them.
	37	;;;;
	38	;;;; If you write modifications of your own for GUILE, it is your choice
	39	;;;; whether to permit this exception to apply to your modifications.
	40	;;;; If you do not wish that, delete this exception notice.
14f1d9fe MD	41	;;;;
	42	\f
	43
	44	(define-module (oop goops dispatch)
	45	:use-module (oop goops)
	46	:use-module (oop goops util)
	47	:use-module (oop goops compile)
1a179b03	48	:export (memoize-method!)
14f1d9fe MD	49	:no-backtrace
	50	)
	51
14f1d9fe MD	52	;;;
	53	;;; This file implements method memoization. It will finally be
	54	;;; implemented on C level in order to obtain fast generic function
	55	;;; application also during the first pass through the code.
	56	;;;
	57
	58	;;;
	59	;;; Constants
	60	;;;
	61
	62	(define hashsets 8)
8b958d72	63	(define hashset-index 6)
14f1d9fe MD	64
	65	(define hash-threshold 3)
	66	(define initial-hash-size 4) ;must be a power of 2 and >= hash-threshold
	67
	68	(define initial-hash-size-1 (- initial-hash-size 1))
	69
	70	(define the-list-of-no-method '(no-method))
	71
	72	;;;
	73	;;; Method cache
	74	;;;
	75
	76	;; (#@dispatch args N-SPECIALIZED #((TYPE1 ... ENV FORMALS FORM1 ...) ...) GF)
	77	;; (#@dispatch args N-SPECIALIZED HASHSET MASK
	78	;; #((TYPE1 ... ENV FORMALS FORM1 ...) ...)
	79	;; GF)
	80
	81	;;; Representation
	82
	83	;; non-hashed form
	84
	85	(define method-cache-entries cadddr)
	86
	87	(define (set-method-cache-entries! mcache entries)
	88	(set-car! (cdddr mcache) entries))
	89
	90	(define (method-cache-n-methods exp)
	91	(n-cache-methods (method-cache-entries exp)))
	92
	93	(define (method-cache-methods exp)
	94	(cache-methods (method-cache-entries exp)))
	95
	96	;; hashed form
	97
	98	(define (set-hashed-method-cache-hashset! exp hashset)
	99	(set-car! (cdddr exp) hashset))
	100
	101	(define (set-hashed-method-cache-mask! exp mask)
	102	(set-car! (cddddr exp) mask))
	103
	104	(define (hashed-method-cache-entries exp)
	105	(list-ref exp 5))
	106
	107	(define (set-hashed-method-cache-entries! exp entries)
	108	(set-car! (list-cdr-ref exp 5) entries))
	109
	110	;; either form
	111
	112	(define (method-cache-generic-function exp)
	113	(list-ref exp (if (method-cache-hashed? exp) 6 4)))
	114
	115	;;; Predicates
	116
	117	(define (method-cache-hashed? x)
	118	(integer? (cadddr x)))
	119
	120	(define max-non-hashed-index (- hash-threshold 2))
	121
	122	(define (passed-hash-threshold? exp)
	123	(and (> (vector-length (method-cache-entries exp)) max-non-hashed-index)
	124	(struct? (car (vector-ref (method-cache-entries exp)
	125	max-non-hashed-index)))))
	126
	127	;;; Converting a method cache to hashed form
128
129	(define (method-cache->hashed! exp)
130	(set-cdr! (cddr exp) (cons 0 (cons initial-hash-size-1 (cdddr exp))))
131	exp)
132
133	;;;
134	;;; Cache entries
135	;;;
136
137	(define (n-cache-methods entries)
138	(do ((i (- (vector-length entries) 1) (- i 1)))
139	((or (< i 0) (struct? (car (vector-ref entries i))))
140	(+ i 1))))
141
142	(define (cache-methods entries)
143	(do ((i (- (vector-length entries) 1) (- i 1))
144	(methods '() (let ((entry (vector-ref entries i)))
145	(if (struct? (car entry))
146	(cons entry methods)
147	methods))))
148	((< i 0) methods)))
149
150	;;;
151	;;; Method insertion
152	;;;
153
154	(define (method-cache-insert! exp entry)
155	(let* ((entries (method-cache-entries exp))
156	(n (n-cache-methods entries)))
157	(if (>= n (vector-length entries))
158	;; grow cache
159	(let ((new-entries (make-vector (* 2 (vector-length entries))
160	the-list-of-no-method)))
161	(do ((i 0 (+ i 1)))
162	((= i n))
163	(vector-set! new-entries i (vector-ref entries i)))
164	(vector-set! new-entries n entry)
165	(set-method-cache-entries! exp new-entries))
166	(vector-set! entries n entry))))
167
168	(define (hashed-method-cache-insert! exp entry)
169	(let* ((cache (hashed-method-cache-entries exp))
170	(size (vector-length cache)))
171	(let* ((entries (cons entry (cache-methods cache)))
172	(size (if (<= (length entries) size)
173	size
174	;; larger size required
175	(let ((new-size (* 2 size)))
176	(set-hashed-method-cache-mask! exp (- new-size 1))
177	new-size)))
178	(min-misses size)
179	(best #f))
180	(do ((hashset 0 (+ 1 hashset)))
181	((= hashset hashsets))
182	(let* ((test-cache (make-vector size the-list-of-no-method))
183	(misses (cache-try-hash! min-misses hashset test-cache entries)))
184	(cond ((zero? misses)
185	(set! min-misses 0)
186	(set! best hashset)
187	(set! cache test-cache)
188	(set! hashset (- hashsets 1)))
189	((< misses min-misses)
190	(set! min-misses misses)
191	(set! best hashset)
192	(set! cache test-cache)))))
193	(set-hashed-method-cache-hashset! exp best)
194	(set-hashed-method-cache-entries! exp cache))))
195
196	;;;
197	;;; Caching
198	;;;
199
200	(define environment? pair?)
201
202	(define (cache-hashval hashset entry)
203	(let ((hashset-index (+ hashset-index hashset)))
204	(do ((sum 0)
205	(classes entry (cdr classes)))
206	((environment? (car classes)) sum)
207	(set! sum (+ sum (struct-ref (car classes) hashset-index))))))
208
209	(define (cache-try-hash! min-misses hashset cache entries)
210	(let ((max-misses 0)
211	(mask (- (vector-length cache) 1)))
212	(catch 'misses
213	(lambda ()
214	(do ((ls entries (cdr ls))
215	(misses 0 0))
216	((null? ls) max-misses)
ca83b028 DH	217	(do ((i (logand mask (cache-hashval hashset (car ls)))
ca83b028 DH	218	(logand mask (+ i 1))))
14f1d9fe MD	219	((not (struct? (car (vector-ref cache i))))
	220	(vector-set! cache i (car ls)))
	221	(set! misses (+ 1 misses))
	222	(if (>= misses min-misses)
	223	(throw 'misses misses)))
	224	(if (> misses max-misses)
	225	(set! max-misses misses))))
	226	(lambda (key misses)
	227	misses))))
	228
	229	;;;
	230	;;; Memoization
	231	;;;
	232
	233	;; Backward compatibility
	234	(if (not (defined? 'lookup-create-cmethod))
	235	(define (lookup-create-cmethod gf args)
	236	(no-applicable-method (car args) (cadr args))))
	237
	238	(define (memoize-method! gf args exp)
	239	(if (not (slot-ref gf 'used-by))
	240	(slot-set! gf 'used-by '()))
	241	(let ((applicable ((if (eq? gf compute-applicable-methods)
	242	%compute-applicable-methods
	243	compute-applicable-methods)
	244	gf args)))
	245	(cond (applicable
	246	;; fixme dispatch.scm needs rewriting Since the current
	247	;; code mutates the method cache, we have to work on a
	248	;; copy. Otherwise we might disturb another thread
	249	;; currently dispatching on the cache. (No need to copy
	250	;; the vector.)
	251	(let* ((new (list-copy exp))
	252	(res
	253	(cond ((method-cache-hashed? new)
	254	(method-cache-install! hashed-method-cache-insert!
	255	new args applicable))
	256	((passed-hash-threshold? new)
	257	(method-cache-install! hashed-method-cache-insert!
	258	(method-cache->hashed! new)
	259	args
	260	applicable))
	261	(else
	262	(method-cache-install! method-cache-insert!
	263	new args applicable)))))
	264	(set-cdr! (cdr exp) (cddr new))
	265	res))
	266	((null? args)
	267	(lookup-create-cmethod no-applicable-method (list gf '())))
	268	(else
	269	;; Mutate arglist to fit no-applicable-method
	270	(set-cdr! args (list (cons (car args) (cdr args))))
	271	(set-car! args gf)
	272	(lookup-create-cmethod no-applicable-method args)))))
	273
	274	(set-procedure-property! memoize-method! 'system-procedure #t)
	275
	276	(define method-cache-install!
	277	(letrec ((first-n
	278	(lambda (ls n)
	279	(if (or (zero? n) (null? ls))
	280	'()
	281	(cons (car ls) (first-n (cdr ls) (- n 1)))))))
	282	(lambda (insert! exp args applicable)
283	(let* ((specializers (method-specializers (car applicable)))
284	(n-specializers
285	(if (list? specializers)
286	(length specializers)
ef42490f	287	(+ 1 (slot-ref (method-cache-generic-function exp)
14f1d9fe MD	288	'n-specialized)))))
	289	(let* ((types (map class-of (first-n args n-specializers)))
	290	(entry+cmethod (compute-entry-with-cmethod applicable types)))
	291	(insert! exp (car entry+cmethod)) ; entry = types + cmethod
	292	(cdr entry+cmethod) ; cmethod
	293	)))))