guile/module/oop/goops/compile.scm

;;;; 	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)))