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

about to work on prompts and splices

Browse Source
This commit is contained in:
Danny Yoo 2011-04-01 13:15:41 -04:00
parent ec26794c8f
commit dbd8d5bebc
5 changed files with 144 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
compile.rkt
View File

@ -65,6 +65,9 @@
[(Seq? exp)
(apply append (map (lambda: ([e : Expression]) (loop e cenv))
(Seq-actions exp)))]
[(Splice? exp)
(apply append (map (lambda: ([e : Expression]) (loop e cenv))
(Splice-actions exp)))]
[(App? exp)
(let ([new-cenv (append (build-list (length (App-operands exp)) (lambda: ([i : Natural]) '?))
cenv)])
@ -135,6 +138,11 @@
cenv
target
linkage)]
[(Splice? exp)
(compile-splice (Splice-actions exp)
cenv
target
linkage)]
[(App? exp)
(compile-application exp cenv target linkage)]
[(Let1? exp)
@ -292,6 +300,26 @@
(compile-sequence (rest-exps seq) cenv target linkage))))
(: compile-splice ((Listof Expression) CompileTimeEnvironment Target Linkage -> InstructionSequence))
;; Wrap a continuation prompt around each of the expressions.
(define (compile-splice seq cenv target linkage)
(cond [(last-exp? seq)
(end-with-linkage
linkage
cenv
(append-instruction-sequences
#;(make-instruction-sequence `(,(make-PushPrompt)))
(compile (first-exp seq) cenv target next-linkage)
#;(make-instruction-sequence `(,(make-PushPrompt)))))]
[else
(append-instruction-sequences
#;(make-instruction-sequence `(,(make-PushPrompt)))
(compile (first-exp seq) cenv target next-linkage)
#;(make-instruction-sequence `(,(make-PushPrompt)))
(compile-splice (rest-exps seq) cenv target linkage))]))
(: compile-lambda (Lam CompileTimeEnvironment Target Linkage -> InstructionSequence))
;; Write out code for lambda expressions.
;; The lambda will close over the free variables.
@ -1196,6 +1224,11 @@
(make-Seq (map (lambda: ([action : Expression])
(adjust-expression-depth action n skip))
(Seq-actions exp)))]
[(Splice? exp)
(make-Splice (map (lambda: ([action : Expression])
(adjust-expression-depth action n skip))
(Splice-actions exp)))]
[(App? exp)
(make-App (adjust-expression-depth (App-operator exp) n

3
expression-structs.rkt
View File

@ -8,7 +8,7 @@
(define-type Expression (U Top Constant
ToplevelRef LocalRef
ToplevelSet
Branch Lam Seq App
Branch Lam Seq Splice App
Let1
LetVoid
LetRec
@ -44,6 +44,7 @@
[entry-label : Symbol]) #:transparent)
(define-struct: Seq ([actions : (Listof Expression)]) #:transparent)
(define-struct: Splice ([actions : (Listof Expression)]) #:transparent)
(define-struct: App ([operator : Expression]
[operands : (Listof Expression)]) #:transparent)

54
parse.rkt
View File

@ -14,7 +14,7 @@
(define (-parse exp)
(let* ([prefix (construct-the-prefix exp)])
(make-Top prefix (parse exp (extend-lexical-environment '() prefix)))))
(make-Top prefix (parse exp (extend-lexical-environment '() prefix) #t))))
@ -72,7 +72,7 @@
;; parse: Any ParseTimeEnvironment -> Expression
;; Compile an expression.
(define (parse exp cenv)
(define (parse exp cenv at-toplevel?)
(cond
[(self-evaluating? exp)
(make-Constant exp)]
@ -100,30 +100,30 @@
(EnvPrefixReference-pos address)
(definition-variable exp)
(parameterize ([current-defined-name (definition-variable exp)])
(parse (definition-value exp) cenv)))]))]
(parse (definition-value exp) cenv #f)))]))]
[(if? exp)
(make-Branch (parse (if-predicate exp) cenv)
(parse (if-consequent exp) cenv)
(parse (if-alternative exp) cenv))]
(make-Branch (parse (if-predicate exp) cenv #f)
(parse (if-consequent exp) cenv #f)
(parse (if-alternative exp) cenv #f))]
[(cond? exp)
(parse (desugar-cond exp) cenv)]
(parse (desugar-cond exp) cenv #f)]
[(lambda? exp)
(parse-lambda exp cenv)]
[(begin? exp)
(let ([actions (map (lambda (e)
(parse e cenv))
(parse e cenv at-toplevel?))
(begin-actions exp))])
(seq actions))]
((if at-toplevel? make-Splice seq) actions))]
[(named-let? exp)
(parse (desugar-named-let exp) cenv)]
(parse (desugar-named-let exp) cenv #f)]
[(let*? exp)
(parse (desugar-let* exp) cenv)]
(parse (desugar-let* exp) cenv #f)]
[(let? exp)
(parse-let exp cenv)]
@ -138,21 +138,21 @@
(make-Seq (list (cond
[(EnvLexicalReference? address)
(make-InstallValue (EnvLexicalReference-depth address)
(parse (set!-value exp) cenv)
(parse (set!-value exp) cenv #f)
#t)]
[(EnvPrefixReference? address)
(make-ToplevelSet (EnvPrefixReference-depth address)
(EnvPrefixReference-pos address)
(definition-variable exp)
(parse (set!-value exp) cenv))])
(parse (set!-value exp) cenv #f))])
(make-Constant (void)))))]
;; Remember, this needs to be the last case.
[(application? exp)
(let ([cenv-with-scratch-space
(extend-lexical-environment/placeholders cenv (length (operands exp)))])
(make-App (parse (operator exp) cenv-with-scratch-space)
(map (lambda (rand) (parse rand cenv-with-scratch-space))
(make-App (parse (operator exp) cenv-with-scratch-space #f)
(map (lambda (rand) (parse rand cenv-with-scratch-space #f))
(operands exp))))]
[else
(error 'compile "Unknown expression type ~e" exp)]))
@ -180,7 +180,7 @@
(make-BoxEnv (env-reference-depth (find-variable a-mutated-param body-cenv))
code))
(seq (map (lambda (b)
(parse b body-cenv))
(parse b body-cenv #f))
(lambda-body exp)))
mutated-parameters)])
(make-Lam (current-defined-name)
@ -441,16 +441,17 @@
[body (let-body exp)])
(cond
[(= 0 (length vars))
(parse `(begin ,@body) cenv)]
(parse `(begin ,@body) cenv #f)]
[(= 1 (length vars))
(let* ([mutated? (and (member (first vars) (find-mutated-names `(begin ,@body))) #t)]
[let-body (parse `(begin ,@body)
(extend-lexical-environment/names
cenv
(list (first vars))
(list mutated?)))])
(list mutated?))
#f)])
(make-Let1 (parameterize ([current-defined-name (first vars)])
(parse (car rhss) (extend-lexical-environment/placeholders cenv 1)))
(parse (car rhss) (extend-lexical-environment/placeholders cenv 1) #f))
(if mutated?
(make-BoxEnv 0 let-body)
let-body)))]
@ -463,7 +464,7 @@
(map (lambda (var rhs index)
(make-InstallValue index
(parameterize ([current-defined-name var])
(parse rhs rhs-cenv))
(parse rhs rhs-cenv #f))
any-mutated?))
vars
rhss
@ -473,7 +474,8 @@
cenv vars
(build-list (length vars)
(lambda (i)
any-mutated?)))))))
any-mutated?)))
#f))))
any-mutated?))])))
@ -485,7 +487,7 @@
[n (length vars)])
(cond
[(= 0 (length vars))
(parse `(begin ,@body) cenv)]
(parse `(begin ,@body) cenv #f)]
[(and (andmap lambda? rhss)
(empty? (list-intersection
vars
@ -498,10 +500,10 @@
;; Install them in reverse order, so that the closure shell for the last element
;; in procs is at stack position 0.
(make-LetRec (map (lambda (rhs name) (parameterize ([current-defined-name name])
(parse rhs new-cenv)))
(parse rhs new-cenv #f)))
rhss
vars)
(parse `(begin ,@body) new-cenv)))]
(parse `(begin ,@body) new-cenv #f)))]
[else
(let ([new-cenv (extend-lexical-environment/boxed-names cenv (reverse vars))])
(make-LetVoid (length vars)
@ -509,12 +511,12 @@
(map (lambda (var rhs index)
(make-InstallValue (- n 1 index)
(parameterize ([current-defined-name var])
(parse rhs new-cenv))
(parse rhs new-cenv #f))
#t))
vars
rhss
(build-list (length rhss) (lambda (i) i)))
(list (parse `(begin ,@body) new-cenv))))
(list (parse `(begin ,@body) new-cenv #f))))
#t))])))

77
test-compiler.rkt
View File

@ -788,6 +788,83 @@
(test '(begin
(define (make-gen gen)
(let ([cont (box #f)])
(lambda ()
(call/cc (lambda (caller)
(if (unbox cont)
((unbox cont) caller)
(gen (lambda (v)
(call/cc (lambda (gen-k)
(begin
(set-box! cont gen-k)
(caller v))))))))))))
(define g1 (make-gen (lambda (return)
(return "a")
(return "b")
(return "c"))))
(list (g1)))
(list "a"))
;; FIXME: this test is failing. I think we need prompts to delimit
;; the continuation capture.
#;(test '(begin
(define (make-gen gen)
(let ([cont (box #f)])
(lambda ()
(call/cc (lambda (caller)
(if (unbox cont)
((unbox cont) caller)
(gen (lambda (v)
(call/cc (lambda (gen-k)
(begin
(set-box! cont gen-k)
(caller v))))))))))))
(define g1 (make-gen (lambda (return)
(return "a")
(return "b")
(return "c"))))
(g1)
(g1))
"b")
;; FIXME: this test is failing. I think we need prompts to delimit
;; the continuation capture.
#;(test '(begin
(define (make-gen gen)
(let ([cont (box #f)])
(lambda ()
(call/cc (lambda (caller)
(if (unbox cont)
((unbox cont) caller)
(gen (lambda (v)
(call/cc (lambda (gen-k)
(begin
(set-box! cont gen-k)
(caller v))))))))))))
(define g1 (make-gen (lambda (return)
(return "a")
(return "b")
(return "c"))))
(displayln (g1))
(displayln (g1))
(displayln (g1)))
"a\nb\nc\n")
#;(test (read (open-input-file "tests/conform/program0.sch"))

8
test-parse.rkt
View File

@ -42,7 +42,7 @@
(test (parse '(begin hello world))
(make-Top (make-Prefix '(hello world))
(make-Seq (list (make-ToplevelRef 0 0)
(make-Splice (list (make-ToplevelRef 0 0)
(make-ToplevelRef 0 1)))))
(test (parse '(define x y))
@ -52,8 +52,8 @@
(test (parse '(begin (define x 42)
(define y x)))
(make-Top (make-Prefix '(x y))
(make-Seq (list (make-ToplevelSet 0 0 'x (make-Constant 42))
(make-ToplevelSet 0 1 'y (make-ToplevelRef 0 0))))))
(make-Splice (list (make-ToplevelSet 0 0 'x (make-Constant 42))
(make-ToplevelSet 0 1 'y (make-ToplevelRef 0 0))))))
(test (parse '(if x y z))
(make-Top (make-Prefix '(x y z))
@ -402,7 +402,7 @@
(list a b)))
(make-Top
(make-Prefix `(a b ,(make-ModuleVariable 'list '#%kernel) reset!))
(make-Seq
(make-Splice
(list
(make-ToplevelSet 0 0 'a (make-Constant '(hello)))
(make-ToplevelSet 0 1 'b (make-Constant '(world)))