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