[Guile-commits] 02/11: Use tag visitors to generate assemblers, disassembly annotations

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 6dd30920eb74bd0a1575961c40a5ad3531d67442
Author: Andy Wingo <address@hidden>
Date:   Thu Oct 26 21:08:39 2017 +0200

    Use tag visitors to generate assemblers, disassembly annotations
    
    * module/system/vm/disassembler.scm (immediate-tag-annotations)
      (heap-tag-annotations): Generate using tag visitors.
    * module/system/vm/assembler.scm
      (define-immediate-tag=?-macro-assembler)
      (define-heap-tag=?-macro-assembler): New helpers.  Use these to
      generate immediate-tag=? and heap-tag=? macro assemblers.
---
 module/system/vm/assembler.scm    | 54 +++++++++++++++++++++++++++++++++++
 module/system/vm/disassembler.scm | 60 +++++++--------------------------------
 2 files changed, 65 insertions(+), 49 deletions(-)

diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 221eb2c..40f5274 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -44,6 +44,7 @@
 
 (define-module (system vm assembler)
   #:use-module (system base target)
+  #:use-module (system base types internal)
   #:use-module (system vm dwarf)
   #:use-module (system vm elf)
   #:use-module (system vm linker)
@@ -84,6 +85,47 @@
             emit-jge
             emit-jnge
 
+            emit-inum?
+            emit-heap-object?
+            emit-char?
+            emit-eq-null?
+            emit-eq-nil?
+            emit-eq-false?
+            emit-eq-true?
+            emit-unspecified?
+            emit-undefined?
+            emit-eof-object?
+
+            emit-pair?
+            emit-struct?
+            emit-symbol?
+            emit-variable?
+            emit-vector?
+            emit-weak-vector?
+            emit-string?
+            emit-number?
+            emit-hash-table?
+            emit-pointer?
+            emit-fluid?
+            emit-stringbuf?
+            emit-dynamic-state?
+            emit-frame?
+            emit-keyword?
+            emit-syntax?
+            emit-program?
+            emit-vm-continuation?
+            emit-bytevector?
+            emit-weak-set?
+            emit-weak-table?
+            emit-array?
+            emit-bitvector?
+            emit-port?
+            emit-smob?
+            emit-bignum?
+            emit-flonum?
+            emit-complex?
+            emit-fraction?
+
             emit-call
             emit-call-label
             emit-tail-call
@@ -1190,6 +1232,18 @@ returned instead."
   (let ((loc (intern-constant asm (make-static-procedure label))))
     (emit-make-non-immediate asm dst loc)))
 
+(define-syntax-rule (define-immediate-tag=?-macro-assembler name pred mask tag)
+  (define-macro-assembler (pred asm slot)
+    (emit-immediate-tag=? asm slot mask tag)))
+
+(visit-immediate-tags define-immediate-tag=?-macro-assembler)
+
+(define-syntax-rule (define-heap-tag=?-macro-assembler name pred mask tag)
+  (define-macro-assembler (pred asm slot)
+    (emit-heap-tag=? asm slot mask tag)))
+
+(visit-heap-tags define-heap-tag=?-macro-assembler)
+
 (define-syntax-rule (define-tc7-macro-assembler name tc7)
   (define-macro-assembler (name asm slot invert? label)
     (emit-br-if-tc7 asm slot invert? tc7 label)))
diff --git a/module/system/vm/disassembler.scm 
b/module/system/vm/disassembler.scm
index 16208f1..9c34594 100644
--- a/module/system/vm/disassembler.scm
+++ b/module/system/vm/disassembler.scm
@@ -181,55 +181,17 @@
 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-fixnum "fixnum?")
-      (#b111 ,%tc3-heap-object "heap-object?")
-      (#xff ,%tc8-char "char?")
-      (#xffff ,%tc16-nil "eq? #nil")
-      (#xffff ,%tc16-null "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-null %tc16-nil) "null?")
-      (,@(common-bits %tc16-false %tc16-nil) "false?")
-      (,@(common-bits %tc16-false %tc16-null) "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-weak-vector "weak-vector?")
-    (#xff ,%tc7-string "string?")
-    (#xff ,%tc7-number "number?")
-    (#xff ,%tc7-hash-table "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-flonum "flonum?")
-    (#xffff ,%tc16-complex "complex?")
-    (#xffff ,%tc16-fraction "fraction?")))
+(define immediate-tag-annotations '())
+(define-syntax-rule (define-immediate-tag-annotation name pred mask tag)
+  (set! immediate-tag-annotations
+        (cons `((,mask ,tag) ,(symbol->string 'pred)) 
immediate-tag-annotations)))
+(visit-immediate-tags define-immediate-tag-annotation)
+
+(define heap-tag-annotations '())
+(define-syntax-rule (define-heap-tag-annotation name pred mask tag)
+  (set! heap-tag-annotations
+        (cons `((,mask ,tag) ,(symbol->string 'pred)) heap-tag-annotations)))
+(visit-heap-tags define-heap-tag-annotation)
 
 (define (code-annotation code len offset start labels context push-addr!)
   ;; FIXME: Print names for register loads and stores that correspond to