mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-11 06:20:23 +02:00
Code Activity

Define new "lowering" phase in compiler

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2020-05-08 16:47:07 +02:00
parent e9c0f3071d
commit 4311dc9858
10 changed files with 89 additions and 66 deletions
Download patch file Download diff file Expand all files Collapse all files

25
module/language/cps/compile-bytecode.scm
View file

@ -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))

63
module/language/cps/optimize.scm
View file

@ -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))))

3
module/language/cps/spec.scm
View file

@ -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)

3
module/language/tree-il/compile-bytecode.scm
View file

@ -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)

5
module/language/tree-il/compile-cps.scm
View file

@ -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)

12
module/language/tree-il/optimize.scm
View file

@ -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))))

2
module/language/tree-il/spec.scm
View file

@ -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)

26
module/scripts/compile.scm
View file

@ -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)

12
module/system/base/compile.scm
View file

@ -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))

4
module/system/base/language.scm
View file

@ -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)