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

in the middle of letrec

Browse Source
This commit is contained in:
Danny Yoo 2011-03-25 18:10:26 -04:00
parent 9a40630785
commit c75385278c
6 changed files with 110 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

59
compile.rkt
View File

@ -77,7 +77,10 @@
[(InstallValue? exp)
(loop (InstallValue-body exp))]
[(BoxEnv? exp)
'()])))
'()]
[(LetRec? exp)
(append (apply append (map loop (LetRec-procs exp)))
(loop (LetRec-body exp)))])))
@ -121,7 +124,9 @@
[(InstallValue? exp)
(compile-install-value exp cenv target linkage)]
[(BoxEnv? exp)
(compile-box-environment-value exp cenv target linkage)]))
(compile-box-environment-value exp cenv target linkage)]
[(LetRec? exp)
(compile-let-rec exp cenv target linkage)]))
@ -584,6 +589,56 @@
after-let))))
(: compile-let-rec (LetRec CompileTimeEnvironment Target Linkage -> InstructionSequence))
(define (compile-let-rec exp cenv target linkage)
(let*: ([extended-cenv : CompileTimeEnvironment (append (map extract-static-knowledge
(reverse (LetRec-procs exp)))
cenv)]
[n : Natural (length (LetRec-procs exp))]
[after-body-code : Linkage (make-label 'afterBodyCode)]
[letrec-linkage : Linkage (cond
[(eq? linkage 'next)
'next]
[(eq? linkage 'return)
'return]
[(symbol? linkage)
after-body-code])])
(end-with-linkage
linkage
extended-cenv
(append-instruction-sequences
(make-instruction-sequence `(,(make-PushEnvironment n #f)))
;; Install each of the closure shells
(apply append-instruction-sequences
(map (lambda: ([lam : Lam]
[i : Natural])
(compile-lambda lam
extended-cenv
(make-EnvLexicalReference i #f)
'next))
(LetRec-procs exp)
(build-list n (lambda: ([i : Natural]) (ensure-natural (- n 1 i))))))
;; Fix the closure maps of each
(apply append-instruction-sequences
(map (lambda: ([lam : Lam]
[i : Natural])
(make-instruction-sequence
`(,(make-PerformStatement
(make-FixClosureShellMap! i (Lam-closure-map lam))))))
(LetRec-procs exp)
(build-list n (lambda: ([i : Natural]) (ensure-natural (- n 1 i))))))
;; Compile the body
(compile (LetRec-body exp) extended-cenv (adjust-target-depth target n) letrec-linkage)
after-body-code
(make-instruction-sequence `(,(make-PopEnvironment n 0)))))))
(: compile-install-value (InstallValue CompileTimeEnvironment Target Linkage -> InstructionSequence))
(define (compile-install-value exp cenv target linkage)
(compile (InstallValue-body exp)

5
expression-structs.rkt
View File

@ -11,6 +11,7 @@
Branch Lam Seq App
Let1
LetVoid
LetRec
InstallValue
BoxEnv))
@ -54,6 +55,10 @@
[boxes? : Boolean])
#:transparent)
(define-struct: LetRec ([procs : (Listof Lam)]
[body : ExpressionCore])
#:transparent)
(define-struct: InstallValue ([depth : Natural]
[body : ExpressionCore]
[box? : Boolean])

6
il-structs.rkt
View File

@ -199,6 +199,11 @@
(define-struct: InstallClosureValues! ()
#:transparent)
(define-struct: FixClosureShellMap! (;; depth: where the closure shell is located in the environment
[depth : Natural]
[closed-vals : (Listof Natural)])
#:transparent)
;; Changes over the control located at the given argument from the structure in env[1]
(define-struct: RestoreControl! ())
@ -213,6 +218,7 @@
CheckClosureArity!
ExtendEnvironment/Prefix!
InstallClosureValues!
FixClosureShellMap!
RestoreEnvironment!
RestoreControl!))

41
parse.rkt
View File

@ -437,25 +437,40 @@
;; Letrec's currently doing a set! kind of thing.
(define (parse-letrec exp cenv)
(let ([vars (let-variables exp)]
[rhss (let-rhss exp)]
[body (let-body exp)])
(let* ([vars (let-variables exp)]
[rhss (let-rhss exp)]
[body (let-body exp)]
[n (length vars)])
(cond
[(= 0 (length vars))
(parse `(begin ,@body) cenv)]
[(and (andmap lambda? rhss)
(empty? (list-intersection
vars
(append (find-mutated-names body)
(apply append (map find-mutated-names rhss))))))
(let ([new-cenv (extend-lexical-environment/names cenv
(reverse vars)
(build-list n (lambda (i) #f)))])
;; Semantics: allocate a closure shell for each lambda form in procs.
;; Install them in reverse order, so that the closure shell for the last element
;; in procs is at stack position 0.
(make-LetRec (map (lambda (rhs) (parse rhs new-cenv))
rhss)
(parse `(begin ,@body) new-cenv)))]
[else
(let ([new-cenv (extend-lexical-environment/boxed-names cenv vars)])
(let ([new-cenv (extend-lexical-environment/boxed-names cenv (reverse vars))])
(make-LetVoid (length vars)
(seq (append
(map (lambda (var rhs index)
(make-InstallValue index
(parameterize ([current-defined-name var])
(parse rhs new-cenv))
#t))
vars
rhss
(build-list (length rhss) (lambda (i) i)))
(list (parse `(begin ,@body) new-cenv))))
(map (lambda (var rhs index)
(make-InstallValue (- n 1 index)
(parameterize ([current-defined-name var])
(parse rhs new-cenv))
#t))
vars
rhss
(build-list (length rhss) (lambda (i) i)))
(list (parse `(begin ,@body) new-cenv))))
#t))])))

3
simulator-structs.rkt
View File

@ -77,7 +77,8 @@
[arity : Natural]
[vals : (Listof SlotValue)]
[display-name : (U Symbol False)])
#:transparent)
#:transparent
#:mutable)

12
simulator.rkt
View File

@ -232,6 +232,13 @@
(error 'step-perform "Procedure register doesn't hold a procedure: ~s"
a-proc)]))]
[(FixClosureShellMap!? op)
(let: ([a-closure-shell : closure (ensure-closure (env-ref m (FixClosureShellMap!-depth op)))])
(set-closure-vals! a-closure-shell
(map (lambda: ([d : Natural]) (env-ref m d))
(FixClosureShellMap!-closed-vals op)))
'ok)]
[(RestoreControl!? op)
(set-machine-control! m (CapturedControl-frames (ensure-CapturedControl (env-ref m 0))))
'ok]
@ -385,6 +392,11 @@
v
(error 'ensure-closure)))
(: ensure-closure (SlotValue -> closure))
(define (ensure-closure v)
(if (closure? v)
v
(error 'ensure-closure)))
(: ensure-symbol (Any -> Symbol))