diff --git a/assemble-expression.rkt b/assemble-expression.rkt index fe0066b..ddba2b1 100644 --- a/assemble-expression.rkt +++ b/assemble-expression.rkt @@ -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)))] diff --git a/assemble-helpers.rkt b/assemble-helpers.rkt index d5b0e47..caa13b3 100644 --- a/assemble-helpers.rkt +++ b/assemble-helpers.rkt @@ -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) diff --git a/assemble.rkt b/assemble.rkt index aaa6301..233d46a 100644 --- a/assemble.rkt +++ b/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)]) diff --git a/test-assemble.rkt b/test-assemble.rkt index 4da9656..9056606 100644 --- a/test-assemble.rkt +++ b/test-assemble.rkt @@ -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") \ No newline at end of file + "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") diff --git a/test-simulator.rkt b/test-simulator.rkt index 1af0360..57eee5a 100644 --- a/test-simulator.rkt +++ b/test-simulator.rkt @@ -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)) +