Heap type predicates preceded by heap-object?

* module/language/cps/compile-bytecode.scm (compile-function): Add
  support for heap-object? in test context.
* module/language/cps/primitives.scm (*immediate-predicates*):
  (*heap-type-predicates*, *comparisons*): New sets of predicates for
  which the VM has branching operations.
  (heap-type-predicate?): New predicate.
  (*branching-primcall-arities*): Make a hash table.
  (branching-primitive?, prim-arity): Adapt
  to *branching-primcall-arities* being a hash table.
* module/language/cps/type-fold.scm (heap-object?): Add folder.
* module/language/tree-il/compile-cps.scm (convert): Precede heap type
  checks with a heap-object? guard.

module/language/cps/compile-bytecode.scm

@@ -1,6 +1,6 @@
 ;;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
+;; Copyright (C) 2013, 2014, 2015, 2017 Free Software Foundation, Inc.
 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -404,6 +404,21 @@
           (let ((invert? (not (prefer-true?))))
             (op asm (from-sp (slot sym)) invert? (if invert? kf kt))
             (emit-j asm (if invert? kt kf))))))
+      (define (emit-branch-for-test)
+        (cond
+         ((eq? kt next-label)
+          (emit-jne asm kf))
+         ((eq? kf next-label)
+          (emit-je asm kt))
+         ((prefer-true?)
+          (emit-je asm kt)
+          (emit-j asm kf))
+         (else
+          (emit-jne asm kf)
+          (emit-j asm kt))))
+      (define (unary* op a)
+        (op asm (from-sp (slot a)))
+        (emit-branch-for-test))
       (define (binary op a b)
         (cond
          ((eq? kt next-label)
@@ -417,6 +432,7 @@
             (emit-j asm (if invert? kt kf))))))
       (match exp
         (($ $values (sym)) (unary emit-br-if-true sym))
+        (($ $primcall 'heap-object? (a)) (unary* emit-heap-object? a))
         (($ $primcall 'null? (a)) (unary emit-br-if-null a))
         (($ $primcall 'nil? (a)) (unary emit-br-if-nil a))
         (($ $primcall 'pair? (a)) (unary emit-br-if-pair a))

module/language/cps/primitives.scm

@@ -1,6 +1,6 @@
 ;;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
+;; Copyright (C) 2013, 2014, 2015, 2017 Free Software Foundation, Inc.
 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -30,6 +30,7 @@
   #:use-module (language bytecode)
   #:export (prim-instruction
             branching-primitive?
+            heap-type-predicate?
             prim-arity
             ))
 
@@ -69,42 +70,97 @@
     (cached-toplevel-box . (1 . 3))
     (cached-module-box . (1 . 4))))
 
-(define *branching-primcall-arities*
+(define *immediate-predicates*
-  '((null? . (1 . 1))
+  '(fixnum?
-    (nil? . (1 . 1))
+    char?
-    (pair? . (1 . 1))
+    eq-nil?
-    (struct? . (1 . 1))
+    eq-eol?
-    (string? . (1 . 1))
+    eq-false?
-    (vector? . (1 . 1))
+    eq-true?
-    (symbol? . (1 . 1))
+    unspecified?
-    (keyword? . (1 . 1))
+    undefined?
-    (variable? . (1 . 1))
+    eof-object?
-    (bitvector? . (1 . 1))
+    null?  ;; '() or #nil
-    (bytevector? . (1 . 1))
+    false? ;; #f or #nil
-    (char? . (1 . 1))
+    nil?   ;; #f or '() or #nil
-    (eq? . (1 . 2))
+    heap-object?))
-    (eqv? . (1 . 2))
+
-    (= . (1 . 2))
+;; All of the following tests must be dominated by heap-object?.
-    (< . (1 . 2))
+(define *heap-type-predicates*
-    (> . (1 . 2))
+  '(pair?
-    (<= . (1 . 2))
+    struct?
-    (>= . (1 . 2))
+    symbol?
-    (u64-= . (1 . 2))
+    variable?
-    (u64-< . (1 . 2))
+    vector?
-    (u64-> . (1 . 2))
+    string?
-    (u64-<= . (1 . 2))
+    keyword?
-    (u64->= . (1 . 2))
+    bytevector?
-    (u64-<-scm . (1 . 2))
+    bitvector?))
-    (u64-<=-scm . (1 . 2))
+
-    (u64-=-scm . (1 . 2))
+;; FIXME: Support these.
-    (u64->=-scm . (1 . 2))
+(define *other-predicates*
-    (u64->-scm . (1 . 2))
+  '(weak-vector?
-    (logtest . (1 . 2))
+    number?
-    (f64-= . (1 . 2))
+    hash-table?
-    (f64-< . (1 . 2))
+    pointer?
-    (f64-> . (1 . 2))
+    fluid?
-    (f64-<= . (1 . 2))
+    stringbuf?
-    (f64->= . (1 . 2))))
+    dynamic-state?
+    frame?
+    syntax?
+    program?
+    vm-continuation?
+    weak-set?
+    weak-table?
+    array?
+    port?
+    smob?
+    bignum?
+    flonum?
+    complex?
+    fraction?))
+
+(define (heap-type-predicate? name)
+  "Is @var{name} a predicate that needs guarding by @code{heap-object?}
+before it is lowered to CPS?"
+  (and (memq name *heap-type-predicates*) #t))
+
+(define *comparisons*
+  '(eq?
+    eqv?
+    <
+    <=
+    =
+    u64-<
+    u64-<=
+    u64-=
+    f64-=
+    f64-<
+    f64-<=
+
+    ;; FIXME: Expand these.
+    logtest
+    u64-<-scm
+    u64-<=-scm
+    u64-=-scm
+
+    ;; FIXME: Remove these.
+    >
+    >=
+    u64->
+    u64->=
+    u64->=-scm
+    u64->-scm
+    f64->
+    f64->=))
+
+(define *branching-primcall-arities* (make-hash-table))
+(for-each (lambda (x) (hashq-set! *branching-primcall-arities* x '(1 . 1)))
+          *immediate-predicates*)
+(for-each (lambda (x) (hashq-set! *branching-primcall-arities* x '(1 . 1)))
+          *heap-type-predicates*)
+(for-each (lambda (x) (hashq-set! *branching-primcall-arities* x '(1 . 2)))
+          *comparisons*)
 
 (define (compute-prim-instructions)
   (let ((table (make-hash-table)))
@@ -126,7 +182,7 @@
   (hashq-ref (force *prim-instructions*) name))
 
 (define (branching-primitive? name)
-  (and (assq name *branching-primcall-arities*) #t))
+  (and (hashq-ref *branching-primcall-arities* name) #t))
 
 (define *prim-arities* (make-hash-table))
 
@@ -134,7 +190,7 @@
   (or (hashq-ref *prim-arities* name)
       (let ((arity (cond
                     ((prim-instruction name) => instruction-arity)
-                    ((assq name *branching-primcall-arities*) => cdr)
+                    ((hashq-ref *branching-primcall-arities* name))
                     (else
                      (error "Primitive of unknown arity" name)))))
         (hashq-set! *prim-arities* name arity)

module/language/cps/type-fold.scm

@@ -90,6 +90,13 @@
        ((eqv? type type*) (values #t #t))
        (else (values #f #f))))))
 
+(define-unary-branch-folder (heap-object? type min max)
+  (define &immediate-types (logior &fixnum &char &special-immediate))
+  (cond
+   ((zero? (logand type &immediate-types)) (values #t #t))
+   ((type<=? type &immediate-types) (values #t #f))
+   (else (values #f #f))))
+
 ;; All the cases that are in compile-bytecode.
 (define-unary-type-predicate-folder pair? &pair)
 (define-unary-type-predicate-folder symbol? &symbol)

module/language/tree-il/compile-cps.scm

@@ -1,6 +1,6 @@
 ;;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
+;; Copyright (C) 2013, 2014, 2015, 2017 Free Software Foundation, Inc.
 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -522,14 +522,25 @@
              (build-term ($continue kf* src
                            ($branch kt ($primcall 'eqv? args))))))))
       ((branching-primitive? name)
-       (convert-args cps args
+       (let ()
-         (lambda (cps args)
+         (define (reify-primcall cps kt kf args)
-           (with-cps cps
+           (if (heap-type-predicate? name)
-             (let$ k (adapt-arity k src 1))
+               (with-cps cps
-             (letk kt ($kargs () () ($continue k src ($const #t))))
+                 (letk kt* ($kargs () ()
-             (letk kf ($kargs () () ($continue k src ($const #f))))
+                             ($continue kf src
-             (build-term ($continue kf src
+                               ($branch kt ($primcall name args)))))
-                           ($branch kt ($primcall name args))))))))
+                 (build-term ($continue kf src
+                               ($branch kt* ($primcall 'heap-object? args)))))
+               (with-cps cps
+                 (build-term ($continue kf src
+                               ($branch kt ($primcall name args)))))))
+         (convert-args cps args
+           (lambda (cps args)
+             (with-cps cps
+               (let$ k (adapt-arity k src 1))
+               (letk kt ($kargs () () ($continue k src ($const #t))))
+               (letk kf ($kargs () () ($continue k src ($const #f))))
+               ($ (reify-primcall kt kf args)))))))
       ((and (eq? name 'not) (match args ((_) #t) (_ #f)))
        (convert-args cps args
          (lambda (cps args)
@@ -788,9 +799,17 @@
          (($ <primcall> src (? branching-primitive? name) args)
           (convert-args cps args
             (lambda (cps args)
-              (with-cps cps
+              (if (heap-type-predicate? name)
-                (build-term ($continue kf src
+                  (with-cps cps
-                              ($branch kt ($primcall name args))))))))
+                    (letk kt* ($kargs () ()
+                                ($continue kf src
+                                  ($branch kt ($primcall name args)))))
+                    (build-term
+                      ($continue kf src
+                        ($branch kt* ($primcall 'heap-object? args)))))
+                  (with-cps cps
+                    (build-term ($continue kf src
+                                  ($branch kt ($primcall name args)))))))))
          (($ <conditional> src test consequent alternate)
           (with-cps cps
             (let$ t (convert-test consequent kt kf))