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

fix var registration in the presence of setjmp

Browse Source 
svn: r5479
This commit is contained in:
Matthew Flatt 2007-01-27 22:54:38 +00:00
parent 71fb3f1efc
commit e911124dbf
1 changed files with 21 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -801,6 +801,11 @@
(define re:_stk_ (regexp "^_stk_")) (define re:_stk_ (regexp "^_stk_"))
;; These don't act like functions, but we need to treat them
;; specially:
(define setjmp-functions
'(setjmp _setjmp scheme_setjmp scheme_mz_setjmp))
;; The non-functions table identifies symbols to ignore when ;; The non-functions table identifies symbols to ignore when
;; finding function calls ;; finding function calls
(define non-functions (define non-functions
@ -812,8 +817,8 @@
__typeof __typeof
;; These don't act like functions: ;; These don't act like functions:
setjmp longjmp _setjmp _longjmp scheme_setjmp scheme_longjmp scheme_mz_setjmp scheme_mz_longjmp setjmp longjmp _longjmp scheme_longjmp_setjmp scheme_mz_longjmp scheme_jit_longjmp
scheme_jit_longjmp scheme_jit_setjmp_prepare scheme_jit_setjmp_prepare
;; The following are functions, but they don't trigger GC, and ;; The following are functions, but they don't trigger GC, and
;; they either take one argument or no pointer arguments. ;; they either take one argument or no pointer arguments.
@ -3316,9 +3321,12 @@
(live-var-info-nonempty-calls? live-vars)))]) (live-var-info-nonempty-calls? live-vars)))])
(let ([non-gcing-call? (let ([non-gcing-call?
(and (null? (cdr func)) (and (null? (cdr func))
(hash-table-get non-gcing-functions (tok-n (car func)) (lambda () #f)))]) (hash-table-get non-gcing-functions (tok-n (car func)) (lambda () #f)))]
[setjmp-call?
(memq (tok-n (car func)) setjmp-functions)])
(loop rest- (loop rest-
(let ([call (if non-gcing-call? (let ([call (if (or non-gcing-call?
setjmp-call?)
;; Call without pointer pushes ;; Call without pointer pushes
(make-parens (make-parens
"(" #f #f ")" "(" #f #f ")"
@ -3360,13 +3368,13 @@
(filter (lambda (x) (not (assq (car x) old-pushed))) (filter (lambda (x) (not (assq (car x) old-pushed)))
pushed-vars))]) pushed-vars))])
(append new-pushed old-pushed)) (append new-pushed old-pushed))
(+ (if non-gcing-call? 0 1) (+ (if (or non-gcing-call? setjmp-call?) 0 1)
(live-var-info-num-calls live-vars)) (live-var-info-num-calls live-vars))
(+ (if non-gcing-call? 0 (if non-returning? 1 0)) (+ (if (or non-gcing-call? setjmp-call?) 0 (if non-returning? 1 0))
(live-var-info-num-noreturn-calls live-vars)) (live-var-info-num-noreturn-calls live-vars))
(+ (if (or non-gcing-call? non-returning?) 0 (if this-nonempty? 0 1)) (+ (if (or non-gcing-call? non-returning? setjmp-call?) 0 (if this-nonempty? 0 1))
(live-var-info-num-empty-calls live-vars)) (live-var-info-num-empty-calls live-vars))
(or (and this-nonempty? (not non-gcing-call?)) (or (and this-nonempty? (not (or non-gcing-call? setjmp-call?)))
(live-var-info-nonempty-calls? live-vars))) (live-var-info-nonempty-calls? live-vars)))
(or converted-sub? (or converted-sub?
(null? rest-) (null? rest-)