Hi hackers,
Here are some list-related scrutiny improvements. I started with pair
walking for the scrutinizer's special cases to fix #759 (patch #2),
which made adding special cases for drop & tail easy (#3). The other
special cases (#4, #5) are basically just improving result type accuracy
for make-list, make-vector and reverse, where possible.
The list-copy types.db fix (#1) speaks for itself, I think. Let me know
if anything looks off.
Cheers,
Evan
>From fd3de2653850806947de6461d3c1db332278e1fc Mon Sep 17 00:00:00 2001
From: Evan Hanson <ev...@foldling.org>
Date: Sat, 16 Aug 2014 16:16:29 +1200
Subject: [PATCH 1/5] Fix list-copy types.db entry to allow any argument type
list-copy accepts any argument type (returning non-pair arguments
unchanged), so its type should be a -> a. This also means it can be
marked pure, and improves the scrutinizer's accuracy on list-copy calls
since the argument type can be preserved as the result type.
---
tests/typematch-tests.scm | 3 +++
types.db | 2 +-
2 files changed, 4 insertions(+), 1 deletion(-)
diff --git a/tests/typematch-tests.scm b/tests/typematch-tests.scm
index bbd5a3c..6cbcc9a 100644
--- a/tests/typematch-tests.scm
+++ b/tests/typematch-tests.scm
@@ -263,6 +263,9 @@
(mx fixnum (##sys#vector-ref '#(1 2 3.4) 0))
(mx (vector fixnum float) (vector 1 2.3))
(mx (list fixnum float) (list 1 2.3))
+(mx (list fixnum float) (list-copy (list 1 2.3)))
+(mx (pair fixnum float) (list-copy (cons 1 2.3)))
+(mx fixnum (list-copy 1))
(: f1 (forall (a) ((list-of a) -> a)))
(define (f1 x) (car x))
diff --git a/types.db b/types.db
index 2621686..e5c0771 100644
--- a/types.db
+++ b/types.db
@@ -1924,7 +1924,7 @@
(last (#(procedure #:clean #:enforce) last (pair) *))
(last-pair (#(procedure #:clean #:enforce) last-pair (pair) *))
(length+ (#(procedure #:clean #:enforce) length+ (list) *))
-(list-copy (forall (a) (#(procedure #:clean #:enforce) list-copy ((list-of a))
(list-of a))))
+(list-copy (forall (a) (#(procedure #:pure) list-copy (a) a)))
(list-index (forall (a) (#(procedure #:enforce) list-index ((procedure (a
#!rest) *) (list-of a) #!rest list) *)))
(list-tabulate (forall (a) (#(procedure #:enforce) list-tabulate (fixnum
(procedure (fixnum) a)) (list-of a))))
(list= (#(procedure #:clean #:enforce) list= (#!optional (procedure (list
list) *) #!rest list) boolean)
--
1.7.10.4
>From 2f96ca6af2cfdb29b10dd00f656fa2a2f22f0e37 Mon Sep 17 00:00:00 2001
From: Evan Hanson <ev...@foldling.org>
Date: Sat, 16 Aug 2014 16:42:07 +1200
Subject: [PATCH 2/5] Walk nested pair types in special-cased scrutiny for
list-ref/list-tail
Also, remove the unused ##sys#list-ref alias and its special case.
Fixes #759.
---
library.scm | 1 -
scrutinizer.scm | 86 +++++++++++++++++++++++++++------------------
tests/typematch-tests.scm | 16 +++++++--
3 files changed, 65 insertions(+), 38 deletions(-)
diff --git a/library.scm b/library.scm
index 74980fb..fb85c86 100644
--- a/library.scm
+++ b/library.scm
@@ -4763,7 +4763,6 @@ EOF
(define ##sys#list? list?)
(define ##sys#null? null?)
(define ##sys#map-n map)
-(define ##sys#list-ref list-ref)
;;; Promises:
diff --git a/scrutinizer.scm b/scrutinizer.scm
index c437933..c756067 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -2232,42 +2232,60 @@
(define-special-case vector-ref vector-ref-result-type)
(define-special-case ##sys#vector-ref vector-ref-result-type))
+
+;;; List-related special cases
+;
+; Preserve known element types for list-ref, list-tail.
+
(let ()
- (define (list-ref-result-type node args rtypes)
- (or (and-let* ((subs (node-subexpressions node))
- ((= (length subs) 3))
- (arg1 (walked-result (second args)))
- ((pair? arg1))
- ((eq? 'list (car arg1)))
- (index (third subs))
- ((eq? 'quote (node-class index)))
- (val (first (node-parameters index)))
- ((fixnum? val))
- ((>= val 0)) ;XXX could warn on failure (but needs
location)
- ((< val (length (cdr arg1)))))
- (list (list-ref (cdr arg1) val)))
- rtypes))
- (define-special-case list-ref list-ref-result-type)
- (define-special-case ##sys#list-ref list-ref-result-type))
-(define-special-case list-tail
- (lambda (node args rtypes)
- (or (and-let* ((subs (node-subexpressions node))
- ((= (length subs) 3))
- (arg1 (walked-result (second args)))
- ((pair? arg1))
- ((eq? 'list (car arg1)))
- (index (third subs))
- ((eq? 'quote (node-class index)))
- (val (first (node-parameters index)))
- ((fixnum? val))
- ((>= val 0))
- ((<= val (length (cdr arg1))))) ;XXX could warn on
failure (but needs location)
- (let ((rest (list-tail (cdr arg1) val)))
- (list (if (null? rest)
- 'null
- `(list ,@rest)))))
- rtypes)))
+ (define (list-or-null a)
+ (if (null? a) 'null `(list ,@a)))
+
+ ;; Split a list or pair type form at index i, calling k with the two
+ ;; sections of the type or returning #f if it doesn't match that far.
+ (define (split-list-type l i k)
+ (cond ((not (pair? l))
+ (and (fx= i 0) (eq? l 'null) (k l l)))
+ ((eq? (first l) 'list)
+ (and (fx< i (length l))
+ (receive (left right) (split-at (cdr l) i)
+ (k (list-or-null left)
+ (list-or-null right)))))
+ ((eq? (first l) 'pair)
+ (let lp ((a '()) (l l) (i i))
+ (cond ((fx= i 0)
+ (k (list-or-null (reverse a)) l))
+ ((and (pair? l)
+ (eq? (first l) 'pair))
+ (lp (cons (second l) a)
+ (third l)
+ (sub1 i)))
+ (else #f))))
+ (else #f)))
+
+ (define (list+index-call-result-type-special-case k)
+ (lambda (node args rtypes)
+ (or (and-let* ((subs (node-subexpressions node))
+ ((= (length subs) 3))
+ (arg1 (walked-result (second args)))
+ (index (third subs))
+ ((eq? 'quote (node-class index)))
+ (val (first (node-parameters index)))
+ ((fixnum? val))
+ ((>= val 0)))
+ (split-list-type arg1 val k))
+ rtypes)))
+
+ (define-special-case list-ref
+ (list+index-call-result-type-special-case
+ (lambda (_ result-type)
+ (and (pair? result-type)
+ (list (cadr result-type))))))
+
+ (define-special-case list-tail
+ (list+index-call-result-type-special-case
+ (lambda (_ result-type) (list result-type)))))
(define-special-case list
(lambda (node args rtypes)
diff --git a/tests/typematch-tests.scm b/tests/typematch-tests.scm
index 6cbcc9a..85ada83 100644
--- a/tests/typematch-tests.scm
+++ b/tests/typematch-tests.scm
@@ -49,9 +49,11 @@
(define-syntax mx
(syntax-rules ()
((_ t x)
- (compiler-typecase
- x
- (t 'ok)))))
+ (begin
+ (print 'x " = " 't)
+ (compiler-typecase
+ x
+ (t 'ok))))))
(define-syntax mn
(er-macro-transformer
@@ -266,6 +268,14 @@
(mx (list fixnum float) (list-copy (list 1 2.3)))
(mx (pair fixnum float) (list-copy (cons 1 2.3)))
(mx fixnum (list-copy 1))
+(mx fixnum (list-ref (list 1 2.3) 0))
+(mx fixnum (list-ref (cons 1 2.3) 0))
+(mx float (list-ref (list 1 2.3) 1))
+(mx (list fixnum float) (list-tail (list 1 2.3) 0))
+(mx (pair fixnum float) (list-tail (cons 1 2.3) 0))
+(mx (list float) (list-tail (list 1 2.3) 1))
+(mx float (list-tail (cons 1 2.3) 1))
+(mx null (list-tail (list 1 2.3) 2))
(: f1 (forall (a) ((list-of a) -> a)))
(define (f1 x) (car x))
--
1.7.10.4
>From 39844c1859d7fc5f22430f5dd136e393701757a3 Mon Sep 17 00:00:00 2001
From: Evan Hanson <ev...@foldling.org>
Date: Sun, 17 Aug 2014 13:10:43 +1200
Subject: [PATCH 3/5] Add scrutiny special cases for split-at, drop & take
This preserves the element types of pair and list arguments in the
result types for these procedures where possible, similarly to the
preexisting special cases for list-ref and list-tail.
---
scrutinizer.scm | 16 +++++++++++++++-
tests/typematch-tests.scm | 12 +++++++++++-
2 files changed, 26 insertions(+), 2 deletions(-)
diff --git a/scrutinizer.scm b/scrutinizer.scm
index c756067..6de343f 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -2235,7 +2235,9 @@
;;; List-related special cases
;
-; Preserve known element types for list-ref, list-tail.
+; Preserve known element types for:
+;
+; list-ref, list-tail, drop, take, split-at
(let ()
@@ -2285,6 +2287,18 @@
(define-special-case list-tail
(list+index-call-result-type-special-case
+ (lambda (_ result-type) (list result-type))))
+
+ (define-special-case split-at
+ (list+index-call-result-type-special-case
+ (lambda result-types (list result-types))))
+
+ (define-special-case take
+ (list+index-call-result-type-special-case
+ (lambda (result-type _) (list result-type))))
+
+ (define-special-case drop
+ (list+index-call-result-type-special-case
(lambda (_ result-type) (list result-type)))))
(define-special-case list
diff --git a/tests/typematch-tests.scm b/tests/typematch-tests.scm
index 85ada83..4051595 100644
--- a/tests/typematch-tests.scm
+++ b/tests/typematch-tests.scm
@@ -1,7 +1,7 @@
;;;; typematch-tests.scm
-(use lolevel data-structures)
+(use srfi-1 lolevel data-structures)
(define-syntax check
@@ -276,6 +276,16 @@
(mx (list float) (list-tail (list 1 2.3) 1))
(mx float (list-tail (cons 1 2.3) 1))
(mx null (list-tail (list 1 2.3) 2))
+(mx (list fixnum float) (drop (list 1 2.3) 0))
+(mx (pair fixnum float) (drop (cons 1 2.3) 0))
+(mx (list float) (drop (list 1 2.3) 1))
+(mx float (drop (cons 1 2.3) 1))
+(mx null (drop (list 1 2.3) 2))
+(mx null (take (list 1 2.3) 0))
+(mx null (take (cons 1 2.3) 0))
+(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))
(: f1 (forall (a) ((list-of a) -> a)))
(define (f1 x) (car x))
--
1.7.10.4
>From b62a8ce2b2a9c405c06acce60866ad3684f61bd0 Mon Sep 17 00:00:00 2001
From: Evan Hanson <ev...@foldling.org>
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
>From 39b3649176042897f91942eec5eb67d9690f4c6c Mon Sep 17 00:00:00 2001
From: Evan Hanson <ev...@foldling.org>
Date: Sat, 6 Sep 2014 09:10:18 +1200
Subject: [PATCH 5/5] Add scrutiny special case for reverse and specialization
for null argument
This preserves the element types of list- and null-type arguments to
reverse in its result type (rather than the less specialized list-of).
---
scrutinizer.scm | 9 +++++++++
tests/typematch-tests.scm | 4 ++++
types.db | 4 +++-
3 files changed, 16 insertions(+), 1 deletion(-)
diff --git a/scrutinizer.scm b/scrutinizer.scm
index d1690b6..1261f8c 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -2322,6 +2322,15 @@
(lambda (node args rtypes)
`((vector ,@(map walked-result (cdr args))))))
+(define-special-case reverse
+ (lambda (node args rtypes)
+ (or (and-let* ((subs (node-subexpressions node))
+ ((= (length subs) 2))
+ (arg1 (walked-result (second args)))
+ ((pair? arg1))
+ ((eq? (car arg1) 'list)))
+ `((list ,@(reverse (cdr arg1)))))
+ rtypes)))
;;; Special cases for make-list/make-vector with a known size
;
diff --git a/tests/typematch-tests.scm b/tests/typematch-tests.scm
index 4374337..930362f 100644
--- a/tests/typematch-tests.scm
+++ b/tests/typematch-tests.scm
@@ -290,6 +290,10 @@
(mx (list string string) (make-list 2 "a"))
(mx (vector * *) (make-vector 2))
(mx (vector string string) (make-vector 2 "a"))
+(mx null (reverse '()))
+(mx list (reverse (the list (list 1 "2"))))
+(mx (list string fixnum) (reverse (list 1 "2")))
+(mx (list fixnum string) (reverse (cons "1" (cons 2 '()))))
(: f1 (forall (a) ((list-of a) -> a)))
(define (f1 x) (car x))
diff --git a/types.db b/types.db
index 76e2a85..b554ace 100644
--- a/types.db
+++ b/types.db
@@ -170,7 +170,9 @@
(append (#(procedure #:clean) append (#!rest *) *)) ; sic
(##sys#append (#(procedure #:clean) ##sys#append (#!rest *) *))
-(reverse (forall (a) (#(procedure #:clean #:enforce) reverse ((list-of a))
(list-of a))))
+;; special cased (see scrutinizer.scm)
+(reverse (forall (a) (#(procedure #:clean #:enforce) reverse ((list-of a))
(list-of a)))
+ ((null) (null) (let ((#(tmp) #(1))) '())))
(memq (forall (a b) (#(procedure #:clean) memq (a (list-of b)) (or false
(list-of b))))
((* list) (##core#inline "C_u_i_memq" #(1) #(2))))
--
1.7.10.4
_______________________________________________
Chicken-hackers mailing list
Chicken-hackers@nongnu.org
https://lists.nongnu.org/mailman/listinfo/chicken-hackers
