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 (defun pcl-compile (expr safety)
  27   (labels ((strictly-heap-p (x)
  28              (or (atom x)
  29                  (and (heap-allocated-p x) (strictly-heap-p (cdr x)))))
  30            (maybe-copy-expr ()
  31              ;; The lambda list goes into a code component as-is.
  32              ;; To avoid creating a heap->arena pointer we might have to copy it.
  33              #-system-tlabs expr
  34              #+system-tlabs
  35              (multiple-value-bind (name rest)
  36                  (ecase (car expr)
  37                    (named-lambda (values (cadr expr) (cddr expr)))
  38                    (lambda (values nil (cdr expr))))
  39                (destructuring-bind (args . body) rest
  40                    (if (strictly-heap-p args)
  41                        expr
  42                        (let ((args-copy (copy-list args)))
  43                          (if name
  44                              `(named-lambda ,name ,args-copy . ,body)
  45                              `(lambda ,args-copy . ,body))))))))
  46     (sb-vm:without-arena "pcl-compile"
  47      (let* ((base-policy sb-c::*policy*)
  48             (lexenv
  49              (sb-c::make-almost-null-lexenv
  50               (ecase safety
  51                 (:safe base-policy)
  52                 (:unsafe (sb-c::process-optimize-decl
  53                           '((space 1) (compilation-speed 1)
  54                             (speed 3) (safety 0) (sb-ext:inhibit-warnings 3) (debug 0))
  55                           base-policy)))
  56               ;; I suspect that INHIBIT-WARNINGS precludes them from happening
  57               (list (cons (sb-kernel:find-classoid 'style-warning) 'muffle-warning)
  58                     (cons (sb-kernel:find-classoid 'compiler-note) 'muffle-warning))
  59               nil nil nil
  60               '((:declare sb-c::tlab :system)))))
  61        (sb-c:compile-in-lexenv (maybe-copy-expr) lexenv nil nil nil nil nil)))))
  62 \f
  63 ;;; GET-FUN is the main user interface to this code. It is like
  64 ;;; COMPILE, only more efficient. It achieves this efficiency by
  65 ;;; reducing the number of times that the compiler needs to be called.
  66 ;;; Calls to GET-FUN in which the lambda forms differ only by
  67 ;;; constants can use the same piece of compiled code. (For example,
  68 ;;; dispatch dfuns and combined method functions can often be shared,
  69 ;;; if they differ only by referring to different methods.)
  70 ;;;
  71 ;;; If GET-FUN is called with a lambda expression only, it will return
  72 ;;; a corresponding function. The optional constant-converter argument
  73 ;;; can be a function which will be called to convert each constant appearing
  74 ;;; in the lambda to whatever value should appear in the function.
  75 ;;;
  76 ;;; There are three internal functions which operate on the lambda argument
  77 ;;; to GET-FUN:
  78 ;;;   COMPUTE-TEST converts the lambda into a key to be used for lookup,
  79 ;;;   COMPUTE-CODE is used by GET-NEW-FUN-GENERATOR-INTERNAL to
  80 ;;;             generate the actual lambda to be compiled, and
  81 ;;;   COMPUTE-CONSTANTS is used to generate the argument list that is
  82 ;;;             to be passed to the compiled function.
  83 ;;;
  84 (defun get-fun (lambda &optional
  85                  (test-converter #'default-test-converter)
  86                  (code-converter #'default-code-converter)
  87                  (constant-converter #'default-constant-converter))
  88   (values (the function
  89             (get-fun-generator lambda test-converter code-converter))
  90           (compute-constants lambda constant-converter)))
  91
  92 (defun default-constantp (form)
  93   (and (constantp form)
  94        (not (typep (constant-form-value form) '(or symbol fixnum cons layout)))))
  95
  96 (defun default-test-converter (form)
  97   (if (default-constantp form)
  98       '.constant.
  99       form))
 100
 101 (defun default-code-converter  (form)
 102   (if (default-constantp form)
 103       (let ((gensym (gensym))) (values gensym (list gensym)))
 104       form))
 105
 106 (defun default-constant-converter (form)
 107   (if (default-constantp form)
 108       (list (constant-form-value form))
 109       nil))
 110 \f
 111 (defstruct (fgen (:constructor make-fgen (gensyms generator generator-lambda system))
 112                  (:copier nil))
 113   gensyms
 114   generator
 115   generator-lambda
 116   system)
 117 (declaim (freeze-type fgen))
 118
 119 ;;; *FGENS* stores all the function generators we have so far. Each
 120 ;;; element is a FGEN structure as implemented below. Don't ever touch this
 121 ;;; table by hand, use GET-FUN-GENERATOR and ENSURE-FGEN.
 122 ;;; We use explicit locking for properly scoped R/M/W operation without
 123 ;;; recursion on the mutex. So the table is not specified as :SYNCHRONIZED.
 124 (define-load-time-global *fgens* (make-hash-table :test #'equal))
 125
 126 (defun ensure-fgen (test gensyms generator generator-lambda system)
 127   (let ((table *fgens*))
 128     (with-system-mutex ((hash-table-lock table))
 129       (let ((old (gethash test table)))
 130         (cond (old
 131                (setf (fgen-generator old) generator)
 132                (unless (fgen-system old)
 133                  (setf (fgen-system old) system)))
 134               (t
 135                (unless (eql (sb-vm:thread-current-arena) 0)
 136                  (setq gensyms (ensure-heap-list gensyms))
 137                  (sb-vm:without-arena
 138                      (setq test (copy-tree test)
 139                            generator-lambda  (copy-tree generator-lambda))))
 140                (setf (gethash test table)
 141                      (make-fgen gensyms generator generator-lambda system))))))))
 142
 143 \f
 144 (defun get-fun-generator (lambda test-converter code-converter)
 145   (let* ((test (compute-test lambda test-converter))
 146          (table *fgens*)
 147          (fgen (with-system-mutex ((hash-table-lock table))
 148                  (gethash test table))))
 149     (if fgen
 150         (fgen-generator fgen)
 151         (get-new-fun-generator lambda test code-converter))))
 152
 153 (defun get-new-fun-generator (lambda test code-converter)
 154   (multiple-value-bind (code gensyms) (compute-code lambda code-converter)
 155     (let ((generator-lambda `(lambda ,gensyms
 156                                (declare (optimize (sb-c:store-source-form 0)
 157                                                   (sb-c::store-xref-data 0)))
 158                                (function ,code))))
 159       (let ((generator (pcl-compile generator-lambda :safe)))
 160         (ensure-fgen test gensyms generator generator-lambda nil)
 161         generator))))
 162
 163 (defun compute-test (lambda test-converter)
 164   (let ((*walk-form-expand-macros-p* t))
 165     (walk-form lambda
 166                nil
 167                (lambda (f c e)
 168                  (declare (ignore e))
 169                  (if (neq c :eval)
 170                      f
 171                      (let ((converted (funcall test-converter f)))
 172                        (values converted (neq converted f))))))))
 173
 174 (defun compute-code (lambda code-converter)
 175   (let ((*walk-form-expand-macros-p* t)
 176         (gensyms ()))
 177     (values (walk-form lambda
 178                        nil
 179                        (lambda (f c e)
 180                          (declare (ignore e))
 181                          (if (neq c :eval)
 182                              f
 183                              (multiple-value-bind (converted gens)
 184                                  (funcall code-converter f)
 185                                (when gens
 186                                  (setq gensyms (append gensyms gens)))
 187                                (values converted (neq converted f))))))
 188             gensyms)))
 189
 190 (defun compute-constants (lambda constant-converter)
 191   (let ((*walk-form-expand-macros-p* t)) ; doesn't matter here.
 192    (collect ((res))
 193     (walk-form lambda
 194                nil
 195                (lambda (f c e)
 196                  (declare (ignore e))
 197                  (if (neq c :eval)
 198                      f
 199                      (let ((consts (funcall constant-converter f)))
 200                        (if consts
 201                            (dolist (x consts (values f t)) (res x))
 202                            f)))))
 203     (res))))
 204 \f
 205 (defmacro precompile-function-generators (&optional system)
 206   (let (collect)
 207     ;; In single threaded code, only at system build time, and not used after.
 208     (maphash (lambda (test fgen)
 209                  (when (or (null (fgen-system fgen))
 210                            (eq (fgen-system fgen) system))
 211                    (when system
 212                      (setf (fgen-system fgen) system))
 213                    (push `(ensure-fgen
 214                            ',test
 215                            ',(fgen-gensyms fgen)
 216                            (function ,(fgen-generator-lambda fgen))
 217                            ',(fgen-generator-lambda fgen)
 218                            ',system)
 219                          collect)))
 220                *fgens*)
 221     `(progn ,@collect)))