[cmucl-commit] CMUCL commit: src/compiler/generic (new-genesis.lisp)
Raymond Toy
rtoy at common-lisp.net
Sat Dec 11 16:07:08 CET 2010
Date: Saturday, December 11, 2010 @ 10:07:08
Author: rtoy
Path: /project/cmucl/cvsroot/src/compiler/generic
Modified: new-genesis.lisp
Revert some of the previous cleanups. They were preventing building
on sparc for some reason. We keep the unicode and non-unicode fops
separate for now.
------------------+
new-genesis.lisp | 85 ++++++++++++++++++++++++++++++++++++-----------------
1 file changed, 59 insertions(+), 26 deletions(-)
Index: src/compiler/generic/new-genesis.lisp
diff -u src/compiler/generic/new-genesis.lisp:1.93 src/compiler/generic/new-genesis.lisp:1.94
--- src/compiler/generic/new-genesis.lisp:1.93 Sat Dec 4 18:17:06 2010
+++ src/compiler/generic/new-genesis.lisp Sat Dec 11 10:07:08 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.93 2010-12-04 23:17:06 rtoy Exp $")
+ "$Header: /project/cmucl/cvsroot/src/compiler/generic/new-genesis.lisp,v 1.94 2010-12-11 15:07:08 rtoy Exp $")
;;;
;;; **********************************************************************
;;;
@@ -431,22 +431,15 @@
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))
-
(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 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)))
+ ;; Swap byte order of unicode strings.
(dotimes (k len)
(let ((x (aref bytes k)))
- (setf (aref bytes k) (maybe-byte-swap-short x))))
- #+(or)
- (format t " new codes = ~{~X~^ ~}~%" (coerce bytes 'list)))
+ (setf (aref bytes k) (+ (ldb (byte 8 8) x)
+ (ash (ldb (byte 8 0) x) 8))))))
(copy-to-system-area bytes (* vm:vector-data-offset
;; the word size of the native backend which
;; may be different from the target backend
@@ -1340,15 +1333,30 @@
(defun maybe-byte-swap-string (s &optional len)
(declare (ignore s len))
s)
-
+
;;; 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::*native-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))))))
+
+#+unicode
(defun cold-load-symbol (size package)
(let ((string (make-string size)))
- (read-n-bytes *fasl-file* string 0 (* vm:char-bytes size))
- ;; Make the string have the correct byte order for the native
- ;; backend.
+ (read-n-bytes *fasl-file* string 0 (* 2 size))
(maybe-byte-swap-string string)
(cold-intern (intern string package) package)))
@@ -1375,11 +1383,21 @@
(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 (* vm:char-bytes size))
+ (read-n-bytes *fasl-file* name 0 (* 2 size))
(maybe-byte-swap-string name)
(let ((symbol (allocate-symbol name)))
(push-table symbol))))
@@ -1434,14 +1452,20 @@
;;; 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 (* 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 not to swap bytes.
+ (read-n-bytes *fasl-file* string 0 (* 2 len))
(maybe-byte-swap-string string)
(string-to-core string)))
@@ -1965,8 +1989,13 @@
(code-object (pop-stack))
(len (read-arg 1))
(sym (make-string len)))
- (read-n-bytes *fasl-file* sym 0 (* vm:char-bytes len))
- (maybe-byte-swap-string sym)
+ #-unicode
+ (read-n-bytes *fasl-file* sym 0 len)
+ #+unicode
+ (progn
+ (read-n-bytes *fasl-file* sym 0 (* 2 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)))
@@ -1981,8 +2010,12 @@
(code-object (pop-stack))
(len (read-arg 1))
(sym (make-string len)))
- (read-n-bytes *fasl-file* sym 0 (* vm:char-bytes len))
- (maybe-byte-swap-string sym)
+ #-unicode
+ (read-n-bytes *fasl-file* sym 0 len)
+ #+unicode
+ (progn
+ (read-n-bytes *fasl-file* sym 0 (* 2 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))
@@ -2185,8 +2218,8 @@
type
*cold-linkage-table*
*cold-foreign-hash*)))
- (+ (c:backend-foreign-linkage-space-start c:*backend*)
- (* entry-num (c:backend-foreign-linkage-entry-size c:*backend*)))))
+ (+ vm:target-foreign-linkage-space-start
+ (* entry-num vm:target-foreign-linkage-entry-size))))
#+linkage-table
(defun init-foreign-linkage ()
More information about the cmucl-commit
mailing list