RTL compiler: Compile TC7 branches.

* module/system/vm/assembler.scm:
* module/system/vm/disassembler.scm (code-annotation):
* module/language/cps/primitives.scm (*branching-primcall-arities*):
* module/language/cps/compile-rtl.scm (emit-rtl-sequence): Add support
  for compiling symbol?, variable?, vector?, and string? branches.

diff --git a/libguile/tags.h b/libguile/tags.h
index 234d4c7..9e6943e 100644 (file)
--- 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 74e44b2..b979a6b 100644 (file)
--- 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 1c683e2..74ff65c 100644 (file)
--- 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 f43acb3..749b693 100644 (file)
--- 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 09ca337..a920923 100644 (file)
--- 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))))