mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-29 16:30:19 +02:00
Code Activity

decompile source info into <glil-source> annotations.

Browse source 
* module/language/glil/decompile-assembly.scm (decompile-load-program):
  Decompile source information into <glil-source> annotations.
This commit is contained in:
Andy Wingo 2009-03-14 16:24:34 +01:00 • committed by Andy Wingo
parent ff33605d6a
commit 06dc937dd7
1 changed files with 26 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

26
module/language/glil/decompile-assembly.scm
View file

@ -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))