diff --git a/compile.rkt b/compile.rkt index e12e238..b51a0b0 100644 --- a/compile.rkt +++ b/compile.rkt @@ -94,7 +94,6 @@ `(,(make-AssignPrimOpStatement target 'lexical-address-lookup (list (make-Const (LocalAddress-depth lexical-pos)) - (make-Const (LocalAddress-pos lexical-pos)) (make-Reg 'env))))))] [(PrefixAddress? lexical-pos) (end-with-linkage linkage @@ -190,12 +189,6 @@ `(,(make-AssignPrimOpStatement target 'make-compiled-procedure (list* (make-Label proc-entry) - ;; TODO: rather than capture the whole - ;; environment, we need to instead - ;; capture the free variables. - ;; But that requires that we box - ;; up all set!-ed variables, in order - ;; to preserve semantics of set! (make-Reg 'env) lexical-references))))) (compile-lambda-body exp cenv @@ -214,20 +207,23 @@ Linkage -> InstructionSequence)) -;; Compiles the body of the lambda. +;; Compiles the body of the lambda in the appropriate environment. (define (compile-lambda-body exp cenv lexical-references proc-entry) - (let*: ([formals : (Listof Symbol) (Lam-parameters exp)] - [extended-cenv : CompileTimeEnvironment (extend-lexical-environment cenv formals)] - [extended-cenv : CompileTimeEnvironment extended-cenv]) - (append-instruction-sequences - (make-instruction-sequence - `(,proc-entry - ;; FIXME: not right: we need to install the closure values here, - ;; instead of replacing the environment altogether. - ,(make-AssignPrimOpStatement 'env - 'compiled-procedure-env - (list (make-Reg 'proc))))) - (compile (Lam-body exp) extended-cenv 'val 'return)))) + (let*: ([formals : (Listof Symbol) (Lam-parameters exp)] + [extended-cenv : CompileTimeEnvironment + (extend-lexical-environment '() formals)] + [extended-cenv : CompileTimeEnvironment + (begin + (lexical-references->compile-time-environment lexical-references cenv extended-cenv))]) + (append-instruction-sequences + (make-instruction-sequence + `(,proc-entry + ;; FIXME: not right: we need to install the closure values here, + ;; instead of replacing the environment altogether. + ,(make-AssignPrimOpStatement 'env + 'compiled-procedure-env + (list (make-Reg 'proc))))) + (compile (Lam-body exp) extended-cenv 'val 'return)))) diff --git a/il-structs.rkt b/il-structs.rkt index 46c7815..8732d21 100644 --- a/il-structs.rkt +++ b/il-structs.rkt @@ -5,14 +5,41 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - +;; Registers of the machine: (define-type StackRegisterSymbol (U 'control 'env)) -(define-type RegisterSymbol (U StackRegisterSymbol 'val 'proc)) +(define-type AtomicRegisterSymbol (U 'val 'proc)) +(define-type RegisterSymbol (U StackRegisterSymbol AtomicRegisterSymbol)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +;; An operation can refer to the following: +(define-type OpArg (U Const ;; an constant + Label ;; an label + Reg ;; an register + EnvLexicalReference + EnvWholePrefixReference)) + +(define-struct: Label ([name : Symbol]) + #:transparent) +(define-struct: Reg ([name : RegisterSymbol]) + #:transparent) +(define-struct: Const ([const : Any]) + #:transparent) +(define-struct: EnvLexicalReference ([depth : Natural]) + #:transparent) +(define-struct: EnvWholePrefixReference ([depth : Natural]) + #:transparent) + + + + + + + ;; instruction sequences (define-type UnlabeledStatement (U AssignImmediateStatement @@ -38,25 +65,6 @@ #:transparent) - - -(define-struct: Label ([name : Symbol]) - #:transparent) -(define-struct: Reg ([name : RegisterSymbol]) - #:transparent) -(define-struct: Const ([const : Any]) - #:transparent) -(define-struct: EnvLexicalReference ([depth : Natural] - [pos : Natural]) - #:transparent) -(define-struct: EnvWholePrefixReference ([depth : Natural]) - #:transparent) - - -;; An operation can refer to a Const, a Register, the top of the Control stack, -;; or a reference within the lexical environment. -(define-type OpArg (U Const Label Reg EnvLexicalReference EnvWholePrefixReference)) - (define-struct: PopEnv ([n : Natural]) #:transparent) (define-struct: PopControl () #:transparent) diff --git a/lexical-env.rkt b/lexical-env.rkt index 576728c..8c635fa 100644 --- a/lexical-env.rkt +++ b/lexical-env.rkt @@ -31,10 +31,12 @@ (make-PrefixAddress depth (find-pos name (Prefix-names (first cenv))) name)] [else (loop (rest cenv) (add1 depth))])] - [(member name (first cenv)) - (make-LocalAddress depth (find-pos name (first cenv)))] - [else - (loop (rest cenv) (add1 depth))]))) + [(symbol? (first cenv)) + (cond + [(eq? name (first cenv)) + (make-LocalAddress depth)] + [else + (loop (rest cenv) (add1 depth))])]))) @@ -44,21 +46,14 @@ (cond [(Prefix? names) (cons names cenv)] [(list? names) - (cons names cenv)])) - + (append names cenv)])) (: lexical-environment-pop-depth (CompileTimeEnvironment -> Natural)) ;; Computes how many environments we need to pop till we clear the procedure arguments. (define (lexical-environment-pop-depth cenv) - (cond [(empty? cenv) - (error 'lexical-environment-pop-depth "Empty environment")] - [(Prefix? (first cenv)) - 1] - [(list? (first cenv)) - 1])) - + (length cenv)) @@ -80,8 +75,7 @@ (cond [(LocalAddress? addr) (set-insert! lexical-references - (make-EnvLexicalReference (LocalAddress-depth addr) - (LocalAddress-pos addr))) + (make-EnvLexicalReference (LocalAddress-depth addr))) (loop (rest addresses))] [(PrefixAddress? addr) (set-insert! prefix-references @@ -89,17 +83,25 @@ (loop (rest addresses))]))])))) -(: lexical-references->compile-time-environment ((Listof (U EnvLexicalReference EnvWholePrefixReference)) - CompileTimeEnvironment - -> CompileTimeEnvironment)) -(define (lexical-references->compile-time-environment refs cenv) - cenv - #;(cond - [(empty? refs) - cenv] - [else - (let ([a-ref (first refs)]) - (cond - [(EnvLexicalReference? a-ref) - ...]))])) +(define-type EnvReference (U EnvLexicalReference EnvWholePrefixReference)) +(: lexical-references->compile-time-environment ((Listof EnvReference) CompileTimeEnvironment CompileTimeEnvironment + -> CompileTimeEnvironment)) +;; Creates a lexical environment containing the closure's bindings. +(define (lexical-references->compile-time-environment refs cenv new-cenv) + (let: loop : CompileTimeEnvironment ([refs : (Listof EnvReference) (reverse refs)] + [new-cenv : CompileTimeEnvironment new-cenv]) + (cond + [(empty? refs) + new-cenv] + [else + (let: ([a-ref : EnvReference (first refs)]) + (cond + [(EnvLexicalReference? a-ref) + (loop (rest refs) + (cons (list-ref cenv (EnvLexicalReference-depth a-ref)) + new-cenv))] + [(EnvWholePrefixReference? a-ref) + (loop (rest refs) + (cons (list-ref cenv (EnvWholePrefixReference-depth a-ref)) + new-cenv))]))]))) diff --git a/lexical-structs.rkt b/lexical-structs.rkt index 0a4a6cd..173d8d8 100644 --- a/lexical-structs.rkt +++ b/lexical-structs.rkt @@ -12,16 +12,14 @@ ;; A compile-time environment is a (listof (listof symbol)). ;; A lexical address is either a 2-tuple (depth pos), or 'not-found. -(define-type CompileTimeEnvironment (Listof (U (Listof Symbol) +(define-type CompileTimeEnvironment (Listof (U Symbol Prefix))) -(define-type LexicalAddress (U LocalAddress PrefixAddress)) -(define-struct: LocalAddress ([depth : Natural] - [pos : Natural]) - ;; These need to be treated transparently for equality checking. +;; A lexical address is a reference to an value in the environment stack. +(define-type LexicalAddress (U LocalAddress PrefixAddress)) +(define-struct: LocalAddress ([depth : Natural]) #:transparent) (define-struct: PrefixAddress ([depth : Natural] [pos : Natural] [name : Symbol]) - ;; These need to be treated transparently for equality checking. #:transparent) \ No newline at end of file