summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/tags.h5
-rw-r--r--module/language/cps/compile-rtl.scm9
-rw-r--r--module/language/cps/primitives.scm4
-rw-r--r--module/system/vm/assembler.scm31
-rw-r--r--module/system/vm/disassembler.scm12
5 files changed, 57 insertions, 4 deletions
diff --git a/libguile/tags.h b/libguile/tags.h
index 234d4c77c..9e6943ed0 100644
--- a/libguile/tags.h
+++ b/libguile/tags.h
@@ -3,7 +3,7 @@
#ifndef SCM_TAGS_H
#define SCM_TAGS_H
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011,2012
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2008,2009,2010,2011,2012,2013
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@@ -402,6 +402,9 @@ typedef union SCM { struct { scm_t_bits n; } n; } SCM;
#define SCM_HAS_TYP7(x, tag) (SCM_HAS_HEAP_TYPE (x, SCM_TYP7, tag))
#define SCM_HAS_TYP7S(x, tag) (SCM_HAS_HEAP_TYPE (x, SCM_TYP7S, tag))
+/* If you change these numbers, change them also in (system vm
+ assembler). */
+
#define scm_tc7_symbol 5
#define scm_tc7_variable 7
diff --git a/module/language/cps/compile-rtl.scm b/module/language/cps/compile-rtl.scm
index 74e44b290..b979a6be9 100644
--- a/module/language/cps/compile-rtl.scm
+++ b/module/language/cps/compile-rtl.scm
@@ -274,8 +274,13 @@
(($ $primcall 'pair? (a)) (unary emit-br-if-pair a))
(($ $primcall 'struct? (a)) (unary emit-br-if-struct a))
(($ $primcall 'char? (a)) (unary emit-br-if-char a))
- ;; Add TC7 tests here
- (($ $primcall 'eq? (a b)) (binary emit-br-if-eq a b))
+ (($ $primcall 'symbol? (a)) (unary emit-br-if-symbol a))
+ (($ $primcall 'variable? (a)) (unary emit-br-if-variable a))
+ (($ $primcall 'vector? (a)) (unary emit-br-if-vector a))
+ (($ $primcall 'string? (a)) (unary emit-br-if-string a))
+ ;; Add more TC7 tests here. Keep in sync with
+ ;; *branching-primcall-arities* in (language cps primitives) and
+ ;; the set of macro-instructions in assembly.scm.
(($ $primcall 'eq? (a b)) (binary emit-br-if-eq a b))
(($ $primcall 'eqv? (a b)) (binary emit-br-if-eqv a b))
(($ $primcall 'equal? (a b)) (binary emit-br-if-equal a b))
diff --git a/module/language/cps/primitives.scm b/module/language/cps/primitives.scm
index 1c683e2f3..74ff65c88 100644
--- a/module/language/cps/primitives.scm
+++ b/module/language/cps/primitives.scm
@@ -51,6 +51,10 @@
(nil? . (1 . 1))
(pair? . (1 . 1))
(struct? . (1 . 1))
+ (string? . (1 . 1))
+ (vector? . (1 . 1))
+ (symbol? . (1 . 1))
+ (variable? . (1 . 1))
(char? . (1 . 1))
(eq? . (1 . 2))
(eqv? . (1 . 2))
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index f43acb3c8..749b69383 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -638,6 +638,37 @@ returned instead."
(let ((loc (intern-constant asm (make-static-procedure label))))
(emit-make-non-immediate asm dst loc)))
+(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)))
+
+;; Keep in sync with tags.h. Part of Guile's ABI. Currently unused
+;; macro assemblers are commented out.
+(define-tc7-macro-assembler br-if-symbol 5)
+(define-tc7-macro-assembler br-if-variable 7)
+(define-tc7-macro-assembler br-if-vector 13)
+;(define-tc7-macro-assembler br-if-weak-vector 13)
+(define-tc7-macro-assembler br-if-string 21)
+;(define-tc7-macro-assembler br-if-heap-number 23)
+;(define-tc7-macro-assembler br-if-stringbuf 39)
+;(define-tc7-macro-assembler br-if-bytevector 77)
+;(define-tc7-macro-assembler br-if-pointer 31)
+;(define-tc7-macro-assembler br-if-hashtable 29)
+;(define-tc7-macro-assembler br-if-fluid 37)
+;(define-tc7-macro-assembler br-if-dynamic-state 45)
+;(define-tc7-macro-assembler br-if-frame 47)
+;(define-tc7-macro-assembler br-if-objcode 53)
+;(define-tc7-macro-assembler br-if-vm 55)
+;(define-tc7-macro-assembler br-if-vm-cont 71)
+;(define-tc7-macro-assembler br-if-rtl-program 69)
+;(define-tc7-macro-assembler br-if-program 79)
+;(define-tc7-macro-assembler br-if-weak-set 85)
+;(define-tc7-macro-assembler br-if-weak-table 87)
+;(define-tc7-macro-assembler br-if-array 93)
+;(define-tc7-macro-assembler br-if-bitvector 95)
+;(define-tc7-macro-assembler br-if-port 125)
+;(define-tc7-macro-assembler br-if-smob 127)
+
(define-macro-assembler (begin-program asm label properties)
(emit-label asm label)
(let ((meta (make-meta label properties (asm-start asm))))
diff --git a/module/system/vm/disassembler.scm b/module/system/vm/disassembler.scm
index 09ca337bf..a9209234e 100644
--- a/module/system/vm/disassembler.scm
+++ b/module/system/vm/disassembler.scm
@@ -214,9 +214,19 @@ address of that offset."
(((or 'br
'br-if-nargs-ne 'br-if-nargs-lt 'br-if-nargs-gt
'br-if-true 'br-if-null 'br-if-nil 'br-if-pair 'br-if-struct
- 'br-if-char 'br-if-tc7 'br-if-eq 'br-if-eqv 'br-if-equal
+ 'br-if-char 'br-if-eq 'br-if-eqv 'br-if-equal
'br-if-= 'br-if-< 'br-if-<= 'br-if-> 'br-if->=) _ ... target)
(list "-> ~A" (vector-ref labels (- (+ offset target) start))))
+ (('br-if-tc7 slot invert? tc7 target)
+ (list "~A -> ~A"
+ (let ((tag (case tc7
+ ((5) "symbol?")
+ ((7) "variable?")
+ ((13) "vector?")
+ ((15) "string?")
+ (else (number->string tc7)))))
+ (if invert? (string-append "not " tag) tag))
+ (vector-ref labels (- (+ offset target) start))))
(('prompt tag escape-only? proc-slot handler)
;; The H is for handler.
(list "H -> ~A" (vector-ref labels (- (+ offset handler) start))))