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

still debugging, but something broke

Browse Source
This commit is contained in:
Danny Yoo 2011-04-05 17:27:17 -04:00
parent 22f213213c
commit 7ed39e96d0
2 changed files with 63 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
assemble.rkt
View File

@ -14,14 +14,15 @@
;; Parameter that controls the generation of a trace.
(define current-emit-debug-trace? (make-parameter #f))
(define current-emit-debug-trace? (make-parameter #t))
(: assemble/write-invoke ((Listof Statement) Output-Port -> Void))
;; Writes out the JavaScript code that represents the anonymous invocation expression.
(define (assemble/write-invoke stmts op)
(let ([basic-blocks (fracture stmts)])
(let* ([basic-blocks (fracture stmts)]
[basic-block-labels (map BasicBlock-name basic-blocks)])
(fprintf op "(function(MACHINE, success, fail, params) {\n")
(fprintf op "var param;\n")
(fprintf op "var RUNTIME = plt.runtime;\n")
@ -30,8 +31,13 @@
(newline op))
basic-blocks)
(for-each (lambda: ([a-paired-label : PairedLabel])
(cond [(member (PairedLabel-label a-paired-label)
basic-block-labels)
(assemble-paired-label a-paired-label op)
(newline op))
(newline op)]
[else
(void)]))
(collect-paired-labels stmts))
(fprintf op "MACHINE.params.currentErrorHandler = fail;\n")
(fprintf op "MACHINE.params.currentSuccessHandler = success;\n")

33
compile.rkt
View File

@ -778,12 +778,14 @@
;; cenv is the compile-time enviroment before arguments have been shifted in.
;; extended-cenv is the compile-time environment after arguments have been shifted in.
(define (compile-general-procedure-call cenv extended-cenv n target linkage)
(let-values ([(after-call-multiple after-call-single)
(make-paired-labels 'afterCallMultiple 'afterCallSingle)])
(let: ([primitive-branch : LabelLinkage (make-LabelLinkage (make-label 'primitiveBranch))]
[compiled-branch : LabelLinkage (make-LabelLinkage (make-label 'compiledBranch))]
[after-call : LabelLinkage (make-LabelLinkage (make-label 'afterCall))])
(let: ([compiled-linkage : Linkage (if (ReturnLinkage? linkage)
[compiled-branch : LabelLinkage (make-LabelLinkage (make-label 'compiledBranch))])
(let: ([compiled-linkage : Linkage
(if (ReturnLinkage? linkage)
linkage
after-call)])
(make-LabelLinkage (PairedLabel-label after-call-single)))])
(append-instruction-sequences
(make-instruction-sequence
`(,(make-TestAndBranchStatement 'primitive-procedure?
@ -795,8 +797,11 @@
(LabelLinkage-label compiled-branch)
(make-instruction-sequence
`(,(make-PerformStatement (make-CheckClosureArity! n))))
(compile-proc-appl extended-cenv (make-Reg 'val) n target compiled-linkage)
(compile-proc-appl extended-cenv
(make-Reg 'val)
n
target
compiled-linkage)
(LabelLinkage-label primitive-branch)
@ -815,7 +820,12 @@
(make-instruction-sequence
`(,(make-PopEnvironment n 0)))
empty-instruction-sequence)
(LabelLinkage-label after-call)))))))
(make-instruction-sequence
`(,(make-GotoStatement (make-Label (PairedLabel-label after-call-single)))))
(make-instruction-sequence
`(,after-call-multiple
,after-call-single)))))))))
(: compile-procedure-call/statically-known-lam
@ -824,9 +834,10 @@
(let-values ([(after-call-multiple
after-call-single)
(make-paired-labels 'afterCallMultiple 'afterCallSingle)])
(let*: ([compiled-linkage : Linkage (if (ReturnLinkage? linkage)
(let*: ([compiled-linkage : Linkage
(if (ReturnLinkage? linkage)
linkage
(make-Label after-call-single))])
(make-LabelLinkage (PairedLabel-label after-call-single)))])
(append-instruction-sequences
(compile-proc-appl extended-cenv
(make-Label (StaticallyKnownLam-entry-point static-knowledge))
@ -836,7 +847,9 @@
(end-with-linkage
linkage
cenv
after-call-single)))))
(make-instruction-sequence
`(,after-call-multiple
,after-call-single)))))))