0.6.11.16:
[sbcl.git] / src / pcl / fngen.lisp
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 \f
26 ;;; GET-FUNCTION 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-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.)
33 ;;;
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.
38 ;;;
39 ;;; There are three internal functions which operate on the lambda argument
40 ;;; to GET-FUNCTION:
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.
46 ;;;
47 (defun get-function (lambda
48                       &optional (test-converter     #'default-test-converter)
49                                 (code-converter     #'default-code-converter)
50                                 (constant-converter #'default-constant-converter))
51   (function-apply (get-function-generator lambda test-converter code-converter)
52                   (compute-constants      lambda constant-converter)))
53
54 (defun get-function1 (lambda
55                       &optional (test-converter     #'default-test-converter)
56                                 (code-converter     #'default-code-converter)
57                                 (constant-converter #'default-constant-converter))
58   (values (the function (get-function-generator lambda test-converter code-converter))
59           (compute-constants      lambda constant-converter)))
60
61 (defun default-constantp (form)
62   (and (constantp form)
63        (not (typep (eval form) '(or symbol fixnum)))))
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 (eval form))
78       nil))
79 \f
80 ;;; *FGENS* is a list of all the function generators we have so far. Each
81 ;;; element is a FGEN structure as implemented below. Don't ever touch this
82 ;;; list by hand, use STORE-FGEN.
83 (defvar *fgens* ())
84
85 (defun store-fgen (fgen)
86   (let ((old (lookup-fgen (fgen-test fgen))))
87     (if old
88         (setf (svref old 2) (fgen-generator fgen)
89               (svref old 4) (or (svref old 4)
90                                 (fgen-system fgen)))
91         (setq *fgens* (nconc *fgens* (list fgen))))))
92
93 (defun lookup-fgen (test)
94   (find test (the list *fgens*) :key #'fgen-test :test #'equal))
95
96 (defun make-fgen (test gensyms generator generator-lambda system)
97   (let ((new (make-array 6)))
98     (setf (svref new 0) test
99           (svref new 1) gensyms
100           (svref new 2) generator
101           (svref new 3) generator-lambda
102           (svref new 4) system)
103     new))
104
105 (defun fgen-test             (fgen) (svref fgen 0))
106 (defun fgen-gensyms          (fgen) (svref fgen 1))
107 (defun fgen-generator        (fgen) (svref fgen 2))
108 (defun fgen-generator-lambda (fgen) (svref fgen 3))
109 (defun fgen-system           (fgen) (svref fgen 4))
110 \f
111 (defun get-function-generator (lambda test-converter code-converter)
112   (let* ((test (compute-test lambda test-converter))
113          (fgen (lookup-fgen test)))
114     (if fgen
115         (fgen-generator fgen)
116         (get-new-function-generator lambda test code-converter))))
117
118 (defun get-new-function-generator (lambda test code-converter)
119   (multiple-value-bind (gensyms generator-lambda)
120       (get-new-function-generator-internal lambda code-converter)
121     (let* ((generator (compile nil generator-lambda))
122            (fgen (make-fgen test gensyms generator generator-lambda nil)))
123       (store-fgen fgen)
124       generator)))
125
126 (defun get-new-function-generator-internal (lambda code-converter)
127   (multiple-value-bind (code gensyms)
128       (compute-code lambda code-converter)
129     (values gensyms `(lambda ,gensyms (function ,code)))))
130
131 (defun compute-test (lambda test-converter)
132   (let ((*walk-form-expand-macros-p* t))
133     (walk-form lambda
134                nil
135                #'(lambda (f c e)
136                    (declare (ignore e))
137                    (if (neq c :eval)
138                        f
139                        (let ((converted (funcall test-converter f)))
140                          (values converted (neq converted f))))))))
141
142 (defun compute-code (lambda code-converter)
143   (let ((*walk-form-expand-macros-p* t)
144         (gensyms ()))
145     (values (walk-form lambda
146                        nil
147                        #'(lambda (f c e)
148                            (declare (ignore e))
149                            (if (neq c :eval)
150                                f
151                                (multiple-value-bind (converted gens)
152                                    (funcall code-converter f)
153                                  (when gens (setq gensyms (append gensyms gens)))
154                                  (values converted (neq converted f))))))
155               gensyms)))
156
157 (defun compute-constants (lambda constant-converter)
158   (let ((*walk-form-expand-macros-p* t)) ; doesn't matter here.
159     (macrolet ((appending ()
160                  `(let ((result ()))
161                    (values #'(lambda (value) (setq result (append result value)))
162                     #'(lambda ()result)))))
163       (gathering1 (appending)
164                   (walk-form lambda
165                              nil
166                              #'(lambda (f c e)
167                                  (declare (ignore e))
168                                  (if (neq c :eval)
169                                      f
170                                      (let ((consts (funcall constant-converter f)))
171                                        (if consts
172                                            (progn (gather1 consts) (values f t))
173                                            f)))))))))
174 \f
175 (defmacro precompile-function-generators (&optional system)
176   `(progn
177     ,@(gathering1 (collecting)
178                   (dolist (fgen *fgens*)
179                     (when (or (null (fgen-system fgen))
180                               (eq (fgen-system fgen) system))
181                       (when system (setf (svref fgen 4) system))
182                       (gather1
183                        `(load-function-generator
184                          ',(fgen-test fgen)
185                          ',(fgen-gensyms fgen)
186                          (function ,(fgen-generator-lambda fgen))
187                          ',(fgen-generator-lambda fgen)
188                          ',system)))))))
189
190 (defun load-function-generator (test gensyms generator generator-lambda system)
191   (store-fgen (make-fgen test gensyms generator generator-lambda system)))
192