[Chicken-hackers] [PATCH] small scrutinizer enhancement

[Felix]

During flow-analysis, when a predicate is applied to a variable, the
variable is assumed to have the corresponding type in the consequent
branch of a conditional that depends on this predicate call. This
patch adds a small enhancement that, in case the variable type is
known to be a typeset (an "(or ...)" type), reduces the typeset by
removing those types that match the predicate-type:

(let ((a ...))  ; say "a" is of type "(or string number)"
  (if (number? a)
      ...           ; "a" is known to be of type "number"
      ...))         ; "a" is now known to be of type "string"  <- new

Here "number" matches the predicate type of "number?" ("number"),
is removed from the "(or string number)" type, and results in
type "string" for "a" in the second "if" branch.


cheers,
felix

>From b4c850ce70ca2036a7af686d35061c15f2c8539f Mon Sep 17 00:00:00 2001
From: felix <address@hidden>
Date: Fri, 12 Oct 2012 19:07:20 +0200
Subject: [PATCH] Reduce typeset in alternative conditional branch with 
predicate.

During flow-analysis, when a predicate is applied to a variable, the
variable is assumed to have the corresponding type in the consequent
branch of a conditional that depends on this predicate call. This
patch adds a small enhancement that, in case the variable type is
known to be a typeset (an "(or ...)" type), reduces the typeset by
removing those types that match the predicate-type:

(let ((a ...))  ; say "a" is of type "(or string number)"
  (if (number? a)
      ...           ; "a" is known to be of type "number"
      ...))         ; "a" is now known to be of type "string"  <- new

Here "number" matches the predicate type of "number?" ("number"),
is removed from the "(or string number)" type, and results in
type "string" for "a" in the second "if" branch.
---
 scrutinizer.scm            |   28 +++++++++++++++++++++++++++-
 tests/scrutiny-tests-3.scm |   19 +++++++++++++++++++
 2 files changed, 46 insertions(+), 1 deletions(-)

diff --git a/scrutinizer.scm b/scrutinizer.scm
index 3ed4753..b4f4b3d 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -447,6 +447,19 @@
                (make-list argc '*)))
          (make-list argc '*)))
 
+    (define (reduce-typeset t pt typeenv)
+      (and-let* ((tnew
+                 (let rec ((t t))
+                   (and (pair? t)
+                        (case (car t)
+                          ((forall) 
+                           (and-let* ((t2 (rec (third t))))
+                             `(forall ,(second t) ,t2)))
+                          ((or) 
+                           `(or ,@(remove (cut match-types <> pt typeenv) (cdr 
t))))
+                          (else #f))))))
+       (simplify-type tnew)))
+
     (define (walk n e loc dest tail flow ctags) ; returns result specifier
       (let ((subs (node-subexpressions n))
            (params (node-parameters n)) 
@@ -717,12 +730,25 @@
                                                    (not (get db var 
'assigned)) 
                                                    (not oparg?))))
                                    (cond (pred
+                                          ;;XXX is this needed? "typeenv" is 
the te of "args",
+                                          ;;    not of "pt":
                                           (let ((pt (resolve pt typeenv)))
                                             (d "  predicate `~a' indicates 
`~a' is ~a in flow ~a"
                                                pn var pt (car ctags))
                                             (add-to-blist 
                                              var (car ctags)
-                                             (if (and a (type<=? (cdr a) pt)) 
(cdr a) pt))))
+                                             (if (and a (type<=? (cdr a) pt)) 
(cdr a) pt))
+                                            ;; if the variable type is an 
"or"-type, we can
+                                            ;; can remove all elements that 
match the predicate
+                                            ;; type
+                                            (when a
+                                              ;;XXX hack, again:
+                                              (let* ((tenv2 (type-typeenv `(or 
,(cdr a) ,pt)))
+                                                     (at (reduce-typeset (cdr 
a) pt tenv2)))
+                                                (when at
+                                                  (d "  predicate `~a' 
indicates `~a' is ~a in flow ~a"
+                                                     pn var at (cdr ctags))
+                                                  (add-to-blist var (cdr 
ctags) at))))))
                                          (a
                                           (when enforces
                                             (let ((ar (cond ((blist-type var 
flow) =>
diff --git a/tests/scrutiny-tests-3.scm b/tests/scrutiny-tests-3.scm
index 41b46fb..243a069 100644
--- a/tests/scrutiny-tests-3.scm
+++ b/tests/scrutiny-tests-3.scm
@@ -10,3 +10,22 @@
  (compiler-typecase vec
    ((vector-of boolean) #f)
    (vector #t)))
+
+
+;;; reduce OR-types in alternative branch of conditional with predicate
+
+(define something)
+
+(let ((x (the (or string number) something)))
+  (if (number? x)
+      (compiler-typecase x
+       (number 1))
+      (compiler-typecase x
+       (string 2))))
+
+(let ((x (the (forall ((a string) (b number)) (or a b)) something)))
+  (if (number? x)
+      (compiler-typecase x
+       (number 3))
+      (compiler-typecase x
+       (string 4))))
-- 
1.7.0.4