[Chicken-hackers] [PATCH] Flow-analysis enhancement for assigned variables

[Felix]

Hello!

The attached patch adds slight improvements to the flow analysis pass
done by the scrutinizer:

1) Variables that are assigned now retain that type-information unless
   they are not captured (previously all assigned variables where
   assumed to be of unknown type), this is still control-flow
   sensitive, so it /should/ do the right thing with respect to
   conditionals

2) Matching of complex list/pair types has been improved by
   "canonicalizing" such types into a form more suitable for
   type-matching (type-analysis of list/pair types turns out to be
   rather hairy, because "list" covers a rather broad selection of
   possible values and the same type can have many different
   representations)

I tested this change a good deal but scrutinizer-changes are always
very subtle and the behaviour of the flow-analysis is highly dependent
on the style of the code being compiled, so this may turn up bugs.


cheers,
felix

>From 7bdb20b12f70e6938612fbb5f7d5fbe96702d22d Mon Sep 17 00:00:00 2001
From: felix <address@hidden>
Date: Fri, 20 Jan 2012 09:20:49 +0100
Subject: [PATCH] Squashed commit of the following:

commit a5c646137f73e31aa92bc576eea9dae02397550f
Author: felix <address@hidden>
Date:   Fri Jan 20 09:20:07 2012 +0100

    disabled debug output for scrutinizer

commit d605271870a12f49e9e3d3e951c52388e0e44bea
Author: felix <address@hidden>
Date:   Fri Dec 30 13:01:59 2011 +0100

    updated expected output for 2nd scrutiny test

commit 059738feaa75789ccbf0b172753a636ccee42178
Author: felix <address@hidden>
Date:   Wed Dec 21 23:16:50 2011 +0100

    FA: invalidate blist entries only for captured variables; canonicalize 
pair/list types prior to matching with list-of type; pounding on matching to 
not make it too strict or too loose
---
 compiler-namespace.scm     |    1 +
 scrutinizer.scm            |   92 ++++++++++++++++++++++++--------------------
 tests/scrutiny-2.expected  |    4 --
 tests/scrutiny-tests-2.scm |    4 +-
 tests/scrutiny.expected    |    6 +++
 5 files changed, 59 insertions(+), 48 deletions(-)

diff --git a/compiler-namespace.scm b/compiler-namespace.scm
index 679f024..6e3c85e 100644
--- a/compiler-namespace.scm
+++ b/compiler-namespace.scm
@@ -42,6 +42,7 @@
  build-node-graph
  c-ify-string
  callback-names
+ canonicalize-list-of-type
  canonicalize-begin-body
  canonicalize-expression
  check-and-open-input-file
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 69682a0..50f7b54 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -643,8 +643,7 @@
                        (alist-cons
                         (cons var (car flow)) 
                         (if (or strict-variable-types
-                                ;;XXX needs to be tested more but might be 
worth it
-                                #;(not (get db var 'captured)))
+                                (not (get db var 'captured)))
                             rt 
                             '*)
                         blist)))
@@ -1095,8 +1094,10 @@
                (pair? t2)
                (case (car t2)
                  ((list-of)
-                  (and (match1 (second t1) (second t2))
-                       (match1 (third t1) t2)))
+                  (let ((ct1 (canonicalize-list-of-type t1)))
+                    (if ct1
+                        (match1 ct1 t2)
+                        #t)))          ; inexact match
                  ((list)
                   (and (match1 (second t1) (second t2))
                        (match1 (third t1)
@@ -1108,9 +1109,10 @@
           (and (pair? t1)
                (case (car t1)
                  ((list-of)
-                  (and ;(not exact)
-                       (match1 (second t1) (second t2))
-                       (match1 t1 (third t2))))
+                  (let ((ct2 (canonicalize-list-of-type t2)))
+                    (if ct2
+                        (match1 t1 ct2)
+                        (and (not exact) (not all))))) ; inexact mode: ok
                  ((list)
                   (and (match1 (second t1) (second t2))
                        (match1 (if (null? (cdr t1))
@@ -1121,15 +1123,9 @@
          ((and (pair? t1) (eq? 'list-of (car t1)))
           (or (eq? 'null t2)
               (and (pair? t2)
-                   (case (car t2)
-                     ((pair)
-                      (and (match1 (second t1) (second t2))
-                           (match1 t1 (third t2))))
-                     ((list)
-                      (match1 
-                       (second t1) 
-                       (simplify-type `(or ,@(cdr t2)))))
-                     (else #f)))))
+                   (memq (car t2) '(pair list))
+                   (let ((ct2 (canonicalize-list-of-type t2)))
+                     (and ct2 (match1 t1 ct2))))))
          ((and (pair? t1) (eq? 'list (car t1)))
           (and (pair? t2)
                (case (car t2)
@@ -1139,23 +1135,16 @@
                        (match1 t1 (third t2))))
                  ((list-of)
                   (and (not exact) (not all)                   
-                       (match1 
-                        (simplify-type `(or ,@(cdr t1)))
-                        (second t2))))
+                       (let ((ct2 (canonicalize-list-of-type t2)))
+                         (and ct2 (match1 t1 ct2)))))
                  (else #f))))
          ((and (pair? t2) (eq? 'list-of (car t2)))
-          (and (not exact)
+          (and (not exact)             ;XXX also check "all"?
                (or (eq? 'null t1)
                    (and (pair? t1)
-                        (case (car t1)
-                          ((pair)
-                           (and (match1 (second t1) (second t2))
-                                (match1 (third t1) t2)))
-                          ((list)
-                           (match1 
-                            (simplify-type `(or ,@(cdr t1)))
-                            (second t2)))
-                          (else #f))))))
+                        (memq (car t1) '(pair list))
+                        (let ((ct1 (canonicalize-list-of-type t1)))
+                          (and ct1 (match1 ct1 t2)))))))
          ((and (pair? t2) (eq? 'list (car t2)))
           (and (pair? t1)
                (case (car t1)
@@ -1165,9 +1154,8 @@
                        (match1 (third t1) t2)))
                  ((list-of)
                   (and (not exact) (not all)
-                       (match1
-                        (second t1)
-                        (simplify-type `(or ,@(cdr t2))))))
+                       (let ((ct1 (canonicalize-list-of-type t1)))
+                         (and ct1 (match1 ct1 t2)))))
                  (else #f))))
          ((and (pair? t1) (eq? 'vector (car t1)))
           (and (not exact) (not all)
@@ -1303,16 +1291,9 @@
                         (tcdr (simplify (third t))))
                     (if (and (eq? '* tcar) (eq? '* tcdr))
                         'pair
-                        (let rec ((tr tcdr) (ts (list tcar)))
-                          (cond ((eq? 'null tr)
-                                 `(list-of ,(simplify `(or ,@ts))))
-                                ((and (pair? tr) (eq? 'pair (first tr)))
-                                 (rec (third tr) (cons (second tr) ts)))
-                                ((and (pair? tr) (eq? 'list (first tr)))
-                                 `(list-of ,(simplify `(or ,@ts ,@(cdr tr)))))
-                                ((and (pair? tr) (eq? 'list-of (first tr)))
-                                 `(list-of ,(simplify-type `(or ,@(reverse ts) 
,@(cdr tr)))))
-                                (else `(pair ,tcar ,tcdr)))))))
+                        (let ((t `(pair ,tcar ,tcdr)))
+                          (or (canonicalize-list-of-type t)
+                              t)))))
                  ((vector-of)
                   (let ((t2 (simplify (second t))))
                     (if (eq? t2 '*)
@@ -2113,6 +2094,33 @@
        specs)))
 
 
+;;; Canonicalize complex pair/list type for matching with "list-of"
+;
+; - returns #f if not possibly matchable with "list-of"
+
+(define (canonicalize-list-of-type t)
+  (cond ((not (pair? t)) t)
+       ((eq? 'pair (car t))
+        (let ((tcar (second t))
+              (tcdr (third t)))
+          (let rec ((tr tcdr) (ts (list tcar)))
+            (cond ((eq? 'null tr)
+                   `(list-of ,(simplify-type `(or ,@ts))))
+                  ((eq? 'list tr) tr)
+                  ((and (pair? tr) (eq? 'pair (first tr)))
+                   (rec (third tr) (cons (second tr) ts)))
+                  ((and (pair? tr) (eq? 'list (first tr)))
+                   `(list-of ,(simplify-type `(or ,@ts ,@(cdr tr)))))
+                  ((and (pair? tr) (eq? 'list-of (first tr)))
+                   `(list-of 
+                     ,(simplify-type
+                       `(or ,@(reverse ts) ,@(cdr tr)))))
+                  (else #f)))))
+       ((eq? 'list (car t)) 
+        `(list-of ,(simplify-type `(or ,@(cdr t)))))
+       (else t)))
+
+
 ;;; hardcoded result types for certain primitives
 
 (define-syntax define-special-case
diff --git a/tests/scrutiny-2.expected b/tests/scrutiny-2.expected
index 55f6602..0946260 100644
--- a/tests/scrutiny-2.expected
+++ b/tests/scrutiny-2.expected
@@ -41,10 +41,6 @@ Note: at toplevel:
 
 Note: at toplevel:
   in procedure call to `null?', the predicate is called with an argument of 
type
-  `pair' and will always return false
-
-Note: at toplevel:
-  in procedure call to `null?', the predicate is called with an argument of 
type
   `null' and will always return true
 
 Note: at toplevel:
diff --git a/tests/scrutiny-tests-2.scm b/tests/scrutiny-tests-2.scm
index 986c303..10dde75 100644
--- a/tests/scrutiny-tests-2.scm
+++ b/tests/scrutiny-tests-2.scm
@@ -18,8 +18,8 @@
       (f 12.3)
       (u (+ i f)))
   (predicate pair? (p) (l n i f))
-  (predicate list? (l) (p n i f))
-  (predicate null? (n) (p l i f))
+  (predicate list? (l n p) (i f))
+  (predicate null? (n l) (p i f))
   (predicate fixnum? (i) (f u))
   (predicate exact? (i) (f u))
   (predicate flonum? (f) (i u))
diff --git a/tests/scrutiny.expected b/tests/scrutiny.expected
index 2a24292..b77bedb 100644
--- a/tests/scrutiny.expected
+++ b/tests/scrutiny.expected
@@ -45,6 +45,12 @@ Warning: at toplevel:
 Warning: at toplevel:
   in procedure call to `g89', expected a value of type `(procedure () *)', but 
was given a value of type `fixnum'
 
+Note: in toplevel procedure `foo':
+  expected value of type boolean in conditional but were given a value of type
+  `(procedure bar29 () *)' which is always true:
+
+(if bar29 3 (##core#undefined))
+
 Warning: in toplevel procedure `foo2':
   scrutiny-tests.scm:57: in procedure call to `string-append', expected 
argument #1 of type `string', but was given an argument of type `number'
 
-- 
1.6.0.4