diff --git a/src/ikarus.boot b/src/ikarus.boot index ffe1b55..6b962f3 100644 Binary files a/src/ikarus.boot and b/src/ikarus.boot differ diff --git a/src/ikarus.compiler.ss b/src/ikarus.compiler.ss index 3788fba..0d925a6 100644 --- a/src/ikarus.compiler.ss +++ b/src/ikarus.compiler.ss @@ -664,7 +664,7 @@ [else (cons (E (car x*) ref comp) (E* (cdr x*) ref comp))])) - (define (do-rhs* i lhs* rhs* ref comp vref vcomp) + (define (do-rhs*-old i lhs* rhs* ref comp vref vcomp) (cond [(null? rhs*) '()] [else @@ -681,7 +681,25 @@ (vector-set! vcomp i #t) (comp))]) (cons (E (car rhs*) ref comp) - (do-rhs* (fxadd1 i) lhs* (cdr rhs*) ref comp vref vcomp))))])) + (do-rhs* (fxadd1 i) lhs* (cdr rhs*) ref comp vref vcomp))))])) + (define (do-rhs* i lhs* rhs* ref comp vref vcomp) + (cond + [(null? rhs*) '()] + [else + (let ([h (make-hash-table)] + [rest (do-rhs* (fxadd1 i) lhs* (cdr rhs*) ref comp vref vcomp)]) + (let ([ref + (lambda (x) + (unless (get-hash-table h x #f) + (put-hash-table! h x #t) + (ref x) + (when (memq x lhs*) + (vector-set! vref i #t))))] + [comp + (lambda () + (vector-set! vcomp i #t) + (comp))]) + (cons (E (car rhs*) ref comp) rest)))])) (define (partition-rhs* i lhs* rhs* vref vcomp) (cond [(null? lhs*) (values '() '() '() '() '() '())] @@ -710,6 +728,13 @@ (let-values ([(slhs* srhs* llhs* lrhs* clhs* crhs*) (partition-rhs* 0 lhs* rhs* vref vcomp)]) (let ([v* (map (lambda (x) (make-constant (void))) clhs*)]) + ;(let ([ls + ; (let f ([ls clhs*]) + ; (cond + ; [(null? ls) '()] + ; [(var-assigned (car ls)) (f (cdr ls))] + ; [else (cons (var-name (car ls)) (f (cdr ls)))]))]) + ; (unless (null? ls) (printf "complex: ~s\n" ls))) (make-bind slhs* srhs* (make-bind clhs* v* (make-fix llhs* lrhs* @@ -969,6 +994,17 @@ (list a0 (make-constant (car ls)))))] [else (make-funcall (make-primref '$memq) rand*)]))))) (giveup))] + [(length) + (or (and (fx= (length rand*) 1) + (let ([a0 (car rand*)]) + (constant-value a0 + (lambda (ls) + (cond + [(not (list? ls)) #f] + [(eq? ctxt 'v) (make-constant (length ls))] + [(eq? ctxt 'e) a0] + [else (mk-seq a0 (make-constant #t))]))))) + (giveup))] [(list) (case ctxt [(v) (if (null? rand*) (make-constant '()) (giveup))] diff --git a/src/libaltcogen.ss b/src/libaltcogen.ss index 6d41bce..1f0d41f 100644 --- a/src/libaltcogen.ss +++ b/src/libaltcogen.ss @@ -1317,7 +1317,7 @@ [(int-/overflow int+/overflow int*/overflow) (let ([v (exception-live-set)]) (unless (vector? v) - (error who "unbound exception")) + (error who "unbound exception for ~s ~s" x v)) (let ([vs (union-vars vs (vector-ref v 0))] [rs (union-regs rs (vector-ref v 1))] [fs (union-frms fs (vector-ref v 2))] @@ -1407,7 +1407,7 @@ [(interrupt) (let ([v (exception-live-set)]) (unless (vector? v) - (error who "unbound exception")) + (error who "unbound exception2")) (values (vector-ref v 0) (vector-ref v 1) (vector-ref v 2) diff --git a/src/pass-specify-rep-primops.ss b/src/pass-specify-rep-primops.ss index 4c294ca..8a337bf 100644 --- a/src/pass-specify-rep-primops.ss +++ b/src/pass-specify-rep-primops.ss @@ -831,6 +831,7 @@ (cond [(non-fixnum? a) (interrupt)] [else + (interrupt) (seq* (assert-fixnums a '()) (prm 'int-/overflow (K 0) (T a)))])] @@ -838,6 +839,7 @@ (cond [(or (non-fixnum? a) (ormap non-fixnum? a*)) (interrupt)] [else + (interrupt) (seq* (assert-fixnums a a*) (let f ([a (T a)] [a* a*]) @@ -854,6 +856,7 @@ (cond [(or (non-fixnum? a) (ormap non-fixnum? a*)) (interrupt)] [else + (interrupt) (seq* (assert-fixnums a a*) (let f ([a (T a)] [a* a*])