suzanne.soy/whalesong
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Trying to clear up procedure application

Browse Source
This commit is contained in:
dyoo 2011-03-02 16:42:33 -05:00
parent 07f5a2a495
commit e6cb5d87a1
3 changed files with 136 additions and 74 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
assemble.rkt
View File

@ -244,7 +244,7 @@ EOF
(EnvWholePrefixReference-depth a-prefix-ref))) (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) (define (assemble-op-expression op-name inputs)
(let ([assembled-inputs (map assemble-input inputs)]) (let ([assembled-inputs (map assemble-input inputs)])
(case op-name (case op-name
@ -276,7 +276,8 @@ EOF
[(apply-primitive-procedure) [(apply-primitive-procedure)
(format "~a(~a)" (format "~a(~a)"
(first assembled-inputs) (first assembled-inputs)
(second assembled-inputs))] ;; FIXME: this doesn't look quite right...
(third assembled-inputs))]
[(lexical-address-lookup) [(lexical-address-lookup)
(format "(~a).valss[~a][~a]" (format "(~a).valss[~a][~a]"
(third assembled-inputs) (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) (define (assemble-op-statement op-name inputs)
(let ([assembled-inputs (map assemble-input inputs)]) (let ([assembled-inputs (map assemble-input inputs)])
(case op-name (case op-name

81
compile.rkt
View File

@ -47,10 +47,8 @@
[names : (Listof Symbol) (Prefix-names (Top-prefix top))]) [names : (Listof Symbol) (Prefix-names (Top-prefix top))])
(append-instruction-sequences (append-instruction-sequences
(make-instruction-sequence (make-instruction-sequence
`(,(make-AssignPrimOpStatement 'env `(,(make-PerformStatement 'extend-environment/prefix!
'extend-environment/prefix (list (make-Const names)))))
(list (make-Const names)
(make-Reg 'env)))))
(compile (Top-code top) cenv target linkage)))) (compile (Top-code top) cenv target linkage))))
@ -61,8 +59,10 @@
[(eq? linkage 'return) [(eq? linkage 'return)
(make-instruction-sequence `(,(make-AssignPrimOpStatement 'proc (make-instruction-sequence `(,(make-AssignPrimOpStatement 'proc
'read-control-label 'read-control-label
(list (make-Reg 'control))) (list))
,(make-PopEnv (lexical-environment-pop-depth cenv)) ,(make-PopEnv (lexical-environment-pop-depth cenv)
;; FIXME: not right
0)
,(make-PopControl) ,(make-PopControl)
,(make-GotoStatement (make-Reg 'proc))))] ,(make-GotoStatement (make-Reg 'proc))))]
[(eq? linkage 'next) [(eq? linkage 'next)
@ -93,7 +93,8 @@
(make-instruction-sequence (make-instruction-sequence
`(,(make-AssignPrimOpStatement target `(,(make-AssignPrimOpStatement target
'lexical-address-lookup 'lexical-address-lookup
(list (make-Const (LocalAddress-depth lexical-pos)) (list (make-Const
(LocalAddress-depth lexical-pos))
(make-Reg 'env))))))] (make-Reg 'env))))))]
[(PrefixAddress? lexical-pos) [(PrefixAddress? lexical-pos)
(end-with-linkage linkage (end-with-linkage linkage
@ -102,8 +103,7 @@
`(,(make-PerformStatement 'check-bound! `(,(make-PerformStatement 'check-bound!
(list (make-Const (PrefixAddress-depth lexical-pos)) (list (make-Const (PrefixAddress-depth lexical-pos))
(make-Const (PrefixAddress-pos lexical-pos)) (make-Const (PrefixAddress-pos lexical-pos))
(make-Const (PrefixAddress-name lexical-pos)) (make-Const (PrefixAddress-name lexical-pos))))
(make-Reg 'env)))
,(make-AssignPrimOpStatement target ,(make-AssignPrimOpStatement target
'toplevel-lookup 'toplevel-lookup
(list (make-Const (PrefixAddress-depth lexical-pos)) (list (make-Const (PrefixAddress-depth lexical-pos))
@ -130,9 +130,7 @@
(make-instruction-sequence `(,(make-PerformStatement 'toplevel-set! (make-instruction-sequence `(,(make-PerformStatement 'toplevel-set!
(list (make-Const (PrefixAddress-depth lexical-pos)) (list (make-Const (PrefixAddress-depth lexical-pos))
(make-Const (PrefixAddress-pos lexical-pos)) (make-Const (PrefixAddress-pos lexical-pos))
(make-Const var) (make-Const var)))
(make-Reg 'env)
(make-Reg 'val)))
,(make-AssignImmediateStatement target (make-Const 'ok))))))]))) ,(make-AssignImmediateStatement target (make-Const 'ok))))))])))
@ -192,7 +190,6 @@
`(,(make-AssignPrimOpStatement target `(,(make-AssignPrimOpStatement target
'make-compiled-procedure 'make-compiled-procedure
(list* (make-Label proc-entry) (list* (make-Label proc-entry)
(make-Reg 'env)
lexical-references))))) lexical-references)))))
(compile-lambda-body exp cenv (compile-lambda-body exp cenv
lexical-references lexical-references
@ -216,15 +213,12 @@
[extended-cenv : CompileTimeEnvironment [extended-cenv : CompileTimeEnvironment
(extend-lexical-environment '() formals)] (extend-lexical-environment '() formals)]
[extended-cenv : CompileTimeEnvironment [extended-cenv : CompileTimeEnvironment
(begin (lexical-references->compile-time-environment
(lexical-references->compile-time-environment lexical-references cenv extended-cenv))]) lexical-references cenv extended-cenv)])
(append-instruction-sequences (append-instruction-sequences
(make-instruction-sequence (make-instruction-sequence
`(,proc-entry `(,proc-entry
;; FIXME: not right: we need to install the closure values here, ,(make-PerformStatement 'install-closure-values!
;; instead of replacing the environment altogether.
,(make-AssignPrimOpStatement 'env
'compiled-procedure-env
(list (make-Reg 'proc))))) (list (make-Reg 'proc)))))
(compile (Lam-body exp) extended-cenv 'val 'return)))) (compile (Lam-body exp) extended-cenv 'val 'return))))
@ -252,9 +246,6 @@
(make-EnvOffset i) (make-EnvOffset i)
'val))))]) '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: we need to push the control.
;; FIXME: at procedure entry, the arguments need to be installed ;; FIXME: at procedure entry, the arguments need to be installed
;; in the environment. We need to install ;; in the environment. We need to install
@ -262,15 +253,15 @@
(append-instruction-sequences (append-instruction-sequences
(make-instruction-sequence `(,(make-PushEnv (length (App-operands exp))))) (make-instruction-sequence `(,(make-PushEnv (length (App-operands exp)))))
proc-code proc-code
(install-operands operand-codes) (juggle-operands operand-codes)
(compile-procedure-call extended-cenv (length (App-operands exp)) target linkage)))) (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, ;; Installs the operators. At the end of this,
;; the procedure lives in 'proc, and the operands on the environment stack. ;; 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 (let: ([n : Natural
;; defensive coding: the operand codes should be nonempty. ;; defensive coding: the operand codes should be nonempty.
(max 0 (sub1 (length operand-codes)))]) (max 0 (sub1 (length operand-codes)))])
@ -294,21 +285,23 @@
(loop (rest ops)))])))) (loop (rest ops)))]))))
(: compile-procedure-call (CompileTimeEnvironment Natural Target Linkage -> InstructionSequence)) (: 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) (define (compile-procedure-call cenv n target linkage)
(let ([primitive-branch (make-label 'primitiveBranch)] (let ([primitive-branch (make-label 'primitiveBranch)]
[compiled-branch (make-label 'compiledBranch)] [compiled-branch (make-label 'compiledBranch)]
[after-call (make-label 'afterCall)]) [after-call (make-label 'afterCall)])
(let ([compiled-linkage (let ([compiled-linkage
(if (eq? linkage 'next) after-call linkage)]) (if (eq? linkage 'next) after-call linkage)])
(append-instruction-sequences (append-instruction-sequences
(make-instruction-sequence `(,(make-TestStatement 'primitive-procedure? 'proc) (make-instruction-sequence `(,(make-TestStatement 'primitive-procedure? 'proc)
,(make-BranchLabelStatement primitive-branch))) ,(make-BranchLabelStatement primitive-branch)))
(append-instruction-sequences
(append-instruction-sequences
compiled-branch compiled-branch
(compile-proc-appl n target compiled-linkage)) (compile-proc-appl n target compiled-linkage)
(append-instruction-sequences
primitive-branch primitive-branch
(end-with-linkage linkage (end-with-linkage linkage
cenv cenv
@ -317,39 +310,61 @@
'apply-primitive-procedure 'apply-primitive-procedure
(list (make-Reg 'proc) (list (make-Reg 'proc)
(make-Const n) (make-Const n)
(make-Reg 'env)))))))) (make-Reg 'env))))))
after-call)))) after-call))))
(: compile-proc-appl (Natural Target Linkage -> InstructionSequence)) (: 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) (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))) (not (eq? linkage 'return)))
;; This case happens for a function call that isn't in
;; tail position.
(make-instruction-sequence (make-instruction-sequence
`(#;,(make-AssignImmediateStatement 'cont (make-Label linkage)) `(,(make-PushControlFrame linkage)
,(make-AssignPrimOpStatement 'val 'compiled-procedure-entry ,(make-AssignPrimOpStatement 'val 'compiled-procedure-entry
(list (make-Reg 'proc))) (list (make-Reg 'proc)))
,(make-GotoStatement (make-Reg 'val))))] ,(make-GotoStatement (make-Reg 'val))))]
[(and (not (eq? target 'val)) [(and (not (eq? target 'val))
(not (eq? linkage 'return))) (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)]) (let ([proc-return (make-label 'procReturn)])
(make-instruction-sequence (make-instruction-sequence
`(#;,(make-AssignImmediateStatement 'cont (make-Label proc-return)) `(,(make-PushControlFrame proc-return)
,(make-AssignPrimOpStatement 'val 'compiled-procedure-entry ,(make-AssignPrimOpStatement 'val 'compiled-procedure-entry
(list (make-Reg 'proc))) (list (make-Reg 'proc)))
,(make-GotoStatement (make-Reg 'val)) ,(make-GotoStatement (make-Reg 'val))
,proc-return ,proc-return
,(make-AssignImmediateStatement target (make-Reg 'val)) ,(make-AssignImmediateStatement target (make-Reg 'val))
,(make-GotoStatement (make-Label linkage)))))] ,(make-GotoStatement (make-Label linkage)))))]
[(and (eq? target 'val) [(and (eq? target 'val)
(eq? linkage 'return)) (eq? linkage 'return))
;; This case happens when we're in tail position.
;; FIXME: do tail call stuff! ;; FIXME: do tail call stuff!
;; Must shift existing environment to replace ;; Must shift existing environment to replace
(make-instruction-sequence (make-instruction-sequence
`(,(make-AssignPrimOpStatement 'val 'compiled-procedure-entry `(,(make-AssignPrimOpStatement 'val 'compiled-procedure-entry
(list (make-Reg 'proc))) (list (make-Reg 'proc)))
,(make-GotoStatement (make-Reg 'val))))] ,(make-GotoStatement (make-Reg 'val))))]
[(and (not (eq? target 'val)) [(and (not (eq? target 'val))
(eq? linkage 'return)) (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)])) (error 'compile "return linkage, target not val: ~s" target)]))

82
il-structs.rkt
View File

@ -51,7 +51,7 @@
PopEnv PopEnv
PopControl PopControl
PushEnv PushEnv
PushControl)) PushControlFrame))
(define-type Statement (U UnlabeledStatement (define-type Statement (U UnlabeledStatement
Symbol ;; label Symbol ;; label
)) ))
@ -65,47 +65,93 @@
#:transparent) #:transparent)
(define-struct: PopEnv ([n : Natural]) #:transparent) (define-struct: PopEnv ([n : Natural]
(define-struct: PopControl () #:transparent) [skip : Natural])
#:transparent)
(define-struct: PopControl ()
#:transparent)
(define-struct: PushEnv ([n : Natural])
#:transparent)
(define-struct: PushEnv ([n : Natural]) #:transparent) ;; Adding a frame for getting back after procedure application.
(define-struct: PushControl () #:transparent) (define-struct: PushControlFrame ([label : Symbol])
#:transparent)
(define-struct: GotoStatement ([target : (U Label Reg)]) (define-struct: GotoStatement ([target : (U Label Reg)])
#:transparent) #:transparent)
(define-struct: PerformStatement ([op : PerformOperator] (define-struct: PerformStatement ([op : PrimitiveCommand]
[rands : (Listof (U Label Reg Const))]) #:transparent) [rands : (Listof (U Label Reg Const))]) #:transparent)
(define-struct: TestStatement ([op : TestOperator] (define-struct: TestStatement ([op : PrimitiveTest]
[register-rand : RegisterSymbol]) #:transparent) [register-rand : RegisterSymbol]) #:transparent)
(define-struct: BranchLabelStatement ([label : Symbol]) #:transparent) (define-struct: BranchLabelStatement ([label : Symbol]) #:transparent)
(define-type PrimitiveOperator (U 'compiled-procedure-entry (define-type PrimitiveOperator (U
'compiled-procedure-env
;; register -> label
;; Get the label from the closure stored in
;; the register and return it.
'compiled-procedure-entry
;; label LexicalReference * -> closure
'make-compiled-procedure 'make-compiled-procedure
'false? ;; primitive-procedure arity -> any
'cons
'list
'apply-primitive-procedure 'apply-primitive-procedure
;; depth -> any
;; Lookup the value in the environment
'lexical-address-lookup 'lexical-address-lookup
;; depth pos symbol -> any
;; lookup the value in the prefix installed in the
;; environment.
'toplevel-lookup 'toplevel-lookup
;; -> label
;; Grabs the label embedded in the top
;; of the control stack
'read-control-label 'read-control-label
))
'extend-environment (define-type PrimitiveTest (U
'extend-environment/prefix))
(define-type TestOperator (U 'false? 'primitive-procedure?)) ;; register -> boolean
;; Meant to branch when the register value is false.
'false?
(define-type PerformOperator (U 'toplevel-set! ;; register -> boolean
'lexical-address-set! ;; Meant to branch when the register value is a primitive
'check-bound!)) ;; procedure
'primitive-procedure?
))
(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!
))