X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fprimtype.lisp;h=9da94af30619fa607144fccf1a4ad25ec3a6da31;hb=4f8254f9a128aecc02fc53986ddf2645d8810c24;hp=962b22fc5328f74367f060a7c860a7af9dfec834;hpb=2034cb134af58c5998f4e305673af6e2c75bc179;p=sbcl.git

diff --git a/src/compiler/generic/primtype.lisp b/src/compiler/generic/primtype.lisp
index 962b22f..9da94af 100644
--- a/src/compiler/generic/primtype.lisp
+++ b/src/compiler/generic/primtype.lisp
@@ -25,26 +25,26 @@
 (!def-primitive-type positive-fixnum (any-reg signed-reg unsigned-reg)
   :type (unsigned-byte #.sb!vm:n-positive-fixnum-bits))
 (/show0 "primtype.lisp 27")
-#!-alpha
+#!+#.(cl:if (cl:= sb!vm::n-machine-word-bits 32) '(and) '(or))
 (!def-primitive-type unsigned-byte-31 (signed-reg unsigned-reg descriptor-reg)
   :type (unsigned-byte 31))
 (/show0 "primtype.lisp 31")
-#!-alpha
+#!+#.(cl:if (cl:= sb!vm::n-machine-word-bits 32) '(and) '(or))
 (!def-primitive-type unsigned-byte-32 (unsigned-reg descriptor-reg)
   :type (unsigned-byte 32))
 (/show0 "primtype.lisp 35")
-#!+alpha
+#!+#.(cl:if (cl:= sb!vm::n-machine-word-bits 64) '(and) '(or))
 (!def-primitive-type unsigned-byte-63 (signed-reg unsigned-reg descriptor-reg)
   :type (unsigned-byte 63))
-#!+alpha
+#!+#.(cl:if (cl:= sb!vm::n-machine-word-bits 64) '(and) '(or))
 (!def-primitive-type unsigned-byte-64 (unsigned-reg descriptor-reg)
   :type (unsigned-byte 64))
 (!def-primitive-type fixnum (any-reg signed-reg)
   :type (signed-byte #.(1+ sb!vm:n-positive-fixnum-bits)))
-#!-alpha
+#!+#.(cl:if (cl:= sb!vm::n-machine-word-bits 32) '(and) '(or))
 (!def-primitive-type signed-byte-32 (signed-reg descriptor-reg)
   :type (signed-byte 32))
-#!+alpha
+#!+#.(cl:if (cl:= sb!vm::n-machine-word-bits 64) '(and) '(or))
 (!def-primitive-type signed-byte-64 (signed-reg descriptor-reg)
   :type (signed-byte 64))
 
@@ -52,17 +52,16 @@
 
 (/show0 "primtype.lisp 53")
 (!def-primitive-type-alias tagged-num (:or positive-fixnum fixnum))
-(!def-primitive-type-alias unsigned-num (:or #!-alpha unsigned-byte-32
-					     #!-alpha unsigned-byte-31
-					     #!+alpha unsigned-byte-64
-					     #!+alpha unsigned-byte-63
-					     positive-fixnum))
-(!def-primitive-type-alias signed-num (:or #!-alpha signed-byte-32
-					   #!+alpha signed-byte-64
-					   fixnum
-					   #!-alpha unsigned-byte-31
-					   #!+alpha unsigned-byte-63
-					   positive-fixnum))
+(!def-primitive-type-alias unsigned-num 
+  #!+#.(cl:if (cl:= sb!vm::n-machine-word-bits 64) '(and) '(or))
+  (:or unsigned-byte-64 unsigned-byte-63 positive-fixnum)
+  #!-#.(cl:if (cl:= sb!vm::n-machine-word-bits 64) '(and) '(or))
+  (:or unsigned-byte-32 unsigned-byte-31 positive-fixnum))
+(!def-primitive-type-alias signed-num 
+  #!+#.(cl:if (cl:= sb!vm::n-machine-word-bits 64) '(and) '(or))
+  (:or signed-byte-64 fixnum unsigned-byte-63 positive-fixnum)
+  #!-#.(cl:if (cl:= sb!vm::n-machine-word-bits 64) '(and) '(or))
+  (:or signed-byte-32 fixnum unsigned-byte-31 positive-fixnum))
 
 ;;; other primitive immediate types
 (/show0 "primtype.lisp 68")
@@ -161,32 +160,48 @@
 	       (case t1-name
 		 (positive-fixnum
 		  (if (or (eq t2-name 'fixnum)
-			  (eq t2-name #!-alpha 'signed-byte-32
-				      #!+alpha 'signed-byte-64)
-			  (eq t2-name #!-alpha 'unsigned-byte-31
-				      #!+alpha 'unsigned-byte-63)
-			  (eq t2-name #!-alpha 'unsigned-byte-32
-				      #!+alpha 'unsigned-byte-64))
+			  (eq t2-name
+			      (ecase sb!vm::n-machine-word-bits
+				(32 'signed-byte-32)
+				(64 'signed-byte-64)))
+			  (eq t2-name
+			      (ecase sb!vm::n-machine-word-bits
+				(32 'unsigned-byte-31)
+				(64 'unsigned-byte-63)))
+			  (eq t2-name
+			      (ecase sb!vm::n-machine-word-bits
+				(32 'unsigned-byte-32)
+				(64 'unsigned-byte-64))))
 		      t2))
 		 (fixnum
 		  (case t2-name
-		    (#!-alpha signed-byte-32
-		     #!+alpha signed-byte-64 t2)
-		    (#!-alpha unsigned-byte-31
-		     #!+alpha unsigned-byte-63
-		     (primitive-type-or-lose
-		      #!-alpha 'signed-byte-32
-		      #!+alpha 'signed-byte-64))))
-		 (#!-alpha signed-byte-32
-		  #!+alpha signed-byte-64
-		  (if (eq t2-name #!-alpha 'unsigned-byte-31
-				  #!+alpha 'unsigned-byte-63)
+		    (#.(ecase sb!vm::n-machine-word-bits
+			 (32 'signed-byte-32)
+			 (64 'signed-byte-64))
+		       t2)
+		    (#.(ecase sb!vm::n-machine-word-bits
+			 (32 'unsigned-byte-31)
+			 (64 'unsigned-byte-63))
+		       (primitive-type-or-lose
+			(ecase sb!vm::n-machine-word-bits
+			  (32 'signed-byte-32)
+			  (64 'signed-byte-64))))))
+		 (#.(ecase sb!vm::n-machine-word-bits
+		      (32 'signed-byte-32)
+		      (64 'signed-byte-64))
+		  (if (eq t2-name
+			  (ecase sb!vm::n-machine-word-bits
+			    (32 'unsigned-byte-31)
+			    (64 'unsigned-byte-63)))
 		      t1))
-		 (#!-alpha unsigned-byte-31
-		  #!+alpha unsigned-byte-63
-		  (if (eq t2-name #!-alpha 'unsigned-byte-32
-				  #!+alpha 'unsigned-byte-64)
-		      t2))))))
+		 (#.(ecase sb!vm::n-machine-word-bits
+		      (32 'unsigned-byte-31)
+		      (64 'unsigned-byte-63))
+		    (if (eq t2-name
+			    (ecase sb!vm::n-machine-word-bits
+			      (32 'unsigned-byte-32)
+			      (64 'unsigned-byte-64)))
+			t2))))))
       (etypecase type
 	(numeric-type
 	 (let ((lo (numeric-type-low type))
@@ -198,22 +213,26 @@
 		 (cond ((and hi lo)
 			(dolist (spec
 				  `((positive-fixnum 0 ,sb!xc:most-positive-fixnum)
-				    #!-alpha
-				    (unsigned-byte-31 0 ,(1- (ash 1 31)))
-				    #!-alpha
-				    (unsigned-byte-32 0 ,(1- (ash 1 32)))
-				    #!+alpha
-				    (unsigned-byte-63 0 ,(1- (ash 1 63)))
-				    #!+alpha
-				    (unsigned-byte-64 0 ,(1- (ash 1 64)))
+				    ,@(ecase sb!vm::n-machine-word-bits
+					(32
+					 `((unsigned-byte-31
+					    0 ,(1- (ash 1 31)))
+					   (unsigned-byte-32
+					    0 ,(1- (ash 1 32)))))
+					(64
+					 `((unsigned-byte-63
+					    0 ,(1- (ash 1 63)))
+					   (unsigned-byte-64
+					    0 ,(1- (ash 1 64))))))
 				    (fixnum ,sb!xc:most-negative-fixnum
 					    ,sb!xc:most-positive-fixnum)
-				    #!-alpha
-				    (signed-byte-32 ,(ash -1 31)
-							  ,(1- (ash 1 31)))
-				    #!+alpha
-				    (signed-byte-64 ,(ash -1 63)
-						    ,(1- (ash 1 63))))
+				    ,(ecase sb!vm::n-machine-word-bits
+				       (32
+					`(signed-byte-32 ,(ash -1 31)
+					                 ,(1- (ash 1 31))))
+				       (64
+					`(signed-byte-64 ,(ash -1 63)
+							 ,(1- (ash 1 63))))))
 				 (if (or (< hi sb!xc:most-negative-fixnum)
 					 (> lo sb!xc:most-positive-fixnum))
 				     (part-of bignum)
@@ -283,12 +302,35 @@
 		       (primitive-type type)
 		     (unless ptype-exact (setq exact nil))
 		     (unless (eq ptype res)
-		       (let ((new-ptype
-			      (or (maybe-numeric-type-union res ptype)
+		       (let ((new-ptype 
+                              (or (maybe-numeric-type-union res ptype)
 				  (maybe-numeric-type-union ptype res))))
 			 (if new-ptype
 			     (setq res new-ptype)
 			     (return (any)))))))))))
+        (intersection-type
+         (let ((types (intersection-type-types type))
+               (res (any))
+               (exact nil))
+           (dolist (type types (values res exact))
+             (when (eq type (specifier-type 'function))
+               ;; KLUDGE: Deal with (and function instance), both of which
+               ;; have an exact primitive type.
+               (return (part-of function)))
+             (multiple-value-bind (ptype ptype-exact)
+                   (primitive-type type)
+                 (when ptype-exact
+                   ;; Apart from the previous kludge exact primitive
+                   ;; types should match, if indeed there are any. It
+                   ;; may be that this assumption isn't really safe,
+                   ;; but at least we'll see what breaks. -- NS 20041104
+                   (aver (or (not exact) (eq ptype res)))
+                   (setq exact t))
+                 (when (or ptype-exact (and (not exact) (eq res (any))))
+                   ;; Try to find a narrower representation then
+                   ;; (any). Takes care of undecidable types in
+                   ;; intersections with decidable ones.
+                   (setq res ptype))))))
 	(member-type
 	 (let* ((members (member-type-members type))
 		(res (primitive-type-of (first members))))
@@ -311,26 +353,26 @@
                    (= (cdar pairs) (1- sb!xc:char-code-limit)))
               (exactly character)
               (part-of character))))
-	(built-in-classoid
-	 (case (classoid-name type)
-	   ((complex function instance
-	     system-area-pointer weak-pointer)
-	    (values (primitive-type-or-lose (classoid-name type)) t))
-	   (funcallable-instance
-	    (part-of function))
-	   (cons-type
-	    (part-of list))
-	   (t
-	    (any))))
-	(fun-type
-	 (exactly function))
-	(classoid
-	 (if (csubtypep type (specifier-type 'function))
-	     (part-of function)
-	     (part-of instance)))
-	(ctype
-         (if (csubtypep type (specifier-type 'function))
-	     (part-of function)
-             (any)))))))
+       (built-in-classoid
+        (case (classoid-name type)
+          ((complex function instance
+                    system-area-pointer weak-pointer)
+           (values (primitive-type-or-lose (classoid-name type)) t))
+          (funcallable-instance
+           (part-of function))
+          (cons-type
+           (part-of list))
+          (t
+           (any))))
+       (fun-type
+        (exactly function))
+       (classoid
+        (if (csubtypep type (specifier-type 'function))
+            (part-of function)
+            (part-of instance)))
+       (ctype
+        (if (csubtypep type (specifier-type 'function))
+            (part-of function)
+            (any)))))))
 
 (/show0 "primtype.lisp end of file")