diff options
author | Andy Wingo <wingo@pobox.com> | 2017-10-26 21:08:39 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2017-10-29 10:05:24 +0100 |
commit | 6dd30920eb74bd0a1575961c40a5ad3531d67442 (patch) | |
tree | db73486c53660edb611405b8b36b825b828ec25f | |
parent | 0a9fa88a853f4146777cf4796723456f8d448890 (diff) | |
download | guile-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.scm | 54 | ||||
-rw-r--r-- | 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 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 |