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

Fixed bug that caused mvcalls to lose their live masks.

This commit is contained in:
Abdulaziz Ghuloum 2007-01-01 01:46:47 +03:00
parent a8e1b860bb
commit eb24d17049
4 changed files with 31 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
bin/Makefile
View File

@ -1,6 +1,6 @@
#CFLAGS = -I/opt/local/include -Wall -DNDEBUG -O3 #-fomit-frame-pointer CFLAGS = -I/opt/local/include -Wall -DNDEBUG -O3 #-fomit-frame-pointer
CFLAGS = -I/opt/local/include -Wall -g #CFLAGS = -I/opt/local/include -Wall -g
LDFLAGS = -L/opt/local/lib -g -ldl -lgmp #-rdynamic LDFLAGS = -L/opt/local/lib -g -ldl -lgmp #-rdynamic
CC = gcc CC = gcc
all: ikarus all: ikarus

BIN
bin/ikarus
View File

Binary file not shown.

BIN
src/ikarus.boot
View File

Binary file not shown.

38
src/libcompile.ss
View File

@ -505,7 +505,7 @@
[(primref op) [(primref op)
(case op (case op
;;; FIXME HERE ;;; FIXME HERE
#;[(call-with-values) [(call-with-values)
(cond (cond
[(fx= (length rand*) 2) [(fx= (length rand*) 2)
(let ([producer (inline (car rand*) '())] (let ([producer (inline (car rand*) '())]
@ -2549,7 +2549,8 @@
[(primref? x) #f] ;;;; PRIMREF CHECK [(primref? x) #f] ;;;; PRIMREF CHECK
[(closure? x) #f] [(closure? x) #f]
[else #t])) [else #t]))
(define (do-new-frame label op rand* si r call-convention rp-convention orig-live) (define (do-new-frame label op rand* si r
call-convention rp-convention orig-live)
(let ([start-si (if save-cp? (fxadd1 si) si)]) (let ([start-si (if save-cp? (fxadd1 si) si)])
(make-new-frame start-si (fx+ (length rand*) 2) (make-new-frame start-si (fx+ (length rand*) 2)
(let f ([r* rand*] [nsi (fxadd1 start-si)] [live orig-live]) (let f ([r* rand*] [nsi (fxadd1 start-si)] [live orig-live])
@ -2619,6 +2620,27 @@
(f (cdr l*) (cons v nlhs*) (fxadd1 si) (f (cdr l*) (cons v nlhs*) (fxadd1 si)
(cons (cons (car l*) v) r) (cons (cons (car l*) v) r)
(cons si live)))]))) (cons si live)))])))
(define (do-tail-frame-unoptimized label op rand* si r call-conv live)
(let f ([i si] [r* rand*] [live live])
(cond
[(null? r*)
(make-seq
(make-eval-cp (check? op) (Expr op i r live))
(let f ([i 1] [j si] [r* rand*])
(cond
[(null? r*)
(make-tailcall-cp call-conv label (length rand*))]
[else
(make-seq
(make-assign (make-frame-var i)
(make-frame-var j))
(f (fxadd1 i) (fxadd1 j) (cdr r*)))])))]
[else
(let ([fv (make-frame-var i)]
[rhs (Expr (car r*) i r live)])
(make-seq
(make-assign fv rhs)
(f (fxadd1 i) (cdr r*) (cons i live))))])))
(define (do-tail-frame label op rand* si r call-conv live) (define (do-tail-frame label op rand* si r call-conv live)
(define (const? x) (define (const? x)
(record-case x (record-case x
@ -2696,10 +2718,8 @@
[(case-info label fml* proper) [(case-info label fml* proper)
(let-values ([(fml* si r live) (let-values ([(fml* si r live)
(bind-fml* fml* (bind-fml* fml*
(if save-cp? (if save-cp? (fx+ si 2) (fx+ si 1))
(fx+ si 2) r live)])
(fx+ si 1))
r)])
(make-clambda-case (make-clambda-case
(make-case-info label fml* proper) (make-case-info label fml* proper)
(k body si r live)))])])) (k body si r live)))])]))
@ -2786,10 +2806,10 @@
(do-mvcall p c x si r live Expr)] (do-mvcall p c x si r live Expr)]
[else (error who "invalid expression ~s" (unparse x))])) [else (error who "invalid expression ~s" (unparse x))]))
(Tail orig-x orig-si orig-r orig-live)) (Tail orig-x orig-si orig-r orig-live))
(define (bind-fml* fml* si r) (define (bind-fml* fml* si r live)
(let f ([si si] [fml* fml*]) (let f ([si si] [fml* fml*])
(cond (cond
[(null? fml*) (values '() si r '())] [(null? fml*) (values '() si r live)]
[else [else
(let-values ([(nfml* nsi r live) (let-values ([(nfml* nsi r live)
(f (fxadd1 si) (cdr fml*))]) (f (fxadd1 si) (cdr fml*))])
@ -2812,7 +2832,7 @@
[(clambda-case info body) [(clambda-case info body)
(record-case info (record-case info
[(case-info label fml* proper) [(case-info label fml* proper)
(let-values ([(fml* si r live) (bind-fml* fml* 1 r)]) (let-values ([(fml* si r live) (bind-fml* fml* 1 r '())])
(make-clambda-case (make-clambda-case
(make-case-info label fml* proper) (make-case-info label fml* proper)
(Body body si r live save-cp?)))])])))) (Body body si r live save-cp?)))])]))))