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

6
il-structs.rkt
View File

@ -67,7 +67,9 @@
PushEnvironment
PushControlFrame
PushControlFrame/Prompt
PopControlFrame))
PopControlFrame
PopControlFrame/Prompt))
(define-type Statement (U UnlabeledStatement
Symbol ;; label
@ -92,6 +94,8 @@
(define-struct: PopControlFrame ()
#:transparent)
(define-struct: PopControlFrame/Prompt ()
#:transparent)
;; Adding a frame for getting back after procedure application.
;; 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
(case-lambda:
[([program-text : (Listof Statement)])
(new-machine program-text #t)]
(new-machine program-text #f)]
[([program-text : (Listof Statement)]
[with-bootstrapping-code? : Boolean])
(let*: ([after-bootstrapping : Symbol (make-label 'afterBootstrapping)]
@ -107,6 +107,8 @@
[(PushControlFrame/Prompt? i)
(step-push-control-frame/prompt! m i)]
[(PopControlFrame? i)
(step-pop-control-frame! m i)]
[(PopControlFrame/Prompt? i)
(step-pop-control-frame! m i)])])
(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)
(let: ([l : Symbol (control-pop! m)])
'ok))

96
test-compiler.rkt
View File

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