From f64090700196d25a7040eca63a9529993c561844 Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Fri, 6 May 2011 15:53:00 -0400 Subject: [PATCH] extending prefixes to also take globalbuckets, although I don't think the simulator or assembler is treating them and modulevariables correctly yet. --- assemble-perform-statement.rkt | 34 +++++++++++++-------- compiler.rkt | 6 ++-- expression-structs.rkt | 50 +++++++++++++++++++++++-------- il-structs.rkt | 2 +- lexical-env.rkt | 21 ++++++++----- lexical-structs.rkt | 5 +++- parse-bytecode.rkt | 55 ++++++++++++++++++++++++++++++++++ simulator-structs.rkt | 2 +- simulator.rkt | 12 ++++---- 9 files changed, 144 insertions(+), 43 deletions(-) create mode 100644 parse-bytecode.rkt diff --git a/assemble-perform-statement.rkt b/assemble-perform-statement.rkt index 33072a1..d4283be 100644 --- a/assemble-perform-statement.rkt +++ b/assemble-perform-statement.rkt @@ -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) diff --git a/compiler.rkt b/compiler.rkt index 42bc185..b1d7852 100644 --- a/compiler.rkt +++ b/compiler.rkt @@ -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 '?]))] diff --git a/expression-structs.rkt b/expression-structs.rkt index fdd41d2..917952e 100644 --- a/expression-structs.rkt +++ b/expression-structs.rkt @@ -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) diff --git a/il-structs.rkt b/il-structs.rkt index 68fb545..45ad227 100644 --- a/il-structs.rkt +++ b/il-structs.rkt @@ -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 diff --git a/lexical-env.rkt b/lexical-env.rkt index df1f0b4..452ee8b 100644 --- a/lexical-env.rkt +++ b/lexical-env.rkt @@ -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)))) diff --git a/lexical-structs.rkt b/lexical-structs.rkt index 4649431..8061647 100644 --- a/lexical-structs.rkt +++ b/lexical-structs.rkt @@ -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] diff --git a/parse-bytecode.rkt b/parse-bytecode.rkt new file mode 100644 index 0000000..f59e7bb --- /dev/null +++ b/parse-bytecode.rkt @@ -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) + \ No newline at end of file diff --git a/simulator-structs.rkt b/simulator-structs.rkt index cf49a86..026966e 100644 --- a/simulator-structs.rkt +++ b/simulator-structs.rkt @@ -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) diff --git a/simulator.rkt b/simulator.rkt index d9db5be..92d8e8d 100644 --- a/simulator.rkt +++ b/simulator.rkt @@ -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)