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-funs*)
  17 (declaim (type hash-table *special-form-constantp-funs*))
  18 (!cold-init-forms
  19   (setf *special-form-constantp-funs* (make-hash-table)))
  20
  21 (defvar *special-form-constant-form-value-funs*)
  22 (declaim (type hash-table *special-form-constant-form-value-funs*))
  23 (!cold-init-forms
  24   (setf *special-form-constant-form-value-funs* (make-hash-table)))
  25
  26 (defvar *special-constant-variables*)
  27 (!cold-init-forms
  28   (setf *special-constant-variables* nil))
  29
  30 (defun %constantp (form environment envp)
  31   (let ((form (if envp
  32                   (sb!xc:macroexpand form environment)
  33                   form)))
  34     (typecase form
  35       ;; This INFO test catches KEYWORDs as well as explicitly
  36       ;; DEFCONSTANT symbols.
  37       (symbol
  38        (or (eq (info :variable :kind form) :constant)
  39            (constant-special-variable-p form)))
  40       (list
  41        (or (constant-special-form-p form environment envp)
  42            #-sb-xc-host
  43            (constant-function-call-p form environment envp)))
  44       (t t))))
  45
  46 (defun %constant-form-value (form environment envp)
  47   (let ((form (if envp
  48                   (sb!xc:macroexpand form environment)
  49                   form)))
  50     (typecase form
  51       (symbol
  52        (symbol-value form))
  53       (list
  54        (if (special-operator-p (car form))
  55            (constant-special-form-value form environment envp)
  56            #-sb-xc-host
  57            (constant-function-call-value form environment envp)))
  58       (t
  59        form))))
  60
  61 (defun constant-special-form-p (form environment envp)
  62   (let ((fun (gethash (car form) *special-form-constantp-funs*)))
  63     (when fun
  64       (funcall fun form environment envp))))
  65
  66 (defun constant-special-form-value (form environment envp)
  67   (let ((fun (gethash (car form) *special-form-constant-form-value-funs*)))
  68     (if fun
  69         (funcall fun form environment envp)
  70         (error "Not a constant-foldable special form: ~S" form))))
  71
  72 (defun constant-special-variable-p (name)
  73   (and (member name *special-constant-variables*) t))
  74
  75 ;;; FIXME: It would be nice to deal with inline functions
  76 ;;; too.
  77 (defun constant-function-call-p (form environment envp)
  78   (let ((name (car form)))
  79     (and (legal-fun-name-p name)
  80          (eq :function (info :function :kind name))
  81          (let ((info (info :function :info name)))
  82            (and info (ir1-attributep (fun-info-attributes info)
  83                                      foldable)))
  84          (every (lambda (arg)
  85                   (%constantp arg environment envp))
  86                 (cdr form)))))
  87
  88 (defun constant-function-call-value (form environment envp)
  89   (apply (fdefinition (car form))
  90          (mapcar (lambda (arg)
  91                    (%constant-form-value arg environment envp))
  92                  (cdr form))))
  93
  94 #!-sb-fluid (declaim (inline sb!xc:constantp))
  95 (defun sb!xc:constantp (form &optional (environment nil envp))
  96   #!+sb-doc
  97   "True of any FORM that has a constant value: self-evaluating objects,
  98 keywords, defined constants, quote forms. Additionally the
  99 constant-foldability of some function calls special forms is recognized. If
 100 ENVIRONMENT is provided the FORM is first macroexpanded in it."
 101   (%constantp form environment envp))
 102
 103 #!-sb-fluid (declaim (inline constant-form-value))
 104 (defun constant-form-value (form &optional (environment nil envp))
 105   #!+sb-doc
 106   "Returns the value of the constant FORM in ENVIRONMENT. Behaviour
 107 is undefined unless CONSTANTP has been first used to determine the
 108 constantness of the FORM in ENVIRONMENT."
 109   (%constant-form-value form environment envp))
 110
 111 (declaim (inline constant-typep))
 112 (defun constant-typep (form type &optional (environment nil envp))
 113   (and (%constantp form environment envp)
 114        ;; FIXME: We probably should be passing the environment to
 115        ;; TYPEP too, but (1) our XC version of typep AVERs that the
 116        ;; environment is null (2) our real version ignores it anyhow.
 117        (sb!xc:typep (%constant-form-value form environment envp) type)))
 118
 119 ;;;; NOTE!!!
 120 ;;;;
 121 ;;;; If you add new special forms, check that they do not
 122 ;;;; alter the logic of existing ones: eg, currently
 123 ;;;; CONSTANT-FORM-VALUE directly evaluates the last expression
 124 ;;;; of a PROGN, as no assignment is allowed. If you extend
 125 ;;;; analysis to assignments then other forms must take this
 126 ;;;; into account.
 127
 128 (defmacro defconstantp (operator lambda-list &key test eval)
 129   (with-unique-names (form environment envp)
 130     (flet ((frob (body)
 131              `(flet ((constantp* (x)
 132                        (%constantp x ,environment ,envp))
 133                      (constant-form-value* (x)
 134                        (%constant-form-value x ,environment ,envp)))
 135                 (declare (ignorable #'constantp* #'constant-form-value*))
 136                 (destructuring-bind ,lambda-list (cdr ,form)
 137                   ;; KLUDGE: is all we need, so we keep it simple
 138                   ;; instead of general (not handling cases like &key (x y))
 139                   (declare (ignorable
 140                             ,@(remove-if (lambda (arg)
 141                                            (member arg lambda-list-keywords))
 142                                          lambda-list)))
 143                    ,body))))
 144       `(progn
 145          (setf (gethash ',operator *special-form-constantp-funs*)
 146                (lambda (,form ,environment ,envp)
 147                  ,(frob test)))
 148          (setf (gethash ',operator *special-form-constant-form-value-funs*)
 149                (lambda (,form ,environment ,envp)
 150                  ,(frob eval)))))))
 151
 152 (!cold-init-forms
 153  (defconstantp quote (value)
 154    :test t
 155    :eval value)
 156
 157  (defconstantp if (test then &optional else)
 158    :test
 159    (and (constantp* test)
 160         (constantp* (if (constant-form-value* test)
 161                         then
 162                         else)))
 163    :eval (if (constant-form-value* test)
 164              (constant-form-value* then)
 165              (constant-form-value* else)))
 166
 167  (defconstantp progn (&body forms)
 168    :test (every #'constantp* forms)
 169    :eval (constant-form-value* (car (last forms))))
 170
 171  (defconstantp unwind-protect (protected-form &body cleanup-forms)
 172    :test (every #'constantp* (cons protected-form cleanup-forms))
 173    :eval (constant-form-value* protected-form))
 174
 175  (defconstantp the (value-type form)
 176    :test (constantp* form)
 177    :eval (let ((value (constant-form-value* form)))
 178            (if (typep value value-type)
 179                value
 180                (error 'type-error
 181                       :datum value
 182                       :expected-type value-type))))
 183
 184  (defconstantp block (name &body forms)
 185    ;; We currently fail to detect cases like
 186    ;;
 187    ;; (BLOCK FOO
 188    ;;   ...CONSTANT-FORMS...
 189    ;;   (RETURN-FROM FOO CONSTANT-VALUE)
 190    ;;   ...ANYTHING...)
 191    ;;
 192    ;; Right now RETURN-FROM kills the constantness unequivocally.
 193    :test (every #'constantp* forms)
 194    :eval (constant-form-value* (car (last forms))))
 195
 196  (defconstantp multiple-value-prog1 (first-form &body forms)
 197    :test (every #'constantp* (cons first-form forms))
 198    :test (constant-form-value* first-form))
 199
 200  (defconstantp progv (symbols values &body forms)
 201    :test (and (constantp* symbols)
 202               (constantp* values)
 203               (let* ((symbol-values (constant-form-value* symbols))
 204                      (*special-constant-variables*
 205                       (append symbol-values *special-constant-variables*)))
 206                 (progv
 207                     symbol-values
 208                     (constant-form-value* values)
 209                   (every #'constantp* forms))))
 210    :eval (progv
 211              (constant-form-value* symbols)
 212              (constant-form-value* values)
 213            (constant-form-value* (car (last forms))))))
 214
 215 (!defun-from-collected-cold-init-forms !constantp-cold-init)
 216