diff --git a/compiler/dump.lisp b/compiler/dump.lisp index b42d4a8d6bb3c316b1fad1b70a2f474dc5fd97f5..124d6dc886b73ba587be81e4c644e5d730a8ec4c 100644 --- a/compiler/dump.lisp +++ b/compiler/dump.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/dump.lisp,v 1.89 2010/11/10 19:51:24 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/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)) diff --git a/compiler/generic/new-genesis.lisp b/compiler/generic/new-genesis.lisp index 767d4d8fbb336b16f11fff8eef51f93d8255df32..2eafbd61fb39330f0483a40608c21de1ac7dd67b 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.91 2010/11/11 21:48:24 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/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 () diff --git a/compiler/ppc/parms.lisp b/compiler/ppc/parms.lisp index a9ac0e705260c3fff4e0bb30720b0f250e79d967..b2f3ba0911a7bcc3884c6503d54c7669a29645f8 100644 --- a/compiler/ppc/parms.lisp +++ b/compiler/ppc/parms.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/parms.lisp,v 1.19 2009/06/11 16:04:00 rtoy Rel $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/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*) diff --git a/compiler/sparc/parms.lisp b/compiler/sparc/parms.lisp index cd4bd5a51326ca82fce521f43f9f2033f015622b..ac331a3f8c437040a6920d66a6fe6764b7535804 100644 --- a/compiler/sparc/parms.lisp +++ b/compiler/sparc/parms.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/parms.lisp,v 1.61 2010/04/19 18:21:31 rtoy Rel $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/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. diff --git a/compiler/x86/parms.lisp b/compiler/x86/parms.lisp index 1192ed1fef1c19cb1239969dc35014c1a2c59202..bfff6f61d808879bafc0252ed2d6128dfb82fb43 100644 --- a/compiler/x86/parms.lisp +++ b/compiler/x86/parms.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/parms.lisp,v 1.40 2010/07/14 13:14:53 rtoy Rel $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/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: diff --git a/lisp/os-common.c b/lisp/os-common.c index d27c7ddcb260c84e158eefec2ff2ea5fec055327..925f2c6c6bde328771d98f8df628451d8b9f1803 100644 --- a/lisp/os-common.c +++ b/lisp/os-common.c @@ -1,6 +1,6 @@ /* - $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/os-common.c,v 1.31 2010/02/01 19:27:07 rtoy Rel $ + $Header: /Volumes/share2/src/cmucl/cvs2git/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 @@ os_foreign_linkage_init(void) */ 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 @@ os_foreign_linkage_init(void) 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, diff --git a/tools/cross-scripts/cross-x86-sparc.lisp b/tools/cross-scripts/cross-x86-sparc.lisp new file mode 100644 index 0000000000000000000000000000000000000000..fbe573c1f632cadf3cc656368b910ef2030de29d --- /dev/null +++ b/tools/cross-scripts/cross-x86-sparc.lisp @@ -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*)