diff --git a/assemble.rkt b/assemble.rkt index fa320b2..e3c9877 100644 --- a/assemble.rkt +++ b/assemble.rkt @@ -10,15 +10,20 @@ assemble-statement) +;; Parameter that controls the generation of a trace. +(define current-emit-debug-trace? (make-parameter #f)) + + + (: assemble/write-invoke ((Listof Statement) Output-Port -> Void)) ;; Writes out the JavaScript code that represents the anonymous invocation expression. (define (assemble/write-invoke stmts op) (let ([basic-blocks (fracture stmts)]) - (fprintf op "(function(success, fail, params) {\n") + (fprintf op "(function(MACHINE, success, fail, params) {\n") (fprintf op "var param;\n") (for-each (lambda: ([basic-block : BasicBlock]) - (displayln (assemble-basic-block basic-block) op) - (newline op)) + (displayln (assemble-basic-block basic-block) op) + (newline op)) basic-blocks) (fprintf op "MACHINE.params.currentErrorHandler = function(e) { fail(e); };\n") (fprintf op #< (Listof Symbol))) (define (collect-location a-location) (cond @@ -132,7 +137,7 @@ EOF empty] [(CaptureControl? op) empty])) - + (: collect-primitive-command (PrimitiveCommand -> (Listof Symbol))) (define (collect-primitive-command op) (cond @@ -151,45 +156,45 @@ EOF (unique/eq? (let: loop : (Listof Symbol) ([stmts : (Listof Statement) stmts]) - (cond [(empty? stmts) - empty] - [else - (let ([stmt (first stmts)]) - (append (cond - [(symbol? stmt) - empty] - [(AssignImmediateStatement? stmt) - (let: ([v : OpArg (AssignImmediateStatement-value stmt)]) - (cond - [(Reg? v) - empty] - [(Label? v) - (list (Label-name v))] - [(Const? v) - empty] - [(EnvLexicalReference? v) - empty] - [(EnvPrefixReference? v) - empty] - [(EnvWholePrefixReference? v) - empty]))] - [(AssignPrimOpStatement? stmt) - (collect-primitive-operator (AssignPrimOpStatement-op stmt))] - [(PerformStatement? stmt) - (collect-primitive-command (PerformStatement-op stmt))] - [(TestAndBranchStatement? stmt) - (list (TestAndBranchStatement-label stmt))] - [(GotoStatement? stmt) - (collect-location (GotoStatement-target stmt))] - [(PushEnvironment? stmt) - empty] - [(PopEnvironment? stmt) - empty] - [(PushControlFrame? stmt) - (list (PushControlFrame-label stmt))] - [(PopControlFrame? stmt) - empty]) - (loop (rest stmts))))])))) + (cond [(empty? stmts) + empty] + [else + (let ([stmt (first stmts)]) + (append (cond + [(symbol? stmt) + empty] + [(AssignImmediateStatement? stmt) + (let: ([v : OpArg (AssignImmediateStatement-value stmt)]) + (cond + [(Reg? v) + empty] + [(Label? v) + (list (Label-name v))] + [(Const? v) + empty] + [(EnvLexicalReference? v) + empty] + [(EnvPrefixReference? v) + empty] + [(EnvWholePrefixReference? v) + empty]))] + [(AssignPrimOpStatement? stmt) + (collect-primitive-operator (AssignPrimOpStatement-op stmt))] + [(PerformStatement? stmt) + (collect-primitive-command (PerformStatement-op stmt))] + [(TestAndBranchStatement? stmt) + (list (TestAndBranchStatement-label stmt))] + [(GotoStatement? stmt) + (collect-location (GotoStatement-target stmt))] + [(PushEnvironment? stmt) + empty] + [(PopEnvironment? stmt) + empty] + [(PushControlFrame? stmt) + (list (PushControlFrame-label stmt))] + [(PopControlFrame? stmt) + empty]) + (loop (rest stmts))))])))) @@ -197,7 +202,7 @@ EOF ;; assemble-basic-block: basic-block -> string (: assemble-basic-block (BasicBlock -> String)) (define (assemble-basic-block a-basic-block) - (format "var ~a=function(){\nif(--MACHINE.callsBeforeTrampoline < 0) { throw ~a; }\n~a};" + (format "var ~a=function(MACHINE){\nif(--MACHINE.callsBeforeTrampoline < 0) { throw function() { return ~a(MACHINE); }; }\n~a};" (BasicBlock-name a-basic-block) (BasicBlock-name a-basic-block) (string-join (map assemble-statement (BasicBlock-stmts a-basic-block)) @@ -223,51 +228,63 @@ EOF (: assemble-statement (UnlabeledStatement -> String)) ;; Generates the code to assemble a statement. (define (assemble-statement stmt) - (cond - [(AssignImmediateStatement? stmt) - (let ([t (assemble-target (AssignImmediateStatement-target stmt))] - [v (AssignImmediateStatement-value stmt)]) - (format "~a = ~a;" t (assemble-oparg v)))] - - [(AssignPrimOpStatement? stmt) - (format "~a=~a;" - (assemble-target (AssignPrimOpStatement-target stmt)) - (assemble-op-expression (AssignPrimOpStatement-op stmt)))] - - [(PerformStatement? stmt) - (assemble-op-statement (PerformStatement-op stmt))] - - [(TestAndBranchStatement? stmt) - (let*: ([test : PrimitiveTest (TestAndBranchStatement-op stmt)]) - (cond - [(eq? test 'false?) - (format "if (! ~a) { return ~a(); }" - (assemble-reg (make-Reg (TestAndBranchStatement-register stmt))) - (assemble-label (make-Label (TestAndBranchStatement-label stmt))))] - [(eq? test 'primitive-procedure?) - (format "if (typeof(~a) === 'function') { return ~a(); };" - (assemble-reg (make-Reg (TestAndBranchStatement-register stmt))) - (assemble-label (make-Label (TestAndBranchStatement-label stmt))))]))] + (string-append + (if (current-emit-debug-trace?) + (format "if (typeof(window.console) !== 'undefined' && typeof(console.log) === 'function') { console.log(~s);\n}" + (format "~a" stmt)) + "") + (cond + [(AssignImmediateStatement? stmt) + (let ([t (assemble-target (AssignImmediateStatement-target stmt))] + [v (AssignImmediateStatement-value stmt)]) + (format "~a = ~a;" t (assemble-oparg v)))] + + [(AssignPrimOpStatement? stmt) + (format "~a=~a;" + (assemble-target (AssignPrimOpStatement-target stmt)) + (assemble-op-expression (AssignPrimOpStatement-op stmt)))] + + [(PerformStatement? stmt) + (assemble-op-statement (PerformStatement-op stmt))] + + [(TestAndBranchStatement? stmt) + (let*: ([test : PrimitiveTest (TestAndBranchStatement-op stmt)]) + (cond + [(eq? test 'false?) + (format "if (! ~a) { ~a }" + (assemble-reg (make-Reg (TestAndBranchStatement-register stmt))) + (assemble-jump (make-Label (TestAndBranchStatement-label stmt))))] + [(eq? test 'primitive-procedure?) + (format "if (typeof(~a) === 'function') { ~a };" + (assemble-reg (make-Reg (TestAndBranchStatement-register stmt))) + (assemble-jump (make-Label (TestAndBranchStatement-label stmt))))]))] + + [(GotoStatement? stmt) + (assemble-jump (GotoStatement-target stmt))] - [(GotoStatement? stmt) - (format "return ~a();" (assemble-location (GotoStatement-target stmt)))] - [(PushControlFrame? stmt) - (format "MACHINE.control.push(new Frame(~a, MACHINE.proc));" (PushControlFrame-label stmt))] - [(PopControlFrame? stmt) - "MACHINE.control.pop();"] - [(PushEnvironment? stmt) - (format "MACHINE.env.push(~a);" (string-join - (build-list (PushEnvironment-n stmt) - (lambda: ([i : Natural]) - (if (PushEnvironment-unbox? stmt) - "[undefined]" - "undefined"))) - ", "))] - [(PopEnvironment? stmt) - (format "MACHINE.env.splice(MACHINE.env.length-(~a),~a);" - (+ (PopEnvironment-skip stmt) - (PopEnvironment-n stmt)) - (PopEnvironment-n stmt))])) + [(PushControlFrame? stmt) + (format "MACHINE.control.push(new Frame(~a, MACHINE.proc));" (PushControlFrame-label stmt))] + [(PopControlFrame? stmt) + "MACHINE.control.pop();"] + [(PushEnvironment? stmt) + (format "MACHINE.env.push(~a);" (string-join + (build-list (PushEnvironment-n stmt) + (lambda: ([i : Natural]) + (if (PushEnvironment-unbox? stmt) + "[undefined]" + "undefined"))) + ", "))] + [(PopEnvironment? stmt) + (format "MACHINE.env.splice(MACHINE.env.length-(~a),~a);" + (+ (PopEnvironment-skip stmt) + (PopEnvironment-n stmt)) + (PopEnvironment-n stmt))]))) + + + +(: assemble-jump ((U Label Reg) -> String)) +(define (assemble-jump target) + (format "return (~a)(MACHINE);" (assemble-location target))) @@ -367,7 +384,7 @@ EOF (format "MACHINE.proc(~a, ~a)" (ApplyPrimitiveProcedure-arity op) (ApplyPrimitiveProcedure-label op))] - + [(GetControlStackLabel? op) (format "MACHINE.control[MACHINE.control.length-1].label")] [(CaptureEnvironment? op) @@ -428,7 +445,7 @@ EOF (assemble-prefix-reference an-input)] [(EnvWholePrefixReference? an-input) (assemble-whole-prefix-reference an-input)])) - + (: assemble-location ((U Reg Label) -> String)) (define (assemble-location a-location) (cond diff --git a/package.rkt b/package.rkt index 8849d9d..e5203b0 100644 --- a/package.rkt +++ b/package.rkt @@ -13,18 +13,8 @@ ;; Packager: produce single .js files to be included. -(define-runtime-path runtime.js "runtime.js") - ;; package: s-expression output-port -> void -(define (package source-code op) - - ;; The runtime code - (call-with-input-file* runtime.js - (lambda (ip) - (copy-port ip op))) - - (newline op) - +(define (package source-code op) (fprintf op "var invoke = ") (assemble/write-invoke (append (get-bootstrapping-code) (compile (parse source-code) diff --git a/runtime.js b/runtime.js index c5d5595..b858eaf 100644 --- a/runtime.js +++ b/runtime.js @@ -293,65 +293,11 @@ var Primitives = (function() { } return true; } - -// , -// 'call/cc': new Closure(callCCEntry, -// 1, -// [], -// "call/cc"), -// 'call-with-current-continuation': new Closure(callCCEntry, -// 1, -// [], -// "call-with-current-continuation") - }; })(); - -// // adaptToJs: closure -> (array (X -> void) -> void) -// // Converts closures to functions that can be called from the -// // JavaScript toplevel. -// Closure.prototype.adaptToJs = function() { -// var that = this; -// return function(args, success, fail) { -// var oldEnv = MACHINE.env; -// var oldCont = MACHINE.cont; -// var oldProc = MACHINE.proc; -// var oldArgl = MACHINE.argl; -// var oldVal = MACHINE.val; -// trampoline( -// function() { -// var proc = that; -// MACHINE.proc = proc; -// MACHINE.argl = undefined; -// for(var i = args.length - 1; i >= 0; i--) { -// MACHINE.argl = [args[i], MACHINE.argl]; -// } - -// MACHINE.cont = function() { -// var result = MACHINE.val; -// MACHINE.env = oldEnv; -// MACHINE.cont = oldCont; -// MACHINE.proc = oldProc; -// MACHINE.argl = oldArgl; -// MACHINE.val = oldVal; -// success(result); -// }; - -// proc.label(); -// }, -// function() { -// }, -// function(e) { -// return fail(e); -// }); -// } -// }; - - - var MACHINE = { callsBeforeTrampoline: 100, val:undefined, proc:undefined, @@ -398,7 +344,7 @@ var recomputeMaxNumBouncesBeforeYield = function(observedDelay) { }; -var trampoline = function(initialJump, success, fail) { +var trampoline = function(MACHINE, initialJump, success, fail) { var thunk = initialJump; var startTime = (new Date()).valueOf(); MACHINE.callsBeforeTrampoline = 100; @@ -408,7 +354,7 @@ var trampoline = function(initialJump, success, fail) { while(thunk) { try { - thunk(); + thunk(MACHINE); break; } catch (e) { if (typeof(e) === 'function') { @@ -420,7 +366,7 @@ var trampoline = function(initialJump, success, fail) { (new Date()).valueOf() - startTime); setTimeout( function() { - trampoline(thunk, success, fail); + trampoline(MACHINE, thunk, success, fail); }, 0); return; diff --git a/test-assemble.rkt b/test-assemble.rkt index aa8fe24..9cb75d1 100644 --- a/test-assemble.rkt +++ b/test-assemble.rkt @@ -69,7 +69,7 @@ (display ";" op) (fprintf op - "return function(succ, fail, params) { myInvoke(function(v) { succ(String(~a));}, fail, params); }" + "return function(succ, fail, params) { myInvoke(MACHINE, function(v) { succ(String(~a));}, fail, params); }" inspector) (display "})" op)))))) (define (E-many stmts (inspector "MACHINE.val")) diff --git a/test-browser-evaluate.rkt b/test-browser-evaluate.rkt index 8c5982a..86e61cb 100644 --- a/test-browser-evaluate.rkt +++ b/test-browser-evaluate.rkt @@ -1,8 +1,36 @@ #lang racket (require "browser-evaluate.rkt" - "package.rkt") + "package.rkt" + racket/runtime-path) -(define evaluate (make-evaluate package-anonymous)) + +(define-runtime-path runtime.js "runtime.js") + +(define evaluate (make-evaluate + (lambda (program op) + + (fprintf op "(function () {") + + ;; The runtime code + (call-with-input-file* runtime.js + (lambda (ip) + (copy-port ip op))) + + (newline op) + + (fprintf op "var innerInvoke = ") + (package-anonymous program op) + (fprintf op "();\n") + + (fprintf op #<