module/oop/goops/dispatch.scm

   1 ;;;;    Copyright (C) 1999, 2000, 2001, 2003, 2006, 2009, 2012 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 3 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-when (expand) (resolve-module '(oop goops)))
  23
  24 (define-module (oop goops dispatch)
  25   #:use-module (oop goops)
  26   #:use-module (oop goops util)
  27   #:use-module (oop goops compile)
  28   #:use-module (system base target)
  29   #:export (memoize-method!)
  30   #:no-backtrace)
  31
  32
  33 (define *dispatch-module* (current-module))
  34
  35 ;;;
  36 ;;; Generic functions have an applicable-methods cache associated with
  37 ;;; them. Every distinct set of types that is dispatched through a
  38 ;;; generic adds an entry to the cache. This cache gets compiled out to
  39 ;;; a dispatch procedure. In steady-state, this dispatch procedure is
  40 ;;; never recompiled; but during warm-up there is some churn, both to
  41 ;;; the cache and to the dispatch procedure.
  42 ;;;
  43 ;;; So what is the deal if warm-up happens in a multithreaded context?
  44 ;;; There is indeed a window between missing the cache for a certain set
  45 ;;; of arguments, and then updating the cache with the newly computed
  46 ;;; applicable methods. One of the updaters is liable to lose their new
  47 ;;; entry.
  48 ;;;
  49 ;;; This is actually OK though, because a subsequent cache miss for the
  50 ;;; race loser will just cause memoization to try again. The cache will
  51 ;;; eventually be consistent. We're not mutating the old part of the
  52 ;;; cache, just consing on the new entry.
  53 ;;;
  54 ;;; It doesn't even matter if the dispatch procedure and the cache are
  55 ;;; inconsistent -- most likely the type-set that lost the dispatch
  56 ;;; procedure race will simply re-trigger a memoization, but since the
  57 ;;; winner isn't in the effective-methods cache, it will likely also
  58 ;;; re-trigger a memoization, and the cache will finally be consistent.
  59 ;;; As you can see there is a possibility for ping-pong effects, but
  60 ;;; it's unlikely given the shortness of the window between slot-set!
  61 ;;; invocations. We could add a mutex, but it is strictly unnecessary,
  62 ;;; and would add runtime cost and complexity.
  63 ;;;
  64
  65 (define (emit-linear-dispatch gf-sym nargs methods free rest?)
  66   (define (gen-syms n stem)
  67     (let lp ((n (1- n)) (syms '()))
  68       (if (< n 0)
  69           syms
  70           (lp (1- n) (cons (gensym stem) syms)))))
  71   (let* ((args (gen-syms nargs "a"))
  72          (types (gen-syms nargs "t")))
  73     (let lp ((methods methods)
  74              (free free)
  75              (exp `(cache-miss ,gf-sym
  76                                ,(if rest?
  77                                     `(cons* ,@args rest)
  78                                     `(list ,@args)))))
  79       (cond
  80        ((null? methods)
  81         (values `(,(if rest? `(,@args . rest) args)
  82                   (let ,(map (lambda (t a)
  83                                `(,t (class-of ,a)))
  84                              types args)
  85                     ,exp))
  86                 free))
  87        (else
  88         ;; jeez
  89         (let preddy ((free free)
  90                      (types types)
  91                      (specs (vector-ref (car methods) 1))
  92                      (checks '()))
  93           (if (null? types)
  94               (let ((m-sym (gensym "p")))
  95                 (lp (cdr methods)
  96                     (acons (vector-ref (car methods) 3)
  97                            m-sym
  98                            free)
  99                     `(if (and . ,checks)
 100                          ,(if rest?
 101                               `(apply ,m-sym ,@args rest)
 102                               `(,m-sym . ,args))
 103                          ,exp)))
 104               (let ((var (assq-ref free (car specs))))
 105                 (if var
 106                     (preddy free
 107                             (cdr types)
 108                             (cdr specs)
 109                             (cons `(eq? ,(car types) ,var)
 110                                   checks))
 111                     (let ((var (gensym "c")))
 112                       (preddy (acons (car specs) var free)
 113                               (cdr types)
 114                               (cdr specs)
 115                               (cons `(eq? ,(car types) ,var)
 116                                     checks))))))))))))
 117
 118 (define (compute-dispatch-procedure gf cache)
 119   (define (scan)
 120     (let lp ((ls cache) (nreq -1) (nrest -1))
 121       (cond
 122        ((null? ls)
 123         (collate (make-vector (1+ nreq) '())
 124                  (make-vector (1+ nrest) '())))
 125        ((vector-ref (car ls) 2)         ; rest
 126         (lp (cdr ls) nreq (max nrest (vector-ref (car ls) 0))))
 127        (else                            ; req
 128         (lp (cdr ls) (max nreq (vector-ref (car ls) 0)) nrest)))))
 129   (define (collate req rest)
 130     (let lp ((ls cache))
 131       (cond
 132        ((null? ls)
 133         (emit req rest))
 134        ((vector-ref (car ls) 2)         ; rest
 135         (let ((n (vector-ref (car ls) 0)))
 136           (vector-set! rest n (cons (car ls) (vector-ref rest n)))
 137           (lp (cdr ls))))
 138        (else                            ; req
 139         (let ((n (vector-ref (car ls) 0)))
 140           (vector-set! req n (cons (car ls) (vector-ref req n)))
 141           (lp (cdr ls)))))))
 142   (define (emit req rest)
 143     (let ((gf-sym (gensym "g")))
 144       (define (emit-rest n clauses free)
 145         (if (< n (vector-length rest))
 146             (let ((methods (vector-ref rest n)))
 147               (cond
 148                ((null? methods)
 149                 (emit-rest (1+ n) clauses free))
 150                ;; FIXME: hash dispatch
 151                (else
 152                 (call-with-values
 153                     (lambda ()
 154                       (emit-linear-dispatch gf-sym n methods free #t))
 155                   (lambda (clause free)
 156                     (emit-rest (1+ n) (cons clause clauses) free))))))
 157             (emit-req (1- (vector-length req)) clauses free)))
 158       (define (emit-req n clauses free)
 159         (if (< n 0)
 160             (comp `(lambda ,(map cdr free)
 161                      (case-lambda ,@clauses))
 162                   (map car free))
 163             (let ((methods (vector-ref req n)))
 164               (cond
 165                ((null? methods)
 166                 (emit-req (1- n) clauses free))
 167                ;; FIXME: hash dispatch
 168                (else
 169                 (call-with-values
 170                     (lambda ()
 171                       (emit-linear-dispatch gf-sym n methods free #f))
 172                   (lambda (clause free)
 173                     (emit-req (1- n) (cons clause clauses) free))))))))
 174
 175       (emit-rest 0
 176                  (if (or (zero? (vector-length rest))
 177                          (null? (vector-ref rest 0)))
 178                      (list `(args (cache-miss ,gf-sym args)))
 179                      '())
 180                  (acons gf gf-sym '()))))
 181   (define (comp exp vals)
 182     ;; When cross-compiling Guile itself, the native Guile must generate
 183     ;; code for the host.
 184     (with-target %host-type
 185       (lambda ()
 186         (let ((p ((@ (system base compile) compile) exp
 187                   #:env *dispatch-module*
 188                   #:from 'scheme
 189                   #:opts '(#:partial-eval? #f #:cse? #f))))
 190           (apply p vals)))))
 191
 192   ;; kick it.
 193   (scan))
 194
 195 ;; o/~  ten, nine, eight
 196 ;;        sometimes that's just how it goes
 197 ;;          three, two, one
 198 ;;
 199 ;;            get out before it blows    o/~
 200 ;;
 201 (define timer-init 30)
 202 (define (delayed-compile gf)
 203   (let ((timer timer-init))
 204     (lambda args
 205       (set! timer (1- timer))
 206       (cond
 207        ((zero? timer)
 208         (let ((dispatch (compute-dispatch-procedure
 209                          gf (slot-ref gf 'effective-methods))))
 210           (slot-set! gf 'procedure dispatch)
 211           (apply dispatch args)))
 212        (else
 213         ;; interestingly, this catches recursive compilation attempts as
 214         ;; well; in that case, timer is negative
 215         (cache-dispatch gf args))))))
 216
 217 (define (cache-dispatch gf args)
 218   (define (map-until n f ls)
 219     (if (or (zero? n) (null? ls))
 220         '()
 221         (cons (f (car ls)) (map-until (1- n) f (cdr ls)))))
 222   (define (equal? x y) ; can't use the stock equal? because it's a generic...
 223     (cond ((pair? x) (and (pair? y)
 224                           (eq? (car x) (car y))
 225                           (equal? (cdr x) (cdr y))))
 226           ((null? x) (null? y))
 227           (else #f)))
 228   (if (slot-ref gf 'n-specialized)
 229       (let ((types (map-until (slot-ref gf 'n-specialized) class-of args)))
 230         (let lp ((cache (slot-ref gf 'effective-methods)))
 231           (cond ((null? cache)
 232                  (cache-miss gf args))
 233                 ((equal? (vector-ref (car cache) 1) types)
 234                  (apply (vector-ref (car cache) 3) args))
 235                 (else (lp (cdr cache))))))
 236       (cache-miss gf args)))
 237
 238 (define (cache-miss gf args)
 239   (apply (memoize-method! gf args) args))
 240
 241 (define (memoize-effective-method! gf args applicable)
 242   (define (first-n ls n)
 243     (if (or (zero? n) (null? ls))
 244         '()
 245         (cons (car ls) (first-n (cdr ls) (- n 1)))))
 246   (define (parse n ls)
 247     (cond ((null? ls)
 248            (memoize n #f (map class-of args)))
 249           ((= n (slot-ref gf 'n-specialized))
 250            (memoize n #t (map class-of (first-n args n))))
 251           (else
 252            (parse (1+ n) (cdr ls)))))
 253   (define (memoize len rest? types)
 254     (let* ((cmethod (compute-cmethod applicable types))
 255            (cache (cons (vector len types rest? cmethod)
 256                         (slot-ref gf 'effective-methods))))
 257       (slot-set! gf 'effective-methods cache)
 258       (slot-set! gf 'procedure (delayed-compile gf))
 259       cmethod))
 260   (parse 0 args))
 261
 262
 263 ;;;
 264 ;;; Memoization
 265 ;;;
 266
 267 (define (memoize-method! gf args)
 268   (let ((applicable ((if (eq? gf compute-applicable-methods)
 269                          %compute-applicable-methods
 270                          compute-applicable-methods)
 271                      gf args)))
 272     (cond (applicable
 273            (memoize-effective-method! gf args applicable))
 274           (else
 275            (no-applicable-method gf args)))))
 276
 277 (set-procedure-property! memoize-method! 'system-procedure #t)