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) (third assembled-inputs)
(first assembled-inputs) (first assembled-inputs)
(second assembled-inputs))] (second assembled-inputs))]
[(toplevel-lookup)
(format "(~a).valss[~a][~a]"
(third assembled-inputs)
(first assembled-inputs)
(second assembled-inputs))]
[(primitive-procedure?) [(primitive-procedure?)
(format "(typeof(~a) === 'function')" (format "(typeof(~a) === 'function')"
(first assembled-inputs))] (first assembled-inputs))]
@ -243,7 +248,11 @@
(format "new ExtendedEnvironment(~a, ~a)" (format "new ExtendedEnvironment(~a, ~a)"
(second assembled-inputs) (second assembled-inputs)
(first 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])" (format "((~a).globalBindings[~a])"
(second assembled-inputs) (second assembled-inputs)
(first assembled-inputs))]))) (first assembled-inputs))])))
@ -252,27 +261,34 @@
(define (assemble-op-statement op-name inputs) (define (assemble-op-statement op-name inputs)
(let ([assembled-inputs (map assemble-input inputs)]) (let ([assembled-inputs (map assemble-input inputs)])
(case op-name (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!) [(lexical-address-set!)
(format "(~a).valss[~a][~a] = ~a;" (format "(~a).valss[~a][~a] = ~a;"
(third assembled-inputs) (third assembled-inputs)
(first assembled-inputs) (first assembled-inputs)
(second assembled-inputs) (second assembled-inputs)
(fourth assembled-inputs))] (fourth assembled-inputs))]
[(check-bound-global!) [(toplevel-set!)
(format "if (! (~a).globalBindings.hasOwnProperty(~a)) { throw new Error(\"Not bound: \" + ~a); }" (let ([depth (first assembled-inputs)]
(second assembled-inputs) [pos (second assembled-inputs)]
(first assembled-inputs) [name (third assembled-inputs)]
(first 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" (require "typed-structs.rkt"
"lexical-env.rkt" "lexical-env.rkt"
"helpers.rkt" "helpers.rkt"
"find-toplevel-variables.rkt"
racket/list) racket/list)
(provide compile) (provide compile-top)
;; SICP, Chapter 5.5
;; registers: env, argl, proc, val, cont ;; registers: env, argl, proc, val, cont
;; as well as the stack. ;; as well as the stack.
(define all-regs '(env argl proc val cont)) (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 ;; compile: expression target linkage -> instruction-sequence
@ -82,29 +94,31 @@
(define (compile-variable exp cenv target linkage) (define (compile-variable exp cenv target linkage)
(let ([lexical-pos (find-variable (Var-id exp) cenv)]) (let ([lexical-pos (find-variable (Var-id exp) cenv)])
(cond (cond
[(eq? lexical-pos 'not-found) [(LocalAddress? lexical-pos)
(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
(end-with-linkage linkage (end-with-linkage linkage
(make-instruction-sequence (make-instruction-sequence
'(env) '(env)
(list target) (list target)
`(,(make-AssignPrimOpStatement target `(,(make-AssignPrimOpStatement target
'lexical-address-lookup 'lexical-address-lookup
(list (make-Const (first lexical-pos)) (list (make-Const (LocalAddress-depth lexical-pos))
(make-Const (second 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))))))]))) (make-Reg 'env))))))])))
@ -116,20 +130,7 @@
[lexical-address [lexical-address
(find-variable var cenv)]) (find-variable var cenv)])
(cond (cond
[(eq? lexical-address 'not-found) [(LocalAddress? lexical-address)
(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
(end-with-linkage (end-with-linkage
linkage linkage
(preserving '(env) (preserving '(env)
@ -138,8 +139,23 @@
'(env val) '(env val)
(list target) (list target)
`(,(make-PerformStatement 'lexical-address-set! `(,(make-PerformStatement 'lexical-address-set!
(list (make-Const (first lexical-address)) (list (make-Const (LocalAddress-depth lexical-address))
(make-Const (second 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 'env)
(make-Reg 'val))) (make-Reg 'val)))
,(make-AssignImmediateStatement target (make-Const 'ok))))))]))) ,(make-AssignImmediateStatement target (make-Const 'ok))))))])))
@ -148,22 +164,29 @@
;; FIXME: exercise 5.43 ;; FIXME: exercise 5.43
(: compile-definition (Def CompileTimeEnvironment Target Linkage -> InstructionSequence)) (: compile-definition (Def CompileTimeEnvironment Target Linkage -> InstructionSequence))
(define (compile-definition exp cenv target linkage) (define (compile-definition exp cenv target linkage)
(let ([var (Def-variable exp)] (let* ([var (Def-variable exp)]
[get-value-code [lexical-pos (find-variable var cenv)]
(compile (Def-value exp) cenv 'val 'next)]) [get-value-code
(end-with-linkage (compile (Def-value exp) cenv 'val 'next)])
linkage (cond
(preserving [(LocalAddress? lexical-pos)
'(env) (error 'compile-definition "Defintion not at toplevel")]
get-value-code [(PrefixAddress? lexical-pos)
(make-instruction-sequence (end-with-linkage
'(env val) linkage
(list target) (preserving
`(,(make-PerformStatement 'define-variable! '(env)
(list (make-Const var) get-value-code
(make-Reg 'val) (make-instruction-sequence
(make-Reg 'env))) '(env val)
,(make-AssignImmediateStatement target (make-Const 'ok)))))))) (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)) (: compile-if (Branch CompileTimeEnvironment Target Linkage -> InstructionSequence))

9
lexical-env.rkt
View File

@ -19,9 +19,14 @@
(let: loop : LexicalAddress ([cenv : CompileTimeEnvironment cenv] (let: loop : LexicalAddress ([cenv : CompileTimeEnvironment cenv]
[depth : Natural 0]) [depth : Natural 0])
(cond [(empty? cenv) (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)) [(member name (first cenv))
(list depth (find-pos name (first cenv)))] (make-LocalAddress depth (find-pos name (first cenv)))]
[else [else
(loop (rest cenv) (add1 depth))]))) (loop (rest cenv) (add1 depth))])))

13
package.rkt
View File

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

15
runtime.js
View File

@ -32,6 +32,21 @@ var TopEnvironment = function() {
this.valss = []; 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 ExtendedEnvironment = function(parent, vs) {
var vals = []; var vals = [];
while(vs) { while(vs) {

26
typed-structs.rkt
View File

@ -73,18 +73,23 @@
(define-type PrimitiveOperator (U 'compiled-procedure-entry (define-type PrimitiveOperator (U 'compiled-procedure-entry
'compiled-procedure-env 'compiled-procedure-env
'make-compiled-procedure 'make-compiled-procedure
'false? 'false?
'cons 'cons
'list 'list
'apply-primitive-procedure 'apply-primitive-procedure
'lexical-address-lookup 'lexical-address-lookup
'toplevel-lookup
'extend-environment 'extend-environment
'lookup-variable-value)) 'extend-environment/prefix))
(define-type TestOperator (U 'false? 'primitive-procedure?)) (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! 'lexical-address-set!
'check-bound-global!)) 'check-bound!))
@ -138,10 +143,17 @@
;; Lexical environments ;; 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 compile-time environment is a (listof (listof symbol)).
;; A lexical address is either a 2-tuple (depth pos), or 'not-found. ;; A lexical address is either a 2-tuple (depth pos), or 'not-found.
(define-type CompileTimeEnvironment (Listof (Listof Symbol))) (define-type CompileTimeEnvironment (Listof (U (Listof Symbol)
(define-type LexicalAddress (U (List Number Number) 'not-found)) 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]))