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'