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

commit

Browse Source
This commit is contained in:
Danny Yoo 2011-02-21 14:49:54 -05:00
parent 940b4882f2
commit 9bed9d2ee1
2 changed files with 38 additions and 81 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

87
assemble.rkt
View File

@ -80,6 +80,7 @@
;; collects all the labels that are potential targets for GOTOs or branches.
(: collect-general-jump-targets ((Listof Statement) -> (Listof Symbol)))
(define (collect-general-jump-targets stmts)
(: collect-input (OpArg -> (Listof Symbol)))
(define (collect-input an-input)
(cond
[(Reg? an-input)
@ -87,15 +88,16 @@
[(Const? an-input)
empty]
[(Label? an-input)
(list (Label-name an-input))]
[else (error 'collect-input "~e" an-input)]))
(list (Label-name an-input))]))
(: collect-location ((U Reg Label) -> (Listof Symbol)))
(define (collect-location a-location)
(cond
[(Reg? a-location)
empty]
[(Label? a-location)
(list (Label-name a-location))]
[else (error 'collect-location "~e" a-location)]))
(list (Label-name a-location))]))
(unique
(let loop ([stmts stmts])
(cond [(empty? stmts)
@ -132,71 +134,6 @@
;; collect-indirect-jump-targets: (listof stmt) -> (listof label)
;; collects the labels that are potential targets for GOTOs or branches from
;; indirect jumps.
;; The only interesting case should be where there's a register assignment
;; whose value is a label.
#;(: collect-indirect-jump-targets ((Listof Statement) -> (Listof Symbol)))
#;(define (collect-indirect-jump-targets stmts)
(define (collect-input an-input)
(cond
[(reg? an-input)
empty]
[(const? an-input)
empty]
[(label? an-input)
empty]
[else (error 'collect-input "~e" an-input)]))
(define (collect-location a-location)
(cond
[(reg? a-location)
empty]
[(label? a-location)
empty]
[else
(error 'collect-location "~e" a-location)]))
(unique
(let loop ([stmts stmts])
(cond [(empty? stmts)
empty]
[else
(let ([stmt (first stmts)])
(append (cond
[(symbol? stmt)
empty]
[(tagged-list? stmt 'assign)
(cond
[(reg? (caddr stmt))
empty]
[(label? (caddr stmt))
;; Watch assignments of labels into registers.
(list (label-name (caddr stmt)))]
[(const? (caddr stmt))
empty]
[(op? (caddr stmt))
empty]
[else
(error 'assemble "~a" stmt)])]
[(tagged-list? stmt 'perform)
empty]
[(tagged-list? stmt 'test)
empty]
[(tagged-list? stmt 'branch)
empty]
[(tagged-list? stmt 'goto)
empty]
[(tagged-list? stmt 'save)
empty]
[(tagged-list? stmt 'restore)
empty]
[else
(error 'assemble "~a" stmt)])
(loop (rest stmts))))]))))
;; assemble-basic-block: basic-block -> string
(: assemble-basic-block (BasicBlock -> String))
@ -267,7 +204,7 @@
[else
(format "~s" val)])))
(: assemble-op-expression (Symbol (Listof OpArg) -> String))
(: assemble-op-expression ((U PrimitiveOperator TestOperator) (Listof OpArg) -> String))
(define (assemble-op-expression op-name inputs)
(let ([assembled-inputs (map assemble-input inputs)])
(case op-name
@ -315,11 +252,9 @@
[(lookup-variable-value)
(format "((~a).globalBindings[~a])"
(second assembled-inputs)
(first assembled-inputs))]
[else
(error 'assemble "~e" op-name)])))
(first assembled-inputs))])))
(: assemble-op-statement (Symbol (Listof OpArg) -> String))
(: assemble-op-statement (PerformOperator (Listof OpArg) -> String))
(define (assemble-op-statement op-name inputs)
(let ([assembled-inputs (map assemble-input inputs)])
(case op-name
@ -343,9 +278,7 @@
(format "if (! (~a).globalBindings.hasOwnProperty(~a)) { throw new Error(\"Not bound: \" + ~a); }"
(second assembled-inputs)
(first assembled-inputs)
(first assembled-inputs))]
[else
(error 'assemble-op-statement "~a" op-name)])))
(first assembled-inputs))])))

32
typed-structs.rkt
View File

@ -1,6 +1,9 @@
#lang typed/racket/base
(provide (all-defined-out))
;; Expressions
(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)
@ -29,7 +32,7 @@
(define (rest-exps seq) (cdr seq))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; instruction sequences
(define-type UnlabeledStatement (U
@ -48,12 +51,12 @@
[value : (U Const Reg Label)])
#:transparent)
(define-struct: AssignPrimOpStatement ([target : Symbol]
[op : Symbol]
[op : PrimitiveOperator]
[rands : (Listof (U Label Reg Const))])
#:transparent)
(define-struct: PerformStatement ([op : Symbol]
(define-struct: PerformStatement ([op : PerformOperator]
[rands : (Listof (U Label Reg Const))]) #:transparent)
(define-struct: TestStatement ([op : (U 'false? 'primitive-procedure?)]
(define-struct: TestStatement ([op : TestOperator]
[register-rand : Symbol]) #:transparent)
(define-struct: BranchLabelStatement ([label : Symbol]) #:transparent)
(define-struct: GotoStatement ([target : (U Label Reg)]) #:transparent)
@ -67,6 +70,22 @@
(define-type OpArg (U Const Label Reg))
(define-type PrimitiveOperator (U 'compiled-procedure-entry
'compiled-procedure-env
'make-compiled-procedure
'false?
'cons
'list
'apply-primitive-procedure
'lexical-address-lookup
'extend-environment
'lookup-variable-value))
(define-type TestOperator (U 'false? 'primitive-procedure?))
(define-type PerformOperator (U 'define-variable!
'set-variable-value!
'lexical-address-set!
'check-bound-global!))
@ -106,5 +125,10 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Assembly
(define-struct: BasicBlock ([name : Symbol]
[stmts : (Listof UnlabeledStatement)]) #:transparent)