[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2012-01-15-g1c6efe8
Raymond Toy
rtoy at common-lisp.net
Sun Jan 29 07:17:16 UTC 2012
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "CMU Common Lisp".
The branch, master has been updated
via 1c6efe8566e0304db811c556388296d14ee78136 (commit)
from f91f2a2e37bd0737457d212c6ef0733bd2b15753 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 1c6efe8566e0304db811c556388296d14ee78136
Author: Raymond Toy <toy.raymond at gmail.com>
Date: Sat Jan 28 23:17:08 2012 -0800
Changes so we can cross-compile from x86 to ppc. This will produce a
core that appears to work. More testing needed.
src/compiler/ppc/c-call.lisp:
o Use the old vops that only store floats in float registers. We
don't need them also stored in integer registers. This causes an
error during cross-compile about %NL1 conflicting with a wired tn.
src/tools/cross-scripts/cross-x86-ppc-darwin.lisp:
o Copy over similar features from cross-x86-sparc.lisp so that the
cross-compile will work.
diff --git a/src/compiler/ppc/c-call.lisp b/src/compiler/ppc/c-call.lisp
index e536b9a..4fd20b6 100644
--- a/src/compiler/ppc/c-call.lisp
+++ b/src/compiler/ppc/c-call.lisp
@@ -69,7 +69,17 @@
;;; double. That way, C programs can get subtle rounding errors
;;; when unrelated arguments are introduced.
-#-darwin
+;; The ABI for ppc says that float arguments are stored in float
+;; registers and also in integer registers. This is mostly needed for
+;; varargs functions. It seems that regular functions know to get the
+;; value out of the float registers.
+;;
+;; However, when bootstrapping (for cross-compiling), this can cause a
+;; compile error about %nl1 conflicting with a wired tn. I (rtoy) do
+;; not know why that happens, but we don't need to have float values
+;; stored in the integer registers when compiling cmucl. (We con't
+;; call any vararg C functions.) So, use the old vops in this case.
+#-(and darwin (not bootstrap))
(def-alien-type-method (single-float :arg-tn) (type state)
(declare (ignore type))
(let* ((fprs (arg-state-fpr-args state)))
@@ -84,7 +94,7 @@
(setf (arg-state-stack-frame-size state) (+ stack-offset 2))
(my-make-wired-tn 'double-float 'double-stack stack-offset))))))
-#+darwin
+#+(and darwin (not bootstrap))
(def-alien-type-method (single-float :arg-tn) (type state)
(declare (ignore type))
(let* ((fprs (arg-state-fpr-args state))
@@ -114,7 +124,7 @@
(incf (arg-state-stack-frame-size state))
(my-make-wired-tn 'single-float 'single-stack stack-offset))))))
-#-darwin
+#-(and darwin (not bootstrap))
(def-alien-type-method (double-float :arg-tn) (type state)
(declare (ignore type))
(let* ((fprs (arg-state-fpr-args state)))
@@ -129,7 +139,7 @@
(setf (arg-state-stack-frame-size state) (+ stack-offset 2))
(my-make-wired-tn 'double-float 'double-stack stack-offset))))))
-#+darwin
+#+(and darwin (not bootstrap))
(def-alien-type-method (double-float :arg-tn) (type state)
(declare (ignore type))
(let ((fprs (arg-state-fpr-args state))
diff --git a/src/tools/cross-scripts/cross-x86-ppc-darwin.lisp b/src/tools/cross-scripts/cross-x86-ppc-darwin.lisp
index 5b2e631..0541163 100644
--- a/src/tools/cross-scripts/cross-x86-ppc-darwin.lisp
+++ b/src/tools/cross-scripts/cross-x86-ppc-darwin.lisp
@@ -2,7 +2,7 @@
;;; Rename the X86 package and backend so that new-backend does the
;;; right thing.
-(rename-package "X86" "OLD-X86")
+(rename-package "X86" "OLD-X86" '("OLD-VM"))
(setf (c:backend-name c:*native-backend*) "OLD-X86")
(c::new-backend "PPC"
@@ -11,14 +11,135 @@
:conservative-float-type
:hash-new :random-mt19937
:darwin :bsd
- :cmu :cmu18 :cmu18e
+ :cmu :cmu20 :cmu20a
+ :gencgc
+ :relative-package-names
+ :modular-arith
+ :double-double
+ :linkage-table
)
;; Features to remove from current *features* here
- '(:x86-bootstrap :alpha :osf1 :mips :x86 :i486 :pentium :ppro
+ '(
+ ;; 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
- :openbsd :freebsd :glibc2 :linux :pentium :linkage-table :elf :mp
- :stack-checking :heap-overflow-check
- :gencgc :cgc :long-float :new-random :small))
+ ;; Other OSes were not using
+ :openbsd :freebsd :glibc2 :linux :mach-o :darwin :bsd
+
+ :pentium
+ :long-float
+ :new-random
+ :small
+ :mp
+ ;; ppc currently doesn't support these.
+ :executable
+ :heap-overflow-check
+ :stack-checking
+ :complex-fp-vops))
+
+;;; Changes needed to bootstrap cross-compiling from x86 to ppc
+
+;; ppc doesn't have these features yet. Remove them. It is a bug in
+;; cross-compiling that these features leak through to the target.
+(setf *features* (remove :executable *features*))
+(setf *features* (remove :heap-overflow-check *features*))
+(setf *features* (remove :stack-checking *features*))
+(setf *features* (remove :complex-fp-vops *features*))
+
+;; Set up the linkage space stuff appropriately for ppc.
+#+nil
+(setf (c::backend-foreign-linkage-space-start c::*target-backend*)
+ #x17000000
+ (c::backend-foreign-linkage-entry-size c::*target-backend*)
+ 32)
+
+(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.
+
+#+unicode
+(progn
+(defconstant ppc::char-bytes 2)
+(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 vm::char-bytes)))))
+ (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 ppc
+
;;; Extern-alien-name for the new backend.
(in-package :vm)
@@ -109,26 +230,55 @@
(find-symbol ,(symbol-name sym)
:vm))))
syms))))
- (frob OLD-X86:BYTE-BITS OLD-X86:WORD-BITS
- #+long-float OLD-X86:SIMPLE-ARRAY-LONG-FLOAT-TYPE
- OLD-X86:SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE
- OLD-X86:SIMPLE-ARRAY-SINGLE-FLOAT-TYPE
- #+long-float OLD-X86:SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-TYPE
- OLD-X86:SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-TYPE
- OLD-X86:SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-TYPE
- OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-2-TYPE
- OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-4-TYPE
- OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-8-TYPE
- OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-16-TYPE
- OLD-X86:SIMPLE-ARRAY-UNSIGNED-BYTE-32-TYPE
- OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-8-TYPE
- OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-16-TYPE
- OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-30-TYPE
- OLD-X86:SIMPLE-ARRAY-SIGNED-BYTE-32-TYPE
- OLD-X86:SIMPLE-BIT-VECTOR-TYPE
- OLD-X86:SIMPLE-STRING-TYPE OLD-X86:SIMPLE-VECTOR-TYPE
- OLD-X86:SIMPLE-ARRAY-TYPE OLD-X86:VECTOR-DATA-OFFSET
- ))
+ (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))
+
+;; 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
+
+;; Hack to define fused-multiply-add and subtract. Doesn't need to be
+;; correct; just needs to exist.
+(defun ppc::fused-multiply-subtract (x y z)
+ "Compute x*y-z with only one rounding operation"
+ (declare (double-float x y z))
+ (- (* x y) z))
+
+(defun ppc::fused-multiply-add (x y z)
+ "Compute x*y+z with only one rounding operation"
+ (declare (double-float x y z))
+ (+ (* x y) z))
(let ((function (symbol-function 'kernel:error-number-or-lose)))
(let ((*info-environment* (c:backend-info-environment c:*target-backend*)))
@@ -175,5 +325,5 @@
;; to the hash table with the same value as x86::any-reg.
(let ((ht (c::backend-sc-names c::*target-backend*)))
- (setf (gethash 'old-x86::any-reg ht)
- (gethash 'ppc::any-reg ht)))
+ (setf (gethash 'old-vm::any-reg ht)
+ (gethash 'vm::any-reg ht)))
-----------------------------------------------------------------------
Summary of changes:
src/compiler/ppc/c-call.lisp | 18 ++-
src/tools/cross-scripts/cross-x86-ppc-darwin.lisp | 206 ++++++++++++++++++---
2 files changed, 192 insertions(+), 32 deletions(-)
hooks/post-receive
--
CMU Common Lisp
More information about the cmucl-cvs
mailing list