#lang typed/racket/base (require "arity-structs.rkt" "expression-structs.rkt" "lexical-structs.rkt" "il-structs.rkt" "compiler-structs.rkt" "kernel-primitives.rkt" "optimize-il.rkt" "analyzer-structs.rkt" "../parameters.rkt" "../sets.rkt" racket/bool racket/list racket/match) (require/typed "../logger.rkt" [log-debug (String -> Void)]) (require/typed "compiler-helper.rkt" [ensure-const-value (Any -> const-value)]) (provide (rename-out [-compile compile]) compile-general-procedure-call) (: -compile (Expression Target Linkage -> (Listof Statement))) ;; Generates the instruction-sequence stream. ;; Note: the toplevel generates the lambda body streams at the head, and then the ;; rest of the instruction stream. (define (-compile exp target linkage) (let* ([after-lam-bodies (make-label 'afterLamBodies)] [before-pop-prompt-multiple (make-label 'beforePopPromptMultiple)] [before-pop-prompt (make-LinkedLabel (make-label 'beforePopPrompt) before-pop-prompt-multiple)]) (optimize-il (statements (append-instruction-sequences ;; Layout the lambda bodies... (make-GotoStatement (make-Label after-lam-bodies)) (compile-lambda-bodies (collect-all-lambdas-with-bodies exp)) after-lam-bodies ;; Begin a prompted evaluation: (make-PushControlFrame/Prompt default-continuation-prompt-tag before-pop-prompt) (compile exp '() 'val return-linkage/nontail) before-pop-prompt-multiple (make-PopEnvironment (make-Reg 'argcount) (make-Const 0)) before-pop-prompt (if (eq? target 'val) empty-instruction-sequence (make-AssignImmediateStatement target (make-Reg 'val)))))))) (define-struct: lam+cenv ([lam : (U Lam CaseLam)] [cenv : CompileTimeEnvironment])) (: collect-all-lambdas-with-bodies (Expression -> (Listof lam+cenv))) ;; Finds all the lambdas in the expression. (define (collect-all-lambdas-with-bodies exp) (let: loop : (Listof lam+cenv) ([exp : Expression exp] [cenv : CompileTimeEnvironment '()]) (cond [(Top? exp) (loop (Top-code exp) (cons (Top-prefix exp) cenv))] [(Module? exp) (loop (Module-code exp) (cons (Module-prefix exp) cenv))] [(Constant? exp) '()] [(LocalRef? exp) '()] [(ToplevelRef? exp) '()] [(ToplevelSet? exp) (loop (ToplevelSet-value exp) cenv)] [(Branch? exp) (append (loop (Branch-predicate exp) cenv) (loop (Branch-consequent exp) cenv) (loop (Branch-alternative exp) cenv))] [(Lam? exp) (cons (make-lam+cenv exp cenv) (loop (Lam-body exp) (extract-lambda-cenv exp cenv)))] [(CaseLam? exp) (cons (make-lam+cenv exp cenv) (apply append (map (lambda: ([lam : (U Lam EmptyClosureReference)]) (loop lam cenv)) (CaseLam-clauses exp))))] [(EmptyClosureReference? exp) '()] [(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)))] [(Begin0? exp) (apply append (map (lambda: ([e : Expression]) (loop e cenv)) (Begin0-actions exp)))] [(App? exp) (let ([new-cenv (append (build-list (length (App-operands exp)) (lambda: ([i : Natural]) '?)) cenv)]) (append (loop (App-operator exp) new-cenv) (apply append (map (lambda: ([e : Expression]) (loop e new-cenv)) (App-operands exp)))))] [(Let1? exp) (append (loop (Let1-rhs exp) (cons '? cenv)) (loop (Let1-body exp) (cons (extract-static-knowledge (Let1-rhs exp) (cons '? cenv)) cenv)))] [(LetVoid? exp) (loop (LetVoid-body exp) (append (build-list (LetVoid-count exp) (lambda: ([i : Natural]) '?)) cenv))] [(InstallValue? exp) (loop (InstallValue-body exp) cenv)] [(BoxEnv? exp) (loop (BoxEnv-body exp) cenv)] [(LetRec? exp) (let ([n (length (LetRec-procs exp))]) (let ([new-cenv (append (map (lambda: ([p : Lam]) (extract-static-knowledge p (append (build-list (length (LetRec-procs exp)) (lambda: ([i : Natural]) '?)) (drop cenv n)))) (LetRec-procs exp)) (drop cenv n))]) (append (apply append (map (lambda: ([lam : Lam]) (loop lam new-cenv)) (LetRec-procs exp))) (loop (LetRec-body exp) new-cenv))))] [(WithContMark? exp) (append (loop (WithContMark-key exp) cenv) (loop (WithContMark-value exp) cenv) (loop (WithContMark-body exp) cenv))] [(ApplyValues? exp) (append (loop (ApplyValues-proc exp) cenv) (loop (ApplyValues-args-expr exp) cenv))] [(DefValues? exp) (append (loop (DefValues-rhs exp) cenv))] [(PrimitiveKernelValue? exp) '()] [(VariableReference? exp) (loop (VariableReference-toplevel exp) cenv)] [(Require? exp) '()]))) (: extract-lambda-cenv (Lam CompileTimeEnvironment -> CompileTimeEnvironment)) ;; Given a Lam and the ambient environment, produces the compile time environment for the ;; body of the lambda. (define (extract-lambda-cenv lam cenv) (append (map (lambda: ([d : Natural]) (list-ref cenv d)) (Lam-closure-map lam)) (build-list (if (Lam-rest? lam) (add1 (Lam-num-parameters lam)) (Lam-num-parameters lam)) (lambda: ([i : Natural]) '?)))) (: end-with-linkage (Linkage CompileTimeEnvironment InstructionSequence -> InstructionSequence)) ;; Add linkage for expressions. (define (end-with-linkage linkage cenv instruction-sequence) (append-instruction-sequences instruction-sequence (compile-linkage cenv linkage))) (: compile-linkage (CompileTimeEnvironment Linkage -> InstructionSequence)) ;; Generates the code necessary to drive the rest of the computation (represented as the linkage). (define (compile-linkage cenv linkage) (cond [(ReturnLinkage? linkage) (cond [(ReturnLinkage-tail? linkage) ;; Under tail calls, clear the environment of the current stack frame (represented by cenv) ;; and do the jump. (append-instruction-sequences (make-PopEnvironment (make-Const (length cenv)) (make-Const 0)) (make-AssignImmediateStatement 'proc (make-ControlStackLabel)) (make-PopControlFrame) (make-GotoStatement (make-Reg 'proc)))] [else ;; Under non-tail calls, leave the stack as is and just do the jump. (append-instruction-sequences (make-AssignImmediateStatement 'proc (make-ControlStackLabel)) (make-PopControlFrame) (make-GotoStatement (make-Reg 'proc)))])] [(NextLinkage? linkage) empty-instruction-sequence] [(LabelLinkage? linkage) (make-GotoStatement (make-Label (LabelLinkage-label linkage)))])) (: compile (Expression CompileTimeEnvironment Target Linkage -> InstructionSequence)) ;; The main dispatching function for compilation. ;; Compiles an expression into an instruction sequence. (define (compile exp cenv target linkage) (cond [(Top? exp) (compile-top exp cenv target linkage)] [(Module? exp) (compile-module exp cenv target linkage)] [(Constant? exp) (compile-constant exp cenv target linkage)] [(LocalRef? exp) (compile-local-reference exp cenv target linkage)] [(ToplevelRef? exp) (compile-toplevel-reference exp cenv target linkage)] [(ToplevelSet? exp) (compile-toplevel-set exp cenv target linkage)] [(Branch? exp) (compile-branch exp cenv target linkage)] [(Lam? exp) (compile-lambda exp cenv target linkage)] [(CaseLam? exp) (compile-case-lambda exp cenv target linkage)] [(EmptyClosureReference? exp) (compile-empty-closure-reference exp cenv target linkage)] [(Seq? exp) (compile-sequence (Seq-actions exp) cenv target linkage)] [(Splice? exp) (compile-splice (Splice-actions exp) cenv target linkage)] [(Begin0? exp) (compile-begin0 (Begin0-actions exp) cenv target linkage)] [(App? exp) (compile-application exp cenv target linkage)] [(Let1? exp) (compile-let1 exp cenv target linkage)] [(LetVoid? exp) (compile-let-void exp cenv target linkage)] [(InstallValue? exp) (compile-install-value exp cenv target linkage)] [(BoxEnv? exp) (compile-box-environment-value exp cenv target linkage)] [(LetRec? exp) (compile-let-rec exp cenv target linkage)] [(WithContMark? exp) (compile-with-cont-mark exp cenv target linkage)] [(ApplyValues? exp) (compile-apply-values exp cenv target linkage)] [(DefValues? exp) (compile-def-values exp cenv target linkage)] [(PrimitiveKernelValue? exp) (compile-primitive-kernel-value exp cenv target linkage)] [(VariableReference? exp) (compile-variable-reference exp cenv target linkage)] [(Require? exp) (compile-require exp cenv target linkage)])) (: compile-top (Top CompileTimeEnvironment Target Linkage -> InstructionSequence)) ;; Generates code to write out the top prefix, evaluate the rest of the body, ;; and then pop the top prefix off. (define (compile-top top cenv target linkage) (let*: ([names : (Listof (U False Symbol GlobalBucket ModuleVariable)) (Prefix-names (Top-prefix top))]) (end-with-linkage linkage cenv (append-instruction-sequences (make-PerformStatement (make-ExtendEnvironment/Prefix! names)) (compile (Top-code top) (cons (Top-prefix top) cenv) 'val next-linkage/drop-multiple) (make-AssignImmediateStatement target (make-Reg 'val)) (make-PopEnvironment (make-Const 1) (make-Const 0)))))) (: compile-module (Module CompileTimeEnvironment Target Linkage -> InstructionSequence)) ;; Generates code to write out the top prefix, evaluate the rest of the body, ;; and then pop the top prefix off. (define (compile-module mod cenv target linkage) ;; fixme: this is not right yet. This should instead install a module record ;; that has not yet been invoked. ;; fixme: This also needs to generate code for the requires and provides. (match mod [(struct Module (name path prefix requires provides code)) (let*: ([after-module-body (make-label 'afterModuleBody)] [module-entry (make-label 'module-entry)] [names : (Listof (U False Symbol GlobalBucket ModuleVariable)) (Prefix-names prefix)] [module-cenv : CompileTimeEnvironment (list prefix)]) (end-with-linkage linkage cenv (append-instruction-sequences (make-PerformStatement (make-InstallModuleEntry! name path module-entry)) (make-GotoStatement (make-Label after-module-body)) module-entry (make-PerformStatement (make-MarkModuleInvoked! path)) ;; Module body definition: ;; 1. First invoke all the modules that this requires. (apply append-instruction-sequences (map compile-module-invoke (Module-requires mod))) ;; 2. Next, evaluate the module body. (make-PerformStatement (make-ExtendEnvironment/Prefix! names)) (make-AssignImmediateStatement (make-ModulePrefixTarget path) (make-EnvWholePrefixReference 0)) ;; TODO: we need to sequester the prefix of the module with the record. (compile (Module-code mod) (cons (Module-prefix mod) module-cenv) 'val next-linkage/drop-multiple) ;; 3. Finally, cleanup and return. (make-PopEnvironment (make-Const 1) (make-Const 0)) (make-AssignImmediateStatement 'proc (make-ControlStackLabel)) (make-PopControlFrame) (make-PerformStatement (make-FinalizeModuleInvokation! path)) (make-GotoStatement (make-Reg 'proc)) after-module-body)))])) (: compile-require (Require CompileTimeEnvironment Target Linkage -> InstructionSequence)) (define (compile-require exp cenv target linkage) (end-with-linkage linkage cenv (append-instruction-sequences (compile-module-invoke (Require-path exp)) (make-AssignImmediateStatement target (make-Const (void)))))) (: compile-module-invoke (ModuleLocator -> InstructionSequence)) ;; Generates code that will invoke a module (if it hasn't been invoked yet) ;; FIXME: assumes the module has already been linked. We should error out ;; if the module hasn't been linked yet. (define (compile-module-invoke a-module-name) (cond [(kernel-module-name? a-module-name) empty-instruction-sequence] [else (let* ([linked (make-label 'linked)] [on-return-multiple (make-label 'onReturnMultiple)] [on-return (make-LinkedLabel (make-label 'onReturn) on-return-multiple)]) (append-instruction-sequences (make-TestAndJumpStatement (make-TestTrue (make-IsModuleLinked a-module-name)) linked) ;; TODO: raise an exception here that says that the module hasn't been ;; linked yet. (make-DebugPrint (make-Const (format "DEBUG: the module ~a hasn't been linked in!!!" (ModuleLocator-name a-module-name)))) (make-GotoStatement (make-Label (LinkedLabel-label on-return))) linked (make-TestAndJumpStatement (make-TestTrue (make-IsModuleInvoked a-module-name)) (LinkedLabel-label on-return)) (make-PushControlFrame/Call on-return) (make-GotoStatement (ModuleEntry a-module-name)) on-return-multiple (make-PopEnvironment (new-SubtractArg (make-Reg 'argcount) (make-Const 1)) (make-Const 0)) on-return))])) (: kernel-module-name? (ModuleLocator -> Boolean)) ;; Produces true if the module is hardcoded. (define (kernel-module-name? name) ((current-kernel-module-locator?) name)) (: emit-singular-context (Linkage -> InstructionSequence)) ;; Emits code specific to a construct that's guaranteed to produce a single value. ;; ;; This does two things: ;; ;; 1. The emitted code raises a runtime error if the linkage requires ;; multiple values will be produced, since there's no way to produce them. ;; ;; 2. In the case where the context is 'keep-multiple, it will also indicate a single ;; value by assigning to the argcount register. (define (emit-singular-context linkage) (cond [(ReturnLinkage? linkage) empty-instruction-sequence] [(or (NextLinkage? linkage) (LabelLinkage? linkage)) (let ([context (linkage-context linkage)]) (cond [(eq? context 'tail) empty-instruction-sequence] [(eq? context 'drop-multiple) empty-instruction-sequence] [(eq? context 'keep-multiple) (make-AssignImmediateStatement 'argcount (make-Const 1))] [(natural? context) (if (= context 1) empty-instruction-sequence (append-instruction-sequences (make-AssignImmediateStatement 'argcount (make-Const 1)) (make-PerformStatement (make-RaiseContextExpectedValuesError! context))))]))])) (: compile-constant (Constant CompileTimeEnvironment Target Linkage -> InstructionSequence)) ;; Generates output for constant values. (define (compile-constant exp cenv target linkage) (let ([singular-context-check (emit-singular-context linkage)]) ;; Compiles constant values. (end-with-linkage linkage cenv (append-instruction-sequences (make-AssignImmediateStatement target (make-Const (ensure-const-value (Constant-v exp)))) singular-context-check)))) (: compile-variable-reference (VariableReference CompileTimeEnvironment Target Linkage -> InstructionSequence)) (define (compile-variable-reference exp cenv target linkage) (let ([singular-context-check (emit-singular-context linkage)]) ;; Compiles constant values. (end-with-linkage linkage cenv (append-instruction-sequences (make-AssignImmediateStatement target exp) singular-context-check)))) (: compile-local-reference (LocalRef CompileTimeEnvironment Target Linkage -> InstructionSequence)) ;; Compiles local variable references. (define (compile-local-reference exp cenv target linkage) (let ([singular-context-check (emit-singular-context linkage)]) (end-with-linkage linkage cenv (append-instruction-sequences (make-AssignImmediateStatement target (make-EnvLexicalReference (LocalRef-depth exp) (LocalRef-unbox? exp))) singular-context-check)))) (: compile-toplevel-reference (ToplevelRef CompileTimeEnvironment Target Linkage -> InstructionSequence)) ;; Compiles toplevel references. (define (compile-toplevel-reference exp cenv target linkage) (let ([singular-context-check (emit-singular-context linkage)]) (end-with-linkage linkage cenv (append-instruction-sequences (if (ToplevelRef-check-defined? exp) (make-PerformStatement (make-CheckToplevelBound! (ToplevelRef-depth exp) (ToplevelRef-pos exp))) empty-instruction-sequence) (make-AssignImmediateStatement target (make-EnvPrefixReference (ToplevelRef-depth exp) (ToplevelRef-pos exp))) singular-context-check)))) (: compile-toplevel-set (ToplevelSet CompileTimeEnvironment Target Linkage -> InstructionSequence)) ;; Compiles a toplevel mutation. (define (compile-toplevel-set exp cenv target linkage) (let ([lexical-pos (make-EnvPrefixReference (ToplevelSet-depth exp) (ToplevelSet-pos exp))]) (let ([get-value-code (compile (ToplevelSet-value exp) cenv lexical-pos next-linkage/expects-single)] [singular-context-check (emit-singular-context linkage)]) (end-with-linkage linkage cenv (append-instruction-sequences get-value-code (make-AssignImmediateStatement target (make-Const (void))) singular-context-check))))) (: compile-branch (Branch CompileTimeEnvironment Target Linkage -> InstructionSequence)) ;; Compiles a conditional branch. (define (compile-branch exp cenv target linkage) (let: ([f-branch : Symbol (make-label 'falseBranch)] [after-if : Symbol (make-label 'afterIf)]) (let ([consequent-linkage (cond [(NextLinkage? linkage) (let ([context (NextLinkage-context linkage)]) (make-LabelLinkage after-if context))] [(ReturnLinkage? linkage) linkage] [(LabelLinkage? linkage) linkage])]) (let ([p-code (compile (Branch-predicate exp) cenv 'val next-linkage/expects-single)] [c-code (compile (Branch-consequent exp) cenv target consequent-linkage)] [a-code (compile (Branch-alternative exp) cenv target linkage)]) (append-instruction-sequences p-code (make-TestAndJumpStatement (make-TestFalse (make-Reg 'val)) f-branch) c-code f-branch a-code after-if))))) (: compile-sequence ((Listof Expression) CompileTimeEnvironment Target Linkage -> InstructionSequence)) ;; Compiles a sequence of expressions. The last expression will be compiled in the provided linkage. (define (compile-sequence seq cenv target linkage) ;; All but the last will use next-linkage linkage. (cond [(empty? seq) (end-with-linkage linkage cenv empty-instruction-sequence)] [(empty? (rest seq)) (compile (first seq) cenv target linkage)] [else (append-instruction-sequences (compile (first seq) cenv 'val next-linkage/drop-multiple) (compile-sequence (rest seq) cenv target linkage))])) (: compile-splice ((Listof Expression) CompileTimeEnvironment Target Linkage -> InstructionSequence)) ;; Compiles a sequence of expressions. A continuation prompt wraps around each of the expressions ;; to delimit any continuation captures. (define (compile-splice seq cenv target linkage) (cond [(empty? seq) (end-with-linkage linkage cenv empty-instruction-sequence)] [(empty? (rest seq)) (let* ([on-return/multiple (make-label 'beforePromptPopMultiple)] [on-return (make-LinkedLabel (make-label 'beforePromptPop) on-return/multiple)]) (end-with-linkage linkage cenv (append-instruction-sequences (make-PushControlFrame/Prompt default-continuation-prompt-tag on-return) (compile (first seq) cenv 'val return-linkage/nontail) (emit-values-context-check-on-procedure-return (linkage-context linkage) on-return/multiple on-return) (make-AssignImmediateStatement target (make-Reg 'val)))))] [else (let* ([on-return/multiple (make-label 'beforePromptPopMultiple)] [on-return (make-LinkedLabel (make-label 'beforePromptPop) on-return/multiple)]) (append-instruction-sequences (make-PushControlFrame/Prompt (make-DefaultContinuationPromptTag) on-return) (compile (first seq) cenv 'val return-linkage/nontail) on-return/multiple (make-PopEnvironment (new-SubtractArg (make-Reg 'argcount) (make-Const 1)) (make-Const 0)) on-return (compile-splice (rest seq) cenv target linkage)))])) (: compile-begin0 ((Listof Expression) CompileTimeEnvironment Target Linkage -> InstructionSequence)) (define (compile-begin0 seq cenv target linkage) (cond [(empty? seq) (end-with-linkage linkage cenv empty-instruction-sequence)] [(empty? (rest seq)) (compile (first seq) cenv target linkage)] [else (let ([evaluate-and-save-first-expression (let ([after-first-seq (make-label 'afterFirstSeqEvaluated)]) (append-instruction-sequences (make-Comment "begin0") ;; Evaluate the first expression in a multiple-value context, and get the values on the stack. (compile (first seq) cenv 'val next-linkage/keep-multiple-on-stack) (make-TestAndJumpStatement (make-TestZero (make-Reg 'argcount)) after-first-seq) (make-PushImmediateOntoEnvironment (make-Reg 'val) #f) after-first-seq ;; At this time, the argcount values are on the stack. ;; Next, we save those values temporarily in a throwaway control frame. (make-PushControlFrame/Generic) (make-AssignImmediateStatement (make-ControlFrameTemporary 'pendingBegin0Count) (make-Reg 'argcount)) (make-PerformStatement (make-UnspliceRestFromStack! (make-Const 0) (make-Reg 'argcount))) (make-AssignImmediateStatement (make-ControlFrameTemporary 'pendingBegin0Values) (make-EnvLexicalReference 0 #f)) (make-PopEnvironment (make-Const 1) (make-Const 0))))] [reinstate-values-on-stack (let ([after-values-reinstated (make-label 'afterValuesReinstated)]) (append-instruction-sequences ;; Reinstate the values of the first expression, and drop the throwaway control frame. (make-PushImmediateOntoEnvironment (make-ControlFrameTemporary 'pendingBegin0Values) #f) (make-PerformStatement (make-SpliceListIntoStack! (make-Const 0))) (make-AssignImmediateStatement 'argcount (make-ControlFrameTemporary 'pendingBegin0Count)) (make-PopControlFrame) (make-TestAndJumpStatement (make-TestZero (make-Reg 'argcount)) after-values-reinstated) (make-AssignImmediateStatement 'val (make-EnvLexicalReference 0 #f)) (make-PopEnvironment (make-Const 1) (make-Const 0)) after-values-reinstated))]) (append-instruction-sequences evaluate-and-save-first-expression (compile-sequence (rest seq) cenv 'val next-linkage/drop-multiple) reinstate-values-on-stack (make-AssignImmediateStatement target (make-Reg 'val)) ;; TODO: context needs check for arguments. (cond [(ReturnLinkage? linkage) (cond [(ReturnLinkage-tail? linkage) (append-instruction-sequences (make-PopEnvironment (make-Const (length cenv)) (new-SubtractArg (make-Reg 'argcount) (make-Const 1))) (make-AssignImmediateStatement 'proc (make-ControlStackLabel/MultipleValueReturn)) (make-PopControlFrame) (make-GotoStatement (make-Reg 'proc)))] [else (append-instruction-sequences (make-AssignImmediateStatement 'proc (make-ControlStackLabel/MultipleValueReturn)) (make-PopControlFrame) (make-GotoStatement (make-Reg 'proc)))])] [(NextLinkage? linkage) empty-instruction-sequence] [(LabelLinkage? linkage) (make-GotoStatement (make-Label (LabelLinkage-label linkage)))])))])) (: compile-lambda (Lam CompileTimeEnvironment Target Linkage -> InstructionSequence)) ;; Write out code for lambda expressions. ;; The lambda will close over the free variables. ;; Assumption: all of the lambda bodies have already been written out at the top, in -compile. (define (compile-lambda exp cenv target linkage) (let ([singular-context-check (emit-singular-context linkage)]) (end-with-linkage linkage cenv (append-instruction-sequences (make-AssignPrimOpStatement target (make-MakeCompiledProcedure (Lam-entry-label exp) (Lam-arity exp) (Lam-closure-map exp) (Lam-name exp))) singular-context-check)))) (: compile-empty-closure-reference (EmptyClosureReference CompileTimeEnvironment Target Linkage -> InstructionSequence)) (define (compile-empty-closure-reference exp cenv target linkage) (let ([singular-context-check (emit-singular-context linkage)]) (end-with-linkage linkage cenv (append-instruction-sequences (make-AssignPrimOpStatement target (make-MakeCompiledProcedure (EmptyClosureReference-entry-label exp) (EmptyClosureReference-arity exp) empty (EmptyClosureReference-name exp))) singular-context-check)))) (: compile-case-lambda (CaseLam CompileTimeEnvironment Target Linkage -> InstructionSequence)) ;; Similar to compile-lambda. (define (compile-case-lambda exp cenv target linkage) (let ([singular-context-check (emit-singular-context linkage)] [n (length (CaseLam-clauses exp))]) ;; We have to build all the lambda values, and then create a single CaseLam that holds onto ;; all of them. (end-with-linkage linkage cenv (append-instruction-sequences ;; Make some temporary space for the lambdas (make-Comment "scratch space for case-lambda") (make-PushEnvironment n #f) ;; Compile each of the lambdas (apply append-instruction-sequences (map (lambda: ([lam : (U Lam EmptyClosureReference)] [target : Target]) (make-AssignPrimOpStatement target (cond [(Lam? lam) (make-MakeCompiledProcedure (Lam-entry-label lam) (Lam-arity lam) (shift-closure-map (Lam-closure-map lam) n) (Lam-name lam))] [(EmptyClosureReference? lam) (make-MakeCompiledProcedure (EmptyClosureReference-entry-label lam) (EmptyClosureReference-arity lam) '() (EmptyClosureReference-name lam))]))) (CaseLam-clauses exp) (build-list (length (CaseLam-clauses exp)) (lambda: ([i : Natural]) (make-EnvLexicalReference i #f))))) ;; Make the case lambda as a regular compiled procedure. Its closed values are the lambdas. (make-AssignPrimOpStatement (adjust-target-depth target n) (make-MakeCompiledProcedure (CaseLam-entry-label exp) (merge-arities (map Lam-arity (CaseLam-clauses exp))) (build-list n (lambda: ([i : Natural]) i)) (CaseLam-name exp))) ;; Finally, pop off the scratch space. (make-PopEnvironment (make-Const n) (make-Const 0)) singular-context-check)))) (: Lam-arity ((U Lam EmptyClosureReference) -> Arity)) (define (Lam-arity lam) (cond [(Lam? lam) (if (Lam-rest? lam) (make-ArityAtLeast (Lam-num-parameters lam)) (Lam-num-parameters lam))] [(EmptyClosureReference? lam) (if (EmptyClosureReference-rest? lam) (make-ArityAtLeast (EmptyClosureReference-num-parameters lam)) (EmptyClosureReference-num-parameters lam))])) (: EmptyClosureReference-arity (EmptyClosureReference -> Arity)) (define (EmptyClosureReference-arity lam) (if (EmptyClosureReference-rest? lam) (make-ArityAtLeast (EmptyClosureReference-num-parameters lam)) (EmptyClosureReference-num-parameters lam))) (: shift-closure-map ((Listof Natural) Natural -> (Listof Natural))) (define (shift-closure-map closure-map n) (map (lambda: ([i : Natural]) (+ i n)) closure-map)) (: merge-arities ((Listof Arity) -> Arity)) (define (merge-arities arities) (cond [(empty? (rest arities)) (first arities)] [else (let ([first-arity (first arities)] [merged-rest (merge-arities (rest arities))]) (cond [(AtomicArity? first-arity) (cond [(AtomicArity? merged-rest) (list first-arity merged-rest)] [(listof-atomic-arity? merged-rest) (cons first-arity merged-rest)])] [(listof-atomic-arity? first-arity) (cond [(AtomicArity? merged-rest) (append first-arity (list merged-rest))] [(listof-atomic-arity? merged-rest) (append first-arity merged-rest)])]))])) (: compile-lambda-shell (Lam CompileTimeEnvironment Target Linkage -> InstructionSequence)) ;; Write out code for lambda expressions, minus the closure map. ;; Assumption: all of the lambda bodies have already been written out at the top, in -compile. (define (compile-lambda-shell exp cenv target linkage) (let ([singular-context-check (emit-singular-context linkage)]) (end-with-linkage linkage cenv (append-instruction-sequences (make-AssignPrimOpStatement target (make-MakeCompiledProcedureShell (Lam-entry-label exp) (if (Lam-rest? exp) (make-ArityAtLeast (Lam-num-parameters exp)) (Lam-num-parameters exp)) (Lam-name exp))) singular-context-check)))) (: compile-lambda-body (Lam CompileTimeEnvironment -> InstructionSequence)) ;; Compiles the body of the lambda in the appropriate environment. ;; Closures will target their value to the 'val register, and use return linkage. (define (compile-lambda-body exp cenv) (let: ([maybe-unsplice-rest-argument : InstructionSequence (if (Lam-rest? exp) (make-PerformStatement (make-UnspliceRestFromStack! (make-Const (Lam-num-parameters exp)) (new-SubtractArg (make-Reg 'argcount) (make-Const (Lam-num-parameters exp))))) empty-instruction-sequence)] [maybe-install-closure-values : InstructionSequence (if (not (empty? (Lam-closure-map exp))) (append-instruction-sequences (make-Comment (format "installing closure for ~s" (Lam-name exp))) (make-PerformStatement (make-InstallClosureValues!))) empty-instruction-sequence)] [lam-body-code : InstructionSequence (compile (Lam-body exp) (extract-lambda-cenv exp cenv) 'val return-linkage)]) (append-instruction-sequences (Lam-entry-label exp) maybe-unsplice-rest-argument maybe-install-closure-values lam-body-code))) (: compile-case-lambda-body (CaseLam CompileTimeEnvironment -> InstructionSequence)) (define (compile-case-lambda-body exp cenv) (append-instruction-sequences (CaseLam-entry-label exp) (apply append-instruction-sequences (map (lambda: ([lam : (U Lam EmptyClosureReference)] [i : Natural]) (let ([not-match (make-label 'notMatch)]) (append-instruction-sequences (make-TestAndJumpStatement (make-TestClosureArityMismatch (make-CompiledProcedureClosureReference (make-Reg 'proc) i) (make-Reg 'argcount)) not-match) ;; Set the procedure register to the lam (make-AssignImmediateStatement 'proc (make-CompiledProcedureClosureReference (make-Reg 'proc) i)) (make-GotoStatement (make-Label (cond [(Lam? lam) (Lam-entry-label lam)] [(EmptyClosureReference? lam) (EmptyClosureReference-entry-label lam)]))) not-match))) (CaseLam-clauses exp) (build-list (length (CaseLam-clauses exp)) (lambda: ([i : Natural]) i)))))) (: compile-lambda-bodies ((Listof lam+cenv) -> InstructionSequence)) ;; Compile several lambda bodies, back to back. (define (compile-lambda-bodies exps) (cond [(empty? exps) empty-instruction-sequence] [else (let: ([lam : (U Lam CaseLam) (lam+cenv-lam (first exps))] [cenv : CompileTimeEnvironment (lam+cenv-cenv (first exps))]) (cond [(Lam? lam) (append-instruction-sequences (compile-lambda-body lam cenv) (compile-lambda-bodies (rest exps)))] [(CaseLam? lam) (append-instruction-sequences (compile-case-lambda-body lam cenv) (compile-lambda-bodies (rest exps)))]))])) (: extend-compile-time-environment/scratch-space (CompileTimeEnvironment Natural -> CompileTimeEnvironment)) (define (extend-compile-time-environment/scratch-space cenv n) (append (build-list n (lambda: ([i : Natural]) '?)) cenv)) (: compile-application (App CompileTimeEnvironment Target Linkage -> InstructionSequence)) ;; Compiles procedure application ;; Special cases: if we know something about the operator, the compiler will special case. ;; This includes: ;; Known closure ;; Known kernel primitive ;; In the general case, we do general procedure application. (define (compile-application exp cenv target linkage) (let ([extended-cenv (extend-compile-time-environment/scratch-space cenv (length (App-operands exp)))]) (define (default) (compile-general-application exp cenv target linkage)) (let: ([op-knowledge : CompileTimeEnvironmentEntry (extract-static-knowledge (App-operator exp) extended-cenv)]) (cond [(eq? op-knowledge '?) (default)] [(operator-is-statically-known-identifier? op-knowledge) => (lambda (id) (cond [(KernelPrimitiveName/Inline? id) (compile-open-codeable-application id exp cenv target linkage)] [((current-primitive-identifier?) id) (compile-primitive-application exp cenv target linkage)] [else (default)]))] [(StaticallyKnownLam? op-knowledge) (compile-statically-known-lam-application op-knowledge exp cenv target linkage)] [(Prefix? op-knowledge) (error 'impossible)] [(Const? op-knowledge) (append-instruction-sequences (make-AssignImmediateStatement 'proc op-knowledge) (make-PerformStatement (make-RaiseOperatorApplicationError! (make-Reg 'proc))))] [else (default)])))) (: operator-is-statically-known-identifier? (CompileTimeEnvironmentEntry -> (U False Symbol))) (define (operator-is-statically-known-identifier? op-knowledge) (cond [(PrimitiveKernelValue? op-knowledge) (let ([id (PrimitiveKernelValue-id op-knowledge)]) id)] [(ModuleVariable? op-knowledge) (cond [(kernel-module-locator? (ModuleVariable-module-name op-knowledge)) (ModuleVariable-name op-knowledge)] [else #f])] [else #f])) (: kernel-module-locator? (ModuleLocator -> Boolean)) ;; Produces true if the ModuleLocator is pointing to a module that's marked ;; as kernel. (define (kernel-module-locator? a-module-locator) (or (symbol=? (ModuleLocator-name a-module-locator) '#%kernel) (symbol=? (ModuleLocator-name a-module-locator) 'whalesong/lang/kernel.rkt))) (: compile-general-application (App CompileTimeEnvironment Target Linkage -> InstructionSequence)) (define (compile-general-application exp cenv target linkage) (let* ([extended-cenv (extend-compile-time-environment/scratch-space cenv (length (App-operands exp)))] [proc-code (compile (App-operator exp) extended-cenv (if (empty? (App-operands exp)) 'proc (make-EnvLexicalReference (ensure-natural (sub1 (length (App-operands exp)))) #f)) next-linkage/expects-single)] [operand-codes (map (lambda: ([operand : Expression] [target : Target]) (compile operand extended-cenv target next-linkage/expects-single)) (App-operands exp) (build-list (length (App-operands exp)) (lambda: ([i : Natural]) (if (< i (sub1 (length (App-operands exp)))) (make-EnvLexicalReference i #f) 'val))))]) (append-instruction-sequences (make-Comment "scratch space for general application") (make-PushEnvironment (length (App-operands exp)) #f) proc-code (juggle-operands operand-codes) (make-AssignImmediateStatement 'argcount (make-Const (length (App-operands exp)))) (compile-general-procedure-call cenv (make-Const (length (App-operands exp))) target linkage)))) (: compile-primitive-application (App CompileTimeEnvironment Target Linkage -> InstructionSequence)) (define (compile-primitive-application exp cenv target linkage) (let* ([extended-cenv (extend-compile-time-environment/scratch-space cenv (length (App-operands exp)))] [proc-code (compile (App-operator exp) extended-cenv 'proc next-linkage/expects-single)] [operand-codes (map (lambda: ([operand : Expression] [target : Target]) (compile operand extended-cenv target next-linkage/expects-single)) (App-operands exp) (build-list (length (App-operands exp)) (lambda: ([i : Natural]) (make-EnvLexicalReference i #f))))]) (append-instruction-sequences (make-PushEnvironment (length (App-operands exp)) #f) (apply append-instruction-sequences operand-codes) proc-code (make-AssignImmediateStatement 'argcount (make-Const (length (App-operands exp)))) (compile-primitive-procedure-call cenv (make-Const (length (App-operands exp))) target linkage)))) (: compile-open-codeable-application (KernelPrimitiveName/Inline App CompileTimeEnvironment Target Linkage -> InstructionSequence)) ;; This is a special case of application, where the operator is statically ;; known to be in the set of hardcoded primitives, and where we can open-code ;; the application. ;; ;; There's a special case optimization we can perform: we can avoid touching ;; the stack for constant arguments; rather than allocate (length (App-operands exp)) ;; stack slots, we can do less than that. ;; ;; We have to be sensitive to mutation. (define (compile-open-codeable-application kernel-op exp cenv target linkage) (let ([singular-context-check (emit-singular-context linkage)] [n (length (App-operands exp))]) (define expected-operand-types (kernel-primitive-expected-operand-types kernel-op n)) (: make-runtime-arity-mismatch-code (Arity -> InstructionSequence)) (define (make-runtime-arity-mismatch-code expected-arity) ;; We compile the code to generate a runtime arity error here. (end-with-linkage linkage cenv (append-instruction-sequences (make-PushEnvironment n #f) (apply append-instruction-sequences (map (lambda: ([operand : Expression] [target : Target]) (compile operand (extend-compile-time-environment/scratch-space cenv (length (App-operands exp))) target next-linkage/expects-single)) (App-operands exp) (build-list (length (App-operands exp)) (lambda: ([i : Natural]) (make-EnvLexicalReference i #f))))) (make-AssignImmediateStatement 'proc (make-PrimitiveKernelValue kernel-op)) (make-AssignImmediateStatement 'argcount (make-Const (length (App-operands exp)))) (make-PerformStatement (make-RaiseArityMismatchError! (make-Reg 'proc) expected-arity (make-Const n)))))) (cond [(IncorrectArity? expected-operand-types) (make-runtime-arity-mismatch-code (IncorrectArity-expected expected-operand-types))] [(not (= n (length expected-operand-types))) (make-runtime-arity-mismatch-code (length expected-operand-types))] [else (cond ;; If all the arguments are primitive enough (all constants, localrefs, or toplevelrefs), ;; then application requires no stack space at all, and application is especially simple. [(andmap (lambda (op) ;; TODO: as long as the operand contains no applications? (or (Constant? op) (ToplevelRef? op) (LocalRef? op))) (App-operands exp)) (let* ([operand-knowledge (map (lambda: ([arg : Expression]) (extract-static-knowledge arg (extend-compile-time-environment/scratch-space cenv n))) (App-operands exp))] [typechecks? (map (lambda: ([dom : OperandDomain] [known : CompileTimeEnvironmentEntry]) (not (redundant-check? dom known))) expected-operand-types operand-knowledge)] [operand-poss (simple-operands->opargs (map (lambda: ([op : Expression]) (adjust-expression-depth op n n)) (App-operands exp)))]) (end-with-linkage linkage cenv (append-instruction-sequences (make-AssignPrimOpStatement target (make-CallKernelPrimitiveProcedure kernel-op operand-poss expected-operand-types typechecks?)) singular-context-check)))] [else ;; Otherwise, we can split the operands into two categories: constants, and the rest. (let*-values ([(constant-operands rest-operands) (split-operands-by-constants (App-operands exp))] ;; here, we rewrite the stack references so they assume no scratch space ;; used by the constant operands. [(extended-cenv constant-operands rest-operands) (values (extend-compile-time-environment/scratch-space cenv (length rest-operands)) (map (lambda: ([constant-operand : Expression]) (ensure-simple-expression (adjust-expression-depth constant-operand (length constant-operands) n))) constant-operands) (map (lambda: ([rest-operand : Expression]) (adjust-expression-depth rest-operand (length constant-operands) n)) rest-operands))] [(operand-knowledge) (append (map (lambda: ([arg : Expression]) (extract-static-knowledge arg extended-cenv)) constant-operands) (map (lambda: ([arg : Expression]) (extract-static-knowledge arg extended-cenv)) rest-operands))] [(typechecks?) (map (lambda: ([dom : OperandDomain] [known : CompileTimeEnvironmentEntry]) (not (redundant-check? dom known))) expected-operand-types operand-knowledge)] [(stack-pushing-code) (make-PushEnvironment (length rest-operands) #f)] [(stack-popping-code) (make-PopEnvironment (make-Const (length rest-operands)) (make-Const 0))] [(constant-operand-poss) (simple-operands->opargs constant-operands)] [(rest-operand-poss) (build-list (length rest-operands) (lambda: ([i : Natural]) (make-EnvLexicalReference i #f)))] [(rest-operand-code) (apply append-instruction-sequences (map (lambda: ([operand : Expression] [target : Target]) (compile operand extended-cenv target next-linkage/expects-single)) rest-operands rest-operand-poss))]) (end-with-linkage linkage cenv (append-instruction-sequences stack-pushing-code rest-operand-code (make-AssignPrimOpStatement (adjust-target-depth target (length rest-operands)) (make-CallKernelPrimitiveProcedure kernel-op (append constant-operand-poss rest-operand-poss) expected-operand-types typechecks?)) stack-popping-code singular-context-check)))])]))) (: ensure-simple-expression (Expression -> (U Constant ToplevelRef LocalRef))) (define (ensure-simple-expression e) (if (or (Constant? e) (LocalRef? e) (ToplevelRef? e)) e (error 'ensure-simple-expression))) (: simple-operands->opargs ((Listof Expression) -> (Listof OpArg))) ;; Produces a list of OpArgs if all the operands are particularly simple, and false therwise. (define (simple-operands->opargs rands) (map (lambda: ([e : Expression]) (cond [(Constant? e) (make-Const (ensure-const-value (Constant-v e)))] [(LocalRef? e) (make-EnvLexicalReference (LocalRef-depth e) (LocalRef-unbox? e))] [(ToplevelRef? e) (make-EnvPrefixReference (ToplevelRef-depth e) (ToplevelRef-pos e))] [else (error 'all-operands-are-constant "Impossible")])) rands)) (: redundant-check? (OperandDomain CompileTimeEnvironmentEntry -> Boolean)) ;; Produces true if we know the knowledge implies the domain-type. (define (redundant-check? domain-type knowledge) (cond [(eq? domain-type 'any) #t] [else (cond [(Const? knowledge) (case domain-type [(number) (number? (Const-const knowledge))] [(string) (string? (Const-const knowledge))] [(box) (box? (Const-const knowledge))] [(list) (list? (Const-const knowledge))] [(pair) (pair? (Const-const knowledge))] [(caarpair) (let ([x (Const-const knowledge)]) (and (pair? x) (pair? (car x))))])] [else #f])])) (: split-operands-by-constants ((Listof Expression) -> (values (Listof (U Constant LocalRef ToplevelRef)) (Listof Expression)))) ;; Splits off the list of operations into two: a prefix of constant ;; or simple expressions, and the remainder. ;; TODO: if we can statically determine what arguments are immutable, regardless of ;; side effects, we can do a much better job here... (define (split-operands-by-constants rands) (let: loop : (values (Listof (U Constant LocalRef ToplevelRef)) (Listof Expression)) ([rands : (Listof Expression) rands] [constants : (Listof (U Constant LocalRef ToplevelRef)) empty]) (cond [(empty? rands) (values (reverse constants) empty)] [else (let ([e (first rands)]) (if (or (Constant? e) ;; These two are commented out because it's not sound otherwise. #;(and (LocalRef? e) (not (LocalRef-unbox? e))) #;(and (ToplevelRef? e) (let ([prefix (ensure-prefix (list-ref cenv (ToplevelRef-depth e)))]) (ModuleVariable? (list-ref prefix (ToplevelRef-pos e)))))) (loop (rest rands) (cons e constants)) (values (reverse constants) rands)))]))) (define-predicate natural? Natural) (define-predicate atomic-arity-list? (Listof (U Natural ArityAtLeast))) (: arity-matches? (Arity Natural -> Boolean)) (define (arity-matches? an-arity n) (cond [(natural? an-arity) (= an-arity n)] [(ArityAtLeast? an-arity) (>= n (ArityAtLeast-value an-arity))] [(atomic-arity-list? an-arity) (ormap (lambda: ([an-arity : (U Natural ArityAtLeast)]) (cond [(natural? an-arity) (= an-arity n)] [(ArityAtLeast? an-arity) (>= n (ArityAtLeast-value an-arity))])) an-arity)])) (: compile-statically-known-lam-application (StaticallyKnownLam App CompileTimeEnvironment Target Linkage -> InstructionSequence)) (define (compile-statically-known-lam-application static-knowledge exp cenv target linkage) (let ([arity-check (cond [(arity-matches? (StaticallyKnownLam-arity static-knowledge) (length (App-operands exp))) empty-instruction-sequence] [else (make-PerformStatement (make-RaiseArityMismatchError! (make-Reg 'proc) (StaticallyKnownLam-arity static-knowledge) (make-Const (length (App-operands exp)))))])]) (let* ([extended-cenv (extend-compile-time-environment/scratch-space cenv (length (App-operands exp)))] [proc-code (compile (App-operator exp) extended-cenv (if (empty? (App-operands exp)) 'proc (make-EnvLexicalReference (ensure-natural (sub1 (length (App-operands exp)))) #f)) next-linkage/expects-single)] [operand-codes (map (lambda: ([operand : Expression] [target : Target]) (compile operand extended-cenv target next-linkage/expects-single)) (App-operands exp) (build-list (length (App-operands exp)) (lambda: ([i : Natural]) (if (< i (sub1 (length (App-operands exp)))) (make-EnvLexicalReference i #f) 'val))))]) (append-instruction-sequences (make-Comment "scratch space for statically known lambda application") (make-PushEnvironment (length (App-operands exp)) #f) proc-code (juggle-operands operand-codes) arity-check (compile-procedure-call/statically-known-lam static-knowledge cenv extended-cenv (length (App-operands exp)) target linkage))))) (: juggle-operands ((Listof InstructionSequence) -> InstructionSequence)) ;; Installs the operators. At the end of this, ;; the procedure lives in 'proc, and the operands on the environment stack. (define (juggle-operands operand-codes) (let: loop : InstructionSequence ([ops : (Listof InstructionSequence) operand-codes]) (cond ;; If there are no operands, no need to juggle. [(null? ops) empty-instruction-sequence] [(null? (rest ops)) (let: ([n : Natural (ensure-natural (sub1 (length operand-codes)))]) ;; The last operand needs to be handled specially: it currently lives in ;; val. We move the procedure at env[n] over to proc, and move the ;; last operand at 'val into env[n]. (append-instruction-sequences (car ops) (make-AssignImmediateStatement 'proc (make-EnvLexicalReference n #f)) (make-AssignImmediateStatement (make-EnvLexicalReference n #f) (make-Reg 'val))))] [else ;; Otherwise, add instructions to juggle the operator and operands in the stack. (append-instruction-sequences (car ops) (loop (rest ops)))]))) (: linkage-context (Linkage -> ValuesContext)) (define (linkage-context linkage) (cond [(ReturnLinkage? linkage) (cond [(ReturnLinkage-tail? linkage) 'tail] [else 'drop-multiple])] [(NextLinkage? linkage) (NextLinkage-context linkage)] [(LabelLinkage? linkage) (LabelLinkage-context linkage)])) (: compile-general-procedure-call (CompileTimeEnvironment OpArg Target Linkage -> InstructionSequence)) ;; Assumes the following: ;; 1. the procedure value has been loaded into the proc register. ;; 2. the n values passed in has been written into argcount register. ;; 3. environment stack contains the n operand values. ;; ;; n is the number of arguments passed in. ;; cenv is the compile-time enviroment before arguments have been shifted in. ;; extended-cenv is the compile-time environment after arguments have been shifted in. (define (compile-general-procedure-call cenv number-of-arguments target linkage) (end-with-linkage linkage cenv (append-instruction-sequences (make-PerformStatement (make-CheckClosureAndArity!)) (compile-compiled-procedure-application cenv number-of-arguments 'dynamic target linkage)))) ;; If we know the procedure is implemented as a primitive (as opposed to a general closure), ;; we can do a little less work. ;; Assumes 1. the procedure value is loaded into proc, ;; 2. number-of-arguments has been written into the argcount register, ; ; 3. the number-of-arguments values are on the stack. (: compile-primitive-procedure-call (CompileTimeEnvironment OpArg Target Linkage -> InstructionSequence)) (define (compile-primitive-procedure-call cenv number-of-arguments target linkage) (end-with-linkage linkage cenv (append-instruction-sequences (make-PerformStatement (make-CheckPrimitiveArity!)) (make-AssignPrimOpStatement 'val (make-ApplyPrimitiveProcedure)) (make-PopEnvironment number-of-arguments (make-Const 0)) (if (eq? target 'val) empty-instruction-sequence (make-AssignImmediateStatement target (make-Reg 'val))) (emit-singular-context linkage)))) (: compile-procedure-call/statically-known-lam (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 : Symbol (make-label 'afterCall)] [compiled-linkage : Linkage (if (and (ReturnLinkage? linkage) (ReturnLinkage-tail? linkage)) linkage (make-LabelLinkage after-call (linkage-context linkage)))]) (append-instruction-sequences (make-AssignImmediateStatement 'argcount (make-Const n)) (compile-compiled-procedure-application cenv (make-Const n) (make-Label (StaticallyKnownLam-entry-point static-knowledge)) target compiled-linkage) (end-with-linkage linkage cenv after-call)))) (: compile-compiled-procedure-application (CompileTimeEnvironment OpArg (U Label 'dynamic) Target Linkage -> InstructionSequence)) ;; This is the heart of compiled procedure application. A lot of things happen here. ;; ;; Procedure linkage. ;; Handling of multiple-value-returns. ;; Tail calls. ;; ;; Three fundamental cases for general compiled-procedure application. ;; 1. Tail calls. ;; 2. Non-tail calls (next/label linkage) that write to val ;; 3. Calls in argument position (next/label linkage) that write to the stack. (define (compile-compiled-procedure-application cenv number-of-arguments entry-point target linkage) (let* ([entry-point-target ;; Optimization: if the entry-point is known to be a static label, ;; use that. Otherwise, grab the entry point from the proc register. (cond [(Label? entry-point) entry-point] [(eq? entry-point 'dynamic) (make-CompiledProcedureEntry (make-Reg 'proc))])] ;; If the target isn't val, migrate the value from val into it. [maybe-migrate-val-to-target (cond [(eq? target 'val) empty-instruction-sequence] [else (make-AssignImmediateStatement target (make-Reg 'val))])] [on-return/multiple (make-label 'procReturnMultiple)] [on-return (make-LinkedLabel (make-label 'procReturn) on-return/multiple)] ;; This code does the initial jump into the procedure. Clients of this code ;; are expected to generate the proc-return-multiple and proc-return code afterwards. [nontail-jump-into-procedure (append-instruction-sequences (make-PushControlFrame/Call on-return) (make-GotoStatement entry-point-target))]) (cond [(ReturnLinkage? linkage) (cond [(eq? target 'val) (cond [(ReturnLinkage-tail? linkage) ;; This case happens when we're in tail position. ;; We clean up the stack right before the jump, and do not add ;; to the control stack. (let ([reuse-the-stack (make-PopEnvironment (make-Const (length cenv)) number-of-arguments)]) (append-instruction-sequences reuse-the-stack ;; Assign the proc value of the existing call frame. (make-PerformStatement (make-SetFrameCallee! (make-Reg 'proc))) (make-GotoStatement entry-point-target)))] [else ;; This case happens when we should be returning to a caller, but where ;; we are not in tail position. (append-instruction-sequences nontail-jump-into-procedure on-return/multiple (make-PopEnvironment (new-SubtractArg (make-Reg 'argcount) (make-Const 1)) (make-Const 0)) on-return)])] [else (error 'compile "return linkage, target not val: ~s" target)])] [(or (NextLinkage? linkage) (LabelLinkage? linkage)) (let* ([context (linkage-context linkage)] [check-values-context-on-procedure-return (emit-values-context-check-on-procedure-return context on-return/multiple on-return)] [maybe-jump-to-label (if (LabelLinkage? linkage) (make-GotoStatement (make-Label (LabelLinkage-label linkage))) empty-instruction-sequence)]) (append-instruction-sequences nontail-jump-into-procedure check-values-context-on-procedure-return maybe-migrate-val-to-target maybe-jump-to-label))]))) (: emit-values-context-check-on-procedure-return (ValuesContext Symbol LinkedLabel -> InstructionSequence)) ;; When we come back from a procedure call, the following code ensures the context's expectations ;; are met. (define (emit-values-context-check-on-procedure-return context on-return/multiple on-return) (cond [(eq? context 'tail) (append-instruction-sequences on-return/multiple on-return)] [(eq? context 'drop-multiple) (append-instruction-sequences on-return/multiple (make-PopEnvironment (new-SubtractArg (make-Reg 'argcount) (make-Const 1)) (make-Const 0)) on-return)] [(eq? context 'keep-multiple) (let ([after-return (make-label 'afterReturn)]) (append-instruction-sequences on-return/multiple (make-GotoStatement (make-Label after-return)) on-return (make-AssignImmediateStatement 'argcount (make-Const 1)) after-return))] [(natural? context) (cond [(= context 1) (append-instruction-sequences on-return/multiple (make-PerformStatement (make-RaiseContextExpectedValuesError! 1)) on-return)] [else (let ([after-value-check (make-label 'afterValueCheck)]) (append-instruction-sequences on-return/multiple ;; if the wrong number of arguments come in, die (make-TestAndJumpStatement (make-TestZero (new-SubtractArg (make-Reg 'argcount) (make-Const context))) after-value-check) on-return (make-PerformStatement (make-RaiseContextExpectedValuesError! context)) after-value-check))])])) (: extract-static-knowledge (Expression CompileTimeEnvironment -> CompileTimeEnvironmentEntry)) ;; Statically determines what we know about the expression, given the compile time environment. ;; We should do more here eventually, including things like type inference or flow analysis, so that ;; we can generate better code. (define (extract-static-knowledge exp cenv) (log-debug (format "Trying to discover information about ~s" exp)) (cond [(Lam? exp) (log-debug "known to be a lambda") (make-StaticallyKnownLam (Lam-name exp) (Lam-entry-label exp) (if (Lam-rest? exp) (make-ArityAtLeast (Lam-num-parameters exp)) (Lam-num-parameters exp)))] [(and (LocalRef? exp) (not (LocalRef-unbox? exp))) (let ([entry (list-ref cenv (LocalRef-depth exp))]) (log-debug (format "known to be ~s" entry)) entry)] [(ToplevelRef? exp) (log-debug (format "toplevel reference of ~a" exp)) (when (ToplevelRef-constant? exp) (log-debug (format "toplevel reference ~a should be known constant" exp))) (let: ([name : (U Symbol False GlobalBucket ModuleVariable) (list-ref (Prefix-names (ensure-prefix (list-ref cenv (ToplevelRef-depth exp)))) (ToplevelRef-pos exp))]) (cond [(ModuleVariable? name) (log-debug (format "toplevel reference is to ~s" name)) name] [(GlobalBucket? name) '?] [else (log-debug (format "nothing statically known about ~s" exp)) '?]))] [(Constant? exp) (make-Const (ensure-const-value (Constant-v exp)))] [(PrimitiveKernelValue? exp) exp] [else (log-debug (format "nothing statically known about ~s" exp)) '?])) (: compile-let1 (Let1 CompileTimeEnvironment Target Linkage -> InstructionSequence)) ;; Single value binding. Since there's only one rhs, we have more static guarantees we can make, ;; which is why we can use extract-static-knowledge here. (define (compile-let1 exp cenv target linkage) (let*: ([rhs-code : InstructionSequence (compile (Let1-rhs exp) (cons '? cenv) (make-EnvLexicalReference 0 #f) next-linkage/expects-single)] [after-body-code : Symbol (make-label 'afterLetBody)] [extended-cenv : CompileTimeEnvironment (cons (extract-static-knowledge (Let1-rhs exp) (cons '? cenv)) cenv)] [context : ValuesContext (linkage-context linkage)] [let-linkage : Linkage (cond [(NextLinkage? linkage) linkage] [(ReturnLinkage? linkage) (cond [(ReturnLinkage-tail? linkage) linkage] [else (make-LabelLinkage after-body-code (linkage-context linkage))])] [(LabelLinkage? linkage) (make-LabelLinkage after-body-code (LabelLinkage-context linkage))])] [body-target : Target (adjust-target-depth target 1)] [body-code : InstructionSequence (compile (Let1-body exp) extended-cenv body-target let-linkage)]) (end-with-linkage linkage extended-cenv (append-instruction-sequences (make-Comment "scratch space for let1") (make-PushEnvironment 1 #f) rhs-code body-code after-body-code ;; We want to clear out the scratch space introduced by the ;; let1. However, there may be multiple values coming ;; back at this point, from the evaluation of the body. We ;; look at the context and route around those values ;; appropriate. (cond [(eq? context 'tail) empty-instruction-sequence] [(eq? context 'drop-multiple) (make-PopEnvironment (make-Const 1) (make-Const 0))] [(eq? context 'keep-multiple) ;; dynamic number of arguments that need ;; to be preserved (make-PopEnvironment (make-Const 1) (new-SubtractArg (make-Reg 'argcount) (make-Const 1)))] [else (cond [(= context 0) (make-PopEnvironment (make-Const 1) (make-Const 0))] [(= context 1) (make-PopEnvironment (make-Const 1) (make-Const 0))] [else ;; n-1 values on stack that we need to route ;; around (make-PopEnvironment (make-Const 1) (new-SubtractArg (make-Const context) (make-Const 1)))])]))))) (: compile-let-void (LetVoid CompileTimeEnvironment Target Linkage -> InstructionSequence)) ;; Binding several values. Unlike before, it has less knowledge about what values will be bound, ;; and so there's less analysis here. (define (compile-let-void exp cenv target linkage) (let*: ([n : Natural (LetVoid-count exp)] [after-let : Symbol (make-label 'afterLet)] [after-body-code : Symbol (make-label 'afterLetBody)] [extended-cenv : CompileTimeEnvironment (append (build-list (LetVoid-count exp) (lambda: ([i : Natural]) '?)) cenv)] [context : ValuesContext (linkage-context linkage)] [let-linkage : Linkage (cond [(NextLinkage? linkage) linkage] [(ReturnLinkage? linkage) (cond [(ReturnLinkage-tail? linkage) linkage] [else (make-LabelLinkage after-body-code context)])] [(LabelLinkage? linkage) (make-LabelLinkage after-body-code context)])] [body-target : Target (adjust-target-depth target n)] [body-code : InstructionSequence (compile (LetVoid-body exp) extended-cenv body-target let-linkage)]) (end-with-linkage linkage extended-cenv (append-instruction-sequences (make-Comment "scratch space for let-void") (make-PushEnvironment n (LetVoid-boxes? exp)) body-code after-body-code ;; We want to clear out the scratch space introduced by the ;; let-void. However, there may be multiple values coming ;; back at this point, from the evaluation of the body. We ;; look at the context and route around those values ;; appropriate. (cond [(eq? context 'tail) empty-instruction-sequence] [(eq? context 'drop-multiple) (make-PopEnvironment (make-Const n) (make-Const 0))] [(eq? context 'keep-multiple) ;; dynamic number of arguments that need ;; to be preserved (make-PopEnvironment (make-Const n) (new-SubtractArg (make-Reg 'argcount) (make-Const 1)))] [else (cond [(= context 0) (make-PopEnvironment (make-Const n) (make-Const 0))] [(= context 1) (make-PopEnvironment (make-Const n) (make-Const 0))] [else ;; n-1 values on stack that we need to route ;; around (make-PopEnvironment (make-Const n) (new-SubtractArg (make-Const context) (make-Const 1)))])]) after-let)))) (: compile-let-rec (LetRec CompileTimeEnvironment Target Linkage -> InstructionSequence)) ;; Compiled recursive Lams. Each lambda is installed as a shell, and then the closures ;; are installed in-place. (define (compile-let-rec exp cenv target linkage) (let*: ([n : Natural (length (LetRec-procs exp))] [extended-cenv : CompileTimeEnvironment (append (map (lambda: ([p : Lam]) (extract-static-knowledge p (append (build-list (length (LetRec-procs exp)) (lambda: ([i : Natural]) '?)) (drop cenv n)))) (LetRec-procs exp)) (drop cenv n))] [n : Natural (length (LetRec-procs exp))] [after-body-code : Symbol (make-label 'afterBodyCode)] [letrec-linkage : Linkage (cond [(NextLinkage? linkage) linkage] [(ReturnLinkage? linkage) (cond [(ReturnLinkage-tail? linkage) linkage] [else (make-LabelLinkage after-body-code (linkage-context linkage))])] [(LabelLinkage? linkage) (make-LabelLinkage after-body-code (LabelLinkage-context linkage))])]) (end-with-linkage linkage extended-cenv (append-instruction-sequences ;; Install each of the closure shells. (apply append-instruction-sequences (map (lambda: ([lam : Lam] [i : Natural]) (compile-lambda-shell lam extended-cenv (make-EnvLexicalReference i #f) next-linkage/expects-single)) (LetRec-procs exp) (build-list n (lambda: ([i : Natural]) i)))) ;; Fix the closure maps of each (apply append-instruction-sequences (map (lambda: ([lam : Lam] [i : Natural]) (append-instruction-sequences (make-Comment (format "Installing shell for ~s\n" (Lam-name lam))) (make-PerformStatement (make-FixClosureShellMap! i (Lam-closure-map lam))))) (LetRec-procs exp) (build-list n (lambda: ([i : Natural]) i)))) ;; Compile the body (compile (LetRec-body exp) extended-cenv target letrec-linkage) after-body-code)))) (: compile-install-value (InstallValue CompileTimeEnvironment Target Linkage -> InstructionSequence)) (define (compile-install-value exp cenv target linkage) (append-instruction-sequences (make-Comment "install-value") (let ([count (InstallValue-count exp)]) (cond [(= count 0) (end-with-linkage linkage cenv (compile (InstallValue-body exp) cenv target (make-NextLinkage 0)))] [(= count 1) (append-instruction-sequences (make-Comment (format "installing single value into ~s" (InstallValue-depth exp))) (end-with-linkage linkage cenv (compile (InstallValue-body exp) cenv (make-EnvLexicalReference (InstallValue-depth exp) (InstallValue-box? exp)) (make-NextLinkage 1))))] [else (end-with-linkage linkage cenv (append-instruction-sequences (make-Comment "install-value: evaluating values") (compile (InstallValue-body exp) cenv 'val (make-NextLinkage count)) (apply append-instruction-sequences (map (lambda: ([to : EnvLexicalReference] [from : OpArg]) (append-instruction-sequences (make-Comment "install-value: installing value") (make-AssignImmediateStatement to from))) (build-list count (lambda: ([i : Natural]) (make-EnvLexicalReference (+ i (InstallValue-depth exp) (sub1 count)) (InstallValue-box? exp)))) (cons (make-Reg 'val) (build-list (sub1 count) (lambda: ([i : Natural]) (make-EnvLexicalReference i #f)))))) (make-PopEnvironment (make-Const (sub1 count)) (make-Const 0))))])))) (: compile-box-environment-value (BoxEnv CompileTimeEnvironment Target Linkage -> InstructionSequence)) (define (compile-box-environment-value exp cenv target linkage) (append-instruction-sequences (make-AssignPrimOpStatement (make-EnvLexicalReference (BoxEnv-depth exp) #f) (make-MakeBoxedEnvironmentValue (BoxEnv-depth exp))) (compile (BoxEnv-body exp) cenv target linkage))) (: compile-with-cont-mark (WithContMark CompileTimeEnvironment Target Linkage -> InstructionSequence)) (define (compile-with-cont-mark exp cenv target linkage) (: in-return-context (-> InstructionSequence)) (define (in-return-context) (append-instruction-sequences (compile (WithContMark-key exp) cenv 'val next-linkage/expects-single) (make-AssignImmediateStatement (make-ControlFrameTemporary 'pendingContinuationMarkKey) (make-Reg 'val)) (compile (WithContMark-value exp) cenv 'val next-linkage/expects-single) (make-PerformStatement (make-InstallContinuationMarkEntry!)) (compile (WithContMark-body exp) cenv target linkage))) (: in-other-context ((U NextLinkage LabelLinkage) -> InstructionSequence)) (define (in-other-context linkage) (let ([body-next-linkage (cond [(NextLinkage? linkage) linkage] [(LabelLinkage? linkage) (make-NextLinkage (LabelLinkage-context linkage))])]) (end-with-linkage linkage cenv (append-instruction-sequences ;; Making a continuation frame; isn't really used for anything ;; but recording the key/value data. (make-PushControlFrame/Generic) (compile (WithContMark-key exp) cenv 'val next-linkage/expects-single) (make-AssignImmediateStatement (make-ControlFrameTemporary 'pendingContinuationMarkKey) (make-Reg 'val)) (compile (WithContMark-value exp) cenv 'val next-linkage/expects-single) (make-PerformStatement (make-InstallContinuationMarkEntry!)) (compile (WithContMark-body exp) cenv target body-next-linkage) (make-PopControlFrame))))) (cond [(ReturnLinkage? linkage) (in-return-context)] [(NextLinkage? linkage) (in-other-context linkage)] [(LabelLinkage? linkage) (in-other-context linkage)])) (: compile-apply-values (ApplyValues CompileTimeEnvironment Target Linkage -> InstructionSequence)) (define (compile-apply-values exp cenv target linkage) (log-debug (format "apply values ~a" exp)) (let ([on-zero (make-label 'onZero)] [after-args-evaluated (make-label 'afterArgsEvaluated)] [consumer-info (extract-static-knowledge (ApplyValues-proc exp) cenv)]) (append-instruction-sequences ;; Save the procedure value temporarily in a control stack frame (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/keep-multiple-on-stack) (make-TestAndJumpStatement (make-TestZero (make-Reg 'argcount)) after-args-evaluated) ;; In the common case where we do get values back, we push val onto the stack too, ;; so that we have n values on the stack before we jump to the procedure call. (make-PushImmediateOntoEnvironment (make-Reg 'val) #f) after-args-evaluated ;; Retrieve the procedure off the temporary control frame. (make-AssignImmediateStatement 'proc (make-ControlFrameTemporary 'pendingApplyValuesProc)) ;; Pop off the temporary control frame (make-PopControlFrame) ;; Finally, do the generic call into the consumer function. ;; FIXME: we have more static knowledge here of what the operator is. ;; We can make this faster. (compile-general-procedure-call cenv (make-Reg 'argcount) target linkage)))) (: compile-def-values (DefValues CompileTimeEnvironment Target Linkage -> InstructionSequence)) (define (compile-def-values exp cenv target linkage) (let* ([ids (DefValues-ids exp)] [rhs (DefValues-rhs exp)] [n (length ids)]) ;; First, compile the body, which will produce right side values. (end-with-linkage linkage cenv (append-instruction-sequences (compile rhs cenv 'val (make-NextLinkage (length ids))) ;; Now install each of the values in place. The first value's in val, and the rest of the ;; values are on the stack. (if (> n 0) (apply append-instruction-sequences (map (lambda: ([id : ToplevelRef] [from : OpArg]) (make-AssignImmediateStatement ;; Slightly subtle: the toplevelrefs were with respect to the ;; stack at the beginning of def-values, but at the moment, ;; there may be additional values that are currently there. (make-EnvPrefixReference (+ (ensure-natural (sub1 n)) (ToplevelRef-depth id)) (ToplevelRef-pos id)) from)) ids (if (> n 0) (cons (make-Reg 'val) (build-list (sub1 n) (lambda: ([i : Natural]) (make-EnvLexicalReference i #f)))) empty))) empty-instruction-sequence) ;; Finally, make sure any multiple values are off the stack. (if (> (length ids) 1) (make-PopEnvironment (make-Const (sub1 (length ids))) (make-Const 0)) empty-instruction-sequence))))) (: compile-primitive-kernel-value (PrimitiveKernelValue CompileTimeEnvironment Target Linkage -> InstructionSequence)) (define (compile-primitive-kernel-value exp cenv target linkage) (let ([id (PrimitiveKernelValue-id exp)]) (cond [(KernelPrimitiveName? id) (let ([singular-context-check (emit-singular-context linkage)]) ;; Compiles constant values. (end-with-linkage linkage cenv (append-instruction-sequences (make-AssignImmediateStatement target exp) singular-context-check)))] [else ;; Maybe warn about the unimplemented kernel primitive. (unless (set-contains? (current-seen-unimplemented-kernel-primitives) id) (set-insert! (current-seen-unimplemented-kernel-primitives) id) ((current-warn-unimplemented-kernel-primitive) id)) (make-PerformStatement (make-RaiseUnimplementedPrimitiveError! id))]))) (: ensure-natural (Integer -> Natural)) (define (ensure-natural n) (if (>= n 0) n (error 'ensure-natural "Not a natural: ~s\n" n))) (: ensure-prefix (CompileTimeEnvironmentEntry -> Prefix)) (define (ensure-prefix x) (if (Prefix? x) x (error 'ensure-prefix "Not a prefix: ~s" x))) (: ensure-lam (Any -> Lam)) (define (ensure-lam x) (if (Lam? x) x (error 'ensure-lam "Not a Lam: ~s" x))) (: ensure-toplevelref (Any -> ToplevelRef)) (define (ensure-toplevelref x) (if (ToplevelRef? x) x (error 'ensure-toplevelref "Not a ToplevelRef: ~s" x))) (: adjust-target-depth (Target Natural -> Target)) (define (adjust-target-depth target n) (cond [(eq? target 'val) target] [(eq? target 'proc) target] [(eq? target 'argcount) target] [(EnvLexicalReference? target) (make-EnvLexicalReference (+ n (EnvLexicalReference-depth target)) (EnvLexicalReference-unbox? target))] [(EnvPrefixReference? target) (make-EnvPrefixReference (+ n (EnvPrefixReference-depth target)) (EnvPrefixReference-pos target))] [(PrimitivesReference? target) target] [(ControlFrameTemporary? target) target] [(ModulePrefixTarget? target) target])) (: adjust-expression-depth (Expression Natural Natural -> Expression)) ;; Redirects references to the stack to route around a region of size n. ;; The region begins at offset skip into the environment. (define (adjust-expression-depth exp n skip) (cond [(Top? exp) (make-Top (Top-prefix exp) (adjust-expression-depth (Top-code exp) n (add1 skip)))] [(Module? exp) (make-Module (Module-name exp) (Module-path exp) (Module-prefix exp) (Module-requires exp) (Module-provides exp) (adjust-expression-depth (Module-code exp) n (add1 skip)))] [(Constant? exp) exp] [(ToplevelRef? exp) (if (< (ToplevelRef-depth exp) skip) exp (make-ToplevelRef (ensure-natural (- (ToplevelRef-depth exp) n)) (ToplevelRef-pos exp) (ToplevelRef-constant? exp) (ToplevelRef-check-defined? exp)))] [(LocalRef? exp) (if (< (LocalRef-depth exp) skip) exp (make-LocalRef (ensure-natural (- (LocalRef-depth exp) n)) (LocalRef-unbox? exp)))] [(ToplevelSet? exp) (if (< (ToplevelSet-depth exp) skip) (make-ToplevelSet (ToplevelSet-depth exp) (ToplevelSet-pos exp) (adjust-expression-depth (ToplevelSet-value exp) n skip)) (make-ToplevelSet (ensure-natural (- (ToplevelSet-depth exp) n)) (ToplevelSet-pos exp) (adjust-expression-depth (ToplevelSet-value exp) n skip)))] [(Branch? exp) (make-Branch (adjust-expression-depth (Branch-predicate exp) n skip) (adjust-expression-depth (Branch-consequent exp) n skip) (adjust-expression-depth (Branch-alternative exp) n skip))] [(Lam? exp) (make-Lam (Lam-name exp) (Lam-num-parameters exp) (Lam-rest? exp) (Lam-body exp) (map (lambda: ([d : Natural]) (if (< d skip) d (ensure-natural (- d n)))) (Lam-closure-map exp)) (Lam-entry-label exp))] [(CaseLam? exp) (make-CaseLam (CaseLam-name exp) (map (lambda: ([lam : (U Lam EmptyClosureReference)]) (cond [(Lam? lam) (ensure-lam (adjust-expression-depth lam n skip))] [(EmptyClosureReference? lam) lam])) (CaseLam-clauses exp)) (CaseLam-entry-label exp))] [(EmptyClosureReference? exp) exp] [(Seq? exp) (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)))] [(Begin0? exp) (make-Begin0 (map (lambda: ([action : Expression]) (adjust-expression-depth action n skip)) (Begin0-actions exp)))] [(App? exp) (make-App (adjust-expression-depth (App-operator exp) n (+ skip (length (App-operands exp)))) (map (lambda: ([operand : Expression]) (adjust-expression-depth operand n (+ skip (length (App-operands exp))))) (App-operands exp)))] [(Let1? exp) (make-Let1 (adjust-expression-depth (Let1-rhs exp) n (add1 skip)) (adjust-expression-depth (Let1-body exp) n (add1 skip)))] [(LetVoid? exp) (make-LetVoid (LetVoid-count exp) (adjust-expression-depth (LetVoid-body exp) n (+ skip (LetVoid-count exp))) (LetVoid-boxes? exp))] [(LetRec? exp) (make-LetRec (let: loop : (Listof Lam) ([procs : (Listof Lam) (LetRec-procs exp)]) (cond [(empty? procs) '()] [else (cons (ensure-lam (adjust-expression-depth (first procs) n skip)) (loop (rest procs)))])) (adjust-expression-depth (LetRec-body exp) n skip))] [(InstallValue? exp) (if (< (InstallValue-depth exp) skip) (make-InstallValue (InstallValue-count exp) (InstallValue-depth exp) (adjust-expression-depth (InstallValue-body exp) n skip) (InstallValue-box? exp)) (make-InstallValue (InstallValue-count exp) (ensure-natural (- (InstallValue-depth exp) n)) (adjust-expression-depth (InstallValue-body exp) n skip) (InstallValue-box? exp)))] [(BoxEnv? exp) (if (< (BoxEnv-depth exp) skip) (make-BoxEnv (BoxEnv-depth exp) (adjust-expression-depth (BoxEnv-body exp) n skip)) (make-BoxEnv (ensure-natural (- (BoxEnv-depth exp) n)) (adjust-expression-depth (BoxEnv-body exp) n skip)))] [(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))] [(ApplyValues? exp) (make-ApplyValues (adjust-expression-depth (ApplyValues-proc exp) n skip) (adjust-expression-depth (ApplyValues-args-expr exp) n skip))] [(DefValues? exp) (make-DefValues (map (lambda: ([id : ToplevelRef]) (ensure-toplevelref (adjust-expression-depth id n skip))) (DefValues-ids exp)) (adjust-expression-depth (DefValues-rhs exp) n skip))] [(PrimitiveKernelValue? exp) exp] [(VariableReference? exp) (make-VariableReference (ensure-toplevelref (adjust-expression-depth (VariableReference-toplevel exp) n skip)))] [(Require? exp) exp]))