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.
|
;; 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))
|
(: assemble/write-invoke ((Listof Statement) Output-Port -> Void))
|
||||||
;; Writes out the JavaScript code that represents the anonymous invocation expression.
|
;; Writes out the JavaScript code that represents the anonymous invocation expression.
|
||||||
(define (assemble/write-invoke stmts op)
|
(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 "(function(MACHINE, success, fail, params) {\n")
|
||||||
(fprintf op "var param;\n")
|
(fprintf op "var param;\n")
|
||||||
(fprintf op "var RUNTIME = plt.runtime;\n")
|
(fprintf op "var RUNTIME = plt.runtime;\n")
|
||||||
|
|
@ -30,8 +31,13 @@
|
||||||
(newline op))
|
(newline op))
|
||||||
basic-blocks)
|
basic-blocks)
|
||||||
(for-each (lambda: ([a-paired-label : PairedLabel])
|
(for-each (lambda: ([a-paired-label : PairedLabel])
|
||||||
(assemble-paired-label a-paired-label op)
|
(cond [(member (PairedLabel-label a-paired-label)
|
||||||
(newline op))
|
basic-block-labels)
|
||||||
|
|
||||||
|
(assemble-paired-label a-paired-label op)
|
||||||
|
(newline op)]
|
||||||
|
[else
|
||||||
|
(void)]))
|
||||||
(collect-paired-labels stmts))
|
(collect-paired-labels stmts))
|
||||||
(fprintf op "MACHINE.params.currentErrorHandler = fail;\n")
|
(fprintf op "MACHINE.params.currentErrorHandler = fail;\n")
|
||||||
(fprintf op "MACHINE.params.currentSuccessHandler = success;\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.
|
;; 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.
|
;; extended-cenv is the compile-time environment after arguments have been shifted in.
|
||||||
(define (compile-general-procedure-call cenv extended-cenv n target linkage)
|
(define (compile-general-procedure-call cenv extended-cenv n target linkage)
|
||||||
(let: ([primitive-branch : LabelLinkage (make-LabelLinkage (make-label 'primitiveBranch))]
|
(let-values ([(after-call-multiple after-call-single)
|
||||||
[compiled-branch : LabelLinkage (make-LabelLinkage (make-label 'compiledBranch))]
|
(make-paired-labels 'afterCallMultiple 'afterCallSingle)])
|
||||||
[after-call : LabelLinkage (make-LabelLinkage (make-label 'afterCall))])
|
(let: ([primitive-branch : LabelLinkage (make-LabelLinkage (make-label 'primitiveBranch))]
|
||||||
(let: ([compiled-linkage : Linkage (if (ReturnLinkage? linkage)
|
[compiled-branch : LabelLinkage (make-LabelLinkage (make-label 'compiledBranch))])
|
||||||
linkage
|
(let: ([compiled-linkage : Linkage
|
||||||
after-call)])
|
(if (ReturnLinkage? linkage)
|
||||||
(append-instruction-sequences
|
linkage
|
||||||
(make-instruction-sequence
|
(make-LabelLinkage (PairedLabel-label after-call-single)))])
|
||||||
`(,(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
|
(append-instruction-sequences
|
||||||
(make-instruction-sequence
|
(make-instruction-sequence
|
||||||
`(,(make-AssignPrimOpStatement
|
`(,(make-TestAndBranchStatement 'primitive-procedure?
|
||||||
;; Optimization: we put the result directly in the registers, or in
|
'proc
|
||||||
;; the appropriate spot on the stack. This takes into account the popenviroment
|
(LabelLinkage-label primitive-branch))))
|
||||||
;; that happens right afterwards.
|
|
||||||
(adjust-target-depth target n)
|
|
||||||
(make-ApplyPrimitiveProcedure n))))
|
;; Compiled branch
|
||||||
(if (not (= n 0))
|
(LabelLinkage-label compiled-branch)
|
||||||
(make-instruction-sequence
|
(make-instruction-sequence
|
||||||
`(,(make-PopEnvironment n 0)))
|
`(,(make-PerformStatement (make-CheckClosureArity! n))))
|
||||||
empty-instruction-sequence)
|
(compile-proc-appl extended-cenv
|
||||||
(LabelLinkage-label after-call)))))))
|
(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
|
(: compile-procedure-call/statically-known-lam
|
||||||
|
|
@ -824,9 +834,10 @@
|
||||||
(let-values ([(after-call-multiple
|
(let-values ([(after-call-multiple
|
||||||
after-call-single)
|
after-call-single)
|
||||||
(make-paired-labels 'afterCallMultiple 'afterCallSingle)])
|
(make-paired-labels 'afterCallMultiple 'afterCallSingle)])
|
||||||
(let*: ([compiled-linkage : Linkage (if (ReturnLinkage? linkage)
|
(let*: ([compiled-linkage : Linkage
|
||||||
linkage
|
(if (ReturnLinkage? linkage)
|
||||||
(make-Label after-call-single))])
|
linkage
|
||||||
|
(make-LabelLinkage (PairedLabel-label after-call-single)))])
|
||||||
(append-instruction-sequences
|
(append-instruction-sequences
|
||||||
(compile-proc-appl extended-cenv
|
(compile-proc-appl extended-cenv
|
||||||
(make-Label (StaticallyKnownLam-entry-point static-knowledge))
|
(make-Label (StaticallyKnownLam-entry-point static-knowledge))
|
||||||
|
|
@ -836,7 +847,9 @@
|
||||||
(end-with-linkage
|
(end-with-linkage
|
||||||
linkage
|
linkage
|
||||||
cenv
|
cenv
|
||||||
after-call-single)))))
|
(make-instruction-sequence
|
||||||
|
`(,after-call-multiple
|
||||||
|
,after-call-single)))))))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user