method lookup caching experiments
[commonqt:commonqt.git] / utils.lisp
1 ;;; -*- show-trailing-whitespace: t; indent-tabs-mode: nil -*-
2
3 ;;; Copyright (c) 2007 Ivan Shvedunov. All rights reserved.
4 ;;; Copyright (c) 2007,2010 David Lichteblau. All rights reserved.
5
6 ;;; Redistribution and use in source and binary forms, with or without
7 ;;; modification, are permitted provided that the following conditions
8 ;;; are met:
9 ;;;
10 ;;;   * Redistributions of source code must retain the above copyright
11 ;;;     notice, this list of conditions and the following disclaimer.
12 ;;;
13 ;;;   * Redistributions in binary form must reproduce the above
14 ;;;     copyright notice, this list of conditions and the following
15 ;;;     disclaimer in the documentation and/or other materials
16 ;;;     provided with the distribution.
17 ;;;
18 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
19 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
20 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
21 ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
22 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
23 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
24 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
25 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
26 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
27 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
28 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
29
30 (in-package :qt)
31 #+sbcl (declaim (optimize (debug 2)))
32
33 ;; Cache the result of COMPILATION-BODY as long as KEYS still match.
34 ;; This is thread-safe because the cache is replaced atomically.  We will
35 ;; lose cache conses if threads replace them simultaneously.  But that's
36 ;; okay, since correctness is not affected.  Losing some values is easier
37 ;; than having to use locking, and contention is not a case we are
38 ;; optimizing for.
39 ;;
40 ;; zzz extend this to use a vector of multiple cache-conses, using either
41 ;; linear search with round-robin replacement, or using SXHASH-based
42 ;; hashing.  Make the size of that table static, but configurable.
43 (defmacro with-cache ((&rest keys) &body compilation-body)
44   (let ((key-values '())
45         (key-tests '()))
46     (dolist (key keys)
47       (destructuring-bind (value &key (test 'equal)) key
48         (push value key-values)
49         (push test key-tests)))
50     (setf key-values (nreverse key-values))
51     (setf key-tests (nreverse key-tests))
52     (let* ((keysyms (loop repeat (length keys) collect (gensym)))
53            (place (gensym))
54            (previous (gensym))
55            (check
56             (when keysyms
57               `((let ((l (cdr ,PREVIOUS)))
58                   , (labels ((recurse (vars tests)
59                                `(and (,(car tests) (car l) ,(car vars))
60                                      ,@ (when (cdr vars)
61                                           `((let ((l (cdr l)))
62                                               ,(recurse (cdr vars)
63                                                         (cdr tests))))))))
64                       (recurse keysyms key-tests)))))))
65       `(let* ((,PLACE (load-time-value (cons nil nil)))
66               (,PREVIOUS (car ,PLACE))
67               ,@(mapcar #'list keysyms key-values))
68          (cond
69            ((and ,PREVIOUS ,@check)
70             #+nil(format sb-sys:*tty* "cache hit: ~A = ~A => ~A~%"
71                     (list ,@keysyms)
72                     (cdr ,PREVIOUS)
73                     (car ,PREVIOUS))
74             #+nil(force-output sb-sys:*tty*)
75             (car ,PREVIOUS))
76            (t
77             (let ((thunk (progn ,@compilation-body)))
78               #+nil(format sb-sys:*tty* "cache miss: ~A = ~A => ~A~%"
79                       (list ,@keysyms)
80                       (cdr ,PREVIOUS)
81                       thunk)
82               #+nil(force-output sb-sys:*tty*)
83               (setf (car ,PLACE) (list thunk ,@keysyms))
84               thunk)))))))