[cmucl-cvs] CMUCL commit: src/compiler/generic (new-genesis.lisp)

Raymond Toy rtoy at common-lisp.net
Sat Dec 11 15:07:08 UTC 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-cvs mailing list