summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2009-03-14 16:24:34 +0100
committerAndy Wingo <wingo@oblong.net>2009-03-17 16:47:43 +0100
commit06dc937dd7575c820d8a0884978d0c22de4946fc (patch)
tree127b3d14f6d226e53e0caf4028e932a7996ed30a
parentff33605d6a5046019562661857e2ea2d41c54f3c (diff)
downloadguile-06dc937dd7575c820d8a0884978d0c22de4946fc.tar.gz
decompile source info into <glil-source> annotations.
* module/language/glil/decompile-assembly.scm (decompile-load-program): Decompile source information into <glil-source> annotations.
-rw-r--r--module/language/glil/decompile-assembly.scm26
1 files changed, 26 insertions, 0 deletions
diff --git a/module/language/glil/decompile-assembly.scm b/module/language/glil/decompile-assembly.scm
index 7b1d591eb..a98c39975 100644
--- a/module/language/glil/decompile-assembly.scm
+++ b/module/language/glil/decompile-assembly.scm
@@ -68,6 +68,7 @@
(unbindings (sort (if meta (car meta) '())
(lambda (x y) (< (binding:end x) (binding:end y)))))
(sources (if meta (cadr meta) '()))
+ (filename #f)
(props (if meta (cddr meta) '())))
(define (pop-bindings! addr)
(let lp ((in bindings) (out '()))
@@ -83,6 +84,19 @@
(set! unbindings in)
(if (null? out) #f (reverse out)))
(lp (cdr in) (cons (car in) out)))))
+ (define (pop-source! addr)
+ ;; a fragile algorithm.
+ (cond ((null? sources) #f)
+ ((eq? (caar sources) 'filename)
+ (set! filename (cdar sources))
+ (pop-source! addr))
+ ((eqv? (caar sources) addr)
+ (let ((x (car sources)))
+ (set! sources (cdr sources))
+ `((filename . ,filename)
+ (line . ,(cadr x))
+ (column . ,(cddr x)))))
+ (else #f)))
(let lp ((in body) (stack '()) (out '()) (pos 0))
(cond
((null? in)
@@ -105,6 +119,9 @@
((pop-unbindings! pos)
=> (lambda (bindings)
(lp in stack (cons (make-glil-unbind) out) pos)))
+ ((pop-source! pos)
+ => (lambda (s)
+ (lp in stack (cons (make-glil-source s) out) pos)))
((and (or (null? out) (not (glil-label? (car out))))
(assv-ref glil-labels pos))
=> (lambda (label)
@@ -131,6 +148,15 @@
(lp (cdr in) (cons 1 stack) out (1+ pos)))
((make-int8 ,n)
(lp (cdr in) (cons n stack) out (+ pos 2)))
+ ((cons)
+ (let ((head (list-head stack 2))
+ (stack (list-tail stack 2)))
+ (if (memq *placeholder* head)
+ (lp (cdr in) (cons *placeholder* stack)
+ (cons (make-glil-call 'cons 2) (emit-constants head out))
+ (+ pos 1))
+ (lp (cdr in) (cons (cons (cadr head) (car head)) stack)
+ out (+ pos 3)))))
((list ,a ,b)
(let* ((len (+ (ash a 8) b))
(head (list-head stack len))