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

continuing to shrink code down. Eliminating the use of simulator in test suite; I don't think we'll need the simulator any more.

Browse Source
This commit is contained in:
Danny Yoo 2011-09-09 14:19:56 -04:00
parent 9e11017b7e
commit 0de37fae86
10 changed files with 48 additions and 92 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
compiler/compiler.rkt
View File

@ -1423,7 +1423,7 @@
;; Compiled branch ;; Compiled branch
(make-PerformStatement (make-CheckClosureArity! (make-Reg 'argcount))) (make-PerformStatement (make-CheckClosureAndArity! (make-Reg 'argcount)))
(compile-compiled-procedure-application cenv (compile-compiled-procedure-application cenv
number-of-arguments number-of-arguments
'dynamic 'dynamic

24
compiler/il-structs.rkt
View File

@ -280,7 +280,6 @@
(define-type PrimitiveOperator (U GetCompiledProcedureEntry (define-type PrimitiveOperator (U GetCompiledProcedureEntry
MakeCompiledProcedure MakeCompiledProcedure
MakeCompiledProcedureShell MakeCompiledProcedureShell
ApplyPrimitiveProcedure
MakeBoxedEnvironmentValue MakeBoxedEnvironmentValue
@ -312,15 +311,6 @@
#:transparent) #:transparent)
;; Applies the primitive procedure that's stored in the proc register, using
;; the argcount number of values that are bound in the environment as arguments
;; to that primitive.
(define-struct: ApplyPrimitiveProcedure ()
#:transparent)
@ -356,14 +346,12 @@
TestTrue TestTrue
TestOne TestOne
TestZero TestZero
TestPrimitiveProcedure
TestClosureArityMismatch TestClosureArityMismatch
)) ))
(define-struct: TestFalse ([operand : OpArg]) #:transparent) (define-struct: TestFalse ([operand : OpArg]) #:transparent)
(define-struct: TestTrue ([operand : OpArg]) #:transparent) (define-struct: TestTrue ([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: TestClosureArityMismatch ([closure : OpArg] (define-struct: TestClosureArityMismatch ([closure : OpArg]
[n : OpArg]) #:transparent) [n : OpArg]) #:transparent)
@ -375,13 +363,10 @@
[pos : Natural]) [pos : Natural])
#:transparent) #:transparent)
;; Check the closure procedure value in 'proc and make sure it can accept the ;; Check the closure procedure value in 'proc and make sure it's a closure
;; # of arguments (stored as a number in the argcount register.). ;; that can accept the right arguments (stored as a number in the argcount register.).
(define-struct: CheckClosureArity! ([num-args : OpArg]) (define-struct: CheckClosureAndArity! ([num-args : OpArg])
#:transparent) #:transparent)
(define-struct: CheckPrimitiveArity! ([num-args : OpArg])
#:transparent)
;; Extends the environment with a prefix that holds ;; Extends the environment with a prefix that holds
@ -481,8 +466,7 @@
(define-type PrimitiveCommand (U (define-type PrimitiveCommand (U
CheckToplevelBound! CheckToplevelBound!
CheckClosureArity! CheckClosureAndArity!
CheckPrimitiveArity!
ExtendEnvironment/Prefix! ExtendEnvironment/Prefix!
InstallClosureValues! InstallClosureValues!

2
compiler/optimize-il.rkt
View File

@ -128,8 +128,6 @@
(MakeCompiledProcedureShell-arity op) (MakeCompiledProcedureShell-arity op)
(MakeCompiledProcedureShell-display-name op))] (MakeCompiledProcedureShell-display-name op))]
[(ApplyPrimitiveProcedure? op)
op]
[(MakeBoxedEnvironmentValue? op) [(MakeBoxedEnvironmentValue? op)
op] op]

3
js-assembler/assemble-expression.rkt
View File

@ -36,9 +36,6 @@
(assemble-arity (MakeCompiledProcedureShell-arity op)) (assemble-arity (MakeCompiledProcedureShell-arity op))
(assemble-display-name (MakeCompiledProcedureShell-display-name op)))] (assemble-display-name (MakeCompiledProcedureShell-display-name op)))]
[(ApplyPrimitiveProcedure? op)
(format "M.proc(M)")]
[(CaptureEnvironment? op) [(CaptureEnvironment? op)
(format "M.env.slice(0, M.env.length - ~a)" (format "M.env.slice(0, M.env.length - ~a)"
(CaptureEnvironment-skip op))] (CaptureEnvironment-skip op))]

13
js-assembler/assemble-perform-statement.rkt
View File

@ -21,18 +21,11 @@
(CheckToplevelBound!-pos op))] (CheckToplevelBound!-pos op))]
[(CheckClosureArity!? op) [(CheckClosureAndArity!? op)
(format "if(!(M.proc instanceof RT.Closure)){RT.raiseOperatorIsNotClosure(M,M.proc);}if(!RT.isArityMatching(M.proc.racketArity,~a)){RT.raiseArityMismatchError(M, M.proc,~a);}" (format "if(!(M.proc instanceof RT.Closure)){RT.raiseOperatorIsNotClosure(M,M.proc);}if(!RT.isArityMatching(M.proc.racketArity,~a)){RT.raiseArityMismatchError(M, M.proc,~a);}"
(assemble-oparg (CheckClosureArity!-num-args op)) (assemble-oparg (CheckClosureAndArity!-num-args op))
(assemble-oparg (CheckClosureArity!-num-args op)))] (assemble-oparg (CheckClosureAndArity!-num-args op)))]
[(CheckPrimitiveArity!? op)
(format "if(!RT.isArityMatching(M.proc.racketArity,~a)){RT.raiseArityMismatchError(M,M.proc,~a);}"
(assemble-oparg (CheckPrimitiveArity!-num-args op))
(assemble-oparg (CheckPrimitiveArity!-num-args op)))]
[(ExtendEnvironment/Prefix!? op) [(ExtendEnvironment/Prefix!? op)
(let: ([names : (Listof (U Symbol False GlobalBucket ModuleVariable)) (ExtendEnvironment/Prefix!-names op)]) (let: ([names : (Listof (U Symbol False GlobalBucket ModuleVariable)) (ExtendEnvironment/Prefix!-names op)])
(format "M.env.push([~a]);M.env[M.env.length-1].names=[~a];" (format "M.env.push([~a]);M.env[M.env.length-1].names=[~a];"

14
js-assembler/assemble.rkt
View File

@ -236,9 +236,9 @@ EOF
(format "if(~a===0)" (format "if(~a===0)"
(assemble-oparg (TestZero-operand test)))] (assemble-oparg (TestZero-operand test)))]
[(TestPrimitiveProcedure? test) ;; [(TestPrimitiveProcedure? test)
(format "if(typeof(~a)==='function')" ;; (format "if(typeof(~a)==='function')"
(assemble-oparg (TestPrimitiveProcedure-operand test)))] ;; (assemble-oparg (TestPrimitiveProcedure-operand test)))]
[(TestClosureArityMismatch? test) [(TestClosureArityMismatch? test)
(format "if(!RT.isArityMatching((~a).racketArity,~a))" (format "if(!RT.isArityMatching((~a).racketArity,~a))"
@ -435,10 +435,10 @@ EOF
(format "if(~a===0){~a}" (format "if(~a===0){~a}"
(assemble-oparg (TestZero-operand test)) (assemble-oparg (TestZero-operand test))
jump)] jump)]
[(TestPrimitiveProcedure? test) ;; [(TestPrimitiveProcedure? test)
(format "if(typeof(~a)==='function'){~a}" ;; (format "if(typeof(~a)==='function'){~a}"
(assemble-oparg (TestPrimitiveProcedure-operand test)) ;; (assemble-oparg (TestPrimitiveProcedure-operand test))
jump)] ;; jump)]
[(TestClosureArityMismatch? test) [(TestClosureArityMismatch? test)
(format "if(!RT.isArityMatching((~a).racketArity,~a)){~a}" (format "if(!RT.isArityMatching((~a).racketArity,~a)){~a}"
(assemble-oparg (TestClosureArityMismatch-closure test)) (assemble-oparg (TestClosureArityMismatch-closure test))

10
js-assembler/collect-jump-targets.rkt
View File

@ -112,8 +112,8 @@
(list (MakeCompiledProcedure-label op))] (list (MakeCompiledProcedure-label op))]
[(MakeCompiledProcedureShell? op) [(MakeCompiledProcedureShell? op)
(list (MakeCompiledProcedureShell-label op))] (list (MakeCompiledProcedureShell-label op))]
[(ApplyPrimitiveProcedure? op) ;; [(ApplyPrimitiveProcedure? op)
empty] ;; empty]
[(CaptureEnvironment? op) [(CaptureEnvironment? op)
empty] empty]
[(CaptureControl? op) [(CaptureControl? op)
@ -258,8 +258,8 @@
(list (MakeCompiledProcedure-label op))] (list (MakeCompiledProcedure-label op))]
[(MakeCompiledProcedureShell? op) [(MakeCompiledProcedureShell? op)
(list (MakeCompiledProcedureShell-label op))] (list (MakeCompiledProcedureShell-label op))]
[(ApplyPrimitiveProcedure? op) ;; [(ApplyPrimitiveProcedure? op)
empty] ;; empty]
[(CaptureEnvironment? op) [(CaptureEnvironment? op)
empty] empty]
[(CaptureControl? op) [(CaptureControl? op)
@ -279,7 +279,7 @@
;; currently written this way because I'm hitting some bad type-checking behavior. ;; currently written this way because I'm hitting some bad type-checking behavior.
#;([(CheckToplevelBound!? op) #;([(CheckToplevelBound!? op)
empty] empty]
[(CheckClosureArity!? op) [(CheckClosureAndArity!? op)
empty] empty]
[(CheckPrimitiveArity!? op) [(CheckPrimitiveArity!? op)
empty] empty]

24
simulator/simulator.rkt
View File

@ -308,15 +308,15 @@
[else [else
'ok]))] 'ok]))]
[(CheckClosureArity!? op) [(CheckClosureAndArity!? op)
(let: ([clos : SlotValue (machine-proc m)]) (let: ([clos : SlotValue (machine-proc m)])
(cond (cond
[(closure? clos) [(closure? clos)
(if (arity-match? (closure-arity clos) (if (arity-match? (closure-arity clos)
(ensure-natural (evaluate-oparg m (CheckClosureArity!-num-args op)))) (ensure-natural (evaluate-oparg m (CheckClosureAndArity!-num-args op))))
'ok 'ok
(error 'check-closure-arity "arity mismatch: passed ~s args to ~s" (error 'check-closure-arity "arity mismatch: passed ~s args to ~s"
(ensure-natural (evaluate-oparg m (CheckClosureArity!-num-args op))) (ensure-natural (evaluate-oparg m (CheckClosureAndArity!-num-args op)))
(closure-display-name clos)))] (closure-display-name clos)))]
[else [else
(error 'check-closure-arity "not a closure: ~s" clos)]))] (error 'check-closure-arity "not a closure: ~s" clos)]))]
@ -654,23 +654,7 @@
(MakeCompiledProcedureShell-arity op) (MakeCompiledProcedureShell-arity op)
'() '()
(MakeCompiledProcedureShell-display-name op)))] (MakeCompiledProcedureShell-display-name op)))]
[(ApplyPrimitiveProcedure? op)
(let: ([prim : SlotValue (machine-proc m)]
[args : (Listof PrimitiveValue)
(map ensure-primitive-value (take (machine-env m)
(ensure-natural (machine-argcount m))))])
(cond
[(primitive-proc? prim)
(target-updater! m (ensure-primitive-value
(parameterize ([current-output-port
(current-simulated-output-port)])
(apply (primitive-proc-f prim)
m
args))))]
[else
(error 'apply-primitive-procedure)]))]
[(CaptureEnvironment? op) [(CaptureEnvironment? op)
(target-updater! m (make-CapturedEnvironment (drop (machine-env m) (target-updater! m (make-CapturedEnvironment (drop (machine-env m)
(CaptureEnvironment-skip op))))] (CaptureEnvironment-skip op))))]

6
tests/test-all.rkt
View File

@ -2,9 +2,9 @@
(require "test-parse.rkt" (require "test-parse.rkt"
"test-parse-bytecode.rkt" "test-parse-bytecode.rkt"
"test-simulator.rkt" ;; "test-simulator.rkt"
"test-compiler.rkt" ;; "test-compiler.rkt"
"test-compiler-2.rkt" ;; "test-compiler-2.rkt"
"test-assemble.rkt" "test-assemble.rkt"
"test-browser-evaluate.rkt" "test-browser-evaluate.rkt"
"test-package.rkt" "test-package.rkt"

42
tests/test-assemble.rkt
View File

@ -265,7 +265,7 @@
(list 0 1) (list 0 1)
'closureStart)) 'closureStart))
(make-PopEnvironment (make-Const 2) (make-Const 0)) (make-PopEnvironment (make-Const 2) (make-Const 0))
(make-PerformStatement (make-CheckClosureArity! (make-Const 5))) (make-PerformStatement (make-CheckClosureAndArity! (make-Const 5)))
'theEnd))) 'theEnd)))
;; this should fail, since the check is for 1, but the closure expects 5. ;; this should fail, since the check is for 1, but the closure expects 5.
@ -288,7 +288,7 @@
(list 0 1) (list 0 1)
'closureStart)) 'closureStart))
(make-PopEnvironment (make-Const 2) (make-Const 0)) (make-PopEnvironment (make-Const 2) (make-Const 0))
(make-PerformStatement (make-CheckClosureArity! (make-Const 1))) (make-PerformStatement (make-CheckClosureAndArity! (make-Const 1)))
'theEnd))) 'theEnd)))
(error 'expected-failure)) (error 'expected-failure))
@ -315,15 +315,15 @@
end)) end))
"ok") "ok")
;; Test for primitive procedure ;; ;; Test for primitive procedure
(test (E-many `(,(make-AssignImmediateStatement 'val (make-Const '+)) ;; (test (E-many `(,(make-AssignImmediateStatement 'val (make-Const '+))
,(make-TestAndJumpStatement (make-TestPrimitiveProcedure (make-Reg 'val)) 'onTrue) ;; ,(make-TestAndJumpStatement (make-TestPrimitiveProcedure (make-Reg 'val)) 'onTrue)
,(make-AssignImmediateStatement 'val (make-Const 'ok)) ;; ,(make-AssignImmediateStatement 'val (make-Const 'ok))
,(make-GotoStatement (make-Label 'end)) ;; ,(make-GotoStatement (make-Label 'end))
onTrue ;; onTrue
,(make-AssignImmediateStatement 'val (make-Const 'not-ok)) ;; ,(make-AssignImmediateStatement 'val (make-Const 'not-ok))
end)) ;; end))
"ok") ;; "ok")
;; ;; Give a primitive procedure in val ;; ;; Give a primitive procedure in val
;; (test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+))) ;; (test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+)))
@ -336,16 +336,16 @@
;; end)) ;; end))
;; "ok") ;; "ok")
;; Give a primitive procedure in proc, but test val ;; ;; Give a primitive procedure in proc, but test val
(test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+))) ;; (test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+)))
,(make-AssignImmediateStatement 'proc (make-EnvPrefixReference 0 0)) ;; ,(make-AssignImmediateStatement 'proc (make-EnvPrefixReference 0 0))
,(make-TestAndJumpStatement (make-TestPrimitiveProcedure (make-Reg 'val)) 'onTrue) ;; ,(make-TestAndJumpStatement (make-TestPrimitiveProcedure (make-Reg 'val)) 'onTrue)
,(make-AssignImmediateStatement 'val (make-Const 'not-a-procedure)) ;; ,(make-AssignImmediateStatement 'val (make-Const 'not-a-procedure))
,(make-GotoStatement (make-Label 'end)) ;; ,(make-GotoStatement (make-Label 'end))
onTrue ;; onTrue
,(make-AssignImmediateStatement 'val (make-Const 'a-procedure)) ;; ,(make-AssignImmediateStatement 'val (make-Const 'a-procedure))
end)) ;; end))
"not-a-procedure") ;; "not-a-procedure")
;; ;; Give a primitive procedure in proc and test proc ;; ;; Give a primitive procedure in proc and test proc
;; (test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+))) ;; (test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+)))