mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-12 06:41:13 +02:00
Code Activity

Remove disassembler support for old-style jump instructions

Browse source 
* module/system/vm/disassembler.scm (code-annotation, compute-labels)
  (instruction-has-fallthrough?, define-jump-parser): Remove
  disassembler support for old-style jump instructions.
This commit is contained in:
Andy Wingo 2017-10-30 10:43:23 +01:00
parent c92b80be2d
commit 9d62724c08
1 changed files with 2 additions and 38 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -206,38 +206,12 @@ address of that offset."
(dereference-pointer (make-pointer addr))))) (dereference-pointer (make-pointer addr)))))
(match code (match code
(((or 'br
'br-if-nargs-ne 'br-if-nargs-lt 'br-if-nargs-gt
'br-if-true 'br-if-null 'br-if-nil 'br-if-pair 'br-if-struct
'br-if-char 'br-if-eq 'br-if-eqv
'br-if-= 'br-if-< 'br-if-<= 'br-if-> 'br-if->=
'br-if-u64-= 'br-if-u64-< 'br-if-u64-<=
'br-if-u64-<-scm 'br-if-u64-<=-scm 'br-if-u64-=-scm
'br-if-u64->-scm 'br-if-u64->=-scm
'br-if-f64-= 'br-if-f64-< 'br-if-f64-<=
'br-if-f64-> 'br-if-f64->=
'br-if-logtest) _ ... target)
(list "-> ~A" (vector-ref labels (- (+ offset target) start))))
(((or 'j 'je 'jl 'jge 'jne 'jnl 'jnge) target) (((or 'j 'je 'jl 'jge 'jne 'jnl 'jnge) target)
(list "-> ~A" (vector-ref labels (- (+ offset target) start)))) (list "-> ~A" (vector-ref labels (- (+ offset target) start))))
(('immediate-tag=? _ mask tag) (('immediate-tag=? _ mask tag)
(assoc-ref immediate-tag-annotations (list mask tag))) (assoc-ref immediate-tag-annotations (list mask tag)))
(('heap-tag=? _ mask tag) (('heap-tag=? _ mask tag)
(assoc-ref heap-tag-annotations (list mask tag))) (assoc-ref heap-tag-annotations (list mask tag)))
(('br-if-tc7 slot invert? tc7 target)
(list "~A -> ~A"
(let ((tag (case tc7
((5) "symbol?")
((7) "variable?")
((13) "vector?")
((15) "string?")
((53) "keyword?")
((#x3d) "syntax?")
((77) "bytevector?")
((95) "bitvector?")
(else (number->string tc7)))))
(if invert? (string-append "not " tag) tag))
(vector-ref labels (- (+ offset target) start))))
(('prompt tag escape-only? proc-slot handler) (('prompt tag escape-only? proc-slot handler)
;; The H is for handler. ;; The H is for handler.
(list "H -> ~A" (vector-ref labels (- (+ offset handler) start)))) (list "H -> ~A" (vector-ref labels (- (+ offset handler) start))))
@ -320,15 +294,7 @@ address of that offset."
(match elt (match elt
((inst arg ...) ((inst arg ...)
(case inst (case inst
((br ((j je jl jge jne jnl jnge)
br-if-nargs-ne br-if-nargs-lt br-if-nargs-gt
br-if-true br-if-null br-if-nil br-if-pair br-if-struct
br-if-char br-if-tc7 br-if-eq br-if-eqv
br-if-= br-if-< br-if-<= br-if-> br-if->= br-if-logtest
br-if-u64-= br-if-u64-< br-if-u64-<=
br-if-u64-<-scm br-if-u64-<=-scm br-if-u64-=-scm
br-if-u64->-scm br-if-u64->=-scm
j je jl jge jne jnl jnge)
(match arg (match arg
((_ ... target) ((_ ... target)
(add-label! (+ offset target) "L")))) (add-label! (+ offset target) "L"))))
@ -549,7 +515,6 @@ address of that offset."
return-values return-values
subr-call foreign-call continuation-call subr-call foreign-call continuation-call
tail-apply tail-apply
br
j)) j))
(let ((opcode (logand (bytevector-u32-native-ref code pos) #xff))) (let ((opcode (logand (bytevector-u32-native-ref code pos) #xff)))
(not (bitvector-ref non-fallthrough-set opcode)))) (not (bitvector-ref non-fallthrough-set opcode))))
@ -559,8 +524,7 @@ address of that offset."
(syntax-case x () (syntax-case x ()
((_ name opcode kind word0 word* ...) ((_ name opcode kind word0 word* ...)
(let ((symname (syntax->datum #'name))) (let ((symname (syntax->datum #'name)))
(if (or (memq symname '(br prompt j je jl jge jne jnl jnge)) (if (memq symname '(prompt j je jl jge jne jnl jnge))
(string-prefix? "br-" (symbol->string symname)))
(let ((offset (* 4 (length #'(word* ...))))) (let ((offset (* 4 (length #'(word* ...)))))
#`(vector-set! #`(vector-set!
jump-parsers jump-parsers