diff --git a/module/language/tree-il/spec.scm b/module/language/tree-il/spec.scm index 441ff7e8a..169f5a067 100644 --- a/module/language/tree-il/spec.scm +++ b/module/language/tree-il/spec.scm @@ -1,6 +1,6 @@ ;;; Tree Intermediate Language -;; Copyright (C) 2009, 2010, 2011, 2013, 2015 Free Software Foundation, Inc. +;; Copyright (C) 2009-2011,2013,2015,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 @@ -22,8 +22,6 @@ #:use-module (system base language) #:use-module (ice-9 match) #:use-module (language tree-il) - #:use-module (language tree-il compile-cps) - #:use-module (language tree-il compile-bytecode) #:use-module ((language tree-il analyze) #:select (make-analyzer)) #:use-module ((language tree-il optimize) #:select (make-lowerer)) #:export (tree-il)) @@ -40,11 +38,13 @@ (_ (error "what!" exps env)))) (define (choose-compiler target optimization-level opts) + (define (load-compiler compiler) + (module-ref (resolve-interface `(language tree-il ,compiler)) compiler)) (if (match (memq #:cps? opts) ((_ cps? . _) cps?) (#f (<= 1 optimization-level))) - (cons 'cps compile-cps) - (cons 'bytecode compile-bytecode))) + (cons 'cps (load-compiler 'compile-bytecode)) + (cons 'bytecode (load-compiler 'compile-bytecode)))) (define-language tree-il #:title "Tree Intermediate Language" @@ -52,8 +52,6 @@ #:printer write-tree-il #:parser parse-tree-il #:joiner join - #:compilers `((cps . ,compile-cps) - (bytecode . ,compile-bytecode)) #:compiler-chooser choose-compiler #:analyzer make-analyzer #:lowerer make-lowerer diff --git a/module/scripts/compile.scm b/module/scripts/compile.scm index 6440c4086..eadd38bf2 100644 --- a/module/scripts/compile.scm +++ b/module/scripts/compile.scm @@ -29,8 +29,8 @@ ;;; Code: (define-module (scripts compile) - #:use-module ((system base language) #:select (lookup-language)) - #:use-module ((system base compile) #:select (compile-file + #:use-module ((system base compile) #:select (compute-compiler + compile-file default-warning-level default-optimization-level)) #:use-module (system base target) @@ -250,12 +250,12 @@ Report bugs to <~A>.~%" (when (assoc-ref options 'install-r7rs?) (install-r7rs!)) - ;; Load FROM and TO before we have changed the load path. That way, when - ;; cross-compiling Guile itself, we can be sure we're loading our own - ;; language modules and not those of the Guile being compiled, which may - ;; have incompatible .go files. - (lookup-language from) - (lookup-language to) + ;; Compute a compiler before changing the load path, for its side + ;; effects of loading compiler modules. That way, when + ;; cross-compiling Guile itself, we can be sure we're loading our + ;; own language modules and not those of the Guile being compiled, + ;; which may have incompatible .go files. + (compute-compiler from to optimization-level warning-level compile-opts) (set! %load-path (append load-path %load-path)) (set! %load-should-auto-compile #f) diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm index 26b28bf41..567765dc0 100644 --- a/module/system/base/compile.scm +++ b/module/system/base/compile.scm @@ -26,6 +26,7 @@ #:export (compiled-file-name compile-file compile-and-load + compute-compiler read-and-compile compile decompile @@ -267,18 +268,16 @@ ;; unit. (values exp env cenv))))))))) -(define (find-language-joint from to) - (match (lookup-compilation-order from to) - (((langs . passes) ...) - (or (let lp ((langs langs)) - (match langs - (() #f) - ((lang . langs) - (or (lp langs) - (and (language-joiner lang) - lang))))) - to)) - (_ (error "no way to compile" from "to" to)))) +(define (find-language-joint from to optimization-level opts) + (let ((from (ensure-language from)) + (to (ensure-language to))) + (let lp ((lang from)) + (match (next-pass from lang to optimization-level opts) + (#f #f) + ((next . pass) + (or (lp next) + (and (language-joiner next) + next))))))) (define (default-language-joiner lang) (lambda (exps env) @@ -305,7 +304,7 @@ (opts '())) (let* ((from (ensure-language from)) (to (ensure-language to)) - (joint (find-language-joint from to))) + (joint (find-language-joint from to optimization-level opts))) (parameterize ((current-language from)) (let lp ((exps '()) (env #f) (cenv env) (from #f) (compile1 #f)) (match (read-and-parse (current-language) port cenv)