From ac678fba7beeac6f32f973017d69ea651dcff0b0 Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Sun, 22 May 2011 18:50:14 -0400 Subject: [PATCH] trying to get module invokation working under tests --- compiler.rkt | 2 +- il-structs.rkt | 5 ++- kernel-primitives.rkt | 1 + lang/kernel.rkt | 5 ++- package.rkt | 36 ++++++---------- simulator/simulator-primitives.rkt | 12 ++++-- simulator/simulator-structs.rkt | 12 +++++- simulator/simulator.rkt | 67 ++++++++++++++++++++++++------ tests/test-compiler.rkt | 20 ++++++++- 9 files changed, 113 insertions(+), 47 deletions(-) diff --git a/compiler.rkt b/compiler.rkt index 17fe13d..8d1970a 100644 --- a/compiler.rkt +++ b/compiler.rkt @@ -382,7 +382,7 @@ (make-IsModuleInvoked a-module-name)) already-loaded) ,(make-PushControlFrame/Call on-return) - ,(make-GotoStatement (make-ModuleEntry a-module-name)) + ,(make-GotoStatement (ModuleEntry a-module-name)) ,on-return-multiple ,(make-PopEnvironment (make-SubtractArg (make-Reg 'argcount) (make-Const 1)) diff --git a/il-structs.rkt b/il-structs.rkt index d1bbf64..bb8305c 100644 --- a/il-structs.rkt +++ b/il-structs.rkt @@ -204,7 +204,10 @@ -(define-struct: GotoStatement ([target : OpArg]) +(define-struct: GotoStatement ([target : (U Label + Reg + ModuleEntry + CompiledProcedureEntry)]) #:transparent) (define-struct: PerformStatement ([op : PrimitiveCommand]) diff --git a/kernel-primitives.rkt b/kernel-primitives.rkt index a8ac987..cd78646 100644 --- a/kernel-primitives.rkt +++ b/kernel-primitives.rkt @@ -59,6 +59,7 @@ 'values 'call-with-values 'apply + 'printf )) (define-predicate KernelPrimitiveName? KernelPrimitiveName) diff --git a/lang/kernel.rkt b/lang/kernel.rkt index 8f0d626..90d1ea8 100644 --- a/lang/kernel.rkt +++ b/lang/kernel.rkt @@ -63,12 +63,13 @@ #%app #%top-interaction #%top - define + module + define define-values let-values let*-values define-struct - if + if cond else case diff --git a/package.rkt b/package.rkt index 13d2108..f0ac426 100644 --- a/package.rkt +++ b/package.rkt @@ -6,6 +6,7 @@ "language-namespace.rkt" "il-structs.rkt" "bootstrapped-primitives.rkt" + "get-module-bytecode.rkt" "get-dependencies.rkt" "js-assembler/assemble.rkt" "js-assembler/get-runtime.rkt" @@ -23,34 +24,21 @@ (define-runtime-path kernel-language-path "lang/kernel.rkt") -;; Use Racket's compiler, and then parse the resulting bytecode -;; to our own AST structures. -(define (parse stx) - (parameterize ([current-namespace (lookup-language-namespace - `(file ,(path->string kernel-language-path)) - #;'racket/base)] - ;; We want to disable some optimizations for the moment. - ;; See: http://docs.racket-lang.org/drracket/module.html - [compile-context-preservation-enabled #t]) - - (let ([bc (racket:compile stx)] - [op (open-output-bytes)]) - (write bc op) - (parse-bytecode - (open-input-bytes (get-output-bytes op)))))) - - ;; package: s-expression output-port -> void (define (package source-code op) - (fprintf op "var invoke = ") - (assemble/write-invoke (append (get-bootstrapping-code) - (compile (parse source-code) - 'val - next-linkage/drop-multiple)) - op) - (fprintf op ";\n")) + (let ([source-code-op (open-output-bytes)]) + (write source-code source-code-op) + (let ([source-code-ip (open-input-bytes (get-output-bytes source-code-op))]) + (fprintf op "var invoke = ") + (assemble/write-invoke (append (get-bootstrapping-code) + (compile (parse-bytecode + (open-input-bytes (get-module-bytecode source-code-ip))) + 'val + next-linkage/drop-multiple)) + op) + (fprintf op ";\n")))) (define (package-anonymous source-code op) diff --git a/simulator/simulator-primitives.rkt b/simulator/simulator-primitives.rkt index c94de83..e69d5ac 100644 --- a/simulator/simulator-primitives.rkt +++ b/simulator/simulator-primitives.rkt @@ -1,6 +1,7 @@ #lang racket/base (require "simulator-structs.rkt" "../il-structs.rkt" + "simulator-helpers.rkt" racket/math racket/list (for-syntax racket/base)) @@ -170,6 +171,11 @@ (error 'member "not a list: ~s" l)])))) +(define my-printf (lambda (fmt args) + (apply printf fmt (map (lambda (x) + (PrimitiveValue->racket x)) + args)))) + (define current-continuation-marks @@ -258,11 +264,11 @@ equal? + symbol? - - - symbol?) + (my-printf printf) + ) #:constants (null pi e current-continuation-marks continuation-mark-set->list))) diff --git a/simulator/simulator-structs.rkt b/simulator/simulator-structs.rkt index 1312322..7f9baee 100644 --- a/simulator/simulator-structs.rkt +++ b/simulator/simulator-structs.rkt @@ -7,6 +7,14 @@ "../lexical-structs.rkt") + + +;; A special "label" in the system that causes evaluation to stop. +(define-struct: halt ()) +(define HALT (make-halt)) + + + (define-type PrimitiveValue (Rec PrimitiveValue (U String Number Symbol Boolean Null VoidValue undefined @@ -79,7 +87,7 @@ #:transparent) -(define-struct: CallFrame ([return : LinkedLabel] +(define-struct: CallFrame ([return : (U LinkedLabel halt)] ;; The procedure being called. Used to optimize self-application [proc : (U closure #f)] ;; TODO: add continuation marks @@ -89,7 +97,7 @@ #:mutable) ;; mutable because we want to allow mutation of proc. (define-struct: PromptFrame ([tag : ContinuationPromptTagValue] - [return : LinkedLabel] + [return : (U LinkedLabel halt)] [env-depth : Natural] [temps : (HashTable Symbol PrimitiveValue)] [marks : (HashTable PrimitiveValue PrimitiveValue)]) diff --git a/simulator/simulator.rkt b/simulator/simulator.rkt index 6bed095..7b0ec36 100644 --- a/simulator/simulator.rkt +++ b/simulator/simulator.rkt @@ -27,14 +27,22 @@ [racket->PrimitiveValue (Any -> PrimitiveValue)]) -(provide new-machine can-step? step! current-instruction +(provide new-machine + can-step? + step! + current-instruction current-simulated-output-port - machine-control-size) + machine-control-size + invoke-module-as-main) (define current-simulated-output-port (make-parameter (current-output-port))) + +(define end-of-program-text 'end-of-program-text) + + (: new-machine (case-lambda [(Listof Statement) -> machine] [(Listof Statement) Boolean -> machine])) (define new-machine @@ -45,11 +53,12 @@ [with-bootstrapping-code? : Boolean]) (let*: ([after-bootstrapping : Symbol (make-label 'afterBootstrapping)] [program-text : (Listof Statement) - (cond [with-bootstrapping-code? - (append (get-bootstrapping-code) - program-text)] - [else - program-text])]) + (append (cond [with-bootstrapping-code? + (append (get-bootstrapping-code) + program-text)] + [else + program-text]) + (list end-of-program-text))]) (let: ([m : machine (make-machine (make-undefined) (make-undefined) (make-undefined) @@ -79,6 +88,25 @@ + +(: invoke-module-as-main (machine Symbol -> 'ok)) +;; Assuming the module has been loaded in, sets the machine +;; up to invoke its body. +(define (invoke-module-as-main m module-name) + (let ([frame (make-PromptFrame + default-continuation-prompt-tag-value + HALT + (length (machine-env m)) + (make-hasheq) + (make-hasheq))] + [module-record (hash-ref (machine-modules m) module-name)]) + (control-push! m frame) + (jump! m (module-record-label module-record)))) + + + + + (: can-step? (machine -> Boolean)) ;; Produces true if we can make a further step in the simulation. (define (can-step? m) @@ -771,10 +799,17 @@ (error 'GetControlStackLabel)] [(PromptFrame? frame) (let ([label (PromptFrame-return frame)]) - (LinkedLabel-label label))] + (cond [(halt? label) + end-of-program-text] + [else + (LinkedLabel-label label)]))] [(CallFrame? frame) (let ([label (CallFrame-return frame)]) - (LinkedLabel-label label))]))] + (cond + [(halt? label) + end-of-program-text] + [else + (LinkedLabel-label label)]))]))] [(ControlStackLabel/MultipleValueReturn? an-oparg) (let ([frame (ensure-frame (first (machine-control m)))]) @@ -783,11 +818,19 @@ (error 'GetControlStackLabel/MultipleValueReturn)] [(PromptFrame? frame) (let ([label (PromptFrame-return frame)]) - (LinkedLabel-linked-to label))] + (cond + [(halt? label) + end-of-program-text] + [else + (LinkedLabel-linked-to label)]))] [(CallFrame? frame) (let ([label (CallFrame-return frame)]) - (LinkedLabel-linked-to label))]))] - + (cond + [(halt? label) + end-of-program-text] + [else + (LinkedLabel-linked-to label)]))]))] + [(ControlFrameTemporary? an-oparg) (let ([ht (frame-temps (control-top m))]) (hash-ref ht diff --git a/tests/test-compiler.rkt b/tests/test-compiler.rkt index 6f9941f..2be9b0a 100644 --- a/tests/test-compiler.rkt +++ b/tests/test-compiler.rkt @@ -54,7 +54,8 @@ #:debug? (debug? false) #:stack-limit (stack-limit false) #:control-limit (control-limit false) - #:with-bootstrapping? (with-bootstrapping? false)) + #:with-bootstrapping? (with-bootstrapping? false) + #:as-main-module (as-main-module #f)) (let ([m (new-machine (run-compiler code) with-bootstrapping?)]) (let loop ([steps 0]) (when debug? @@ -76,7 +77,15 @@ (step! m) (loop (add1 steps))] [else - (values m steps)])))) + (cond + [as-main-module + ;; Set the pc to the module's entry point + ;; Set the return point to halt on exit. + (invoke-module-as-main m as-main-module) + (set! as-main-module #f) + (loop (add1 steps))] + [else + (values m steps)])])))) ;; Atomic expressions @@ -1327,6 +1336,13 @@ +(test '(module foo racket/base + (printf "hello world")) + (make-undefined) + #:as-main-module 'foo) + + + ;; begin0 is still broken.