dispatch.scm 10 KB

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