mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-08 10:50:21 +02:00
b6cf4d0265
I tried to split this one, and I know it's a bit disruptive, but this stuff really is one big cobweb. So instead we'll pretend like these are separate commits, by separating the changelog. Applicable struct runtime support. * libguile/debug.c (scm_procedure_source): * libguile/eval.c (scm_trampoline_0, scm_trampoline_1) (scm_trampoline_2): * libguile/eval.i.c (CEVAL): * libguile/goops.c (scm_class_of): * libguile/procprop.c (scm_i_procedure_arity): * libguile/procs.c (scm_procedure_p, scm_procedure, scm_setter): Allow for applicable structs. Whee! * libguile/deprecated.h (scm_vtable_index_vtable): Define as a synonym for scm_vtable_index_self. (scm_vtable_index_printer): Alias scm_vtable_index_instance_printer. (scm_struct_i_free): Alias scm_vtable_index_instance_finalize. (scm_struct_i_flags): Alias scm_vtable_index_flags. (SCM_STRUCTF_FLAGS): Be a -1 mask, we have a whole word now. (SCM_SET_VTABLE_DESTRUCTOR): Implement by hand. Hidden slots. * libguile/struct.c (scm_make_struct_layout): Add support for "hidden" fields, writable fields that are not visible to make-struct. This allows us to add fields to vtables and not break existing make-struct invocations. (scm_struct_ref, scm_struct_set_x): Always get struct length from the vtable. Support hidden fields. * libguile/goops.c (scm_class_hidden, scm_class_protected_hidden): New slot classes, to correspond to the new vtable slots. (scm_sys_prep_layout_x): Turn hidden slots into 'h'. (build_class_class_slots): Reorder the class slots to account for vtable fields coming out of negative-land, for name as a vtable slot, and for hidden fields. (create_standard_classes): Define <hidden-slot> and <protected-hidden-slot>. Clean up struct.h. * libguile/struct.h: Lay things out cleaner. There are no more hidden (negative) words. Names are nicer. The exposition is nicer. But the basics are the same. The incompatibilities are that <vtable> has more slots now, and that scm_alloc_struct's signature has changed. The former is ameliorated by the "hidden" slots mentioned before, and the latter, well, it was always a very internal thing... (scm_t_struct_finalize): New type, a finalizer function to be run when instances of a vtable are collected. (scm_t_struct_free): Removed, structs' data is managed by the GC now, and not freed by vtable functions. * libguile/struct.c: (scm_vtable_p): Now we keep flags on vtable-vtables, so this check is cheaper. (scm_alloc_struct): No hidden words. Yippee. (struct_finalizer_trampoline): Entersify. (scm_make_struct): No need to babysit extra words, though now we have to babysit flags. Propagate the vtable, applicable, and setter flags appropriately. (scm_make_vtable_vtable): Update for new simplicity. (scm_print_struct): A better printer. (scm_init_struct): Define <applicable-struct-vtable>, a magical vtable like CL's funcallable-standard-class. Also define <applicable-struct-with-setter-vtable>. Remove foreign object implementation. * libguile/goops.h: * libguile/goops.c (scm_make_foreign_object, scm_make_class) (scm_add_slot, scm_wrap_object, scm_wrap_component): Remove, these were undocumented and unworking. Clean up goops.h, a little. * libguile/goops.h: * libguile/goops.c: Also clean up. * module/oop/goops/dispatch.scm (hashset-index): Adapt for new hashset index.
268 lines
8.1 KiB
Scheme
268 lines
8.1 KiB
Scheme
;;;; Copyright (C) 1999, 2000, 2001, 2003, 2006, 2009 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 3 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
|
||
;;;;
|
||
|
||
|
||
;; 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 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
|
||
;;;
|
||
|
||
;; 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
|