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)))