diff --git a/assemble.rkt b/assemble.rkt index 575bb8b..ac5849d 100644 --- a/assemble.rkt +++ b/assemble.rkt @@ -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))] diff --git a/compile.rkt b/compile.rkt index 20034a5..de20f45 100644 --- a/compile.rkt +++ b/compile.rkt @@ -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)))))) diff --git a/il-structs.rkt b/il-structs.rkt index a5016fc..84e9597 100644 --- a/il-structs.rkt +++ b/il-structs.rkt @@ -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. diff --git a/simulator.rkt b/simulator.rkt index 6f17fe4..60e0594 100644 --- a/simulator.rkt +++ b/simulator.rkt @@ -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)] diff --git a/test-compiler.rkt b/test-compiler.rkt index 7eddf41..d33ec06 100644 --- a/test-compiler.rkt +++ b/test-compiler.rkt @@ -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")))