From 1e30968481eefe9cbbccf8a9f0a174134faa7620 Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Wed, 23 Mar 2011 19:17:56 -0400 Subject: [PATCH] tracing bug with boxenv --- compile.rkt | 17 +++++---------- parse.rkt | 25 ++++++++++++---------- test-compiler.rkt | 9 ++++---- test-parse.rkt | 54 ++++++++++++++++++++++++++++++++++++++--------- 4 files changed, 67 insertions(+), 38 deletions(-) diff --git a/compile.rkt b/compile.rkt index 752769a..bb21a55 100644 --- a/compile.rkt +++ b/compile.rkt @@ -392,18 +392,11 @@ [(and (not (eq? target 'val)) (eq? linkage 'return)) - ;; This case happens for set!, which may install the results of an - ;; application directly into the environment. - (let ([proc-return (make-label 'procReturn)]) - (end-with-linkage linkage - cenv-without-args - (make-instruction-sequence - `(,(make-PushControlFrame proc-return) - ,(make-AssignPrimOpStatement 'val (make-GetCompiledProcedureEntry)) - ,(make-GotoStatement (make-Reg 'val)) - ,proc-return - ,(make-AssignImmediateStatement target (make-Reg 'val))))))])) - + ;; This case should be impossible: return linkage should only + ;; occur when we're in tail position, and we're in tail position + ;; only when the target is the val register. + (error 'compile "return linkage, target not val: ~s" target)])) + (: compile-let1 (Let1 Natural Target Linkage -> InstructionSequence)) (define (compile-let1 exp cenv target linkage) diff --git a/parse.rkt b/parse.rkt index f59fe7f..c4c17e3 100644 --- a/parse.rkt +++ b/parse.rkt @@ -88,17 +88,20 @@ [(set!? exp) (let ([address (find-variable (set!-name exp) cenv)]) - (cond - [(EnvLexicalReference? address) - (make-InstallValue (EnvLexicalReference-depth address) - (parse (set!-value exp) cenv) - #t)] - [(EnvPrefixReference? address) - (make-ToplevelSet (EnvPrefixReference-depth address) - (EnvPrefixReference-pos address) - (definition-variable exp) - (parse (set!-value exp) cenv))]))] - + ;; Subtle: this needs to be a sequence here to disable tail calls for the + ;; extent of the set!-value. + (make-Seq (list (cond + [(EnvLexicalReference? address) + (make-InstallValue (EnvLexicalReference-depth address) + (parse (set!-value exp) cenv) + #t)] + [(EnvPrefixReference? address) + (make-ToplevelSet (EnvPrefixReference-depth address) + (EnvPrefixReference-pos address) + (definition-variable exp) + (parse (set!-value exp) cenv))]) + (make-Constant (void)))))] + ;; Remember, this needs to be the last case. [(application? exp) (let ([cenv-with-scratch-space diff --git a/test-compiler.rkt b/test-compiler.rkt index 90653ed..94017da 100644 --- a/test-compiler.rkt +++ b/test-compiler.rkt @@ -667,8 +667,8 @@ (define b '(world)) (define reset! (lambda () - (set! a '()) - (reset!))) + (set! a '()))) + (reset!) (list a b)) '(() (world))) @@ -688,9 +688,8 @@ (lambda () (set! a '()) 'ok)) - (reset!) - (list a b)) - '(()(world))) + (list a b (reset!) a b)) + '((hello) (world) ok () (world))) (test '(begin (define a '(hello)) (define b '(world)) diff --git a/test-parse.rkt b/test-parse.rkt index 8b10405..668eec4 100644 --- a/test-parse.rkt +++ b/test-parse.rkt @@ -317,11 +317,12 @@ (make-Let1 (make-Constant 0) (make-BoxEnv 0 (make-Lam #f 0 - (make-InstallValue - 1 - (make-App (make-ToplevelRef 1 0) - (list (make-LocalRef 2 #t))) - #t) + (make-Seq (list (make-InstallValue + 1 + (make-App (make-ToplevelRef 1 0) + (list (make-LocalRef 2 #t))) + #t) + (make-Constant (void)))) '(1 0)))))) ;; x is 0, prefix is 1 @@ -336,10 +337,43 @@ (make-InstallValue 0 (make-Constant 0) #t) (make-InstallValue 1 (make-Constant 1) #t) (make-Lam #f 0 - (make-InstallValue - 1 - (make-App (make-ToplevelRef 1 0) - (list (make-LocalRef 2 #t))) - #t) + (make-Seq + (list (make-InstallValue + 1 + (make-App (make-ToplevelRef 1 0) + (list (make-LocalRef 2 #t))) + #t) + (make-Constant (void)))) '(2 0)))) #t))) + + + +(test (parse '(begin (define a '(hello)) + (define b '(world)) + (define reset! + (lambda () + (set! a '()) + (set! b '()))) + (reset!) + (list a b))) + (make-Top + (make-Prefix '(a b list reset!)) + (make-Seq + (list + (make-ToplevelSet 0 0 'a (make-Constant '(hello))) + (make-ToplevelSet 0 1 'b (make-Constant '(world))) + (make-ToplevelSet + 0 + 3 + 'reset! + (make-Lam + 'reset! + 0 + (make-Seq + (list + (make-Seq (list (make-ToplevelSet 0 0 'a (make-Constant '())) (make-Constant (void)))) + (make-Seq (list (make-ToplevelSet 0 1 'b (make-Constant '())) (make-Constant (void)))))) + '(0))) + (make-App (make-ToplevelRef 0 3) '()) + (make-App (make-ToplevelRef 2 2) (list (make-ToplevelRef 2 0) (make-ToplevelRef 2 1))))))) \ No newline at end of file