From 25e76ec2b1083ac6a4bba42af7ad7b5a8239f2b8 Mon Sep 17 00:00:00 2001 From: Alexey Dejneka Date: Sun, 26 Jan 2003 06:38:09 +0000 Subject: [PATCH] 0.7.12.1: * Replace TRULY-THE with THE in inline structure slot accessors when they may be not initialized; * treat known function bindings as constant; * CHANGE-REF-LEAF: mark the substitution as used. --- src/code/defstruct.lisp | 42 ++++++++++++++++++++++-------------------- src/compiler/ir1opt.lisp | 10 ++++++---- src/compiler/ir1util.lisp | 1 + tests/defstruct.impure.lisp | 23 ++++++++++++++++++++--- version.lisp-expr | 2 +- 5 files changed, 50 insertions(+), 28 deletions(-) diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index 01ed4b2..2a7cebe 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -175,7 +175,7 @@ (:copier nil) #-sb-xc-host (:pure t)) ;; string name of slot - %name + %name ;; its position in the implementation sequence (index (missing-arg) :type fixnum) ;; the name of the accessor function @@ -187,6 +187,8 @@ (accessor-name nil) default ; default value expression (type t) ; declared type specifier + (safe-p t :type boolean) ; whether the slot is known to be + ; always of the specified type ;; If this object does not describe a raw slot, this value is T. ;; ;; If this object describes a raw slot, this value is the type of the @@ -235,11 +237,11 @@ ;; What operator is used (on the raw data vector) to access a slot ;; of this type? (accessor-name (missing-arg) :type symbol :read-only t) - ;; How many words are each value of this type? (This is used to + ;; How many words are each value of this type? (This is used to ;; rescale the offset into the raw data vector.) (n-words (missing-arg) :type (and index (integer 1)) :read-only t)) - (defvar *raw-slot-data-list* + (defvar *raw-slot-data-list* (list ;; The compiler thinks that the raw data vector is a vector of ;; word-sized unsigned bytes, so if the slot we want to access @@ -888,17 +890,16 @@ ;;; and writer functions of the slot described by DSD. (defun slot-accessor-inline-expansion-designators (dd dsd) (let ((instance-type-decl `(declare (type ,(dd-name dd) instance))) - (accessor-place-form (%accessor-place-form dd dsd 'instance)) - (dsd-type (dsd-type dsd))) - (values (lambda () - `(lambda (instance) - ,instance-type-decl - (truly-the ,dsd-type ,accessor-place-form))) - (lambda () - `(lambda (new-value instance) - (declare (type ,dsd-type new-value)) - ,instance-type-decl - (setf ,accessor-place-form new-value)))))) + (accessor-place-form (%accessor-place-form dd dsd 'instance)) + (dsd-type (dsd-type dsd)) + (value-the (if (dsd-safe-p dsd) 'truly-the 'the))) + (values (lambda () `(lambda (instance) + ,instance-type-decl + (,value-the ,dsd-type ,accessor-place-form))) + (lambda () `(lambda (new-value instance) + (declare (type ,dsd-type new-value)) + ,instance-type-decl + (setf ,accessor-place-form new-value)))))) ;;; Return a LAMBDA form which can be used to set a slot. (defun slot-setter-lambda-form (dd dsd) @@ -1398,10 +1399,11 @@ (arglist) (vars) (types) (loop for slot in (dd-slots defstruct) for name = (dsd-name slot) - collect (if (find name (skipped-vars) :test #'string=) - '.do-not-initialize-slot. - (or (find (dsd-name slot) (vars) :test #'string=) - (dsd-default slot)))))))) + collect (cond ((find name (skipped-vars) :test #'string=) + (setf (dsd-safe-p slot) nil) + '.do-not-initialize-slot.) + ((or (find (dsd-name slot) (vars) :test #'string=) + (dsd-default slot))))))))) ;;; Grovel the constructor options, and decide what constructors (if ;;; any) to create. @@ -1461,7 +1463,7 @@ ;;;; main DEFSTRUCT macro. Hopefully it will go away presently ;;;; (perhaps when CL:CLASS and SB-PCL:CLASS meet) as per FIXME below. ;;;; -- WHN 2001-10-28 -;;;; +;;;; ;;;; FIXME: There seems to be no good reason to shoehorn CONDITION, ;;;; STANDARD-INSTANCE, and GENERIC-FUNCTION into mutated structures ;;;; instead of just implementing them as primitive objects. (This @@ -1585,7 +1587,7 @@ ,slot-name))) slot-names) ,object-gensym)) - + ;; predicate ,@(when predicate ;; Just delegate to the compiler's type optimization diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index e2abea6..02b8340 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -1322,12 +1322,14 @@ (null (lambda-var-sets leaf))) (defined-fun (not (eq (defined-fun-inlinep leaf) :notinline))) - #!+(and (not sb-fluid) (not sb-xc-host)) (global-var (case (global-var-kind leaf) - (:global-function (let ((name (leaf-source-name leaf))) - (eq (symbol-package (fun-name-block-name name)) - *cl-package*)))))))) + (:global-function + (let ((name (leaf-source-name leaf))) + (or #-sb-xc-host + (eq (symbol-package (fun-name-block-name name)) + *cl-package*) + (info :function :info name))))))))) ;;; If we have a non-set LET var with a single use, then (if possible) ;;; replace the variable reference's CONT with the arg continuation. diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index cbc5d9f..4988282 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -1246,6 +1246,7 @@ (push ref (leaf-refs leaf)) (delete-ref ref) (setf (ref-leaf ref) leaf) + (setf (leaf-ever-used leaf) t) (let ((ltype (leaf-type leaf))) (if (fun-type-p ltype) (setf (node-derived-type ref) ltype) diff --git a/tests/defstruct.impure.lisp b/tests/defstruct.impure.lisp index 3fe5c5e..ae949e9 100644 --- a/tests/defstruct.impure.lisp +++ b/tests/defstruct.impure.lisp @@ -26,10 +26,27 @@ ;;; An &AUX variable in a boa-constructor without a default value ;;; means "do not initialize slot" and does not cause type error (defstruct (boa-saux (:constructor make-boa-saux (&aux a (b 3) (c)))) - (a #\! :type (integer 1 2)) - (b #\? :type (integer 3 4)) - (c #\# :type (integer 5 6))) + (a #\! :type (integer 1 2)) + (b #\? :type (integer 3 4)) + (c #\# :type (integer 5 6))) (let ((s (make-boa-saux))) + (declare (notinline identity)) + #+nil ; bug 235a + (locally (declare (optimize (safety 3)) + (inline boa-saux-a)) + (assert (raises-error? (identity (boa-saux-a s)) type-error))) + (setf (boa-saux-a s) 1) + (setf (boa-saux-c s) 5) + (assert (eql (boa-saux-a s) 1)) + (assert (eql (boa-saux-b s) 3)) + (assert (eql (boa-saux-c s) 5))) + ; these two checks should be + ; kept separated +(let ((s (make-boa-saux))) + (declare (notinline identity)) + (locally (declare (optimize (safety 0)) + (inline boa-saux-a)) + (assert (eql (identity (boa-saux-a s)) 0))) (setf (boa-saux-a s) 1) (setf (boa-saux-c s) 5) (assert (eql (boa-saux-a s) 1)) diff --git a/version.lisp-expr b/version.lisp-expr index a7c6658..41e148f 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.7.12" +"0.7.12.1" -- 1.7.10.4