0.7.1.47:

[sbcl.git] / src / compiler / generic / genesis.lisp

diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp
index b803202..0e20313 100644 (file)
--- a/src/compiler/generic/genesis.lisp
+++ b/src/compiler/generic/genesis.lisp
@@ -1008,8 +1008,8 @@
 (defvar *cold-package-symbols*)
 (declaim (type list *cold-package-symbols*))
 
-;;; a map from descriptors to symbols, so that we can back up. The key is the
-;;; address in the target core.
+;;; a map from descriptors to symbols, so that we can back up. The key
+;;; is the address in the target core.
 (defvar *cold-symbols*)
 (declaim (type hash-table *cold-symbols*))
 
@@ -1035,7 +1035,12 @@
   ;; need is SB!KERNEL:%BYTE-BLT.
   (let ((package-name (package-name package)))
     (cond ((find package-name '("COMMON-LISP" "KEYWORD") :test #'string=)
-          ;; That's OK then.
+          ;; Cold interning things in these standard packages is OK.
+          ;; (Cold interning things in the other standard package,
+          ;; CL-USER, isn't OK. We just use CL-USER to expose symbols
+          ;; whose homes are in other packages. Thus, trying to cold
+          ;; intern a symbol whose home package is CL-USER probably
+          ;; means that a coding error has been made somewhere.)
           (values))
          ((string= package-name "SB!" :end1 3 :end2 3)
           ;; That looks OK, too. (All the target-code packages
@@ -1044,9 +1049,10 @@
          (t
           ;; looks bad: maybe COMMON-LISP-USER? maybe an extension
           ;; package in the xc host? something we can't think of
-          ;; a valid reason to dump, anyway...
-          (bug "internal error: PACKAGE-NAME=~S looks too much like a typo."
-               package-name))))
+          ;; a valid reason to cold intern, anyway...
+          (error ; not #'BUG, because #'BUG isn't defined yet
+           "internal error: PACKAGE-NAME=~S looks too much like a typo."
+           package-name))))
 
   (let (;; Information about each cold-interned symbol is stored
        ;; in COLD-INTERN-INFO.
@@ -1612,11 +1618,7 @@
       (:alpha
         (ecase kind
          (:jmp-hint
-          (assert (zerop (ldb (byte 2 0) value)))
-          #+nil ;; was commented out in cmucl source too.  Don't know what
-          ;; it does   -dan 2001.05.03
-           (setf (sap-ref-16 sap 0)
-                (logior (sap-ref-16 sap 0) (ldb (byte 14 0) (ash value -2)))))
+          (assert (zerop (ldb (byte 2 0) value))))
         (:bits-63-48
          (let* ((value (if (logbitp 15 value) (+ value (ash 1 16)) value))
                 (value (if (logbitp 31 value) (+ value (ash 1 32)) value))
@@ -1643,6 +1645,20 @@
                 (ldb (byte 8 0) value)
                 (byte-vector-ref-8 gspace-bytes (1+ gspace-byte-offset))
                 (ldb (byte 8 8) value)))))
+      (:ppc
+       (ecase kind
+         (:ba
+          (setf (byte-vector-ref-32 gspace-bytes gspace-byte-offset)
+                (dpb (ash value -2) (byte 24 2) 
+                     (byte-vector-ref-32 gspace-bytes gspace-byte-offset))))
+         (:ha
+          (let* ((h (ldb (byte 16 16) value))
+                 (l (ldb (byte 16 0) value)))
+            (setf (byte-vector-ref-16 gspace-bytes (+ gspace-byte-offset 2))
+                  (if (logbitp 15 l) (ldb (byte 16 0) (1+ h)) h))))
+         (:l
+          (setf (byte-vector-ref-16 gspace-bytes (+ gspace-byte-offset 2))
+                (ldb (byte 16 0) value)))))     
       (:sparc
        (ecase kind
         (:call
@@ -2654,6 +2670,18 @@
                   i)))))
   (terpri)
 
+  ;; FIXME: The SPARC has a PSEUDO-ATOMIC-TRAP that differs between
+  ;; platforms. If we export this from the SB!VM package, it gets
+  ;; written out as #define trap_PseudoAtomic, which is confusing as
+  ;; the runtime treats trap_ as the prefix for illegal instruction
+  ;; type things. We therefore don't export it, but instead do
+  (when (boundp 'sb!vm::pseudo-atomic-trap)
+    (format t "#define PSEUDO_ATOMIC_TRAP ~D /* 0x~:*~X */~%" sb!vm::pseudo-atomic-trap)
+    (terpri))
+  ;; possibly this is another candidate for a rename (to
+  ;; pseudo-atomic-trap-number or pseudo-atomic-magic-constant
+  ;; [possibly applicable to other platforms])
+
   ;; writing primitive object layouts
   (let ((structs (sort (copy-list sb!vm:*primitive-objects*) #'string<
                       :key (lambda (obj)