From 30102669e42f45b852eb5325678fd385999c587f Mon Sep 17 00:00:00 2001
From: rtoy <rtoy>
Date: Mon, 19 Jul 2010 23:08:37 +0000
Subject: [PATCH] Merge changes from sparc-tramp-assem-2010-07-19.  This moves
 closure_tramp and undefined_tramp from the C side to the Lisp side via Lisp
 assembly routines.  (Simplifies things quite a bit for sparc.)

Also includes some GC fixes for sparc and ppc to handle moving the pc,
npc, lr, and ctr registers.  They need to be handled like the lip
register.

See bootfiles/20a/boot-2010-07-1-cross.lisp for instructions on how to
bootstrap this change.  A basic cross-compile with a specific cross
bootstrap file is needed.
---
 assembly/sparc/assem-rtns.lisp          |  71 +++++++-
 assembly/x86/assem-rtns.lisp            |  22 ++-
 bootfiles/20a/boot-2010-07-1-cross.lisp |  16 ++
 compiler/generic/new-genesis.lisp       |  31 +++-
 compiler/sparc/alloc.lisp               |   9 +-
 compiler/sparc/cell.lisp                |  26 +--
 compiler/sparc/vm.lisp                  |   4 +-
 compiler/x86/alloc.lisp                 |  16 +-
 compiler/x86/cell.lisp                  |  37 ++++-
 lisp/gencgc.c                           | 212 ++++++++++++++----------
 lisp/sparc-assem.S                      |   9 +-
 lisp/x86-assem.S                        |  11 +-
 tools/cross-build-world.sh              |   2 +-
 13 files changed, 348 insertions(+), 118 deletions(-)
 create mode 100644 bootfiles/20a/boot-2010-07-1-cross.lisp

diff --git a/assembly/sparc/assem-rtns.lisp b/assembly/sparc/assem-rtns.lisp
index 63a2a4526..584c1c889 100644
--- a/assembly/sparc/assem-rtns.lisp
+++ b/assembly/sparc/assem-rtns.lisp
@@ -5,11 +5,11 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/sparc/assem-rtns.lisp,v 1.4 2005/02/11 21:02:32 rtoy Rel $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/sparc/assem-rtns.lisp,v 1.5 2010/07/19 23:08:37 rtoy Rel $")
 ;;;
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/sparc/assem-rtns.lisp,v 1.4 2005/02/11 21:02:32 rtoy Rel $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/sparc/assem-rtns.lisp,v 1.5 2010/07/19 23:08:37 rtoy Rel $
 ;;;
 ;;;
 (in-package "SPARC")
@@ -242,3 +242,70 @@
   (inst nop))
 
 
+
+
+;; Assembly routines for undefined_tramp and closure_tramp
+
+#+assembler
+(define-assembly-routine (closure-tramp-function-alignment
+			  (:return-style :none))
+                         ()
+  ;; Align to a dualword and put in the magic function header stuff so
+  ;; that closure-tramp looks like a normal function with a function
+  ;; tag.
+  (align vm:lowtag-bits)
+  (inst byte 0))
+
+#+assembler
+(define-assembly-routine (closure-tramp
+			  (:return-style :none))
+                         ()
+  (inst byte 0)
+  (inst byte 0)
+  (inst byte vm:function-header-type)
+  ;; This is supposed to be closure-tramp, not 0.
+  (inst word 0)
+  (inst word (kernel:get-lisp-obj-address nil))
+  (inst word (kernel:get-lisp-obj-address nil))
+  (inst word (kernel:get-lisp-obj-address nil))
+  (inst word (kernel:get-lisp-obj-address nil))
+
+  (loadw lexenv-tn cname-tn fdefn-function-slot other-pointer-type)
+  (loadw code-tn lexenv-tn closure-function-slot function-pointer-type)
+  (inst j code-tn (- (* function-code-offset word-bytes) function-pointer-type))
+  (inst nop)
+  ;; Make sure following routine is dual-word aligned
+  (align vm:lowtag-bits))
+
+#+assembler
+(define-assembly-routine (undefined-tramp-function-alignment
+			  (:return-style :none))
+                         ()
+  ;; Align to a dualword and put in the magic function header stuff so
+  ;; that closure-tramp looks like a normal function with a function
+  ;; tag.
+  (align vm:lowtag-bits)
+  (inst byte 0))
+
+#+assembler
+(define-assembly-routine (undefined-tramp
+			  (:return-style :none))
+                         ()
+  (inst byte 0)
+  (inst byte 0)
+  (inst byte vm:function-header-type)
+  ;; This is supposed to be undefined-tramp, not 0.
+  (inst word 0)
+  (inst word (kernel:get-lisp-obj-address nil))
+  (inst word (kernel:get-lisp-obj-address nil))
+  (inst word (kernel:get-lisp-obj-address nil))
+  (inst word (kernel:get-lisp-obj-address nil))
+
+  (let ((error (generate-cerror-code nil undefined-symbol-error cname-tn)))
+    (inst b error)
+    (inst nop)
+    ;; I don't think we ever return from the undefined-symbol-error
+    ;; handler, but the assembly code did this so we'll do it too.
+    (loadw code-tn cname-tn fdefn-raw-addr-slot other-pointer-type)
+    (inst j code-tn (- (* function-code-offset word-bytes) function-pointer-type))
+    (inst nop)))
diff --git a/assembly/x86/assem-rtns.lisp b/assembly/x86/assem-rtns.lisp
index 23861df15..3f6a18260 100644
--- a/assembly/x86/assem-rtns.lisp
+++ b/assembly/x86/assem-rtns.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
- "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/x86/assem-rtns.lisp,v 1.8 2009/06/11 16:03:56 rtoy Rel $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/x86/assem-rtns.lisp,v 1.9 2010/07/19 23:08:37 rtoy Rel $")
 ;;;
 ;;; **********************************************************************
 ;;; 
@@ -274,3 +274,23 @@
 
   (inst jmp (make-ea :byte :base block
 		     :disp (* unwind-block-entry-pc-slot word-bytes))))
+
+#+assembler
+(define-assembly-routine (closure-tramp
+			  (:return-style :none))
+                         ()
+  (loadw eax-tn eax-tn fdefn-function-slot other-pointer-type)
+  (inst jmp (make-ea :dword :base eax-tn
+		     :disp (- (* closure-function-slot word-bytes)
+			      function-pointer-type))))
+
+#+assembler
+(define-assembly-routine (undefined-tramp
+			  (:return-style :none))
+                         ()
+  (let ((error (generate-error-code nil undefined-symbol-error
+				    (make-random-tn :kind :normal
+						    :sc (sc-or-lose 'descriptor-reg c::*backend*)
+						    :offset 0))))
+    (inst jmp error)
+    (inst ret)))
diff --git a/bootfiles/20a/boot-2010-07-1-cross.lisp b/bootfiles/20a/boot-2010-07-1-cross.lisp
new file mode 100644
index 000000000..fe193aa75
--- /dev/null
+++ b/bootfiles/20a/boot-2010-07-1-cross.lisp
@@ -0,0 +1,16 @@
+;;; Simple cross-compile file for moving closure_tramp and
+;;; undefined_tramp to Lisp assembly routines.
+;;;
+;;; But note that to do the cross-compile using the 2010-06 binaries,
+;;; we need a cross-bootstrap file.  Thus, use boot-2010-07-1.lisp as
+;;; the cross-bootstrap file.  The cross-compile can be done as follows:
+;;;
+;;; src/tools/cross-build-world.sh -rl -B src/bootfiles/20a/boot-2010-07-1.lisp <target>
+;;;     <cross> src/bootfiles/20a/boot-2010-07-1-cross <oldlisp> <lisp options>
+
+
+#+x86
+(load "target:tools/cross-scripts/cross-x86-x86")
+
+#+sparc
+(load "target:tools/cross-scripts/cross-sparc-sparc")
diff --git a/compiler/generic/new-genesis.lisp b/compiler/generic/new-genesis.lisp
index 0fdfbb916..cc9f023c8 100644
--- a/compiler/generic/new-genesis.lisp
+++ b/compiler/generic/new-genesis.lisp
@@ -4,7 +4,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/new-genesis.lisp,v 1.89 2010/03/19 15:19:01 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/new-genesis.lisp,v 1.90 2010/07/19 23:08:37 rtoy Rel $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -2165,11 +2165,25 @@
 ;; running lisp.  Why?  Because new C code may have moved these
 ;; addresses so we need to use the right values.  We get worldbuild
 ;; issues if we use the old values that don't match.
+#+nil
 (defun lookup-special-symbol (name)
   (or (gethash name *cold-foreign-symbol-table* nil)
       (lookup-foreign-symbol (vm::extern-alien-name name)
 			     #+(or sparc ppc) :data)))
 
+(defun lookup-special-symbol (name)
+  (cond
+    #+(or sparc x86 amd64)
+    ((string= name "closure_tramp")
+     (lookup-assembler-reference 'vm::closure-tramp))
+    #+(or sparc x86 amd64)
+    ((string= name "undefined_tramp")
+     (lookup-assembler-reference 'vm::undefined-tramp))
+    (t
+     (or (gethash name *cold-foreign-symbol-table* nil)
+	 (lookup-foreign-symbol (vm::extern-alien-name name)
+				#+(or sparc ppc) :data)))))
+
 (defvar *cold-linkage-table* (make-array 8192 :adjustable t :fill-pointer 0))
 (defvar *cold-foreign-hash* (make-hash-table :test #'equal))
 
@@ -2193,7 +2207,9 @@
   #+(or sparc ppc)
   (progn
     (cold-register-foreign-linkage (vm::extern-alien-name "call_into_c") :code)
+    #-sparc
     (cold-register-foreign-linkage (vm::extern-alien-name "undefined_tramp") :data)
+    #-sparc
     (cold-register-foreign-linkage (vm::extern-alien-name "closure_tramp") :data)
     ))
 
@@ -2725,6 +2741,19 @@
 	    (initialize-symbols)
 	    (initialize-layouts)
 	    (setf *current-init-functions-cons* *nil-descriptor*)
+	    ;; Load the assembler-routines now since they include
+	    ;; undefined-tramp and closure-tramp.  We need the former
+	    ;; in order to initialize the static functions and we need
+	    ;; the latter to be able to static fset closures.
+	    (flet ((is-assemfile (x)
+		     (string-equal "assem"
+				   (pathname-type x))))
+	      (dolist (file-name (remove-if-not #'is-assemfile  file-list))
+		(write-line (namestring (truename file-name)))
+		(cold-load file-name))
+	      ;; Don't load the assem files again, otherwise we'll get
+	      ;; two copies of everything.
+	      (setf file-list (remove-if #'is-assemfile file-list)))
 	    (initialize-static-fns)
 	    (dolist (file (if (listp file-list)
 			      file-list
diff --git a/compiler/sparc/alloc.lisp b/compiler/sparc/alloc.lisp
index b213685d1..613c6805c 100644
--- a/compiler/sparc/alloc.lisp
+++ b/compiler/sparc/alloc.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/sparc/alloc.lisp,v 1.24 2010/03/19 15:19:01 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/alloc.lisp,v 1.25 2010/07/19 23:08:37 rtoy Rel $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -143,11 +143,8 @@
       ;; For the linkage-table stuff, we need to look up the address
       ;; of undefined_tramp from the linkage table instead of using
       ;; the address directly.
-      (inst li temp (make-fixup (extern-alien-name "undefined_tramp")
-				#-linkage-table :foreign
-				#+linkage-table :foreign-data))
-      #+linkage-table
-      (loadw temp temp)
+      (inst li temp (make-fixup 'undefined-tramp
+				:assembly-routine))
       (storew name result fdefn-name-slot other-pointer-type)
       (storew null-tn result fdefn-function-slot other-pointer-type)
       (storew temp result fdefn-raw-addr-slot other-pointer-type))))
diff --git a/compiler/sparc/cell.lisp b/compiler/sparc/cell.lisp
index f87461f5b..8aedc405a 100644
--- a/compiler/sparc/cell.lisp
+++ b/compiler/sparc/cell.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/sparc/cell.lisp,v 1.27 2010/03/19 15:19:01 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/cell.lisp,v 1.28 2010/07/19 23:08:37 rtoy Rel $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -135,7 +135,7 @@
   (:translate (setf fdefn-function))
   (:args (function :scs (descriptor-reg) :target result)
 	 (fdefn :scs (descriptor-reg)))
-  (:temporary (:scs (interior-reg)) lip)
+  (:temporary (:scs (descriptor-reg)) temp)
   (:temporary (:scs (non-descriptor-reg)) type)
   (:results (result :scs (descriptor-reg)))
   (:generator 38
@@ -143,17 +143,12 @@
       (load-type type function (- function-pointer-type))
       (inst cmp type function-header-type)
       (inst b :eq normal-fn)
-      (inst move lip function)
-      ;; For the linkage-table stuff, we need to look up the address
-      ;; from the linkage table instead of using the address directly.
-      (inst li lip (make-fixup (extern-alien-name "closure_tramp")
-			       #-linkage-table :foreign
-			       #+linkage-table :foreign-data))
-      #+linkage-table
-      (loadw lip lip)
+      (inst move temp function)
+      (inst li temp (make-fixup 'closure-tramp
+			       :assembly-routine))
       (emit-label normal-fn)
       (storew function fdefn fdefn-function-slot other-pointer-type)
-      (storew lip fdefn fdefn-raw-addr-slot other-pointer-type)
+      (storew temp fdefn fdefn-raw-addr-slot other-pointer-type)
       (move result function))))
 
 (define-vop (fdefn-makunbound)
@@ -164,13 +159,8 @@
   (:results (result :scs (descriptor-reg)))
   (:generator 38
     (storew null-tn fdefn fdefn-function-slot other-pointer-type)
-    ;; For the linkage-table stuff, we need to look up the address
-    ;; from the linkage table instead of using the address directly.
-    (inst li temp (make-fixup (extern-alien-name "undefined_tramp")
-			      #-linkage-table :foreign
-			      #+linkage-table :foreign-data))
-    #+linkage-table
-    (loadw temp temp)
+    (inst li temp (make-fixup 'undefined-tramp
+			      :assembly-routine))
     (storew temp fdefn fdefn-raw-addr-slot other-pointer-type)
     (move result fdefn)))
 
diff --git a/compiler/sparc/vm.lisp b/compiler/sparc/vm.lisp
index 587f07d10..46d9b867c 100644
--- a/compiler/sparc/vm.lisp
+++ b/compiler/sparc/vm.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/sparc/vm.lisp,v 1.26 2006/06/30 18:41:32 rtoy Rel $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/vm.lisp,v 1.27 2010/07/19 23:08:37 rtoy Rel $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -387,6 +387,8 @@
 (defregtn nsp any-reg)
 (defregtn gtemp any-reg) 
 
+(defregtn lexenv descriptor-reg)
+(defregtn cname descriptor-reg)
 
 
 ;;; Immediate-Constant-SC  --  Interface
diff --git a/compiler/x86/alloc.lisp b/compiler/x86/alloc.lisp
index 23472b6bc..6d7f19831 100644
--- a/compiler/x86/alloc.lisp
+++ b/compiler/x86/alloc.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/x86/alloc.lisp,v 1.14 2010/03/19 15:19:01 rtoy Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/alloc.lisp,v 1.15 2010/07/19 23:08:37 rtoy Rel $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -162,6 +162,7 @@
     (storew nil-value result code-debug-info-slot other-pointer-type)))
 
 
+#+nil
 (define-vop (make-fdefn)
   (:policy :fast-safe)
   (:translate make-fdefn)
@@ -175,6 +176,19 @@
       (storew (make-fixup (extern-alien-name "undefined_tramp") :foreign)
 	      result fdefn-raw-addr-slot other-pointer-type))))
 
+(define-vop (make-fdefn)
+  (:policy :fast-safe)
+  (:translate make-fdefn)
+  (:args (name :scs (descriptor-reg) :to :eval))
+  (:results (result :scs (descriptor-reg) :from :argument))
+  (:node-var node)
+  (:generator 37
+    (with-fixed-allocation (result fdefn-type fdefn-size node)
+      (storew name result fdefn-name-slot other-pointer-type)
+      (storew nil-value result fdefn-function-slot other-pointer-type)
+      (storew (make-fixup 'undefined-tramp :assembly-routine)
+	      result fdefn-raw-addr-slot other-pointer-type))))
+
 
 (define-vop (make-closure)
   (:args (function :to :save :scs (descriptor-reg)))
diff --git a/compiler/x86/cell.lisp b/compiler/x86/cell.lisp
index 339571f20..3633a70dc 100644
--- a/compiler/x86/cell.lisp
+++ b/compiler/x86/cell.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/x86/cell.lisp,v 1.16 2010/03/19 15:19:01 rtoy Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/cell.lisp,v 1.17 2010/07/19 23:08:37 rtoy Rel $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -169,6 +169,7 @@
     (let ((err-lab (generate-error-code vop undefined-symbol-error object)))
       (inst jmp :e err-lab))))
 
+#+nil
 (define-vop (set-fdefn-function)
   (:policy :fast-safe)
   (:translate (setf fdefn-function))
@@ -191,6 +192,29 @@
     (storew raw fdefn fdefn-raw-addr-slot other-pointer-type)
     (move result function)))
 
+(define-vop (set-fdefn-function)
+  (:policy :fast-safe)
+  (:translate (setf fdefn-function))
+  (:args (function :scs (descriptor-reg) :target result)
+	 (fdefn :scs (descriptor-reg)))
+  (:temporary (:sc unsigned-reg) raw)
+  (:temporary (:sc byte-reg) type)
+  (:results (result :scs (descriptor-reg)))
+  (:generator 38
+    (load-type type function (- function-pointer-type))
+    (inst lea raw
+	  (make-ea :byte :base function
+		   :disp (- (* function-code-offset word-bytes)
+			    function-pointer-type)))
+    (inst cmp type function-header-type)
+    (inst jmp :e normal-fn)
+    (inst lea raw (make-fixup 'closure-tramp :assembly-routine))
+    NORMAL-FN
+    (storew function fdefn fdefn-function-slot other-pointer-type)
+    (storew raw fdefn fdefn-raw-addr-slot other-pointer-type)
+    (move result function)))
+
+#+nil
 (define-vop (fdefn-makunbound)
   (:policy :fast-safe)
   (:translate fdefn-makunbound)
@@ -202,6 +226,17 @@
 	    fdefn fdefn-raw-addr-slot other-pointer-type)
     (move result fdefn)))
 
+(define-vop (fdefn-makunbound)
+  (:policy :fast-safe)
+  (:translate fdefn-makunbound)
+  (:args (fdefn :scs (descriptor-reg) :target result))
+  (:results (result :scs (descriptor-reg)))
+  (:generator 38
+    (storew nil-value fdefn fdefn-function-slot other-pointer-type)
+    (storew (make-fixup 'undefined-tramp :assembly-routine)
+	    fdefn fdefn-raw-addr-slot other-pointer-type)
+    (move result fdefn)))
+
 
 
 ;;;; Binding and Unbinding.
diff --git a/lisp/gencgc.c b/lisp/gencgc.c
index 11703d9ca..b71645f94 100644
--- a/lisp/gencgc.c
+++ b/lisp/gencgc.c
@@ -7,7 +7,7 @@
  *
  * Douglas Crosher, 1996, 1997, 1998, 1999.
  *
- * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/gencgc.c,v 1.107 2010/04/01 14:05:45 rtoy Exp $
+ * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/gencgc.c,v 1.108 2010/07/19 23:08:37 rtoy Exp $
  *
  */
 
@@ -670,6 +670,9 @@ print_generation_stats(int verbose)
 #define SSE_STATE_SIZE ((512+16)/4)
     int fpu_state[FPU_STATE_SIZE];
     int sse_state[SSE_STATE_SIZE];
+
+    extern void sse_save(void *);
+    extern void sse_restore(void *);
 #elif defined(sparc)
     /*
      * 32 (single-precision) FP registers, and the FP state register.
@@ -2019,13 +2022,17 @@ signal_space_p(lispobj obj)
 #endif    
 }
 
-#if defined(sparc) || (defined(DARWIN) && defined(__ppc__))
+#if (defined(DARWIN) && defined(__ppc__))
 /*
  * The assembly code defines these as functions, so we make them
  * functions.  We only care about their addresses anyway.
  */
 extern char closure_tramp();
 extern char undefined_tramp();
+#elif defined(sparc)
+/* closure tramp and undefined tramp are Lisp assembly routines */
+#elif (defined(i386) || defined(__x86_64))
+/* undefined tramp are Lisp assembly routines */
 #else
 extern int undefined_tramp;
 #endif
@@ -2576,72 +2583,123 @@ scavenge(void *start_obj, long nwords)
 
 static int boxed_registers[] = BOXED_REGISTERS;
 
+/* The GC has a notion of an "interior pointer" register, an unboxed
+ * register that typically contains a pointer to inside an object
+ * referenced by another pointer.  The most obvious of these is the
+ * program counter, although many compiler backends define a "Lisp
+ * Interior Pointer" register known as reg_LIP, and various CPU
+ * architectures have other registers that also partake of the
+ * interior-pointer nature.  As the code for pairing an interior
+ * pointer value up with its "base" register, and fixing it up after
+ * scavenging is complete is horribly repetitive, a few macros paper
+ * over the monotony.  --AB, 2010-Jul-14 */
+
+#define INTERIOR_POINTER_VARS(name) \
+    unsigned long name;		    \
+    unsigned long name##_offset;    \
+    int name##_register_pair
+
+#define PAIR_INTERIOR_POINTER(name, accessor)		\
+    name = accessor;					\
+    pair_interior_pointer(context, name,		\
+			  &name##_offset,		\
+			  &name##_register_pair)
+
+/*
+ * Do we need to check if the register we're fixing up is in the
+ * from-space?
+ */
+#define FIXUP_INTERIOR_POINTER(name, accessor)				\
+    do {								\
+	if (name##_register_pair >= 0) {				\
+	    accessor =							\
+		SC_REG(context, name##_register_pair)                   \
+                + name##_offset;                                        \
+	}								\
+    } while (0)
+
+
+static void
+pair_interior_pointer(os_context_t *context, unsigned long pointer,
+		      unsigned long *saved_offset, int *register_pair)
+{
+    int i;
+
+    /*
+     * I (RLT) think this is trying to find the boxed register that is
+     * closest to the LIP address, without going past it.  Usually, it's
+     * reg_CODE or reg_LRA.  But sometimes, nothing can be found.
+     */
+    *saved_offset = 0x7FFFFFFF;
+    *register_pair = -1;
+    for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++) {
+        unsigned long reg;
+        long offset;
+        int index;
+
+        index = boxed_registers[i];
+        reg = SC_REG(context, index);
+
+	/* An interior pointer is never relative to a non-pointer
+	 * register (an oversight in the original implementation).
+	 * The simplest argument for why this is true is to consider
+	 * the fixnum that happens by coincide to be the word-index in
+	 * memory of the header for some object plus two.  This is
+	 * happenstance would cause the register containing the fixnum
+	 * to be selected as the register_pair if the interior pointer
+	 * is to anywhere after the first two words of the object.
+	 * The fixnum won't be changed during GC, but the object might
+	 * move, thus destroying the interior pointer.  --AB,
+	 * 2010-Jul-14 */
+
+        if (Pointerp(reg) && (PTR(reg) <= pointer)) {
+            offset = pointer - reg;
+            if (offset < *saved_offset) {
+                *saved_offset = offset;
+                *register_pair = index;
+            }
+        }
+    }
+}
+
+
 static void
 scavenge_interrupt_context(os_context_t * context)
 {
     int i;
-    unsigned long pc_code_offset;
 
+    INTERIOR_POINTER_VARS(pc);
 #ifdef reg_LIP
-    unsigned long lip;
-    unsigned long lip_offset;
-    int lip_register_pair;
+    INTERIOR_POINTER_VARS(lip);
 #endif
 #ifdef reg_LR
-    unsigned long lr_code_offset;
+    INTERIOR_POINTER_VARS(lr);
 #endif
 #ifdef reg_CTR    
-    unsigned long ctr_code_offset;
+    INTERIOR_POINTER_VARS(ctr);
 #endif
 #ifdef SC_NPC
-    unsigned long npc_code_offset;
+    INTERIOR_POINTER_VARS(npc);
 #endif
 
 #ifdef reg_LIP
-    /* Find the LIP's register pair and calculate it's offset */
-    /* before we scavenge the context. */
-
-    /*
-     * I (RLT) think this is trying to find the boxed register that is
-     * closest to the LIP address, without going past it.  Usually, it's
-     * reg_CODE or reg_LRA.  But sometimes, nothing can be found.
-     */
-    lip = SC_REG(context, reg_LIP);
-    lip_offset = 0x7FFFFFFF;
-    lip_register_pair = -1;
-    for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++) {
-	unsigned long reg;
-	long offset;
-	int index;
-
-	index = boxed_registers[i];
-	reg = SC_REG(context, index);
-	if (Pointerp(reg) && PTR(reg) <= lip) {
-	    offset = lip - reg;
-	    if (offset < lip_offset) {
-		lip_offset = offset;
-		lip_register_pair = index;
-	    }
-	}
-    }
+    PAIR_INTERIOR_POINTER(lip, SC_REG(context, reg_LIP));
 #endif /* reg_LIP */
 
-    /*
-     * Compute the PC's offset from the start of the CODE 
-     * register.
-     */
-    pc_code_offset = SC_PC(context) - SC_REG(context, reg_CODE);
+    PAIR_INTERIOR_POINTER(pc, SC_PC(context));
+
 #ifdef SC_NPC
-    npc_code_offset = SC_NPC(context) - SC_REG(context, reg_CODE);
-#endif /* SC_NPC */
+    PAIR_INTERIOR_POINTER(npc, SC_NPC(context));
+#endif    
 
 #ifdef reg_LR
-    lr_code_offset = SC_REG(context, reg_LR) - SC_REG(context, reg_CODE);
-#endif    
+    PAIR_INTERIOR_POINTER(pc, SC_REG(context, reg_LR));
+#endif
+
 #ifdef reg_CTR
-    ctr_code_offset = SC_REG(context, reg_CTR) - SC_REG(context, reg_CODE);
+    PAIR_INTERIOR_POINTER(pc, SC_REG(context, reg_CTR));
 #endif    
-
+    
     /* Scanvenge all boxed registers in the context. */
     for (i = 0; i < (sizeof(boxed_registers) / sizeof(int)); i++) {
 	int index;
@@ -2655,43 +2713,27 @@ scavenge_interrupt_context(os_context_t * context)
 	scavenge(&(SC_REG(context, index)), 1);
     }
 
-#ifdef reg_LIP
-    /* Fix the LIP */
-
     /*
-     * But what happens if lip_register_pair is -1?  SC_REG on Solaris
-     * (see solaris_register_address in solaris-os.c) will return
-     * &context->uc_mcontext.gregs[2].  But gregs[2] is REG_nPC.  Is
-     * that what we really want?  My guess is that that is not what we
-     * want, so if lip_register_pair is -1, we don't touch reg_LIP at
-     * all.  But maybe it doesn't really matter if LIP is trashed?
+     * Now that the scavenging is done, repair the various interior
+     * pointers.
      */
-    if (lip_register_pair >= 0) {
-	SC_REG(context, reg_LIP) =
-	    SC_REG(context, lip_register_pair) + lip_offset;
-    }
-#endif /* reg_LIP */
+#ifdef reg_LIP
+    FIXUP_INTERIOR_POINTER(lip, SC_REG(context, reg_LIP));
+#endif
+
+    FIXUP_INTERIOR_POINTER(pc, SC_PC(context));
 
-    /* Fix the PC if it was in from space */
-    if (from_space_p(SC_PC(context))) {
-        SC_PC(context) = SC_REG(context, reg_CODE) + pc_code_offset;
-    }
 #ifdef SC_NPC
-    if (from_space_p(SC_NPC(context))) {
-	SC_NPC(context) = SC_REG(context, reg_CODE) + npc_code_offset;
-    }
-#endif /* SC_NPC */
+    FIXUP_INTERIOR_POINTER(npc, SC_NPC(context));
+#endif
 
 #ifdef reg_LR
-    if (from_space_p(SC_REG(context, reg_LR))) {
-        SC_REG(context, reg_LR) = SC_REG(context, reg_CODE) + lr_code_offset;
-    }
-#endif	
+    FIXUP_INTERIOR_POINTER(lr, SC_REG(context, reg_LR));
+#endif
+
 #ifdef reg_CTR
-    if (from_space_p(SC_REG(context, reg_CTR))) {
-      SC_REG(context, reg_CTR) = SC_REG(context, reg_CODE) + ctr_code_offset;
-    }
-#endif	
+    FIXUP_INTERIOR_POINTER(ctr, SC_REG(context, reg_CTR));
+#endif
 }
 
 void
@@ -6837,20 +6879,24 @@ verify_space(lispobj * start, size_t words)
 #endif
 	    } else {
 		/* Verify that it points to another valid space */
-		if (!to_readonly_space && !to_static_space &&
-#if defined(sparc) || (defined(DARWIN) && defined(__ppc__))
-		    !((thing == (int) &closure_tramp) ||
-		      (thing == (int) &undefined_tramp))
+		if (!to_readonly_space && !to_static_space 
+#if (defined(DARWIN) && defined(__ppc__))
+
+		    && !((thing == (int) &closure_tramp) ||
+                         (thing == (int) &undefined_tramp))
+#elif defined(sparc) || defined(i386) || defined(__x86_64)
+                    /* Nothing for since these are Lisp assembly routines */
 #else
-		    thing != (int) &undefined_tramp
+		    && thing != (int) &undefined_tramp
 #endif
 		    ) {
+#if !(defined(sparc) || defined(i386) || defined(__x86_64))
 		    fprintf(stderr,
 			    "*** Ptr %lx @ %lx sees Junk (undefined_tramp = %lx)",
 			    (unsigned long) thing, (unsigned long) start,
 			    (unsigned long) &undefined_tramp);
-                    
-#if defined(sparc) || (defined(DARWIN) && defined(__ppc__))
+#endif                    
+#if (defined(DARWIN) && defined(__ppc__))
                     fprintf(stderr, " (closure_tramp = %lx)",
 			    (unsigned long) &closure_tramp);
 #endif
diff --git a/lisp/sparc-assem.S b/lisp/sparc-assem.S
index ad3b2648a..1bb4f9115 100644
--- a/lisp/sparc-assem.S
+++ b/lisp/sparc-assem.S
@@ -269,7 +269,12 @@ _call_into_c:
 
 	SET_SIZE(_call_into_c)
 
-
+#if 0
+/* undefined_tramp and closure_tramp are now Lisp assembly routines.
+ * so we don't need these anymore.  Leave them here for a bit so 
+ * we can look at the "real" versions for a while.  But eventually,
+ * remove these.
+ */
         .global _undefined_tramp
 	FUNCDEF(_undefined_tramp)
         .align  8
@@ -318,7 +323,7 @@ _closure_tramp:
 	jmp	reg_CODE+FUNCTION_CODE_OFFSET
 	nop
 	SET_SIZE(_closure_tramp)
-
+#endif
 
 
 /*
diff --git a/lisp/x86-assem.S b/lisp/x86-assem.S
index f1c1e3d37..46233ef05 100644
--- a/lisp/x86-assem.S
+++ b/lisp/x86-assem.S
@@ -1,6 +1,6 @@
 ### x86-assem.S -*- Mode: Asm; -*-
 /**
- * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/x86-assem.S,v 1.33 2010/04/01 14:05:45 rtoy Exp $
+ * $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/x86-assem.S,v 1.34 2010/07/19 23:08:37 rtoy Rel $
  *
  * Authors:	Paul F. Werkowski <pw@snoopy.mv.com>
  *		Douglas T. Crosher
@@ -286,7 +286,14 @@ FUNCDEF(sse_restore)
 ENDFUNC(sse_restore)
 
 
+#if 0
 /*
+ * These are now implemented as Lisp assembly routines.  We leave
+ * these here for the time being until we're sure the assembly
+ * routines are working as expected.
+ */
+
+ /*
  * The undefined-function trampoline.
  */
 FUNCDEF(undefined_tramp)
@@ -308,6 +315,8 @@ FUNCDEF(closure_tramp)
 	jmp	*CLOSURE_FUNCTION_OFFSET(%eax)
 ENDFUNC(closure_tramp)
 
+#endif
+
 /*
  * Function-end breakpoint magic.
  */
diff --git a/tools/cross-build-world.sh b/tools/cross-build-world.sh
index 019ca581b..79ba037bd 100755
--- a/tools/cross-build-world.sh
+++ b/tools/cross-build-world.sh
@@ -1,7 +1,7 @@
 #!/bin/sh
 
 usage() {
-    echo "cross-build-world.sh [-crl] target-dir cross-dir cross-compiler-script [build-binary [flags]]"
+    echo "cross-build-world.sh [-crl] [-B file] target-dir cross-dir cross-compiler-script [build-binary [flags]]"
     echo "  -c      Clean target and cross directories before compiling"
     echo "  -r      Recompile lisp runtime"
     echo "  -l      Load cross-compiled kernel to make a new lisp kernel"
-- 
GitLab