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

chased after lexical scoping bug introduced by combination of let1 + multiple values.

Browse Source
This commit is contained in:
Danny Yoo 2011-09-27 16:04:04 -04:00
parent 40820a96b4
commit d2eb1dea77
4 changed files with 93 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
compiler/bootstrapped-primitives.rkt
View File

@ -252,17 +252,17 @@
;; Common case: we're running multiple values. Put the first in the val register
;; and go to the multiple value return.
,(make-AssignImmediateStatement 'proc (make-ControlStackLabel/MultipleValueReturn))
,(make-AssignImmediateStatement 'val (make-EnvLexicalReference 0 #f))
,(make-PopEnvironment (make-Const 1) (make-Const 0))
,(make-AssignImmediateStatement 'proc (make-ControlStackLabel/MultipleValueReturn))
,(make-PopControlFrame)
,(make-GotoStatement (make-Reg 'proc))
;; Special case: on a single value, just use the regular return address
,on-single-value
,(make-AssignImmediateStatement 'proc (make-ControlStackLabel))
,(make-AssignImmediateStatement 'val (make-EnvLexicalReference 0 #f))
,(make-PopEnvironment (make-Const 1) (make-Const 0))
,(make-AssignImmediateStatement 'proc (make-ControlStackLabel))
,(make-PopControlFrame)
,(make-GotoStatement (make-Reg 'proc))

46
compiler/compiler.rkt
View File

@ -1680,9 +1680,11 @@
(make-EnvLexicalReference 0 #f)
next-linkage/expects-single)]
[after-body-code : Symbol (make-label 'afterLetBody)]
[extended-cenv : CompileTimeEnvironment (cons (extract-static-knowledge (Let1-rhs exp)
(cons '? cenv))
cenv)]
[extended-cenv : CompileTimeEnvironment
(cons (extract-static-knowledge (Let1-rhs exp)
(cons '? cenv))
cenv)]
[context : ValuesContext (linkage-context linkage)]
[let-linkage : Linkage
(cond
[(NextLinkage? linkage)
@ -1694,6 +1696,7 @@
(make-LabelLinkage after-body-code (linkage-context linkage))])]
[(LabelLinkage? linkage)
(make-LabelLinkage after-body-code (LabelLinkage-context linkage))])]
[body-target : Target (adjust-target-depth target 1)]
[body-code : InstructionSequence
(compile (Let1-body exp) extended-cenv body-target let-linkage)])
@ -1706,7 +1709,42 @@
rhs-code
body-code
after-body-code
(make-PopEnvironment (make-Const 1) (make-Const 0))))))
;; We want to clear out the scratch space introduced by the
;; let1. However, there may be multiple values coming
;; back at this point, from the evaluation of the body. We
;; look at the context and route around those values
;; appropriate.
(cond
[(eq? context 'tail)
empty-instruction-sequence]
[(eq? context 'drop-multiple)
(make-PopEnvironment (make-Const 1)
(new-SubtractArg
(make-Reg 'argcount)
(make-Const 1)))]
[(eq? context 'keep-multiple)
;; dynamic number of arguments that need
;; to be preserved
(make-PopEnvironment (make-Const 1)
(new-SubtractArg
(make-Reg 'argcount)
(make-Const 1)))]
[else
(cond [(= context 0)
(make-PopEnvironment (make-Const 1)
(make-Const 0))]
[(= context 1)
(make-PopEnvironment (make-Const 1)
(make-Const 0))]
[else
;; n-1 values on stack that we need to route
;; around
(make-PopEnvironment (make-Const 1)
(new-SubtractArg
(make-Const context)
(make-Const 1)))])])))))

50
tests/more-tests/isolating-bug.rkt
View File

@ -17,16 +17,62 @@
#'(begin
(define-values (names ...)
(let ()
(define-struct name (fields ...) kw ...)
(call-with-values (lambda ()
(let ([cnstr (lambda args
(apply cnstr args))])
(displayln names) ...
(values names ...)))
(lambda args
(displayln "in the result of call-with-values")
(displayln args)
(apply values args))))))))]))
(define-syntax (my-define-struct2 stx)
(syntax-case stx ()
[(_ name (fields ...) kw ...)
(with-syntax ([(names ...)
(build-struct-names #'name
(syntax->list #'(fields ...))
#f
#f)])
(with-syntax ([cnstr (syntax-case #'(names ...) ()
[(struct:name-id constructor misc ...)
#'constructor])])
#'(begin
(define-values (names ...)
(let ()
(begin
(define-struct name (fields ...) kw ...)
(let ([cnstr (lambda args
(apply cnstr args))])
(apply cnstr args))])
(displayln names) ...
(values names ...))))))))]))
(my-define-struct swf (f) #:mutable)
(displayln "---")
struct:swf
make-swf
swf?
swf-f
set-swf-f!
set-swf-f!
(displayln "***")
(my-define-struct swf2 (f) #:mutable)
(displayln "---")
struct:swf2
make-swf2
swf2?
swf2-f
set-swf2-f!

2
version.rkt
View File

@ -6,4 +6,4 @@
(provide version)
(: version String)
(define version "1.41")
(define version "1.42")