conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

fxarithmetic-shift-left now detects overflows properly.

This commit is contained in:
Abdulaziz Ghuloum 2008-03-18 00:49:24 -04:00
parent 97507bce08
commit 85d09cbc1c
7 changed files with 78 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
scheme/ikarus.boot.prebuilt
View File

Binary file not shown.

19
scheme/ikarus.compiler.altcogen.ss
View File

@ -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"))])

24
scheme/ikarus.fixnums.ss
View File

@ -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)
(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))
($fxsll x y)))
(import (ikarus))
(fxarithmetic-shift-left x y)))
(define fxarithmetic-shift
(lambda (x y)

2
scheme/last-revision
View File

@ -1 +1 @@
1415
1416

1
scheme/makefile.ss
View File

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

38
scheme/pass-specify-rep-primops.ss
View File

@ -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

15
scheme/pass-specify-rep.ss
View File

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