still debugging, but something broke
This commit is contained in:
Danny Yoo
parent
22f213213c
commit
7ed39e96d0
14
assemble.rkt
14
assemble.rkt
|
|
@ -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])
|
||||
(assemble-paired-label a-paired-label op)
|
||||
(newline op))
|
||||
(cond [(member (PairedLabel-label a-paired-label)
|
||||
basic-block-labels)
|
||||
|
||||
(assemble-paired-label a-paired-label op)
|
||||
(newline op)]
|
||||
[else
|
||||
(void)]))
|
||||
(collect-paired-labels stmts))
|
||||
(fprintf op "MACHINE.params.currentErrorHandler = fail;\n")
|
||||
(fprintf op "MACHINE.params.currentSuccessHandler = success;\n")
|
||||
|
|
|
|||
93
compile.rkt
93
compile.rkt
|
|
@ -778,44 +778,54 @@
|
|||
;; 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: ([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)
|
||||
linkage
|
||||
after-call)])
|
||||
(append-instruction-sequences
|
||||
(make-instruction-sequence
|
||||
`(,(make-TestAndBranchStatement 'primitive-procedure?
|
||||
'proc
|
||||
(LabelLinkage-label primitive-branch))))
|
||||
|
||||
|
||||
;; Compiled branch
|
||||
(LabelLinkage-label compiled-branch)
|
||||
(make-instruction-sequence
|
||||
`(,(make-PerformStatement (make-CheckClosureArity! n))))
|
||||
(compile-proc-appl extended-cenv (make-Reg 'val) n target compiled-linkage)
|
||||
|
||||
|
||||
|
||||
(LabelLinkage-label primitive-branch)
|
||||
(end-with-linkage
|
||||
linkage
|
||||
cenv
|
||||
(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))])
|
||||
(let: ([compiled-linkage : Linkage
|
||||
(if (ReturnLinkage? linkage)
|
||||
linkage
|
||||
(make-LabelLinkage (PairedLabel-label after-call-single)))])
|
||||
(append-instruction-sequences
|
||||
(make-instruction-sequence
|
||||
`(,(make-AssignPrimOpStatement
|
||||
;; Optimization: we put the result directly in the registers, or in
|
||||
;; the appropriate spot on the stack. This takes into account the popenviroment
|
||||
;; that happens right afterwards.
|
||||
(adjust-target-depth target n)
|
||||
(make-ApplyPrimitiveProcedure n))))
|
||||
(if (not (= n 0))
|
||||
(make-instruction-sequence
|
||||
`(,(make-PopEnvironment n 0)))
|
||||
empty-instruction-sequence)
|
||||
(LabelLinkage-label after-call)))))))
|
||||
`(,(make-TestAndBranchStatement 'primitive-procedure?
|
||||
'proc
|
||||
(LabelLinkage-label primitive-branch))))
|
||||
|
||||
|
||||
;; Compiled branch
|
||||
(LabelLinkage-label compiled-branch)
|
||||
(make-instruction-sequence
|
||||
`(,(make-PerformStatement (make-CheckClosureArity! n))))
|
||||
(compile-proc-appl extended-cenv
|
||||
(make-Reg 'val)
|
||||
n
|
||||
target
|
||||
compiled-linkage)
|
||||
|
||||
|
||||
(LabelLinkage-label primitive-branch)
|
||||
(end-with-linkage
|
||||
linkage
|
||||
cenv
|
||||
(append-instruction-sequences
|
||||
(make-instruction-sequence
|
||||
`(,(make-AssignPrimOpStatement
|
||||
;; Optimization: we put the result directly in the registers, or in
|
||||
;; the appropriate spot on the stack. This takes into account the popenviroment
|
||||
;; that happens right afterwards.
|
||||
(adjust-target-depth target n)
|
||||
(make-ApplyPrimitiveProcedure n))))
|
||||
(if (not (= n 0))
|
||||
(make-instruction-sequence
|
||||
`(,(make-PopEnvironment n 0)))
|
||||
empty-instruction-sequence)
|
||||
(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)
|
||||
linkage
|
||||
(make-Label after-call-single))])
|
||||
(let*: ([compiled-linkage : Linkage
|
||||
(if (ReturnLinkage? linkage)
|
||||
linkage
|
||||
(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)))))))
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user