diff options
author | Andy Wingo <wingo@pobox.com> | 2015-10-21 15:02:28 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2015-10-21 15:02:28 +0200 |
commit | f03960412ebf3ac40686a79b8ed5ebf7c6e49b18 (patch) | |
tree | b2067775d68c638a698241ed95df1bbd4bb77cdb | |
parent | 4afb46f8599854dd36af25576ec4b7ab1c39745f (diff) | |
download | guile-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.
-rw-r--r-- | module/system/vm/disassembler.scm | 78 | ||||
-rw-r--r-- | module/system/vm/frame.scm | 54 |
2 files changed, 121 insertions, 11 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))) diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm index b84f6683e..7f0211da8 100644 --- a/module/system/vm/frame.scm +++ b/module/system/vm/frame.scm @@ -25,6 +25,7 @@ #:use-module (system vm debug) #:use-module (system vm disassembler) #:use-module (srfi srfi-9) + #:use-module (srfi srfi-11) #:use-module (rnrs bytevectors) #:use-module (ice-9 match) #:export (binding-index @@ -83,6 +84,49 @@ (lp (1+ n) (+ pos (vector-ref parsed n))))) 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) (let ((genv (make-vector (vector-length parsed) '()))) (define (add-def! pos var) @@ -118,8 +162,11 @@ by-slot)) (define (compute-killv code parsed defs) - (let ((defs-by-slot (compute-defs-by-slot defs)) - (killv (make-vector (vector-length parsed) #f))) + (let*-values (((defs-by-slot) (compute-defs-by-slot defs)) + ((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) (bit-set*! (vector-ref killv n) (vector-ref defs-by-slot slot) #t)) (let lp ((n 0)) @@ -147,7 +194,8 @@ (when (< slot (vector-length defs-by-slot)) (kill-slot! n slot))) (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))))) killv)) |