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

callcc still broken...

Browse Source
This commit is contained in:
Danny Yoo 2011-04-01 22:57:34 -04:00
parent 931078130f
commit 49ff8c0aa1
4 changed files with 119 additions and 122 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

133
compile.rkt
View File

@ -24,17 +24,16 @@
(let ([after-lam-bodies (make-label 'afterLamBodies)] (let ([after-lam-bodies (make-label 'afterLamBodies)]
[before-pop-prompt (make-label 'beforePopPrompt)]) [before-pop-prompt (make-label 'beforePopPrompt)])
(statements (statements
(end-with-linkage (append-instruction-sequences (make-instruction-sequence
linkage '() `(,(make-GotoStatement (make-Label after-lam-bodies))))
(append-instruction-sequences (make-instruction-sequence (compile-lambda-bodies (collect-all-lams exp))
`(,(make-GotoStatement (make-Label after-lam-bodies)))) after-lam-bodies
(compile-lambda-bodies (collect-all-lams exp))
after-lam-bodies (make-instruction-sequence
(make-instruction-sequence `(,(make-PushControlFrame/Prompt default-continuation-prompt-tag
`(,(make-PushControlFrame/Prompt default-continuation-prompt-tag before-pop-prompt)))
before-pop-prompt))) (compile exp '() target prompt-linkage)
(compile exp '() target prompt-linkage) before-pop-prompt))))
before-pop-prompt)))))
(define-struct: lam+cenv ([lam : Lam] (define-struct: lam+cenv ([lam : Lam]
[cenv : CompileTimeEnvironment])) [cenv : CompileTimeEnvironment]))
@ -166,10 +165,14 @@
(: compile-top (Top CompileTimeEnvironment Target Linkage -> InstructionSequence)) (: compile-top (Top CompileTimeEnvironment Target Linkage -> InstructionSequence))
(define (compile-top top cenv target linkage) (define (compile-top top cenv target linkage)
(let*: ([names : (Listof (U Symbol ModuleVariable False)) (Prefix-names (Top-prefix top))]) (let*: ([names : (Listof (U Symbol ModuleVariable False)) (Prefix-names (Top-prefix top))])
(append-instruction-sequences (end-with-linkage
(make-instruction-sequence linkage cenv
`(,(make-PerformStatement (make-ExtendEnvironment/Prefix! names)))) (append-instruction-sequences
(compile (Top-code top) (cons (Top-prefix top) cenv) target linkage)))) (make-instruction-sequence
`(,(make-PerformStatement (make-ExtendEnvironment/Prefix! names))))
(compile (Top-code top) (cons (Top-prefix top) cenv) target next-linkage)
(make-instruction-sequence
`(,(make-PopEnvironment 1 0)))))))
@ -180,27 +183,19 @@
(compile-linkage cenv linkage))) (compile-linkage cenv linkage)))
(: end-with-compiled-application-linkage (Linkage CompileTimeEnvironment InstructionSequence ->
InstructionSequence))
;; Add linkage for applications; we need to specialize this to preserve tail calls.
(define (end-with-compiled-application-linkage linkage cenv instruction-sequence)
(append-instruction-sequences instruction-sequence
(compile-application-linkage cenv linkage)))
(: compile-linkage (CompileTimeEnvironment Linkage -> InstructionSequence)) (: compile-linkage (CompileTimeEnvironment Linkage -> InstructionSequence))
(define (compile-linkage cenv linkage) (define (compile-linkage cenv linkage)
(cond (cond
[(ReturnLinkage? linkage) [(ReturnLinkage? linkage)
(make-instruction-sequence `(,(make-AssignPrimOpStatement 'proc (make-instruction-sequence `(,(make-AssignPrimOpStatement 'proc (make-GetControlStackLabel))
(make-GetControlStackLabel))
,(make-PopEnvironment (length cenv) 0) ,(make-PopEnvironment (length cenv) 0)
,(make-PopControlFrame) ,(make-PopControlFrame)
,(make-GotoStatement (make-Reg 'proc))))] ,(make-GotoStatement (make-Reg 'proc))))]
[(PromptLinkage? linkage) [(PromptLinkage? linkage)
(make-instruction-sequence `(,(make-AssignPrimOpStatement 'proc (make-GetControlStackLabel)) (make-instruction-sequence `(,(make-AssignPrimOpStatement 'proc (make-GetControlStackLabel))
,(make-PopControlFrame) ,(make-PopControlFrame/Prompt)
,(make-GotoStatement (make-Reg 'proc))))] ,(make-GotoStatement (make-Reg 'proc))))]
[(NextLinkage? linkage) [(NextLinkage? linkage)
empty-instruction-sequence] empty-instruction-sequence]
@ -208,27 +203,6 @@
(make-instruction-sequence `(,(make-GotoStatement (make-Label (LabelLinkage-label linkage)))))])) (make-instruction-sequence `(,(make-GotoStatement (make-Label (LabelLinkage-label linkage)))))]))
(: compile-application-linkage (CompileTimeEnvironment Linkage -> InstructionSequence))
;; Like compile-linkage, but the special case for return-linkage linkage already assumes
;; the stack has been appropriately popped.
(define (compile-application-linkage cenv linkage)
(cond
[(ReturnLinkage? linkage)
(make-instruction-sequence `(,(make-AssignPrimOpStatement 'proc (make-GetControlStackLabel))
,(make-PopControlFrame)
,(make-GotoStatement (make-Reg 'proc))))]
[(PromptLinkage? linkage)
(make-instruction-sequence `(,(make-AssignPrimOpStatement 'proc (make-GetControlStackLabel))
,(make-PopControlFrame)
,(make-PopEnvironment (length cenv) 0)
,(make-GotoStatement (make-Reg 'proc))))]
[(NextLinkage? linkage)
(make-instruction-sequence `(,(make-PopEnvironment (length cenv) 0)))]
[(LabelLinkage? linkage)
(make-instruction-sequence `(,(make-PopEnvironment (length cenv) 0)
,(make-GotoStatement (make-Label (LabelLinkage-label linkage)))))]))
(: compile-constant (Constant CompileTimeEnvironment Target Linkage -> InstructionSequence)) (: compile-constant (Constant CompileTimeEnvironment Target Linkage -> InstructionSequence))
(define (compile-constant exp cenv target linkage) (define (compile-constant exp cenv target linkage)
@ -758,6 +732,7 @@
proc-code proc-code
(juggle-operands operand-codes) (juggle-operands operand-codes)
(compile-procedure-call/statically-known-lam static-knowledge (compile-procedure-call/statically-known-lam static-knowledge
cenv
extended-cenv extended-cenv
(length (App-operands exp)) (length (App-operands exp))
target target
@ -804,20 +779,23 @@
(let: ([primitive-branch : LabelLinkage (make-LabelLinkage (make-label 'primitiveBranch))] (let: ([primitive-branch : LabelLinkage (make-LabelLinkage (make-label 'primitiveBranch))]
[compiled-branch : LabelLinkage (make-LabelLinkage (make-label 'compiledBranch))] [compiled-branch : LabelLinkage (make-LabelLinkage (make-label 'compiledBranch))]
[after-call : LabelLinkage (make-LabelLinkage (make-label 'afterCall))]) [after-call : LabelLinkage (make-LabelLinkage (make-label 'afterCall))])
(let: ([compiled-linkage : Linkage (if (eq? linkage next-linkage) after-call linkage)]) (let: ([compiled-linkage : Linkage (if (ReturnLinkage? linkage)
linkage
after-call)])
(append-instruction-sequences (append-instruction-sequences
(make-instruction-sequence (make-instruction-sequence
`(,(make-TestAndBranchStatement 'primitive-procedure? `(,(make-TestAndBranchStatement 'primitive-procedure?
'proc 'proc
(LabelLinkage-label primitive-branch)))) (LabelLinkage-label primitive-branch))))
;; Compiled branch
(LabelLinkage-label compiled-branch) (LabelLinkage-label compiled-branch)
(make-instruction-sequence (make-instruction-sequence
`(,(make-PerformStatement (make-CheckClosureArity! n)))) `(,(make-PerformStatement (make-CheckClosureArity! n))))
(end-with-compiled-application-linkage (compile-proc-appl extended-cenv (make-Reg 'val) n target compiled-linkage)
compiled-linkage
extended-cenv
(compile-proc-appl extended-cenv (make-Reg 'val) n target compiled-linkage))
(LabelLinkage-label primitive-branch) (LabelLinkage-label primitive-branch)
(end-with-linkage (end-with-linkage
@ -834,25 +812,27 @@
(if (not (= n 0)) (if (not (= n 0))
(make-instruction-sequence (make-instruction-sequence
`(,(make-PopEnvironment n 0))) `(,(make-PopEnvironment n 0)))
empty-instruction-sequence))) empty-instruction-sequence)
(LabelLinkage-label after-call))))) (LabelLinkage-label after-call)))))))
(: compile-procedure-call/statically-known-lam (: compile-procedure-call/statically-known-lam
(StaticallyKnownLam CompileTimeEnvironment Natural Target Linkage -> InstructionSequence)) (StaticallyKnownLam CompileTimeEnvironment CompileTimeEnvironment Natural Target Linkage -> InstructionSequence))
(define (compile-procedure-call/statically-known-lam static-knowledge extended-cenv n target linkage) (define (compile-procedure-call/statically-known-lam static-knowledge cenv extended-cenv n target linkage)
(let*: ([after-call : LabelLinkage (make-LabelLinkage (make-label 'afterCall))] (let*: ([after-call : LabelLinkage (make-LabelLinkage (make-label 'afterCall))]
[compiled-linkage : Linkage (if (eq? linkage next-linkage) after-call linkage)]) [compiled-linkage : Linkage (if (ReturnLinkage? linkage)
linkage
after-call)])
(append-instruction-sequences (append-instruction-sequences
(end-with-compiled-application-linkage (compile-proc-appl extended-cenv
compiled-linkage (make-Label (StaticallyKnownLam-entry-point static-knowledge))
extended-cenv n
(compile-proc-appl extended-cenv target
(make-Label (StaticallyKnownLam-entry-point static-knowledge)) compiled-linkage)
n (end-with-linkage
target linkage
compiled-linkage)) cenv
(LabelLinkage-label after-call)))) (LabelLinkage-label after-call)))))
@ -895,7 +875,8 @@
`(,(make-PushControlFrame proc-return) `(,(make-PushControlFrame proc-return)
,(make-AssignPrimOpStatement 'val (make-GetCompiledProcedureEntry)) ,(make-AssignPrimOpStatement 'val (make-GetCompiledProcedureEntry))
,(make-GotoStatement entry-point) ,(make-GotoStatement entry-point)
,proc-return)))] ,proc-return
#;,(make-PopEnvironment n 0))))]
[else [else
;; This case happens for evaluating arguments, since the ;; This case happens for evaluating arguments, since the
@ -934,10 +915,13 @@
(cond [(eq? target 'val) (cond [(eq? target 'val)
;; This case happens for a function call that isn't in ;; This case happens for a function call that isn't in
;; tail position. ;; tail position.
(make-instruction-sequence (let ([proc-return (make-label 'procReturn)])
`(,(make-PushControlFrame (LabelLinkage-label linkage)) (make-instruction-sequence
,(make-AssignPrimOpStatement 'val (make-GetCompiledProcedureEntry)) `(,(make-PushControlFrame proc-return)
,(make-GotoStatement entry-point)))] ,(make-AssignPrimOpStatement 'val (make-GetCompiledProcedureEntry))
,(make-GotoStatement entry-point)
,proc-return
,(make-GotoStatement (make-Label (LabelLinkage-label linkage))))))]
[else [else
;; This case happens for evaluating arguments, since the ;; This case happens for evaluating arguments, since the
@ -953,9 +937,6 @@
(: extract-static-knowledge (Expression CompileTimeEnvironment -> (: extract-static-knowledge (Expression CompileTimeEnvironment ->
CompileTimeEnvironmentEntry)) CompileTimeEnvironmentEntry))
;; Statically determines what we know about exp, given the compile time environment. ;; Statically determines what we know about exp, given the compile time environment.
@ -1006,7 +987,7 @@
[(ReturnLinkage? linkage) [(ReturnLinkage? linkage)
linkage] linkage]
[(PromptLinkage? linkage) [(PromptLinkage? linkage)
linkage] after-body-code]
[(LabelLinkage? linkage) [(LabelLinkage? linkage)
after-body-code])] after-body-code])]
[body-target : Target (adjust-target-depth target 1)] [body-target : Target (adjust-target-depth target 1)]
@ -1040,7 +1021,7 @@
[(ReturnLinkage? linkage) [(ReturnLinkage? linkage)
linkage] linkage]
[(PromptLinkage? linkage) [(PromptLinkage? linkage)
linkage] after-body-code]
[(LabelLinkage? linkage) [(LabelLinkage? linkage)
after-body-code])] after-body-code])]
[body-target : Target (adjust-target-depth target n)] [body-target : Target (adjust-target-depth target n)]
@ -1082,7 +1063,7 @@
[(ReturnLinkage? linkage) [(ReturnLinkage? linkage)
linkage] linkage]
[(PromptLinkage? linkage) [(PromptLinkage? linkage)
linkage] after-body-code]
[(LabelLinkage? linkage) [(LabelLinkage? linkage)
after-body-code])]) after-body-code])])
(end-with-linkage (end-with-linkage

6
il-structs.rkt
View File

@ -67,7 +67,9 @@
PushEnvironment PushEnvironment
PushControlFrame PushControlFrame
PushControlFrame/Prompt PushControlFrame/Prompt
PopControlFrame))
PopControlFrame
PopControlFrame/Prompt))
(define-type Statement (U UnlabeledStatement (define-type Statement (U UnlabeledStatement
Symbol ;; label Symbol ;; label
@ -92,6 +94,8 @@
(define-struct: PopControlFrame () (define-struct: PopControlFrame ()
#:transparent) #:transparent)
(define-struct: PopControlFrame/Prompt ()
#:transparent)
;; Adding a frame for getting back after procedure application. ;; Adding a frame for getting back after procedure application.
;; The 'proc register must hold either #f or a closure at the time of ;; The 'proc register must hold either #f or a closure at the time of

6
simulator.rkt
View File

@ -38,7 +38,7 @@
(define new-machine (define new-machine
(case-lambda: (case-lambda:
[([program-text : (Listof Statement)]) [([program-text : (Listof Statement)])
(new-machine program-text #t)] (new-machine program-text #f)]
[([program-text : (Listof Statement)] [([program-text : (Listof Statement)]
[with-bootstrapping-code? : Boolean]) [with-bootstrapping-code? : Boolean])
(let*: ([after-bootstrapping : Symbol (make-label 'afterBootstrapping)] (let*: ([after-bootstrapping : Symbol (make-label 'afterBootstrapping)]
@ -107,6 +107,8 @@
[(PushControlFrame/Prompt? i) [(PushControlFrame/Prompt? i)
(step-push-control-frame/prompt! m i)] (step-push-control-frame/prompt! m i)]
[(PopControlFrame? i) [(PopControlFrame? i)
(step-pop-control-frame! m i)]
[(PopControlFrame/Prompt? i)
(step-pop-control-frame! m i)])]) (step-pop-control-frame! m i)])])
(increment-pc! m))) (increment-pc! m)))
@ -168,7 +170,7 @@
(: step-pop-control-frame! (machine PopControlFrame -> 'ok)) (: step-pop-control-frame! (machine (U PopControlFrame PopControlFrame/Prompt) -> 'ok))
(define (step-pop-control-frame! m stmt) (define (step-pop-control-frame! m stmt)
(let: ([l : Symbol (control-pop! m)]) (let: ([l : Symbol (control-pop! m)])
'ok)) 'ok))

96
test-compiler.rkt
View File

@ -21,13 +21,13 @@
(begin (begin
(printf "Running ~s ...\n" code) (printf "Running ~s ...\n" code)
(let*-values([(a-machine num-steps) (let*-values([(a-machine num-steps)
(run (new-machine (run-compiler code)) options ...)] (run code options ...)]
[(actual) (PrimitiveValue->racket (machine-val a-machine))]) [(actual) (PrimitiveValue->racket (machine-val a-machine))])
(unless (equal? actual exp) (unless (equal? actual exp)
(raise-syntax-error #f (format "Expected ~s, got ~s" exp actual) (raise-syntax-error #f (format "Expected ~s, got ~s" exp actual)
#'stx)) #'stx))
(unless (= (machine-stack-size a-machine) 1) (unless (= (machine-stack-size a-machine) 0)
(raise-syntax-error #f (format "Stack is not back to the prefix as expected!") (raise-syntax-error #f (format "Stack is not back to empty as expected!")
#'stx)) #'stx))
(unless (null? (machine-control a-machine)) (unless (null? (machine-control a-machine))
@ -47,7 +47,7 @@
(with-handlers ([exn:fail? (lambda (exn) (with-handlers ([exn:fail? (lambda (exn)
(printf "ok\n\n") (printf "ok\n\n")
(return))]) (return))])
(run (new-machine (run-compiler code)) options ...)) (run code options ...))
(raise-syntax-error #f (format "Expected an exception") (raise-syntax-error #f (format "Expected an exception")
#'stx)))))])) #'stx)))))]))
@ -55,32 +55,33 @@
;; run: machine -> (machine number) ;; run: machine -> (machine number)
;; Run the machine to completion. ;; Run the machine to completion.
(define (run m (define (run code
#:debug? (debug? false) #:debug? (debug? false)
#:stack-limit (stack-limit false) #:stack-limit (stack-limit false)
#:control-limit (control-limit false)) #:control-limit (control-limit false)
#:with-bootstrapping? (with-bootstrapping? false))
(let loop ([steps 0]) (let ([m (new-machine (run-compiler code) with-bootstrapping?)])
(when debug? (let loop ([steps 0])
(when (can-step? m) (when debug?
(printf "|env|=~s, |control|=~s, instruction=~s\n" (when (can-step? m)
(length (machine-env m)) (printf "|env|=~s, |control|=~s, instruction=~s\n"
(length (machine-control m)) (length (machine-env m))
(current-instruction m)))) (length (machine-control m))
(when stack-limit (current-instruction m))))
(when (> (machine-stack-size m) stack-limit) (when stack-limit
(error 'run "Stack overflow"))) (when (> (machine-stack-size m) stack-limit)
(error 'run "Stack overflow")))
(when control-limit
(when (> (machine-control-size m) control-limit) (when control-limit
(error 'run "Control overflow"))) (when (> (machine-control-size m) control-limit)
(error 'run "Control overflow")))
(cond
[(can-step? m) (cond
(step! m) [(can-step? m)
(loop (add1 steps))] (step! m)
[else (loop (add1 steps))]
(values m steps)]))) [else
(values m steps)]))))
;; Atomic expressions ;; Atomic expressions
@ -580,20 +581,22 @@
#:control-limit 3) #:control-limit 3)
(test '(let ([x 16]) #;(test '(let ([x 16])
(call/cc (lambda (k) (+ x x)))) (call/cc (lambda (k) (+ x x))))
32) 32
#:with-bootstrapping? #t)
(test '(add1 (let ([x 16]) #;(test '(add1 (let ([x 16])
(call/cc (lambda (k) (call/cc (lambda (k)
(k 0) (k 0)
(+ x x))))) (+ x x)))))
1) 1
#:with-bootstrapping? #t)
;; Reference: http://lists.racket-lang.org/users/archive/2009-January/029812.html ;; Reference: http://lists.racket-lang.org/users/archive/2009-January/029812.html
(let ([op (open-output-string)]) #;(let ([op (open-output-string)])
(parameterize ([current-simulated-output-port op]) (parameterize ([current-simulated-output-port op])
(test '(begin (define program (lambda () (test '(begin (define program (lambda ()
(let ((y (call/cc (lambda (c) c)))) (let ((y (call/cc (lambda (c) c))))
@ -603,7 +606,8 @@
(call/cc (lambda (c) (y c))) (call/cc (lambda (c) (y c)))
(display 3)))) (display 3))))
(program)) (program))
(void)) (void)
#:with-bootstrapping? #t)
(unless (string=? (get-output-string op) (unless (string=? (get-output-string op)
"11213") "11213")
(error "puzzle failed: ~s" (get-output-string op))))) (error "puzzle failed: ~s" (get-output-string op)))))
@ -612,7 +616,7 @@
;; ctak ;; ctak
(test '(begin #;(test '(begin
(define (ctak x y z) (define (ctak x y z)
(call-with-current-continuation (call-with-current-continuation
(lambda (k) (lambda (k)
@ -643,7 +647,8 @@
x x
y)))))))) y))))))))
(ctak 18 12 6)) (ctak 18 12 6))
7) 7
#:with-bootstrapping? #t)
(test '(let ([x 3] (test '(let ([x 3]
@ -788,7 +793,7 @@
(test '(begin #;(test '(begin
(define (make-gen gen) (define (make-gen gen)
(let ([cont (box #f)]) (let ([cont (box #f)])
(lambda () (lambda ()
@ -807,13 +812,15 @@
(return "c")))) (return "c"))))
(list (g1))) (list (g1)))
(list "a"))
(list "a")
#:with-bootstrapping #t)
(test '(begin (define (f) #;(test '(begin (define (f)
(define cont #f) (define cont #f)
(define n 0) (define n 0)
(call/cc (lambda (x) (set! cont x))) (call/cc (lambda (x) (set! cont x)))
@ -822,11 +829,12 @@
(cont 'dontcare)) (cont 'dontcare))
n) n)
(f)) (f))
10) 10
#:with-bootstrapping #t)
;; This should produce 0 because there needs to be a continuation prompt around each evaluation. ;; This should produce 0 because there needs to be a continuation prompt around each evaluation.
(test '(begin #;(test '(begin
(define cont #f) (define cont #f)
(define n 0) (define n 0)
(call/cc (lambda (x) (set! cont x))) (call/cc (lambda (x) (set! cont x)))
@ -834,7 +842,8 @@
(if (< n 10) (if (< n 10)
(cont 'dontcare)) (cont 'dontcare))
n) n)
0) 0
#:with-bootstrapping? #t)
@ -888,7 +897,8 @@
(displayln (g1)) (displayln (g1))
(displayln (g1)) (displayln (g1))
(displayln (g1))) (displayln (g1)))
"a\nb\nc\n") "a\nb\nc\n"
#:with-bootstrapping #t)