Define new "lowering" phase in compiler

* module/language/cps/compile-bytecode.scm (compile-bytecode):
* module/language/tree-il/compile-bytecode.scm (compile-bytecode):
* module/language/tree-il/compile-cps.scm (compile-cps): Rely on
  compiler to lower incoming term already.
* module/language/tree-il/optimize.scm (make-lowerer): New procedure.
* module/system/base/compile.scm (compute-lowerer): New procedure,
  replaceing add-default-optimizations.
  (compute-compiler): Lower before running compiler.
* module/system/base/language.scm (<language>): Change
  optimizations-for-level field to "lowerer".
* module/scripts/compile.scm (%options, compile): Parse -O0, -O1 and so
  on to #:optimization-level instead of expanding to all the
  optimization flags.
* module/language/cps/optimize.scm (lower-cps): Move here from
  compile-bytecode.scm.
  (make-cps-lowerer): New function.
* module/language/cps/spec.scm (cps): Declare lowerer.

module/language/cps/compile-bytecode.scm

@@ -29,12 +29,6 @@
   #:use-module (language cps)
   #:use-module (language cps slot-allocation)
   #:use-module (language cps utils)
-  #:use-module (language cps closure-conversion)
-  #:use-module (language cps loop-instrumentation)
-  #: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)
@@ -680,7 +674,7 @@
 
     (intmap-for-each compile-cont cps)))
 
-(define (emit-bytecode exp env opts)
+(define (compile-bytecode exp env opts)
   (let ((asm (make-assembler)))
     (intmap-for-each (lambda (kfun body)
                        (compile-function (intmap-select exp body) asm opts))
@@ -688,20 +682,3 @@
     (values (link-assembly asm #:page-aligned? (kw-arg-ref opts #:to-file? #f))
             env
             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))
-  (set! exp (reify-primitives exp))
-  (set! exp (add-loop-instrumentation exp))
-  (renumber exp))
-
-(define (compile-bytecode exp env opts)
-  (set! exp (lower-cps exp opts))
-  (emit-bytecode exp env opts))

module/language/cps/optimize.scm

@@ -1,20 +1,19 @@
 ;;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2013, 2014, 2015, 2017, 2018 Free Software Foundation, Inc.
+;; Copyright (C) 2013-2018,2020 Free Software Foundation, Inc.
 
-;;;; This library is free software; you can redistribute it and/or
+;;; This library is free software; you can redistribute it and/or modify it
-;;;; modify it under the terms of the GNU Lesser General Public
+;;; under the terms of the GNU Lesser General Public License as published by
-;;;; License as published by the Free Software Foundation; either
+;;; the Free Software Foundation; either version 3 of the License, or (at
-;;;; version 3 of the License, or (at your option) any later version.
+;;; your option) any later version.
-;;;;
+;;;
-;;;; This library is distributed in the hope that it will be useful,
+;;; This library is distributed in the hope that it will be useful, but
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser
-;;;; Lesser General Public License for more details.
+;;; General Public License for more details.
-;;;;
+;;;
-;;;; You should have received a copy of the GNU Lesser General Public
+;;; You should have received a copy of the GNU Lesser General Public License
-;;;; License along with this library; if not, write to the Free Software
+;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 
 ;;; Commentary:
 ;;;
@@ -24,23 +23,29 @@
 
 (define-module (language cps optimize)
   #:use-module (ice-9 match)
+  #:use-module (language cps closure-conversion)
   #:use-module (language cps contification)
   #:use-module (language cps cse)
-  #:use-module (language cps devirtualize-integers)
   #:use-module (language cps dce)
+  #:use-module (language cps devirtualize-integers)
   #:use-module (language cps licm)
+  #:use-module (language cps loop-instrumentation)
   #:use-module (language cps peel-loops)
   #:use-module (language cps prune-top-level-scopes)
+  #:use-module (language cps reify-primitives)
+  #:use-module (language cps renumber)
   #:use-module (language cps rotate-loops)
   #:use-module (language cps self-references)
   #:use-module (language cps simplify)
-  #:use-module (language cps specialize-primcalls)
   #:use-module (language cps specialize-numbers)
+  #: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
-            cps-optimizations))
+            cps-optimizations
+            make-cps-lowerer))
 
 (define (kw-arg-ref args kw default)
   (match (memq kw args)
@@ -128,3 +133,27 @@
     (#:rotate-loops? 2)
     ;; This one is used by the slot allocator.
     (#:precolor-calls? 2)))
+
+(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))
+  (set! exp (reify-primitives exp))
+  (set! exp (add-loop-instrumentation exp))
+  (renumber exp))
+
+(define (make-cps-lowerer optimization-level opts)
+  (define (enabled-for-level? level) (<= level optimization-level))
+  (let ((opts (let lp ((all-opts (cps-optimizations)))
+                (match all-opts
+                  (() '())
+                  (((kw level) . all-opts)
+                   (acons kw (kw-arg-ref opts kw (enabled-for-level? level))
+                          (lp all-opts)))))))
+    (lambda (exp env)
+      (lower-cps exp opts))))

module/language/cps/spec.scm

@@ -23,6 +23,7 @@
   #:use-module (system base language)
   #:use-module (language cps)
   #:use-module (language cps intmap)
+  #:use-module (language cps optimize)
   #:use-module (language cps compile-bytecode)
   #:export (cps))
 
@@ -48,4 +49,4 @@
   #:printer	write-cps
   #:compilers   `((bytecode . ,compile-bytecode))
   #:for-humans? #f
-  )
+  #:lowerer     make-cps-lowerer)

module/language/tree-il/compile-bytecode.scm

@@ -41,7 +41,6 @@
   #:use-module (ice-9 match)
   #:use-module (language bytecode)
   #:use-module (language tree-il)
-  #:use-module (language tree-il optimize)
   #:use-module ((srfi srfi-1) #:select (filter-map
                                         fold
                                         lset-union lset-difference))
@@ -1320,7 +1319,7 @@ in the frame with for the lambda-case clause @var{clause}."
     (_ default)))
 
 (define (compile-bytecode exp env opts)
-  (let* ((exp (canonicalize (optimize exp env opts)))
+  (let* ((exp (canonicalize exp))
          (asm (make-assembler)))
     (call-with-values (lambda () (split-closures exp))
       (lambda (closures assigned)

module/language/tree-il/compile-cps.scm

@@ -60,7 +60,6 @@
   #:use-module (language cps utils)
   #:use-module (language cps with-cps)
   #:use-module (language tree-il cps-primitives)
-  #:use-module (language tree-il optimize)
   #:use-module (language tree-il)
   #:use-module (language cps intmap)
   #:export (compile-cps))
@@ -2537,9 +2536,7 @@ integer."
    exp))
 
 (define (compile-cps exp env opts)
-  (values (cps-convert/thunk (canonicalize (optimize exp env opts)))
+  (values (cps-convert/thunk (canonicalize exp)) env env))
-          env
-          env))
 
 ;;; Local Variables:
 ;;; eval: (put 'convert-arg 'scheme-indent-function 2)

module/language/tree-il/optimize.scm

@@ -28,6 +28,7 @@
   #:use-module (language tree-il primitives)
   #:use-module (ice-9 match)
   #:export (optimize
+            make-lowerer
             tree-il-optimizations))
 
 (define (kw-arg-ref args kw default)
@@ -75,3 +76,14 @@
     (#:seal-private-bindings? 3)
     (#:partial-eval? 1)
     (#:eta-expand? 2)))
+
+(define (make-lowerer optimization-level opts)
+  (define (enabled-for-level? level) (<= level optimization-level))
+  (let ((opts (let lp ((all-opts (tree-il-optimizations)))
+                (match all-opts
+                  (() '())
+                  (((kw level) . all-opts)
+                   (acons kw (kw-arg-ref opts kw (enabled-for-level? level))
+                          (lp all-opts)))))))
+    (lambda (exp env)
+      (optimize exp env opts))))

module/language/tree-il/spec.scm

@@ -24,6 +24,7 @@
   #:use-module (language tree-il)
   #:use-module (language tree-il compile-cps)
   #:use-module ((language tree-il analyze) #:select (make-analyzer))
+  #:use-module ((language tree-il optimize) #:select (make-lowerer))
   #:export (tree-il))
 
 (define (write-tree-il exp . port)
@@ -45,4 +46,5 @@
   #:joiner      join
   #:compilers   `((cps . ,compile-cps))
   #:analyzer    make-analyzer
+  #:lowerer     make-lowerer
   #:for-humans? #f)

module/scripts/compile.scm

@@ -113,10 +113,12 @@
                    ((string=? arg "help")
                     (show-optimization-help)
                     (exit 0))
-                   ((equal? arg "0") (return (optimizations-for-level 0)))
+                   ((string->number arg)
-                   ((equal? arg "1") (return (optimizations-for-level 1)))
+                    => (lambda (level)
-                   ((equal? arg "2") (return (optimizations-for-level 2)))
+                         (unless (and (exact-integer? level) (<= 0 level 9))
-                   ((equal? arg "3") (return (optimizations-for-level 3)))
+                           (fail "Bad optimization level `~a'" level))
+                         (alist-cons 'optimization-level level
+                                     (alist-delete 'optimization-level result))))
                    ((string-prefix? "no-" arg)
                     (return-option (substring arg 3) #f))
                    (else
@@ -153,6 +155,7 @@ options."
              `((input-files)
 	       (load-path)
                (warning-level . ,(default-warning-level))
+               (optimization-level . ,(default-optimization-level))
                (warnings unsupported-warning))))
 
 (define (show-version)
@@ -197,6 +200,7 @@ There is NO WARRANTY, to the extent permitted by law.~%"))
   (let* ((options         (parse-args args))
          (help?           (assoc-ref options 'help?))
          (warning-level   (assoc-ref options 'warning-level))
+         (optimization-level (assoc-ref options 'optimization-level))
          (compile-opts    `(#:warnings
                             ,(assoc-ref options 'warnings)
                             ,@(append-map
@@ -275,12 +279,14 @@ Report bugs to <~A>.~%"
                         (with-fluids ((*current-warning-prefix* ""))
                           (with-target target
                             (lambda ()
-                              (compile-file file
+                              (compile-file
-                                            #:output-file output-file
+                               file
-                                            #:from from
+                               #:output-file output-file
-                                            #:to to
+                               #:from from
-                                            #:warning-level warning-level
+                               #:to to
-                                            #:opts compile-opts))))))
+                               #:warning-level warning-level
+                               #:optimization-level optimization-level
+                               #:opts compile-opts))))))
               input-files)))
 
 (define main compile)

module/system/base/compile.scm

@@ -224,11 +224,11 @@
                     ((#:warnings warnings . _) warnings)
                     ((_ _ . opts) (lp opts))))))))
 
-(define (add-default-optimizations lang optimization-level opts)
+(define (compute-lowerer lang optimization-level opts)
   (level-validator optimization-level)
-  (match (language-optimizations-for-level lang)
+  (match (language-lowerer lang)
-    (#f opts)
+    (#f (lambda (exp env) exp))
-    (get-opts (append opts (get-opts optimization-level)))))
+    (proc (proc optimization-level opts))))
 
 (define (compute-compiler from to optimization-level warning-level opts)
   (let lp ((order (or (lookup-compilation-order from to)
@@ -237,10 +237,10 @@
       (() (lambda (exp env) (values exp env env)))
       (((lang . pass) . order)
        (let* ((analyze (compute-analyzer lang warning-level opts))
-              (opts (add-default-optimizations lang optimization-level opts))
+              (lower (compute-lowerer lang optimization-level opts))
               (compile (lambda (exp env)
                          (analyze exp env)
-                         (pass exp env opts)))
+                         (pass (lower exp env) env opts)))
               (tail (lp order)))
          (lambda (exp env)
            (let*-values (((exp env cenv) (compile exp env))

module/system/base/language.scm

@@ -27,7 +27,7 @@
             language-compilers language-decompilers language-evaluator
             language-joiner language-for-humans?
             language-make-default-environment
-            language-optimizations-for-level
+            language-lowerer
             language-analyzer
 
             lookup-compilation-order lookup-decompilation-order
@@ -52,7 +52,7 @@
   (joiner #f)
   (for-humans? #t)
   (make-default-environment make-fresh-user-module)
-  (optimizations-for-level #f)
+  (lowerer #f)
   (analyzer #f))
 
 (define-syntax-rule (define-language name . spec)