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 (!defvar *special-constant-variables* nil)
  15
  16 (defun %constantp (form environment envp)
  17   (let ((form (if envp
  18                   (%macroexpand form environment)
  19                   form)))
  20     (typecase form
  21       ;; This INFO test catches KEYWORDs as well as explicitly
  22       ;; DEFCONSTANT symbols.
  23       (symbol
  24        (or (eq (info :variable :kind form) :constant)
  25            (constant-special-variable-p form)))
  26       (list
  27        (let ((answer (constant-special-form-p form environment envp)))
  28          (if (eq answer :maybe)
  29              (values (constant-function-call-p form environment envp))
  30              answer)))
  31       (t t))))
  32
  33 (defun %constant-form-value (form environment envp)
  34   (let ((form (if envp
  35                   (%macroexpand form environment)
  36                   form)))
  37     (typecase form
  38       (symbol
  39        ;; KLUDGE: superficially, this might look good enough: we grab
  40        ;; the value from FORM's property list, and if it isn't there (or
  41        ;; is NIL, but hey) we use the host's value.  This works for
  42        ;; MOST-POSITIVE-FIXNUM and friends, but still fails for
  43        ;; float-related constants, where there is in fact no guarantee
  44        ;; that we can represent our target value at all in the host,
  45        ;; so we don't try.  We should rework all uses of floating
  46        ;; point so that we never try to use a host's value, and then
  47        ;; make some kind of assertion that we never attempt to take
  48        ;; a host value of a constant in the CL package.
  49        (or #+sb-xc-host (xc-constant-value form) (symbol-value form)))
  50       (list
  51        (multiple-value-bind (specialp value)
  52            (constant-special-form-value form environment envp)
  53          (if specialp value (constant-function-call-value
  54                              form environment envp))))
  55       (t
  56        form))))
  57
  58 (defun constant-special-variable-p (name)
  59   (and (member name *special-constant-variables*) t))
  60
  61 ;;; FIXME: It would be nice to deal with inline functions
  62 ;;; too.
  63 (defun constant-function-call-p (form environment envp)
  64   (let ((name (car form)))
  65     (if (and (legal-fun-name-p name)
  66              (eq :function (info :function :kind name))
  67              (let ((info (info :function :info name)))
  68                (and info (ir1-attributep (fun-info-attributes info)
  69                                          foldable)))
  70              (and (every (lambda (arg)
  71                            (%constantp arg environment envp))
  72                          (cdr form))))
  73         ;; Even though the function may be marked as foldable
  74         ;; the call may still signal an error -- eg: (CAR 1).
  75         (handler-case
  76             (values t (constant-function-call-value form environment envp))
  77           (error ()
  78             (values nil nil)))
  79         (values nil nil))))
  80
  81 (defun constant-function-call-value (form environment envp)
  82   (apply (fdefinition (car form))
  83          (mapcar (lambda (arg)
  84                    (%constant-form-value arg environment envp))
  85                  (cdr form))))
  86
  87 ;;;; NOTE!!!
  88 ;;;;
  89 ;;;; If you add new special forms, check that they do not
  90 ;;;; alter the logic of existing ones: eg, currently
  91 ;;;; CONSTANT-FORM-VALUE directly evaluates the last expression
  92 ;;;; of a PROGN, as no assignment is allowed. If you extend
  93 ;;;; analysis to assignments then other forms must take this
  94 ;;;; into account.
  95
  96 (eval-when (:compile-toplevel :execute)
  97 (defparameter *special-form-constantp-defs* (make-array 20 :fill-pointer 0)))
  98
  99 (defmacro !defconstantp (operator lambda-list &key test eval)
 100   (let ((args (make-symbol "ARGS")))
 101     (flet
 102         ;; FIXME: DESTRUCTURING-BIND should have the option to expand this way.
 103         ;; It would be useful for DEFINE-SOURCE-TRANSFORM as well.
 104         ((binding-maker (input on-error)
 105            (multiple-value-bind (llks req opt rest key aux env whole)
 106                (parse-lambda-list
 107                 lambda-list
 108                 :accept (lambda-list-keyword-mask '(&whole &optional &rest &body)))
 109              (declare (ignore llks key aux env))
 110              (aver (every (lambda (x) (and (symbolp x) x)) (append req opt rest)))
 111              (flet ((bind (var pred enforce-end)
 112                       `(,(car var)
 113                         ,(if enforce-end
 114                              `(if (and (,pred ,args) (not (cdr ,args)))
 115                                   (car ,args)
 116                                   ,on-error)
 117                              `(if (,pred ,args) (pop ,args) ,on-error)))))
 118                `((,args ,input)
 119                  ,@(when whole
 120                      ;; If both &WHOLE and &REST are present, the &WHOLE var
 121                      ;; must be a list, although we don't know that just yet.
 122                      ;; It will be verified when the &REST arg is bound.
 123                      `((,(car whole) ,(if rest `(truly-the list ,args) args))))
 124                  ,@(maplist (lambda (x)
 125                               (bind x (if (cdr x) 'listp 'consp)
 126                                     (and (not (cdr x)) (not opt) (not rest))))
 127                             req)
 128                  ,@(maplist (lambda (x) (bind x 'listp (and (not (cdr x)) (not rest))))
 129                             opt)
 130                  ,@(when rest
 131                      `((,(car rest)
 132                         (if (proper-list-p ,args)
 133                             (truly-the list ,args) ; to open-code EVERY #'P on &REST arg
 134                             ,on-error)))))))))
 135       `(eval-when (:compile-toplevel :execute)
 136          (vector-push-extend ',(list* operator test eval
 137                                       (binding-maker 'args '(go fail)))
 138                              *special-form-constantp-defs*)))))
 139
 140 ;;; NOTE: special forms are tested in the order as written,
 141 ;;; so there is some benefit to listing important ones earliest.
 142
 143 (!defconstantp quote (value)
 144    :test t
 145    :eval value)
 146
 147 (!defconstantp if (test then &optional else)
 148    :test
 149    (and (constantp* test)
 150         (constantp* (if (constant-form-value* test)
 151                         then
 152                         else)))
 153    :eval (if (constant-form-value* test)
 154              (constant-form-value* then)
 155              (constant-form-value* else)))
 156
 157 ;; FIXME: isn't it sufficient for non-final forms to be flushable and/or
 158 ;; maybe satisfy some other conditions? e.g. (PROGN (LIST 1) 'FOO) is constant.
 159 (!defconstantp progn (&body forms)
 160    :test (every #'constantp* forms)
 161    :eval (constant-form-value* (car (last forms))))
 162
 163 (!defconstantp the (type form)
 164    ;; We can't call TYPEP because the form might be (THE (FUNCTION (t) t) #<fn>)
 165    ;; which is valid for declaration but not for discrimination.
 166    ;; Instead use %%TYPEP in non-strict mode. FIXME:
 167    ;; (1) CAREFUL-SPECIFIER-TYPE should never fail. See lp#1395910.
 168    ;; (2) CONTAINS-UNKNOWN-TYPE-P should grovel into ARRAY-TYPE-ELEMENT-TYPE
 169    ;; so that (C-U-T-P (SPECIFIER-TYPE '(OR (VECTOR BAD) FUNCTION))) => T
 170    ;; and then we can parse, check for unknowns, and get rid of HANDLER-CASE.
 171    :test (and (constantp* form)
 172               (handler-case
 173                   ;; in case the type-spec is malformed!
 174                   (let ((parsed (careful-specifier-type type)))
 175                     ;; xc can't rely on a "non-strict" mode of TYPEP.
 176                     (and parsed
 177                          #+sb-xc-host
 178                          (typep (constant-form-value* form)
 179                                 (let ((*unparse-fun-type-simplify* t))
 180                                   (declare (special *unparse-fun-type-simplify*))
 181                                   (type-specifier parsed)))
 182                          #-sb-xc-host
 183                          (%%typep (constant-form-value* form) parsed nil)))
 184                 (error () nil)))
 185    :eval (constant-form-value* form))
 186
 187 (!defconstantp unwind-protect (&whole subforms protected-form &body cleanup-forms)
 188    :test (every #'constantp* subforms)
 189    :eval (constant-form-value* protected-form))
 190
 191 (!defconstantp block (name &body forms)
 192    ;; We currently fail to detect cases like
 193    ;;
 194    ;; (BLOCK FOO
 195    ;;   ...CONSTANT-FORMS...
 196    ;;   (RETURN-FROM FOO CONSTANT-VALUE)
 197    ;;   ...ANYTHING...)
 198    ;;
 199    ;; Right now RETURN-FROM kills the constantness unequivocally.
 200    :test (every #'constantp* forms)
 201    :eval (constant-form-value* (car (last forms))))
 202
 203 (!defconstantp multiple-value-prog1 (&whole subforms first-form &body forms)
 204    :test (every #'constantp* subforms)
 205    :eval (constant-form-value* first-form))
 206
 207 (!defconstantp progv (symbols values &body forms)
 208    :test (and (constantp* symbols)
 209               (constantp* values)
 210               (let* ((symbol-values (constant-form-value* symbols))
 211                      (*special-constant-variables*
 212                       (append symbol-values *special-constant-variables*)))
 213                 (progv
 214                     symbol-values
 215                     (constant-form-value* values)
 216                   (every #'constantp* forms))))
 217    :eval (progv
 218              (constant-form-value* symbols)
 219              (constant-form-value* values)
 220            (constant-form-value* (car (last forms)))))
 221
 222 ;;;
 223
 224 (macrolet
 225     ((expand-cases (expr-selector default-clause)
 226        `(flet ((constantp* (x) (%constantp x environment envp))
 227                (constant-form-value* (x) (%constant-form-value x environment envp)))
 228           (declare (optimize speed) (ignorable #'constantp*)
 229                    (ftype (function (t) (values t &optional)) ; avoid "unknown values"
 230                           constantp* constant-form-value*))
 231           (let ((args (cdr (truly-the list form))))
 232             (case (car form)
 233               ,@(map 'list
 234                      (lambda (spec &aux (bindings (cdddr spec)))
 235                        `(,(first spec)
 236                          (let* ,bindings
 237                            (declare (ignorable ,@(mapcar #'car bindings)))
 238                            ,(nth expr-selector spec))))
 239                      *special-form-constantp-defs*)
 240               (t
 241                ,default-clause))))))
 242
 243   (defun constant-special-form-p (form environment envp)
 244     (let (result)
 245       (tagbody (setq result (expand-cases 1 :maybe)) fail)
 246       result))
 247
 248   (defun constant-special-form-value (form environment envp)
 249     (let ((result))
 250       (tagbody
 251        (setq result (expand-cases 2 (return-from constant-special-form-value
 252                                       (values nil nil))))
 253        (return-from constant-special-form-value (values t result))
 254        fail))
 255     ;; Mutatation of FORM could cause failure. It's user error, not a bug.
 256     (error "CONSTANT-FORM-VALUE called with invalid expression ~S" form)))