diff --git a/NOTES b/NOTES index 2f2c95f..7e0f27d 100644 --- a/NOTES +++ b/NOTES @@ -462,4 +462,9 @@ such a context. Ok, I think I've been able to do this successfully. I lifted out the code for emit-values-context-check-on-procedure-return so it's used for both the returns from procedure call, as well as the calls from -the prompt splicing. \ No newline at end of file +the prompt splicing. + + +---------------------------------------------------------------------- + + diff --git a/assemble-perform-statement.rkt b/assemble-perform-statement.rkt index d4283be..2eb371b 100644 --- a/assemble-perform-statement.rkt +++ b/assemble-perform-statement.rkt @@ -123,4 +123,9 @@ [(RaiseOperatorApplicationError!? op) (format "RUNTIME.raiseOperatorApplicationError(MACHINE, ~a);" - (assemble-oparg (RaiseOperatorApplicationError!-operator op)))])) + (assemble-oparg (RaiseOperatorApplicationError!-operator op)))] + + [(InstallModuleEntry!? op) + (format "MACHINE.modules[~s]=new RUNTIME.ModuleRecord(~s, ~a);" + (symbol->string (ModuleName-name (InstallModuleEntry!-name op))) + (assemble-label (make-Label (InstallModuleEntry!-entry-point op))))])) diff --git a/collect-jump-targets.rkt b/collect-jump-targets.rkt index 2f7be9e..f554f30 100644 --- a/collect-jump-targets.rkt +++ b/collect-jump-targets.rkt @@ -154,7 +154,9 @@ [(RaiseArityMismatchError!? op) empty] [(RaiseOperatorApplicationError!? op) - empty])) + empty] + [(InstallModuleEntry!? op) + (list (InstallModuleEntry!-entry-point op))])) diff --git a/compiler.rkt b/compiler.rkt index 66910ad..01c01f1 100644 --- a/compiler.rkt +++ b/compiler.rkt @@ -65,6 +65,8 @@ (cond [(Top? exp) (loop (Top-code exp) (cons (Top-prefix exp) cenv))] + [(Module? exp) + (loop (Module-code exp) (cons (Module-prefix exp) cenv))] [(Constant? exp) '()] [(LocalRef? exp) @@ -168,6 +170,8 @@ (cond [(Top? exp) (compile-top exp cenv target linkage)] + [(Module? exp) + (compile-module exp cenv target linkage)] [(Constant? exp) (compile-constant exp cenv target linkage)] [(LocalRef? exp) @@ -244,6 +248,33 @@ + +(: compile-module (Module CompileTimeEnvironment Target Linkage -> InstructionSequence)) +;; Generates code to write out the top prefix, evaluate the rest of the body, +;; and then pop the top prefix off. +(define (compile-module top cenv target linkage) + ;; fixme: this is not right yet. This should instead install a module record + ;; that has not yet been invoked. + ;; fixme: This also needs to generate code for the requires and provides. + (let*: ([names : (Listof (U False Symbol GlobalBucket ModuleVariable)) + (Prefix-names (Module-prefix top))]) + (end-with-linkage + linkage cenv + (append-instruction-sequences + (make-instruction-sequence + `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! names)))) + (compile (Module-code top) + (cons (Module-prefix top) cenv) + target + next-linkage/drop-multiple) + (make-instruction-sequence + `(,(make-PopEnvironment (make-Const 1) + (make-Const 0)))))))) + + + + + (: end-with-linkage (Linkage CompileTimeEnvironment InstructionSequence -> InstructionSequence)) ;; Add linkage for expressions. (define (end-with-linkage linkage cenv instruction-sequence) @@ -815,7 +846,9 @@ (default)] [(ModuleVariable? op-knowledge) (cond - [(symbol=? (ModuleVariable-module-path op-knowledge) '#%kernel) + [(symbol=? (ModuleName-name + (ModuleVariable-module-name op-knowledge)) + '#%kernel) (let ([op (ModuleVariable-name op-knowledge)]) (cond [(KernelPrimitiveName? op) (compile-kernel-primitive-application @@ -1952,6 +1985,13 @@ (make-Top (Top-prefix exp) (adjust-expression-depth (Top-code exp) n (add1 skip)))] + [(Module? exp) + (make-Module (Module-name exp) + (Module-prefix exp) + (Module-requires exp) + (Module-provides exp) + (adjust-expression-depth (Module-code exp) n (add1 skip)))] + [(Constant? exp) exp] diff --git a/il-structs.rkt b/il-structs.rkt index cafdd72..eca1a50 100644 --- a/il-structs.rkt +++ b/il-structs.rkt @@ -196,6 +196,7 @@ + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Primitive Operators @@ -369,6 +370,13 @@ ;; Adds a continuation mark into the current top control frame. (define-struct: InstallContinuationMarkEntry! () #:transparent) + +;; Installs a module record into the machine +(define-struct: InstallModuleEntry! ([name : ModuleName] + [entry-point : Symbol]) + #:transparent) + + (define-type PrimitiveCommand (U CheckToplevelBound! CheckClosureArity! @@ -389,7 +397,10 @@ RaiseOperatorApplicationError! RestoreEnvironment! - RestoreControl!)) + RestoreControl! + + InstallModuleEntry! + )) diff --git a/parse.rkt b/parse.rkt index b03d586..aae7c94 100644 --- a/parse.rkt +++ b/parse.rkt @@ -52,7 +52,7 @@ [(current-language) => (lambda (lang) (if (member sym lang) - (make-ModuleVariable sym '#%kernel) + (make-ModuleVariable sym (make-ModuleName '#%kernel)) #f))] [else #f])) diff --git a/runtime.js b/runtime.js index af0aef2..82af631 100644 --- a/runtime.js +++ b/runtime.js @@ -64,6 +64,7 @@ this.env = []; this.control = []; // Arrayof (U Frame CallFrame PromptFrame) this.running = false; + this.modules = {}; // String -> ModuleRecord this.params = { 'currentDisplayer': function(v) {}, 'currentOutputPort': new StandardOutputPort(), @@ -92,6 +93,12 @@ + var ModuleRecord = function(name, label) { + this.name = name; + this.label = label; + this.isInvoked = false; + this.exports = {}; + }; @@ -1128,6 +1135,7 @@ exports['CallFrame'] = CallFrame; exports['PromptFrame'] = PromptFrame; exports['Closure'] = Closure; + exports['ModuleRecord'] = ModuleRecord; exports['ContinuationPromptTag'] = ContinuationPromptTag; exports['DEFAULT_CONTINUATION_PROMPT_TAG'] = DEFAULT_CONTINUATION_PROMPT_TAG; @@ -1162,4 +1170,6 @@ exports['heir'] = heir; exports['makeClassPredicate'] = makeClassPredicate; + + }).call(this); \ No newline at end of file diff --git a/simulator-structs.rkt b/simulator-structs.rkt index e61a866..7a31c95 100644 --- a/simulator-structs.rkt +++ b/simulator-structs.rkt @@ -48,6 +48,8 @@ [pc : Natural] ;; program counter [text : (Vectorof Statement)] ;; text of the program + [modules : (HashTable Symbol module-record)] + ;; other metrics for debugging [stack-size : Natural] @@ -58,6 +60,13 @@ #:mutable) +(define-struct: module-record ([name : ModuleName] + [label : Symbol] + [invoked? : Boolean] + [exports : (HashTable Symbol PrimitiveValue)]) + #:transparent + #:mutable) + (define-type frame (U GenericFrame CallFrame PromptFrame)) diff --git a/simulator.rkt b/simulator.rkt index e1f55cc..901ec34 100644 --- a/simulator.rkt +++ b/simulator.rkt @@ -57,6 +57,7 @@ '() 0 (list->vector program-text) + ((inst make-hash Symbol module-record)) 0 ((inst make-hash Symbol Natural)))]) (let: loop : Void ([i : Natural 0]) @@ -401,7 +402,17 @@ [(RaiseOperatorApplicationError!? op) (error "expected procedure, given ~a" - (evaluate-oparg m (RaiseOperatorApplicationError!-operator op)))]))) + (evaluate-oparg m (RaiseOperatorApplicationError!-operator op)))] + + + [(InstallModuleEntry!? op) + (hash-set! (machine-modules m) + (ModuleName-name (InstallModuleEntry!-name op)) + (make-module-record (InstallModuleEntry!-name op) + (InstallModuleEntry!-entry-point op) + #f + (make-hash))) + 'ok]))) @@ -879,7 +890,7 @@ (define (current-instruction m) (match m [(struct machine (val proc argcount env control pc text - stack-size jump-table)) + modules stack-size jump-table)) (vector-ref text pc)])) @@ -903,7 +914,7 @@ (: env-push! (machine SlotValue -> 'ok)) (define (env-push! m v) (match m - [(struct machine (val proc argcount env control pc text stack-size jump-table)) + [(struct machine (val proc argcount env control pc text modules stack-size jump-table)) (set-machine-env! m (cons v env)) (set-machine-stack-size! m (add1 stack-size)) 'ok])) @@ -911,7 +922,7 @@ (: env-push-many! (machine (Listof SlotValue) -> 'ok)) (define (env-push-many! m vs) (match m - [(struct machine (val proc argcount env control pc text stack-size jump-table)) + [(struct machine (val proc argcount env control pc text modules stack-size jump-table)) (set-machine-env! m (append vs env)) (set-machine-stack-size! m (+ stack-size (length vs))) 'ok])) @@ -920,13 +931,13 @@ (: env-ref (machine Natural -> SlotValue)) (define (env-ref m i) (match m - [(struct machine (val proc argcount env control pc text stack-size jump-table)) + [(struct machine (val proc argcount env control pc text modules stack-size jump-table)) (list-ref env i)])) (: env-mutate! (machine Natural SlotValue -> 'ok)) (define (env-mutate! m i v) (match m - [(struct machine (val proc argcount env control pc text stack-size jump-table)) + [(struct machine (val proc argcount env control pc text modules stack-size jump-table)) (set-machine-env! m (list-replace env i v)) 'ok])) @@ -944,7 +955,7 @@ (: env-pop! (machine Natural Natural -> 'ok)) (define (env-pop! m n skip) (match m - [(struct machine (val proc argcount env control pc text stack-size jump-table)) + [(struct machine (val proc argcount env control pc text modules stack-size jump-table)) (set-machine-env! m (append (take env skip) (drop env (+ skip n)))) (set-machine-stack-size! m (ensure-natural (- stack-size n))) @@ -954,7 +965,7 @@ (: control-push! (machine frame -> 'ok)) (define (control-push! m a-frame) (match m - [(struct machine (val proc argcount env control pc text stack-size jump-table)) + [(struct machine (val proc argcount env control pc text modules stack-size jump-table)) (set-machine-control! m (cons a-frame control)) 'ok])) @@ -962,14 +973,14 @@ (: control-pop! (machine -> 'ok)) (define (control-pop! m) (match m - [(struct machine (val proc argcount env control pc text stack-size jump-table)) + [(struct machine (val proc argcount env control pc text modules stack-size jump-table)) (set-machine-control! m (rest control)) 'ok])) (: control-top (machine -> frame)) (define (control-top m) (match m - [(struct machine (val proc argcount env control pc text stack-size jump-table)) + [(struct machine (val proc argcount env control pc text modules stack-size jump-table)) (first control)])) @@ -985,7 +996,7 @@ ;; Jumps directly to the instruction at the given label. (define (jump! m l) (match m - [(struct machine (val proc argcount env control pc text stack-size jump-table)) + [(struct machine (val proc argcount env control pc text modules stack-size jump-table)) (set-machine-pc! m (hash-ref jump-table l)) 'ok])) diff --git a/test-parse.rkt b/test-parse.rkt index d72fd15..73494e5 100644 --- a/test-parse.rkt +++ b/test-parse.rkt @@ -208,7 +208,7 @@ 'lamEntry2))) (test (parse '(+ x x)) - (make-Top (make-Prefix `(,(make-ModuleVariable '+ '#%kernel) + (make-Top (make-Prefix `(,(make-ModuleVariable '+ (make-ModuleName '#%kernel)) x)) (make-App (make-ToplevelRef 2 0) (list (make-ToplevelRef 2 1) @@ -216,7 +216,7 @@ (test (parse '(lambda (x) (+ x x))) - (make-Top (make-Prefix `(,(make-ModuleVariable '+ '#%kernel))) + (make-Top (make-Prefix `(,(make-ModuleVariable '+ (make-ModuleName '#%kernel)))) (make-Lam 'unknown 1 #f (make-App (make-ToplevelRef 2 0) (list (make-LocalRef 3 #f) @@ -226,8 +226,8 @@ (test (parse '(lambda (x) (+ (* x x) x))) - (make-Top (make-Prefix `(,(make-ModuleVariable '* '#%kernel) - ,(make-ModuleVariable '+ '#%kernel))) + (make-Top (make-Prefix `(,(make-ModuleVariable '* (make-ModuleName '#%kernel)) + ,(make-ModuleVariable '+ (make-ModuleName '#%kernel)))) (make-Lam 'unknown 1 #f ;; stack layout: [???, ???, prefix, x] (make-App (make-ToplevelRef 2 1) @@ -286,7 +286,7 @@ (test (parse '(let* ([x 3] [x (add1 x)]) (add1 x))) - (make-Top (make-Prefix `(,(make-ModuleVariable 'add1 '#%kernel))) + (make-Top (make-Prefix `(,(make-ModuleVariable 'add1 (make-ModuleName '#%kernel)))) ;; stack layout: [prefix] @@ -415,7 +415,7 @@ (test (parse '(let ([x 0]) (lambda () (set! x (add1 x))))) - (make-Top (make-Prefix `(,(make-ModuleVariable 'add1 '#%kernel))) + (make-Top (make-Prefix `(,(make-ModuleVariable 'add1 (make-ModuleName '#%kernel)))) (make-Let1 (make-Constant 0) (make-BoxEnv 0 (make-Lam 'unknown 0 #f @@ -434,7 +434,7 @@ [y 1]) (lambda () (set! x (add1 x))))) - (make-Top (make-Prefix `(,(make-ModuleVariable 'add1 '#%kernel))) + (make-Top (make-Prefix `(,(make-ModuleVariable 'add1 (make-ModuleName '#%kernel)))) (make-LetVoid 2 (make-Seq (list (make-InstallValue 1 0 (make-Constant 0) #t) @@ -462,7 +462,7 @@ (reset!) (list a b))) (make-Top - (make-Prefix `(a b ,(make-ModuleVariable 'list '#%kernel) reset!)) + (make-Prefix `(a b ,(make-ModuleVariable 'list (make-ModuleName '#%kernel)) reset!)) (make-Splice (list (make-ToplevelSet 0 0 (make-Constant '(hello)))