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

trying to fix the popenv stuff

Browse Source
This commit is contained in:
Danny Yoo 2011-03-07 23:08:58 -05:00
parent 470730bcb8
commit ab2f16508e
3 changed files with 88 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
compile.rkt
View File

@ -55,10 +55,10 @@
(define (compile-top top cenv target linkage)
(let*: ([cenv : CompileTimeEnvironment (extend-lexical-environment cenv (Top-prefix top))]
[names : (Listof Symbol) (Prefix-names (Top-prefix top))])
(append-instruction-sequences
(make-instruction-sequence
`(,(make-PerformStatement (make-ExtendEnvironment/Prefix! names))))
(compile (Top-code top) cenv target linkage))))
(append-instruction-sequences
(make-instruction-sequence
`(,(make-PerformStatement (make-ExtendEnvironment/Prefix! names))))
(compile (Top-code top) cenv target linkage))))
@ -69,7 +69,7 @@
(make-instruction-sequence `(,(make-AssignPrimOpStatement 'proc
(make-GetControlStackLabel))
,(make-PopEnvironment (lexical-environment-pop-depth cenv)
0)
0)
,(make-PopControlFrame)
,(make-GotoStatement (make-Reg 'proc))))]
[(eq? linkage 'next)
@ -86,7 +86,7 @@
(: end-with-compiled-application-linkage (Linkage CompileTimeEnvironment InstructionSequence ->
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)
(append-instruction-sequences instruction-sequence
@ -238,7 +238,7 @@
(: compile-lambda-body (Lam CompileTimeEnvironment
(Listof EnvReference)
@ -249,7 +249,9 @@
(define (compile-lambda-body exp cenv lexical-references proc-entry)
(let*: ([formals : (Listof Symbol) (Lam-parameters exp)]
[extended-cenv : CompileTimeEnvironment
(extend-lexical-environment '() formals)]
(extend-lexical-environment
'()
(make-FunctionExtension formals))]
[extended-cenv : CompileTimeEnvironment
(lexical-references->compile-time-environment
lexical-references cenv extended-cenv)])
@ -282,7 +284,7 @@
(if (< i (sub1 (length (App-operands exp))))
(make-EnvLexicalReference i)
'val))))])
;; FIXME: we need to push the control.
;; FIXME: at procedure entry, the arguments need to be installed
;; in the environment. We need to install
@ -292,7 +294,7 @@
proc-code
(juggle-operands operand-codes)
(compile-procedure-call extended-cenv (length (App-operands exp)) target linkage))))
(: juggle-operands ((Listof InstructionSequence) -> InstructionSequence))
@ -348,15 +350,14 @@
compiled-linkage
cenv
(compile-proc-appl cenv n target compiled-linkage))
primitive-branch
(end-with-linkage linkage
cenv
(make-instruction-sequence
`(,(make-AssignPrimOpStatement
target
(make-ApplyPrimitiveProcedure n))
,(make-PopEnvironment n 0))))
(make-ApplyPrimitiveProcedure n)))))
after-call))))
@ -401,7 +402,7 @@
,(make-PopEnvironment (max 0 (- (lexical-environment-pop-depth cenv) n))
n)
,(make-GotoStatement (make-Reg 'val))))]
[(and (not (eq? target 'val))
(eq? linkage 'return))
;; This case should be impossible: return linkage should only
@ -419,8 +420,8 @@
(: append-2-sequences (InstructionSequence InstructionSequence -> InstructionSequence))
(define (append-2-sequences seq1 seq2)
(make-instruction-sequence
(append (statements seq1) (statements seq2))))
(make-instruction-sequence
(append (statements seq1) (statements seq2))))
(: append-seq-list ((Listof InstructionSequence) -> InstructionSequence))
(define (append-seq-list seqs)

79
lexical-env.rkt
View File

@ -30,44 +30,81 @@
[else
(let: ([elt : CompileTimeEnvironmentEntry (first cenv)])
(cond
[(eq? #f elt)
(loop (rest cenv) (add1 depth))]
[(Prefix? elt)
(cond [(member name (Prefix-names elt))
(make-PrefixAddress depth (find-pos name (Prefix-names elt)) name)]
[else
(loop (rest cenv) (add1 depth))])]
[(symbol? elt)
(cond
[(eq? name elt)
(make-LocalAddress depth)]
[else
(loop (rest cenv) (add1 depth))])]))])))
[(FunctionExtension? elt)
(let: ([index : (U #f Natural) (list-index name (FunctionExtension-names elt))])
(cond
[(boolean? index)
(loop (rest cenv) (+ depth (length (FunctionExtension-names elt))))]
[else
(make-LocalAddress (+ depth index))]))]
[(LocalExtension? elt)
(let: ([index : (U #f Natural) (list-index name (LocalExtension-names elt))])
(cond
[(boolean? index)
(loop (rest cenv) (+ depth (length (LocalExtension-names elt))))]
[else
(make-LocalAddress (+ depth index))]))]
[(TemporaryExtension? elt)
(loop (rest cenv)
(+ depth (TemporaryExtension-n elt)))]))])))
(: list-index (All (A) A (Listof A) -> (U #f Natural)))
(define (list-index x l)
(let loop ([i 0]
[l l])
(cond
[(empty? l)
#f]
[(eq? x (first l))
i]
[else
(loop (add1 i) (rest l))])))
(: extend-lexical-environment (CompileTimeEnvironment (U (Listof Symbol) Prefix) -> CompileTimeEnvironment))
(: extend-lexical-environment
(CompileTimeEnvironment CompileTimeEnvironmentEntry -> CompileTimeEnvironment))
;; Extends the lexical environment with procedure bindings.
(define (extend-lexical-environment cenv names)
(cond [(Prefix? names)
(cons names cenv)]
[(list? names)
(append names cenv)]))
(define (extend-lexical-environment cenv extension)
(cons extension cenv))
(: extend-lexical-environment/placeholders (CompileTimeEnvironment Natural -> CompileTimeEnvironment))
(: extend-lexical-environment/placeholders
(CompileTimeEnvironment Natural -> CompileTimeEnvironment))
;; Add placeholders to the lexical environment (This represents what happens during procedure application.)
(define (extend-lexical-environment/placeholders cenv n)
(cond [(= n 0)
cenv]
[else
(extend-lexical-environment/placeholders (cons #f cenv) (sub1 n))]))
(cons (make-TemporaryExtension n)
cenv))
(: lexical-environment-pop-depth (CompileTimeEnvironment -> Natural))
;; Computes how many environments we need to pop till we clear the procedure arguments.
(define (lexical-environment-pop-depth cenv)
(length cenv))
(cond
[(empty? cenv)
0]
[else
(let: ([entry : CompileTimeEnvironmentEntry (first cenv)])
(cond
[(Prefix? entry)
(+ (length (Prefix-names entry))
(lexical-environment-pop-depth (rest cenv)))]
[(FunctionExtension? entry)
(length (FunctionExtension-names entry))]
[(LocalExtension? entry)
(+ (length (LocalExtension-names entry))
(lexical-environment-pop-depth (rest cenv)))]
[(TemporaryExtension? entry)
(+ (TemporaryExtension-n entry)
(lexical-environment-pop-depth (rest cenv)))]))]))

18
lexical-structs.rkt
View File

@ -6,19 +6,27 @@
;; Lexical environments
;; A toplevel prefix contains a list of toplevel variables.
(define-struct: Prefix ([names : (Listof Symbol)])
#:transparent)
(define-struct: FunctionExtension ([names : (Listof Symbol)])
#:transparent)
(define-struct: LocalExtension ([names : (Listof Symbol)])
#:transparent)
(define-struct: TemporaryExtension ([n : Natural])
#:transparent)
(define-type CompileTimeEnvironmentEntry (U Prefix ;; a prefix
FunctionExtension
LocalExtension
TemporaryExtension))
(define-type CompileTimeEnvironmentEntry (U False ;; placeholder for temporary space
Symbol ;; lexically bound local identiifer
Prefix ;; a prefix
))
;; 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))