diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm index 4fc75b6a7..5efc7eec5 100644 --- a/module/language/tree-il/optimize.scm +++ b/module/language/tree-il/optimize.scm @@ -19,43 +19,46 @@ ;;; Code: (define-module (language tree-il optimize) - #:use-module (language tree-il) - #:use-module (language tree-il debug) - #:use-module (language tree-il eta-expand) - #:use-module (language tree-il fix-letrec) - #:use-module (language tree-il letrectify) - #:use-module (language tree-il peval) - #:use-module (language tree-il primitives) #:use-module (ice-9 match) + ;; FIXME: Perhaps allow bootstrap builds to skip fix-letrec, because + ;; it imports intset, intmap, etc. + #:use-module (language tree-il fix-letrec) #:use-module (system base optimize) #:export (optimize make-lowerer tree-il-optimizations)) -(define *debug?* #f) - -(define (maybe-verify x) - (if *debug?* - (verify-tree-il x) - x)) +(define (make-optimizer opts) + (define-syntax lookup + (syntax-rules () + ((lookup kw id) + (lookup kw id id)) + ((lookup kw submodule proc) + (and (assq-ref opts kw) + (module-ref (resolve-interface '(language tree-il submodule)) + 'proc))))) + (let ((verify (or (lookup #:verify-tree-il? debug verify-tree-il) + (lambda (exp) exp))) + (resolve (lookup #:resolve-primitives? primitives resolve-primitives)) + (expand (lookup #:expand-primitives? primitives expand-primitives)) + (letrectify (lookup #:letrectify? letrectify)) + (seal? (assq-ref opts #:seal-private-bindings?)) + (peval (lookup #:partial-eval? peval)) + (eta-expand (lookup #:eta-expand? eta-expand))) + (define-syntax-rule (run-pass! (proc exp arg ...)) + (when proc (set! exp (verify (proc exp arg ...))))) + (lambda (exp env) + (verify exp) + (run-pass! (resolve exp env)) + (run-pass! (expand exp)) + (run-pass! (letrectify exp)) + (run-pass! (fix-letrec exp)) + (run-pass! (peval exp env)) + (run-pass! (eta-expand exp)) + exp))) (define (optimize x env opts) - (define-syntax-rule (run-pass pass kw) - (when (assq-ref opts kw) - (set! x (maybe-verify (pass x))))) - (define (resolve* x) (resolve-primitives x env)) - (define (peval* x) (peval x env)) - (define (letrectify* x) - (let ((seal? (assq-ref opts #:seal-private-bindings?))) - (letrectify x #:seal-private-bindings? seal?))) - (maybe-verify x) - (run-pass resolve* #:resolve-primitives?) - (run-pass expand-primitives #:expand-primitives?) - (run-pass letrectify* #:letrectify?) - (set! x (fix-letrec x)) - (run-pass peval* #:partial-eval?) - (run-pass eta-expand #:eta-expand?) - x) + ((make-optimizer opts) x env)) (define (tree-il-optimizations) (available-optimizations 'tree-il)) @@ -66,11 +69,10 @@ ((_ val . _) val) (_ default))) (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)))) + (make-optimizer + (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)))))))