From 5238d2b389e7325c48ac2253f1094fee5678fcc8 Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Mon, 30 May 2011 11:30:28 -0400 Subject: [PATCH 1/7] adding command to print the runtime. --- whalesong.rkt | 23 ++++++++++++++++++++--- 1 file changed, 20 insertions(+), 3 deletions(-) diff --git a/whalesong.rkt b/whalesong.rkt index 169abaa..9b95d73 100755 --- a/whalesong.rkt +++ b/whalesong.rkt @@ -6,7 +6,8 @@ racket/string racket/path "make-structs.rkt" - "js-assembler/package.rkt") + "js-assembler/package.rkt" + "js-assembler/get-runtime.rkt") ;; Usage: @@ -14,11 +15,19 @@ ;; * Build standalone .xhtml application. ;; ;; $ whalesong build main-module-name.rkt +;; +;; +;; * Print out the runtime library to standard output. +;; +;; $ whalesong get-runtime (define commands `((build ,(lambda (args) - (do-the-build args))))) + (do-the-build args))) + (get-runtime + ,(lambda (args) + (print-the-runtime))))) ;; listof string (define command-names (map (lambda (x) (symbol->string (car x))) @@ -61,7 +70,15 @@ (make-ModuleSource (build-path f)) op)) #:exists 'replace))))) - + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (print-the-runtime) + (display (get-runtime))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (at-toplevel) From 837fdf480d321edfb8da7c020a20f942328f4840 Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Mon, 30 May 2011 12:17:03 -0400 Subject: [PATCH 2/7] adjusting the generated code so it waits until the runtime is ready. --- Makefile | 3 +++ js-assembler/assemble-helpers.rkt | 2 +- js-assembler/mini-runtime.js | 37 ++++++++++++++++++++++++++ js-assembler/package.rkt | 43 +++++++++++++++++++++++++++---- tests/test-browser-evaluate.rkt | 1 - tests/test-conform-browser.rkt | 1 - tests/test-earley-browser.rkt | 1 - whalesong.rkt | 21 ++++++++++++--- 8 files changed, 97 insertions(+), 12 deletions(-) diff --git a/Makefile b/Makefile index 52c7dfb..ae61dd3 100644 --- a/Makefile +++ b/Makefile @@ -9,6 +9,9 @@ test-all: raco make -v --disable-inline tests/test-all.rkt racket tests/test-all.rkt +test-browser-evaluate: + raco make -v --disable-inline tests/test-browser-evaluate.rkt + racket tests/test-browser-evaluate.rkt test-compiler: raco make -v --disable-inline tests/test-compiler.rkt diff --git a/js-assembler/assemble-helpers.rkt b/js-assembler/assemble-helpers.rkt index 9c3b163..513e63c 100644 --- a/js-assembler/assemble-helpers.rkt +++ b/js-assembler/assemble-helpers.rkt @@ -80,7 +80,7 @@ [(EnvPrefixReference? target) (assemble-prefix-reference target)] [(PrimitivesReference? target) - (format "MACHINE.primitives[~s]" (symbol->string (PrimitivesReference-name target)))] + (format "RUNTIME.Primitives[~s]" (symbol->string (PrimitivesReference-name target)))] [(ControlFrameTemporary? target) (assemble-control-frame-temporary target)] [(ModulePrefixTarget? target) diff --git a/js-assembler/mini-runtime.js b/js-assembler/mini-runtime.js index c8203cf..a2c39ab 100644 --- a/js-assembler/mini-runtime.js +++ b/js-assembler/mini-runtime.js @@ -1278,7 +1278,44 @@ + ////////////////////////////////////////////////////////////////////// + (function(scope) { + scope.ready = function(f) { + if (runtimeIsReady) { + notifyWaiter(f); + } else { + readyWaiters.push(f); + } + }; + scope.setReadyTrue = function() { + var i; + runtimeIsReady = true; + for (i = 0; i < readyWaiters.length; i++) { + notifyWaiter(readyWaiters[i]); + } + readyWaiters = []; + }; + + var runtimeIsReady = false; + var readyWaiters = []; + var notifyWaiter = function(w) { + setTimeout(w, 0); + }; + })(this); + ////////////////////////////////////////////////////////////////////// + + + + // Exports + exports['Primitives'] = Primitives; + + exports['ready'] = ready; + // Private: the runtime library will set this flag to true when + // the library has finished loading. + exports['setReadyTrue'] = setReadyTrue; + + exports['Machine'] = Machine; exports['Frame'] = Frame; exports['CallFrame'] = CallFrame; diff --git a/js-assembler/package.rkt b/js-assembler/package.rkt index e289a65..f9bb3a5 100644 --- a/js-assembler/package.rkt +++ b/js-assembler/package.rkt @@ -4,14 +4,16 @@ "quote-cdata.rkt" "../make.rkt" "../make-structs.rkt" - "get-runtime.rkt" + (prefix-in runtime: "get-runtime.rkt") (prefix-in racket: racket/base)) (provide package package-anonymous - package-standalone-xhtml) + package-standalone-xhtml + get-code + get-runtime) ;; Packager: produce single .js files to be included to execute a ;; program. Follows module dependencies. @@ -36,7 +38,7 @@ ;; indicates whether we should continue following module paths. ;; ;; The generated output defines a function called 'invoke' with -;; four arguments (MACHINE, SUCCESS, FAIL, PARAMS). When called, it'll +;; four arguments (MACHINE, SUCCESS, FAIL, PARAMS). When called, it will ;; execute the code to either run standalone expressions or ;; load in modules. (define (package source-code @@ -62,13 +64,15 @@ (fprintf op "var invoke = (function(MACHINE, SUCCESS, FAIL, PARAMS) {") - (make (cons only-bootstrapped-code - (list (make-MainModuleSource source-code))) + (fprintf op " plt.runtime.ready(function() {") + (make (list (make-MainModuleSource source-code)) packaging-configuration) + (fprintf op " });"); (fprintf op "});\n")) + ;; package-standalone-xhtml: X output-port -> void (define (package-standalone-xhtml source-code op) (display *header* op) @@ -78,6 +82,35 @@ +;; get-runtime: -> string +(define (get-runtime) + (let* ([buffer (open-output-string)] + [packaging-configuration + (make-Configuration + ;; should-follow? + (lambda (p) #t) + ;; on + (lambda (ast stmts) + (assemble/write-invoke stmts buffer) + (fprintf buffer "(MACHINE, function() { ")) + + ;; after + (lambda (ast stmts) + (fprintf buffer " }, FAIL, PARAMS);")) + + ;; last + (lambda () + (fprintf buffer "SUCCESS();")))]) + + (display (runtime:get-runtime) buffer) + + (fprintf buffer "(function(MACHINE, SUCCESS, FAIL, PARAMS) {") + (make (list only-bootstrapped-code) packaging-configuration) + (fprintf buffer "})(new plt.runtime.Machine(), function(){ plt.runtime.setReadyTrue(); }, function(){}, {});\n") + (get-output-string buffer))) + + + (define *header* #<string (car x))) @@ -78,6 +88,11 @@ (define (print-the-runtime) (display (get-runtime))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (get-javascript-code filename) + (display (get-code (make-ModuleSource (build-path filename))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; From 0bf99cde69b125beb41c08acc594f30e22b83e7b Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Mon, 30 May 2011 12:34:51 -0400 Subject: [PATCH 3/7] runtime should load first before any modules are evaluated. --- tests/test-assemble.rkt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/test-assemble.rkt b/tests/test-assemble.rkt index 69afaf7..5efb59a 100644 --- a/tests/test-assemble.rkt +++ b/tests/test-assemble.rkt @@ -2,7 +2,7 @@ (require "browser-evaluate.rkt" "../js-assembler/assemble.rkt" - "../js-assembler/get-runtime.rkt" + "../js-assembler/package.rkt" "../compiler/lexical-structs.rkt" "../compiler/il-structs.rkt" racket/port From ad04fd44250f5c6dfe93673aa646f9f82f363330 Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Mon, 30 May 2011 13:34:42 -0400 Subject: [PATCH 4/7] Systematizing exception throwing so they all go through plt.runtime.raiseX --- compiler/compiler.rkt | 10 ++--- compiler/il-structs.rkt | 3 +- js-assembler/assemble-open-coded.rkt | 4 +- js-assembler/assemble-perform-statement.rkt | 35 ++++++++++++--- js-assembler/mini-runtime.js | 50 +++++++++++++++++---- js-assembler/package.rkt | 4 +- 6 files changed, 82 insertions(+), 24 deletions(-) diff --git a/compiler/compiler.rkt b/compiler/compiler.rkt index 64858c9..b44eada 100644 --- a/compiler/compiler.rkt +++ b/compiler/compiler.rkt @@ -1320,11 +1320,11 @@ (length (App-operands exp))) empty-instruction-sequence] [else - (make-instruction-sequence - `(,(make-PerformStatement - (make-RaiseArityMismatchError! - (StaticallyKnownLam-arity static-knowledge) - (make-Const (length (App-operands exp)))))))])]) + (make-PerformStatement + (make-RaiseArityMismatchError! + (make-Reg 'proc) + (StaticallyKnownLam-arity static-knowledge) + (make-Const (length (App-operands exp)))))])]) (let* ([extended-cenv (extend-compile-time-environment/scratch-space cenv diff --git a/compiler/il-structs.rkt b/compiler/il-structs.rkt index ab95e62..6921bdc 100644 --- a/compiler/il-structs.rkt +++ b/compiler/il-structs.rkt @@ -383,7 +383,8 @@ ;; Raises an exception that says that we're doing a ;; procedure application, but got sent an incorrect number. -(define-struct: RaiseArityMismatchError! ([expected : Arity] +(define-struct: RaiseArityMismatchError! ([proc : OpArg] + [expected : Arity] [received : OpArg]) #:transparent) diff --git a/js-assembler/assemble-open-coded.rkt b/js-assembler/assemble-open-coded.rkt index 620fc25..df1a11e 100644 --- a/js-assembler/assemble-open-coded.rkt +++ b/js-assembler/assemble-open-coded.rkt @@ -137,12 +137,12 @@ [(box) (format "(typeof(~a) === 'object' && (~a).length === 1)" operand-string operand-string)])]) - (format "((~a) ? (~a) : RUNTIME.raise(MACHINE, new Error('~a: expected ' + ~s + ' as argument ' + ~s + ' but received ' + ~a)))" + (format "((~a) ? (~a) : RUNTIME.raiseArgumentTypeError(MACHINE, ~s, ~s, ~s, ~a))" test-string operand-string caller (symbol->string domain) - (add1 pos) + pos operand-string))])) diff --git a/js-assembler/assemble-perform-statement.rkt b/js-assembler/assemble-perform-statement.rkt index 1c98907..9334be9 100644 --- a/js-assembler/assemble-perform-statement.rkt +++ b/js-assembler/assemble-perform-statement.rkt @@ -14,18 +14,42 @@ (cond [(CheckToplevelBound!? op) - (format "if (MACHINE.env[MACHINE.env.length - 1 - ~a][~a] === undefined) { throw new Error(\"Not bound: \" + MACHINE.env[MACHINE.env.length - 1 - ~a].names[~a]); }" + (format "if (MACHINE.env[MACHINE.env.length - 1 - ~a][~a] === undefined) { RUNTIME.raiseUnboundToplevelError(MACHINE.env[MACHINE.env.length - 1 - ~a].names[~a]); }" (CheckToplevelBound!-depth op) (CheckToplevelBound!-pos op) (CheckToplevelBound!-depth op) (CheckToplevelBound!-pos op))] - + + + ;; FIXME: use raiseArityMismatchError [(CheckClosureArity!? op) - (format "if (! (MACHINE.proc instanceof RUNTIME.Closure && RUNTIME.isArityMatching(MACHINE.proc.arity, ~a))) { if (! (MACHINE.proc instanceof RUNTIME.Closure)) { throw new Error(\"not a closure\"); } else { throw new Error(\"arity failure:\" + MACHINE.proc.displayName); } }" + (format #< Date: Mon, 30 May 2011 16:10:42 -0400 Subject: [PATCH 5/7] Working on making it easy to run whalesong from the shell. whalesong.rkt now provides two additional commands: get-runtime: prints the runtime into standard output get-javascript: compiles the given program and writes to standard output --- compiler/il-structs.rkt | 9 +-- js-assembler/assemble-perform-statement.rkt | 9 +-- js-assembler/assemble.rkt | 10 +-- js-assembler/mini-runtime.js | 44 ++++++++++- js-assembler/package.rkt | 87 ++++++++++++++------- make.rkt | 5 +- simulator/simulator.rkt | 6 +- whalesong.rkt | 4 +- 8 files changed, 114 insertions(+), 60 deletions(-) diff --git a/compiler/il-structs.rkt b/compiler/il-structs.rkt index 6921bdc..e038cbb 100644 --- a/compiler/il-structs.rkt +++ b/compiler/il-structs.rkt @@ -425,10 +425,9 @@ #:transparent) -;; Give an alternative locator to the module. Assumes the module has -;; already been installed. -(define-struct: AliasModuleName! ([from : ModuleLocator] - [to : ModuleLocator]) +;; Give an alternative locator to the module as a main module. +;; Assumes the module has already been installed. +(define-struct: AliasModuleAsMain! ([from : ModuleLocator]) #:transparent) ;; Given the module locator, do any finalizing operations, like @@ -463,7 +462,7 @@ InstallModuleEntry! MarkModuleInvoked! - AliasModuleName! + AliasModuleAsMain! FinalizeModuleInvokation! )) diff --git a/js-assembler/assemble-perform-statement.rkt b/js-assembler/assemble-perform-statement.rkt index 9334be9..5c76afd 100644 --- a/js-assembler/assemble-perform-statement.rkt +++ b/js-assembler/assemble-perform-statement.rkt @@ -21,7 +21,6 @@ (CheckToplevelBound!-pos op))] - ;; FIXME: use raiseArityMismatchError [(CheckClosureArity!? op) (format #<string (ModuleLocator-name (MarkModuleInvoked!-path op))))] - [(AliasModuleName!? op) - (format "MACHINE.modules[~s] = MACHINE.modules[~s];" - (symbol->string (ModuleLocator-name (AliasModuleName!-to op))) - (symbol->string (ModuleLocator-name (AliasModuleName!-from op))))] + [(AliasModuleAsMain!? op) + (format "MACHINE.mainModules.push(MACHINE.modules[~s]);" + (symbol->string (ModuleLocator-name (AliasModuleAsMain!-from op))))] [(FinalizeModuleInvokation!? op) (format "MACHINE.modules[~s].finalizeModuleInvokation();" diff --git a/js-assembler/assemble.rkt b/js-assembler/assemble.rkt index 5c61cc0..fdfde55 100644 --- a/js-assembler/assemble.rkt +++ b/js-assembler/assemble.rkt @@ -12,8 +12,7 @@ racket/string racket/list) -(provide assemble/write-invoke-module-as-main - assemble/write-invoke +(provide assemble/write-invoke fracture assemble-basic-block assemble-statement) @@ -25,13 +24,6 @@ -(: assemble/write-invoke-module-as-main (Symbol Output-Port -> Void)) -(define (assemble/write-invoke-module-as-main module-name op) - ;; FIXME - (void)) - - - (: assemble/write-invoke ((Listof Statement) Output-Port -> Void)) ;; Writes out the JavaScript code that represents the anonymous invocation expression. ;; What's emitted is a function expression that, when invoked, runs the diff --git a/js-assembler/mini-runtime.js b/js-assembler/mini-runtime.js index 69f9e51..cdf9d6d 100644 --- a/js-assembler/mini-runtime.js +++ b/js-assembler/mini-runtime.js @@ -65,6 +65,7 @@ this.control = []; // Arrayof (U Frame CallFrame PromptFrame) this.running = false; this.modules = {}; // String -> ModuleRecord + this.mainModules = []; // Arrayof String this.params = { // currentDisplayer: DomNode -> Void @@ -139,6 +140,10 @@ // External invokation of a module. ModuleRecord.prototype.invoke = function(MACHINE, succ, fail) { + MACHINE = MACHINE || plt.runtime.currentMachine; + succ = succ || function(){}; + fail = fail || function(){}; + var oldErrorHandler = MACHINE.params['currentErrorHandler']; var afterGoodInvoke = function(MACHINE) { MACHINE.params['currentErrorHandler'] = oldErrorHandler; @@ -1305,6 +1310,9 @@ ////////////////////////////////////////////////////////////////////// + ////////////////////////////////////////////////////////////////////// + ////////////////////////////////////////////////////////////////////// + (function(scope) { scope.ready = function(f) { if (runtimeIsReady) { @@ -1328,14 +1336,44 @@ setTimeout(w, 0); }; })(this); + + ////////////////////////////////////////////////////////////////////// + ////////////////////////////////////////////////////////////////////// + ////////////////////////////////////////////////////////////////////// + + // Executes all programs that have been labeled as a main module + var invokeMains = function(machine, succ, fail) { + plt.runtime.ready(function() { + machine = machine || plt.runtime.currentMachine; + succ = succ || function() {}; + fail = fail || function() {}; + var mainModules = machine.mainModules.slice(); + var loop = function() { + if (mainModules.length > 0) { + var nextModule = mainModules.shift(); + nextModule.invoke(machine, loop, fail); + } else { + succ(); + } + }; + setTimeout(loop, 0); + }); + }; + + + + ////////////////////////////////////////////////////////////////////// + ////////////////////////////////////////////////////////////////////// ////////////////////////////////////////////////////////////////////// - - // Exports - exports['Primitives'] = Primitives; + + exports['currentMachine'] = new Machine(); + exports['invokeMains'] = invokeMains; + exports['Primitives'] = Primitives; + exports['ready'] = ready; // Private: the runtime library will set this flag to true when // the library has finished loading. diff --git a/js-assembler/package.rkt b/js-assembler/package.rkt index a64993c..f88e4fb 100644 --- a/js-assembler/package.rkt +++ b/js-assembler/package.rkt @@ -12,11 +12,14 @@ (provide package package-anonymous package-standalone-xhtml - get-code - get-runtime) + get-standalone-code + write-standalone-code + get-runtime + write-runtime) + ;; Packager: produce single .js files to be included to execute a -;; program. Follows module dependencies. +;; program. @@ -84,34 +87,41 @@ ;; get-runtime: -> string (define (get-runtime) - (let* ([buffer (open-output-string)] - [packaging-configuration - (make-Configuration - ;; should-follow? - (lambda (p) #t) - ;; on - (lambda (ast stmts) - (assemble/write-invoke stmts buffer) - (fprintf buffer "(MACHINE, function() { ")) - - ;; after - (lambda (ast stmts) - (fprintf buffer " }, FAIL, PARAMS);")) - - ;; last - (lambda () - (fprintf buffer "SUCCESS();")))]) - - (display (runtime:get-runtime) buffer) - (newline buffer) - (fprintf buffer "(function(MACHINE, SUCCESS, FAIL, PARAMS) {") - (make (list only-bootstrapped-code) packaging-configuration) - (fprintf buffer "})(new plt.runtime.Machine(),\nfunction(){ plt.runtime.setReadyTrue(); },\nfunction(){},\n{});\n") + (let ([buffer (open-output-string)]) + (write-runtime buffer) (get-output-string buffer))) +;; write-runtime: output-port -> void +(define (write-runtime op) + (let ([packaging-configuration + (make-Configuration + ;; should-follow? + (lambda (p) #t) + ;; on + (lambda (ast stmts) + (assemble/write-invoke stmts op) + (fprintf op "(MACHINE, function() { ")) + + ;; after + (lambda (ast stmts) + (fprintf op " }, FAIL, PARAMS);")) + + ;; last + (lambda () + (fprintf op "SUCCESS();")))]) + + (display (runtime:get-runtime) op) + (newline op) + (fprintf op "(function(MACHINE, SUCCESS, FAIL, PARAMS) {") + (make (list only-bootstrapped-code) packaging-configuration) + (fprintf op "})(plt.runtime.currentMachine,\nfunction(){ plt.runtime.setReadyTrue(); },\nfunction(){},\n{});\n"))) + + + +;; *header* : string (define *header* #< @@ -126,6 +136,7 @@ EOF ) +;; get-code: source -> string (define (get-code source-code) (let ([buffer (open-output-string)]) (package source-code @@ -134,15 +145,33 @@ EOF (get-output-string buffer))) + +;; get-standalone-code: source -> string +(define (get-standalone-code source-code) + (let ([buffer (open-output-string)]) + (write-standalone-code source-code buffer) + (get-output-string buffer))) + + +;; write-standalone-code: source output-port -> void +(define (write-standalone-code source-code op) + (package-anonymous source-code + #:should-follow? (lambda (p) #t) + #:output-port op) + (fprintf op "()(plt.runtime.currentMachine, function() {}, function() {}, {});\n")) + + + + (define *footer* #< Date: Tue, 31 May 2011 15:18:22 -0400 Subject: [PATCH 6/7] re-enabling some optimizations --- NOTES | 14 +++++++++++++- compiler/analyzer-structs.rkt | 3 ++- compiler/compiler.rkt | 28 ++++++++++++++++------------ compiler/optimize-il.rkt | 4 ++-- js-assembler/assemble-open-coded.rkt | 2 +- lang/kernel.rkt | 28 ++++++++++++++-------------- 6 files changed, 48 insertions(+), 31 deletions(-) diff --git a/NOTES b/NOTES index fdf36fe..517ca3c 100644 --- a/NOTES +++ b/NOTES @@ -583,4 +583,16 @@ What's currently preventing racket/base? Nan, INF Numbers, Regular expressions, keywords, byte strings, character literals -Missing #%paramz module \ No newline at end of file +Missing #%paramz module + + +---------------------------------------------------------------------- + + +What needs to be done next? + +benchmarks + +being able to write modules in javascript + +being able to bundle external resources (like images) \ No newline at end of file diff --git a/compiler/analyzer-structs.rkt b/compiler/analyzer-structs.rkt index 1c63d5a..66ab6e5 100644 --- a/compiler/analyzer-structs.rkt +++ b/compiler/analyzer-structs.rkt @@ -22,7 +22,8 @@ (U '? ;; no knowledge Prefix ;; placeholder: necessary since the toplevel lives in the environment too StaticallyKnownLam ;; The value is a known lam - ModuleVariable ;; The value is a known module variable + ModuleVariable ;; The value is a variable from a module + PrimitiveKernelValue Const )) diff --git a/compiler/compiler.rkt b/compiler/compiler.rkt index b44eada..867e639 100644 --- a/compiler/compiler.rkt +++ b/compiler/compiler.rkt @@ -7,7 +7,7 @@ "kernel-primitives.rkt" "optimize-il.rkt" "analyzer-structs.rkt" - "analyzer.rkt" + #;"analyzer.rkt" "../parameters.rkt" "../sets.rkt" racket/match @@ -20,8 +20,8 @@ -(: current-analysis (Parameterof Analysis)) -(define current-analysis (make-parameter (empty-analysis))) +#;(: current-analysis (Parameterof Analysis)) +#;(define current-analysis (make-parameter (empty-analysis))) @@ -30,7 +30,7 @@ ;; Note: the toplevel generates the lambda body streams at the head, and then the ;; rest of the instruction stream. (define (-compile exp target linkage) - (parameterize ([current-analysis (analyze exp)]) + (parameterize (#;[current-analysis (analyze exp)]) (let* ([after-lam-bodies (make-label 'afterLamBodies)] [before-pop-prompt-multiple (make-label 'beforePopPromptMultiple)] [before-pop-prompt (make-LinkedLabel @@ -60,6 +60,7 @@ (make-instruction-sequence `(,(make-AssignImmediateStatement target (make-Reg 'val))))))))))) + (define-struct: lam+cenv ([lam : (U Lam CaseLam)] [cenv : CompileTimeEnvironment])) @@ -338,12 +339,10 @@ (make-PerformStatement (make-MarkModuleInvoked! path)) ;; Module body definition: ;; 1. First invoke all the modules that this requires. - #;(make-DebugPrint (make-Const "handling internal requires")) (apply append-instruction-sequences (map compile-module-invoke (Module-requires mod))) ;; 2. Next, evaluate the module body. - #;(make-DebugPrint (make-Const (format "evaluating module body of ~s" path))) (make-PerformStatement (make-ExtendEnvironment/Prefix! names)) (make-AssignImmediateStatement (make-ModulePrefixTarget path) @@ -354,14 +353,11 @@ 'val next-linkage/drop-multiple) - #;(make-DebugPrint (make-Const (format "About to clean up ~s" path))) - ;; 3. Finally, cleanup and return. (make-PopEnvironment (make-Const 1) (make-Const 0)) (make-AssignImmediateStatement 'proc (make-ControlStackLabel)) (make-PopControlFrame) - #;(make-DebugPrint (make-Const "Returning from module invokation.")) - #;(make-DebugPrint (make-Reg 'proc)) + (make-PerformStatement (make-FinalizeModuleInvokation! path)) (make-GotoStatement (make-Reg 'proc)) @@ -405,7 +401,6 @@ ,(make-TestAndBranchStatement (make-TestTrue (make-IsModuleInvoked a-module-name)) already-loaded) - #;,(make-DebugPrint (make-Const (format "entering module ~s" a-module-name))) ,(make-PushControlFrame/Call on-return) ,(make-GotoStatement (ModuleEntry a-module-name)) ,on-return-multiple @@ -413,7 +408,6 @@ (make-Const 1)) (make-Const 0)) ,on-return - #;,(make-DebugPrint (make-Const (format "coming back from module ~s" a-module-name))) ,already-loaded)))])) @@ -994,6 +988,13 @@ (cond [(eq? op-knowledge '?) (default)] + [(PrimitiveKernelValue? op-knowledge) + (let ([id (PrimitiveKernelValue-id op-knowledge)]) + (cond + [(KernelPrimitiveName/Inline? id) + (compile-kernel-primitive-application id exp cenv target linkage)] + [else + (default)]))] [(ModuleVariable? op-knowledge) (cond [(symbol=? (ModuleLocator-name @@ -1689,6 +1690,9 @@ [(Constant? exp) (make-Const (Constant-v exp))] + + [(PrimitiveKernelValue? exp) + exp] [else '?])) diff --git a/compiler/optimize-il.rkt b/compiler/optimize-il.rkt index 6cf02bc..c7cf732 100644 --- a/compiler/optimize-il.rkt +++ b/compiler/optimize-il.rkt @@ -14,10 +14,10 @@ (: optimize-il ((Listof Statement) -> (Listof Statement))) (define (optimize-il statements) - statements + #;statements ;; For now, replace pairs of PushEnvironment / AssignImmediate(0, ...) ;; We should do some more optimizations here, like peephole... - #;(let loop ([statements (filter not-no-op? statements)]) + (let loop ([statements (filter not-no-op? statements)]) (cond [(empty? statements) empty] diff --git a/js-assembler/assemble-open-coded.rkt b/js-assembler/assemble-open-coded.rkt index df1a11e..8c13742 100644 --- a/js-assembler/assemble-open-coded.rkt +++ b/js-assembler/assemble-open-coded.rkt @@ -140,7 +140,7 @@ (format "((~a) ? (~a) : RUNTIME.raiseArgumentTypeError(MACHINE, ~s, ~s, ~s, ~a))" test-string operand-string - caller + (symbol->string caller) (symbol->string domain) pos operand-string))])) diff --git a/lang/kernel.rkt b/lang/kernel.rkt index a6766d8..91f5f11 100644 --- a/lang/kernel.rkt +++ b/lang/kernel.rkt @@ -235,7 +235,7 @@ ;; number->string ;; string->number ;; procedure? -;; pair? + pair? ;; (undefined? -undefined?) ;; immutable? ;; void? @@ -263,7 +263,7 @@ ;; box? ;; hash? ;; eqv? -;; equal? + equal? ;; caar ;; cadr ;; cdar @@ -277,20 +277,20 @@ ;; caddr ;; cdddr ;; cadddr -;; length + length ;; list? ;; list* ;; list-ref ;; list-tail -;; append -;; reverse + append + reverse ;; for-each -;; map + map ;; andmap ;; ormap ;; memq ;; memv -;; member + member ;; memf ;; assq ;; assv @@ -354,13 +354,13 @@ ;; bytes=? ;; bytes? -;; make-vector -;; vector -;; vector-length -;; vector-ref -;; vector-set! -;; vector->list -;; list->vector + make-vector + vector + vector-length + vector-ref + vector-set! + vector->list + list->vector ;; build-vector ;; char=? ;; char Date: Wed, 1 Jun 2011 11:43:36 -0400 Subject: [PATCH 7/7] trying to clean up requires in prepwork --- compiler/analyzer.rkt | 401 ------------------------------------------ get-dependencies.rkt | 3 +- make-structs.rkt | 12 +- make.rkt | 1 - whalesong.rkt | 2 - 5 files changed, 3 insertions(+), 416 deletions(-) delete mode 100644 compiler/analyzer.rkt diff --git a/compiler/analyzer.rkt b/compiler/analyzer.rkt deleted file mode 100644 index cb81da9..0000000 --- a/compiler/analyzer.rkt +++ /dev/null @@ -1,401 +0,0 @@ -#lang typed/racket/base - -(provide (rename-out [-analyze analyze]) - analysis-lookup - analysis-alias!) - -(require "analyzer-structs.rkt" - "expression-structs.rkt" - "il-structs.rkt" - "lexical-structs.rkt" - racket/match - racket/list) - - - - -(: current-expression-map - (Parameterof (HashTable Expression CompileTimeEnvironmentEntry))) -(define current-expression-map (make-parameter - ((inst make-hasheq Expression - CompileTimeEnvironmentEntry)))) - - - - -(: -analyze (Expression -> Analysis)) -(define (-analyze exp) - (parameterize ([current-expression-map - ((inst make-hasheq Expression CompileTimeEnvironmentEntry))]) - (analyze exp '()) - (make-Analysis (current-expression-map)))) - - - - - - - -(: analyze (Expression CompileTimeEnvironment -> 'ok)) -;; Finds all the lambdas in the expression. -(define (analyze exp cenv) - (cond - [(Top? exp) - (analyze-Top exp cenv)] - [(Module? exp) - (analyze-Module exp cenv)] - [(Constant? exp) - (analyze-Constant exp cenv)] - [(LocalRef? exp) - (analyze-LocalRef exp cenv)] - [(ToplevelRef? exp) - (analyze-ToplevelRef exp cenv)] - [(ToplevelSet? exp) - (analyze-ToplevelSet exp cenv)] - [(Branch? exp) - (analyze-Branch exp cenv)] - [(Lam? exp) - (analyze-Lam exp cenv)] - [(CaseLam? exp) - (analyze-CaseLam exp cenv)] - [(EmptyClosureReference? exp) - (analyze-EmptyClosureReference exp cenv)] - [(Seq? exp) - (analyze-Seq exp cenv)] - [(Splice? exp) - (analyze-Splice exp cenv)] - [(Begin0? exp) - (analyze-Begin0 exp cenv)] - [(App? exp) - (analyze-App exp cenv)] - [(Let1? exp) - (analyze-Let1 exp cenv)] - [(LetVoid? exp) - (analyze-LetVoid exp cenv)] - [(InstallValue? exp) - (analyze-InstallValue exp cenv)] - [(BoxEnv? exp) - (analyze-BoxEnv exp cenv)] - [(LetRec? exp) - (analyze-LetRec exp cenv)] - [(WithContMark? exp) - (analyze-WithContMark exp cenv)] - [(ApplyValues? exp) - (analyze-ApplyValues exp cenv)] - [(DefValues? exp) - (analyze-DefValues exp cenv)] - [(PrimitiveKernelValue? exp) - (analyze-PrimitiveKernelValue exp cenv)] - [(VariableReference? exp) - (analyze-VariableReference exp cenv)] - [(Require? exp) - (analyze-Require exp cenv)])) - - - - -(: analyze-Top (Top CompileTimeEnvironment -> 'ok)) -(define (analyze-Top exp cenv) - (match exp - [(struct Top (prefix code)) - (analyze code (list prefix))])) - - -(: analyze-Module (Module CompileTimeEnvironment -> 'ok)) -(define (analyze-Module exp cenv) - (match exp - [(struct Module (name path prefix requires code)) - (analyze code (list prefix))])) - - -(: analyze-Constant (Constant CompileTimeEnvironment -> 'ok)) -(define (analyze-Constant exp cenv) - 'ok) - - -(: analyze-LocalRef (LocalRef CompileTimeEnvironment -> 'ok)) -(define (analyze-LocalRef exp cenv) - (annotate exp (extract-static-knowledge exp cenv)) - 'ok) - - -(: analyze-ToplevelRef (ToplevelRef CompileTimeEnvironment -> 'ok)) -(define (analyze-ToplevelRef exp cenv) - (annotate exp (extract-static-knowledge exp cenv)) - 'ok) - - -(: analyze-ToplevelSet (ToplevelSet CompileTimeEnvironment -> 'ok)) -(define (analyze-ToplevelSet exp cenv) - (match exp - [(struct ToplevelSet (depth pos value)) - (analyze value cenv)])) - - -(: analyze-Branch (Branch CompileTimeEnvironment -> 'ok)) -(define (analyze-Branch exp cenv) - (match exp - [(struct Branch (test cons alter)) - (analyze test cenv) - (analyze cons cenv) - (analyze alter cenv)])) - - -(: analyze-Lam (Lam CompileTimeEnvironment -> 'ok)) -(define (analyze-Lam exp cenv) - (match exp - [(struct Lam (name num-parameters rest? body closure-map entry-label)) - (analyze body (extract-lambda-body-cenv exp cenv))])) - - - -(: extract-lambda-body-cenv (Lam CompileTimeEnvironment -> CompileTimeEnvironment)) -;; Given a Lam and the ambient environment, produces the compile time environment for the -;; body of the lambda. -(define (extract-lambda-body-cenv lam cenv) - (append (map (lambda: ([d : Natural]) - (list-ref cenv d)) - (Lam-closure-map lam)) - (build-list (if (Lam-rest? lam) - (add1 (Lam-num-parameters lam)) - (Lam-num-parameters lam)) - (lambda: ([i : Natural]) '?)))) - - - -(: analyze-CaseLam (CaseLam CompileTimeEnvironment -> 'ok)) -(define (analyze-CaseLam exp cenv) - (match exp - [(struct CaseLam (name clauses entry-label)) - (for-each (lambda: ([c : Expression]) - (analyze c cenv)) - clauses) - 'ok])) - - -(: analyze-EmptyClosureReference (EmptyClosureReference CompileTimeEnvironment -> 'ok)) -(define (analyze-EmptyClosureReference exp cenv) - 'ok) - -(: analyze-Seq (Seq CompileTimeEnvironment -> 'ok)) -(define (analyze-Seq exp cenv) - (match exp - [(struct Seq (actions)) - (for-each (lambda: ([e : Expression]) - (analyze e cenv)) - actions) - 'ok])) - -(: analyze-Splice (Splice CompileTimeEnvironment -> 'ok)) -(define (analyze-Splice exp cenv) - (match exp - [(struct Splice (actions)) - (for-each (lambda: ([e : Expression]) - (analyze e cenv)) - actions) - 'ok])) - -(: analyze-Begin0 (Begin0 CompileTimeEnvironment -> 'ok)) -(define (analyze-Begin0 exp cenv) - (match exp - [(struct Begin0 (actions)) - (for-each (lambda: ([e : Expression]) - (analyze e cenv)) - actions) - 'ok])) - -(: analyze-App (App CompileTimeEnvironment -> 'ok)) -(define (analyze-App exp cenv) - (match exp - [(struct App (operator operands)) - (let ([extended-cenv (extend/unknowns cenv (length operands))]) - (analyze operator extended-cenv) - (for-each (lambda: ([o : Expression]) - (analyze o extended-cenv)) - operands) - 'ok)])) - -(: analyze-Let1 (Let1 CompileTimeEnvironment -> 'ok)) -(define (analyze-Let1 exp cenv) - (match exp - [(struct Let1 (rhs body)) - (analyze rhs - (extend/unknowns cenv 1)) - (analyze body - (cons (extract-static-knowledge - rhs - (extend/unknowns cenv 1)) - cenv))])) - -(: analyze-LetVoid (LetVoid CompileTimeEnvironment -> 'ok)) -(define (analyze-LetVoid exp cenv) - (match exp - [(struct LetVoid (count body boxes?)) - (analyze body (extend/unknowns cenv count))])) - - -(: analyze-InstallValue (InstallValue CompileTimeEnvironment -> 'ok)) -(define (analyze-InstallValue exp cenv) - (match exp - [(struct InstallValue (count depth body box?)) - (analyze body cenv)])) - - -(: analyze-BoxEnv (BoxEnv CompileTimeEnvironment -> 'ok)) -(define (analyze-BoxEnv exp cenv) - (match exp - [(struct BoxEnv (depth body)) - (analyze body cenv)])) - - -(: analyze-LetRec (LetRec CompileTimeEnvironment -> 'ok)) -(define (analyze-LetRec exp cenv) - (match exp - [(struct LetRec (procs body)) - (let* ([n (length procs)] - [extended-cenv - (append (map (lambda: ([p : Expression]) - (extract-static-knowledge p cenv)) - procs) - (drop cenv n))]) - (for-each (lambda: ([p : Expression]) - (analyze p extended-cenv)) - procs) - (analyze body extended-cenv))])) - - -(: analyze-WithContMark (WithContMark CompileTimeEnvironment -> 'ok)) -(define (analyze-WithContMark exp cenv) - (match exp - [(struct WithContMark (key value body)) - (analyze key cenv) - (analyze value cenv) - (analyze body cenv)])) - -(: analyze-ApplyValues (ApplyValues CompileTimeEnvironment -> 'ok)) -(define (analyze-ApplyValues exp cenv) - (match exp - [(struct ApplyValues (proc args-expr)) - (analyze args-expr cenv) - (analyze proc cenv)])) - - -(: analyze-DefValues (DefValues CompileTimeEnvironment -> 'ok)) -(define (analyze-DefValues exp cenv) - (match exp - [(struct DefValues (ids rhs)) - (analyze rhs cenv)])) - - -(: analyze-PrimitiveKernelValue (PrimitiveKernelValue CompileTimeEnvironment -> 'ok)) -(define (analyze-PrimitiveKernelValue exp cenv) - 'ok) - -(: analyze-VariableReference (VariableReference CompileTimeEnvironment -> 'ok)) -(define (analyze-VariableReference exp cenv) - 'ok) - -(: analyze-Require (Require CompileTimeEnvironment -> 'ok)) -(define (analyze-Require exp cenv) - 'ok) - - - - -(: annotate (Expression CompileTimeEnvironmentEntry -> 'ok)) -;; Accumulate information about an expression into the map. -(define (annotate exp info) - (let ([my-map (current-expression-map)]) - (hash-set! my-map exp info) - 'ok)) - - - - -(: extend/unknowns - (CompileTimeEnvironment Natural -> CompileTimeEnvironment)) -(define (extend/unknowns cenv n) - (append (build-list n (lambda: ([i : Natural]) - '?)) - cenv)) - - - - -(: extract-static-knowledge (Expression CompileTimeEnvironment -> - CompileTimeEnvironmentEntry)) -;; Statically determines what we know about the expression, given the compile time environment. -;; We should do more here eventually, including things like type inference or flow analysis, so that -;; we can generate better code. -(define (extract-static-knowledge exp cenv) - (cond - [(Lam? exp) - (make-StaticallyKnownLam (Lam-name exp) - (Lam-entry-label exp) - (if (Lam-rest? exp) - (make-ArityAtLeast (Lam-num-parameters exp)) - (Lam-num-parameters exp)))] - - [(and (LocalRef? exp) (not (LocalRef-unbox? exp))) - (let ([entry (list-ref cenv (LocalRef-depth exp))]) - entry)] - - [(ToplevelRef? exp) - (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 - '?]))] - - [(Constant? exp) - (make-Const (Constant-v exp))] - - [else - '?])) - - - - -(: analysis-lookup (Analysis Expression -> CompileTimeEnvironmentEntry)) -(define (analysis-lookup an-analysis an-exp) - (cond - [(Lam? exp) - (make-StaticallyKnownLam (Lam-name exp) - (Lam-entry-label exp) - (if (Lam-rest? exp) - (make-ArityAtLeast (Lam-num-parameters exp)) - (Lam-num-parameters exp)))] - - [(and (LocalRef? exp) (not (LocalRef-unbox? exp))) - (hash-ref (Analysis-ht an-analysis) an-exp '?)] - - - [(ToplevelRef? exp) - (hash-ref (Analysis-ht an-analysis) an-exp '?)] - - [(Constant? exp) - (make-Const (Constant-v exp))] - - [else - '?])) - - -(: analysis-alias! (Analysis Expression Expression -> Void)) -(define (analysis-alias! an-analysis from to) - (hash-set! (Analysis-ht an-analysis) to - (analysis-lookup an-analysis from))) - - - -(: ensure-prefix (Any -> Prefix)) -(define (ensure-prefix x) - (if (Prefix? x) - x - (error 'ensure-prefix "Not a prefix: ~e" x))) \ No newline at end of file diff --git a/get-dependencies.rkt b/get-dependencies.rkt index ec0b39b..7483948 100644 --- a/get-dependencies.rkt +++ b/get-dependencies.rkt @@ -1,8 +1,7 @@ #lang typed/racket/base (require "compiler/expression-structs.rkt" "compiler/lexical-structs.rkt" - "sets.rkt" - racket/match) + "sets.rkt") ;; Collect the complete list of dependencies for a module. diff --git a/make-structs.rkt b/make-structs.rkt index 90ec2d5..a514a31 100644 --- a/make-structs.rkt +++ b/make-structs.rkt @@ -1,17 +1,9 @@ #lang typed/racket/base -(require "compiler/compiler.rkt" - "compiler/il-structs.rkt" - "compiler/lexical-structs.rkt" +(require "compiler/il-structs.rkt" "compiler/bootstrapped-primitives.rkt" - "compiler/compiler-structs.rkt" "compiler/expression-structs.rkt" - - "get-dependencies.rkt" - "parameters.rkt" - "sets.rkt" - racket/list - racket/match) + "get-dependencies.rkt") diff --git a/make.rkt b/make.rkt index d71f6e1..2dbb0e7 100644 --- a/make.rkt +++ b/make.rkt @@ -3,7 +3,6 @@ (require "compiler/compiler.rkt" "compiler/il-structs.rkt" "compiler/lexical-structs.rkt" - "compiler/bootstrapped-primitives.rkt" "compiler/compiler-structs.rkt" "compiler/expression-structs.rkt" "get-dependencies.rkt" diff --git a/whalesong.rkt b/whalesong.rkt index 1daa7d3..b405ca2 100755 --- a/whalesong.rkt +++ b/whalesong.rkt @@ -2,9 +2,7 @@ #lang racket/base (require racket/list - racket/match racket/string - racket/path "make-structs.rkt" "js-assembler/package.rkt")