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            #-sb-xc-host
  40            (values (constant-function-call-p form environment envp))))
  41       (t t))))
  42
  43 (defun %constant-form-value (form environment envp)
  44   (let ((form (if envp
  45                   (%macroexpand form environment)
  46                   form)))
  47     (typecase form
  48       (symbol
  49        ;; KLUDGE: superficially, this might look good enough: we grab
  50        ;; the value from FORM's property list, and if it isn't there (or
  51        ;; is NIL, but hey) we use the host's value.  This works for
  52        ;; MOST-POSITIVE-FIXNUM and friends, but still fails for
  53        ;; float-related constants, where there is in fact no guarantee
  54        ;; that we can represent our target value at all in the host,
  55        ;; so we don't try.  We should rework all uses of floating
  56        ;; point so that we never try to use a host's value, and then
  57        ;; make some kind of assertion that we never attempt to take
  58        ;; a host value of a constant in the CL package.
  59        (or #+sb-xc-host (xc-constant-value form) (symbol-value form)))
  60       (list
  61        (if (special-operator-p (car form))
  62            (constant-special-form-value form environment envp)
  63            #-sb-xc-host
  64            (constant-function-call-value form environment envp)))
  65       (t
  66        form))))
  67
  68 (defun constant-special-form-p (form environment envp)
  69   (let ((fun (gethash (car form) **special-form-constantp-tests**)))
  70     (when fun
  71       (funcall (car fun) form environment envp))))
  72
  73 (defun constant-special-form-value (form environment envp)
  74   (let ((fun (gethash (car form) **special-form-constantp-tests**)))
  75     (if fun
  76         (funcall (cdr fun) form environment envp)
  77         (error "Not a constant-foldable special form: ~S" form))))
  78
  79 (defun constant-special-variable-p (name)
  80   (and (member name *special-constant-variables*) t))
  81
  82 ;;; FIXME: It would be nice to deal with inline functions
  83 ;;; too.
  84 (defun constant-function-call-p (form environment envp)
  85   (let ((name (car form)))
  86     (if (and (legal-fun-name-p name)
  87              (eq :function (info :function :kind name))
  88              (let ((info (info :function :info name)))
  89                (and info (ir1-attributep (fun-info-attributes info)
  90                                          foldable)))
  91              (and (every (lambda (arg)
  92                            (%constantp arg environment envp))
  93                          (cdr form))))
  94         ;; Even though the function may be marked as foldable
  95         ;; the call may still signal an error -- eg: (CAR 1).
  96         (handler-case
  97             (values t (constant-function-call-value form environment envp))
  98           (error ()
  99             (values nil nil)))
 100         (values nil nil))))
 101
 102 (defun constant-function-call-value (form environment envp)
 103   (apply (fdefinition (car form))
 104          (mapcar (lambda (arg)
 105                    (%constant-form-value arg environment envp))
 106                  (cdr form))))
 107
 108 #!-sb-fluid (declaim (inline sb!xc:constantp))
 109 (defun sb!xc:constantp (form &optional (environment nil envp))
 110   #!+sb-doc
 111   "True of any FORM that has a constant value: self-evaluating objects,
 112 keywords, defined constants, quote forms. Additionally the
 113 constant-foldability of some function calls special forms is recognized. If
 114 ENVIRONMENT is provided the FORM is first macroexpanded in it."
 115   (%constantp form environment envp))
 116
 117 #!-sb-fluid (declaim (inline constant-form-value))
 118 (defun constant-form-value (form &optional (environment nil envp))
 119   #!+sb-doc
 120   "Returns the value of the constant FORM in ENVIRONMENT. Behaviour
 121 is undefined unless CONSTANTP has been first used to determine the
 122 constantness of the FORM in ENVIRONMENT."
 123   (%constant-form-value form environment envp))
 124
 125 (declaim (inline constant-typep))
 126 (defun constant-typep (form type &optional (environment nil envp))
 127   (and (%constantp form environment envp)
 128        ;; FIXME: We probably should be passing the environment to
 129        ;; TYPEP too, but (1) our XC version of typep AVERs that the
 130        ;; environment is null (2) our real version ignores it anyhow.
 131        (sb!xc:typep (%constant-form-value form environment envp) type)))
 132
 133 ;;;; NOTE!!!
 134 ;;;;
 135 ;;;; If you add new special forms, check that they do not
 136 ;;;; alter the logic of existing ones: eg, currently
 137 ;;;; CONSTANT-FORM-VALUE directly evaluates the last expression
 138 ;;;; of a PROGN, as no assignment is allowed. If you extend
 139 ;;;; analysis to assignments then other forms must take this
 140 ;;;; into account.
 141
 142 (defmacro !defconstantp (operator lambda-list &key test eval)
 143   (let ((test-fn (symbolicate "CONSTANTP-TEST$" operator))
 144         (eval-fn (symbolicate "CONSTANTP-EVAL$" operator))
 145         (form (make-symbol "FORM"))
 146         (environment (make-symbol "ENV"))
 147         (envp (make-symbol "ENVP")))
 148     (flet ((frob (body)
 149              `(flet ((constantp* (x)
 150                        (%constantp x ,environment ,envp))
 151                      (constant-form-value* (x)
 152                        (%constant-form-value x ,environment ,envp)))
 153                 (declare (ignorable #'constantp* #'constant-form-value*))
 154                 (destructuring-bind ,lambda-list (cdr ,form)
 155                   ;; KLUDGE: is all we need, so we keep it simple
 156                   ;; instead of general (not handling cases like &key (x y))
 157                   (declare (ignorable
 158                             ,@(remove-if (lambda (arg)
 159                                            (member arg sb!xc:lambda-list-keywords))
 160                                          lambda-list)))
 161                    ,body))))
 162       `(progn
 163          (defun ,test-fn (,form ,environment ,envp) ,(frob test))
 164          (defun ,eval-fn (,form ,environment ,envp) ,(frob eval))
 165          (!cold-init-forms
 166           (setf (gethash ',operator **special-form-constantp-tests**)
 167                 (cons #',test-fn #',eval-fn)))))))
 168
 169 (!defconstantp quote (value)
 170    :test t
 171    :eval value)
 172
 173 (!defconstantp if (test then &optional else)
 174    :test
 175    (and (constantp* test)
 176         (constantp* (if (constant-form-value* test)
 177                         then
 178                         else)))
 179    :eval (if (constant-form-value* test)
 180              (constant-form-value* then)
 181              (constant-form-value* else)))
 182
 183 (!defconstantp progn (&body forms)
 184    :test (every #'constantp* forms)
 185    :eval (constant-form-value* (car (last forms))))
 186
 187 (!defconstantp unwind-protect (protected-form &body cleanup-forms)
 188    :test (every #'constantp* (cons protected-form cleanup-forms))
 189    :eval (constant-form-value* protected-form))
 190
 191 (!defconstantp the (type form)
 192    ;; We can't call TYPEP because the form might be (THE (FUNCTION (t) t) #<fn>)
 193    ;; which is valid for declaration but not for discrimination.
 194    ;; Instead use %%TYPEP in non-strict mode. FIXME:
 195    ;; (1) CAREFUL-SPECIFIER-TYPE should never fail. See lp#1395910.
 196    ;; (2) CONTAINS-UNKNOWN-TYPE-P should grovel into ARRAY-TYPE-ELEMENT-TYPE
 197    ;; so that (C-U-T-P (SPECIFIER-TYPE '(OR (VECTOR BAD) FUNCTION))) => T
 198    ;; and then we can parse, check for unknowns, and get rid of HANDLER-CASE.
 199    :test (and (constantp* form)
 200               (handler-case
 201                   ;; in case the type-spec is malformed!
 202                   (let ((parsed (careful-specifier-type type)))
 203                     ;; xc can't rely on a "non-strict" mode of TYPEP.
 204                     (and parsed
 205                          #+sb-xc-host
 206                          (typep (constant-form-value* form)
 207                                 (let ((*unparse-fun-type-simplify* t))
 208                                   (type-specifier parsed)))
 209                          #-sb-xc-host
 210                          (sb!kernel::%%typep (constant-form-value* form)
 211                                              parsed nil)))
 212                 (error () nil)))
 213    :eval (constant-form-value* form))
 214
 215 (!defconstantp block (name &body forms)
 216    ;; We currently fail to detect cases like
 217    ;;
 218    ;; (BLOCK FOO
 219    ;;   ...CONSTANT-FORMS...
 220    ;;   (RETURN-FROM FOO CONSTANT-VALUE)
 221    ;;   ...ANYTHING...)
 222    ;;
 223    ;; Right now RETURN-FROM kills the constantness unequivocally.
 224    :test (every #'constantp* forms)
 225    :eval (constant-form-value* (car (last forms))))
 226
 227 (!defconstantp multiple-value-prog1 (first-form &body forms)
 228    :test (every #'constantp* (cons first-form forms))
 229    :eval (constant-form-value* first-form))
 230
 231 (!defconstantp progv (symbols values &body forms)
 232    :test (and (constantp* symbols)
 233               (constantp* values)
 234               (let* ((symbol-values (constant-form-value* symbols))
 235                      (*special-constant-variables*
 236                       (append symbol-values *special-constant-variables*)))
 237                 (progv
 238                     symbol-values
 239                     (constant-form-value* values)
 240                   (every #'constantp* forms))))
 241    :eval (progv
 242              (constant-form-value* symbols)
 243              (constant-form-value* values)
 244            (constant-form-value* (car (last forms)))))
 245
 246 (!defun-from-collected-cold-init-forms !constantp-cold-init)
 247