[cmucl-cvs] CMUCL commit: src (7 files)
Raymond Toy
rtoy at common-lisp.net
Sat Dec 4 17:32:35 UTC 2010
Date: Saturday, December 4, 2010 @ 12:32:35
Author: rtoy
Path: /project/cmucl/cvsroot/src
Modified: compiler/dump.lisp compiler/generic/new-genesis.lisp
compiler/ppc/parms.lisp compiler/sparc/parms.lisp
compiler/x86/parms.lisp lisp/os-common.c
tools/cross-scripts/cross-x86-sparc.lisp
Support cross-compiling from x86 to sparc, unicode. Also fixes some
bugs with dumping unicode strings to fasls on a different endian
architecture. Combined with cross-x86-sparc.lisp, this will
successfully cross-compile from x86 (OSX) to sparc (Solaris). The
result won't, unfortunately, built itself, but if the callback support
is commented out, the build is successful. This new build can then be
successfully used to do another build that includes callback support.
don't know what is causing this issue.
compiler/dump.lisp:
o DUMP-DATA-MAYBE-BYTE-SWAPPING needs to byte-swap unicode (16-bit)
strings.
compiler/generic/new-genesis.lisp:
o STRING-TO-CORE needs to swap the byte order of unicode strings if
the backend and native backend have different endianness.
o LOAD-CHAR-CODE should load characters based on the backend, not
native-backend. (This not used anymore, though?)
o Add new function byte-swap the char codes of a unicode string.
o COLD-LOAD-SYMBOL calls MAYBE-BYTE-SWAP-STRING
o FOP-UNINTERNED-SYMBOL-SAVE, FOP-UNINTERNED-SMALL-SYMBOL-SAVE,
FOP-STRING, FOP-SMALL-STRING, FOP-FOREIGN-FIXUP,
and FOP-FOREIGN-DATA-FIXUP need to call MAYBE-BYTE-SWAP-STRING for
unicode strings.
compiler/ppc/parms.lisp:
compiler/sparc/parms.lisp:
compiler/x86/parms.lisp:
o Initialize backend foreign-linkage space start and entry size
appropriately. The target versions are initialized from the backend
values now too.
lisp/os-common.c:
o Some debugging stuff for foreign linkage data to print out symbol
names. Currently ifdef'ed out.
------------------------------------------+
compiler/dump.lisp | 20 -
compiler/generic/new-genesis.lisp | 87 +++++-
compiler/ppc/parms.lisp | 7
compiler/sparc/parms.lisp | 18 -
compiler/x86/parms.lisp | 14 -
lisp/os-common.c | 33 ++
tools/cross-scripts/cross-x86-sparc.lisp | 377 +++++++++++++++++++++++++++++
7 files changed, 513 insertions(+), 43 deletions(-)
Index: src/compiler/dump.lisp
diff -u src/compiler/dump.lisp:1.89 src/compiler/dump.lisp:1.90
--- src/compiler/dump.lisp:1.89 Wed Nov 10 14:51:24 2010
+++ src/compiler/dump.lisp Sat Dec 4 12:32:34 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/dump.lisp,v 1.89 2010-11-10 19:51:24 rtoy Exp $")
+ "$Header: /project/cmucl/cvsroot/src/compiler/dump.lisp,v 1.90 2010-12-04 17:32:34 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -1635,14 +1635,16 @@
bytes-per-element)
(type unsigned-byte elements))
(if (stringp data-vector)
- ;; Don't swap string bytes. We get here only if we're
- ;; cross-compiling from one arch to a different endian
- ;; arch. To be able to load the fasls, we need to keep
- ;; strings in the native format. When genesis is done,
- ;; genesis will swap string bytes when creating the
- ;; core so that the bytes are in the correct order.
- (dotimes (index elements)
- (setf (aref result index) (char-code (aref data-vector index))))
+ (progn
+ ;;(format t "reverse string data: ~S~%" data-vector)
+ #+(or)
+ (dotimes (index elements)
+ (let ((c (char-code (aref data-vector index))))
+ (setf (aref result index) c)))
+ (dotimes (index elements)
+ (let ((c (char-code (aref data-vector index))))
+ (setf (aref result index) (logior (ash (ldb (byte 8 0) c) 8)
+ (ldb (byte 8 8) c))))))
(dotimes (index elements)
(let ((element (aref data-vector index))
(new-element 0))
Index: src/compiler/generic/new-genesis.lisp
diff -u src/compiler/generic/new-genesis.lisp:1.91 src/compiler/generic/new-genesis.lisp:1.92
--- src/compiler/generic/new-genesis.lisp:1.91 Thu Nov 11 16:48:24 2010
+++ src/compiler/generic/new-genesis.lisp Sat Dec 4 12:32:34 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.91 2010-11-11 21:48:24 rtoy Exp $")
+ "$Header: /project/cmucl/cvsroot/src/compiler/generic/new-genesis.lisp,v 1.92 2010-12-04 17:32:34 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -431,16 +431,22 @@
vm:simple-string-type))
(bytes (make-array (1+ len) :element-type '(unsigned-byte 16))))
(write-indexed des vm:vector-length-slot (make-fixnum-descriptor len))
- ;;(format t "s-t-c: len = ~d, ~S~%" len string)
+
(dotimes (k len)
(setf (aref bytes k) (logand #xffff (char-code (aref string k)))))
(unless (eq (c:backend-byte-order c:*backend*)
(c:backend-byte-order c:*native-backend*))
- ;; Swap byte order of unicode strings.
+ ;; Swap byte order of unicode strings if the backend and
+ ;; native-backend have different endianness.
+ #+(or)
+ (progn
+ (format t "s-t-c: len = ~d, ~S~%" len string)
+ (format t " codes = ~{~X~^ ~}~%" (map 'list #'char-code string)))
(dotimes (k len)
(let ((x (aref bytes k)))
- (setf (aref bytes k) (+ (ldb (byte 8 8) x)
- (ash (ldb (byte 8 0) x) 8))))))
+ (setf (aref bytes k) (maybe-byte-swap-short x))))
+ #+(or)
+ (format t " new codes = ~{~X~^ ~}~%" (coerce bytes 'list)))
(copy-to-system-area bytes (* vm:vector-data-offset
;; the word size of the native backend which
;; may be different from the target backend
@@ -1324,7 +1330,7 @@
#+unicode
(defmacro load-char-code ()
- (ecase (c::backend-byte-order c::*native-backend*)
+ (ecase (c::backend-byte-order c::*backend*)
(:little-endian
`(code-char (+ (read-arg 1)
(ash (read-arg 1) 8))))
@@ -1332,13 +1338,33 @@
`(code-char (+ (ash (read-arg 1) 8)
(read-arg 1))))))
+(declaim (inline swap-16))
+(defun swap-16 (n)
+ (declare (type (unsigned-byte 16) n))
+ (logior (ash (ldb (byte 8 0) n) 8)
+ (ldb (byte 8 8) n)))
+
+;; Destructively byte swap a string, if the backend and the native
+;; backend have different endianness.
+(defun maybe-byte-swap-string (s &optional (len (length s)))
+ (unless (eq (c:backend-byte-order c:*backend*)
+ (c:backend-byte-order c:*native-backend*))
+ (dotimes (k len)
+ (let ((code (char-code (aref s k))))
+ (setf (aref s k) (code-char (swap-16 code))))))
+ s)
+
#+unicode
(defun cold-load-symbol (size package)
(let ((string (make-string size)))
- #+nil
(read-n-bytes *fasl-file* string 0 (* 2 size))
- (dotimes (k size)
- (setf (aref string k) (load-char-code)))
+ #+(or)
+ (format t "pre swap cold-load-symbol: ~S to package ~S~%" string package)
+ ;; Make the string have the correct byte order for the native
+ ;; backend.
+ (maybe-byte-swap-string string)
+ #+(or)
+ (format t "post swap cold-load-symbol: ~S to package ~S~%" string package)
(cold-intern (intern string package) package)))
(clone-cold-fop (fop-symbol-save)
@@ -1378,10 +1404,8 @@
(fop-uninterned-small-symbol-save)
(let* ((size (clone-arg))
(name (make-string size)))
- #+nil
- (read-n-bytes *fasl-file* name 0 size)
- (dotimes (k size)
- (setf (aref name k) (load-char-code)))
+ (read-n-bytes *fasl-file* name 0 (* 2 size))
+ (maybe-byte-swap-string name)
(let ((symbol (allocate-symbol name)))
(push-table symbol))))
@@ -1448,10 +1472,15 @@
(fop-small-string)
(let* ((len (clone-arg))
(string (make-string len)))
- #+nil
(read-n-bytes *fasl-file* string 0 (* 2 len))
- (dotimes (k len)
- (setf (aref string k) (load-char-code)))
+ #+(or)
+ (format t "pre fop-string result = ~{~X~^ ~}~%" (map 'list #'char-code string))
+ ;; Make the string have the correct byte order for the native
+ ;; backend. (This wouldn't be needed if string-to-core had an
+ ;; option to
+ (maybe-byte-swap-string string)
+ #+(or)
+ (format t "post fop-string result = ~{~X~^ ~}~%" (map 'list #'char-code string))
(string-to-core string)))
(clone-cold-fop (fop-vector)
@@ -1977,8 +2006,15 @@
#-unicode
(read-n-bytes *fasl-file* sym 0 len)
#+unicode
- (dotimes (k len)
- (setf (aref sym k) (load-char-code)))
+ (progn
+ (read-n-bytes *fasl-file* sym 0 (* 2 len))
+ #+(or)
+ (progn
+ (format t "foreign-fixup: ~S~%" sym)
+ (format t " codes: ~{~X~^ ~}~%" (map 'list #'char-code sym)))
+ (maybe-byte-swap-string sym)
+ #+(or)
+ (format t " swaps: ~S~%" sym))
(let ((offset (read-arg 4))
(value #+linkage-table (cold-register-foreign-linkage sym :code)
#-linkage-table (lookup-foreign-symbol sym)))
@@ -1996,8 +2032,15 @@
#-unicode
(read-n-bytes *fasl-file* sym 0 len)
#+unicode
- (dotimes (k len)
- (setf (aref sym k) (load-char-code)))
+ (progn
+ (read-n-bytes *fasl-file* sym 0 (* 2 len))
+ #+(or)
+ (progn
+ (format t "foreign-data-fixup: ~S~%" sym)
+ (format t " codes: ~{~X~^ ~}~%" (map 'list #'char-code sym)))
+ (maybe-byte-swap-string sym)
+ #+(or)
+ (format t " swaps: ~{~X~^ ~}~%" (map 'list #'char-code sym)))
(let ((offset (read-arg 4))
(value (cold-register-foreign-linkage sym :data)))
(do-cold-fixup code-object offset value kind))
@@ -2200,8 +2243,8 @@
type
*cold-linkage-table*
*cold-foreign-hash*)))
- (+ vm:target-foreign-linkage-space-start
- (* entry-num vm:target-foreign-linkage-entry-size))))
+ (+ (c:backend-foreign-linkage-space-start c:*backend*)
+ (* entry-num (c:backend-foreign-linkage-entry-size c:*backend*)))))
#+linkage-table
(defun init-foreign-linkage ()
Index: src/compiler/ppc/parms.lisp
diff -u src/compiler/ppc/parms.lisp:1.19 src/compiler/ppc/parms.lisp:1.20
--- src/compiler/ppc/parms.lisp:1.19 Thu Jun 11 12:04:00 2009
+++ src/compiler/ppc/parms.lisp Sat Dec 4 12:32:34 2010
@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group at cs.cmu.edu.
;;;
(ext:file-comment
- "$Header: /project/cmucl/cvsroot/src/compiler/ppc/parms.lisp,v 1.19 2009-06-11 16:04:00 rtoy Rel $")
+ "$Header: /project/cmucl/cvsroot/src/compiler/ppc/parms.lisp,v 1.20 2010-12-04 17:32:34 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -37,6 +37,11 @@
(setf (backend-byte-order *target-backend*) :big-endian)
(setf (backend-page-size *target-backend*) 4096)
+(setf (c::backend-foreign-linkage-space-start *target-backend*)
+ #x17000000
+ (c::backend-foreign-linkage-entry-size *target-backend*)
+ 32)
+
); eval-when
(pushnew :new-assembler *features*)
Index: src/compiler/sparc/parms.lisp
diff -u src/compiler/sparc/parms.lisp:1.61 src/compiler/sparc/parms.lisp:1.62
--- src/compiler/sparc/parms.lisp:1.61 Mon Apr 19 14:21:31 2010
+++ src/compiler/sparc/parms.lisp Sat Dec 4 12:32:34 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/parms.lisp,v 1.61 2010-04-19 18:21:31 rtoy Rel $")
+ "$Header: /project/cmucl/cvsroot/src/compiler/sparc/parms.lisp,v 1.62 2010-12-04 17:32:34 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -47,6 +47,13 @@
(setf (backend-page-size *target-backend*)
#+mach 4096 #+sunos 8192)
+(setf (c::backend-foreign-linkage-space-start *target-backend*)
+ ;; This better match the value in sparc-validate.h!
+ #x0f800000
+ (c::backend-foreign-linkage-entry-size *target-backend*)
+ ;; This better agree with what sparc-arch.c thinks it is! Right now,
+ ;; it's 4 instructions, so 16 bytes.
+ 16)
); eval-when
(pushnew :new-assembler *features*)
@@ -213,11 +220,10 @@
(defconstant target-static-space-start #x28000000)
(defconstant target-dynamic-space-start #x40000000)
-;; This better match the value in sparc-validate.h!
-(defconstant target-foreign-linkage-space-start #x0f800000)
-;; This better agree with what sparc-arch.c thinks it is! Right now,
-;; it's 4 instructions, so 16 bytes.
-(defconstant target-foreign-linkage-entry-size 16)
+(defconstant target-foreign-linkage-space-start
+ (c:backend-foreign-linkage-space-start *target-backend*))
+(defconstant target-foreign-linkage-entry-size
+ (c:backend-foreign-linkage-entry-size *target-backend*))
;;;; Other random constants.
Index: src/compiler/x86/parms.lisp
diff -u src/compiler/x86/parms.lisp:1.40 src/compiler/x86/parms.lisp:1.41
--- src/compiler/x86/parms.lisp:1.40 Wed Jul 14 09:14:53 2010
+++ src/compiler/x86/parms.lisp Sat Dec 4 12:32:34 2010
@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group at cs.cmu.edu.
;;;
(ext:file-comment
- "$Header: /project/cmucl/cvsroot/src/compiler/x86/parms.lisp,v 1.40 2010-07-14 13:14:53 rtoy Rel $")
+ "$Header: /project/cmucl/cvsroot/src/compiler/x86/parms.lisp,v 1.41 2010-12-04 17:32:34 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -62,6 +62,12 @@
|#
(setf (backend-page-size *target-backend*) 4096)
+
+(setf (c::backend-foreign-linkage-space-start *target-backend*)
+ #+linux #x58000000
+ #-linux #xB0000000
+ (c::backend-foreign-linkage-entry-size *target-backend*)
+ 8)
); eval-when
@@ -213,9 +219,9 @@
#+linux #x58100000
#-linux #x48000000)
(defconstant target-foreign-linkage-space-start
- #+linux #x58000000
- #-linux #xB0000000)
-(defconstant target-foreign-linkage-entry-size 8) ;In bytes. Duh.
+ (c:backend-foreign-linkage-space-start *target-backend*))
+(defconstant target-foreign-linkage-entry-size
+ (c:backend-foreign-linkage-entry-size *target-backend*)) ;In bytes. Duh.
;;; Given that NIL is the first thing allocated in static space, we
;;; know its value at compile time:
Index: src/lisp/os-common.c
diff -u src/lisp/os-common.c:1.31 src/lisp/os-common.c:1.32
--- src/lisp/os-common.c:1.31 Mon Feb 1 14:27:07 2010
+++ src/lisp/os-common.c Sat Dec 4 12:32:34 2010
@@ -1,6 +1,6 @@
/*
- $Header: /project/cmucl/cvsroot/src/lisp/os-common.c,v 1.31 2010-02-01 19:27:07 rtoy Rel $
+ $Header: /project/cmucl/cvsroot/src/lisp/os-common.c,v 1.32 2010-12-04 17:32:34 rtoy Exp $
This code was written as part of the CMU Common Lisp project at
Carnegie Mellon University, and has been placed in the public domain.
@@ -195,6 +195,23 @@
*/
convert_lisp_string(c_symbol_name, symbol_name->data, (symbol_name->length >> 2));
+
+#if 0
+ fprintf(stderr, "i =%2d: %s\n", i, c_symbol_name);
+ {
+ int k;
+ unsigned short int* wide_string;
+
+ fprintf(stderr, " symbol_name->data = ");
+
+ wide_string = (unsigned short int *) symbol_name->data;
+
+ for (k = 0; k < (symbol_name->length >> 2); ++k) {
+ fprintf(stderr, "%4x ", wide_string[k]);
+ }
+ fprintf(stderr, "\n");
+ }
+#endif
if (i == 0) {
#if defined(sparc)
if (type != LINKAGE_CODE_TYPE || strcmp(c_symbol_name, "call_into_c")) {
@@ -226,6 +243,20 @@
void *target_addr = os_dlsym(c_symbol_name, NIL);
if (!target_addr) {
+#if 0
+ int k;
+ unsigned short int* wide_string;
+
+ fprintf(stderr, "c_symbol_name = `%s'\n", c_symbol_name);
+ fprintf(stderr, "symbol_name->data = \n");
+
+ wide_string = (unsigned short int *) symbol_name->data;
+
+ for (k = 0; k < (symbol_name->length >> 2); ++k) {
+ fprintf(stderr, "%4x ", wide_string[k]);
+ }
+ fprintf(stderr, "\n");
+#endif
lose("%s is not defined.\n", c_symbol_name);
}
arch_make_linkage_entry(i / LINKAGE_DATA_ENTRY_SIZE, target_addr,
Index: src/tools/cross-scripts/cross-x86-sparc.lisp
diff -u /dev/null src/tools/cross-scripts/cross-x86-sparc.lisp:1.2
--- /dev/null Sat Dec 4 12:32:35 2010
+++ src/tools/cross-scripts/cross-x86-sparc.lisp Sat Dec 4 12:32:35 2010
@@ -0,0 +1,377 @@
+;;; Cross-compile script to build a sparc core using x86 as the
+;;; compiling system. This needs work!
+
+(in-package :cl-user)
+
+;;; Rename the X86 package and backend so that new-backend does the
+;;; right thing.
+(rename-package "X86" "OLD-X86" '("OLD-VM"))
+(setf (c:backend-name c:*native-backend*) "OLD-X86")
+
+(c::new-backend "SPARC"
+ ;; Features to add here
+ '(:sparc
+ :sparc-v9 ; For Ultrasparc processors
+ :complex-fp-vops ; Some slightly faster FP vops on complex numbers
+ :linkage-table
+ :stack-checking ; Throw error if we run out of stack
+ :heap-overflow-check ; Throw error if we run out of
+ ; heap (This requires gencgc!)
+ :gencgc ; Generational GC
+ :relative-package-names ; Relative package names from Allegro
+ :conservative-float-type
+ :hash-new
+ :random-mt19937 ; MT-19937 generator
+ :cmu ; Announce this is CMUCL
+ :cmu20 :cmu20b ; Current version identifier
+ :modular-arith ; Modular arithmetic
+ :double-double ; Double-double float support
+ :executable
+
+ :solaris
+ :svr4
+ :sun4
+ :sunos
+ :unix
+ )
+ ;; Features to remove from current *features* here
+ '(:sparc-v8 :sparc-v7 ; Choose only one of :sparc-v7, :sparc-v8, :sparc-v9
+ ;; Other architectures we aren't using. Particularly important
+ ;; to get rid of sse2 and x87 so we don't accidentally try to
+ ;; compile the x87/sse2 float support on sparc, which won't work.
+ :x86 :x86-bootstrap :sse2 :x87 :i486
+ :alpha :osf1 :mips
+ ;; Really old stuff that should have been removed long ago.
+ :propagate-fun-type :propagate-float-type :constrain-float-type
+ ;; Other OSes were not using
+ :openbsd :freebsd :glibc2 :linux :mach-o :darwin :bsd
+
+ :pentium
+ :long-float
+ :new-random
+ :small
+ :mp))
+
+;;; Changes needed to bootstrap cross-compiling from x86 to sparc
+
+;; Set up the linkage space stuff appropriately for sparc.
+(setf (c::backend-foreign-linkage-space-start c::*target-backend*)
+ #x0f800000
+ (c::backend-foreign-linkage-entry-size c::*target-backend*)
+ 16)
+
+(in-package "LISP")
+;; We need the the fops because the cross-compiled fasl file is in
+;; big-endian order for sparc. When we read in a string, we need to
+;; convert the big-endian string to little-endian for x86 so we can
+;; process the symbols and such as expected.
+(progn
+(defun maybe-swap-string (f name &optional (len (length name)))
+ (declare (ignorable f))
+ (unless (eq (c:backend-byte-order c:*backend*)
+ (c:backend-byte-order c:*native-backend*))
+ (dotimes (k len)
+ (let ((code (char-code (aref name k))))
+ (setf (aref name k)
+ (code-char (logior (ash (ldb (byte 8 0) code) 8)
+ (ldb (byte 8 8) code))))))
+ ;;(format t "~S: new name = ~S~%" f (subseq name 0 len))
+ name))
+
+(macrolet ((frob (name code name-size package)
+ (let ((n-package (gensym "PACKAGE-"))
+ (n-size (gensym "SIZE-"))
+ (n-buffer (gensym "BUFFER-"))
+ (k (gensym "IDX-")))
+ `(define-fop (,name ,code)
+ (prepare-for-fast-read-byte *fasl-file*
+ (let ((,n-package ,package)
+ (,n-size (fast-read-u-integer ,name-size)))
+ (when (> ,n-size *load-symbol-buffer-size*)
+ (setq *load-symbol-buffer*
+ (make-string (setq *load-symbol-buffer-size*
+ (* ,n-size 2)))))
+ (done-with-fast-read-byte)
+ (let ((,n-buffer *load-symbol-buffer*))
+ (read-n-bytes *fasl-file* ,n-buffer 0
+ (* old-vm:char-bytes ,n-size))
+ (maybe-swap-string ',name ,n-buffer ,n-size)
+ (push-table (intern* ,n-buffer ,n-size ,n-package)))))))))
+ (frob fop-symbol-save 6 4 *package*)
+ (frob fop-small-symbol-save 7 1 *package*)
+ (frob fop-lisp-symbol-save 75 4 *lisp-package*)
+ (frob fop-lisp-small-symbol-save 76 1 *lisp-package*)
+ (frob fop-keyword-symbol-save 77 4 *keyword-package*)
+ (frob fop-keyword-small-symbol-save 78 1 *keyword-package*)
+
+ (frob fop-symbol-in-package-save 8 4
+ (svref *current-fop-table* (fast-read-u-integer 4)))
+ (frob fop-small-symbol-in-package-save 9 1
+ (svref *current-fop-table* (fast-read-u-integer 4)))
+ (frob fop-symbol-in-byte-package-save 10 4
+ (svref *current-fop-table* (fast-read-u-integer 1)))
+ (frob fop-small-symbol-in-byte-package-save 11 1
+ (svref *current-fop-table* (fast-read-u-integer 1))))
+
+(define-fop (fop-package 14)
+ (let ((name (pop-stack)))
+ ;;(format t "xfop-package: ~{~X~^ ~}~%" (map 'list #'char-code name))
+ (or (find-package name)
+ (error (intl:gettext "The package ~S does not exist.") name))))
+
+(clone-fop (fop-string 37)
+ (fop-small-string 38)
+ (let* ((arg (clone-arg))
+ (res (make-string arg)))
+ (read-n-bytes *fasl-file* res 0
+ (* old-vm:char-bytes arg))
+ (maybe-swap-string 'fop-string res)
+ res))
+
+#+unicode
+(defun cold-load-symbol (size package)
+ (let ((string (make-string size)))
+ (read-n-bytes *fasl-file* string 0 (* 2 size))
+ ;;(format t "xpre swap cold-load-symbol: ~S to package ~S~%" string package)
+ (maybe-swap-string 'cold-load-symbol string)
+ ;;(format t "xpost swap cold-load-symbol: ~S to package ~S~%" string package)
+ (cold-intern (intern string package) package)))
+)
+
+
+;;; End changes needed to bootstrap cross-compiling from x86 to sparc
+
+;;; Extern-alien-name for the new backend.
+(in-package :vm)
+(defun extern-alien-name (name)
+ (declare (type simple-string name))
+ ;;(format t "extern-alien-name: ~S~%" name)
+ ;;(lisp::maybe-swap-string 'extern-alien-name (copy-seq name))
+ name)
+(export 'extern-alien-name)
+#+(or)
+(defun fixup-code-object (code offset fixup kind)
+ (declare (type index offset))
+ (unless (zerop (rem offset vm::word-bytes))
+ (error (intl:gettext "Unaligned instruction? offset=#x~X.") offset))
+ (system:without-gcing
+ (let ((sap (truly-the system-area-pointer
+ (%primitive c::code-instructions code))))
+ (ecase kind
+ (:call
+ (error (intl:gettext "Can't deal with CALL fixups, yet.")))
+ (:sethi
+ (setf (ldb (byte 22 0) (sap-ref-32 sap offset))
+ (ldb (byte 22 10) fixup)))
+ (:add
+ (setf (ldb (byte 10 0) (sap-ref-32 sap offset))
+ (ldb (byte 10 0) fixup)))))))
+(export 'fixup-code-object)
+#+(or)
+(defun sanctify-for-execution (component)
+ (without-gcing
+ (alien-funcall (extern-alien "os_flush_icache"
+ (function void
+ system-area-pointer
+ unsigned-long))
+ (code-instructions component)
+ (* (code-header-ref component code-code-size-slot)
+ word-bytes)))
+ nil)
+(export 'sanctify-for-execution)
+
+;;; Compile the new backend.
+(pushnew :bootstrap *features*)
+(pushnew :building-cross-compiler *features*)
+(load "target:tools/comcom")
+
+;;; Load the new backend.
+(setf (search-list "c:")
+ '("target:compiler/"))
+(setf (search-list "vm:")
+ '("c:sparc/" "c:generic/"))
+(setf (search-list "assem:")
+ '("target:assembly/" "target:assembly/sparc/"))
+
+;; Load the backend of the compiler.
+
+(in-package "C")
+
+(load "vm:vm-macs")
+(load "vm:parms")
+(load "vm:objdef")
+(load "vm:interr")
+(load "assem:support")
+
+(load "target:compiler/srctran")
+(load "vm:vm-typetran")
+(load "target:compiler/float-tran")
+(load "target:compiler/saptran")
+
+(load "vm:macros")
+(load "vm:utils")
+
+(load "vm:vm")
+(load "vm:insts")
+(load "vm:primtype")
+(load "vm:move")
+(load "vm:sap")
+(load "vm:system")
+(load "vm:char")
+(load "vm:float")
+
+(load "vm:memory")
+(load "vm:static-fn")
+(load "vm:arith")
+(load "vm:cell")
+(load "vm:subprim")
+(load "vm:debug")
+(load "vm:c-call")
+(load "vm:print")
+(load "vm:alloc")
+(load "vm:call")
+(load "vm:nlx")
+(load "vm:values")
+(load "vm:array")
+(load "vm:pred")
+(load "vm:type-vops")
+
+(load "assem:assem-rtns")
+
+(load "assem:array")
+(load "assem:arith")
+(load "assem:alloc")
+
+(load "c:pseudo-vops")
+
+(check-move-function-consistency)
+
+(load "vm:new-genesis")
+
+;;; OK, the cross compiler backend is loaded.
+
+(setf *features* (remove :building-cross-compiler *features*))
+
+;;; Info environment hacks.
+(macrolet ((frob (&rest syms)
+ `(progn ,@(mapcar #'(lambda (sym)
+ `(defconstant ,sym
+ (symbol-value
+ (find-symbol ,(symbol-name sym)
+ :vm))))
+ syms))))
+ (frob OLD-VM:BYTE-BITS OLD-VM:WORD-BITS
+ OLD-VM:CHAR-BITS
+ OLD-VM:LOWTAG-BITS
+ #+long-float OLD-VM:SIMPLE-ARRAY-LONG-FLOAT-TYPE
+ OLD-VM:SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE
+ OLD-VM:SIMPLE-ARRAY-SINGLE-FLOAT-TYPE
+ #+long-float OLD-VM:SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-TYPE
+ OLD-VM:SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-TYPE
+ OLD-VM:SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-TYPE
+ OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-2-TYPE
+ OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-4-TYPE
+ OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-8-TYPE
+ OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-16-TYPE
+ OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-32-TYPE
+ OLD-VM:SIMPLE-ARRAY-SIGNED-BYTE-8-TYPE
+ OLD-VM:SIMPLE-ARRAY-SIGNED-BYTE-16-TYPE
+ OLD-VM:SIMPLE-ARRAY-SIGNED-BYTE-30-TYPE
+ OLD-VM:SIMPLE-ARRAY-SIGNED-BYTE-32-TYPE
+ OLD-VM:SIMPLE-BIT-VECTOR-TYPE
+ OLD-VM:SIMPLE-STRING-TYPE OLD-VM:SIMPLE-VECTOR-TYPE
+ OLD-VM:SIMPLE-ARRAY-TYPE OLD-VM:VECTOR-DATA-OFFSET
+ OLD-VM:DOUBLE-FLOAT-DIGITS
+ old-vm:single-float-digits
+ OLD-VM:DOUBLE-FLOAT-EXPONENT-BYTE
+ OLD-VM:DOUBLE-FLOAT-NORMAL-EXPONENT-MAX
+ OLD-VM:DOUBLE-FLOAT-SIGNIFICAND-BYTE
+ OLD-VM:SINGLE-FLOAT-EXPONENT-BYTE
+ OLD-VM:SINGLE-FLOAT-NORMAL-EXPONENT-MAX
+ OLD-VM:SINGLE-FLOAT-SIGNIFICAND-BYTE
+ )
+ #+double-double
+ (frob OLD-VM:SIMPLE-ARRAY-COMPLEX-DOUBLE-DOUBLE-FLOAT-TYPE
+ OLD-VM:SIMPLE-ARRAY-DOUBLE-DOUBLE-FLOAT-TYPE)
+ )
+
+(let ((function (symbol-function 'kernel:error-number-or-lose)))
+ (let ((*info-environment* (c:backend-info-environment c:*target-backend*)))
+ (setf (symbol-function 'kernel:error-number-or-lose) function)
+ (setf (info function kind 'kernel:error-number-or-lose) :function)
+ (setf (info function where-from 'kernel:error-number-or-lose) :defined)))
+
+(defun fix-class (name)
+ (let* ((new-value (find-class name))
+ (new-layout (kernel::%class-layout new-value))
+ (new-cell (kernel::find-class-cell name))
+ (*info-environment* (c:backend-info-environment c:*target-backend*)))
+ (remhash name kernel::*forward-referenced-layouts*)
+ (kernel::%note-type-defined name)
+ (setf (info type kind name) :instance)
+ (setf (info type class name) new-cell)
+ (setf (info type compiler-layout name) new-layout)
+ new-value))
+(fix-class 'c::vop-parse)
+(fix-class 'c::operand-parse)
+
+#+random-mt19937
+(declaim (notinline kernel:random-chunk))
+
+(setf c:*backend* c:*target-backend*)
+
+;;; Extern-alien-name for the new backend.
+(in-package :vm)
+(defun extern-alien-name (name)
+ (declare (type simple-string name))
+ ;;(format t "extern-alien-name: ~S~%" name)
+ ;;(lisp::maybe-swap-string 'extern-alien-name (copy-seq name))
+ name)
+(export 'extern-alien-name)
+#+(or)
+(defun fixup-code-object (code offset fixup kind)
+ (declare (type index offset))
+ (unless (zerop (rem offset vm::word-bytes))
+ (error (intl:gettext "Unaligned instruction? offset=#x~X.") offset))
+ (system:without-gcing
+ (let ((sap (truly-the system-area-pointer
+ (%primitive c::code-instructions code))))
+ (ecase kind
+ (:call
+ (error (intl:gettext "Can't deal with CALL fixups, yet.")))
+ (:sethi
+ (setf (ldb (byte 22 0) (sap-ref-32 sap offset))
+ (ldb (byte 22 10) fixup)))
+ (:add
+ (setf (ldb (byte 10 0) (sap-ref-32 sap offset))
+ (ldb (byte 10 0) fixup)))))))
+(export 'fixup-code-object)
+#+(or)
+(defun sanctify-for-execution (component)
+ (without-gcing
+ (alien-funcall (extern-alien "os_flush_icache"
+ (function void
+ system-area-pointer
+ unsigned-long))
+ (code-instructions component)
+ (* (code-header-ref component code-code-size-slot)
+ word-bytes)))
+ nil)
+(export 'sanctify-for-execution)
+
+(in-package :cl-user)
+
+;;; Don't load compiler parts from the target compilation
+
+(defparameter *load-stuff* nil)
+
+;; hack, hack, hack: Make old-x86::any-reg the same as
+;; x86::any-reg as an SC. Do this by adding old-x86::any-reg
+;; to the hash table with the same value as x86::any-reg.
+
+(let ((ht (c::backend-sc-names c::*target-backend*)))
+ (setf (gethash 'old-vm::any-reg ht)
+ (gethash 'vm::any-reg ht)))
+
+
+;;(pushnew :debug *features*)
More information about the cmucl-cvs
mailing list