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

trying to simplify code

Browse Source
This commit is contained in:
Danny Yoo 2011-04-25 13:49:02 -04:00
parent 8b5bd061db
commit 876d3bb8e2
1 changed files with 73 additions and 95 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

164
compiler.rkt
View File

@ -44,8 +44,10 @@
(make-instruction-sequence (make-instruction-sequence
`(,(make-PopEnvironment (make-Reg 'argcount) (make-Const 0)))) `(,(make-PopEnvironment (make-Reg 'argcount) (make-Const 0))))
before-pop-prompt before-pop-prompt
(make-instruction-sequence (if (eq? target 'val)
`(,(make-AssignImmediateStatement target (make-Reg 'val))))))))) empty-instruction-sequence
(make-instruction-sequence
`(,(make-AssignImmediateStatement target (make-Reg 'val))))))))))
(define-struct: lam+cenv ([lam : Lam] (define-struct: lam+cenv ([lam : Lam]
[cenv : CompileTimeEnvironment])) [cenv : CompileTimeEnvironment]))
@ -936,7 +938,10 @@
(define (linkage-context linkage) (define (linkage-context linkage)
(cond (cond
[(ReturnLinkage? linkage) [(ReturnLinkage? linkage)
'keep-multiple] (cond [(ReturnLinkage-tail? linkage)
'keep-multiple]
[else
'drop-multiple])]
[(NextLinkage? linkage) [(NextLinkage? linkage)
(NextLinkage-context linkage)] (NextLinkage-context linkage)]
[(LabelLinkage? linkage) [(LabelLinkage? linkage)
@ -1031,8 +1036,7 @@
(: compile-compiled-procedure-application (OpArg (U Label 'val) Target Linkage -> InstructionSequence)) (: compile-compiled-procedure-application (OpArg (U Label 'val) Target Linkage -> InstructionSequence))
;; This is the heart of compiled procedure application. A lot of ;; This is the heart of compiled procedure application. A lot of things happen here.
;; things happen here.
;; ;;
;; Procedure linkage. ;; Procedure linkage.
;; Handling of multiple-value-returns. ;; Handling of multiple-value-returns.
@ -1114,97 +1118,71 @@
(error 'compile "return linkage, target not val: ~s" target)])] (error 'compile "return linkage, target not val: ~s" target)])]
[(NextLinkage? linkage) [(or (NextLinkage? linkage) (LabelLinkage? linkage))
(let ([context (NextLinkage-context linkage)]) (let* ([context (linkage-context linkage)]
(cond
[(eq? context 'drop-multiple) [check-values-context-on-procedure-return
(append-instruction-sequences (cond
nontail-jump-into-procedure
proc-return-multiple [(eq? context 'drop-multiple)
(make-instruction-sequence (append-instruction-sequences
`(,(make-PopEnvironment (make-Reg 'argcount) (make-Const 0)))) proc-return-multiple
proc-return (make-instruction-sequence
maybe-migrate-val-to-target)] `(,(make-PopEnvironment (make-Reg 'argcount) (make-Const 0))))
proc-return)]
[(eq? context 'keep-multiple)
(let ([after-return (make-label 'afterReturn)])
(append-instruction-sequences
proc-return-multiple
(make-instruction-sequence
`(,(make-GotoStatement (make-Label after-return))))
proc-return
(make-instruction-sequence
`(,(make-AssignImmediateStatement 'argcount (make-Const 1))
,(make-PushImmediateOntoEnvironment (make-Reg 'val) #f)))
after-return))]
[(natural? context)
(cond
[(= context 1)
(append-instruction-sequences
proc-return-multiple
(make-instruction-sequence
`(,(make-PerformStatement
(make-RaiseContextExpectedValuesError! 1))))
proc-return)]
[else
(let ([after-value-check (make-label 'afterValueCheck)])
(append-instruction-sequences
proc-return-multiple
(make-instruction-sequence
`(
;; if the wrong number of arguments come in, die
,(make-TestAndBranchStatement
'zero?
(make-SubtractArg (make-Reg 'argcount)
(make-Const context))
after-value-check)))
proc-return
(make-instruction-sequence
`(,(make-PerformStatement
(make-RaiseContextExpectedValuesError! context))))
after-value-check))])])]
[maybe-jump-to-label
(if (LabelLinkage? linkage)
(make-instruction-sequence
`(,(make-GotoStatement (make-Label (LabelLinkage-label linkage)))))
empty-instruction-sequence)])
(append-instruction-sequences
nontail-jump-into-procedure
check-values-context-on-procedure-return
maybe-migrate-val-to-target
maybe-jump-to-label))])))
;; FIXME: this isn't doing the proper checks!!!
[else
(let* ([after-value-check (make-label 'afterValueCheck)]
[return-point-code
(cond
[(eq? context 'keep-multiple)
(let ([after-return (make-label 'afterReturn)])
(append-instruction-sequences
proc-return-multiple
(make-instruction-sequence
`(,(make-GotoStatement (make-Label after-return))))
proc-return
(make-instruction-sequence
`(,(make-AssignImmediateStatement 'argcount (make-Const 1))
,(make-PushImmediateOntoEnvironment (make-Reg 'val) #f)))
after-return))]
[(natural? context)
(cond
[(= context 1)
(append-instruction-sequences
proc-return-multiple
(make-instruction-sequence
`(,(make-PerformStatement
(make-RaiseContextExpectedValuesError! 1))))
proc-return)]
[else
(append-instruction-sequences
proc-return-multiple
(make-instruction-sequence
`(
;; if the wrong number of arguments come in, die
,(make-TestAndBranchStatement
'zero?
(make-SubtractArg (make-Reg 'argcount)
(make-Const context))
after-value-check)))
proc-return
(make-instruction-sequence
`(,(make-PerformStatement
(make-RaiseContextExpectedValuesError! context))))
after-value-check)])])])
(append-instruction-sequences
nontail-jump-into-procedure
return-point-code
maybe-migrate-val-to-target))]))]
[(LabelLinkage? linkage)
(let ([context (LabelLinkage-context linkage)])
(cond
[(eq? context 'drop-multiple)
(append-instruction-sequences
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
(append-instruction-sequences
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))))))]))])))