suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

3m bug fix for function calls chained with &&, ||, etc

Browse Source 
svn: r4072
This commit is contained in:
Matthew Flatt 2006-08-16 23:08:24 +00:00
parent 6cedffd7c0
commit 87e78e0f96
1 changed files with 53 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

83
collects/compiler/private/xform.ss
View File

@ -612,16 +612,24 @@
"" ""
"SET_GC_VARIABLE_STACK(__gc_var_stack__), ") "SET_GC_VARIABLE_STACK(__gc_var_stack__), ")
"__gc_var_stack__[1] = (void *)x)~n")) "__gc_var_stack__[1] = (void *)x)~n"))
;; Debugging support:
(printf "#ifdef MZ_3M_CHECK_VAR_STACK\n")
(printf "static int _bad_var_stack_() { *(long *)0x0 = 1; return 0; }\n")
(printf "# define CHECK_GC_V_S ((GC_VARIABLE_STACK == __gc_var_stack__) ? 0 : _bad_var_stack_()),\n")
(printf "#else\n")
(printf "# define CHECK_GC_V_S /*empty*/\n")
(printf "#endif\n")
;; Call a function where the number of registered variables can change in ;; Call a function where the number of registered variables can change in
;; nested blocks: ;; nested blocks:
(printf "#define FUNCCALL_each(setup, x) (setup, x)~n") (printf "#define FUNCCALL_each(setup, x) (CHECK_GC_V_S setup, x)~n")
;; The same, but a "tail" call: ;; The same, but a "tail" call:
(printf "#define FUNCCALL_EMPTY_each(x) FUNCCALL_each(SET_GC_VARIABLE_STACK((void **)__gc_var_stack__[0]), x)~n") (printf "#define FUNCCALL_EMPTY_each(x) (SET_GC_VARIABLE_STACK((void **)__gc_var_stack__[0]), x)~n")
;; The same, but the number of registered variables for this call is definitely ;; The same, but the number of registered variables for this call is definitely
;; the same as for the previous call: ;; the same as for the previous call:
(printf (if callee-restore? (printf (if callee-restore?
"#define FUNCCALL_AGAIN_each(x) x~n" "#define FUNCCALL_AGAIN_each(x) (CHECK_GC_V_S x)~n"
"#define FUNCCALL_AGAIN_each(x) FUNCCALL_each(SET_GC_VARIABLE_STACK(__gc_var_stack__), x)~n")) "#define FUNCCALL_AGAIN_each(x) FUNCCALL_each(SET_GC_VARIABLE_STACK(__gc_var_stack__), x)~n"))
;; As above, but when the number of registered variables never changes ;; As above, but when the number of registered variables never changes
@ -3091,11 +3099,11 @@
;; because they're blessed by the lifter] ;; because they're blessed by the lifter]
(let ([e- (reverse e)] (let ([e- (reverse e)]
[orig-num-calls (live-var-info-num-calls live-vars)]) [orig-num-calls (live-var-info-num-calls live-vars)])
(let loop ([e- e-][result null][live-vars live-vars]) (let loop ([e- e-][result null][live-vars live-vars][converted-sub? #f])
(cond (cond
[(null? e-) (values result live-vars)] [(null? e-) (values result live-vars)]
[(ignored-stuff? e-) [(ignored-stuff? e-)
(loop (cdr e-) (cons (car e-) result) live-vars)] (loop (cdr e-) (cons (car e-) result) live-vars converted-sub?)]
[(eq? 'return (tok-n (car e-))) [(eq? 'return (tok-n (car e-)))
;; Look forward in result to semicolon, and wrap that: ;; Look forward in result to semicolon, and wrap that:
(let rloop ([result result][l null]) (let rloop ([result result][l null])
@ -3107,16 +3115,21 @@
(if (null? l) (if (null? l)
(cons (make-tok RET_NOTHING (tok-line (car e-)) (tok-file (car e-))) (cons (make-tok RET_NOTHING (tok-line (car e-)) (tok-file (car e-)))
result) result)
(let ([has-empty-funccall? (let loop ([l l]) (let ([has-empty-funccall?
(cond ;; All calls must be empty calls, otherwise
[(null? l) #f] ;; the result might not depend on the empty call
[(and (call? (car l)) ;; (e.g., f() && empty(f()) )
(null? (call-live (car l)))) (let loop ([l l][one? #f])
#t] (cond
[(seq? (car l)) [(null? l) one?]
(or (loop (seq->list (seq-in (car l)))) [(call? (car l))
(loop (cdr l)))] (if (null? (call-live (car l)))
[else #f]))]) (loop (cdr l) #t)
#f)]
[(seq? (car l))
(and (loop (seq->list (seq-in (car l))) one?)
(loop (cdr l) one?))]
[else #f]))])
(list* (make-tok (if has-empty-funccall? (list* (make-tok (if has-empty-funccall?
RET_VALUE_EMPTY_START RET_VALUE_EMPTY_START
RET_VALUE_START) RET_VALUE_START)
@ -3129,7 +3142,8 @@
RET_VALUE_END) RET_VALUE_END)
(tok-line (car e-)) (tok-file (car e-))) (tok-line (car e-)) (tok-file (car e-)))
result))) result)))
live-vars)] live-vars
converted-sub?)]
[else (rloop (cdr result) (cons (car result) l))]))] [else (rloop (cdr result) (cons (car result) l))]))]
[(looks-like-call? e-) [(looks-like-call? e-)
;; Looks like a function call, maybe a cast: ;; Looks like a function call, maybe a cast:
@ -3141,7 +3155,8 @@
(convert-paren-interior (car e-) vars &-vars c++-class live-vars complain-not-in #f)]) (convert-paren-interior (car e-) vars &-vars c++-class live-vars complain-not-in #f)])
(loop (cddr e-) (loop (cddr e-)
(list* (cadr e-) v result) (list* (cadr e-) v result)
live-vars))) live-vars
#t)))
(lambda () (lambda ()
;; It's a function call; find the start ;; It's a function call; find the start
(let-values ([(args) (car e-)] (let-values ([(args) (car e-)]
@ -3246,7 +3261,8 @@
(or (and (null? (cdr func)) (or (and (null? (cdr func))
(memq (tok-n (car func)) non-returning-functions)) (memq (tok-n (car func)) non-returning-functions))
(and (pair? rest-) (and (pair? rest-)
(eq? 'return (tok-n (car rest-))))) (eq? 'return (tok-n (car rest-)))
(not converted-sub?)))
;; no arrays of pointers in this scope, or addresses of ;; no arrays of pointers in this scope, or addresses of
;; local vars taken in the function. ;; local vars taken in the function.
(not (or (ormap (lambda (var) (not (or (ormap (lambda (var)
@ -3316,11 +3332,15 @@
(+ (if non-returning? 1 0) (+ (if non-returning? 1 0)
(live-var-info-num-noreturn-calls live-vars)) (live-var-info-num-noreturn-calls live-vars))
(or this-nonempty? (or this-nonempty?
(live-var-info-nonempty-calls? live-vars)))))))))] (live-var-info-nonempty-calls? live-vars)))
(or converted-sub?
(null? rest-)
(not (memq (tok-n (car rest-)) '(return else))))))))))]
[(eq? 'goto (tok-n (car e-))) [(eq? 'goto (tok-n (car e-)))
;; Goto - assume all vars are live ;; Goto - assume all vars are live
(loop (cdr e-) (cons (car e-) result) (loop (cdr e-) (cons (car e-) result)
(replace-live-vars live-vars vars))] (replace-live-vars live-vars vars)
#t)]
[(eq? '= (tok-n (car e-))) [(eq? '= (tok-n (car e-)))
;; Check for assignments where the LHS can move due to ;; Check for assignments where the LHS can move due to
;; a function call on the RHS. [Note that special support ;; a function call on the RHS. [Note that special support
@ -3369,7 +3389,8 @@
(live-var-info-pushed-vars live-vars) (live-var-info-pushed-vars live-vars)
(live-var-info-num-calls live-vars) (live-var-info-num-calls live-vars)
(live-var-info-num-noreturn-calls live-vars) (live-var-info-num-noreturn-calls live-vars)
(live-var-info-nonempty-calls? live-vars)))) (live-var-info-nonempty-calls? live-vars))
#t))
(begin (begin
(when (and (not (null? assignee)) (when (and (not (null? assignee))
(or (if (brackets? (car assignee)) (or (if (brackets? (car assignee))
@ -3402,8 +3423,8 @@
(log-warning "[ASSIGN] ~a in ~a: suspicious assignment with a function call, LHS ends ~s." (log-warning "[ASSIGN] ~a in ~a: suspicious assignment with a function call, LHS ends ~s."
(tok-line (car e-)) (tok-file (car e-)) (tok-line (car e-)) (tok-file (car e-))
(tok-n (cadr e-)))) (tok-n (cadr e-))))
(loop (cdr e-) (cons (car e-) result) live-vars))))) (loop (cdr e-) (cons (car e-) result) live-vars #t)))))
(loop (cdr e-) (cons (car e-) result) live-vars))] (loop (cdr e-) (cons (car e-) result) live-vars #t))]
[(and (braces? (car e-)) (not braces-are-aggregates?)) [(and (braces? (car e-)) (not braces-are-aggregates?))
(let*-values ([(v) (car e-)] (let*-values ([(v) (car e-)]
;; do/while/for: we'll need a fixpoint for live-vars ;; do/while/for: we'll need a fixpoint for live-vars
@ -3490,7 +3511,8 @@
(seq-close v) (seq-close v)
(list->seq e))) (list->seq e)))
result) result)
(filter-live-vars live-vars)))] (filter-live-vars live-vars)
#t))]
[(seq? (car e-)) [(seq? (car e-))
;; Do nested body. ;; Do nested body.
;; For (v = new x, ...) parens, check for special conversion ;; For (v = new x, ...) parens, check for special conversion
@ -3505,7 +3527,7 @@
(and (brackets? (car e-)) (and (brackets? (car e-))
"array access")) "array access"))
#f)]) #f)])
(loop (cdr e-) (cons v result) live-vars)))] (loop (cdr e-) (cons v result) live-vars #t)))]
[(and (assq (tok-n (car e-)) vars) [(and (assq (tok-n (car e-)) vars)
(not (assq (tok-n (car e-)) (live-var-info-vars live-vars)))) (not (assq (tok-n (car e-)) (live-var-info-vars live-vars))))
;; Add a live variable: ;; Add a live variable:
@ -3513,7 +3535,8 @@
(cons (car e-) result) (cons (car e-) result)
(replace-live-vars live-vars (replace-live-vars live-vars
(cons (assq (tok-n (car e-)) vars) (cons (assq (tok-n (car e-)) vars)
(live-var-info-vars live-vars))))] (live-var-info-vars live-vars)))
#t)]
[(and (memq (tok-n (car e-)) '(while do for)) [(and (memq (tok-n (car e-)) '(while do for))
(case (tok-n (car e-)) (case (tok-n (car e-))
[(do) [(do)
@ -3525,7 +3548,7 @@
(braces? (cadr result))))])) (braces? (cadr result))))]))
(log-error "[LOOP] ~a in ~a: while/do/for with body not in braces." (log-error "[LOOP] ~a in ~a: while/do/for with body not in braces."
(tok-line (car e-)) (tok-file (car e-))) (tok-line (car e-)) (tok-file (car e-)))
(loop (cdr e-) (cons (car e-) result) live-vars)] (loop (cdr e-) (cons (car e-) result) live-vars #t)]
[else [else
(when (and check-arith? (not memcpy?) (when (and check-arith? (not memcpy?)
(positive? (live-var-info-num-calls live-vars))) (positive? (live-var-info-num-calls live-vars)))
@ -3544,7 +3567,7 @@
(log-warning "[ARITH] ~a in ~a: suspicious arithmetic, LHS ends ~s." (log-warning "[ARITH] ~a in ~a: suspicious arithmetic, LHS ends ~s."
(tok-line (car e-)) (tok-file (car e-)) (tok-line (car e-)) (tok-file (car e-))
(tok-n (cadr e-)))))) (tok-n (cadr e-))))))
(loop (cdr e-) (cons (car e-) result) live-vars)])))) (loop (cdr e-) (cons (car e-) result) live-vars converted-sub?)]))))
(define (convert-seq-interior v comma-sep? vars &-vars c++-class live-vars complain-not-in memcpy?) (define (convert-seq-interior v comma-sep? vars &-vars c++-class live-vars complain-not-in memcpy?)
(let ([e (seq->list (seq-in v))]) (let ([e (seq->list (seq-in v))])