trying to eliminate redundant code in application, because it's getting hard to understand
This commit is contained in:
Danny Yoo
parent
759bedd9cf
commit
8b5bd061db
208
compiler.rkt
208
compiler.rkt
|
|
@ -1043,114 +1043,98 @@
|
|||
;; 2. Non-tail calls (next/label linkage) that write to val
|
||||
;; 3. Calls in argument position (next/label linkage) that write to the stack.
|
||||
(define (compile-compiled-procedure-application cenv-length-with-args entry-point target linkage)
|
||||
(let*-values
|
||||
([(maybe-install-jump-address entry-point-target)
|
||||
(let*-values ([(maybe-install-jump-address entry-point-target)
|
||||
;; Optimization: if the entry-point is supposed to be val, then it needs to hold
|
||||
;; the procedure entry here. Otherwise, it doesn't.
|
||||
(cond [(Label? entry-point)
|
||||
(values empty-instruction-sequence
|
||||
entry-point)]
|
||||
(values empty-instruction-sequence entry-point)]
|
||||
[(eq? entry-point 'val)
|
||||
(values (make-instruction-sequence
|
||||
`(,(make-AssignPrimOpStatement 'val (make-GetCompiledProcedureEntry))))
|
||||
(make-Reg 'val))])]
|
||||
|
||||
[(proc-return-multiple) (make-label 'procReturnMultiple)]
|
||||
[(proc-return) (make-LinkedLabel (make-label 'procReturn)
|
||||
proc-return-multiple)])
|
||||
(cond [(ReturnLinkage? linkage)
|
||||
(cond
|
||||
[(ReturnLinkage-tail? linkage)
|
||||
;; If the target isn't val, migrate the value from val into it.
|
||||
[(maybe-migrate-val-to-target)
|
||||
(cond
|
||||
[(eq? target 'val)
|
||||
empty-instruction-sequence]
|
||||
[else
|
||||
(make-instruction-sequence
|
||||
`(,(make-AssignImmediateStatement target (make-Reg 'val))))])]
|
||||
|
||||
[(proc-return-multiple) (make-label 'procReturnMultiple)]
|
||||
|
||||
[(proc-return) (make-LinkedLabel (make-label 'procReturn)
|
||||
proc-return-multiple)]
|
||||
|
||||
;; This code does the initial jump into the procedure. Clients of this code
|
||||
;; are expected to generate the proc-return-multiple and proc-return code afterwards.
|
||||
[(nontail-jump-into-procedure)
|
||||
(append-instruction-sequences
|
||||
maybe-install-jump-address
|
||||
(make-instruction-sequence
|
||||
`(,(make-PushControlFrame/Call proc-return)
|
||||
,(make-GotoStatement entry-point-target))))])
|
||||
|
||||
(cond [(ReturnLinkage? linkage)
|
||||
(cond
|
||||
[(eq? target 'val)
|
||||
(cond
|
||||
[(ReturnLinkage-tail? linkage)
|
||||
;; This case happens when we're in tail position.
|
||||
;; We clean up the stack right before the jump, and do not add
|
||||
;; to the control stack.
|
||||
(append-instruction-sequences
|
||||
maybe-install-jump-address
|
||||
(let ([reuse-the-stack
|
||||
(cond [(equal? cenv-length-with-args (make-Reg 'argcount))
|
||||
empty-instruction-sequence]
|
||||
[else
|
||||
(make-instruction-sequence
|
||||
`(,(make-PopEnvironment
|
||||
(make-SubtractArg cenv-length-with-args
|
||||
(make-Reg 'argcount))
|
||||
(make-Reg 'argcount))))])
|
||||
(make-instruction-sequence
|
||||
`(;; Assign the proc value of the existing call frame
|
||||
,(make-PerformStatement
|
||||
(make-SetFrameCallee! (make-Reg 'proc)))
|
||||
|
||||
,(make-GotoStatement entry-point-target))))]
|
||||
|
||||
[else
|
||||
;; This case should be impossible: return linkage should only
|
||||
;; occur when we're in tail position, and we should be in tail position
|
||||
;; only when the target is the val register.
|
||||
(error 'compile "return linkage, target not val: ~s" target)])]
|
||||
[else
|
||||
(cond [(eq? target 'val)
|
||||
;; This case happens for a function call that isn't in
|
||||
;; tail position.
|
||||
(make-SubtractArg cenv-length-with-args (make-Reg 'argcount))
|
||||
(make-Reg 'argcount))))])])
|
||||
(append-instruction-sequences
|
||||
(make-instruction-sequence
|
||||
`(,(make-PushControlFrame/Call proc-return)))
|
||||
maybe-install-jump-address
|
||||
reuse-the-stack
|
||||
(make-instruction-sequence
|
||||
`(,(make-GotoStatement entry-point-target)))
|
||||
`(;; Assign the proc value of the existing call frame.
|
||||
,(make-PerformStatement (make-SetFrameCallee! (make-Reg 'proc)))
|
||||
,(make-GotoStatement entry-point-target)))))]
|
||||
|
||||
[else
|
||||
;; This case happens when we should be returning to a caller, but where
|
||||
;; we are not in tail position.
|
||||
(append-instruction-sequences
|
||||
nontail-jump-into-procedure
|
||||
proc-return-multiple
|
||||
(make-instruction-sequence
|
||||
`(,(make-PopEnvironment (make-Reg 'argcount)
|
||||
(make-Const 0))))
|
||||
proc-return)]
|
||||
`(,(make-PopEnvironment (make-Reg 'argcount) (make-Const 0))))
|
||||
proc-return)])]
|
||||
|
||||
[else
|
||||
(error 'compile "return linkage, target not val: ~s" target)])])]
|
||||
(error 'compile "return linkage, target not val: ~s" target)])]
|
||||
|
||||
|
||||
[(NextLinkage? linkage)
|
||||
(let ([context (NextLinkage-context linkage)])
|
||||
(cond
|
||||
[(eq? context 'drop-multiple)
|
||||
(cond [(eq? target 'val)
|
||||
;; This case happens for a function call that isn't in
|
||||
;; tail position.
|
||||
(append-instruction-sequences
|
||||
(make-instruction-sequence
|
||||
`(,(make-PushControlFrame/Call proc-return)))
|
||||
maybe-install-jump-address
|
||||
(make-instruction-sequence
|
||||
`(,(make-GotoStatement entry-point-target)))
|
||||
nontail-jump-into-procedure
|
||||
proc-return-multiple
|
||||
(make-instruction-sequence
|
||||
`(,(make-PopEnvironment (make-Reg 'argcount)
|
||||
(make-Const 0))))
|
||||
proc-return)]
|
||||
|
||||
[else
|
||||
;; This case happens for evaluating arguments, since the
|
||||
;; arguments are being installed into the scratch space.
|
||||
(append-instruction-sequences
|
||||
(make-instruction-sequence
|
||||
`(,(make-PushControlFrame/Call proc-return)))
|
||||
maybe-install-jump-address
|
||||
(make-instruction-sequence
|
||||
`(,(make-GotoStatement entry-point-target)))
|
||||
proc-return-multiple
|
||||
(make-instruction-sequence
|
||||
`(,(make-PopEnvironment (make-Reg 'argcount)
|
||||
(make-Const 0))))
|
||||
`(,(make-PopEnvironment (make-Reg 'argcount) (make-Const 0))))
|
||||
proc-return
|
||||
(make-instruction-sequence
|
||||
`(,(make-AssignImmediateStatement target (make-Reg 'val)))))])]
|
||||
maybe-migrate-val-to-target)]
|
||||
|
||||
|
||||
|
||||
;; FIXME: this isn't doing the proper checks!!!
|
||||
[else
|
||||
(let* ([n context]
|
||||
[after-value-check (make-label 'afterValueCheck)]
|
||||
(let* ([after-value-check (make-label 'afterValueCheck)]
|
||||
|
||||
[return-point-code
|
||||
(cond
|
||||
[(eq? n 'keep-multiple)
|
||||
[(eq? context 'keep-multiple)
|
||||
(let ([after-return (make-label 'afterReturn)])
|
||||
(append-instruction-sequences
|
||||
proc-return-multiple
|
||||
|
|
@ -1161,9 +1145,9 @@
|
|||
`(,(make-AssignImmediateStatement 'argcount (make-Const 1))
|
||||
,(make-PushImmediateOntoEnvironment (make-Reg 'val) #f)))
|
||||
after-return))]
|
||||
[(natural? n)
|
||||
[(natural? context)
|
||||
(cond
|
||||
[(= n 1)
|
||||
[(= context 1)
|
||||
(append-instruction-sequences
|
||||
proc-return-multiple
|
||||
(make-instruction-sequence
|
||||
|
|
@ -1179,34 +1163,18 @@
|
|||
,(make-TestAndBranchStatement
|
||||
'zero?
|
||||
(make-SubtractArg (make-Reg 'argcount)
|
||||
(make-Const n))
|
||||
(make-Const context))
|
||||
after-value-check)))
|
||||
proc-return
|
||||
(make-instruction-sequence
|
||||
`(,(make-PerformStatement
|
||||
(make-RaiseContextExpectedValuesError! n))))
|
||||
(make-RaiseContextExpectedValuesError! context))))
|
||||
after-value-check)])])])
|
||||
(cond [(eq? target 'val)
|
||||
(append-instruction-sequences
|
||||
(make-instruction-sequence
|
||||
`(,(make-PushControlFrame/Call proc-return)))
|
||||
maybe-install-jump-address
|
||||
(make-instruction-sequence
|
||||
`(,(make-GotoStatement entry-point-target)))
|
||||
return-point-code)]
|
||||
|
||||
[else
|
||||
;; This case happens for evaluating arguments, since the
|
||||
;; arguments are being installed into the scratch space.
|
||||
(append-instruction-sequences
|
||||
(make-instruction-sequence
|
||||
`(,(make-PushControlFrame/Call proc-return)))
|
||||
maybe-install-jump-address
|
||||
(make-instruction-sequence
|
||||
`(,(make-GotoStatement entry-point-target)))
|
||||
nontail-jump-into-procedure
|
||||
return-point-code
|
||||
(make-instruction-sequence
|
||||
`(,(make-AssignImmediateStatement target (make-Reg 'val)))))]))]))]
|
||||
maybe-migrate-val-to-target))]))]
|
||||
|
||||
|
||||
|
||||
|
|
@ -1214,80 +1182,30 @@
|
|||
(let ([context (LabelLinkage-context linkage)])
|
||||
(cond
|
||||
[(eq? context 'drop-multiple)
|
||||
|
||||
(cond [(eq? target 'val)
|
||||
;; This case happens for a function call that isn't in
|
||||
;; tail position.
|
||||
(append-instruction-sequences
|
||||
(make-instruction-sequence
|
||||
`(,(make-PushControlFrame/Call proc-return)))
|
||||
maybe-install-jump-address
|
||||
(make-instruction-sequence
|
||||
`(,(make-GotoStatement entry-point-target)))
|
||||
nontail-jump-into-procedure
|
||||
proc-return-multiple
|
||||
(make-instruction-sequence
|
||||
`(,(make-PopEnvironment (make-Reg 'argcount)
|
||||
(make-Const 0))))
|
||||
proc-return
|
||||
maybe-migrate-val-to-target
|
||||
(make-instruction-sequence
|
||||
`(,(make-GotoStatement (make-Label (LabelLinkage-label linkage))))))]
|
||||
|
||||
[else
|
||||
;; This case happens for evaluating arguments, since the
|
||||
;; arguments are being installed into the scratch space.
|
||||
|
||||
(append-instruction-sequences
|
||||
(make-instruction-sequence
|
||||
`(,(make-PushControlFrame/Call proc-return)))
|
||||
maybe-install-jump-address
|
||||
(make-instruction-sequence
|
||||
`(,(make-GotoStatement entry-point-target)))
|
||||
proc-return-multiple
|
||||
(make-instruction-sequence
|
||||
`(,(make-PopEnvironment (make-Reg 'argcount)
|
||||
(make-Const 0))))
|
||||
proc-return
|
||||
(make-instruction-sequence
|
||||
`(,(make-AssignImmediateStatement target (make-Reg 'val))
|
||||
,(make-GotoStatement (make-Label (LabelLinkage-label linkage))))))])]
|
||||
[else
|
||||
;; FIXME!!! this isn't doing the correct checks!
|
||||
(cond [(eq? target 'val)
|
||||
;; This case happens for a function call that isn't in
|
||||
;; tail position.
|
||||
(append-instruction-sequences
|
||||
(make-instruction-sequence
|
||||
`(,(make-PushControlFrame/Call proc-return)))
|
||||
maybe-install-jump-address
|
||||
(make-instruction-sequence
|
||||
`(,(make-GotoStatement entry-point-target)))
|
||||
nontail-jump-into-procedure
|
||||
proc-return-multiple
|
||||
;; FIXME: this may need to raise a runtime error here!
|
||||
(make-instruction-sequence
|
||||
`(,(make-PopEnvironment (make-Reg 'argcount)
|
||||
(make-Const 0))))
|
||||
proc-return
|
||||
maybe-migrate-val-to-target
|
||||
(make-instruction-sequence
|
||||
`(,(make-GotoStatement (make-Label (LabelLinkage-label linkage))))))]
|
||||
`(,(make-GotoStatement (make-Label (LabelLinkage-label linkage))))))]))])))
|
||||
|
||||
[else
|
||||
;; This case happens for evaluating arguments, since the
|
||||
;; arguments are being installed into the scratch space.
|
||||
(append-instruction-sequences
|
||||
(make-instruction-sequence
|
||||
`(,(make-PushControlFrame/Call proc-return)))
|
||||
maybe-install-jump-address
|
||||
(make-instruction-sequence
|
||||
`(,(make-GotoStatement entry-point-target)))
|
||||
proc-return-multiple
|
||||
;; FIXME: this may need to raise a runtime error here!
|
||||
(make-instruction-sequence
|
||||
`(,(make-PopEnvironment (make-Reg 'argcount)
|
||||
(make-Const 0))))
|
||||
proc-return
|
||||
(make-instruction-sequence
|
||||
`(,(make-AssignImmediateStatement target (make-Reg 'val))
|
||||
,(make-GotoStatement (make-Label (LabelLinkage-label linkage))))))])]))])))
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -519,6 +519,15 @@
|
|||
(void))
|
||||
|
||||
|
||||
|
||||
(test '(begin (define (f x)
|
||||
(* x x))
|
||||
(f 3)
|
||||
(f 4)
|
||||
(f 5))
|
||||
25)
|
||||
|
||||
|
||||
(test '(begin (define (sum-integers a b)
|
||||
(if (> a b)
|
||||
0
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user