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

79
lexical-env.rkt
View File

@ -30,44 +30,81 @@
[else [else
(let: ([elt : CompileTimeEnvironmentEntry (first cenv)]) (let: ([elt : CompileTimeEnvironmentEntry (first cenv)])
(cond (cond
[(eq? #f elt)
(loop (rest cenv) (add1 depth))]
[(Prefix? elt) [(Prefix? elt)
(cond [(member name (Prefix-names elt)) (cond [(member name (Prefix-names elt))
(make-PrefixAddress depth (find-pos name (Prefix-names elt)) name)] (make-PrefixAddress depth (find-pos name (Prefix-names elt)) name)]
[else [else
(loop (rest cenv) (add1 depth))])] (loop (rest cenv) (add1 depth))])]
[(symbol? elt)
(cond [(FunctionExtension? elt)
[(eq? name elt) (let: ([index : (U #f Natural) (list-index name (FunctionExtension-names elt))])
(make-LocalAddress depth)] (cond
[else [(boolean? index)
(loop (rest cenv) (add1 depth))])]))]))) (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
(: extend-lexical-environment (CompileTimeEnvironment (U (Listof Symbol) Prefix) -> CompileTimeEnvironment)) (CompileTimeEnvironment CompileTimeEnvironmentEntry -> CompileTimeEnvironment))
;; Extends the lexical environment with procedure bindings. ;; Extends the lexical environment with procedure bindings.
(define (extend-lexical-environment cenv names) (define (extend-lexical-environment cenv extension)
(cond [(Prefix? names) (cons extension cenv))
(cons names cenv)]
[(list? names)
(append names 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.) ;; Add placeholders to the lexical environment (This represents what happens during procedure application.)
(define (extend-lexical-environment/placeholders cenv n) (define (extend-lexical-environment/placeholders cenv n)
(cond [(= n 0) (cons (make-TemporaryExtension n)
cenv] cenv))
[else
(extend-lexical-environment/placeholders (cons #f cenv) (sub1 n))]))
(: lexical-environment-pop-depth (CompileTimeEnvironment -> Natural)) (: lexical-environment-pop-depth (CompileTimeEnvironment -> Natural))
;; Computes how many environments we need to pop till we clear the procedure arguments. ;; Computes how many environments we need to pop till we clear the procedure arguments.
(define (lexical-environment-pop-depth cenv) (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 ;; Lexical environments
;; A toplevel prefix contains a list of toplevel variables. ;; A toplevel prefix contains a list of toplevel variables.
(define-struct: Prefix ([names : (Listof Symbol)]) (define-struct: Prefix ([names : (Listof Symbol)])
#:transparent) #: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 compile-time environment is a (listof (listof symbol)).
;; A lexical address is either a 2-tuple (depth pos), or 'not-found. ;; A lexical address is either a 2-tuple (depth pos), or 'not-found.
(define-type CompileTimeEnvironment (Listof CompileTimeEnvironmentEntry)) (define-type CompileTimeEnvironment (Listof CompileTimeEnvironmentEntry))