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

Fix stack effect/clobber parsing for calls

Browse source 
* module/system/vm/disassembler.scm (define-stack-effect-parser)
  (define-clobber-parser):
* module/system/vm/frame.scm (compute-frame-sizes, compute-killv):
  Fix bug introduced in dd8bf6a98c whereby
  a call would clobber all locals, leaving the backtrace much less
  useful than it should be.
This commit is contained in:
Andy Wingo 2017-12-27 15:00:08 +01:00
parent da7144d93c
commit a5dfbf5d0a
2 changed files with 9 additions and 9 deletions
Download patch file Download diff file Expand all files Collapse all files

12
module/system/vm/disassembler.scm
View file

@ -566,13 +566,13 @@ address of that offset."
(define (stack-effect-parser name) (define (stack-effect-parser name)
(case name (case name
((push) ((push)
#'(lambda (code pos size) (+ size 1))) #'(lambda (code pos size) (and size (+ size 1))))
((pop) ((pop)
#'(lambda (code pos size) (- size 1))) #'(lambda (code pos size) (and size (- size 1))))
((drop) ((drop)
#'(lambda (code pos size) #'(lambda (code pos size)
(let ((count (ash (bytevector-u32-native-ref code pos) -8))) (let ((count (ash (bytevector-u32-native-ref code pos) -8)))
(- size count)))) (and size (- size count)))))
((alloc-frame reset-frame) ((alloc-frame reset-frame)
#'(lambda (code pos size) #'(lambda (code pos size)
(let ((nlocals (ash (bytevector-u32-native-ref code pos) -8))) (let ((nlocals (ash (bytevector-u32-native-ref code pos) -8)))
@ -632,7 +632,7 @@ address of that offset."
(match elt (match elt
((_ proc . _) ((_ proc . _)
(let lp ((slot (- proc 2))) (let lp ((slot (- proc 2)))
(if (< slot nslots-in) (if (and nslots-in (< 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)))
@ -650,7 +650,9 @@ address of that offset."
((X8_F24 X8_F12_F12) ((X8_F24 X8_F12_F12)
#'(list dst)) #'(list dst))
(else (else
#'(list (- nslots-out 1 dst))))))))))) #'(if nslots-out
(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)))))))

6
module/system/vm/frame.scm
View file

@ -126,7 +126,7 @@
(else (error "bad target" target))))))) (else (error "bad target" target)))))))
(when (< n (vector-length parsed)) (when (< n (vector-length parsed))
(let* ((in (vector-ref in-sizes n)) (let* ((in (vector-ref in-sizes n))
(out (and in (instruction-stack-size-after code pos in)))) (out (instruction-stack-size-after code pos in)))
(vector-set! out-sizes n out) (vector-set! out-sizes n out)
(when out (when out
(when (instruction-has-fallthrough? code pos) (when (instruction-has-fallthrough? code pos)
@ -207,9 +207,7 @@
(kill-slot! n slot))) (kill-slot! n slot)))
(let ((in (vector-ref in-sizes n)) (let ((in (vector-ref in-sizes n))
(out (vector-ref out-sizes n))) (out (vector-ref out-sizes n)))
(if out (instruction-slot-clobbers code pos in out)))
(instruction-slot-clobbers code pos in out)
(iota (or in 0)))))
(lp (1+ n) (+ pos (vector-ref parsed n))))) (lp (1+ n) (+ pos (vector-ref parsed n)))))
killv)) killv))