CMUCL commit: amd64-dd-branch src/tools/cross-scripts (cross-x86-amd64.lisp)
Raymond Toy
rtoy at common-lisp.net
Fri Nov 6 20:52:21 CET 2009
Date: Friday, November 6, 2009 @ 14:52:21
Author: rtoy
Path: /project/cmucl/cvsroot/src/tools/cross-scripts
Tag: amd64-dd-branch
Modified: cross-x86-amd64.lisp
o Some partial support compiling for sse2, but not yet used or
tested.
o Need to tell new backend about the new bignum type.
o Forgot to tell new backend about appropriate backend-type-predicates
and backend-predicate-types for bignums.
These changes appear to make two-arg-+ handle fixnums correctly.
----------------------+
cross-x86-amd64.lisp | 139 ++++++++++++++++++++++++++++++++++++++++++++++++-
1 file changed, 138 insertions(+), 1 deletion(-)
Index: src/tools/cross-scripts/cross-x86-amd64.lisp
diff -u src/tools/cross-scripts/cross-x86-amd64.lisp:1.1.2.4 src/tools/cross-scripts/cross-x86-amd64.lisp:1.1.2.5
--- src/tools/cross-scripts/cross-x86-amd64.lisp:1.1.2.4 Wed Nov 4 08:02:51 2009
+++ src/tools/cross-scripts/cross-x86-amd64.lisp Fri Nov 6 14:52:21 2009
@@ -237,9 +237,13 @@
(load "vm:primtype")
(load "vm:move")
(load "vm:sap")
+(when (target-featurep :sse2)
+ (load "vm:sse2-sap"))
(load "vm:system")
(load "vm:char")
-(load "vm:float")
+(if (target-featurep :sse2)
+ (load "vm:float-sse2")
+ (load "vm:float"))
(load "vm:memory")
(load "vm:static-fn")
@@ -248,6 +252,11 @@
(load "vm:subprim")
(load "vm:debug")
(load "vm:c-call")
+#+nil
+(if (target-featurep :sse2)
+ (load "vm:sse2-c-call")
+ (load "vm:x87-c-call"))
+
(load "vm:print")
(load "vm:alloc")
(load "vm:call")
@@ -370,6 +379,84 @@
(deftype c::non-negative-fixnum () '(unsigned-byte 61))
+#||
+(describe (c::info c::type c::builtin 'fixnum))
+
+
+(in-package "KERNEL")
+(let ((*info-environment* (c:backend-info-environment c:*target-backend*)))
+ (c::values-specifier-type-cache-clear)
+
+ (c::clear-info c::type c::builtin 'fixnum)
+ (setf (c::info c::type c::builtin 'fixnum)
+ (c::make-numeric-type :class 'integer
+ :low (ash -1 61)
+ :high (1- (ash 1 61))))
+
+ (describe (c::info c::type c::builtin 'fixnum))
+ (setf (c::backend-type-predicates c::*target-backend*)
+ (acons (c::make-numeric-type :class 'integer
+ :low (ash -1 61)
+ :high (1- (ash 1 61)))
+ 'fixnump
+ (c::backend-type-predicates c::*target-backend*)))
+
+ (deftype kernel::index () '(unsigned-byte 61))
+ ;;(deftype c::non-negative-fixnum () '(unsigned-byte 61))
+
+(define-type-method (number :unparse) (type)
+ (let* ((complexp (numeric-type-complexp type))
+ (low (numeric-type-low type))
+ (high (numeric-type-high type))
+ (base (case (numeric-type-class type)
+ (integer 'integer)
+ (rational 'rational)
+ (float (or (numeric-type-format type) 'float))
+ (t 'real))))
+ (let ((base+bounds
+ (cond ((and (eq base 'integer) high low)
+ (let ((high-count (logcount high))
+ (high-length (integer-length high)))
+ (cond ((= low 0)
+ (cond ((= high 0) '(integer 0 0))
+ ((= high 1) 'bit)
+ ((and (= high-count high-length)
+ (plusp high-length))
+ `(unsigned-byte ,high-length))
+ (t
+ `(mod ,(1+ high)))))
+ ((and (= low vm::target-most-negative-fixnum)
+ (= high vm::target-most-positive-fixnum))
+ 'fixnum)
+ ((and (= low (lognot high))
+ (= high-count high-length)
+ (> high-count 0))
+ `(signed-byte ,(1+ high-length)))
+ (t
+ `(integer ,low ,high)))))
+ (high `(,base ,(or low '*) ,high))
+ (low
+ (if (and (eq base 'integer) (= low 0))
+ 'unsigned-byte
+ `(,base ,low)))
+ (t base))))
+ (ecase complexp
+ (:real
+ base+bounds)
+ (:complex
+ (if (eq base+bounds 'real)
+ 'complex
+ `(complex ,base+bounds)))
+ ((nil)
+ (assert (eq base+bounds 'real))
+ 'number)))))
+(setf (type-class-unparse (type-class-info (c::specifier-type 'fixnum)))
+ #'kernel::number-unparse-type-method)
+
+(c::clear-info c::type c::builtin 'fixnum)
+ )
+||#
+
(describe (c::info c::type c::builtin 'fixnum))
(c::values-specifier-type-cache-clear)
@@ -381,13 +468,63 @@
:high (1- (ash 1 61))))
(describe (c::info c::type c::builtin 'fixnum))
+
+(c::clear-info c::type c::builtin 'bignum)
+(setf (c::info c::type c::builtin 'bignum)
+ (c::specifier-type '(or (integer * -2305843009213693953)
+ (integer 2305843009213693952))))
+
+(describe (c::info c::type c::builtin 'bignum))
+
(setf (c::backend-type-predicates c::*target-backend*)
(acons (c::make-numeric-type :class 'integer
:low (ash -1 61)
:high (1- (ash 1 61)))
'fixnump
(c::backend-type-predicates c::*target-backend*)))
+
+(setf (c::backend-type-predicates c::*target-backend*)
+ (acons (c::specifier-type '(or (integer * -2305843009213693953)
+ (integer 2305843009213693952)))
+ 'bignump
+ (c::backend-type-predicates c::*target-backend*)))
+
+(setf (gethash 'fixnump (c::backend-predicate-types c::*target-backend*))
+ (c::make-numeric-type :class 'integer
+ :low (ash -1 61)
+ :high (1- (ash 1 61))))
+
+(setf (gethash 'bignump (c::backend-predicate-types c::*target-backend*))
+ (c::specifier-type '(or (integer * -2305843009213693953)
+ (integer 2305843009213693952))))
+
;;(deftype kernel::index () '(unsigned-byte 61))
(deftype c::non-negative-fixnum () '(unsigned-byte 61))
+#+nil
+(let ((*info-environment* (c::backend-info-environment c:*target-backend*)))
+(kernel::def-type-translator integer (&optional low high)
+ (let* ((l (check-bound low integer))
+ (lb (if (consp l) (1+ (car l)) l))
+ (h (check-bound high integer))
+ (hb (if (consp h) (1- (car h)) h)))
+ (flet ((hack-bound (b)
+ (cond ((= b 536870911)
+ (1- (ash 1 61)))
+ ((= b -536870912)
+ (ash -1 61)))))
+ (if (and hb lb (< hb lb))
+ ;; This used to signal an error when the lb > hb, but the CLHS
+ ;; doesn't say that this is an error, so we silently accept it
+ ;; (as the empty type).
+ *empty-type*
+ (make-numeric-type :class 'integer :complexp :real
+ :enumerable (not (null (and l h)))
+ :low (hack-bound lb)
+ :high (hack-bound hb))))))
+
+)
+
+(break)
+
More information about the cmucl-commit
mailing list