1 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; This software is derived from software originally released by Xerox
5 ;;;; Corporation. Copyright and release statements follow. Later modifications
6 ;;;; to the software are in the public domain and are provided with
7 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
10 ;;;; copyright information from original PCL sources:
12 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
13 ;;;; All rights reserved.
15 ;;;; Use and copying of this software and preparation of derivative works based
16 ;;;; upon this software are permitted. Any distribution of this software or
17 ;;;; derivative works must comply with all applicable United States export
20 ;;;; This software is made available AS IS, and Xerox Corporation makes no
21 ;;;; warranty about the software, its performance or its conformity to any
26 ;;; GET-FUNCTION is the main user interface to this code. It is like
27 ;;; COMPILE-LAMBDA, only more efficient. It achieves this efficiency by
28 ;;; reducing the number of times that the compiler needs to be called.
29 ;;; Calls to GET-FUNCTION in which the lambda forms differ only by constants
30 ;;; can use the same piece of compiled code. (For example, dispatch dfuns and
31 ;;; combined method functions can often be shared, if they differ only
32 ;;; by referring to different methods.)
34 ;;; If GET-FUNCTION is called with a lambda expression only, it will return
35 ;;; a corresponding function. The optional constant-converter argument
36 ;;; can be a function which will be called to convert each constant appearing
37 ;;; in the lambda to whatever value should appear in the function.
39 ;;; There are three internal functions which operate on the lambda argument
41 ;;; compute-test converts the lambda into a key to be used for lookup,
42 ;;; compute-code is used by get-new-function-generator-internal to
43 ;;; generate the actual lambda to be compiled, and
44 ;;; compute-constants is used to generate the argument list that is
45 ;;; to be passed to the compiled function.
47 ;;; Whether the returned function is actually compiled depends on whether
48 ;;; the compiler is present (see COMPILE-LAMBDA) and whether this shape of
49 ;;; code was precompiled.
50 (defun get-function (lambda
51 &optional (test-converter #'default-test-converter)
52 (code-converter #'default-code-converter)
53 (constant-converter #'default-constant-converter))
54 (function-apply (get-function-generator lambda test-converter code-converter)
55 (compute-constants lambda constant-converter)))
57 (defun get-function1 (lambda
58 &optional (test-converter #'default-test-converter)
59 (code-converter #'default-code-converter)
60 (constant-converter #'default-constant-converter))
61 (values (the function (get-function-generator lambda test-converter code-converter))
62 (compute-constants lambda constant-converter)))
64 (defun default-constantp (form)
66 (not (typep (eval form) '(or symbol fixnum)))))
68 (defun default-test-converter (form)
69 (if (default-constantp form)
73 (defun default-code-converter (form)
74 (if (default-constantp form)
75 (let ((gensym (gensym))) (values gensym (list gensym)))
78 (defun default-constant-converter (form)
79 (if (default-constantp form)
83 ;;; *FGENS* is a list of all the function generators we have so far. Each
84 ;;; element is a FGEN structure as implemented below. Don't ever touch this
85 ;;; list by hand, use STORE-FGEN.
88 (defun store-fgen (fgen)
89 (let ((old (lookup-fgen (fgen-test fgen))))
91 (setf (svref old 2) (fgen-generator fgen)
92 (svref old 4) (or (svref old 4)
94 (setq *fgens* (nconc *fgens* (list fgen))))))
96 (defun lookup-fgen (test)
97 (find test (the list *fgens*) :key #'fgen-test :test #'equal))
99 (defun make-fgen (test gensyms generator generator-lambda system)
100 (let ((new (make-array 6)))
101 (setf (svref new 0) test
102 (svref new 1) gensyms
103 (svref new 2) generator
104 (svref new 3) generator-lambda
105 (svref new 4) system)
108 (defun fgen-test (fgen) (svref fgen 0))
109 (defun fgen-gensyms (fgen) (svref fgen 1))
110 (defun fgen-generator (fgen) (svref fgen 2))
111 (defun fgen-generator-lambda (fgen) (svref fgen 3))
112 (defun fgen-system (fgen) (svref fgen 4))
114 (defun get-function-generator (lambda test-converter code-converter)
115 (let* ((test (compute-test lambda test-converter))
116 (fgen (lookup-fgen test)))
118 (fgen-generator fgen)
119 (get-new-function-generator lambda test code-converter))))
121 (defun get-new-function-generator (lambda test code-converter)
122 (multiple-value-bind (gensyms generator-lambda)
123 (get-new-function-generator-internal lambda code-converter)
124 (let* ((generator (compile-lambda generator-lambda))
125 (fgen (make-fgen test gensyms generator generator-lambda nil)))
129 (defun get-new-function-generator-internal (lambda code-converter)
130 (multiple-value-bind (code gensyms)
131 (compute-code lambda code-converter)
132 (values gensyms `(lambda ,gensyms (function ,code)))))
134 (defun compute-test (lambda test-converter)
135 (let ((*walk-form-expand-macros-p* t))
142 (let ((converted (funcall test-converter f)))
143 (values converted (neq converted f))))))))
145 (defun compute-code (lambda code-converter)
146 (let ((*walk-form-expand-macros-p* t)
148 (values (walk-form lambda
154 (multiple-value-bind (converted gens)
155 (funcall code-converter f)
156 (when gens (setq gensyms (append gensyms gens)))
157 (values converted (neq converted f))))))
160 (defun compute-constants (lambda constant-converter)
161 (let ((*walk-form-expand-macros-p* t)) ; doesn't matter here.
162 (macrolet ((appending ()
164 (values #'(lambda (value) (setq result (append result value)))
165 #'(lambda ()result)))))
166 (gathering1 (appending)
173 (let ((consts (funcall constant-converter f)))
175 (progn (gather1 consts) (values f t))
178 (defmacro precompile-function-generators (&optional system)
180 `(progn ,@(gathering1 (collecting)
181 (dolist (fgen *fgens*)
182 (when (or (null (fgen-system fgen))
183 (eq (fgen-system fgen) system))
184 (when system (setf (svref fgen 4) system))
187 `(precompile-function-generators ,system ,(incf index))
189 `(load-function-generator
191 ',(fgen-gensyms fgen)
192 (function ,(fgen-generator-lambda fgen))
193 ',(fgen-generator-lambda fgen)
196 (defun load-function-generator (test gensyms generator generator-lambda system)
197 (store-fgen (make-fgen test gensyms generator generator-lambda system)))