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
  26 (sb-int:file-comment
  27   "$Header$")
  28 \f
  29 ;;; GET-FUNCTION is the main user interface to this code. It is like
  30 ;;; COMPILE-LAMBDA, only more efficient. It achieves this efficiency by
  31 ;;; reducing the number of times that the compiler needs to be called.
  32 ;;; Calls to GET-FUNCTION in which the lambda forms differ only by constants
  33 ;;; can use the same piece of compiled code. (For example, dispatch dfuns and
  34 ;;; combined method functions can often be shared, if they differ only
  35 ;;; by referring to different methods.)
  36 ;;;
  37 ;;; If GET-FUNCTION is called with a lambda expression only, it will return
  38 ;;; a corresponding function. The optional constant-converter argument
  39 ;;; can be a function which will be called to convert each constant appearing
  40 ;;; in the lambda to whatever value should appear in the function.
  41 ;;;
  42 ;;; There are three internal functions which operate on the lambda argument
  43 ;;; to GET-FUNCTION:
  44 ;;;   compute-test converts the lambda into a key to be used for lookup,
  45 ;;;   compute-code is used by get-new-function-generator-internal to
  46 ;;;             generate the actual lambda to be compiled, and
  47 ;;;   compute-constants is used to generate the argument list that is
  48 ;;;             to be passed to the compiled function.
  49 ;;;
  50 ;;; Whether the returned function is actually compiled depends on whether
  51 ;;; the compiler is present (see COMPILE-LAMBDA) and whether this shape of
  52 ;;; code was precompiled.
  53 (defun get-function (lambda
  54                       &optional (test-converter     #'default-test-converter)
  55                                 (code-converter     #'default-code-converter)
  56                                 (constant-converter #'default-constant-converter))
  57   (function-apply (get-function-generator lambda test-converter code-converter)
  58                   (compute-constants      lambda constant-converter)))
  59
  60 (defun get-function1 (lambda
  61                       &optional (test-converter     #'default-test-converter)
  62                                 (code-converter     #'default-code-converter)
  63                                 (constant-converter #'default-constant-converter))
  64   (values (the function (get-function-generator lambda test-converter code-converter))
  65           (compute-constants      lambda constant-converter)))
  66
  67 (defun default-constantp (form)
  68   (and (constantp form)
  69        (not (typep (eval form) '(or symbol fixnum)))))
  70
  71 (defun default-test-converter (form)
  72   (if (default-constantp form)
  73       '.constant.
  74       form))
  75
  76 (defun default-code-converter  (form)
  77   (if (default-constantp form)
  78       (let ((gensym (gensym))) (values gensym (list gensym)))
  79       form))
  80
  81 (defun default-constant-converter (form)
  82   (if (default-constantp form)
  83       (list (eval form))
  84       nil))
  85 \f
  86 ;;; *FGENS* is a list of 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 STORE-FGEN.
  89 (defvar *fgens* ())
  90
  91 (defun store-fgen (fgen)
  92   (let ((old (lookup-fgen (fgen-test fgen))))
  93     (if old
  94         (setf (svref old 2) (fgen-generator fgen)
  95               (svref old 4) (or (svref old 4)
  96                                 (fgen-system fgen)))
  97         (setq *fgens* (nconc *fgens* (list fgen))))))
  98
  99 (defun lookup-fgen (test)
 100   (find test (the list *fgens*) :key #'fgen-test :test #'equal))
 101
 102 (defun make-fgen (test gensyms generator generator-lambda system)
 103   (let ((new (make-array 6)))
 104     (setf (svref new 0) test
 105           (svref new 1) gensyms
 106           (svref new 2) generator
 107           (svref new 3) generator-lambda
 108           (svref new 4) system)
 109     new))
 110
 111 (defun fgen-test             (fgen) (svref fgen 0))
 112 (defun fgen-gensyms       (fgen) (svref fgen 1))
 113 (defun fgen-generator   (fgen) (svref fgen 2))
 114 (defun fgen-generator-lambda (fgen) (svref fgen 3))
 115 (defun fgen-system         (fgen) (svref fgen 4))
 116 \f
 117 (defun get-function-generator (lambda test-converter code-converter)
 118   (let* ((test (compute-test lambda test-converter))
 119          (fgen (lookup-fgen test)))
 120     (if fgen
 121         (fgen-generator fgen)
 122         (get-new-function-generator lambda test code-converter))))
 123
 124 (defun get-new-function-generator (lambda test code-converter)
 125   (multiple-value-bind (gensyms generator-lambda)
 126       (get-new-function-generator-internal lambda code-converter)
 127     (let* ((generator (compile-lambda generator-lambda))
 128            (fgen (make-fgen test gensyms generator generator-lambda nil)))
 129       (store-fgen fgen)
 130       generator)))
 131
 132 (defun get-new-function-generator-internal (lambda code-converter)
 133   (multiple-value-bind (code gensyms)
 134       (compute-code lambda code-converter)
 135     (values gensyms `(lambda ,gensyms (function ,code)))))
 136
 137 (defun compute-test (lambda test-converter)
 138   (let ((*walk-form-expand-macros-p* t))
 139     (walk-form lambda
 140                nil
 141                #'(lambda (f c e)
 142                    (declare (ignore e))
 143                    (if (neq c :eval)
 144                        f
 145                        (let ((converted (funcall test-converter f)))
 146                          (values converted (neq converted f))))))))
 147
 148 (defun compute-code (lambda code-converter)
 149   (let ((*walk-form-expand-macros-p* t)
 150         (gensyms ()))
 151     (values (walk-form lambda
 152                        nil
 153                        #'(lambda (f c e)
 154                            (declare (ignore e))
 155                            (if (neq c :eval)
 156                                f
 157                                (multiple-value-bind (converted gens)
 158                                    (funcall code-converter f)
 159                                  (when gens (setq gensyms (append gensyms gens)))
 160                                  (values converted (neq converted f))))))
 161               gensyms)))
 162
 163 (defun compute-constants (lambda constant-converter)
 164   (let ((*walk-form-expand-macros-p* t)) ; doesn't matter here.
 165     (macrolet ((appending ()
 166                  `(let ((result ()))
 167                    (values #'(lambda (value) (setq result (append result value)))
 168                     #'(lambda ()result)))))
 169       (gathering1 (appending)
 170                   (walk-form lambda
 171                              nil
 172                              #'(lambda (f c e)
 173                                  (declare (ignore e))
 174                                  (if (neq c :eval)
 175                                      f
 176                                      (let ((consts (funcall constant-converter f)))
 177                                        (if consts
 178                                            (progn (gather1 consts) (values f t))
 179                                            f)))))))))
 180 \f
 181 (defmacro precompile-function-generators (&optional system)
 182   (let ((index -1))
 183     `(progn ,@(gathering1 (collecting)
 184                 (dolist (fgen *fgens*)
 185                   (when (or (null (fgen-system fgen))
 186                             (eq (fgen-system fgen) system))
 187                     (when system (setf (svref fgen 4) system))
 188                     (gather1
 189                      (make-top-level-form
 190                       `(precompile-function-generators ,system ,(incf index))
 191                       '(:load-toplevel)
 192                       `(load-function-generator
 193                         ',(fgen-test fgen)
 194                         ',(fgen-gensyms fgen)
 195                         (function ,(fgen-generator-lambda fgen))
 196                         ',(fgen-generator-lambda fgen)
 197                         ',system)))))))))
 198
 199 (defun load-function-generator (test gensyms generator generator-lambda system)
 200   (store-fgen (make-fgen test gensyms generator generator-lambda system)))
 201