/[cmucl]/src/pcl/gf-call-optimization.lisp
ViewVC logotype

Contents of /src/pcl/gf-call-optimization.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.7 - (show annotations)
Fri Mar 19 15:19:03 2010 UTC (4 years, 1 month ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, post-merge-intl-branch, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.6: +2 -1 lines
Merge intl-branch 2010-03-18 to HEAD.  To build, you need to use
boot-2010-02-1 as the bootstrap file.  You should probably also use
the new -P option for build.sh to generate and update the po files
while building.
1 ;;; Copyright (C) 2003 Gerd Moellmann <gerd.moellmann@t-online.de>
2 ;;; All rights reserved.
3 ;;;
4 ;;; Redistribution and use in source and binary forms, with or without
5 ;;; modification, are permitted provided that the following conditions
6 ;;; are met:
7 ;;;
8 ;;; 1. Redistributions of source code must retain the above copyright
9 ;;; notice, this list of conditions and the following disclaimer.
10 ;;; 2. Redistributions in binary form must reproduce the above copyright
11 ;;; notice, this list of conditions and the following disclaimer in the
12 ;;; documentation and/or other materials provided with the distribution.
13 ;;; 3. The name of the author may not be used to endorse or promote
14 ;;; products derived from this software without specific prior written
15 ;;; permission.
16 ;;;
17 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS
18 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
19 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
20 ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE
21 ;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
22 ;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
23 ;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
24 ;;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
25 ;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
26 ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
27 ;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
28 ;;; DAMAGE.
29
30 (file-comment "$Header: /tiger/var/lib/cvsroots/cmucl/src/pcl/gf-call-optimization.lisp,v 1.7 2010/03/19 15:19:03 rtoy Rel $")
31
32 (in-package "PCL")
33 (intl:textdomain "cmucl")
34
35 ;;; ***************************************************
36 ;;; General Generic Function Call Optimization *******
37 ;;; ***************************************************
38 ;;;
39 ;;; This optimizes calls to generic functions to calls of effective
40 ;;; method functions, which are stored in the pv-table cache of a
41 ;;; method.
42 ;;;
43 ;;; Each method has a pv table associated with it, whose cache maps
44 ;;; the wrappers of actual method arguments to pv-cells. The cdr of
45 ;;; these pv-cells is a vector of effective methods, one for each
46 ;;; pv-optimized generic function call in the pv-table's call-list.
47 ;;; The local variable .CALLS. is bound to the call vector in a method
48 ;;; function.
49
50 (defvar *optimize-gf-calls-p* t)
51
52 (defmacro callsref (call-vector i)
53 `(%svref ,call-vector ,i))
54
55 (define-walker-template call-optimization-barrier)
56 (defmacro call-optimization-barrier (x) x)
57
58 (defun optimize-gf-call (form required-method-parameters calls env)
59 (flet ((make-call-optimization-barrier (form)
60 `(,(first form) (call-optimization-barrier ,(second form))
61 ,@(cddr form)))
62 (call-optimization-barrier-p (form)
63 (let ((arg (second form)))
64 (and (consp arg) (eq 'call-optimization-barrier (car arg))))))
65 (when (and *optimize-gf-calls-p*
66 (eq *boot-state* 'complete)
67 (not (eq 'apply (first form)))
68 (not (call-optimization-barrier-p form)))
69 (let ((call (make-pv-call form required-method-parameters env)))
70 (when call
71 (let ((entry (assoc call calls :test #'equal))
72 (pv-offset-form (list 'pv-offset -1)))
73 (when (null entry)
74 (push (setq entry (cons call nil)) (cdr calls)))
75 (push pv-offset-form (cdr entry))
76 ;;
77 (let* ((nreq (length (cdr call)))
78 (gf-info (gf-info (car call)))
79 ;;
80 ;; According to MAKE-FAST-METHOD-CALL-LAMBDA-LIST, a
81 ;; fast method function has a rest arg if the generic
82 ;; function's applyp flag is set.
83 (rest-p (gf-info-applyp gf-info))
84 (rest (when rest-p (nthcdr nreq (cdr form))))
85 (required-args (when rest-p (ldiff (cdr form) rest))))
86 (setq form
87 `(let ((.emf. (callsref .calls. ,pv-offset-form)))
88 (declare #.*optimize-speed*)
89 (cond ((fast-method-call-p .emf.)
90 ,@(if rest-p
91 `((invoke-fast-method-call
92 .emf. ,@required-args
93 (list ,@rest)))
94 `((invoke-fast-method-call
95 .emf. ,@(cdr form)))))
96 (.emf.
97 (funcall (lambda (&rest args)
98 (invoke-emf .emf. args))
99 ,@(cdr form)))
100 (t
101 ,(make-call-optimization-barrier form))))))))))
102 form))
103
104 ;;;
105 ;;; Value is NIL if FORM is not optimizable. Otherwise, a list
106 ;;; (GF-NAME <pos0> <pos1> ...) is returned. GF-NAME is the name of
107 ;;; the generic function being called, and each <posN> is the index of
108 ;;; a method parameter used as argument N to the generic function.
109 ;;;
110 (defun make-pv-call (form required-params env)
111 (let* ((gf-name (first form))
112 (gf-info (gf-info gf-name))
113 (nreq (gf-info-nreq gf-info)))
114 (flet (;;
115 ;; If VAR is the name of a specialized method parameter,
116 ;; or a rebinding of it, return the method parameter's name,
117 ;; otherwise return NIL.
118 (specialized-method-parameter (var)
119 (let ((param (method-parameter var required-params env)))
120 (when param
121 (let ((cname (caddr (variable-declaration 'class param
122 env))))
123 (when (and cname (not (eq t cname)))
124 param))))))
125 ;;
126 ;; Check the generic function call argument list. If all
127 ;; arguments are required method parameter, and no method
128 ;; parameter is used more than once, we can optimize the call.
129 ;; Method parameters may not appear twice in the argument list
130 ;; because we can only have one wrapper for each method
131 ;; parameter the pv-table cache.
132 (unless (case nreq
133 (0 t)
134 ((1 2) (info-accessor-p gf-name))
135 (t nil))
136 (loop with optimizable-p = t
137 for arg in (rest form) and i below nreq
138 as param = (specialized-method-parameter arg)
139 as pos = (and param (posq param required-params))
140 when (or (null param) (member pos posns)) do
141 (setq optimizable-p nil)
142 (loop-finish)
143 collect pos into posns
144 finally
145 (return (and optimizable-p (cons gf-name posns))))))))
146
147 (defun compute-calls (table call-list all-method-wrappers)
148 ;;
149 ;; Small quirk here: set this flag so that GET-METHOD-FUNCTION
150 ;; won't try to use the PV cache while it's being computed.
151 (letf (((pv-table-computing-cache-p table) t))
152 (collect ((emfs))
153 (dolist (call call-list (coerce (emfs) 'simple-vector))
154 (emfs (compute-call call all-method-wrappers))))))
155
156 (defun compute-call (call all-method-wrappers)
157 (let ((gf-name (car call)))
158 ;;
159 ;; We have to check that GF-NAME is actually a generic function
160 ;; here. There can concievably be cases where GF-NAME appears to
161 ;; be a generic function when files are compiled, but isn't, or
162 ;; isn't yet, when compiled files are loaded.
163 (when (and (fboundp gf-name)
164 (generic-function-p (gdefinition gf-name)))
165 (loop with all-wrappers =
166 (if (atom all-method-wrappers)
167 (list all-method-wrappers)
168 all-method-wrappers)
169 with gf = (gdefinition gf-name)
170 for wrapper-index in (cdr call)
171 as wrapper = (nth wrapper-index all-wrappers)
172 as class = (wrapper-class* wrapper)
173 as type = `(class-eq ,class)
174 collect wrapper into wrappers
175 collect class into classes
176 collect type into types
177 finally
178 (return (cache-miss-values-internal gf (gf-arg-info gf)
179 wrappers classes types
180 'caching))))))
181
182 (defun update-pv-calls-for-gf (gf &optional gf-removed-p)
183 (when (eq *boot-state* 'complete)
184 (let ((call-key `(call ,(generic-function-name gf))))
185 (do-pv-tables (table call-key)
186 (let ((cache (pv-table-cache table)))
187 (when cache
188 (map-cache (lambda (wrappers pv-cell)
189 (let ((call-vector (cdr pv-cell)))
190 (do-pv-calls (call index table)
191 (setf (callsref call-vector index)
192 (if gf-removed-p
193 nil
194 (compute-call call wrappers))))))
195 cache))))
196 (when gf-removed-p
197 (remhash call-key *pv-key->pv-tables*)))))
198
199 ;;; end of gf-call-optimization.lisp

  ViewVC Help
Powered by ViewVC 1.1.5