summaryrefslogtreecommitdiff
path: root/module/language
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2023-09-12 14:00:57 +0200
committerAndy Wingo <wingo@pobox.com>2023-09-12 14:00:57 +0200
commitc0715e09033de4697013e5ddc62ab06296d1ae82 (patch)
tree519d16f515d785fc98770b58b8723d580a7d0cb4 /module/language
parentb5bedf74ad796557f9a5c08c6afdb1ec6a5a78ab (diff)
downloadguile-c0715e09033de4697013e5ddc62ab06296d1ae82.tar.gz
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.
Diffstat (limited to 'module/language')
-rw-r--r--module/language/cps/effects-analysis.scm42
-rw-r--r--module/language/cps/guile-vm/lower-primcalls.scm15
-rw-r--r--module/language/cps/type-fold.scm33
-rw-r--r--module/language/cps/types.scm37
-rw-r--r--module/language/tree-il/cps-primitives.scm2
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 &not-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)