diff --git a/compiler/disassem.lisp b/compiler/disassem.lisp
index 7f196ac496e5a04a7c091b8c4d28af044f01365c..d0eebe780b89cecc61e3cae61c2e6d1b61929b5c 100644
--- a/compiler/disassem.lisp
+++ b/compiler/disassem.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/disassem.lisp,v 1.46 2005/02/07 17:27:16 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/disassem.lisp,v 1.47 2005/04/10 15:01:44 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -3205,8 +3205,13 @@
       #+sparc
       (progn
 	;; Initialize these to a sane value, just in case.
-	(setf sparc::*note-sethi-inst* nil)
-	(setf sparc::*pseudo-atomic-set* nil))
+	(setf vm::*note-sethi-inst* nil)
+	(setf vm::*pseudo-atomic-set* nil))
+      #+ppc
+      (progn
+	;; Initialize these to a sane value, just in case.
+	(setf vm::*note-addis-inst* nil)
+	(setf vm::*pseudo-atomic-set* nil))
       (dolist (seg segments)
 	(disassemble-segment seg stream dstate)))))
 
diff --git a/compiler/ppc/insts.lisp b/compiler/ppc/insts.lisp
index a47e41dee6ba1df6b2fa091ce9b302463f102d26..52f743c2d80f0a3af18f68a478c812169ff14706 100644
--- a/compiler/ppc/insts.lisp
+++ b/compiler/ppc/insts.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/insts.lisp,v 1.9 2005/04/10 02:15:52 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/insts.lisp,v 1.10 2005/04/10 15:01:45 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -83,11 +83,83 @@
 		 (t (make-symbol (concatenate 'string "$" name)))))
        *register-names*))
 
+(defun get-reg-name (index)
+  (if *disassem-use-lisp-reg-names*
+      (aref reg-symbols index)
+    (format nil "~A~D" 'r index)))
+
+(macrolet
+    ((frob (&rest names)
+       (let ((results (mapcar #'(lambda (n)
+				  (let ((nn (intern (concatenate 'string (string n)
+								 "-TYPE"))))
+				    `(,(eval nn) ,nn)))
+			      names)))
+	 `(eval-when (compile load eval)
+	   (defconstant header-word-type-alist
+	     ',results)))))
+  ;; This is the same list as in objdefs.
+  (frob bignum
+	ratio
+	single-float
+	double-float
+	#+long-float long-float
+	complex
+	complex-single-float
+	complex-double-float
+	#+long-float complex-long-float
+  
+	simple-array
+	simple-string
+	simple-bit-vector
+	simple-vector
+	simple-array-unsigned-byte-2
+	simple-array-unsigned-byte-4
+	simple-array-unsigned-byte-8
+	simple-array-unsigned-byte-16
+	simple-array-unsigned-byte-32
+	simple-array-signed-byte-8
+	simple-array-signed-byte-16
+	simple-array-signed-byte-30
+	simple-array-signed-byte-32
+	simple-array-single-float
+	simple-array-double-float
+	#+long-float simple-array-long-float
+	simple-array-complex-single-float
+	simple-array-complex-double-float
+	#+long-float simple-array-complex-long-float
+	complex-string
+	complex-bit-vector
+	complex-vector
+	complex-array
+  
+	code-header
+	function-header
+	closure-header
+	funcallable-instance-header
+	byte-code-function
+	byte-code-closure
+	dylan-function-header
+	closure-function-header
+	#-gengc return-pc-header
+	#+gengc forwarding-pointer
+	value-cell-header
+	symbol-header
+	base-char
+	sap
+	unbound-marker
+	weak-pointer
+	instance-header
+	fdefn
+	#+(or gengc gencgc) scavenger-hook))
+
 (defvar *note-addis-inst* nil
   "An alist for the disassembler indicating the target register and
 value used in an ADDIS instruction.  This is used to make annotations
 about function addresses and register values.")
 
+(defvar *pseudo-atomic-set* nil)
+
 (defun handle-ld/st-inst (reg word dstate)
   (let ((ra (ldb (byte 5 16) word))
 	(d (ldb (byte 16 0) word)))
@@ -104,16 +176,75 @@ about function addresses and register values.")
 	     (disassem:maybe-note-static-function d dstate)))))))
 
 (defun handle-addi-inst (reg word dstate)
-  (let ((ra (ldb (byte 5 16) word))
+  (let ((rt (ldb (byte 5 21) word))
+	(ra (ldb (byte 5 16) word))
 	(d (ldb (byte 16 0) word)))
     (when (= reg ra)
-      (case ra
-	(18
-	 ;; An ADDI rt, $NULL, <n> instruction.  This a
-	 ;; reference to a static symbol.
-	 (disassem::maybe-note-nil-indexed-object d dstate))))))
-
-(defun handle-addis-inst (reg word state)
+      (let ((addis (assoc ra *note-addis-inst*)))
+	(cond
+	 (addis
+	  ;; RA was used in a ADDIS instruction.  Assume that this is
+	  ;; the offset part of the ADDIS instruction for a full
+	  ;; 32-bit address or value.  Make a note about this usage as
+	  ;; a Lisp assembly routine or a foreign routine.  If note,
+	  ;; just note the final value.
+	  (let ((addr (+ d (ash (cdr addis) 16))))
+	    (or (disassem::note-code-constant-absolute addr dstate)
+		(disassem::maybe-note-assembler-routine addr t dstate)
+		(disassem::note (format nil "~A = #x~8,'0X"
+					(get-reg-name rt) addr)
+				dstate)))
+	  ;; We're done with this ADDIS/ADDI instruction combination.
+	  ;; Remove ADDIS.
+	  (setf *note-addis-inst* (delete addis *note-addis-inst*)))
+	 ((= ra null-offset)
+	  ;; An ADDI rt, $NULL, <n> instruction.  This a
+	  ;; reference to a static symbol.
+	  (disassem::maybe-note-nil-indexed-object d dstate))
+	 ((= ra alloc-offset)
+	  ;; addi rt, $alloc, n.  This must be some allocation or
+	  ;; pseudo-atomic stuff.  Look at the pseudo-atomic macro to
+	  ;; make sure this is right.
+	  (cond ((and (= d 4)
+		      (= rt alloc-offset)
+		      (not *pseudo-atomic-set*))
+		 ;; "ADD $ALLOC, $ALLOC, 4" sets the PA flag
+		 (disassem:note "Set pseudo-atomic flag" dstate)
+		 (setf *pseudo-atomic-set*
+		       (sys:sap+ (disassem:dstate-segment-sap dstate)
+				 (disassem:dstate-cur-offs dstate))))
+		((and (= rt alloc-offset)
+		      *pseudo-atomic-set*
+		      (not (sys:sap= *pseudo-atomic-set*
+				     (sys:sap+ (disassem:dstate-segment-sap dstate)
+					       (disassem:dstate-cur-offs dstate)))))
+		 ;; "ADD $ALLOC, $ALLOC, n" is allocating space
+		 (disassem:note (format nil "Allocating ~D bytes" d)
+				dstate))))
+	 ((and (= ra zero-offset) *pseudo-atomic-set*)
+	  ;; "ADDI RT, $ZERO, n" inside a pseudo-atomic is very likely
+	  ;; loading up a header word.  Make a note to that effect.
+	  (let ((type (second (assoc (logand d #xff) header-word-type-alist)))
+		(size (ldb (byte 24 8) d)))
+	    (when type
+	      (disassem:note (format nil "Header word ~A, size ~D?" type size)
+			     dstate)))))))))
+
+(defun handle-add-inst (reg word dstate)
+  (let ((rt (ldb (byte 5 21) word))
+	(ra (ldb (byte 5 16) word)))
+    (when (and (= reg 6)
+	       (= rt alloc-offset)
+	       (= ra alloc-offset))
+      ;; We have "ADD $ALLOC, $ALLOC, $NL3".  This turns off
+      ;; pseudo-atomic.  (See the pseudo-atomic macro.)
+      (disassem:note "Reset pseudo-atomic flag" dstate)
+      (setf *pseudo-atomic-set* nil))))
+  
+(defun update-addis-notes (word)
+  ;; If this instruction writes to register that was the target of an
+  ;; ADDIS instruction, we should remove it from *note-addis-inst* so
+  ;; we don't get confused an print out erroneous notes.
   )
 
 ;; Look at the current instruction and see if we can't add some notes
@@ -135,13 +266,17 @@ about function addresses and register values.")
 
     (cond ((or (= 32 opcode)
 	       (= 36 opcode))
-	   ;; An LWZ or STW instruction.  Extract the target and src
-	   ;; register and the offset.
+	   ;; An LWZ or STW instruction.
 	   (handle-ld/st-inst reg word dstate))
-	  ((= 14 opcode)
-	   ;; An ADDI instruction.  Extract the target and src register
-	   ;; and the offset.
-	   (handle-addi-inst reg word dstate)))))
+	  ((or (= 14 opcode)
+	       (= 24 opcode))
+	   ;; An ADDI or ORI instruction.
+	   (handle-addi-inst reg word dstate))
+	  ((and (= 31 opcode)
+		(= 266 (ldb (byte 9 1) word)))
+	   ;; An ADD instruction
+	   (handle-add-inst reg word dstate)))
+    (update-addis-notes word)))
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
 (defun reg-arg-printer (value stream dstate)
@@ -1122,19 +1257,19 @@ about function addresses and register values.")
 (eval-when (compile load eval)
   (defun addis-arg-printer (value stream dstate)
     (format stream "~D" value)
-    (let ((shifted (ash value 16)))
-      (disassem:note (format nil "0x~x = ~D" shifted shifted) dstate))
     ;; Save the immediate value and the destination register for this
     ;; addis instruction.  This is used later to print some possible
     ;; notes about the value loaded by addis.
-    (let* ((word (disassem::sap-ref-int (disassem:dstate-segment-sap dstate)
+    (let* ((shifted (ash value 16))
+	   (word (disassem::sap-ref-int (disassem:dstate-segment-sap dstate)
 					(disassem:dstate-cur-offs dstate)
 					vm:word-bytes
 					(disassem::dstate-byte-order dstate)))
 	   (si (ldb (byte 0 16) word))
-	   (rd (ldb (byte 5 26) word)))
-      #+nil
-      (push (cons rd si) *note-addis-inst*))))
+	   (rd (ldb (byte 5 21) word)))
+      (disassem:note (format nil "0x~x = ~D" shifted shifted)
+		     dstate)
+      (push (cons rd value) *note-addis-inst*))))
   
 (define-d-si-instruction addis 15 :fixup :ha :si-printer #'addis-arg-printer)