summaryrefslogtreecommitdiff
path: root/module/oop/goops/compile.scm
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2009-02-13 23:30:20 +0100
committerAndy Wingo <wingo@pobox.com>2009-02-13 23:30:20 +0100
commite177058bc4599c68308e6d7fcfbd3f2a0e695f84 (patch)
tree244367492900b766c386e04924ea5acad7f34416 /module/oop/goops/compile.scm
parent5a0df7be5ff3b0e4ec558cf3428b08d5086e3f77 (diff)
downloadguile-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.scm190
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)))))