diff --git a/compiler/il-structs.rkt b/compiler/il-structs.rkt index 3265be2..7fc7f27 100644 --- a/compiler/il-structs.rkt +++ b/compiler/il-structs.rkt @@ -154,6 +154,8 @@ ;; instruction sequences (define-type UnlabeledStatement (U StraightLineStatement BranchingStatement)) +(define-predicate UnlabeledStatement? UnlabeledStatement) + ;; Debug print statement. (define-struct: DebugPrint ([value : OpArg]) @@ -483,7 +485,7 @@ (define-type InstructionSequence (U Symbol LinkedLabel - Statement + UnlabeledStatement instruction-sequence-list instruction-sequence-chunks)) (define-struct: instruction-sequence-list ([statements : (Listof Statement)]) @@ -498,16 +500,29 @@ (: statements (InstructionSequence -> (Listof Statement))) (define (statements s) - (cond [(symbol? s) - (list s)] - [(LinkedLabel? s) - (list s)] - [(Statement? s) - (list s)] - [(instruction-sequence-list? s) - (instruction-sequence-list-statements s)] - [(instruction-sequence-chunks? s) - (apply append (map statements (instruction-sequence-chunks-chunks s)))])) + (reverse (statements-fold (inst cons Statement (Listof Statement)) + '() s))) + + +(: statements-fold (All (A) ((Statement A -> A) A InstructionSequence -> A))) +(define (statements-fold f acc seq) + (cond + [(symbol? seq) + (f seq acc)] + [(LinkedLabel? seq) + (f seq acc)] + [(UnlabeledStatement? seq) + (f seq acc)] + [(instruction-sequence-list? seq) + (foldl f acc (instruction-sequence-list-statements seq))] + [(instruction-sequence-chunks? seq) + (foldl (lambda: ([subseq : InstructionSequence] [acc : A]) + (statements-fold f acc subseq)) + acc + (instruction-sequence-chunks-chunks seq))])) + + + diff --git a/tests/browser-harness.rkt b/tests/browser-harness.rkt index bf3172b..5c2af8c 100644 --- a/tests/browser-harness.rkt +++ b/tests/browser-harness.rkt @@ -50,6 +50,13 @@ EOF ))) +;; Flatten the paths out. +(define (strip-paths s) + (regexp-replace* #px"#]+>" + s + "")) + + ;; We use a customized error structure that supports ;; source location reporting. @@ -70,7 +77,8 @@ EOF [src-path source-file-path] [result (evaluate (make-MainModuleSource (make-ModuleSource src-path)))] [output (evaluated-stdout result)]) - (cond [(string=? output exp) + (cond [(string=? (strip-paths output) + (strip-paths exp)) (printf " ok (~a milliseconds)\n" (evaluated-t result))] [else (printf " error!\n") diff --git a/whalesong.rkt b/whalesong.rkt index 94a5c4d..2062a2b 100755 --- a/whalesong.rkt +++ b/whalesong.rkt @@ -3,7 +3,9 @@ (require "private/command.rkt" "parameters.rkt" - "whalesong-helpers.rkt") + "whalesong-helpers.rkt" + profile + (for-syntax racket/base)) ;; Command line for running Whalesong. @@ -30,6 +32,15 @@ ;; $ whalesong get-javascript main-module-name.rkt (define as-standalone-html? (make-parameter #f)) +(define with-profiling? (make-parameter #f)) + +(define-syntax (maybe-with-profiling stx) + (syntax-case stx () + [(_ expr) + (syntax/loc stx + (if (with-profiling?) + (profile expr) + expr))])) (define (at-toplevel) @@ -46,6 +57,9 @@ [("--debug-show-timings") ("Display debug messages about compilation time.") (current-timing-port (current-output-port))] + [("--enable-profiling") + ("Enable profiling to standard output") + (with-profiling? #t)] [("--compress-javascript") ("Compress JavaScript with Google Closure (requires Java)") (current-compress-javascript? #t)] @@ -58,9 +72,10 @@ (as-standalone-html? #t)] #:args (path) - (if (as-standalone-html?) - (build-standalone-xhtml path) - (build-html-and-javascript path))] + (maybe-with-profiling + (if (as-standalone-html?) + (build-standalone-xhtml path) + (build-html-and-javascript path)))] ["get-runtime" "print the runtime library to standard output" "Prints the runtime JavaScript library that's used by Whalesong programs." @@ -71,12 +86,16 @@ [("--debug-show-timings") ("Display debug messages about compilation time.") (current-timing-port (current-output-port))] + [("--enable-profiling") + ("Enable profiling to standard output") + (with-profiling? #t)] [("--compress-javascript") ("Compress JavaScript with Google Closure (requires Java)") (current-compress-javascript? #t)] #:args () - (print-the-runtime)] + (maybe-with-profiling + (print-the-runtime))] ["get-javascript" "Gets just the JavaScript code and prints it to standard output" "Builds a racket program into JavaScript. The outputted file depends on the runtime." #:once-each @@ -86,13 +105,17 @@ [("--debug-show-timings") ("Display debug messages about compilation time.") (current-timing-port (current-output-port))] + [("--enable-profiling") + ("Enable profiling to standard output") + (with-profiling? #t)] [("--compress-javascript") ("Compress JavaScript with Google Closure (requires Java)") (current-compress-javascript? #t)] #:args (file) - (get-javascript-code file)])) + (maybe-with-profiling + (get-javascript-code file))])) (at-toplevel)