X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Ffngen.lisp;h=aec5b5997746db7998bba56ec671dfd1b8fe2af7;hb=ed7ba4dad8a79726fdfeba5aa12e276ea852c540;hp=9c74f490936e202ea83adf1cc22202bf28b3dda4;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git diff --git a/src/pcl/fngen.lisp b/src/pcl/fngen.lisp index 9c74f49..aec5b59 100644 --- a/src/pcl/fngen.lisp +++ b/src/pcl/fngen.lisp @@ -22,12 +22,9 @@ ;;;; specification. (in-package "SB-PCL") - -(sb-int:file-comment - "$Header$") ;;; GET-FUNCTION is the main user interface to this code. It is like -;;; COMPILE-LAMBDA, only more efficient. It achieves this efficiency by +;;; 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 @@ -42,14 +39,11 @@ ;;; 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-function-generator-internal to +;;; 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. ;;; -;;; Whether the returned function is actually compiled depends on whether -;;; the compiler is present (see COMPILE-LAMBDA) and whether this shape of -;;; code was precompiled. (defun get-function (lambda &optional (test-converter #'default-test-converter) (code-converter #'default-code-converter) @@ -109,27 +103,27 @@ new)) (defun fgen-test (fgen) (svref fgen 0)) -(defun fgen-gensyms (fgen) (svref fgen 1)) -(defun fgen-generator (fgen) (svref fgen 2)) +(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)) +(defun fgen-system (fgen) (svref fgen 4)) (defun get-function-generator (lambda test-converter code-converter) (let* ((test (compute-test lambda test-converter)) (fgen (lookup-fgen test))) (if fgen (fgen-generator fgen) - (get-new-function-generator lambda test code-converter)))) + (get-new-fun-generator lambda test code-converter)))) -(defun get-new-function-generator (lambda test code-converter) +(defun get-new-fun-generator (lambda test code-converter) (multiple-value-bind (gensyms generator-lambda) - (get-new-function-generator-internal lambda code-converter) - (let* ((generator (compile-lambda 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-function-generator-internal (lambda code-converter) +(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))))) @@ -138,63 +132,60 @@ (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)))))))) + (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 ())) (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))) + (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 (nconc collect consts)) + (values f t)) + f))))) + collect)) (defmacro precompile-function-generators (&optional system) - (let ((index -1)) - `(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 - (make-top-level-form - `(precompile-function-generators ,system ,(incf index)) - '(:load-toplevel) - `(load-function-generator - ',(fgen-test fgen) - ',(fgen-gensyms fgen) - (function ,(fgen-generator-lambda fgen)) - ',(fgen-generator-lambda fgen) - ',system))))))))) + `(progn + ,@(let (collect) + (dolist (fgen *fgens*) + (when (or (null (fgen-system fgen)) + (eq (fgen-system fgen) system)) + (when system (setf (svref fgen 4) system)) + (push `(load-function-generator + ',(fgen-test fgen) + ',(fgen-gensyms fgen) + (function ,(fgen-generator-lambda fgen)) + ',(fgen-generator-lambda fgen) + ',system) + collect))) + (nreverse collect)))) (defun load-function-generator (test gensyms generator generator-lambda system) (store-fgen (make-fgen test gensyms generator generator-lambda system)))