summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2017-10-26 21:08:39 +0200
committerAndy Wingo <wingo@pobox.com>2017-10-29 10:05:24 +0100
commit6dd30920eb74bd0a1575961c40a5ad3531d67442 (patch)
treedb73486c53660edb611405b8b36b825b828ec25f
parent0a9fa88a853f4146777cf4796723456f8d448890 (diff)
downloadguile-6dd30920eb74bd0a1575961c40a5ad3531d67442.tar.gz
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.
-rw-r--r--module/system/vm/assembler.scm54
-rw-r--r--module/system/vm/disassembler.scm60
2 files changed, 65 insertions, 49 deletions
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 221eb2c0f..40f5274cf 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 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