From 444d2072bc52e60a41af62ee22e343e76109212f Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Mon, 27 Feb 2006 13:12:34 +0000 Subject: [PATCH] 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. --- NEWS | 3 + build-order.lisp-expr | 1 + package-data-list.lisp-expr | 5 + src/code/cold-init.lisp | 1 + src/code/condition.lisp | 8 +- src/code/early-pprint.lisp | 11 +- src/code/loop.lisp | 24 ++--- src/code/target-alieneval.lisp | 2 +- src/compiler/constantp.lisp | 213 +++++++++++++++++++++++++++++++++++++ src/compiler/info-functions.lisp | 24 ----- src/compiler/ir1-translators.lisp | 37 +++---- src/pcl/boot.lisp | 6 +- src/pcl/ctor.lisp | 17 +-- src/pcl/defcombin.lisp | 3 +- src/pcl/fngen.lisp | 5 +- src/pcl/macros.lisp | 5 +- src/pcl/slots-boot.lisp | 6 +- src/pcl/slots.lisp | 6 +- src/pcl/vector.lisp | 12 ++- tests/compiler.pure.lisp | 2 + tests/eval.impure.lisp | 40 +++++++ version.lisp-expr | 2 +- 22 files changed, 333 insertions(+), 100 deletions(-) create mode 100644 src/compiler/constantp.lisp diff --git a/NEWS b/NEWS index 127f97e..5f23c7d 100644 --- a/NEWS +++ b/NEWS @@ -8,6 +8,9 @@ changes in sbcl-0.9.11 relative to sbcl-0.9.10: * optimization: calling functions via constant symbols -- as in (FUNCALL 'FOO) -- is now roughly as efficient as calling them via the function object as in (FUNCALL #'FOO). + * enhancement: CONSTANTP is now able to determine constantness of + more complex forms, including calls to constant-foldable standardized + functions and some special forms beyond QUOTE. changes in sbcl-0.9.10 relative to sbcl-0.9.9: * new feature: new SAVE-LISP-AND-DIE keyword argument :EXECUTABLE can diff --git a/build-order.lisp-expr b/build-order.lisp-expr index 3cb8a46..75a621c 100644 --- a/build-order.lisp-expr +++ b/build-order.lisp-expr @@ -389,6 +389,7 @@ ;; defines IR1-ATTRIBUTES macro, needed by proclaim.lisp ("src/compiler/knownfun") + ("src/compiler/constantp") ;; needs FUN-INFO structure slot setters, defined in knownfun.lisp ("src/compiler/fun-info-funs") diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index b5e0026..d0aa44b 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -798,6 +798,10 @@ retained, possibly temporariliy, because it might be used internally." "INFO" "MAKE-INFO-ENVIRONMENT" + ;; Constant form evaluation + "CONSTANT-FORM-VALUE" + "CONSTANT-TYPEP" + ;; stepping control "*STEPPING*" "*STEP*" @@ -1576,6 +1580,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "!VM-TYPE-COLD-INIT" "!BACKQ-COLD-INIT" "!SHARPM-COLD-INIT" "!EARLY-PROCLAIM-COLD-INIT" "!LATE-PROCLAIM-COLD-INIT" "!CLASS-FINALIZE" + "!CONSTANTP-COLD-INIT" "GC-REINIT" "SIGNAL-COLD-INIT-OR-REINIT" diff --git a/src/code/cold-init.lisp b/src/code/cold-init.lisp index edbcf42..fd3ee81 100644 --- a/src/code/cold-init.lisp +++ b/src/code/cold-init.lisp @@ -146,6 +146,7 @@ (show-and-call !policy-cold-init-or-resanify) (/show0 "back from !POLICY-COLD-INIT-OR-RESANIFY") + (show-and-call !constantp-cold-init) (show-and-call !early-proclaim-cold-init) ;; KLUDGE: Why are fixups mixed up with toplevel forms? Couldn't diff --git a/src/code/condition.lisp b/src/code/condition.lisp index ae93468..8c19059 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -529,8 +529,8 @@ :initform-p ',initform-p :documentation ',documentation :initform - ,(if (constantp initform) - `',(eval initform) + ,(if (sb!xc:constantp initform) + `',(constant-form-value initform) `#'(lambda () ,initform))))))) (dolist (option options) @@ -553,8 +553,8 @@ (let ((val (second initargs))) (setq default-initargs (list* `',(first initargs) - (if (constantp val) - `',(eval val) + (if (sb!xc:constantp val) + `',(constant-form-value val) `#'(lambda () ,val)) default-initargs))))) (t diff --git a/src/code/early-pprint.lisp b/src/code/early-pprint.lisp index e620d16..407059c 100644 --- a/src/code/early-pprint.lisp +++ b/src/code/early-pprint.lisp @@ -76,17 +76,16 @@ (let ((,count-name 0)) (declare (type index ,count-name) (ignorable ,count-name)) ,@(when (and (or prefixp per-line-prefix-p) - (not (and (sb!xc:constantp (or prefix per-line-prefix) env) - ;; KLUDGE: EVAL-IN-ENV would - ;; be useful here. - (typep (eval (or prefix per-line-prefix)) 'string)))) + (not (sb!int:constant-typep + (or prefix per-line-prefix) + 'string + env))) `((unless (typep ,(or prefix per-line-prefix) 'string) (error 'type-error :datum ,(or prefix per-line-prefix) :expected-type 'string)))) ,@(when (and suffixp - (not (and (sb!xc:constantp suffix env) - (typep (eval suffix) 'string)))) + (not (sb!int:constant-typep suffix 'string env))) `((unless (typep ,suffix 'string) (error 'type-error :datum ,suffix diff --git a/src/code/loop.lisp b/src/code/loop.lisp index 101a8df..9ffa2c0 100644 --- a/src/code/loop.lisp +++ b/src/code/loop.lisp @@ -503,27 +503,21 @@ code to be loaded. ;;;; code analysis stuff (defun loop-constant-fold-if-possible (form &optional expected-type) - (let ((new-form form) (constantp nil) (constant-value nil)) - (when (setq constantp (constantp new-form)) - (setq constant-value (eval new-form))) + (let* ((constantp (sb!xc:constantp form)) + (value (and constantp (sb!int:constant-form-value form)))) (when (and constantp expected-type) - (unless (sb!xc:typep constant-value expected-type) + (unless (sb!xc:typep value expected-type) (loop-warn "~@" - form constant-value expected-type) - (setq constantp nil constant-value nil))) - (values new-form constantp constant-value))) - -(defun loop-constantp (form) - (constantp form)) + form value expected-type) + (setq constantp nil value nil))) + (values form constantp value))) ;;;; LOOP iteration optimization -(defvar *loop-duplicate-code* - nil) +(defvar *loop-duplicate-code* nil) -(defvar *loop-iteration-flag-var* - (make-symbol "LOOP-NOT-FIRST-TIME")) +(defvar *loop-iteration-flag-var* (make-symbol "LOOP-NOT-FIRST-TIME")) (defun loop-code-duplication-threshold (env) (declare (ignore env)) @@ -1067,7 +1061,7 @@ code to be loaded. (t (error "invalid LOOP variable passed in: ~S" name)))) (defun loop-maybe-bind-form (form data-type) - (if (loop-constantp form) + (if (constantp form) form (loop-make-var (gensym "LOOP-BIND-") form data-type))) diff --git a/src/code/target-alieneval.lisp b/src/code/target-alieneval.lisp index 61aea07..1c421f1 100644 --- a/src/code/target-alieneval.lisp +++ b/src/code/target-alieneval.lisp @@ -235,7 +235,7 @@ (when (constantp size) (setf alien-type (copy-alien-array-type alien-type)) (setf (alien-array-type-dimensions alien-type) - (cons (eval size) (cdr dims))))) + (cons (constant-form-value size) (cdr dims))))) (dims (setf size (car dims))) (t diff --git a/src/compiler/constantp.lisp b/src/compiler/constantp.lisp new file mode 100644 index 0000000..41a69d6 --- /dev/null +++ b/src/compiler/constantp.lisp @@ -0,0 +1,213 @@ +;;;; 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) + diff --git a/src/compiler/info-functions.lisp b/src/compiler/info-functions.lisp index c835264..e47f287 100644 --- a/src/compiler/info-functions.lisp +++ b/src/compiler/info-functions.lisp @@ -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, diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index 5976435..70fdcfd 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -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)) diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 46f45e0..cb62ef5 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -406,7 +406,7 @@ bootstrapping. (if (consp s) (and (eq (car s) 'eql) (constantp (cadr s)) - (let ((sv (eval (cadr s)))) + (let ((sv (constant-form-value (cadr s)))) (or (interned-symbol-p sv) (integerp sv) (and (characterp sv) @@ -713,7 +713,7 @@ bootstrapping. (constant-value-p (and (null (cdr real-body)) (constantp (car real-body)))) (constant-value (and constant-value-p - (eval (car real-body)))) + (constant-form-value (car real-body)))) (plist (and constant-value-p (or (typep constant-value '(or number character)) @@ -953,7 +953,7 @@ bootstrapping. ;; broken if RESTP evaluates to a non-self-evaluating form. E.g. if ;; (INVOKE-EFFECTIVE-METHOD-FUNCTION EMF '(ERROR "gotcha") ...) ;; then TRACE-EMF-CALL-CALL-INTERNAL might die on a gotcha error. - (setq restp (eval restp)) + (setq restp (constant-form-value restp)) `(progn (trace-emf-call ,emf ,restp (list ,@required-args+rest-arg)) (cond ((typep ,emf 'fast-method-call) diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp index 68ab005..6db57f9 100644 --- a/src/pcl/ctor.lisp +++ b/src/pcl/ctor.lisp @@ -86,7 +86,7 @@ (defun constant-symbol-p (form) (and (constantp form) - (let ((constant (eval form))) + (let ((constant (constant-form-value form))) (and (symbolp constant) (not (null (symbol-package constant))))))) @@ -183,7 +183,7 @@ (loop for (key . more) on args by #'cddr do (when (or (null more) (not (constant-symbol-p key)) - (eq :allow-other-keys (eval key))) + (eq :allow-other-keys (constant-form-value key))) (return-from make-instance->constructor-call nil))))) (check-class) (check-args) @@ -192,7 +192,7 @@ ;; VALUE-FORMS. (multiple-value-bind (initargs value-forms) (loop for (key value) on args by #'cddr and i from 0 - collect (eval key) into initargs + collect (constant-form-value key) into initargs if (constantp value) collect value into initargs else @@ -200,7 +200,7 @@ and collect value into value-forms finally (return (values initargs value-forms))) - (let* ((class-name (eval class-name)) + (let* ((class-name (constant-form-value class-name)) (function-name (make-ctor-function-name class-name initargs))) ;; Prevent compiler warnings for calling the ctor. (proclaim-as-fun-name function-name) @@ -578,11 +578,12 @@ `(when (eq (clos-slots-ref .slots. ,i) +slot-unbound+) (setf (clos-slots-ref .slots. ,i) - ',(eval value))) + ',(constant-form-value value))) `(setf (clos-slots-ref .slots. ,i) - ',(eval value)))) + ',(constant-form-value value)))) (constant - `(setf (clos-slots-ref .slots. ,i) ',(eval value))))))) + `(setf (clos-slots-ref .slots. ,i) + ',(constant-form-value value))))))) ;; we are not allowed to modify QUOTEd locations, so we can't ;; generate code like (setf (cdr ',location) arg). Instead, ;; we have to do (setf (cdr .L0.) arg) and arrange for .L0. to @@ -595,7 +596,7 @@ collect location into locations collect `(setf (cdr ,name) ,(case type - (constant `',(eval value)) + (constant `',(constant-form-value value)) ((param var) `,value) (initfn `(funcall ,value)))) into class-init-forms diff --git a/src/pcl/defcombin.lisp b/src/pcl/defcombin.lisp index 4edc8bd..711696f 100644 --- a/src/pcl/defcombin.lisp +++ b/src/pcl/defcombin.lisp @@ -343,7 +343,8 @@ :format-arguments (list ',name)))) required-checks)) (loop (unless (and (constantp order) - (neq order (setq order (eval order)))) + (neq order (setq order + (constant-form-value order)))) (return t))) (push (cond ((eq order :most-specific-first) `(setq ,name (nreverse ,name))) diff --git a/src/pcl/fngen.lisp b/src/pcl/fngen.lisp index 0017ce0..8491082 100644 --- a/src/pcl/fngen.lisp +++ b/src/pcl/fngen.lisp @@ -60,8 +60,7 @@ (compute-constants lambda constant-converter))) (defun default-constantp (form) - (and (constantp form) - (not (typep (eval form) '(or symbol fixnum))))) + (constant-typep form '(not (or symbol fixnum)))) (defun default-test-converter (form) (if (default-constantp form) @@ -75,7 +74,7 @@ (defun default-constant-converter (form) (if (default-constantp form) - (list (eval form)) + (list (constant-form-value form)) nil)) ;;; *FGENS* is a list of all the function generators we have so far. Each diff --git a/src/pcl/macros.lisp b/src/pcl/macros.lisp index f676758..3060a06 100644 --- a/src/pcl/macros.lisp +++ b/src/pcl/macros.lisp @@ -137,11 +137,10 @@ symbol &optional (errorp t) environment) (declare (ignore environment)) (if (and (constantp symbol) - (legal-class-name-p (eval symbol)) + (legal-class-name-p (setf symbol (constant-form-value symbol))) (constantp errorp) (member *boot-state* '(braid complete))) - (let ((symbol (eval symbol)) - (errorp (not (null (eval errorp)))) + (let ((errorp (not (null (constant-form-value errorp)))) (class-cell (make-symbol "CLASS-CELL"))) `(let ((,class-cell (load-time-value (find-class-cell ',symbol)))) (or (find-class-cell-class ,class-cell) diff --git a/src/pcl/slots-boot.lisp b/src/pcl/slots-boot.lisp index e23b889..aee9ea0 100644 --- a/src/pcl/slots-boot.lisp +++ b/src/pcl/slots-boot.lisp @@ -48,7 +48,7 @@ (defmacro accessor-slot-value (object slot-name) (aver (constantp slot-name)) - (let* ((slot-name (eval slot-name)) + (let* ((slot-name (constant-form-value slot-name)) (reader-name (slot-reader-name slot-name))) `(let ((.ignore. (load-time-value (ensure-accessor 'reader ',reader-name ',slot-name)))) @@ -60,7 +60,7 @@ (aver (constantp slot-name)) (setq object (macroexpand object env)) (setq slot-name (macroexpand slot-name env)) - (let* ((slot-name (eval slot-name)) + (let* ((slot-name (constant-form-value slot-name)) (bindings (unless (or (constantp new-value) (atom new-value)) (let ((object-var (gensym))) (prog1 `((,object-var ,object)) @@ -80,7 +80,7 @@ (defmacro accessor-slot-boundp (object slot-name) (aver (constantp slot-name)) - (let* ((slot-name (eval slot-name)) + (let* ((slot-name (constant-form-value slot-name)) (boundp-name (slot-boundp-name slot-name))) `(let ((.ignore. (load-time-value (ensure-accessor 'boundp ',boundp-name ',slot-name)))) diff --git a/src/pcl/slots.lisp b/src/pcl/slots.lisp index 6b7b120..2e3d358 100644 --- a/src/pcl/slots.lisp +++ b/src/pcl/slots.lisp @@ -90,7 +90,7 @@ (define-compiler-macro slot-value (&whole form object slot-name) (if (and (constantp slot-name) - (interned-symbol-p (eval slot-name))) + (interned-symbol-p (constant-form-value slot-name))) `(accessor-slot-value ,object ,slot-name) form)) @@ -105,7 +105,7 @@ (define-compiler-macro set-slot-value (&whole form object slot-name new-value) (if (and (constantp slot-name) - (interned-symbol-p (eval slot-name))) + (interned-symbol-p (constant-form-value slot-name))) `(accessor-set-slot-value ,object ,slot-name ,new-value) form)) @@ -120,7 +120,7 @@ (define-compiler-macro slot-boundp (&whole form object slot-name) (if (and (constantp slot-name) - (interned-symbol-p (eval slot-name))) + (interned-symbol-p (constant-form-value slot-name))) `(accessor-slot-boundp ,object ,slot-name) form)) diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp index 7c307f0..b29655f 100644 --- a/src/pcl/vector.lisp +++ b/src/pcl/vector.lisp @@ -586,7 +586,7 @@ (when (and class-name (not (eq class-name t))) (position parameter-or-nil slots :key #'car)))))) (if (constantp form) - (let ((form (eval form))) + (let ((form (constant-form-value form))) (if (symbolp form) form *unspecific-arg*)) @@ -630,8 +630,9 @@ ;;; It is safe for these two functions to be wrong. They just try to ;;; guess what the most likely case will be. (defun generate-fast-class-slot-access-p (class-form slot-name-form) - (let ((class (and (constantp class-form) (eval class-form))) - (slot-name (and (constantp slot-name-form) (eval slot-name-form)))) + (let ((class (and (constantp class-form) (constant-form-value class-form))) + (slot-name (and (constantp slot-name-form) + (constant-form-value slot-name-form)))) (and (eq *boot-state* 'complete) (standard-class-p class) (not (eq class *the-class-t*)) ; shouldn't happen, though. @@ -639,8 +640,9 @@ (and slotd (eq :class (slot-definition-allocation slotd))))))) (defun skip-fast-slot-access-p (class-form slot-name-form type) - (let ((class (and (constantp class-form) (eval class-form))) - (slot-name (and (constantp slot-name-form) (eval slot-name-form)))) + (let ((class (and (constantp class-form) (constant-form-value class-form))) + (slot-name (and (constantp slot-name-form) + (constant-form-value slot-name-form)))) (and (eq *boot-state* 'complete) (standard-class-p class) (not (eq class *the-class-t*)) ; shouldn't happen, though. diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index e2eac2f..1a4a58c 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -1977,3 +1977,5 @@ (declare (optimize (safety 3) (space 3) (compilation-speed 3) (speed 0) (debug 1))) (not (not (logbitp 0 (floor 2147483651 (min -23 0)))))))))) + + diff --git a/tests/eval.impure.lisp b/tests/eval.impure.lisp index 9dfbc14..6b6293d 100644 --- a/tests/eval.impure.lisp +++ b/tests/eval.impure.lisp @@ -100,6 +100,46 @@ (assert (constantp (find-class 'symbol))) (assert (constantp #p"")) +;;; More CONSTANTP tests +;;; form constantp sb-int:constant-form-value +(dolist (test '((t t t) + (x nil) + ('x t x) + (:keyword t :keyword) + (42 t 42) + ((if t :ok x) t :ok) + ((if t x :no) nil) + ((progn + (error "oops") + t) nil) + ((progn 1 2 3) t 3) + ((block foo :good) t :good) + ((block foo + (return-from foo t)) nil) + ((progv + (list (gensym)) + '(1) + (+ 1)) nil) + ((progv + '(x) + (list (random 2)) + x) nil) + ((progv + '(x) + '(1) + (1+ x)) t 2) + ((unwind-protect 1 nil) t 1) + ((unwind-protect 1 + (xxx)) nil) + ((the integer 1) t 1) + ((the integer (+ 1 1)) t 2) + ((the integer (foo)) nil) + ((+ 1 2) t 3))) + (destructuring-bind (form c &optional v) test + (assert (eql (constantp form) c)) + (when c + (assert (eql v (sb-int:constant-form-value form)))))) + ;;; DEFPARAMETER must assign a dynamic variable (let ((var (gensym))) (assert (equal (eval `(list (let ((,var 1)) diff --git a/version.lisp-expr b/version.lisp-expr index fcca4e2..a0cb646 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.9.10.3" +"0.9.10.4" -- 1.7.10.4