Add (system base optimize) module

* module/system/base/optimize.scm: New module.
* module/Makefile.am (SOURCES):
* am/bootstrap.am (SOURCES): Add new module.
* module/language/tree-il/optimize.scm (tree-il-optimizations): Rename
  from tree-il-default-optimization-options.  Directly specify the
  optimization level at which a pass should be enabled.
* module/language/cps/optimize.scm (cps-optimizations): Likewise, rename
  from cps-default-optimization-options.
* module/scripts/compile.scm (%options, show-optimization-help): Adapt
  to use new module.

6 files changed, 78 insertions, 43 deletions

diff --git a/am/bootstrap.am b/am/bootstrap.am
index 2d0120634..cb5301fff 100644
--- a/am/bootstrap.am
+++ b/am/bootstrap.am
@@ -114,6 +114,7 @@ SOURCES =					\
   system/base/pmatch.scm			\
   system/base/syntax.scm			\
   system/base/compile.scm			\
+  system/base/optimize.scm			\
   system/base/language.scm			\
   system/base/lalr.scm				\
   system/base/message.scm			\
diff --git a/module/Makefile.am b/module/Makefile.am
index b582bbb2d..3d105f11b 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -298,6 +298,7 @@ SOURCES =					\
   system/base/pmatch.scm			\
   system/base/syntax.scm			\
   system/base/compile.scm			\
+  system/base/optimize.scm			\
   system/base/language.scm			\
   system/base/lalr.scm				\
   system/base/message.scm			\
diff --git a/module/language/cps/optimize.scm b/module/language/cps/optimize.scm
index 5bbd75f1d..ef73d4996 100644
--- a/module/language/cps/optimize.scm
+++ b/module/language/cps/optimize.scm
@@ -40,7 +40,7 @@
   #:use-module (language cps verify)
   #:export (optimize-higher-order-cps
             optimize-first-order-cps
-            cps-default-optimization-options))
+            cps-optimizations))
 
 (define (kw-arg-ref args kw default)
   (match (memq kw args)
@@ -111,20 +111,20 @@
   (rotate-loops #:rotate-loops? #t)
   (simplify #:simplify? #t))
 
-(define (cps-default-optimization-options)
-  (list ;; #:split-rec? #t
-   #:simplify? #t
-   #:eliminate-dead-code? #t
-   #:prune-top-level-scopes? #t
-   #:contify? #t
-   #:specialize-primcalls? #t
-   #:peel-loops? #t
-   #:cse? #t
-   #:type-fold? #t
-   #:resolve-self-references? #t
-   #:devirtualize-integers? #t
-   #:specialize-numbers? #t
-   #:licm? #t
-   #:rotate-loops? #t
-   ;; This one is used by the slot allocator.
-   #:precolor-calls? #t))
+(define (cps-optimizations)
+  '( ;; (#:split-rec? #t)
+    (#:simplify? 2)
+    (#:eliminate-dead-code? 2)
+    (#:prune-top-level-scopes? 2)
+    (#:contify? 2)
+    (#:specialize-primcalls? 2)
+    (#:peel-loops? 2)
+    (#:cse? 2)
+    (#:type-fold? 2)
+    (#:resolve-self-references? 2)
+    (#:devirtualize-integers? 2)
+    (#:specialize-numbers? 2)
+    (#:licm? 2)
+    (#:rotate-loops? 2)
+    ;; This one is used by the slot allocator.
+    (#:precolor-calls? 2)))
diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm
index 8fa6a80e8..1bd0c7905 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, 2015 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010-2015, 2018 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
@@ -26,7 +26,7 @@
   #:use-module (language tree-il debug)
   #:use-module (ice-9 match)
   #:export (optimize
-            tree-il-default-optimization-options))
+            tree-il-optimizations))
 
 (define (optimize x env opts)
   (let ((peval (match (memq #:partial-eval? opts)
@@ -39,5 +39,11 @@
       (peval (expand-primitives (resolve-primitives x env))
              env)))))
 
-(define (tree-il-default-optimization-options)
-  '(#:partial-eval? #t))
+(define (tree-il-optimizations)
+  ;; Avoid resolve-primitives until -O2, when CPS optimizations kick in.
+  ;; Otherwise, inlining the primcalls during Tree-IL->CPS compilation
+  ;; will result in a lot of code that will never get optimized nicely.
+  '((#:resolve-primitives? 2)
+    (#:expand-primitives? 1)
+    (#:partial-eval? 1)
+    (#:fix-letrec? 1)))
diff --git a/module/scripts/compile.scm b/module/scripts/compile.scm
index 939fb2564..26c79f1ee 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, 2015 Free Software Foundation, Inc.
+;; Copyright 2005, 2008-2011, 2013, 2014, 2015, 2018 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,8 +32,7 @@
   #: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 (system base optimize)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-13)
   #:use-module (srfi srfi-37)
@@ -48,20 +47,6 @@
   (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
@@ -101,7 +86,7 @@
                   (define (return-option name val)
                     (let ((kw (symbol->keyword
                                (string->symbol (string-append name "?")))))
-                      (unless (memq kw (available-optimizations))
+                      (unless (assq kw (available-optimizations))
                         (fail "Unknown optimization pass `~a'" name))
                       (return (list kw val))))
                   (cond
@@ -170,11 +155,10 @@ There is NO WARRANTY, to the extent permitted by law.~%"))
   (let lp ((options (available-optimizations)))
     (match options
       (() #t)
-      ((kw val . options)
+      (((kw level) . options)
        (let ((name (string-trim-right (symbol->string (keyword->symbol kw))
                                       #\?)))
-         (format #t "  -O~a~%"
-                 (if val name (string-append "no-" name)))
+         (format #t "  -O~a~%" name)
          (lp options)))))
   (format #t "~%")
   (format #t "To disable an optimization, prepend it with `no-', for example~%")
diff --git a/module/system/base/optimize.scm b/module/system/base/optimize.scm
new file mode 100644
index 000000000..562f94ae7
--- /dev/null
+++ b/module/system/base/optimize.scm
@@ -0,0 +1,43 @@
+;;; Optimization flags
+
+;; Copyright (C) 2018 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
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;; 
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;; 
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Code:
+
+(define-module (system base optimize)
+  #:use-module (language tree-il optimize)
+  #:use-module (language cps optimize)
+  #:use-module (ice-9 match)
+  #:export (available-optimizations
+            pass-optimization-level
+            optimizations-for-level))
+
+(define (available-optimizations)
+  (append (tree-il-optimizations) (cps-optimizations)))
+
+(define (pass-optimization-level kw)
+  (match (assq kw (available-optimizations))
+    ((kw level) level)
+    (_ (error "unknown optimization" kw))))
+
+;; Turn on all optimizations unless -O0.
+(define (optimizations-for-level level)
+  (let lp ((options (available-optimizations)))
+    (match options
+      (() '())
+      (((kw at-level) . options)
+       (cons* kw (<= at-level level) (lp options))))))