about to change calling convension
This commit is contained in:
Danny Yoo
parent
2975a9f215
commit
1c64447e08
287
compile.rkt
287
compile.rkt
|
|
@ -11,7 +11,7 @@
|
|||
|
||||
;; registers: env, argl, proc, val, cont
|
||||
;; as well as the stack.
|
||||
(define all-regs '(env argl proc val cont))
|
||||
(define all-regs '(val control env))
|
||||
|
||||
|
||||
(: compile-top (Expression Target Linkage -> InstructionSequence))
|
||||
|
|
@ -20,8 +20,6 @@
|
|||
[cenv : CompileTimeEnvironment (list (make-Prefix names))])
|
||||
(append-instruction-sequences
|
||||
(make-instruction-sequence
|
||||
'(env)
|
||||
'(env)
|
||||
`(,(make-AssignPrimOpStatement 'env
|
||||
'extend-environment/prefix
|
||||
(list (make-Const names)
|
||||
|
|
@ -35,24 +33,24 @@
|
|||
(cond
|
||||
[(Constant? exp)
|
||||
(compile-self-evaluating exp cenv target linkage)]
|
||||
[(Quote? exp)
|
||||
#;[(Quote? exp)
|
||||
(compile-quoted exp cenv target linkage)]
|
||||
[(Var? exp)
|
||||
#;[(Var? exp)
|
||||
(compile-variable exp cenv target linkage)]
|
||||
[(Assign? exp)
|
||||
#;[(Assign? exp)
|
||||
(compile-assignment exp cenv target linkage)]
|
||||
[(Def? exp)
|
||||
#;[(Def? exp)
|
||||
(compile-definition exp cenv target linkage)]
|
||||
[(Branch? exp)
|
||||
#;[(Branch? exp)
|
||||
(compile-if exp cenv target linkage)]
|
||||
[(Lam? exp)
|
||||
#;[(Lam? exp)
|
||||
(compile-lambda exp cenv target linkage)]
|
||||
[(Seq? exp)
|
||||
#;[(Seq? exp)
|
||||
(compile-sequence (Seq-actions exp)
|
||||
cenv
|
||||
target
|
||||
linkage)]
|
||||
[(App? exp)
|
||||
#;[(App? exp)
|
||||
(compile-application exp cenv target linkage)]))
|
||||
|
||||
|
||||
|
|
@ -60,45 +58,37 @@
|
|||
(: compile-linkage (Linkage -> InstructionSequence))
|
||||
(define (compile-linkage linkage)
|
||||
(cond
|
||||
[(eq? linkage 'return)
|
||||
(make-instruction-sequence '(cont) '() `(,(make-GotoStatement (make-Reg 'cont))))]
|
||||
#;[(eq? linkage 'return)
|
||||
(make-instruction-sequence `(,(make-GotoStatement (make-ControlOffset 0))))]
|
||||
[(eq? linkage 'next)
|
||||
empty-instruction-sequence]
|
||||
[else
|
||||
(make-instruction-sequence '() '()
|
||||
`(,(make-GotoStatement (make-Label linkage))))]))
|
||||
(make-instruction-sequence `(,(make-GotoStatement (make-Label linkage))))]))
|
||||
|
||||
(: end-with-linkage (Linkage InstructionSequence -> InstructionSequence))
|
||||
(define (end-with-linkage linkage instruction-sequence)
|
||||
(preserving '(cont)
|
||||
instruction-sequence
|
||||
(compile-linkage linkage)))
|
||||
(append-instruction-sequences 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
|
||||
'()
|
||||
(list target)
|
||||
`(,(make-AssignImmediateStatement target (make-Const (Constant-v exp)))))))
|
||||
|
||||
(: compile-quoted (Quote CompileTimeEnvironment Target Linkage -> InstructionSequence))
|
||||
(define (compile-quoted exp cenv target linkage)
|
||||
#;(: compile-quoted (Quote CompileTimeEnvironment Target Linkage -> InstructionSequence))
|
||||
#;(define (compile-quoted exp cenv target linkage)
|
||||
(end-with-linkage linkage
|
||||
(make-instruction-sequence
|
||||
'()
|
||||
(list target)
|
||||
`(,(make-AssignImmediateStatement target (make-Const (Quote-text exp)))))))
|
||||
|
||||
(: compile-variable (Var CompileTimeEnvironment Target Linkage -> InstructionSequence))
|
||||
(define (compile-variable exp cenv target linkage)
|
||||
#;(: compile-variable (Var CompileTimeEnvironment Target Linkage -> InstructionSequence))
|
||||
#;(define (compile-variable exp cenv target linkage)
|
||||
(let ([lexical-pos (find-variable (Var-id exp) cenv)])
|
||||
(cond
|
||||
[(LocalAddress? lexical-pos)
|
||||
(end-with-linkage linkage
|
||||
(make-instruction-sequence
|
||||
'(env)
|
||||
(list target)
|
||||
`(,(make-AssignPrimOpStatement target
|
||||
'lexical-address-lookup
|
||||
(list (make-Const (LocalAddress-depth lexical-pos))
|
||||
|
|
@ -107,8 +97,6 @@
|
|||
[(PrefixAddress? lexical-pos)
|
||||
(end-with-linkage linkage
|
||||
(make-instruction-sequence
|
||||
'(env)
|
||||
(list target)
|
||||
`(,(make-PerformStatement 'check-bound!
|
||||
(list (make-Const (PrefixAddress-depth lexical-pos))
|
||||
(make-Const (PrefixAddress-pos lexical-pos))
|
||||
|
|
@ -122,8 +110,8 @@
|
|||
(make-Reg 'env))))))])))
|
||||
|
||||
|
||||
(: compile-assignment (Assign CompileTimeEnvironment Target Linkage -> InstructionSequence))
|
||||
(define (compile-assignment exp cenv target linkage)
|
||||
#;(: compile-assignment (Assign CompileTimeEnvironment Target Linkage -> InstructionSequence))
|
||||
#;(define (compile-assignment exp cenv target linkage)
|
||||
(let* ([var (Assign-variable exp)]
|
||||
[get-value-code
|
||||
(compile (Assign-value exp) cenv 'val 'next)]
|
||||
|
|
@ -133,36 +121,30 @@
|
|||
[(LocalAddress? lexical-address)
|
||||
(end-with-linkage
|
||||
linkage
|
||||
(preserving '(env)
|
||||
get-value-code
|
||||
(make-instruction-sequence
|
||||
'(env val)
|
||||
(list target)
|
||||
`(,(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))))))]
|
||||
(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
|
||||
(preserving '(env)
|
||||
get-value-code
|
||||
(make-instruction-sequence
|
||||
'(env val)
|
||||
(list target)
|
||||
`(,(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))))))])))
|
||||
(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)
|
||||
#;(: compile-definition (Def CompileTimeEnvironment Target Linkage -> InstructionSequence))
|
||||
#;(define (compile-definition exp cenv target linkage)
|
||||
(let* ([var (Def-variable exp)]
|
||||
[lexical-pos (find-variable var cenv)]
|
||||
[get-value-code
|
||||
|
|
@ -173,23 +155,19 @@
|
|||
[(PrefixAddress? lexical-pos)
|
||||
(end-with-linkage
|
||||
linkage
|
||||
(preserving
|
||||
'(env)
|
||||
(append-instruction-sequences
|
||||
get-value-code
|
||||
(make-instruction-sequence
|
||||
'(env val)
|
||||
(list target)
|
||||
`(,(make-PerformStatement 'toplevel-set!
|
||||
(list (make-Const (PrefixAddress-depth lexical-pos))
|
||||
(make-Const (PrefixAddress-pos lexical-pos))
|
||||
(make-Const var)
|
||||
(make-Reg 'env)
|
||||
(make-Reg 'val)))
|
||||
,(make-AssignImmediateStatement target (make-Const 'ok))))))])))
|
||||
(make-instruction-sequence `(,(make-PerformStatement 'toplevel-set!
|
||||
(list (make-Const (PrefixAddress-depth lexical-pos))
|
||||
(make-Const (PrefixAddress-pos lexical-pos))
|
||||
(make-Const var)
|
||||
(make-Reg 'env)
|
||||
(make-Reg 'val)))
|
||||
,(make-AssignImmediateStatement target (make-Const 'ok))))))])))
|
||||
|
||||
|
||||
(: compile-if (Branch CompileTimeEnvironment Target Linkage -> InstructionSequence))
|
||||
(define (compile-if exp cenv target linkage)
|
||||
#;(: 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)]
|
||||
[after-if (make-label 'afterIf)])
|
||||
|
|
@ -200,31 +178,27 @@
|
|||
(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
|
||||
(make-instruction-sequence
|
||||
'(val)
|
||||
'()
|
||||
`(,(make-TestStatement 'false? 'val)
|
||||
,(make-BranchLabelStatement f-branch)))
|
||||
(parallel-instruction-sequences
|
||||
(append-instruction-sequences t-branch c-code)
|
||||
(append-instruction-sequences f-branch a-code))
|
||||
after-if))))))
|
||||
(append-instruction-sequences p-code
|
||||
(append-instruction-sequences
|
||||
(make-instruction-sequence
|
||||
`(,(make-TestStatement 'false? 'val)
|
||||
,(make-BranchLabelStatement f-branch)))
|
||||
(parallel-instruction-sequences
|
||||
(append-instruction-sequences t-branch c-code)
|
||||
(append-instruction-sequences f-branch a-code))
|
||||
after-if))))))
|
||||
|
||||
|
||||
(: compile-sequence ((Listof Expression) CompileTimeEnvironment Target Linkage -> InstructionSequence))
|
||||
(define (compile-sequence seq cenv target linkage)
|
||||
#;(: 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)
|
||||
(preserving '(env cont)
|
||||
(compile (first-exp seq) cenv target 'next)
|
||||
(compile-sequence (rest-exps seq) cenv target linkage))))
|
||||
(append-instruction-sequences (compile (first-exp seq) cenv target 'next)
|
||||
(compile-sequence (rest-exps seq) cenv target linkage))))
|
||||
|
||||
|
||||
(: compile-lambda (Lam CompileTimeEnvironment Target Linkage -> InstructionSequence))
|
||||
(define (compile-lambda exp 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)])
|
||||
(let ([lambda-linkage
|
||||
|
|
@ -235,8 +209,6 @@
|
|||
(tack-on-instruction-sequence
|
||||
(end-with-linkage lambda-linkage
|
||||
(make-instruction-sequence
|
||||
'(env)
|
||||
(list target)
|
||||
`(,(make-AssignPrimOpStatement target
|
||||
'make-compiled-procedure
|
||||
(list (make-Label proc-entry)
|
||||
|
|
@ -251,14 +223,12 @@
|
|||
proc-entry))
|
||||
after-lambda))))
|
||||
|
||||
(: compile-lambda-body (Lam CompileTimeEnvironment Linkage -> InstructionSequence))
|
||||
(define (compile-lambda-body exp cenv proc-entry)
|
||||
#;(: compile-lambda-body (Lam CompileTimeEnvironment Linkage -> InstructionSequence))
|
||||
#;(define (compile-lambda-body exp cenv proc-entry)
|
||||
(let* ([formals (Lam-parameters exp)]
|
||||
[extended-cenv (extend-lexical-environment cenv formals)])
|
||||
(append-instruction-sequences
|
||||
(make-instruction-sequence
|
||||
'(env proc argl)
|
||||
'(env)
|
||||
`(,proc-entry
|
||||
,(make-AssignPrimOpStatement 'env
|
||||
'compiled-procedure-env
|
||||
|
|
@ -269,8 +239,8 @@
|
|||
(make-Reg 'env)))))
|
||||
(compile-sequence (Lam-body exp) extended-cenv 'val 'return))))
|
||||
|
||||
(: compile-application (App CompileTimeEnvironment Target Linkage -> InstructionSequence))
|
||||
(define (compile-application exp cenv target linkage)
|
||||
#;(: compile-application (App CompileTimeEnvironment Target Linkage -> InstructionSequence))
|
||||
#;(define (compile-application exp cenv target linkage)
|
||||
;; FIXME: I need to implement important special cases.
|
||||
;; 1. We may be able to open-code if the operator is primitive
|
||||
;; 2. We may have a static location to jump to if the operator is lexically scoped.
|
||||
|
|
@ -278,59 +248,51 @@
|
|||
[operand-codes (map (lambda: ([operand : Expression])
|
||||
(compile operand cenv 'val 'next))
|
||||
(App-operands exp))])
|
||||
(preserving '(env cont)
|
||||
proc-code
|
||||
(preserving '(proc cont)
|
||||
(construct-arglist operand-codes)
|
||||
(compile-procedure-call target linkage)))))
|
||||
(append-instruction-sequences
|
||||
proc-code
|
||||
(append-instruction-sequences
|
||||
(construct-arglist operand-codes)
|
||||
(compile-procedure-call target linkage)))))
|
||||
|
||||
(: construct-arglist ((Listof InstructionSequence) -> InstructionSequence))
|
||||
(define (construct-arglist operand-codes)
|
||||
#;(: construct-arglist ((Listof InstructionSequence) -> InstructionSequence))
|
||||
#;(define (construct-arglist operand-codes)
|
||||
(let ([operand-codes (reverse operand-codes)])
|
||||
(if (null? operand-codes)
|
||||
(make-instruction-sequence '()
|
||||
'(argl)
|
||||
`(,(make-AssignImmediateStatement 'argl (make-Const '()))))
|
||||
(make-instruction-sequence `(,(make-AssignImmediateStatement 'argl (make-Const '()))))
|
||||
(let ([code-to-get-last-arg
|
||||
(append-instruction-sequences
|
||||
(car operand-codes)
|
||||
(make-instruction-sequence '(val) '(argl)
|
||||
`(,(make-AssignPrimOpStatement 'argl 'list
|
||||
(make-instruction-sequence `(,(make-AssignPrimOpStatement 'argl 'list
|
||||
(list (make-Reg 'val))))))])
|
||||
(if (null? (cdr operand-codes))
|
||||
code-to-get-last-arg
|
||||
(preserving '(env)
|
||||
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)
|
||||
(append-instruction-sequences 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)
|
||||
(car operand-codes)
|
||||
(make-instruction-sequence
|
||||
'(val argl)
|
||||
'(argl)
|
||||
`(,(make-AssignPrimOpStatement 'argl
|
||||
'cons
|
||||
(list (make-Reg 'val)
|
||||
(make-Reg 'argl))))))])
|
||||
(append-instruction-sequences
|
||||
(car operand-codes)
|
||||
(make-instruction-sequence
|
||||
`(,(make-AssignPrimOpStatement 'argl
|
||||
'cons
|
||||
(list (make-Reg 'val)
|
||||
(make-Reg 'argl))))))])
|
||||
(if (null? (cdr operand-codes))
|
||||
code-for-next-arg
|
||||
(preserving '(env)
|
||||
code-for-next-arg
|
||||
(code-to-get-rest-args (cdr operand-codes))))))
|
||||
(append-instruction-sequences code-for-next-arg
|
||||
(code-to-get-rest-args (cdr operand-codes))))))
|
||||
|
||||
(: compile-procedure-call (Target Linkage -> InstructionSequence))
|
||||
(define (compile-procedure-call target linkage)
|
||||
#;(: compile-procedure-call (Target Linkage -> InstructionSequence))
|
||||
#;(define (compile-procedure-call target linkage)
|
||||
(let ([primitive-branch (make-label 'primitiveBranch)]
|
||||
[compiled-branch (make-label 'compiledBranch)]
|
||||
[after-call (make-label 'afterCall)])
|
||||
(let ([compiled-linkage
|
||||
(if (eq? linkage 'next) after-call linkage)])
|
||||
(append-instruction-sequences
|
||||
(make-instruction-sequence '(proc) '()
|
||||
`(,(make-TestStatement 'primitive-procedure? 'proc)
|
||||
(make-instruction-sequence `(,(make-TestStatement 'primitive-procedure? 'proc)
|
||||
,(make-BranchLabelStatement primitive-branch)))
|
||||
(parallel-instruction-sequences
|
||||
(append-instruction-sequences
|
||||
|
|
@ -340,21 +302,17 @@
|
|||
primitive-branch
|
||||
(end-with-linkage linkage
|
||||
(make-instruction-sequence
|
||||
'(proc argl)
|
||||
(list target)
|
||||
`(,(make-AssignPrimOpStatement target
|
||||
'apply-primitive-procedure
|
||||
(list (make-Reg 'proc)
|
||||
(make-Reg 'argl))))))))
|
||||
after-call))))
|
||||
|
||||
(: compile-proc-appl (Target Linkage -> InstructionSequence))
|
||||
(define (compile-proc-appl target linkage)
|
||||
#;(: compile-proc-appl (Target Linkage -> InstructionSequence))
|
||||
#;(define (compile-proc-appl target linkage)
|
||||
(cond [(and (eq? target 'val)
|
||||
(not (eq? linkage 'return)))
|
||||
(make-instruction-sequence
|
||||
'(proc)
|
||||
all-regs
|
||||
`(,(make-AssignImmediateStatement 'cont (make-Label linkage))
|
||||
,(make-AssignPrimOpStatement 'val 'compiled-procedure-entry
|
||||
(list (make-Reg 'proc)))
|
||||
|
|
@ -363,8 +321,6 @@
|
|||
(not (eq? linkage 'return)))
|
||||
(let ([proc-return (make-label 'procReturn)])
|
||||
(make-instruction-sequence
|
||||
'(proc)
|
||||
all-regs
|
||||
`(,(make-AssignImmediateStatement 'cont (make-Label proc-return))
|
||||
,(make-AssignPrimOpStatement 'val 'compiled-procedure-entry
|
||||
(list (make-Reg 'proc)))
|
||||
|
|
@ -375,8 +331,6 @@
|
|||
[(and (eq? target 'val)
|
||||
(eq? linkage 'return))
|
||||
(make-instruction-sequence
|
||||
'(proc cont)
|
||||
all-regs
|
||||
`(,(make-AssignPrimOpStatement 'val 'compiled-procedure-entry
|
||||
(list (make-Reg 'proc)))
|
||||
,(make-GotoStatement (make-Reg 'val))))]
|
||||
|
|
@ -388,39 +342,6 @@
|
|||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
(: needs-register? (InstructionSequence Symbol -> Boolean))
|
||||
(define (needs-register? seq reg)
|
||||
(and (memq reg (registers-needed seq)) #t))
|
||||
|
||||
(: modifies-register? (InstructionSequence Symbol -> Boolean))
|
||||
(define (modifies-register? seq reg)
|
||||
(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)
|
||||
(let ([first-reg (car regs)])
|
||||
(if (and (needs-register? seq2 first-reg)
|
||||
(modifies-register? seq1 first-reg))
|
||||
(preserving (cdr regs)
|
||||
(make-instruction-sequence
|
||||
(list-union (list first-reg)
|
||||
(registers-needed seq1))
|
||||
(list-difference (registers-modified seq1)
|
||||
(list first-reg))
|
||||
(append `(,(make-SaveStatement first-reg))
|
||||
(statements seq1)
|
||||
`(,(make-RestoreStatement first-reg))))
|
||||
seq2)
|
||||
(preserving (cdr regs) seq1 seq2)))))
|
||||
|
||||
|
||||
|
||||
(: append-instruction-sequences (InstructionSequence * -> InstructionSequence))
|
||||
(define (append-instruction-sequences . seqs)
|
||||
(append-seq-list seqs))
|
||||
|
|
@ -428,11 +349,6 @@
|
|||
(: 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)
|
||||
(registers-modified seq1)))
|
||||
(list-union (registers-modified seq1)
|
||||
(registers-modified seq2))
|
||||
(append (statements seq1) (statements seq2))))
|
||||
|
||||
(: append-seq-list ((Listof InstructionSequence) -> InstructionSequence))
|
||||
|
|
@ -447,16 +363,9 @@
|
|||
|
||||
(: 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))))
|
||||
(make-instruction-sequence (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)
|
||||
(registers-needed seq2))
|
||||
(list-union (registers-modified seq1)
|
||||
(registers-modified seq2))
|
||||
(append (statements seq1) (statements seq2))))
|
||||
(make-instruction-sequence (append (statements seq1) (statements seq2))))
|
||||
|
||||
|
|
|
|||
|
|
@ -4,8 +4,8 @@
|
|||
|
||||
;; Expressions
|
||||
|
||||
(define-type ExpressionCore (U Constant Quote Var Branch Def Lam Seq App))
|
||||
(define-type Expression (U ExpressionCore Assign))
|
||||
(define-type ExpressionCore (U Constant #;Quote #;Var #;Branch #;Def #;Lam #;Seq #;App))
|
||||
(define-type Expression (U ExpressionCore #;Assign))
|
||||
(define-struct: Constant ([v : Any]) #:transparent)
|
||||
(define-struct: Quote ([text : Any]) #:transparent)
|
||||
(define-struct: Var ([id : Symbol]) #:transparent)
|
||||
|
|
@ -33,6 +33,10 @@
|
|||
(define (rest-exps seq) (cdr seq))
|
||||
|
||||
|
||||
(define-type StackRegisterSymbol (U 'control 'env))
|
||||
(define-type RegisterSymbol (U StackRegisterSymbol 'val))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;; instruction sequences
|
||||
|
|
@ -43,30 +47,30 @@
|
|||
TestStatement
|
||||
BranchLabelStatement
|
||||
GotoStatement
|
||||
SaveStatement
|
||||
RestoreStatement))
|
||||
#;SaveStatement
|
||||
#;RestoreStatement))
|
||||
(define-type Statement (U UnlabeledStatement
|
||||
Symbol ;; label
|
||||
))
|
||||
(define-struct: AssignImmediateStatement ([target : Symbol]
|
||||
(define-struct: AssignImmediateStatement ([target : Target]
|
||||
[value : (U Const Reg Label)])
|
||||
#:transparent)
|
||||
(define-struct: AssignPrimOpStatement ([target : Symbol]
|
||||
(define-struct: AssignPrimOpStatement ([target : Target]
|
||||
[op : PrimitiveOperator]
|
||||
[rands : (Listof (U Label Reg Const))])
|
||||
#:transparent)
|
||||
(define-struct: PerformStatement ([op : PerformOperator]
|
||||
[rands : (Listof (U Label Reg Const))]) #:transparent)
|
||||
(define-struct: TestStatement ([op : TestOperator]
|
||||
[register-rand : Symbol]) #:transparent)
|
||||
[register-rand : RegisterSymbol]) #: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: SaveStatement ([reg : RegisterSymbol]) #:transparent)
|
||||
#;(define-struct: RestoreStatement ([reg : RegisterSymbol]) #:transparent)
|
||||
|
||||
(define-struct: Label ([name : Symbol])
|
||||
#:transparent)
|
||||
(define-struct: Reg ([name : Symbol])
|
||||
(define-struct: Reg ([name : RegisterSymbol])
|
||||
#:transparent)
|
||||
(define-struct: Const ([const : Any])
|
||||
#:transparent)
|
||||
|
|
@ -99,10 +103,9 @@
|
|||
|
||||
|
||||
(define-type InstructionSequence (U Symbol instruction-sequence))
|
||||
(define-struct: instruction-sequence ([needs : (Listof Symbol)]
|
||||
[modifies : (Listof Symbol)]
|
||||
[statements : (Listof Statement)]) #:transparent)
|
||||
(define empty-instruction-sequence (make-instruction-sequence '() '() '()))
|
||||
(define-struct: instruction-sequence ([statements : (Listof Statement)])
|
||||
#:transparent)
|
||||
(define empty-instruction-sequence (make-instruction-sequence '()))
|
||||
|
||||
(: make-label (Symbol -> Symbol))
|
||||
(define make-label
|
||||
|
|
@ -112,14 +115,6 @@
|
|||
(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 Statement)))
|
||||
(define (statements s)
|
||||
(if (symbol? s) (list s) (instruction-sequence-statements s)))
|
||||
|
|
@ -127,10 +122,15 @@
|
|||
|
||||
|
||||
;; Targets
|
||||
(define-type Target Symbol)
|
||||
(define-type Target (U RegisterSymbol ControlOffset EnvOffset))
|
||||
(define-struct: ControlOffset ([depth : Natural]))
|
||||
(define-struct: EnvOffset ([depth : Natural]
|
||||
[pos : Natural]))
|
||||
|
||||
;; Linkage
|
||||
(define-type Linkage (U 'return 'next Symbol))
|
||||
(define-type Linkage (U #; 'return
|
||||
'next
|
||||
Symbol))
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user