[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 10/10: Define new "lowering" phase in compiler
From: |
Andy Wingo |
Subject: |
[Guile-commits] 10/10: Define new "lowering" phase in compiler |
Date: |
Fri, 8 May 2020 11:13:44 -0400 (EDT) |
wingo pushed a commit to branch master
in repository guile.
commit 4311dc9858ba7c6db50a851e95fc7c387b9381b2
Author: Andy Wingo <address@hidden>
AuthorDate: Fri May 8 16:47:07 2020 +0200
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 | 25 +----------
module/language/cps/optimize.scm | 63 ++++++++++++++++++++--------
module/language/cps/spec.scm | 3 +-
module/language/tree-il/compile-bytecode.scm | 3 +-
module/language/tree-il/compile-cps.scm | 5 +--
module/language/tree-il/optimize.scm | 12 ++++++
module/language/tree-il/spec.scm | 2 +
module/scripts/compile.scm | 26 +++++++-----
module/system/base/compile.scm | 12 +++---
module/system/base/language.scm | 4 +-
10 files changed, 89 insertions(+), 66 deletions(-)
diff --git a/module/language/cps/compile-bytecode.scm
b/module/language/cps/compile-bytecode.scm
index 6e7dab8..48e6ba1 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/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))
diff --git a/module/language/cps/optimize.scm b/module/language/cps/optimize.scm
index ef73d49..a94a471 100644
--- a/module/language/cps/optimize.scm
+++ b/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
-;;;; 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
+;;; 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 program. If not, see <http://www.gnu.org/licenses/>.
;;; 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))))
diff --git a/module/language/cps/spec.scm b/module/language/cps/spec.scm
index e2c46d2..5864203 100644
--- a/module/language/cps/spec.scm
+++ b/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)
diff --git a/module/language/tree-il/compile-bytecode.scm
b/module/language/tree-il/compile-bytecode.scm
index 0656b46..e327ca4 100644
--- a/module/language/tree-il/compile-bytecode.scm
+++ b/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)
diff --git a/module/language/tree-il/compile-cps.scm
b/module/language/tree-il/compile-cps.scm
index 06ced58..a2dbbc5 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/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)))
- env
- env))
+ (values (cps-convert/thunk (canonicalize exp)) env env))
;;; Local Variables:
;;; eval: (put 'convert-arg 'scheme-indent-function 2)
diff --git a/module/language/tree-il/optimize.scm
b/module/language/tree-il/optimize.scm
index 4123781..66725b9 100644
--- a/module/language/tree-il/optimize.scm
+++ b/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))))
diff --git a/module/language/tree-il/spec.scm b/module/language/tree-il/spec.scm
index c168c5c..8ee4bf3 100644
--- a/module/language/tree-il/spec.scm
+++ b/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)
diff --git a/module/scripts/compile.scm b/module/scripts/compile.scm
index 7b6daea..5d91538 100644
--- a/module/scripts/compile.scm
+++ b/module/scripts/compile.scm
@@ -113,10 +113,12 @@
((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->number arg)
+ => (lambda (level)
+ (unless (and (exact-integer? level) (<= 0 level 9))
+ (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
- #:output-file output-file
- #:from from
- #:to to
- #:warning-level warning-level
- #:opts compile-opts))))))
+ (compile-file
+ file
+ #:output-file output-file
+ #:from from
+ #:to to
+ #:warning-level warning-level
+ #:optimization-level optimization-level
+ #:opts compile-opts))))))
input-files)))
(define main compile)
diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm
index 7ec2da3..3ea1e7a 100644
--- a/module/system/base/compile.scm
+++ b/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)
- (#f opts)
- (get-opts (append opts (get-opts optimization-level)))))
+ (match (language-lowerer lang)
+ (#f (lambda (exp env) exp))
+ (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))
diff --git a/module/system/base/language.scm b/module/system/base/language.scm
index f73d7db..5f23fa8 100644
--- a/module/system/base/language.scm
+++ b/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)
- [Guile-commits] branch master updated (728de16 -> 4311dc9), Andy Wingo, 2020/05/08
- [Guile-commits] 06/10: Add #:optimization-level, #:warning-level compile keyword args, Andy Wingo, 2020/05/08
- [Guile-commits] 09/10: Warning and optimization levels always small integers, Andy Wingo, 2020/05/08
- [Guile-commits] 08/10: Wire up simplified warning levels in "guild compile", Andy Wingo, 2020/05/08
- [Guile-commits] 02/10: Remove compilation order cache, Andy Wingo, 2020/05/08
- [Guile-commits] 01/10: Update (system base compile) header, Andy Wingo, 2020/05/08
- [Guile-commits] 04/10: Use more `match' in (system base compile), Andy Wingo, 2020/05/08
- [Guile-commits] 05/10: Rework compile-fold, Andy Wingo, 2020/05/08
- [Guile-commits] 10/10: Define new "lowering" phase in compiler,
Andy Wingo <=
- [Guile-commits] 07/10: Add language-specific analysis pass to compiler infrastructure, Andy Wingo, 2020/05/08
- [Guile-commits] 03/10: Slight (system base compile) refactor, Andy Wingo, 2020/05/08