going to see if we can do something lexically smart here.
This commit is contained in:
Danny Yoo
parent
56e616c04b
commit
97762a015f
|
|
@ -46,8 +46,8 @@
|
|||
,(make-PopEnvironment 2 0)))
|
||||
|
||||
;; Finally, do a tail call into f.
|
||||
(compile-procedure-call 0
|
||||
1
|
||||
(compile-procedure-call '()
|
||||
'(?)
|
||||
1
|
||||
'val
|
||||
'return)
|
||||
|
|
|
|||
141
compile.rkt
141
compile.rkt
|
|
@ -12,17 +12,19 @@
|
|||
|
||||
|
||||
|
||||
|
||||
|
||||
(: -compile (ExpressionCore Target Linkage -> (Listof Statement)))
|
||||
(define (-compile exp target linkage)
|
||||
(statements
|
||||
(compile exp
|
||||
0
|
||||
'()
|
||||
target
|
||||
linkage)))
|
||||
|
||||
|
||||
|
||||
(: compile (ExpressionCore Natural Target Linkage -> InstructionSequence))
|
||||
(: compile (ExpressionCore CompileTimeEnvironment Target Linkage -> InstructionSequence))
|
||||
;; Compiles an expression into an instruction sequence.
|
||||
(define (compile exp cenv target linkage)
|
||||
(cond
|
||||
|
|
@ -59,24 +61,24 @@
|
|||
|
||||
|
||||
|
||||
(: compile-top (Top Natural Target Linkage -> InstructionSequence))
|
||||
(: compile-top (Top CompileTimeEnvironment Target Linkage -> InstructionSequence))
|
||||
(define (compile-top top cenv target linkage)
|
||||
(let*: ([names : (Listof (U Symbol False)) (Prefix-names (Top-prefix top))])
|
||||
(append-instruction-sequences
|
||||
(make-instruction-sequence
|
||||
`(,(make-PerformStatement (make-ExtendEnvironment/Prefix! names))))
|
||||
(compile (Top-code top) (add1 cenv) target linkage))))
|
||||
(compile (Top-code top) (cons 'prefix cenv) target linkage))))
|
||||
|
||||
|
||||
|
||||
;; Add linkage for expressions.
|
||||
(: end-with-linkage (Linkage Natural InstructionSequence -> InstructionSequence))
|
||||
(: end-with-linkage (Linkage CompileTimeEnvironment InstructionSequence -> InstructionSequence))
|
||||
(define (end-with-linkage linkage cenv instruction-sequence)
|
||||
(append-instruction-sequences instruction-sequence
|
||||
(compile-linkage cenv linkage)))
|
||||
|
||||
|
||||
(: end-with-compiled-application-linkage (Linkage Natural InstructionSequence ->
|
||||
(: end-with-compiled-application-linkage (Linkage CompileTimeEnvironment InstructionSequence ->
|
||||
InstructionSequence))
|
||||
;; Add linkage for applications; we need to specialize this to preserve tail calls.
|
||||
(define (end-with-compiled-application-linkage linkage cenv instruction-sequence)
|
||||
|
|
@ -85,13 +87,13 @@
|
|||
|
||||
|
||||
|
||||
(: compile-linkage (Natural Linkage -> InstructionSequence))
|
||||
(: compile-linkage (CompileTimeEnvironment Linkage -> InstructionSequence))
|
||||
(define (compile-linkage cenv linkage)
|
||||
(cond
|
||||
[(eq? linkage 'return)
|
||||
(make-instruction-sequence `(,(make-AssignPrimOpStatement 'proc
|
||||
(make-GetControlStackLabel))
|
||||
,(make-PopEnvironment cenv 0)
|
||||
,(make-PopEnvironment (length cenv) 0)
|
||||
,(make-PopControlFrame)
|
||||
,(make-GotoStatement (make-Reg 'proc))))]
|
||||
[(eq? linkage 'next)
|
||||
|
|
@ -100,7 +102,7 @@
|
|||
(make-instruction-sequence `(,(make-GotoStatement (make-Label linkage))))]))
|
||||
|
||||
|
||||
(: compile-application-linkage (Natural Linkage -> InstructionSequence))
|
||||
(: compile-application-linkage (CompileTimeEnvironment Linkage -> InstructionSequence))
|
||||
;; Like compile-linkage, but the special case for 'return linkage already assumes
|
||||
;; the stack has been appropriately popped.
|
||||
(define (compile-application-linkage cenv linkage)
|
||||
|
|
@ -110,14 +112,14 @@
|
|||
,(make-PopControlFrame)
|
||||
,(make-GotoStatement (make-Reg 'proc))))]
|
||||
[(eq? linkage 'next)
|
||||
(make-instruction-sequence `(,(make-PopEnvironment cenv 0)))]
|
||||
(make-instruction-sequence `(,(make-PopEnvironment (length cenv) 0)))]
|
||||
[(symbol? linkage)
|
||||
(make-instruction-sequence `(,(make-PopEnvironment cenv 0)
|
||||
(make-instruction-sequence `(,(make-PopEnvironment (length cenv) 0)
|
||||
,(make-GotoStatement (make-Label linkage))))]))
|
||||
|
||||
|
||||
|
||||
(: compile-constant (Constant Natural Target Linkage -> InstructionSequence))
|
||||
(: compile-constant (Constant CompileTimeEnvironment Target Linkage -> InstructionSequence))
|
||||
(define (compile-constant exp cenv target linkage)
|
||||
(end-with-linkage linkage
|
||||
cenv
|
||||
|
|
@ -126,7 +128,7 @@
|
|||
|
||||
|
||||
|
||||
(: compile-local-reference (LocalRef Natural Target Linkage -> InstructionSequence))
|
||||
(: compile-local-reference (LocalRef CompileTimeEnvironment Target Linkage -> InstructionSequence))
|
||||
(define (compile-local-reference exp cenv target linkage)
|
||||
(end-with-linkage linkage
|
||||
cenv
|
||||
|
|
@ -137,7 +139,7 @@
|
|||
(LocalRef-unbox? exp)))))))
|
||||
|
||||
|
||||
(: compile-toplevel-reference (ToplevelRef Natural Target Linkage -> InstructionSequence))
|
||||
(: compile-toplevel-reference (ToplevelRef CompileTimeEnvironment Target Linkage -> InstructionSequence))
|
||||
(define (compile-toplevel-reference exp cenv target linkage)
|
||||
(end-with-linkage linkage
|
||||
cenv
|
||||
|
|
@ -151,7 +153,7 @@
|
|||
(ToplevelRef-pos exp)))))))
|
||||
|
||||
|
||||
(: compile-toplevel-set (ToplevelSet Natural Target Linkage -> InstructionSequence))
|
||||
(: compile-toplevel-set (ToplevelSet CompileTimeEnvironment Target Linkage -> InstructionSequence))
|
||||
(define (compile-toplevel-set exp cenv target linkage)
|
||||
(let* ([var (ToplevelSet-name exp)]
|
||||
[lexical-pos (make-EnvPrefixReference (ToplevelSet-depth exp)
|
||||
|
|
@ -167,8 +169,8 @@
|
|||
(make-instruction-sequence `(,(make-AssignImmediateStatement target (make-Const (void))))))))))
|
||||
|
||||
|
||||
(: compile-branch (Branch Natural Target Linkage -> InstructionSequence))
|
||||
(define (compile-branch exp cenv target linkage)
|
||||
(: compile-branch (Branch CompileTimeEnvironment Target Linkage -> InstructionSequence))
|
||||
(define (compile-branch exp cenv target linkage)
|
||||
(let ([t-branch (make-label 'trueBranch)]
|
||||
[f-branch (make-label 'falseBranch)]
|
||||
[after-if (make-label 'afterIf)])
|
||||
|
|
@ -192,7 +194,7 @@
|
|||
after-if))))))
|
||||
|
||||
|
||||
(: compile-sequence ((Listof Expression) Natural Target Linkage -> InstructionSequence))
|
||||
(: compile-sequence ((Listof Expression) CompileTimeEnvironment Target Linkage -> InstructionSequence))
|
||||
(define (compile-sequence seq cenv target linkage)
|
||||
;; All but the last will use 'next linkage.
|
||||
(if (last-exp? seq)
|
||||
|
|
@ -201,7 +203,7 @@
|
|||
(compile-sequence (rest-exps seq) cenv target linkage))))
|
||||
|
||||
|
||||
(: compile-lambda (Lam Natural Target Linkage -> InstructionSequence))
|
||||
(: compile-lambda (Lam CompileTimeEnvironment Target Linkage -> InstructionSequence))
|
||||
;; Write out code for lambda expressions.
|
||||
;; The lambda will close over the free variables.
|
||||
(define (compile-lambda exp cenv target linkage)
|
||||
|
|
@ -234,8 +236,9 @@
|
|||
`(,proc-entry
|
||||
,(make-PerformStatement (make-InstallClosureValues!))))
|
||||
(compile (Lam-body exp)
|
||||
(+ (Lam-num-parameters exp)
|
||||
(length (Lam-closure-map exp)))
|
||||
(build-list (+ (Lam-num-parameters exp)
|
||||
(length (Lam-closure-map exp)))
|
||||
(lambda: ([i : Natural]) '?))
|
||||
'val
|
||||
'return)))
|
||||
|
||||
|
|
@ -245,35 +248,43 @@
|
|||
;; 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.
|
||||
(: compile-application (App Natural Target Linkage -> InstructionSequence))
|
||||
(: compile-application (App CompileTimeEnvironment Target Linkage -> InstructionSequence))
|
||||
(define (compile-application exp cenv target linkage)
|
||||
(let* ([extended-cenv (+ cenv (length (App-operands exp)))]
|
||||
[proc-code (compile (App-operator exp)
|
||||
extended-cenv
|
||||
(if (empty? (App-operands exp))
|
||||
'proc
|
||||
(make-EnvLexicalReference
|
||||
(ensure-natural (sub1 (length (App-operands exp))))
|
||||
#f))
|
||||
'next)]
|
||||
[operand-codes (map (lambda: ([operand : Expression]
|
||||
[target : Target])
|
||||
(compile operand extended-cenv target 'next))
|
||||
(App-operands exp)
|
||||
(build-list (length (App-operands exp))
|
||||
(lambda: ([i : Natural])
|
||||
(if (< i (sub1 (length (App-operands exp))))
|
||||
(make-EnvLexicalReference i #f)
|
||||
'val))))])
|
||||
|
||||
(append-instruction-sequences
|
||||
(make-instruction-sequence `(,(make-PushEnvironment (length (App-operands exp)) #f)))
|
||||
proc-code
|
||||
(juggle-operands operand-codes)
|
||||
(compile-procedure-call cenv
|
||||
extended-cenv
|
||||
(length (App-operands exp))
|
||||
target linkage))))
|
||||
(let ([operator (App-operator exp)])
|
||||
(cond
|
||||
;; FIXME: add special cases here.
|
||||
|
||||
[else
|
||||
(let* ([extended-cenv (append (map (lambda: ([op : ExpressionCore])
|
||||
'?)
|
||||
(App-operands exp))
|
||||
cenv)]
|
||||
[proc-code (compile (App-operator exp)
|
||||
extended-cenv
|
||||
(if (empty? (App-operands exp))
|
||||
'proc
|
||||
(make-EnvLexicalReference
|
||||
(ensure-natural (sub1 (length (App-operands exp))))
|
||||
#f))
|
||||
'next)]
|
||||
[operand-codes (map (lambda: ([operand : Expression]
|
||||
[target : Target])
|
||||
(compile operand extended-cenv target 'next))
|
||||
(App-operands exp)
|
||||
(build-list (length (App-operands exp))
|
||||
(lambda: ([i : Natural])
|
||||
(if (< i (sub1 (length (App-operands exp))))
|
||||
(make-EnvLexicalReference i #f)
|
||||
'val))))])
|
||||
|
||||
(append-instruction-sequences
|
||||
(make-instruction-sequence `(,(make-PushEnvironment (length (App-operands exp)) #f)))
|
||||
proc-code
|
||||
(juggle-operands operand-codes)
|
||||
(compile-procedure-call cenv
|
||||
extended-cenv
|
||||
(length (App-operands exp))
|
||||
target linkage)))])))
|
||||
|
||||
|
||||
|
||||
|
|
@ -305,7 +316,7 @@
|
|||
|
||||
|
||||
|
||||
(: compile-procedure-call (Natural Natural
|
||||
(: compile-procedure-call (CompileTimeEnvironment CompileTimeEnvironment
|
||||
Natural Target Linkage
|
||||
->
|
||||
InstructionSequence))
|
||||
|
|
@ -330,7 +341,7 @@
|
|||
(end-with-compiled-application-linkage
|
||||
compiled-linkage
|
||||
extended-cenv
|
||||
(compile-proc-appl cenv extended-cenv n target compiled-linkage))
|
||||
(compile-proc-appl extended-cenv n target compiled-linkage))
|
||||
|
||||
primitive-branch
|
||||
(end-with-linkage
|
||||
|
|
@ -349,13 +360,13 @@
|
|||
|
||||
|
||||
|
||||
(: compile-proc-appl (Natural Natural Natural Target Linkage -> InstructionSequence))
|
||||
(: compile-proc-appl (CompileTimeEnvironment Natural Target Linkage -> InstructionSequence))
|
||||
;; Three fundamental cases for general compiled-procedure application.
|
||||
;; 1. Non-tail calls that write to val
|
||||
;; 2. Calls in argument position that write to the environment
|
||||
;; 3. Tail calls.
|
||||
;; The Other cases should be excluded.
|
||||
(define (compile-proc-appl cenv-without-args cenv-with-args n target linkage)
|
||||
(define (compile-proc-appl cenv-with-args n target linkage)
|
||||
(cond [(and (eq? target 'val)
|
||||
(not (eq? linkage 'return)))
|
||||
;; This case happens for a function call that isn't in
|
||||
|
|
@ -386,7 +397,7 @@
|
|||
(make-instruction-sequence
|
||||
`(,(make-AssignPrimOpStatement 'val
|
||||
(make-GetCompiledProcedureEntry))
|
||||
,(make-PopEnvironment (ensure-natural (- cenv-with-args n))
|
||||
,(make-PopEnvironment (ensure-natural (- (length cenv-with-args) n))
|
||||
n)
|
||||
,(make-GotoStatement (make-Reg 'val))))]
|
||||
|
||||
|
|
@ -398,16 +409,16 @@
|
|||
(error 'compile "return linkage, target not val: ~s" target)]))
|
||||
|
||||
|
||||
(: compile-let1 (Let1 Natural Target Linkage -> InstructionSequence))
|
||||
(: compile-let1 (Let1 CompileTimeEnvironment Target Linkage -> InstructionSequence))
|
||||
(define (compile-let1 exp cenv target linkage)
|
||||
(let*: ([rhs-code : InstructionSequence
|
||||
(compile (Let1-rhs exp)
|
||||
(add1 cenv)
|
||||
(cons '? cenv)
|
||||
(make-EnvLexicalReference 0 #f)
|
||||
'next)]
|
||||
[after-let1 : Symbol (make-label 'afterLetOne)]
|
||||
[after-body-code : Symbol (make-label 'afterLetBody)]
|
||||
[extended-cenv : Natural (add1 cenv)]
|
||||
[extended-cenv : CompileTimeEnvironment (cons '? cenv)]
|
||||
[let-linkage : Linkage
|
||||
(cond
|
||||
[(eq? linkage 'next)
|
||||
|
|
@ -432,12 +443,14 @@
|
|||
|
||||
|
||||
|
||||
(: compile-let-void (LetVoid Natural Target Linkage -> InstructionSequence))
|
||||
(: compile-let-void (LetVoid CompileTimeEnvironment Target Linkage -> InstructionSequence))
|
||||
(define (compile-let-void exp cenv target linkage)
|
||||
(let*: ([n : Natural (LetVoid-count exp)]
|
||||
[after-let : Symbol (make-label 'afterLet)]
|
||||
[after-body-code : Symbol (make-label 'afterLetBody)]
|
||||
[extended-cenv : Natural (+ cenv (LetVoid-count exp))]
|
||||
[extended-cenv : CompileTimeEnvironment (append (build-list (LetVoid-count exp)
|
||||
(lambda: ([i : Natural]) '?))
|
||||
cenv)]
|
||||
[let-linkage : Linkage
|
||||
(cond
|
||||
[(eq? linkage 'next)
|
||||
|
|
@ -460,7 +473,7 @@
|
|||
after-let))))
|
||||
|
||||
|
||||
(: compile-install-value (InstallValue Natural Target Linkage -> InstructionSequence))
|
||||
(: compile-install-value (InstallValue CompileTimeEnvironment Target Linkage -> InstructionSequence))
|
||||
(define (compile-install-value exp cenv target linkage)
|
||||
(compile (InstallValue-body exp)
|
||||
cenv
|
||||
|
|
@ -469,7 +482,7 @@
|
|||
|
||||
|
||||
|
||||
(: compile-box-environment-value (BoxEnv Natural Target Linkage -> InstructionSequence))
|
||||
(: compile-box-environment-value (BoxEnv CompileTimeEnvironment Target Linkage -> InstructionSequence))
|
||||
(define (compile-box-environment-value exp cenv target linkage)
|
||||
(append-instruction-sequences
|
||||
(make-instruction-sequence
|
||||
|
|
@ -518,3 +531,9 @@
|
|||
(EnvPrefixReference-pos target))]
|
||||
[(PrimitivesReference? target)
|
||||
target]))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
(define-type CompileTimeEnvironment (Listof (U '? 'prefix)))
|
||||
|
|
@ -18,7 +18,7 @@
|
|||
|
||||
|
||||
;; Find where the variable is located in the lexical environment
|
||||
(: find-variable (Symbol CompileTimeEnvironment -> LexicalAddress))
|
||||
(: find-variable (Symbol ParseTimeEnvironment -> LexicalAddress))
|
||||
(define (find-variable name cenv)
|
||||
(: find-pos (Symbol (Listof (U Symbol False)) -> Natural))
|
||||
(define (find-pos sym los)
|
||||
|
|
@ -28,12 +28,12 @@
|
|||
[else
|
||||
(add1 (find-pos sym (cdr los)))]))
|
||||
(let: loop : LexicalAddress
|
||||
([cenv : CompileTimeEnvironment cenv]
|
||||
([cenv : ParseTimeEnvironment cenv]
|
||||
[depth : Natural 0])
|
||||
(cond [(empty? cenv)
|
||||
(error 'find-variable "~s not in lexical environment" name)]
|
||||
[else
|
||||
(let: ([elt : CompileTimeEnvironmentEntry (first cenv)])
|
||||
(let: ([elt : ParseTimeEnvironmentEntry (first cenv)])
|
||||
(cond
|
||||
[(Prefix? elt)
|
||||
(cond [(member name (Prefix-names elt))
|
||||
|
|
@ -67,35 +67,35 @@
|
|||
|
||||
|
||||
(: extend-lexical-environment
|
||||
(CompileTimeEnvironment CompileTimeEnvironmentEntry -> CompileTimeEnvironment))
|
||||
(ParseTimeEnvironment ParseTimeEnvironmentEntry -> ParseTimeEnvironment))
|
||||
;; Extends the lexical environment with procedure bindings.
|
||||
(define (extend-lexical-environment cenv extension)
|
||||
(cons extension cenv))
|
||||
|
||||
|
||||
|
||||
(: extend-lexical-environment/names (CompileTimeEnvironment (Listof Symbol) (Listof Boolean) ->
|
||||
CompileTimeEnvironment))
|
||||
(: extend-lexical-environment/names (ParseTimeEnvironment (Listof Symbol) (Listof Boolean) ->
|
||||
ParseTimeEnvironment))
|
||||
(define (extend-lexical-environment/names cenv names boxed?)
|
||||
(append (map (lambda: ([n : Symbol]
|
||||
[b : Boolean]) (make-NamedBinding n #f b)) names boxed?)
|
||||
cenv))
|
||||
|
||||
(: extend-lexical-environment/parameter-names (CompileTimeEnvironment (Listof Symbol) (Listof Boolean) -> CompileTimeEnvironment))
|
||||
(: extend-lexical-environment/parameter-names (ParseTimeEnvironment (Listof Symbol) (Listof Boolean) -> ParseTimeEnvironment))
|
||||
(define (extend-lexical-environment/parameter-names cenv names boxed?)
|
||||
(append (map (lambda: ([n : Symbol]
|
||||
[b : Boolean])
|
||||
(make-NamedBinding n #t b)) names boxed?)
|
||||
cenv))
|
||||
|
||||
(: extend-lexical-environment/boxed-names (CompileTimeEnvironment (Listof Symbol) -> CompileTimeEnvironment))
|
||||
(: extend-lexical-environment/boxed-names (ParseTimeEnvironment (Listof Symbol) -> ParseTimeEnvironment))
|
||||
(define (extend-lexical-environment/boxed-names cenv names)
|
||||
(append (map (lambda: ([n : Symbol]) (make-NamedBinding n #f #t)) names)
|
||||
cenv))
|
||||
|
||||
|
||||
(: extend-lexical-environment/placeholders
|
||||
(CompileTimeEnvironment Natural -> CompileTimeEnvironment))
|
||||
(ParseTimeEnvironment Natural -> ParseTimeEnvironment))
|
||||
;; Add placeholders to the lexical environment (This represents what happens during procedure application.)
|
||||
(define (extend-lexical-environment/placeholders cenv n)
|
||||
(append (build-list n (lambda: ([i : Natural]) #f))
|
||||
|
|
@ -131,13 +131,13 @@
|
|||
|
||||
|
||||
|
||||
(: lexical-references->compile-time-environment ((Listof EnvReference) CompileTimeEnvironment CompileTimeEnvironment
|
||||
(: lexical-references->compile-time-environment ((Listof EnvReference) ParseTimeEnvironment ParseTimeEnvironment
|
||||
(Listof Symbol)
|
||||
-> CompileTimeEnvironment))
|
||||
-> ParseTimeEnvironment))
|
||||
;; Creates a lexical environment containing the closure's bindings.
|
||||
(define (lexical-references->compile-time-environment refs cenv new-cenv symbols-to-keep)
|
||||
(let: loop : CompileTimeEnvironment ([refs : (Listof EnvReference) (reverse refs)]
|
||||
[new-cenv : CompileTimeEnvironment new-cenv])
|
||||
(let: loop : ParseTimeEnvironment ([refs : (Listof EnvReference) (reverse refs)]
|
||||
[new-cenv : ParseTimeEnvironment new-cenv])
|
||||
(cond
|
||||
[(empty? refs)
|
||||
new-cenv]
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@
|
|||
#:transparent)
|
||||
|
||||
|
||||
(define-type CompileTimeEnvironmentEntry (U Prefix ;; a prefix
|
||||
(define-type ParseTimeEnvironmentEntry (U Prefix ;; a prefix
|
||||
NamedBinding
|
||||
False))
|
||||
|
||||
|
|
@ -28,7 +28,7 @@
|
|||
|
||||
;; A compile-time environment is a (listof (listof symbol)).
|
||||
;; A lexical address is either a 2-tuple (depth pos), or 'not-found.
|
||||
(define-type CompileTimeEnvironment (Listof CompileTimeEnvironmentEntry))
|
||||
(define-type ParseTimeEnvironment (Listof ParseTimeEnvironmentEntry))
|
||||
|
||||
;; A lexical address is a reference to an value in the environment stack.
|
||||
(define-type LexicalAddress (U EnvLexicalReference EnvPrefixReference))
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@
|
|||
(make-Top prefix (parse exp (extend-lexical-environment '() prefix)))))
|
||||
|
||||
|
||||
;; find-prefix: CompileTimeEnvironment -> Natural
|
||||
;; find-prefix: ParseTimeEnvironment -> Natural
|
||||
(define (find-prefix cenv)
|
||||
(cond
|
||||
[(empty? cenv)
|
||||
|
|
@ -25,7 +25,7 @@
|
|||
(add1 (find-prefix (rest cenv)))]))
|
||||
|
||||
|
||||
;; parse: Any CompileTimeEnvironment -> ExpressionCore
|
||||
;; parse: Any ParseTimeEnvironment -> ExpressionCore
|
||||
;; Compile an expression.
|
||||
(define (parse exp cenv)
|
||||
(cond
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user