[Sbcl-commits] CVS: sbcl/src/compiler constantp.lisp,NONE,1.1 info-functions.lisp,1.27,1.28 ir1-translators.lisp,1.70,1.71

[Nikodemus S. <de...@us...>]

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))