~ chicken-core (chicken-5) cb90575d87917281ffbdb2c17c5bc8ff46e1d640
commit cb90575d87917281ffbdb2c17c5bc8ff46e1d640
Author: megane <meganeka@gmail.com>
AuthorDate: Tue Aug 20 11:16:57 2019 +0300
Commit: Peter Bex <peter@more-magic.net>
CommitDate: Sun Sep 15 10:43:38 2019 +0200
* scrutinizer.scm (walk): Remove unused 'tail' parameter
Signed-off-by: Peter Bex <peter@more-magic.net>
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 47b7c0d3..f4a0e745 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)
Trap