diff options
Diffstat (limited to 'module/language')
-rw-r--r-- | module/language/cps/effects-analysis.scm | 42 | ||||
-rw-r--r-- | module/language/cps/guile-vm/lower-primcalls.scm | 15 | ||||
-rw-r--r-- | module/language/cps/type-fold.scm | 33 | ||||
-rw-r--r-- | module/language/cps/types.scm | 37 | ||||
-rw-r--r-- | 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) |