X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fgenesis.lisp;h=a381dfd4814227d2d49c159678a0e79540016e11;hb=a02f19f746ef4808147de0d3d72700eb06b2253c;hp=8d6a047d59c184bc95bd92378f1301325fafcb01;hpb=31f072311935e32751508ecf824905c6b58a1d95;p=sbcl.git

diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp
index 8d6a047..a381dfd 100644
--- a/src/compiler/generic/genesis.lisp
+++ b/src/compiler/generic/genesis.lisp
@@ -924,22 +924,17 @@ core and return a descriptor to it."
             ;; the target Lisp's (RANDOM-LAYOUT-CLOS-HASH) sequence
             ;; and show up as the CLOS-HASH value of some other
             ;; LAYOUT.
-            ;;
-            ;; FIXME: This expression here can generate a zero value,
-            ;; and the CMU CL code goes out of its way to generate
-            ;; strictly positive values (even though the field is
-            ;; declared as an INDEX). Check that it's really OK to
-            ;; have zero values in the CLOS-HASH slots.
-            (hash-value (mod (logxor (logand   (random-layout-clos-hash) 15253)
-                                     (logandc2 (random-layout-clos-hash) 15253)
-                                     1)
-                             ;; (The MOD here is defensive programming
-                             ;; to make sure we never write an
-                             ;; out-of-range value even if some joker
-                             ;; sets LAYOUT-CLOS-HASH-MAX to other
-                             ;; than 2^n-1 at some time in the
-                             ;; future.)
-                             (1+ sb!kernel:layout-clos-hash-max))))
+            (hash-value
+             (1+ (mod (logxor (logand   (random-layout-clos-hash) 15253)
+                              (logandc2 (random-layout-clos-hash) 15253)
+                              1)
+                      ;; (The MOD here is defensive programming
+                      ;; to make sure we never write an
+                      ;; out-of-range value even if some joker
+                      ;; sets LAYOUT-CLOS-HASH-MAX to other
+                      ;; than 2^n-1 at some time in the
+                      ;; future.)
+                      sb!kernel:layout-clos-hash-max))))
         (write-wordindexed result
                            (+ i sb!vm:instance-slots-offset 1)
                            (make-fixnum-descriptor hash-value))))
@@ -1265,6 +1260,7 @@ core and return a descriptor to it."
                           (cold-fdefinition-object (cold-intern ',symbol)))))
     (frob sub-gc)
     (frob internal-error)
+    #!+win32 (frob handle-win32-exception)
     (frob sb!kernel::control-stack-exhausted-error)
     (frob sb!kernel::undefined-alien-variable-error)
     (frob sb!kernel::undefined-alien-function-error)
@@ -1769,20 +1765,29 @@ core and return a descriptor to it."
                 (logior (mask-field (byte 16 16)
                                     (bvref-32 gspace-bytes gspace-byte-offset))
                         (ldb (byte 16 0) value))))))
+       ;; FIXME: PowerPC Fixups are not fully implemented. The bit
+       ;; here starts to set things up to work properly, but there
+       ;; needs to be corresponding code in ppc-vm.lisp
        (:ppc
-       (ecase kind
-         (:ba
-          (setf (bvref-32 gspace-bytes gspace-byte-offset)
-                (dpb (ash value -2) (byte 24 2)
-                     (bvref-32 gspace-bytes gspace-byte-offset))))
-         (:ha
-          (let* ((h (ldb (byte 16 16) value))
-                 (l (ldb (byte 16 0) value)))
-            (setf (bvref-16 gspace-bytes (+ gspace-byte-offset 2))
-                  (if (logbitp 15 l) (ldb (byte 16 0) (1+ h)) h))))
-         (:l
-          (setf (bvref-16 gspace-bytes (+ gspace-byte-offset 2))
-                (ldb (byte 16 0) value)))))
+        (ecase kind
+          (:ba
+           (setf (bvref-32 gspace-bytes gspace-byte-offset)
+                 (dpb (ash value -2) (byte 24 2)
+                      (bvref-32 gspace-bytes gspace-byte-offset))))
+          (:ha
+           (let* ((un-fixed-up (bvref-16 gspace-bytes
+                                         (+ gspace-byte-offset 2)))
+                  (fixed-up (+ un-fixed-up value))
+                  (h (ldb (byte 16 16) fixed-up))
+                  (l (ldb (byte 16 0) fixed-up)))
+             (setf (bvref-16 gspace-bytes (+ gspace-byte-offset 2))
+                   (if (logbitp 15 l) (ldb (byte 16 0) (1+ h)) h))))
+          (:l
+           (let* ((un-fixed-up (bvref-16 gspace-bytes
+                                         (+ gspace-byte-offset 2)))
+                  (fixed-up (+ un-fixed-up value)))
+             (setf (bvref-16 gspace-bytes (+ gspace-byte-offset 2))
+                   (ldb (byte 16 0) fixed-up))))))
       (:sparc
        (ecase kind
          (:call