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.

module/language/cps/primitives.scm

@@ -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)))

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)))))