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.

diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp
index 01ed4b2..2a7cebe 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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"