>From b62a8ce2b2a9c405c06acce60866ad3684f61bd0 Mon Sep 17 00:00:00 2001
From: Evan Hanson <address@hidden>
Date: Sun, 17 Aug 2014 18:36:21 +1200
Subject: [PATCH 4/5] Add scrutiny special cases for make-list/make-vector
 with known sizes

---
 scrutinizer.scm           |   32 +++++++++++++++++++++++++++++++-
 tests/typematch-tests.scm |    4 ++++
 types.db                  |    2 ++
 3 files changed, 37 insertions(+), 1 deletion(-)

diff --git a/scrutinizer.scm b/scrutinizer.scm
index 6de343f..d1690b6 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -110,6 +110,7 @@
 (define-constant +fragment-max-length+ 6)
 (define-constant +fragment-max-depth+ 4)
 (define-constant +maximal-union-type-length+ 20)
+(define-constant +maximal-complex-object-constructor-result-type-length+ 256)
 
 
 (define specialization-statistics '())
@@ -2322,6 +2323,34 @@
     `((vector ,@(map walked-result (cdr args))))))
 
 
+;;; Special cases for make-list/make-vector with a known size
+;
+; e.g. (make-list 3 #\a) => (list char char char)
+
+(let ()
+
+  (define (complex-object-constructor-result-type-special-case type)
+    (lambda (node args rtypes)
+      (or (and-let* ((subs (node-subexpressions node))
+		     (fill (case (length subs)
+			     ((2) '*)
+			     ((3) (walked-result (third args)))
+			     (else #f)))
+		     (sub2 (second subs))
+		     ((eq? 'quote (node-class sub2)))
+		     (size (first (node-parameters sub2)))
+		     ((fixnum? size))
+		     ((<= 0 size +maximal-complex-object-constructor-result-type-length+)))
+	    `((,type ,@(make-list size fill))))
+	  rtypes)))
+
+  (define-special-case make-list
+    (complex-object-constructor-result-type-special-case 'list))
+
+  (define-special-case make-vector
+    (complex-object-constructor-result-type-special-case 'vector)))
+
+
 ;;; perform check over all typevar instantiations
 
 (define (over-all-instantiations tlist typeenv exact process)
@@ -2365,7 +2394,8 @@
 
     (ddd " over-all-instantiations: ~s exact=~a" tlist exact)
     ;; process all tlist elements
-    (let loop ((ts tlist) (ok #f))
+    (let loop ((ts (delete-duplicates tlist equal?))
+	       (ok #f))
       (cond ((null? ts)
 	     (cond ((or ok (null? tlist))
 		    (for-each 
diff --git a/tests/typematch-tests.scm b/tests/typematch-tests.scm
index 4051595..4374337 100644
--- a/tests/typematch-tests.scm
+++ b/tests/typematch-tests.scm
@@ -286,6 +286,10 @@
 (mx (list fixnum) (take (list 1 2.3) 1))
 (mx (list fixnum) (take (cons 1 2.3) 1))
 (mx (list fixnum float) (take (list 1 2.3) 2))
+(mx (list * *) (make-list 2))
+(mx (list string string) (make-list 2 "a"))
+(mx (vector * *) (make-vector 2))
+(mx (vector string string) (make-vector 2 "a"))
 
 (: f1 (forall (a) ((list-of a) -> a)))
 (define (f1 x) (car x))
diff --git a/types.db b/types.db
index e5c0771..76e2a85 100644
--- a/types.db
+++ b/types.db
@@ -561,6 +561,7 @@
 
 (vector? (#(procedure #:pure #:predicate vector) vector? (*) boolean))
 
+;; special-cased (see scrutinizer.scm)
 (make-vector (forall (a) (#(procedure #:clean #:enforce) make-vector (fixnum #!optional a) 
 			  (vector-of a))))
 
@@ -1993,6 +1994,7 @@
  ((procedure) (let ((#(tmp) #(1))) '#t))
  ((procedure list) (let ((#(tmp1) #(1)) (#(tmp2) #(2))) '#t)))
 
+;; special-cased (see scrutinizer.scm)
 (make-list (forall (a) (#(procedure #:clean #:enforce) make-list (fixnum #!optional a) (list-of a))))
 
 (map!
-- 
1.7.10.4