diff options
author | Andy Wingo <wingo@pobox.com> | 2009-02-13 23:30:20 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2009-02-13 23:30:20 +0100 |
commit | e177058bc4599c68308e6d7fcfbd3f2a0e695f84 (patch) | |
tree | 244367492900b766c386e04924ea5acad7f34416 /module/oop/goops/compile.scm | |
parent | 5a0df7be5ff3b0e4ec558cf3428b08d5086e3f77 (diff) | |
download | guile-e177058bc4599c68308e6d7fcfbd3f2a0e695f84.tar.gz |
don't re-enter the compiler during method dispatch
* libguile/goops.c (scm_make): In the pre-inst `make', default
`procedure' to #f, and read a `make-procedure' instead of
`compile-env'.
* libguile/goops.h (scm_si_make_procedure): This instead of
scm_si_compile_env.
* module/oop/goops.scm (make-method): Remove this unused function. Users
should use (make <method> ...) directly.
(method): Capture `make-procedure' instead of `procedure' in the case
that the body calls a next-method. Allows for the kind of
"recompilation" that we were using before, but with closures instead of
re-entering the compiler. Type-specific compilation is still
interesting, but probably should be implemented in another way.
(initialize): Default #:procedure to #f, and
s/compile-env/make-procedure/.
* module/oop/goops/compile.scm (code-table-lookup): Just return the
cmethod, not the entry -- since the entry is now just (append types
cmethod).
(compile-make-procedure): New procedure, returns a form that, when
evaluated/compiled, will yield a procedure of one argument, the
next-method. When called with a next-method, the procedure returns an
actual method implementation. compile-make-procedure returns #f if the
body doesn't call next-method.
(compile-method): Unify to always return procedures. Much cleaner and
*much* faster in the compiled case. In the interpreted case, there
might be a slight slowdown, but if there is one it should be slight.
* module/oop/goops/dispatch.scm (method-cache-install!): Adapt to removal
of compute-entry-with-cmethod.
Diffstat (limited to 'module/oop/goops/compile.scm')
-rw-r--r-- | module/oop/goops/compile.scm | 190 |
1 files changed, 38 insertions, 152 deletions
diff --git a/module/oop/goops/compile.scm b/module/oop/goops/compile.scm index edf956ea7..22741de40 100644 --- a/module/oop/goops/compile.scm +++ b/module/oop/goops/compile.scm @@ -24,8 +24,7 @@ (define-module (oop goops compile) :use-module (oop goops) :use-module (oop goops util) - :export (compute-cmethod compute-entry-with-cmethod - compile-method cmethod-code cmethod-environment) + :export (compute-cmethod compile-make-procedure) :no-backtrace ) @@ -42,46 +41,20 @@ (check-entry (cdr entry) (cdr types))))))) (lambda (code-table types) (cond ((null? code-table) #f) - ((check-entry (car code-table) types) - => (lambda (cmethod) - (cons (car code-table) cmethod))) + ((check-entry (car code-table) types)) (else (code-table-lookup (cdr code-table) types)))))) -(define (compute-entry-with-cmethod methods types) +(define (compute-cmethod methods types) (or (code-table-lookup (slot-ref (car methods) 'code-table) types) (let* ((method (car methods)) (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))) - -;;; -;;; Next methods -;;; - -;;; Temporary solution---return #f if x doesn't refer to `next-method'. -(define (next-method? x) - (and (pair? x) - (or (eq? (car x) 'next-method) - (next-method? (car x)) - (next-method? (cdr x))))) - -(define (make-final-make-next-method method) - (lambda default-args - (lambda args - (@apply method (if (null? args) default-args args))))) - -(define (make-final-make-no-next-method gf) - (lambda default-args - (lambda args - (no-next-method gf (if (null? args) default-args args))))) + cmethod))) ;;; -;;; Method compilation +;;; Compiling next methods into method bodies ;;; ;;; So, for the reader: there basic idea is that, given that the @@ -98,125 +71,38 @@ ;;; 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))) - #:env (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) - (begin - (set-cdr! vcell (make-final-make-no-next-method gf)) - (no-next-method gf (if (null? args) default-args args))) - (let* ((cmethod (compute-cmethod methods types)) - (method - (if (pair? cmethod) - (local-eval (cons 'lambda (cmethod-code cmethod)) - (cmethod-environment cmethod)) - cmethod))) - (set-cdr! vcell (make-final-make-next-method method)) - (@apply method (if (null? args) default-args args))))))) +;;; Temporary solution---return #f if x doesn't refer to `next-method'. +(define (next-method? x) + (and (pair? x) + (or (eq? (car x) 'next-method) + (next-method? (car x)) + (next-method? (cdr x))))) -(define (compile-method/memoizer+next methods types proc formals body) - (let ((vcell (cons 'goops:make-next-method #f))) - (set-cdr! vcell - (make-make-next-method/memoizer - vcell - (method-generic-function (car methods)) - (cdr methods) types)) - ;;*fixme* - `(,(cons vcell (procedure-environment proc)) - ,formals - ;;*fixme* Only do this on source where next-method can't be inlined - (let ((next-method ,(if (list? formals) - `(goops:make-next-method ,@formals) - `(apply goops:make-next-method - ,@(improper->proper formals))))) - ,@body)))) +;; Called by the `method' macro in goops.scm. +(define (compile-make-procedure formals specializers body) + (and (next-method? body) + (let ((next-method-sym (gensym " next-method")) + (args-sym (gensym))) + `(lambda (,next-method-sym) + (lambda ,formals + (let ((next-method (lambda ,args-sym + (if (null? ,args-sym) + ,(if (list? formals) + `(,next-method-sym ,@formals) + `(apply + ,next-method-sym + ,@(improper->proper formals))) + (apply ,next-method-sym ,args-sym))))) + ,@(if (null? body) + '((begin)) + body))))))) -(define (compile-method/memoizer methods types) - (let* ((proc (method-procedure (car methods))) - ;; XXX - procedure-source can not be guaranteed to be - ;; reliable or efficient - (src (procedure-source proc))) - (if src - (let ((formals (source-formals src)) - (body (source-body src))) - (if (next-method? body) - (compile-method/memoizer+next methods types proc formals body) - (cons (procedure-environment proc) - (cons formals - (%tag-body body))) - )) - proc))) +(define (compile-method methods types) + (let ((make-procedure (slot-ref (car methods) 'make-procedure))) + (if make-procedure + (make-procedure + (if (null? methods) + (lambda args + (no-next-method (method-generic-function (car methods)) args)) + (compute-cmethod (cdr methods) types))) + (method-procedure (car methods))))) |