module/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 ;; There are circularities here; you can't import (oop goops compile)
  20 ;; before (oop goops). So when compiling, make sure that things are
  21 ;; kosher.
  22 (eval-case ((compile-toplevel) (resolve-module '(oop goops))))
  23
  24 (define-module (oop goops compile)
  25   :use-module (oop goops)
  26   :use-module (oop goops util)
  27   :export (compute-cmethod compute-entry-with-cmethod
  28            compile-method cmethod-code cmethod-environment)
  29   :no-backtrace
  30   )
  31
  32 ;;;
  33 ;;; Method entries
  34 ;;;
  35
  36 (define code-table-lookup
  37   (letrec ((check-entry (lambda (entry types)
  38                           (if (null? types)
  39                               (and (not (struct? (car entry)))
  40                                    entry)
  41                               (and (eq? (car entry) (car types))
  42                                    (check-entry (cdr entry) (cdr types)))))))
  43     (lambda (code-table types)
  44       (cond ((null? code-table) #f)
  45             ((check-entry (car code-table) types)
  46              => (lambda (cmethod)
  47                   (cons (car code-table) cmethod)))
  48             (else (code-table-lookup (cdr code-table) types))))))
  49
  50 (define (compute-entry-with-cmethod methods types)
  51   (or (code-table-lookup (slot-ref (car methods) 'code-table) types)
  52       (let* ((method (car methods))
  53              (cmethod (compile-method methods types))
  54              (entry (append types cmethod)))
  55         (slot-set! method 'code-table
  56                    (cons entry (slot-ref method 'code-table)))
  57         (cons entry cmethod))))
  58
  59 (define (compute-cmethod methods types)
  60   (cdr (compute-entry-with-cmethod methods types)))
  61
  62 ;;;
  63 ;;; Next methods
  64 ;;;
  65
  66 ;;; Temporary solution---return #f if x doesn't refer to `next-method'.
  67 (define (next-method? x)
  68   (and (pair? x)
  69        (or (eq? (car x) 'next-method)
  70            (next-method? (car x))
  71            (next-method? (cdr x)))))
  72
  73 (define (make-final-make-next-method method)
  74   (lambda default-args
  75     (lambda args
  76       (@apply method (if (null? args) default-args args)))))
  77
  78 (define (make-final-make-no-next-method gf)
  79   (lambda default-args
  80     (lambda args
  81       (no-next-method gf (if (null? args) default-args args)))))
  82
  83 ;;;
  84 ;;; Method compilation
  85 ;;;
  86
  87 ;;; So, for the reader: there basic idea is that, given that the
  88 ;;; semantics of `next-method' depend on the concrete types being
  89 ;;; dispatched, why not compile a specific procedure to handle each type
  90 ;;; combination that we see at runtime. There are two compilation
  91 ;;; strategies implemented: one for the memoizer, and one for the VM
  92 ;;; compiler.
  93 ;;;
  94 ;;; In theory we can do much better than a bytecode compilation, because
  95 ;;; we know the *exact* types of the arguments. It's ideal for native
  96 ;;; compilation. A task for the future.
  97 ;;;
  98 ;;; I think this whole generic application mess would benefit from a
  99 ;;; strict MOP.
 100
 101 (define (compile-method methods types)
 102   (if (slot-ref (car methods) 'compile-env)
 103       (compile-method/vm methods types)
 104       (compile-method/memoizer methods types)))
 105
 106 (define (make-next-method gf methods types)
 107   (if (null? methods)
 108       (lambda args (no-next-method gf args))
 109       (let ((cmethod (compute-cmethod methods types)))
 110         (if (pair? cmethod)
 111             ;; if it's a pair, the next-method is interpreted
 112             (local-eval (cons 'lambda (cmethod-code cmethod))
 113                         (cmethod-environment cmethod))
 114             ;; otherwise a normal procedure
 115             cmethod))))
 116
 117 (define (compile-method/vm methods types)
 118   (let* ((program-external (@ (system vm program) program-external))
 119          (formals (slot-ref (car methods) 'formals))
 120          (body (slot-ref (car methods) 'body)))
 121     (cond
 122      ((not (next-method? body))
 123       ;; just one method to call -- in the future we could compile this
 124       ;; based on the types that we see, but for now just return the
 125       ;; method procedure (which is vm-compiled already)
 126       (method-procedure (car methods)))
 127
 128      ;; (and-map (lambda (m) (null? (slot-ref m 'compile-env))) methods)
 129      ;; many methods, but with no lexical bindings: can inline, in theory.
 130      ;;
 131      ;; modules complicate this though, the different method bodies only
 132      ;; make sense in the contexts of their modules. so while we could
 133      ;; expand this to a big letrec, there wouldn't be real inlining.
 134
 135      (else
 136       (let* ((next-method-sym (gensym " next-method"))
 137              (method (car methods))
 138              (cmethod (compile
 139                        `(let ((,next-method-sym #f))
 140                           (lambda ,formals
 141                             (let ((next-method
 142                                    (lambda args
 143                                      (if (null? args)
 144                                          ,(if (list? formals)
 145                                               `(,next-method-sym ,@formals)
 146                                               `(apply
 147                                                 ,next-method-sym
 148                                                 ,@(improper->proper formals)))
 149                                          (apply ,next-method-sym args)))))
 150                               ,@body)))
 151                        #:env (slot-ref method 'compile-env))))
 152         (list-set! (program-external cmethod) 0
 153                    (make-next-method (method-generic-function method)
 154                                      (cdr methods)
 155                                      types))
 156         cmethod)))))
 157
 158 ;;;
 159 ;;; Compiling methods for the memoizer
 160 ;;;
 161
 162 (define source-formals cadr)
 163 (define source-body cddr)
 164
 165 (define cmethod-code cdr)
 166 (define cmethod-environment car)
 167
 168 (define %tag-body
 169   (nested-ref the-root-module '(app modules oop goops %tag-body)))
 170
 171 ;;; An exegetical note: the strategy here seems to be to (a) only put in
 172 ;;; next-method if it's referenced in the code; (b) memoize the lookup
 173 ;;; lazily, when `next-method' is first called.
 174
 175 (define (make-make-next-method/memoizer vcell gf methods types)
 176   (lambda default-args
 177     (lambda args
 178       (if (null? methods)
 179           (begin
 180             (set-cdr! vcell (make-final-make-no-next-method gf))
 181             (no-next-method gf (if (null? args) default-args args)))
 182           (let* ((cmethod (compute-cmethod methods types))
 183                  (method
 184                   (if (pair? cmethod)
 185                       (local-eval (cons 'lambda (cmethod-code cmethod))
 186                                   (cmethod-environment cmethod))
 187                       cmethod)))
 188             (set-cdr! vcell (make-final-make-next-method method))
 189             (@apply method (if (null? args) default-args args)))))))
 190
 191 (define (compile-method/memoizer+next methods types proc formals body)
 192   (let ((vcell (cons 'goops:make-next-method #f)))
 193     (set-cdr! vcell
 194               (make-make-next-method/memoizer
 195                vcell
 196                (method-generic-function (car methods))
 197                (cdr methods) types))
 198     ;;*fixme*
 199     `(,(cons vcell (procedure-environment proc))
 200       ,formals
 201       ;;*fixme* Only do this on source where next-method can't be inlined
 202       (let ((next-method ,(if (list? formals)
 203                               `(goops:make-next-method ,@formals)
 204                               `(apply goops:make-next-method
 205                                       ,@(improper->proper formals)))))
 206         ,@body))))
 207
 208 (define (compile-method/memoizer methods types)
 209   (let* ((proc (method-procedure (car methods)))
 210          ;; XXX - procedure-source can not be guaranteed to be
 211          ;;       reliable or efficient
 212          (src (procedure-source proc)))
 213     (if src
 214         (let ((formals (source-formals src))
 215               (body (source-body src)))
 216           (if (next-method? body)
 217               (compile-method/memoizer+next methods types proc formals body)
 218               (cons (procedure-environment proc)
 219                     (cons formals
 220                           (%tag-body body)))
 221               ))
 222         proc)))