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

trying to get toplevel addressing to work.

Browse Source
This commit is contained in:
Danny Yoo 2011-02-21 17:11:44 -05:00
parent cf3be4c0e2
commit a9586c97d5
6 changed files with 154 additions and 84 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
assemble.rkt
View File

@ -236,6 +236,11 @@
(third assembled-inputs)
(first assembled-inputs)
(second assembled-inputs))]
[(toplevel-lookup)
(format "(~a).valss[~a][~a]"
(third assembled-inputs)
(first assembled-inputs)
(second assembled-inputs))]
[(primitive-procedure?)
(format "(typeof(~a) === 'function')"
(first assembled-inputs))]
@ -243,7 +248,11 @@
(format "new ExtendedEnvironment(~a, ~a)"
(second assembled-inputs)
(first assembled-inputs))]
[(lookup-variable-value)
[(extend-environment/prefix)
(format "new ExtendedPrefixEnvironment(~a, ~a)"
(second assembled-inputs)
(first assembled-inputs))]
#;[(lookup-variable-value)
(format "((~a).globalBindings[~a])"
(second assembled-inputs)
(first assembled-inputs))])))
@ -252,27 +261,34 @@
(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))])))
[(toplevel-set!)
(let ([depth (first assembled-inputs)]
[pos (second assembled-inputs)]
[name (third assembled-inputs)]
[env (fourth assembled-inputs)]
[val (fifth assembled-inputs)])
(format "(~a).valss[~a][~a] = ~a;"
env
depth
pos
val))]
[(check-bound!)
(let ([depth (first assembled-inputs)]
[pos (second assembled-inputs)]
[name (third assembled-inputs)]
[env (fourth assembled-inputs)])
(format "if ((~a).valss[~a][~a] === undefined) { throw new Error(\"Not bound: \" + ~a); }"
env
depth
pos
name))])))

127
compile.rkt
View File

@ -3,18 +3,30 @@
(require "typed-structs.rkt"
"lexical-env.rkt"
"helpers.rkt"
"find-toplevel-variables.rkt"
racket/list)
(provide compile)
(provide compile-top)
;; SICP, Chapter 5.5
;; registers: env, argl, proc, val, cont
;; as well as the stack.
(define all-regs '(env argl proc val cont))
(: compile-top (Expression Target Linkage -> InstructionSequence))
(define (compile-top exp target linkage)
(let*: ([names : (Listof Symbol) (find-toplevel-variables exp)]
[cenv : CompileTimeEnvironment (list (make-Prefix names))])
(append-instruction-sequences
(make-instruction-sequence
'(env)
'(env)
`(,(make-AssignPrimOpStatement 'env
'extend-environment/prefix
(list (make-Const names)
(make-Reg 'env)))))
(compile exp cenv target linkage))))
;; compile: expression target linkage -> instruction-sequence
@ -82,29 +94,31 @@
(define (compile-variable exp cenv target linkage)
(let ([lexical-pos (find-variable (Var-id exp) cenv)])
(cond
[(eq? lexical-pos 'not-found)
(end-with-linkage linkage
(make-instruction-sequence
'(env)
(list target)
;; Slight modification: explicitly testing for
;; global variable binding before lookup.
`(,(make-PerformStatement 'check-bound-global!
(list (make-Const (Var-id exp))
(make-Reg 'env)))
,(make-AssignPrimOpStatement target
'lookup-variable-value
(list (make-Const (Var-id exp))
(make-Reg 'env))))))]
[else
[(LocalAddress? lexical-pos)
(end-with-linkage linkage
(make-instruction-sequence
'(env)
(list target)
`(,(make-AssignPrimOpStatement target
'lexical-address-lookup
(list (make-Const (first lexical-pos))
(make-Const (second lexical-pos))
(list (make-Const (LocalAddress-depth lexical-pos))
(make-Const (LocalAddress-pos lexical-pos))
(make-Reg 'env))))))]
[(PrefixAddress? lexical-pos)
(end-with-linkage linkage
(make-instruction-sequence
'(env)
(list target)
`(,(make-PerformStatement 'check-bound!
(list (make-Const (PrefixAddress-depth lexical-pos))
(make-Const (PrefixAddress-pos lexical-pos))
(make-Const (PrefixAddress-name lexical-pos))
(make-Reg 'env)))
,(make-AssignPrimOpStatement target
'toplevel-lookup
(list (make-Const (PrefixAddress-depth lexical-pos))
(make-Const (PrefixAddress-pos lexical-pos))
(make-Const (PrefixAddress-name lexical-pos))
(make-Reg 'env))))))])))
@ -116,20 +130,7 @@
[lexical-address
(find-variable var cenv)])
(cond
[(eq? lexical-address 'not-found)
(end-with-linkage
linkage
(preserving '(env)
get-value-code
(make-instruction-sequence
'(env val)
(list target)
`(,(make-PerformStatement 'set-variable-value!
(list (make-Const var)
(make-Reg 'val)
(make-Reg 'env)))
,(make-AssignImmediateStatement target (make-Const 'ok))))))]
[else
[(LocalAddress? lexical-address)
(end-with-linkage
linkage
(preserving '(env)
@ -138,8 +139,23 @@
'(env val)
(list target)
`(,(make-PerformStatement 'lexical-address-set!
(list (make-Const (first lexical-address))
(make-Const (second lexical-address))
(list (make-Const (LocalAddress-depth lexical-address))
(make-Const (LocalAddress-pos lexical-address))
(make-Reg 'env)
(make-Reg 'val)))
,(make-AssignImmediateStatement target (make-Const 'ok))))))]
[(PrefixAddress? lexical-address)
(end-with-linkage
linkage
(preserving '(env)
get-value-code
(make-instruction-sequence
'(env val)
(list target)
`(,(make-PerformStatement 'toplevel-set!
(list (make-Const (PrefixAddress-depth lexical-address))
(make-Const (PrefixAddress-pos lexical-address))
(make-Const (PrefixAddress-name lexical-address))
(make-Reg 'env)
(make-Reg 'val)))
,(make-AssignImmediateStatement target (make-Const 'ok))))))])))
@ -148,22 +164,29 @@
;; FIXME: exercise 5.43
(: compile-definition (Def CompileTimeEnvironment Target Linkage -> InstructionSequence))
(define (compile-definition exp cenv target linkage)
(let ([var (Def-variable exp)]
[get-value-code
(compile (Def-value exp) cenv 'val 'next)])
(end-with-linkage
linkage
(preserving
'(env)
get-value-code
(make-instruction-sequence
'(env val)
(list target)
`(,(make-PerformStatement 'define-variable!
(list (make-Const var)
(make-Reg 'val)
(make-Reg 'env)))
,(make-AssignImmediateStatement target (make-Const 'ok))))))))
(let* ([var (Def-variable exp)]
[lexical-pos (find-variable var cenv)]
[get-value-code
(compile (Def-value exp) cenv 'val 'next)])
(cond
[(LocalAddress? lexical-pos)
(error 'compile-definition "Defintion not at toplevel")]
[(PrefixAddress? lexical-pos)
(end-with-linkage
linkage
(preserving
'(env)
get-value-code
(make-instruction-sequence
'(env val)
(list target)
`(,(make-PerformStatement 'toplevel-set!
(list (make-Const (PrefixAddress-depth lexical-pos))
(make-Const (PrefixAddress-pos lexical-pos))
(make-Const var)
(make-Reg 'env)
(make-Reg 'val)))
,(make-AssignImmediateStatement target (make-Const 'ok))))))])))
(: compile-if (Branch CompileTimeEnvironment Target Linkage -> InstructionSequence))

9
lexical-env.rkt
View File

@ -19,9 +19,14 @@
(let: loop : LexicalAddress ([cenv : CompileTimeEnvironment cenv]
[depth : Natural 0])
(cond [(empty? cenv)
'not-found]
(error 'find-variable "Unable to find ~s in the environment" name)]
[(Prefix? (first cenv))
(cond [(member name (Prefix-names (first cenv)))
(make-PrefixAddress depth (find-pos name (Prefix-names (first cenv))) name)]
[else
(loop (rest cenv) (add1 depth))])]
[(member name (first cenv))
(list depth (find-pos name (first cenv)))]
(make-LocalAddress depth (find-pos name (first cenv)))]
[else
(loop (rest cenv) (add1 depth))])))

13
package.rkt
View File

@ -17,10 +17,9 @@
(copy-port ip op)))
(newline op)
(fprintf op "var invoke = ")
(assemble/write-invoke (statements (compile (parse source-code)
'()
'val
'return))
(assemble/write-invoke (statements (compile-top (parse source-code)
'val
'return))
op)
(fprintf op ";\n"))
@ -35,7 +34,7 @@
1
(* (factorial (- n 1))
n))))
(test '(begin
#;(test '(begin
(define (factorial n)
(fact-iter n 1))
(define (fact-iter n acc)
@ -43,13 +42,13 @@
acc
(fact-iter (- n 1) (* acc n))))))
(test '(define (gauss n)
#;(test '(define (gauss n)
(if (= n 0)
0
(+ (gauss (- n 1))
n))))
(test '(define (fib n)
#;(test '(define (fib n)
(if (< n 2)
1
(+ (fib (- n 1))

15
runtime.js
View File

@ -32,6 +32,21 @@ var TopEnvironment = function() {
this.valss = [];
};
var ExtendedPrefixEnvironment = function(parent, vs) {
var vals = [];
while(vs) {
if (parent.globalBindings[vs[0]]) {
vals.push(parent.globalBindings[vs[0]]);
} else {
vals.push(undefined);
}
vs = vs[1];
}
this.valss = parent.valss.slice();
this.valss.unshift(vals);
this.globalBindings = parent.globalBindings;
};
var ExtendedEnvironment = function(parent, vs) {
var vals = [];
while(vs) {

26
typed-structs.rkt
View File

@ -73,18 +73,23 @@
(define-type PrimitiveOperator (U 'compiled-procedure-entry
'compiled-procedure-env
'make-compiled-procedure
'false?
'cons
'list
'apply-primitive-procedure
'lexical-address-lookup
'toplevel-lookup
'extend-environment
'lookup-variable-value))
'extend-environment/prefix))
(define-type TestOperator (U 'false? 'primitive-procedure?))
(define-type PerformOperator (U 'define-variable!
'set-variable-value!
(define-type PerformOperator (U 'toplevel-set!
'lexical-address-set!
'check-bound-global!))
'check-bound!))
@ -138,10 +143,17 @@
;; Lexical environments
;; A toplevel prefix contains a list of toplevel variables.
(define-struct: Prefix ([names : (Listof Symbol)]))
;; A compile-time environment is a (listof (listof symbol)).
;; A lexical address is either a 2-tuple (depth pos), or 'not-found.
(define-type CompileTimeEnvironment (Listof (Listof Symbol)))
(define-type LexicalAddress (U (List Number Number) 'not-found))
(define-type CompileTimeEnvironment (Listof (U (Listof Symbol)
Prefix)))
(define-type LexicalAddress (U LocalAddress PrefixAddress))
(define-struct: Prefix ([names : (Listof Symbol)]))
(define-struct: LocalAddress ([depth : Natural]
[pos : Natural]))
(define-struct: PrefixAddress ([depth : Natural]
[pos : Natural]
[name : Symbol]))