From b4cd3ec41c1a12ae70ea5e8ea0641fe999239052 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gustavo=20Henrique=20Milar=C3=A9?= Date: Wed, 22 Feb 2012 15:50:15 -0200 Subject: Optimize CONSTANTP. CONSTANT-FORM-VALUE now detects whether the parameter FORM is constant and either signals an error or returns some default value otherwise. CONSTANTP doesn't signal an error on bad code anymore. --- src/compiler/constantp.lisp | 300 +++++++++++++++++++++---------------------- tests/eval.impure.lisp | 16 ++- 2 files changed, 161 insertions(+), 155 deletions(-) diff --git a/src/compiler/constantp.lisp b/src/compiler/constantp.lisp index d06d226..f39133e 100644 --- a/src/compiler/constantp.lisp +++ b/src/compiler/constantp.lisp @@ -18,97 +18,84 @@ (!cold-init-forms (setf *special-form-constantp-funs* (make-hash-table))) -(defvar *special-form-constant-form-value-funs*) -(declaim (type hash-table *special-form-constant-form-value-funs*)) +(defvar *constant-variables*) (!cold-init-forms - (setf *special-form-constant-form-value-funs* (make-hash-table))) - -(defvar *special-constant-variables*) -(!cold-init-forms - (setf *special-constant-variables* nil)) + (setf *constant-variables* nil)) (defun %constantp (form environment envp) - (let ((form (if envp - (%macroexpand form environment) - form))) - (typecase form - ;; This INFO test catches KEYWORDs as well as explicitly - ;; DEFCONSTANT symbols. - (symbol - (or (eq (info :variable :kind form) :constant) - (constant-special-variable-p form))) - (list - (or (constant-special-form-p form environment envp) - #-sb-xc-host - (values (constant-function-call-p form environment envp)))) - (t t)))) - -(defun %constant-form-value (form environment envp) - (let ((form (if envp - (%macroexpand form environment) - form))) - (typecase form - (symbol - ;; KLUDGE: superficially, this might look good enough: we grab - ;; the value from the info database, and if it isn't there (or - ;; is NIL, but hey) we use the host's value. This works for - ;; MOST-POSITIVE-FIXNUM and friends, but still fails for - ;; float-related constants, where there is in fact no guarantee - ;; that we can represent our target value at all in the host, - ;; so we don't try. We should rework all uses of floating - ;; point so that we never try to use a host's value, and then - ;; make some kind of assertion that we never attempt to take - ;; a host value of a constant in the CL package. - #+sb-xc-host (or (info :variable :xc-constant-value form) - (symbol-value form)) - #-sb-xc-host (symbol-value form)) - (list - (if (special-operator-p (car form)) - (constant-special-form-value form environment envp) - #-sb-xc-host - (constant-function-call-value form environment envp))) - (t - form)))) + (handler-case + (let ((form (if (or envp + ;; Macroexpand FORM if it is a CL macro + #-sb-xc-host + (and (listp form) (symbolp (car form)) + (eq (symbol-package (car form)) + (find-package :cl)))) + (%macroexpand form environment) + form))) + (typecase form + ;; This INFO test catches KEYWORDs as well as explicitly + ;; DEFCONSTANT symbols. + (symbol + (if (eq (info :variable :kind form) :constant) + ;; KLUDGE: superficially, this might look good enough: we grab + ;; the value from the info database, and if it isn't there (or + ;; is NIL, but hey) we use the host's value. This works for + ;; MOST-POSITIVE-FIXNUM and friends, but still fails for + ;; float-related constants, where there is in fact no guarantee + ;; that we can represent our target value at all in the host, + ;; so we don't try. We should rework all uses of floating + ;; point so that we never try to use a host's value, and then + ;; make some kind of assertion that we never attempt to take + ;; a host value of a constant in the CL package. + (values t (or #+sb-xc-host (info :variable :xc-constant-value form) + (symbol-value form))) + (constant-variable-p form))) + (list + (if (special-operator-p (car form)) + (constant-special-form-p form environment envp) + #-sb-xc-host + (constant-function-call-p form environment envp))) + (t (values t form)))) + ;; ANSI says CONSTANTP shouldn't have any exceptional situation + (error () nil))) (defun constant-special-form-p (form environment envp) (let ((fun (gethash (car form) *special-form-constantp-funs*))) (when fun (funcall fun form environment envp)))) -(defun constant-special-form-value (form environment envp) - (let ((fun (gethash (car form) *special-form-constant-form-value-funs*))) - (if fun - (funcall fun form environment envp) - (error "Not a constant-foldable special form: ~S" form)))) - -(defun constant-special-variable-p (name) - (and (member name *special-constant-variables*) t)) +(defun constant-variable-p (name) + (let ((entry (assoc name *constant-variables*))) + (when entry + (values t (cdr entry))))) ;;; FIXME: It would be nice to deal with inline functions ;;; too. (defun constant-function-call-p (form environment envp) (let ((name (car form))) - (if (and (legal-fun-name-p name) - (eq :function (info :function :kind name)) - (let ((info (info :function :info name))) - (and info (ir1-attributep (fun-info-attributes info) - foldable))) - (and (every (lambda (arg) - (%constantp arg environment envp)) - (cdr form)))) - ;; Even though the function may be marked as foldable - ;; the call may still signal an error -- eg: (CAR 1). - (handler-case - (values t (constant-function-call-value form environment envp)) - (error () - (values nil nil))) - (values nil nil)))) - -(defun constant-function-call-value (form environment envp) - (apply (fdefinition (car form)) - (mapcar (lambda (arg) - (%constant-form-value arg environment envp)) - (cdr form)))) + (and (legal-fun-name-p name) + (eq :function (info :function :kind name)) + (or + (let ((info (info :function :info name))) + (and info (ir1-attributep (fun-info-attributes info) + foldable))) + ;; VALUES should be foldable, but uncommenting the following form + ;; causes bug LP#938404 + #+nil (eq 'values name)) + (block nil + (let ((args (mapcar (lambda (arg) + (multiple-value-bind (constantp value) + (%constantp arg environment envp) + (unless constantp (return)) + value)) + (cdr form)))) + ;; Even though the function may be marked as foldable + ;; the call may still signal an error -- eg: (CAR 1). + (handler-case + (multiple-value-call #'values + t (apply (fdefinition (car form)) + args)) + (error () nil))))))) #!-sb-fluid (declaim (inline sb!xc:constantp)) (defun sb!xc:constantp (form &optional (environment nil envp)) @@ -117,87 +104,95 @@ keywords, defined constants, quote forms. Additionally the constant-foldability of some function calls special forms is recognized. If ENVIRONMENT is provided the FORM is first macroexpanded in it." - (%constantp form environment envp)) + (values (%constantp form environment envp))) #!-sb-fluid (declaim (inline constant-form-value)) -(defun constant-form-value (form &optional (environment nil envp)) +(defun constant-form-value (form &optional (environment nil envp) + not-constant-error-p not-constant-value) #!+sb-doc - "Returns the value of the constant FORM in ENVIRONMENT. Behaviour -is undefined unless CONSTANTP has been first used to determine the -constantness of the FORM in ENVIRONMENT." - (%constant-form-value form environment envp)) + "Return all the values of the constant FORM in ENVIRONMENT. If +NOT-CONSTANT-ERROR-P is true, an error is signaled if FORM is not constant +or if it's value could not be determined; if NOT-CONSTANT-ERROR-P is NIL, +return NOT-CONSTANT-VALUE instead." + (destructuring-bind (constantp &rest values) + (multiple-value-list (%constantp form environment envp)) + (cond + (constantp (apply #'values values)) + (not-constant-error-p + (error "Could not determine the constant value of form ~S." form)) + (t not-constant-value)))) (declaim (inline constant-typep)) (defun constant-typep (form type &optional (environment nil envp)) - (and (%constantp form environment envp) - ;; FIXME: We probably should be passing the environment to - ;; TYPEP too, but (1) our XC version of typep AVERs that the - ;; environment is null (2) our real version ignores it anyhow. - (sb!xc:typep (%constant-form-value form environment envp) type))) - -;;;; NOTE!!! -;;;; -;;;; If you add new special forms, check that they do not -;;;; alter the logic of existing ones: eg, currently -;;;; CONSTANT-FORM-VALUE directly evaluates the last expression -;;;; of a PROGN, as no assignment is allowed. If you extend -;;;; analysis to assignments then other forms must take this -;;;; into account. - -(defmacro defconstantp (operator lambda-list &key test eval) + (multiple-value-bind (constantp value) (%constantp form environment envp) + (and constantp + ;; FIXME: We probably should be passing the environment to + ;; TYPEP too, but (1) our XC version of typep AVERs that the + ;; environment is null (2) our real version ignores it anyhow. + (sb!xc:typep value type)))) + +(defmacro defconstantp (operator lambda-list &key test) (with-unique-names (form environment envp) (flet ((frob (body) `(flet ((constantp* (x) - (%constantp x ,environment ,envp)) - (constant-form-value* (x) - (%constant-form-value x ,environment ,envp))) - (declare (ignorable #'constantp* #'constant-form-value*)) - (destructuring-bind ,lambda-list (cdr ,form) - ;; KLUDGE: is all we need, so we keep it simple - ;; instead of general (not handling cases like &key (x y)) - (declare (ignorable - ,@(remove-if (lambda (arg) - (member arg sb!xc:lambda-list-keywords)) - lambda-list))) - ,body)))) + (%constantp x ,environment ,envp))) + (declare (ignorable #'constantp*)) + (flet ((constant-progn-p* (forms) + (loop for forms* on forms + until (null (cdr forms*)) + do (unless (constantp* (car forms*)) + (return)) + finally (return (constantp* (car forms*)))))) + (declare (ignorable #'constant-progn-p*)) + (destructuring-bind ,lambda-list (cdr ,form) + ;; KLUDGE: is all we need, so we keep it simple + ;; instead of general (not handling cases like &key (x y)) + (declare (ignorable + ,@(remove-if (lambda (arg) + (member arg sb!xc:lambda-list-keywords)) + lambda-list))) + ,body))))) `(progn (setf (gethash ',operator *special-form-constantp-funs*) (lambda (,form ,environment ,envp) - ,(frob test))) - (setf (gethash ',operator *special-form-constant-form-value-funs*) - (lambda (,form ,environment ,envp) - ,(frob eval))))))) + ,(frob test))))))) (!cold-init-forms (defconstantp quote (value) - :test t - :eval value) + :test (values t value)) (defconstantp if (test then &optional else) - :test - (and (constantp* test) - (constantp* (if (constant-form-value* test) - then - else))) - :eval (if (constant-form-value* test) - (constant-form-value* then) - (constant-form-value* else))) + :test (multiple-value-bind (constantp value) (constantp* test) + (and constantp + (constantp* (if value + then + else))))) (defconstantp progn (&body forms) - :test (every #'constantp* forms) - :eval (constant-form-value* (car (last forms)))) + :test (constant-progn-p* forms)) (defconstantp unwind-protect (protected-form &body cleanup-forms) - :test (every #'constantp* (cons protected-form cleanup-forms)) - :eval (constant-form-value* protected-form)) + :test (block nil + (multiple-value-prog1 (constantp* protected-form) + (unless (every #'constantp* cleanup-forms) + (return))))) (defconstantp the (type form) - :test (and (constantp* form) - (handler-case - ;; in case the type-spec is malformed! - (typep (constant-form-value* form) type) - (error () nil))) - :eval (constant-form-value* form)) + :test (destructuring-bind (constantp &rest values) + (multiple-value-list (constantp* form)) + (and constantp + ;; in case the type-spec is malformed! + (handler-case + (if (and (listp type) (eq (car type) 'values)) + (let* ((types (cdr type)) + (values + (append values + (make-list (max 0 (- (length types) + (length values))))))) + (every #'typep values types)) + (typep (car values) type)) + (error () nil)) + (apply #'values t values)))) (defconstantp block (name &body forms) ;; We currently fail to detect cases like @@ -208,27 +203,28 @@ constantness of the FORM in ENVIRONMENT." ;; ...ANYTHING...) ;; ;; Right now RETURN-FROM kills the constantness unequivocally. - :test (every #'constantp* forms) - :eval (constant-form-value* (car (last forms)))) + :test (constant-progn-p* forms)) (defconstantp multiple-value-prog1 (first-form &body forms) - :test (every #'constantp* (cons first-form forms)) - :eval (constant-form-value* first-form)) + :test (block nil + (multiple-value-prog1 (constantp* first-form) + (unless (every #'constantp* forms) + (return))))) (defconstantp progv (symbols values &body forms) - :test (and (constantp* symbols) - (constantp* values) - (let* ((symbol-values (constant-form-value* symbols)) - (*special-constant-variables* - (append symbol-values *special-constant-variables*))) - (progv - symbol-values - (constant-form-value* values) - (every #'constantp* forms)))) - :eval (progv - (constant-form-value* symbols) - (constant-form-value* values) - (constant-form-value* (car (last forms)))))) + :test (multiple-value-bind (constantp symbols) (constantp* symbols) + (when constantp + (multiple-value-bind (constantp values) (constantp* values) + (when constantp + (block progv + (let ((*constant-variables* *constant-variables*)) + (loop for symbol in symbols + for value in values + do + (when (eq (info :variable :kind symbol) :constant) + (return-from progv)) + (push (cons symbol value) *constant-variables*)) + (constant-progn-p* forms))))))))) (!defun-from-collected-cold-init-forms !constantp-cold-init) diff --git a/tests/eval.impure.lisp b/tests/eval.impure.lisp index 0baf4e9..1539974 100644 --- a/tests/eval.impure.lisp +++ b/tests/eval.impure.lisp @@ -146,11 +146,21 @@ (/ 1 0)) nil) ((/ 1 0) nil) ((/ 1 1) t 1) - ((+ 1 2) t 3))) - (destructuring-bind (form c &optional v) test + ((+ 1 2) t 3) + ;; Should not signal an error + ((if t 1 2 3) nil) + ((the integer 1 2) nil) + ((truncate 10 3) t 3 1) + ((the (values integer + integer) + (truncate 7 2)) t 3 1) + ((the (values integer + list) + (truncate 3 3)) nil))) + (destructuring-bind (form c &rest vs) test (assert (eql (constantp form) c)) (when c - (assert (eql v (sb-int:constant-form-value form)))))) + (assert (every #'eql vs (multiple-value-list (sb-int:constant-form-value form))))))) ;;; DEFPARAMETER must assign a dynamic variable (let ((var (gensym))) -- 1.7.5.4