suzanne.soy/scheme-to-c
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

cleaned up a little bit of how code is displayed when it is unparsed for tracing purposes

Browse Source
This commit is contained in:
Andy Keep 2013-12-10 00:41:15 -07:00
parent 9b36621375
commit cd5cc82694
1 changed files with 179 additions and 74 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

251
c.ss
View File

@ -250,6 +250,34 @@
(string->symbol (string->symbol
(string-append (symbol->string name) "." (number->string c))))))) (string-append (symbol->string name) "." (number->string c)))))))
;; strip the numberic bit back off the unique-var
(define base-var
(lambda (x)
(define s0
(lambda (rls)
(if (null? rls)
(error 'base-var "not a unique-var created variable" x)
(let ([c (car rls)])
(cond
[(char-numeric? c) (s1 (cdr rls))]
[else (error 'base-var
"not a unique-var created variable" x)])))))
(define s1
(lambda (rls)
(if (null? rls)
(error 'base-var "not a unique-var created variable" x)
(let ([c (car rls)])
(cond
[(char-numeric? c) (s1 (cdr rls))]
[(char=? c #\.) (cdr rls)]
[else (error 'base-var
"not a unique-var created variable" x)])))))
(string->symbol
(list->string
(reverse
(s0 (reverse (string->list (symbol->string x)))))))))
;;; Convenience procedure for building temporaries in the compiler. ;;; Convenience procedure for building temporaries in the compiler.
(define make-tmp (lambda () (unique-var 't))) (define make-tmp (lambda () (unique-var 't)))
@ -732,7 +760,7 @@
(let ([x* e*] ...) abody) (let ([x* e*] ...) abody)
(letrec ([x* e*] ...) abody))) (letrec ([x* e*] ...) abody)))
(AssignedBody (abody) (AssignedBody (abody)
(+ (assigned (a* ...) body) => body))) (+ (assigned (a* ...) body))))
;;; Language 8: letrec binding is changed to only bind variables to lambdas. ;;; Language 8: letrec binding is changed to only bind variables to lambdas.
; ;
@ -1004,13 +1032,15 @@
(Expr (e body) (Expr (e body)
(- x (- x
(quote c) (quote c)
(label l)
(primcall pr e* ...) (primcall pr e* ...)
(e e* ...)) (e e* ...))
(+ se (+ se
(primcall pr se* ...) (primcall pr se* ...) => (pr se* ...)
(se se* ...))) (se se* ...)))
(SimpleExpr (se) (SimpleExpr (se)
(+ x (+ x
(label l)
(quote c)))) (quote c))))
;;; Language 16: separates the Expr nonterminal into the Value, Effect, and ;;; Language 16: separates the Expr nonterminal into the Value, Effect, and
@ -1037,14 +1067,14 @@
(if p0 v1 v2) (if p0 v1 v2)
(begin e* ... v) (begin e* ... v)
(let ([x* v*] ...) body) (let ([x* v*] ...) body)
(primcall vpr se* ...) (primcall vpr se* ...) => (vpr se* ...)
(se se* ...)) (se se* ...))
(Effect (e) (Effect (e)
(nop) (nop)
(if p0 e1 e2) (if p0 e1 e2)
(begin e* ... e) (begin e* ... e)
(let ([x* v*] ...) e) (let ([x* v*] ...) e)
(primcall epr se* ...) (primcall epr se* ...) => (epr se* ...)
(se se* ...)) (se se* ...))
(Predicate (p) (Predicate (p)
(true) (true)
@ -1052,7 +1082,7 @@
(if p0 p1 p2) (if p0 p1 p2)
(begin e* ... p) (begin e* ... p)
(let ([x* v*] ...) p) (let ([x* v*] ...) p)
(primcall ppr se* ...))) (primcall ppr se* ...) => (ppr se* ...)))
;;; Language 17: removes the allocation primitives: cons, box, make-vector, ;;; Language 17: removes the allocation primitives: cons, box, make-vector,
;;; and make-closure and adds a generic alloc form for specifying allocation. It ;;; and make-closure and adds a generic alloc form for specifying allocation. It
@ -1225,7 +1255,7 @@
(Rhs (rhs) (Rhs (rhs)
(+ se (+ se
(alloc i se) (alloc i se)
(primcall vpr se* ...) (primcall vpr se* ...) => (vpr se* ...)
(se se* ...))) (se se* ...)))
(Effect (e) (Effect (e)
(- (set! x v)) (- (set! x v))
@ -1719,12 +1749,25 @@
;;; with-output-language. ;;; with-output-language.
(definitions (definitions
;;; build-begin - helper function to build a begin only when the body ;;; build-begin - helper function to build a begin only when the body
;;; contains more then one expression. ;;; contains more then one expression. (this version of the helper
;;; is a little over-kill, but it makes our traces look a little
;;; cleaner. there should be a simpler way of doing this.)
(define build-begin (define build-begin
(lambda (body* body) (lambda (e* e)
(if (null? body*) (nanopass-case (L3 Expr) e
body [(begin ,e1* ... ,e)
`(begin ,body* ... ,body))))) (build-begin (append e* e1*) e)]
[else
(if (null? e*)
e
(let loop ([e* e*] [re* '()])
(if (null? e*)
`(begin ,(reverse re*) ... ,e)
(let ([e (car e*)])
(nanopass-case (L3 Expr) e
[(begin ,e0* ... ,e0)
(loop (append e0* (cons e0 (cdr e*))) re*)]
[else (loop (cdr e*) (cons (car e*) re*))])))))]))))
[(let ([,x* ,[e*]] ...) ,[body*] ... ,[body]) [(let ([,x* ,[e*]] ...) ,[body*] ... ,[body])
`(let ([,x* ,e*] ...) ,(build-begin body* body))] `(let ([,x* ,e*] ...) ,(build-begin body* body))]
[(letrec ([,x* ,[e*]] ...) ,[body*] ... ,[body]) [(letrec ([,x* ,[e*]] ...) ,[body*] ... ,[body])
@ -2057,10 +2100,21 @@
;; build a begin when we have more then one expression, otherwise just ;; build a begin when we have more then one expression, otherwise just
;; return the one expression. ;; return the one expression.
(define build-begin (define build-begin
(lambda (body* body) (lambda (e* e)
(if (null? body*) (nanopass-case (L8 Expr) e
body [(begin ,e1* ... ,e)
`(begin ,body* ... ,body))))) (build-begin (append e* e1*) e)]
[else
(if (null? e*)
e
(let loop ([e* e*] [re* '()])
(if (null? e*)
`(begin ,(reverse re*) ... ,e)
(let ([e (car e*)])
(nanopass-case (L8 Expr) e
[(begin ,e0* ... ,e0)
(loop (append e0* (cons e0 (cdr e*))) re*)]
[else (loop (cdr e*) (cons (car e*) re*))])))))]))))
[(letrec ([,x* ,[e*]] ...) (assigned (,a* ...) ,[body])) [(letrec ([,x* ,[e*]] ...) (assigned (,a* ...) ,[body]))
;; loop through our bindings, separating them into simple, lambda, and ;; loop through our bindings, separating them into simple, lambda, and
;; complex. ;; complex.
@ -2182,7 +2236,7 @@
(define-pass remove-anonymous-lambda : L8 (e) -> L9 () (define-pass remove-anonymous-lambda : L8 (e) -> L9 ()
(Expr : Expr (e) -> Expr () (Expr : Expr (e) -> Expr ()
[(lambda (,x* ...) ,[abody]) [(lambda (,x* ...) ,[abody])
(let ([t (make-tmp)]) (let ([t (unique-var 'anon)])
`(letrec ([,t (lambda (,x* ...) ,abody)]) ,t))])) `(letrec ([,t (lambda (,x* ...) ,abody)]) ,t))]))
;;; pass: convert-assignments : L9 -> L10 ;;; pass: convert-assignments : L9 -> L10
@ -2265,19 +2319,17 @@
[(let ([,x* ,[e*]] ...) (assigned (,a* ...) ,body)) [(let ([,x* ,[e*]] ...) (assigned (,a* ...) ,body))
(build-env x* a* env (build-env x* a* env
(lambda (x* t* env) (lambda (x* t* env)
(let ([box* (make-boxes t*)] [body (Expr body env)]) (build-let x* e*
`(let ([,x* ,e*] ...) (build-let a* (make-boxes t*)
(let ([,a* ,box*] ...) (Expr body env)))))]
,body)))))]
[,x (if (assq x env) `(primcall unbox ,x) x)] [,x (if (assq x env) `(primcall unbox ,x) x)]
[(set! ,x ,[e]) `(primcall set-box! ,x ,e)]) [(set! ,x ,[e]) `(primcall set-box! ,x ,e)])
(LambdaExpr : LambdaExpr (le env) -> LambdaExpr () (LambdaExpr : LambdaExpr (le env) -> LambdaExpr ()
[(lambda (,x* ...) (assigned (,a* ...) ,body)) [(lambda (,x* ...) (assigned (,a* ...) ,body))
(build-env x* a* env (build-env x* a* env
(lambda (x* t* env) (lambda (x* t* env)
(let ([box* (make-boxes t*)] [body (Expr body env)]) `(lambda (,x* ...)
`(lambda (,x* ...) ,(build-let a* (make-boxes t*) (Expr body env)))))]))
(let ([,a* ,box*] ...) ,body)))))]))
;;; pass: uncover-free : L10 -> L11 ;;; pass: uncover-free : L10 -> L11
;;; ;;;
@ -2367,10 +2419,18 @@
;;; any free variables. ;;; any free variables.
;;; ;;;
(define-pass convert-closures : L11 (e) -> L12 () (define-pass convert-closures : L11 (e) -> L12 ()
(definitions
(define make-cp (lambda (x) (unique-var 'cp)))
(define make-label
(lambda (x)
(unique-var
(string->symbol
(string-append "l:"
(symbol->string (base-var x))))))))
(Expr : Expr (e) -> Expr () (Expr : Expr (e) -> Expr ()
[(letrec ([,x* (lambda (,x** ...) (free (,f** ...) ,[body*]))] ...) [(letrec ([,x* (lambda (,x** ...) (free (,f** ...) ,[body*]))] ...)
,[body]) ,[body])
(let ([l* (map unique-var x*)] [cp* (map unique-var x*)]) (let ([l* (map make-label x*)] [cp* (map make-cp x*)])
`(closures ([,x* ,l* ,f** ...] ...) `(closures ([,x* ,l* ,f** ...] ...)
(labels ([,l* (lambda (,cp* ,x** ...) (labels ([,l* (lambda (,cp* ,x** ...)
(free (,f** ...) ,body*))] ...) (free (,f** ...) ,body*))] ...)
@ -2487,12 +2547,14 @@
e*))))) e*)))))
'() '()
x* l* f**)))) x* l* f**))))
[(closures ([,x* ,l* ,f** ...] ...) ,lbody) [(closures ([,x* ,l* ,f** ...] ...)
(labels ([,l2* ,[le*]] ...) ,[body]))
(let ([size* (map length f**)]) (let ([size* (map length f**)])
`(let ([,x* (primcall make-closure (quote ,size*))] ...) `(let ([,x* (primcall make-closure (quote ,size*))] ...)
(begin (labels ([,l2* ,le*] ...)
,(build-closure-set* x* l* f** cp free*) ... (begin
,(LabelsBody lbody))))] ,(build-closure-set* x* l* f** cp free*) ...
,body))))]
[,x (handle-closure-ref x cp free*)] [,x (handle-closure-ref x cp free*)]
[((label ,l) ,[e*] ...) `((label ,l) ,e* ...)] [((label ,l) ,[e*] ...) `((label ,l) ,e* ...)]
[(,[e] ,[e*] ...) `((primcall closure-code ,e) ,e* ...)]) [(,[e] ,[e*] ...) `((primcall closure-code ,e) ,e* ...)])
@ -2524,7 +2586,7 @@
(set! *l* (append l* *l*)) (set! *l* (append l* *l*))
(set! *le* (append le* *le*)) (set! *le* (append le* *le*))
body]) body])
(let ([e (Expr e)] [l (make-tmp)]) (let ([e (Expr e)] [l (unique-var 'l:program)])
`(labels ([,l (lambda () ,e)] [,*l* ,*le*] ...) ,l))) `(labels ([,l (lambda () ,e)] [,*l* ,*le*] ...) ,l)))
;;; pass: remove-complex-opera* : L14 -> L15 ;;; pass: remove-complex-opera* : L14 -> L15
@ -2560,6 +2622,7 @@
(nanopass-case (L15 Expr) e (nanopass-case (L15 Expr) e
[,x (loop (cdr e*) t* te* (cons x re*))] [,x (loop (cdr e*) t* te* (cons x re*))]
[(quote ,c) (loop (cdr e*) t* te* (cons e re*))] [(quote ,c) (loop (cdr e*) t* te* (cons e re*))]
[(label ,l) (loop (cdr e*) t* te* (cons e re*))]
[else (let ([t (make-tmp)]) [else (let ([t (make-tmp)])
(loop (cdr e*) (cons t t*) (loop (cdr e*) (cons t t*)
(cons e te*) (cons t re*)))]))))))) (cons e te*) (cons t re*)))])))))))
@ -2784,13 +2847,25 @@
(definitions (definitions
(define build-begin (define build-begin
(lambda (e* v) (lambda (e* v)
(if (null? e*) (nanopass-case (L18 Value) v
v [(begin ,e1* ... ,v)
`(begin ,e* ... ,v))))) (build-begin (append e* e1*) v)]
[else
(if (null? e*)
v
(let loop ([e* e*] [re* '()])
(if (null? e*)
`(begin ,(reverse re*) ... ,v)
(let ([e (car e*)])
(nanopass-case (L18 Effect) e
[(nop) (loop (cdr e*) re*)]
[(begin ,e0* ... ,e0)
(loop (append e0* (cons e0 (cdr e*))) re*)]
[else (loop (cdr e*) (cons (car e*) re*))])))))]))))
[(if ,[p0 var0*] ,[v1 var1*] ,[v2 var2*]) [(if ,[p0 var0*] ,[v1 var1*] ,[v2 var2*])
(values `(if ,p0 ,v1 ,v2) (append var0* var1* var2*))] (values `(if ,p0 ,v1 ,v2) (append var0* var1* var2*))]
[(begin ,[e* var**] ... ,[v var*]) [(begin ,[e* var**] ... ,[v var*])
(values `(begin ,e* ... ,v) (apply append var* var**))] (values (build-begin e* v) (apply append var* var**))]
[(primcall ,vpr ,[se* var**] ...) [(primcall ,vpr ,[se* var**] ...)
(values `(primcall ,vpr ,se* ...) (apply append var**))] (values `(primcall ,vpr ,se* ...) (apply append var**))]
[(,[se var*] ,[se* var**] ...) [(,[se var*] ,[se* var**] ...)
@ -2803,13 +2878,25 @@
(definitions (definitions
(define build-begin (define build-begin
(lambda (e* e) (lambda (e* e)
(if (null? e*) (nanopass-case (L18 Effect) e
e [(begin ,e1* ... ,e)
`(begin ,e* ... ,e))))) (build-begin (append e* e1*) e)]
[else
(if (null? e*)
e
(let loop ([e* e*] [re* '()])
(if (null? e*)
`(begin ,(reverse re*) ... ,e)
(let ([e (car e*)])
(nanopass-case (L18 Effect) e
[(nop) (loop (cdr e*) re*)]
[(begin ,e0* ... ,e0)
(loop (append e0* (cons e0 (cdr e*))) re*)]
[else (loop (cdr e*) (cons (car e*) re*))])))))]))))
[(if ,[p0 var0*] ,[e1 var1*] ,[e2 var2*]) [(if ,[p0 var0*] ,[e1 var1*] ,[e2 var2*])
(values `(if ,p0 ,e1 ,e2) (append var0* var1* var2*))] (values `(if ,p0 ,e1 ,e2) (append var0* var1* var2*))]
[(begin ,[e* var**] ... ,[e var*]) [(begin ,[e* var**] ... ,[e var*])
(values `(begin ,e* ... ,e) (apply append var* var**))] (values (build-begin e* e) (apply append var* var**))]
[(primcall ,epr ,[se* var**] ...) [(primcall ,epr ,[se* var**] ...)
(values `(primcall ,epr ,se* ...) (apply append var**))] (values `(primcall ,epr ,se* ...) (apply append var**))]
[(,[se var*] ,[se* var**] ...) [(,[se var*] ,[se* var**] ...)
@ -2822,13 +2909,25 @@
(definitions (definitions
(define build-begin (define build-begin
(lambda (e* p) (lambda (e* p)
(if (null? e*) (nanopass-case (L18 Predicate) p
p [(begin ,e1* ... ,p)
`(begin ,e* ... ,p))))) (build-begin (append e* e1*) p)]
[else
(if (null? e*)
p
(let loop ([e* e*] [re* '()])
(if (null? e*)
`(begin ,(reverse re*) ... ,e)
(let ([e (car e*)])
(nanopass-case (L18 Effect) e
[(nop) (loop (cdr e*) re*)]
[(begin ,e0* ... ,e0)
(loop (append e0* (cons e0 (cdr e*))) re*)]
[else (loop (cdr e*) (cons (car e*) re*))])))))]))))
[(if ,[p0 var0*] ,[p1 var1*] ,[p2 var2*]) [(if ,[p0 var0*] ,[p1 var1*] ,[p2 var2*])
(values `(if ,p0 ,p1 ,p2) (append var0* var1* var2*))] (values `(if ,p0 ,p1 ,p2) (append var0* var1* var2*))]
[(begin ,[e* var**] ... ,[p var*]) [(begin ,[e* var**] ... ,[p var*])
(values `(begin ,e* ... ,p) (apply append var* var**))] (values (build-begin e* p) (apply append var* var**))]
[(primcall ,ppr ,[se* var**] ...) [(primcall ,ppr ,[se* var**] ...)
(values `(primcall ,ppr ,se* ...) (apply append var**))] (values `(primcall ,ppr ,se* ...) (apply append var**))]
[(let ([,x* ,[v* var**]] ...) ,[p var*]) [(let ([,x* ,[v* var**]] ...) ,[p var*])
@ -2955,7 +3054,7 @@
;;; the representation to LLVM or asm.js. ;;; the representation to LLVM or asm.js.
;;;; ;;;;
(define-pass expand-primitives : L21 (e) -> L22 () (define-pass expand-primitives : L21 (e) -> L22 ()
#;(Value : Value (v) -> Value () (Value : Value (v) -> Value ()
(definitions (definitions
(define build-begin (define build-begin
(lambda (e* v) (lambda (e* v)
@ -2963,15 +3062,17 @@
[(begin ,e1* ... ,v) [(begin ,e1* ... ,v)
(build-begin (append e* e1*) v)] (build-begin (append e* e1*) v)]
[else [else
(let loop ([e* e*] [re* '()]) (if (null? e*)
(if (null? e*) v
`(begin ,(reverse re*) ... ,v) (let loop ([e* e*] [re* '()])
(let ([e (car e*)]) (if (null? e*)
(nanopass-case (L22 Effect) e `(begin ,(reverse re*) ... ,v)
[(nop) (loop (cdr e*) re*)] (let ([e (car e*)])
[(begin ,e0* ... ,e0) (nanopass-case (L22 Effect) e
(loop (append e0* (cons e0 (cdr e*))) re*)] [(nop) (loop (cdr e*) re*)]
[else (loop (cdr e*) (cons (car e*) re*))]))))])))) [(begin ,e0* ... ,e0)
(loop (append e0* (cons e0 (cdr e*))) re*)]
[else (loop (cdr e*) (cons (car e*) re*))])))))]))))
[(begin ,[e*] ... ,[v]) (build-begin e* v)]) [(begin ,[e*] ... ,[v]) (build-begin e* v)])
(Rhs : Rhs (rhs) -> Rhs () (Rhs : Rhs (rhs) -> Rhs ()
[(primcall ,vpr) [(primcall ,vpr)
@ -3003,23 +3104,25 @@
[(primcall ,vpr ,se* ...) [(primcall ,vpr ,se* ...)
(error who "unexpected value primitive" vpr)]) (error who "unexpected value primitive" vpr)])
(Effect : Effect (e) -> Effect () (Effect : Effect (e) -> Effect ()
#;(definitions (definitions
(define build-begin (define build-begin
(lambda (e* e) (lambda (e* e)
(nanopass-case (L22 Effect) e (nanopass-case (L22 Effect) e
[(begin ,e1* ... ,e) [(begin ,e1* ... ,e)
(build-begin (append e* e1*) e)] (build-begin (append e* e1*) e)]
[else [else
(let loop ([e* e*] [re* '()]) (if (null? e*)
(if (null? e*) e
`(begin ,(reverse re*) ... ,e) (let loop ([e* e*] [re* '()])
(let ([e (car e*)]) (if (null? e*)
(nanopass-case (L22 Effect) e `(begin ,(reverse re*) ... ,e)
[(nop) (loop (cdr e*) re*)] (let ([e (car e*)])
[(begin ,e0* ... ,e0) (nanopass-case (L22 Effect) e
(loop (append e0* (cons e0 (cdr e*))) re*)] [(nop) (loop (cdr e*) re*)]
[else (loop (cdr e*) (cons (car e*) re*))]))))])))) [(begin ,e0* ... ,e0)
#;[(begin ,[e*] ... ,[e]) (build-begin e* e)] (loop (append e0* (cons e0 (cdr e*))) re*)]
[else (loop (cdr e*) (cons (car e*) re*))])))))]))))
[(begin ,[e*] ... ,[e]) (build-begin e* e)]
[(primcall ,epr ,[se0] ,[se1]) [(primcall ,epr ,[se0] ,[se1])
(case epr (case epr
[(set-box!) `(mset! ,se0 #f ,(- box-tag) ,se1)] [(set-box!) `(mset! ,se0 #f ,(- box-tag) ,se1)]
@ -3037,23 +3140,25 @@
[(primcall ,epr ,se* ...) [(primcall ,epr ,se* ...)
(error who "unexpected effect primitive" epr)]) (error who "unexpected effect primitive" epr)])
(Predicate : Predicate (p) -> Predicate () (Predicate : Predicate (p) -> Predicate ()
#;(definitions (definitions
(define build-begin (define build-begin
(lambda (e* p) (lambda (e* p)
(nanopass-case (L22 Predicate) p (nanopass-case (L22 Predicate) p
[(begin ,e1* ... ,p) [(begin ,e1* ... ,p)
(build-begin (append e* e1*) p)] (build-begin (append e* e1*) p)]
[else [else
(let loop ([e* e*] [re* '()]) (if (null? e*)
(if (null? e*) p
`(begin ,(reverse re*) ... ,p) (let loop ([e* e*] [re* '()])
(let ([e (car e*)]) (if (null? e*)
(nanopass-case (L22 Effect) e `(begin ,(reverse re*) ... ,p)
[(nop) (loop (cdr e*) re*)] (let ([e (car e*)])
[(begin ,e0* ... ,e0) (nanopass-case (L22 Effect) e
(loop (append e0* (cons e0 (cdr e*))) re*)] [(nop) (loop (cdr e*) re*)]
[else (loop (cdr e*) (cons (car e*) re*))]))))])))) [(begin ,e0* ... ,e0)
#;[(begin ,[e*] ... ,[p]) (build-begin e* p)] (loop (append e0* (cons e0 (cdr e*))) re*)]
[else (loop (cdr e*) (cons (car e*) re*))])))))]))))
[(begin ,[e*] ... ,[p]) (build-begin e* p)]
[(primcall ,ppr ,[se]) [(primcall ,ppr ,[se])
(case ppr (case ppr
[(pair?) `(= (logand ,se ,pair-mask) ,pair-tag)] [(pair?) `(= (logand ,se ,pair-mask) ,pair-tag)]