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

adjusting control frames to hold the procedure in hand, just in case

Browse Source
This commit is contained in:
Danny Yoo 2011-03-10 14:31:31 -05:00
parent f365767023
commit 49a53c0864
6 changed files with 67 additions and 50 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
assemble.rkt
View File

@ -238,7 +238,7 @@ EOF
(format "return ~a();" (format "return ~a();"
(assemble-location (GotoStatement-target stmt)))] (assemble-location (GotoStatement-target stmt)))]
[(PushControlFrame? 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) [(PopControlFrame? stmt)
"MACHINE.control.pop();"] "MACHINE.control.pop();"]
[(PushEnvironment? stmt) [(PushEnvironment? stmt)

2
il-structs.rkt
View File

@ -93,6 +93,8 @@
#:transparent) #:transparent)
;; Adding a frame for getting back after procedure application. ;; 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]) (define-struct: PushControlFrame ([label : Symbol])
#:transparent) #:transparent)

77
runtime.js
View File

@ -104,8 +104,9 @@ var Primitives = (function() {
})(); })();
var Frame = function(label) { var Frame = function(label, proc) {
this.label = label; this.label = label;
this.proc = proc;
}; };
@ -119,45 +120,45 @@ var Closure = function(label, arity, closedVals, displayName) {
}; };
// adaptToJs: closure -> (array (X -> void) -> void) // // adaptToJs: closure -> (array (X -> void) -> void)
// Converts closures to functions that can be called from the // // Converts closures to functions that can be called from the
// JavaScript toplevel. // // JavaScript toplevel.
Closure.prototype.adaptToJs = function() { // Closure.prototype.adaptToJs = function() {
var that = this; // var that = this;
return function(args, success, fail) { // return function(args, success, fail) {
var oldEnv = MACHINE.env; // var oldEnv = MACHINE.env;
var oldCont = MACHINE.cont; // var oldCont = MACHINE.cont;
var oldProc = MACHINE.proc; // var oldProc = MACHINE.proc;
var oldArgl = MACHINE.argl; // var oldArgl = MACHINE.argl;
var oldVal = MACHINE.val; // var oldVal = MACHINE.val;
trampoline( // trampoline(
function() { // function() {
var proc = that; // var proc = that;
MACHINE.proc = proc; // MACHINE.proc = proc;
MACHINE.argl = undefined; // MACHINE.argl = undefined;
for(var i = args.length - 1; i >= 0; i--) { // for(var i = args.length - 1; i >= 0; i--) {
MACHINE.argl = [args[i], MACHINE.argl]; // MACHINE.argl = [args[i], MACHINE.argl];
} // }
MACHINE.cont = function() { // MACHINE.cont = function() {
var result = MACHINE.val; // var result = MACHINE.val;
MACHINE.env = oldEnv; // MACHINE.env = oldEnv;
MACHINE.cont = oldCont; // MACHINE.cont = oldCont;
MACHINE.proc = oldProc; // MACHINE.proc = oldProc;
MACHINE.argl = oldArgl; // MACHINE.argl = oldArgl;
MACHINE.val = oldVal; // MACHINE.val = oldVal;
success(result); // success(result);
}; // };
proc.label(); // proc.label();
}, // },
function() { // function() {
}, // },
function(e) { // function(e) {
return fail(e); // return fail(e);
}); // });
} // }
}; // };

2
simulator-structs.rkt
View File

@ -32,6 +32,8 @@
(define-struct: frame ([return : Symbol] (define-struct: frame ([return : Symbol]
;; The procedure being called. Used to optimize self-application
[proc : (U closure #f)]
;; TODO: add continuation marks ;; TODO: add continuation marks
) )
#:transparent) #:transparent)

16
simulator.rkt
View File

@ -119,7 +119,8 @@
(: step-push-control-frame (machine PushControlFrame -> machine)) (: step-push-control-frame (machine PushControlFrame -> machine))
(define (step-push-control-frame m stmt) (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)) (: step-pop-control-frame (machine PopControlFrame -> machine))
(define (step-pop-control-frame m stmt) (define (step-pop-control-frame m stmt)
@ -305,6 +306,13 @@
v]))])) 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)) (: ensure-primitive-value (Any -> PrimitiveValue))
;; Make sure the value is primitive. ;; Make sure the value is primitive.
(define (ensure-primitive-value val) (define (ensure-primitive-value val)
@ -426,11 +434,11 @@
(ensure-natural (- stack-size n)))])) (ensure-natural (- stack-size n)))]))
(: control-push (machine Symbol -> machine)) (: control-push (machine frame -> machine))
(define (control-push m l) (define (control-push m a-frame)
(match m (match m
[(struct machine (val proc env control pc text stack-size)) [(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)])) stack-size)]))

18
test-simulator.rkt
View File

@ -122,20 +122,22 @@
;; PushControl ;; PushControl
(let ([m (new-machine `(foo (let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const #f))
foo
,(make-PushControlFrame 'foo) ,(make-PushControlFrame 'foo)
bar bar
,(make-PushControlFrame 'bar) ,(make-PushControlFrame 'bar)
baz baz
))]) ))])
(test (machine-control (run m)) (test (machine-control (run m))
(list (make-frame 'bar) (list (make-frame 'bar #f)
(make-frame 'foo)))) (make-frame 'foo #f))))
;; PopControl ;; PopControl
(let ([m (new-machine `(foo (let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const #f))
foo
,(make-PushControlFrame 'foo) ,(make-PushControlFrame 'foo)
bar bar
,(make-PushControlFrame 'bar) ,(make-PushControlFrame 'bar)
@ -143,9 +145,10 @@
,(make-PopControlFrame) ,(make-PopControlFrame)
))]) ))])
(test (machine-control (run m)) (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) ,(make-PushControlFrame 'foo)
bar bar
,(make-PushControlFrame 'bar) ,(make-PushControlFrame 'bar)
@ -429,7 +432,8 @@
;; GetControlStackLabel ;; GetControlStackLabel
(let ([m (new-machine `(foo (let ([m (new-machine `(,(make-AssignImmediateStatement 'proc (make-Const #f))
foo
,(make-PushControlFrame 'foo) ,(make-PushControlFrame 'foo)
,(make-AssignPrimOpStatement 'proc (make-GetControlStackLabel))))]) ,(make-AssignPrimOpStatement 'proc (make-GetControlStackLabel))))])
(test (machine-proc (run m)) (test (machine-proc (run m))