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_slot_missing = SCM_BOOL_F;
static SCM var_no_applicable_method = SCM_BOOL_F; static SCM var_no_applicable_method = SCM_BOOL_F;
static SCM var_change_class = 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_unbound, "slot-unbound");
SCM_SYMBOL (sym_slot_missing, "slot-missing"); 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_DEFINE (scm_sys_allocate_instance, "%allocate-instance", 2, 0, 0,
(SCM class, SCM initargs), (SCM class, SCM initargs),
"Create a new instance of class @var{class} and initialize it\n" "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; SCM_STRUCT_DATA (obj)[i] = 0;
} }
if (SCM_CLASS_FLAGS (class) & SCM_CLASSF_PURE_GENERIC)
clear_method_cache (obj);
return obj; return obj;
} }
#undef FUNC_NAME #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_KEYWORD (k_name, "name");
SCM_GLOBAL_SYMBOL (scm_sym_args, "args"); 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_DEFINE (scm_generic_capability_p, "generic-capability?", 1, 0, 0,
(SCM proc), (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_DEFINE (scm_make, "make", 0, 0, 1,
(SCM args), (SCM args),
"Make a new object. @var{args} must contain the class and\n" "Make a new object. @var{args} must contain the class and\n"
"all necessary initialization information.") "all necessary initialization information.")
#define FUNC_NAME s_scm_make #define FUNC_NAME s_scm_make
{ {
SCM class, z; return scm_apply_0 (scm_variable_ref (var_make), args);
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;
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -1755,6 +1596,8 @@ scm_load_goops ()
} }
SCM_KEYWORD (k_setter, "setter");
SCM SCM
scm_ensure_accessor (SCM name) 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 #define FUNC_NAME s_scm_sys_goops_early_init
{ {
var_make_standard_class = scm_c_lookup ("make-standard-class"); 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_class = scm_variable_ref (scm_c_lookup ("<class>"));
scm_class_top = scm_variable_ref (scm_c_lookup ("<top>")); 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_struct_classes ();
create_port_classes (); create_port_classes ();
{ scm_no_applicable_method = scm_variable_ref (scm_c_lookup ("no-applicable-method"));
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);
}
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
} }

4
module/Makefile.am
View file

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

954
module/oop/goops.scm
View file

File diff suppressed because it is too large Load diff

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)