This is an automated email from the git hooks/post-receive script.
wingo pushed a commit to branch main
in repository guile.
The following commit(s) were added to refs/heads/main by this push:
new c0715e090 Recognize procedure? as a CPS primitive
c0715e090 is described below
commit c0715e09033de4697013e5ddc62ab06296d1ae82
Author: Andy Wingo <wi...@pobox.com>
AuthorDate: Tue Sep 12 14:00:57 2023 +0200
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 | 42 ++++++++++++++----------
module/language/cps/guile-vm/lower-primcalls.scm | 15 +++++++++
module/language/cps/type-fold.scm | 33 ++++++++++++++-----
module/language/cps/types.scm | 37 ++++++++++++++-------
module/language/tree-il/cps-primitives.scm | 2 ++
5 files changed, 91 insertions(+), 38 deletions(-)
diff --git a/module/language/cps/effects-analysis.scm
b/module/language/cps/effects-analysis.scm
index c82dc9d0e..bd7c03239 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/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))
+ ((bignum? arg))
+ ((bitvector? arg))
+ ((bytevector? arg))
((char? arg))
+ ((compnum? arg))
((eq-constant? arg))
- ((undefined? arg))
- ((null? arg))
((false? arg))
- ((nil? arg))
+ ((fixnum? arg))
+ ((flonum? arg))
+ ((fluid? arg))
+ ((fracnum? arg))
+ ((heap-number? arg))
((heap-object? arg))
- ((pair? arg))
- ((symbol? arg))
- ((variable? arg))
- ((vector? arg))
- ((struct? arg))
- ((string? arg))
- ((number? arg))
- ((bytevector? arg))
+ ((immutable-vector? arg))
((keyword? arg))
- ((bitvector? 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))
- ((heap-number? arg))
- ((bignum? arg))
- ((flonum? arg))
- ((compnum? arg))
- ((fracnum? arg)))
+ ((undefined? arg))
+ ((variable? arg))
+ ((vector? arg)))
;; Fluids.
(define-primitive-effects
diff --git a/module/language/cps/guile-vm/lower-primcalls.scm
b/module/language/cps/guile-vm/lower-primcalls.scm
index 5a46c87c3..3072bb7bf 100644
--- a/module/language/cps/guile-vm/lower-primcalls.scm
+++ b/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
diff --git a/module/language/cps/type-fold.scm
b/module/language/cps/type-fold.scm
index e09cc6966..f030c41e4 100644
--- a/module/language/cps/type-fold.scm
+++ b/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 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-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 char? &char)
(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))
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 095b4f7e2..f33d07492 100644
--- a/module/language/cps/types.scm
+++ b/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 ¬-vector (logand &all-types (lognot &vector)))
diff --git a/module/language/tree-il/cps-primitives.scm
b/module/language/tree-il/cps-primitives.scm
index ab16653ae..380ebb48f 100644
--- a/module/language/tree-il/cps-primitives.scm
+++ b/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)
