From: Nikodemus S. <de...@us...> - 2006-02-27 13:12:44
|
Update of /cvsroot/sbcl/sbcl/src/compiler In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv2812/src/compiler Modified Files: info-functions.lisp ir1-translators.lisp Added Files: constantp.lisp Log Message: 0.9.10.4: better CONSTANTP * Recognizes constant argument calls to foldable functions and also deals with some simple special forms like. * Replace a ton of EVAL calls with CONSTANT-FORM-VALUE. --- NEW FILE: constantp.lisp --- ;;;; implementation of CONSTANTP, needs both INFO and IR1-ATTRIBUTES ;;;; This software is part of the SBCL system. See the README file for ;;;; more information. ;;;; ;;;; This software is derived from the CMU CL system, which was ;;;; written at Carnegie Mellon University and released into the ;;;; public domain. The software is in the public domain and is ;;;; provided with absolutely no warranty. See the COPYING and CREDITS ;;;; files for more information. (in-package "SB!C") (!begin-collecting-cold-init-forms) (defvar *special-form-constantp-funs*) (declaim (type hash-table *special-form-constantp-funs*)) (!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*)) (!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)) (defun %constantp (form environment envp) (let ((form (if envp (sb!xc: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 (constant-function-call-p form environment envp))) (t t)))) (defun %constant-form-value (form environment envp) (let ((form (if envp (sb!xc:macroexpand form environment) form))) (typecase form (symbol (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)))) (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)) ;;; FIXME: It would be nice to deal with inline functions ;;; too. (defun constant-function-call-p (form environment envp) (let ((name (car form))) (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))) (every (lambda (arg) (%constantp arg environment envp)) (cdr form))))) (defun constant-function-call-value (form environment envp) (apply (fdefinition (car form)) (mapcar (lambda (arg) (%constant-form-value arg environment envp)) (cdr form)))) #!-sb-fluid (declaim (inline sb!xc:constantp)) (defun sb!xc:constantp (form &optional (environment nil envp)) #!+sb-doc "True of any FORM that has a constant value: self-evaluating objects, 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)) #!-sb-fluid (declaim (inline constant-form-value)) (defun constant-form-value (form &optional (environment nil envp)) #!+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)) (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) (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 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))))))) (!cold-init-forms (defconstantp quote (value) :test t :eval 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))) (defconstantp progn (&body forms) :test (every #'constantp* forms) :eval (constant-form-value* (car (last forms)))) (defconstantp unwind-protect (protected-form &body cleanup-forms) :test (every #'constantp* (cons protected-form cleanup-forms)) :eval (constant-form-value* protected-form)) (defconstantp the (value-type form) :test (constantp* form) :eval (let ((value (constant-form-value* form))) (if (typep value value-type) value (error 'type-error :datum value :expected-type value-type)))) (defconstantp block (name &body forms) ;; We currently fail to detect cases like ;; ;; (BLOCK FOO ;; ...CONSTANT-FORMS... ;; (RETURN-FROM FOO CONSTANT-VALUE) ;; ...ANYTHING...) ;; ;; Right now RETURN-FROM kills the constantness unequivocally. :test (every #'constantp* forms) :eval (constant-form-value* (car (last forms)))) (defconstantp multiple-value-prog1 (first-form &body forms) :test (every #'constantp* (cons first-form forms)) :test (constant-form-value* first-form)) (defconstantp progv (symbols values &body forms) :test (and (constantp* symbols) (constantp* values) (let ((*special-constant-variables* (append (constant-form-value* symbols) *special-constant-variables*))) (every #'constantp* forms))) :eval (progv (constant-form-value* symbols) (constant-form-value* values) (constant-form-value* (car (last forms)))))) (!defun-from-collected-cold-init-forms !constantp-cold-init) Index: info-functions.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/info-functions.lisp,v retrieving revision 1.27 retrieving revision 1.28 diff -u -d -r1.27 -r1.28 --- info-functions.lisp 14 Jul 2005 18:56:59 -0000 1.27 +++ info-functions.lisp 27 Feb 2006 13:12:35 -0000 1.28 @@ -121,30 +121,6 @@ ;;;; ANSI Common Lisp functions which are defined in terms of the info ;;;; database -(defun sb!xc:constantp (object &optional environment) - #!+sb-doc - "True of any Lisp object that has a constant value: types that eval to - themselves, keywords, constants, and list whose car is QUOTE." - ;; FIXME: Someday it would be nice to make the code recognize foldable - ;; functions and call itself recursively on their arguments, so that - ;; more of the examples in the ANSI CL definition are recognized. - ;; (e.g. (+ 3 2), (SQRT PI), and (LENGTH '(A B C))) - (declare (ignore environment)) - (typecase object - ;; (Note that the following test on INFO catches KEYWORDs as well as - ;; explicitly DEFCONSTANT symbols.) - (symbol (eq (info :variable :kind object) :constant)) - (list (and (eq (car object) 'quote) - (consp (cdr object)))) - (t t))) - -(defun constant-form-value (form) - (typecase form - (symbol (info :variable :constant-value form)) - ((cons (eql quote) cons) - (second form)) - (t form))) - (defun sb!xc:macro-function (symbol &optional env) #!+sb-doc "If SYMBOL names a macro in ENV, returns the expansion function, Index: ir1-translators.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1-translators.lisp,v retrieving revision 1.70 retrieving revision 1.71 diff -u -d -r1.70 -r1.71 --- ir1-translators.lisp 27 Feb 2006 11:07:31 -0000 1.70 +++ ir1-translators.lisp 27 Feb 2006 13:12:35 -0000 1.71 @@ -499,14 +499,11 @@ (with-fun-name-leaf (leaf thing start :global t) (reference-leaf start next result leaf))) -(defun constant-global-fun-name-p (thing) - ;; FIXME: Once we have a marginally better CONSTANTP and - ;; CONSTANT-VALUE we can use those instead. - (and (consp thing) - (eq 'quote (car thing)) - (null (cddr thing)) - (legal-fun-name-p (cadr thing)) - t)) +(defun constant-global-fun-name (thing) + (let ((constantp (sb!xc:constantp thing))) + (and constantp + (let ((name (constant-form-value thing))) + (and (legal-fun-name-p name) name))))) ;;;; FUNCALL @@ -540,12 +537,12 @@ ;;; directly to %FUNCALL, instead of waiting around for type ;;; inference. (define-source-transform funcall (function &rest args) - (cond ((and (consp function) (eq (car function) 'function)) - `(%funcall ,function ,@args)) - ((constant-global-fun-name-p function) - `(%funcall (global-function ,(second function)) ,@args)) - (t - (values nil t)))) + (if (and (consp function) (eq (car function) 'function)) + `(%funcall ,function ,@args) + (let ((name (constant-global-fun-name function))) + (if name + `(%funcall (global-function ,name) ,@args) + (values nil t))))) (deftransform %coerce-callable-to-fun ((thing) (function) *) "optimize away possible call to FDEFINITION at runtime" @@ -1026,12 +1023,12 @@ ;; MV-COMBINATIONS. (make-combination fun-lvar)))) (ir1-convert start ctran fun-lvar - (cond ((and (consp fun) (eq (car fun) 'function)) - fun) - ((constant-global-fun-name-p fun) - `(global-function ,(second fun))) - (t - `(%coerce-callable-to-fun ,fun)))) + (if (and (consp fun) (eq (car fun) 'function)) + fun + (let ((name (constant-global-fun-name fun))) + (if name + `(global-function ,name) + `(%coerce-callable-to-fun ,fun))))) (setf (lvar-dest fun-lvar) node) (collect ((arg-lvars)) (let ((this-start ctran)) |