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

trying to lexically scope MACHINE for modularity and performance

Browse Source
This commit is contained in:
Danny Yoo 2011-03-18 20:10:44 -04:00
parent dcff043704
commit cbd1d8cb58
5 changed files with 174 additions and 193 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

261
assemble.rkt
View File

@ -10,15 +10,20 @@
assemble-statement) 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)) (: assemble/write-invoke ((Listof Statement) Output-Port -> Void))
;; 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 (fracture stmts)]) (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") (fprintf op "var param;\n")
(for-each (lambda: ([basic-block : BasicBlock]) (for-each (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)
(fprintf op "MACHINE.params.currentErrorHandler = function(e) { fail(e); };\n") (fprintf op "MACHINE.params.currentErrorHandler = function(e) { fail(e); };\n")
(fprintf op #<<EOF (fprintf op #<<EOF
@ -29,7 +34,7 @@ for (param in params) {
} }
EOF EOF
) )
(fprintf op "trampoline(~a, function() {success(MACHINE.val)}, fail); })" (fprintf op "trampoline(MACHINE, ~a, function() {success(MACHINE.val)}, fail); })"
(BasicBlock-name (first basic-blocks))))) (BasicBlock-name (first basic-blocks)))))
@ -43,7 +48,7 @@ EOF
(first stmts) (first stmts)
(make-label 'start))] (make-label 'start))]
[stmts (if (and (not (empty? stmts)) [stmts (if (and (not (empty? stmts))
(symbol? (first stmts))) (symbol? (first stmts)))
(rest stmts) (rest stmts)
stmts)] stmts)]
[jump-targets [jump-targets
@ -54,35 +59,35 @@ EOF
[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 (cond
[(null? stmts) [(null? stmts)
(reverse (cons (make-BasicBlock name (reverse acc)) (reverse (cons (make-BasicBlock name (reverse acc))
basic-blocks))] basic-blocks))]
[(symbol? (car stmts)) [(symbol? (car stmts))
(cond (cond
[(member (car stmts) jump-targets) [(member (car stmts) jump-targets)
(loop (car stmts) (loop (car stmts)
'() '()
(cons (make-BasicBlock name (cons (make-BasicBlock name
(if last-stmt-goto? (if last-stmt-goto?
(reverse acc) (reverse acc)
(reverse (append `(,(make-GotoStatement (make-Label (car stmts)))) (reverse (append `(,(make-GotoStatement (make-Label (car stmts))))
acc)))) acc))))
basic-blocks) basic-blocks)
(cdr stmts) (cdr stmts)
last-stmt-goto?)] last-stmt-goto?)]
[else [else
(loop name (loop name
acc acc
basic-blocks basic-blocks
(cdr stmts) (cdr stmts)
last-stmt-goto?)])] last-stmt-goto?)])]
[else [else
(loop name (loop name
(cons (car stmts) acc) (cons (car stmts) acc)
basic-blocks basic-blocks
(cdr stmts) (cdr stmts)
(GotoStatement? (car stmts)))])))) (GotoStatement? (car stmts)))]))))
@ -108,7 +113,7 @@ EOF
empty] empty]
[(EnvWholePrefixReference? an-input) [(EnvWholePrefixReference? an-input)
empty])) empty]))
(: collect-location ((U Reg Label) -> (Listof Symbol))) (: collect-location ((U Reg Label) -> (Listof Symbol)))
(define (collect-location a-location) (define (collect-location a-location)
(cond (cond
@ -132,7 +137,7 @@ EOF
empty] empty]
[(CaptureControl? op) [(CaptureControl? op)
empty])) empty]))
(: collect-primitive-command (PrimitiveCommand -> (Listof Symbol))) (: collect-primitive-command (PrimitiveCommand -> (Listof Symbol)))
(define (collect-primitive-command op) (define (collect-primitive-command op)
(cond (cond
@ -151,45 +156,45 @@ EOF
(unique/eq? (unique/eq?
(let: loop : (Listof Symbol) ([stmts : (Listof Statement) stmts]) (let: loop : (Listof Symbol) ([stmts : (Listof Statement) stmts])
(cond [(empty? stmts) (cond [(empty? stmts)
empty] empty]
[else [else
(let ([stmt (first stmts)]) (let ([stmt (first stmts)])
(append (cond (append (cond
[(symbol? stmt) [(symbol? stmt)
empty] empty]
[(AssignImmediateStatement? stmt) [(AssignImmediateStatement? stmt)
(let: ([v : OpArg (AssignImmediateStatement-value stmt)]) (let: ([v : OpArg (AssignImmediateStatement-value stmt)])
(cond (cond
[(Reg? v) [(Reg? v)
empty] empty]
[(Label? v) [(Label? v)
(list (Label-name v))] (list (Label-name v))]
[(Const? v) [(Const? v)
empty] empty]
[(EnvLexicalReference? v) [(EnvLexicalReference? v)
empty] empty]
[(EnvPrefixReference? v) [(EnvPrefixReference? v)
empty] empty]
[(EnvWholePrefixReference? v) [(EnvWholePrefixReference? v)
empty]))] empty]))]
[(AssignPrimOpStatement? stmt) [(AssignPrimOpStatement? stmt)
(collect-primitive-operator (AssignPrimOpStatement-op stmt))] (collect-primitive-operator (AssignPrimOpStatement-op stmt))]
[(PerformStatement? stmt) [(PerformStatement? stmt)
(collect-primitive-command (PerformStatement-op stmt))] (collect-primitive-command (PerformStatement-op stmt))]
[(TestAndBranchStatement? stmt) [(TestAndBranchStatement? stmt)
(list (TestAndBranchStatement-label stmt))] (list (TestAndBranchStatement-label stmt))]
[(GotoStatement? stmt) [(GotoStatement? stmt)
(collect-location (GotoStatement-target stmt))] (collect-location (GotoStatement-target stmt))]
[(PushEnvironment? stmt) [(PushEnvironment? stmt)
empty] empty]
[(PopEnvironment? stmt) [(PopEnvironment? stmt)
empty] empty]
[(PushControlFrame? stmt) [(PushControlFrame? stmt)
(list (PushControlFrame-label stmt))] (list (PushControlFrame-label stmt))]
[(PopControlFrame? stmt) [(PopControlFrame? stmt)
empty]) empty])
(loop (rest stmts))))])))) (loop (rest stmts))))]))))
@ -197,7 +202,7 @@ EOF
;; assemble-basic-block: basic-block -> string ;; assemble-basic-block: basic-block -> string
(: assemble-basic-block (BasicBlock -> String)) (: assemble-basic-block (BasicBlock -> String))
(define (assemble-basic-block a-basic-block) (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)
(BasicBlock-name a-basic-block) (BasicBlock-name a-basic-block)
(string-join (map assemble-statement (BasicBlock-stmts a-basic-block)) (string-join (map assemble-statement (BasicBlock-stmts a-basic-block))
@ -223,51 +228,63 @@ 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)
(cond (string-append
[(AssignImmediateStatement? stmt) (if (current-emit-debug-trace?)
(let ([t (assemble-target (AssignImmediateStatement-target stmt))] (format "if (typeof(window.console) !== 'undefined' && typeof(console.log) === 'function') { console.log(~s);\n}"
[v (AssignImmediateStatement-value stmt)]) (format "~a" stmt))
(format "~a = ~a;" t (assemble-oparg v)))] "")
(cond
[(AssignPrimOpStatement? stmt) [(AssignImmediateStatement? stmt)
(format "~a=~a;" (let ([t (assemble-target (AssignImmediateStatement-target stmt))]
(assemble-target (AssignPrimOpStatement-target stmt)) [v (AssignImmediateStatement-value stmt)])
(assemble-op-expression (AssignPrimOpStatement-op stmt)))] (format "~a = ~a;" t (assemble-oparg v)))]
[(PerformStatement? stmt) [(AssignPrimOpStatement? stmt)
(assemble-op-statement (PerformStatement-op stmt))] (format "~a=~a;"
(assemble-target (AssignPrimOpStatement-target stmt))
[(TestAndBranchStatement? stmt) (assemble-op-expression (AssignPrimOpStatement-op stmt)))]
(let*: ([test : PrimitiveTest (TestAndBranchStatement-op stmt)])
(cond [(PerformStatement? stmt)
[(eq? test 'false?) (assemble-op-statement (PerformStatement-op stmt))]
(format "if (! ~a) { return ~a(); }"
(assemble-reg (make-Reg (TestAndBranchStatement-register stmt))) [(TestAndBranchStatement? stmt)
(assemble-label (make-Label (TestAndBranchStatement-label stmt))))] (let*: ([test : PrimitiveTest (TestAndBranchStatement-op stmt)])
[(eq? test 'primitive-procedure?) (cond
(format "if (typeof(~a) === 'function') { return ~a(); };" [(eq? test 'false?)
(assemble-reg (make-Reg (TestAndBranchStatement-register stmt))) (format "if (! ~a) { ~a }"
(assemble-label (make-Label (TestAndBranchStatement-label stmt))))]))] (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) [(PushControlFrame? stmt)
(format "return ~a();" (assemble-location (GotoStatement-target stmt)))] (format "MACHINE.control.push(new Frame(~a, MACHINE.proc));" (PushControlFrame-label stmt))]
[(PushControlFrame? stmt) [(PopControlFrame? stmt)
(format "MACHINE.control.push(new Frame(~a, MACHINE.proc));" (PushControlFrame-label stmt))] "MACHINE.control.pop();"]
[(PopControlFrame? stmt) [(PushEnvironment? stmt)
"MACHINE.control.pop();"] (format "MACHINE.env.push(~a);" (string-join
[(PushEnvironment? stmt) (build-list (PushEnvironment-n stmt)
(format "MACHINE.env.push(~a);" (string-join (lambda: ([i : Natural])
(build-list (PushEnvironment-n stmt) (if (PushEnvironment-unbox? stmt)
(lambda: ([i : Natural]) "[undefined]"
(if (PushEnvironment-unbox? stmt) "undefined")))
"[undefined]" ", "))]
"undefined"))) [(PopEnvironment? stmt)
", "))] (format "MACHINE.env.splice(MACHINE.env.length-(~a),~a);"
[(PopEnvironment? stmt) (+ (PopEnvironment-skip stmt)
(format "MACHINE.env.splice(MACHINE.env.length-(~a),~a);" (PopEnvironment-n stmt))
(+ (PopEnvironment-skip stmt) (PopEnvironment-n 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)" (format "MACHINE.proc(~a, ~a)"
(ApplyPrimitiveProcedure-arity op) (ApplyPrimitiveProcedure-arity op)
(ApplyPrimitiveProcedure-label op))] (ApplyPrimitiveProcedure-label op))]
[(GetControlStackLabel? op) [(GetControlStackLabel? op)
(format "MACHINE.control[MACHINE.control.length-1].label")] (format "MACHINE.control[MACHINE.control.length-1].label")]
[(CaptureEnvironment? op) [(CaptureEnvironment? op)
@ -428,7 +445,7 @@ EOF
(assemble-prefix-reference an-input)] (assemble-prefix-reference an-input)]
[(EnvWholePrefixReference? an-input) [(EnvWholePrefixReference? an-input)
(assemble-whole-prefix-reference an-input)])) (assemble-whole-prefix-reference an-input)]))
(: assemble-location ((U Reg Label) -> String)) (: assemble-location ((U Reg Label) -> String))
(define (assemble-location a-location) (define (assemble-location a-location)
(cond (cond

12
package.rkt
View File

@ -13,18 +13,8 @@
;; Packager: produce single .js files to be included. ;; Packager: produce single .js files to be included.
(define-runtime-path runtime.js "runtime.js")
;; package: s-expression output-port -> void ;; package: s-expression output-port -> void
(define (package source-code op) (define (package source-code op)
;; The runtime code
(call-with-input-file* runtime.js
(lambda (ip)
(copy-port ip op)))
(newline op)
(fprintf op "var invoke = ") (fprintf op "var invoke = ")
(assemble/write-invoke (append (get-bootstrapping-code) (assemble/write-invoke (append (get-bootstrapping-code)
(compile (parse source-code) (compile (parse source-code)

60
runtime.js
View File

@ -293,65 +293,11 @@ var Primitives = (function() {
} }
return true; 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, var MACHINE = { callsBeforeTrampoline: 100,
val:undefined, val:undefined,
proc: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 thunk = initialJump;
var startTime = (new Date()).valueOf(); var startTime = (new Date()).valueOf();
MACHINE.callsBeforeTrampoline = 100; MACHINE.callsBeforeTrampoline = 100;
@ -408,7 +354,7 @@ var trampoline = function(initialJump, success, fail) {
while(thunk) { while(thunk) {
try { try {
thunk(); thunk(MACHINE);
break; break;
} catch (e) { } catch (e) {
if (typeof(e) === 'function') { if (typeof(e) === 'function') {
@ -420,7 +366,7 @@ var trampoline = function(initialJump, success, fail) {
(new Date()).valueOf() - startTime); (new Date()).valueOf() - startTime);
setTimeout( setTimeout(
function() { function() {
trampoline(thunk, success, fail); trampoline(MACHINE, thunk, success, fail);
}, },
0); 0);
return; return;

2
test-assemble.rkt
View File

@ -69,7 +69,7 @@
(display ";" op) (display ";" op)
(fprintf 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) inspector)
(display "})" op)))))) (display "})" op))))))
(define (E-many stmts (inspector "MACHINE.val")) (define (E-many stmts (inspector "MACHINE.val"))

32
test-browser-evaluate.rkt
View File

@ -1,8 +1,36 @@
#lang racket #lang racket
(require "browser-evaluate.rkt" (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 #<<EOF
return (function(succ, fail, params) {
return innerInvoke(MACHINE, succ, fail, params);
});
});
EOF
)
)))
;; test-find-toplevel-variables ;; test-find-toplevel-variables
(define-syntax (test stx) (define-syntax (test stx)