trying to work on statements

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))]))
+
+            
+
 
 
 

tests/browser-harness.rkt

@@ -50,6 +50,13 @@ EOF
                     )))
 
 
+;; Flatten the paths out.
+(define (strip-paths s)
+  (regexp-replace* #px"#<path:[^>]+>"
+                   s
+                   "<path:...>"))
+
+                  
 
 ;; 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")

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)