CMUCL commit: src (13 files)
Raymond Toy
rtoy at common-lisp.net
Tue Jul 20 01:08:37 CEST 2010
Date: Monday, July 19, 2010 @ 19:08:37
Author: rtoy
Path: /project/cmucl/cvsroot/src
Modified: assembly/sparc/assem-rtns.lisp assembly/x86/assem-rtns.lisp
bootfiles/20a/boot-2010-07-1-cross.lisp
compiler/generic/new-genesis.lisp compiler/sparc/alloc.lisp
compiler/sparc/cell.lisp compiler/sparc/vm.lisp
compiler/x86/alloc.lisp compiler/x86/cell.lisp lisp/gencgc.c
lisp/sparc-assem.S lisp/x86-assem.S tools/cross-build-world.sh
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(-)
Index: src/assembly/sparc/assem-rtns.lisp
diff -u src/assembly/sparc/assem-rtns.lisp:1.4 src/assembly/sparc/assem-rtns.lisp:1.5
--- src/assembly/sparc/assem-rtns.lisp:1.4 Fri Feb 11 16:02:32 2005
+++ src/assembly/sparc/assem-rtns.lisp Mon Jul 19 19:08:37 2010
@@ -5,11 +5,11 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
- "$Header: /project/cmucl/cvsroot/src/assembly/sparc/assem-rtns.lisp,v 1.4 2005-02-11 21:02:32 rtoy Rel $")
+ "$Header: /project/cmucl/cvsroot/src/assembly/sparc/assem-rtns.lisp,v 1.5 2010-07-19 23:08:37 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
-;;; $Header: /project/cmucl/cvsroot/src/assembly/sparc/assem-rtns.lisp,v 1.4 2005-02-11 21:02:32 rtoy Rel $
+;;; $Header: /project/cmucl/cvsroot/src/assembly/sparc/assem-rtns.lisp,v 1.5 2010-07-19 23:08:37 rtoy Exp $
;;;
;;;
(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)))
Index: src/assembly/x86/assem-rtns.lisp
diff -u src/assembly/x86/assem-rtns.lisp:1.8 src/assembly/x86/assem-rtns.lisp:1.9
--- src/assembly/x86/assem-rtns.lisp:1.8 Thu Jun 11 12:03:56 2009
+++ src/assembly/x86/assem-rtns.lisp Mon Jul 19 19:08:37 2010
@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group at cs.cmu.edu.
;;;
(ext:file-comment
- "$Header: /project/cmucl/cvsroot/src/assembly/x86/assem-rtns.lisp,v 1.8 2009-06-11 16:03:56 rtoy Rel $")
+ "$Header: /project/cmucl/cvsroot/src/assembly/x86/assem-rtns.lisp,v 1.9 2010-07-19 23:08:37 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -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)))
Index: src/bootfiles/20a/boot-2010-07-1-cross.lisp
diff -u /dev/null src/bootfiles/20a/boot-2010-07-1-cross.lisp:1.2
--- /dev/null Mon Jul 19 19:08:37 2010
+++ src/bootfiles/20a/boot-2010-07-1-cross.lisp Mon Jul 19 19:08:37 2010
@@ -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")
Index: src/compiler/generic/new-genesis.lisp
diff -u src/compiler/generic/new-genesis.lisp:1.89 src/compiler/generic/new-genesis.lisp:1.90
--- src/compiler/generic/new-genesis.lisp:1.89 Fri Mar 19 11:19:01 2010
+++ src/compiler/generic/new-genesis.lisp Mon Jul 19 19:08:37 2010
@@ -4,7 +4,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
- "$Header: /project/cmucl/cvsroot/src/compiler/generic/new-genesis.lisp,v 1.89 2010-03-19 15:19:01 rtoy Exp $")
+ "$Header: /project/cmucl/cvsroot/src/compiler/generic/new-genesis.lisp,v 1.90 2010-07-19 23:08:37 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -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
Index: src/compiler/sparc/alloc.lisp
diff -u src/compiler/sparc/alloc.lisp:1.24 src/compiler/sparc/alloc.lisp:1.25
--- src/compiler/sparc/alloc.lisp:1.24 Fri Mar 19 11:19:01 2010
+++ src/compiler/sparc/alloc.lisp Mon Jul 19 19:08:37 2010
@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
- "$Header: /project/cmucl/cvsroot/src/compiler/sparc/alloc.lisp,v 1.24 2010-03-19 15:19:01 rtoy Exp $")
+ "$Header: /project/cmucl/cvsroot/src/compiler/sparc/alloc.lisp,v 1.25 2010-07-19 23:08:37 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -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))))
Index: src/compiler/sparc/cell.lisp
diff -u src/compiler/sparc/cell.lisp:1.27 src/compiler/sparc/cell.lisp:1.28
--- src/compiler/sparc/cell.lisp:1.27 Fri Mar 19 11:19:01 2010
+++ src/compiler/sparc/cell.lisp Mon Jul 19 19:08:37 2010
@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
- "$Header: /project/cmucl/cvsroot/src/compiler/sparc/cell.lisp,v 1.27 2010-03-19 15:19:01 rtoy Exp $")
+ "$Header: /project/cmucl/cvsroot/src/compiler/sparc/cell.lisp,v 1.28 2010-07-19 23:08:37 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -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)))
Index: src/compiler/sparc/vm.lisp
diff -u src/compiler/sparc/vm.lisp:1.26 src/compiler/sparc/vm.lisp:1.27
--- src/compiler/sparc/vm.lisp:1.26 Fri Jun 30 14:41:32 2006
+++ src/compiler/sparc/vm.lisp Mon Jul 19 19:08:37 2010
@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
- "$Header: /project/cmucl/cvsroot/src/compiler/sparc/vm.lisp,v 1.26 2006-06-30 18:41:32 rtoy Rel $")
+ "$Header: /project/cmucl/cvsroot/src/compiler/sparc/vm.lisp,v 1.27 2010-07-19 23:08:37 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -387,6 +387,8 @@
(defregtn nsp any-reg)
(defregtn gtemp any-reg)
+(defregtn lexenv descriptor-reg)
+(defregtn cname descriptor-reg)
;;; Immediate-Constant-SC -- Interface
Index: src/compiler/x86/alloc.lisp
diff -u src/compiler/x86/alloc.lisp:1.14 src/compiler/x86/alloc.lisp:1.15
--- src/compiler/x86/alloc.lisp:1.14 Fri Mar 19 11:19:01 2010
+++ src/compiler/x86/alloc.lisp Mon Jul 19 19:08:37 2010
@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group at cs.cmu.edu.
;;;
(ext:file-comment
- "$Header: /project/cmucl/cvsroot/src/compiler/x86/alloc.lisp,v 1.14 2010-03-19 15:19:01 rtoy Exp $")
+ "$Header: /project/cmucl/cvsroot/src/compiler/x86/alloc.lisp,v 1.15 2010-07-19 23:08:37 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -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)))
Index: src/compiler/x86/cell.lisp
diff -u src/compiler/x86/cell.lisp:1.16 src/compiler/x86/cell.lisp:1.17
--- src/compiler/x86/cell.lisp:1.16 Fri Mar 19 11:19:01 2010
+++ src/compiler/x86/cell.lisp Mon Jul 19 19:08:37 2010
@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group at cs.cmu.edu.
;;;
(ext:file-comment
- "$Header: /project/cmucl/cvsroot/src/compiler/x86/cell.lisp,v 1.16 2010-03-19 15:19:01 rtoy Exp $")
+ "$Header: /project/cmucl/cvsroot/src/compiler/x86/cell.lisp,v 1.17 2010-07-19 23:08:37 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -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.
Index: src/lisp/gencgc.c
diff -u src/lisp/gencgc.c:1.107 src/lisp/gencgc.c:1.108
--- src/lisp/gencgc.c:1.107 Thu Apr 1 10:05:45 2010
+++ src/lisp/gencgc.c Mon Jul 19 19:08:37 2010
@@ -7,7 +7,7 @@
*
* Douglas Crosher, 1996, 1997, 1998, 1999.
*
- * $Header: /project/cmucl/cvsroot/src/lisp/gencgc.c,v 1.107 2010-04-01 14:05:45 rtoy Exp $
+ * $Header: /project/cmucl/cvsroot/src/lisp/gencgc.c,v 1.108 2010-07-19 23:08:37 rtoy Exp $
*
*/
@@ -670,6 +670,9 @@
#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 @@
#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 @@
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(&(SC_REG(context, index)), 1);
}
+ /*
+ * Now that the scavenging is done, repair the various interior
+ * pointers.
+ */
#ifdef reg_LIP
- /* Fix the LIP */
+ FIXUP_INTERIOR_POINTER(lip, SC_REG(context, reg_LIP));
+#endif
- /*
- * 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?
- */
- if (lip_register_pair >= 0) {
- SC_REG(context, reg_LIP) =
- SC_REG(context, lip_register_pair) + lip_offset;
- }
-#endif /* reg_LIP */
+ 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 @@
#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
Index: src/lisp/sparc-assem.S
diff -u src/lisp/sparc-assem.S:1.24 src/lisp/sparc-assem.S:1.25
--- src/lisp/sparc-assem.S:1.24 Thu Oct 23 22:57:00 2003
+++ src/lisp/sparc-assem.S Mon Jul 19 19:08:37 2010
@@ -269,7 +269,12 @@
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 @@
jmp reg_CODE+FUNCTION_CODE_OFFSET
nop
SET_SIZE(_closure_tramp)
-
+#endif
/*
Index: src/lisp/x86-assem.S
diff -u src/lisp/x86-assem.S:1.33 src/lisp/x86-assem.S:1.34
--- src/lisp/x86-assem.S:1.33 Thu Apr 1 10:05:45 2010
+++ src/lisp/x86-assem.S Mon Jul 19 19:08:37 2010
@@ -1,6 +1,6 @@
### x86-assem.S -*- Mode: Asm; -*-
/**
- * $Header: /project/cmucl/cvsroot/src/lisp/x86-assem.S,v 1.33 2010-04-01 14:05:45 rtoy Exp $
+ * $Header: /project/cmucl/cvsroot/src/lisp/x86-assem.S,v 1.34 2010-07-19 23:08:37 rtoy Exp $
*
* Authors: Paul F. Werkowski <pw at snoopy.mv.com>
* Douglas T. Crosher
@@ -286,7 +286,14 @@
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 @@
jmp *CLOSURE_FUNCTION_OFFSET(%eax)
ENDFUNC(closure_tramp)
+#endif
+
/*
* Function-end breakpoint magic.
*/
Index: src/tools/cross-build-world.sh
diff -u src/tools/cross-build-world.sh:1.5 src/tools/cross-build-world.sh:1.6
--- src/tools/cross-build-world.sh:1.5 Tue Jun 22 11:27:40 2010
+++ src/tools/cross-build-world.sh Mon Jul 19 19:08:37 2010
@@ -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"
More information about the cmucl-commit
mailing list