fxarithmetic-shift-left now detects overflows properly.

scheme/ikarus.compiler.altcogen.ss

@@ -514,7 +514,7 @@
                   (make-asm-instr 'cltd edx eax)
                   (make-asm-instr 'idiv edx (cadr rands))
                   (make-set d edx))))]
-         [(sll sra srl)
+         [(sll sra srl sll/overflow)
           (let ([a (car rands)] [b (cadr rands)])
             (cond
               [(constant? b)
@@ -1419,7 +1419,8 @@
                       (mark-nfv/frms-conf! d fs)
                       (R s vs rs fs (add-nfv d ns)))])]
                 [else (error who "invalid op d" (unparse x))])))] 
-         [(logand logor logxor sll sra srl int+ int- int* bswap!) 
+         [(logand logor logxor sll sra srl int+ int- int* bswap!
+           sll/overflow) 
           (cond
             [(var? d) 
              (cond
@@ -1665,7 +1666,8 @@
               sll sra srl bswap!
               cltd idiv int-/overflow int+/overflow int*/overflow
               fl:load fl:store fl:add! fl:sub! fl:mul! fl:div!
-              fl:from-int fl:shuffle fl:load-single fl:store-single)
+              fl:from-int fl:shuffle fl:load-single fl:store-single
+              sll/overflow)
             (make-asm-instr op (R d) (R s))]
            [(nop) (make-primcall 'nop '())]
            [else (error who "invalid op" op)])]
@@ -1888,7 +1890,8 @@
             (let ([s (set-rem d (set-union s (exception-live-set)))])
               (set-for-each (lambda (y) (add-edge! g d y)) s)
               (set-union (set-union (R v) (R d)) s))] 
-           [(logand logxor int+ int- int* logor sll sra srl bswap!)
+           [(logand logxor int+ int- int* logor sll sra srl bswap!
+             sll/overflow)
             (let ([s (set-rem d s)])
               (set-for-each (lambda (y) (add-edge! g d y)) s)
               (set-union (set-union (R v) (R d)) s))]
@@ -2234,7 +2237,7 @@
               [(disp? b)
                (error who "invalid arg to idiv" b)]
               [else x])]
-           [(sll sra srl)
+           [(sll sra srl sll/overflow)
             (unless (or (constant? b)
                         (eq? b ecx))
               (error who "invalid shift" b))
@@ -2554,6 +2557,12 @@
             (cons* `(subl ,(R s) ,(R d)) 
                    `(jo ,L)
                    ac))]
+         [(sll/overflow)
+          (let ([L (or (exception-label) 
+                       (error who "no exception label"))])
+            (cons* `(sall ,(R/cl s) ,(R d))
+                   `(jo ,L)
+                   ac))]
          [(int*/overflow)
           (let ([L (or (exception-label) 
                        (error who "no exception label"))])

scheme/ikarus.fixnums.ss

@@ -26,7 +26,9 @@
           fixnum->string 
           fxarithmetic-shift-left fxarithmetic-shift-right fxarithmetic-shift
           fxmin fxmax
-          error@fx+ error@fx* error@fx- error@fxadd1 error@fxsub1)
+          error@fx+ error@fx* error@fx- error@fxadd1 error@fxsub1
+          error@fxarithmetic-shift-left
+          )
   (import 
     (ikarus system $fx)
     (ikarus system $chars)
@@ -267,16 +269,22 @@
         (die 'fxsll "negative shift not allowed" y))
       ($fxsll x y))) 
 
+  (define (error@fxarithmetic-shift-left x y)
+    (unless (fixnum? x)
+      (die 'fxarithmetic-shift-left "not a fixnum" x))
+    (unless (fixnum? y)
+      (die 'fxarithmetic-shift-left "not a fixnum" y))
+    (unless ($fx>= y 0)
+      (die 'fxarithmetic-shift-left "negative shift not allowed" y))
+    (unless ($fx< y (fixnum-width))
+      (die 'fxarithmetic-shift-left 
+        "shift is not less than fixnum-width" y))
+    (die 'fxarithmetic-shift-left "overflow" x y))
 
   (define fxarithmetic-shift-left
     (lambda (x y) 
-      (unless (fixnum? x)
+      (import (ikarus))
-        (die 'fxarithmetic-shift-left "not a fixnum" x))
+      (fxarithmetic-shift-left x y)))
-      (unless (fixnum? y)
-        (die 'fxarithmetic-shift-left "not a fixnum" y))
-      (unless ($fx>= y 0)
-        (die 'fxarithmetic-shift-left "negative shift not allowed" y))
-      ($fxsll x y)))
 
   (define fxarithmetic-shift
     (lambda (x y) 

scheme/last-revision

@@ -1 +1 @@
-1415
+1416

scheme/makefile.ss

@@ -568,6 +568,7 @@
     [make-promise                                ]
     [make-traced-procedure                       i]
     [error@fx+                                   ]
+    [error@fxarithmetic-shift-left               ]
     [error@fx*                                   ]
     [error@fx-                                   ]
     [error@add1                                  ]

scheme/pass-specify-rep-primops.ss

@@ -1295,6 +1295,42 @@
      (cogen-pred-$fxzero? x))]
   [(E x) (interrupt-unless (cogen-pred-fixnum? x))])
 
+
+(define-primop fxarithmetic-shift-left safe
+  [(V x n) 
+   (struct-case n 
+     [(constant i) 
+      (cond
+        [(and (fixnum? i)
+              (>= i 0)
+              (< i (- (* wordsize 8) fx-shift)))
+         (with-tmp ([x (T x)])
+           (assert-fixnum x)
+           (cond
+             [(< i 6) 
+              (let f ([i i]) 
+                (cond
+                  [(zero? i) x]
+                  [else (prm 'sll/overflow (f (- i 1)) (K 1))]))]
+             [else 
+              (with-tmp ([x2 (prm 'sll x (K i))])
+                (interrupt-unless (prm '= (prm 'sra x2 (K i)) x))
+                x2)]))]
+        [else
+         (interrupt)])]
+     [else 
+      (with-tmp ([x (T x)] [n (T n)])
+        (assert-fixnums x (list n))
+        (with-tmp ([n (prm 'sra n (K fx-shift))])
+          (interrupt-when 
+            (prm '< n (K 0)))
+          (interrupt-when 
+            (prm '>= n (K (- (* wordsize 8) fx-shift))))
+          (with-tmp ([x2 (prm 'sll x n)])
+            (interrupt-unless (prm '= (prm 'sra x2 n) x))
+            x2)))])])
+
+
 (define (log2 n) 
   (let f ([n n] [i 0])
     (cond
@@ -1303,6 +1339,8 @@
       [(= n 1) i]
       [else #f])))
 
+
+
 (define-primop div safe
   [(V x n) 
    (struct-case n 

scheme/pass-specify-rep.ss

@@ -55,13 +55,14 @@
     (prm 'interrupt))
   (define (primop-interrupt-handler x)
     (case x
-      [(fx+)          'error@fx+]
+      [(fx+)                     'error@fx+]
-      [(fx-)          'error@fx-]
+      [(fx-)                     'error@fx-]
-      [(fx*)          'error@fx*]
+      [(fx*)                     'error@fx*]
-      [(add1)         'error@add1]
+      [(add1)                    'error@add1]
-      [(sub1)         'error@sub1]
+      [(sub1)                    'error@sub1]
-      [(fxadd1)       'error@fxadd1]
+      [(fxadd1)                  'error@fxadd1]
-      [(fxsub1)       'error@fxsub1]
+      [(fxsub1)                  'error@fxsub1]
+      [(fxarithmetic-shift-left) 'error@fxarithmetic-shift-left]
       [else                    x]))
   (define (make-interrupt-call op args)
     (make-funcall