1.0.41.37: ppc: allocation fixes for threaded builds.
[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-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 \f
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-hash-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 \f
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 \f
165 (defmacro precompile-function-generators (&optional system)
166   (let (collect)
167     (with-locked-hash-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)))