diff --git a/compile.rkt b/compile.rkt index d932fec..582dead 100644 --- a/compile.rkt +++ b/compile.rkt @@ -9,12 +9,9 @@ (provide compile-top) -;; registers: env, argl, proc, val, cont -;; as well as the stack. -(define all-regs '(val control env)) -(: compile-top (Expression Target Linkage -> InstructionSequence)) +(: compile-top (ExpressionCore Target Linkage -> InstructionSequence)) (define (compile-top exp target linkage) (let*: ([names : (Listof Symbol) (find-toplevel-variables exp)] [cenv : CompileTimeEnvironment (list (make-Prefix names))]) @@ -28,24 +25,22 @@ ;; compile: expression target linkage -> instruction-sequence -(: compile (Expression CompileTimeEnvironment Target Linkage -> InstructionSequence)) +(: compile (ExpressionCore CompileTimeEnvironment Target Linkage -> InstructionSequence)) (define (compile exp cenv target linkage) (cond [(Constant? exp) - (compile-self-evaluating exp cenv target linkage)] - #;[(Quote? exp) + (compile-constant exp cenv target linkage)] + [(Quote? exp) (compile-quoted exp cenv target linkage)] - #;[(Var? exp) + [(Var? exp) (compile-variable exp cenv target linkage)] - #;[(Assign? exp) - (compile-assignment exp cenv target linkage)] - #;[(Def? exp) + [(Def? exp) (compile-definition exp cenv target linkage)] - #;[(Branch? exp) - (compile-if exp cenv target linkage)] + [(Branch? exp) + (compile-branch exp cenv target linkage)] #;[(Lam? exp) (compile-lambda exp cenv target linkage)] - #;[(Seq? exp) + [(Seq? exp) (compile-sequence (Seq-actions exp) cenv target @@ -55,39 +50,48 @@ -(: compile-linkage (Linkage -> InstructionSequence)) -(define (compile-linkage linkage) +(: compile-linkage (CompileTimeEnvironment Linkage -> InstructionSequence)) +(define (compile-linkage cenv linkage) (cond - #;[(eq? linkage 'return) - (make-instruction-sequence `(,(make-GotoStatement (make-ControlOffset 0))))] + [(eq? linkage 'return) + (make-instruction-sequence `(,(make-AssignPrimOpStatement 'proc + 'read-control-label + (list (make-Reg 'control))) + ,(make-PopEnv (lexical-environment-pop-depth cenv)) + ,(make-PopControl) + ,(make-GotoStatement (make-Reg 'proc))))] [(eq? linkage 'next) empty-instruction-sequence] - [else + [(symbol? linkage) (make-instruction-sequence `(,(make-GotoStatement (make-Label linkage))))])) -(: end-with-linkage (Linkage InstructionSequence -> InstructionSequence)) -(define (end-with-linkage linkage instruction-sequence) +(: end-with-linkage (Linkage CompileTimeEnvironment InstructionSequence -> + InstructionSequence)) +(define (end-with-linkage linkage cenv instruction-sequence) (append-instruction-sequences instruction-sequence - (compile-linkage linkage))) + (compile-linkage cenv linkage))) -(: compile-self-evaluating (Constant CompileTimeEnvironment Target Linkage -> InstructionSequence)) -(define (compile-self-evaluating exp cenv target linkage) +(: compile-constant (Constant CompileTimeEnvironment Target Linkage -> InstructionSequence)) +(define (compile-constant exp cenv target linkage) (end-with-linkage linkage + cenv (make-instruction-sequence `(,(make-AssignImmediateStatement target (make-Const (Constant-v exp))))))) -#;(: compile-quoted (Quote CompileTimeEnvironment Target Linkage -> InstructionSequence)) -#;(define (compile-quoted exp cenv target linkage) +(: compile-quoted (Quote CompileTimeEnvironment Target Linkage -> InstructionSequence)) +(define (compile-quoted exp cenv target linkage) (end-with-linkage linkage + cenv (make-instruction-sequence `(,(make-AssignImmediateStatement target (make-Const (Quote-text exp))))))) -#;(: compile-variable (Var CompileTimeEnvironment Target Linkage -> InstructionSequence)) -#;(define (compile-variable exp cenv target linkage) +(: compile-variable (Var CompileTimeEnvironment Target Linkage -> InstructionSequence)) +(define (compile-variable exp cenv target linkage) (let ([lexical-pos (find-variable (Var-id exp) cenv)]) (cond [(LocalAddress? lexical-pos) (end-with-linkage linkage + cenv (make-instruction-sequence `(,(make-AssignPrimOpStatement target 'lexical-address-lookup @@ -96,6 +100,7 @@ (make-Reg 'env))))))] [(PrefixAddress? lexical-pos) (end-with-linkage linkage + cenv (make-instruction-sequence `(,(make-PerformStatement 'check-bound! (list (make-Const (PrefixAddress-depth lexical-pos)) @@ -110,41 +115,8 @@ (make-Reg 'env))))))]))) -#;(: compile-assignment (Assign CompileTimeEnvironment Target Linkage -> InstructionSequence)) -#;(define (compile-assignment exp cenv target linkage) - (let* ([var (Assign-variable exp)] - [get-value-code - (compile (Assign-value exp) cenv 'val 'next)] - [lexical-address - (find-variable var cenv)]) - (cond - [(LocalAddress? lexical-address) - (end-with-linkage - linkage - (append-instruction-sequences get-value-code - (make-instruction-sequence - `(,(make-PerformStatement 'lexical-address-set! - (list (make-Const (LocalAddress-depth lexical-address)) - (make-Const (LocalAddress-pos lexical-address)) - (make-Reg 'env) - (make-Reg 'val))) - ,(make-AssignImmediateStatement target (make-Const 'ok))))))] - [(PrefixAddress? lexical-address) - (end-with-linkage - linkage - (append-instruction-sequences get-value-code - (make-instruction-sequence - `(,(make-PerformStatement 'toplevel-set! - (list (make-Const (PrefixAddress-depth lexical-address)) - (make-Const (PrefixAddress-pos lexical-address)) - (make-Const (PrefixAddress-name lexical-address)) - (make-Reg 'env) - (make-Reg 'val))) - ,(make-AssignImmediateStatement target (make-Const 'ok))))))]))) - - -#;(: compile-definition (Def CompileTimeEnvironment Target Linkage -> InstructionSequence)) -#;(define (compile-definition exp cenv target linkage) +(: compile-definition (Def CompileTimeEnvironment Target Linkage -> InstructionSequence)) +(define (compile-definition exp cenv target linkage) (let* ([var (Def-variable exp)] [lexical-pos (find-variable var cenv)] [get-value-code @@ -155,6 +127,7 @@ [(PrefixAddress? lexical-pos) (end-with-linkage linkage + cenv (append-instruction-sequences get-value-code (make-instruction-sequence `(,(make-PerformStatement 'toplevel-set! @@ -166,8 +139,8 @@ ,(make-AssignImmediateStatement target (make-Const 'ok))))))]))) -#;(: compile-if (Branch CompileTimeEnvironment Target Linkage -> InstructionSequence)) -#;(define (compile-if exp cenv target linkage) +(: 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)]) @@ -189,8 +162,8 @@ after-if)))))) -#;(: compile-sequence ((Listof Expression) CompileTimeEnvironment Target Linkage -> InstructionSequence)) -#;(define (compile-sequence seq cenv target linkage) +(: compile-sequence ((Listof Expression) CompileTimeEnvironment Target Linkage -> InstructionSequence)) +(define (compile-sequence seq cenv target linkage) (if (last-exp? seq) (compile (first-exp seq) cenv target linkage) (append-instruction-sequences (compile (first-exp seq) cenv target 'next) diff --git a/lexical-env.rkt b/lexical-env.rkt index b4eb97f..33585f7 100644 --- a/lexical-env.rkt +++ b/lexical-env.rkt @@ -2,7 +2,7 @@ (require racket/list "typed-structs.rkt") -(provide find-variable extend-lexical-environment) +(provide find-variable extend-lexical-environment lexical-environment-pop-depth) ;; find-variable: symbol compile-time-environment -> lexical-address @@ -35,4 +35,14 @@ ;; extend-lexical-environment: lexical-environment (listof symbol) -> lexical-envrionment (: extend-lexical-environment (CompileTimeEnvironment (Listof Symbol) -> CompileTimeEnvironment)) (define (extend-lexical-environment cenv names) - (cons names cenv)) \ No newline at end of file + (cons names cenv)) + + +(: lexical-environment-pop-depth (CompileTimeEnvironment -> Natural)) +(define (lexical-environment-pop-depth cenv) + (cond [(empty? cenv) + (error 'lexical-environment-pop-depth "Empty environment")] + [(Prefix? (first cenv)) + 1] + [(list? (first cenv)) + 1])) \ No newline at end of file diff --git a/typed-structs.rkt b/typed-structs.rkt index 1cab9d0..c3385c9 100644 --- a/typed-structs.rkt +++ b/typed-structs.rkt @@ -4,7 +4,7 @@ ;; Expressions -(define-type ExpressionCore (U Constant #;Quote #;Var #;Branch #;Def #;Lam #;Seq #;App)) +(define-type ExpressionCore (U Constant Quote Var Branch Def #;Lam Seq #;App)) (define-type Expression (U ExpressionCore #;Assign)) (define-struct: Constant ([v : Any]) #:transparent) (define-struct: Quote ([text : Any]) #:transparent) @@ -33,8 +33,11 @@ (define (rest-exps seq) (cdr seq)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (define-type StackRegisterSymbol (U 'control 'env)) -(define-type RegisterSymbol (U StackRegisterSymbol 'val)) +(define-type RegisterSymbol (U StackRegisterSymbol 'val 'proc)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -43,30 +46,25 @@ (define-type UnlabeledStatement (U AssignImmediateStatement AssignPrimOpStatement + GotoStatement PerformStatement TestStatement BranchLabelStatement - GotoStatement + PopEnv + PopControl #;SaveStatement #;RestoreStatement)) (define-type Statement (U UnlabeledStatement Symbol ;; label )) + (define-struct: AssignImmediateStatement ([target : Target] - [value : (U Const Reg Label)]) + [value : OpArg]) #:transparent) (define-struct: AssignPrimOpStatement ([target : Target] [op : PrimitiveOperator] - [rands : (Listof (U Label Reg Const))]) + [rands : (Listof OpArg)]) #:transparent) -(define-struct: PerformStatement ([op : PerformOperator] - [rands : (Listof (U Label Reg Const))]) #:transparent) -(define-struct: TestStatement ([op : TestOperator] - [register-rand : RegisterSymbol]) #:transparent) -(define-struct: BranchLabelStatement ([label : Symbol]) #:transparent) -(define-struct: GotoStatement ([target : (U Label Reg)]) #:transparent) -#;(define-struct: SaveStatement ([reg : RegisterSymbol]) #:transparent) -#;(define-struct: RestoreStatement ([reg : RegisterSymbol]) #:transparent) (define-struct: Label ([name : Symbol]) #:transparent) @@ -75,7 +73,25 @@ (define-struct: Const ([const : Any]) #:transparent) -(define-type OpArg (U Const Label Reg)) +(define-struct: TopControlProcedure ()) + +(define-type OpArg (U Const Label Reg TopControlProcedure)) + +(define-struct: PopEnv ([n : Natural])) +(define-struct: PopControl ()) + +(define-struct: GotoStatement ([target : (U Label Reg)]) + #:transparent) + + +(define-struct: PerformStatement ([op : PerformOperator] + [rands : (Listof (U Label Reg Const))]) #:transparent) +(define-struct: TestStatement ([op : TestOperator] + [register-rand : RegisterSymbol]) #:transparent) +(define-struct: BranchLabelStatement ([label : Symbol]) #:transparent) +#;(define-struct: SaveStatement ([reg : RegisterSymbol]) #:transparent) +#;(define-struct: RestoreStatement ([reg : RegisterSymbol]) #:transparent) + (define-type PrimitiveOperator (U 'compiled-procedure-entry @@ -90,6 +106,8 @@ 'lexical-address-lookup 'toplevel-lookup + 'read-control-label + 'extend-environment 'extend-environment/prefix)) @@ -122,13 +140,13 @@ ;; Targets -(define-type Target (U RegisterSymbol ControlOffset EnvOffset)) -(define-struct: ControlOffset ([depth : Natural])) +(define-type Target (U RegisterSymbol ControlTarget EnvOffset)) +(define-struct: ControlTarget ()) (define-struct: EnvOffset ([depth : Natural] [pos : Natural])) ;; Linkage -(define-type Linkage (U #; 'return +(define-type Linkage (U 'return 'next Symbol))