From 5487977b1bf4a120cc3604f649cc51ea39b533d9 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 30 Oct 2008 13:42:40 +0100 Subject: [PATCH] runtime byte compilation of goops methods, whooooo * ice-9/boot-9.scm (make-modules-in): Change to make sure that we are making modules in modules; that is, that a global binding of `compile' doesn't prevent a module from importing a submodule named `compile'. (resolve-module): Clean up a bit, and serialize the logic. * libguile/objects.c (scm_mcache_lookup_cmethod, scm_apply_generic): * libguile/eval.i.c (CEVAL): Now that cmethod entries can have a program as their tail instead of a memoized proc, we have to change the halting condition on the method cache search, in both places: the one that's inlined into eval.i.c and the one in objects.c. If the cmethod isn't a pair, apply it. * libguile/goops.c (make): In the `make' procedure that's used before GOOPS is booted, bind #:formals, #:body, and #:compile-env on methods. * oop/goops/compile.scm (compute-entry-with-cmethod): There was a terrible trick here that involved putting a dummy pair in the cache, then modifying it in place with the result of memoization. The note claimed that this was to cut recursion short, or something. I can't see how it could recurse, given that `methods' is changing each time. Also, the pair trick doesn't work with byte-compiled methods. So, remove it. (compile-method): Dispatch to the appropriate method compiler, based on whether the method was defined with the interpreter or with the compiler. (make-next-method): New function, generically computes a `next-method' procedure, though the caller has to supply the arguments. (compile-method/vm): Exciting method byte compiler! (make-make-next-method/memoizer, compile-method/memoizer): Add the /memoizer suffix, and move all this code to the bottom of the file. --- ice-9/boot-9.scm | 55 +++++++++--------- libguile/eval.i.c | 18 ++++-- libguile/goops.c | 21 +++++++ libguile/objects.c | 15 +++-- oop/goops/compile.scm | 130 ++++++++++++++++++++++++++++++++---------- 5 files changed, 170 insertions(+), 69 deletions(-) diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index e32964ae4..be67560dd 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -1801,16 +1801,18 @@ (define (make-modules-in module name) (if (null? name) module - (cond - ((module-ref module (car name) #f) - => (lambda (m) (make-modules-in m (cdr name)))) - (else (let ((m (make-module 31))) - (set-module-kind! m 'directory) - (set-module-name! m (append (or (module-name module) - '()) - (list (car name)))) - (module-define! module (car name) m) - (make-modules-in m (cdr name))))))) + (make-modules-in + (let* ((var (module-local-variable module (car name))) + (val (and var (variable-bound? var) (variable-ref var)))) + (if (module? val) + val + (let ((m (make-module 31))) + (set-module-kind! m 'directory) + (set-module-name! m (append (or (module-name module) '()) + (list (car name)))) + (module-define! module (car name) m) + m))) + (cdr name)))) (define (beautify-user-module! module) (let ((interface (module-public-interface module))) @@ -1833,23 +1835,22 @@ (if (equal? name '(guile)) the-root-module (let ((full-name (append '(%app modules) name))) - (let ((already (nested-ref the-root-module full-name))) - (if already - ;; The module already exists... - (if (and (or (null? maybe-autoload) (car maybe-autoload)) - (not (module-public-interface already))) - ;; ...but we are told to load and it doesn't contain source, so - (begin - (try-load-module name) - already) - ;; simply return it. - already) - (begin - ;; Try to autoload it if we are told so - (if (or (null? maybe-autoload) (car maybe-autoload)) - (try-load-module name)) - ;; Get/create it. - (make-modules-in (current-module) full-name))))))))) + (let ((already (nested-ref the-root-module full-name)) + (autoload (or (null? maybe-autoload) (car maybe-autoload)))) + (cond + ((and already (module? already) + (or (not autoload) (module-public-interface already))) + ;; A hit, a palpable hit. + already) + (autoload + ;; Try to autoload the module, and recurse. + (try-load-module name) + (resolve-module name #f)) + (else + ;; A module is not bound (but maybe something else is), + ;; we're not autoloading -- here's the weird semantics, + ;; we create an empty module. + (make-modules-in the-root-module full-name))))))))) ;; Cheat. These bindings are needed by modules.c, but we don't want ;; to move their real definition here because that would be unnatural. diff --git a/libguile/eval.i.c b/libguile/eval.i.c index 3d686700b..407a64281 100644 --- a/libguile/eval.i.c +++ b/libguile/eval.i.c @@ -855,8 +855,8 @@ dispatch: args = SCM_CDR (args); z = SCM_CDR (z); } - /* Fewer arguments than specifiers => CAR != ENV */ - if (scm_is_null (SCM_CAR (z)) || scm_is_pair (SCM_CAR (z))) + /* Fewer arguments than specifiers => CAR != CLASS */ + if (!SCM_CLASSP (SCM_CAR (z))) goto apply_cmethod; next_method: hash_value = (hash_value + 1) & mask; @@ -867,10 +867,16 @@ dispatch: apply_cmethod: /* inputs: z, arg1 */ { - SCM formals = SCM_CMETHOD_FORMALS (z); - env = SCM_EXTEND_ENV (formals, arg1, SCM_CMETHOD_ENV (z)); - x = SCM_CMETHOD_BODY (z); - goto nontoplevel_begin; + if (scm_is_pair (z)) { + SCM formals = SCM_CMETHOD_FORMALS (z); + env = SCM_EXTEND_ENV (formals, arg1, SCM_CMETHOD_ENV (z)); + x = SCM_CMETHOD_BODY (z); + goto nontoplevel_begin; + } else { + proc = z; + PREP_APPLY (proc, arg1); + goto apply_proc; + } } } } diff --git a/libguile/goops.c b/libguile/goops.c index 89556c540..f647cca93 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -2215,6 +2215,9 @@ scm_memoize_method (SCM x, SCM args) 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_compile_env, "compile-env"); SCM_KEYWORD (k_dsupers, "dsupers"); SCM_KEYWORD (k_slots, "slots"); SCM_KEYWORD (k_gf, "generic-function"); @@ -2281,6 +2284,24 @@ SCM_DEFINE (scm_make, "make", 0, 0, 1, SCM_EOL, FUNC_NAME)); SCM_SET_SLOT (z, scm_si_code_table, SCM_EOL); + 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_compile_env, + scm_i_get_keyword (k_compile_env, + args, + len - 1, + SCM_BOOL_F, + FUNC_NAME)); } else { diff --git a/libguile/objects.c b/libguile/objects.c index 995d2e4c9..f3c9731a4 100644 --- a/libguile/objects.c +++ b/libguile/objects.c @@ -138,8 +138,8 @@ scm_mcache_lookup_cmethod (SCM cache, SCM args) z = SCM_CDR (z); } while (j-- && !scm_is_null (ls)); - /* Fewer arguments than specifiers => CAR != ENV */ - if (scm_is_null (SCM_CAR (z)) || scm_is_pair (SCM_CAR (z))) + /* Fewer arguments than specifiers => CAR != CLASS */ + if (!SCM_CLASSP (SCM_CAR (z))) return z; next_method: i = (i + 1) & mask; @@ -161,10 +161,13 @@ SCM scm_apply_generic (SCM gf, SCM args) { SCM cmethod = scm_mcache_compute_cmethod (SCM_ENTITY_PROCEDURE (gf), args); - return scm_eval_body (SCM_CDR (SCM_CMETHOD_CODE (cmethod)), - SCM_EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (cmethod)), - args, - SCM_CMETHOD_ENV (cmethod))); + if (scm_is_pair (cmethod)) + return scm_eval_body (SCM_CDR (SCM_CMETHOD_CODE (cmethod)), + SCM_EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (cmethod)), + args, + SCM_CMETHOD_ENV (cmethod))); + else + return scm_apply (cmethod, args, SCM_EOL); } SCM diff --git a/oop/goops/compile.scm b/oop/goops/compile.scm index c0175a72a..2e7a16f77 100644 --- a/oop/goops/compile.scm +++ b/oop/goops/compile.scm @@ -24,13 +24,6 @@ :no-backtrace ) -(define source-formals cadr) -(define source-body cddr) - -(define cmethod-code cdr) -(define cmethod-environment car) - - ;;; ;;; Method entries ;;; @@ -52,16 +45,11 @@ (define (compute-entry-with-cmethod methods types) (or (code-table-lookup (slot-ref (car methods) 'code-table) types) (let* ((method (car methods)) - (place-holder (list #f)) - (entry (append types place-holder))) - ;; In order to handle recursion nicely, put the entry - ;; into the code-table before compiling the method - (slot-set! (car methods) 'code-table - (cons entry (slot-ref (car methods) 'code-table))) - (let ((cmethod (compile-method methods types))) - (set-car! place-holder (car cmethod)) - (set-cdr! place-holder (cdr cmethod))) - (cons entry place-holder)))) + (cmethod (compile-method methods types)) + (entry (append types cmethod))) + (slot-set! method 'code-table + (cons entry (slot-ref method 'code-table))) + (cons entry cmethod)))) (define (compute-cmethod methods types) (cdr (compute-entry-with-cmethod methods types))) @@ -87,7 +75,99 @@ (lambda args (no-next-method gf (if (null? args) default-args args))))) -(define (make-make-next-method vcell gf methods types) +;;; +;;; Method compilation +;;; + +;;; 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. There are two compilation +;;; strategies implemented: one for the memoizer, and one for the VM +;;; compiler. +;;; +;;; 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 (compile-method methods types) + (if (slot-ref (car methods) 'compile-env) + (compile-method/vm methods types) + (compile-method/memoizer methods types))) + +(define (make-next-method gf methods types) + (if (null? methods) + (lambda args (no-next-method gf args)) + (let ((cmethod (compute-cmethod methods types))) + (if (pair? cmethod) + ;; if it's a pair, the next-method is interpreted + (local-eval (cons 'lambda (cmethod-code cmethod)) + (cmethod-environment cmethod)) + ;; otherwise a normal procedure + cmethod)))) + +(define (compile-method/vm methods types) + (let* ((program-external (@ (system vm program) program-external)) + (formals (slot-ref (car methods) 'formals)) + (body (slot-ref (car methods) 'body))) + (cond + ((not (next-method? body)) + ;; just one method to call -- in the future we could compile this + ;; based on the types that we see, but for now just return the + ;; method procedure (which is vm-compiled already) + (method-procedure (car methods))) + + ;; (and-map (lambda (m) (null? (slot-ref m 'compile-env))) methods) + ;; many methods, but with no lexical bindings: can inline, in theory. + ;; + ;; modules complicate this though, the different method bodies only + ;; make sense in the contexts of their modules. so while we could + ;; expand this to a big letrec, there wouldn't be real inlining. + + (else + (let* ((next-method-sym (gensym " next-method")) + (method (car methods)) + (cmethod (compile + `(let ((,next-method-sym #f)) + (lambda ,formals + (let ((next-method + (lambda args + (if (null? args) + ,(if (list? formals) + `(,next-method-sym ,@formals) + `(apply + ,next-method-sym + ,@(improper->proper formals))) + (apply ,next-method-sym args))))) + ,@body))) + (slot-ref method 'compile-env)))) + (list-set! (program-external cmethod) 0 + (make-next-method (method-generic-function method) + (cdr methods) + types)) + cmethod))))) + +;;; +;;; Compiling methods for the memoizer +;;; + +(define source-formals cadr) +(define source-body cddr) + +(define cmethod-code cdr) +(define cmethod-environment car) + +(define %tag-body + (nested-ref the-root-module '(app modules oop goops %tag-body))) + +;;; An exegetical note: the strategy here seems to be to (a) only put in +;;; next-method if it's referenced in the code; (b) memoize the lookup +;;; lazily, when `next-method' is first called. + +(define (make-make-next-method/memoizer vcell gf methods types) (lambda default-args (lambda args (if (null? methods) @@ -100,17 +180,7 @@ (set-cdr! vcell (make-final-make-next-method method)) (@apply method (if (null? args) default-args args))))))) -;;; -;;; Method compilation -;;; - -;;; NOTE: This section is far from finished. It will finally be -;;; implemented on C level. - -(define %tag-body - (nested-ref the-root-module '(app modules oop goops %tag-body))) - -(define (compile-method methods types) +(define (compile-method/memoizer methods types) (let* ((proc (method-procedure (car methods))) ;; XXX - procedure-source can not be guaranteed to be ;; reliable or efficient @@ -120,7 +190,7 @@ (if (next-method? body) (let ((vcell (cons 'goops:make-next-method #f))) (set-cdr! vcell - (make-make-next-method + (make-make-next-method/memoizer vcell (method-generic-function (car methods)) (cdr methods) types)) -- 2.20.1