diff --git a/compile.rkt b/compile.rkt index ff6b722..4fe061c 100644 --- a/compile.rkt +++ b/compile.rkt @@ -55,10 +55,10 @@ (define (compile-top top cenv target linkage) (let*: ([cenv : CompileTimeEnvironment (extend-lexical-environment cenv (Top-prefix top))] [names : (Listof Symbol) (Prefix-names (Top-prefix top))]) - (append-instruction-sequences - (make-instruction-sequence - `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! names)))) - (compile (Top-code top) cenv target linkage)))) + (append-instruction-sequences + (make-instruction-sequence + `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! names)))) + (compile (Top-code top) cenv target linkage)))) @@ -69,7 +69,7 @@ (make-instruction-sequence `(,(make-AssignPrimOpStatement 'proc (make-GetControlStackLabel)) ,(make-PopEnvironment (lexical-environment-pop-depth cenv) - 0) + 0) ,(make-PopControlFrame) ,(make-GotoStatement (make-Reg 'proc))))] [(eq? linkage 'next) @@ -86,7 +86,7 @@ (: end-with-compiled-application-linkage (Linkage CompileTimeEnvironment InstructionSequence -> - InstructionSequence)) + InstructionSequence)) ;; Add linkage for applications; we need to specialize this to preserve tail calls. (define (end-with-compiled-application-linkage linkage cenv instruction-sequence) (append-instruction-sequences instruction-sequence @@ -238,7 +238,7 @@ - + (: compile-lambda-body (Lam CompileTimeEnvironment (Listof EnvReference) @@ -249,7 +249,9 @@ (define (compile-lambda-body exp cenv lexical-references proc-entry) (let*: ([formals : (Listof Symbol) (Lam-parameters exp)] [extended-cenv : CompileTimeEnvironment - (extend-lexical-environment '() formals)] + (extend-lexical-environment + '() + (make-FunctionExtension formals))] [extended-cenv : CompileTimeEnvironment (lexical-references->compile-time-environment lexical-references cenv extended-cenv)]) @@ -282,7 +284,7 @@ (if (< i (sub1 (length (App-operands exp)))) (make-EnvLexicalReference i) 'val))))]) - + ;; FIXME: we need to push the control. ;; FIXME: at procedure entry, the arguments need to be installed ;; in the environment. We need to install @@ -292,7 +294,7 @@ proc-code (juggle-operands operand-codes) (compile-procedure-call extended-cenv (length (App-operands exp)) target linkage)))) - + (: juggle-operands ((Listof InstructionSequence) -> InstructionSequence)) @@ -348,15 +350,14 @@ compiled-linkage cenv (compile-proc-appl cenv n target compiled-linkage)) - + primitive-branch (end-with-linkage linkage cenv (make-instruction-sequence `(,(make-AssignPrimOpStatement target - (make-ApplyPrimitiveProcedure n)) - ,(make-PopEnvironment n 0)))) + (make-ApplyPrimitiveProcedure n))))) after-call)))) @@ -401,7 +402,7 @@ ,(make-PopEnvironment (max 0 (- (lexical-environment-pop-depth cenv) n)) n) ,(make-GotoStatement (make-Reg 'val))))] - + [(and (not (eq? target 'val)) (eq? linkage 'return)) ;; This case should be impossible: return linkage should only @@ -419,8 +420,8 @@ (: append-2-sequences (InstructionSequence InstructionSequence -> InstructionSequence)) (define (append-2-sequences seq1 seq2) - (make-instruction-sequence - (append (statements seq1) (statements seq2)))) + (make-instruction-sequence + (append (statements seq1) (statements seq2)))) (: append-seq-list ((Listof InstructionSequence) -> InstructionSequence)) (define (append-seq-list seqs) diff --git a/lexical-env.rkt b/lexical-env.rkt index fc6ef1f..7d59b45 100644 --- a/lexical-env.rkt +++ b/lexical-env.rkt @@ -30,44 +30,81 @@ [else (let: ([elt : CompileTimeEnvironmentEntry (first cenv)]) (cond - [(eq? #f elt) - (loop (rest cenv) (add1 depth))] [(Prefix? elt) (cond [(member name (Prefix-names elt)) (make-PrefixAddress depth (find-pos name (Prefix-names elt)) name)] [else (loop (rest cenv) (add1 depth))])] - [(symbol? elt) - (cond - [(eq? name elt) - (make-LocalAddress depth)] - [else - (loop (rest cenv) (add1 depth))])]))]))) + + [(FunctionExtension? elt) + (let: ([index : (U #f Natural) (list-index name (FunctionExtension-names elt))]) + (cond + [(boolean? index) + (loop (rest cenv) (+ depth (length (FunctionExtension-names elt))))] + [else + (make-LocalAddress (+ depth index))]))] + + [(LocalExtension? elt) + (let: ([index : (U #f Natural) (list-index name (LocalExtension-names elt))]) + (cond + [(boolean? index) + (loop (rest cenv) (+ depth (length (LocalExtension-names elt))))] + [else + (make-LocalAddress (+ depth index))]))] + + [(TemporaryExtension? elt) + (loop (rest cenv) + (+ depth (TemporaryExtension-n elt)))]))]))) + +(: list-index (All (A) A (Listof A) -> (U #f Natural))) +(define (list-index x l) + (let loop ([i 0] + [l l]) + (cond + [(empty? l) + #f] + [(eq? x (first l)) + i] + [else + (loop (add1 i) (rest l))]))) - -(: extend-lexical-environment (CompileTimeEnvironment (U (Listof Symbol) Prefix) -> CompileTimeEnvironment)) +(: extend-lexical-environment + (CompileTimeEnvironment CompileTimeEnvironmentEntry -> CompileTimeEnvironment)) ;; Extends the lexical environment with procedure bindings. -(define (extend-lexical-environment cenv names) - (cond [(Prefix? names) - (cons names cenv)] - [(list? names) - (append names cenv)])) +(define (extend-lexical-environment cenv extension) + (cons extension cenv)) -(: extend-lexical-environment/placeholders (CompileTimeEnvironment Natural -> CompileTimeEnvironment)) +(: extend-lexical-environment/placeholders + (CompileTimeEnvironment Natural -> CompileTimeEnvironment)) ;; Add placeholders to the lexical environment (This represents what happens during procedure application.) (define (extend-lexical-environment/placeholders cenv n) - (cond [(= n 0) - cenv] - [else - (extend-lexical-environment/placeholders (cons #f cenv) (sub1 n))])) + (cons (make-TemporaryExtension n) + 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) - (length cenv)) + (cond + [(empty? cenv) + 0] + [else + (let: ([entry : CompileTimeEnvironmentEntry (first cenv)]) + (cond + [(Prefix? entry) + (+ (length (Prefix-names entry)) + (lexical-environment-pop-depth (rest cenv)))] + [(FunctionExtension? entry) + (length (FunctionExtension-names entry))] + [(LocalExtension? entry) + (+ (length (LocalExtension-names entry)) + (lexical-environment-pop-depth (rest cenv)))] + [(TemporaryExtension? entry) + (+ (TemporaryExtension-n entry) + (lexical-environment-pop-depth (rest cenv)))]))])) + diff --git a/lexical-structs.rkt b/lexical-structs.rkt index 4fa5647..dc27a49 100644 --- a/lexical-structs.rkt +++ b/lexical-structs.rkt @@ -6,19 +6,27 @@ ;; Lexical environments + ;; A toplevel prefix contains a list of toplevel variables. (define-struct: Prefix ([names : (Listof Symbol)]) #:transparent) +(define-struct: FunctionExtension ([names : (Listof Symbol)]) + #:transparent) + +(define-struct: LocalExtension ([names : (Listof Symbol)]) + #:transparent) + +(define-struct: TemporaryExtension ([n : Natural]) + #:transparent) +(define-type CompileTimeEnvironmentEntry (U Prefix ;; a prefix + FunctionExtension + LocalExtension + TemporaryExtension)) -(define-type CompileTimeEnvironmentEntry (U False ;; placeholder for temporary space - Symbol ;; lexically bound local identiifer - Prefix ;; a prefix - )) - ;; 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 CompileTimeEnvironmentEntry))