[Chicken-hackers] [PATCH] fix handling of assignment in different flow when scrutinizing

[Felix]

The attached patch fixes a problem with the flow-analysis of assignments
in the scrutinizer (as reported by Joerg): The analysis keeps track of
the current flow using a list of integers, where each integer identifiers
a particular flow. Entering a conditional branch, for example, will push
a new identifer on the list, so for the example Joerg gave, we would have:
                        
(define (write-blob-to-sql sql identifier last blob c-c)  ; Flow:
 (define ins '())                                         ; (1)
 (define del '())                                         ; (1)
 (if (vector? blob)                                       ; (1)
     (begin                                               ; (2 1)
        (set! ins (vector-ref blob 1))                    ; (2 1)
        (set! del (vector-ref blob 2))                    ; (2 1)
        (set! blob (vector-ref blob 0))))                 ; (2 1)
                                                          ; [else-branch would 
be (3 1)
                                                          ;  but is empty here]
 (if (or (pair? ins)                                      ; (1)
         (pair? del))                                     ; (1) [actually 
nested cond.]
     (<handle-ins-and-del>))                              ; (4 1) ...
 (<do-some-more>))                                        ; (1)

A variable can have different types assigned for each flow, which will
be stored in the so-called "blist" as a "((<VARIABLE> . <FLOWTAG>)
. <TYPE>)" associatione, where "<FLOWTAG>", the topmost flow-number.
The assignments above add blist entries for "ins", "del" and "blob",
but didn't also change any existing blist entries. In the example
above, "ins" and "del" have blist entries for tag 1, then entries for
the assignment in the conditional are added. But when the control-flow
leaves the conditional, the old blist entries are still there holding
"null" as type. This never caused a problem since assignments where
generally handled conservatively, but the recent change of doing so
only for captured variables made this bug appear.

What the patch does is destructively modifying existing blist entries
for a variable that match the complete current flow (e.g. all tags),
merging the old and new types, so "ins" and "del" will be changed for
all flows (and all later execution in the same flow).


cheers,
felix

>From 12162bf7c5a6a8cdeacd97aee6753af34485eaad Mon Sep 17 00:00:00 2001
From: felix <address@hidden>
Date: Tue, 14 Feb 2012 13:15:28 +0100
Subject: [PATCH] possible fix for flow-analysis bug reported by JW: assignment 
now also destructively modifies blist entries for all sub- (outer) flows

---
 scrutinizer.scm          |   28 ++++++++++++++++++----------
 tests/scrutiny-tests.scm |   19 +++++++++++++++++++
 tests/scrutiny.expected  |    2 +-
 3 files changed, 38 insertions(+), 11 deletions(-)

diff --git a/scrutinizer.scm b/scrutinizer.scm
index bb5ea06..332ed2e 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -456,8 +456,8 @@
            (class (node-class n)) )
        (dd "walk: ~a ~s (loc: ~a, dest: ~a, tail: ~a, flow: ~a)"
            class params loc dest tail flow)
-       ;;(dd "walk: ~a ~s (loc: ~a, dest: ~a, tail: ~a, flow: ~a, blist: ~a, 
e: ~a)"
-       ;;    class params loc dest tail flow blist e)
+       #;(dd "walk: ~a ~s (loc: ~a, dest: ~a, tail: ~a, flow: ~a, blist: ~a, 
e: ~a)"
+           class params loc dest tail flow blist e)
        (set! d-depth (add1 d-depth))
        (let ((results
               (case class
@@ -639,14 +639,22 @@
                                    var ot rt)
                                  #t)))))
                      ;; don't use "add-to-blist" since the current operation 
does not affect aliases
-                     (set! blist
-                       (alist-cons
-                        (cons var (car flow)) 
-                        (if (or strict-variable-types
-                                (not (get db var 'captured)))
-                            rt 
-                            '*)
-                        blist)))
+                     (let ((t (if (or strict-variable-types
+                                      (not (get db var 'captured)))
+                                  rt 
+                                  '*))
+                           (fl (car flow)))
+                       (let loop ((bl blist) (f #f))
+                         (cond ((null? bl)
+                                (unless f
+                                  (set! blist (alist-cons (cons var fl) t 
blist))))
+                               ((eq? (caaar bl) var)
+                                (let ((t (simplify-type `(or ,t ,(cdar bl)))))
+                                  (dd "assignment modifies blist entry ~s -> 
~a"
+                                      (caar bl) t)
+                                  (set-cdr! (car bl) t)
+                                  (loop (cdr bl) (eq? fl (cdaar bl)))))
+                               (else (loop (cdr bl) f))))))
                    '(undefined)))
                 ((##core#primitive ##core#inline_ref) '*)
                 ((##core#call)
diff --git a/tests/scrutiny-tests.scm b/tests/scrutiny-tests.scm
index 42c3b27..717ad7f 100644
--- a/tests/scrutiny-tests.scm
+++ b/tests/scrutiny-tests.scm
@@ -109,3 +109,22 @@
   (the * (values 1 2))                         ; 1 + 2
   (the * (values))                             ; 3
   (the fixnum (* x y)))                                ; nothing (but warns 
about "x" being string)
+
+
+;; Reported by Joerg Wittenberger:
+;
+; - assignment inside first conditional does not invalidate blist
+;;  entries for "ins"/"del" in outer flow.
+
+(define (write-blob-to-sql sql identifier last blob c-c)
+ (define ins '())
+ (define del '())
+ (if (vector? blob)
+     (begin
+       (set! ins (vector-ref blob 1))
+       (set! del (vector-ref blob 2))
+       (set! blob (vector-ref blob 0))))
+ (if (or (pair? ins)
+        (pair? del))
+     (<handle-ins-and-del>))
+ (<do-some-more>))
diff --git a/tests/scrutiny.expected b/tests/scrutiny.expected
index 0848f36..31eeb2b 100644
--- a/tests/scrutiny.expected
+++ b/tests/scrutiny.expected
@@ -37,7 +37,7 @@ Warning: at toplevel:
   (scrutiny-tests.scm:28) in procedure call to `+', expected argument #2 of 
type `number', but was given an argument of type `symbol'
 
 Warning: at toplevel:
-  assignment of value of type `fixnum' to toplevel variable `car' does not 
match declared type `(forall (a105) (procedure car ((pair a105 *)) a105))'
+  assignment of value of type `fixnum' to toplevel variable `car' does not 
match declared type `(forall (a123) (procedure car ((pair a123 *)) a123))'
 
 Warning: at toplevel:
   expected in `let' binding of `g8' a single result, but were given 2 results
-- 
1.6.0.4