X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Ffngen.lisp;h=4df2a35e42b3fae0045e404f1712584c0e997ffa;hb=076d38141d1d2689a1040dc8af71bd7fbf2b54a4;hp=bdcb74687374a1e667d8765813918bd63ba5dd7f;hpb=0cfad881b88e03971a2b3ef0c0c0fc2e5f4f1bc8;p=sbcl.git diff --git a/src/pcl/fngen.lisp b/src/pcl/fngen.lisp index bdcb746..4df2a35 100644 --- a/src/pcl/fngen.lisp +++ b/src/pcl/fngen.lisp @@ -23,44 +23,44 @@ (in-package "SB-PCL") -;;; GET-FUNCTION is the main user interface to this code. It is like +;;; GET-FUN is the main user interface to this code. It is like ;;; COMPILE, only more efficient. It achieves this efficiency by ;;; reducing the number of times that the compiler needs to be called. -;;; Calls to GET-FUNCTION in which the lambda forms differ only by constants -;;; can use the same piece of compiled code. (For example, dispatch dfuns and -;;; combined method functions can often be shared, if they differ only -;;; by referring to different methods.) +;;; Calls to GET-FUN in which the lambda forms differ only by +;;; constants can use the same piece of compiled code. (For example, +;;; dispatch dfuns and combined method functions can often be shared, +;;; if they differ only by referring to different methods.) ;;; -;;; If GET-FUNCTION is called with a lambda expression only, it will return +;;; If GET-FUN is called with a lambda expression only, it will return ;;; a corresponding function. The optional constant-converter argument ;;; can be a function which will be called to convert each constant appearing ;;; in the lambda to whatever value should appear in the function. ;;; ;;; There are three internal functions which operate on the lambda argument -;;; to GET-FUNCTION: -;;; compute-test converts the lambda into a key to be used for lookup, -;;; compute-code is used by get-new-fun-generator-internal to -;;; generate the actual lambda to be compiled, and -;;; compute-constants is used to generate the argument list that is -;;; to be passed to the compiled function. +;;; to GET-FUN: +;;; COMPUTE-TEST converts the lambda into a key to be used for lookup, +;;; COMPUTE-CODE is used by GET-NEW-FUN-GENERATOR-INTERNAL to +;;; generate the actual lambda to be compiled, and +;;; COMPUTE-CONSTANTS is used to generate the argument list that is +;;; to be passed to the compiled function. ;;; -(defun get-function (lambda - &optional (test-converter #'default-test-converter) - (code-converter #'default-code-converter) - (constant-converter #'default-constant-converter)) - (function-apply (get-function-generator lambda test-converter code-converter) - (compute-constants lambda constant-converter))) - -(defun get-function1 (lambda - &optional (test-converter #'default-test-converter) - (code-converter #'default-code-converter) - (constant-converter #'default-constant-converter)) - (values (the function (get-function-generator lambda test-converter code-converter)) - (compute-constants lambda constant-converter))) +(defun get-fun (lambda &optional + (test-converter #'default-test-converter) + (code-converter #'default-code-converter) + (constant-converter #'default-constant-converter)) + (function-apply (get-fun-generator lambda test-converter code-converter) + (compute-constants lambda constant-converter))) + +(defun get-fun1 (lambda &optional + (test-converter #'default-test-converter) + (code-converter #'default-code-converter) + (constant-converter #'default-constant-converter)) + (values (the function + (get-fun-generator lambda test-converter code-converter)) + (compute-constants lambda constant-converter))) (defun default-constantp (form) - (and (constantp form) - (not (typep (eval form) '(or symbol fixnum))))) + (constant-typep form '(not (or symbol fixnum cons)))) (defun default-test-converter (form) (if (default-constantp form) @@ -74,119 +74,108 @@ (defun default-constant-converter (form) (if (default-constantp form) - (list (eval form)) + (list (constant-form-value form)) nil)) -;;; *FGENS* is a list of all the function generators we have so far. Each -;;; element is a FGEN structure as implemented below. Don't ever touch this -;;; list by hand, use STORE-FGEN. -(defvar *fgens* ()) +(defstruct (fgen (:constructor make-fgen (gensyms generator generator-lambda system))) + gensyms + generator + generator-lambda + system) -(defun store-fgen (fgen) - (let ((old (lookup-fgen (fgen-test fgen)))) - (if old - (setf (svref old 2) (fgen-generator fgen) - (svref old 4) (or (svref old 4) - (fgen-system fgen))) - (setq *fgens* (nconc *fgens* (list fgen)))))) +;;; *FGENS* stores all the function generators we have so far. Each +;;; element is a FGEN structure as implemented below. Don't ever touch this +;;; list by hand, use LOOKUP-FGEN, and ENSURE-FGEN. +(defvar *fgens* (make-hash-table :test #'equal :synchronized t)) + +(defun ensure-fgen (test gensyms generator generator-lambda system) + (with-locked-system-table (*fgens*) + (let ((old (lookup-fgen test))) + (cond (old + (setf (fgen-generator old) generator) + (unless (fgen-system old) + (setf (fgen-system old) system))) + (t + (setf (gethash test *fgens*) + (make-fgen gensyms generator generator-lambda system))))))) (defun lookup-fgen (test) - (find test (the list *fgens*) :key #'fgen-test :test #'equal)) - -(defun make-fgen (test gensyms generator generator-lambda system) - (let ((new (make-array 6))) - (setf (svref new 0) test - (svref new 1) gensyms - (svref new 2) generator - (svref new 3) generator-lambda - (svref new 4) system) - new)) - -(defun fgen-test (fgen) (svref fgen 0)) -(defun fgen-gensyms (fgen) (svref fgen 1)) -(defun fgen-generator (fgen) (svref fgen 2)) -(defun fgen-generator-lambda (fgen) (svref fgen 3)) -(defun fgen-system (fgen) (svref fgen 4)) + (gethash test *fgens*)) -(defun get-function-generator (lambda test-converter code-converter) +(defun get-fun-generator (lambda test-converter code-converter) (let* ((test (compute-test lambda test-converter)) - (fgen (lookup-fgen test))) + (fgen (lookup-fgen test))) (if fgen - (fgen-generator fgen) - (get-new-fun-generator lambda test code-converter)))) + (fgen-generator fgen) + (get-new-fun-generator lambda test code-converter)))) (defun get-new-fun-generator (lambda test code-converter) - (multiple-value-bind (gensyms generator-lambda) - (get-new-fun-generator-internal lambda code-converter) - (let* ((generator (compile nil generator-lambda)) - (fgen (make-fgen test gensyms generator generator-lambda nil))) - (store-fgen fgen) - generator))) - -(defun get-new-fun-generator-internal (lambda code-converter) - (multiple-value-bind (code gensyms) - (compute-code lambda code-converter) - (values gensyms `(lambda ,gensyms (function ,code))))) + (multiple-value-bind (code gensyms) (compute-code lambda code-converter) + (let ((generator-lambda `(lambda ,gensyms + (declare (muffle-conditions compiler-note)) + (function ,code)))) + (let ((generator (compile nil generator-lambda))) + (ensure-fgen test gensyms generator generator-lambda nil) + generator)))) (defun compute-test (lambda test-converter) (let ((*walk-form-expand-macros-p* t)) (walk-form lambda - nil - #'(lambda (f c e) - (declare (ignore e)) - (if (neq c :eval) - f - (let ((converted (funcall test-converter f))) - (values converted (neq converted f)))))))) + nil + (lambda (f c e) + (declare (ignore e)) + (if (neq c :eval) + f + (let ((converted (funcall test-converter f))) + (values converted (neq converted f)))))))) (defun compute-code (lambda code-converter) (let ((*walk-form-expand-macros-p* t) - (gensyms ())) + (gensyms ())) (values (walk-form lambda - nil - #'(lambda (f c e) - (declare (ignore e)) - (if (neq c :eval) - f - (multiple-value-bind (converted gens) - (funcall code-converter f) - (when gens (setq gensyms (append gensyms gens))) - (values converted (neq converted f)))))) - gensyms))) + nil + (lambda (f c e) + (declare (ignore e)) + (if (neq c :eval) + f + (multiple-value-bind (converted gens) + (funcall code-converter f) + (when gens + (setq gensyms (append gensyms gens))) + (values converted (neq converted f)))))) + gensyms))) (defun compute-constants (lambda constant-converter) - (let ((*walk-form-expand-macros-p* t)) ; doesn't matter here. - (macrolet ((appending () - `(let ((result ())) - (values #'(lambda (value) (setq result (append result value))) - #'(lambda ()result))))) - (gathering1 (appending) - (walk-form lambda - nil - #'(lambda (f c e) - (declare (ignore e)) - (if (neq c :eval) - f - (let ((consts (funcall constant-converter f))) - (if consts - (progn (gather1 consts) (values f t)) - f))))))))) + (let ((*walk-form-expand-macros-p* t) ; doesn't matter here. + collect) + (walk-form lambda + nil + (lambda (f c e) + (declare (ignore e)) + (if (neq c :eval) + f + (let ((consts (funcall constant-converter f))) + (if consts + (progn + (setq collect (append collect consts)) + (values f t)) + f))))) + collect)) (defmacro precompile-function-generators (&optional system) - `(progn - ,@(gathering1 (collecting) - (dolist (fgen *fgens*) - (when (or (null (fgen-system fgen)) - (eq (fgen-system fgen) system)) - (when system (setf (svref fgen 4) system)) - (gather1 - `(load-function-generator - ',(fgen-test fgen) - ',(fgen-gensyms fgen) - (function ,(fgen-generator-lambda fgen)) - ',(fgen-generator-lambda fgen) - ',system))))))) - -(defun load-function-generator (test gensyms generator generator-lambda system) - (store-fgen (make-fgen test gensyms generator generator-lambda system))) - + (let (collect) + (with-locked-system-table (*fgens*) + (maphash (lambda (test fgen) + (when (or (null (fgen-system fgen)) + (eq (fgen-system fgen) system)) + (when system + (setf (fgen-system fgen) system)) + (push `(ensure-fgen + ',test + ',(fgen-gensyms fgen) + (function ,(fgen-generator-lambda fgen)) + ',(fgen-generator-lambda fgen) + ',system) + collect))) + *fgens*)) + `(progn ,@collect)))