[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Chicken-hackers] [PATCH 4/6] * scrutinizer.scm: Infer more exact types
|
From: |
megane |
|
Subject: |
[Chicken-hackers] [PATCH 4/6] * scrutinizer.scm: Infer more exact types after set! |
|
Date: |
Thu, 22 Aug 2019 14:51:26 +0300 |
|
User-agent: |
mu4e 1.0; emacs 25.1.1 |
Hi,
I'm working on some inference improvements and I noticed the blist keeps
accumulating some bogus entries. Commit 0003 removes some of those.
There's also a small improvement (0004).
>From abe8809647a0f6b64f37c1c512688f9368a42ab2 Mon Sep 17 00:00:00 2001
From: megane <address@hidden>
Date: Tue, 20 Aug 2019 11:16:57 +0300
Subject: [PATCH 1/6] * scrutinizer.scm (walk): Remove unused 'tail' parameter
---
scrutinizer.scm | 44 ++++++++++++++++++++++----------------------
1 file changed, 22 insertions(+), 22 deletions(-)
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 8f5923d5..c2aa147b 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -435,14 +435,14 @@
(make-list argc '*)))
(make-list argc '*)))
- (define (walk n e loc dest tail flow ctags) ; returns result specifier
+ (define (walk n e loc dest flow ctags) ; returns result specifier
(let ((subs (node-subexpressions n))
(params (node-parameters n))
(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, flow: ~a)"
+ class params loc dest flow)
+ #;(dd "walk: ~a ~s (loc: ~a, dest: ~a, flow: ~a, blist: ~a, e: ~a)"
+ class params loc dest flow blist e)
(set! d-depth (add1 d-depth))
(let ((results
(case class
@@ -460,7 +460,7 @@
(tst (first subs))
(nor-1 noreturn))
(set! noreturn #f)
- (let* ((rt (single (walk tst e loc #f #f flow tags)
+ (let* ((rt (single (walk tst e loc #f flow tags)
(cut r-conditional-value-count-invalid
loc n tst <>)))
(c (second subs))
(a (third subs))
@@ -469,16 +469,16 @@
((and (always-true n tst rt loc) specialize)
(set! dropped-branches (add1 dropped-branches))
(mutate-node! n `(let ((,(gensym) ,tst)) ,c))
- (walk n e loc dest tail flow ctags))
+ (walk n e loc dest flow ctags))
((and (always-false n tst rt loc) specialize)
(set! dropped-branches (add1 dropped-branches))
(mutate-node! n `(let ((,(gensym) ,tst)) ,a))
- (walk n e loc dest tail flow ctags))
+ (walk n e loc dest flow ctags))
(else
- (let* ((r1 (walk c e loc dest tail (cons (car tags)
flow) #f))
+ (let* ((r1 (walk c e loc dest (cons (car tags) flow)
#f))
(nor1 noreturn))
(set! noreturn #f)
- (let* ((r2 (walk a e loc dest tail (cons (cdr tags)
flow) #f))
+ (let* ((r2 (walk a e loc dest (cons (cdr tags) flow)
#f))
(nor2 noreturn))
(set! noreturn (or nor-1 nor0 (and nor1 nor2)))
;; when only one branch is noreturn, add blist
entries for
@@ -511,10 +511,10 @@
;; before CPS-conversion, `let'-nodes may have multiple
bindings
(let loop ((vars params) (body subs) (e2 '()))
(if (null? vars)
- (walk (car body) (append e2 e) loc dest tail flow ctags)
+ (walk (car body) (append e2 e) loc dest flow ctags)
(let* ((var (car vars))
(val (car body))
- (t (single (walk val e loc var #f flow #f)
+ (t (single (walk val e loc var flow #f)
(cut r-let-value-count-invalid loc
var n val <>))))
(when (and (eq? (node-class val) '##core#variable)
(not (db-get db var 'assigned)))
@@ -542,7 +542,7 @@
(r (walk (first subs)
(if rest (alist-cons rest 'list e2) e2)
(add-loc dest loc)
- #f #t (list initial-tag) #f)))
+ #f (list initial-tag) #f)))
#;(when (and specialize
dest
(variable-mark dest
'##compiler#type-source)
@@ -579,7 +579,7 @@
((set! ##core#set!)
(let* ((var (first params))
(type (variable-mark var '##compiler#type))
- (rt (single (walk (first subs) e loc var #f flow #f)
+ (rt (single (walk (first subs) e loc var flow #f)
(cut r-assignment-value-count-invalid
loc var n (first subs) <>)))
(typeenv (append
@@ -655,7 +655,7 @@
'##core#the/result
(list
(single
- (walk n2 e loc #f #f flow #f)
+ (walk n2 e loc #f flow #f)
(cut r-proc-call-argument-value-count
loc n i n2 <>)))
(list n2)))
subs
@@ -678,7 +678,7 @@
(smash-component-types! e "env")
(smash-component-types! blist "blist")))
(cond (specialized?
- (walk n e loc dest tail flow ctags)
+ (walk n e loc dest flow ctags)
(smash)
;; keep type, as the specialization may contain
icky stuff
;; like "##core#inline", etc.
@@ -686,7 +686,7 @@
r
(map (cut resolve <> typeenv) r)))
((eq? 'quote (node-class n)) ; Call got constant
folded
- (walk n e loc dest tail flow ctags))
+ (walk n e loc dest flow ctags))
(else
(for-each
(lambda (arg argr)
@@ -748,7 +748,7 @@
(map (cut resolve <> typeenv) r)))))))
((##core#the)
(let ((t (first params))
- (rt (walk (first subs) e loc dest tail flow ctags)))
+ (rt (walk (first subs) e loc dest flow ctags)))
(cond ((eq? rt '*))
((null? rt) (r-zero-values-for-the loc (first subs)
t))
(else
@@ -760,7 +760,7 @@
(r-type-mismatch-in-the loc (first subs) (first
rt) t))))
(list t)))
((##core#typecase)
- (let* ((ts (walk (first subs) e loc #f #f flow ctags))
+ (let* ((ts (walk (first subs) e loc #f flow ctags))
(trail0 trail)
(typeenv0 (type-typeenv (car ts))))
;; first exp is always a variable so ts must be of length 1
@@ -771,20 +771,20 @@
(if (match-types (car types) (car ts) typeenv #t)
(begin ; drops exp
(mutate-node! n (car subs))
- (walk n e loc dest tail flow ctags))
+ (walk n e loc dest flow ctags))
(begin
(trail-restore trail0 typeenv)
(loop (cdr types) (cdr subs)))))))))
((##core#switch ##core#cond)
(bomb "scrutinize: unexpected node class" class))
(else
- (for-each (lambda (n) (walk n e loc #f #f flow #f)) subs)
+ (for-each (lambda (n) (walk n e loc #f flow #f)) subs)
'*))))
(set! d-depth (sub1 d-depth))
(dd " ~a -> ~a" class results)
results)))
- (let ((rn (walk (first (node-subexpressions node)) '() '() #f #f (list
(tag)) #f)))
+ (let ((rn (walk (first (node-subexpressions node)) '() '() #f (list (tag))
#f)))
(when (pair? specialization-statistics)
(with-debugging-output
'(o e)
--
2.17.1
>From 8b23acc2e98107f6b8db47fcf0ef8bd5a86095fc Mon Sep 17 00:00:00 2001
From: megane <address@hidden>
Date: Tue, 20 Aug 2019 11:18:15 +0300
Subject: [PATCH 2/6] * scrutinizer.scm (call-result): Remove unused 'e' ,
'params' parameters
---
scrutinizer.scm | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/scrutinizer.scm b/scrutinizer.scm
index c2aa147b..f0f88239 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -302,7 +302,7 @@
(c (append (or a '()) (or b '()))))
(and (pair? c) c)))
- (define (call-result node args e loc params typeenv)
+ (define (call-result node args loc typeenv)
(let* ((actualtypes (map walked-result args))
(ptype (car actualtypes))
(pptype? (procedure-type? ptype))
@@ -668,7 +668,7 @@
(and pn (variable-mark pn '##compiler#enforce)))
(pt (and pn (variable-mark pn '##compiler#predicate))))
(let-values (((r specialized?)
- (call-result n args e loc params typeenv)))
+ (call-result n args loc typeenv)))
(define (smash)
(when (and (not strict)
(or (not pn)
--
2.17.1
>From 488ac92974c96bc1d76517274a4a3729d570352c Mon Sep 17 00:00:00 2001
From: megane <address@hidden>
Date: Tue, 20 Aug 2019 20:03:54 +0300
Subject: [PATCH 3/6] * scrutinizer.scm: Don't insert duplicate entries in
blist
The important change is changing
(eq? fl (cdaar bl))
to
(or fl-found? (eq? fl (ble-tag ble)))
Example showing the behaviour:
(lambda (x y)
(if y (+ x 1))
(set! x 'a)
(set! x 'a) ; <- these add more and more identical entries to blist
(set! x 'a)
(set! x 'a))
Also rename f -> fl-found?. It took half an hour to figure out
what was happening here at all, hopefully this helps the next soul.
Also added accessors for the blist entries.
---
scrutinizer.scm | 47 +++++++++++++++++++++++++++++++++++++----------
1 file changed, 37 insertions(+), 10 deletions(-)
diff --git a/scrutinizer.scm b/scrutinizer.scm
index f0f88239..186f0fe6 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -624,22 +624,39 @@
loc
"variable `~a' of type `~a' was modified to a
value of type `~a'"
var ot rt)))))
- ;; don't use "add-to-blist" since the current operation
does not affect aliases
(let ((t (if (or strict (not (db-get db var 'captured)))
rt
'*))
(fl (car flow)))
- (let loop ((bl blist) (f #f))
+ ;; For each outer flow F, change the var's
+ ;; type to (or t <old-type@F>). Add a new
+ ;; entry for current flow if it's missing.
+ ;;
+ ;; Motivating example:
+ ;;
+ ;; (let* ((x 1)
+ ;; (y x)) ; y x : fixnum @ flow f_1
+ ;; (if foo
+ ;; (set! y 'a)) ; y : symbol @ flow f_2
+ ;; y) ; (1) @ flow f_1
+ ;;
+ ;; At point (1) the type of y can be inferred
+ ;; to be (or fixnum symbol). The type of x
+ ;; should stay unchanged, however.
+ (let loop ((bl blist) (fl-found? #f))
(cond ((null? bl)
- (unless f
+ (unless fl-found?
+ (dd "set! ~a in ~a (new) --> ~a" var fl t)
(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))))))
+ ((eq? var (ble-id (car bl)))
+ (let* ((ble (car bl))
+ (old-type (ble-type ble))
+ (t2 (simplify-type `(or ,t ,old-type))))
+ (dd "set! ~a in ~a, or old ~a with ~a --> ~a"
+ var tag old-type t t2)
+ (ble-type-set! ble t2)
+ (loop (cdr bl) (or fl-found? (eq? fl
(ble-tag ble))))))
+ (else (loop (cdr bl) fl-found?))))))
(when (always-immediate var rt loc)
(set! assigned-immediates (add1 assigned-immediates))
@@ -839,6 +856,16 @@
(cute set-car! (cddr t) <>))))))))
+;;; blist (binding list) helpers
+;;
+;; - Entries (ble) in blist have type ((symbol . fixnum) . type)
+
+(define ble-id caar) ; variable name : symbol
+(define ble-tag cdar) ; block tag : fixnum
+(define ble-type cdr) ; variable type : valid type sexp
+(define ble-type-set! set-cdr!)
+
+
;;; Type-matching
;
; - "all" means: all elements in `or'-types in second argument must match
--
2.17.1
>From f18704baf3e80d62172eae792a30f87f4db1a40f Mon Sep 17 00:00:00 2001
From: megane <address@hidden>
Date: Wed, 21 Aug 2019 08:21:50 +0300
Subject: [PATCH 4/6] * scrutinizer.scm: Infer more exact types after set!
In the following code the type of x after the second set! is
currently
(or symbol null)
when it can be inferred to be just null.
(lambda (x)
(set! x 'a)
(set! x '())
(compiler-typecase x ((not *) 1)))
---
scrutinizer.scm | 24 +++++++++++++++---------
tests/typematch-tests.scm | 14 ++++++++++++++
2 files changed, 29 insertions(+), 9 deletions(-)
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 186f0fe6..aaa73686 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -626,8 +626,7 @@
var ot rt)))))
(let ((t (if (or strict (not (db-get db var 'captured)))
rt
- '*))
- (fl (car flow)))
+ '*)))
;; For each outer flow F, change the var's
;; type to (or t <old-type@F>). Add a new
;; entry for current flow if it's missing.
@@ -643,20 +642,27 @@
;; At point (1) the type of y can be inferred
;; to be (or fixnum symbol). The type of x
;; should stay unchanged, however.
- (let loop ((bl blist) (fl-found? #f))
+ (let loop ((bl blist) (cur-tag (car flow)))
(cond ((null? bl)
- (unless fl-found?
- (dd "set! ~a in ~a (new) --> ~a" var fl t)
- (set! blist (alist-cons (cons var fl) t
blist))))
- ((eq? var (ble-id (car bl)))
+ (when cur-tag
+ (dd "set! ~a in ~a (current) (new) --> ~a"
var cur-tag t)
+ (set! blist (alist-cons (cons var cur-tag) t
blist))))
+ ((not (eq? (ble-id (car bl)) var))
+ (loop (cdr bl) cur-tag))
+ ((eq? cur-tag (ble-tag (car bl)))
+ ;; In current flow the type is just
+ ;; the type of the assigned value.
+ (dd "set! ~a in ~a (current) --> ~a" var
cur-tag t)
+ (ble-type-set! (car bl) t)
+ (loop (cdr bl) #f))
+ (else
(let* ((ble (car bl))
(old-type (ble-type ble))
(t2 (simplify-type `(or ,t ,old-type))))
(dd "set! ~a in ~a, or old ~a with ~a --> ~a"
var tag old-type t t2)
(ble-type-set! ble t2)
- (loop (cdr bl) (or fl-found? (eq? fl
(ble-tag ble))))))
- (else (loop (cdr bl) fl-found?))))))
+ (loop (cdr bl) cur-tag)))))))
(when (always-immediate var rt loc)
(set! assigned-immediates (add1 assigned-immediates))
diff --git a/tests/typematch-tests.scm b/tests/typematch-tests.scm
index ac2d447c..77aaaaf1 100644
--- a/tests/typematch-tests.scm
+++ b/tests/typematch-tests.scm
@@ -427,4 +427,18 @@
(infer true (= 3 (+ 1 2))) ; Constant folding should happen before / during
scrutiny
+(define (set-infer-1 x)
+ (set! x 'a)
+ (set! x '())
+ (compiler-typecase x (null 1)))
+
+(define (set-infer-2 x y)
+ (set! x 'a)
+ (if y
+ (begin
+ (set! x '())
+ (compiler-typecase x (null 1))))
+ (assert (compiler-typecase x (null #f) (symbol #f) ((or null symbol) #t))))
+(set-infer-2 (begin) (begin))
+
(test-exit)
--
2.17.1
>From 0dafaa88b7921b6d0872518a1a8778e11bc5a3fa Mon Sep 17 00:00:00 2001
From: megane <address@hidden>
Date: Wed, 21 Aug 2019 08:28:59 +0300
Subject: [PATCH 5/6] * scrutinizer.scm: Inline always-immediate for
readability
---
scrutinizer.scm | 8 ++------
1 file changed, 2 insertions(+), 6 deletions(-)
diff --git a/scrutinizer.scm b/scrutinizer.scm
index aaa73686..12e6f96a 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -277,11 +277,6 @@
(r-cond-test-always-false loc if-node test-node)
#t))
- (define (always-immediate var t loc)
- (and-let* ((_ (type-always-immediate? t)))
- (d "assignment to var ~a in ~a is always immediate" var loc)
- #t))
-
(define (single tv r-value-count-mismatch)
(if (eq? '* tv)
'*
@@ -664,7 +659,8 @@
(ble-type-set! ble t2)
(loop (cdr bl) cur-tag)))))))
- (when (always-immediate var rt loc)
+ (when (type-always-immediate? rt)
+ (d " assignment to var ~a in ~a is always immediate" var
loc)
(set! assigned-immediates (add1 assigned-immediates))
(set-cdr! params '(#t)))
--
2.17.1
>From 63a09d79c3559675e3ace3806c6f757b0688d8d1 Mon Sep 17 00:00:00 2001
From: megane <address@hidden>
Date: Wed, 21 Aug 2019 08:51:04 +0300
Subject: [PATCH 6/6] * scrutinizer.scm: Improve debug output
Print walk result at the same indentation level as the "walk:"
message. Prefix with "walked" so it's quicker to see what this message
is about.
The big banners are helpful for finding where the scrutiny starts.
Especially when there's a lot of define-types which generate debugging
output too.
---
scrutinizer.scm | 4 +++-
1 file changed, 3 insertions(+), 1 deletion(-)
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 12e6f96a..55b900a2 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -175,6 +175,7 @@
(else #f)))
(define (scrutinize node db complain specialize strict block-compilation)
+ (d "################################## SCRUTINIZE
##################################")
(define (report loc msg . args)
(when *complain?*
(warning
@@ -800,7 +801,7 @@
(for-each (lambda (n) (walk n e loc #f flow #f)) subs)
'*))))
(set! d-depth (sub1 d-depth))
- (dd " ~a -> ~a" class results)
+ (dd "walked ~a -> ~a flow: ~a" class results flow)
results)))
(let ((rn (walk (first (node-subexpressions node)) '() '() #f (list (tag))
#f)))
@@ -819,6 +820,7 @@
(debugging '(o e) "dropped branches" dropped-branches))
(when (positive? assigned-immediates)
(debugging '(o e) "assignments to immediate values"
assigned-immediates))
+ (d "############################### SCRUTINIZE FINISH
##############################")
(when errors
(quit-compiling "some variable types do not satisfy strictness"))
rn)))
--
2.17.1
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Chicken-hackers] [PATCH 4/6] * scrutinizer.scm: Infer more exact types after set!,
megane <=