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) [(Seq? exp)
(apply append (map (lambda: ([e : Expression]) (loop e cenv)) (apply append (map (lambda: ([e : Expression]) (loop e cenv))
(Seq-actions exp)))] (Seq-actions exp)))]
[(Splice? exp)
(apply append (map (lambda: ([e : Expression]) (loop e cenv))
(Splice-actions exp)))]
[(App? exp) [(App? exp)
(let ([new-cenv (append (build-list (length (App-operands exp)) (lambda: ([i : Natural]) '?)) (let ([new-cenv (append (build-list (length (App-operands exp)) (lambda: ([i : Natural]) '?))
cenv)]) cenv)])
@ -135,6 +138,11 @@
cenv cenv
target target
linkage)] linkage)]
[(Splice? exp)
(compile-splice (Splice-actions exp)
cenv
target
linkage)]
[(App? exp) [(App? exp)
(compile-application exp cenv target linkage)] (compile-application exp cenv target linkage)]
[(Let1? exp) [(Let1? exp)
@ -292,6 +300,26 @@
(compile-sequence (rest-exps seq) cenv target linkage)))) (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)) (: compile-lambda (Lam CompileTimeEnvironment Target Linkage -> InstructionSequence))
;; Write out code for lambda expressions. ;; Write out code for lambda expressions.
;; The lambda will close over the free variables. ;; The lambda will close over the free variables.
@ -1197,6 +1225,11 @@
(adjust-expression-depth action n skip)) (adjust-expression-depth action n skip))
(Seq-actions exp)))] (Seq-actions exp)))]
[(Splice? exp)
(make-Splice (map (lambda: ([action : Expression])
(adjust-expression-depth action n skip))
(Splice-actions exp)))]
[(App? exp) [(App? exp)
(make-App (adjust-expression-depth (App-operator exp) n (make-App (adjust-expression-depth (App-operator exp) n
(+ skip (length (App-operands exp)))) (+ skip (length (App-operands exp))))

3
expression-structs.rkt
View File

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

54
parse.rkt
View File

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

8
test-parse.rkt
View File

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