1;;;; This software is part of the SBCL system. See the README file for
2;;;; more information.
3
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
8;;;; information.
9
10;;;; copyright information from original PCL sources:
11;;;;
12;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
13;;;; All rights reserved.
14;;;;
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
18;;;; control laws.
19;;;;
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
22;;;; specification.
23
24(in-package "SB-PCL")
25
26;;; GET-FUN is the main user interface to this code. It is like
27;;; COMPILE, 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-FUN in which the lambda forms differ only by
30;;; constants can use the same piece of compiled code. (For example,
31;;; dispatch dfuns and combined method functions can often be shared,
32;;; if they differ only by referring to different methods.)
33;;;
34;;; If GET-FUN 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.
38;;;
39;;; There are three internal functions which operate on the lambda argument
40;;; to GET-FUN:
41;;;   COMPUTE-TEST converts the lambda into a key to be used for lookup,
42;;;   COMPUTE-CODE is used by GET-NEW-FUN-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.
46;;;
47(defun get-fun (lambda &optional
48                 (test-converter #'default-test-converter)
49                 (code-converter #'default-code-converter)
50                 (constant-converter #'default-constant-converter))
51  (function-apply (get-fun-generator lambda test-converter code-converter)
52                  (compute-constants lambda constant-converter)))
53
54(defun get-fun1 (lambda &optional
55                  (test-converter #'default-test-converter)
56                  (code-converter #'default-code-converter)
57                  (constant-converter #'default-constant-converter))
58  (values (the function
59            (get-fun-generator lambda test-converter code-converter))
60          (compute-constants lambda constant-converter)))
61
62(defun default-constantp (form)
63  (constant-typep form '(not (or symbol fixnum cons))))
64
65(defun default-test-converter (form)
66  (if (default-constantp form)
67      '.constant.
68      form))
69
70(defun default-code-converter  (form)
71  (if (default-constantp form)
72      (let ((gensym (gensym))) (values gensym (list gensym)))
73      form))
74
75(defun default-constant-converter (form)
76  (if (default-constantp form)
77      (list (constant-form-value form))
78      nil))
79
80(defstruct (fgen (:constructor make-fgen (gensyms generator generator-lambda system)))
81  gensyms
82  generator
83  generator-lambda
84  system)
85
86;;; *FGENS* stores all the function generators we have so far. Each
87;;; element is a FGEN structure as implemented below. Don't ever touch this
88;;; list by hand, use LOOKUP-FGEN, and ENSURE-FGEN.
89(defvar *fgens* (make-hash-table :test #'equal :synchronized t))
90
91(defun ensure-fgen (test gensyms generator generator-lambda system)
92  (with-locked-system-table (*fgens*)
93    (let ((old (lookup-fgen test)))
94      (cond (old
95             (setf (fgen-generator old) generator)
96             (unless (fgen-system old)
97               (setf (fgen-system old) system)))
98            (t
99             (setf (gethash test *fgens*)
100                   (make-fgen gensyms generator generator-lambda system)))))))
101
102(defun lookup-fgen (test)
103  (gethash test *fgens*))
104
105(defun get-fun-generator (lambda test-converter code-converter)
106  (let* ((test (compute-test lambda test-converter))
107         (fgen (lookup-fgen test)))
108    (if fgen
109        (fgen-generator fgen)
110        (get-new-fun-generator lambda test code-converter))))
111
112(defun get-new-fun-generator (lambda test code-converter)
113  (multiple-value-bind (code gensyms) (compute-code lambda code-converter)
114    (let ((generator-lambda `(lambda ,gensyms
115                               (declare (muffle-conditions compiler-note))
116                               (function ,code))))
117      (let ((generator (compile nil generator-lambda)))
118        (ensure-fgen test gensyms generator generator-lambda nil)
119        generator))))
120
121(defun compute-test (lambda test-converter)
122  (let ((*walk-form-expand-macros-p* t))
123    (walk-form lambda
124               nil
125               (lambda (f c e)
126                 (declare (ignore e))
127                 (if (neq c :eval)
128                     f
129                     (let ((converted (funcall test-converter f)))
130                       (values converted (neq converted f))))))))
131
132(defun compute-code (lambda code-converter)
133  (let ((*walk-form-expand-macros-p* t)
134        (gensyms ()))
135    (values (walk-form lambda
136                       nil
137                       (lambda (f c e)
138                         (declare (ignore e))
139                         (if (neq c :eval)
140                             f
141                             (multiple-value-bind (converted gens)
142                                 (funcall code-converter f)
143                               (when gens
144                                 (setq gensyms (append gensyms gens)))
145                               (values converted (neq converted f))))))
146            gensyms)))
147
148(defun compute-constants (lambda constant-converter)
149  (let ((*walk-form-expand-macros-p* t) ; doesn't matter here.
150        collect)
151    (walk-form lambda
152               nil
153               (lambda (f c e)
154                 (declare (ignore e))
155                 (if (neq c :eval)
156                     f
157                     (let ((consts (funcall constant-converter f)))
158                       (if consts
159                           (progn
160                             (setq collect (append collect consts))
161                             (values f t))
162                           f)))))
163    collect))
164
165(defmacro precompile-function-generators (&optional system)
166  (let (collect)
167    (with-locked-system-table (*fgens*)
168      (maphash (lambda (test fgen)
169                 (when (or (null (fgen-system fgen))
170                           (eq (fgen-system fgen) system))
171                   (when system
172                     (setf (fgen-system fgen) system))
173                   (push `(ensure-fgen
174                           ',test
175                           ',(fgen-gensyms fgen)
176                           (function ,(fgen-generator-lambda fgen))
177                           ',(fgen-generator-lambda fgen)
178                           ',system)
179                         collect)))
180               *fgens*))
181    `(progn ,@collect)))
182