src/compiler/constantp.lisp

   1 ;;;; implementation of CONSTANTP, needs both INFO and IR1-ATTRIBUTES
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!C")
  13
  14 (!begin-collecting-cold-init-forms)
  15
  16 (defglobal **special-form-constantp-tests** nil)
  17 #-sb-xc-host
  18 (declaim (type hash-table **special-form-constantp-tests**))
  19 ;; FIXME: inlined FIND in a simple-vector of 8 things seems to perform
  20 ;; roughly twice as fast as GETHASH when optimized for speed.
  21 ;; Even for as many as 16 things it would be faster.
  22 (!cold-init-forms
  23   (setf **special-form-constantp-tests** (make-hash-table)))
  24
  25 (!defvar *special-constant-variables* nil)
  26
  27 (defun %constantp (form environment envp)
  28   (let ((form (if envp
  29                   (%macroexpand form environment)
  30                   form)))
  31     (typecase form
  32       ;; This INFO test catches KEYWORDs as well as explicitly
  33       ;; DEFCONSTANT symbols.
  34       (symbol
  35        (or (eq (info :variable :kind form) :constant)
  36            (constant-special-variable-p form)))
  37       (list
  38        (or (constant-special-form-p form environment envp)
  39            (values (constant-function-call-p form environment envp))))
  40       (t t))))
  41
  42 (defun %constant-form-value (form environment envp)
  43   (let ((form (if envp
  44                   (%macroexpand form environment)
  45                   form)))
  46     (typecase form
  47       (symbol
  48        ;; KLUDGE: superficially, this might look good enough: we grab
  49        ;; the value from FORM's property list, and if it isn't there (or
  50        ;; is NIL, but hey) we use the host's value.  This works for
  51        ;; MOST-POSITIVE-FIXNUM and friends, but still fails for
  52        ;; float-related constants, where there is in fact no guarantee
  53        ;; that we can represent our target value at all in the host,
  54        ;; so we don't try.  We should rework all uses of floating
  55        ;; point so that we never try to use a host's value, and then
  56        ;; make some kind of assertion that we never attempt to take
  57        ;; a host value of a constant in the CL package.
  58        (or #+sb-xc-host (xc-constant-value form) (symbol-value form)))
  59       (list
  60        (if (sb!xc:special-operator-p (car form))
  61            (constant-special-form-value form environment envp)
  62            (constant-function-call-value form environment envp)))
  63       (t
  64        form))))
  65
  66 (defun constant-special-form-p (form environment envp)
  67   (let ((fun (gethash (car form) **special-form-constantp-tests**)))
  68     (when fun
  69       (funcall (car fun) form environment envp))))
  70
  71 (defun constant-special-form-value (form environment envp)
  72   (let ((fun (gethash (car form) **special-form-constantp-tests**)))
  73     (if fun
  74         (funcall (cdr fun) form environment envp)
  75         (error "Not a constant-foldable special form: ~S" form))))
  76
  77 (defun constant-special-variable-p (name)
  78   (and (member name *special-constant-variables*) t))
  79
  80 (defun constant-function-call-value (form environment envp)
  81   (apply (fdefinition (car form))
  82          (mapcar (lambda (arg)
  83                    (%constant-form-value arg environment envp))
  84                  (cdr form))))
  85
  86 #!-sb-fluid (declaim (inline sb!xc:constantp))
  87 (defun sb!xc:constantp (form &optional (environment nil envp))
  88   #!+sb-doc
  89   "True of any FORM that has a constant value: self-evaluating objects,
  90 keywords, defined constants, quote forms. Additionally the
  91 constant-foldability of some function calls special forms is recognized. If
  92 ENVIRONMENT is provided the FORM is first macroexpanded in it."
  93   (%constantp form environment envp))
  94
  95 #!-sb-fluid (declaim (inline constant-form-value))
  96 (defun constant-form-value (form &optional (environment nil envp))
  97   #!+sb-doc
  98   "Returns the value of the constant FORM in ENVIRONMENT. Behaviour
  99 is undefined unless CONSTANTP has been first used to determine the
 100 constantness of the FORM in ENVIRONMENT."
 101   (%constant-form-value form environment envp))
 102
 103 (declaim (inline constant-typep))
 104 (defun constant-typep (form type &optional (environment nil envp))
 105   (and (%constantp form environment envp)
 106        ;; FIXME: We probably should be passing the environment to
 107        ;; TYPEP too, but (1) our XC version of typep AVERs that the
 108        ;; environment is null (2) our real version ignores it anyhow.
 109        (sb!xc:typep (%constant-form-value form environment envp) type)))
 110
 111 ;;;; NOTE!!!
 112 ;;;;
 113 ;;;; If you add new special forms, check that they do not
 114 ;;;; alter the logic of existing ones: eg, currently
 115 ;;;; CONSTANT-FORM-VALUE directly evaluates the last expression
 116 ;;;; of a PROGN, as no assignment is allowed. If you extend
 117 ;;;; analysis to assignments then other forms must take this
 118 ;;;; into account.
 119
 120 (defmacro !defconstantp (operator lambda-list &key test eval)
 121   (let ((test-fn (symbolicate "CONSTANTP-TEST$" operator))
 122         (eval-fn (symbolicate "CONSTANTP-EVAL$" operator))
 123         (form (make-symbol "FORM"))
 124         (environment (make-symbol "ENV"))
 125         (envp (make-symbol "ENVP")))
 126     (flet ((frob (body)
 127              `(flet ((constantp* (x)
 128                        (%constantp x ,environment ,envp))
 129                      (constant-form-value* (x)
 130                        (%constant-form-value x ,environment ,envp)))
 131                 (declare (ignorable #'constantp* #'constant-form-value*))
 132                 (destructuring-bind ,lambda-list (cdr ,form)
 133                   ;; KLUDGE: is all we need, so we keep it simple
 134                   ;; instead of general (not handling cases like &key (x y))
 135                   (declare (ignorable
 136                             ,@(remove-if (lambda (arg)
 137                                            (member arg sb!xc:lambda-list-keywords))
 138                                          lambda-list)))
 139                    ,body))))
 140       `(progn
 141          (defun ,test-fn (,form ,environment ,envp) ,(frob test))
 142          (defun ,eval-fn (,form ,environment ,envp) ,(frob eval))
 143          (!cold-init-forms
 144           (setf (gethash ',operator **special-form-constantp-tests**)
 145                 (cons #',test-fn #',eval-fn)))))))
 146
 147 (!defconstantp quote (value)
 148    :test t
 149    :eval value)
 150
 151 (!defconstantp if (test then &optional else)
 152    :test
 153    (and (constantp* test)
 154         (constantp* (if (constant-form-value* test)
 155                         then
 156                         else)))
 157    :eval (if (constant-form-value* test)
 158              (constant-form-value* then)
 159              (constant-form-value* else)))
 160
 161 (!defconstantp progn (&body forms)
 162    :test (every #'constantp* forms)
 163    :eval (constant-form-value* (car (last forms))))
 164
 165 (!defconstantp unwind-protect (protected-form &body cleanup-forms)
 166    :test (every #'constantp* (cons protected-form cleanup-forms))
 167    :eval (constant-form-value* protected-form))
 168
 169 (!defconstantp block (name &body forms)
 170    ;; We currently fail to detect cases like
 171    ;;
 172    ;; (BLOCK FOO
 173    ;;   ...CONSTANT-FORMS...
 174    ;;   (RETURN-FROM FOO CONSTANT-VALUE)
 175    ;;   ...ANYTHING...)
 176    ;;
 177    ;; Right now RETURN-FROM kills the constantness unequivocally.
 178    :test (every #'constantp* forms)
 179    :eval (constant-form-value* (car (last forms))))
 180
 181 (!defconstantp multiple-value-prog1 (first-form &body forms)
 182    :test (every #'constantp* (cons first-form forms))
 183    :eval (constant-form-value* first-form))
 184
 185 (!defconstantp progv (symbols values &body forms)
 186    :test (and (constantp* symbols)
 187               (constantp* values)
 188               (let* ((symbol-values (constant-form-value* symbols))
 189                      (*special-constant-variables*
 190                       (append symbol-values *special-constant-variables*)))
 191                 (progv
 192                     symbol-values
 193                     (constant-form-value* values)
 194                   (every #'constantp* forms))))
 195    :eval (progv
 196              (constant-form-value* symbols)
 197              (constant-form-value* values)
 198            (constant-form-value* (car (last forms)))))
 199
 200 (!defun-from-collected-cold-init-forms !constantp-cold-init)