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

a little work on the runtime.

Browse Source
This commit is contained in:
Danny Yoo 2011-02-09 00:47:29 -05:00
parent 45e8973d40
commit 671ce83b14
4 changed files with 133 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

78
assemble.rkt
View File

@ -8,9 +8,13 @@
(define-struct basic-block (name stmts) #:transparent)
;; fracture: (listof stmt) -> (listof basic-block)
(define (fracture stmts)
(let* ([first-block-label (make-label 'start)]
[headers (cons first-block-label (collect-headers stmts))])
[jump-targets
(cons first-block-label (collect-general-jump-targets stmts))])
(let loop ([name first-block-label]
[acc '()]
[basic-blocks '()]
@ -22,7 +26,7 @@
basic-blocks))]
[(symbol? (car stmts))
(cond
[(member (car stmts) headers)
[(member (car stmts) jump-targets)
(loop (car stmts)
'()
(cons (make-basic-block name
@ -47,6 +51,7 @@
(tagged-list? (car stmts) 'goto))]))))
;; unique: (listof symbol -> listof symbol)
(define (unique los)
(let ([ht (make-hasheq)])
@ -56,9 +61,9 @@
k)))
;; collect-headers: (listof stmt) -> (listof label)
;; collect-general-jump-targets: (listof stmt) -> (listof label)
;; collects all the labels that are potential targets for GOTOs or branches.
(define (collect-headers stmts)
(define (collect-general-jump-targets stmts)
(define (collect-input an-input)
(cond
[(reg? an-input)
@ -114,6 +119,71 @@
;; collect-indirect-jump-targets: (listof stmt) -> (listof label)
;; collects the labels that are potential targets for GOTOs or branches from
;; indirect jumps.
;; The only interesting case should be where there's a register assignment
;; whose value is a label.
(define (collect-indirect-jump-targets stmts)
(define (collect-input an-input)
(cond
[(reg? an-input)
empty]
[(const? an-input)
empty]
[(label? an-input)
empty]
[else (error 'collect-input "~e" an-input)]))
(define (collect-location a-location)
(cond
[(reg? a-location)
empty]
[(label? a-location)
empty]
[else
(error 'collect-location "~e" a-location)]))
(unique
(let loop ([stmts stmts])
(cond [(empty? stmts)
empty]
[else
(let ([stmt (first stmts)])
(append (cond
[(symbol? stmt)
empty]
[(tagged-list? stmt 'assign)
(cond
[(reg? (caddr stmt))
empty]
[(label? (caddr stmt))
;; Watch assignments of labels into registers.
(list (label-name (caddr stmt)))]
[(const? (caddr stmt))
empty]
[(op? (caddr stmt))
empty]
[else
(error 'assemble "~a" stmt)])]
[(tagged-list? stmt 'perform)
empty]
[(tagged-list? stmt 'test)
empty]
[(tagged-list? stmt 'branch)
empty]
[(tagged-list? stmt 'goto)
empty]
[(tagged-list? stmt 'save)
empty]
[(tagged-list? stmt 'restore)
empty]
[else
(error 'assemble "~a" stmt)])
(loop (rest stmts))))]))))
;; assemble-basic-block: basic-block -> string
(define (assemble-basic-block a-basic-block)
(format "var ~a=function(){\nif(--MACHINE.callsBeforeTrampoline < 0) { throw ~a; }\n~a};"

5
cm.rkt
View File

@ -479,13 +479,14 @@
(fracture (statements (compile source-code
'()
'val
'next)))])
'return)))])
(printf "var invoke = function(MACHINE, k) {\n")
(for-each (lambda (basic-block)
(displayln (assemble-basic-block basic-block))
(newline))
basic-blocks)
(printf "_harness(~a, k); };\n"
(printf "MACHINE.cont = k;\n")
(printf "trampoline(~a, function() {}); };\n"
(basic-block-name (first basic-blocks)))))

59
runtime.js
View File

@ -17,9 +17,17 @@ var TopEnvironment = function() {
return argl[0] + argl[1][0];
},
'*': function(argl) {
return argl[0] * argl[1][0];
},
'-': function(argl) {
return argl[0] - argl[1][0];
}
},
'/': function(argl) {
return argl[0] / argl[1][0];
}
};
this.valss = [];
};
@ -44,6 +52,44 @@ var Closure = function(env, label) {
};
// adaptToJs: closure -> (array (X -> void) -> void)
// Converts closures to functions that can be called from the
// JavaScript toplevel.
Closure.adaptToJs = function() {
return function(args, k) {
var oldEnv = MACHINE.env;
var oldCont = MACHINE.cont;
var oldProc = MACHINE.proc;
var oldArgl = MACHINE.argl;
var oldVal = MACHINE.val;
trampoline(
function() {
var proc = _envLookup("gauss", MACHINE.env);
MACHINE.proc = proc;
MACHINE.argl = undefined;
for(var i = args.length - 1; i >= 0; i--) {
MACHINE.argl = _list(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;
k(result);
};
_closureEntry(proc)();
},
function() {
});
}
};
var MACHINE={callsBeforeTrampoline: 100,
env: new TopEnvironment(),
proc:undefined,
@ -54,20 +100,17 @@ var MACHINE={callsBeforeTrampoline: 100,
// harness: (->) (->) -> void
var _harness = function(thunk, k) {
var toCall;
var trampoline = function(initialJump, k) {
var thunk = initialJump;
MACHINE.callsBeforeTrampoline = 100;
while(thunk) {
try {
toCall = thunk;
thunk = undefined;
toCall();
thunk();
break;
} catch (e) {
if (typeof(e) === 'function') {
thunk = e;
MACHINE.callsBeforeTrampoline = 100;
} else if (e === 'done') {
break;
} else {
throw e;
}

7
structs.rkt
View File

@ -78,8 +78,11 @@
(define empty-instruction-sequence (make-instruction-sequence '() '() '()))
(define (make-label l)
(gensym l))
(define make-label
(let ([n 0])
(lambda (l)
(set! n (add1 n))
(string->symbol (format "~a~a" l n)))))
(define (registers-needed s)