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

removing superfluous structures.

Browse Source
This commit is contained in:
Danny Yoo 2011-03-18 22:34:43 -04:00
parent 745ce9f768
commit 20818b0a7a
8 changed files with 59 additions and 61 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
assemble.rkt
View File

@ -1,5 +1,6 @@
#lang typed/racket/base #lang typed/racket/base
(require "il-structs.rkt" (require "il-structs.rkt"
"lexical-structs.rkt"
"helpers.rkt" "helpers.rkt"
racket/string racket/string
racket/list) racket/list)

28
compile.rkt
View File

@ -153,27 +153,24 @@
(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
[(LocalAddress? lexical-pos) [(EnvLexicalReference? lexical-pos)
(end-with-linkage linkage (end-with-linkage linkage
cenv cenv
(make-instruction-sequence (make-instruction-sequence
`(,(make-AssignImmediateStatement `(,(make-AssignImmediateStatement
target target
(make-EnvLexicalReference (LocalAddress-depth lexical-pos) lexical-pos))))]
(LocalAddress-unbox? lexical-pos))))))] [(EnvPrefixReference? lexical-pos)
[(PrefixAddress? lexical-pos)
(end-with-linkage linkage (end-with-linkage linkage
cenv cenv
(make-instruction-sequence (make-instruction-sequence
`(,(make-PerformStatement (make-CheckToplevelBound! `(,(make-PerformStatement (make-CheckToplevelBound!
(PrefixAddress-depth lexical-pos) (EnvPrefixReference-depth lexical-pos)
(PrefixAddress-pos lexical-pos) (EnvPrefixReference-pos lexical-pos)
(PrefixAddress-name lexical-pos))) (EnvPrefixReference-name lexical-pos)))
,(make-AssignImmediateStatement ,(make-AssignImmediateStatement
target target
(make-EnvPrefixReference lexical-pos))))])))
(PrefixAddress-depth lexical-pos)
(PrefixAddress-pos lexical-pos))))))])))
(: compile-definition (Def CompileTimeEnvironment Target Linkage -> InstructionSequence)) (: compile-definition (Def CompileTimeEnvironment Target Linkage -> InstructionSequence))
@ -181,14 +178,12 @@
(let* ([var (Def-variable exp)] (let* ([var (Def-variable exp)]
[lexical-pos (find-variable var cenv)]) [lexical-pos (find-variable var cenv)])
(cond (cond
[(LocalAddress? lexical-pos) [(EnvLexicalReference? lexical-pos)
(error 'compile-definition "Defintion not at toplevel")] (error 'compile-definition "Defintion not at toplevel")]
[(PrefixAddress? lexical-pos) [(EnvPrefixReference? lexical-pos)
(let ([get-value-code (let ([get-value-code
(parameterize ([current-defined-name var]) (parameterize ([current-defined-name var])
(compile (Def-value exp) cenv (make-EnvPrefixReference (compile (Def-value exp) cenv lexical-pos
(PrefixAddress-depth lexical-pos)
(PrefixAddress-pos lexical-pos))
'next))]) 'next))])
(end-with-linkage (end-with-linkage
linkage linkage
@ -621,7 +616,8 @@
(EnvLexicalReference-unbox? target))] (EnvLexicalReference-unbox? target))]
[(EnvPrefixReference? target) [(EnvPrefixReference? target)
(make-EnvPrefixReference (+ n (EnvPrefixReference-depth target)) (make-EnvPrefixReference (+ n (EnvPrefixReference-depth target))
(EnvPrefixReference-pos target))] (EnvPrefixReference-pos target)
(EnvPrefixReference-name target))]
[(PrimitivesReference? target) [(PrimitivesReference? target)
target])) target]))

11
il-structs.rkt
View File

@ -1,6 +1,8 @@
#lang typed/racket/base #lang typed/racket/base
(provide (all-defined-out)) (provide (all-defined-out))
(require "lexical-structs.rkt")
@ -40,14 +42,7 @@
#:transparent) #:transparent)
(define-struct: Const ([const : Any]) (define-struct: Const ([const : Any])
#:transparent) #:transparent)
(define-struct: EnvLexicalReference ([depth : Natural]
[unbox? : Boolean])
#:transparent)
(define-struct: EnvPrefixReference ([depth : Natural]
[pos : Natural])
#:transparent)
(define-struct: EnvWholePrefixReference ([depth : Natural])
#:transparent)
(define-struct: PrimitivesReference ([name : Symbol]) (define-struct: PrimitivesReference ([name : Symbol])

17
lexical-env.rkt
View File

@ -34,21 +34,23 @@
(cond (cond
[(Prefix? elt) [(Prefix? elt)
(cond [(member name (Prefix-names elt)) (cond [(member name (Prefix-names elt))
(make-PrefixAddress depth (find-pos name (Prefix-names elt)) name)] (make-EnvPrefixReference depth
(find-pos name (Prefix-names elt))
name)]
[else [else
(loop (rest cenv) (add1 depth))])] (loop (rest cenv) (add1 depth))])]
[(symbol? elt) [(symbol? elt)
(cond (cond
[(eq? elt name) [(eq? elt name)
(make-LocalAddress depth #f)] (make-EnvLexicalReference depth #f)]
[else [else
(loop (rest cenv) (add1 depth))])] (loop (rest cenv) (add1 depth))])]
[(box? elt) [(box? elt)
(cond (cond
[(eq? (unbox elt) name) [(eq? (unbox elt) name)
(make-LocalAddress depth #t)] (make-EnvLexicalReference depth #t)]
[else [else
(loop (rest cenv) (add1 depth))])] (loop (rest cenv) (add1 depth))])]
@ -113,14 +115,13 @@
[else [else
(let ([addr (first addresses)]) (let ([addr (first addresses)])
(cond (cond
[(LocalAddress? addr) [(EnvLexicalReference? addr)
(set-insert! lexical-references (set-insert! lexical-references
(make-EnvLexicalReference (LocalAddress-depth addr) addr)
(LocalAddress-unbox? addr)))
(loop (rest addresses))] (loop (rest addresses))]
[(PrefixAddress? addr) [(EnvPrefixReference? addr)
(set-insert! prefix-references (set-insert! prefix-references
(make-EnvWholePrefixReference (PrefixAddress-depth addr))) (make-EnvWholePrefixReference (EnvPrefixReference-depth addr)))
(loop (rest addresses))]))])))) (loop (rest addresses))]))]))))

24
lexical-structs.rkt
View File

@ -18,10 +18,7 @@
(define-type CompileTimeEnvironmentEntry (U Prefix ;; a prefix (define-type CompileTimeEnvironmentEntry (U Prefix ;; a prefix
Symbol Symbol
(Boxof Symbol) ;; A boxed local (Boxof Symbol) ;; A boxed local
False False))
#;FunctionExtension
#;LocalExtension
#;TemporaryExtension))
;; A compile-time environment is a (listof (listof symbol)). ;; A compile-time environment is a (listof (listof symbol)).
@ -29,11 +26,16 @@
(define-type CompileTimeEnvironment (Listof CompileTimeEnvironmentEntry)) (define-type CompileTimeEnvironment (Listof CompileTimeEnvironmentEntry))
;; A lexical address is a reference to an value in the environment stack. ;; A lexical address is a reference to an value in the environment stack.
(define-type LexicalAddress (U LocalAddress PrefixAddress)) (define-type LexicalAddress (U EnvLexicalReference EnvPrefixReference))
(define-struct: LocalAddress ([depth : Natural]
[unbox? : Boolean])
(define-struct: EnvLexicalReference ([depth : Natural]
[unbox? : Boolean])
#:transparent)
(define-struct: EnvPrefixReference ([depth : Natural]
[pos : Natural]
[name : Symbol])
#:transparent)
(define-struct: EnvWholePrefixReference ([depth : Natural])
#:transparent) #:transparent)
(define-struct: PrefixAddress ([depth : Natural]
[pos : Natural]
[name : Symbol])
#:transparent)

1
simulator.rkt
View File

@ -6,6 +6,7 @@
;; I also need to do things like count pushes and pops. Basically, low-level benchmarking. ;; I also need to do things like count pushes and pops. Basically, low-level benchmarking.
(require "il-structs.rkt" (require "il-structs.rkt"
"lexical-structs.rkt"
"simulator-structs.rkt" "simulator-structs.rkt"
"bootstrapped-primitives.rkt" "bootstrapped-primitives.rkt"
racket/list racket/list

13
test-assemble.rkt
View File

@ -3,6 +3,7 @@
(require "assemble.rkt" (require "assemble.rkt"
"browser-evaluate.rkt" "browser-evaluate.rkt"
"parse.rkt" "parse.rkt"
"lexical-structs.rkt"
"il-structs.rkt" "il-structs.rkt"
"compile.rkt" "compile.rkt"
racket/port racket/port
@ -145,7 +146,7 @@
;; Simple application ;; Simple application
(test (E-many (list (make-PerformStatement (make-ExtendEnvironment/Prefix! '(+))) (test (E-many (list (make-PerformStatement (make-ExtendEnvironment/Prefix! '(+)))
(make-AssignImmediateStatement 'proc (make-EnvPrefixReference 0 0)) (make-AssignImmediateStatement 'proc (make-EnvPrefixReference 0 0 '+))
(make-PushEnvironment 2 #f) (make-PushEnvironment 2 #f)
(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-AssignImmediateStatement (make-EnvLexicalReference 0 #f)
(make-Const 3)) (make-Const 3))
@ -313,7 +314,7 @@
;; Give a primitive procedure in val ;; Give a primitive procedure in val
(test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+))) (test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+)))
,(make-AssignImmediateStatement 'val (make-EnvPrefixReference 0 0)) ,(make-AssignImmediateStatement 'val (make-EnvPrefixReference 0 0 '+))
,(make-TestAndBranchStatement 'primitive-procedure? 'val 'onTrue) ,(make-TestAndBranchStatement 'primitive-procedure? 'val 'onTrue)
,(make-AssignImmediateStatement 'val (make-Const 'not-ok)) ,(make-AssignImmediateStatement 'val (make-Const 'not-ok))
,(make-GotoStatement (make-Label 'end)) ,(make-GotoStatement (make-Label 'end))
@ -324,7 +325,7 @@
;; Give a primitive procedure in proc, but test val ;; Give a primitive procedure in proc, but test val
(test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+))) (test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+)))
,(make-AssignImmediateStatement 'proc (make-EnvPrefixReference 0 0)) ,(make-AssignImmediateStatement 'proc (make-EnvPrefixReference 0 0 '+))
,(make-TestAndBranchStatement 'primitive-procedure? 'val 'onTrue) ,(make-TestAndBranchStatement 'primitive-procedure? 'val 'onTrue)
,(make-AssignImmediateStatement 'val (make-Const 'not-a-procedure)) ,(make-AssignImmediateStatement 'val (make-Const 'not-a-procedure))
,(make-GotoStatement (make-Label 'end)) ,(make-GotoStatement (make-Label 'end))
@ -335,7 +336,7 @@
;; Give a primitive procedure in proc and test proc ;; Give a primitive procedure in proc and test proc
(test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+))) (test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+)))
,(make-AssignImmediateStatement 'proc (make-EnvPrefixReference 0 0)) ,(make-AssignImmediateStatement 'proc (make-EnvPrefixReference 0 0 '+))
,(make-TestAndBranchStatement 'primitive-procedure? 'proc 'onTrue) ,(make-TestAndBranchStatement 'primitive-procedure? 'proc 'onTrue)
,(make-AssignImmediateStatement 'val (make-Const 'not-a-procedure)) ,(make-AssignImmediateStatement 'val (make-Const 'not-a-procedure))
,(make-GotoStatement (make-Label 'end)) ,(make-GotoStatement (make-Label 'end))
@ -349,7 +350,7 @@
;; Set-toplevel ;; Set-toplevel
(test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(advisor))) (test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(advisor)))
,(make-AssignImmediateStatement 'val (make-Const "Kathi")) ,(make-AssignImmediateStatement 'val (make-Const "Kathi"))
,(make-AssignImmediateStatement (make-EnvPrefixReference 0 0) (make-Reg 'val))) ,(make-AssignImmediateStatement (make-EnvPrefixReference 0 0 'advisor) (make-Reg 'val)))
"MACHINE.env[0][0]") "MACHINE.env[0][0]")
"Kathi") "Kathi")
@ -365,7 +366,7 @@
;; check-toplevel-bound shouldn't fail here. ;; check-toplevel-bound shouldn't fail here.
(test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(another-advisor))) (test (E-many `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(another-advisor)))
,(make-AssignImmediateStatement 'val (make-Const "Shriram")) ,(make-AssignImmediateStatement 'val (make-Const "Shriram"))
,(make-AssignImmediateStatement (make-EnvPrefixReference 0 0) (make-Reg 'val)) ,(make-AssignImmediateStatement (make-EnvPrefixReference 0 0 'another-advisor) (make-Reg 'val))
,(make-PerformStatement (make-CheckToplevelBound! 0 0 'another-advisor))) ,(make-PerformStatement (make-CheckToplevelBound! 0 0 'another-advisor)))
"MACHINE.env[0][0]") "MACHINE.env[0][0]")
"Shriram") "Shriram")

25
test-simulator.rkt
View File

@ -1,6 +1,7 @@
#lang racket #lang racket
(require "il-structs.rkt" (require "il-structs.rkt"
"lexical-structs.rkt"
"simulator-structs.rkt" "simulator-structs.rkt"
"simulator-primitives.rkt" "simulator-primitives.rkt"
"simulator.rkt") "simulator.rkt")
@ -279,20 +280,20 @@
(let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(some-variable))) (let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(some-variable)))
,(make-AssignImmediateStatement 'val (make-Const "Danny")) ,(make-AssignImmediateStatement 'val (make-Const "Danny"))
,(make-AssignImmediateStatement (make-EnvPrefixReference 0 0) (make-Reg 'val))))]) ,(make-AssignImmediateStatement (make-EnvPrefixReference 0 0 'some-variable) (make-Reg 'val))))])
(test (machine-env (run m)) (test (machine-env (run m))
(list (make-toplevel (list "Danny"))))) (list (make-toplevel (list "Danny")))))
(let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(some-variable another))) (let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(some-variable another)))
,(make-AssignImmediateStatement 'val (make-Const "Danny")) ,(make-AssignImmediateStatement 'val (make-Const "Danny"))
,(make-AssignImmediateStatement (make-EnvPrefixReference 0 1) (make-Reg 'val))))]) ,(make-AssignImmediateStatement (make-EnvPrefixReference 0 1 'another) (make-Reg 'val))))])
(test (machine-env (run m)) (test (machine-env (run m))
(list (make-toplevel (list (make-undefined) "Danny"))))) (list (make-toplevel (list (make-undefined) "Danny")))))
(let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(some-variable))) (let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(some-variable)))
,(make-AssignImmediateStatement 'val (make-Const "Danny")) ,(make-AssignImmediateStatement 'val (make-Const "Danny"))
,(make-PushEnvironment 5 #f) ,(make-PushEnvironment 5 #f)
,(make-AssignImmediateStatement (make-EnvPrefixReference 5 0) (make-Reg 'val))))]) ,(make-AssignImmediateStatement (make-EnvPrefixReference 5 0 'some-variable) (make-Reg 'val))))])
(test (machine-env (run m)) (test (machine-env (run m))
(list (make-undefined) (make-undefined) (make-undefined) (make-undefined) (make-undefined) (list (make-undefined) (make-undefined) (make-undefined) (make-undefined) (make-undefined)
(make-toplevel (list "Danny"))))) (make-toplevel (list "Danny")))))
@ -313,7 +314,7 @@
;; check-toplevel-bound shouldn't fail here. ;; check-toplevel-bound shouldn't fail here.
(let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(some-variable))) (let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(some-variable)))
,(make-AssignImmediateStatement 'val (make-Const "Danny")) ,(make-AssignImmediateStatement 'val (make-Const "Danny"))
,(make-AssignImmediateStatement (make-EnvPrefixReference 0 0) (make-Reg 'val)) ,(make-AssignImmediateStatement (make-EnvPrefixReference 0 0 'some-variable) (make-Reg 'val))
,(make-PerformStatement (make-CheckToplevelBound! 0 0 'some-variable))))]) ,(make-PerformStatement (make-CheckToplevelBound! 0 0 'some-variable))))])
(void (run m))) (void (run m)))
@ -385,11 +386,11 @@
;; make-compiled-procedure: Capturing a toplevel. ;; make-compiled-procedure: Capturing a toplevel.
(let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(x y z))) (let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(x y z)))
,(make-AssignImmediateStatement 'val (make-Const "x")) ,(make-AssignImmediateStatement 'val (make-Const "x"))
,(make-AssignImmediateStatement (make-EnvPrefixReference 0 0) (make-Reg 'val)) ,(make-AssignImmediateStatement (make-EnvPrefixReference 0 0 'x) (make-Reg 'val))
,(make-AssignImmediateStatement 'val (make-Const "y")) ,(make-AssignImmediateStatement 'val (make-Const "y"))
,(make-AssignImmediateStatement (make-EnvPrefixReference 0 1) (make-Reg 'val)) ,(make-AssignImmediateStatement (make-EnvPrefixReference 0 1 'y) (make-Reg 'val))
,(make-AssignImmediateStatement 'val (make-Const "z")) ,(make-AssignImmediateStatement 'val (make-Const "z"))
,(make-AssignImmediateStatement (make-EnvPrefixReference 0 2) (make-Reg 'val)) ,(make-AssignImmediateStatement (make-EnvPrefixReference 0 2 'z) (make-Reg 'val))
,(make-AssignPrimOpStatement ,(make-AssignPrimOpStatement
'val 'val
(make-MakeCompiledProcedure 'procedure-entry (make-MakeCompiledProcedure 'procedure-entry
@ -407,11 +408,11 @@
;; make-compiled-procedure: Capturing both a toplevel and some lexical values ;; make-compiled-procedure: Capturing both a toplevel and some lexical values
(let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(x y z))) (let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(x y z)))
,(make-AssignImmediateStatement 'val (make-Const "x")) ,(make-AssignImmediateStatement 'val (make-Const "x"))
,(make-AssignImmediateStatement (make-EnvPrefixReference 0 0) (make-Reg 'val)) ,(make-AssignImmediateStatement (make-EnvPrefixReference 0 0 'x) (make-Reg 'val))
,(make-AssignImmediateStatement 'val (make-Const "y")) ,(make-AssignImmediateStatement 'val (make-Const "y"))
,(make-AssignImmediateStatement (make-EnvPrefixReference 0 1) (make-Reg 'val)) ,(make-AssignImmediateStatement (make-EnvPrefixReference 0 1 'y) (make-Reg 'val))
,(make-AssignImmediateStatement 'val (make-Const "z")) ,(make-AssignImmediateStatement 'val (make-Const "z"))
,(make-AssignImmediateStatement (make-EnvPrefixReference 0 2) (make-Reg 'val)) ,(make-AssignImmediateStatement (make-EnvPrefixReference 0 2 'z) (make-Reg 'val))
,(make-PushEnvironment 3 #f) ,(make-PushEnvironment 3 #f)
,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-Const 'larry)) ,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-Const 'larry))
@ -441,7 +442,7 @@
;; Test toplevel lookup ;; Test toplevel lookup
(let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+))) (let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+)))
,(make-AssignImmediateStatement 'val (make-EnvPrefixReference 0 0))))]) ,(make-AssignImmediateStatement 'val (make-EnvPrefixReference 0 0 '+))))])
(test (machine-val (run m)) (test (machine-val (run m))
(lookup-primitive '+))) (lookup-primitive '+)))
@ -469,7 +470,7 @@
;; ApplyPrimitiveProcedure ;; ApplyPrimitiveProcedure
;; Adding two numbers ;; Adding two numbers
(let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+))) (let ([m (new-machine `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! '(+)))
,(make-AssignImmediateStatement 'proc (make-EnvPrefixReference 0 0)) ,(make-AssignImmediateStatement 'proc (make-EnvPrefixReference 0 0 '+))
,(make-PushEnvironment 2 #f) ,(make-PushEnvironment 2 #f)
,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-Const 126389)) ,(make-AssignImmediateStatement (make-EnvLexicalReference 0 #f) (make-Const 126389))
,(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f) (make-Const 42)) ,(make-AssignImmediateStatement (make-EnvLexicalReference 1 #f) (make-Const 42))