diff --git a/NOTES b/NOTES index 94ea350..e305a90 100644 --- a/NOTES +++ b/NOTES @@ -17,6 +17,9 @@ Some possible optimizations with application: +---------------------------------------------------------------------- + + Multiple values There's interplay between compile-proc-appl and the linkage compiling @@ -28,6 +31,36 @@ in Scheme" that I'll need to read. http://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.39.1668&rep=rep1&type=pdf +Basic idea: each return address is actually a pair, where the +secondary address lies at a fixed offset of the first and handles +multiple value return. Multiple values are returned back by keeping +them on the stack, and assigning argcount to the number of the +returned values. + + +In the context of my compiler: the compiler implicitly defines a +singleton, statement context by using next-linkage. But some uses of +next-linkage ignore the number of values that come back, and others +should raise an error. Here are the contexts that care: + + app + let1 + install-value + toplevel-set (define-values, assign) + + +For the contexts that don't care, we need to set up a return address +that just pops those values off. + + + + + + + + +---------------------------------------------------------------------- + diff --git a/assemble.rkt b/assemble.rkt index 00e2132..beb1653 100644 --- a/assemble.rkt +++ b/assemble.rkt @@ -143,6 +143,8 @@ EOF empty] [(GetControlStackLabel? op) empty] + [(GetControlStackLabel/MultipleValueReturn? op) + empty] [(CaptureEnvironment? op) empty] [(CaptureControl? op) @@ -377,7 +379,10 @@ EOF [(GetControlStackLabel? op) (format "MACHINE.control[MACHINE.control.length-1].label")] - + + [(GetControlStackLabel/MultipleValueReturn? op) + (format "MACHINE.control[MACHINE.control.length-1].label.multipleValueReturn")] + [(CaptureEnvironment? op) (format "MACHINE.env.slice(0, MACHINE.env.length - ~a)" (CaptureEnvironment-skip op))] diff --git a/bootstrapped-primitives.rkt b/bootstrapped-primitives.rkt index ef2f92b..8fc9aa0 100644 --- a/bootstrapped-primitives.rkt +++ b/bootstrapped-primitives.rkt @@ -143,6 +143,9 @@ + + + ;; The call/cc code is special: (let ([after-call/cc-code (make-label 'afterCallCCImplementation)]) (append @@ -157,6 +160,26 @@ + ;; values + (let ([after-values (make-label 'afterValues)] + [values-entry (make-label 'valuesEntry)]) + `(,(make-GotoStatement (make-Label after-values)) + ,values-entry + ;; values simply keeps the values on the stack, preserves the argcount, and does a return + ;; to the multiple-value-return address. + ,(make-AssignPrimOpStatement 'proc (make-GetControlStackLabel/MultipleValueReturn)) + ,(make-PopControlFrame) + ,(make-GotoStatement (make-Reg 'proc)) + ,after-values + ,(make-AssignPrimOpStatement (make-PrimitivesReference 'values) + (make-MakeCompiledProcedure values-entry + (make-ArityAtLeast 0) + '() + 'values)))) + + + + ;; As is apply: (let ([after-apply-code (make-label 'afterApplyCode)] [apply-entry (make-label 'applyEntry)]) diff --git a/il-structs.rkt b/il-structs.rkt index 77f0943..60e2d10 100644 --- a/il-structs.rkt +++ b/il-structs.rkt @@ -81,9 +81,16 @@ PopControlFrame/Prompt)) (define-type Statement (U UnlabeledStatement - Symbol ;; label + Symbol ;; label + LinkedLabel ;; Label with a reference to a multiple-return-value label )) + +(define-struct: LinkedLabel ([label : Symbol] + [linked-to : Symbol]) + #:transparent) + + (define-struct: AssignImmediateStatement ([target : Target] [value : OpArg]) #:transparent) @@ -115,11 +122,11 @@ ;; Adding a frame for getting back after procedure application. ;; The 'proc register must hold either #f or a closure at the time of ;; this call, as the control frame will hold onto the called procedure record. -(define-struct: PushControlFrame ([label : Symbol]) +(define-struct: PushControlFrame ([label : (U Symbol LinkedLabel)]) #:transparent) (define-struct: PushControlFrame/Prompt ([tag : (U OpArg DefaultContinuationPromptTag)] - [label : Symbol] + [label : (U Symbol LinkedLabel)] ;; TODO: add handler and arguments ) #:transparent) @@ -155,7 +162,11 @@ MakeCompiledProcedureShell ApplyPrimitiveProcedure + ;; Gets at the single-value-return address. GetControlStackLabel + ;; Gets at the multiple-value-return address. + GetControlStackLabel/MultipleValueReturn + MakeBoxedEnvironmentValue CaptureEnvironment @@ -209,6 +220,9 @@ ;; Gets the return address embedded at the top of the control stack. (define-struct: GetControlStackLabel () #:transparent) +(define-struct: GetControlStackLabel/MultipleValueReturn () + #:transparent) + (define-struct: MakeBoxedEnvironmentValue ([depth : Natural]) #:transparent) diff --git a/simulator-structs.rkt b/simulator-structs.rkt index 6341bab..2e64205 100644 --- a/simulator-structs.rkt +++ b/simulator-structs.rkt @@ -58,7 +58,7 @@ (define-type frame (U CallFrame PromptFrame)) -(define-struct: CallFrame ([return : Symbol] +(define-struct: CallFrame ([return : (U Symbol LinkedLabel)] ;; The procedure being called. Used to optimize self-application [proc : (U closure #f)] ;; TODO: add continuation marks @@ -67,7 +67,7 @@ #:mutable) (define-struct: PromptFrame ([tag : ContinuationPromptTagValue] - [return : Symbol] + [return : (U Symbol LinkedLabel)] [env-depth : Natural]) #:transparent) diff --git a/simulator.rkt b/simulator.rkt index 5c7f83c..e99381a 100644 --- a/simulator.rkt +++ b/simulator.rkt @@ -89,6 +89,8 @@ (cond [(symbol? i) 'ok] + [(LinkedLabel? i) + 'ok] [(AssignImmediateStatement? i) (step-assign-immediate! m i)] [(AssignPrimOpStatement? i) @@ -479,6 +481,13 @@ (PromptFrame-return frame)] [(CallFrame? frame) (CallFrame-return frame)])))] + [(GetControlStackLabel/MultipleValueReturn? op) + (target-updater! m (let ([frame (ensure-frame (first (machine-control m)))]) + (cond + [(PromptFrame? frame) + (PromptFrame-return frame)] + [(CallFrame? frame) + (CallFrame-return frame)])))] [(CaptureEnvironment? op) (target-updater! m (make-CapturedEnvironment (drop (machine-env m) diff --git a/test-compiler.rkt b/test-compiler.rkt index d4905f9..0365088 100644 --- a/test-compiler.rkt +++ b/test-compiler.rkt @@ -1075,6 +1075,10 @@ #:control-limit 3 #:with-bootstrapping? #t) + + + + #;(test (read (open-input-file "tests/conform/program0.sch")) (port->string (open-input-file "tests/conform/expected0.txt")))