mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-11 22:31:12 +02:00
Add stack size computation to disassembler
* module/system/vm/disassembler.scm (define-stack-effect-parser) (stack-effect-parsers, instruction-stack-size-after): New stack size facility. (define-clobber-parser, clobber-parsers, instruction-slot-clobbers): Take incoming and outgoing stack sizes as arguments to interpret SP-relative clobbers. * module/system/vm/frame.scm (compute-frame-sizes): New helper that computes frame sizes for each position in a function. (compute-killv): Adapt to compute the clobbered set given the computed frame sizes.
This commit is contained in:
parent
4afb46f859
commit
f03960412e
2 changed files with 121 additions and 11 deletions
|
@ -39,6 +39,7 @@
|
||||||
instruction-length
|
instruction-length
|
||||||
instruction-has-fallthrough?
|
instruction-has-fallthrough?
|
||||||
instruction-relative-jump-targets
|
instruction-relative-jump-targets
|
||||||
|
instruction-stack-size-after
|
||||||
instruction-slot-clobbers))
|
instruction-slot-clobbers))
|
||||||
|
|
||||||
(define-syntax-rule (u32-ref buf n)
|
(define-syntax-rule (u32-ref buf n)
|
||||||
|
@ -536,15 +537,70 @@ address of that offset."
|
||||||
(let ((opcode (logand (bytevector-u32-native-ref code pos) #xff)))
|
(let ((opcode (logand (bytevector-u32-native-ref code pos) #xff)))
|
||||||
((vector-ref jump-parsers opcode) code pos)))
|
((vector-ref jump-parsers opcode) code pos)))
|
||||||
|
|
||||||
|
(define-syntax define-stack-effect-parser
|
||||||
|
(lambda (x)
|
||||||
|
(define (stack-effect-parser name)
|
||||||
|
(case name
|
||||||
|
((push)
|
||||||
|
#'(lambda (code pos size) (+ size 1)))
|
||||||
|
((pop)
|
||||||
|
#'(lambda (code pos size) (- size 1)))
|
||||||
|
((drop)
|
||||||
|
#'(lambda (code pos size)
|
||||||
|
(let ((count (ash (bytevector-u32-native-ref code pos) -8)))
|
||||||
|
(- size count))))
|
||||||
|
((alloc-frame reset-frame)
|
||||||
|
#'(lambda (code pos size)
|
||||||
|
(let ((nlocals (ash (bytevector-u32-native-ref code pos) -8)))
|
||||||
|
nlocals)))
|
||||||
|
((receive)
|
||||||
|
#'(lambda (code pos size)
|
||||||
|
(let ((nlocals (ash (bytevector-u32-native-ref code (+ pos 4))
|
||||||
|
-8)))
|
||||||
|
nlocals)))
|
||||||
|
((bind-kwargs)
|
||||||
|
#'(lambda (code pos size)
|
||||||
|
(let ((ntotal (ash (bytevector-u32-native-ref code (+ pos 8)) -8)))
|
||||||
|
ntotal)))
|
||||||
|
((bind-rest)
|
||||||
|
#'(lambda (code pos size)
|
||||||
|
(let ((dst (ash (bytevector-u32-native-ref code pos) -8)))
|
||||||
|
(+ dst 1))))
|
||||||
|
((assert-nargs-ee/locals)
|
||||||
|
#'(lambda (code pos size)
|
||||||
|
(let ((nargs (logand (ash (bytevector-u32-native-ref code pos) -8)
|
||||||
|
#xfff))
|
||||||
|
(nlocals (ash (bytevector-u32-native-ref code pos) -20)))
|
||||||
|
(+ nargs nlocals))))
|
||||||
|
((call call-label)
|
||||||
|
#'(lambda (code pos size) #f))
|
||||||
|
((tail-call tail-call-label tail-call/shuffle tail-apply)
|
||||||
|
#'(lambda (code pos size) #f))
|
||||||
|
(else
|
||||||
|
#f)))
|
||||||
|
(syntax-case x ()
|
||||||
|
((_ name opcode kind word0 word* ...)
|
||||||
|
(let ((parser (stack-effect-parser (syntax->datum #'name))))
|
||||||
|
(if parser
|
||||||
|
#`(vector-set! stack-effect-parsers opcode #,parser)
|
||||||
|
#'(begin)))))))
|
||||||
|
|
||||||
|
(define stack-effect-parsers (make-vector 256 (lambda (code pos size) size)))
|
||||||
|
(visit-opcodes define-stack-effect-parser)
|
||||||
|
|
||||||
|
(define (instruction-stack-size-after code pos size)
|
||||||
|
(let ((opcode (logand (bytevector-u32-native-ref code pos) #xff)))
|
||||||
|
((vector-ref stack-effect-parsers opcode) code pos size)))
|
||||||
|
|
||||||
(define-syntax define-clobber-parser
|
(define-syntax define-clobber-parser
|
||||||
(lambda (x)
|
(lambda (x)
|
||||||
(syntax-case x ()
|
(syntax-case x ()
|
||||||
((_ name opcode kind arg ...)
|
((_ name opcode kind arg0 arg* ...)
|
||||||
(case (syntax->datum #'kind)
|
(case (syntax->datum #'kind)
|
||||||
((!)
|
((!)
|
||||||
(case (syntax->datum #'name)
|
(case (syntax->datum #'name)
|
||||||
((call call-label)
|
((call call-label)
|
||||||
#'(let ((parse (lambda (code pos nslots)
|
#'(let ((parse (lambda (code pos nslots-in nslots-out)
|
||||||
(call-with-values
|
(call-with-values
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(disassemble-one code (/ pos 4)))
|
(disassemble-one code (/ pos 4)))
|
||||||
|
@ -552,26 +608,32 @@ address of that offset."
|
||||||
(match elt
|
(match elt
|
||||||
((_ proc . _)
|
((_ proc . _)
|
||||||
(let lp ((slot (- proc 2)))
|
(let lp ((slot (- proc 2)))
|
||||||
(if (< slot nslots)
|
(if (< slot nslots-in)
|
||||||
(cons slot (lp (1+ slot)))
|
(cons slot (lp (1+ slot)))
|
||||||
'())))))))))
|
'())))))))))
|
||||||
(vector-set! clobber-parsers opcode parse)))
|
(vector-set! clobber-parsers opcode parse)))
|
||||||
(else
|
(else
|
||||||
#'(begin))))
|
#'(begin))))
|
||||||
((<-)
|
((<-)
|
||||||
#'(let ((parse (lambda (code pos nslots)
|
#`(let ((parse (lambda (code pos nslots-in nslots-out)
|
||||||
(call-with-values
|
(call-with-values
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(disassemble-one code (/ pos 4)))
|
(disassemble-one code (/ pos 4)))
|
||||||
(lambda (len elt)
|
(lambda (len elt)
|
||||||
(match elt
|
(match elt
|
||||||
((_ dst . _) (list dst))))))))
|
((_ dst . _)
|
||||||
|
#,(case (syntax->datum #'arg0)
|
||||||
|
((X8_F24 X8_F12_F12)
|
||||||
|
#'(list dst))
|
||||||
|
(else
|
||||||
|
#'(list (- nslots-out 1 dst)))))))))))
|
||||||
(vector-set! clobber-parsers opcode parse)))
|
(vector-set! clobber-parsers opcode parse)))
|
||||||
(else (error "unexpected instruction kind" #'kind)))))))
|
(else (error "unexpected instruction kind" #'kind)))))))
|
||||||
|
|
||||||
(define clobber-parsers (make-vector 256 (lambda (code pos nslots) '())))
|
(define clobber-parsers
|
||||||
|
(make-vector 256 (lambda (code pos nslots-in nslots-out) '())))
|
||||||
(visit-opcodes define-clobber-parser)
|
(visit-opcodes define-clobber-parser)
|
||||||
|
|
||||||
(define (instruction-slot-clobbers code pos nslots)
|
(define (instruction-slot-clobbers code pos nslots-in nslots-out)
|
||||||
(let ((opcode (logand (bytevector-u32-native-ref code pos) #xff)))
|
(let ((opcode (logand (bytevector-u32-native-ref code pos) #xff)))
|
||||||
((vector-ref clobber-parsers opcode) code pos nslots)))
|
((vector-ref clobber-parsers opcode) code pos nslots-in nslots-out)))
|
||||||
|
|
|
@ -25,6 +25,7 @@
|
||||||
#:use-module (system vm debug)
|
#:use-module (system vm debug)
|
||||||
#:use-module (system vm disassembler)
|
#:use-module (system vm disassembler)
|
||||||
#:use-module (srfi srfi-9)
|
#:use-module (srfi srfi-9)
|
||||||
|
#:use-module (srfi srfi-11)
|
||||||
#:use-module (rnrs bytevectors)
|
#:use-module (rnrs bytevectors)
|
||||||
#:use-module (ice-9 match)
|
#:use-module (ice-9 match)
|
||||||
#:export (binding-index
|
#:export (binding-index
|
||||||
|
@ -83,6 +84,49 @@
|
||||||
(lp (1+ n) (+ pos (vector-ref parsed n)))))
|
(lp (1+ n) (+ pos (vector-ref parsed n)))))
|
||||||
preds))
|
preds))
|
||||||
|
|
||||||
|
(define (compute-frame-sizes code parsed initial-size)
|
||||||
|
(let ((in-sizes (make-vector (vector-length parsed) #f))
|
||||||
|
(out-sizes (make-vector (vector-length parsed) #f)))
|
||||||
|
;; This only computes all possible valid stack sizes if the bytecode
|
||||||
|
;; is sorted topologically. Guiles' compiler does this currently,
|
||||||
|
;; but if that changes we should do a proper pre-order visit. Of
|
||||||
|
;; course the bytecode has to be valid too.
|
||||||
|
(define (find-idx n diff)
|
||||||
|
(let lp ((n n) (diff diff))
|
||||||
|
(cond
|
||||||
|
((negative? diff)
|
||||||
|
(lp (1- n) (+ diff (vector-ref parsed (1- n)))))
|
||||||
|
((positive? diff)
|
||||||
|
(lp (1+ n) (- diff (vector-ref parsed n))))
|
||||||
|
(else n))))
|
||||||
|
(vector-set! in-sizes 0 initial-size)
|
||||||
|
(let lp ((n 0) (pos 0))
|
||||||
|
(define (offset->idx target)
|
||||||
|
(call-with-values (lambda ()
|
||||||
|
(if (>= target pos)
|
||||||
|
(values n pos)
|
||||||
|
(values 0 0)))
|
||||||
|
(lambda (n pos)
|
||||||
|
(let lp ((n n) (pos pos))
|
||||||
|
(cond
|
||||||
|
((= pos target) n)
|
||||||
|
((< pos target) (lp (1+ n) (+ pos (vector-ref parsed n))))
|
||||||
|
(else (error "bad target" target)))))))
|
||||||
|
(when (< n (vector-length parsed))
|
||||||
|
(let* ((in (vector-ref in-sizes n))
|
||||||
|
(out (instruction-stack-size-after code pos in)))
|
||||||
|
(vector-set! out-sizes n out)
|
||||||
|
(when out
|
||||||
|
(when (instruction-has-fallthrough? code pos)
|
||||||
|
(vector-set! in-sizes (1+ n) out))
|
||||||
|
(for-each (lambda (target)
|
||||||
|
(let ((idx (find-idx n target)))
|
||||||
|
(when idx
|
||||||
|
(vector-set! in-sizes idx out))))
|
||||||
|
(instruction-relative-jump-targets code pos))))
|
||||||
|
(lp (1+ n) (+ pos (vector-ref parsed n)))))
|
||||||
|
(values in-sizes out-sizes)))
|
||||||
|
|
||||||
(define (compute-genv parsed defs)
|
(define (compute-genv parsed defs)
|
||||||
(let ((genv (make-vector (vector-length parsed) '())))
|
(let ((genv (make-vector (vector-length parsed) '())))
|
||||||
(define (add-def! pos var)
|
(define (add-def! pos var)
|
||||||
|
@ -118,8 +162,11 @@
|
||||||
by-slot))
|
by-slot))
|
||||||
|
|
||||||
(define (compute-killv code parsed defs)
|
(define (compute-killv code parsed defs)
|
||||||
(let ((defs-by-slot (compute-defs-by-slot defs))
|
(let*-values (((defs-by-slot) (compute-defs-by-slot defs))
|
||||||
(killv (make-vector (vector-length parsed) #f)))
|
((initial-frame-size) (vector-length defs-by-slot))
|
||||||
|
((in-sizes out-sizes)
|
||||||
|
(compute-frame-sizes code parsed initial-frame-size))
|
||||||
|
((killv) (make-vector (vector-length parsed) #f)))
|
||||||
(define (kill-slot! n slot)
|
(define (kill-slot! n slot)
|
||||||
(bit-set*! (vector-ref killv n) (vector-ref defs-by-slot slot) #t))
|
(bit-set*! (vector-ref killv n) (vector-ref defs-by-slot slot) #t))
|
||||||
(let lp ((n 0))
|
(let lp ((n 0))
|
||||||
|
@ -147,7 +194,8 @@
|
||||||
(when (< slot (vector-length defs-by-slot))
|
(when (< slot (vector-length defs-by-slot))
|
||||||
(kill-slot! n slot)))
|
(kill-slot! n slot)))
|
||||||
(instruction-slot-clobbers code pos
|
(instruction-slot-clobbers code pos
|
||||||
(vector-length defs-by-slot)))
|
(vector-ref in-sizes n)
|
||||||
|
(vector-ref out-sizes n)))
|
||||||
(lp (1+ n) (+ pos (vector-ref parsed n)))))
|
(lp (1+ n) (+ pos (vector-ref parsed n)))))
|
||||||
killv))
|
killv))
|
||||||
|
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue