X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=inline;f=src%2Fcompiler%2Faliencomp.lisp;h=89771f2ebeb6acc86bab51fc74f69f0f3355aa29;hb=78fa16bf55be44cc16845be84d98023e83fb14bc;hp=697410a8f05eb8c9b7afd67753b88fe698159ea9;hpb=57e21c4b62e8c1a1ee7ef59ed2abb0c864fb06bc;p=sbcl.git

diff --git a/src/compiler/aliencomp.lisp b/src/compiler/aliencomp.lisp
index 697410a..89771f2 100644
--- a/src/compiler/aliencomp.lisp
+++ b/src/compiler/aliencomp.lisp
@@ -61,9 +61,9 @@
   (flushable movable))
 (defknown deport (alien alien-type) t
   (flushable movable))
-(defknown extract-alien-value (system-area-pointer index alien-type) t
+(defknown extract-alien-value (system-area-pointer unsigned-byte alien-type) t
   (flushable))
-(defknown deposit-alien-value (system-area-pointer index alien-type t) t
+(defknown deposit-alien-value (system-area-pointer unsigned-byte alien-type t) t
   ())
 
 (defknown alien-funcall (alien-value &rest *) *
@@ -346,11 +346,11 @@
     (/noshow (local-alien-info-force-to-memory-p info))
     (/noshow alien-type (unparse-alien-type alien-type) (alien-type-bits alien-type))
     (if (local-alien-info-force-to-memory-p info)
-      #!+x86 `(truly-the system-area-pointer
+      #!+(or x86 x86-64) `(truly-the system-area-pointer
 			 (%primitive alloc-alien-stack-space
 				     ,(ceiling (alien-type-bits alien-type)
 					       sb!vm:n-byte-bits)))
-      #!-x86 `(truly-the system-area-pointer
+      #!-(or x86 x86-64) `(truly-the system-area-pointer
 			 (%primitive alloc-number-stack-space
 				     ,(ceiling (alien-type-bits alien-type)
 					       sb!vm:n-byte-bits)))
@@ -434,10 +434,10 @@
   (let* ((info (lvar-value info))
 	 (alien-type (local-alien-info-type info)))
     (if (local-alien-info-force-to-memory-p info)
-      #!+x86 `(%primitive dealloc-alien-stack-space
+      #!+(or x86 x86-64) `(%primitive dealloc-alien-stack-space
 			  ,(ceiling (alien-type-bits alien-type)
 				    sb!vm:n-byte-bits))
-      #!-x86 `(%primitive dealloc-number-stack-space
+      #!-(or x86 x86-64) `(%primitive dealloc-number-stack-space
 			  ,(ceiling (alien-type-bits alien-type)
 				    sb!vm:n-byte-bits))
       nil)))
@@ -520,7 +520,8 @@
 	 (count-low-order-zeros (lvar-value thing))
 	 (count-low-order-zeros (lvar-uses thing))))
     (combination
-     (case (lvar-fun-name (combination-fun thing))
+     (case (let ((name (lvar-fun-name (combination-fun thing))))
+             (or (modular-version-info name :unsigned) name))
        ((+ -)
 	(let ((min most-positive-fixnum)
 	      (itype (specifier-type 'integer)))
@@ -553,15 +554,18 @@
 	 (do ((result 0 (1+ result))
 	      (num thing (ash num -1)))
 	     ((logbitp 0 num) result))))
+    (cast
+     (count-low-order-zeros (cast-value thing)))
     (t
      0)))
 
 (deftransform / ((numerator denominator) (integer integer))
+  "convert x/2^k to shift"
   (unless (constant-lvar-p denominator)
     (give-up-ir1-transform))
   (let* ((denominator (lvar-value denominator))
 	 (bits (1- (integer-length denominator))))
-    (unless (= (ash 1 bits) denominator)
+    (unless (and (> denominator 0) (= (ash 1 bits) denominator))
       (give-up-ir1-transform))
     (let ((alignment (count-low-order-zeros numerator)))
       (unless (>= alignment bits)
@@ -570,20 +574,29 @@
 
 (deftransform ash ((value amount))
   (let ((value-node (lvar-uses value)))
-    (unless (and (combination-p value-node)
-		 (eq (lvar-fun-name (combination-fun value-node))
-		     'ash))
+    (unless (combination-p value-node)
       (give-up-ir1-transform))
-    (let ((inside-args (combination-args value-node)))
-      (unless (= (length inside-args) 2)
-	(give-up-ir1-transform))
-      (let ((inside-amount (second inside-args)))
-	(unless (and (constant-lvar-p inside-amount)
-		     (not (minusp (lvar-value inside-amount))))
-	  (give-up-ir1-transform)))))
-  (extract-fun-args value 'ash 2)
-  '(lambda (value amount1 amount2)
-     (ash value (+ amount1 amount2))))
+    (let ((inside-fun-name (lvar-fun-name (combination-fun value-node))))
+      (multiple-value-bind (prototype width)
+          (modular-version-info inside-fun-name :unsigned)
+        (unless (eq (or prototype inside-fun-name) 'ash)
+          (give-up-ir1-transform))
+        (when (and width (not (constant-lvar-p amount)))
+          (give-up-ir1-transform))
+        (let ((inside-args (combination-args value-node)))
+          (unless (= (length inside-args) 2)
+            (give-up-ir1-transform))
+          (let ((inside-amount (second inside-args)))
+            (unless (and (constant-lvar-p inside-amount)
+                         (not (minusp (lvar-value inside-amount))))
+              (give-up-ir1-transform)))
+          (extract-fun-args value inside-fun-name 2)
+          (if width
+              `(lambda (value amount1 amount2)
+                 (logand (ash value (+ amount1 amount2))
+                         ,(1- (ash 1 (+ width (lvar-value amount))))))
+              `(lambda (value amount1 amount2)
+                 (ash value (+ amount1 amount2)))))))))
 
 ;;;; ALIEN-FUNCALL support
 
@@ -665,19 +678,19 @@
 	(let* ((arg (pop args))
 	       (sc (tn-sc tn))
 	       (scn (sc-number sc))
-	       #!-x86 (temp-tn (make-representation-tn (tn-primitive-type tn)
+	       #!-(or x86 x86-64) (temp-tn (make-representation-tn (tn-primitive-type tn)
 						       scn))
 	       (move-arg-vops (svref (sc-move-arg-vops sc) scn)))
 	  (aver arg)
 	  (unless (= (length move-arg-vops) 1)
 	    (error "no unique move-arg-vop for moves in SC ~S" (sc-name sc)))
-	  #!+x86 (emit-move-arg-template call
+	  #!+(or x86 x86-64) (emit-move-arg-template call
 					 block
 					 (first move-arg-vops)
 					 (lvar-tn call block arg)
 					 nsp
 					 tn)
-	  #!-x86 (progn
+	  #!-(or x86 x86-64) (progn
 		   (emit-move call
 			      block
 			      (lvar-tn call block arg)