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
(require "il-structs.rkt"
"lexical-structs.rkt"
"helpers.rkt"
racket/string
racket/list)

28
compile.rkt
View File

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

11
il-structs.rkt
View File

@ -1,6 +1,8 @@
#lang typed/racket/base
(provide (all-defined-out))
(require "lexical-structs.rkt")
@ -40,14 +42,7 @@
#:transparent)
(define-struct: Const ([const : Any])
#: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])

17
lexical-env.rkt
View File

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

24
lexical-structs.rkt
View File

@ -18,10 +18,7 @@
(define-type CompileTimeEnvironmentEntry (U Prefix ;; a prefix
Symbol
(Boxof Symbol) ;; A boxed local
False
#;FunctionExtension
#;LocalExtension
#;TemporaryExtension))
False))
;; A compile-time environment is a (listof (listof symbol)).
@ -29,11 +26,16 @@
(define-type CompileTimeEnvironment (Listof CompileTimeEnvironmentEntry))
;; A lexical address is a reference to an value in the environment stack.
(define-type LexicalAddress (U LocalAddress PrefixAddress))
(define-struct: LocalAddress ([depth : Natural]
[unbox? : Boolean])
(define-type LexicalAddress (U EnvLexicalReference EnvPrefixReference))
(define-struct: EnvLexicalReference ([depth : Natural]
[unbox? : Boolean])
#:transparent)
(define-struct: EnvPrefixReference ([depth : Natural]
[pos : Natural]
[name : Symbol])
#:transparent)
(define-struct: EnvWholePrefixReference ([depth : Natural])
#: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.
(require "il-structs.rkt"
"lexical-structs.rkt"
"simulator-structs.rkt"
"bootstrapped-primitives.rkt"
racket/list

13
test-assemble.rkt
View File

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

25
test-simulator.rkt
View File

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