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