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

TestClosureArityMismatch

Browse Source
This commit is contained in:
Danny Yoo 2011-05-03 16:46:42 -04:00
parent ba92000960
commit 62bba7470e
6 changed files with 186 additions and 156 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

298
assemble.rkt
View File

@ -2,12 +2,12 @@
(require "il-structs.rkt" (require "il-structs.rkt"
"lexical-structs.rkt" "lexical-structs.rkt"
"helpers.rkt" "helpers.rkt"
"assemble-structs.rkt" "assemble-structs.rkt"
"assemble-helpers.rkt" "assemble-helpers.rkt"
"assemble-open-coded.rkt" "assemble-open-coded.rkt"
"assemble-expression.rkt" "assemble-expression.rkt"
"assemble-perform-statement.rkt" "assemble-perform-statement.rkt"
"collect-jump-targets.rkt" "collect-jump-targets.rkt"
racket/string racket/string
racket/list) racket/list)
@ -26,27 +26,27 @@
;; 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 : (Listof BasicBlock) (fracture stmts)]) (let: ([basic-blocks : (Listof BasicBlock) (fracture stmts)])
(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")
(for-each (for-each
(lambda: ([basic-block : BasicBlock]) (lambda: ([basic-block : BasicBlock])
(displayln (assemble-basic-block basic-block) op) (displayln (assemble-basic-block basic-block) op)
(newline op)) (newline op))
basic-blocks) basic-blocks)
(write-linked-label-attributes stmts op) (write-linked-label-attributes stmts op)
(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")
(fprintf op #<<EOF (fprintf op #<<EOF
for (param in params) { for (param in params) {
if (params.hasOwnProperty(param)) { if (params.hasOwnProperty(param)) {
MACHINE.params[param] = params[param]; MACHINE.params[param] = params[param];
} }
} }
EOF EOF
) )
(fprintf op "RUNTIME.trampoline(MACHINE, ~a); })" (fprintf op "RUNTIME.trampoline(MACHINE, ~a); })"
(BasicBlock-name (first basic-blocks))))) (BasicBlock-name (first basic-blocks)))))
@ -55,59 +55,59 @@ EOF
(: fracture ((Listof Statement) -> (Listof BasicBlock))) (: fracture ((Listof Statement) -> (Listof BasicBlock)))
(define (fracture stmts) (define (fracture stmts)
(let*: ([first-block-label : Symbol (if (and (not (empty? stmts)) (let*: ([first-block-label : Symbol (if (and (not (empty? stmts))
(symbol? (first stmts))) (symbol? (first stmts)))
(first stmts) (first stmts)
(make-label 'start))] (make-label 'start))]
[stmts : (Listof Statement) (if (and (not (empty? stmts)) [stmts : (Listof Statement) (if (and (not (empty? stmts))
(symbol? (first stmts))) (symbol? (first stmts)))
(rest stmts) (rest stmts)
stmts)] stmts)]
[jump-targets : (Listof Symbol) [jump-targets : (Listof Symbol)
(cons first-block-label (collect-general-jump-targets stmts))]) (cons first-block-label (collect-general-jump-targets stmts))])
(let: loop : (Listof BasicBlock) (let: loop : (Listof BasicBlock)
([name : Symbol first-block-label] ([name : Symbol first-block-label]
[acc : (Listof UnlabeledStatement) '()] [acc : (Listof UnlabeledStatement) '()]
[basic-blocks : (Listof BasicBlock) '()] [basic-blocks : (Listof BasicBlock) '()]
[stmts : (Listof Statement) stmts] [stmts : (Listof Statement) stmts]
[last-stmt-goto? : Boolean #f]) [last-stmt-goto? : Boolean #f])
(cond
[(null? stmts)
(reverse (cons (make-BasicBlock name (reverse acc))
basic-blocks))]
[else
(let: ([first-stmt : Statement (car stmts)])
(: do-on-label (Symbol -> (Listof BasicBlock)))
(define (do-on-label label-name)
(cond
[(member label-name jump-targets)
(loop label-name
'()
(cons (make-BasicBlock
name
(if last-stmt-goto?
(reverse acc)
(reverse (append `(,(make-GotoStatement (make-Label label-name)))
acc))))
basic-blocks)
(cdr stmts)
last-stmt-goto?)]
[else
(loop name
acc
basic-blocks
(cdr stmts)
last-stmt-goto?)]))
(cond (cond
[(symbol? first-stmt) [(null? stmts)
(do-on-label first-stmt)] (reverse (cons (make-BasicBlock name (reverse acc))
[(LinkedLabel? first-stmt) basic-blocks))]
(do-on-label (LinkedLabel-label first-stmt))]
[else [else
(loop name (let: ([first-stmt : Statement (car stmts)])
(cons first-stmt acc) (: do-on-label (Symbol -> (Listof BasicBlock)))
basic-blocks (define (do-on-label label-name)
(cdr stmts) (cond
(GotoStatement? (car stmts)))]))])))) [(member label-name jump-targets)
(loop label-name
'()
(cons (make-BasicBlock
name
(if last-stmt-goto?
(reverse acc)
(reverse (append `(,(make-GotoStatement (make-Label label-name)))
acc))))
basic-blocks)
(cdr stmts)
last-stmt-goto?)]
[else
(loop name
acc
basic-blocks
(cdr stmts)
last-stmt-goto?)]))
(cond
[(symbol? first-stmt)
(do-on-label first-stmt)]
[(LinkedLabel? first-stmt)
(do-on-label (LinkedLabel-label first-stmt))]
[else
(loop name
(cons first-stmt acc)
basic-blocks
(cdr stmts)
(GotoStatement? (car stmts)))]))]))))
(: write-linked-label-attributes ((Listof Statement) Output-Port -> 'ok)) (: write-linked-label-attributes ((Listof Statement) Output-Port -> 'ok))
@ -118,40 +118,40 @@ EOF
[else [else
(let: ([stmt : Statement (first stmts)]) (let: ([stmt : Statement (first stmts)])
(define (next) (write-linked-label-attributes (rest stmts) op)) (define (next) (write-linked-label-attributes (rest stmts) op))
(cond (cond
[(symbol? stmt) [(symbol? stmt)
(next)] (next)]
[(LinkedLabel? stmt) [(LinkedLabel? stmt)
(fprintf op "~a.multipleValueReturn = ~a;\n" (fprintf op "~a.multipleValueReturn = ~a;\n"
(LinkedLabel-label stmt) (LinkedLabel-label stmt)
(LinkedLabel-linked-to stmt)) (LinkedLabel-linked-to stmt))
(next)] (next)]
[(AssignImmediateStatement? stmt) [(AssignImmediateStatement? stmt)
(next)] (next)]
[(AssignPrimOpStatement? stmt) [(AssignPrimOpStatement? stmt)
(next)] (next)]
[(PerformStatement? stmt) [(PerformStatement? stmt)
(next)] (next)]
[(TestAndBranchStatement? stmt) [(TestAndBranchStatement? stmt)
(next)] (next)]
[(GotoStatement? stmt) [(GotoStatement? stmt)
(next)] (next)]
[(PushEnvironment? stmt) [(PushEnvironment? stmt)
(next)] (next)]
[(PopEnvironment? stmt) [(PopEnvironment? stmt)
(next)] (next)]
[(PushImmediateOntoEnvironment? stmt) [(PushImmediateOntoEnvironment? stmt)
(next)] (next)]
[(PushControlFrame/Generic? stmt) [(PushControlFrame/Generic? stmt)
(next)] (next)]
[(PushControlFrame/Call? stmt) [(PushControlFrame/Call? stmt)
(next)] (next)]
[(PushControlFrame/Prompt? stmt) [(PushControlFrame/Prompt? stmt)
(next)] (next)]
[(PopControlFrame? stmt) [(PopControlFrame? stmt)
(next)]))])) (next)]))]))
@ -167,7 +167,6 @@ EOF
(: assemble-statement (UnlabeledStatement -> String)) (: assemble-statement (UnlabeledStatement -> String))
;; Generates the code to assemble a statement. ;; Generates the code to assemble a statement.
(define (assemble-statement stmt) (define (assemble-statement stmt)
@ -179,8 +178,8 @@ EOF
(cond (cond
[(AssignImmediateStatement? stmt) [(AssignImmediateStatement? stmt)
(let: ([t : String (assemble-target (AssignImmediateStatement-target stmt))] (let: ([t : String (assemble-target (AssignImmediateStatement-target stmt))]
[v : OpArg (AssignImmediateStatement-value stmt)]) [v : OpArg (AssignImmediateStatement-value stmt)])
(format "~a = ~a;" t (assemble-oparg v)))] (format "~a = ~a;" t (assemble-oparg v)))]
[(AssignPrimOpStatement? stmt) [(AssignPrimOpStatement? stmt)
(format "~a=~a;" (format "~a=~a;"
@ -191,24 +190,33 @@ EOF
(assemble-op-statement (PerformStatement-op stmt))] (assemble-op-statement (PerformStatement-op stmt))]
[(TestAndBranchStatement? stmt) [(TestAndBranchStatement? stmt)
(let*: ([test : PrimitiveTest (TestAndBranchStatement-op stmt)]) (let*: ([test : PrimitiveTest (TestAndBranchStatement-op stmt)]
(cond [jump : String (assemble-jump
[(TestFalse? test) (make-Label (TestAndBranchStatement-label stmt)))])
(format "if (~a === false) { ~a }" ;; to help localize type checks, we add a type annotation here.
(assemble-oparg (TestFalse-operand test)) (ann (cond
(assemble-jump (make-Label (TestAndBranchStatement-label stmt))))] [(TestFalse? test)
[(TestOne? test) (format "if (~a === false) { ~a }"
(format "if (~a === 1) { ~a }" (assemble-oparg (TestFalse-operand test))
(assemble-oparg (TestOne-operand test)) jump)]
(assemble-jump (make-Label (TestAndBranchStatement-label stmt))))] [(TestOne? test)
[(TestZero? test) (format "if (~a === 1) { ~a }"
(format "if (~a === 0) { ~a }" (assemble-oparg (TestOne-operand test))
(assemble-oparg (TestZero-operand test)) jump)]
(assemble-jump (make-Label (TestAndBranchStatement-label stmt))))] [(TestZero? test)
[(TestPrimitiveProcedure? test) (format "if (~a === 0) { ~a }"
(format "if (typeof(~a) === 'function') { ~a };" (assemble-oparg (TestZero-operand test))
(assemble-oparg (TestPrimitiveProcedure-operand test)) jump)]
(assemble-jump (make-Label (TestAndBranchStatement-label stmt))))]))] [(TestPrimitiveProcedure? test)
(format "if (typeof(~a) === 'function') { ~a }"
(assemble-oparg (TestPrimitiveProcedure-operand test))
jump)]
[(TestClosureArityMismatch? test)
(format "if (! RUNTIME.isArityMatching(~a.arity, ~a)) { ~a }"
(assemble-oparg (TestClosureArityMismatch-closure test))
(assemble-oparg (TestClosureArityMismatch-n test))
jump)])
String))]
[(GotoStatement? stmt) [(GotoStatement? stmt)
(assemble-jump (GotoStatement-target stmt))] (assemble-jump (GotoStatement-target stmt))]
@ -219,25 +227,25 @@ EOF
[(PushControlFrame/Call? stmt) [(PushControlFrame/Call? stmt)
(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) label]
[(LinkedLabel? label) (LinkedLabel-label label)])))] [(LinkedLabel? 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) label]
[(LinkedLabel? label) (LinkedLabel-label label)])) [(LinkedLabel? label) (LinkedLabel-label label)]))
(let: ([tag : (U DefaultContinuationPromptTag OpArg) (let: ([tag : (U DefaultContinuationPromptTag OpArg)
(PushControlFrame/Prompt-tag stmt)]) (PushControlFrame/Prompt-tag stmt)])
(cond (cond
[(DefaultContinuationPromptTag? tag) [(DefaultContinuationPromptTag? tag)
(assemble-default-continuation-prompt-tag)] (assemble-default-continuation-prompt-tag)]
[(OpArg? tag) [(OpArg? tag)
(assemble-oparg tag)])))] (assemble-oparg tag)])))]
[(PopControlFrame? stmt) [(PopControlFrame? stmt)
"MACHINE.control.pop();"] "MACHINE.control.pop();"]
@ -254,15 +262,15 @@ EOF
", ")))] ", ")))]
[(PopEnvironment? stmt) [(PopEnvironment? stmt)
(let: ([skip : OpArg (PopEnvironment-skip stmt)]) (let: ([skip : OpArg (PopEnvironment-skip stmt)])
(cond (cond
[(and (Const? skip) (= (ensure-natural (Const-const skip)) 0)) [(and (Const? skip) (= (ensure-natural (Const-const skip)) 0))
(format "MACHINE.env.length = MACHINE.env.length - ~a;" (format "MACHINE.env.length = MACHINE.env.length - ~a;"
(assemble-oparg (PopEnvironment-n stmt)))] (assemble-oparg (PopEnvironment-n stmt)))]
[else [else
(format "MACHINE.env.splice(MACHINE.env.length - (~a + ~a), ~a);" (format "MACHINE.env.splice(MACHINE.env.length - (~a + ~a), ~a);"
(assemble-oparg (PopEnvironment-skip stmt)) (assemble-oparg (PopEnvironment-skip stmt))
(assemble-oparg (PopEnvironment-n stmt)) (assemble-oparg (PopEnvironment-n stmt))
(assemble-oparg (PopEnvironment-n stmt)))]))] (assemble-oparg (PopEnvironment-n stmt)))]))]
[(PushImmediateOntoEnvironment? stmt) [(PushImmediateOntoEnvironment? stmt)
(format "MACHINE.env.push(~a);" (format "MACHINE.env.push(~a);"

4
compiler.rkt
View File

@ -606,13 +606,13 @@
(define (compile-case-lambda-body exp cenv) (define (compile-case-lambda-body exp cenv)
empty-instruction-sequence empty-instruction-sequence
#;(append-instruction-sequences #;(append-instruction-sequences
(make-instruction-sequence (make-instruction-sequence
`(,(CaseLam-entry-label exp))) `(,(CaseLam-entry-label exp)))
(apply append-instruction-sequences (apply append-instruction-sequences
;; todo: Add the case-dispatch based on arity matching.
(map (lambda: ([lam : Lam] (map (lambda: ([lam : Lam]
[i : Natural]) [i : Natural])
(let ([not-match (make-label)]) (let ([not-match (make-label)])
(make-instruction-sequence (make-instruction-sequence
`(,(make-TestAndBranchStatement arity-mismatch? `(,(make-TestAndBranchStatement arity-mismatch?

5
il-structs.rkt
View File

@ -266,17 +266,18 @@
;; Primitive tests (used with TestAndBranch) ;; Primitive tests (used with TestAndBranch)
(define-type PrimitiveTest (U (define-type PrimitiveTest (U
TestFalse TestFalse
TestOne TestOne
TestZero TestZero
TestPrimitiveProcedure TestPrimitiveProcedure
TestClosureArityMismatch
)) ))
(define-struct: TestFalse ([operand : OpArg]) #:transparent) (define-struct: TestFalse ([operand : OpArg]) #:transparent)
(define-struct: TestOne ([operand : OpArg]) #:transparent) (define-struct: TestOne ([operand : OpArg]) #:transparent)
(define-struct: TestZero ([operand : OpArg]) #:transparent) (define-struct: TestZero ([operand : OpArg]) #:transparent)
(define-struct: TestPrimitiveProcedure ([operand : OpArg]) #:transparent) (define-struct: TestPrimitiveProcedure ([operand : OpArg]) #:transparent)
(define-struct: TestClosureArityMismatch ([closure : OpArg]
[n : OpArg]) #:transparent)

9
simulator.rkt
View File

@ -210,7 +210,14 @@
(= (ensure-natural (evaluate-oparg m (TestZero-operand test))) (= (ensure-natural (evaluate-oparg m (TestZero-operand test)))
0)] 0)]
[(TestPrimitiveProcedure? test) [(TestPrimitiveProcedure? test)
(primitive-proc? (evaluate-oparg m (TestPrimitiveProcedure-operand test)))])]) (primitive-proc? (evaluate-oparg m (TestPrimitiveProcedure-operand test)))]
[(TestClosureArityMismatch? test)
(let ([proc (ensure-closure
(evaluate-oparg m (TestClosureArityMismatch-closure test)))]
[n (ensure-natural
(evaluate-oparg m (TestClosureArityMismatch-n test)))])
(not (arity-match? (closure-arity proc) n)))])])
v) v)
(jump! m (TestAndBranchStatement-label stmt)) (jump! m (TestAndBranchStatement-label stmt))
'ok))) 'ok)))

3
test-compiler.rkt
View File

@ -1217,6 +1217,9 @@
#:with-bootstrapping? #t) #:with-bootstrapping? #t)
(test '((case-lambda [(x) x]) 42)
42)

11
test-parse.rkt
View File

@ -552,3 +552,14 @@
(list (make-Lam #f 1 #f (make-LocalRef 0 #f) '() 'lamEntry2) (list (make-Lam #f 1 #f (make-LocalRef 0 #f) '() 'lamEntry2)
(make-Lam #f 2 #f (make-LocalRef 1 #f) '() 'lamEntry3)) (make-Lam #f 2 #f (make-LocalRef 1 #f) '() 'lamEntry3))
'lamEntry1))) 'lamEntry1)))
(test (parse '(case-lambda [(x y) y]
[(x) x]))
(make-Top (make-Prefix '())
(make-CaseLam
#f
(list (make-Lam #f 2 #f (make-LocalRef 1 #f) '() 'lamEntry2)
(make-Lam #f 1 #f (make-LocalRef 0 #f) '() 'lamEntry3))
'lamEntry1)))