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 <megan...@gmail.com> 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 <megan...@gmail.com> 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 <megan...@gmail.com> 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 <megan...@gmail.com> 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 <megan...@gmail.com> 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 <megan...@gmail.com> 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
_______________________________________________ Chicken-hackers mailing list Chicken-hackers@nongnu.org https://lists.nongnu.org/mailman/listinfo/chicken-hackers