diff --git a/cm.rkt b/cm.rkt index d4bb690..f2d34cc 100644 --- a/cm.rkt +++ b/cm.rkt @@ -1,7 +1,7 @@ -#lang racket/base +#lang typed/racket/base -(require "structs.rkt" - "assemble.rkt" +(require "typed-structs.rkt" + #;"assemble.rkt" racket/list) (provide compile) @@ -16,66 +16,67 @@ ;; A compile-time environment is a (listof (listof symbol)). ;; A lexical address is either a 2-tuple (depth pos), or 'not-found. - +(define-type CompileTimeEnvironment (Listof (Listof Symbol))) +(define-type LexicalAddress (U (List Number Number) 'not-found)) ;; find-variable: symbol compile-time-environment -> lexical-address ;; Find where the variable should be located. +(: find-variable (Symbol CompileTimeEnvironment -> LexicalAddress)) (define (find-variable name cenv) + (: find-pos (Symbol (Listof Symbol) -> Natural)) (define (find-pos sym los) (cond [(eq? sym (car los)) 0] [else (add1 (find-pos sym (cdr los)))])) - (let loop ([cenv cenv] - [depth 0]) - (cond [(empty? cenv) - 'not-found] - [(member name (first cenv)) - (list depth (find-pos name (first cenv)))] - [else - (loop (rest cenv) (add1 depth))]))) + (let: loop : LexicalAddress ([cenv : CompileTimeEnvironment cenv] + [depth : Natural 0]) + (cond [(empty? cenv) + 'not-found] + [(member name (first cenv)) + (list depth (find-pos name (first cenv)))] + [else + (loop (rest cenv) (add1 depth))]))) -;; global-lexical-address?: lexical-address -> boolean -;; Produces true if the address refers to the toplevel environment. -(define (global-lexical-address? address) - (eq? address 'not-found)) ;; 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)) ;; compile: expression target linkage -> instruction-sequence +(: compile (Expression CompileTimeEnvironment Target Linkage -> InstructionSequence)) (define (compile exp cenv target linkage) (cond - [(self-evaluating? exp) + [(Constant? exp) (compile-self-evaluating exp cenv target linkage)] - [(quoted? exp) + [(Quote? exp) (compile-quoted exp cenv target linkage)] - [(variable? exp) + [(Var? exp) (compile-variable exp cenv target linkage)] - [(assignment? exp) + [(Assign? exp) (compile-assignment exp cenv target linkage)] - [(definition? exp) + [(Def? exp) (compile-definition exp cenv target linkage)] - [(if? exp) + [(Branch? exp) (compile-if exp cenv target linkage)] - [(lambda? exp) + [(Lam? exp) (compile-lambda exp cenv target linkage)] - [(begin? exp) - (compile-sequence (begin-actions exp) + [(Seq? exp) + (compile-sequence (Seq-actions exp) cenv target linkage)] - [(application? exp) + [(App? exp) (compile-application exp cenv target linkage)] [else (error 'compile "Unknown expression type ~e" exp)])) - +(: compile-linkage (Linkage -> InstructionSequence)) (define (compile-linkage linkage) (cond [(eq? linkage 'return) @@ -86,12 +87,13 @@ (make-instruction-sequence '() '() `((goto (label ,linkage))))])) +(: end-with-linkage (Linkage InstructionSequence -> InstructionSequence)) (define (end-with-linkage linkage instruction-sequence) (preserving '(cont) 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 @@ -99,19 +101,19 @@ (list target) `((assign ,target (const ,exp)))))) - +(: compile-quoted (Quote CompileTimeEnvironment Target Linkage -> InstructionSequence)) (define (compile-quoted exp cenv target linkage) (end-with-linkage linkage (make-instruction-sequence '() (list target) - `((assign ,target (const ,(text-of-quotation exp))))))) - + `((assign ,target (const ,(Quote-text exp))))))) +(: compile-variable (Var CompileTimeEnvironment Target Linkage -> InstructionSequence)) (define (compile-variable exp cenv target linkage) - (let ([lexical-pos (find-variable exp cenv)]) + (let ([lexical-pos (find-variable (Var-id exp) cenv)]) (cond - [(global-lexical-address? lexical-pos) + [(eq? lexical-pos 'not-found) (end-with-linkage linkage (make-instruction-sequence '(env) @@ -119,11 +121,11 @@ ;; Slight modification: explicitly testing for ;; global variable binding before lookup. `((perform (op check-bound-global!) - (const ,exp) + (const ,(Var-id exp)) (reg env)) (assign ,target (op lookup-variable-value) - (const ,exp) + (const ,(Var-id exp)) (reg env)))))] [else (end-with-linkage linkage @@ -137,15 +139,15 @@ (reg env)))))]))) - +(: compile-assignment (Assign CompileTimeEnvironment Target Linkage -> InstructionSequence)) (define (compile-assignment exp cenv target linkage) - (let* ([var (assignment-variable exp)] + (let* ([var (Assign-variable exp)] [get-value-code - (compile (assignment-value exp) cenv 'val 'next)] + (compile (Assign-value exp) cenv 'val 'next)] [lexical-address (find-variable var cenv)]) (cond - [(global-lexical-address? lexical-address) + [(eq? lexical-address 'not-found) (end-with-linkage linkage (preserving '(env) @@ -175,10 +177,11 @@ ;; FIXME: exercise 5.43 +(: compile-definition (Def CompileTimeEnvironment Target Linkage -> InstructionSequence)) (define (compile-definition exp cenv target linkage) - (let ([var (definition-variable exp)] + (let ([var (Def-variable exp)] [get-value-code - (compile (definition-value exp) cenv 'val 'next)]) + (compile (Def-value exp) cenv 'val 'next)]) (end-with-linkage linkage (preserving @@ -194,7 +197,7 @@ (assign ,target (const ok)))))))) - +(: 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)] @@ -203,9 +206,9 @@ (if (eq? linkage 'next) after-if linkage)]) - (let ([p-code (compile (if-predicate exp) cenv 'val 'next)] - [c-code (compile (if-consequent exp) cenv target consequent-linkage)] - [a-code (compile (if-alternative exp) cenv target linkage)]) + (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 @@ -220,7 +223,7 @@ after-if)))))) - +(: 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) @@ -229,6 +232,7 @@ (compile-sequence (rest-exps seq) 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)]) @@ -256,9 +260,9 @@ proc-entry)) after-lambda)))) - +(: compile-lambda-body (Lam CompileTimeEnvironment Linkage -> InstructionSequence)) (define (compile-lambda-body exp cenv proc-entry) - (let* ([formals (lambda-parameters exp)] + (let* ([formals (Lam-parameters exp)] [extended-cenv (extend-lexical-environment cenv formals)]) (append-instruction-sequences (make-instruction-sequence @@ -270,20 +274,21 @@ (op extend-environment) (reg argl) (reg env)))) - (compile-sequence (lambda-body exp) extended-cenv 'val 'return)))) - + (compile-sequence (Lam-body exp) extended-cenv 'val 'return)))) +(: compile-application (App CompileTimeEnvironment Target Linkage -> InstructionSequence)) (define (compile-application exp cenv target linkage) - (let ([proc-code (compile (operator exp) cenv 'proc 'next)] - [operand-codes (map (lambda (operand) + (let ([proc-code (compile (App-operator exp) cenv 'proc 'next)] + [operand-codes (map (lambda: ([operand : Expression]) (compile operand cenv 'val 'next)) - (operands exp))]) + (App-operands exp))]) (preserving '(env cont) proc-code (preserving '(proc cont) (construct-arglist operand-codes) (compile-procedure-call target linkage))))) +(: construct-arglist ((Listof InstructionSequence) -> InstructionSequence)) (define (construct-arglist operand-codes) (let ([operand-codes (reverse operand-codes)]) (if (null? operand-codes) @@ -301,6 +306,7 @@ 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) @@ -315,7 +321,7 @@ code-for-next-arg (code-to-get-rest-args (cdr operand-codes)))))) - +(: compile-procedure-call (Target Linkage -> InstructionSequence)) (define (compile-procedure-call target linkage) (let ([primitive-branch (make-label 'primitiveBranch)] [compiled-branch (make-label 'compiledBranch)] @@ -342,6 +348,7 @@ (reg argl))))))) after-call)))) +(: compile-proc-appl (Target Linkage -> InstructionSequence)) (define (compile-proc-appl target linkage) (cond [(and (eq? target 'val) (not (eq? linkage 'return))) @@ -385,13 +392,15 @@ - +(: needs-register? (InstructionSequence Symbol -> Boolean)) (define (needs-register? seq reg) - (memq reg (registers-needed seq))) + (and (memq reg (registers-needed seq)) #t)) + +(: modifies-register? (InstructionSequence Symbol -> Boolean)) (define (modifies-register? seq reg) - (memq reg (registers-modified seq))) - + (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) @@ -412,9 +421,12 @@ - +(: append-instruction-sequences (InstructionSequence * -> InstructionSequence)) (define (append-instruction-sequences . seqs) - (define (append-2-sequences seq1 seq2) + (append-seq-list seqs)) + +(: 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) @@ -422,19 +434,23 @@ (list-union (registers-modified seq1) (registers-modified seq2)) (append (statements seq1) (statements seq2)))) - (define (append-seq-list seqs) - (if (null? seqs) - empty-instruction-sequence - (append-2-sequences (car seqs) - (append-seq-list (cdr seqs))))) - (append-seq-list seqs)) +(: append-seq-list ((Listof InstructionSequence) -> InstructionSequence)) +(define (append-seq-list seqs) + (if (null? seqs) + empty-instruction-sequence + (append-2-sequences (car seqs) + (append-seq-list (cdr seqs))))) + +(: list-union ((Listof Symbol) (Listof Symbol) -> (Listof Symbol))) (define (list-union s1 s2) (cond [(null? s1) s2] [(memq (car s1) s2) (list-union (cdr s1) s2)] [else (cons (car s1) (list-union (cdr s1) s2))])) + +(: list-difference ((Listof Symbol) (Listof Symbol) -> (Listof Symbol))) (define (list-difference s1 s2) (cond [(null? s1) '()] [(memq (car s1) s2) @@ -443,13 +459,13 @@ (cons (car s1) (list-difference (cdr s1) s2))])) - +(: 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)))) - +(: parallel-instruction-sequences (InstructionSequence InstructionSequence -> InstructionSequence)) (define (parallel-instruction-sequences seq1 seq2) (make-instruction-sequence (list-union (registers-needed seq1) @@ -474,7 +490,7 @@ -(define (test source-code) +#;(define (test source-code) (let ([basic-blocks (fracture (statements (compile source-code '() diff --git a/typed-parse.rkt b/typed-parse.rkt new file mode 100644 index 0000000..363d9e0 --- /dev/null +++ b/typed-parse.rkt @@ -0,0 +1,6 @@ +#lang typed/racket/base +(require "typed-structs.rkt") +(require/typed "parse.rkt" + [parse (Any -> Expression)]) + +(provide parse) \ No newline at end of file diff --git a/typed-structs.rkt b/typed-structs.rkt new file mode 100644 index 0000000..72e575c --- /dev/null +++ b/typed-structs.rkt @@ -0,0 +1,66 @@ +#lang typed/racket/base +(provide (all-defined-out)) + +(define-type Expression (U Constant Quote Var Assign Branch Def Lam Seq App)) +(define-struct: Constant ([v : Any]) #:transparent) +(define-struct: Quote ([text : Any]) #:transparent) +(define-struct: Var ([id : Symbol]) #:transparent) +(define-struct: Assign ([variable : Symbol] + [value : Expression]) #:transparent) +(define-struct: Branch ([predicate : Expression] + [consequent : Expression] + [alternative : Expression]) #:transparent) +(define-struct: Def ([variable : Symbol] + [value : Expression]) #:transparent) +(define-struct: Lam ([parameters : (Listof Symbol)] + [body : (Listof Expression)]) #:transparent) +(define-struct: Seq ([actions : (Listof Expression)]) #:transparent) +(define-struct: App ([operator : Expression] + [operands : (Listof Expression)]) #:transparent) + +(: last-exp? ((Listof Expression) -> Boolean)) +(define (last-exp? seq) + (null? (cdr seq))) + +(: first-exp ((Listof Expression) -> Expression)) +(define (first-exp seq) (car seq)) + +(: rest-exps ((Listof Expression) -> (Listof Expression))) +(define (rest-exps seq) (cdr seq)) + + + +;; instruction sequences +(define-type InstructionSequence (U Symbol instruction-sequence)) +(define-struct: instruction-sequence ([needs : (Listof Symbol)] + [modifies : (Listof Symbol)] + [statements : (Listof Any)]) #:transparent) +(define empty-instruction-sequence (make-instruction-sequence '() '() '())) + +(: make-label (Symbol -> Symbol)) +(define make-label + (let ([n 0]) + (lambda (l) + (set! n (add1 n)) + (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 Any))) +(define (statements s) + (if (symbol? s) (list s) (instruction-sequence-statements s))) + + + +;; Targets +(define-type Target Symbol) + +;; Linkage +(define-type Linkage (U 'return 'next Symbol)) \ No newline at end of file