diff --git a/assemble.rkt b/assemble.rkt index a5f527f..81c3874 100644 --- a/assemble.rkt +++ b/assemble.rkt @@ -244,7 +244,7 @@ EOF (EnvWholePrefixReference-depth a-prefix-ref))) -(: assemble-op-expression ((U PrimitiveOperator TestOperator) (Listof OpArg) -> String)) +(: assemble-op-expression ((U PrimitiveOperator PrimitiveTest) (Listof OpArg) -> String)) (define (assemble-op-expression op-name inputs) (let ([assembled-inputs (map assemble-input inputs)]) (case op-name @@ -274,9 +274,10 @@ EOF (first assembled-inputs) (loop (rest assembled-inputs)))]))])] [(apply-primitive-procedure) - (format "~a(~a)" + (format "~a(~a)" (first assembled-inputs) - (second assembled-inputs))] + ;; FIXME: this doesn't look quite right... + (third assembled-inputs))] [(lexical-address-lookup) (format "(~a).valss[~a][~a]" (third assembled-inputs) @@ -304,7 +305,7 @@ EOF ))) -(: assemble-op-statement (PerformOperator (Listof OpArg) -> String)) +(: assemble-op-statement (PrimitiveCommand (Listof OpArg) -> String)) (define (assemble-op-statement op-name inputs) (let ([assembled-inputs (map assemble-input inputs)]) (case op-name diff --git a/compile.rkt b/compile.rkt index 4b1965e..202793c 100644 --- a/compile.rkt +++ b/compile.rkt @@ -47,10 +47,8 @@ [names : (Listof Symbol) (Prefix-names (Top-prefix top))]) (append-instruction-sequences (make-instruction-sequence - `(,(make-AssignPrimOpStatement 'env - 'extend-environment/prefix - (list (make-Const names) - (make-Reg 'env))))) + `(,(make-PerformStatement 'extend-environment/prefix! + (list (make-Const names))))) (compile (Top-code top) cenv target linkage)))) @@ -61,8 +59,10 @@ [(eq? linkage 'return) (make-instruction-sequence `(,(make-AssignPrimOpStatement 'proc 'read-control-label - (list (make-Reg 'control))) - ,(make-PopEnv (lexical-environment-pop-depth cenv)) + (list)) + ,(make-PopEnv (lexical-environment-pop-depth cenv) + ;; FIXME: not right + 0) ,(make-PopControl) ,(make-GotoStatement (make-Reg 'proc))))] [(eq? linkage 'next) @@ -93,7 +93,8 @@ (make-instruction-sequence `(,(make-AssignPrimOpStatement target 'lexical-address-lookup - (list (make-Const (LocalAddress-depth lexical-pos)) + (list (make-Const + (LocalAddress-depth lexical-pos)) (make-Reg 'env))))))] [(PrefixAddress? lexical-pos) (end-with-linkage linkage @@ -102,8 +103,7 @@ `(,(make-PerformStatement 'check-bound! (list (make-Const (PrefixAddress-depth lexical-pos)) (make-Const (PrefixAddress-pos lexical-pos)) - (make-Const (PrefixAddress-name lexical-pos)) - (make-Reg 'env))) + (make-Const (PrefixAddress-name lexical-pos)))) ,(make-AssignPrimOpStatement target 'toplevel-lookup (list (make-Const (PrefixAddress-depth lexical-pos)) @@ -130,9 +130,7 @@ (make-instruction-sequence `(,(make-PerformStatement 'toplevel-set! (list (make-Const (PrefixAddress-depth lexical-pos)) (make-Const (PrefixAddress-pos lexical-pos)) - (make-Const var) - (make-Reg 'env) - (make-Reg 'val))) + (make-Const var))) ,(make-AssignImmediateStatement target (make-Const 'ok))))))]))) @@ -192,7 +190,6 @@ `(,(make-AssignPrimOpStatement target 'make-compiled-procedure (list* (make-Label proc-entry) - (make-Reg 'env) lexical-references))))) (compile-lambda-body exp cenv lexical-references @@ -216,16 +213,13 @@ [extended-cenv : CompileTimeEnvironment (extend-lexical-environment '() formals)] [extended-cenv : CompileTimeEnvironment - (begin - (lexical-references->compile-time-environment lexical-references cenv extended-cenv))]) + (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))))) + ,(make-PerformStatement 'install-closure-values! + (list (make-Reg 'proc))))) (compile (Lam-body exp) extended-cenv 'val 'return)))) @@ -252,9 +246,6 @@ (make-EnvOffset i) 'val))))]) - ;; FIXME: we need to allocate space for the arguments in the environment. - ;; FIXME: we need to compile each operand especially to write to the correct - ;; environment location. ;; FIXME: we need to push the control. ;; FIXME: at procedure entry, the arguments need to be installed ;; in the environment. We need to install @@ -262,15 +253,15 @@ (append-instruction-sequences (make-instruction-sequence `(,(make-PushEnv (length (App-operands exp))))) proc-code - (install-operands operand-codes) + (juggle-operands operand-codes) (compile-procedure-call extended-cenv (length (App-operands exp)) target linkage)))) -(: install-operands ((Listof InstructionSequence) -> InstructionSequence)) +(: juggle-operands ((Listof InstructionSequence) -> InstructionSequence)) ;; Installs the operators. At the end of this, ;; the procedure lives in 'proc, and the operands on the environment stack. -(define (install-operands operand-codes) +(define (juggle-operands operand-codes) (let: ([n : Natural ;; defensive coding: the operand codes should be nonempty. (max 0 (sub1 (length operand-codes)))]) @@ -294,62 +285,86 @@ (loop (rest ops)))])))) + (: compile-procedure-call (CompileTimeEnvironment Natural Target Linkage -> InstructionSequence)) +;; Assumes the procedure value has been loaded into the proc register. (define (compile-procedure-call cenv n target linkage) (let ([primitive-branch (make-label 'primitiveBranch)] [compiled-branch (make-label 'compiledBranch)] [after-call (make-label 'afterCall)]) (let ([compiled-linkage (if (eq? linkage 'next) after-call linkage)]) + (append-instruction-sequences (make-instruction-sequence `(,(make-TestStatement 'primitive-procedure? 'proc) - ,(make-BranchLabelStatement primitive-branch))) - (append-instruction-sequences - (append-instruction-sequences - compiled-branch - (compile-proc-appl n target compiled-linkage)) - (append-instruction-sequences - primitive-branch - (end-with-linkage linkage - cenv - (make-instruction-sequence - `(,(make-AssignPrimOpStatement target - 'apply-primitive-procedure - (list (make-Reg 'proc) - (make-Const n) - (make-Reg 'env)))))))) + ,(make-BranchLabelStatement primitive-branch))) + + compiled-branch + (compile-proc-appl n target compiled-linkage) + + primitive-branch + (end-with-linkage linkage + cenv + (make-instruction-sequence + `(,(make-AssignPrimOpStatement target + 'apply-primitive-procedure + (list (make-Reg 'proc) + (make-Const n) + (make-Reg 'env)))))) after-call)))) + + (: compile-proc-appl (Natural Target Linkage -> InstructionSequence)) +;; Three fundamental cases for general compiled-procedure application. +;; 1. Non-tail calls that write to val +;; 2. Calls in argument position that write to the environment +;; 3. Tail calls. +;; The Other cases should be excluded. (define (compile-proc-appl n target linkage) - (cond [(and (eq? target 'val) + (cond [(eq? linkage 'next) + ;; This case should be impossible: next linkage can't be used in this position. + (error 'compile "next linkage")] + + [(and (eq? target 'val) (not (eq? linkage 'return))) + ;; This case happens for a function call that isn't in + ;; tail position. (make-instruction-sequence - `(#;,(make-AssignImmediateStatement 'cont (make-Label linkage)) + `(,(make-PushControlFrame linkage) ,(make-AssignPrimOpStatement 'val 'compiled-procedure-entry (list (make-Reg 'proc))) ,(make-GotoStatement (make-Reg 'val))))] + [(and (not (eq? target 'val)) (not (eq? linkage 'return))) + ;; This case happens for evaluating arguments, since the + ;; arguments are being installed into the scratch space. (let ([proc-return (make-label 'procReturn)]) (make-instruction-sequence - `(#;,(make-AssignImmediateStatement 'cont (make-Label proc-return)) + `(,(make-PushControlFrame proc-return) ,(make-AssignPrimOpStatement 'val 'compiled-procedure-entry (list (make-Reg 'proc))) ,(make-GotoStatement (make-Reg 'val)) ,proc-return ,(make-AssignImmediateStatement target (make-Reg 'val)) ,(make-GotoStatement (make-Label linkage)))))] + [(and (eq? target 'val) (eq? linkage 'return)) + ;; This case happens when we're in tail position. ;; FIXME: do tail call stuff! ;; Must shift existing environment to replace (make-instruction-sequence `(,(make-AssignPrimOpStatement 'val 'compiled-procedure-entry (list (make-Reg 'proc))) ,(make-GotoStatement (make-Reg 'val))))] + [(and (not (eq? target 'val)) (eq? linkage 'return)) + ;; This case should be impossible: return linkage should only + ;; occur when we're in tail position, and we're in tail position + ;; only when the target is the val register. (error 'compile "return linkage, target not val: ~s" target)])) diff --git a/il-structs.rkt b/il-structs.rkt index c9131fc..79e9f65 100644 --- a/il-structs.rkt +++ b/il-structs.rkt @@ -51,7 +51,7 @@ PopEnv PopControl PushEnv - PushControl)) + PushControlFrame)) (define-type Statement (U UnlabeledStatement Symbol ;; label )) @@ -65,47 +65,93 @@ #:transparent) -(define-struct: PopEnv ([n : Natural]) #:transparent) -(define-struct: PopControl () #:transparent) +(define-struct: PopEnv ([n : Natural] + [skip : Natural]) + #:transparent) +(define-struct: PopControl () + #:transparent) +(define-struct: PushEnv ([n : Natural]) + #:transparent) -(define-struct: PushEnv ([n : Natural]) #:transparent) -(define-struct: PushControl () #:transparent) +;; Adding a frame for getting back after procedure application. +(define-struct: PushControlFrame ([label : Symbol]) + #:transparent) (define-struct: GotoStatement ([target : (U Label Reg)]) #:transparent) -(define-struct: PerformStatement ([op : PerformOperator] +(define-struct: PerformStatement ([op : PrimitiveCommand] [rands : (Listof (U Label Reg Const))]) #:transparent) -(define-struct: TestStatement ([op : TestOperator] +(define-struct: TestStatement ([op : PrimitiveTest] [register-rand : RegisterSymbol]) #:transparent) (define-struct: BranchLabelStatement ([label : Symbol]) #:transparent) -(define-type PrimitiveOperator (U 'compiled-procedure-entry - 'compiled-procedure-env - 'make-compiled-procedure - - 'false? - 'cons - 'list - 'apply-primitive-procedure +(define-type PrimitiveOperator (U + + ;; register -> label + ;; Get the label from the closure stored in + ;; the register and return it. + 'compiled-procedure-entry + + ;; label LexicalReference * -> closure + 'make-compiled-procedure - 'lexical-address-lookup - 'toplevel-lookup - - 'read-control-label - - 'extend-environment - 'extend-environment/prefix)) + ;; primitive-procedure arity -> any + 'apply-primitive-procedure + + ;; depth -> any + ;; Lookup the value in the environment + 'lexical-address-lookup + + ;; depth pos symbol -> any + ;; lookup the value in the prefix installed in the + ;; environment. + 'toplevel-lookup + + ;; -> label + ;; Grabs the label embedded in the top + ;; of the control stack + 'read-control-label + )) -(define-type TestOperator (U 'false? 'primitive-procedure?)) +(define-type PrimitiveTest (U + + ;; register -> boolean + ;; Meant to branch when the register value is false. + 'false? + + ;; register -> boolean + ;; Meant to branch when the register value is a primitive + ;; procedure + 'primitive-procedure? + )) -(define-type PerformOperator (U 'toplevel-set! - 'lexical-address-set! - 'check-bound!)) +(define-type PrimitiveCommand (U + + ;; depth pos symbol + ;; Assign the value in the val register into + ;; the prefix installed at (depth, pos). + 'toplevel-set! + + ;; depth pos symbol -> void + ;; Check that the value in the prefix has been defined. + ;; If not, raise an error and stop evaluation. + 'check-bound! + + ;; (listof symbol) -> void + ;; Extends the environment with a prefix that holds + ;; lookups to the namespace. + 'extend-environment/prefix! + + ;; register -> void + ;; Adjusts the environment by pushing the values in the + ;; closure (held in the register) into itself. + 'install-closure-values! + ))