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   ;; Pick off quasiquote prior to macroexpansion.
  18   (when (typep form '(cons (eql quasiquote) (cons t null)))
  19     (return-from %constantp
  20       (constant-quasiquote-form-p (cadr form) environment envp)))
  21   (let ((form (if envp
  22                   (handler-case
  23                       (%macroexpand form environment)
  24                     (error ()
  25                       (return-from %constantp)))
  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        (let ((answer (constant-special-form-p form environment envp)))
  35          (if (eq answer :maybe)
  36              (values (constant-function-call-p form environment envp))
  37              answer)))
  38       (t t))))
  39
  40 (defun constant-quasiquote-form-p (expr environment envp)
  41   ;; This is an utter cinch because we haven't macroexpanded.
  42   ;; Parse just enough to recognize (DEFTYPE <T2> () (<T1> ,THING)) etc.
  43   (named-let recurse ((expr expr))
  44     (cond ((atom expr)
  45            (cond ((comma-p expr)
  46                   (%constantp (comma-expr expr) environment envp))
  47                  ((simple-vector-p expr) (every #'recurse expr))
  48                  (t)))
  49           ((eq (car expr) 'quasiquote) nil) ; give up
  50           (t (and (recurse (car expr)) (recurse (cdr expr)))))))
  51
  52 (defun %constant-form-value (form environment envp)
  53   (let ((form (if (or envp
  54                       (typep form '(cons (eql quasiquote) (cons t null))))
  55                   (%macroexpand form environment)
  56                   form)))
  57     (typecase form
  58       (symbol
  59        (symbol-value form))
  60       (list
  61        (multiple-value-bind (specialp value)
  62            (constant-special-form-value form environment envp)
  63          (if specialp value (constant-function-call-value
  64                              form environment envp))))
  65       (t
  66        form))))
  67
  68 (defun constant-special-variable-p (name)
  69   (and (member name *special-constant-variables*) t))
  70
  71 ;;; FIXME: It would be nice to deal with inline functions
  72 ;;; too.
  73 (defun constant-function-call-p (form environment envp)
  74   (let ((name (car form)))
  75     (if (and (legal-fun-name-p name)
  76              (eq :function (info :function :kind name))
  77              (let ((info (info :function :info name)))
  78                (and info (ir1-attributep (fun-info-attributes info)
  79                                          foldable)))
  80              (and (every (lambda (arg)
  81                            ;; filter-lvar inserts dummy constants,
  82                            ;; while the forms are clearly not
  83                            ;; constant. Most functions fail on them.
  84                            ;; But there's a problem with error
  85                            ;; signaling during cold init.
  86                            ;; And some functions might not signal errors at all.
  87                            (unless (constant-p 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 ;;;; NOTE!!!
 105 ;;;;
 106 ;;;; If you add new special forms, check that they do not
 107 ;;;; alter the logic of existing ones: eg, currently
 108 ;;;; CONSTANT-FORM-VALUE directly evaluates the last expression
 109 ;;;; of a PROGN, as no assignment is allowed. If you extend
 110 ;;;; analysis to assignments then other forms must take this
 111 ;;;; into account.
 112
 113 (eval-when (:compile-toplevel :execute)
 114 (defparameter *!special-form-constantp-defs* (make-array 20 :fill-pointer 0)))
 115
 116 (defmacro !defconstantp (operator lambda-list &key test eval)
 117   (let ((args (make-symbol "ARGS")))
 118     (flet
 119         ;; FIXME: DESTRUCTURING-BIND should have the option to expand this way.
 120         ;; It would be useful for DEFINE-SOURCE-TRANSFORM as well.
 121         ((binding-maker (input on-error)
 122            (multiple-value-bind (llks req opt rest key aux env whole)
 123                (parse-lambda-list
 124                 lambda-list
 125                 :accept (lambda-list-keyword-mask '(&whole &optional &rest &body)))
 126              (declare (ignore llks key aux env))
 127              (aver (every (lambda (x) (and (symbolp x) x)) (append req opt rest)))
 128              (flet ((bind (var pred enforce-end)
 129                       `(,(car var)
 130                         ,(if enforce-end
 131                              `(if (and (,pred ,args) (not (cdr ,args)))
 132                                   (car ,args)
 133                                   ,on-error)
 134                              `(if (,pred ,args) (pop ,args) ,on-error)))))
 135                `((,args ,input)
 136                  ,@(when whole
 137                      ;; If both &WHOLE and &REST are present, the &WHOLE var
 138                      ;; must be a list, although we don't know that just yet.
 139                      ;; It will be verified when the &REST arg is bound.
 140                      `((,(car whole) ,(if rest `(truly-the list ,args) args))))
 141                  ,@(maplist (lambda (x)
 142                               (bind x (if (cdr x) 'listp 'consp)
 143                                     (and (not (cdr x)) (not opt) (not rest))))
 144                             req)
 145                  ,@(maplist (lambda (x) (bind x 'listp (and (not (cdr x)) (not rest))))
 146                             opt)
 147                  ,@(when rest
 148                      `((,(car rest)
 149                         (if (proper-list-p ,args)
 150                             (truly-the list ,args) ; to open-code EVERY #'P on &REST arg
 151                             ,on-error)))))))))
 152       `(eval-when (:compile-toplevel :execute)
 153          (vector-push-extend ',(list* operator test eval
 154                                       (binding-maker 'args '(go fail)))
 155                              *!special-form-constantp-defs*)))))
 156
 157 ;;; NOTE: special forms are tested in the order as written,
 158 ;;; so there is some benefit to listing important ones earliest.
 159
 160 (!defconstantp quote (value)
 161    :test t
 162    :eval value)
 163
 164 (!defconstantp if (test then &optional else)
 165    :test
 166    (and (constantp* test)
 167         (constantp* (if (constant-form-value* test)
 168                         then
 169                         else)))
 170    :eval (if (constant-form-value* test)
 171              (constant-form-value* then)
 172              (constant-form-value* else)))
 173
 174 ;; FIXME: isn't it sufficient for non-final forms to be flushable and/or
 175 ;; maybe satisfy some other conditions? e.g. (PROGN (LIST 1) 'FOO) is constant.
 176 (!defconstantp progn (&body forms)
 177    :test (every #'constantp* forms)
 178    :eval (constant-form-value* (car (last forms))))
 179
 180 (!defconstantp the (type form)
 181    ;; We can't call TYPEP because the form might be (THE (FUNCTION (t) t) #<fn>)
 182    ;; which is valid for declaration but not for discrimination.
 183    ;; CTYPEP handles unknown types and SATISFIES with non-foldable functions.
 184    :test (and (constantp* form)
 185               (let ((parsed (careful-specifier-type type)))
 186                 (and parsed
 187                      (ctypep (constant-form-value* form) parsed))))
 188    :eval (constant-form-value* form))
 189
 190 (!defconstantp unwind-protect (&whole subforms protected-form &body cleanup-forms)
 191    :test (every #'constantp* subforms)
 192    :eval (constant-form-value* protected-form))
 193
 194 (!defconstantp block (name &body forms)
 195    ;; We currently fail to detect cases like
 196    ;;
 197    ;; (BLOCK FOO
 198    ;;   ...CONSTANT-FORMS...
 199    ;;   (RETURN-FROM FOO CONSTANT-VALUE)
 200    ;;   ...ANYTHING...)
 201    ;;
 202    ;; Right now RETURN-FROM kills the constantness unequivocally.
 203    :test (and (symbolp name)
 204               (every #'constantp* forms))
 205    :eval (constant-form-value* (car (last forms))))
 206
 207 (!defconstantp multiple-value-prog1 (&whole subforms first-form &body forms)
 208    :test (every #'constantp* subforms)
 209    :eval (constant-form-value* first-form))
 210
 211 (!defconstantp progv (symbols values &body forms)
 212    :test (and (constantp* symbols)
 213               (constantp* values)
 214               (let* ((symbols (constant-form-value* symbols))
 215                      (values (constant-form-value* values)))
 216                 (and (proper-list-p values)
 217                      (proper-list-p symbols)
 218                      (>= (length values)
 219                          (length symbols))
 220                      (loop for symbol in symbols
 221                            for value in values
 222                            always (and (symbolp symbol)
 223                                        (not (constantp symbol))
 224                                        (memq (info :variable :kind symbol)
 225                                              '(:unknown :special))
 226                                        (multiple-value-bind (type declaredp)
 227                                            (info :variable :type symbol)
 228                                          (or (not declaredp)
 229                                              (ctypep value type)))))
 230                      (let ((*special-constant-variables*
 231                              (append symbols *special-constant-variables*)))
 232                        (progv symbols values
 233                          (and forms
 234                               (every #'constantp* forms)))))))
 235    :eval (progv
 236              (constant-form-value* symbols)
 237              (constant-form-value* values)
 238            (constant-form-value* (car (last forms)))))
 239
 240 (!defconstantp with-source-form (source-form form)
 241    :test (constantp* form)
 242    :eval (constant-form-value* form))
 243
 244 (!defconstantp the* (options form)
 245    :test (destructuring-bind (type &key use-annotations
 246                               &allow-other-keys)
 247              options
 248            (declare (ignore type))
 249            (and use-annotations
 250                 (constantp* form)))
 251    :eval (constant-form-value* form))
 252
 253 ;;;
 254
 255 (macrolet
 256     ((expand-cases (expr-selector default-clause)
 257        `(flet ((constantp* (x) (%constantp x environment envp))
 258                (constant-form-value* (x) (%constant-form-value x environment envp)))
 259           (declare (optimize speed) (ignorable #'constantp*)
 260                    (ftype (sfunction (t) t) constantp* constant-form-value*))
 261           (let ((args (cdr (truly-the list form))))
 262             (case (car form)
 263               ,@(map 'list
 264                      (lambda (spec &aux (bindings (cdddr spec)))
 265                        `(,(first spec)
 266                          (let* ,bindings
 267                            (declare (ignorable ,@(mapcar #'car bindings)))
 268                            ,(nth expr-selector spec))))
 269                      *!special-form-constantp-defs*)
 270               (t
 271                ,default-clause))))))
 272
 273   (defun constant-special-form-p (form environment envp)
 274     (let (result)
 275       (tagbody (setq result (expand-cases 1 :maybe)) fail)
 276       result))
 277
 278   (defun constant-special-form-value (form environment envp)
 279     (let ((result))
 280       (tagbody
 281          (setq result (expand-cases 2 (return-from constant-special-form-value
 282                                         (values nil nil))))
 283          (return-from constant-special-form-value (values t result))
 284        fail))
 285     ;; Mutatation of FORM could cause failure. It's user error, not a bug.
 286     (error "CONSTANT-FORM-VALUE called with invalid expression ~S" form)))