From e1c406c6a1c6cbddfe997d8955d4970e39761f83 Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Mon, 25 Apr 2011 15:42:37 -0400 Subject: [PATCH] hacking in a call-with-values form to see if i got apply-values right --- assemble-helpers.rkt | 11 +++++--- bootstrapped-primitives.rkt | 7 ++++- collect-jump-targets.rkt | 4 ++- compiler.rkt | 52 ++++++++++++++++++++++++++++++++++--- expression-structs.rkt | 9 ++++++- il-structs.rkt | 8 +++--- optimize-il.rkt | 4 ++- parse.rkt | 40 +++++++++++++++++++++++++++- simulator.rkt | 8 +++++- test-parse.rkt | 14 +++++++++- 10 files changed, 141 insertions(+), 16 deletions(-) diff --git a/assemble-helpers.rkt b/assemble-helpers.rkt index 73b7db0..d5b0e47 100644 --- a/assemble-helpers.rkt +++ b/assemble-helpers.rkt @@ -43,7 +43,9 @@ [(ControlStackLabel/MultipleValueReturn? v) (assemble-control-stack-label/multiple-value-return v)] [(CompiledProcedureEntry? v) - (assemble-compiled-procedure-entry v)])) + (assemble-compiled-procedure-entry v)] + [(ControlFrameTemporary? v) + (assemble-control-frame-temporary v)])) @@ -64,10 +66,13 @@ [(PrimitivesReference? target) (format "MACHINE.primitives[~s]" (symbol->string (PrimitivesReference-name target)))] [(ControlFrameTemporary? target) - (format "MACHINE.control[MACHINE.control.length-1].~a" - (ControlFrameTemporary-name target))])) + (assemble-control-frame-temporary target)])) +(: assemble-control-frame-temporary (ControlFrameTemporary -> String)) +(define (assemble-control-frame-temporary t) + (format "MACHINE.control[MACHINE.control.length-1].~a" + (ControlFrameTemporary-name t))) ;; fixme: use js->string (: assemble-const (Const -> String)) diff --git a/bootstrapped-primitives.rkt b/bootstrapped-primitives.rkt index de0ea02..0dfd9a9 100644 --- a/bootstrapped-primitives.rkt +++ b/bootstrapped-primitives.rkt @@ -220,4 +220,9 @@ ,after-apply-code ,(make-AssignPrimOpStatement (make-PrimitivesReference 'apply) - (make-MakeCompiledProcedure apply-entry (make-ArityAtLeast 2) '() 'apply)))))) \ No newline at end of file + (make-MakeCompiledProcedure apply-entry (make-ArityAtLeast 2) '() 'apply)))) + + + + + )) \ No newline at end of file diff --git a/collect-jump-targets.rkt b/collect-jump-targets.rkt index 59cc920..12405b7 100644 --- a/collect-jump-targets.rkt +++ b/collect-jump-targets.rkt @@ -84,7 +84,9 @@ [(ControlStackLabel/MultipleValueReturn? an-input) empty] [(CompiledProcedureEntry? an-input) - (collect-input (CompiledProcedureEntry-proc an-input))])) + (collect-input (CompiledProcedureEntry-proc an-input))] + [(ControlFrameTemporary? an-input) + empty])) (: collect-location ((U Reg Label) -> (Listof Symbol))) (define (collect-location a-location) diff --git a/compiler.rkt b/compiler.rkt index ba8aa18..ee2458f 100644 --- a/compiler.rkt +++ b/compiler.rkt @@ -121,7 +121,10 @@ [(WithContMark? exp) (append (loop (WithContMark-key exp) cenv) (loop (WithContMark-value exp) cenv) - (loop (WithContMark-body exp) cenv))]))) + (loop (WithContMark-body exp) cenv))] + [(ApplyValues? exp) + (append (loop (ApplyValues-proc exp) cenv) + (loop (ApplyValues-args-expr exp) cenv))]))) @@ -178,7 +181,9 @@ [(LetRec? exp) (compile-let-rec exp cenv target linkage)] [(WithContMark? exp) - (compile-with-cont-mark exp cenv target linkage)])) + (compile-with-cont-mark exp cenv target linkage)] + [(ApplyValues? exp) + (compile-apply-values exp cenv target linkage)])) @@ -1416,6 +1421,44 @@ (in-other-context linkage)])) +(: compile-apply-values (ApplyValues CompileTimeEnvironment Target Linkage -> InstructionSequence)) +(define (compile-apply-values exp cenv target linkage) + (append-instruction-sequences + + ;; Save the procedure value temporarily in a control stack frame + (make-instruction-sequence + `(,(make-PushControlFrame/Generic))) + (compile (ApplyValues-proc exp) + cenv + (make-ControlFrameTemporary 'pendingApplyValuesProc) + next-linkage/expects-single) + + ;; Then evaluate the value producer in a context that expects + ;; the return values to be placed onto the stack. + (compile (ApplyValues-args-expr exp) + cenv + 'val + next-linkage/values-on-stack) + + ;; Retrieve the procedure off the temporary control frame. + (make-instruction-sequence + `(,(make-AssignImmediateStatement + 'proc + (make-ControlFrameTemporary 'pendingApplyValuesProc)))) + + ;; Pop off the temporary control frame + (make-instruction-sequence + `(,(make-PopControlFrame))) + + ;; Finally, do the generic call into the function. + (compile-general-procedure-call cenv (make-Reg 'argcount) target linkage))) + + + + + + + (: append-instruction-sequences (InstructionSequence * -> InstructionSequence)) (define (append-instruction-sequences . seqs) @@ -1594,6 +1637,9 @@ [(WithContMark? exp) (make-WithContMark (adjust-expression-depth (WithContMark-key exp) n skip) (adjust-expression-depth (WithContMark-value exp) n skip) - (adjust-expression-depth (WithContMark-body exp) n skip))])) + (adjust-expression-depth (WithContMark-body exp) n skip))] + [(ApplyValues? exp) + (make-ApplyValues (adjust-expression-depth (ApplyValues-proc exp) n skip) + (adjust-expression-depth (ApplyValues-args-expr exp) n skip))])) diff --git a/expression-structs.rkt b/expression-structs.rkt index f3ad0e7..03b1843 100644 --- a/expression-structs.rkt +++ b/expression-structs.rkt @@ -14,7 +14,8 @@ LetRec InstallValue BoxEnv - WithContMark)) + WithContMark + ApplyValues)) (define-struct: Top ([prefix : Prefix] [code : Expression]) #:transparent) @@ -80,6 +81,12 @@ #:transparent) +(define-struct: ApplyValues ([proc : Expression] + [args-expr : Expression]) + #:transparent) + + + (: last-exp? ((Listof Expression) -> Boolean)) (define (last-exp? seq) (null? (cdr seq))) diff --git a/il-structs.rkt b/il-structs.rkt index 2a52852..23010b4 100644 --- a/il-structs.rkt +++ b/il-structs.rkt @@ -30,7 +30,7 @@ ControlStackLabel ControlStackLabel/MultipleValueReturn CompiledProcedureEntry - )) + ControlFrameTemporary)) ;; Targets: these are the allowable lhs's for an assignment. @@ -42,7 +42,9 @@ ;; When we need to store a value temporarily in the top control frame, we can use this as a target. -(define-struct: ControlFrameTemporary ([name : (U 'pendingContinuationMarkKey)]) +(define-struct: ControlFrameTemporary ([name : (U 'pendingContinuationMarkKey ;; for continuation marks + 'pendingApplyValuesProc ;; for apply-values + )]) #:transparent) @@ -419,7 +421,7 @@ (define-struct: NextLinkage ([context : ValuesContext])) (define next-linkage/drop-multiple (make-NextLinkage 'drop-multiple)) (define next-linkage/expects-single (make-NextLinkage 1)) - +(define next-linkage/values-on-stack (make-NextLinkage 'keep-multiple)) diff --git a/optimize-il.rkt b/optimize-il.rkt index 9d2c0f3..9d14f9c 100644 --- a/optimize-il.rkt +++ b/optimize-il.rkt @@ -71,7 +71,9 @@ [(ControlStackLabel/MultipleValueReturn? oparg) oparg] [(CompiledProcedureEntry? oparg) - (make-CompiledProcedureEntry (adjust-oparg-depth (CompiledProcedureEntry-proc oparg) n))])) + (make-CompiledProcedureEntry (adjust-oparg-depth (CompiledProcedureEntry-proc oparg) n))] + [(ControlFrameTemporary? oparg) + oparg])) (define-predicate natural? Natural) diff --git a/parse.rkt b/parse.rkt index 767575b..56051b2 100644 --- a/parse.rkt +++ b/parse.rkt @@ -151,7 +151,9 @@ (make-WithContMark (parse (with-continuation-mark-key exp) cenv #f) (parse (with-continuation-mark-value exp) cenv #f) (parse (with-continuation-mark-body exp) cenv #f))] - + + [(call-with-values? exp) + (parse-call-with-values exp cenv)] ;; Remember, this needs to be the last case. [(application? exp) @@ -282,6 +284,10 @@ (append (loop (with-continuation-mark-key exp)) (loop (with-continuation-mark-value exp)) (loop (with-continuation-mark-body exp)))] + + [(call-with-values? exp) + (append (loop (call-with-values-producer exp)) + (loop (call-with-values-consumer exp)))] ;; Remember: this needs to be the last case. [(application? exp) @@ -351,6 +357,10 @@ (loop (with-continuation-mark-value exp)) (loop (with-continuation-mark-body exp)))] + [(call-with-values? exp) + (append (loop (call-with-values-producer exp)) + (loop (call-with-values-consumer exp)))] + ;; Remember, this needs to be the last case. [(application? exp) (append (loop (operator exp)) @@ -582,6 +592,26 @@ #t))]))) + +(define (parse-call-with-values exp cenv) + (cond + [(and (lambda? (call-with-values-producer exp)) + (empty? (lambda-parameters (call-with-values-producer exp)))) + (let ([producer (parse `(begin ,@(lambda-body (call-with-values-producer exp))) + cenv #f)] + [consumer-proc (parse (call-with-values-consumer exp) cenv #f)]) + (make-ApplyValues consumer-proc producer))] + [else + (let ([producer (parse `(,(call-with-values-producer exp)) cenv #f)] + [consumer-proc (parse (call-with-values-consumer exp) cenv #f)]) + (make-ApplyValues consumer-proc producer))])) + + + + + + + (define (desugar-let* exp) (let ([body (let-body exp)]) (let loop ([vars (let-variables exp)] @@ -604,6 +634,7 @@ + (define (named-let? exp) (and (tagged-list? exp 'let) (symbol? (cadr exp)))) @@ -622,6 +653,13 @@ (cdddr exp)) +(define (call-with-values? exp) + (tagged-list? exp 'call-with-values)) +(define (call-with-values-producer exp) + (cadr exp)) +(define (call-with-values-consumer exp) + (caddr exp)) + ;; any -> boolean (define (let? exp) diff --git a/simulator.rkt b/simulator.rkt index afb3e07..7af362e 100644 --- a/simulator.rkt +++ b/simulator.rkt @@ -746,7 +746,13 @@ [(CompiledProcedureEntry? an-oparg) (let ([proc (ensure-closure (evaluate-oparg m (CompiledProcedureEntry-proc an-oparg)))]) - (closure-label proc))])) + (closure-label proc))] + + [(ControlFrameTemporary? an-oparg) + (let ([ht (frame-temps (control-top m))]) + (hash-ref ht + (ControlFrameTemporary-name an-oparg)))])) + (: ensure-closure-or-false (SlotValue -> (U closure #f))) diff --git a/test-parse.rkt b/test-parse.rkt index bf08447..653f38c 100644 --- a/test-parse.rkt +++ b/test-parse.rkt @@ -486,4 +486,16 @@ (make-Top (make-Prefix '(x y z)) (make-WithContMark (make-ToplevelRef 0 0) (make-ToplevelRef 0 1) - (make-ToplevelRef 0 2)))) \ No newline at end of file + (make-ToplevelRef 0 2)))) + + + +(test (parse '(call-with-values x y)) + (make-Top (make-Prefix '(x y)) + (make-ApplyValues (make-ToplevelRef 0 1) + (make-App (make-ToplevelRef 0 0) (list))))) + +(test (parse '(call-with-values (lambda () x) y)) + (make-Top (make-Prefix '(x y)) + (make-ApplyValues (make-ToplevelRef 0 1) + (make-ToplevelRef 0 0)))) \ No newline at end of file