mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-28 16:00:22 +02:00
decompile source info into <glil-source> annotations.
* module/language/glil/decompile-assembly.scm (decompile-load-program): Decompile source information into <glil-source> annotations.
This commit is contained in:
parent
ff33605d6a
commit
06dc937dd7
1 changed files with 26 additions and 0 deletions
|
@ -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))
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue