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

all the operations should be open-coded to reduce procedure calls.

Browse Source
This commit is contained in:
Danny Yoo 2011-02-08 17:02:54 -05:00
parent 6e9805a983
commit 61a245e4b4
2 changed files with 222 additions and 151 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

246
cm.rkt
View File

@ -31,6 +31,15 @@
[else [else
(loop (rest cenv) (add1 depth))]))) (loop (rest cenv) (add1 depth))])))
;; global-lexical-address?: lexical-address -> boolean
;; Produces true if the address refers to the toplevel environment.
(define (global-lexical-address? address)
(eq? address 'not-found))
;; extend-lexical-environment: lexical-environment (listof symbol) -> lexical-envrionment
(define (extend-lexical-environment cenv names)
(cons names cenv))
@ -97,39 +106,73 @@
(define (compile-variable exp cenv target linkage) (define (compile-variable exp cenv target linkage)
;; FIXME: must find lexical address (let ([lexical-pos (find-variable exp cenv)])
(end-with-linkage linkage (cond
(make-instruction-sequence [(global-lexical-address? lexical-pos)
'(env) (end-with-linkage linkage
(list target) (make-instruction-sequence
`((assign ,target '(env)
(op lookup-variable-value) (list target)
(const ,exp) ;; Slight modification: explicitly testing for
(reg env)))))) ;; global variable binding before lookup.
`((perform (op check-bound-global!)
(const ,exp)
(reg env))
(assign ,target
(op lookup-variable-value)
(const ,exp)
(reg env)))))]
[else
(end-with-linkage linkage
(make-instruction-sequence
'(env)
(list target)
`((assign ,target
(op lexical-address-lookup)
(const ,(first lexical-pos))
(const ,(second lexical-pos))
(reg env)))))])))
(define (compile-assignment exp cenv target linkage) (define (compile-assignment exp cenv target linkage)
;; FIXME: must find lexical address (let* ([var (assignment-variable exp)]
(let ([var (assignment-variable exp)] [get-value-code
[get-value-code (compile (assignment-value exp) cenv 'val 'next)]
(compile (assignment-value exp) cenv 'val 'next)]) [lexical-address
(end-with-linkage (find-variable var cenv)])
linkage (cond
(preserving '(env) [(global-lexical-address? lexical-address)
get-value-code (end-with-linkage
(make-instruction-sequence linkage
'(env val) (preserving '(env)
(list target) get-value-code
`((perform (op set-variable-value!) (make-instruction-sequence
(const ,var) '(env val)
(reg val) (list target)
(reg env)) `((perform (op set-variable-value!)
(assign ,target (const ok)))))))) (const ,var)
(reg val)
(reg env))
(assign ,target (const ok))))))]
[else
(end-with-linkage
linkage
(preserving '(env)
get-value-code
(make-instruction-sequence
'(env val)
(list target)
`((perform (op lexical-address-set!)
(const ,(first lexical-address))
(const ,(second lexical-address))
(reg env)
(reg val))
(assign ,target (const ok))))))])))
;; FIXME: exercise 5.43
(define (compile-definition exp cenv target linkage) (define (compile-definition exp cenv target linkage)
;; FIXME: must find lexical address
(let ([var (definition-variable exp)] (let ([var (definition-variable exp)]
[get-value-code [get-value-code
(compile (definition-value exp) cenv 'val 'next)]) (compile (definition-value exp) cenv 'val 'next)])
@ -184,7 +227,6 @@
(define (compile-lambda exp cenv target linkage) (define (compile-lambda exp cenv target linkage)
;; FIXME: must extend compile-time lexical environment
(let ([proc-entry (make-label 'entry)] (let ([proc-entry (make-label 'entry)]
[after-lambda (make-label 'afterLambda)]) [after-lambda (make-label 'afterLambda)])
(let ([lambda-linkage (let ([lambda-linkage
@ -200,14 +242,21 @@
`((assign ,target `((assign ,target
(op make-compiled-procedure) (op make-compiled-procedure)
(label ,proc-entry) (label ,proc-entry)
;; TODO: rather than capture the whole
;; environment, we may instead
;; just capture the free variables.
;; But that requires that we box
;; up all set!-ed variables, in order
;; to preserve semantics of set!
(reg env))))) (reg env)))))
(compile-lambda-body exp cenv (compile-lambda-body exp cenv
proc-entry)) proc-entry))
after-lambda)))) after-lambda))))
(define (compile-lambda-body exp cenv proc-entry) (define (compile-lambda-body exp cenv proc-entry)
;; FIXME: must extend compile-time lexical environment (let* ([formals (lambda-parameters exp)]
(let ([formals (lambda-parameters exp)]) [extended-cenv (extend-lexical-environment cenv formals)])
(append-instruction-sequences (append-instruction-sequences
(make-instruction-sequence (make-instruction-sequence
'(env proc argl) '(env proc argl)
@ -216,10 +265,9 @@
(assign env (op compiled-procedure-env) (reg proc)) (assign env (op compiled-procedure-env) (reg proc))
(assign env (assign env
(op extend-environment) (op extend-environment)
(const ,formals)
(reg argl) (reg argl)
(reg env)))) (reg env))))
(compile-sequence (lambda-body exp) cenv 'val 'return)))) (compile-sequence (lambda-body exp) extended-cenv 'val 'return))))
(define (compile-application exp cenv target linkage) (define (compile-application exp cenv target linkage)
@ -517,10 +565,10 @@
(loop (car stmts) (loop (car stmts)
'() '()
(cons (make-basic-block name (cons (make-basic-block name
(if last-stmt-goto? (if last-stmt-goto?
(reverse acc) (reverse acc)
(reverse (append `((goto (label ,(car stmts)))) (reverse (append `((goto (label ,(car stmts))))
acc)))) acc))))
basic-blocks) basic-blocks)
(cdr stmts) (cdr stmts)
(tagged-list? (car stmts) 'goto))] (tagged-list? (car stmts) 'goto))]
@ -577,17 +625,17 @@
[(op? (caddr stmt)) [(op? (caddr stmt))
(format "MACHINE.~a=~a;" (format "MACHINE.~a=~a;"
(cadr stmt) (cadr stmt)
(assemble-op-call (op-name (caddr stmt)) (assemble-op-expression (op-name (caddr stmt))
(cdddr stmt)))] (cdddr stmt)))]
[else [else
(error 'assemble "~a" stmt)])] (error 'assemble "~a" stmt)])]
[(tagged-list? stmt 'perform) [(tagged-list? stmt 'perform)
(assemble-op-call (op-name (cadr stmt)) (assemble-op-statement (op-name (cadr stmt))
(cddr stmt))] (cddr stmt))]
[(tagged-list? stmt 'test) [(tagged-list? stmt 'test)
(format "if(~a){" (format "if(~a){"
(assemble-op-call (op-name (cadr stmt)) (assemble-op-expression (op-name (cadr stmt))
(cddr stmt)))] (cddr stmt)))]
[(tagged-list? stmt 'branch) [(tagged-list? stmt 'branch)
(format "if(--MACHINE.callsBeforeTrampoline){return ~a()}else{throw ~a}}" (format "if(--MACHINE.callsBeforeTrampoline){return ~a()}else{throw ~a}}"
(assemble-location (cadr stmt)) (assemble-location (cadr stmt))
@ -615,29 +663,87 @@
[else [else
(format "~s" val)]))) (format "~s" val)])))
(define (assemble-op-call op-name inputs) (define (assemble-op-expression op-name inputs)
(case op-name (let ([assembled-inputs (map assemble-input inputs)])
[(compiled-procedure-entry) (case op-name
(format "~a.label" (assemble-input (first inputs)))] ;; open coding some of the primitive operations:
[(compiled-procedure-env) [(compiled-procedure-entry)
(format "~a.env" (assemble-input (first inputs)))] (format "(~a.label)" (assemble-input (first inputs)))]
[else [(compiled-procedure-env)
(format "~a(~a)" (format "(~a.env)" (assemble-input (first inputs)))]
(case op-name [(make-compiled-procedure)
(format "(new Closure(~a, ~a))"
(second assembled-inputs)
(first assembled-inputs))]
[(false?)
(format "(!(~a))" (assemble-input (first inputs)))]
[(cons)
(format "[~a]" (string-join (map assemble-input inputs) ","))]
[(list)
(cond [(empty? inputs)
"undefined"]
[else
(let loop ([assembled-inputs assembled-inputs])
(cond
[(empty? assembled-inputs)
"undefined"]
[else
(format "[~a, ~a]"
(first assembled-inputs)
(loop (rest assembled-inputs)))]))])]
[(apply-primitive-procedure)
(format "~a(~a)"
(first assembled-inputs)
(second assembled-inputs))]
[(lexical-address-lookup)
(format "(~a).valss[~a][~a]"
(third assembled-inputs)
(first assembled-inputs)
(second assembled-inputs))]
[(primitive-procedure?)
(format "(typeof(~a) === 'function')"
(first assembled-inputs))]
[(extend-environment)
(format "(new ExtendedEnvironment(~a, ~a)"
(second assembled-inputs)
(first assembled-inputs))]
[(lookup-variable-value)
(format "((~a).globalBindings[~a])"
(second assembled-inputs)
(first assembled-inputs))]
[else
(error 'assemble "~e" op-name)])))
(define (assemble-op-statement op-name inputs)
(let ([assembled-inputs (map assemble-input inputs)])
(case op-name
[(define-variable!)
(format "(~a).globalBindings[~a] = ~a;"
(third assembled-inputs)
(first assembled-inputs)
(second assembled-inputs))]
[(set-variable-value!)
(format "(~a).globalBindings[~a] = ~a;"
(third assembled-inputs)
(first assembled-inputs)
(second assembled-inputs))]
[(lexical-address-set!)
(format "(~a).valss[~a][~a] = ~a;"
(third assembled-inputs)
(first assembled-inputs)
(second assembled-inputs)
(fourth assembled-inputs))]
[(check-bound-global!)
(format "if (! (~a).globalBindings.hasOwnProperty(~a)) { throw new Error('Not bound: ~a') }"
(second assembled-inputs)
(first assembled-inputs)
(first assembled-inputs))]
[else
(error 'assemble-op-statement "~a" op-name)])))
[(lookup-variable-value) "_envLookup"]
[(set-variable-value!) "_envSet"]
[(define-variable!) "_envDefine"]
[(extend-environment) "_envExtend"]
[(false?) "_isFalse"]
[(make-compiled-procedure) "_makeClosure"]
[(list) "_list"]
[(cons) "_cons"]
[(primitive-procedure?) "_isPrimProc"]
[(apply-primitive-procedure) "_applyPrimProc"]
[else (error 'assemble "~e" op-name)])
(string-join (map assemble-input inputs) ","))]))
(define (assemble-input an-input) (define (assemble-input an-input)
(cond (cond
@ -683,10 +789,10 @@
#;(test '(define (factorial n) #;(test '(define (factorial n)
(if (= n 0) (if (= n 0)
1 1
(* (factorial (- n 1)) (* (factorial (- n 1))
n)))) n))))
(test '(define (gauss n) (test '(define (gauss n)
(if (= n 0) (if (= n 0)
0 0
@ -694,7 +800,7 @@
n)))) n))))
#;(test '(define (fib m) #;(test '(define (fib m)
(if (< n 2) (if (< n 2)
1 1
(+ (fib (- n 1)) (+ (fib (- n 1))
(fib (- n 2)))))) (fib (- n 2))))))

103
runtime.js
View File

@ -1,84 +1,49 @@
// Type representations:
//
// number are numbers
//
// cons pairs are [first, rest]
//
// function closures are Closures
// primitive procedures are regular functions.
var TopEnvironment = function() { var TopEnvironment = function() {
this.bindings = {'=': function(argl) { this.globalBindings = {
return argl[0] === argl[1][0]; '=': function(argl) {
}, return argl[0] === argl[1][0];
'+': function(argl) { },
return argl[0] + argl[1][0];
}, '+': function(argl) {
'-': function(argl) { return argl[0] + argl[1][0];
return argl[0] - argl[1][0]; },
}
}; '-': function(argl) {
this.parent = undefined; return argl[0] - argl[1][0];
}
};
this.valss = [];
}; };
var ExtendedEnvironment = function(parent) { var ExtendedEnvironment = function(parent, vs) {
this.bindings = {}; var vals = [];
this.parent = parent; while(vs) {
vals.push(vs[0]);
vs = vs[1];
}
this.valss = parent.valss.slice();
this.valss.shift(vals);
this.globalBindings = parent.globalBindings;
}; };
// A closure consists of its free variables as well as a label
// into its text segment.
var Closure = function(env, label) { var Closure = function(env, label) {
this.env = env; this.env = env;
this.label = label; this.label = label;
}; };
var _isFalse = function(x) { if(x) return false; return true; }
var _isPrimProc = function(x) { return typeof(x) === 'function'; };
var _applyPrimProc = function(p, argl) { return p(argl); }
var _closureEnv = function(c) { return c.env; }
var _closureEntry = function(c) { return c.label; }
var _makeClosure = function(l, e) { return new Closure(e, l); }
var _envDefine = function(n, v, e) {
e.bindings[n] = v;
};
var _envExtend = function(ns, vs, e) {
var e2 = new ExtendedEnvironment(e);
while(ns) {
e2.bindings[ns[0]] = vs[0];
ns = ns[1]; vs = vs[1];
}
return e2;
};
var _envLookup = function(n, e) {
while (e) {
if (e.bindings.hasOwnProperty(n)) {
return e.bindings[n];
}
e = e.parent;
}
throw new Error("Not bound: " + n);
};
//////////////////////////////////////////////////////////////////////
// Lexical addressing
var _lexicalAddressLookup = function(depth, pos, env) {
// FIXME
};
var _lexicalAddressAssign = function(depth, pos, env, value) {
// FIXME
};
//////////////////////////////////////////////////////////////////////
var _cons = function(x, y) { return [x, y]; }
var _list = function() {
var i;
var result;
for (i = arguments.length - 1; i >= 0; i--) {
result = [arguments[i], result];
}
return result;
}
var MACHINE={callsBeforeTrampoline: 100, var MACHINE={callsBeforeTrampoline: 100,
env: new TopEnvironment(), env: new TopEnvironment(),
proc:undefined, proc:undefined,