diff --git a/compile.rkt b/compile.rkt index 895a325..d994b62 100644 --- a/compile.rkt +++ b/compile.rkt @@ -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) diff --git a/expression-structs.rkt b/expression-structs.rkt index cc77352..cdd2c57 100644 --- a/expression-structs.rkt +++ b/expression-structs.rkt @@ -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]) diff --git a/il-structs.rkt b/il-structs.rkt index a368647..53526ab 100644 --- a/il-structs.rkt +++ b/il-structs.rkt @@ -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!)) diff --git a/parse.rkt b/parse.rkt index 99e7173..d89941a 100644 --- a/parse.rkt +++ b/parse.rkt @@ -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))]))) diff --git a/simulator-structs.rkt b/simulator-structs.rkt index a06000b..0dfb8d8 100644 --- a/simulator-structs.rkt +++ b/simulator-structs.rkt @@ -77,7 +77,8 @@ [arity : Natural] [vals : (Listof SlotValue)] [display-name : (U Symbol False)]) - #:transparent) + #:transparent + #:mutable) diff --git a/simulator.rkt b/simulator.rkt index 9d73a74..c170bac 100644 --- a/simulator.rkt +++ b/simulator.rkt @@ -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))