From 671ce83b14edf616f91d15c975ccbed071eaba7a Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Wed, 9 Feb 2011 00:47:29 -0500 Subject: [PATCH] a little work on the runtime. --- assemble.rkt | 78 +++++++++++++++++++++++++++++++++++++++++++++++++--- cm.rkt | 5 ++-- runtime.js | 59 +++++++++++++++++++++++++++++++++------ structs.rkt | 7 +++-- 4 files changed, 133 insertions(+), 16 deletions(-) diff --git a/assemble.rkt b/assemble.rkt index 31179e3..1fd05a4 100644 --- a/assemble.rkt +++ b/assemble.rkt @@ -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};" diff --git a/cm.rkt b/cm.rkt index 2ac6a99..af41ce6 100644 --- a/cm.rkt +++ b/cm.rkt @@ -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))))) diff --git a/runtime.js b/runtime.js index 6c9e76c..eba4abe 100644 --- a/runtime.js +++ b/runtime.js @@ -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; } diff --git a/structs.rkt b/structs.rkt index f033d2c..22db048 100644 --- a/structs.rkt +++ b/structs.rkt @@ -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)