[Chicken-hackers] [PATCH] add special case in specialization for list-ref/list-tail

[Felix]

The attached patch adds special cases for list-ref and list-tail
to the scrutinizer to obtain more precise result-type information
when the index argument is a constant (and the list argument
is of a known fixed-length list type).

>From 7daa568aa21234ee823d5b6339a0be6446a1d241 Mon Sep 17 00:00:00 2001
From: felix <address@hidden>
Date: Thu, 15 Dec 2011 08:19:38 +0100
Subject: [PATCH] scrutiny: add special cases for result types of
 list-ref/list-tail

---
 scrutinizer.scm |   36 ++++++++++++++++++++++++++++++++++++
 types.db        |    1 +
 2 files changed, 37 insertions(+), 0 deletions(-)

diff --git a/scrutinizer.scm b/scrutinizer.scm
index 2f8ed8f..a3e2ad4 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -2147,6 +2147,42 @@
   (define-special-case vector-ref vector-ref-result-type)
   (define-special-case ##sys#vector-ref vector-ref-result-type))
 
+(let ()
+  (define (list-ref-result-type node args rtypes)
+    (or (let ((subs (node-subexpressions node))
+             (arg1 (second args)))
+         (and (pair? arg1)
+              (eq? 'list (car arg1))
+              (= (length subs) 3)
+              (let ((index (third subs)))
+                (and (eq? 'quote (node-class index))
+                     (let ((val (first (node-parameters index))))
+                       (and (fixnum? val)
+                            (>= val 0) (< val (length (cdr arg1))) ;XXX could 
warn on failure (but needs location)
+                            (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 (let ((subs (node-subexpressions node))
+             (arg1 (second args)))
+         (and (pair? arg1)
+              (eq? 'list (car arg1))
+              (= (length subs) 3)
+              (let ((index (third subs)))
+                (and (eq? 'quote (node-class index))
+                     (let ((val (first (node-parameters index))))
+                       (and (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-special-case list
   (lambda (node args rtypes)
     (if (null? (cdr args))
diff --git a/types.db b/types.db
index 06ad8af..0936869 100644
--- a/types.db
+++ b/types.db
@@ -163,6 +163,7 @@
              ((null) '0)
              ((list) (##core#inline "C_u_i_length" #(1))))
 
+;; these are special cased (see scrutinizer.scm)
 (list-tail (forall (a) (#(procedure #:clean #:enforce) list-tail ((list-of a) 
fixnum) (list-of a))))
 (list-ref (forall (a) (#(procedure #:clean #:enforce) list-ref ((list-of a) 
fixnum) a)))
 
-- 
1.7.6.msysgit.0