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

extending prefixes to also take globalbuckets, although I don't think the simulator or assembler is treating them and modulevariables correctly yet.

Browse Source
This commit is contained in:
Danny Yoo 2011-05-06 15:53:00 -04:00
parent d1a18ae57c
commit f640907001
9 changed files with 144 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
assemble-perform-statement.rkt
View File

@ -29,28 +29,36 @@
[(ExtendEnvironment/Prefix!? op)
(let: ([names : (Listof (U Symbol False ModuleVariable)) (ExtendEnvironment/Prefix!-names op)])
(let: ([names : (Listof (U Symbol False GlobalBucket ModuleVariable)) (ExtendEnvironment/Prefix!-names op)])
(format "MACHINE.env.push([~a]); MACHINE.env[MACHINE.env.length-1].names = [~a];"
(string-join (map
(lambda: ([n : (U Symbol False ModuleVariable)])
(cond [(symbol? n)
(format "MACHINE.params.currentNamespace[~s] || MACHINE.primitives[~s]"
(symbol->string n)
(symbol->string n))]
[(eq? n #f)
"false"]
[(ModuleVariable? n)
(format "MACHINE.primitives[~s]"
(symbol->string (ModuleVariable-name n)))]))
names)
(lambda: ([n : (U Symbol False GlobalBucket ModuleVariable)])
(cond [(symbol? n)
(format "MACHINE.params.currentNamespace[~s] || MACHINE.primitives[~s]"
(symbol->string n)
(symbol->string n))]
[(eq? n #f)
"false"]
[(GlobalBucket? n)
;; FIXME: maybe we should keep a set of global variables here?
(format "MACHINE.primitives[~s]"
(symbol->string (GlobalBucket-name n)))]
;; FIXME: this should be looking at the module path and getting
;; the value here! It shouldn't be looking into Primitives...
[(ModuleVariable? n)
(format "MACHINE.primitives[~s]"
(symbol->string (ModuleVariable-name n)))]))
names)
",")
(string-join (map
(lambda: ([n : (U Symbol False ModuleVariable)])
(lambda: ([n : (U Symbol False GlobalBucket ModuleVariable)])
(cond
[(symbol? n)
(format "~s" (symbol->string n))]
[(eq? n #f)
"false"]
[(GlobalBucket? n)
(format "~s" (symbol->string (GlobalBucket-name n)))]
[(ModuleVariable? n)
(format "~s" (symbol->string (ModuleVariable-name n)))]))
names)

6
compiler.rkt
View File

@ -209,7 +209,7 @@
;; Generates code to write out the top prefix, evaluate the rest of the body,
;; and then pop the top prefix off.
(define (compile-top top cenv target linkage)
(let*: ([names : (Listof (U Symbol ModuleVariable False)) (Prefix-names (Top-prefix top))])
(let*: ([names : (Listof (U False Symbol GlobalBucket ModuleVariable)) (Prefix-names (Top-prefix top))])
(end-with-linkage
linkage cenv
(append-instruction-sequences
@ -1374,12 +1374,14 @@
entry)]
[(ToplevelRef? exp)
(let: ([name : (U Symbol False ModuleVariable)
(let: ([name : (U Symbol False GlobalBucket ModuleVariable)
(list-ref (Prefix-names (ensure-prefix (list-ref cenv (ToplevelRef-depth exp))))
(ToplevelRef-pos exp))])
(cond
[(ModuleVariable? name)
name]
[(GlobalBucket? name)
'?]
[else
'?]))]

50
expression-structs.rkt
View File

@ -3,20 +3,44 @@
(provide (all-defined-out))
;; Expressions
(define-type Expression (U Top Constant
ToplevelRef LocalRef
ToplevelSet
Branch CaseLam Lam Seq Splice App
Let1
LetVoid
LetRec
InstallValue
BoxEnv
WithContMark
ApplyValues
DefValues))
;; Expressions
(define-type Expression (U
Top
Constant
ToplevelRef
LocalRef
ToplevelSet
Branch
CaseLam
Lam
Seq
Splice
App
Let1
LetVoid
LetRec
InstallValue
BoxEnv
WithContMark
ApplyValues
DefValues))
;; A ModuleName is an identifier for a Module.
(define-struct: ModuleName ([name : Symbol])
#:transparent)
(define-struct: Provided ([name : Symbol]
[src-name : Symbol])
#:transparent)
(define-struct: Module ([name : ModuleName]
[prefix : Prefix]
[requires : (Listof ModuleName)]
[provides : (Listof Provided)]
[code : Expression])
#:transparent)
(define-struct: Top ([prefix : Prefix]
[code : Expression]) #:transparent)

2
il-structs.rkt
View File

@ -303,7 +303,7 @@
;; Extends the environment with a prefix that holds
;; lookups to the namespace.
(define-struct: ExtendEnvironment/Prefix! ([names : (Listof (U Symbol ModuleVariable False))])
(define-struct: ExtendEnvironment/Prefix! ([names : (Listof (U False Symbol GlobalBucket ModuleVariable))])
#:transparent)
;; Adjusts the environment by pushing the values in the

21
lexical-env.rkt
View File

@ -40,17 +40,19 @@
(cond
[(Prefix? elt)
(let: prefix-loop : LexicalAddress
([names : (Listof (U Symbol False ModuleVariable)) (Prefix-names elt)]
[pos : Natural 0])
([names : (Listof (U False Symbol GlobalBucket ModuleVariable)) (Prefix-names elt)]
[pos : Natural 0])
(cond [(empty? names)
(loop (rest cenv) (add1 depth))]
[else
(let: ([n : (U Symbol False ModuleVariable) (first names)])
(let: ([n : (U False Symbol GlobalBucket ModuleVariable) (first names)])
(cond
[(and (symbol? n) (eq? name n))
(make-EnvPrefixReference depth pos)]
[(and (ModuleVariable? n) (eq? name (ModuleVariable-name n)))
(make-EnvPrefixReference depth pos)]
[(and (GlobalBucket? n) (eq? name (GlobalBucket-name n)))
(make-EnvPrefixReference depth pos)]
[else
(prefix-loop (rest names) (add1 pos))]))]))]
@ -189,16 +191,21 @@
;; Masks elements of the prefix off.
(define (place-prefix-mask a-prefix symbols-to-keep)
(make-Prefix
(map (lambda: ([n : (U Symbol False ModuleVariable)])
(cond [(symbol? n)
(map (lambda: ([n : (U False Symbol GlobalBucket ModuleVariable)])
(cond [(eq? n #f)
n]
[(symbol? n)
(if (member n symbols-to-keep)
n
#f)]
[(GlobalBucket? n)
(if (member (GlobalBucket-name n) symbols-to-keep)
n
#f)]
[(ModuleVariable? n)
(if (member (ModuleVariable-name n) symbols-to-keep)
n
#f)]
[else n]))
#f)]))
(Prefix-names a-prefix))))

5
lexical-structs.rkt
View File

@ -9,7 +9,10 @@
;; A toplevel prefix contains a list of toplevel variables. Some of the
;; names may be masked out by #f.
(define-struct: Prefix ([names : (Listof (U Symbol ModuleVariable False))])
(define-struct: Prefix ([names : (Listof (U False Symbol GlobalBucket ModuleVariable))])
#:transparent)
(define-struct: GlobalBucket ([name : Symbol])
#:transparent)
(define-struct: ModuleVariable ([name : Symbol]

55
parse-bytecode.rkt Normal file
View File

@ -0,0 +1,55 @@
#lang racket/base
(require "expression-structs.rkt"
"lexical-structs.rkt")
(require compiler/zo-parse
racket/match
racket/list)
(provide parse-bytecode)
(define (parse-bytecode in)
(let ([compilation-top (zo-parse in)])
(parse-top compilation-top)))
(define (parse-top a-top)
(match a-top
[(struct compilation-top (max-let-depth prefix code))
(make-Top (parse-prefix prefix) (parse-top-code code))]))
(define (parse-prefix a-prefix)
(match a-prefix
[(struct prefix (num-lifts toplevels stxs))
(make-Prefix
(append (map parse-prefix-toplevel toplevels)
(if (empty? stxs)
empty
empty ;; fixme
)
(build-list num-lifts
(lambda (i)))))]))
;; parse-top-code: (U form Any -> Expression)
(define (parse-top-code code)
(cond
[(form? code)
(parse-form code)]
[else
(make-Constant code)]))
;; parse-prefix-toplevel: (U #f symbol global-bucket module-variable) -> (U False Symbol GlobalBucket ModuleVariable)
(define (parse-prefix-toplevel a-toplevel)
(cond
[(eq? a-toplevel #f)
#f]
[(symbol? a-toplevel)
a-toplevel]
[(global-bucket? a-toplevel)

2
simulator-structs.rkt
View File

@ -134,7 +134,7 @@
(define-struct: toplevel ([names : (Listof (U #f Symbol ModuleVariable))]
(define-struct: toplevel ([names : (Listof (U #f Symbol GlobalBucket ModuleVariable))]
[vals : (Listof PrimitiveValue)])
#:transparent
#:mutable)

12
simulator.rkt
View File

@ -288,13 +288,15 @@
[(ExtendEnvironment/Prefix!? op)
(env-push! m
(make-toplevel (ExtendEnvironment/Prefix!-names op)
(map (lambda: ([name : (U Symbol ModuleVariable False)])
(cond [(symbol? name)
(map (lambda: ([name : (U False Symbol GlobalBucket ModuleVariable)])
(cond [(eq? name #f)
(make-undefined)]
[(symbol? name)
(lookup-primitive name)]
[(GlobalBucket? name)
(lookup-primitive (GlobalBucket-name name))]
[(ModuleVariable? name)
(lookup-primitive (ModuleVariable-name name))]
[(eq? name #f)
(make-undefined)]))
(lookup-primitive (ModuleVariable-name name))]))
(ExtendEnvironment/Prefix!-names op))))]
[(InstallClosureValues!? op)