diff --git a/compile.rkt b/compile.rkt index b7adc7d..d932fec 100644 --- a/compile.rkt +++ b/compile.rkt @@ -11,7 +11,7 @@ ;; registers: env, argl, proc, val, cont ;; as well as the stack. -(define all-regs '(env argl proc val cont)) +(define all-regs '(val control env)) (: compile-top (Expression Target Linkage -> InstructionSequence)) @@ -20,8 +20,6 @@ [cenv : CompileTimeEnvironment (list (make-Prefix names))]) (append-instruction-sequences (make-instruction-sequence - '(env) - '(env) `(,(make-AssignPrimOpStatement 'env 'extend-environment/prefix (list (make-Const names) @@ -35,24 +33,24 @@ (cond [(Constant? exp) (compile-self-evaluating exp cenv target linkage)] - [(Quote? exp) + #;[(Quote? exp) (compile-quoted exp cenv target linkage)] - [(Var? exp) + #;[(Var? exp) (compile-variable exp cenv target linkage)] - [(Assign? exp) + #;[(Assign? exp) (compile-assignment exp cenv target linkage)] - [(Def? exp) + #;[(Def? exp) (compile-definition exp cenv target linkage)] - [(Branch? exp) + #;[(Branch? exp) (compile-if exp cenv target linkage)] - [(Lam? exp) + #;[(Lam? exp) (compile-lambda exp cenv target linkage)] - [(Seq? exp) + #;[(Seq? exp) (compile-sequence (Seq-actions exp) cenv target linkage)] - [(App? exp) + #;[(App? exp) (compile-application exp cenv target linkage)])) @@ -60,45 +58,37 @@ (: compile-linkage (Linkage -> InstructionSequence)) (define (compile-linkage linkage) (cond - [(eq? linkage 'return) - (make-instruction-sequence '(cont) '() `(,(make-GotoStatement (make-Reg 'cont))))] + #;[(eq? linkage 'return) + (make-instruction-sequence `(,(make-GotoStatement (make-ControlOffset 0))))] [(eq? linkage 'next) empty-instruction-sequence] [else - (make-instruction-sequence '() '() - `(,(make-GotoStatement (make-Label linkage))))])) + (make-instruction-sequence `(,(make-GotoStatement (make-Label linkage))))])) (: end-with-linkage (Linkage InstructionSequence -> InstructionSequence)) (define (end-with-linkage linkage instruction-sequence) - (preserving '(cont) - instruction-sequence - (compile-linkage linkage))) + (append-instruction-sequences instruction-sequence + (compile-linkage linkage))) (: compile-self-evaluating (Constant CompileTimeEnvironment Target Linkage -> InstructionSequence)) (define (compile-self-evaluating exp cenv target linkage) (end-with-linkage linkage (make-instruction-sequence - '() - (list target) `(,(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 (make-instruction-sequence - '() - (list target) `(,(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 (make-instruction-sequence - '(env) - (list target) `(,(make-AssignPrimOpStatement target 'lexical-address-lookup (list (make-Const (LocalAddress-depth lexical-pos)) @@ -107,8 +97,6 @@ [(PrefixAddress? lexical-pos) (end-with-linkage linkage (make-instruction-sequence - '(env) - (list target) `(,(make-PerformStatement 'check-bound! (list (make-Const (PrefixAddress-depth lexical-pos)) (make-Const (PrefixAddress-pos lexical-pos)) @@ -122,8 +110,8 @@ (make-Reg 'env))))))]))) -(: compile-assignment (Assign CompileTimeEnvironment Target Linkage -> InstructionSequence)) -(define (compile-assignment exp cenv target linkage) +#;(: 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)] @@ -133,36 +121,30 @@ [(LocalAddress? lexical-address) (end-with-linkage linkage - (preserving '(env) - get-value-code - (make-instruction-sequence - '(env val) - (list target) - `(,(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))))))] + (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 - (preserving '(env) - get-value-code - (make-instruction-sequence - '(env val) - (list target) - `(,(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))))))]))) + (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 @@ -173,23 +155,19 @@ [(PrefixAddress? lexical-pos) (end-with-linkage linkage - (preserving - '(env) + (append-instruction-sequences get-value-code - (make-instruction-sequence - '(env val) - (list target) - `(,(make-PerformStatement 'toplevel-set! - (list (make-Const (PrefixAddress-depth lexical-pos)) - (make-Const (PrefixAddress-pos lexical-pos)) - (make-Const var) - (make-Reg 'env) - (make-Reg 'val))) - ,(make-AssignImmediateStatement target (make-Const 'ok))))))]))) + (make-instruction-sequence `(,(make-PerformStatement 'toplevel-set! + (list (make-Const (PrefixAddress-depth lexical-pos)) + (make-Const (PrefixAddress-pos lexical-pos)) + (make-Const var) + (make-Reg 'env) + (make-Reg 'val))) + ,(make-AssignImmediateStatement target (make-Const 'ok))))))]))) -(: compile-if (Branch CompileTimeEnvironment Target Linkage -> InstructionSequence)) -(define (compile-if exp cenv target linkage) +#;(: compile-if (Branch CompileTimeEnvironment Target Linkage -> InstructionSequence)) +#;(define (compile-if exp cenv target linkage) (let ([t-branch (make-label 'trueBranch)] [f-branch (make-label 'falseBranch)] [after-if (make-label 'afterIf)]) @@ -200,31 +178,27 @@ (let ([p-code (compile (Branch-predicate exp) cenv 'val 'next)] [c-code (compile (Branch-consequent exp) cenv target consequent-linkage)] [a-code (compile (Branch-alternative exp) cenv target linkage)]) - (preserving '(env cont) - p-code - (append-instruction-sequences - (make-instruction-sequence - '(val) - '() - `(,(make-TestStatement 'false? 'val) - ,(make-BranchLabelStatement f-branch))) - (parallel-instruction-sequences - (append-instruction-sequences t-branch c-code) - (append-instruction-sequences f-branch a-code)) - after-if)))))) + (append-instruction-sequences p-code + (append-instruction-sequences + (make-instruction-sequence + `(,(make-TestStatement 'false? 'val) + ,(make-BranchLabelStatement f-branch))) + (parallel-instruction-sequences + (append-instruction-sequences t-branch c-code) + (append-instruction-sequences f-branch a-code)) + 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) - (preserving '(env cont) - (compile (first-exp seq) cenv target 'next) - (compile-sequence (rest-exps seq) cenv target linkage)))) + (append-instruction-sequences (compile (first-exp seq) cenv target 'next) + (compile-sequence (rest-exps seq) cenv target linkage)))) -(: compile-lambda (Lam CompileTimeEnvironment Target Linkage -> InstructionSequence)) -(define (compile-lambda exp cenv target linkage) +#;(: compile-lambda (Lam CompileTimeEnvironment Target Linkage -> InstructionSequence)) +#;(define (compile-lambda exp cenv target linkage) (let ([proc-entry (make-label 'entry)] [after-lambda (make-label 'afterLambda)]) (let ([lambda-linkage @@ -235,8 +209,6 @@ (tack-on-instruction-sequence (end-with-linkage lambda-linkage (make-instruction-sequence - '(env) - (list target) `(,(make-AssignPrimOpStatement target 'make-compiled-procedure (list (make-Label proc-entry) @@ -251,14 +223,12 @@ proc-entry)) after-lambda)))) -(: compile-lambda-body (Lam CompileTimeEnvironment Linkage -> InstructionSequence)) -(define (compile-lambda-body exp cenv proc-entry) +#;(: compile-lambda-body (Lam CompileTimeEnvironment Linkage -> InstructionSequence)) +#;(define (compile-lambda-body exp cenv proc-entry) (let* ([formals (Lam-parameters exp)] [extended-cenv (extend-lexical-environment cenv formals)]) (append-instruction-sequences (make-instruction-sequence - '(env proc argl) - '(env) `(,proc-entry ,(make-AssignPrimOpStatement 'env 'compiled-procedure-env @@ -269,8 +239,8 @@ (make-Reg 'env))))) (compile-sequence (Lam-body exp) extended-cenv 'val 'return)))) -(: compile-application (App CompileTimeEnvironment Target Linkage -> InstructionSequence)) -(define (compile-application exp cenv target linkage) +#;(: compile-application (App CompileTimeEnvironment Target Linkage -> InstructionSequence)) +#;(define (compile-application exp cenv target linkage) ;; FIXME: I need to implement important special cases. ;; 1. We may be able to open-code if the operator is primitive ;; 2. We may have a static location to jump to if the operator is lexically scoped. @@ -278,59 +248,51 @@ [operand-codes (map (lambda: ([operand : Expression]) (compile operand cenv 'val 'next)) (App-operands exp))]) - (preserving '(env cont) - proc-code - (preserving '(proc cont) - (construct-arglist operand-codes) - (compile-procedure-call target linkage))))) + (append-instruction-sequences + proc-code + (append-instruction-sequences + (construct-arglist operand-codes) + (compile-procedure-call target linkage))))) -(: construct-arglist ((Listof InstructionSequence) -> InstructionSequence)) -(define (construct-arglist operand-codes) +#;(: construct-arglist ((Listof InstructionSequence) -> InstructionSequence)) +#;(define (construct-arglist operand-codes) (let ([operand-codes (reverse operand-codes)]) (if (null? operand-codes) - (make-instruction-sequence '() - '(argl) - `(,(make-AssignImmediateStatement 'argl (make-Const '())))) + (make-instruction-sequence `(,(make-AssignImmediateStatement 'argl (make-Const '())))) (let ([code-to-get-last-arg (append-instruction-sequences (car operand-codes) - (make-instruction-sequence '(val) '(argl) - `(,(make-AssignPrimOpStatement 'argl 'list + (make-instruction-sequence `(,(make-AssignPrimOpStatement 'argl 'list (list (make-Reg 'val))))))]) (if (null? (cdr operand-codes)) code-to-get-last-arg - (preserving '(env) - code-to-get-last-arg - (code-to-get-rest-args - (cdr operand-codes)))))))) -(: code-to-get-rest-args ((Listof InstructionSequence) -> InstructionSequence)) -(define (code-to-get-rest-args operand-codes) + (append-instruction-sequences code-to-get-last-arg + (code-to-get-rest-args + (cdr operand-codes)))))))) +#;(: code-to-get-rest-args ((Listof InstructionSequence) -> InstructionSequence)) +#;(define (code-to-get-rest-args operand-codes) (let ([code-for-next-arg - (preserving '(argl) - (car operand-codes) - (make-instruction-sequence - '(val argl) - '(argl) - `(,(make-AssignPrimOpStatement 'argl - 'cons - (list (make-Reg 'val) - (make-Reg 'argl))))))]) + (append-instruction-sequences + (car operand-codes) + (make-instruction-sequence + `(,(make-AssignPrimOpStatement 'argl + 'cons + (list (make-Reg 'val) + (make-Reg 'argl))))))]) (if (null? (cdr operand-codes)) code-for-next-arg - (preserving '(env) - code-for-next-arg - (code-to-get-rest-args (cdr operand-codes)))))) + (append-instruction-sequences code-for-next-arg + (code-to-get-rest-args (cdr operand-codes)))))) -(: compile-procedure-call (Target Linkage -> InstructionSequence)) -(define (compile-procedure-call target linkage) +#;(: compile-procedure-call (Target Linkage -> InstructionSequence)) +#;(define (compile-procedure-call 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)]) (append-instruction-sequences - (make-instruction-sequence '(proc) '() - `(,(make-TestStatement 'primitive-procedure? 'proc) + (make-instruction-sequence `(,(make-TestStatement 'primitive-procedure? 'proc) ,(make-BranchLabelStatement primitive-branch))) (parallel-instruction-sequences (append-instruction-sequences @@ -340,21 +302,17 @@ primitive-branch (end-with-linkage linkage (make-instruction-sequence - '(proc argl) - (list target) `(,(make-AssignPrimOpStatement target 'apply-primitive-procedure (list (make-Reg 'proc) (make-Reg 'argl)))))))) after-call)))) -(: compile-proc-appl (Target Linkage -> InstructionSequence)) -(define (compile-proc-appl target linkage) +#;(: compile-proc-appl (Target Linkage -> InstructionSequence)) +#;(define (compile-proc-appl target linkage) (cond [(and (eq? target 'val) (not (eq? linkage 'return))) (make-instruction-sequence - '(proc) - all-regs `(,(make-AssignImmediateStatement 'cont (make-Label linkage)) ,(make-AssignPrimOpStatement 'val 'compiled-procedure-entry (list (make-Reg 'proc))) @@ -363,8 +321,6 @@ (not (eq? linkage 'return))) (let ([proc-return (make-label 'procReturn)]) (make-instruction-sequence - '(proc) - all-regs `(,(make-AssignImmediateStatement 'cont (make-Label proc-return)) ,(make-AssignPrimOpStatement 'val 'compiled-procedure-entry (list (make-Reg 'proc))) @@ -375,8 +331,6 @@ [(and (eq? target 'val) (eq? linkage 'return)) (make-instruction-sequence - '(proc cont) - all-regs `(,(make-AssignPrimOpStatement 'val 'compiled-procedure-entry (list (make-Reg 'proc))) ,(make-GotoStatement (make-Reg 'val))))] @@ -388,39 +342,6 @@ - - - - -(: needs-register? (InstructionSequence Symbol -> Boolean)) -(define (needs-register? seq reg) - (and (memq reg (registers-needed seq)) #t)) - -(: modifies-register? (InstructionSequence Symbol -> Boolean)) -(define (modifies-register? seq reg) - (and (memq reg (registers-modified seq)) #t)) - -(: preserving ((Listof Symbol) InstructionSequence InstructionSequence -> InstructionSequence)) -(define (preserving regs seq1 seq2) - (if (null? regs) - (append-instruction-sequences seq1 seq2) - (let ([first-reg (car regs)]) - (if (and (needs-register? seq2 first-reg) - (modifies-register? seq1 first-reg)) - (preserving (cdr regs) - (make-instruction-sequence - (list-union (list first-reg) - (registers-needed seq1)) - (list-difference (registers-modified seq1) - (list first-reg)) - (append `(,(make-SaveStatement first-reg)) - (statements seq1) - `(,(make-RestoreStatement first-reg)))) - seq2) - (preserving (cdr regs) seq1 seq2))))) - - - (: append-instruction-sequences (InstructionSequence * -> InstructionSequence)) (define (append-instruction-sequences . seqs) (append-seq-list seqs)) @@ -428,11 +349,6 @@ (: append-2-sequences (InstructionSequence InstructionSequence -> InstructionSequence)) (define (append-2-sequences seq1 seq2) (make-instruction-sequence - (list-union (registers-needed seq1) - (list-difference (registers-needed seq2) - (registers-modified seq1))) - (list-union (registers-modified seq1) - (registers-modified seq2)) (append (statements seq1) (statements seq2)))) (: append-seq-list ((Listof InstructionSequence) -> InstructionSequence)) @@ -447,16 +363,9 @@ (: tack-on-instruction-sequence (InstructionSequence InstructionSequence -> InstructionSequence)) (define (tack-on-instruction-sequence seq body-seq) - (make-instruction-sequence (registers-needed seq) - (registers-modified seq) - (append (statements seq) (statements body-seq)))) + (make-instruction-sequence (append (statements seq) (statements body-seq)))) (: parallel-instruction-sequences (InstructionSequence InstructionSequence -> InstructionSequence)) (define (parallel-instruction-sequences seq1 seq2) - (make-instruction-sequence - (list-union (registers-needed seq1) - (registers-needed seq2)) - (list-union (registers-modified seq1) - (registers-modified seq2)) - (append (statements seq1) (statements seq2)))) + (make-instruction-sequence (append (statements seq1) (statements seq2)))) diff --git a/typed-structs.rkt b/typed-structs.rkt index 29ddf40..1cab9d0 100644 --- a/typed-structs.rkt +++ b/typed-structs.rkt @@ -4,8 +4,8 @@ ;; Expressions -(define-type ExpressionCore (U Constant Quote Var Branch Def Lam Seq App)) -(define-type Expression (U ExpressionCore Assign)) +(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) (define-struct: Var ([id : Symbol]) #:transparent) @@ -33,6 +33,10 @@ (define (rest-exps seq) (cdr seq)) +(define-type StackRegisterSymbol (U 'control 'env)) +(define-type RegisterSymbol (U StackRegisterSymbol 'val)) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; instruction sequences @@ -43,30 +47,30 @@ TestStatement BranchLabelStatement GotoStatement - SaveStatement - RestoreStatement)) + #;SaveStatement + #;RestoreStatement)) (define-type Statement (U UnlabeledStatement Symbol ;; label )) -(define-struct: AssignImmediateStatement ([target : Symbol] +(define-struct: AssignImmediateStatement ([target : Target] [value : (U Const Reg Label)]) #:transparent) -(define-struct: AssignPrimOpStatement ([target : Symbol] +(define-struct: AssignPrimOpStatement ([target : Target] [op : PrimitiveOperator] [rands : (Listof (U Label Reg Const))]) #:transparent) (define-struct: PerformStatement ([op : PerformOperator] [rands : (Listof (U Label Reg Const))]) #:transparent) (define-struct: TestStatement ([op : TestOperator] - [register-rand : Symbol]) #:transparent) + [register-rand : RegisterSymbol]) #:transparent) (define-struct: BranchLabelStatement ([label : Symbol]) #:transparent) (define-struct: GotoStatement ([target : (U Label Reg)]) #:transparent) -(define-struct: SaveStatement ([reg : Symbol]) #:transparent) -(define-struct: RestoreStatement ([reg : Symbol]) #:transparent) +#;(define-struct: SaveStatement ([reg : RegisterSymbol]) #:transparent) +#;(define-struct: RestoreStatement ([reg : RegisterSymbol]) #:transparent) (define-struct: Label ([name : Symbol]) #:transparent) -(define-struct: Reg ([name : Symbol]) +(define-struct: Reg ([name : RegisterSymbol]) #:transparent) (define-struct: Const ([const : Any]) #:transparent) @@ -99,10 +103,9 @@ (define-type InstructionSequence (U Symbol instruction-sequence)) -(define-struct: instruction-sequence ([needs : (Listof Symbol)] - [modifies : (Listof Symbol)] - [statements : (Listof Statement)]) #:transparent) -(define empty-instruction-sequence (make-instruction-sequence '() '() '())) +(define-struct: instruction-sequence ([statements : (Listof Statement)]) + #:transparent) +(define empty-instruction-sequence (make-instruction-sequence '())) (: make-label (Symbol -> Symbol)) (define make-label @@ -112,14 +115,6 @@ (string->symbol (format "~a~a" l n))))) -(: registers-needed (InstructionSequence -> (Listof Symbol))) -(define (registers-needed s) - (if (symbol? s) '() (instruction-sequence-needs s))) - -(: registers-modified (InstructionSequence -> (Listof Symbol))) -(define (registers-modified s) - (if (symbol? s) '() (instruction-sequence-modifies s))) - (: statements (InstructionSequence -> (Listof Statement))) (define (statements s) (if (symbol? s) (list s) (instruction-sequence-statements s))) @@ -127,10 +122,15 @@ ;; Targets -(define-type Target Symbol) +(define-type Target (U RegisterSymbol ControlOffset EnvOffset)) +(define-struct: ControlOffset ([depth : Natural])) +(define-struct: EnvOffset ([depth : Natural] + [pos : Natural])) ;; Linkage -(define-type Linkage (U 'return 'next Symbol)) +(define-type Linkage (U #; 'return + 'next + Symbol))