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.

1 files changed, 11 insertions, 49 deletions

diff --git a/module/system/vm/disassembler.scm b/module/system/vm/disassembler.scm
index 16208f190..9c34594b6 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