From 3952355d3012fefb0e7986f72cb6688ebebf1606 Mon Sep 17 00:00:00 2001 From: Gustavo Massaccesi Date: Mon, 15 Mar 2021 14:21:33 -0300 Subject: [PATCH] Chez Scheme: add suport for lists in cptypes With list-assuming-immutable? and the internal construct immutable-list the compiler can assume that some lists will not be mutated. Also, change the definition of interned-char?, because in CS all chars are interned. --- pkgs/racket-test-core/tests/racket/basic.rktl | 2 +- .../tests/racket/optimize.rktl | 37 +++++++++++-------- racket/src/ChezScheme/mats/cptypes.ms | 31 ++++++++++++++++ racket/src/ChezScheme/s/cptypes-lattice.ss | 19 +++++++++- racket/src/ChezScheme/s/cptypes.ss | 14 ++++++- racket/src/ChezScheme/s/primdata.ss | 2 +- racket/src/cs/rumble/char.ss | 2 +- 7 files changed, 87 insertions(+), 20 deletions(-) diff --git a/pkgs/racket-test-core/tests/racket/basic.rktl b/pkgs/racket-test-core/tests/racket/basic.rktl index c3676f8350..89b00bd1b8 100644 --- a/pkgs/racket-test-core/tests/racket/basic.rktl +++ b/pkgs/racket-test-core/tests/racket/basic.rktl @@ -540,7 +540,7 @@ (test #t k:interned-char? #\() (test #t k:interned-char? #\ ) (test #t k:interned-char? '#\newline) - (test #f k:interned-char? #\u100) + (test (not (eq? 'chez-scheme (system-type 'vm))) k:interned-char? #\u100) (test #f k:interned-char? 7) (test #f k:interned-char? #t) (test #f k:interned-char? #t) diff --git a/pkgs/racket-test-core/tests/racket/optimize.rktl b/pkgs/racket-test-core/tests/racket/optimize.rktl index 9b319fc013..7dcb3d2e68 100644 --- a/pkgs/racket-test-core/tests/racket/optimize.rktl +++ b/pkgs/racket-test-core/tests/racket/optimize.rktl @@ -2680,6 +2680,10 @@ (let ([test-implies (lambda (pred1 pred2 [val '=>]) + (test-comp `(lambda (z) (when (,pred1 z) (,pred1 z))) + `(lambda (z) (when (,pred1 z) #t))) + (test-comp `(lambda (z) (when (,pred2 z) (,pred2 z))) + `(lambda (z) (when (,pred2 z) #t))) (cond [(eq? val '=>) (test-comp `(lambda (z) (when (,pred1 z) (,pred2 z))) @@ -2690,6 +2694,11 @@ (test-comp `(lambda (z) (when (,pred2 z) (,pred1 z))) `(lambda (z) (when (,pred2 z) #f)) #f)] + [(eq? val '=) + (test-comp `(lambda (z) (when (,pred1 z) (,pred2 z))) + `(lambda (z) (when (,pred1 z) #t))) + (test-comp `(lambda (z) (when (,pred2 z) (,pred1 z))) + `(lambda (z) (when (,pred2 z) #t)))] [(eq? val '!=) (test-comp `(lambda (z) (when (,pred1 z) (,pred2 z))) `(lambda (z) (when (,pred1 z) #f))) @@ -2714,17 +2723,15 @@ (test-implies 'null? 'k:list-pair? '!=) (test-implies 'null? 'pair? '!=) (test-implies 'null? 'list?) - (unless (eq? 'chez-scheme (system-type 'vm)) - (test-implies 'k:list-pair? 'pair?) - (test-implies 'k:list-pair? 'list?)) + (test-implies 'k:list-pair? 'pair?) + (test-implies 'k:list-pair? 'list?) (test-implies 'list? 'pair? '?) - (test-implies 'k:interned-char? 'char?) + (test-implies 'k:interned-char? 'char? (if (eq? 'chez-scheme (system-type 'vm)) '= '=>)) (test-implies 'not 'boolean?) (test-implies 'k:true-object? 'boolean?) ) -(test-comp #:except 'chez-scheme ; list-pair? is not primitive enough for cptypes - '(lambda (z) +(test-comp '(lambda (z) (when (and (list? z) (pair? z)) (k:list-pair? z))) @@ -2732,7 +2739,7 @@ (when (and (list? z) (pair? z)) #t))) -(test-comp #:except 'chez-scheme +(test-comp #:except 'chez-scheme '(lambda (z) (when (and (list? z) (not (null? z))) @@ -2787,20 +2794,20 @@ `(let ([e ,expr]) (list ',pred-name e e ,val))))]) - (unless (eq? 'chez-scheme (system-type 'vm)) ; cptypes doesn't yet specialize `list?` - (test-reduce 'list? 0 #f) - (test-reduce 'list? ''()) - (test-reduce 'list? ''(1)) - (test-reduce 'list? ''(1 2)) - #;(test-reduce 'list? ''(1 . 2) #f) + (test-reduce 'list? 0 #f) + (test-reduce 'list? ''()) + (test-reduce 'list? ''(1)) + (test-reduce 'list? ''(1 2)) + #;(test-reduce 'list? ''(1 . 2) #f) + (unless (eq? 'chez-scheme (system-type 'vm)) ; cptypes doesn't yet consider (list ...) as immutable (test-reduce 'list? '(list)) (test-reduce 'list? '(list 1)) (test-reduce 'list? '(list 1 2)) #;(test-reduce 'list? '(cons 1 2) #f) (test-reduce 'list? '(cons 1 null)) (test-reduce 'list? '(cons 1 (list 2 3))) - (test-reduce 'list? '(cdr (list 1 2))) - (test-reduce 'list? '(cdr (list 1)))) + (test-reduce 'list? '(cdr (list 1 2)))) + (test-reduce 'list? '(cdr (list 1))) (test-reduce 'null? 0 #f) (test-reduce 'null? ''()) diff --git a/racket/src/ChezScheme/mats/cptypes.ms b/racket/src/ChezScheme/mats/cptypes.ms index a78a0abee1..d4cccf60d9 100644 --- a/racket/src/ChezScheme/mats/cptypes.ms +++ b/racket/src/ChezScheme/mats/cptypes.ms @@ -210,6 +210,18 @@ (cptypes-equivalent-expansion? '(lambda (x) (when (and (fixnum? x) (zero? x)) x)) '(lambda (x) (when (and (fixnum? x) (zero? x)) 0))) + (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 @@ -572,6 +584,7 @@ (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))) @@ -584,6 +597,9 @@ (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 @@ -710,6 +726,21 @@ (lambda (x) #f)))) ) +(mat cptypes-lists + (cptypes-equivalent-expansion? + '(lambda (x) (when (list-assuming-immutable? x) (list? (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)) #t))) + (cptypes-equivalent-expansion? + '(lambda (x) (when (list-assuming-immutable? x) (list? (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) (#2%cdr x)))) +) + (mat cptypes-unsafe (cptypes-equivalent-expansion? '(lambda (x) (when (pair? x) (car x))) diff --git a/racket/src/ChezScheme/s/cptypes-lattice.ss b/racket/src/ChezScheme/s/cptypes-lattice.ss index 9f588138da..08ad09ca9b 100644 --- a/racket/src/ChezScheme/s/cptypes-lattice.ss +++ b/racket/src/ChezScheme/s/cptypes-lattice.ss @@ -34,6 +34,7 @@ maybe-char-pred maybe-symbol-pred $fixmediate-pred + $list-pred ; immutable lists true-pred ; anything that is not #f true-rec ; only the #t object false-rec @@ -76,6 +77,7 @@ (define true-pred (make-pred-or 'true-immediate 'normalptr '$record)) (define ptr-pred (make-pred-or 'immediate 'normalptr '$record)) (define null-or-pair-pred (make-pred-or null-rec 'pair 'bottom)) + (define $list-pred (make-pred-or null-rec '$list-pair 'bottom)) (define $fixmediate-pred (make-pred-or 'immediate 'fixnum 'bottom)) (define maybe-fixnum-pred (make-pred-or false-rec 'fixnum 'bottom)) (define eof/fixnum-pred (make-pred-or eof-rec 'fixnum 'bottom)) @@ -214,7 +216,8 @@ [pair 'pair] [maybe-pair maybe-pair-pred] - [(list list-assume-immutable) (cons null-rec null-or-pair-pred)] + [list (cons $list-pred null-or-pair-pred)] + [list-assuming-immutable $list-pred] [box 'box] [vector 'vector] [string 'string] @@ -568,6 +571,13 @@ (union/symbol x interned-symbol? 'interned-symbol)] [(symbol) (union/symbol x symbol? 'symbol)] + [(pair $list-pair) + (cond + [(or (eq? x 'pair) + (eq? x '$list-pair)) + 'pair] + [else + 'normalptr])] [(vector) (union/simple x vector? y)]; i.e. #() [(string) (union/simple x string? y)]; i.e. "" [(bytevector) (union/simple x bytevector? y)] ; i.e. '#vu8() @@ -886,6 +896,13 @@ x] [else 'bottom])] + [(pair $list-pair) + (cond + [(or (eq? x 'pair) + (eq? x '$list-pair)) + '$list-pair] + [else + 'bottom])] [(vector) (intersect/simple x vector? 'vector y)]; i.e. #() [(string) (intersect/simple x string? 'string y)]; i.e. "" [(bytevector) (intersect/simple x bytevector? 'bytevector y)] ; i.e. '#vu8() diff --git a/racket/src/ChezScheme/s/cptypes.ss b/racket/src/ChezScheme/s/cptypes.ss index 4383bc01ea..dafc026f8f 100644 --- a/racket/src/ChezScheme/s/cptypes.ss +++ b/racket/src/ChezScheme/s/cptypes.ss @@ -530,6 +530,7 @@ Notes: [(#3%$record? d) '$record] ;check first to avoid double representation of rtd [(okay-to-copy? d) ir] [(and (integer? d) (exact? d)) 'exact-integer] + [(list? d) '$list-pair] ; quoted list should not be modified. [(pair? d) 'pair] [(box? d) 'box] [(vector? d) 'vector] @@ -846,6 +847,17 @@ Notes: [() (values null-rec null-rec ntypes #f #f)] ; should have been reduced by cp0 [e* (values `(call ,preinfo ,pr ,e* ...) 'pair ntypes #f #f)]) + (define-specialize 2 cdr + [(v) (values `(call ,preinfo ,pr ,v) + (cond + [(predicate-implies? ret 'bottom) + ret] + [(predicate-implies? (predicate-intersect (get-type v) 'pair) '$list-pair) + $list-pred] + [else + ptr-pred]) + ntypes #f #f)]) + (define-specialize 2 $record [(rtd . e*) (values `(call ,preinfo ,pr ,rtd ,e* ...) (rtd->record-predicate rtd #t) ntypes #f #f)]) @@ -1634,7 +1646,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) - ret types #f #f)] + (if (null? e*) null-rec '$list-pair) types #f #f)] [(moi) (values ir #f types #f #f)] [(pariah) (values ir void-rec types #f #f)] [(cte-optimization-loc ,box ,[e 'value types plxc -> e ret types t-types f-types] ,exts) diff --git a/racket/src/ChezScheme/s/primdata.ss b/racket/src/ChezScheme/s/primdata.ss index 628c89f161..410dd45208 100644 --- a/racket/src/ChezScheme/s/primdata.ss +++ b/racket/src/ChezScheme/s/primdata.ss @@ -257,7 +257,7 @@ (cons [sig [(ptr ptr) -> (#1=(ptr . ptr))]] [flags unrestricted alloc ieee r5rs]) ; c..r non-alphabetic so marks come before references (car [sig [(#1#) -> (ptr)]] [flags mifoldable discard cp02 safeongoodargs ieee r5rs]) - (cdr [sig [(#1#) -> (ptr)]] [flags mifoldable discard cp02 safeongoodargs ieee r5rs]) + (cdr [sig [(#1#) -> (ptr)]] [flags mifoldable discard cp02 cptypes2 safeongoodargs ieee r5rs]) (caar [sig [(#2=(#1# . ptr)) -> (ptr)]] [flags mifoldable discard ieee r5rs]) (cdar [sig [(#2#) -> (ptr)]] [flags mifoldable discard ieee r5rs]) (cadr [sig [(#3=(ptr . #1#)) -> (ptr)]] [flags mifoldable discard ieee r5rs]) diff --git a/racket/src/cs/rumble/char.ss b/racket/src/cs/rumble/char.ss index ac330d1dc9..b5882bf5cf 100644 --- a/racket/src/cs/rumble/char.ss +++ b/racket/src/cs/rumble/char.ss @@ -29,7 +29,7 @@ (and (#%memq (#%char-general-category x) '(Sm Sc Sk So)) #t)) (define (interned-char? v) - (and (char? v) (< (char->integer v) 256))) + (char? v)) (define (char-general-category ch) (or (with-global-lock* (getprop (#%char-general-category ch) 'downcase #f))