Trying to clear up procedure application
This commit is contained in:
dyoo
parent
07f5a2a495
commit
e6cb5d87a1
|
|
@ -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
|
||||
|
|
|
|||
103
compile.rkt
103
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)]))
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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!
|
||||
))
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user