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

@@ -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)

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? 'pair?)
+  (test-implies 'k:list-pair? 'list?)
-    (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
+(test-comp '(lambda (z)
-           '(lambda (z)
               (when (and (list? z)
                          (pair? z))
                 (k:list-pair? 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? 0 #f)
+  (test-reduce 'list? ''())
-    (test-reduce 'list? ''())
+  (test-reduce 'list? ''(1))
-    (test-reduce 'list? ''(1))
+  (test-reduce 'list? ''(1 2))
-    (test-reduce 'list? ''(1 2))
+  #;(test-reduce 'list? ''(1 . 2) #f)
-    #;(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 2))))
-    (test-reduce 'list? '(cdr (list 1))))
+  (test-reduce 'list? '(cdr (list 1)))
 
   (test-reduce 'null? 0 #f)
   (test-reduce 'null? ''())

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)))

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()

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)

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])

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))