mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 19:50:24 +02:00
Code Activity

Fold GOOPS compile and dispatch modules into main GOOPS module

Browse source 
* libguile/goops.c (scm_sys_invalidate_method_cache_x): Remove C
  interface to this internal method.  Instead, internal callers are all
  from Scheme, so we move the implementation to Scheme.
  (scm_make): Dispatch to `make' in Scheme.  This is an incompatible but
  great change, as it fulfills the common user perception that scm_make
  is the same as GOOPS's `make'.
  (scm_sys_goops_early_init): Capture `make'.
  (scm_no_applicable_method): Define in Scheme and capture in C.

* module/Makefile.am: Remove oop/goops/compile.scm and
  oop/goops/dispatch.scm.

* module/oop/goops/compile.scm:
* module/oop/goops/dispatch.scm: Fold into goops.scm.

* module/oop/goops.scm: Fold in the generic compile and dispatch
  modules.  This eliminates a circularity that caused some eval-when
  shenanigans, so remove the eval-whens as well.  Reimplement the boot
  version of `make' in Scheme, and make the <generic> `initialize'
  method handle invalidation instead of the generic %allocate-instance.
  (no-applicable-method): Define here.  Import the utils module in the
  normal define-module block.
This commit is contained in:
Andy Wingo 2015-01-04 15:52:12 -05:00
parent 6098d96b7b
commit e0590e7c27
5 changed files with 642 additions and 821 deletions
Download patch file Download diff file Expand all files Collapse all files

173
libguile/goops.c
View file

@ -77,6 +77,7 @@ static SCM var_slot_unbound = SCM_BOOL_F;
static SCM var_slot_missing = SCM_BOOL_F;
static SCM var_no_applicable_method = SCM_BOOL_F;
static SCM var_change_class = SCM_BOOL_F;
static SCM var_make = SCM_BOOL_F;
SCM_SYMBOL (sym_slot_unbound, "slot-unbound");
SCM_SYMBOL (sym_slot_missing, "slot-missing");
@ -1021,8 +1022,6 @@ SCM_DEFINE (scm_slot_exists_p, "slot-exists?", 2, 0, 0,
*
******************************************************************************/
static void clear_method_cache (SCM);
SCM_DEFINE (scm_sys_allocate_instance, "%allocate-instance", 2, 0, 0,
(SCM class, SCM initargs),
"Create a new instance of class @var{class} and initialize it\n"
@ -1054,9 +1053,6 @@ SCM_DEFINE (scm_sys_allocate_instance, "%allocate-instance", 2, 0, 0,
SCM_STRUCT_DATA (obj)[i] = 0;
}
if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC)
clear_method_cache (obj);
return obj;
}
#undef FUNC_NAME
@ -1232,47 +1228,8 @@ scm_change_object_class (SCM obj, SCM old_class SCM_UNUSED, SCM new_class)
******************************************************************************/
SCM_KEYWORD (k_name, "name");
SCM_GLOBAL_SYMBOL (scm_sym_args, "args");
SCM_SYMBOL (sym_delayed_compile, "delayed-compile");
static SCM delayed_compile_var;
static void
init_delayed_compile_var (void)
{
delayed_compile_var
= scm_c_private_lookup ("oop goops dispatch", "delayed-compile");
}
static SCM
make_dispatch_procedure (SCM gf)
{
static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
scm_i_pthread_once (&once, init_delayed_compile_var);
return scm_call_1 (scm_variable_ref (delayed_compile_var), gf);
}
static void
clear_method_cache (SCM gf)
{
SCM_SET_GENERIC_DISPATCH_PROCEDURE (gf, make_dispatch_procedure (gf));
SCM_CLEAR_GENERIC_EFFECTIVE_METHODS (gf);
}
SCM_DEFINE (scm_sys_invalidate_method_cache_x, "%invalidate-method-cache!", 1, 0, 0,
(SCM gf),
"")
#define FUNC_NAME s_scm_sys_invalidate_method_cache_x
{
SCM_ASSERT (SCM_PUREGENERICP (gf), gf, SCM_ARG1, FUNC_NAME);
clear_method_cache (gf);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_DEFINE (scm_generic_capability_p, "generic-capability?", 1, 0, 0,
(SCM proc),
"")
@ -1445,129 +1402,13 @@ scm_wta_dispatch_n (SCM gf, SCM args, int pos, const char *subr)
*
******************************************************************************/
/******************************************************************************
*
* A simple make (which will be redefined later in Scheme)
* This version handles only creation of gf, methods and classes (no instances)
*
* Since this code will disappear when Goops will be fully booted,
* no precaution is taken to be efficient.
*
******************************************************************************/
SCM_KEYWORD (k_setter, "setter");
SCM_KEYWORD (k_specializers, "specializers");
SCM_KEYWORD (k_procedure, "procedure");
SCM_KEYWORD (k_formals, "formals");
SCM_KEYWORD (k_body, "body");
SCM_KEYWORD (k_make_procedure, "make-procedure");
SCM_KEYWORD (k_dsupers, "dsupers");
SCM_KEYWORD (k_slots, "slots");
SCM_KEYWORD (k_gf, "generic-function");
SCM_DEFINE (scm_make, "make", 0, 0, 1,
(SCM args),
"Make a new object. @var{args} must contain the class and\n"
"all necessary initialization information.")
#define FUNC_NAME s_scm_make
{
SCM class, z;
long len = scm_ilength (args);
if (len <= 0 || (len & 1) == 0)
SCM_WRONG_NUM_ARGS ();
class = SCM_CAR(args);
args = SCM_CDR(args);
if (scm_is_eq (class, scm_class_generic)
|| scm_is_eq (class, scm_class_accessor))
{
z = scm_make_struct (class, SCM_INUM0,
scm_list_4 (SCM_BOOL_F,
SCM_EOL,
SCM_INUM0,
SCM_EOL));
scm_set_procedure_property_x (z, scm_sym_name,
scm_get_keyword (k_name,
args,
SCM_BOOL_F));
clear_method_cache (z);
if (scm_is_eq (class, scm_class_accessor))
{
SCM setter = scm_get_keyword (k_setter, args, SCM_BOOL_F);
if (scm_is_true (setter))
scm_sys_set_object_setter_x (z, setter);
}
}
else
{
z = scm_sys_allocate_instance (class, args);
if (scm_is_eq (class, scm_class_method)
|| scm_is_eq (class, scm_class_accessor_method))
{
SCM_SET_SLOT (z, scm_si_generic_function,
scm_i_get_keyword (k_gf,
args,
len - 1,
SCM_BOOL_F,
FUNC_NAME));
SCM_SET_SLOT (z, scm_si_specializers,
scm_i_get_keyword (k_specializers,
args,
len - 1,
SCM_EOL,
FUNC_NAME));
SCM_SET_SLOT (z, scm_si_procedure,
scm_i_get_keyword (k_procedure,
args,
len - 1,
SCM_BOOL_F,
FUNC_NAME));
SCM_SET_SLOT (z, scm_si_formals,
scm_i_get_keyword (k_formals,
args,
len - 1,
SCM_EOL,
FUNC_NAME));
SCM_SET_SLOT (z, scm_si_body,
scm_i_get_keyword (k_body,
args,
len - 1,
SCM_EOL,
FUNC_NAME));
SCM_SET_SLOT (z, scm_si_make_procedure,
scm_i_get_keyword (k_make_procedure,
args,
len - 1,
SCM_BOOL_F,
FUNC_NAME));
}
else
{
/* In all the others case, make a new class .... No instance here */
SCM_SET_SLOT (z, scm_vtable_index_name,
scm_i_get_keyword (k_name,
args,
len - 1,
scm_from_latin1_symbol ("???"),
FUNC_NAME));
SCM_SET_SLOT (z, scm_si_direct_supers,
scm_i_get_keyword (k_dsupers,
args,
len - 1,
SCM_EOL,
FUNC_NAME));
SCM_SET_SLOT (z, scm_si_direct_slots,
scm_i_get_keyword (k_slots,
args,
len - 1,
SCM_EOL,
FUNC_NAME));
}
}
return z;
return scm_apply_0 (scm_variable_ref (var_make), args);
}
#undef FUNC_NAME
@ -1755,6 +1596,8 @@ scm_load_goops ()
}
SCM_KEYWORD (k_setter, "setter");
SCM
scm_ensure_accessor (SCM name)
{
@ -1824,6 +1667,7 @@ SCM_DEFINE (scm_sys_goops_early_init, "%goops-early-init", 0, 0, 0,
#define FUNC_NAME s_scm_sys_goops_early_init
{
var_make_standard_class = scm_c_lookup ("make-standard-class");
var_make = scm_c_lookup ("make");
scm_class_class = scm_variable_ref (scm_c_lookup ("<class>"));
scm_class_top = scm_variable_ref (scm_c_lookup ("<top>"));
@ -1895,12 +1739,7 @@ SCM_DEFINE (scm_sys_goops_early_init, "%goops-early-init", 0, 0, 0,
create_struct_classes ();
create_port_classes ();
{
SCM name = scm_from_latin1_symbol ("no-applicable-method");
scm_no_applicable_method =
scm_make (scm_list_3 (scm_class_generic, k_name, name));
scm_module_define (scm_module_goops, name, scm_no_applicable_method);
}
scm_no_applicable_method = scm_variable_ref (scm_c_lookup ("no-applicable-method"));
return SCM_UNSPECIFIED;
}

4
module/Makefile.am
View file

@ -1,7 +1,7 @@
## Process this file with automake to produce Makefile.in.
##
## Copyright (C) 2009, 2010, 2011, 2012, 2013,
## 2014 Free Software Foundation, Inc.
## 2014, 2015 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
@ -356,10 +356,8 @@ EXTRA_DIST += scripts/README
OOP_SOURCES = \
oop/goops.scm \
oop/goops/active-slot.scm \
oop/goops/compile.scm \
oop/goops/composite-slot.scm \
oop/goops/describe.scm \
oop/goops/dispatch.scm \
oop/goops/internal.scm \
oop/goops/save.scm \
oop/goops/stklos.scm \

370
module/oop/goops.scm
View file

@ -27,6 +27,8 @@
(define-module (oop goops)
#:use-module (srfi srfi-1)
#:use-module (ice-9 match)
#:use-module (oop goops util)
#:use-module (system base target)
#:export-syntax (define-class class standard-define-class
define-generic define-accessor define-method
define-extended-generic define-extended-generics
@ -134,7 +136,20 @@
slot-exists? make find-method get-keyword)
#:no-backtrace)
;; XXX FIXME: figure out why the 'eval-when's in this file must use
;; 'compile' and must avoid 'expand', but only in 2.2, and only when
;; compiling something that imports goops, e.g. (ice-9 occam-channel),
;; before (oop goops) itself has been compiled.
;; First initialize the builtin part of GOOPS
(eval-when (compile load eval)
(load-extension (string-append "libguile-" (effective-version))
"scm_init_goops_builtins"))
(eval-when (compile load eval)
(use-modules ((language tree-il primitives) :select (add-interesting-primitive!)))
(add-interesting-primitive! 'class-of))
;;; The standard class precedence list computation algorithm
;;;
;;; Correct behaviour:
@ -190,21 +205,7 @@
;; Bootstrap version.
(define (compute-cpl class)
(compute-std-cpl class class-direct-supers)))
;; XXX FIXME: figure out why the 'eval-when's in this file must use
;; 'compile' and must avoid 'expand', but only in 2.2, and only when
;; compiling something that imports goops, e.g. (ice-9 occam-channel),
;; before (oop goops) itself has been compiled.
;; First initialize the builtin part of GOOPS
(eval-when (compile load eval)
(load-extension (string-append "libguile-" (effective-version))
"scm_init_goops_builtins"))
(eval-when (compile load eval)
(use-modules ((language tree-il primitives) :select (add-interesting-primitive!)))
(add-interesting-primitive! 'class-of))
(compute-std-cpl class class-direct-supers))
;; During boot, the specialized slot classes aren't defined yet, so we
;; initialize <class> with unspecialized slots.
@ -243,7 +244,6 @@
(unspecialized-slot getters-n-setters)
(unspecialized-slot nfields))))
(eval-when (compile load eval)
(define (build-slots-list dslots cpl)
(define (check-cpl slots class-slots)
(when (or-map (lambda (slot-def) (assq (car slot-def) slots))
@ -481,8 +481,6 @@
(define-standard-class <boolean> (<top>))
(define-standard-class <char> (<top>))
(define-standard-class <list> (<top>))
;; Not all pairs are lists, but there is code out there that relies on
;; (is-a? '(1 2 3) <list>) to work. Terrible. How to fix?
(define-standard-class <pair> (<list>))
(define-standard-class <null> (<list>))
(define-standard-class <string> (<top>))
@ -513,21 +511,339 @@
(define-standard-class <input-port> (<port>))
(define-standard-class <output-port> (<port>))
(define-standard-class <input-output-port> (<input-port> <output-port>))
)
(eval-when (compile load eval)
(%goops-early-init))
(define (%invalidate-method-cache! gf)
(slot-set! gf 'procedure (delayed-compile gf))
(slot-set! gf 'effective-methods '()))
;; Boot definition.
(define (invalidate-method-cache! gf)
(%invalidate-method-cache! gf))
;; A simple make which will be redefined later. This version handles
;; only creation of gf, methods and classes (no instances).
;;
;; Since this code will disappear when Goops will be fully booted,
;; no precaution is taken to be efficient.
;;
(define (make class . args)
(cond
((or (eq? class <generic>) (eq? class <accessor>))
(let ((z (make-struct/no-tail class #f '() 0 '())))
(set-procedure-property! z 'name (get-keyword #:name args #f))
(invalidate-method-cache! z)
(when (eq? class <accessor>)
(let ((setter (get-keyword #:setter args #f)))
(when setter
(%set-object-setter! z setter))))
z))
(else
(let ((z (%allocate-instance class args)))
(cond
((or (eq? class <method>) (eq? class <accessor-method>))
(for-each (match-lambda
((kw slot default)
(slot-set! z slot (get-keyword kw args default))))
'((#:generic-function generic-function #f)
(#:specializers specializers ())
(#:procedure procedure #f)
(#:formals formals ())
(#:body body ())
(#:make-procedure make-procedure #f))))
((memq <class> (class-precedence-list class))
(for-each (match-lambda
((kw slot default)
(slot-set! z slot (get-keyword kw args default))))
'((#:name name ???)
(#:dsupers direct-supers ())
(#:slots direct-slots ())
)))
(else
(error "boot `make' does not support this class" class)))
z))))
(define *dispatch-module* (current-module))
;;;
;;; Generic functions have an applicable-methods cache associated with
;;; them. Every distinct set of types that is dispatched through a
;;; generic adds an entry to the cache. This cache gets compiled out to
;;; a dispatch procedure. In steady-state, this dispatch procedure is
;;; never recompiled; but during warm-up there is some churn, both to
;;; the cache and to the dispatch procedure.
;;;
;;; So what is the deal if warm-up happens in a multithreaded context?
;;; There is indeed a window between missing the cache for a certain set
;;; of arguments, and then updating the cache with the newly computed
;;; applicable methods. One of the updaters is liable to lose their new
;;; entry.
;;;
;;; This is actually OK though, because a subsequent cache miss for the
;;; race loser will just cause memoization to try again. The cache will
;;; eventually be consistent. We're not mutating the old part of the
;;; cache, just consing on the new entry.
;;;
;;; It doesn't even matter if the dispatch procedure and the cache are
;;; inconsistent -- most likely the type-set that lost the dispatch
;;; procedure race will simply re-trigger a memoization, but since the
;;; winner isn't in the effective-methods cache, it will likely also
;;; re-trigger a memoization, and the cache will finally be consistent.
;;; As you can see there is a possibility for ping-pong effects, but
;;; it's unlikely given the shortness of the window between slot-set!
;;; invocations. We could add a mutex, but it is strictly unnecessary,
;;; and would add runtime cost and complexity.
;;;
(define (emit-linear-dispatch gf-sym nargs methods free rest?)
(define (gen-syms n stem)
(let lp ((n (1- n)) (syms '()))
(if (< n 0)
syms
(lp (1- n) (cons (gensym stem) syms)))))
(let* ((args (gen-syms nargs "a"))
(types (gen-syms nargs "t")))
(let lp ((methods methods)
(free free)
(exp `(cache-miss ,gf-sym
,(if rest?
`(cons* ,@args rest)
`(list ,@args)))))
(cond
((null? methods)
(values `(,(if rest? `(,@args . rest) args)
(let ,(map (lambda (t a)
`(,t (class-of ,a)))
types args)
,exp))
free))
(else
;; jeez
(let preddy ((free free)
(types types)
(specs (vector-ref (car methods) 1))
(checks '()))
(if (null? types)
(let ((m-sym (gensym "p")))
(lp (cdr methods)
(acons (vector-ref (car methods) 3)
m-sym
free)
`(if (and . ,checks)
,(if rest?
`(apply ,m-sym ,@args rest)
`(,m-sym . ,args))
,exp)))
(let ((var (assq-ref free (car specs))))
(if var
(preddy free
(cdr types)
(cdr specs)
(cons `(eq? ,(car types) ,var)
checks))
(let ((var (gensym "c")))
(preddy (acons (car specs) var free)
(cdr types)
(cdr specs)
(cons `(eq? ,(car types) ,var)
checks))))))))))))
(define (compute-dispatch-procedure gf cache)
(define (scan)
(let lp ((ls cache) (nreq -1) (nrest -1))
(cond
((null? ls)
(collate (make-vector (1+ nreq) '())
(make-vector (1+ nrest) '())))
((vector-ref (car ls) 2) ; rest
(lp (cdr ls) nreq (max nrest (vector-ref (car ls) 0))))
(else ; req
(lp (cdr ls) (max nreq (vector-ref (car ls) 0)) nrest)))))
(define (collate req rest)
(let lp ((ls cache))
(cond
((null? ls)
(emit req rest))
((vector-ref (car ls) 2) ; rest
(let ((n (vector-ref (car ls) 0)))
(vector-set! rest n (cons (car ls) (vector-ref rest n)))
(lp (cdr ls))))
(else ; req
(let ((n (vector-ref (car ls) 0)))
(vector-set! req n (cons (car ls) (vector-ref req n)))
(lp (cdr ls)))))))
(define (emit req rest)
(let ((gf-sym (gensym "g")))
(define (emit-rest n clauses free)
(if (< n (vector-length rest))
(let ((methods (vector-ref rest n)))
(cond
((null? methods)
(emit-rest (1+ n) clauses free))
;; FIXME: hash dispatch
(else
(call-with-values
(lambda ()
(emit-linear-dispatch gf-sym n methods free #t))
(lambda (clause free)
(emit-rest (1+ n) (cons clause clauses) free))))))
(emit-req (1- (vector-length req)) clauses free)))
(define (emit-req n clauses free)
(if (< n 0)
(comp `(lambda ,(map cdr free)
(case-lambda ,@clauses))
(map car free))
(let ((methods (vector-ref req n)))
(cond
((null? methods)
(emit-req (1- n) clauses free))
;; FIXME: hash dispatch
(else
(call-with-values
(lambda ()
(emit-linear-dispatch gf-sym n methods free #f))
(lambda (clause free)
(emit-req (1- n) (cons clause clauses) free))))))))
(emit-rest 0
(if (or (zero? (vector-length rest))
(null? (vector-ref rest 0)))
(list `(args (cache-miss ,gf-sym args)))
'())
(acons gf gf-sym '()))))
(define (comp exp vals)
;; When cross-compiling Guile itself, the native Guile must generate
;; code for the host.
(with-target %host-type
(lambda ()
(let ((p ((@ (system base compile) compile) exp
#:env *dispatch-module*
#:from 'scheme
#:opts '(#:partial-eval? #f #:cse? #f))))
(apply p vals)))))
;; kick it.
(scan))
;; o/~ ten, nine, eight
;; sometimes that's just how it goes
;; three, two, one
;;
;; get out before it blows o/~
;;
(define timer-init 30)
(define (delayed-compile gf)
(let ((timer timer-init))
(lambda args
(set! timer (1- timer))
(cond
((zero? timer)
(let ((dispatch (compute-dispatch-procedure
gf (slot-ref gf 'effective-methods))))
(slot-set! gf 'procedure dispatch)
(apply dispatch args)))
(else
;; interestingly, this catches recursive compilation attempts as
;; well; in that case, timer is negative
(cache-dispatch gf args))))))
(define (cache-dispatch gf args)
(define (map-until n f ls)
(if (or (zero? n) (null? ls))
'()
(cons (f (car ls)) (map-until (1- n) f (cdr ls)))))
(define (equal? x y) ; can't use the stock equal? because it's a generic...
(cond ((pair? x) (and (pair? y)
(eq? (car x) (car y))
(equal? (cdr x) (cdr y))))
((null? x) (null? y))
(else #f)))
(if (slot-ref gf 'n-specialized)
(let ((types (map-until (slot-ref gf 'n-specialized) class-of args)))
(let lp ((cache (slot-ref gf 'effective-methods)))
(cond ((null? cache)
(cache-miss gf args))
((equal? (vector-ref (car cache) 1) types)
(apply (vector-ref (car cache) 3) args))
(else (lp (cdr cache))))))
(cache-miss gf args)))
(define (cache-miss gf args)
(apply (memoize-method! gf args) args))
(define (memoize-effective-method! gf args applicable)
(define (first-n ls n)
(if (or (zero? n) (null? ls))
'()
(cons (car ls) (first-n (cdr ls) (- n 1)))))
(define (parse n ls)
(cond ((null? ls)
(memoize n #f (map class-of args)))
((= n (slot-ref gf 'n-specialized))
(memoize n #t (map class-of (first-n args n))))
(else
(parse (1+ n) (cdr ls)))))
(define (memoize len rest? types)
(let* ((cmethod (compute-cmethod applicable types))
(cache (cons (vector len types rest? cmethod)
(slot-ref gf 'effective-methods))))
(slot-set! gf 'effective-methods cache)
(slot-set! gf 'procedure (delayed-compile gf))
cmethod))
(parse 0 args))
;;;
;;; Compiling next methods into method bodies
;;;
;;; So, for the reader: there basic idea is that, given that the
;;; semantics of `next-method' depend on the concrete types being
;;; dispatched, why not compile a specific procedure to handle each type
;;; combination that we see at runtime.
;;;
;;; In theory we can do much better than a bytecode compilation, because
;;; we know the *exact* types of the arguments. It's ideal for native
;;; compilation. A task for the future.
;;;
;;; I think this whole generic application mess would benefit from a
;;; strict MOP.
(define (compute-cmethod methods types)
(let ((make-procedure (slot-ref (car methods) 'make-procedure)))
(if make-procedure
(make-procedure
(if (null? (cdr methods))
(lambda args
(no-next-method (method-generic-function (car methods)) args))
(compute-cmethod (cdr methods) types)))
(method-procedure (car methods)))))
;;;
;;; Memoization
;;;
(define (memoize-method! gf args)
(let ((applicable ((if (eq? gf compute-applicable-methods)
%compute-applicable-methods
compute-applicable-methods)
gf args)))
(cond (applicable
(memoize-effective-method! gf args applicable))
(else
(no-applicable-method gf args)))))
(set-procedure-property! memoize-method! 'system-procedure #t)
(define no-applicable-method
(make <generic> #:name 'no-applicable-method))
(%goops-early-init)
;; Then load the rest of GOOPS
(use-modules (oop goops util)
(oop goops dispatch)
(oop goops compile))
;; FIXME: deprecate.
(eval-when (compile load eval)
(define min-fixnum (- (expt 2 29)))
(define max-fixnum (- (expt 2 29) 1)))
(define max-fixnum (- (expt 2 29) 1))
;;
;; goops-error
@ -1855,7 +2171,7 @@
'()))
(if name
(set-procedure-property! generic 'name name))
))
(invalidate-method-cache! generic)))
(define-method (initialize (gws <generic-with-setter>) initargs)
(next-method)

55
module/oop/goops/compile.scm
View file

@ -1,55 +0,0 @@
;;;; Copyright (C) 1999, 2001, 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 (expand) (resolve-module '(oop goops)))
(define-module (oop goops compile)
:use-module (oop goops)
:use-module (oop goops util)
:export (compute-cmethod)
:no-backtrace
)
;;;
;;; Compiling next methods into method bodies
;;;
;;; So, for the reader: there basic idea is that, given that the
;;; semantics of `next-method' depend on the concrete types being
;;; dispatched, why not compile a specific procedure to handle each type
;;; combination that we see at runtime.
;;;
;;; In theory we can do much better than a bytecode compilation, because
;;; we know the *exact* types of the arguments. It's ideal for native
;;; compilation. A task for the future.
;;;
;;; I think this whole generic application mess would benefit from a
;;; strict MOP.
(define (compute-cmethod methods types)
(let ((make-procedure (slot-ref (car methods) 'make-procedure)))
(if make-procedure
(make-procedure
(if (null? (cdr methods))
(lambda args
(no-next-method (method-generic-function (car methods)) args))
(compute-cmethod (cdr methods) types)))
(method-procedure (car methods)))))

277
module/oop/goops/dispatch.scm
View file

@ -1,277 +0,0 @@
;;;; Copyright (C) 1999, 2000, 2001, 2003, 2006, 2009, 2012 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 (expand) (resolve-module '(oop goops)))
(define-module (oop goops dispatch)
#:use-module (oop goops)
#:use-module (oop goops util)
#:use-module (oop goops compile)
#:use-module (system base target)
#:export (memoize-method!)
#:no-backtrace)
(define *dispatch-module* (current-module))
;;;
;;; Generic functions have an applicable-methods cache associated with
;;; them. Every distinct set of types that is dispatched through a
;;; generic adds an entry to the cache. This cache gets compiled out to
;;; a dispatch procedure. In steady-state, this dispatch procedure is
;;; never recompiled; but during warm-up there is some churn, both to
;;; the cache and to the dispatch procedure.
;;;
;;; So what is the deal if warm-up happens in a multithreaded context?
;;; There is indeed a window between missing the cache for a certain set
;;; of arguments, and then updating the cache with the newly computed
;;; applicable methods. One of the updaters is liable to lose their new
;;; entry.
;;;
;;; This is actually OK though, because a subsequent cache miss for the
;;; race loser will just cause memoization to try again. The cache will
;;; eventually be consistent. We're not mutating the old part of the
;;; cache, just consing on the new entry.
;;;
;;; It doesn't even matter if the dispatch procedure and the cache are
;;; inconsistent -- most likely the type-set that lost the dispatch
;;; procedure race will simply re-trigger a memoization, but since the
;;; winner isn't in the effective-methods cache, it will likely also
;;; re-trigger a memoization, and the cache will finally be consistent.
;;; As you can see there is a possibility for ping-pong effects, but
;;; it's unlikely given the shortness of the window between slot-set!
;;; invocations. We could add a mutex, but it is strictly unnecessary,
;;; and would add runtime cost and complexity.
;;;
(define (emit-linear-dispatch gf-sym nargs methods free rest?)
(define (gen-syms n stem)
(let lp ((n (1- n)) (syms '()))
(if (< n 0)
syms
(lp (1- n) (cons (gensym stem) syms)))))
(let* ((args (gen-syms nargs "a"))
(types (gen-syms nargs "t")))
(let lp ((methods methods)
(free free)
(exp `(cache-miss ,gf-sym
,(if rest?
`(cons* ,@args rest)
`(list ,@args)))))
(cond
((null? methods)
(values `(,(if rest? `(,@args . rest) args)
(let ,(map (lambda (t a)
`(,t (class-of ,a)))
types args)
,exp))
free))
(else
;; jeez
(let preddy ((free free)
(types types)
(specs (vector-ref (car methods) 1))
(checks '()))
(if (null? types)
(let ((m-sym (gensym "p")))
(lp (cdr methods)
(acons (vector-ref (car methods) 3)
m-sym
free)
`(if (and . ,checks)
,(if rest?
`(apply ,m-sym ,@args rest)
`(,m-sym . ,args))
,exp)))
(let ((var (assq-ref free (car specs))))
(if var
(preddy free
(cdr types)
(cdr specs)
(cons `(eq? ,(car types) ,var)
checks))
(let ((var (gensym "c")))
(preddy (acons (car specs) var free)
(cdr types)
(cdr specs)
(cons `(eq? ,(car types) ,var)
checks))))))))))))
(define (compute-dispatch-procedure gf cache)
(define (scan)
(let lp ((ls cache) (nreq -1) (nrest -1))
(cond
((null? ls)
(collate (make-vector (1+ nreq) '())
(make-vector (1+ nrest) '())))
((vector-ref (car ls) 2) ; rest
(lp (cdr ls) nreq (max nrest (vector-ref (car ls) 0))))
(else ; req
(lp (cdr ls) (max nreq (vector-ref (car ls) 0)) nrest)))))
(define (collate req rest)
(let lp ((ls cache))
(cond
((null? ls)
(emit req rest))
((vector-ref (car ls) 2) ; rest
(let ((n (vector-ref (car ls) 0)))
(vector-set! rest n (cons (car ls) (vector-ref rest n)))
(lp (cdr ls))))
(else ; req
(let ((n (vector-ref (car ls) 0)))
(vector-set! req n (cons (car ls) (vector-ref req n)))
(lp (cdr ls)))))))
(define (emit req rest)
(let ((gf-sym (gensym "g")))
(define (emit-rest n clauses free)
(if (< n (vector-length rest))
(let ((methods (vector-ref rest n)))
(cond
((null? methods)
(emit-rest (1+ n) clauses free))
;; FIXME: hash dispatch
(else
(call-with-values
(lambda ()
(emit-linear-dispatch gf-sym n methods free #t))
(lambda (clause free)
(emit-rest (1+ n) (cons clause clauses) free))))))
(emit-req (1- (vector-length req)) clauses free)))
(define (emit-req n clauses free)
(if (< n 0)
(comp `(lambda ,(map cdr free)
(case-lambda ,@clauses))
(map car free))
(let ((methods (vector-ref req n)))
(cond
((null? methods)
(emit-req (1- n) clauses free))
;; FIXME: hash dispatch
(else
(call-with-values
(lambda ()
(emit-linear-dispatch gf-sym n methods free #f))
(lambda (clause free)
(emit-req (1- n) (cons clause clauses) free))))))))
(emit-rest 0
(if (or (zero? (vector-length rest))
(null? (vector-ref rest 0)))
(list `(args (cache-miss ,gf-sym args)))
'())
(acons gf gf-sym '()))))
(define (comp exp vals)
;; When cross-compiling Guile itself, the native Guile must generate
;; code for the host.
(with-target %host-type
(lambda ()
(let ((p ((@ (system base compile) compile) exp
#:env *dispatch-module*
#:from 'scheme
#:opts '(#:partial-eval? #f #:cse? #f))))
(apply p vals)))))
;; kick it.
(scan))
;; o/~ ten, nine, eight
;; sometimes that's just how it goes
;; three, two, one
;;
;; get out before it blows o/~
;;
(define timer-init 30)
(define (delayed-compile gf)
(let ((timer timer-init))
(lambda args
(set! timer (1- timer))
(cond
((zero? timer)
(let ((dispatch (compute-dispatch-procedure
gf (slot-ref gf 'effective-methods))))
(slot-set! gf 'procedure dispatch)
(apply dispatch args)))
(else
;; interestingly, this catches recursive compilation attempts as
;; well; in that case, timer is negative
(cache-dispatch gf args))))))
(define (cache-dispatch gf args)
(define (map-until n f ls)
(if (or (zero? n) (null? ls))
'()
(cons (f (car ls)) (map-until (1- n) f (cdr ls)))))
(define (equal? x y) ; can't use the stock equal? because it's a generic...
(cond ((pair? x) (and (pair? y)
(eq? (car x) (car y))
(equal? (cdr x) (cdr y))))
((null? x) (null? y))
(else #f)))
(if (slot-ref gf 'n-specialized)
(let ((types (map-until (slot-ref gf 'n-specialized) class-of args)))
(let lp ((cache (slot-ref gf 'effective-methods)))
(cond ((null? cache)
(cache-miss gf args))
((equal? (vector-ref (car cache) 1) types)
(apply (vector-ref (car cache) 3) args))
(else (lp (cdr cache))))))
(cache-miss gf args)))
(define (cache-miss gf args)
(apply (memoize-method! gf args) args))
(define (memoize-effective-method! gf args applicable)
(define (first-n ls n)
(if (or (zero? n) (null? ls))
'()
(cons (car ls) (first-n (cdr ls) (- n 1)))))
(define (parse n ls)
(cond ((null? ls)
(memoize n #f (map class-of args)))
((= n (slot-ref gf 'n-specialized))
(memoize n #t (map class-of (first-n args n))))
(else
(parse (1+ n) (cdr ls)))))
(define (memoize len rest? types)
(let* ((cmethod (compute-cmethod applicable types))
(cache (cons (vector len types rest? cmethod)
(slot-ref gf 'effective-methods))))
(slot-set! gf 'effective-methods cache)
(slot-set! gf 'procedure (delayed-compile gf))
cmethod))
(parse 0 args))
;;;
;;; Memoization
;;;
(define (memoize-method! gf args)
(let ((applicable ((if (eq? gf compute-applicable-methods)
%compute-applicable-methods
compute-applicable-methods)
gf args)))
(cond (applicable
(memoize-effective-method! gf args applicable))
(else
(no-applicable-method gf args)))))
(set-procedure-property! memoize-method! 'system-procedure #t)