From a982d6b0ea9bd520d7287be4299dac8f7c336ff2 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 28 Aug 2024 07:46:31 -0600 Subject: [PATCH] Chez Scheme: improve support for lists in cptypes (#858) Move `list` form the normalptr slot to the multiplet slot. In particular, this allows the reduction of (lambda (x f) (unless (list-assuming-immutable? x) (f) (list-assuming-immutable? x))) `pair`s are split in `list-pairs` and `nonlist-pairs`. A `pair` may go from one classification to the other, so the internal representations of the `list?` predicate use both of them or neither. Co-authored-by: Gustavo Massaccesi --- mats/cptypes.ms | 64 +++++++++++++++++++++++++++++--------------- s/cptypes-lattice.ss | 60 ++++++++++++++++++++--------------------- s/cptypes.ss | 12 ++++----- 3 files changed, 78 insertions(+), 58 deletions(-) diff --git a/mats/cptypes.ms b/mats/cptypes.ms index 520157c90..2ac5d6a82 100644 --- a/mats/cptypes.ms +++ b/mats/cptypes.ms @@ -234,18 +234,6 @@ (cptypes/once-equivalent-expansion? '(lambda (x) (when (fixnum? x) (zero? x) 7)) '(lambda (x) (when (fixnum? x) 7))) - (cptypes-equivalent-expansion? - '(lambda (x f) (when (list-assuming-immutable? x) (f x) (list-assuming-immutable? x))) - '(lambda (x f) (when (list-assuming-immutable? x) (f x) #t))) - (not (cptypes-equivalent-expansion? - '(lambda (x f) (when (list? x) (f x) (unless (list? x) 1))) - '(lambda (x f) (when (list? x) (f x) (unless (list? x) 2))))) - (cptypes-equivalent-expansion? - '(lambda (f) (define x '(1 2 3)) (f x) (list-assuming-immutable? x)) - '(lambda (f) (define x '(1 2 3)) (f x) #t)) - (cptypes-equivalent-expansion? - '(lambda () (define x '(1 2 3)) (pair? x)) - '(lambda () (define x '(1 2 3)) #t)) ) (mat cptypes-type-if @@ -666,7 +654,6 @@ (test-chain* '(record? #3%$record?)) (test-chain* '((lambda (x) (eq? x car)) procedure?)) (test-chain* '(record-type-descriptor? #3%$record?)) - (test-chain* '(null? list-assuming-immutable? list? (lambda (x) (or (null? x) (pair? x))))) (test-disjoint '(pair? box? #3%$record? number? vector? string? bytevector? fxvector? symbol? char? boolean? null? (lambda (x) (eq? x (void))) @@ -680,11 +667,6 @@ (test-disjoint '(integer? ratnum?)) (test-disjoint '((lambda (x) (eq? x 'banana)) (lambda (x) (eq? x 'apple)))) (test-disjoint* '(list? record? vector?)) - (not (test-disjoint* '(list? null?))) - (not (test-disjoint* '(list? pair?))) - (not (test-disjoint* '(list-assuming-immutable? null?))) - (not (test-disjoint* '(list-assuming-immutable? pair?))) - (not (test-disjoint* '(list-assuming-immutable? list?))) ) ; use a gensym to make expansions equivalent @@ -812,18 +794,56 @@ ) (mat cptypes-lists + (test-chain '(null? list-assuming-immutable? (lambda (x) (or (null? x) (pair? x))))) + (test-chain* '(null? list? (lambda (x) (or (null? x) (pair? x))))) + (cptypes-equivalent-expansion? + '(lambda (x f) (when (list-assuming-immutable? x) (f) (list-assuming-immutable? x))) + '(lambda (x f) (when (list-assuming-immutable? x) (f) #t))) + (cptypes-equivalent-expansion? + '(lambda (x f) (unless (list-assuming-immutable? x) (f) (list-assuming-immutable? x))) + '(lambda (x f) (unless (list-assuming-immutable? x) (f) #f))) + (not (cptypes-equivalent-expansion? + '(lambda (x f) (when (list? x) (f) (list? x))) + '(lambda (x f) (when (list? x) (f) #t)))) + (not (cptypes-equivalent-expansion? + '(lambda (x f) (unless (list? x) (f) (list? x))) + '(lambda (x f) (unless (list? x) (f) #f)))) + (test-disjoint '(null? pair?)) + (not (test-disjoint* '(list? null?))) + (not (test-disjoint* '(list? pair?))) + (not (test-disjoint* '(list-assuming-immutable? null?))) + (not (test-disjoint* '(list-assuming-immutable? pair?))) + (not (test-disjoint* '(list-assuming-immutable? list?))) (cptypes-equivalent-expansion? - '(lambda (x) (when (list-assuming-immutable? x) (list? (cdr x)))) + '(lambda (x) (when (list-assuming-immutable? x) (list-assuming-immutable? (cdr x)))) '(lambda (x) (when (list-assuming-immutable? x) (cdr x) #t))) (cptypes-equivalent-expansion? - '(lambda (x) (when (and (list-assuming-immutable? x) (pair? x)) (list? (cdr x)))) + '(lambda (x) (when (and (list-assuming-immutable? x) (pair? x)) (list-assuming-immutable? (cdr x)))) '(lambda (x) (when (and (list-assuming-immutable? x) (pair? x)) #t))) (cptypes-equivalent-expansion? - '(lambda (x) (when (list-assuming-immutable? x) (list? (cdr (error 'e ""))))) + '(lambda (x) (when (list-assuming-immutable? x) (list-assuming-immutable? (cdr (error 'e ""))))) '(lambda (x) (when (list-assuming-immutable? x) (error 'e "")))) (cptypes-equivalent-expansion? - '(lambda (x) (when (vector? x) (list? (#2%cdr x)) 1)) + '(lambda (x) (when (vector? x) (list-assuming-immutable? (#2%cdr x)) 1)) '(lambda (x) (when (vector? x) (#2%cdr x)))) + (cptypes-equivalent-expansion? + '(lambda (f) (define x '(1 2 3)) (f x) (list-assuming-immutable? x)) + '(lambda (f) (define x '(1 2 3)) (f x) #t)) + (cptypes-equivalent-expansion? + '(lambda () (define x '(1 2 3)) (pair? x)) + '(lambda () (define x '(1 2 3)) #t)) + (cptypes-equivalent-expansion? + '(lambda (x) (when (vector? x) (#2%list->vector x) 1)) + '(lambda (x) (when (vector? x) (#2%list->vector x) 2))) + (cptypes-equivalent-expansion? + '(lambda (x) (unless (or (null? x) (pair? x)) (#2%list->vector x) 1)) + '(lambda (x) (unless (or (null? x) (pair? x)) (#2%list->vector x) 2))) + (cptypes-equivalent-expansion? + '(lambda (x f) (#2%list->vector x) (f) (or (null? x) (pair? x))) + '(lambda (x f) (#2%list->vector x) (f) #t)) + (not (cptypes-equivalent-expansion? + '(lambda (x f) (list->vector x) (f) (list? x)) + '(lambda (x f) (list->vector x) (f) #t))) ) (mat cptypes-unsafe diff --git a/s/cptypes-lattice.ss b/s/cptypes-lattice.ss index 26d63bb4f..b96d2dd87 100644 --- a/s/cptypes-lattice.ss +++ b/s/cptypes-lattice.ss @@ -68,6 +68,8 @@ flzero-pred $fixmediate-pred $list-pred ; immutable lists + list-pair-pred + pair-pred box-pred vector*-pred vector-pred @@ -263,7 +265,8 @@ char-pred symbol-pred interned-symbol-pred uninterned-symbol-pred gensym-pred box-pred - fxvector*-pred flvector*-pred bytevector*-pred string*-pred vector*-pred) + fxvector*-pred flvector*-pred bytevector*-pred string*-pred vector*-pred + list-pair-pred nonlist-pair-pred) (define exact-complex-mask #b0000000000000001) (define ratnum-mask #b0000000000000010) @@ -285,9 +288,13 @@ (define flvector*-mask #b0100000000000000) (define box-mask #b1000000000000000) + ; These two are trickier, because they are not constant properties. + (define list-pair-mask #b010000000000000000) + (define nonlist-pair-mask #b100000000000000000) + (define number*-pred-mask #b0000000000111111) (define symbol-pred-mask #b0000001110000000) - (define multiplet-pred-mask #b1111111111111111) ; for the check in is-ptr? + (define multiplet-pred-mask #b111111111111111111) ; for the check in is-ptr? (define flonum-pred-mask (fxior flonum*-mask flinteger*-mask flzero-mask)) (define flinteger-pred-mask (fxior flinteger*-mask flzero-mask)) @@ -343,6 +350,8 @@ (define fxvector*-pred (make-pred-multiplet fxvector*-mask)) (define flvector*-pred (make-pred-multiplet flvector*-mask)) (define box-pred (make-pred-multiplet box-mask)) + (define list-pair-pred (make-pred-multiplet list-pair-mask)) + (define nonlist-pair-pred (make-pred-multiplet nonlist-pair-mask)) (define multiplet-pred (make-pred-multiplet multiplet-pred-mask)) ) @@ -440,9 +449,9 @@ [(pair? name) (cond [(equal? name '(ptr . ptr)) - 'pair] + pair-pred] [else - (if (not extend?) 'bottom 'pair)])] + (if (not extend?) 'bottom pair-pred)])] [else (let ([r (do-primref-name/nqm->predicate name extend?)]) (cond @@ -469,11 +478,19 @@ [bwp-object bwp-rec] [$immediate immediate-pred] - [pair 'pair] + [pair pair-pred] [maybe-pair maybe-pair-pred] - [list (cons $list-pred null-or-pair-pred)] + [char/pair (predicate-union char-pred pair-pred)] [list-assuming-immutable $list-pred] - [char/pair (predicate-union char-pred 'pair)] + [list + (cons null-rec null-or-pair-pred)] ; Very conservative to avoid problems with mutations. + [(sub-list list-of-string-pairs list-of-symbols) + (cons 'bottom null-or-pair-pred)] + [void/list + (cons (predicate-union void-rec null-rec) (predicate-union void-rec null-or-pair-pred))] + [symbol/list + (cons (predicate-union symbol-pred null-rec) (predicate-union symbol-pred null-or-pair-pred))] + [box box-pred] [immutable-box (cons 'bottom box-pred)] [mutable-box (cons 'bottom box-pred)] @@ -694,16 +711,7 @@ (predicate-union/multiplet x y) 'normalptr)] [else - (case y - [(pair $list-pair) - (cond - [(or (eq? x 'pair) - (eq? x '$list-pair)) - 'pair] - [else - 'normalptr])] - [else - 'normalptr])])) + 'normalptr])) (define (predicate-union/exact-integer x y) (or (cond @@ -879,16 +887,7 @@ (predicate-intersect/multiplet x y) 'bottom)] [else - (case y - [(pair $list-pair) - (cond - [(or (eq? x 'pair) - (eq? x '$list-pair)) - '$list-pair] - [else - 'bottom])] - [else - 'bottom])])) + 'bottom])) (define (predicate-intersect/exact-integer x y) (cond @@ -1439,9 +1438,10 @@ (define true-pred (make-pred-or true-singleton-pred multiplet-pred 'normalptr 'exact-integer '$record)) (define immediate-pred (predicate-union immediate*-pred char-pred)) (define $fixmediate-pred (predicate-union immediate-pred 'fixnum)) - (define maybe-pair-pred (maybe 'pair)) - (define null-or-pair-pred (predicate-union null-rec 'pair)) - (define $list-pred (predicate-union null-rec '$list-pair)) + (define pair-pred (predicate-union list-pair-pred nonlist-pair-pred)) + (define maybe-pair-pred (maybe pair-pred)) + (define null-or-pair-pred (predicate-union null-rec pair-pred)) + (define $list-pred (predicate-union null-rec list-pair-pred)) (define maybe-fixnum-pred (maybe 'fixnum)) (define eof/fixnum-pred (eof/ 'fixnum)) (define maybe-exact-integer-pred (maybe 'exact-integer)) diff --git a/s/cptypes.ss b/s/cptypes.ss index 1936eff71..5c8f8639d 100644 --- a/s/cptypes.ss +++ b/s/cptypes.ss @@ -572,8 +572,8 @@ Notes: (cond [(#3%$record? d) '$record] ;check first to avoid double representation of rtd [(okay-to-copy? d) ir] - [(list? d) '$list-pair] ; quoted list should not be modified. - [(pair? d) 'pair] + [(list? d) list-pair-pred] ; quoted list should not be modified. + [(pair? d) pair-pred] [(box? d) box-pred] [(vector? d) vector*-pred] [(string? d) string*-pred] @@ -1069,12 +1069,12 @@ Notes: (define-specialize 2 list [() (values null-rec null-rec ntypes #f #f)] ; should have been reduced by cp0 - [e* (values `(call ,preinfo ,pr ,e* ...) 'pair ntypes #f #f)]) + [e* (values `(call ,preinfo ,pr ,e* ...) pair-pred ntypes #f #f)]) (define-specialize 2 cdr [(v) (values `(call ,preinfo ,pr ,v) (cond - [(predicate-implies? (predicate-intersect (get-type v) 'pair) '$list-pair) + [(predicate-implies? (predicate-intersect (get-type v) pair-pred) list-pair-pred) $list-pred] [else ptr-pred]) @@ -1515,7 +1515,7 @@ Notes: (define (cut-r* r* n) (let loop ([i n] [r* r*]) (if (fx= i 0) - (list (if (null? r*) null-rec 'pair)) + (list (if (null? r*) null-rec pair-pred)) (cons (car r*) (loop (fx- i 1) (cdr r*)))))) (let*-values ([(ntypes e* r* t* t-t* f-t*) (map-Expr/delayed e* oldtypes plxc)]) @@ -1909,7 +1909,7 @@ Notes: [(immutable-list (,[e* 'value types plxc -> e* r* t* t-t* f-t*] ...) ,[e 'value types plxc -> e ret types t-types f-types]) (values `(immutable-list (,e* ...) ,e) - (if (null? e*) null-rec '$list-pair) types #f #f)] + (if (null? e*) null-rec $list-pred) types #f #f)] [(immutable-vector (,[e* 'value types plxc -> e* r* t* t-t* f-t*] ...) ,[e 'value types plxc -> e ret types t-types f-types]) (values `(immutable-vector (,e* ...) ,e)