diff --git a/assemble.rkt b/assemble.rkt index 863d2d7..d75905e 100644 --- a/assemble.rkt +++ b/assemble.rkt @@ -238,7 +238,7 @@ EOF (format "return ~a();" (assemble-location (GotoStatement-target stmt)))] [(PushControlFrame? stmt) - (format "MACHINE.control.push(new Frame(~a));" (PushControlFrame-label stmt))] + (format "MACHINE.control.push(new Frame(~a, MACHINE.proc));" (PushControlFrame-label stmt))] [(PopControlFrame? stmt) "MACHINE.control.pop();"] [(PushEnvironment? stmt) diff --git a/il-structs.rkt b/il-structs.rkt index f302f5a..eb89aa0 100644 --- a/il-structs.rkt +++ b/il-structs.rkt @@ -93,6 +93,8 @@ #:transparent) ;; Adding a frame for getting back after procedure application. +;; The 'proc register must hold either #f or a closure at the time of +;; this call, as the control frame will hold onto the called procedure record. (define-struct: PushControlFrame ([label : Symbol]) #:transparent) diff --git a/runtime.js b/runtime.js index e37ffe6..4995bc5 100644 --- a/runtime.js +++ b/runtime.js @@ -104,8 +104,9 @@ var Primitives = (function() { })(); -var Frame = function(label) { +var Frame = function(label, proc) { this.label = label; + this.proc = proc; }; @@ -119,45 +120,45 @@ var Closure = function(label, arity, closedVals, displayName) { }; -// 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]; - } +// // 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); - }; +// 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); - }); - } -}; +// proc.label(); +// }, +// function() { +// }, +// function(e) { +// return fail(e); +// }); +// } +// }; diff --git a/simulator-structs.rkt b/simulator-structs.rkt index 6005df5..1cba667 100644 --- a/simulator-structs.rkt +++ b/simulator-structs.rkt @@ -32,6 +32,8 @@ (define-struct: frame ([return : Symbol] + ;; The procedure being called. Used to optimize self-application + [proc : (U closure #f)] ;; TODO: add continuation marks ) #:transparent) diff --git a/simulator.rkt b/simulator.rkt index 74c3845..2bbe723 100644 --- a/simulator.rkt +++ b/simulator.rkt @@ -119,7 +119,8 @@ (: step-push-control-frame (machine PushControlFrame -> machine)) (define (step-push-control-frame m stmt) - (control-push m (PushControlFrame-label stmt))) + (control-push m (make-frame (PushControlFrame-label stmt) + (ensure-closure-or-false (machine-proc m))))) (: step-pop-control-frame (machine PopControlFrame -> machine)) (define (step-pop-control-frame m stmt) @@ -305,6 +306,13 @@ v]))])) +(: ensure-closure-or-false (SlotValue -> (U closure #f))) +(define (ensure-closure-or-false v) + (if (or (closure? v) (eq? v #f)) + v + (error 'ensure-closure))) + + (: ensure-primitive-value (Any -> PrimitiveValue)) ;; Make sure the value is primitive. (define (ensure-primitive-value val) @@ -426,11 +434,11 @@ (ensure-natural (- stack-size n)))])) -(: control-push (machine Symbol -> machine)) -(define (control-push m l) +(: control-push (machine frame -> machine)) +(define (control-push m a-frame) (match m [(struct machine (val proc env control pc text stack-size)) - (make-machine val proc env (cons (make-frame l) control) pc text + (make-machine val proc env (cons a-frame control) pc text stack-size)])) diff --git a/test-simulator.rkt b/test-simulator.rkt index aec103e..14ff9e9 100644 --- a/test-simulator.rkt +++ b/test-simulator.rkt @@ -122,20 +122,22 @@ ;; PushControl -(let ([m (new-machine `(foo +(let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const #f)) + foo ,(make-PushControlFrame 'foo) bar ,(make-PushControlFrame 'bar) baz ))]) (test (machine-control (run m)) - (list (make-frame 'bar) - (make-frame 'foo)))) + (list (make-frame 'bar #f) + (make-frame 'foo #f)))) ;; PopControl -(let ([m (new-machine `(foo +(let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const #f)) + foo ,(make-PushControlFrame 'foo) bar ,(make-PushControlFrame 'bar) @@ -143,9 +145,10 @@ ,(make-PopControlFrame) ))]) (test (machine-control (run m)) - (list (make-frame 'foo)))) + (list (make-frame 'foo #f)))) -(let ([m (new-machine `(foo +(let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const #f)) + foo ,(make-PushControlFrame 'foo) bar ,(make-PushControlFrame 'bar) @@ -429,7 +432,8 @@ ;; GetControlStackLabel -(let ([m (new-machine `(foo +(let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const #f)) + foo ,(make-PushControlFrame 'foo) ,(make-AssignPrimOpStatement 'proc (make-GetControlStackLabel))))]) (test (machine-proc (run m))