[Guile-commits] 09/16: Refactor lowering of Tree-IL primcalls to CPS

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 36e6a3dacacbcc981395b10bfe36e2ef6efad37e
Author: Andy Wingo <address@hidden>
Date:   Tue Dec 26 10:18:59 2017 +0100

    Refactor lowering of Tree-IL primcalls to CPS
    
    * module/language/tree-il/cps-primitives.scm: New file,
      replacing (language cps primitives).  Lists known primitives and their
      relation to Tree-IL explicitly, instead of assuming that any Tree-IL
      primcall that shares a name with a bytecode instruction is a CPS
      primcall.
    * module/language/cps/verify.scm: Remove use of (language cps
      primitives) and primcall arity checking.  Would be nice to add this
      back at some point.
    * module/language/tree-il/compile-cps.scm (convert): Refactor to use new
      tree-il-primitive->cps-primitive+nargs+nvalues helper.
    * module/Makefile.am:
    * am/bootstrap.am: Adapt.
---
 am/bootstrap.am                            |   2 +-
 module/Makefile.am                         |   2 +-
 module/language/cps/primitives.scm         | 199 -----------------------------
 module/language/cps/verify.scm             |  14 +-
 module/language/tree-il/compile-cps.scm    | 146 ++++++++++-----------
 module/language/tree-il/cps-primitives.scm | 169 ++++++++++++++++++++++++
 6 files changed, 244 insertions(+), 288 deletions(-)

diff --git a/am/bootstrap.am b/am/bootstrap.am
index 97780e7..8e83e51 100644
--- a/am/bootstrap.am
+++ b/am/bootstrap.am
@@ -64,6 +64,7 @@ SOURCES =                                     \
   language/tree-il/analyze.scm                 \
   language/tree-il/canonicalize.scm            \
   language/tree-il/compile-cps.scm             \
+  language/tree-il/cps-primitives.scm          \
   language/tree-il/debug.scm                   \
   language/tree-il/effects.scm                 \
   language/tree-il/fix-letrec.scm              \
@@ -85,7 +86,6 @@ SOURCES =                                     \
   language/cps/handle-interrupts.scm           \
   language/cps/licm.scm                                \
   language/cps/peel-loops.scm                  \
-  language/cps/primitives.scm                  \
   language/cps/prune-bailouts.scm              \
   language/cps/prune-top-level-scopes.scm      \
   language/cps/reify-primitives.scm            \
diff --git a/module/Makefile.am b/module/Makefile.am
index 81fd3fd..e1ff9f6 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -144,7 +144,6 @@ SOURCES =                                   \
   language/cps/licm.scm                                \
   language/cps/optimize.scm                    \
   language/cps/peel-loops.scm                  \
-  language/cps/primitives.scm                  \
   language/cps/prune-bailouts.scm              \
   language/cps/prune-top-level-scopes.scm      \
   language/cps/reify-primitives.scm            \
@@ -191,6 +190,7 @@ SOURCES =                                   \
   language/tree-il/analyze.scm                 \
   language/tree-il/canonicalize.scm            \
   language/tree-il/compile-cps.scm             \
+  language/tree-il/cps-primitives.scm          \
   language/tree-il/debug.scm                   \
   language/tree-il/effects.scm                 \
   language/tree-il/fix-letrec.scm              \
diff --git a/module/language/cps/primitives.scm 
b/module/language/cps/primitives.scm
deleted file mode 100644
index 8d774cb..0000000
--- a/module/language/cps/primitives.scm
+++ /dev/null
@@ -1,199 +0,0 @@
-;;; Continuation-passing style (CPS) intermediate language (IL)
-
-;; 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
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 
USA
-
-;;; Commentary:
-;;;
-;;; Information about named primitives, as they appear in $prim and
-;;; $primcall.
-;;;
-;;; Code:
-
-(define-module (language cps primitives)
-  #:use-module (ice-9 match)
-  #:use-module ((srfi srfi-1) #:select (fold))
-  #:use-module (srfi srfi-26)
-  #:use-module (language bytecode)
-  #:export (prim-instruction
-            branching-primitive?
-            heap-type-predicate?
-            prim-arity
-            ))
-
-(define *instruction-aliases*
-  '((+ . add)
-    (- . sub)
-    (* . mul)
-    (/ . div)
-    (quotient . quo) (remainder . rem)
-    (modulo . mod)
-    (variable-ref . box-ref)
-    (variable-set! . box-set!)
-    (bytevector-length . bv-length)
-    (bytevector-u8-ref . bv-u8-ref)
-    (bytevector-u16-native-ref . bv-u16-ref)
-    (bytevector-u32-native-ref . bv-u32-ref)
-    (bytevector-u64-native-ref . bv-u64-ref)
-    (bytevector-s8-ref . bv-s8-ref)
-    (bytevector-s16-native-ref . bv-s16-ref)
-    (bytevector-s32-native-ref . bv-s32-ref)
-    (bytevector-s64-native-ref . bv-s64-ref)
-    (bytevector-ieee-single-native-ref . bv-f32-ref)
-    (bytevector-ieee-double-native-ref . bv-f64-ref)
-    (bytevector-u8-set! . bv-u8-set!)
-    (bytevector-u16-native-set! . bv-u16-set!)
-    (bytevector-u32-native-set! . bv-u32-set!)
-    (bytevector-u64-native-set! . bv-u64-set!)
-    (bytevector-s8-set! . bv-s8-set!)
-    (bytevector-s16-native-set! . bv-s16-set!)
-    (bytevector-s32-native-set! . bv-s32-set!)
-    (bytevector-s64-native-set! . bv-s64-set!)
-    (bytevector-ieee-single-native-set! . bv-f32-set!)
-    (bytevector-ieee-double-native-set! . bv-f64-set!)))
-
-(define *macro-instruction-arities*
-  '((u64->s64 . (1 . 1))
-    (s64->u64 . (1 . 1))
-    (sadd . (2 . 1))
-    (ssub . (2 . 1))
-    (smul . (2 . 1))
-    (sadd/immediate . (1 . 1))
-    (ssub/immediate . (1 . 1))
-    (smul/immediate . (1 . 1))
-    (slsh . (2 . 1))
-    (slsh/immediate . (1 . 1))
-    (u64->scm/unlikely . (1 . 1))
-    (s64->scm/unlikely . (1 . 1))
-    (tag-fixnum/unlikely . (1 . 1))
-    (load-const/unlikely . (0 . 1))
-    (cache-current-module! . (0 . 1))
-    (cached-toplevel-box . (1 . 0))
-    (cached-module-box . (1 . 0))))
-
-(define *immediate-predicates*
-  '(fixnum?
-    char?
-    eq-nil?
-    eq-eol?
-    eq-false?
-    eq-true?
-    unspecified?
-    undefined?
-    eof-object?
-    null?  ;; '() or #nil
-    false? ;; #f or #nil
-    nil?   ;; #f or '() or #nil
-    heap-object?))
-
-;; All of the following tests must be dominated by heap-object?.
-(define *heap-type-predicates*
-  '(pair?
-    struct?
-    symbol?
-    variable?
-    vector?
-    string?
-    keyword?
-    bytevector?
-    bitvector?
-    heap-number?
-    bignum?))
-
-;; FIXME: Support these.
-(define *other-predicates*
-  '(weak-vector?
-    hash-table?
-    pointer?
-    fluid?
-    stringbuf?
-    dynamic-state?
-    frame?
-    syntax?
-    program?
-    vm-continuation?
-    weak-set?
-    weak-table?
-    array?
-    port?
-    smob?
-    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?
-    heap-numbers-equal?
-
-    <
-    <=
-    =
-
-    u64-<
-    u64-=
-
-    s64-<
-
-    f64-<
-    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)))
-    (for-each
-     (match-lambda ((inst . _) (hashq-set! table inst inst)))
-     (instruction-list))
-    (for-each
-     (match-lambda ((prim . inst) (hashq-set! table prim inst)))
-     *instruction-aliases*)
-    (for-each
-     (match-lambda ((inst . arity) (hashq-set! table inst inst)))
-     *macro-instruction-arities*)
-    table))
-
-(define *prim-instructions* (delay (compute-prim-instructions)))
-
-;; prim -> instruction | #f
-(define (prim-instruction name)
-  (hashq-ref (force *prim-instructions*) name))
-
-(define (branching-primitive? name)
-  (and (hashq-ref *branching-primcall-arities* name) #t))
-
-(define *prim-arities* (make-hash-table))
-
-(define (prim-arity name)
-  (or (hashq-ref *prim-arities* name)
-      (let ((arity (cond
-                    ((prim-instruction name) => instruction-arity)
-                    ((hashq-ref *branching-primcall-arities* name))
-                    (else
-                     (error "Primitive of unknown arity" name)))))
-        (hashq-set! *prim-arities* name arity)
-        arity)))
diff --git a/module/language/cps/verify.scm b/module/language/cps/verify.scm
index 67a8304..5dc4b84 100644
--- a/module/language/cps/verify.scm
+++ b/module/language/cps/verify.scm
@@ -27,7 +27,6 @@
   #:use-module (language cps utils)
   #:use-module (language cps intmap)
   #:use-module (language cps intset)
-  #:use-module (language cps primitives)
   #:use-module (srfi srfi-11)
   #:export (verify))
 
@@ -244,16 +243,9 @@ definitions that are available at LABEL."
          (cont (error "bad kt" cont))))
       (($ $primcall name param args)
        (match cont
-         (($ $kargs names)
-          (match (prim-arity name)
-            ((out . in)
-             (unless (= in (length args))
-               (error "bad arity to primcall" name args in))
-             (unless (= out (length names))
-               (error "bad return arity from primcall" name names out)))))
-         (($ $kreceive)
-          (when (false-if-exception (prim-arity name))
-            (error "primitive should continue to $kargs, not $kreceive" name)))
+         (($ $kargs) #t)
+         ;; FIXME: Remove this case; instead use $prim and $call.
+         (($ $kreceive) #t)
          (($ $ktail)
           (unless (memv name '(throw throw/value throw/value+data))
             (error "primitive should continue to $kargs, not $ktail" name)))))
diff --git a/module/language/tree-il/compile-cps.scm 
b/module/language/tree-il/compile-cps.scm
index 9e00295..ed97a52 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -58,7 +58,7 @@
   #:use-module (language cps)
   #:use-module (language cps utils)
   #:use-module (language cps with-cps)
-  #:use-module (language cps primitives)
+  #:use-module (language tree-il cps-primitives)
   #:use-module (language tree-il analyze)
   #:use-module (language tree-il optimize)
   #:use-module (language tree-il)
@@ -443,13 +443,11 @@
       (($ <let-values> src exp body) (zero-valued? body))
       (($ <seq> src head tail) (zero-valued? tail))
       (($ <primcall> src name args)
-       (match (prim-instruction name)
+       (match (tree-il-primitive->cps-primitive+nargs+nvalues name)
          (#f #f)
-         (inst
-          (match (prim-arity inst)
-            ((out . in)
-             (and (eqv? out 0)
-                  (eqv? in (length args))))))))
+         (#(cps-prim nargs nvalues)
+          (and (eqv? nvalues 0)
+               (eqv? nargs (length args))))))
       (_ #f)))
   (define (single-valued? exp)
     (match exp
@@ -461,13 +459,11 @@
       (($ <let-values> src exp body) (single-valued? body))
       (($ <seq> src head tail) (single-valued? tail))
       (($ <primcall> src name args)
-       (match (prim-instruction name)
+       (match (tree-il-primitive->cps-primitive+nargs+nvalues name)
          (#f #f)
-         (inst
-          (match (prim-arity inst)
-            ((out . in)
-             (and (eqv? out 1)
-                  (eqv? in (length args))))))))
+         (#(cps-prim nargs nvalues)
+          (and (eqv? nvalues 1)
+               (eqv? nargs (length args))))))
       (_ #f)))
   ;; exp (v-name -> term) -> term
   (define (convert-arg cps exp k)
@@ -733,71 +729,69 @@
                  (specialize 'throw/value `#(,key ,subr ,msg) x))
                 (_ (fallback)))))
            (_ (fallback)))))
-      ((prim-instruction name)
-       => (lambda (instruction)
-            (define (cvt cps k src instruction args)
-              (define (default)
-                (convert-args cps args
+      ((tree-il-primitive->cps-primitive+nargs+nvalues name)
+       =>
+       (match-lambda
+        (#(cps-prim nargs nvalues)
+         (define (cvt cps k src op args)
+           (define (default)
+             (convert-args cps args
+               (lambda (cps args)
+                 (with-cps cps
+                   ($ (convert-primcall* k src op #f args))))))
+           (define-syntax-rule (specialize-case (pat (op c (arg ...))) ...
+                                                (_ def))
+             (match (cons cps-prim args)
+               (pat
+                (convert-args cps (list arg ...)
                   (lambda (cps args)
                     (with-cps cps
-                      ($ (convert-primcall* k src instruction #f args))))))
-              (define-syntax-rule (specialize-case (pat (op c (arg ...))) ...
-                                                   (_ def))
-                (match (cons instruction args)
-                  (pat
-                   (convert-args cps (list arg ...)
-                     (lambda (cps args)
-                       (with-cps cps
-                         ($ (convert-primcall* k src 'op c args))))))
-                  ...
-                  (_ def)))
-              (define (uint? val) (and (exact-integer? val) (<= 0 val)))
-              (define (negint? val) (and (exact-integer? val) (< val 0)))
-              ;; FIXME: Add case for mul
-              (specialize-case
-                (('make-vector ($ <const> _ (? uint? n)) init)
-                 (make-vector/immediate n (init)))
-                (('vector-ref v ($ <const> _ (? uint? n)))
-                 (vector-ref/immediate n (v)))
-                (('vector-set! v ($ <const> _ (? uint? n)) x)
-                 (vector-set!/immediate n (v x)))
-                (('allocate-struct v ($ <const> _ (? uint? n)))
-                 (allocate-struct/immediate n (v)))
-                (('struct-ref s ($ <const> _ (? uint? n)))
-                 (struct-ref/immediate n (s)))
-                (('struct-set! s ($ <const> _ (? uint? n)) x)
-                 (struct-set!/immediate n (s x)))
-                (('add x ($ <const> _ (? number? y)))
-                 (add/immediate y (x)))
-                (('add ($ <const> _ (? number? y)) x)
-                 (add/immediate y (x)))
-                (('sub x ($ <const> _ (? number? y)))
-                 (sub/immediate y (x)))
-                (('lsh x ($ <const> _ (? uint? y)))
-                 (lsh/immediate y (x)))
-                (('rsh x ($ <const> _ (? uint? y)))
-                 (rsh/immediate y (x)))
-                (_
-                 (default))))
-            (when (branching-primitive? name)
-              (error "branching primcall in bad context" name))
-            ;; Tree-IL primcalls are sloppy, in that it could be that
-            ;; they are called with too many or too few arguments.  In
-            ;; CPS we are more strict and only residualize a $primcall
-            ;; if the argument count matches.
-            (match (prim-arity instruction)
-              ((out . in)
-               (if (= in (length args))
-                   (with-cps cps
-                     (let$ k (adapt-arity k src out))
-                     ($ (cvt k src instruction args)))
-                   (convert-args cps args
-                     (lambda (cps args)
-                       (with-cps cps
-                         (letv prim)
-                         (letk kprim ($kargs ('prim) (prim)
-                                       ($continue k src ($call prim args))))
-                         (build-term ($continue kprim src ($prim 
name)))))))))))
+                      ($ (convert-primcall* k src 'op c args))))))
+               ...
+               (_ def)))
+           (define (uint? val) (and (exact-integer? val) (<= 0 val)))
+           (define (negint? val) (and (exact-integer? val) (< val 0)))
+           ;; FIXME: Add case for mul
+           (specialize-case
+            (('make-vector ($ <const> _ (? uint? n)) init)
+             (make-vector/immediate n (init)))
+            (('vector-ref v ($ <const> _ (? uint? n)))
+             (vector-ref/immediate n (v)))
+            (('vector-set! v ($ <const> _ (? uint? n)) x)
+             (vector-set!/immediate n (v x)))
+            (('allocate-struct v ($ <const> _ (? uint? n)))
+             (allocate-struct/immediate n (v)))
+            (('struct-ref s ($ <const> _ (? uint? n)))
+             (struct-ref/immediate n (s)))
+            (('struct-set! s ($ <const> _ (? uint? n)) x)
+             (struct-set!/immediate n (s x)))
+            (('add x ($ <const> _ (? number? y)))
+             (add/immediate y (x)))
+            (('add ($ <const> _ (? number? y)) x)
+             (add/immediate y (x)))
+            (('sub x ($ <const> _ (? number? y)))
+             (sub/immediate y (x)))
+            (('lsh x ($ <const> _ (? uint? y)))
+             (lsh/immediate y (x)))
+            (('rsh x ($ <const> _ (? uint? y)))
+             (rsh/immediate y (x)))
+            (_
+             (default))))
+         ;; Tree-IL primcalls are sloppy, in that it could be that
+         ;; they are called with too many or too few arguments.  In
+         ;; CPS we are more strict and only residualize a $primcall
+         ;; if the argument count matches.
+         (if (= nargs (length args))
+             (with-cps cps
+               (let$ k (adapt-arity k src nvalues))
+               ($ (cvt k src cps-prim args)))
+             (convert-args cps args
+               (lambda (cps args)
+                 (with-cps cps
+                   (letv prim)
+                   (letk kprim ($kargs ('prim) (prim)
+                                 ($continue k src ($call prim args))))
+                   (build-term ($continue kprim src ($prim name))))))))))
       (else
        ;; We have something that's a primcall for Tree-IL but not for
        ;; CPS, which will get compiled as a call and so the right thing
diff --git a/module/language/tree-il/cps-primitives.scm 
b/module/language/tree-il/cps-primitives.scm
new file mode 100644
index 0000000..e25d1ce
--- /dev/null
+++ b/module/language/tree-il/cps-primitives.scm
@@ -0,0 +1,169 @@
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; 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
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 
USA
+
+;;; Commentary:
+;;;
+;;; Information about named primitives, as they appear in $prim and
+;;; $primcall.
+;;;
+;;; Code:
+
+(define-module (language tree-il cps-primitives)
+  #:use-module (ice-9 match)
+  #:use-module (language bytecode)
+  #:use-module (system base types internal)
+  #:export (tree-il-primitive->cps-primitive+nargs+nvalues
+            branching-primitive?
+            heap-type-predicate?))
+
+(define *primitives* (make-hash-table))
+
+(define-syntax define-cps-primitive
+  (syntax-rules ()
+    ((_ (tree-il-primitive cps-primitive) nargs nvalues)
+     (hashq-set! *primitives* 'tree-il-primitive
+                 '#(cps-primitive nargs nvalues)))
+    ((_ primitive nargs nvalues)
+     (define-cps-primitive (primitive primitive) nargs nvalues))))
+
+;; tree-il-prim -> #(cps-prim nargs nvalues) | #f
+(define (tree-il-primitive->cps-primitive+nargs+nvalues name)
+  (hashq-ref *primitives* name))
+
+(define-cps-primitive box 1 1)
+(define-cps-primitive (variable-ref box-ref) 1 1)
+(define-cps-primitive (variable-set! box-set!) 2 0)
+
+(define-cps-primitive current-module 0 1)
+(define-cps-primitive define! 1 1)
+
+(define-cps-primitive wind 2 0)
+(define-cps-primitive unwind 0 0)
+(define-cps-primitive push-dynamic-state 1 0)
+(define-cps-primitive pop-dynamic-state 0 0)
+
+(define-cps-primitive push-fluid 2 0)
+(define-cps-primitive pop-fluid 0 0)
+(define-cps-primitive fluid-ref 1 1)
+(define-cps-primitive fluid-set! 2 0)
+
+(define-cps-primitive string-length 1 1)
+(define-cps-primitive string-ref 2 1)
+(define-cps-primitive string-set! 3 0)
+(define-cps-primitive string->number 1 1)
+(define-cps-primitive string->symbol 1 1)
+(define-cps-primitive symbol->keyword 1 1)
+
+(define-cps-primitive integer->char 1 1)
+(define-cps-primitive char->integer 1 1)
+
+(define-cps-primitive cons 2 1)
+(define-cps-primitive car 1 1)
+(define-cps-primitive cdr 1 1)
+(define-cps-primitive set-car! 2 0)
+(define-cps-primitive set-cdr! 2 0)
+
+(define-cps-primitive (+ add) 2 1)
+(define-cps-primitive (- sub) 2 1)
+(define-cps-primitive (* mul) 2 1)
+(define-cps-primitive (/ div) 2 1)
+(define-cps-primitive (quotient quo) 2 1)
+(define-cps-primitive (remainder rem) 2 1)
+(define-cps-primitive (modulo mod) 2 1)
+
+(define-cps-primitive lsh 2 1)
+(define-cps-primitive rsh 2 1)
+(define-cps-primitive logand 2 1)
+(define-cps-primitive logior 2 1)
+(define-cps-primitive logxor 2 1)
+(define-cps-primitive logsub 2 1)
+
+(define-cps-primitive make-vector 2 1)
+(define-cps-primitive vector-length 1 1)
+(define-cps-primitive vector-ref 2 1)
+(define-cps-primitive vector-set! 3 0)
+
+(define-cps-primitive struct-vtable 1 1)
+(define-cps-primitive allocate-struct 2 1)
+(define-cps-primitive struct-ref 2 1)
+(define-cps-primitive struct-set! 3 0)
+
+(define-cps-primitive class-of 1 1)
+
+(define-cps-primitive (bytevector-length bv-length) 1 1)
+(define-cps-primitive (bytevector-u8-ref bv-u8-ref) 2 1)
+(define-cps-primitive (bytevector-u16-native-ref bv-u16-ref) 2 1)
+(define-cps-primitive (bytevector-u32-native-ref bv-u32-ref) 2 1)
+(define-cps-primitive (bytevector-u64-native-ref bv-u64-ref) 2 1)
+(define-cps-primitive (bytevector-s8-ref bv-s8-ref) 2 1)
+(define-cps-primitive (bytevector-s16-native-ref bv-s16-ref) 2 1)
+(define-cps-primitive (bytevector-s32-native-ref bv-s32-ref) 2 1)
+(define-cps-primitive (bytevector-s64-native-ref bv-s64-ref) 2 1)
+(define-cps-primitive (bytevector-ieee-single-native-ref bv-f32-ref) 2 1)
+(define-cps-primitive (bytevector-ieee-double-native-ref bv-f64-ref) 2 1)
+(define-cps-primitive (bytevector-u8-set! bv-u8-set!) 3 0)
+(define-cps-primitive (bytevector-u16-native-set! bv-u16-set!) 3 0)
+(define-cps-primitive (bytevector-u32-native-set! bv-u32-set!) 3 0)
+(define-cps-primitive (bytevector-u64-native-set! bv-u64-set!) 3 0)
+(define-cps-primitive (bytevector-s8-set! bv-s8-set!) 3 0)
+(define-cps-primitive (bytevector-s16-native-set! bv-s16-set!) 3 0)
+(define-cps-primitive (bytevector-s32-native-set! bv-s32-set!) 3 0)
+(define-cps-primitive (bytevector-s64-native-set! bv-s64-set!) 3 0)
+(define-cps-primitive (bytevector-ieee-single-native-set! bv-f32-set!) 3 0)
+(define-cps-primitive (bytevector-ieee-double-native-set! bv-f64-set!) 3 0)
+
+(define-cps-primitive current-thread 0 1)
+
+(define-cps-primitive make-atomic-box 1 1)
+(define-cps-primitive atomic-box-ref 1 1)
+(define-cps-primitive atomic-box-set! 2 0)
+(define-cps-primitive atomic-box-swap! 2 1)
+(define-cps-primitive atomic-box-compare-and-swap! 3 1)
+
+(define *branching-primitive-arities* (make-hash-table))
+(define-syntax-rule (define-branching-primitive name nargs)
+  (hashq-set! *branching-primitive-arities* 'name '(0 . nargs)))
+
+(define-syntax-rule (define-immediate-type-predicate name pred mask tag)
+  (define-branching-primitive pred 1))
+(define *heap-type-predicates* (make-hash-table))
+(define-syntax-rule (define-heap-type-predicate name pred mask tag)
+  (begin
+    (hashq-set! *heap-type-predicates* 'pred #t)
+    (define-branching-primitive pred 1)))
+
+(visit-immediate-tags define-immediate-type-predicate)
+(visit-heap-tags define-heap-type-predicate)
+
+(define (branching-primitive? name)
+  "Is @var{name} a primitive that can only appear in $branch CPS terms?"
+  (hashq-ref *branching-primitive-arities* name))
+
+(define (heap-type-predicate? name)
+  "Is @var{name} a predicate that needs guarding by @code{heap-object?}
+ before it is lowered to CPS?"
+  (hashq-ref *heap-type-predicates* name))
+
+;; We only need to define those branching primitives that are used as
+;; Tree-IL primitives.  There are others like u64-= which are emitted by
+;; CPS code.
+(define-branching-primitive eq? 2)
+(define-branching-primitive heap-numbers-equal? 2)
+(define-branching-primitive < 2)
+(define-branching-primitive <= 2)
+(define-branching-primitive = 2)