Date: Tuesday, November 16, 2010 @ 12:29:35
Author: rtoy
Path: /project/cmucl/cvsroot/src
Tag: cross-sparc-branch
Added: tools/cross-scripts/cross-x86-sparc.lisp
Modified: compiler/dump.lisp compiler/generic/new-genesis.lisp
compiler/ppc/parms.lisp compiler/sparc/parms.lisp
compiler/x86/parms.lisp
First cut at getting a cross-compile (Unicode) from x86 to sparc.
This needs more work, but the cross-compile does produce a sparc core
where the repl works. But currently that sparc core cannot rebuild
cmucl.
To do this, a version of cmucl from the HEAD branch needs to be
created to add the new slots to the backend. Then a new x86 build
needs to be done using these sources. Finally, a cross-compile can be
done using cross-x86-sparc.lisp as the cross-compile script.
compiler/dump.lisp:
o I think we actually do need to swap the string bytes when dumping
strings to a fasl because the fasl will eventually get loaded by the
target system, and the codes need to be in the correct byte order.
compiler/generic/new-genesis.lisp:
o LOAD-CHAR-CODE should test against C:*BACKEND*, not
C:*NATIVE-BACKEND*.
o Add MAYBE-BYTE-SWAP-STRING to swap the bytes of the character codes
if the *backend* and *native-backend* have different endianness.
o Swap the strings read from a fasl. The fasl should have strings in
the target endianness, but when we cold-load them, we need the
native endianness. (I think). This means swapping bytes in
COLD-LOAD-SYMBOL, FOP-UNINTERNED-SYMBOL-SAVE,
FOP-UNINTERNED-SMALL-SYMBOL-SAVE, FOP-STRING, FOP-SMALL-STRING.
o In MAKE-COLD-LINKAGE-VECTOR, byte swap the string before we store
the string to the core. The string in the linkage vector already
has the correct endianness, and string-to-core will swap the bytes.
(Not sure why the linkage string ares this way, though. This is a
hack.)
o Add optional swap-p paramter to COLD-REGISTER-FOREIGN-LINKAGE to
enable byte swapping of the symbol string. This is a hack to get
"call_into_c" into the correct byte order for the target and
MAKE-COLD-LINKAGE-VECTOR.
o Use the backend foreign-linkage-space-start and
foreign-linkage-entry-size for COLD-REGISTER-FOREIGN-LINKAGE. This
prevents the wrong addresses leaking into the target. (Previously,
the values form the native backend were getting used, which wreaks
havoc on the target since the addresses are not even close.)
compiler/ppc/parms.lisp:
o Set up the backend-foreign-linkage-space-start and
backend-foreign-linkage-entry-size with the correct values.
compiler/sparc/parms.lisp:
o Set up the backend-foreign-linkage-space-start and
backend-foreign-linkage-entry-size with the correct values.
compiler/x86/parms.lisp:
o Set up the backend-foreign-linkage-space-start and
backend-foreign-linkage-entry-size with the correct values.
tools/cross-scripts/cross-x86-sparc.lisp:
o New cross-compile script to do an x86 to sparc cross-compile. Needs
work.
------------------------------------------+
compiler/dump.lisp | 20 -
compiler/generic/new-genesis.lisp | 61 +++-
compiler/ppc/parms.lisp | 7
compiler/sparc/parms.lisp | 6
compiler/x86/parms.lisp | 8
tools/cross-scripts/cross-x86-sparc.lisp | 369 +++++++++++++++++++++++++++++
6 files changed, 439 insertions(+), 32 deletions(-)
Index: src/compiler/dump.lisp
diff -u src/compiler/dump.lisp:1.89 src/compiler/dump.lisp:1.89.2.1
--- src/compiler/dump.lisp:1.89 Wed Nov 10 14:51:24 2010
+++ src/compiler/dump.lisp Tue Nov 16 12:29: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.89.2.1 2010-11-16 17:29: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.91.2.1
--- src/compiler/generic/new-genesis.lisp:1.91 Thu Nov 11 16:48:24 2010
+++ src/compiler/generic/new-genesis.lisp Tue Nov 16 12:29: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.91.2.1 2010-11-16 17:29:34 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -431,16 +431,19 @@
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.
+ (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))))
+ (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 +1327,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 +1335,27 @@
`(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)))
+
+(defun maybe-byte-swap-string (s)
+ (unless (eq (c:backend-byte-order c:*backend*)
+ (c:backend-byte-order c:*native-backend*))
+ (dotimes (k (length s))
+ (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)))
+ (format t "pre swap cold-load-symbol: ~S to package ~S~%" string package)
+ (maybe-byte-swap-string string)
+ (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 +1395,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 +1463,10 @@
(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)))
+ (format t "pre fop-string result = ~{~X~^ ~}~%" (map 'list #'char-code string))
+ (maybe-byte-swap-string string)
+ (format t "post fop-string result = ~{~X~^ ~}~%" (map 'list #'char-code string))
(string-to-core string)))
(clone-cold-fop (fop-vector)
@@ -1596,6 +1611,9 @@
do (write-indexed data-vec (+ i vm:vector-data-offset)
(etypecase vec-elem
(string
+ (format t "make-cold-linkage-vector: string = ~{~X~^ ~}~%"
+ (map 'list #'char-code vec-elem))
+ (maybe-byte-swap-string vec-elem)
(string-to-core vec-elem))
(number
(number-to-core vec-elem))
@@ -2195,13 +2213,15 @@
(defvar *cold-foreign-hash* (make-hash-table :test #'equal))
#+linkage-table
-(defun cold-register-foreign-linkage (sym type)
- (let ((entry-num (register-foreign-linkage sym
+(defun cold-register-foreign-linkage (sym type &optional (swap-p nil))
+ (let ((entry-num (register-foreign-linkage (if swap-p
+ (maybe-byte-swap-string (copy-seq sym))
+ sym)
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 ()
@@ -2213,7 +2233,7 @@
(cold-register-foreign-linkage "resolve_linkage_tramp" :code)
#+(or sparc ppc)
(progn
- (cold-register-foreign-linkage (vm::extern-alien-name "call_into_c") :code)
+ (cold-register-foreign-linkage (vm::extern-alien-name "call_into_c") :code t)
#-sparc
(cold-register-foreign-linkage (vm::extern-alien-name "undefined_tramp") :data)
#-sparc
@@ -2461,6 +2481,7 @@
(defun linkage-info-to-core ()
(let ((result *nil-descriptor*))
(maphash #'(lambda (symbol value)
+ (format t "linkage-info symbol = ~S~%" symbol)
(cold-push (allocate-cons *dynamic*
(string-to-core symbol)
(number-to-core value))
Index: src/compiler/ppc/parms.lisp
diff -u src/compiler/ppc/parms.lisp:1.19 src/compiler/ppc/parms.lisp:1.19.20.1
--- src/compiler/ppc/parms.lisp:1.19 Thu Jun 11 12:04:00 2009
+++ src/compiler/ppc/parms.lisp Tue Nov 16 12:29:34 2010
@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group(a)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.19.20.1 2010-11-16 17:29: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.61.6.1
--- src/compiler/sparc/parms.lisp:1.61 Mon Apr 19 14:21:31 2010
+++ src/compiler/sparc/parms.lisp Tue Nov 16 12:29: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.61.6.1 2010-11-16 17:29:34 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -47,6 +47,10 @@
(setf (backend-page-size *target-backend*)
#+mach 4096 #+sunos 8192)
+(setf (c::backend-foreign-linkage-space-start *target-backend*)
+ #x0f800000
+ (c::backend-foreign-linkage-entry-size *target-backend*)
+ 16)
); eval-when
(pushnew :new-assembler *features*)
Index: src/compiler/x86/parms.lisp
diff -u src/compiler/x86/parms.lisp:1.40 src/compiler/x86/parms.lisp:1.40.6.1
--- src/compiler/x86/parms.lisp:1.40 Wed Jul 14 09:14:53 2010
+++ src/compiler/x86/parms.lisp Tue Nov 16 12:29:35 2010
@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group(a)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.40.6.1 2010-11-16 17:29:35 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
Index: src/tools/cross-scripts/cross-x86-sparc.lisp
diff -u /dev/null src/tools/cross-scripts/cross-x86-sparc.lisp:1.1.2.1
--- /dev/null Tue Nov 16 12:29:35 2010
+++ src/tools/cross-scripts/cross-x86-sparc.lisp Tue Nov 16 12:29:35 2010
@@ -0,0 +1,369 @@
+;;; 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.
+ :x86 :x86-bootstrap :sse2 :x87
+ :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
+(setf (c::backend-foreign-linkage-space-start c::*target-backend*)
+ #x0f800000
+ (c::backend-foreign-linkage-entry-size c::*target-backend*)
+ 16)
+
+(in-package "LISP")
+(progn
+(defun maybe-swap-string (f name &optional (len (length name)))
+ (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 name)
+ 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))
+ ;; Byte swap 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-byte-swap-string 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*)
