suzanne.soy/whalesong
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

rest break

Browse Source
This commit is contained in:
Danny Yoo 2011-02-18 18:08:13 -05:00
parent ac9ea0c75c
commit b78a1b35c2
2 changed files with 80 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

86
cm.rkt
View File

@ -1,7 +1,7 @@
#lang racket/base #lang typed/racket/base
(require "structs.rkt" (require "typed-structs.rkt"
"assemble.rkt" #;"assemble.rkt"
racket/list) racket/list)
(provide compile) (provide compile)
@ -16,25 +16,28 @@
;; A compile-time environment is a (listof (listof symbol)). ;; A compile-time environment is a (listof (listof symbol)).
;; A lexical address is either a 2-tuple (depth pos), or 'not-found. ;; A lexical address is either a 2-tuple (depth pos), or 'not-found.
(define-type CompileTimeEnvironment (Listof (Listof Symbol)))
(define-type LexicalAddress (List Number Number))
;; find-variable: symbol compile-time-environment -> lexical-address ;; find-variable: symbol compile-time-environment -> lexical-address
;; Find where the variable should be located. ;; Find where the variable should be located.
(: find-variable (Symbol CompileTimeEnvironment -> LexicalAddress))
(define (find-variable name cenv) (define (find-variable name cenv)
(: find-pos (Symbol (Listof Symbol) -> Natural))
(define (find-pos sym los) (define (find-pos sym los)
(cond (cond
[(eq? sym (car los)) [(eq? sym (car los))
0] 0]
[else [else
(add1 (find-pos sym (cdr los)))])) (add1 (find-pos sym (cdr los)))]))
(let loop ([cenv cenv] (let: loop : (U LexicalAddress 'not-found) ([cenv : CompileTimeEnvironment cenv]
[depth 0]) [depth : Natural 0])
(cond [(empty? cenv) (cond [(empty? cenv)
'not-found] 'not-found]
[(member name (first cenv)) [(member name (first cenv))
(list depth (find-pos name (first cenv)))] (list depth (find-pos name (first cenv)))]
[else [else
(loop (rest cenv) (add1 depth))]))) (loop (rest cenv) (add1 depth))])))
;; global-lexical-address?: lexical-address -> boolean ;; global-lexical-address?: lexical-address -> boolean
;; Produces true if the address refers to the toplevel environment. ;; Produces true if the address refers to the toplevel environment.
@ -48,28 +51,29 @@
;; compile: expression target linkage -> instruction-sequence ;; compile: expression target linkage -> instruction-sequence
(: compile (Expression CompileTimeEnvironment Target Linkage -> InstructionSequence))
(define (compile exp cenv target linkage) (define (compile exp cenv target linkage)
(cond (cond
[(self-evaluating? exp) [(Constant? exp)
(compile-self-evaluating exp cenv target linkage)] (compile-self-evaluating exp cenv target linkage)]
[(quoted? exp) [(Quote? exp)
(compile-quoted exp cenv target linkage)] (compile-quoted exp cenv target linkage)]
[(variable? exp) [(Var? exp)
(compile-variable exp cenv target linkage)] (compile-variable exp cenv target linkage)]
[(assignment? exp) [(Assign? exp)
(compile-assignment exp cenv target linkage)] (compile-assignment exp cenv target linkage)]
[(definition? exp) [(Def? exp)
(compile-definition exp cenv target linkage)] (compile-definition exp cenv target linkage)]
[(if? exp) [(Branch? exp)
(compile-if exp cenv target linkage)] (compile-if exp cenv target linkage)]
[(lambda? exp) [(Lam? exp)
(compile-lambda exp cenv target linkage)] (compile-lambda exp cenv target linkage)]
[(begin? exp) [(Seq? exp)
(compile-sequence (begin-actions exp) (compile-sequence (Seq-actions exp)
cenv cenv
target target
linkage)] linkage)]
[(application? exp) [(App? exp)
(compile-application exp cenv target linkage)] (compile-application exp cenv target linkage)]
[else [else
(error 'compile "Unknown expression type ~e" exp)])) (error 'compile "Unknown expression type ~e" exp)]))
@ -105,7 +109,7 @@
(make-instruction-sequence (make-instruction-sequence
'() '()
(list target) (list target)
`((assign ,target (const ,(text-of-quotation exp))))))) `((assign ,target (const ,(Quote-text exp)))))))
(define (compile-variable exp cenv target linkage) (define (compile-variable exp cenv target linkage)
@ -139,9 +143,9 @@
(define (compile-assignment exp cenv target linkage) (define (compile-assignment exp cenv target linkage)
(let* ([var (assignment-variable exp)] (let* ([var (Assign-variable exp)]
[get-value-code [get-value-code
(compile (assignment-value exp) cenv 'val 'next)] (compile (Assign-value exp) cenv 'val 'next)]
[lexical-address [lexical-address
(find-variable var cenv)]) (find-variable var cenv)])
(cond (cond
@ -176,9 +180,9 @@
;; FIXME: exercise 5.43 ;; FIXME: exercise 5.43
(define (compile-definition exp cenv target linkage) (define (compile-definition exp cenv target linkage)
(let ([var (definition-variable exp)] (let ([var (Def-variable exp)]
[get-value-code [get-value-code
(compile (definition-value exp) cenv 'val 'next)]) (compile (Def-value exp) cenv 'val 'next)])
(end-with-linkage (end-with-linkage
linkage linkage
(preserving (preserving
@ -203,9 +207,9 @@
(if (eq? linkage 'next) (if (eq? linkage 'next)
after-if after-if
linkage)]) linkage)])
(let ([p-code (compile (if-predicate exp) cenv 'val 'next)] (let ([p-code (compile (Branch-predicate exp) cenv 'val 'next)]
[c-code (compile (if-consequent exp) cenv target consequent-linkage)] [c-code (compile (Branch-consequent exp) cenv target consequent-linkage)]
[a-code (compile (if-alternative exp) cenv target linkage)]) [a-code (compile (Branch-alternative exp) cenv target linkage)])
(preserving '(env cont) (preserving '(env cont)
p-code p-code
(append-instruction-sequences (append-instruction-sequences
@ -258,7 +262,7 @@
(define (compile-lambda-body exp cenv proc-entry) (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)]) [extended-cenv (extend-lexical-environment cenv formals)])
(append-instruction-sequences (append-instruction-sequences
(make-instruction-sequence (make-instruction-sequence
@ -270,7 +274,7 @@
(op extend-environment) (op extend-environment)
(reg argl) (reg argl)
(reg env)))) (reg env))))
(compile-sequence (lambda-body exp) extended-cenv 'val 'return)))) (compile-sequence (Lam-body exp) extended-cenv 'val 'return))))
(define (compile-application exp cenv target linkage) (define (compile-application exp cenv target linkage)
@ -414,7 +418,9 @@
(define (append-instruction-sequences . seqs) (define (append-instruction-sequences . seqs)
(define (append-2-sequences seq1 seq2) (append-seq-list seqs))
(define (append-2-sequences seq1 seq2)
(make-instruction-sequence (make-instruction-sequence
(list-union (registers-needed seq1) (list-union (registers-needed seq1)
(list-difference (registers-needed seq2) (list-difference (registers-needed seq2)
@ -422,12 +428,12 @@
(list-union (registers-modified seq1) (list-union (registers-modified seq1)
(registers-modified seq2)) (registers-modified seq2))
(append (statements seq1) (statements seq2)))) (append (statements seq1) (statements seq2))))
(define (append-seq-list seqs)
(if (null? seqs) (define (append-seq-list seqs)
empty-instruction-sequence (if (null? seqs)
(append-2-sequences (car seqs) empty-instruction-sequence
(append-seq-list (cdr seqs))))) (append-2-sequences (car seqs)
(append-seq-list seqs)) (append-seq-list (cdr seqs)))))
(define (list-union s1 s2) (define (list-union s1 s2)
(cond [(null? s1) s2] (cond [(null? s1) s2]
@ -474,7 +480,7 @@
(define (test source-code) #;(define (test source-code)
(let ([basic-blocks (let ([basic-blocks
(fracture (statements (compile source-code (fracture (statements (compile source-code
'() '()

43
typed-structs.rkt
View File

@ -3,17 +3,42 @@
(define-type Expression (U Constant Quote Var Assign Branch Def Lam Seq App)) (define-type Expression (U Constant Quote Var Assign Branch Def Lam Seq App))
(define-struct: Constant ([v : Any]) #:transparent) (define-struct: Constant ([v : Any]) #:transparent)
(define-struct: Quote ([v : Any]) #:transparent) (define-struct: Quote ([text : Any]) #:transparent)
(define-struct: Var ([id : Symbol]) #:transparent) (define-struct: Var ([id : Symbol]) #:transparent)
(define-struct: Assign ([id : Symbol] (define-struct: Assign ([variable : Symbol]
[expr : Expression]) #:transparent) [value : Expression]) #:transparent)
(define-struct: Branch ([test : Expression] (define-struct: Branch ([predicate : Expression]
[consequent : Expression] [consequent : Expression]
[alternative : Expression]) #:transparent) [alternative : Expression]) #:transparent)
(define-struct: Def ([id : Symbol] (define-struct: Def ([variable : Symbol]
[expr : Expression]) #:transparent) [value : Expression]) #:transparent)
(define-struct: Lam ([ids : (Listof Symbol)] (define-struct: Lam ([parameters : (Listof Symbol)]
[body : Expression]) #:transparent) [body : (Listof Expression)]) #:transparent)
(define-struct: Seq ([es : (Listof Expression)]) #:transparent) (define-struct: Seq ([actions : (Listof Expression)]) #:transparent)
(define-struct: App ([op : Expression] (define-struct: App ([op : Expression]
[rands : (Listof Expression)]) #:transparent) [rands : (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-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)))))