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

uncommented most of the code; need to work on application

Browse Source
This commit is contained in:
Danny Yoo 2011-03-01 02:26:26 -05:00
parent 1c64447e08
commit 4f90538722
3 changed files with 87 additions and 86 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

107
compile.rkt
View File

@ -9,12 +9,9 @@
(provide compile-top) (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) (define (compile-top exp target linkage)
(let*: ([names : (Listof Symbol) (find-toplevel-variables exp)] (let*: ([names : (Listof Symbol) (find-toplevel-variables exp)]
[cenv : CompileTimeEnvironment (list (make-Prefix names))]) [cenv : CompileTimeEnvironment (list (make-Prefix names))])
@ -28,24 +25,22 @@
;; compile: expression target linkage -> instruction-sequence ;; compile: expression target linkage -> instruction-sequence
(: compile (Expression CompileTimeEnvironment Target Linkage -> InstructionSequence)) (: compile (ExpressionCore CompileTimeEnvironment Target Linkage -> InstructionSequence))
(define (compile exp cenv target linkage) (define (compile exp cenv target linkage)
(cond (cond
[(Constant? exp) [(Constant? exp)
(compile-self-evaluating exp cenv target linkage)] (compile-constant exp cenv target linkage)]
#;[(Quote? exp) [(Quote? exp)
(compile-quoted exp cenv target linkage)] (compile-quoted exp cenv target linkage)]
#;[(Var? exp) [(Var? exp)
(compile-variable exp cenv target linkage)] (compile-variable exp cenv target linkage)]
#;[(Assign? exp) [(Def? exp)
(compile-assignment exp cenv target linkage)]
#;[(Def? exp)
(compile-definition exp cenv target linkage)] (compile-definition exp cenv target linkage)]
#;[(Branch? exp) [(Branch? exp)
(compile-if exp cenv target linkage)] (compile-branch exp cenv target linkage)]
#;[(Lam? exp) #;[(Lam? exp)
(compile-lambda exp cenv target linkage)] (compile-lambda exp cenv target linkage)]
#;[(Seq? exp) [(Seq? exp)
(compile-sequence (Seq-actions exp) (compile-sequence (Seq-actions exp)
cenv cenv
target target
@ -55,39 +50,48 @@
(: compile-linkage (Linkage -> InstructionSequence)) (: compile-linkage (CompileTimeEnvironment Linkage -> InstructionSequence))
(define (compile-linkage linkage) (define (compile-linkage cenv linkage)
(cond (cond
#;[(eq? linkage 'return) [(eq? linkage 'return)
(make-instruction-sequence `(,(make-GotoStatement (make-ControlOffset 0))))] (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) [(eq? linkage 'next)
empty-instruction-sequence] empty-instruction-sequence]
[else [(symbol? linkage)
(make-instruction-sequence `(,(make-GotoStatement (make-Label linkage))))])) (make-instruction-sequence `(,(make-GotoStatement (make-Label linkage))))]))
(: end-with-linkage (Linkage InstructionSequence -> InstructionSequence)) (: end-with-linkage (Linkage CompileTimeEnvironment InstructionSequence ->
(define (end-with-linkage linkage instruction-sequence) InstructionSequence))
(define (end-with-linkage linkage cenv instruction-sequence)
(append-instruction-sequences instruction-sequence (append-instruction-sequences instruction-sequence
(compile-linkage linkage))) (compile-linkage cenv linkage)))
(: compile-self-evaluating (Constant CompileTimeEnvironment Target Linkage -> InstructionSequence)) (: compile-constant (Constant CompileTimeEnvironment Target Linkage -> InstructionSequence))
(define (compile-self-evaluating exp cenv target linkage) (define (compile-constant exp cenv target linkage)
(end-with-linkage linkage (end-with-linkage linkage
cenv
(make-instruction-sequence (make-instruction-sequence
`(,(make-AssignImmediateStatement target (make-Const (Constant-v exp))))))) `(,(make-AssignImmediateStatement target (make-Const (Constant-v exp)))))))
#;(: compile-quoted (Quote CompileTimeEnvironment Target Linkage -> InstructionSequence)) (: compile-quoted (Quote CompileTimeEnvironment Target Linkage -> InstructionSequence))
#;(define (compile-quoted exp cenv target linkage) (define (compile-quoted exp cenv target linkage)
(end-with-linkage linkage (end-with-linkage linkage
cenv
(make-instruction-sequence (make-instruction-sequence
`(,(make-AssignImmediateStatement target (make-Const (Quote-text exp))))))) `(,(make-AssignImmediateStatement target (make-Const (Quote-text exp)))))))
#;(: compile-variable (Var CompileTimeEnvironment Target Linkage -> InstructionSequence)) (: compile-variable (Var CompileTimeEnvironment Target Linkage -> InstructionSequence))
#;(define (compile-variable exp cenv target linkage) (define (compile-variable exp cenv target linkage)
(let ([lexical-pos (find-variable (Var-id exp) cenv)]) (let ([lexical-pos (find-variable (Var-id exp) cenv)])
(cond (cond
[(LocalAddress? lexical-pos) [(LocalAddress? lexical-pos)
(end-with-linkage linkage (end-with-linkage linkage
cenv
(make-instruction-sequence (make-instruction-sequence
`(,(make-AssignPrimOpStatement target `(,(make-AssignPrimOpStatement target
'lexical-address-lookup 'lexical-address-lookup
@ -96,6 +100,7 @@
(make-Reg 'env))))))] (make-Reg 'env))))))]
[(PrefixAddress? lexical-pos) [(PrefixAddress? lexical-pos)
(end-with-linkage linkage (end-with-linkage linkage
cenv
(make-instruction-sequence (make-instruction-sequence
`(,(make-PerformStatement 'check-bound! `(,(make-PerformStatement 'check-bound!
(list (make-Const (PrefixAddress-depth lexical-pos)) (list (make-Const (PrefixAddress-depth lexical-pos))
@ -110,41 +115,8 @@
(make-Reg 'env))))))]))) (make-Reg 'env))))))])))
#;(: compile-assignment (Assign CompileTimeEnvironment Target Linkage -> InstructionSequence)) (: compile-definition (Def CompileTimeEnvironment Target Linkage -> InstructionSequence))
#;(define (compile-assignment exp cenv target linkage) (define (compile-definition 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)
(let* ([var (Def-variable exp)] (let* ([var (Def-variable exp)]
[lexical-pos (find-variable var cenv)] [lexical-pos (find-variable var cenv)]
[get-value-code [get-value-code
@ -155,6 +127,7 @@
[(PrefixAddress? lexical-pos) [(PrefixAddress? lexical-pos)
(end-with-linkage (end-with-linkage
linkage linkage
cenv
(append-instruction-sequences (append-instruction-sequences
get-value-code get-value-code
(make-instruction-sequence `(,(make-PerformStatement 'toplevel-set! (make-instruction-sequence `(,(make-PerformStatement 'toplevel-set!
@ -166,8 +139,8 @@
,(make-AssignImmediateStatement target (make-Const 'ok))))))]))) ,(make-AssignImmediateStatement target (make-Const 'ok))))))])))
#;(: compile-if (Branch CompileTimeEnvironment Target Linkage -> InstructionSequence)) (: compile-branch (Branch CompileTimeEnvironment Target Linkage -> InstructionSequence))
#;(define (compile-if exp cenv target linkage) (define (compile-branch exp cenv target linkage)
(let ([t-branch (make-label 'trueBranch)] (let ([t-branch (make-label 'trueBranch)]
[f-branch (make-label 'falseBranch)] [f-branch (make-label 'falseBranch)]
[after-if (make-label 'afterIf)]) [after-if (make-label 'afterIf)])
@ -189,8 +162,8 @@
after-if)))))) after-if))))))
#;(: compile-sequence ((Listof Expression) CompileTimeEnvironment Target Linkage -> InstructionSequence)) (: compile-sequence ((Listof Expression) CompileTimeEnvironment Target Linkage -> InstructionSequence))
#;(define (compile-sequence seq cenv target linkage) (define (compile-sequence seq cenv target linkage)
(if (last-exp? seq) (if (last-exp? seq)
(compile (first-exp seq) cenv target linkage) (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)

12
lexical-env.rkt
View File

@ -2,7 +2,7 @@
(require racket/list (require racket/list
"typed-structs.rkt") "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 ;; find-variable: symbol compile-time-environment -> lexical-address
@ -36,3 +36,13 @@
(: extend-lexical-environment (CompileTimeEnvironment (Listof Symbol) -> CompileTimeEnvironment)) (: extend-lexical-environment (CompileTimeEnvironment (Listof Symbol) -> CompileTimeEnvironment))
(define (extend-lexical-environment cenv names) (define (extend-lexical-environment cenv names)
(cons names cenv)) (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]))

52
typed-structs.rkt
View File

@ -4,7 +4,7 @@
;; Expressions ;; 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-type Expression (U ExpressionCore #;Assign))
(define-struct: Constant ([v : Any]) #:transparent) (define-struct: Constant ([v : Any]) #:transparent)
(define-struct: Quote ([text : Any]) #:transparent) (define-struct: Quote ([text : Any]) #:transparent)
@ -33,8 +33,11 @@
(define (rest-exps seq) (cdr seq)) (define (rest-exps seq) (cdr seq))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-type StackRegisterSymbol (U 'control 'env)) (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 (define-type UnlabeledStatement (U
AssignImmediateStatement AssignImmediateStatement
AssignPrimOpStatement AssignPrimOpStatement
GotoStatement
PerformStatement PerformStatement
TestStatement TestStatement
BranchLabelStatement BranchLabelStatement
GotoStatement PopEnv
PopControl
#;SaveStatement #;SaveStatement
#;RestoreStatement)) #;RestoreStatement))
(define-type Statement (U UnlabeledStatement (define-type Statement (U UnlabeledStatement
Symbol ;; label Symbol ;; label
)) ))
(define-struct: AssignImmediateStatement ([target : Target] (define-struct: AssignImmediateStatement ([target : Target]
[value : (U Const Reg Label)]) [value : OpArg])
#:transparent) #:transparent)
(define-struct: AssignPrimOpStatement ([target : Target] (define-struct: AssignPrimOpStatement ([target : Target]
[op : PrimitiveOperator] [op : PrimitiveOperator]
[rands : (Listof (U Label Reg Const))]) [rands : (Listof OpArg)])
#:transparent) #: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]) (define-struct: Label ([name : Symbol])
#:transparent) #:transparent)
@ -75,7 +73,25 @@
(define-struct: Const ([const : Any]) (define-struct: Const ([const : Any])
#:transparent) #: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 (define-type PrimitiveOperator (U 'compiled-procedure-entry
@ -90,6 +106,8 @@
'lexical-address-lookup 'lexical-address-lookup
'toplevel-lookup 'toplevel-lookup
'read-control-label
'extend-environment 'extend-environment
'extend-environment/prefix)) 'extend-environment/prefix))
@ -122,13 +140,13 @@
;; Targets ;; Targets
(define-type Target (U RegisterSymbol ControlOffset EnvOffset)) (define-type Target (U RegisterSymbol ControlTarget EnvOffset))
(define-struct: ControlOffset ([depth : Natural])) (define-struct: ControlTarget ())
(define-struct: EnvOffset ([depth : Natural] (define-struct: EnvOffset ([depth : Natural]
[pos : Natural])) [pos : Natural]))
;; Linkage ;; Linkage
(define-type Linkage (U #; 'return (define-type Linkage (U 'return
'next 'next
Symbol)) Symbol))