[Guile-commits] 04/07: Add assembler and disassembler support for new instructions

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 258c59b4cc227baef26bc9f2aeb8a6c2f40e6327
Author: Andy Wingo <address@hidden>
Date:   Wed Oct 25 12:32:12 2017 +0200

    Add assembler and disassembler support for new instructions
    
    * module/system/vm/assembler.scm: Export assemblers for the new
      instructions.
    * module/system/vm/disassembler.scm (immediate-tag-annotations)
      (heap-tag-annotations, code-annotation): Add support for disassembling
      the new instructions, with good annotations.
      (compute-labels, instruction-has-fallthrough?, define-jump-parser):
      Add support for new branching instructions.
---
 module/system/vm/assembler.scm    | 21 +++++++++++++
 module/system/vm/disassembler.scm | 65 +++++++++++++++++++++++++++++++++++++--
 2 files changed, 83 insertions(+), 3 deletions(-)

diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 89b7407..221eb2c 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -63,6 +63,27 @@
             (emit-mov* . emit-mov)
             (emit-fmov* . emit-fmov)
 
+            emit-u64=?
+            emit-u64<?
+            emit-s64=?
+            emit-s64<?
+            emit-f64=?
+            emit-f64<?
+            emit-=?
+            emit-<?
+            emit-arguments<=?
+            emit-positional-arguments<=?
+            emit-immediate-tag=?
+            emit-heap-tag=?
+            emit-eq?
+            emit-j
+            emit-jl
+            emit-je
+            emit-jnl
+            emit-jne
+            emit-jge
+            emit-jnge
+
             emit-call
             emit-call-label
             emit-tail-call
diff --git a/module/system/vm/disassembler.scm 
b/module/system/vm/disassembler.scm
index 0ab8c6b..8ffa6bc 100644
--- a/module/system/vm/disassembler.scm
+++ b/module/system/vm/disassembler.scm
@@ -24,6 +24,7 @@
   #:use-module (system vm debug)
   #:use-module (system vm program)
   #:use-module (system vm loader)
+  #:use-module (system base types internal)
   #:use-module (system foreign)
   #:use-module (rnrs bytevectors)
   #:use-module (ice-9 format)
@@ -180,6 +181,56 @@
 address of that offset."
   (+ (debug-context-base context) (* offset 4)))
 
+(define immediate-tag-annotations
+  (let ()
+    (define (common-bits a b)
+      (list (lognot (logxor a b)) (logand a b)))
+    `((#b11 ,%tc2-inum "inum?")
+      (#b111 ,%tc3-heap-object "heap-object?")
+      (#xff ,%tc8-char "char?")
+      (#xffff ,%tc16-nil "eq? #nil")
+      (#xffff ,%tc16-eol "eq? '()")
+      (#xffff ,%tc16-false "eq? #f")
+      (#xffff ,%tc16-true "eq? #t")
+      (#xffff ,%tc16-unspecified "unspecified?")
+      (#xffff ,%tc16-undefined "undefined?")
+      (#xffff ,%tc16-eof "eof-object?")
+      ;; See discussions in boolean.h.
+      (,@(common-bits %tc16-eol %tc16-nil) "null?")
+      (,@(common-bits %tc16-false %tc16-nil) "false?")
+      (,@(common-bits %tc16-false %tc16-eol) "nil?"))))
+
+(define heap-tag-annotations
+  `((#b1 ,%tc1-pair "pair?")
+    (#b111 ,%tc3-struct "struct?")
+    (#xff ,%tc7-symbol "symbol?")
+    (#xff ,%tc7-variable "variable?")
+    (#xff ,%tc7-vector "vector?")
+    (#xff ,%tc7-wvect "weak-vector?")
+    (#xff ,%tc7-string "string?")
+    (#xff ,%tc7-number "number?")
+    (#xff ,%tc7-hashtable "hash-table?")
+    (#xff ,%tc7-pointer "pointer?")
+    (#xff ,%tc7-fluid "fluid?")
+    (#xff ,%tc7-stringbuf "stringbuf?")
+    (#xff ,%tc7-dynamic-state "dynamic-state?")
+    (#xff ,%tc7-frame "frame?")
+    (#xff ,%tc7-keyword "keyword?")
+    (#xff ,%tc7-syntax "syntax?")
+    (#xff ,%tc7-program "program?")
+    (#xff ,%tc7-vm-continuation "vm-continuation?")
+    (#xff ,%tc7-bytevector "bytevector?")
+    (#xff ,%tc7-weak-set "weak-set?")
+    (#xff ,%tc7-weak-table "weak-table?")
+    (#xff ,%tc7-array "array?")
+    (#xff ,%tc7-bitvector "bitvector?")
+    (#xff ,%tc7-port "port?")
+    (#xff ,%tc7-smob "smob?")
+    (#xffff ,%tc16-bignum "bignum?")
+    (#xffff ,%tc16-real "flonum?")
+    (#xffff ,%tc16-complex "complex?")
+    (#xffff ,%tc16-fraction "fraction?")))
+
 (define (code-annotation code len offset start labels context push-addr!)
   ;; FIXME: Print names for register loads and stores that correspond to
   ;; access to named locals.
@@ -205,6 +256,12 @@ address of that offset."
           '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)
+     (list "-> ~A" (vector-ref labels (- (+ offset target) start))))
+    (('immediate-tag=? _ mask tag)
+     (assoc-ref immediate-tag-annotations (list mask tag)))
+    (('heap-tag=? _ mask tag)
+     (assoc-ref heap-tag-annotations (list mask tag)))
     (('br-if-tc7 slot invert? tc7 target)
      (list "~A -> ~A"
            (let ((tag (case tc7
@@ -308,7 +365,8 @@ address of that offset."
                    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)
+                   br-if-u64->-scm br-if-u64->=-scm
+                   j je jl jge jne jnl jnge)
                   (match arg
                     ((_ ... target)
                      (add-label! (+ offset target) "L"))))
@@ -529,7 +587,8 @@ address of that offset."
                        return-values
                        subr-call foreign-call continuation-call
                        tail-apply
-                       br))
+                       br
+                       j))
   (let ((opcode (logand (bytevector-u32-native-ref code pos) #xff)))
     (not (bitvector-ref non-fallthrough-set opcode))))
 
@@ -538,7 +597,7 @@ address of that offset."
     (syntax-case x ()
       ((_ name opcode kind word0 word* ...)
        (let ((symname (syntax->datum #'name)))
-         (if (or (memq symname '(br prompt))
+         (if (or (memq symname '(br prompt j je jl jge jne jnl jnge))
                  (string-prefix? "br-" (symbol->string symname)))
              (let ((offset (* 4 (length #'(word* ...)))))
                #`(vector-set!