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

case-info record type for cases

This commit is contained in:
Abdulaziz Ghuloum 2006-12-04 19:58:24 -05:00
parent b8b4172797
commit c54ade7cef
2 changed files with 89 additions and 74 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
lib/ikarus.boot
View File

Binary file not shown.

163
lib/libcompile.ss
View File

@ -231,7 +231,8 @@
(define-record fix (lhs* rhs* body)) (define-record fix (lhs* rhs* body))
(define-record seq (e0 e1)) (define-record seq (e0 e1))
(define-record clambda-case (arg* proper body)) (define-record case-info (args proper))
(define-record clambda-case (info body))
(define-record clambda (label cases free)) (define-record clambda (label cases free))
(define-record closure (code free*)) (define-record closure (code free*))
(define-record funcall (op rand*)) (define-record funcall (op rand*))
@ -243,7 +244,6 @@
(define (unique-var x) (define (unique-var x)
(make-var (gensym x) #f #f)) (make-var (gensym x) #f #f))
(define (recordize x) (define (recordize x)
(define (gen-fml* fml*) (define (gen-fml* fml*)
(cond (cond
@ -347,8 +347,9 @@
(let ([nfml* (gen-fml* fml*)]) (let ([nfml* (gen-fml* fml*)])
(let ([body (E body (extend-env fml* nfml* env))]) (let ([body (E body (extend-env fml* nfml* env))])
(make-clambda-case (make-clambda-case
(properize nfml*) (make-case-info
(list? fml*) (properize nfml*)
(list? fml*))
body))))) body)))))
(cdr x))]) (cdr x))])
(make-clambda (gensym) cls* #f))] (make-clambda (gensym) cls* #f))]
@ -432,8 +433,10 @@
`(fix ,(map (lambda (lhs rhs) (list (E lhs) (E rhs))) lhs* rhs*) `(fix ,(map (lambda (lhs rhs) (list (E lhs) (E rhs))) lhs* rhs*)
,(E body))] ,(E body))]
[(seq e0 e1) `(begin ,(E e0) ,(E e1))] [(seq e0 e1) `(begin ,(E e0) ,(E e1))]
[(clambda-case args proper body) [(clambda-case info body)
`(clambda-case ,(E-args proper args) ,(E body))] `(clambda-case ,(E-args (case-info-proper info)
(case-info-args info))
,(E body))]
[(clambda g cls*) [(clambda g cls*)
`(case-lambda . ,(map E cls*))] `(case-lambda . ,(map E cls*))]
[(clambda label clauses free) [(clambda label clauses free)
@ -486,12 +489,14 @@
[else (cons (car rhs*) (properize (cdr lhs*) (cdr rhs*)))])) [else (cons (car rhs*) (properize (cdr lhs*) (cdr rhs*)))]))
(define (inline-case cls rand*) (define (inline-case cls rand*)
(record-case cls (record-case cls
[(clambda-case fml* proper body) [(clambda-case info body)
(if proper (record-case info
(and (fx= (length fml*) (length rand*)) [(case-info fml* proper)
(make-bind fml* rand* body)) (if proper
(and (fx<= (length fml*) (length rand*)) (and (fx= (length fml*) (length rand*))
(make-bind fml* (properize fml* rand*) body)))])) (make-bind fml* rand* body))
(and (fx<= (length fml*) (length rand*))
(make-bind fml* (properize fml* rand*) body)))])]))
(define (try-inline cls* rand* default) (define (try-inline cls* rand* default)
(cond (cond
[(null? cls*) default] [(null? cls*) default]
@ -523,8 +528,8 @@
(make-clambda g (make-clambda g
(map (lambda (x) (map (lambda (x)
(record-case x (record-case x
[(clambda-case fml* proper body) [(clambda-case info body)
(make-clambda-case fml* proper (Expr body))])) (make-clambda-case info (Expr body))]))
cls*) cls*)
#f)] #f)]
[(primcall rator rand*) [(primcall rator rand*)
@ -562,7 +567,7 @@
[else #f])) [else #f]))
(define (branching-clause? x) (define (branching-clause? x)
(record-case x (record-case x
[(clambda-case fml* proper body) [(clambda-case info body)
(bt? body)])) (bt? body)]))
(record-case x (record-case x
[(clambda g cls*) [(clambda g cls*)
@ -601,7 +606,7 @@
(for-each (for-each
(lambda (x) (lambda (x)
(record-case x (record-case x
[(clambda-case fml* proper body) (E body)])) [(clambda-case info body) (E body)]))
cls*)] cls*)]
[(primcall rator rand*) [(primcall rator rand*)
(for-each E rand*) (for-each E rand*)
@ -721,10 +726,10 @@
(make-clambda g (make-clambda g
(map (lambda (x) (map (lambda (x)
(record-case x (record-case x
[(clambda-case fml* proper body) [(clambda-case info body)
(let ([h (make-hash-table)]) (let ([h (make-hash-table)])
(let ([body (E body (extend-hash fml* h ref) void)]) (let ([body (E body (extend-hash (case-info-args info) h ref) void)])
(make-clambda-case fml* proper body)))])) (make-clambda-case info body)))]))
cls*) cls*)
#f)] #f)]
[(primcall rator rand*) [(primcall rator rand*)
@ -792,8 +797,8 @@
(make-clambda g (make-clambda g
(map (lambda (x) (map (lambda (x)
(record-case x (record-case x
[(clambda-case fml* proper body) [(clambda-case info body)
(make-clambda-case fml* proper (Expr body))])) (make-clambda-case info (Expr body))]))
cls*) cls*)
#f)] #f)]
[(primcall rator rand*) [(primcall rator rand*)
@ -836,8 +841,10 @@
[(clambda g cls*) [(clambda g cls*)
(for-each (for-each
(lambda (cls) (lambda (cls)
(for-each init-var (clambda-case-arg* cls)) (record-case cls
(Expr (clambda-case-body cls))) [(clambda-case info body)
(for-each init-var (case-info-args info))
(Expr body)]))
cls*)] cls*)]
[(primcall rator rand*) (Expr* rand*)] [(primcall rator rand*) (Expr* rand*)]
[(funcall rator rand*) [(funcall rator rand*)
@ -921,9 +928,8 @@
(make-clambda g (make-clambda g
(map (lambda (cls) (map (lambda (cls)
(record-case cls (record-case cls
[(clambda-case arg* proper body) [(clambda-case info body)
(make-clambda-case arg* proper (make-clambda-case info (Value body))]))
(Value body))]))
cls*) cls*)
#f)) #f))
(define (Effect x) (define (Effect x)
@ -1057,10 +1063,13 @@
(make-clambda g (make-clambda g
(map (lambda (cls) (map (lambda (cls)
(record-case cls (record-case cls
[(clambda-case fml* proper body) [(clambda-case info body)
(let-values ([(fml* a-lhs* a-rhs*) (fix-lhs* fml*)]) (record-case info
(make-clambda-case fml* proper [(case-info fml* proper)
(bind-assigned a-lhs* a-rhs* (Expr body))))])) (let-values ([(fml* a-lhs* a-rhs*) (fix-lhs* fml*)])
(make-clambda-case
(make-case-info fml* proper)
(bind-assigned a-lhs* a-rhs* (Expr body))))])]))
cls*) cls*)
#f)] #f)]
[(primcall op rand*) [(primcall op rand*)
@ -1103,13 +1112,12 @@
[(null? cls*) (values '() '())] [(null? cls*) (values '() '())]
[else [else
(record-case (car cls*) (record-case (car cls*)
[(clambda-case fml* proper body) [(clambda-case info body)
(let-values ([(body body-free) (Expr body)] (let-values ([(body body-free) (Expr body)]
[(cls* cls*-free) (f (cdr cls*))]) [(cls* cls*-free) (f (cdr cls*))])
(values (values
(cons (make-clambda-case fml* proper body) (cons (make-clambda-case info body) cls*)
cls*) (union (difference body-free (case-info-args info))
(union (difference body-free fml*)
cls*-free)))])]))]) cls*-free)))])]))])
(values (make-closure (make-clambda g cls* free) free) (values (make-closure (make-clambda g cls* free) free)
free))])) free))]))
@ -1184,10 +1192,10 @@
(let ([cls* (map (let ([cls* (map
(lambda (x) (lambda (x)
(record-case x (record-case x
[(clambda-case fml* proper body) [(clambda-case info body)
(for-each init-non-thunk fml*) (for-each init-non-thunk
(make-clambda-case fml* proper (case-info-args info))
(E body))])) (make-clambda-case info (E body))]))
cls*)]) cls*)])
(let ([g (make-code-loc label)]) (let ([g (make-code-loc label)])
(set! all-codes (set! all-codes
@ -1306,8 +1314,8 @@
(let ([cls* (map (let ([cls* (map
(lambda (x) (lambda (x)
(record-case x (record-case x
[(clambda-case fml* proper body) [(clambda-case info body)
(make-clambda-case fml* proper (E body))])) (make-clambda-case info (E body))]))
cls*)]) cls*)])
(let ([g (make-code-loc label)]) (let ([g (make-code-loc label)])
(set! all-codes (set! all-codes
@ -1533,8 +1541,8 @@
[else (error who "invalid expression ~s" (unparse x))])) [else (error who "invalid expression ~s" (unparse x))]))
(define (CaseExpr x) (define (CaseExpr x)
(record-case x (record-case x
[(clambda-case fml* proper body) [(clambda-case info body)
(make-clambda-case fml* proper (Tail body))])) (make-clambda-case info (Tail body))]))
(define (CodeExpr x) (define (CodeExpr x)
(record-case x (record-case x
[(clambda L cases free) [(clambda L cases free)
@ -1614,8 +1622,8 @@
[else (error who "invalid expression ~s" (unparse x))])) [else (error who "invalid expression ~s" (unparse x))]))
(define (CaseExpr x) (define (CaseExpr x)
(record-case x (record-case x
[(clambda-case fml* proper body) [(clambda-case info body)
(make-clambda-case fml* proper (Tail body))])) (make-clambda-case info (Tail body))]))
(define (CodeExpr x) (define (CodeExpr x)
(record-case x (record-case x
[(clambda L clauses free) [(clambda L clauses free)
@ -1666,9 +1674,9 @@
[else (error who "invalid tail expression ~s" (unparse x))])) [else (error who "invalid tail expression ~s" (unparse x))]))
(define (CaseExpr x) (define (CaseExpr x)
(record-case x (record-case x
[(clambda-case fml* proper body) [(clambda-case info body)
(if (Tail body) (if (Tail body)
(make-clambda-case fml* proper (insert-check body)) (make-clambda-case info (insert-check body))
x)])) x)]))
(define (CodeExpr x) (define (CodeExpr x)
(record-case x (record-case x
@ -1814,8 +1822,8 @@
[else (error who "invalid expression ~s" (unparse x))])) [else (error who "invalid expression ~s" (unparse x))]))
(define (CaseExpr x) (define (CaseExpr x)
(record-case x (record-case x
[(clambda-case fml* proper body) [(clambda-case info body)
(make-clambda-case fml* proper (Tail body))])) (make-clambda-case info (Tail body))]))
(define (CodeExpr x) (define (CodeExpr x)
(record-case x (record-case x
[(clambda L cases free) [(clambda L cases free)
@ -2053,9 +2061,12 @@
(lambda (r) (lambda (r)
(lambda (x) (lambda (x)
(record-case x (record-case x
[(clambda-case fml* proper body) [(clambda-case info body)
(let-values ([(fml* si r live) (bind-fml* fml* r)]) (let-values ([(fml* si r live)
(make-clambda-case fml* proper (Tail body si r live)))])))) (bind-fml* (case-info-args info) r)])
(make-clambda-case
(make-case-info fml* (case-info-proper info))
(Tail body si r live)))]))))
(define (CodeExpr x) (define (CodeExpr x)
(record-case x (record-case x
[(clambda L cases free) [(clambda L cases free)
@ -2156,8 +2167,8 @@
(define CaseExpr (define CaseExpr
(lambda (x) (lambda (x)
(record-case x (record-case x
[(clambda-case fml* proper body) [(clambda-case info body)
(make-clambda-case fml* proper (Tail body 0))]))) (make-clambda-case info (Tail body 0))])))
(define (CodeExpr x) (define (CodeExpr x)
(record-case x (record-case x
[(clambda L cases free) [(clambda L cases free)
@ -3724,34 +3735,38 @@
ac)) ac))
(define (Entry check? x ac) (define (Entry check? x ac)
(record-case x (record-case x
[(clambda-case fml* proper body) [(clambda-case info body)
(let ([ac (Tail body ac)]) (let ([ac (Tail body ac)])
(cond (record-case info
[(and proper check?) [(case-info fml* proper)
(list* (cmpl (int (argc-convention (length fml*))) eax) (cond
(jne (label SL_invalid_args)) [(and proper check?)
ac)] (list* (cmpl (int (argc-convention (length fml*))) eax)
[proper ac] (jne (label SL_invalid_args))
[else ac)]
(handle-vararg (length fml*) ac)]))])) [proper ac]
[else
(handle-vararg (length fml*) ac)])]))]))
(define make-dispatcher (define make-dispatcher
(lambda (j? L L* x x* ac) (lambda (j? L L* x x* ac)
(cond (cond
[(null? L*) (if j? (cons (jmp (label L)) ac) ac)] [(null? L*) (if j? (cons (jmp (label L)) ac) ac)]
[else [else
(record-case x (record-case x
[(clambda-case fml* proper _) [(clambda-case info _)
(cond (record-case info
[proper [(case-info fml* proper)
(list* (cmpl (int (argc-convention (length fml*))) eax) (cond
(je (label L)) [proper
(make-dispatcher #t (list* (cmpl (int (argc-convention (length fml*))) eax)
(car L*) (cdr L*) (car x*) (cdr x*) ac))] (je (label L))
[else (make-dispatcher #t
(list* (cmpl (int (argc-convention (fxsub1 (length fml*)))) eax) (car L*) (cdr L*) (car x*) (cdr x*) ac))]
(jle (label L)) [else
(make-dispatcher #t (list* (cmpl (int (argc-convention (fxsub1 (length fml*)))) eax)
(car L*) (cdr L*) (car x*) (cdr x*) ac))])])]))) (jle (label L))
(make-dispatcher #t
(car L*) (cdr L*) (car x*) (cdr x*) ac))])])])])))
(define (handle-cases x x*) (define (handle-cases x x*)
(let ([L* (map (lambda (_) (gensym)) x*)] (let ([L* (map (lambda (_) (gensym)) x*)]
[L (gensym)]) [L (gensym)])