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

Merge remote branch 'origin/master'

Browse Source
This commit is contained in:
Danny Yoo 2011-02-20 23:22:26 -05:00
commit 79074ccecb
3 changed files with 246 additions and 187 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

228
assemble.rkt
View File

@ -1,5 +1,5 @@
#lang racket/base #lang typed/racket/base
(require "structs.rkt" (require "typed-structs.rkt"
racket/string racket/string
racket/list) racket/list)
@ -7,43 +7,46 @@
;; assemble/write-invoke: (listof statement) output-port -> void ;; assemble/write-invoke: (listof statement) output-port -> void
(: assemble/write-invoke ((Listof Statement) Output-Port -> Void))
(define (assemble/write-invoke stmts op) (define (assemble/write-invoke stmts op)
(let ([basic-blocks (fracture stmts)]) (let ([basic-blocks (fracture stmts)])
(fprintf op "function(k) {\n") (fprintf op "function(k) {\n")
(for-each (lambda (basic-block) (for-each (lambda: ([basic-block : BasicBlock])
(displayln (assemble-basic-block basic-block) op) (displayln (assemble-basic-block basic-block) op)
(newline op)) (newline op))
basic-blocks) basic-blocks)
(fprintf op "MACHINE.cont = k;\n") (fprintf op "MACHINE.cont = k;\n")
(fprintf op "trampoline(~a, function() {}); }" (fprintf op "trampoline(~a, function() {}); }"
(basic-block-name (first basic-blocks))))) (BasicBlock-name (first basic-blocks)))))
;; fracture: (listof stmt) -> (listof basic-block) ;; fracture: (listof stmt) -> (listof basic-block)
(: fracture ((Listof Statement) -> (Listof BasicBlock)))
(define (fracture stmts) (define (fracture stmts)
(let* ([first-block-label (make-label 'start)] (let* ([first-block-label (make-label 'start)]
[jump-targets [jump-targets
(cons first-block-label (collect-general-jump-targets stmts))]) (cons first-block-label (collect-general-jump-targets stmts))])
(let loop ([name first-block-label] (let: loop : (Listof BasicBlock)
[acc '()] ([name : Symbol first-block-label]
[basic-blocks '()] [acc : (Listof UnlabeledStatement) '()]
[stmts stmts] [basic-blocks : (Listof BasicBlock) '()]
[last-stmt-goto? #f]) [stmts : (Listof Statement) stmts]
[last-stmt-goto? : Boolean #f])
(cond (cond
[(null? stmts) [(null? stmts)
(reverse (cons (make-basic-block name (reverse acc)) (reverse (cons (make-BasicBlock name (reverse acc))
basic-blocks))] basic-blocks))]
[(symbol? (car stmts)) [(symbol? (car stmts))
(cond (cond
[(member (car stmts) jump-targets) [(member (car stmts) jump-targets)
(loop (car stmts) (loop (car stmts)
'() '()
(cons (make-basic-block name (cons (make-BasicBlock name
(if last-stmt-goto? (if last-stmt-goto?
(reverse acc) (reverse acc)
(reverse (append `((goto (label ,(car stmts)))) (reverse (append `(,(make-GotoStatement (make-Label (car stmts))))
acc)))) acc))))
basic-blocks) basic-blocks)
(cdr stmts) (cdr stmts)
@ -59,37 +62,39 @@
(cons (car stmts) acc) (cons (car stmts) acc)
basic-blocks basic-blocks
(cdr stmts) (cdr stmts)
(tagged-list? (car stmts) 'goto))])))) (GotoStatement? (car stmts)))]))))
;; unique: (listof symbol -> listof symbol) ;; unique: (listof symbol -> listof symbol)
(: unique ((Listof Symbol) -> (Listof Symbol)))
(define (unique los) (define (unique los)
(let ([ht (make-hasheq)]) (let: ([ht : (HashTable Symbol Boolean) (make-hasheq)])
(for ([l los]) (for ([l los])
(hash-set! ht l #t)) (hash-set! ht l #t))
(for/list ([k (in-hash-keys ht)]) (hash-map ht (lambda: ([k : Symbol] [v : Boolean]) k))))
k)))
;; collect-general-jump-targets: (listof stmt) -> (listof label) ;; collect-general-jump-targets: (listof stmt) -> (listof label)
;; collects all the labels that are potential targets for GOTOs or branches. ;; 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) (define (collect-general-jump-targets stmts)
(define (collect-input an-input) (define (collect-input an-input)
(cond (cond
[(reg? an-input) [(Reg? an-input)
empty] empty]
[(const? an-input) [(Const? an-input)
empty] empty]
[(label? an-input) [(Label? an-input)
(list (label-name an-input))] (list (Label-name an-input))]
[else (error 'collect-input "~e" an-input)])) [else (error 'collect-input "~e" an-input)]))
(define (collect-location a-location) (define (collect-location a-location)
(cond (cond
[(reg? a-location) [(Reg? a-location)
empty] empty]
[(label? a-location) [(Label? a-location)
(list (label-name a-location))] (list (Label-name a-location))]
[else (error 'collect-location "~e" a-location)])) [else (error 'collect-location "~e" a-location)]))
(unique (unique
(let loop ([stmts stmts]) (let loop ([stmts stmts])
@ -100,32 +105,29 @@
(append (cond (append (cond
[(symbol? stmt) [(symbol? stmt)
empty] empty]
[(tagged-list? stmt 'assign) [(AssignImmediateStatement? stmt)
(cond (let ([v (AssignImmediateStatement-value stmt)])
[(reg? (caddr stmt)) (cond
empty] [(Reg? v)
[(label? (caddr stmt)) empty]
(list (label-name (caddr stmt)))] [(Label? v)
[(const? (caddr stmt)) (list (Label-name v))]
empty] [(Const? v)
[(op? (caddr stmt)) empty]))]
(apply append (map collect-input (cdddr stmt)))] [(AssignPrimOpStatement? stmt)
[else (apply append (map collect-input (AssignPrimOpStatement-rands stmt)))]
(error 'assemble "~a" stmt)])] [(PerformStatement? stmt)
[(tagged-list? stmt 'perform) (apply append (map collect-input (PerformStatement-rands stmt)))]
(apply append (map collect-input (cddr stmt)))] [(TestStatement? stmt)
[(tagged-list? stmt 'test)
(apply append (map collect-input (cddr stmt)))]
[(tagged-list? stmt 'branch)
(collect-location (cadr stmt))]
[(tagged-list? stmt 'goto)
(collect-location (cadr stmt))]
[(tagged-list? stmt 'save)
empty] empty]
[(tagged-list? stmt 'restore) [(BranchLabelStatement? stmt)
(list (BranchLabelStatement-label stmt))]
[(GotoStatement? stmt)
(collect-location (GotoStatement-target stmt))]
[(SaveStatement? stmt)
empty] empty]
[else [(RestoreStatement? stmt)
(error 'assemble "~a" stmt)]) empty])
(loop (rest stmts))))])))) (loop (rest stmts))))]))))
@ -135,7 +137,8 @@
;; indirect jumps. ;; indirect jumps.
;; The only interesting case should be where there's a register assignment ;; The only interesting case should be where there's a register assignment
;; whose value is a label. ;; whose value is a label.
(define (collect-indirect-jump-targets stmts) #;(: collect-indirect-jump-targets ((Listof Statement) -> (Listof Symbol)))
#;(define (collect-indirect-jump-targets stmts)
(define (collect-input an-input) (define (collect-input an-input)
(cond (cond
[(reg? an-input) [(reg? an-input)
@ -196,70 +199,75 @@
;; assemble-basic-block: basic-block -> string ;; assemble-basic-block: basic-block -> string
(: assemble-basic-block (BasicBlock -> String))
(define (assemble-basic-block a-basic-block) (define (assemble-basic-block a-basic-block)
(format "var ~a=function(){\nif(--MACHINE.callsBeforeTrampoline < 0) { throw ~a; }\n~a};" (format "var ~a=function(){\nif(--MACHINE.callsBeforeTrampoline < 0) { throw ~a; }\n~a};"
(basic-block-name a-basic-block) (BasicBlock-name a-basic-block)
(basic-block-name a-basic-block) (BasicBlock-name a-basic-block)
(string-join (map assemble-stmt (basic-block-stmts a-basic-block)) (string-join (map assemble-stmt (BasicBlock-stmts a-basic-block))
"\n"))) "\n")))
;; assemble-stmt: stmt -> string ;; assemble-stmt: stmt -> string
(: assemble-stmt (UnlabeledStatement -> String))
(define (assemble-stmt stmt) (define (assemble-stmt stmt)
(cond (cond
[(tagged-list? stmt 'assign) [(AssignImmediateStatement? stmt)
(cond (let ([v (AssignImmediateStatement-value stmt)])
[(reg? (caddr stmt)) (cond
(format "MACHINE.~a=~a" [(Reg? v)
(cadr stmt) (format "MACHINE.~a=~a"
(assemble-reg (caddr stmt)))] (AssignImmediateStatement-target stmt)
[(label? (caddr stmt)) (assemble-reg v))]
(format "MACHINE.~a=~a;" (cadr stmt) [(Label? v)
(assemble-label (caddr stmt)))] (format "MACHINE.~a=~a;"
[(const? (caddr stmt)) (AssignImmediateStatement-target stmt)
(format "MACHINE.~a=~a;" (assemble-label v))]
(cadr stmt) [(Const? v)
(assemble-const (caddr stmt)))] (format "MACHINE.~a=~a;"
[(op? (caddr stmt)) (AssignImmediateStatement-target stmt)
(format "MACHINE.~a=~a;" (assemble-const v))]))]
(cadr stmt)
(assemble-op-expression (op-name (caddr stmt)) [(AssignPrimOpStatement? stmt)
(cdddr stmt)))] (format "MACHINE.~a=~a;"
[else (AssignPrimOpStatement-target stmt)
(error 'assemble "~a" stmt)])] (assemble-op-expression (AssignPrimOpStatement-op stmt)
[(tagged-list? stmt 'perform) (AssignPrimOpStatement-rands stmt)))]
(assemble-op-statement (op-name (cadr stmt)) [(PerformStatement? stmt)
(cddr stmt))] (assemble-op-statement (PerformStatement-op stmt)
[(tagged-list? stmt 'test) (PerformStatement-rands stmt))]
[(TestStatement? stmt)
(format "if(~a){" (format "if(~a){"
(assemble-op-expression (op-name (cadr stmt)) (assemble-op-expression (TestStatement-op stmt)
(cddr stmt)))] (list (make-Reg (TestStatement-register-rand stmt)))))]
[(tagged-list? stmt 'branch) [(BranchLabelStatement? stmt)
;; the unbalanced } is deliberate: test and branch always follow each other. ;; the unbalanced } is deliberate: test and branch always follow each other.
(format "return ~a();}" (format "return ~a();}"
(assemble-location (cadr stmt)))] (assemble-location (make-Label (BranchLabelStatement-label stmt))))]
[(tagged-list? stmt 'goto) [(GotoStatement? stmt)
(format "return ~a();" (format "return ~a();"
(assemble-location (cadr stmt)))] (assemble-location (GotoStatement-target stmt)))]
[(tagged-list? stmt 'save) [(SaveStatement? stmt)
(format "MACHINE.stack.push(MACHINE.~a);" (format "MACHINE.stack.push(MACHINE.~a);"
(cadr stmt))] (SaveStatement-reg stmt))]
[(tagged-list? stmt 'restore) [(RestoreStatement? stmt)
(format "MACHINE.~a=MACHINE.stack.pop();" (format "MACHINE.~a=MACHINE.stack.pop();"
(cadr stmt))] (RestoreStatement-reg stmt))]))
[else (error 'assemble "~a" stmt)]))
;; fixme: use js->string ;; fixme: use js->string
(: assemble-const (Const -> String))
(define (assemble-const stmt) (define (assemble-const stmt)
(let loop ([val (cadr stmt)]) (let: loop : String ([val : Any (Const-const stmt)])
(cond [(symbol? val) (cond [(symbol? val)
(format "~s" (symbol->string val))] (format "~s" (symbol->string val))]
[(list? val) [(list? val)
(format "_list(~a)" (string-join (map loop val) (format "_list(~a)" (string-join (map loop val)
","))] ","))]
[else [else
(format "~s" val)]))) (format "~s" val)])))
(: assemble-op-expression (Symbol (Listof OpArg) -> String))
(define (assemble-op-expression op-name inputs) (define (assemble-op-expression op-name inputs)
(let ([assembled-inputs (map assemble-input inputs)]) (let ([assembled-inputs (map assemble-input inputs)])
(case op-name (case op-name
@ -280,7 +288,7 @@
(cond [(empty? inputs) (cond [(empty? inputs)
"undefined"] "undefined"]
[else [else
(let loop ([assembled-inputs assembled-inputs]) (let: loop : String ([assembled-inputs : (Listof String) assembled-inputs])
(cond (cond
[(empty? assembled-inputs) [(empty? assembled-inputs)
"undefined"] "undefined"]
@ -311,7 +319,7 @@
[else [else
(error 'assemble "~e" op-name)]))) (error 'assemble "~e" op-name)])))
(: assemble-op-statement (Symbol (Listof OpArg) -> String))
(define (assemble-op-statement op-name inputs) (define (assemble-op-statement op-name inputs)
(let ([assembled-inputs (map assemble-input inputs)]) (let ([assembled-inputs (map assemble-input inputs)])
(case op-name (case op-name
@ -341,28 +349,28 @@
(: assemble-input ((U Reg Const Label) -> String))
(define (assemble-input an-input) (define (assemble-input an-input)
(cond (cond
[(reg? an-input) [(Reg? an-input)
(assemble-reg an-input)] (assemble-reg an-input)]
[(const? an-input) [(Const? an-input)
(assemble-const an-input)] (assemble-const an-input)]
[(label? an-input) [(Label? an-input)
(assemble-label an-input)] (assemble-label an-input)]))
[else (error 'assemble-input "~e" an-input)]))
(: assemble-location ((U Reg Label) -> String))
(define (assemble-location a-location) (define (assemble-location a-location)
(cond (cond
[(reg? a-location) [(Reg? a-location)
(assemble-reg a-location)] (assemble-reg a-location)]
[(label? a-location) [(Label? a-location)
(assemble-label a-location)] (assemble-label a-location)]))
[else (error 'assemble-location "~e" a-location)]))
(: assemble-reg (Reg -> String))
(define (assemble-reg a-reg) (define (assemble-reg a-reg)
(string-append "MACHINE." (symbol->string (cadr a-reg)))) (string-append "MACHINE." (symbol->string (Reg-name a-reg))))
(: assemble-label (Label -> String))
(define (assemble-label a-label) (define (assemble-label a-label)
(symbol->string (label-name a-label))) (symbol->string (Label-name a-label)))

155
cm.rkt → compile.rkt
View File

@ -1,7 +1,6 @@
#lang typed/racket/base #lang typed/racket/base
(require "typed-structs.rkt" (require "typed-structs.rkt"
#;"assemble.rkt"
racket/list) racket/list)
(provide compile) (provide compile)
@ -19,6 +18,8 @@
(define-type CompileTimeEnvironment (Listof (Listof Symbol))) (define-type CompileTimeEnvironment (Listof (Listof Symbol)))
(define-type LexicalAddress (U (List Number Number) 'not-found)) (define-type LexicalAddress (U (List Number Number) 'not-found))
;; 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)) (: find-variable (Symbol CompileTimeEnvironment -> LexicalAddress))
@ -80,12 +81,12 @@
(define (compile-linkage linkage) (define (compile-linkage linkage)
(cond (cond
[(eq? linkage 'return) [(eq? linkage 'return)
(make-instruction-sequence '(cont) '() '((goto (reg cont))))] (make-instruction-sequence '(cont) '() `(,(make-GotoStatement (make-Reg 'cont))))]
[(eq? linkage 'next) [(eq? linkage 'next)
empty-instruction-sequence] empty-instruction-sequence]
[else [else
(make-instruction-sequence '() '() (make-instruction-sequence '() '()
`((goto (label ,linkage))))])) `(,(make-GotoStatement (make-Label linkage))))]))
(: end-with-linkage (Linkage InstructionSequence -> InstructionSequence)) (: end-with-linkage (Linkage InstructionSequence -> InstructionSequence))
(define (end-with-linkage linkage instruction-sequence) (define (end-with-linkage linkage instruction-sequence)
@ -99,7 +100,7 @@
(make-instruction-sequence (make-instruction-sequence
'() '()
(list target) (list target)
`((assign ,target (const ,exp)))))) `(,(make-AssignImmediateStatement target (make-Const 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)
@ -107,7 +108,7 @@
(make-instruction-sequence (make-instruction-sequence
'() '()
(list target) (list target)
`((assign ,target (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)
@ -120,23 +121,23 @@
(list target) (list target)
;; Slight modification: explicitly testing for ;; Slight modification: explicitly testing for
;; global variable binding before lookup. ;; global variable binding before lookup.
`((perform (op check-bound-global!) `(,(make-PerformStatement 'check-bound-global!
(const ,(Var-id exp)) (list (make-Const (Var-id exp))
(reg env)) (make-Reg 'env)))
(assign ,target ,(make-AssignPrimOpStatement target
(op lookup-variable-value) 'lookup-variable-value
(const ,(Var-id exp)) (list (make-Const (Var-id exp))
(reg env)))))] (make-Reg 'env))))))]
[else [else
(end-with-linkage linkage (end-with-linkage linkage
(make-instruction-sequence (make-instruction-sequence
'(env) '(env)
(list target) (list target)
`((assign ,target `(,(make-AssignPrimOpStatement target
(op lexical-address-lookup) 'lexical-address-lookup
(const ,(first lexical-pos)) (list (make-Const (first lexical-pos))
(const ,(second lexical-pos)) (make-Const (second lexical-pos))
(reg env)))))]))) (make-Reg 'env))))))])))
(: compile-assignment (Assign CompileTimeEnvironment Target Linkage -> InstructionSequence)) (: compile-assignment (Assign CompileTimeEnvironment Target Linkage -> InstructionSequence))
@ -155,11 +156,11 @@
(make-instruction-sequence (make-instruction-sequence
'(env val) '(env val)
(list target) (list target)
`((perform (op set-variable-value!) `(,(make-PerformStatement 'set-variable-value!
(const ,var) (list (make-Const var)
(reg val) (make-Reg 'val)
(reg env)) (make-Reg 'env)))
(assign ,target (const ok))))))] ,(make-AssignImmediateStatement target (make-Const 'ok))))))]
[else [else
(end-with-linkage (end-with-linkage
linkage linkage
@ -168,12 +169,12 @@
(make-instruction-sequence (make-instruction-sequence
'(env val) '(env val)
(list target) (list target)
`((perform (op lexical-address-set!) `(,(make-PerformStatement 'lexical-address-set!
(const ,(first lexical-address)) (list (make-Const (first lexical-address))
(const ,(second lexical-address)) (make-Const (second lexical-address))
(reg env) (make-Reg 'env)
(reg val)) (make-Reg 'val)))
(assign ,target (const ok))))))]))) ,(make-AssignImmediateStatement target (make-Const 'ok))))))])))
;; FIXME: exercise 5.43 ;; FIXME: exercise 5.43
@ -190,11 +191,11 @@
(make-instruction-sequence (make-instruction-sequence
'(env val) '(env val)
(list target) (list target)
`((perform (op define-variable!) `(,(make-PerformStatement 'define-variable!
(const ,var) (list (make-Const var)
(reg val) (make-Reg 'val)
(reg env)) (make-Reg 'env)))
(assign ,target (const ok)))))))) ,(make-AssignImmediateStatement target (make-Const 'ok))))))))
(: compile-if (Branch CompileTimeEnvironment Target Linkage -> InstructionSequence)) (: compile-if (Branch CompileTimeEnvironment Target Linkage -> InstructionSequence))
@ -215,8 +216,8 @@
(make-instruction-sequence (make-instruction-sequence
'(val) '(val)
'() '()
`((test (op false?) (reg val)) `(,(make-TestStatement 'false? 'val)
(branch (label ,f-branch)))) ,(make-BranchLabelStatement f-branch)))
(parallel-instruction-sequences (parallel-instruction-sequences
(append-instruction-sequences t-branch c-code) (append-instruction-sequences t-branch c-code)
(append-instruction-sequences f-branch a-code)) (append-instruction-sequences f-branch a-code))
@ -246,16 +247,16 @@
(make-instruction-sequence (make-instruction-sequence
'(env) '(env)
(list target) (list target)
`((assign ,target `(,(make-AssignPrimOpStatement target
(op make-compiled-procedure) 'make-compiled-procedure
(label ,proc-entry) (list (make-Label proc-entry)
;; TODO: rather than capture the whole ;; TODO: rather than capture the whole
;; environment, we may instead ;; environment, we may instead
;; just capture the free variables. ;; just capture the free variables.
;; But that requires that we box ;; But that requires that we box
;; up all set!-ed variables, in order ;; up all set!-ed variables, in order
;; to preserve semantics of set! ;; to preserve semantics of set!
(reg env))))) (make-Reg 'env))))))
(compile-lambda-body exp cenv (compile-lambda-body exp cenv
proc-entry)) proc-entry))
after-lambda)))) after-lambda))))
@ -269,11 +270,13 @@
'(env proc argl) '(env proc argl)
'(env) '(env)
`(,proc-entry `(,proc-entry
(assign env (op compiled-procedure-env) (reg proc)) ,(make-AssignPrimOpStatement 'env
(assign env 'compiled-procedure-env
(op extend-environment) (list (make-Reg 'proc)))
(reg argl) ,(make-AssignPrimOpStatement 'env
(reg env)))) 'extend-environment
(list (make-Reg 'argl)
(make-Reg 'env)))))
(compile-sequence (Lam-body exp) extended-cenv 'val 'return)))) (compile-sequence (Lam-body exp) extended-cenv 'val 'return))))
(: compile-application (App CompileTimeEnvironment Target Linkage -> InstructionSequence)) (: compile-application (App CompileTimeEnvironment Target Linkage -> InstructionSequence))
@ -294,12 +297,13 @@
(if (null? operand-codes) (if (null? operand-codes)
(make-instruction-sequence '() (make-instruction-sequence '()
'(argl) '(argl)
'((assign argl (const ())))) `(,(make-AssignImmediateStatement 'argl (make-Const '()))))
(let ([code-to-get-last-arg (let ([code-to-get-last-arg
(append-instruction-sequences (append-instruction-sequences
(car operand-codes) (car operand-codes)
(make-instruction-sequence '(val) '(argl) (make-instruction-sequence '(val) '(argl)
'((assign argl (op list) (reg val)))))]) `(,(make-AssignPrimOpStatement 'argl 'list
(list (make-Reg 'val))))))])
(if (null? (cdr operand-codes)) (if (null? (cdr operand-codes))
code-to-get-last-arg code-to-get-last-arg
(preserving '(env) (preserving '(env)
@ -314,7 +318,10 @@
(make-instruction-sequence (make-instruction-sequence
'(val argl) '(val argl)
'(argl) '(argl)
'((assign argl (op cons) (reg val) (reg argl)))))]) `(,(make-AssignPrimOpStatement 'argl
'cons
(list (make-Reg 'val)
(make-Reg 'argl))))))])
(if (null? (cdr operand-codes)) (if (null? (cdr operand-codes))
code-for-next-arg code-for-next-arg
(preserving '(env) (preserving '(env)
@ -330,8 +337,8 @@
(if (eq? linkage 'next) after-call linkage)]) (if (eq? linkage 'next) after-call linkage)])
(append-instruction-sequences (append-instruction-sequences
(make-instruction-sequence '(proc) '() (make-instruction-sequence '(proc) '()
`((test (op primitive-procedure?) (reg proc)) `(,(make-TestStatement 'primitive-procedure? 'proc)
(branch (label ,primitive-branch)))) ,(make-BranchLabelStatement primitive-branch)))
(parallel-instruction-sequences (parallel-instruction-sequences
(append-instruction-sequences (append-instruction-sequences
compiled-branch compiled-branch
@ -342,10 +349,10 @@
(make-instruction-sequence (make-instruction-sequence
'(proc argl) '(proc argl)
(list target) (list target)
`((assign ,target `(,(make-AssignPrimOpStatement target
(op apply-primitive-procedure) 'apply-primitive-procedure
(reg proc) (list (make-Reg 'proc)
(reg argl))))))) (make-Reg 'argl))))))))
after-call)))) after-call))))
(: compile-proc-appl (Target Linkage -> InstructionSequence)) (: compile-proc-appl (Target Linkage -> InstructionSequence))
@ -355,31 +362,31 @@
(make-instruction-sequence (make-instruction-sequence
'(proc) '(proc)
all-regs all-regs
`((assign cont (label ,linkage)) `(,(make-AssignImmediateStatement 'cont (make-Label linkage))
(assign val (op compiled-procedure-entry) ,(make-AssignPrimOpStatement 'val 'compiled-procedure-entry
(reg proc)) (list (make-Reg 'proc)))
(goto (reg val))))] ,(make-GotoStatement (make-Reg 'val))))]
[(and (not (eq? target 'val)) [(and (not (eq? target 'val))
(not (eq? linkage 'return))) (not (eq? linkage 'return)))
(let ([proc-return (make-label 'procReturn)]) (let ([proc-return (make-label 'procReturn)])
(make-instruction-sequence (make-instruction-sequence
'(proc) '(proc)
all-regs all-regs
`((assign cont (label ,proc-return)) `(,(make-AssignImmediateStatement 'cont (make-Label proc-return))
(assign val (op compiled-procedure-entry) ,(make-AssignPrimOpStatement 'val 'compiled-procedure-entry
(reg proc)) (list (make-Reg 'proc)))
(goto (reg val)) ,(make-GotoStatement (make-Reg 'val))
,proc-return ,proc-return
(assign ,target (reg val)) ,(make-AssignImmediateStatement target (make-Reg 'val))
(goto (label ,linkage)))))] ,(make-GotoStatement (make-Label linkage)))))]
[(and (eq? target 'val) [(and (eq? target 'val)
(eq? linkage 'return)) (eq? linkage 'return))
(make-instruction-sequence (make-instruction-sequence
'(proc cont) '(proc cont)
all-regs all-regs
'((assign val (op compiled-procedure-entry) `(,(make-AssignPrimOpStatement 'val 'compiled-procedure-entry
(reg proc)) (list (make-Reg 'proc)))
(goto (reg val))))] ,(make-GotoStatement (make-Reg 'val))))]
[(and (not (eq? target 'val)) [(and (not (eq? target 'val))
(eq? linkage 'return)) (eq? linkage 'return))
(error 'compile "return linkage, target not val: ~s" target)])) (error 'compile "return linkage, target not val: ~s" target)]))
@ -413,9 +420,9 @@
(registers-needed seq1)) (registers-needed seq1))
(list-difference (registers-modified seq1) (list-difference (registers-modified seq1)
(list first-reg)) (list first-reg))
(append `((save ,first-reg)) (append `(,(make-SaveStatement first-reg))
(statements seq1) (statements seq1)
`((restore ,first-reg)))) `(,(make-RestoreStatement first-reg))))
seq2) seq2)
(preserving (cdr regs) seq1 seq2))))) (preserving (cdr regs) seq1 seq2)))))

50
typed-structs.rkt
View File

@ -30,11 +30,50 @@
;; instruction sequences ;; instruction sequences
(define-type UnlabeledStatement (U
AssignImmediateStatement
AssignPrimOpStatement
PerformStatement
TestStatement
BranchLabelStatement
GotoStatement
SaveStatement
RestoreStatement))
(define-type Statement (U UnlabeledStatement
Symbol ;; label
))
(define-struct: AssignImmediateStatement ([target : Symbol]
[value : (U Const Reg Label)])
#:transparent)
(define-struct: AssignPrimOpStatement ([target : Symbol]
[op : Symbol]
[rands : (Listof (U Label Reg Const))])
#:transparent)
(define-struct: PerformStatement ([op : Symbol]
[rands : (Listof (U Label Reg Const))]) #:transparent)
(define-struct: TestStatement ([op : (U 'false? 'primitive-procedure?)]
[register-rand : Symbol]) #: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: Label ([name : Symbol]))
(define-struct: Reg ([name : Symbol]))
(define-struct: Const ([const : Any]))
(define-type OpArg (U Const Label Reg))
(define-type InstructionSequence (U Symbol instruction-sequence)) (define-type InstructionSequence (U Symbol instruction-sequence))
(define-struct: instruction-sequence ([needs : (Listof Symbol)] (define-struct: instruction-sequence ([needs : (Listof Symbol)]
[modifies : (Listof Symbol)] [modifies : (Listof Symbol)]
[statements : (Listof Any)]) #:transparent) [statements : (Listof Statement)]) #:transparent)
(define empty-instruction-sequence (make-instruction-sequence '() '() '())) (define empty-instruction-sequence (make-instruction-sequence '() '() '()))
(: make-label (Symbol -> Symbol)) (: make-label (Symbol -> Symbol))
@ -53,7 +92,7 @@
(define (registers-modified s) (define (registers-modified s)
(if (symbol? s) '() (instruction-sequence-modifies s))) (if (symbol? s) '() (instruction-sequence-modifies s)))
(: statements (InstructionSequence -> (Listof Any))) (: statements (InstructionSequence -> (Listof Statement)))
(define (statements s) (define (statements s)
(if (symbol? s) (list s) (instruction-sequence-statements s))) (if (symbol? s) (list s) (instruction-sequence-statements s)))
@ -63,4 +102,9 @@
(define-type Target Symbol) (define-type Target Symbol)
;; Linkage ;; Linkage
(define-type Linkage (U 'return 'next Symbol)) (define-type Linkage (U 'return 'next Symbol))
(define-struct: BasicBlock ([name : Symbol]
[stmts : (Listof UnlabeledStatement)]) #:transparent)