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

skeletonizign assemble.rkt

Browse Source
This commit is contained in:
Danny Yoo 2011-03-09 12:30:12 -05:00
parent e27052ccf6
commit 228bd73958
3 changed files with 139 additions and 147 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

151
assemble.rkt
View File

@ -106,6 +106,16 @@ EOF
[(Label? a-location) [(Label? a-location)
(list (Label-name a-location))])) (list (Label-name a-location))]))
(: collect-primitive-operator (PrimitiveOperator -> (Listof Symbol)))
(define (collect-primitive-operator op)
;; fixme
(error 'collect-primitive-operator))
(define (collect-primitive-command op)
;; fixme
(error 'collect-primitive-command))
(unique/eq? (unique/eq?
(let: loop : (Listof Symbol) ([stmts : (Listof Statement) stmts]) (let: loop : (Listof Symbol) ([stmts : (Listof Statement) stmts])
(cond [(empty? stmts) (cond [(empty? stmts)
@ -129,22 +139,20 @@ EOF
[(EnvWholePrefixReference? v) [(EnvWholePrefixReference? v)
empty]))] empty]))]
[(AssignPrimOpStatement? stmt) [(AssignPrimOpStatement? stmt)
(apply append (map collect-input (AssignPrimOpStatement-rands stmt)))] (collect-primitive-operator (AssignPrimOpStatement-op stmt))]
[(PerformStatement? stmt) [(PerformStatement? stmt)
(apply append (map collect-input (PerformStatement-rands stmt)))] (collect-primitive-command (PerformStatement-op stmt))]
[(TestStatement? stmt) [(TestAndBranchStatement? stmt)
empty] (list (TestAndBranchStatement-label stmt))]
[(BranchLabelStatement? stmt)
(list (BranchLabelStatement-label stmt))]
[(GotoStatement? stmt) [(GotoStatement? stmt)
(collect-location (GotoStatement-target stmt))] (collect-location (GotoStatement-target stmt))]
[(PushEnv? stmt) [(PushEnvironment? stmt)
empty] empty]
[(PopEnv? stmt) [(PopEnvironment? stmt)
empty] empty]
[(PushControl? stmt) [(PushControlFrame? stmt)
empty] empty]
[(PopControl? stmt) [(PopControlFrame? stmt)
empty]) empty])
(loop (rest stmts))))])))) (loop (rest stmts))))]))))
@ -192,29 +200,28 @@ EOF
[(AssignPrimOpStatement? stmt) [(AssignPrimOpStatement? stmt)
(format "MACHINE.~a=~a;" (format "MACHINE.~a=~a;"
(AssignPrimOpStatement-target stmt) (AssignPrimOpStatement-target stmt)
(assemble-op-expression (AssignPrimOpStatement-op stmt) (assemble-op-expression (AssignPrimOpStatement-op stmt)))]
(AssignPrimOpStatement-rands stmt)))]
[(PerformStatement? stmt) [(PerformStatement? stmt)
(assemble-op-statement (PerformStatement-op stmt) (assemble-op-statement (PerformStatement-op stmt))]
(PerformStatement-rands stmt))]
[(TestStatement? stmt) [(TestAndBranchStatement? stmt)
(format "if(~a){" (error 'assemble-stmt)
(assemble-op-expression (TestStatement-op stmt) #;(format "if(~a){return ~a();}"
(list (make-Reg (TestStatement-register-rand stmt)))))] (assemble-op-expression (TestAndBranchStatement-op stmt)
[(BranchLabelStatement? stmt) (list (make-Reg (TestAndBranchStatement-register stmt))))
;; the unbalanced } is deliberate: test and branch always follow each other. (assemble-location (make-Label (TestAndBranchStatement-label stmt))))]
(format "return ~a();}"
(assemble-location (make-Label (BranchLabelStatement-label stmt))))]
[(GotoStatement? stmt) [(GotoStatement? stmt)
(format "return ~a();" (format "return ~a();"
(assemble-location (GotoStatement-target stmt)))] (assemble-location (GotoStatement-target stmt)))]
[(PushControl? stmt) [(PushControlFrame? stmt)
"fixme"] "fixme"]
[(PopControl? stmt) [(PopControlFrame? stmt)
"fixme"] "fixme"]
[(PushEnv? stmt) [(PushEnvironment? stmt)
"fixme"] "fixme"]
[(PopEnv? stmt) [(PopEnvironment? stmt)
"fixme"])) "fixme"]))
@ -244,24 +251,36 @@ EOF
(EnvWholePrefixReference-depth a-prefix-ref))) (EnvWholePrefixReference-depth a-prefix-ref)))
(: assemble-op-expression ((U PrimitiveOperator PrimitiveTest) (Listof OpArg) -> String))
(define (assemble-op-expression op-name inputs)
(let ([assembled-inputs (map assemble-input inputs)]) (: assemble-op-expression (PrimitiveOperator -> String))
(case op-name (define (assemble-op-expression op)
;; open coding some of the primitive operations: (cond
[(compiled-procedure-entry) [(GetCompiledProcedureEntry? op)
(format "(~a.label)" (assemble-input (first inputs)))] (error 'assemble-op-expression)
[(compiled-procedure-env) #;(format "(~a.label)" (assemble-input (first inputs)))]
(format "(~a.env)" (assemble-input (first inputs)))] [(MakeCompiledProcedure? op)
[(make-compiled-procedure) (error 'assemble-op-expression)]
[(ApplyPrimitiveProcedure? op)
(error 'assemble-op-expression)]
[(LookupLexicalAddress? op)
(error 'assemble-op-expression)]
[(LookupToplevelAddress? op)
(error 'assemble-op-expression)]
[(GetControlStackLabel? op)
(error 'assemble-op-expression)]
#;[(compiled-procedure-env)
#;(format "(~a.env)" (assemble-input (first inputs)))]
#;[(make-compiled-procedure)
(format "(new Closure(~a, ~a))" (format "(new Closure(~a, ~a))"
(second assembled-inputs) (second assembled-inputs)
(first assembled-inputs))] (first assembled-inputs))]
[(false?) #;[(false?)
(format "(!(~a))" (assemble-input (first inputs)))] (format "(!(~a))" (assemble-input (first inputs)))]
[(cons) #;[(cons)
(format "[~a]" (string-join (map assemble-input inputs) ","))] (format "[~a]" (string-join (map assemble-input inputs) ","))]
[(list) #;[(list)
(cond [(empty? inputs) (cond [(empty? inputs)
"undefined"] "undefined"]
[else [else
@ -273,50 +292,44 @@ EOF
(format "[~a, ~a]" (format "[~a, ~a]"
(first assembled-inputs) (first assembled-inputs)
(loop (rest assembled-inputs)))]))])] (loop (rest assembled-inputs)))]))])]
[(apply-primitive-procedure) #;[(apply-primitive-procedure)
(format "~a(~a)" (format "~a(~a)"
(first assembled-inputs) (first assembled-inputs)
;; FIXME: this doesn't look quite right... ;; FIXME: this doesn't look quite right...
(third assembled-inputs))] (third assembled-inputs))]
[(lexical-address-lookup) #;[(lexical-address-lookup)
(format "(~a).valss[~a][~a]" (format "(~a).valss[~a][~a]"
(third assembled-inputs) (third assembled-inputs)
(first assembled-inputs) (first assembled-inputs)
(second assembled-inputs))] (second assembled-inputs))]
[(toplevel-lookup) #;[(toplevel-lookup)
(let ([depth (first assembled-inputs)] (let ([depth (first assembled-inputs)]
[pos (second assembled-inputs)] [pos (second assembled-inputs)]
[name (third assembled-inputs)] [name (third assembled-inputs)]
[env (fourth assembled-inputs)]) [env (fourth assembled-inputs)])
(format "(~a).valss[~a][~a]" env depth pos))] (format "(~a).valss[~a][~a]" env depth pos))]
[(primitive-procedure?) #;[(primitive-procedure?)
(format "(typeof(~a) === 'function')" (format "(typeof(~a) === 'function')"
(first assembled-inputs))] (first assembled-inputs))]
[(extend-environment) #;[(extend-environment)
(format "new ExtendedEnvironment(~a, ~a)" (format "new ExtendedEnvironment(~a, ~a)"
(second assembled-inputs) (second assembled-inputs)
(first assembled-inputs))] (first assembled-inputs))]
[(extend-environment/prefix) #;[(extend-environment/prefix)
(format "new ExtendedPrefixEnvironment(~a, ~a)" (format "new ExtendedPrefixEnvironment(~a, ~a)"
(second assembled-inputs) (second assembled-inputs)
(first assembled-inputs))] (first assembled-inputs))]
[(read-control-label) #;[(read-control-label)
"fixme"] "fixme"]
))) ))
(: assemble-op-statement (PrimitiveCommand (Listof OpArg) -> String)) (: assemble-op-statement (PrimitiveCommand -> String))
(define (assemble-op-statement op-name inputs) (define (assemble-op-statement op)
(let ([assembled-inputs (map assemble-input inputs)]) (cond
(case op-name [(SetToplevel!? op)
[(lexical-address-set!) (error 'assemble-op-statement)
(format "(~a).valss[~a][~a] = ~a;" #;(let ([depth (first assembled-inputs)]
(third assembled-inputs)
(first assembled-inputs)
(second assembled-inputs)
(fourth assembled-inputs))]
[(toplevel-set!)
(let ([depth (first assembled-inputs)]
[pos (second assembled-inputs)] [pos (second assembled-inputs)]
[name (third assembled-inputs)] [name (third assembled-inputs)]
[env (fourth assembled-inputs)] [env (fourth assembled-inputs)]
@ -326,8 +339,10 @@ EOF
depth depth
pos pos
val))] val))]
[(check-bound!)
(let ([depth (first assembled-inputs)] [(CheckToplevelBound!? op)
(error 'assemble-op-statement)
#;(let ([depth (first assembled-inputs)]
[pos (second assembled-inputs)] [pos (second assembled-inputs)]
[name (third assembled-inputs)] [name (third assembled-inputs)]
[env (fourth assembled-inputs)]) [env (fourth assembled-inputs)])
@ -335,7 +350,19 @@ EOF
env env
depth depth
pos pos
name))]))) name))]
[(CheckClosureArity!? op)
;; fixme
(error 'assemble-op-statement)]
[(ExtendEnvironment/Prefix!? op)
;; fixme
(error 'assemble-op-statement)]
[(InstallClosureValues!? op)
(error 'assemble-op-statement)]))

50
runtime.js
View File

@ -75,48 +75,6 @@ var Primitives = {
}; };
var TopEnvironment = function() {
this.valss = [];
};
var ExtendedPrefixEnvironment = function(parent, vs) {
var vals = [];
this.names = [];
while(vs) {
this.names.push(vs[0]);
if (Primitives[vs[0]]) {
vals.push(Primitives[vs[0]]);
} else {
vals.push(undefined);
}
vs = vs[1];
}
this.valss = parent.valss.slice();
this.valss.unshift(vals);
};
ExtendedPrefixEnvironment.prototype.lookup = function(name) {
var i;
for (i = 0; i < this.names.length; i++) {
if (this.names[i] === name) {
return this.valss[0][i];
}
}
return undefined;
};
var ExtendedEnvironment = function(parent, vs) {
var vals = [];
while(vs) {
vals.push(vs[0]);
vs = vs[1];
}
this.valss = parent.valss.slice();
this.valss.unshift(vals);
};
// A closure consists of its free variables as well as a label // A closure consists of its free variables as well as a label
// into its text segment. // into its text segment.
@ -169,12 +127,10 @@ Closure.prototype.adaptToJs = function() {
var MACHINE={callsBeforeTrampoline: 100, var MACHINE={callsBeforeTrampoline: 100,
env: new TopEnvironment(),
proc:undefined,
argl:undefined,
val:undefined, val:undefined,
cont:undefined, proc:undefined,
stack: [], env: [],
control : [],
params: {currentDisplayer: function(v) {}, params: {currentDisplayer: function(v) {},
currentErrorHandler: function(e) {}}}; currentErrorHandler: function(e) {}}};

9
test-all.rkt Normal file
View File

@ -0,0 +1,9 @@
#lang racket
(require "test-find-toplevel-variables.rkt"
"test-simulator.rkt"
"test-compiler.rkt"
#; test-browser-evaluate
#; test-package
)