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 <gustavo@oma.org.ar>

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

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

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)