1.0.27.43: constant coalescing agreement fixes

Constant coalescing decisions, legitimately differing between different
hosts, can if not very careful propagate into the target, often through
vop-parse structures.  Be explicit in which constants can be shared and
which shouldn't.

5 messages follow:

constant coalescing KLUDGE, part 1 [(any)]

The constant initforms for the vop-parse structure are evaluated on the
host; therefore, their coalescing is at the host's discretion.  This
wouldn't matter except that (why?) vop-parse structures get dumped
at each vop definition.  Make the coalescedness explicit.

constant coalescing KLUDGE, part 2: [(fixnumize n)]

The static function template for at least LENGTH (in subprim.lisp)
contains two instances of (FIXNUMIZE 2), which are coaelesced
differently on different host lisps.  We can KLUDGE around this problem
(and gain a millimetric amount of efficiency, too!) by evaluating the
FIXNUMIZE calls at expansion time.

remove confusing code structure sharing from DEF-MOVE-IF

I can't actually see exactly where the code structure sharing happens
nor why it causes xc fasl contents to differ between hosts, but since
it makes the code clearer to rewrite the macro...

fix two separate issues in compiler/globaldb

One is a hash-table traversal issue; the other is coalescing of
constants.  I *think* what's going on in the latter case is that there
are two separate ways that shared constants can happen.  One is in the
dumping of objects which are EQUAL, where the compiler can dump a
reference to a previous object instead; the other is the dumping of a
single object with circularities, where a nil is dumped along with a
later instruction to backpatch the circularity in.  We need to ensure a
deterministic cold-init-form, so that means we need to control the
coalescing in the _host_ compiler (because the cold-init-form is
generated from introspection), but of course we can't, so we COPY-TREE
instead, which will allow the xc to coalesce and will prevent the form
as compiled from sharing structure.

Static function template vop macro has a common subexpression, factored
out as new-ebp-ea.

diff --git a/src/compiler/globaldb.lisp b/src/compiler/globaldb.lisp
index 202893c..50a425e 100644 (file)
--- a/src/compiler/globaldb.lisp
+++ b/src/compiler/globaldb.lisp
@@ -302,16 +302,15 @@
                   (new-type-info
                    (make-type-info :name ',type
                                    :class class-info
-                                   :number new-type-number)))
+                                   :number new-type-number
+                                   :type ',type-spec)))
              (setf (aref *info-types* new-type-number) new-type-info)
              (push new-type-info (class-info-types class-info)))))
-       ;; Arrange for TYPE-INFO-DEFAULT and TYPE-INFO-TYPE to be set
-       ;; at cold load time. (They can't very well be set at
-       ;; cross-compile time, since they differ between the
-       ;; cross-compiler and the target. The DEFAULT slot values
-       ;; differ because they're compiled closures, and the TYPE slot
-       ;; values differ in the use of SB!XC symbols instead of CL
-       ;; symbols.)
+       ;; Arrange for TYPE-INFO-DEFAULT and
+       ;; TYPE-INFO-VALIDATE-FUNCTION to be set at cold load
+       ;; time. (They can't very well be set at cross-compile time,
+       ;; since they differ between host and target and are
+       ;; host-compiled closures.)
        (push `(let ((type-info (type-info-or-lose ,',class ,',type)))
                 (setf (type-info-validate-function type-info)
                       ,',validate-function)
@@ -326,8 +325,7 @@
                        ;; NIL) instead of full-blown (LAMBDA (X) NIL).
                        (lambda (name)
                          (declare (ignorable name))
-                         ,',default))
-                (setf (type-info-type type-info) ',',type-spec))
+                         ,',default)))
              *!reversed-type-info-init-forms*))
      ',type))
 
@@ -1299,14 +1297,14 @@
 (!cold-init-forms
   (/show0 "beginning *INFO-CLASSES* init, calling MAKE-HASH-TABLE")
   (setf *info-classes*
-        (make-hash-table :test 'eq :size #.(hash-table-size *info-classes*)))
+        (make-hash-table :test 'eq :size #.(* 2 (hash-table-count *info-classes*))))
   (/show0 "done with MAKE-HASH-TABLE in *INFO-CLASSES* init")
   (dolist (class-info-name '#.(let ((result nil))
                                 (maphash (lambda (key value)
                                            (declare (ignore value))
                                            (push key result))
                                          *info-classes*)
-                                result))
+                                (sort result #'string<)))
     (let ((class-info (make-class-info class-info-name)))
       (setf (gethash class-info-name *info-classes*)
             class-info)))
@@ -1332,7 +1330,14 @@
                          (list (type-info-name info-type)
                                (class-info-name (type-info-class info-type))
                                (type-info-number info-type)
-                               (type-info-type info-type))))
+                               ;; KLUDGE: for repeatable xc fasls, to
+                               ;; avoid different cross-compiler
+                               ;; treatment of equal constants here we
+                               ;; COPY-TREE, which is not in general a
+                               ;; valid identity transformation
+                               ;; [e.g. on (EQL (FOO))] but is OK for
+                               ;; all the types we use here.
+                               (copy-tree (type-info-type info-type)))))
                      *info-types*)))
   (/show0 "done with *INFO-TYPES* initialization"))
 

diff --git a/src/compiler/meta-vmdef.lisp b/src/compiler/meta-vmdef.lisp
index b7318fe..6fe1a05 100644 (file)
--- a/src/compiler/meta-vmdef.lisp
+++ b/src/compiler/meta-vmdef.lisp
@@ -417,8 +417,8 @@
   (note nil :type (or string null))
   ;; a list of the names of the Effects and Affected attributes for
   ;; this VOP
-  (effects '(any) :type list)
-  (affected '(any) :type list)
+  (effects '#1=(any) :type list)
+  (affected '#1# :type list)
   ;; a list of the names of functions this VOP is a translation of and
   ;; the policy that allows this translation to be done. :FAST is a
   ;; safe default, since it isn't a safe policy.

diff --git a/src/compiler/x86/pred.lisp b/src/compiler/x86/pred.lisp
index 73a6f8d..f7bb241 100644 (file)
--- a/src/compiler/x86/pred.lisp
+++ b/src/compiler/x86/pred.lisp
@@ -134,33 +134,25 @@
          (setf then temp))
        (inst cmov (first flags) res then))))
 
-(macrolet ((def-move-if (name type reg &optional stack)
-               (when stack (setf stack (list stack)))
-
+(macrolet ((def-move-if (name type reg stack)
                `(define-vop (,name move-if)
-                  (:args (then :scs (immediate ,reg ,@stack) :to :eval
+                  (:args (then :scs (immediate ,reg ,stack) :to :eval
                                :target temp
                                :load-if (not (or (sc-is then immediate)
-                                                 (and (sc-is then ,@stack)
+                                                 (and (sc-is then ,stack)
                                                       (not (location= else res))))))
-                         (else :scs (immediate ,reg ,@stack) :target res
-                               :load-if (not (sc-is else immediate ,@stack))))
+                         (else :scs (immediate ,reg ,stack) :target res
+                               :load-if (not (sc-is else immediate ,stack))))
                   (:arg-types ,type ,type)
                   (:results (res :scs (,reg)
                                  :from (:argument 1)))
                   (:result-types ,type))))
-  (def-move-if move-if/t
-      t descriptor-reg control-stack)
-  (def-move-if move-if/fx
-      tagged-num any-reg control-stack)
-  (def-move-if move-if/unsigned
-      unsigned-num unsigned-reg unsigned-stack)
-  (def-move-if move-if/signed
-      signed-num signed-reg signed-stack)
-  (def-move-if move-if/char
-      character character-reg character-stack)
-  (def-move-if move-if/sap
-      system-area-pointer sap-reg sap-stack))
+  (def-move-if move-if/t t descriptor-reg control-stack)
+  (def-move-if move-if/fx tagged-num any-reg control-stack)
+  (def-move-if move-if/unsigned unsigned-num unsigned-reg unsigned-stack)
+  (def-move-if move-if/signed signed-num signed-reg signed-stack)
+  (def-move-if move-if/char character character-reg character-stack)
+  (def-move-if move-if/sap system-area-pointer sap-reg sap-stack))
 
 \f
 ;;;; conditional VOPs

diff --git a/src/compiler/x86/static-fn.lisp b/src/compiler/x86/static-fn.lisp
index 42433bf..ba7a40e 100644 (file)
--- a/src/compiler/x86/static-fn.lisp
+++ b/src/compiler/x86/static-fn.lisp
@@ -39,7 +39,11 @@
     (error "either too many args (~W) or too many results (~W); max = ~W"
            num-args num-results register-arg-count))
   (let ((num-temps (max num-args num-results))
-        (node (sb!xc:gensym "NODE")))
+        (node (sb!xc:gensym "NODE"))
+        (new-ebp-ea
+         '(make-ea :dword
+           :disp (frame-byte-offset (+ sp->fp-offset -3 ocfp-save-offset))
+           :base esp-tn)))
     (collect ((temp-names) (temps) (arg-names) (args) (result-names) (results))
       (dotimes (i num-results)
         (let ((result-name (intern (format nil "RESULT-~D" i))))
@@ -78,26 +82,17 @@
          ;; effect of the ENTER with discrete instructions. Takes
          ;; 3+4+4=11 bytes as opposed to 1+4=5 bytes.
          (cond ((policy ,node (>= speed space))
-                (inst sub esp-tn (fixnumize 3))
-                (inst mov (make-ea :dword :base esp-tn
-                                   :disp (frame-byte-offset
-                                          (+ sp->fp-offset
-                                             -3
-                                             ocfp-save-offset)))
-                      ebp-tn)
-                (inst lea ebp-tn (make-ea :dword :base esp-tn
-                                          :disp (frame-byte-offset
-                                                 (+ sp->fp-offset
-                                                    -3
-                                                    ocfp-save-offset)))))
+                (inst sub esp-tn ,(fixnumize 3))
+                (inst mov ,new-ebp-ea ebp-tn)
+                (inst lea ebp-tn ,new-ebp-ea))
                (t
                 ;; Dummy for return address.
                 (inst push ebp-tn)
-                (inst enter (fixnumize 1))))
+                (inst enter ,(fixnumize 1))))
 
          ,(if (zerop num-args)
               '(inst xor ecx ecx)
-              `(inst mov ecx (fixnumize ,num-args)))
+              `(inst mov ecx ,(fixnumize num-args)))
 
          (note-this-location vop :call-site)
          ;; Old CMU CL comment:

diff --git a/version.lisp-expr b/version.lisp-expr
index a710b05..1f4b0fe 100644 (file)
--- 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".)
-"1.0.27.42"
+"1.0.27.43"