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