[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Chicken-hackers] [PATCH] ensure scrutiny doesn't walk nodes more than o
|
From: |
Felix |
|
Subject: |
[Chicken-hackers] [PATCH] ensure scrutiny doesn't walk nodes more than once |
|
Date: |
Wed, 30 May 2012 22:15:22 +0200 (CEST) |
The attached patch fixes a problem with the scrutinizer which causes
nodes to be walked more than once. A case detected by Christian and
Mario turned out that this behaviour (which is known - see bug #751)
can cause code to make incorrect assumptions about argument types and
so drop necessary type checks. For example, in
(zero? (string-length foo))
the expression "(string-length ...)" is analyzed first (the analysis
is depth-first), returning an exact integer. The application of
"string-length" will mark "foo" as being a string in subsequent code
(otherwise the primitive would have triggered an error). The
specialization-template for "zero?" with a fixnum argument will expand
into code that refers to the "string-length" call and will be
re-analyzed (a specialization may contain code that could be subject
to another specialization). That second analysis will now think "foo"
is a string, based on the assumption made by the previous analysis of
this form. Now the call is "optimized" by rewriting "string-length" to
a lower-level, unsafe call to "##sys#size". This is of course wrong,
will result in unsafe code (when called with incorrectly typed
arguments) and additionally produces multiple identical warnings, when
an expression with a possible type error is analyzed several times.
The patch modifies the specialization of a procedure call by wrapping
the arguments in a special "(##core#the/result ...)" node and
replacing references to those arguments in the specialization-template
with the wrapped ones. When the scrutinizer encounters these nodes, it
just extracts the saved type and does not continue walking the inner,
nested node (since they have already been walked during the earlier
specialization). The CPS conversion pass, which drops "##core#the"
nodes (used for explicit type-declaration in the scrutinizer-pass)
drops "##core#the/result" nodes as well.
The tests all seem to pass (with the applied patch and after a
complete self-compile with the patched compiler). Still, this is
a non-trivial change and may break stuff.
This patch fixes bug #751 (and #855 which is a duplicate of the
former).
cheers,
felix
>From fe3c32b02ab841207dd56d8fa83dcdb9dfa12b61 Mon Sep 17 00:00:00 2001
From: felix <address@hidden>
Date: Tue, 29 May 2012 13:27:10 +0200
Subject: [PATCH] when specializing, substitute argument nodes by nodes wrapped
in ##core#the/result nodes which are never rewalked
---
compiler.scm | 3 +-
scrutinizer.scm | 103 +++++++++++++++++++--------------------
tests/specialization-test-2.scm | 12 +++++
tweaks.scm | 10 +++-
4 files changed, 72 insertions(+), 56 deletions(-)
diff --git a/compiler.scm b/compiler.scm
index 408852e..94d178d 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -175,6 +175,7 @@
; [##core#direct_call {<safe-flag> <debug-info> <call-id> <words>} <exp-f>
<exp>...]
; [##core#direct_lambda {<id> <mode> (<variable>... [. <variable>]) <size>}
<exp>]
; [##core#the {<type> <strict>} <exp>]
+; [##core#the/result {<typelist>} <exp>]
; [##core#typecase {<info> (<type> ...)} <exp> <body1> ... [<elsebody>]]
; - Closure converted/prepared language:
@@ -1722,7 +1723,7 @@
(walk-inline-call class params subs k) )
((##core#call) (walk-call returnvar (car subs) (cdr subs) params k))
((##core#callunit) (walk-call-unit returnvar (first params) k))
- ((##core#the)
+ ((##core#the ##core#the/result)
;; remove "the" nodes, as they are not used after scrutiny
(walk returnvar (car subs) k))
((##core#typecase)
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 697b24f..dbf6481 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -29,7 +29,7 @@
(hide specialize-node! specialization-statistics
procedure-type? named? procedure-result-types procedure-argument-types
noreturn-type? rest-type procedure-name d-depth
- noreturn-procedure-type? trail trail-restore
+ noreturn-procedure-type? trail trail-restore walked-result
typename multiples procedure-arguments procedure-results
smash-component-types! generate-type-checks! over-all-instantiations
compatible-types? type<=? match-types resolve match-argument-types))
@@ -114,6 +114,9 @@
(define (multiples n)
(if (= n 1) "" "s"))
+(define (walked-result n)
+ (first (node-parameters n))) ; assumes ##core#the/result node
+
(define (scrutinize node db complain specialize)
(let ((blist '()) ; (((VAR . FLOW) TYPE) ...)
@@ -299,13 +302,14 @@
""))
"")
(fragment (first (node-subexpressions node)))))
- (d " call: ~a " args)
- (let* ((ptype (car args))
+ (let* ((actualtypes (map walked-result args))
+ (ptype (car actualtypes))
(pptype? (procedure-type? ptype))
(nargs (length (cdr args)))
(xptype `(procedure ,(make-list nargs '*) *))
- (typeenv (append-map type-typeenv args))
+ (typeenv (append-map type-typeenv actualtypes))
(op #f))
+ (d " call: ~a " actualtypes)
(cond ((and (not pptype?) (not (match-types xptype ptype typeenv)))
(report
loc
@@ -326,11 +330,14 @@
(pname)
alen (multiples alen)
nargs (multiples nargs))))
- (do ((args (cdr args) (cdr args))
+ (do ((actualtypes (cdr actualtypes) (cdr actualtypes))
(atypes atypes (cdr atypes))
(i 1 (add1 i)))
- ((or (null? args) (null? atypes)))
- (unless (match-types (car atypes) (car args) typeenv)
+ ((or (null? actualtypes) (null? atypes)))
+ (unless (match-types
+ (car atypes)
+ (car actualtypes)
+ typeenv)
(report
loc
(sprintf
@@ -338,10 +345,10 @@
(pname)
i
(resolve (car atypes) typeenv)
- (resolve (car args) typeenv)))))
+ (resolve (car actualtypes) typeenv)))))
(when (noreturn-procedure-type? ptype)
(set! noreturn #t))
- (let ((r (procedure-result-types ptype values-rest (cdr args)
typeenv)))
+ (let ((r (procedure-result-types ptype values-rest (cdr
actualtypes) typeenv)))
(let* ((pn (procedure-name ptype))
(trail0 trail))
(when pn
@@ -349,29 +356,29 @@
(variable-mark pn '##compiler#predicate)) =>
(lambda (pt)
(cond ((match-argument-types
- (list pt) (cdr args) typeenv #f #t)
+ (list pt) (cdr actualtypes)
typeenv #f #t)
(report-notice
loc
(sprintf
"~athe predicate is called
with an argument of type\n `~a' and will always return true"
- (pname) (cadr args)))
+ (pname) (cadr actualtypes)))
(when specialize
(specialize-node!
- node
+ node (cdr args)
`(let ((#(tmp) #(1))) '#t))
(set! op (list pn pt))))
((begin
(trail-restore trail0 typeenv)
(match-argument-types
- (list `(not ,pt)) (cdr args)
typeenv #f #t))
+ (list `(not ,pt)) (cdr
actualtypes) typeenv #f #t))
(report-notice
loc
(sprintf
"~athe predicate is called
with an argument of type\n `~a' and will always return false"
- (pname) (cadr args)))
+ (pname) (cadr actualtypes)))
(when specialize
(specialize-node!
- node
+ node (cdr args)
`(let ((#(tmp) #(1))) '#f))
(set! op (list pt `(not ,pt)))))
(else (trail-restore trail0
typeenv)))))
@@ -385,7 +392,7 @@
(append-map type-typeenv
stype)
typeenv)))
(cond ((match-argument-types
- stype (cdr args) tenv2
+ stype (cdr actualtypes) tenv2
#t)
(set! op (cons pn (car spec)))
(set! typeenv tenv2)
@@ -394,7 +401,7 @@
(rewrite (if r2
(third spec)
(second
spec))))
- (specialize-node! node
rewrite)
+ (specialize-node! node (cdr
args) rewrite)
(when r2 (set! r r2))))
(else
(trail-restore trail0 tenv2)
@@ -414,18 +421,6 @@
(d " result-types: ~a" r)
(values r op))))))))
- ;; not used in the moment
- (define (self-call? node loc)
- (case (node-class node)
- ((##core#call)
- (and (pair? loc)
- (let ((op (first (node-subexpressions node))))
- (and (eq? '##core#variable (node-class op))
- (eq? (car loc) (first (node-parameters op)))))))
- ((let)
- (self-call? (last (node-subexpressions node)) loc))
- (else #f)))
-
(define tag
(let ((n 0))
(lambda ()
@@ -461,6 +456,7 @@
(set! d-depth (add1 d-depth))
(let ((results
(case class
+ ((##core#the/result) (list (first params))) ; already walked
((quote) (list (constant-result (first params))))
((##core#undefined) '(*))
((##core#proc) '(procedure))
@@ -476,7 +472,7 @@
(a (third subs))
(nor0 noreturn))
(when (and (always-true rt loc n) specialize)
- (set! dropped-branches (+ dropped-branches 1))
+ (set! dropped-branches (add1 dropped-branches))
(copy-node!
(build-node-graph
`(let ((,(gensym) ,tst)) ,c))
@@ -661,19 +657,25 @@
(let* ((f (fragment n))
(len (length subs))
(args (map (lambda (n i)
- (single
- (sprintf
- "in ~a of procedure call `~s'"
- (if (zero? i)
- "operator position"
- (sprintf "argument #~a" i))
- f)
- (walk n e loc #f #f flow #f) loc))
+ (make-node
+ '##core#the/result
+ (list
+ (single
+ (sprintf
+ "in ~a of procedure call `~s'"
+ (if (zero? i)
+ "operator position"
+ (sprintf "argument #~a" i))
+ f)
+ (walk n e loc #f #f flow #f)
+ loc))
+ (list n)))
subs
(iota len)))
- (fn (car args))
+ (fn (walked-result (car args)))
(pn (procedure-name fn))
- (typeenv (type-typeenv `(or ,@args))) ; hack
+ (typeenv (type-typeenv
+ `(or ,@(map walked-result args)))) ; hack
(enforces
(and pn (variable-mark pn '##compiler#enforce)))
(pt (and pn (variable-mark pn '##compiler#predicate))))
@@ -688,8 +690,6 @@
(smash-component-types! e "env")
(smash-component-types! blist "blist")))
(cond (specialized?
- ;;XXX this will walk the arguments again,
resulting in
- ;; duplicate warnings
(walk n e loc dest tail flow ctags)
(smash)
;; keep type, as the specialization may contain
icky stuff
@@ -1859,9 +1859,8 @@
;; Mutate node for specialization
-(define (specialize-node! node template)
- (let ((args (cdr (node-subexpressions node)))
- (env '()))
+(define (specialize-node! node args template)
+ (let ((env '()))
(define (subst x)
(cond ((and (vector? x)
(= 1 (vector-length x)) )
@@ -2165,7 +2164,7 @@
(define (vector-ref-result-type node args rtypes)
(or (and-let* ((subs (node-subexpressions node))
((= (length subs) 3))
- (arg1 (second args))
+ (arg1 (walked-result (second args)))
((pair? arg1))
((eq? 'vector (car arg1)))
(index (third subs))
@@ -2183,7 +2182,7 @@
(define (list-ref-result-type node args rtypes)
(or (and-let* ((subs (node-subexpressions node))
((= (length subs) 3))
- (arg1 (second args))
+ (arg1 (walked-result (second args)))
((pair? arg1))
((eq? 'list (car arg1)))
(index (third subs))
@@ -2201,7 +2200,7 @@
(lambda (node args rtypes)
(or (and-let* ((subs (node-subexpressions node))
((= (length subs) 3))
- (arg1 (second args))
+ (arg1 (walked-result (second args)))
((pair? arg1))
((eq? 'list (car arg1)))
(index (third subs))
@@ -2220,21 +2219,21 @@
(lambda (node args rtypes)
(if (null? (cdr args))
'(null)
- `((list ,@(cdr args))))))
+ `((list ,@(map walked-result (cdr args)))))))
(define-special-case ##sys#list
(lambda (node args rtypes)
(if (null? (cdr args))
'(null)
- `((list ,@(cdr args))))))
+ `((list ,@(map walked-result (cdr args)))))))
(define-special-case vector
(lambda (node args rtypes)
- `((vector ,@(cdr args)))))
+ `((vector ,@(map walked-result (cdr args))))))
(define-special-case ##sys#vector
(lambda (node args rtypes)
- `((vector ,@(cdr args)))))
+ `((vector ,@(map walked-result (cdr args))))))
;;; perform check over all typevar instantiations
diff --git a/tests/specialization-test-2.scm b/tests/specialization-test-2.scm
index db894aa..e24e5cb 100644
--- a/tests/specialization-test-2.scm
+++ b/tests/specialization-test-2.scm
@@ -14,3 +14,15 @@ return n;}
(assert (= 1 (bar 1)))
)
+
+
+;; #855: second walk of arguments after specialization of call to "zero?"
+;; applies enforced type-assumption for argument "y" to "string-length"
+;; to call to "string-length" itself
+
+(define (bug855 x)
+ (let ((y (car x)))
+ (zero? (string-length y))))
+
+(assert (handle-exceptions ex #t (bug855 '(#f)) #f))
+
diff --git a/tweaks.scm b/tweaks.scm
index b92427e..3dd01d8 100644
--- a/tweaks.scm
+++ b/tweaks.scm
@@ -40,9 +40,13 @@
(define-inline (node? x) (##sys#structure? x 'node))
(define-inline (make-node c p s) (##sys#make-structure 'node c p s))
-(define-inline (node-class n) (##sys#slot n 1))
-(define-inline (node-parameters n) (##sys#slot n 2))
-(define-inline (node-subexpressions n) (##sys#slot n 3))
+
+(cond-expand
+ ((not debugbuild)
+ (define-inline (node-class n) (##sys#slot n 1))
+ (define-inline (node-parameters n) (##sys#slot n 2))
+ (define-inline (node-subexpressions n) (##sys#slot n 3)))
+ (else))
(define-inline (intrinsic? sym) (##sys#get sym '##compiler#intrinsic))
--
1.7.0.4
- [Chicken-hackers] [PATCH] ensure scrutiny doesn't walk nodes more than once,
Felix <=