oop/goops/compile.scm

   1 ;;;;    Copyright (C) 1999, 2001, 2006 Free Software Foundation, Inc.
   2 ;;;;
   3 ;;;; This library is free software; you can redistribute it and/or
   4 ;;;; modify it under the terms of the GNU Lesser General Public
   5 ;;;; License as published by the Free Software Foundation; either
   6 ;;;; version 2.1 of the License, or (at your option) any later version.
   7 ;;;;
   8 ;;;; This library is distributed in the hope that it will be useful,
   9 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11 ;;;; Lesser General Public License for more details.
  12 ;;;;
  13 ;;;; You should have received a copy of the GNU Lesser General Public
  14 ;;;; License along with this library; if not, write to the Free Software
  15 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  16 ;;;;
  17 \f
  18
  19 (define-module (oop goops compile)
  20   :use-module (oop goops)
  21   :use-module (oop goops util)
  22   :export (compute-cmethod compute-entry-with-cmethod
  23            compile-method cmethod-code cmethod-environment)
  24   :no-backtrace
  25   )
  26
  27 ;;;
  28 ;;; Method entries
  29 ;;;
  30
  31 (define code-table-lookup
  32   (letrec ((check-entry (lambda (entry types)
  33                           (if (null? types)
  34                               (and (not (struct? (car entry)))
  35                                    entry)
  36                               (and (eq? (car entry) (car types))
  37                                    (check-entry (cdr entry) (cdr types)))))))
  38     (lambda (code-table types)
  39       (cond ((null? code-table) #f)
  40             ((check-entry (car code-table) types)
  41              => (lambda (cmethod)
  42                   (cons (car code-table) cmethod)))
  43             (else (code-table-lookup (cdr code-table) types))))))
  44
  45 (define (compute-entry-with-cmethod methods types)
  46   (or (code-table-lookup (slot-ref (car methods) 'code-table) types)
  47       (let* ((method (car methods))
  48              (cmethod (compile-method methods types))
  49              (entry (append types cmethod)))
  50         (slot-set! method 'code-table
  51                    (cons entry (slot-ref method 'code-table)))
  52         (cons entry cmethod))))
  53
  54 (define (compute-cmethod methods types)
  55   (cdr (compute-entry-with-cmethod methods types)))
  56
  57 ;;;
  58 ;;; Next methods
  59 ;;;
  60
  61 ;;; Temporary solution---return #f if x doesn't refer to `next-method'.
  62 (define (next-method? x)
  63   (and (pair? x)
  64        (or (eq? (car x) 'next-method)
  65            (next-method? (car x))
  66            (next-method? (cdr x)))))
  67
  68 (define (make-final-make-next-method method)
  69   (lambda default-args
  70     (lambda args
  71       (@apply method (if (null? args) default-args args)))))
  72
  73 (define (make-final-make-no-next-method gf)
  74   (lambda default-args
  75     (lambda args
  76       (no-next-method gf (if (null? args) default-args args)))))
  77
  78 ;;;
  79 ;;; Method compilation
  80 ;;;
  81
  82 ;;; So, for the reader: there basic idea is that, given that the
  83 ;;; semantics of `next-method' depend on the concrete types being
  84 ;;; dispatched, why not compile a specific procedure to handle each type
  85 ;;; combination that we see at runtime. There are two compilation
  86 ;;; strategies implemented: one for the memoizer, and one for the VM
  87 ;;; compiler.
  88 ;;;
  89 ;;; In theory we can do much better than a bytecode compilation, because
  90 ;;; we know the *exact* types of the arguments. It's ideal for native
  91 ;;; compilation. A task for the future.
  92 ;;;
  93 ;;; I think this whole generic application mess would benefit from a
  94 ;;; strict MOP.
  95
  96 (define (compile-method methods types)
  97   (if (slot-ref (car methods) 'compile-env)
  98       (compile-method/vm methods types)
  99       (compile-method/memoizer methods types)))
 100
 101 (define (make-next-method gf methods types)
 102   (if (null? methods)
 103       (lambda args (no-next-method gf args))
 104       (let ((cmethod (compute-cmethod methods types)))
 105         (if (pair? cmethod)
 106             ;; if it's a pair, the next-method is interpreted
 107             (local-eval (cons 'lambda (cmethod-code cmethod))
 108                         (cmethod-environment cmethod))
 109             ;; otherwise a normal procedure
 110             cmethod))))
 111
 112 (define (compile-method/vm methods types)
 113   (let* ((program-external (@ (system vm program) program-external))
 114          (formals (slot-ref (car methods) 'formals))
 115          (body (slot-ref (car methods) 'body)))
 116     (cond
 117      ((not (next-method? body))
 118       ;; just one method to call -- in the future we could compile this
 119       ;; based on the types that we see, but for now just return the
 120       ;; method procedure (which is vm-compiled already)
 121       (method-procedure (car methods)))
 122
 123      ;; (and-map (lambda (m) (null? (slot-ref m 'compile-env))) methods)
 124      ;; many methods, but with no lexical bindings: can inline, in theory.
 125      ;;
 126      ;; modules complicate this though, the different method bodies only
 127      ;; make sense in the contexts of their modules. so while we could
 128      ;; expand this to a big letrec, there wouldn't be real inlining.
 129
 130      (else
 131       (let* ((next-method-sym (gensym " next-method"))
 132              (method (car methods))
 133              (cmethod (compile
 134                        `(let ((,next-method-sym #f))
 135                           (lambda ,formals
 136                             (let ((next-method
 137                                    (lambda args
 138                                      (if (null? args)
 139                                          ,(if (list? formals)
 140                                               `(,next-method-sym ,@formals)
 141                                               `(apply
 142                                                 ,next-method-sym
 143                                                 ,@(improper->proper formals)))
 144                                          (apply ,next-method-sym args)))))
 145                               ,@body)))
 146                        (slot-ref method 'compile-env))))
 147         (list-set! (program-external cmethod) 0
 148                    (make-next-method (method-generic-function method)
 149                                      (cdr methods)
 150                                      types))
 151         cmethod)))))
 152
 153 ;;;
 154 ;;; Compiling methods for the memoizer
 155 ;;;
 156
 157 (define source-formals cadr)
 158 (define source-body cddr)
 159
 160 (define cmethod-code cdr)
 161 (define cmethod-environment car)
 162
 163 (define %tag-body
 164   (nested-ref the-root-module '(app modules oop goops %tag-body)))
 165
 166 ;;; An exegetical note: the strategy here seems to be to (a) only put in
 167 ;;; next-method if it's referenced in the code; (b) memoize the lookup
 168 ;;; lazily, when `next-method' is first called.
 169
 170 (define (make-make-next-method/memoizer vcell gf methods types)
 171   (lambda default-args
 172     (lambda args
 173       (if (null? methods)
 174           (begin
 175             (set-cdr! vcell (make-final-make-no-next-method gf))
 176             (no-next-method gf (if (null? args) default-args args)))
 177           (let* ((cmethod (compute-cmethod methods types))
 178                  (method (local-eval (cons 'lambda (cmethod-code cmethod))
 179                                      (cmethod-environment cmethod))))
 180             (set-cdr! vcell (make-final-make-next-method method))
 181             (@apply method (if (null? args) default-args args)))))))
 182
 183 (define (compile-method/memoizer methods types)
 184   (let* ((proc (method-procedure (car methods)))
 185          ;; XXX - procedure-source can not be guaranteed to be
 186          ;;       reliable or efficient
 187          (src (procedure-source proc))
 188          (formals (source-formals src))
 189          (body (source-body src)))
 190     (if (next-method? body)
 191         (let ((vcell (cons 'goops:make-next-method #f)))
 192           (set-cdr! vcell
 193                     (make-make-next-method/memoizer
 194                      vcell
 195                      (method-generic-function (car methods))
 196                      (cdr methods) types))
 197           ;;*fixme*
 198           `(,(cons vcell (procedure-environment proc))
 199             ,formals
 200             ;;*fixme* Only do this on source where next-method can't be inlined
 201             (let ((next-method ,(if (list? formals)
 202                                     `(goops:make-next-method ,@formals)
 203                                     `(apply goops:make-next-method
 204                                             ,@(improper->proper formals)))))
 205               ,@body)))
 206         (cons (procedure-environment proc)
 207               (cons formals
 208                     (%tag-body body)))
 209         )))