Recognize procedure? as a CPS primitive

* module/language/cps/effects-analysis.scm: Mark more predicates as
effect-free.  Sort the list.
* module/language/cps/guile-vm/lower-primcalls.scm (procedure?): Reify a
call to a primitive.  Sadly we can't elide the $kreceive, as even though
we know that it's single-valued, $call can't continue to $kargs (has to
be $callk).  Perhaps is worth relaxing in the future.
* module/language/cps/type-fold.scm: Define a number of additional
folders for disjoint types.
(procedure?): Define a folder for &procedure.  Has to include structs,
though.
* module/language/cps/types.scm: Same as for type-fold.scm.
* module/language/tree-il/cps-primitives.scm: Lower procedure? primcalls
to CPS.

module/language/cps/effects-analysis.scm

@@ -367,31 +367,37 @@ the LABELS that are clobbered by the effects of LABEL."
 (define-primitive-effects
   ((eq? x y))
   ((equal? x y))
-  ((fixnum? arg))
-  ((char? arg))
-  ((eq-constant? arg))
-  ((undefined? arg))
-  ((null? arg))
-  ((false? arg))
-  ((nil? arg))
-  ((heap-object? arg))
-  ((pair? arg))
-  ((symbol? arg))
-  ((variable? arg))
-  ((vector? arg))
-  ((struct? arg))
-  ((string? arg))
-  ((number? arg))
-  ((bytevector? arg))
-  ((keyword? arg))
-  ((bitvector? arg))
-  ((procedure? arg))
-  ((thunk? arg))
-  ((heap-number? arg))
   ((bignum? arg))
-  ((flonum? arg))
+  ((bitvector? arg))
+  ((bytevector? arg))
+  ((char? arg))
   ((compnum? arg))
-  ((fracnum? arg)))
+  ((eq-constant? arg))
+  ((false? arg))
+  ((fixnum? arg))
+  ((flonum? arg))
+  ((fluid? arg))
+  ((fracnum? arg))
+  ((heap-number? arg))
+  ((heap-object? arg))
+  ((immutable-vector? arg))
+  ((keyword? arg))
+  ((nil? arg))
+  ((null? arg))
+  ((mutable-vector? arg))
+  ((number? arg))
+  ((pair? arg))
+  ((pointer? arg))
+  ((procedure? arg))
+  ((program? arg))
+  ((string? arg))
+  ((struct? arg))
+  ((symbol? arg))
+  ((syntax? arg))
+  ((thunk? arg))
+  ((undefined? arg))
+  ((variable? arg))
+  ((vector? arg)))
 
 ;; Fluids.
 (define-primitive-effects

module/language/cps/guile-vm/lower-primcalls.scm

@@ -597,6 +597,21 @@
                                  (8 2)))
                    ())))))
 
+(define-branching-primcall-lowerer (procedure? cps kf kt src #f (x))
+  (with-cps cps
+    (letv procedure? result)
+    (letk kresult
+          ($kargs ('result) (result)
+            ($branch kt kf src 'eq-constant? #f (result))))
+    (letk krecv
+          ($kreceive '(result) '() kresult))
+    (letk kcall
+          ($kargs ('procedure?) (procedure?)
+            ($continue krecv src
+              ($call procedure? (x)))))
+    (build-term
+      ($continue kcall src ($prim 'procedure?)))))
+
 (define (lower-primcalls cps)
   (with-fresh-name-state cps
     (persistent-intmap

module/language/cps/type-fold.scm

@@ -1,5 +1,5 @@
 ;;; Abstract constant folding on CPS
-;;; Copyright (C) 2014-2020 Free Software Foundation, Inc.
+;;; Copyright (C) 2014-2020, 2023 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
@@ -142,17 +142,27 @@
    (else (values #f #f))))
 
 ;; All the cases that are in compile-bytecode.
-(define-unary-type-predicate-folder fixnum? &fixnum)
 (define-unary-type-predicate-folder bignum? &bignum)
-(define-unary-type-predicate-folder pair? &pair)
-(define-unary-type-predicate-folder symbol? &symbol)
-(define-unary-type-predicate-folder variable? &box)
-(define-unary-type-predicate-folder mutable-vector? &mutable-vector)
-(define-unary-type-predicate-folder immutable-vector? &immutable-vector)
-(define-unary-type-predicate-folder struct? &struct)
-(define-unary-type-predicate-folder string? &string)
-(define-unary-type-predicate-folder number? &number)
+(define-unary-type-predicate-folder bitvector? &bitvector)
+(define-unary-type-predicate-folder bytevector? &bytevector)
 (define-unary-type-predicate-folder char? &char)
+(define-unary-type-predicate-folder compnum? &complex)
+(define-unary-type-predicate-folder fixnum? &fixnum)
+(define-unary-type-predicate-folder flonum? &flonum)
+(define-unary-type-predicate-folder fluid? &fluid)
+(define-unary-type-predicate-folder fracnum? &fraction)
+(define-unary-type-predicate-folder immutable-vector? &immutable-vector)
+(define-unary-type-predicate-folder keyword? &keyword)
+(define-unary-type-predicate-folder mutable-vector? &mutable-vector)
+(define-unary-type-predicate-folder number? &number)
+(define-unary-type-predicate-folder pair? &pair)
+(define-unary-type-predicate-folder pointer? &pointer)
+(define-unary-type-predicate-folder program? &procedure)
+(define-unary-type-predicate-folder string? &string)
+(define-unary-type-predicate-folder struct? &struct)
+(define-unary-type-predicate-folder symbol? &symbol)
+(define-unary-type-predicate-folder syntax? &syntax)
+(define-unary-type-predicate-folder variable? &box)
 
 (define-unary-branch-folder (vector? type min max)
   (cond
@@ -160,6 +170,13 @@
    ((type<=? type &vector) (values #t #t))
    (else (values #f #f))))
 
+(define-unary-branch-folder (procedure? type min max)
+  (define applicable-types (logior &procedure &struct &other-heap-object))
+  (cond
+   ((zero? (logand type applicable-types)) (values #t #f))
+   ((= type &procedure) (values #t #t))
+   (else (values #f #f))))
+
 (define-binary-branch-folder (eq? type0 min0 max0 type1 min1 max1)
   (cond
    ((or (zero? (logand type0 type1)) (< max0 min1) (< max1 min0))

module/language/cps/types.scm

@@ -679,22 +679,35 @@ minimum, and maximum."
                     (logand (&type val) (lognot type)))))
       (restrict! val type -inf.0 +inf.0))))
 
-(define-simple-predicate-inferrer pair? &pair)
-(define-simple-predicate-inferrer symbol? &symbol)
-(define-simple-predicate-inferrer variable? &box)
-(define-simple-predicate-inferrer immutable-vector? &immutable-vector)
-(define-simple-predicate-inferrer mutable-vector? &mutable-vector)
-(define-simple-predicate-inferrer struct? &struct)
-(define-simple-predicate-inferrer string? &string)
-(define-simple-predicate-inferrer bytevector? &bytevector)
+(define-simple-predicate-inferrer bignum? &bignum)
 (define-simple-predicate-inferrer bitvector? &bitvector)
-(define-simple-predicate-inferrer keyword? &keyword)
-(define-simple-predicate-inferrer number? &number)
+(define-simple-predicate-inferrer bytevector? &bytevector)
 (define-simple-predicate-inferrer char? &char)
-(define-simple-predicate-inferrer procedure? &procedure)
-(define-simple-predicate-inferrer flonum? &flonum)
 (define-simple-predicate-inferrer compnum? &complex)
+(define-simple-predicate-inferrer flonum? &flonum)
+(define-simple-predicate-inferrer fixnum? &fixnum)
+(define-simple-predicate-inferrer fluid? &fluid)
 (define-simple-predicate-inferrer fracnum? &fraction)
+(define-simple-predicate-inferrer immutable-vector? &immutable-vector)
+(define-simple-predicate-inferrer keyword? &keyword)
+(define-simple-predicate-inferrer mutable-vector? &mutable-vector)
+(define-simple-predicate-inferrer number? &number)
+(define-simple-predicate-inferrer pair? &pair)
+(define-simple-predicate-inferrer pointer? &pointer)
+(define-simple-predicate-inferrer program? &procedure)
+(define-simple-predicate-inferrer string? &string)
+(define-simple-predicate-inferrer struct? &struct)
+(define-simple-predicate-inferrer symbol? &symbol)
+(define-simple-predicate-inferrer syntax? &syntax)
+(define-simple-predicate-inferrer variable? &box)
+
+(define-predicate-inferrer (procedure? val true?)
+  ;; Besides proper procedures, structs and smobs can also be applicable
+  ;; in the guile-vm target.
+  (define applicable-types (logior &procedure &struct &other-heap-object))
+  (when true?
+    (restrict! val (logand (&type val) applicable-types)
+               (&min val) (&max val))))
 
 (define-predicate-inferrer (vector? val true?)
   (define &not-vector (logand &all-types (lognot &vector)))

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

@@ -191,3 +191,5 @@
 (define-branching-primitive < 2)
 (define-branching-primitive <= 2)
 (define-branching-primitive = 2)
+
+(define-branching-primitive procedure? 1)