;;;; Copyright (C) 1999, 2001, 2006 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 2.1 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-case ((compile-toplevel) (resolve-module '(oop goops)))) (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) :no-backtrace ) ;;; ;;; Method entries ;;; (define code-table-lookup (letrec ((check-entry (lambda (entry types) (if (null? types) (and (not (struct? (car entry))) entry) (and (eq? (car entry) (car types)) (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))) (else (code-table-lookup (cdr code-table) types)))))) (define (compute-entry-with-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))))) ;;; ;;; 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))) #: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))))))) (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)))) (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)))