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] empty]
[(MakeCompiledProcedure? op) [(MakeCompiledProcedure? op)
(list (MakeCompiledProcedure-label op))] (list (MakeCompiledProcedure-label op))]
[(MakeCompiledProcedureShell? op)
(list (MakeCompiledProcedureShell-label op))]
[(ApplyPrimitiveProcedure? op) [(ApplyPrimitiveProcedure? op)
empty] empty]
[(GetControlStackLabel? op) [(GetControlStackLabel? op)
@ -389,6 +391,12 @@ EOF
", ") ", ")
(assemble-display-name (MakeCompiledProcedure-display-name op)))] (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) [(ApplyPrimitiveProcedure? op)
(format "MACHINE.proc(MACHINE, ~a)" (format "MACHINE.proc(MACHINE, ~a)"
(ApplyPrimitiveProcedure-arity op))] (ApplyPrimitiveProcedure-arity op))]

77
compile.rkt
View File

@ -321,13 +321,34 @@
(Lam-closure-map exp) (Lam-closure-map exp)
(Lam-name 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)) (: compile-lambda-body (Lam CompileTimeEnvironment -> InstructionSequence))
;; Compiles the body of the lambda in the appropriate environment. ;; Compiles the body of the lambda in the appropriate environment.
(define (compile-lambda-body exp cenv) (define (compile-lambda-body exp cenv)
(append-instruction-sequences (append-instruction-sequences
(make-instruction-sequence (make-instruction-sequence
`(,(Lam-entry-label exp) `(,(Lam-entry-label exp)))
,(make-PerformStatement (make-InstallClosureValues!))))
(if (not (empty? (Lam-closure-map exp)))
(make-instruction-sequence `(,(make-PerformStatement (make-InstallClosureValues!))))
empty-instruction-sequence)
(compile (Lam-body exp) (compile (Lam-body exp)
(append (map (lambda: ([d : Natural]) (append (map (lambda: ([d : Natural])
(list-ref cenv d)) (list-ref cenv d))
@ -412,7 +433,9 @@
(make-EnvLexicalReference i #f) (make-EnvLexicalReference i #f)
'val))))]) 'val))))])
(append-instruction-sequences (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 proc-code
(juggle-operands operand-codes) (juggle-operands operand-codes)
(compile-general-procedure-call cenv (compile-general-procedure-call cenv
@ -550,15 +573,18 @@
(end-with-linkage (end-with-linkage
linkage linkage
cenv cenv
(make-instruction-sequence (append-instruction-sequences
`(,(make-AssignPrimOpStatement (make-instruction-sequence
;; Optimization: we put the result directly in the registers, or in `(,(make-AssignPrimOpStatement
;; the appropriate spot on the stack. This takes into account the popenviroment ;; Optimization: we put the result directly in the registers, or in
;; that happens right afterwards. ;; the appropriate spot on the stack. This takes into account the popenviroment
(adjust-target-depth target n) ;; that happens right afterwards.
(make-ApplyPrimitiveProcedure n)) (adjust-target-depth target n)
,(make-PopEnvironment n 0)))) (make-ApplyPrimitiveProcedure n))))
(if (not (= n 0))
(make-instruction-sequence
`(,(make-PopEnvironment n 0)))
empty-instruction-sequence)))
after-call)))) after-call))))
@ -729,15 +755,16 @@
(: compile-let-rec (LetRec CompileTimeEnvironment Target Linkage -> InstructionSequence)) (: compile-let-rec (LetRec CompileTimeEnvironment Target Linkage -> InstructionSequence))
(define (compile-let-rec exp cenv target linkage) (define (compile-let-rec exp cenv target linkage)
(let*: ([extended-cenv : CompileTimeEnvironment (append (map (lambda: ([p : Lam]) (let*: ([extended-cenv : CompileTimeEnvironment
(extract-static-knowledge (append (map (lambda: ([p : Lam])
p (extract-static-knowledge
(append (build-list (length (LetRec-procs exp)) p
(lambda: ([i : Natural]) (append (build-list (length (LetRec-procs exp))
'?)) (lambda: ([i : Natural])
cenv))) '?))
(reverse (LetRec-procs exp))) cenv)))
cenv)] (reverse (LetRec-procs exp)))
cenv)]
[n : Natural (length (LetRec-procs exp))] [n : Natural (length (LetRec-procs exp))]
[after-body-code : Linkage (make-label 'afterBodyCode)] [after-body-code : Linkage (make-label 'afterBodyCode)]
[letrec-linkage : Linkage (cond [letrec-linkage : Linkage (cond
@ -757,10 +784,10 @@
(apply append-instruction-sequences (apply append-instruction-sequences
(map (lambda: ([lam : Lam] (map (lambda: ([lam : Lam]
[i : Natural]) [i : Natural])
(compile-lambda lam (compile-lambda-shell lam
extended-cenv extended-cenv
(make-EnvLexicalReference i #f) (make-EnvLexicalReference i #f)
'next)) 'next))
(LetRec-procs exp) (LetRec-procs exp)
(build-list n (lambda: ([i : Natural]) (ensure-natural (- n 1 i)))))) (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. ;; The operators that return values, that are used in AssignPrimopStatement.
(define-type PrimitiveOperator (U GetCompiledProcedureEntry (define-type PrimitiveOperator (U GetCompiledProcedureEntry
MakeCompiledProcedure MakeCompiledProcedure
MakeCompiledProcedureShell
ApplyPrimitiveProcedure ApplyPrimitiveProcedure
GetControlStackLabel GetControlStackLabel
@ -140,6 +141,14 @@
[display-name : (U Symbol False)]) [display-name : (U Symbol False)])
#:transparent) #: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 ;; 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 ;; the arity number of values that are bound in the environment as arguments
;; to that primitive. ;; to that primitive.

6
simulator.rkt
View File

@ -301,6 +301,12 @@
(MakeCompiledProcedure-closed-vals op)) (MakeCompiledProcedure-closed-vals op))
(MakeCompiledProcedure-display-name op)))] (MakeCompiledProcedure-display-name op)))]
[(MakeCompiledProcedureShell? op)
(target-updater! m (make-closure (MakeCompiledProcedureShell-label op)
(MakeCompiledProcedureShell-arity op)
'()
(MakeCompiledProcedureShell-display-name op)))]
[(ApplyPrimitiveProcedure? op) [(ApplyPrimitiveProcedure? op)
(let: ([prim : SlotValue (machine-proc m)] (let: ([prim : SlotValue (machine-proc m)]
[args : (Listof PrimitiveValue) [args : (Listof PrimitiveValue)

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")) #;(test (read (open-input-file "tests/conform/program0.sch"))
(port->string (open-input-file "tests/conform/expected0.txt"))) (port->string (open-input-file "tests/conform/expected0.txt")))