Wire up `guild compile -O0 foo.scm'

* module/scripts/compile.scm (%options): Resurrect -O option and make it
  follow GCC, more or less.  The default is equivalent to -O2.

* module/language/cps/compile-bytecode.scm (lower-cps):
* module/language/cps/optimize.scm (optimize-higher-order-cps): Move
  split-rec to run unconditionally for now, as closure conversion fails
  without it.
  (define-optimizer): Only verify the result if we are debugging, to
  save time.
  (cps-default-optimization-options): New exported procedure.

* module/language/tree-il/optimize.scm
  (tree-il-default-optimization-options): New exported procedure.

4 files changed, 105 insertions, 15 deletions

diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm
index 5b0c32990..86c9d307d 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -34,6 +34,7 @@
   #:use-module (language cps optimize)
   #:use-module (language cps reify-primitives)
   #:use-module (language cps renumber)
+  #:use-module (language cps split-rec)
   #:use-module (language cps intmap)
   #:use-module (language cps intset)
   #:use-module (system vm assembler)
@@ -513,6 +514,11 @@
             env)))
 
 (define (lower-cps exp opts)
+  ;; FIXME: For now the closure conversion pass relies on $rec instances
+  ;; being separated into SCCs.  We should fix this to not be the case,
+  ;; and instead move the split-rec pass back to
+  ;; optimize-higher-order-cps.
+  (set! exp (split-rec exp))
   (set! exp (optimize-higher-order-cps exp opts))
   (set! exp (convert-closures exp))
   (set! exp (optimize-first-order-cps exp opts))
diff --git a/module/language/cps/optimize.scm b/module/language/cps/optimize.scm
index c6576fc4a..8777222c9 100644
--- a/module/language/cps/optimize.scm
+++ b/module/language/cps/optimize.scm
@@ -37,11 +37,11 @@
   #:use-module (language cps self-references)
   #:use-module (language cps simplify)
   #:use-module (language cps specialize-primcalls)
-  #:use-module (language cps split-rec)
   #:use-module (language cps type-fold)
   #:use-module (language cps verify)
   #:export (optimize-higher-order-cps
-            optimize-first-order-cps))
+            optimize-first-order-cps
+            cps-default-optimization-options))
 
 (define (kw-arg-ref args kw default)
   (match (memq kw args)
@@ -75,8 +75,7 @@
           (maybe-verify (pass program))
           program))
     ...
-    (verify program)
-    program))
+    (maybe-verify program)))
 
 ;; Passes that are needed:
 ;;
@@ -84,7 +83,11 @@
 ;;    calls, and eliding prompts if possible.
 ;;
 (define-optimizer optimize-higher-order-cps
-  (split-rec #:split-rec? #t)
+  ;; FIXME: split-rec call temporarily moved to compile-bytecode and run
+  ;; unconditionally, because closure conversion requires it.  Move the
+  ;; pass back here when that's fixed.
+  ;;
+  ;; (split-rec #:split-rec? #t)
   (eliminate-dead-code #:eliminate-dead-code? #t)
   (prune-top-level-scopes #:prune-top-level-scopes? #t)
   (simplify #:simplify? #t)
@@ -106,3 +109,19 @@
   (eliminate-dead-code #:eliminate-dead-code? #t)
   (rotate-loops #:rotate-loops? #t)
   (simplify #:simplify? #t))
+
+(define (cps-default-optimization-options)
+  (list ;; #:split-rec? #t
+   #:eliminate-dead-code? #t
+   #:prune-top-level-scopes? #t
+   #:contify? #t
+   #:inline-constructors? #t
+   #:specialize-primcalls? #t
+   #:elide-values? #t
+   #:prune-bailouts? #t
+   #:peel-loops? #t
+   #:cse? #t
+   #:type-fold? #t
+   #:resolve-self-references? #t
+   #:licm? #t
+   #:rotate-loops? #t))
diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm
index d5d4f43a0..8fa6a80e8 100644
--- a/module/language/tree-il/optimize.scm
+++ b/module/language/tree-il/optimize.scm
@@ -1,6 +1,6 @@
 ;;; Tree-il optimizer
 
-;; Copyright (C) 2009, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2011, 2012, 2013, 2014, 2015 Free Software Foundation, Inc.
 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -25,7 +25,8 @@
   #:use-module (language tree-il fix-letrec)
   #:use-module (language tree-il debug)
   #:use-module (ice-9 match)
-  #:export (optimize))
+  #:export (optimize
+            tree-il-default-optimization-options))
 
 (define (optimize x env opts)
   (let ((peval (match (memq #:partial-eval? opts)
@@ -37,3 +38,6 @@
      (verify-tree-il
       (peval (expand-primitives (resolve-primitives x env))
              env)))))
+
+(define (tree-il-default-optimization-options)
+  '(#:partial-eval? #t))
diff --git a/module/scripts/compile.scm b/module/scripts/compile.scm
index 5b644c3d4..939fb2564 100644
--- a/module/scripts/compile.scm
+++ b/module/scripts/compile.scm
@@ -1,6 +1,6 @@
 ;;; Compile --- Command-line Guile Scheme compiler  -*- coding: iso-8859-1 -*-
 
-;; Copyright 2005, 2008-2011, 2013, 2014 Free Software Foundation, Inc.
+;; Copyright 2005, 2008-2011, 2013, 2014, 2015 Free Software Foundation, Inc.
 ;;
 ;; This program is free software; you can redistribute it and/or
 ;; modify it under the terms of the GNU Lesser General Public License
@@ -32,10 +32,13 @@
   #:use-module ((system base compile) #:select (compile-file))
   #:use-module (system base target)
   #:use-module (system base message)
+  #:use-module (language tree-il optimize)
+  #:use-module (language cps optimize)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-13)
   #:use-module (srfi srfi-37)
   #:use-module (ice-9 format)
+  #:use-module (ice-9 match)
   #:export (compile))
 
 (define %summary "Compile a file.")
@@ -45,6 +48,20 @@
   (format (current-error-port) "error: ~{~a~}~%" messages)
   (exit 1))
 
+(define (available-optimizations)
+  (append (tree-il-default-optimization-options)
+          (cps-default-optimization-options)))
+
+;; Turn on all optimizations unless -O0.
+(define (optimizations-for-level level)
+  (let lp ((options (available-optimizations)))
+    (match options
+      (() '())
+      ((#:partial-eval? val . options)
+       (cons* #:partial-eval? (> level 0) (lp options)))
+      ((kw val . options)
+       (cons* kw (> level 1) (lp options))))))
+
 (define %options
   ;; Specifications of the command-line options.
   (list (option '(#\h "help") #f #f
@@ -77,9 +94,28 @@
                                     (cons (string->symbol arg) warnings)
                                     (alist-delete 'warnings result))))))
 
-	(option '(#\O "optimize") #f #f
+	(option '(#\O "optimize") #t #f
 		(lambda (opt name arg result)
-		  (alist-cons 'optimize? #t result)))
+                  (define (return val)
+                    (alist-cons 'optimizations val result))
+                  (define (return-option name val)
+                    (let ((kw (symbol->keyword
+                               (string->symbol (string-append name "?")))))
+                      (unless (memq kw (available-optimizations))
+                        (fail "Unknown optimization pass `~a'" name))
+                      (return (list kw val))))
+                  (cond
+                   ((string=? arg "help")
+                    (show-optimization-help)
+                    (exit 0))
+                   ((equal? arg "0") (return (optimizations-for-level 0)))
+                   ((equal? arg "1") (return (optimizations-for-level 1)))
+                   ((equal? arg "2") (return (optimizations-for-level 2)))
+                   ((equal? arg "3") (return (optimizations-for-level 3)))
+                   ((string-prefix? "no-" arg)
+                    (return-option (substring arg 3) #f))
+                   (else
+                    (return-option arg #t)))))
 	(option '(#\f "from") #t #f
 		(lambda (opt name arg result)
                   (if (assoc-ref result 'from)
@@ -129,15 +165,38 @@ There is NO WARRANTY, to the extent permitted by law.~%"))
             %warning-types)
   (format #t "~%"))
 
+(define (show-optimization-help)
+  (format #t "The available optimizations are:~%~%")
+  (let lp ((options (available-optimizations)))
+    (match options
+      (() #t)
+      ((kw val . options)
+       (let ((name (string-trim-right (symbol->string (keyword->symbol kw))
+                                      #\?)))
+         (format #t "  -O~a~%"
+                 (if val name (string-append "no-" name)))
+         (lp options)))))
+  (format #t "~%")
+  (format #t "To disable an optimization, prepend it with `no-', for example~%")
+  (format #t "`-Ono-cse.'~%~%")
+  (format #t "You may also specify optimization levels as `-O0', `-O1',~%")
+  (format #t "`-O2', or `-O3'.  Currently `-O0' turns off all optimizations,~%")
+  (format #t "`-O1' turns on partial evaluation, and `-O2' and `-O3' turn on~%")
+  (format #t "everything.  The default is equivalent to `-O2'.")
+  (format #t "~%"))
+
 
 (define (compile . args)
   (let* ((options         (parse-args args))
          (help?           (assoc-ref options 'help?))
-         (compile-opts    (let ((o `(#:warnings
-                                     ,(assoc-ref options 'warnings))))
-                            (if (assoc-ref options 'optimize?)
-                                (cons #:O o)
-                                o)))
+         (compile-opts    `(#:warnings
+                            ,(assoc-ref options 'warnings)
+                            ,@(append-map
+                               (lambda (opt)
+                                 (match opt
+                                   (('optimizations . opts) opts)
+                                   (_ '())))
+                               options)))
          (from            (or (assoc-ref options 'from) 'scheme))
          (to              (or (assoc-ref options 'to) 'bytecode))
          (target          (or (assoc-ref options 'target) %host-type))
@@ -156,6 +215,8 @@ Compile each Guile source file FILE into a Guile object.
 
   -W, --warn=WARNING   emit warnings of type WARNING; use `--warn=help'
                        for a list of available warnings
+  -O, --optimize=OPT   specify optimization passes to run; use `-Ohelp'
+                       for a list of available optimizations
 
   -f, --from=LANG      specify a source language other than `scheme'
   -t, --to=LANG        specify a target language other than `bytecode'