- cmucl-cvs - mailman3.common-lisp.net

[cmucl-cvs] CMUCL commit: src/compiler/generic (new-genesis.lisp)
by Raymond Toy 04 Dec '10

04 Dec '10

Date: Saturday, December 4, 2010 @ 18:17:06 Author: rtoy Path: /project/cmucl/cvsroot/src/compiler/generic Modified: new-genesis.lisp Clean up implementation. o Add an implementation of MAYBE-BYTE-SWAP-STRING for non-unicode builds. (Basically the identity function, since no swapping needed.) o Get rid of most unicode/non-unicode implementations of the fops by calling MAYBE-BYTE-SWAP-STRING. o Remove unused LOAD-CHAR-CODE macro. o Remove some debugging stuff. ------------------+ new-genesis.lisp | 94 ++++++++++------------------------------------------- 1 file changed, 18 insertions(+), 76 deletions(-) Index: src/compiler/generic/new-genesis.lisp diff -u src/compiler/generic/new-genesis.lisp:1.92 src/compiler/generic/new-genesis.lisp:1.93 --- src/compiler/generic/new-genesis.lisp:1.92 Sat Dec 4 12:32:34 2010 +++ src/compiler/generic/new-genesis.lisp Sat Dec 4 18:17:06 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.92 2010-12-04 17:32:34 rtoy Exp $") + "$Header: /project/cmucl/cvsroot/src/compiler/generic/new-genesis.lisp,v 1.93 2010-12-04 23:17:06 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1319,25 +1319,6 @@ ;;; Loading symbols... -;;; Cold-Load-Symbol loads a symbol N characters long from the File and interns -;;; that symbol in the given Package. -;;; -#-unicode -(defun cold-load-symbol (size package) - (let ((string (make-string size))) - (read-n-bytes *fasl-file* string 0 size) - (cold-intern (intern string package) package))) - -#+unicode -(defmacro load-char-code () - (ecase (c::backend-byte-order c::*backend*) - (:little-endian - `(code-char (+ (read-arg 1) - (ash (read-arg 1) 8)))) - (:big-endian - `(code-char (+ (ash (read-arg 1) 8) - (read-arg 1)))))) - (declaim (inline swap-16)) (defun swap-16 (n) (declare (type (unsigned-byte 16) n)) @@ -1346,6 +1327,8 @@ ;; Destructively byte swap a string, if the backend and the native ;; backend have different endianness. +(declaim (inline maybe-byte-swap-string)) +#+unicode (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*)) @@ -1353,18 +1336,20 @@ (let ((code (char-code (aref s k)))) (setf (aref s k) (code-char (swap-16 code)))))) s) +#-unicode +(defun maybe-byte-swap-string (s &optional len) + (declare (ignore s len)) + s) -#+unicode +;;; Cold-Load-Symbol loads a symbol N characters long from the File and interns +;;; that symbol in the given Package. +;;; (defun cold-load-symbol (size package) (let ((string (make-string size))) - (read-n-bytes *fasl-file* string 0 (* 2 size)) - #+(or) - (format t "pre swap cold-load-symbol: ~S to package ~S~%" string package) + (read-n-bytes *fasl-file* string 0 (* vm:char-bytes size)) ;; 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) @@ -1390,21 +1375,11 @@ (fop-keyword-small-symbol-save) (push-table (cold-load-symbol (clone-arg) *keyword-package*))) -#-unicode -(clone-cold-fop (fop-uninterned-symbol-save) - (fop-uninterned-small-symbol-save) - (let* ((size (clone-arg)) - (name (make-string size))) - (read-n-bytes *fasl-file* name 0 size) - (let ((symbol (allocate-symbol name))) - (push-table symbol)))) - -#+unicode (clone-cold-fop (fop-uninterned-symbol-save) (fop-uninterned-small-symbol-save) (let* ((size (clone-arg)) (name (make-string size))) - (read-n-bytes *fasl-file* name 0 (* 2 size)) + (read-n-bytes *fasl-file* name 0 (* vm:char-bytes size)) (maybe-byte-swap-string name) (let ((symbol (allocate-symbol name))) (push-table symbol)))) @@ -1459,28 +1434,15 @@ ;;; Loading vectors... -#-unicode -(clone-cold-fop (fop-string) - (fop-small-string) - (let* ((len (clone-arg)) - (string (make-string len))) - (read-n-bytes *fasl-file* string 0 len) - (string-to-core string))) - -#+unicode (clone-cold-fop (fop-string) (fop-small-string) (let* ((len (clone-arg)) (string (make-string len))) - (read-n-bytes *fasl-file* string 0 (* 2 len)) - #+(or) - (format t "pre fop-string result = ~{~X~^ ~}~%" (map 'list #'char-code string)) + (read-n-bytes *fasl-file* string 0 (* vm:char-bytes len)) ;; 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 + ;; option not to swap bytes. (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) @@ -2003,18 +1965,8 @@ (code-object (pop-stack)) (len (read-arg 1)) (sym (make-string len))) - #-unicode - (read-n-bytes *fasl-file* sym 0 len) - #+unicode - (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)) + (read-n-bytes *fasl-file* sym 0 (* vm:char-bytes len)) + (maybe-byte-swap-string sym) (let ((offset (read-arg 4)) (value #+linkage-table (cold-register-foreign-linkage sym :code) #-linkage-table (lookup-foreign-symbol sym))) @@ -2029,18 +1981,8 @@ (code-object (pop-stack)) (len (read-arg 1)) (sym (make-string len))) - #-unicode - (read-n-bytes *fasl-file* sym 0 len) - #+unicode - (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))) + (read-n-bytes *fasl-file* sym 0 (* vm:char-bytes len)) + (maybe-byte-swap-string sym) (let ((offset (read-arg 4)) (value (cold-register-foreign-linkage sym :data))) (do-cold-fixup code-object offset value kind))

1 0

[cmucl-cvs] CMUCL commit: src (7 files)
by Raymond Toy 04 Dec '10

04 Dec '10

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(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.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(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.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*)

1 0

[cmucl-cvs] CMUCL commit: src/bootfiles/20b (boot-2010-11-1-cross.lisp)
by Raymond Toy 03 Dec '10

03 Dec '10

Date: Friday, December 3, 2010 @ 10:04:32 Author: rtoy Path: /project/cmucl/cvsroot/src/bootfiles/20b Modified: boot-2010-11-1-cross.lisp Add comment. ---------------------------+ boot-2010-11-1-cross.lisp | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) Index: src/bootfiles/20b/boot-2010-11-1-cross.lisp diff -u src/bootfiles/20b/boot-2010-11-1-cross.lisp:1.1 src/bootfiles/20b/boot-2010-11-1-cross.lisp:1.2 --- src/bootfiles/20b/boot-2010-11-1-cross.lisp:1.1 Wed Nov 10 14:51:23 2010 +++ src/bootfiles/20b/boot-2010-11-1-cross.lisp Fri Dec 3 10:04:32 2010 @@ -1,4 +1,5 @@ -;;; Adding slots to the backend requires a cross-compile. +;;; Bootstrap for building the 2010-12 snapshot. Adding slots to the +;;; backend requires a cross-compile. ;;; ;;; Answer CLOBBER-IT for the restart about changing the size of the ;;; backend structure.

1 0

[cmucl-cvs] CMUCL commit: src/i18n/locale (cmucl.pot)
by Raymond Toy 02 Dec '10

02 Dec '10

Date: Thursday, December 2, 2010 @ 16:12:40 Author: rtoy Path: /project/cmucl/cvsroot/src/i18n/locale Modified: cmucl.pot Regenerated from current sources. -----------+ cmucl.pot | 4 ++++ 1 file changed, 4 insertions(+) Index: src/i18n/locale/cmucl.pot diff -u src/i18n/locale/cmucl.pot:1.17 src/i18n/locale/cmucl.pot:1.18 --- src/i18n/locale/cmucl.pot:1.17 Mon Nov 8 09:02:40 2010 +++ src/i18n/locale/cmucl.pot Thu Dec 2 16:12:40 2010 @@ -7763,6 +7763,10 @@ msgstr "" #: src/code/format.lisp +msgid "~~:; directive not effective in ~~:[" +msgstr "" + +#: src/code/format.lisp msgid "Must specify exactly two sections." msgstr ""

1 0

[cmucl-cvs] CMUCL commit: src/general-info (release-20c.txt)
by Raymond Toy 02 Dec '10

02 Dec '10

Date: Thursday, December 2, 2010 @ 09:26:46 Author: rtoy Path: /project/cmucl/cvsroot/src/general-info Modified: release-20c.txt Update from logs. -----------------+ release-20c.txt | 1 + 1 file changed, 1 insertion(+) Index: src/general-info/release-20c.txt diff -u src/general-info/release-20c.txt:1.12 src/general-info/release-20c.txt:1.13 --- src/general-info/release-20c.txt:1.12 Tue Nov 30 08:51:29 2010 +++ src/general-info/release-20c.txt Thu Dec 2 09:26:45 2010 @@ -26,6 +26,7 @@ Slime to do character name completion. * Changes + - ASDF2 updated to version 2.010. - COMPILE-FILE now accepts a :DECODING-ERROR argument that indicates how to handle decoding errors when reading the file. It has the same meaning and effect as the :DECODING-ERROR

1 0

[cmucl-cvs] CMUCL commit: src/tools/cross-scripts (cross-x86-osx-freebsd.lisp)
by Raymond Toy 01 Dec '10

01 Dec '10

Date: Wednesday, December 1, 2010 @ 08:55:25 Author: rtoy Path: /project/cmucl/cvsroot/src/tools/cross-scripts Added: cross-x86-osx-freebsd.lisp Initial version of script to cross-compile from x86 OSX to x86 FreeBSD. ----------------------------+ cross-x86-osx-freebsd.lisp | 228 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 228 insertions(+) Index: src/tools/cross-scripts/cross-x86-osx-freebsd.lisp diff -u /dev/null src/tools/cross-scripts/cross-x86-osx-freebsd.lisp:1.1 --- /dev/null Wed Dec 1 08:55:25 2010 +++ src/tools/cross-scripts/cross-x86-osx-freebsd.lisp Wed Dec 1 08:55:25 2010 @@ -0,0 +1,228 @@ +;; Basic cross-compile script for cross-compiling from x86 on darwin +;; (Mac OS X) to x86 on FreeBSD. This is a basic x86-to-x86 +;; cross-compile, except we tweek the features and misfeatures to +;; match the FreeBSD features. + +(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 "X86" + ;; Features to add here. These are just examples. You may not + ;; need to list anything here. We list them here anyway as a + ;; record of typical features for all x86 ports. + '(:x86 + :i486 + :pentium + :stack-checking ; Catches stack overflow + :heap-overflow-check ; Catches heap overflows + :relative-package-names ; relative package names + :mp ; multiprocessing + :gencgc ; Generational GC + :conservative-float-type + :complex-fp-vops + :hash-new + :random-mt19937 + :cmu :cmu20 :cmu20b ; Version features + :double-double ; double-double float support + :linkage-table + + :freebsd :bsd :elf + ;; The :sse2 and :x87 features will get set by the compiling + ;; lisp, so don't set it here! + ) + ;; Features to remove from current *features* here. Normally don't + ;; need to list anything here unless you are trying to remove a + ;; feature. + '(:x86-bootstrap + ;; :alpha :osf1 :mips + :propagate-fun-type :propagate-float-type :constrain-float-type + ;; :openbsd :freebsd :glibc2 :linux + :mach-o :darwin + :long-float :new-random :small)) + +;;; Compile the new backend. +(pushnew :bootstrap *features*) +(pushnew :building-cross-compiler *features*) + +;; Make fixup-code-object and sanctify-for-execution in the VM package +;; be the same as the original. Needed to get rid of a compiler error +;; in generic/core.lisp. (This halts cross-compilations if the +;; compiling lisp uses the -batch flag. +(import 'old-vm::fixup-code-object "VM") +(import 'old-vm::sanctify-for-execution "VM") +(export 'vm::fixup-code-object "VM") +(export 'vm::sanctify-for-execution "VM") + +(load "target:tools/comcom") + +;;; Load the new backend. +(setf (search-list "c:") + '("target:compiler/")) +(setf (search-list "vm:") + '("c:x86/" "c:generic/")) +(setf (search-list "assem:") + '("target:assembly/" "target:assembly/x86/")) + +;; 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") +(when (target-featurep :sse2) + (load "vm:sse2-sap")) +(load "vm:system") +(load "vm:char") +(if (target-featurep :sse2) + (load "vm:float-sse2") + (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") +(if (target-featurep :sse2) + (load "vm:sse2-c-call") + (load "vm:x87-c-call")) + +(load "vm:print") +(load "vm:alloc") +(load "vm:call") +(load "vm:nlx") +(load "vm:values") +;; These need to be loaded before array because array wants to use +;; some vops as templates. +(load (if (target-featurep :sse2) + "vm:sse2-array" + "vm:x87-array")) +(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 + #+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-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)) + +;; Modular arith hacks +(setf (fdefinition 'vm::ash-left-mod32) #'old-vm::ash-left-mod32) +(setf (fdefinition 'vm::lognot-mod32) #'old-vm::lognot-mod32) +;; End arith hacks + +(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)) + name) +(export 'extern-alien-name) +(in-package :cl-user) + +;;; Don't load compiler parts from the target compilation + +(defparameter *load-stuff* nil) + +;; hack, hack, hack: Make old-vm::any-reg the same as +;; x86::any-reg as an SC. Do this by adding old-vm::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)))

1 0

[cmucl-cvs] CMUCL commit: src/general-info (release-20c.txt)
by Raymond Toy 30 Nov '10

30 Nov '10

Date: Tuesday, November 30, 2010 @ 08:51:29 Author: rtoy Path: /project/cmucl/cvsroot/src/general-info Modified: release-20c.txt Clarify entry on realpart/imagpart bug. It's an x86-only problem, and only happens in some situations. -----------------+ release-20c.txt | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) Index: src/general-info/release-20c.txt diff -u src/general-info/release-20c.txt:1.11 src/general-info/release-20c.txt:1.12 --- src/general-info/release-20c.txt:1.11 Mon Nov 29 23:18:43 2010 +++ src/general-info/release-20c.txt Tue Nov 30 08:51:29 2010 @@ -66,8 +66,9 @@ Previously, it skipped over non-BMP codepoints. This also requires a fix in %COMPOSE to handle non-BMP codepoints correctly. The normalization test now passes. - - REALPART and IMAGPART no longer incorrectly returns 0 instead of - the correct part of a complex number. + - On x86, REALPART and IMAGPART no longer incorrectly returns 0 + instead of the correct part of a complex number in some + situations. - The command line parser now correctly handles the case where "--" is the first command option. - build.sh was accidenally loading the site-init file, but it

1 0

[cmucl-cvs] CMUCL commit: src/general-info (release-20c.txt)
by Raymond Toy 30 Nov '10

30 Nov '10

Date: Monday, November 29, 2010 @ 23:18:43 Author: rtoy Path: /project/cmucl/cvsroot/src/general-info Modified: release-20c.txt Update from commits. -----------------+ release-20c.txt | 2 ++ 1 file changed, 2 insertions(+) Index: src/general-info/release-20c.txt diff -u src/general-info/release-20c.txt:1.10 src/general-info/release-20c.txt:1.11 --- src/general-info/release-20c.txt:1.10 Tue Nov 16 14:27:39 2010 +++ src/general-info/release-20c.txt Mon Nov 29 23:18:43 2010 @@ -81,6 +81,8 @@ returned because GET-BEST-AUTHORIZATION was looking for the hostname. - FORMAT signals an warning if ~:; is used inside ~:[. + - SET-SYSTEM-EXTERNAL-FORMAT was not actually setting the filename + encoding if given. * Trac Tickets:

1 0

[cmucl-cvs] CMUCL commit: src/code (extfmts.lisp)
by Raymond Toy 30 Nov '10

30 Nov '10

Date: Monday, November 29, 2010 @ 23:09:42 Author: rtoy Path: /project/cmucl/cvsroot/src/code Modified: extfmts.lisp o *FILENAME-ENCODING* was never getting set. Fix that. (From Paul Foley.) o While we're here, canonicalize *FILENAME-ENCODING* using the actual external format name. --------------+ extfmts.lisp | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) Index: src/code/extfmts.lisp diff -u src/code/extfmts.lisp:1.41 src/code/extfmts.lisp:1.42 --- src/code/extfmts.lisp:1.41 Tue Sep 7 22:58:06 2010 +++ src/code/extfmts.lisp Mon Nov 29 23:09:42 2010 @@ -5,7 +5,7 @@ ;;; domain. ;;; (ext:file-comment - "$Header: /project/cmucl/cvsroot/src/code/extfmts.lisp,v 1.41 2010-09-08 02:58:06 rtoy Rel $") + "$Header: /project/cmucl/cvsroot/src/code/extfmts.lisp,v 1.42 2010-11-30 04:09:42 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1102,11 +1102,12 @@ (when filenames (unless (find-external-format filenames) (error (intl:gettext "Can't find external-format ~S.") filenames)) + (setq filenames (ef-name (find-external-format filenames))) (when (and unix::*filename-encoding* (not (eq unix::*filename-encoding* filenames))) (cerror (intl:gettext "Change it anyway.") - (intl:gettext "The external-format for encoding filenames is already set.")) - (setq unix::*filename-encoding* filenames))) + (intl:gettext "The external-format for encoding filenames is already set."))) + (setq unix::*filename-encoding* filenames)) t)

1 0

[cmucl-cvs] CMUCL commit: cross-sparc-branch src/compiler/sparc (parms.lisp)
by Raymond Toy 20 Nov '10

20 Nov '10

Date: Saturday, November 20, 2010 @ 10:45:05 Author: rtoy Path: /project/cmucl/cvsroot/src/compiler/sparc Tag: cross-sparc-branch Modified: parms.lisp Set up TARGET-FOREIGN-LINKAGE-SPACE-START and TARGET-FOREIGN-LINKAGE-ENTRY-SIZE from the backend values. ------------+ parms.lisp | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) Index: src/compiler/sparc/parms.lisp diff -u src/compiler/sparc/parms.lisp:1.61.6.1 src/compiler/sparc/parms.lisp:1.61.6.2 --- src/compiler/sparc/parms.lisp:1.61.6.1 Tue Nov 16 12:29:34 2010 +++ src/compiler/sparc/parms.lisp Sat Nov 20 10:45:05 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.6.1 2010-11-16 17:29:34 rtoy Exp $") + "$Header: /project/cmucl/cvsroot/src/compiler/sparc/parms.lisp,v 1.61.6.2 2010-11-20 15:45:05 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -48,8 +48,11 @@ #+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 @@ -217,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.

1 0