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