[Guile-commits] 08/16: Flesh out compile-bytecode for all heap objects

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 549ad3ce8cfdc507b6b4dd0b31e6e253f6a0e61e
Author: Andy Wingo <address@hidden>
Date:   Wed Dec 27 12:11:07 2017 +0100

    Flesh out compile-bytecode for all heap objects
    
    * module/language/cps/compile-bytecode.scm (compile-function): Organize
      emitters and flesh out with more heap type tag predicates.  Remove
      now-needless (language cps primitives) import.
---
 module/language/cps/compile-bytecode.scm | 39 +++++++++++++++++++++++---------
 1 file changed, 28 insertions(+), 11 deletions(-)

diff --git a/module/language/cps/compile-bytecode.scm 
b/module/language/cps/compile-bytecode.scm
index aa33b68..2b3b23f 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -27,7 +27,6 @@
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
   #:use-module (language cps)
-  #:use-module (language cps primitives)
   #:use-module (language cps slot-allocation)
   #:use-module (language cps utils)
   #:use-module (language cps closure-conversion)
@@ -476,10 +475,10 @@
         (op asm (from-sp (slot a)) b)
         (emit-branch emit-jl emit-jnl))
       (match exp
+        ;; Immediate type tag predicates.
+        (($ $primcall 'fixnum? #f (a)) (unary emit-fixnum? a))
         (($ $primcall 'heap-object? #f (a)) (unary emit-heap-object? a))
-        (($ $primcall 'null? #f (a)) (unary emit-null? a))
-        (($ $primcall 'nil? #f (a)) (unary emit-nil? a))
-        (($ $primcall 'false? #f (a)) (unary emit-false? a))
+        (($ $primcall 'char? #f (a)) (unary emit-char? a))
         (($ $primcall 'eq-false? #f (a)) (unary emit-eq-false? a))
         (($ $primcall 'eq-nil? #f (a)) (unary emit-eq-nil? a))
         (($ $primcall 'eq-null? #f (a)) (unary emit-eq-null? a))
@@ -487,22 +486,40 @@
         (($ $primcall 'unspecified? #f (a)) (unary emit-unspecified? a))
         (($ $primcall 'undefined? #f (a)) (unary emit-undefined? a))
         (($ $primcall 'eof-object? #f (a)) (unary emit-eof-object? a))
+        (($ $primcall 'null? #f (a)) (unary emit-null? a))
+        (($ $primcall 'false? #f (a)) (unary emit-false? a))
+        (($ $primcall 'nil? #f (a)) (unary emit-nil? a))
+        ;; Heap type tag predicates.
         (($ $primcall 'pair? #f (a)) (unary emit-pair? a))
         (($ $primcall 'struct? #f (a)) (unary emit-struct? a))
-        (($ $primcall 'char? #f (a)) (unary emit-char? a))
         (($ $primcall 'symbol? #f (a)) (unary emit-symbol? a))
         (($ $primcall 'variable? #f (a)) (unary emit-variable? a))
         (($ $primcall 'vector? #f (a)) (unary emit-vector? a))
         (($ $primcall 'string? #f (a)) (unary emit-string? a))
+        (($ $primcall 'heap-number? #f (a)) (unary emit-heap-number? a))
+        (($ $primcall 'hash-table? #f (a)) (unary emit-hash-table? a))
+        (($ $primcall 'pointer? #f (a)) (unary emit-pointer? a))
+        (($ $primcall 'fluid? #f (a)) (unary emit-fluid? a))
+        (($ $primcall 'stringbuf? #f (a)) (unary emit-stringbuf? a))
+        (($ $primcall 'dynamic-state? #f (a)) (unary emit-dynamic-state? a))
+        (($ $primcall 'frame? #f (a)) (unary emit-frame? a))
+        (($ $primcall 'keyword? #f (a)) (unary emit-keyword? a))
+        (($ $primcall 'atomic-box? #f (a)) (unary emit-atomic-box? a))
+        (($ $primcall 'syntax? #f (a)) (unary emit-syntax? a))
+        (($ $primcall 'program? #f (a)) (unary emit-program? a))
+        (($ $primcall 'vm-continuation? #f (a)) (unary emit-vm-continuation? 
a))
         (($ $primcall 'bytevector? #f (a)) (unary emit-bytevector? a))
+        (($ $primcall 'weak-set? #f (a)) (unary emit-weak-set? a))
+        (($ $primcall 'weak-table? #f (a)) (unary emit-weak-table? a))
+        (($ $primcall 'array? #f (a)) (unary emit-array? a))
         (($ $primcall 'bitvector? #f (a)) (unary emit-bitvector? a))
-        (($ $primcall 'keyword? #f (a)) (unary emit-keyword? a))
-        (($ $primcall 'heap-number? #f (a)) (unary emit-heap-number? a))
-        (($ $primcall 'fixnum? #f (a)) (unary emit-fixnum? a))
+        (($ $primcall 'smob? #f (a)) (unary emit-smob? a))
+        (($ $primcall 'port? #f (a)) (unary emit-port? a))
         (($ $primcall 'bignum? #f (a)) (unary emit-bignum? 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 'flonum? #f (a)) (unary emit-flonum? a))
+        (($ $primcall 'compnum? #f (a)) (unary emit-compnum? a))
+        (($ $primcall 'fracnum? #f (a)) (unary emit-fracnum? a))
+        ;; Binary predicates.
         (($ $primcall 'eq? #f (a b)) (binary-test emit-eq? a b))
         (($ $primcall 'heap-numbers-equal? #f (a b))
          (binary-test emit-heap-numbers-equal? a b))