summaryrefslogtreecommitdiff
path: root/module/system/vm/disassembler.scm
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2015-10-21 15:02:28 +0200
committerAndy Wingo <wingo@pobox.com>2015-10-21 15:02:28 +0200
commitf03960412ebf3ac40686a79b8ed5ebf7c6e49b18 (patch)
treeb2067775d68c638a698241ed95df1bbd4bb77cdb /module/system/vm/disassembler.scm
parent4afb46f8599854dd36af25576ec4b7ab1c39745f (diff)
downloadguile-f03960412ebf3ac40686a79b8ed5ebf7c6e49b18.tar.gz
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.
Diffstat (limited to 'module/system/vm/disassembler.scm')
-rw-r--r--module/system/vm/disassembler.scm78
1 files changed, 70 insertions, 8 deletions
diff --git a/module/system/vm/disassembler.scm b/module/system/vm/disassembler.scm
index c1a8ce700..b76433ba5 100644
--- a/module/system/vm/disassembler.scm
+++ b/module/system/vm/disassembler.scm
@@ -39,6 +39,7 @@
instruction-length
instruction-has-fallthrough?
instruction-relative-jump-targets
+ instruction-stack-size-after
instruction-slot-clobbers))
(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)))
((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
(lambda (x)
(syntax-case x ()
- ((_ name opcode kind arg ...)
+ ((_ name opcode kind arg0 arg* ...)
(case (syntax->datum #'kind)
((!)
(case (syntax->datum #'name)
((call call-label)
- #'(let ((parse (lambda (code pos nslots)
+ #'(let ((parse (lambda (code pos nslots-in nslots-out)
(call-with-values
(lambda ()
(disassemble-one code (/ pos 4)))
@@ -552,26 +608,32 @@ address of that offset."
(match elt
((_ proc . _)
(let lp ((slot (- proc 2)))
- (if (< slot nslots)
+ (if (< slot nslots-in)
(cons slot (lp (1+ slot)))
'())))))))))
(vector-set! clobber-parsers opcode parse)))
(else
#'(begin))))
((<-)
- #'(let ((parse (lambda (code pos nslots)
+ #`(let ((parse (lambda (code pos nslots-in nslots-out)
(call-with-values
(lambda ()
(disassemble-one code (/ pos 4)))
(lambda (len 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)))
(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)
-(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)))
- ((vector-ref clobber-parsers opcode) code pos nslots)))
+ ((vector-ref clobber-parsers opcode) code pos nslots-in nslots-out)))