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

working on labels

Browse Source
This commit is contained in:
Danny Yoo 2011-05-03 17:36:50 -04:00
parent 62bba7470e
commit b388d01ff8
5 changed files with 173 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
assemble-expression.rkt
View File

@ -20,7 +20,7 @@
[(MakeCompiledProcedure? op) [(MakeCompiledProcedure? op)
(format "new RUNTIME.Closure(~a, ~a, [~a], ~a)" (format "new RUNTIME.Closure(~a, ~a, [~a], ~a)"
(MakeCompiledProcedure-label op) (assemble-label (make-Label (MakeCompiledProcedure-label op)))
(assemble-arity (MakeCompiledProcedure-arity op)) (assemble-arity (MakeCompiledProcedure-arity op))
(string-join (map (string-join (map
assemble-env-reference/closure-capture assemble-env-reference/closure-capture
@ -34,7 +34,7 @@
[(MakeCompiledProcedureShell? op) [(MakeCompiledProcedureShell? op)
(format "new RUNTIME.Closure(~a, ~a, undefined, ~a)" (format "new RUNTIME.Closure(~a, ~a, undefined, ~a)"
(MakeCompiledProcedureShell-label op) (assemble-label (make-Label (MakeCompiledProcedureShell-label op)))
(assemble-arity (MakeCompiledProcedureShell-arity op)) (assemble-arity (MakeCompiledProcedureShell-arity op))
(assemble-display-name (MakeCompiledProcedureShell-display-name op)))] (assemble-display-name (MakeCompiledProcedureShell-display-name op)))]

18
assemble-helpers.rkt
View File

@ -20,6 +20,9 @@
assemble-display-name assemble-display-name
assemble-location) assemble-location)
(require/typed typed/racket/base
[regexp-split (Regexp String -> (Listof String))])
(: assemble-oparg (OpArg -> String)) (: assemble-oparg (OpArg -> String))
(define (assemble-oparg v) (define (assemble-oparg v)
@ -135,7 +138,20 @@
(: assemble-label (Label -> String)) (: assemble-label (Label -> String))
(define (assemble-label a-label) (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)) (: assemble-subtractarg (SubtractArg -> String))
(define (assemble-subtractarg s) (define (assemble-subtractarg s)

24
assemble.rkt
View File

@ -46,7 +46,7 @@ for (param in params) {
EOF EOF
) )
(fprintf op "RUNTIME.trampoline(MACHINE, ~a); })" (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)] (next)]
[(LinkedLabel? stmt) [(LinkedLabel? stmt)
(fprintf op "~a.multipleValueReturn = ~a;\n" (fprintf op "~a.multipleValueReturn = ~a;\n"
(LinkedLabel-label stmt) (assemble-label (make-Label (LinkedLabel-label stmt)))
(LinkedLabel-linked-to stmt)) (assemble-label (make-Label (LinkedLabel-linked-to stmt))))
(next)] (next)]
[(AssignImmediateStatement? stmt) [(AssignImmediateStatement? stmt)
(next)] (next)]
@ -160,8 +160,8 @@ EOF
(: assemble-basic-block (BasicBlock -> String)) (: assemble-basic-block (BasicBlock -> String))
(define (assemble-basic-block a-basic-block) (define (assemble-basic-block a-basic-block)
(format "var ~a=function(MACHINE){\nif(--MACHINE.callsBeforeTrampoline < 0) { throw ~a; }\n~a};" (format "var ~a=function(MACHINE){\nif(--MACHINE.callsBeforeTrampoline < 0) { throw ~a; }\n~a};"
(BasicBlock-name a-basic-block) (assemble-label (make-Label (BasicBlock-name a-basic-block)))
(BasicBlock-name a-basic-block) (assemble-label (make-Label (BasicBlock-name a-basic-block)))
(string-join (map assemble-statement (BasicBlock-stmts a-basic-block)) (string-join (map assemble-statement (BasicBlock-stmts a-basic-block))
"\n"))) "\n")))
@ -212,7 +212,7 @@ EOF
(assemble-oparg (TestPrimitiveProcedure-operand test)) (assemble-oparg (TestPrimitiveProcedure-operand test))
jump)] jump)]
[(TestClosureArityMismatch? test) [(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-closure test))
(assemble-oparg (TestClosureArityMismatch-n test)) (assemble-oparg (TestClosureArityMismatch-n test))
jump)]) jump)])
@ -228,16 +228,20 @@ EOF
(format "MACHINE.control.push(new RUNTIME.CallFrame(~a, MACHINE.proc));" (format "MACHINE.control.push(new RUNTIME.CallFrame(~a, MACHINE.proc));"
(let: ([label : (U Symbol LinkedLabel) (PushControlFrame/Call-label stmt)]) (let: ([label : (U Symbol LinkedLabel) (PushControlFrame/Call-label stmt)])
(cond (cond
[(symbol? label) label] [(symbol? label)
[(LinkedLabel? label) (LinkedLabel-label label)])))] (assemble-label (make-Label label))]
[(LinkedLabel? label)
(assemble-label (make-Label (LinkedLabel-label label)))])))]
[(PushControlFrame/Prompt? stmt) [(PushControlFrame/Prompt? stmt)
;; fixme: use a different frame structure ;; fixme: use a different frame structure
(format "MACHINE.control.push(new RUNTIME.PromptFrame(~a, ~a));" (format "MACHINE.control.push(new RUNTIME.PromptFrame(~a, ~a));"
(let: ([label : (U Symbol LinkedLabel) (PushControlFrame/Prompt-label stmt)]) (let: ([label : (U Symbol LinkedLabel) (PushControlFrame/Prompt-label stmt)])
(cond (cond
[(symbol? label) label] [(symbol? label)
[(LinkedLabel? label) (LinkedLabel-label label)])) (assemble-label (make-Label label))]
[(LinkedLabel? label)
(assemble-label (make-Label (LinkedLabel-label label)))]))
(let: ([tag : (U DefaultContinuationPromptTag OpArg) (let: ([tag : (U DefaultContinuationPromptTag OpArg)
(PushControlFrame/Prompt-tag stmt)]) (PushControlFrame/Prompt-tag stmt)])

68
test-assemble.rkt
View File

@ -425,3 +425,71 @@
,(make-PerformStatement (make-UnspliceRestFromStack! (make-Const 2) (make-Const 3)))) ,(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]") "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")

71
test-simulator.rkt
View File

@ -659,3 +659,74 @@
"world" "world"
(make-MutablePair 'x (make-MutablePair 'y (make-MutablePair 'z null)))))) (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))