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

* Fixes bug 161923: Segfault on float ops 

(I was trying to be too clever with optimizing the checks.)
This commit is contained in:
Abdulaziz Ghuloum 2007-11-11 00:09:00 -05:00
parent 5a6e106a44
commit 5d0f86377e
2 changed files with 55 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
scheme/ikarus.boot.orig
View File

Binary file not shown.

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

@ -858,34 +858,61 @@
x)]) x)])
(define (check-flonums ls code) (define (check-flonums ls code)
(define (or* a*) (cond
(cond [(null? ls) code]
[(null? (cdr a*)) (car a*)] [else
[else (prm 'logor (car a*) (or* (cdr a*)))])) (struct-case (car ls)
(let ([check [(constant v)
(let f ([ls ls] [ac '()]) (if (flonum? v)
(cond (check-flonums (cdr ls) code)
[(null? ls) ac] (interrupt))]
[else [else
(struct-case (car ls) (check-flonums (cdr ls)
[(constant v) (with-tmp ([x (T (car ls))])
(if (flonum? v) (interrupt-unless
(f (cdr ls) ac) (tag-test x vector-mask vector-tag))
#f)] (interrupt-unless
[else (f (cdr ls) (cons (T (car ls)) ac))])]))]) (prm '= (prm 'mref x (K (- vector-tag)))
(cond (K flonum-tag)))
[(not check) (interrupt)] code))])]))
[(null? check) code]
[else ; (define (primary-tag-tests ls)
(seq* ; (cond
(interrupt-unless ; [(null? ls) (prm 'nop)]
(tag-test (or* check) vector-mask vector-tag)) ; [else
(interrupt-unless ; (seq*
(prm '= (or* (map (lambda (x) ; (interrupt-unless
(prm 'mref x (K (- vector-tag)))) ; (tag-test (car ls) vector-mask vector-tag))
check)) ; (primary-tag-tests (cdr ls)))]))
(K flonum-tag))) ; (define (secondary-tag-tests ls)
code)]))) ; (define (or* a*)
; (cond
; [(null? (cdr a*)) (car a*)]
; [else (prm 'logor (car a*) (or* (cdr a*)))]))
; (interrupt-unless
; (prm '= (or* (map (lambda (x)
; (prm 'mref x (K (- vector-tag))))
; ls))
; (K flonum-tag))))
; (let ([check
; (let f ([ls ls] [ac '()])
; (cond
; [(null? ls) ac]
; [else
; (struct-case (car ls)
; [(constant v)
; (if (flonum? v)
; (f (cdr ls) ac)
; #f)]
; [else (f (cdr ls) (cons (T (car ls)) ac))])]))])
; (cond
; [(not check) (interrupt)]
; [(null? check) code]
; [else
; (seq*
; (primary-tag-tests check)
; (secondary-tag-tests check)
; code)])))
(define-primop $fl+ unsafe (define-primop $fl+ unsafe
[(V x y) ($flop-aux 'fl:add! x y)]) [(V x y) ($flop-aux 'fl:add! x y)])