optimizer: add types for something->immutable-something

pkgs/racket-test-core/tests/racket/optimize.rktl

@@ -219,6 +219,7 @@
     (un #t 'keyword? '#:ok)
     (un #f 'keyword? #f)
     (un #t 'vector? (vector 1 2 3))
+    (un #t 'vector? (vector-immutable 1 2 3))
     (un #f 'vector? #f)
     (un #t 'box? (box 10))
     (un #f 'box? #f)
@@ -1287,6 +1288,8 @@
            '(lambda (w z) (random) (read) #t))
 (test-comp '(lambda (w z) (vector? (vector w z)))
            '(lambda (w z) #t))
+(test-comp '(lambda (w z) (vector? (vector-immutable w z)))
+           '(lambda (w z) #t))
 (test-comp '(lambda (w z) (vector? (list 1)))
            '(lambda (w z) #f))
 (test-comp '(lambda (w z) (mpair? (mcons 1 2)))
@@ -1326,10 +1329,6 @@
            '(lambda (x) (cdr x) (pair? x)))
 (test-comp '(lambda (x) (cadr x) #t)
            '(lambda (x) (cadr x) (pair? x)))
-(test-comp '(lambda (x) (vector-ref x 0) #t)
-           '(lambda (x) (vector-ref x 0) (vector? x)))
-(test-comp '(lambda (x) (vector-set! x 0 #t) #t)
-           '(lambda (x) (vector-set! x 0 #t) (vector? x)))
 (test-comp '(lambda (f) (procedure-arity-includes? f 5) #t)
            '(lambda (f) (procedure-arity-includes? f 5) (procedure? f)))
 (test-comp '(lambda (f l) (f l) #t)
@@ -1372,20 +1371,14 @@
               #;(display (primitive? map))
               (display (lambda (f l) (map f l) (procedure? f)))))
 
-(test-comp '(lambda (w z) (vector? (list->vector w)))
+;Test special cases of make-vector
-           '(lambda (w z) (list->vector w) #t))
-(test-comp '(lambda (w z) (vector? (struct->vector w)))
-           '(lambda (w z) (struct->vector w) #t))
-(test-comp '(lambda (w z) (vector? (struct->vector w z)))
-           '(lambda (w z) (struct->vector w z) #t))
-
 (test-comp '(lambda (w z) (vector? (make-vector (w) (z))))
            '(lambda (w z) (make-vector (w) (z)) #t))
 (test-comp '(lambda (w z) (vector? (make-vector (w))))
            '(lambda (w z) (make-vector (w)) #t))
 (test-comp '(lambda (w z) (vector? (make-vector 5 (z))))
            '(lambda (w z) (values (z)) #t))
-#;(test-comp '(lambda (w z) (vector? (make-vector 5 w)))
+(test-comp '(lambda (w z) (vector? (make-vector 5 w)))
            '(lambda (w z) #t))
 (test-comp '(lambda (w z) (vector? (make-vector 5)))
            '(lambda (w z) #t))
@@ -1396,6 +1389,34 @@
            '(lambda (w z) #t)
            #f)
 
+;Test types inference for vector?
+(test-comp '(lambda (v) (fixnum? (vector-length v)))
+           '(lambda (v) (vector-length v) #t))
+(test-comp '(lambda (v) (vector-length v) (vector? v))
+           '(lambda (v) (vector-length v) #t))
+(test-comp '(lambda (v) (vector->values v) (vector? v))
+           '(lambda (v) (vector->values v) #t))
+(test-comp '(lambda (v x) (vector-ref v x) #t)
+           '(lambda (v x) (vector-ref v x) (vector? v)))
+(test-comp '(lambda (v x) (vector-set! v x #t) #t)
+           '(lambda (v x) (vector-set! v x #t) (vector? v)))
+(test-comp '(lambda (l) (vector? (list->vector l)))
+           '(lambda (l) (list->vector l) #t))
+(test-comp '(lambda (l) (list->vector l) (list? l))
+           '(lambda (l) (list->vector l) #t))
+(test-comp '(lambda (v) (list? (vector->list v)))
+           '(lambda (v) (vector->list v) #t))
+(test-comp '(lambda (v) (vector->list v) (vector? v))
+           '(lambda (v) (vector->list v) #t))
+(test-comp '(lambda (s) (vector? (struct->vector s)))
+           '(lambda (s) (struct->vector s) #t))
+(test-comp '(lambda (s x) (vector? (struct->vector s x)))
+           '(lambda (s x) (struct->vector s x) #t))
+(test-comp '(lambda (v) (vector? (vector->immutable-vector v)))
+           '(lambda (v) (vector->immutable-vector v) #t))
+(test-comp '(lambda (v) (vector->immutable-vector v) (vector? v))
+           '(lambda (v) (vector->immutable-vector v) #t))
+
 ;Test types inference for string?
 (test-comp '(lambda (s) (fixnum? (string-length s)))
            '(lambda (s) (string-length s) #t))
@@ -1417,6 +1438,10 @@
            '(lambda (s1 s2) (string-append s1 s2) #t))
 (test-comp '(lambda (s1 s2 s3) (string? (string-append s1 s2 s3)))
            '(lambda (s1 s2 s3) (string-append s1 s2 s3) #t))
+(test-comp '(lambda (s) (string? (string->immutable-string s)))
+           '(lambda (s) (string->immutable-string s) #t))
+(test-comp '(lambda (s) (string->immutable-string s) (string? s))
+           '(lambda (s) (string->immutable-string s) #t))
 
 ;Test types inference for bytes?
 (test-comp '(lambda (s) (fixnum? (bytes-length s)))
@@ -1439,6 +1464,10 @@
            '(lambda (s1 s2) (bytes-append s1 s2) #t))
 (test-comp '(lambda (s1 s2 s3) (bytes? (bytes-append s1 s2 s3)))
            '(lambda (s1 s2 s3) (bytes-append s1 s2 s3) #t))
+(test-comp '(lambda (s) (bytes? (bytes->immutable-bytes s)))
+           '(lambda (s) (bytes->immutable-bytes s) #t))
+(test-comp '(lambda (s) (bytes->immutable-bytes s) (bytes? s))
+           '(lambda (s) (bytes->immutable-bytes s) #t))
 
 (test-comp '(lambda (w z)
               (let ([x (list* w z)]
@@ -2974,6 +3003,7 @@
   (test-pred 'mpair?)
   (test-pred 'list?)
   (test-pred 'k:list-pair?)
+  (test-pred 'vector?)
   (test-pred 'box?)
   (test-pred 'number?)
   (test-pred 'real?)

racket/src/racket/src/optimize.c

@@ -2644,15 +2644,20 @@ static Scheme_Object *rator_implies_predicate(Scheme_Object *rator, int argc)
     } else if (SAME_OBJ(rator, scheme_list_star_proc)) {
       if (argc > 2)
         return scheme_pair_p_proc;
-    } else if (IS_NAMED_PRIM(rator, "string-append")) {
+    } else if (IS_NAMED_PRIM(rator, "vector->list")) {
+      return scheme_list_p_proc;
+    } else if (IS_NAMED_PRIM(rator, "string-append")
+               || IS_NAMED_PRIM(rator, "string->immutable-string")) {
         return scheme_string_p_proc;
-    } else if (IS_NAMED_PRIM(rator, "bytes-append")) {
+    } else if (IS_NAMED_PRIM(rator, "bytes-append")
+               || IS_NAMED_PRIM(rator, "bytes->immutable-bytes")) {
         return scheme_byte_string_p_proc;
     } else if (SAME_OBJ(rator, scheme_vector_proc)
                || SAME_OBJ(rator, scheme_vector_immutable_proc)
                || SAME_OBJ(rator, scheme_make_vector_proc)
                || SAME_OBJ(rator, scheme_list_to_vector_proc)
-               || SAME_OBJ(rator, scheme_struct_to_vector_proc))
+               || SAME_OBJ(rator, scheme_struct_to_vector_proc)
+               || IS_NAMED_PRIM(rator, "vector->immutable-vector"))
       return scheme_vector_p_proc;
     else if (SAME_OBJ(rator, scheme_box_proc)
              || SAME_OBJ(rator, scheme_box_immutable_proc))
@@ -3184,7 +3189,7 @@ static int check_known_variant(Optimize_Info *info, Scheme_Object *app,
    rator implies a check, so add type information for subsequent
    expressions: the argument is consistent with `implies_pred` (which
    must be itself implied by `expected_pred`, but might be weaker). If
-   the rand has alredy an incompatible type, mark that this will
+   the rand has already an incompatible type, mark that this will
    generate an error. If unsafe is NULL then rator has no unsafe
    version, so only check the type. */
 {
@@ -3827,6 +3832,8 @@ static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimiz
 
       check_known(info, app_o, rator, rand, "string-append", scheme_string_p_proc, scheme_true);
       check_known(info, app_o, rator, rand, "bytes-append", scheme_byte_string_p_proc, scheme_true);
+      check_known(info, app_o, rator, rand, "string->immutable-string", scheme_string_p_proc, scheme_true);
+      check_known(info, app_o, rator, rand, "bytes->immutable-bytes", scheme_byte_string_p_proc, scheme_true);
 
       if (SCHEME_PRIM_PROC_OPT_FLAGS(rator) & SCHEME_PRIM_WANTS_REAL)
         check_known(info, app_o, rator, rand, NULL, scheme_real_p_proc,
@@ -3846,8 +3853,10 @@ static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimiz
       check_known(info, app_o, rator, rand, "cadddr", scheme_pair_p_proc, NULL);
       check_known(info, app_o, rator, rand, "cddddr", scheme_pair_p_proc, NULL);
 
+      check_known(info, app_o, rator, rand, "list->vector", scheme_list_p_proc, NULL);
       check_known(info, app_o, rator, rand, "vector->list", scheme_vector_p_proc, NULL);
       check_known(info, app_o, rator, rand, "vector->values", scheme_vector_p_proc, NULL);
+      check_known(info, app_o, rator, rand, "vector->immutable-vector", scheme_vector_p_proc, NULL);
       
       /* Some of these may have changed app->rator. */
       rator = app->rator;