From 0de37fae867f77c4d324c8ae4b91b22205717585 Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Fri, 9 Sep 2011 14:19:56 -0400 Subject: [PATCH] continuing to shrink code down. Eliminating the use of simulator in test suite; I don't think we'll need the simulator any more. --- compiler/compiler.rkt | 2 +- compiler/il-structs.rkt | 24 ++---------- compiler/optimize-il.rkt | 2 - js-assembler/assemble-expression.rkt | 3 -- js-assembler/assemble-perform-statement.rkt | 13 ++----- js-assembler/assemble.rkt | 14 +++---- js-assembler/collect-jump-targets.rkt | 10 ++--- simulator/simulator.rkt | 24 ++---------- tests/test-all.rkt | 6 +-- tests/test-assemble.rkt | 42 ++++++++++----------- 10 files changed, 48 insertions(+), 92 deletions(-) diff --git a/compiler/compiler.rkt b/compiler/compiler.rkt index 2342c24..bfe9a99 100644 --- a/compiler/compiler.rkt +++ b/compiler/compiler.rkt @@ -1423,7 +1423,7 @@ ;; Compiled branch - (make-PerformStatement (make-CheckClosureArity! (make-Reg 'argcount))) + (make-PerformStatement (make-CheckClosureAndArity! (make-Reg 'argcount))) (compile-compiled-procedure-application cenv number-of-arguments 'dynamic diff --git a/compiler/il-structs.rkt b/compiler/il-structs.rkt index 33552b2..2783aa5 100644 --- a/compiler/il-structs.rkt +++ b/compiler/il-structs.rkt @@ -280,7 +280,6 @@ (define-type PrimitiveOperator (U GetCompiledProcedureEntry MakeCompiledProcedure MakeCompiledProcedureShell - ApplyPrimitiveProcedure MakeBoxedEnvironmentValue @@ -312,15 +311,6 @@ #: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 TestOne TestZero - TestPrimitiveProcedure TestClosureArityMismatch )) (define-struct: TestFalse ([operand : OpArg]) #:transparent) (define-struct: TestTrue ([operand : OpArg]) #:transparent) (define-struct: TestOne ([operand : OpArg]) #:transparent) (define-struct: TestZero ([operand : OpArg]) #:transparent) -(define-struct: TestPrimitiveProcedure ([operand : OpArg]) #:transparent) (define-struct: TestClosureArityMismatch ([closure : OpArg] [n : OpArg]) #:transparent) @@ -375,13 +363,10 @@ [pos : Natural]) #:transparent) -;; Check the closure procedure value in 'proc and make sure it can accept the -;; # of arguments (stored as a number in the argcount register.). -(define-struct: CheckClosureArity! ([num-args : OpArg]) +;; Check the closure procedure value in 'proc and make sure it's a closure +;; that can accept the right arguments (stored as a number in the argcount register.). +(define-struct: CheckClosureAndArity! ([num-args : OpArg]) #:transparent) -(define-struct: CheckPrimitiveArity! ([num-args : OpArg]) - #:transparent) - ;; Extends the environment with a prefix that holds @@ -481,8 +466,7 @@ (define-type PrimitiveCommand (U CheckToplevelBound! - CheckClosureArity! - CheckPrimitiveArity! + CheckClosureAndArity! ExtendEnvironment/Prefix! InstallClosureValues! diff --git a/compiler/optimize-il.rkt b/compiler/optimize-il.rkt index 4f4b48c..4c8f921 100644 --- a/compiler/optimize-il.rkt +++ b/compiler/optimize-il.rkt @@ -128,8 +128,6 @@ (MakeCompiledProcedureShell-arity op) (MakeCompiledProcedureShell-display-name op))] - [(ApplyPrimitiveProcedure? op) - op] [(MakeBoxedEnvironmentValue? op) op] diff --git a/js-assembler/assemble-expression.rkt b/js-assembler/assemble-expression.rkt index 651da60..47c9708 100644 --- a/js-assembler/assemble-expression.rkt +++ b/js-assembler/assemble-expression.rkt @@ -36,9 +36,6 @@ (assemble-arity (MakeCompiledProcedureShell-arity op)) (assemble-display-name (MakeCompiledProcedureShell-display-name op)))] - [(ApplyPrimitiveProcedure? op) - (format "M.proc(M)")] - [(CaptureEnvironment? op) (format "M.env.slice(0, M.env.length - ~a)" (CaptureEnvironment-skip op))] diff --git a/js-assembler/assemble-perform-statement.rkt b/js-assembler/assemble-perform-statement.rkt index 61db922..5944fc1 100644 --- a/js-assembler/assemble-perform-statement.rkt +++ b/js-assembler/assemble-perform-statement.rkt @@ -21,18 +21,11 @@ (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);}" - (assemble-oparg (CheckClosureArity!-num-args op)) - (assemble-oparg (CheckClosureArity!-num-args op)))] + (assemble-oparg (CheckClosureAndArity!-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) (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];" diff --git a/js-assembler/assemble.rkt b/js-assembler/assemble.rkt index 096e846..951d0b2 100644 --- a/js-assembler/assemble.rkt +++ b/js-assembler/assemble.rkt @@ -236,9 +236,9 @@ EOF (format "if(~a===0)" (assemble-oparg (TestZero-operand test)))] - [(TestPrimitiveProcedure? test) - (format "if(typeof(~a)==='function')" - (assemble-oparg (TestPrimitiveProcedure-operand test)))] + ;; [(TestPrimitiveProcedure? test) + ;; (format "if(typeof(~a)==='function')" + ;; (assemble-oparg (TestPrimitiveProcedure-operand test)))] [(TestClosureArityMismatch? test) (format "if(!RT.isArityMatching((~a).racketArity,~a))" @@ -435,10 +435,10 @@ EOF (format "if(~a===0){~a}" (assemble-oparg (TestZero-operand test)) jump)] - [(TestPrimitiveProcedure? test) - (format "if(typeof(~a)==='function'){~a}" - (assemble-oparg (TestPrimitiveProcedure-operand test)) - jump)] + ;; [(TestPrimitiveProcedure? test) + ;; (format "if(typeof(~a)==='function'){~a}" + ;; (assemble-oparg (TestPrimitiveProcedure-operand test)) + ;; jump)] [(TestClosureArityMismatch? test) (format "if(!RT.isArityMatching((~a).racketArity,~a)){~a}" (assemble-oparg (TestClosureArityMismatch-closure test)) diff --git a/js-assembler/collect-jump-targets.rkt b/js-assembler/collect-jump-targets.rkt index b21c56f..0f334bf 100644 --- a/js-assembler/collect-jump-targets.rkt +++ b/js-assembler/collect-jump-targets.rkt @@ -112,8 +112,8 @@ (list (MakeCompiledProcedure-label op))] [(MakeCompiledProcedureShell? op) (list (MakeCompiledProcedureShell-label op))] - [(ApplyPrimitiveProcedure? op) - empty] + ;; [(ApplyPrimitiveProcedure? op) + ;; empty] [(CaptureEnvironment? op) empty] [(CaptureControl? op) @@ -258,8 +258,8 @@ (list (MakeCompiledProcedure-label op))] [(MakeCompiledProcedureShell? op) (list (MakeCompiledProcedureShell-label op))] - [(ApplyPrimitiveProcedure? op) - empty] + ;; [(ApplyPrimitiveProcedure? op) + ;; empty] [(CaptureEnvironment? op) empty] [(CaptureControl? op) @@ -279,7 +279,7 @@ ;; currently written this way because I'm hitting some bad type-checking behavior. #;([(CheckToplevelBound!? op) empty] - [(CheckClosureArity!? op) + [(CheckClosureAndArity!? op) empty] [(CheckPrimitiveArity!? op) empty] diff --git a/simulator/simulator.rkt b/simulator/simulator.rkt index 8ef658a..36d60bc 100644 --- a/simulator/simulator.rkt +++ b/simulator/simulator.rkt @@ -308,15 +308,15 @@ [else 'ok]))] - [(CheckClosureArity!? op) + [(CheckClosureAndArity!? op) (let: ([clos : SlotValue (machine-proc m)]) (cond [(closure? 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 (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)))] [else (error 'check-closure-arity "not a closure: ~s" clos)]))] @@ -654,23 +654,7 @@ (MakeCompiledProcedureShell-arity 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) (target-updater! m (make-CapturedEnvironment (drop (machine-env m) (CaptureEnvironment-skip op))))] diff --git a/tests/test-all.rkt b/tests/test-all.rkt index cb7cfbd..4237463 100644 --- a/tests/test-all.rkt +++ b/tests/test-all.rkt @@ -2,9 +2,9 @@ (require "test-parse.rkt" "test-parse-bytecode.rkt" - "test-simulator.rkt" - "test-compiler.rkt" - "test-compiler-2.rkt" + ;; "test-simulator.rkt" + ;; "test-compiler.rkt" + ;; "test-compiler-2.rkt" "test-assemble.rkt" "test-browser-evaluate.rkt" "test-package.rkt" diff --git a/tests/test-assemble.rkt b/tests/test-assemble.rkt index 40f6123..e92b5d3 100644 --- a/tests/test-assemble.rkt +++ b/tests/test-assemble.rkt @@ -265,7 +265,7 @@ (list 0 1) 'closureStart)) (make-PopEnvironment (make-Const 2) (make-Const 0)) - (make-PerformStatement (make-CheckClosureArity! (make-Const 5))) + (make-PerformStatement (make-CheckClosureAndArity! (make-Const 5))) 'theEnd))) ;; this should fail, since the check is for 1, but the closure expects 5. @@ -288,7 +288,7 @@ (list 0 1) 'closureStart)) (make-PopEnvironment (make-Const 2) (make-Const 0)) - (make-PerformStatement (make-CheckClosureArity! (make-Const 1))) + (make-PerformStatement (make-CheckClosureAndArity! (make-Const 1))) 'theEnd))) (error 'expected-failure)) @@ -315,15 +315,15 @@ end)) "ok") -;; Test for primitive procedure -(test (E-many `(,(make-AssignImmediateStatement 'val (make-Const '+)) - ,(make-TestAndJumpStatement (make-TestPrimitiveProcedure (make-Reg 'val)) 'onTrue) - ,(make-AssignImmediateStatement 'val (make-Const 'ok)) - ,(make-GotoStatement (make-Label 'end)) - onTrue - ,(make-AssignImmediateStatement 'val (make-Const 'not-ok)) - end)) - "ok") +;; ;; Test for primitive procedure +;; (test (E-many `(,(make-AssignImmediateStatement 'val (make-Const '+)) +;; ,(make-TestAndJumpStatement (make-TestPrimitiveProcedure (make-Reg 'val)) 'onTrue) +;; ,(make-AssignImmediateStatement 'val (make-Const 'ok)) +;; ,(make-GotoStatement (make-Label 'end)) +;; onTrue +;; ,(make-AssignImmediateStatement 'val (make-Const 'not-ok)) +;; end)) +;; "ok") ;; ;; Give a primitive procedure in val ;; (test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+))) @@ -336,16 +336,16 @@ ;; end)) ;; "ok") -;; Give a primitive procedure in proc, but test val -(test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+))) - ,(make-AssignImmediateStatement 'proc (make-EnvPrefixReference 0 0)) - ,(make-TestAndJumpStatement (make-TestPrimitiveProcedure (make-Reg 'val)) 'onTrue) - ,(make-AssignImmediateStatement 'val (make-Const 'not-a-procedure)) - ,(make-GotoStatement (make-Label 'end)) - onTrue - ,(make-AssignImmediateStatement 'val (make-Const 'a-procedure)) - end)) - "not-a-procedure") +;; ;; Give a primitive procedure in proc, but test val +;; (test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+))) +;; ,(make-AssignImmediateStatement 'proc (make-EnvPrefixReference 0 0)) +;; ,(make-TestAndJumpStatement (make-TestPrimitiveProcedure (make-Reg 'val)) 'onTrue) +;; ,(make-AssignImmediateStatement 'val (make-Const 'not-a-procedure)) +;; ,(make-GotoStatement (make-Label 'end)) +;; onTrue +;; ,(make-AssignImmediateStatement 'val (make-Const 'a-procedure)) +;; end)) +;; "not-a-procedure") ;; ;; Give a primitive procedure in proc and test proc ;; (test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+)))