From be8b62ca7f66f6acd1d342cd8576688cc33baf1c Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 26 Oct 2013 15:16:09 +0200 Subject: [PATCH] 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. --- libguile/tags.h | 5 ++++- module/language/cps/compile-rtl.scm | 9 +++++++-- module/language/cps/primitives.scm | 4 ++++ module/system/vm/assembler.scm | 31 +++++++++++++++++++++++++++++ module/system/vm/disassembler.scm | 12 ++++++++++- 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))))