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

minor optimization to letrec

Browse Source
This commit is contained in:
Danny Yoo 2011-03-26 23:46:01 -04:00
parent 6387e19157
commit a640cfe083
5 changed files with 95 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
assemble.rkt
View File

@ -131,6 +131,8 @@ EOF
empty]
[(MakeCompiledProcedure? op)
(list (MakeCompiledProcedure-label op))]
[(MakeCompiledProcedureShell? op)
(list (MakeCompiledProcedureShell-label op))]
[(ApplyPrimitiveProcedure? op)
empty]
[(GetControlStackLabel? op)
@ -389,6 +391,12 @@ EOF
", ")
(assemble-display-name (MakeCompiledProcedure-display-name op)))]
[(MakeCompiledProcedureShell? op)
(format "new Closure(~a, ~a, undefined, ~a)"
(MakeCompiledProcedureShell-label op)
(MakeCompiledProcedureShell-arity op)
(assemble-display-name (MakeCompiledProcedureShell-display-name op)))]
[(ApplyPrimitiveProcedure? op)
(format "MACHINE.proc(MACHINE, ~a)"
(ApplyPrimitiveProcedure-arity op))]

77
compile.rkt
View File

@ -321,13 +321,34 @@
(Lam-closure-map exp)
(Lam-name exp)))))))
(: compile-lambda-shell (Lam CompileTimeEnvironment Target Linkage -> InstructionSequence))
;; Write out code for lambda expressions, minus the closure map.
;; Assumption: all of the lambda bodies have already been written out at the top, in -compile.
(define (compile-lambda-shell exp cenv target linkage)
(end-with-linkage
linkage
cenv
(make-instruction-sequence
`(,(make-AssignPrimOpStatement
target
(make-MakeCompiledProcedureShell (Lam-entry-label exp)
(Lam-num-parameters exp)
(Lam-name exp)))))))
(: compile-lambda-body (Lam CompileTimeEnvironment -> InstructionSequence))
;; Compiles the body of the lambda in the appropriate environment.
(define (compile-lambda-body exp cenv)
(append-instruction-sequences
(make-instruction-sequence
`(,(Lam-entry-label exp)
,(make-PerformStatement (make-InstallClosureValues!))))
`(,(Lam-entry-label exp)))
(if (not (empty? (Lam-closure-map exp)))
(make-instruction-sequence `(,(make-PerformStatement (make-InstallClosureValues!))))
empty-instruction-sequence)
(compile (Lam-body exp)
(append (map (lambda: ([d : Natural])
(list-ref cenv d))
@ -412,7 +433,9 @@
(make-EnvLexicalReference i #f)
'val))))])
(append-instruction-sequences
(make-instruction-sequence `(,(make-PushEnvironment (length (App-operands exp)) #f)))
(if (not (empty? (App-operands exp)))
(make-instruction-sequence `(,(make-PushEnvironment (length (App-operands exp)) #f)))
empty-instruction-sequence)
proc-code
(juggle-operands operand-codes)
(compile-general-procedure-call cenv
@ -550,15 +573,18 @@
(end-with-linkage
linkage
cenv
(make-instruction-sequence
`(,(make-AssignPrimOpStatement
;; Optimization: we put the result directly in the registers, or in
;; the appropriate spot on the stack. This takes into account the popenviroment
;; that happens right afterwards.
(adjust-target-depth target n)
(make-ApplyPrimitiveProcedure n))
,(make-PopEnvironment n 0))))
(append-instruction-sequences
(make-instruction-sequence
`(,(make-AssignPrimOpStatement
;; Optimization: we put the result directly in the registers, or in
;; the appropriate spot on the stack. This takes into account the popenviroment
;; that happens right afterwards.
(adjust-target-depth target n)
(make-ApplyPrimitiveProcedure n))))
(if (not (= n 0))
(make-instruction-sequence
`(,(make-PopEnvironment n 0)))
empty-instruction-sequence)))
after-call))))
@ -729,15 +755,16 @@
(: compile-let-rec (LetRec CompileTimeEnvironment Target Linkage -> InstructionSequence))
(define (compile-let-rec exp cenv target linkage)
(let*: ([extended-cenv : CompileTimeEnvironment (append (map (lambda: ([p : Lam])
(extract-static-knowledge
p
(append (build-list (length (LetRec-procs exp))
(lambda: ([i : Natural])
'?))
cenv)))
(reverse (LetRec-procs exp)))
cenv)]
(let*: ([extended-cenv : CompileTimeEnvironment
(append (map (lambda: ([p : Lam])
(extract-static-knowledge
p
(append (build-list (length (LetRec-procs exp))
(lambda: ([i : Natural])
'?))
cenv)))
(reverse (LetRec-procs exp)))
cenv)]
[n : Natural (length (LetRec-procs exp))]
[after-body-code : Linkage (make-label 'afterBodyCode)]
[letrec-linkage : Linkage (cond
@ -757,10 +784,10 @@
(apply append-instruction-sequences
(map (lambda: ([lam : Lam]
[i : Natural])
(compile-lambda lam
extended-cenv
(make-EnvLexicalReference i #f)
'next))
(compile-lambda-shell lam
extended-cenv
(make-EnvLexicalReference i #f)
'next))
(LetRec-procs exp)
(build-list n (lambda: ([i : Natural]) (ensure-natural (- n 1 i))))))

9
il-structs.rkt
View File

@ -117,6 +117,7 @@
;; The operators that return values, that are used in AssignPrimopStatement.
(define-type PrimitiveOperator (U GetCompiledProcedureEntry
MakeCompiledProcedure
MakeCompiledProcedureShell
ApplyPrimitiveProcedure
GetControlStackLabel
@ -140,6 +141,14 @@
[display-name : (U Symbol False)])
#:transparent)
;; Constructs a closure shell. Like MakeCompiledProcedure, but doesn't
;; bother with trying to capture the free variables.
(define-struct: MakeCompiledProcedureShell ([label : Symbol]
[arity : Natural]
[display-name : (U Symbol False)])
#:transparent)
;; Applies the primitive procedure that's stored in the proc register, using
;; the arity number of values that are bound in the environment as arguments
;; to that primitive.

6
simulator.rkt
View File

@ -300,6 +300,12 @@
(map (lambda: ([d : Natural]) (env-ref m d))
(MakeCompiledProcedure-closed-vals op))
(MakeCompiledProcedure-display-name op)))]
[(MakeCompiledProcedureShell? op)
(target-updater! m (make-closure (MakeCompiledProcedureShell-label op)
(MakeCompiledProcedureShell-arity op)
'()
(MakeCompiledProcedureShell-display-name op)))]
[(ApplyPrimitiveProcedure? op)
(let: ([prim : SlotValue (machine-proc m)]

20
test-compiler.rkt
View File

@ -733,6 +733,26 @@
(test '(letrec ([sum-iter (lambda (x acc)
(if (= x 0)
acc
(let* ([y (sub1 x)]
[z (+ x acc)])
(sum-iter y z))))])
(sum-iter 300 0))
45150
#:stack-limit 10
#:control-limit 1)
#;(test (read (open-input-file "tests/conform/program0.sch"))
(port->string (open-input-file "tests/conform/expected0.txt")))