/[cmucl]/src/pcl/fngen.lisp
ViewVC logotype

Contents of /src/pcl/fngen.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.15 - (show annotations)
Mon Apr 19 02:31:14 2010 UTC (4 years ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, 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-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.14: +2 -2 lines
Remove _N"" reader macro from docstrings when possible.
1 ;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
2 ;;;
3 ;;; *************************************************************************
4 ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
5 ;;; All rights reserved.
6 ;;;
7 ;;; Use and copying of this software and preparation of derivative works
8 ;;; based upon this software are permitted. Any distribution of this
9 ;;; software or derivative works must comply with all applicable United
10 ;;; States export control laws.
11 ;;;
12 ;;; This software is made available AS IS, and Xerox Corporation makes no
13 ;;; warranty about the software, its performance or its conformity to any
14 ;;; specification.
15 ;;;
16 ;;; Any person obtaining a copy of this software is requested to send their
17 ;;; name and post office or electronic mail address to:
18 ;;; CommonLoops Coordinator
19 ;;; Xerox PARC
20 ;;; 3333 Coyote Hill Rd.
21 ;;; Palo Alto, CA 94304
22 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
23 ;;;
24 ;;; Suggestions, comments and requests for improvements are also welcome.
25 ;;; *************************************************************************
26
27 (file-comment
28 "$Header: /tiger/var/lib/cvsroots/cmucl/src/pcl/fngen.lisp,v 1.15 2010/04/19 02:31:14 rtoy Rel $")
29
30 (in-package :pcl)
31 (intl:textdomain "cmucl")
32
33 ;;;
34 ;;; GET-FUNCTION is the main user interface to this code. It is like
35 ;;; COMPILE-LAMBDA, only more efficient. It achieves this efficiency by
36 ;;; reducing the number of times that the compiler needs to be called.
37 ;;; Calls to GET-FUNCTION in which the lambda forms differ only by constants
38 ;;; can use the same piece of compiled code. (For example, dispatch dfuns and
39 ;;; combined method functions can often be shared, if they differ only
40 ;;; by referring to different methods.)
41 ;;;
42 ;;; If GET-FUNCTION is called with a lambda expression only, it will return
43 ;;; a corresponding function. The optional constant-converter argument
44 ;;; can be a function which will be called to convert each constant appearing
45 ;;; in the lambda to whatever value should appear in the function.
46 ;;;
47 ;;; There are three internal functions which operate on the lambda argument
48 ;;; to GET-FUNCTION:
49 ;;; compute-test converts the lambda into a key to be used for lookup,
50 ;;; compute-code is used by get-new-function-generator-internal to
51 ;;; generate the actual lambda to be compiled, and
52 ;;; compute-constants is used to generate the argument list that is
53 ;;; to be passed to the compiled function.
54 ;;;
55 ;;; Whether the returned function is actually compiled depends on whether
56 ;;; the compiler is present (see COMPILE-LAMBDA) and whether this shape of
57 ;;; code was precompiled.
58 ;;;
59
60 (defun get-function1 (lambda &optional
61 (test-converter #'default-test-converter)
62 (code-converter #'default-code-converter)
63 (constant-converter #'default-constant-converter))
64 (values (the function (get-function-generator lambda test-converter
65 code-converter))
66 (compute-constants lambda constant-converter)))
67
68 (defun default-constantp (form)
69 (and (constantp form)
70 (not (typep (eval form) '(or symbol fixnum)))))
71
72 (defun default-test-converter (form)
73 (if (default-constantp form)
74 '.constant.
75 form))
76
77 (defun default-code-converter (form)
78 (if (default-constantp form)
79 (let ((gensym (gensym))) (values gensym (list gensym)))
80 form))
81
82 (defun default-constant-converter (form)
83 (if (default-constantp form)
84 (list (eval form))
85 nil))
86
87
88 (defstruct (fgen (:constructor %make-fgen))
89 test
90 gensyms
91 generator
92 generator-lambda
93 system)
94
95 ;;;
96 ;;; *fgens* is a list of all the function generators we have so far. Each
97 ;;; element is a FGEN structure as implemented below. Don't ever touch this
98 ;;; list by hand, use STORE-FGEN.
99 ;;;
100 (defvar *fgens* ())
101
102 (defun lookup-fgen (test)
103 (find test (the list *fgens*) :key #'fgen-test :test #'equal))
104
105 (defun store-fgen (fgen)
106 (let ((old (lookup-fgen (fgen-test fgen))))
107 (if old
108 (setf (fgen-generator old) (fgen-generator fgen)
109 (fgen-system old) (or (fgen-system old)
110 (fgen-system fgen)))
111 (setq *fgens* (nconc *fgens* (list fgen))))))
112
113 (defun make-fgen (test gensyms generator generator-lambda system)
114 (%make-fgen :test test :gensyms gensyms :generator generator
115 :generator-lambda generator-lambda :system system))
116
117
118
119 (defun get-function-generator (lambda test-converter code-converter)
120 (let* ((test (compute-test lambda test-converter))
121 (fgen (lookup-fgen test)))
122 (if fgen
123 (fgen-generator fgen)
124 (get-new-function-generator lambda test code-converter))))
125
126 (defun get-new-function-generator (lambda test code-converter)
127 (multiple-value-bind (gensyms generator-lambda)
128 (get-new-function-generator-internal lambda code-converter)
129 (let* ((generator (compile-lambda generator-lambda))
130 (fgen (make-fgen test gensyms generator generator-lambda nil)))
131 (store-fgen fgen)
132 generator)))
133
134 (defun get-new-function-generator-internal (lambda code-converter)
135 (multiple-value-bind (code gensyms)
136 (compute-code lambda code-converter)
137 (values gensyms `(lambda ,gensyms (function ,code)))))
138
139 (defun compute-test (lambda test-converter)
140 (let ((walk-form-expand-macros-p t))
141 (walk-form lambda
142 nil
143 (lambda (f c e)
144 (declare (ignore e))
145 (if (neq c :eval)
146 f
147 (let ((converted (funcall test-converter f)))
148 (values converted (neq converted f))))))))
149
150 (defun compute-code (lambda code-converter)
151 (let ((walk-form-expand-macros-p t)
152 (gensyms ()))
153 (values (walk-form lambda
154 nil
155 (lambda (f c e)
156 (declare (ignore e))
157 (if (neq c :eval)
158 f
159 (multiple-value-bind (converted gens)
160 (funcall code-converter f)
161 (when gens
162 (setq gensyms (append gensyms gens)))
163 (values converted (neq converted f))))))
164 gensyms)))
165
166 (defun compute-constants (lambda constant-converter)
167 (let ((walk-form-expand-macros-p t) ; doesn't matter here.
168 (collected ()))
169 (walk-form lambda
170 nil
171 (lambda (f c e)
172 (declare (ignore e))
173 (if (eq c :eval)
174 (let ((consts (funcall constant-converter f)))
175 (if consts
176 (progn
177 (setq collected (append collected consts))
178 (values f t))
179 f))
180 f)))
181 collected))
182
183
184 ;;;
185 ;;;
186 ;;;
187 (defmacro precompile-function-generators (&optional system)
188 (let ((index -1))
189 `(progn ,@(let ((collected ()))
190 (dolist (fgen *fgens* (nreverse collected))
191 (when (or (null (fgen-system fgen))
192 (eq (fgen-system fgen) system))
193 (when system
194 (setf (fgen-system fgen) system))
195 (push
196 (make-top-level-form
197 `(precompile-function-generators ,system ,(incf index))
198 '(:load-toplevel)
199 `(load-function-generator
200 ',(fgen-test fgen)
201 ',(fgen-gensyms fgen)
202 (function ,(fgen-generator-lambda fgen))
203 ',(fgen-generator-lambda fgen)
204 ',system))
205 collected)))))))
206
207 (defun load-function-generator (test gensyms generator generator-lambda system)
208 (store-fgen (make-fgen test gensyms generator generator-lambda system)))
209
210 (defun flush-emf-cache (&optional gf)
211 "Flush cached emf functions. If GF is supplied, it should be a
212 generic function metaobject or the name of a generic function, and
213 this function flushes all cached emfs for the given generic
214 function. If GF is not supplied, all cached emfs are flushed."
215 (let ((gf-name (if (generic-function-p gf)
216 (generic-function-name gf)
217 gf)))
218 (collect ((new))
219 (dolist (f *fgens* (setq *fgens* (new)))
220 (when (notany (lambda (x)
221 (and (consp x)
222 (eq (car x) 'fast-method)
223 (or (null gf-name)
224 (equal gf-name (cadr x)))))
225 (fgen-test f))
226 (new f))))))
227

  ViewVC Help
Powered by ViewVC 1.1.5