diff --git a/compile.rkt b/compile.rkt index 202793c..0e95d5a 100644 --- a/compile.rkt +++ b/compile.rkt @@ -58,8 +58,7 @@ (cond [(eq? linkage 'return) (make-instruction-sequence `(,(make-AssignPrimOpStatement 'proc - 'read-control-label - (list)) + (make-GetControlStackLabel)) ,(make-PopEnv (lexical-environment-pop-depth cenv) ;; FIXME: not right 0) @@ -91,11 +90,9 @@ (end-with-linkage linkage cenv (make-instruction-sequence - `(,(make-AssignPrimOpStatement target - 'lexical-address-lookup - (list (make-Const - (LocalAddress-depth lexical-pos)) - (make-Reg 'env))))))] + `(,(make-AssignPrimOpStatement + target + (make-LookupLexicalAddress (LocalAddress-depth lexical-pos))))))] [(PrefixAddress? lexical-pos) (end-with-linkage linkage cenv @@ -104,12 +101,12 @@ (list (make-Const (PrefixAddress-depth lexical-pos)) (make-Const (PrefixAddress-pos lexical-pos)) (make-Const (PrefixAddress-name lexical-pos)))) - ,(make-AssignPrimOpStatement target - 'toplevel-lookup - (list (make-Const (PrefixAddress-depth lexical-pos)) - (make-Const (PrefixAddress-pos lexical-pos)) - (make-Const (PrefixAddress-name lexical-pos)) - (make-Reg 'env))))))]))) + ,(make-AssignPrimOpStatement + target + (make-LookupToplevelAddress + (PrefixAddress-depth lexical-pos) + (PrefixAddress-pos lexical-pos) + (PrefixAddress-name lexical-pos))))))]))) (: compile-definition (Def CompileTimeEnvironment Target Linkage -> InstructionSequence)) @@ -184,13 +181,13 @@ [lexical-references : (Listof (U EnvLexicalReference EnvWholePrefixReference)) (collect-lexical-references lexical-addresses)]) (append-instruction-sequences - (end-with-linkage lambda-linkage - cenv - (make-instruction-sequence - `(,(make-AssignPrimOpStatement target - 'make-compiled-procedure - (list* (make-Label proc-entry) - lexical-references))))) + (end-with-linkage + lambda-linkage + cenv + (make-instruction-sequence + `(,(make-AssignPrimOpStatement target + (make-MakeCompiledProcedure proc-entry + lexical-references))))) (compile-lambda-body exp cenv lexical-references proc-entry) @@ -306,11 +303,9 @@ (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-AssignPrimOpStatement + target + (make-ApplyPrimitiveProcedure n))))) after-call)))) @@ -332,8 +327,7 @@ ;; tail position. (make-instruction-sequence `(,(make-PushControlFrame linkage) - ,(make-AssignPrimOpStatement 'val 'compiled-procedure-entry - (list (make-Reg 'proc))) + ,(make-AssignPrimOpStatement 'val (make-GetCompiledProcedureEntry)) ,(make-GotoStatement (make-Reg 'val))))] [(and (not (eq? target 'val)) @@ -343,8 +337,8 @@ (let ([proc-return (make-label 'procReturn)]) (make-instruction-sequence `(,(make-PushControlFrame proc-return) - ,(make-AssignPrimOpStatement 'val 'compiled-procedure-entry - (list (make-Reg 'proc))) + ,(make-AssignPrimOpStatement 'val + (make-GetCompiledProcedureEntry)) ,(make-GotoStatement (make-Reg 'val)) ,proc-return ,(make-AssignImmediateStatement target (make-Reg 'val)) @@ -356,8 +350,9 @@ ;; 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-AssignPrimOpStatement 'val + (make-GetCompiledProcedureEntry)) + ;; FIXME: shift off the environment? ,(make-GotoStatement (make-Reg 'val))))] [(and (not (eq? target 'val)) diff --git a/il-structs.rkt b/il-structs.rkt index 79e9f65..cb11492 100644 --- a/il-structs.rkt +++ b/il-structs.rkt @@ -35,6 +35,9 @@ #:transparent) +(define-type LexicalReference (U EnvLexicalReference + EnvWholePrefixReference)) + @@ -60,8 +63,7 @@ [value : OpArg]) #:transparent) (define-struct: AssignPrimOpStatement ([target : Target] - [op : PrimitiveOperator] - [rands : (Listof OpArg)]) + [op : PrimitiveOperator]) #:transparent) @@ -90,33 +92,50 @@ -(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 - - ;; 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 - )) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Primitive Operators + +;; The operators that return values, that are used in AssignPrimopStatement. +(define-type PrimitiveOperator (U GetCompiledProcedureEntry + MakeCompiledProcedure + ApplyPrimitiveProcedure + LookupLexicalAddress + LookupToplevelAddress + GetControlStackLabel)) + +;; Gets the label from the closure stored in the 'proc register and returns it. +(define-struct: GetCompiledProcedureEntry () + #:transparent) + +;; Constructs a closure, given the label and the set of lexical references +;; into the environment that the closure needs to close over. +(define-struct: MakeCompiledProcedure ([label : Symbol] + [closed-vals : (Listof LexicalReference)]) + #: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. +(define-struct: ApplyPrimitiveProcedure ([arity : Natural]) + #:transparent) + +;; Gets the value stored at the given depth in the environment. +(define-struct: LookupLexicalAddress ([depth : Natural]) + #:transparent) + +;; Looks up the value in the prefix installed in the environment. +(define-struct: LookupToplevelAddress ([depth : Natural] + [pos : Natural] + [name : Symbol]) + #:transparent) + +;; Gets the return address embedded at the top of the control stack. +(define-struct: GetControlStackLabel () + #:transparent) + + + (define-type PrimitiveTest (U