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) [(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];" (format "MACHINE.env.push([~a]); MACHINE.env[MACHINE.env.length-1].names = [~a];"
(string-join (map (string-join (map
(lambda: ([n : (U Symbol False ModuleVariable)]) (lambda: ([n : (U Symbol False GlobalBucket ModuleVariable)])
(cond [(symbol? n) (cond [(symbol? n)
(format "MACHINE.params.currentNamespace[~s] || MACHINE.primitives[~s]" (format "MACHINE.params.currentNamespace[~s] || MACHINE.primitives[~s]"
(symbol->string n) (symbol->string n)
(symbol->string n))] (symbol->string n))]
[(eq? n #f) [(eq? n #f)
"false"] "false"]
[(ModuleVariable? n) [(GlobalBucket? n)
(format "MACHINE.primitives[~s]" ;; FIXME: maybe we should keep a set of global variables here?
(symbol->string (ModuleVariable-name n)))])) (format "MACHINE.primitives[~s]"
names) (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 (string-join (map
(lambda: ([n : (U Symbol False ModuleVariable)]) (lambda: ([n : (U Symbol False GlobalBucket ModuleVariable)])
(cond (cond
[(symbol? n) [(symbol? n)
(format "~s" (symbol->string n))] (format "~s" (symbol->string n))]
[(eq? n #f) [(eq? n #f)
"false"] "false"]
[(GlobalBucket? n)
(format "~s" (symbol->string (GlobalBucket-name n)))]
[(ModuleVariable? n) [(ModuleVariable? n)
(format "~s" (symbol->string (ModuleVariable-name n)))])) (format "~s" (symbol->string (ModuleVariable-name n)))]))
names) names)

6
compiler.rkt
View File

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

50
expression-structs.rkt
View File

@ -3,20 +3,44 @@
(provide (all-defined-out)) (provide (all-defined-out))
;; Expressions
(define-type Expression (U Top Constant ;; Expressions
ToplevelRef LocalRef (define-type Expression (U
ToplevelSet Top
Branch CaseLam Lam Seq Splice App Constant
Let1 ToplevelRef
LetVoid LocalRef
LetRec ToplevelSet
InstallValue Branch
BoxEnv CaseLam
WithContMark Lam
ApplyValues Seq
DefValues)) 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] (define-struct: Top ([prefix : Prefix]
[code : Expression]) #:transparent) [code : Expression]) #:transparent)

2
il-structs.rkt
View File

@ -303,7 +303,7 @@
;; Extends the environment with a prefix that holds ;; Extends the environment with a prefix that holds
;; lookups to the namespace. ;; 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) #:transparent)
;; Adjusts the environment by pushing the values in the ;; Adjusts the environment by pushing the values in the

21
lexical-env.rkt
View File

@ -40,17 +40,19 @@
(cond (cond
[(Prefix? elt) [(Prefix? elt)
(let: prefix-loop : LexicalAddress (let: prefix-loop : LexicalAddress
([names : (Listof (U Symbol False ModuleVariable)) (Prefix-names elt)] ([names : (Listof (U False Symbol GlobalBucket ModuleVariable)) (Prefix-names elt)]
[pos : Natural 0]) [pos : Natural 0])
(cond [(empty? names) (cond [(empty? names)
(loop (rest cenv) (add1 depth))] (loop (rest cenv) (add1 depth))]
[else [else
(let: ([n : (U Symbol False ModuleVariable) (first names)]) (let: ([n : (U False Symbol GlobalBucket ModuleVariable) (first names)])
(cond (cond
[(and (symbol? n) (eq? name n)) [(and (symbol? n) (eq? name n))
(make-EnvPrefixReference depth pos)] (make-EnvPrefixReference depth pos)]
[(and (ModuleVariable? n) (eq? name (ModuleVariable-name n))) [(and (ModuleVariable? n) (eq? name (ModuleVariable-name n)))
(make-EnvPrefixReference depth pos)] (make-EnvPrefixReference depth pos)]
[(and (GlobalBucket? n) (eq? name (GlobalBucket-name n)))
(make-EnvPrefixReference depth pos)]
[else [else
(prefix-loop (rest names) (add1 pos))]))]))] (prefix-loop (rest names) (add1 pos))]))]))]
@ -189,16 +191,21 @@
;; Masks elements of the prefix off. ;; Masks elements of the prefix off.
(define (place-prefix-mask a-prefix symbols-to-keep) (define (place-prefix-mask a-prefix symbols-to-keep)
(make-Prefix (make-Prefix
(map (lambda: ([n : (U Symbol False ModuleVariable)]) (map (lambda: ([n : (U False Symbol GlobalBucket ModuleVariable)])
(cond [(symbol? n) (cond [(eq? n #f)
n]
[(symbol? n)
(if (member n symbols-to-keep) (if (member n symbols-to-keep)
n n
#f)] #f)]
[(GlobalBucket? n)
(if (member (GlobalBucket-name n) symbols-to-keep)
n
#f)]
[(ModuleVariable? n) [(ModuleVariable? n)
(if (member (ModuleVariable-name n) symbols-to-keep) (if (member (ModuleVariable-name n) symbols-to-keep)
n n
#f)] #f)]))
[else n]))
(Prefix-names a-prefix)))) (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 ;; A toplevel prefix contains a list of toplevel variables. Some of the
;; names may be masked out by #f. ;; 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) #:transparent)
(define-struct: ModuleVariable ([name : Symbol] (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)]) [vals : (Listof PrimitiveValue)])
#:transparent #:transparent
#:mutable) #:mutable)

12
simulator.rkt
View File

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