diff --git a/compile.rkt b/compile.rkt index f9d88aa..3bd2ad2 100644 --- a/compile.rkt +++ b/compile.rkt @@ -54,7 +54,7 @@ (let: loop : (Listof lam+cenv) ([exp : ExpressionCore exp] [cenv : CompileTimeEnvironment '()]) - + (cond [(Top? exp) (loop (Top-code exp) (cons (Top-prefix exp) cenv))] @@ -98,11 +98,11 @@ '()] [(LetRec? exp) (let ([new-cenv (append (map (lambda: ([p : Lam]) - (extract-static-knowledge - p - (append (build-list (length (LetRec-procs exp)) - (lambda: ([i : Natural]) '?)) - cenv))) + (extract-static-knowledge + p + (append (build-list (length (LetRec-procs exp)) + (lambda: ([i : Natural]) '?)) + cenv))) (reverse (LetRec-procs exp))) cenv)]) (append (apply append @@ -110,8 +110,8 @@ (loop lam new-cenv)) (LetRec-procs exp))) (loop (LetRec-body exp) new-cenv)))]))) - - + + (: extract-lambda-cenv (Lam CompileTimeEnvironment -> CompileTimeEnvironment)) (define (extract-lambda-cenv lam cenv) @@ -192,32 +192,32 @@ (: compile-linkage (CompileTimeEnvironment Linkage -> InstructionSequence)) (define (compile-linkage cenv linkage) (cond - [(eq? linkage 'return) + [(ReturnLinkage? linkage) (make-instruction-sequence `(,(make-AssignPrimOpStatement 'proc (make-GetControlStackLabel)) ,(make-PopEnvironment (length cenv) 0) ,(make-PopControlFrame) ,(make-GotoStatement (make-Reg 'proc))))] - [(eq? linkage 'next) + [(NextLinkage? linkage) empty-instruction-sequence] - [(symbol? linkage) - (make-instruction-sequence `(,(make-GotoStatement (make-Label linkage))))])) + [(LabelLinkage? linkage) + (make-instruction-sequence `(,(make-GotoStatement (make-Label (LabelLinkage-label linkage)))))])) (: compile-application-linkage (CompileTimeEnvironment Linkage -> InstructionSequence)) -;; Like compile-linkage, but the special case for 'return linkage already assumes +;; Like compile-linkage, but the special case for return-linkage linkage already assumes ;; the stack has been appropriately popped. (define (compile-application-linkage cenv linkage) (cond - [(eq? linkage 'return) + [(ReturnLinkage? linkage) (make-instruction-sequence `(,(make-AssignPrimOpStatement 'proc (make-GetControlStackLabel)) ,(make-PopControlFrame) ,(make-GotoStatement (make-Reg 'proc))))] - [(eq? linkage 'next) + [(NextLinkage? linkage) (make-instruction-sequence `(,(make-PopEnvironment (length cenv) 0)))] - [(symbol? linkage) + [(LabelLinkage? linkage) (make-instruction-sequence `(,(make-PopEnvironment (length cenv) 0) - ,(make-GotoStatement (make-Label linkage))))])) + ,(make-GotoStatement (make-Label (LabelLinkage-label linkage)))))])) @@ -262,7 +262,7 @@ (ToplevelSet-pos exp))]) (let ([get-value-code (compile (ToplevelSet-value exp) cenv lexical-pos - 'next)]) + next-linkage)]) (end-with-linkage linkage cenv @@ -273,14 +273,14 @@ (: compile-branch (Branch CompileTimeEnvironment Target Linkage -> InstructionSequence)) (define (compile-branch exp cenv target linkage) - (let ([t-branch (make-label 'trueBranch)] - [f-branch (make-label 'falseBranch)] - [after-if (make-label 'afterIf)]) + (let: ([t-branch : LabelLinkage (make-LabelLinkage (make-label 'trueBranch))] + [f-branch : LabelLinkage (make-LabelLinkage (make-label 'falseBranch))] + [after-if : LabelLinkage (make-LabelLinkage (make-label 'afterIf))]) (let ([consequent-linkage - (if (eq? linkage 'next) + (if (eq? linkage next-linkage) after-if linkage)]) - (let ([p-code (compile (Branch-predicate exp) cenv 'val 'next)] + (let ([p-code (compile (Branch-predicate exp) cenv 'val next-linkage)] [c-code (compile (Branch-consequent exp) cenv target consequent-linkage)] [a-code (compile (Branch-alternative exp) cenv target linkage)]) (append-instruction-sequences p-code @@ -288,20 +288,19 @@ (make-instruction-sequence `(,(make-TestAndBranchStatement 'false? 'val - f-branch) - )) + (LabelLinkage-label f-branch)))) (append-instruction-sequences - (append-instruction-sequences t-branch c-code) - (append-instruction-sequences f-branch a-code)) - after-if)))))) + (append-instruction-sequences (LabelLinkage-label t-branch) c-code) + (append-instruction-sequences (LabelLinkage-label f-branch) a-code)) + (LabelLinkage-label after-if))))))) (: compile-sequence ((Listof Expression) CompileTimeEnvironment Target Linkage -> InstructionSequence)) (define (compile-sequence seq cenv target linkage) - ;; All but the last will use 'next linkage. + ;; All but the last will use next-linkage linkage. (if (last-exp? seq) (compile (first-exp seq) cenv target linkage) - (append-instruction-sequences (compile (first-exp seq) cenv target 'next) + (append-instruction-sequences (compile (first-exp seq) cenv target next-linkage) (compile-sequence (rest-exps seq) cenv target linkage)))) @@ -344,7 +343,7 @@ (make-instruction-sequence `(,(Lam-entry-label exp))) - + (if (not (empty? (Lam-closure-map exp))) (make-instruction-sequence `(,(make-PerformStatement (make-InstallClosureValues!)))) empty-instruction-sequence) @@ -356,7 +355,7 @@ ;; fixme: We need to capture the cenv so we can maintain static knowledge (build-list (Lam-num-parameters exp) (lambda: ([i : Natural]) '?))) 'val - 'return))) + return-linkage))) @@ -422,10 +421,10 @@ (make-EnvLexicalReference (ensure-natural (sub1 (length (App-operands exp)))) #f)) - 'next)] + next-linkage)] [operand-codes (map (lambda: ([operand : Expression] [target : Target]) - (compile operand extended-cenv target 'next)) + (compile operand extended-cenv target next-linkage)) (App-operands exp) (build-list (length (App-operands exp)) (lambda: ([i : Natural]) @@ -457,7 +456,7 @@ (make-EnvLexicalReference i #f)))] [operand-codes (map (lambda: ([operand : Expression] [target : Target]) - (compile operand extended-cenv target 'next)) + (compile operand extended-cenv target next-linkage)) (App-operands exp) operand-poss)]) (cond @@ -535,7 +534,7 @@ (StaticallyKnownLam-name static-knowledge) (StaticallyKnownLam-arity static-knowledge) (length (App-operands exp)))) - + (let ([proc-code (compile (App-operator exp) extended-cenv (if (empty? (App-operands exp)) @@ -543,10 +542,10 @@ (make-EnvLexicalReference (ensure-natural (sub1 (length (App-operands exp)))) #f)) - 'next)] + next-linkage)] [operand-codes (map (lambda: ([operand : Expression] [target : Target]) - (compile operand extended-cenv target 'next)) + (compile operand extended-cenv target next-linkage)) (App-operands exp) (build-list (length (App-operands exp)) (lambda: ([i : Natural]) @@ -595,25 +594,25 @@ (: compile-general-procedure-call (CompileTimeEnvironment CompileTimeEnvironment - Natural Target Linkage - -> - InstructionSequence)) + Natural Target Linkage + -> + InstructionSequence)) ;; Assumes the procedure value has been loaded into the proc register. ;; 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 extended-cenv n target linkage) - (let ([primitive-branch (make-label 'primitiveBranch)] - [compiled-branch (make-label 'compiledBranch)] - [after-call (make-label 'afterCall)]) - (let ([compiled-linkage (if (eq? linkage 'next) after-call linkage)]) + (let: ([primitive-branch : LabelLinkage (make-LabelLinkage (make-label 'primitiveBranch))] + [compiled-branch : LabelLinkage (make-LabelLinkage (make-label 'compiledBranch))] + [after-call : LabelLinkage (make-LabelLinkage (make-label 'afterCall))]) + (let: ([compiled-linkage : Linkage (if (eq? linkage next-linkage) after-call linkage)]) (append-instruction-sequences (make-instruction-sequence `(,(make-TestAndBranchStatement 'primitive-procedure? 'proc - primitive-branch))) + (LabelLinkage-label primitive-branch)))) - compiled-branch + (LabelLinkage-label compiled-branch) (make-instruction-sequence `(,(make-PerformStatement (make-CheckClosureArity! n)))) (end-with-compiled-application-linkage @@ -621,7 +620,7 @@ extended-cenv (compile-proc-appl extended-cenv (make-Reg 'val) n target compiled-linkage)) - primitive-branch + (LabelLinkage-label primitive-branch) (end-with-linkage linkage cenv @@ -637,14 +636,14 @@ (make-instruction-sequence `(,(make-PopEnvironment n 0))) empty-instruction-sequence))) - after-call)))) + (LabelLinkage-label after-call))))) (: compile-procedure-call/statically-known-lam (StaticallyKnownLam CompileTimeEnvironment Natural Target Linkage -> InstructionSequence)) (define (compile-procedure-call/statically-known-lam static-knowledge extended-cenv n target linkage) - (let* ([after-call (make-label 'afterCall)] - [compiled-linkage (if (eq? linkage 'next) after-call linkage)]) + (let*: ([after-call : LabelLinkage (make-LabelLinkage (make-label 'afterCall))] + [compiled-linkage : Linkage (if (eq? linkage next-linkage) after-call linkage)]) (append-instruction-sequences (end-with-compiled-application-linkage compiled-linkage @@ -654,62 +653,86 @@ n target compiled-linkage)) - after-call))) - + (LabelLinkage-label after-call)))) + (: compile-proc-appl (CompileTimeEnvironment (U Label Reg) Natural Target Linkage -> InstructionSequence)) ;; Three fundamental cases for general compiled-procedure application. -;; 1. Non-tail calls that write to val -;; 2. Calls in argument position that write to the environment -;; 3. Tail calls. -;; The Other cases should be excluded. +;; 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-proc-appl cenv-with-args entry-point n target linkage) - (cond [(and (eq? target 'val) - (not (eq? linkage 'return))) - ;; This case happens for a function call that isn't in - ;; tail position. - (make-instruction-sequence - `(,(make-PushControlFrame linkage) - ,(make-AssignPrimOpStatement 'val (make-GetCompiledProcedureEntry)) - ,(make-GotoStatement entry-point)))] + (cond [(ReturnLinkage? linkage) + (cond + [(eq? target 'val) + ;; 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: ([num-slots-to-delete : Natural (ensure-natural (- (length cenv-with-args) n))]) + (append-instruction-sequences + (make-instruction-sequence + `(,(make-AssignPrimOpStatement 'val + (make-GetCompiledProcedureEntry)))) + (if (> num-slots-to-delete 0) + (make-instruction-sequence `(,(make-PopEnvironment num-slots-to-delete n))) + empty-instruction-sequence) + (make-instruction-sequence + `(,(make-GotoStatement entry-point)))))] + + [else + ;; This case should be impossible: return linkage should only + ;; occur when we're in tail position, and we should be in tail position + ;; only when the target is the val register. + (error 'compile "return linkage, target not val: ~s" target)])] - [(and (not (eq? target 'val)) - (not (eq? linkage 'return))) - ;; This case happens for evaluating arguments, since the - ;; arguments are being installed into the scratch space. - (let ([proc-return (make-label 'procReturn)]) - (make-instruction-sequence - `(,(make-PushControlFrame proc-return) - ,(make-AssignPrimOpStatement 'val (make-GetCompiledProcedureEntry)) - ,(make-GotoStatement entry-point) - ,proc-return - ,(make-AssignImmediateStatement target (make-Reg 'val)) - ,(make-GotoStatement (make-Label linkage)))))] + + [(NextLinkage? linkage) + (cond [(eq? target 'val) + ;; This case happens for a function call that isn't in + ;; tail position. + (let ([proc-return (make-label 'procReturn)]) + (make-instruction-sequence + `(,(make-PushControlFrame proc-return) + ,(make-AssignPrimOpStatement 'val (make-GetCompiledProcedureEntry)) + ,(make-GotoStatement entry-point) + ,proc-return)))] + + [else + ;; This case happens for evaluating arguments, since the + ;; arguments are being installed into the scratch space. + (let ([proc-return (make-label 'procReturn)]) + (make-instruction-sequence + `(,(make-PushControlFrame proc-return) + ,(make-AssignPrimOpStatement 'val (make-GetCompiledProcedureEntry)) + ,(make-GotoStatement entry-point) + ,proc-return + ,(make-AssignImmediateStatement target (make-Reg 'val)))))])] - [(and (eq? target 'val) - (eq? linkage 'return)) - ;; 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: ([num-slots-to-delete : Natural (ensure-natural (- (length cenv-with-args) n))]) - (append-instruction-sequences - (make-instruction-sequence - `(,(make-AssignPrimOpStatement 'val - (make-GetCompiledProcedureEntry)))) - (if (> num-slots-to-delete 0) - (make-instruction-sequence `(,(make-PopEnvironment num-slots-to-delete n))) - empty-instruction-sequence) - (make-instruction-sequence - `(,(make-GotoStatement entry-point)))))] - - [(and (not (eq? target 'val)) - (eq? linkage 'return)) - ;; This case should be impossible: return linkage should only - ;; occur when we're in tail position, and we're in tail position - ;; only when the target is the val register. - (error 'compile "return linkage, target not val: ~s" target)])) - + [(LabelLinkage? linkage) + (cond [(eq? target 'val) + ;; This case happens for a function call that isn't in + ;; tail position. + (make-instruction-sequence + `(,(make-PushControlFrame (LabelLinkage-label linkage)) + ,(make-AssignPrimOpStatement 'val (make-GetCompiledProcedureEntry)) + ,(make-GotoStatement entry-point)))] + + [else + ;; This case happens for evaluating arguments, since the + ;; arguments are being installed into the scratch space. + (let ([proc-return (make-label 'procReturn)]) + (make-instruction-sequence + `(,(make-PushControlFrame proc-return) + ,(make-AssignPrimOpStatement 'val (make-GetCompiledProcedureEntry)) + ,(make-GotoStatement entry-point) + ,proc-return + ,(make-AssignImmediateStatement target (make-Reg 'val)) + ,(make-GotoStatement (make-Label (LabelLinkage-label linkage))))))])])) + + + + (: extract-static-knowledge (ExpressionCore CompileTimeEnvironment -> @@ -741,26 +764,26 @@ [else '?])) - + (: compile-let1 (Let1 CompileTimeEnvironment Target Linkage -> InstructionSequence)) (define (compile-let1 exp cenv target linkage) (let*: ([rhs-code : InstructionSequence (compile (Let1-rhs exp) (cons '? cenv) (make-EnvLexicalReference 0 #f) - 'next)] + next-linkage)] [after-let1 : Symbol (make-label 'afterLetOne)] - [after-body-code : Symbol (make-label 'afterLetBody)] + [after-body-code : LabelLinkage (make-LabelLinkage (make-label 'afterLetBody))] [extended-cenv : CompileTimeEnvironment (cons (extract-static-knowledge (Let1-rhs exp) (cons '? cenv)) cenv)] [let-linkage : Linkage (cond - [(eq? linkage 'next) - 'next] - [(eq? linkage 'return) - 'return] - [(symbol? linkage) + [(NextLinkage? linkage) + linkage] + [(ReturnLinkage? linkage) + linkage] + [(LabelLinkage? linkage) after-body-code])] [body-target : Target (adjust-target-depth target 1)] [body-code : InstructionSequence @@ -772,7 +795,7 @@ (make-instruction-sequence `(,(make-PushEnvironment 1 #f))) rhs-code body-code - after-body-code + (LabelLinkage-label after-body-code) (make-instruction-sequence `(,(make-PopEnvironment 1 0))) after-let1)))) @@ -782,17 +805,17 @@ (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)] + [after-body-code : LabelLinkage (make-LabelLinkage (make-label 'afterLetBody))] [extended-cenv : CompileTimeEnvironment (append (build-list (LetVoid-count exp) (lambda: ([i : Natural]) '?)) - cenv)] + cenv)] [let-linkage : Linkage (cond - [(eq? linkage 'next) - 'next] - [(eq? linkage 'return) - 'return] - [(symbol? linkage) + [(NextLinkage? linkage) + linkage] + [(ReturnLinkage? linkage) + linkage] + [(LabelLinkage? linkage) after-body-code])] [body-target : Target (adjust-target-depth target n)] [body-code : InstructionSequence @@ -805,7 +828,7 @@ (make-instruction-sequence `(,(make-PushEnvironment n (LetVoid-boxes? exp)))) empty-instruction-sequence) body-code - after-body-code + (LabelLinkage-label after-body-code) (if (> n 0) (make-instruction-sequence `(,(make-PopEnvironment n 0))) empty-instruction-sequence) @@ -825,52 +848,52 @@ cenv))) (reverse (LetRec-procs exp))) cenv)] - [n : Natural (length (LetRec-procs exp))] - [after-body-code : Linkage (make-label 'afterBodyCode)] - [letrec-linkage : Linkage (cond - [(eq? linkage 'next) - 'next] - [(eq? linkage 'return) - 'return] - [(symbol? linkage) - after-body-code])]) - (end-with-linkage - linkage - extended-cenv - (append-instruction-sequences - (if (> n 0) - (make-instruction-sequence `(,(make-PushEnvironment n #f))) - empty-instruction-sequence) - - ;; 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)) - (LetRec-procs exp) - (build-list n (lambda: ([i : Natural]) (ensure-natural (- n 1 i)))))) - - ;; Fix the closure maps of each - (apply append-instruction-sequences - (map (lambda: ([lam : Lam] - [i : Natural]) - (make-instruction-sequence - `(,(make-PerformStatement - (make-FixClosureShellMap! i (Lam-closure-map lam)))))) - - (LetRec-procs exp) - (build-list n (lambda: ([i : Natural]) (ensure-natural (- n 1 i)))))) - - ;; Compile the body - (compile (LetRec-body exp) extended-cenv (adjust-target-depth target n) letrec-linkage) - after-body-code - (if (> n 0) - (make-instruction-sequence `(,(make-PopEnvironment n 0))) - empty-instruction-sequence))))) - + [n : Natural (length (LetRec-procs exp))] + [after-body-code : LabelLinkage (make-LabelLinkage (make-label 'afterBodyCode))] + [letrec-linkage : Linkage (cond + [(NextLinkage? linkage) + linkage] + [(ReturnLinkage? linkage) + linkage] + [(LabelLinkage? linkage) + after-body-code])]) + (end-with-linkage + linkage + extended-cenv + (append-instruction-sequences + (if (> n 0) + (make-instruction-sequence `(,(make-PushEnvironment n #f))) + empty-instruction-sequence) + + ;; 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)) + (LetRec-procs exp) + (build-list n (lambda: ([i : Natural]) (ensure-natural (- n 1 i)))))) + + ;; Fix the closure maps of each + (apply append-instruction-sequences + (map (lambda: ([lam : Lam] + [i : Natural]) + (make-instruction-sequence + `(,(make-PerformStatement + (make-FixClosureShellMap! i (Lam-closure-map lam)))))) + + (LetRec-procs exp) + (build-list n (lambda: ([i : Natural]) (ensure-natural (- n 1 i)))))) + + ;; Compile the body + (compile (LetRec-body exp) extended-cenv (adjust-target-depth target n) letrec-linkage) + (LabelLinkage-label after-body-code) + (if (> n 0) + (make-instruction-sequence `(,(make-PopEnvironment n 0))) + empty-instruction-sequence))))) + (: compile-install-value (InstallValue CompileTimeEnvironment Target Linkage -> InstructionSequence)) @@ -884,11 +907,11 @@ (: compile-box-environment-value (BoxEnv CompileTimeEnvironment Target Linkage -> InstructionSequence)) (define (compile-box-environment-value exp cenv target linkage) - (append-instruction-sequences - (make-instruction-sequence - `(,(make-AssignPrimOpStatement (make-EnvLexicalReference (BoxEnv-depth exp) #f) - (make-MakeBoxedEnvironmentValue (BoxEnv-depth exp))))) - (compile (BoxEnv-body exp) cenv target linkage))) + (append-instruction-sequences + (make-instruction-sequence + `(,(make-AssignPrimOpStatement (make-EnvLexicalReference (BoxEnv-depth exp) #f) + (make-MakeBoxedEnvironmentValue (BoxEnv-depth exp))))) + (compile (BoxEnv-body exp) cenv target linkage))) (: append-instruction-sequences (InstructionSequence * -> InstructionSequence)) diff --git a/il-structs.rkt b/il-structs.rkt index 84e9597..f60db10 100644 --- a/il-structs.rkt +++ b/il-structs.rkt @@ -279,10 +279,19 @@ + ;; Linkage -(define-type Linkage (U 'return - 'next - Symbol)) +(define-struct: NextLinkage ()) +(define next-linkage (make-NextLinkage)) + +(define-struct: ReturnLinkage ()) +(define return-linkage (make-ReturnLinkage)) + +(define-struct: LabelLinkage ([label : Symbol])) + +(define-type Linkage (U NextLinkage + ReturnLinkage + LabelLinkage))