working on labels
This commit is contained in:
Danny Yoo
parent
62bba7470e
commit
b388d01ff8
|
|
@ -20,7 +20,7 @@
|
|||
|
||||
[(MakeCompiledProcedure? op)
|
||||
(format "new RUNTIME.Closure(~a, ~a, [~a], ~a)"
|
||||
(MakeCompiledProcedure-label op)
|
||||
(assemble-label (make-Label (MakeCompiledProcedure-label op)))
|
||||
(assemble-arity (MakeCompiledProcedure-arity op))
|
||||
(string-join (map
|
||||
assemble-env-reference/closure-capture
|
||||
|
|
@ -34,7 +34,7 @@
|
|||
|
||||
[(MakeCompiledProcedureShell? op)
|
||||
(format "new RUNTIME.Closure(~a, ~a, undefined, ~a)"
|
||||
(MakeCompiledProcedureShell-label op)
|
||||
(assemble-label (make-Label (MakeCompiledProcedureShell-label op)))
|
||||
(assemble-arity (MakeCompiledProcedureShell-arity op))
|
||||
(assemble-display-name (MakeCompiledProcedureShell-display-name op)))]
|
||||
|
||||
|
|
|
|||
|
|
@ -20,6 +20,9 @@
|
|||
assemble-display-name
|
||||
assemble-location)
|
||||
|
||||
(require/typed typed/racket/base
|
||||
[regexp-split (Regexp String -> (Listof String))])
|
||||
|
||||
|
||||
(: assemble-oparg (OpArg -> String))
|
||||
(define (assemble-oparg v)
|
||||
|
|
@ -135,7 +138,20 @@
|
|||
|
||||
(: assemble-label (Label -> String))
|
||||
(define (assemble-label a-label)
|
||||
(symbol->string (Label-name a-label)))
|
||||
(let ([chunks
|
||||
(regexp-split #rx"[^a-zA-Z0-9]+"
|
||||
(symbol->string (Label-name a-label)))])
|
||||
(cond
|
||||
[(empty? chunks)
|
||||
(error "impossible: empty label ~s" a-label)]
|
||||
[(empty? (rest chunks))
|
||||
(string-append "_" (first chunks))]
|
||||
[else
|
||||
(string-append "_"
|
||||
(first chunks)
|
||||
(apply string-append (map string-titlecase (rest chunks))))])))
|
||||
|
||||
|
||||
|
||||
(: assemble-subtractarg (SubtractArg -> String))
|
||||
(define (assemble-subtractarg s)
|
||||
|
|
|
|||
24
assemble.rkt
24
assemble.rkt
|
|
@ -46,7 +46,7 @@ for (param in params) {
|
|||
EOF
|
||||
)
|
||||
(fprintf op "RUNTIME.trampoline(MACHINE, ~a); })"
|
||||
(BasicBlock-name (first basic-blocks)))))
|
||||
(assemble-label (make-Label (BasicBlock-name (first basic-blocks)))))))
|
||||
|
||||
|
||||
|
||||
|
|
@ -125,8 +125,8 @@ EOF
|
|||
(next)]
|
||||
[(LinkedLabel? stmt)
|
||||
(fprintf op "~a.multipleValueReturn = ~a;\n"
|
||||
(LinkedLabel-label stmt)
|
||||
(LinkedLabel-linked-to stmt))
|
||||
(assemble-label (make-Label (LinkedLabel-label stmt)))
|
||||
(assemble-label (make-Label (LinkedLabel-linked-to stmt))))
|
||||
(next)]
|
||||
[(AssignImmediateStatement? stmt)
|
||||
(next)]
|
||||
|
|
@ -160,8 +160,8 @@ EOF
|
|||
(: assemble-basic-block (BasicBlock -> String))
|
||||
(define (assemble-basic-block a-basic-block)
|
||||
(format "var ~a=function(MACHINE){\nif(--MACHINE.callsBeforeTrampoline < 0) { throw ~a; }\n~a};"
|
||||
(BasicBlock-name a-basic-block)
|
||||
(BasicBlock-name a-basic-block)
|
||||
(assemble-label (make-Label (BasicBlock-name a-basic-block)))
|
||||
(assemble-label (make-Label (BasicBlock-name a-basic-block)))
|
||||
(string-join (map assemble-statement (BasicBlock-stmts a-basic-block))
|
||||
"\n")))
|
||||
|
||||
|
|
@ -212,7 +212,7 @@ EOF
|
|||
(assemble-oparg (TestPrimitiveProcedure-operand test))
|
||||
jump)]
|
||||
[(TestClosureArityMismatch? test)
|
||||
(format "if (! RUNTIME.isArityMatching(~a.arity, ~a)) { ~a }"
|
||||
(format "if (! RUNTIME.isArityMatching((~a).arity, ~a)) { ~a }"
|
||||
(assemble-oparg (TestClosureArityMismatch-closure test))
|
||||
(assemble-oparg (TestClosureArityMismatch-n test))
|
||||
jump)])
|
||||
|
|
@ -228,16 +228,20 @@ EOF
|
|||
(format "MACHINE.control.push(new RUNTIME.CallFrame(~a, MACHINE.proc));"
|
||||
(let: ([label : (U Symbol LinkedLabel) (PushControlFrame/Call-label stmt)])
|
||||
(cond
|
||||
[(symbol? label) label]
|
||||
[(LinkedLabel? label) (LinkedLabel-label label)])))]
|
||||
[(symbol? label)
|
||||
(assemble-label (make-Label label))]
|
||||
[(LinkedLabel? label)
|
||||
(assemble-label (make-Label (LinkedLabel-label label)))])))]
|
||||
|
||||
[(PushControlFrame/Prompt? stmt)
|
||||
;; fixme: use a different frame structure
|
||||
(format "MACHINE.control.push(new RUNTIME.PromptFrame(~a, ~a));"
|
||||
(let: ([label : (U Symbol LinkedLabel) (PushControlFrame/Prompt-label stmt)])
|
||||
(cond
|
||||
[(symbol? label) label]
|
||||
[(LinkedLabel? label) (LinkedLabel-label label)]))
|
||||
[(symbol? label)
|
||||
(assemble-label (make-Label label))]
|
||||
[(LinkedLabel? label)
|
||||
(assemble-label (make-Label (LinkedLabel-label label)))]))
|
||||
|
||||
(let: ([tag : (U DefaultContinuationPromptTag OpArg)
|
||||
(PushControlFrame/Prompt-tag stmt)])
|
||||
|
|
|
|||
|
|
@ -424,4 +424,72 @@
|
|||
,(make-AssignImmediateStatement 'argcount (make-Const 5))
|
||||
,(make-PerformStatement (make-UnspliceRestFromStack! (make-Const 2) (make-Const 3))))
|
||||
"MACHINE.argcount + ',' + MACHINE.env.length + ',' + plt.runtime.isList(MACHINE.env[0]) + ',' + MACHINE.env[2] + ',' + MACHINE.env[1]")
|
||||
"3,3,true,hello,world")
|
||||
"3,3,true,hello,world")
|
||||
|
||||
|
||||
|
||||
;; Check closure mismatch. Make sure we're getting the right values from the test.
|
||||
(test (E-many `(procedure-entry
|
||||
;; doesn't matter about the procedure entry...
|
||||
,(make-AssignPrimOpStatement
|
||||
'proc
|
||||
(make-MakeCompiledProcedure 'procedure-entry 0 (list) 'procedure-entry))
|
||||
,(make-TestAndBranchStatement
|
||||
(make-TestClosureArityMismatch (make-Reg 'proc) (make-Const 0))
|
||||
'bad)
|
||||
,(make-AssignImmediateStatement 'val (make-Const 'ok))
|
||||
,(make-GotoStatement (make-Label 'end))
|
||||
bad
|
||||
,(make-AssignImmediateStatement 'val (make-Const 'bad))
|
||||
end)
|
||||
"MACHINE.val")
|
||||
"ok")
|
||||
|
||||
|
||||
(test (E-many `(procedure-entry
|
||||
;; doesn't matter about the procedure entry...
|
||||
,(make-AssignPrimOpStatement
|
||||
'proc
|
||||
(make-MakeCompiledProcedure 'procedure-entry 0 (list) 'procedure-entry))
|
||||
,(make-TestAndBranchStatement
|
||||
(make-TestClosureArityMismatch (make-Reg 'proc) (make-Const 1))
|
||||
'ok)
|
||||
,(make-AssignImmediateStatement 'val (make-Const 'bad))
|
||||
,(make-GotoStatement (make-Label 'end))
|
||||
ok
|
||||
,(make-AssignImmediateStatement 'val (make-Const 'ok))
|
||||
end)
|
||||
"MACHINE.val")
|
||||
"ok")
|
||||
|
||||
(test (E-many `(procedure-entry
|
||||
;; doesn't matter about the procedure entry...
|
||||
,(make-AssignPrimOpStatement
|
||||
'proc
|
||||
(make-MakeCompiledProcedure 'procedure-entry (make-ArityAtLeast 2) (list) 'procedure-entry))
|
||||
,(make-TestAndBranchStatement
|
||||
(make-TestClosureArityMismatch (make-Reg 'proc) (make-Const 0))
|
||||
'ok)
|
||||
,(make-AssignImmediateStatement 'val (make-Const 'bad))
|
||||
,(make-GotoStatement (make-Label 'end))
|
||||
ok
|
||||
,(make-AssignImmediateStatement 'val (make-Const 'ok))
|
||||
end)
|
||||
"MACHINE.val")
|
||||
"ok")
|
||||
|
||||
(test (E-many `(procedure-entry
|
||||
;; doesn't matter about the procedure entry...
|
||||
,(make-AssignPrimOpStatement
|
||||
'proc
|
||||
(make-MakeCompiledProcedure 'procedure-entry (make-ArityAtLeast 2) (list) 'procedure-entry))
|
||||
,(make-TestAndBranchStatement
|
||||
(make-TestClosureArityMismatch (make-Reg 'proc) (make-Const 2))
|
||||
'bad)
|
||||
,(make-AssignImmediateStatement 'val (make-Const 'ok))
|
||||
,(make-GotoStatement (make-Label 'end))
|
||||
bad
|
||||
,(make-AssignImmediateStatement 'val (make-Const 'bad))
|
||||
end)
|
||||
"MACHINE.val")
|
||||
"ok")
|
||||
|
|
|
|||
|
|
@ -659,3 +659,74 @@
|
|||
"world"
|
||||
(make-MutablePair 'x (make-MutablePair 'y (make-MutablePair 'z null))))))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
;; Check closure mismatch. Make sure we're getting the right values from the test.
|
||||
(let ([m (new-machine `(procedure-entry
|
||||
;; doesn't matter about the procedure entry...
|
||||
,(make-AssignPrimOpStatement
|
||||
'proc
|
||||
(make-MakeCompiledProcedure 'procedure-entry 0 (list) 'procedure-entry))
|
||||
,(make-TestAndBranchStatement
|
||||
(make-TestClosureArityMismatch (make-Reg 'proc) (make-Const 0))
|
||||
'bad)
|
||||
,(make-AssignImmediateStatement 'val (make-Const 'ok))
|
||||
,(make-GotoStatement (make-Label 'end))
|
||||
bad
|
||||
,(make-AssignImmediateStatement 'val (make-Const 'bad))
|
||||
end))])
|
||||
(test (machine-val (run! m))
|
||||
'ok))
|
||||
|
||||
(let ([m (new-machine `(procedure-entry
|
||||
;; doesn't matter about the procedure entry...
|
||||
,(make-AssignPrimOpStatement
|
||||
'proc
|
||||
(make-MakeCompiledProcedure 'procedure-entry 0 (list) 'procedure-entry))
|
||||
,(make-TestAndBranchStatement
|
||||
(make-TestClosureArityMismatch (make-Reg 'proc) (make-Const 1))
|
||||
'ok)
|
||||
,(make-AssignImmediateStatement 'val (make-Const 'bad))
|
||||
,(make-GotoStatement (make-Label 'end))
|
||||
ok
|
||||
,(make-AssignImmediateStatement 'val (make-Const 'ok))
|
||||
end))])
|
||||
(test (machine-val (run! m))
|
||||
'ok))
|
||||
|
||||
(let ([m (new-machine `(procedure-entry
|
||||
;; doesn't matter about the procedure entry...
|
||||
,(make-AssignPrimOpStatement
|
||||
'proc
|
||||
(make-MakeCompiledProcedure 'procedure-entry (make-ArityAtLeast 2) (list) 'procedure-entry))
|
||||
,(make-TestAndBranchStatement
|
||||
(make-TestClosureArityMismatch (make-Reg 'proc) (make-Const 0))
|
||||
'ok)
|
||||
,(make-AssignImmediateStatement 'val (make-Const 'bad))
|
||||
,(make-GotoStatement (make-Label 'end))
|
||||
ok
|
||||
,(make-AssignImmediateStatement 'val (make-Const 'ok))
|
||||
end))])
|
||||
(test (machine-val (run! m))
|
||||
'ok))
|
||||
|
||||
(let ([m (new-machine `(procedure-entry
|
||||
;; doesn't matter about the procedure entry...
|
||||
,(make-AssignPrimOpStatement
|
||||
'proc
|
||||
(make-MakeCompiledProcedure 'procedure-entry (make-ArityAtLeast 2) (list) 'procedure-entry))
|
||||
,(make-TestAndBranchStatement
|
||||
(make-TestClosureArityMismatch (make-Reg 'proc) (make-Const 2))
|
||||
'bad)
|
||||
,(make-AssignImmediateStatement 'val (make-Const 'ok))
|
||||
,(make-GotoStatement (make-Label 'end))
|
||||
bad
|
||||
,(make-AssignImmediateStatement 'val (make-Const 'bad))
|
||||
end))])
|
||||
(test (machine-val (run! m))
|
||||
'ok))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user