diff options
author | Andy Wingo <wingo@pobox.com> | 2009-05-17 16:46:46 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2009-05-17 16:46:46 +0200 |
commit | 2ce77f2d95271887b54d0c56d1e81d7f472ae1ae (patch) | |
tree | 2f006f38fae2759af204bcb69b93183e6b0079ab | |
parent | 696495f4d21fc8bc479b50588c08ea55e7c6e3a7 (diff) | |
download | guile-2ce77f2d95271887b54d0c56d1e81d7f472ae1ae.tar.gz |
and now, we residualize the original names into the metadata. yay!
* module/language/tree-il/compile-glil.scm (vars->bind-list)
(emit-bindings, flatten-lambda, flatten): Write the original names into
<glil-bind> structures. Yaaaaay!
-rw-r--r-- | module/language/tree-il/compile-glil.scm | 41 |
1 files changed, 24 insertions, 17 deletions
diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm index 75d3f9603..29a9ee976 100644 --- a/module/language/tree-il/compile-glil.scm +++ b/module/language/tree-il/compile-glil.scm @@ -44,18 +44,20 @@ (define (make-label) (gensym ":L")) -(define (vars->bind-list vars allocation) - (map (lambda (v) +(define (vars->bind-list ids vars allocation) + (map (lambda (id v) (let ((loc (hashq-ref allocation v))) (case (car loc) - ((stack) (list v 'local (cdr loc))) - ((heap) (list v 'external (cddr loc))) - (else (error "badness" v loc))))) + ((stack) (list id 'local (cdr loc))) + ((heap) (list id 'external (cddr loc))) + (else (error "badness" id v loc))))) + ids vars)) -(define (emit-bindings src vars allocation emit-code) +(define (emit-bindings src ids vars allocation emit-code) (if (pair? vars) - (emit-code src (make-glil-bind (vars->bind-list vars allocation))))) + (emit-code src (make-glil-bind + (vars->bind-list ids vars allocation))))) (define (with-output-to-code proc) (let ((out '())) @@ -67,11 +69,16 @@ (reverse out))) (define (flatten-lambda x level allocation) - (receive (vars nargs nrest) - (let lp ((vars (lambda-vars x)) (out '()) (n 0)) - (cond ((null? vars) (values (reverse out) n 0)) - ((pair? vars) (lp (cdr vars) (cons (car vars) out) (1+ n))) - (else (values (reverse (cons vars out)) (1+ n) 1)))) + (receive (ids vars nargs nrest) + (let lp ((ids (lambda-names x)) (vars (lambda-vars x)) + (oids '()) (ovars '()) (n 0)) + (cond ((null? vars) (values (reverse oids) (reverse ovars) n 0)) + ((pair? vars) (lp (cdr ids) (cdr vars) + (cons (car ids) oids) (cons (car vars) ovars) + (1+ n))) + (else (values (reverse (cons ids oids)) + (reverse (cons vars ovars)) + (1+ n) 1)))) (let ((nlocs (car (hashq-ref allocation x))) (nexts (cdr (hashq-ref allocation x)))) (make-glil-program @@ -79,7 +86,7 @@ (with-output-to-code (lambda (emit-code) ;; write bindings and source debugging info - (emit-bindings #f vars allocation emit-code) + (emit-bindings #f ids vars allocation emit-code) (if (lambda-src x) (emit-code (make-glil-src (lambda-src x)))) @@ -246,9 +253,9 @@ (emit-code #f (flatten-lambda x level allocation)) (emit-code #f (make-glil-call 'return 1))))) - ((<let> src vars vals exp) + ((<let> src names vars vals exp) (for-each comp-push vals) - (emit-bindings src vars allocation emit-code) + (emit-bindings src names vars allocation emit-code) (for-each (lambda (v) (let ((loc (hashq-ref allocation v))) (case (car loc) @@ -261,9 +268,9 @@ (comp-tail exp) (emit-code #f (make-glil-unbind))) - ((<letrec> src vars vals exp) + ((<letrec> src names vars vals exp) (for-each comp-push vals) - (emit-bindings src vars allocation emit-code) + (emit-bindings src names vars allocation emit-code) (for-each (lambda (v) (let ((loc (hashq-ref allocation v))) (case (car loc) |