guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] GNU Guile branch, master, updated. v2.1.0-892-g85270a8


From: Andy Wingo
Subject: [Guile-commits] GNU Guile branch, master, updated. v2.1.0-892-g85270a8
Date: Sun, 06 Apr 2014 09:55:43 +0000

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=85270a8c895f5912d688d764b686fdaeba0157d5

The branch, master has been updated
       via  85270a8c895f5912d688d764b686fdaeba0157d5 (commit)
      from  d03c3c77950dafddec69e87c5f75bec4a4197a60 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 85270a8c895f5912d688d764b686fdaeba0157d5
Author: Andy Wingo <address@hidden>
Date:   Sun Apr 6 11:08:05 2014 +0200

    Remove old Tree-IL CSE pass
    
    * module/language/tree-il/cse.scm: Delete.
    
    * module/language/tree-il/optimize.scm: Remove use of Tree-IL CSE.
    
    * module/Makefile.am: Remove language/tree-il/cse.scm.
    
    * module/language/cps/compile-bytecode.scm: Rename CSE keyword to
      #:cse?.

-----------------------------------------------------------------------

Summary of changes:
 module/Makefile.am                       |    1 -
 module/language/cps/compile-bytecode.scm |    2 +-
 module/language/tree-il/cse.scm          |  546 ------------------------------
 module/language/tree-il/optimize.scm     |   15 +-
 4 files changed, 4 insertions(+), 560 deletions(-)
 delete mode 100644 module/language/tree-il/cse.scm

diff --git a/module/Makefile.am b/module/Makefile.am
index b3b96d9..335e14c 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -47,7 +47,6 @@ ice-9/match.go: ice-9/match.scm ice-9/match.upstream.scm
 SOURCES =                                      \
   ice-9/boot-9.scm                             \
   language/tree-il/peval.scm                    \
-  language/tree-il/cse.scm                      \
   system/vm/elf.scm                            \
   ice-9/vlist.scm                               \
   srfi/srfi-1.scm                               \
diff --git a/module/language/cps/compile-bytecode.scm 
b/module/language/cps/compile-bytecode.scm
index a4d96ad..77edf64 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -71,7 +71,7 @@
          (exp (run-pass exp specialize-primcalls #:specialize-primcalls? #t))
          (exp (run-pass exp elide-values #:elide-values? #t))
          (exp (run-pass exp prune-bailouts #:prune-bailouts? #t))
-         (exp (run-pass exp eliminate-common-subexpressions #:cps-cse? #t))
+         (exp (run-pass exp eliminate-common-subexpressions #:cse? #t))
          (exp (run-pass exp eliminate-dead-code #:eliminate-dead-code? #t))
          (exp (run-pass exp simplify #:simplify? #t)))
     ;; Passes that are needed:
diff --git a/module/language/tree-il/cse.scm b/module/language/tree-il/cse.scm
deleted file mode 100644
index d4cf686..0000000
--- a/module/language/tree-il/cse.scm
+++ /dev/null
@@ -1,546 +0,0 @@
-;;; Common Subexpression Elimination (CSE) on Tree-IL
-
-;; Copyright (C) 2011, 2012, 2013, 2014 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
-
-(define-module (language tree-il cse)
-  #:use-module (language tree-il)
-  #:use-module (language tree-il primitives)
-  #:use-module (language tree-il effects)
-  #:use-module (ice-9 vlist)
-  #:use-module (ice-9 match)
-  #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-9)
-  #:use-module (srfi srfi-11)
-  #:use-module (srfi srfi-26)
-  #:export (cse))
-
-;;;
-;;; This pass eliminates common subexpressions in Tree-IL.  It works
-;;; best locally -- within a function -- so it is meant to be run after
-;;; partial evaluation, which usually inlines functions and so opens up
-;;; a bigger space for CSE to work.
-;;;
-;;; The algorithm traverses the tree of expressions, returning two
-;;; values: the newly rebuilt tree, and a "database".  The database is
-;;; the set of expressions that will have been evaluated as part of
-;;; evaluating an expression.  For example, in:
-;;;
-;;;   (1- (+ (if a b c) (* x y)))
-;;;
-;;; We can say that when it comes time to evaluate (1- <>), that the
-;;; subexpressions +, x, y, and (* x y) must have been evaluated in
-;;; values context.  We know that a was evaluated in test context, but
-;;; we don't know if it was true or false.
-;;;
-;;; The expressions in the database /dominate/ any subsequent
-;;; expression: FOO dominates BAR if evaluation of BAR implies that any
-;;; effects associated with FOO have already occured.
-;;;
-;;; When adding expressions to the database, we record the context in
-;;; which they are evaluated.  We treat expressions in test context
-;;; specially: the presence of such an expression indicates that the
-;;; expression is true.  In this way we can elide duplicate predicates.
-;;;
-;;; Duplicate predicates are not common in code that users write, but
-;;; can occur quite frequently in macro-generated code.
-;;;
-;;; For example:
-;;;
-;;;   (and (foo? x) (foo-bar x))
-;;;   => (if (and (struct? x) (eq? (struct-vtable x) <foo>))
-;;;          (if (and (struct? x) (eq? (struct-vtable x) <foo>))
-;;;              (struct-ref x 1)
-;;;              (throw 'not-a-foo))
-;;;          #f))
-;;;   => (if (and (struct? x) (eq? (struct-vtable x) <foo>))
-;;;          (struct-ref x 1)
-;;;          #f)
-;;;
-;;; A conditional bailout in effect context also has the effect of
-;;; adding predicates to the database:
-;;;
-;;;   (begin (foo-bar x) (foo-baz x))
-;;;   => (begin
-;;;        (if (and (struct? x) (eq? (struct-vtable x) <foo>))
-;;;            (struct-ref x 1)
-;;;            (throw 'not-a-foo))
-;;;        (if (and (struct? x) (eq? (struct-vtable x) <foo>))
-;;;            (struct-ref x 2)
-;;;            (throw 'not-a-foo)))
-;;;   => (begin
-;;;        (if (and (struct? x) (eq? (struct-vtable x) <foo>))
-;;;            (struct-ref x 1)
-;;;            (throw 'not-a-foo))
-;;;        (struct-ref x 2))
-;;;
-;;; When removing code, we have to ensure that the semantics of the
-;;; source program and the residual program are the same.  It's easy to
-;;; ensure that they have the same value, because those manipulations
-;;; are just algebraic, but the tricky thing is to ensure that the
-;;; expressions exhibit the same ordering of effects.  For that, we use
-;;; the effects analysis of (language tree-il effects).  We only
-;;; eliminate code if the duplicate code commutes with all of the
-;;; dominators on the path from the duplicate to the original.
-;;;
-;;; The implementation uses vhashes as the fundamental data structure.
-;;; This can be seen as a form of global value numbering.  This
-;;; algorithm currently spends most of its time in vhash-assoc.  I'm not
-;;; sure whether that is due to our bad hash function in Guile 2.0, an
-;;; inefficiency in vhashes, or what.  Overall though the complexity
-;;; should be linear, or N log N -- whatever vhash-assoc's complexity
-;;; is.  Walking the dominators is nonlinear, but that only happens when
-;;; we've actually found a common subexpression so that should be OK.
-;;;
-
-;; Logging helpers, as in peval.
-;;
-(define-syntax *logging* (identifier-syntax #f))
-;; (define %logging #f)
-;; (define-syntax *logging* (identifier-syntax %logging))
-(define-syntax log
-  (syntax-rules (quote)
-    ((log 'event arg ...)
-     (if (and *logging*
-              (or (eq? *logging* #t)
-                  (memq 'event *logging*)))
-         (log* 'event arg ...)))))
-(define (log* event . args)
-  (let ((pp (module-ref (resolve-interface '(ice-9 pretty-print))
-                        'pretty-print)))
-    (pp `(log ,event . ,args))
-    (newline)
-    (values)))
-
-;; A pre-pass on the source program to determine the set of assigned
-;; lexicals.
-;;
-(define* (build-assigned-var-table exp #:optional (table vlist-null))
-  (tree-il-fold
-   (lambda (exp res)
-     (match exp
-       (($ <lexical-set> src name gensym exp)
-        (vhash-consq gensym #t res))
-       (_ res)))
-   (lambda (exp res) res)
-   table exp))
-
-(define (boolean-valued-primitive? primitive)
-  (or (negate-primitive primitive)
-      (eq? primitive 'not)
-      (let ((chars (symbol->string primitive)))
-        (eqv? (string-ref chars (1- (string-length chars)))
-              #\?))))
-
-(define (boolean-valued-expression? x ctx)
-  (match x
-    (($ <primcall> _ (? boolean-valued-primitive?)) #t)
-    (($ <const> _ (? boolean?)) #t)
-    (_ (eq? ctx 'test))))
-
-(define (singly-valued-expression? x ctx)
-  (match x
-    (($ <const>) #t)
-    (($ <lexical-ref>) #t)
-    (($ <void>) #t)
-    (($ <lexical-ref>) #t)
-    (($ <primitive-ref>) #t)
-    (($ <module-ref>) #t)
-    (($ <toplevel-ref>) #t)
-    (($ <primcall> _ (? singly-valued-primitive?)) #t)
-    (($ <primcall> _ 'values (val)) #t)
-    (($ <lambda>) #t)
-    (_ (eq? ctx 'value))))
-
-(define* (cse exp)
-  "Eliminate common subexpressions in EXP."
-
-  (define assigned-lexical?
-    (let ((table (build-assigned-var-table exp)))
-      (lambda (sym)
-        (vhash-assq sym table))))
-
-  (define %compute-effects
-    (make-effects-analyzer assigned-lexical?))
-
-  (define (negate exp ctx)
-    (match exp
-      (($ <const> src x)
-       (make-const src (not x)))
-      (($ <void> src)
-       (make-const src #f))
-      (($ <conditional> src test consequent alternate)
-       (make-conditional src test (negate consequent ctx) (negate alternate 
ctx)))
-      (($ <primcall> _ 'not
-          ((and x (? (cut boolean-valued-expression? <> ctx)))))
-       x)
-      (($ <primcall> src (and pred (? negate-primitive)) args)
-       (make-primcall src (negate-primitive pred) args))
-      (_
-       (make-primcall #f 'not (list exp)))))
-
-  
-  (define (hasher n)
-    (lambda (x size) (hashq n size)))
-
-  (define (add-to-db exp effects ctx db)
-    (let ((v (vector exp effects ctx))
-          (h (tree-il-hash exp)))
-      (vhash-cons v h db (hasher h))))
-
-  (define (control-flow-boundary db)
-    (let ((h (hashq 'lambda most-positive-fixnum)))
-      (vhash-cons 'lambda h db (hasher h))))
-
-  (define (find-dominating-expression exp effects ctx db)
-    (define (entry-matches? v1 v2)
-      (match (if (vector? v1) v1 v2)
-        (#(exp* effects* ctx*)
-         (and (tree-il=? exp exp*)
-              (or (not ctx) (eq? ctx* ctx))))
-        (_ #f)))
-      
-    (let ((len (vlist-length db))
-          (h (tree-il-hash exp)))
-      (and (vhash-assoc #t db entry-matches? (hasher h))
-           (let lp ((n 0))
-             (and (< n len)
-                  (match (vlist-ref db n)
-                    (('lambda . h*)
-                     ;; We assume that lambdas can escape and thus be
-                     ;; called from anywhere.  Thus code inside a lambda
-                     ;; only has a dominating expression if it does not
-                     ;; depend on any effects.
-                     (and (not (depends-on-effects? effects &all-effects))
-                          (lp (1+ n))))
-                    ((#(exp* effects* ctx*) . h*)
-                     (log 'walk (unparse-tree-il exp) effects
-                          (unparse-tree-il exp*) effects* ctx*)
-                     (or (and (= h h*)
-                              (or (not ctx) (eq? ctx ctx*))
-                              (tree-il=? exp exp*))
-                         (and (effects-commute? effects effects*)
-                              (lp (1+ n)))))))))))
-
-  ;; Return #t if EXP is dominated by an instance of itself.  In that
-  ;; case, we can exclude *type-check* effects, because the first
-  ;; expression already caused them if needed.
-  (define (has-dominating-effect? exp effects db)
-    (or (constant? effects)
-        (and
-         (effect-free?
-          (exclude-effects effects
-                           (logior &zero-values
-                                   &allocation
-                                   &type-check)))
-         (find-dominating-expression exp effects #f db))))
-
-  (define (find-dominating-test exp effects db)
-    (and
-     (effect-free?
-      (exclude-effects effects (logior &allocation
-                                       &type-check)))
-     (match exp
-       (($ <const> src val)
-        (if (boolean? val)
-            exp
-            (make-const src (not (not val)))))
-       ;; For (not FOO), try to prove FOO, then negate the result.
-       (($ <primcall> src 'not (exp*))
-        (match (find-dominating-test exp* effects db)
-          (($ <const> _ val)
-           (log 'inferring exp (not val))
-           (make-const src (not val)))
-          (_
-           #f)))
-       (_
-        (cond
-         ((find-dominating-expression exp effects 'test db)
-          ;; We have an EXP fact, so we infer #t.
-          (log 'inferring exp #t)
-          (make-const (tree-il-src exp) #t))
-         ((find-dominating-expression (negate exp 'test) effects 'test db)
-          ;; We have a (not EXP) fact, so we infer #f.
-          (log 'inferring exp #f)
-          (make-const (tree-il-src exp) #f))
-         (else
-          ;; Otherwise we don't know.
-          #f))))))
-
-  (define (add-to-env exp name sym db env)
-    (let* ((v (vector exp name sym (vlist-length db)))
-           (h (tree-il-hash exp)))
-      (vhash-cons v h env (hasher h))))
-
-  (define (augment-env env names syms exps db)
-    (if (null? names)
-        env
-        (let ((name (car names)) (sym (car syms)) (exp (car exps)))
-          (augment-env (if (or (assigned-lexical? sym)
-                               (lexical-ref? exp))
-                           env
-                           (add-to-env exp name sym db env))
-                       (cdr names) (cdr syms) (cdr exps) db))))
-
-  (define (find-dominating-lexical exp effects env db)
-    (define (entry-matches? v1 v2)
-      (match (if (vector? v1) v1 v2)
-        (#(exp* name sym db)
-         (tree-il=? exp exp*))
-        (_ #f)))
-      
-    (define (unroll db base n)
-      (or (zero? n)
-          (match (vlist-ref db base)
-            (('lambda . h*)
-             ;; See note in find-dominating-expression.
-             (and (not (depends-on-effects? effects &all-effects))
-                  (unroll db (1+ base) (1- n))))
-            ((#(exp* effects* ctx*) . h*)
-             (and (effects-commute? effects effects*)
-                  (unroll db (1+ base) (1- n)))))))
-
-    (let ((h (tree-il-hash exp)))
-      (and (effect-free? (exclude-effects effects &type-check))
-           (vhash-assoc exp env entry-matches? (hasher h))
-           (let ((env-len (vlist-length env))
-                 (db-len (vlist-length db)))
-             (let lp ((n 0) (m 0))
-               (and (< n env-len)
-                    (match (vlist-ref env n)
-                      ((#(exp* name sym db-len*) . h*)
-                       (let ((niter (- (- db-len db-len*) m)))
-                         (and (unroll db m niter)
-                              (if (and (= h h*) (tree-il=? exp* exp))
-                                  (make-lexical-ref (tree-il-src exp) name sym)
-                                  (lp (1+ n) (- db-len db-len*)))))))))))))
-
-  (define (lookup-lexical sym env)
-    (let ((env-len (vlist-length env)))
-      (let lp ((n 0))
-        (and (< n env-len)
-             (match (vlist-ref env n)
-               ((#(exp _ sym* _) . _)
-                (if (eq? sym sym*)
-                    exp
-                    (lp (1+ n)))))))))
-
-  (define (intersection db+ db-)
-    (vhash-fold-right
-     (lambda (k h out)
-       (if (vhash-assoc k db- equal? (hasher h))
-           (vhash-cons k h out (hasher h))
-           out))
-     vlist-null
-     db+))
-
-  (define (concat db1 db2)
-    (vhash-fold-right (lambda (k h tail)
-                        (vhash-cons k h tail (hasher h)))
-                      db2 db1))
-
-  (let visit ((exp   exp)
-              (db vlist-null) ; dominating expressions: #(exp effects ctx) -> 
hash
-              (env vlist-null) ; named expressions: #(exp name sym db) -> hash
-              (ctx 'values)) ; test, effect, value, or values
-    
-    (define (parallel-visit exps db env ctx)
-      (let lp ((in exps) (out '()) (db* vlist-null))
-        (if (pair? in)
-            (call-with-values (lambda () (visit (car in) db env ctx))
-              (lambda (x db**)
-                (lp (cdr in) (cons x out) (concat db** db*))))
-            (values (reverse out) db*))))
-
-    (define (compute-effects exp)
-      (%compute-effects exp (lambda (sym) (lookup-lexical sym env))))
-
-    (define (bailout? exp)
-      (causes-effects? (compute-effects exp) &definite-bailout))
-
-    (define (return exp db*)
-      (let ((effects (compute-effects exp)))
-        (cond
-         ((and (eq? ctx 'effect)
-               (not (lambda-case? exp))
-               (or (effect-free?
-                    (exclude-effects effects
-                                     (logior &zero-values
-                                             &allocation)))
-                   (has-dominating-effect? exp effects db)))
-          (cond
-           ((void? exp)
-            (values exp db*))
-           (else
-            (log 'elide ctx (unparse-tree-il exp))
-            (values (make-void #f) db*))))
-         ((and (boolean-valued-expression? exp ctx)
-               (find-dominating-test exp effects db))
-          => (lambda (exp)
-               (log 'propagate-test ctx (unparse-tree-il exp))
-               (values exp db*)))
-         ((and (singly-valued-expression? exp ctx)
-               (find-dominating-lexical exp effects env db))
-          => (lambda (exp)
-               (log 'propagate-value ctx (unparse-tree-il exp))
-               (values exp db*)))
-         ((and (constant? effects) (memq ctx '(value values)))
-          ;; Adds nothing to the db.
-          (values exp db*))
-         (else
-          (log 'return ctx effects (unparse-tree-il exp) db*)
-          (values exp
-                  (add-to-db exp effects ctx db*))))))
-
-    (log 'visit ctx (unparse-tree-il exp) db env)
-
-    (match exp
-      (($ <const>)
-       (return exp vlist-null))
-      (($ <void>)
-       (return exp vlist-null))
-      (($ <lexical-ref> _ _ gensym)
-       (return exp vlist-null))
-      (($ <lexical-set> src name gensym exp)
-       (let*-values (((exp db*) (visit exp db env 'value)))
-         (return (make-lexical-set src name gensym exp)
-                 db*)))
-      (($ <let> src names gensyms vals body)
-       (let*-values (((vals db*) (parallel-visit vals db env 'value))
-                     ((body db**) (visit body (concat db* db)
-                                         (augment-env env names gensyms vals 
db)
-                                         ctx)))
-         (return (make-let src names gensyms vals body)
-                 (concat db** db*))))
-      (($ <letrec> src in-order? names gensyms vals body)
-       (let*-values (((vals db*) (parallel-visit vals db env 'value))
-                     ((body db**) (visit body (concat db* db)
-                                         (augment-env env names gensyms vals 
db)
-                                         ctx)))
-         (return (make-letrec src in-order? names gensyms vals body)
-                 (concat db** db*))))
-      (($ <fix> src names gensyms vals body)
-       (let*-values (((vals db*) (parallel-visit vals db env 'value))
-                     ((body db**) (visit body (concat db* db) env ctx)))
-         (return (make-fix src names gensyms vals body)
-                 (concat db** db*))))
-      (($ <let-values> src producer consumer)
-       (let*-values (((producer db*) (visit producer db env 'values))
-                     ((consumer db**) (visit consumer (concat db* db) env 
ctx)))
-         (return (make-let-values src producer consumer)
-                 (concat db** db*))))
-      (($ <toplevel-ref>)
-       (return exp vlist-null))
-      (($ <module-ref>)
-       (return exp vlist-null))
-      (($ <module-set> src mod name public? exp)
-       (let*-values (((exp db*) (visit exp db env 'value)))
-         (return (make-module-set src mod name public? exp)
-                 db*)))
-      (($ <toplevel-define> src name exp)
-       (let*-values (((exp db*) (visit exp db env 'value)))
-         (return (make-toplevel-define src name exp)
-                 db*)))
-      (($ <toplevel-set> src name exp)
-       (let*-values (((exp db*) (visit exp db env 'value)))
-         (return (make-toplevel-set src name exp)
-                 db*)))
-      (($ <primitive-ref>)
-       (return exp vlist-null))
-      (($ <conditional> src test consequent alternate)
-       (let*-values
-           (((test db+) (visit test db env 'test))
-            ((converse db-) (visit (negate test 'test) db env 'test))
-            ((consequent db++) (visit consequent (concat db+ db) env ctx))
-            ((alternate db--) (visit alternate (concat db- db) env ctx)))
-         (match (make-conditional src test consequent alternate)
-           (($ <conditional> _ ($ <const> _ exp))
-            (if exp
-                (return consequent (concat db++ db+))
-                (return alternate (concat db-- db-))))
-           ;; (if FOO A A) => (begin FOO A)
-           (($ <conditional> src _
-               ($ <const> _ a) ($ <const> _ (? (cut equal? a <>))))
-            (visit (make-seq #f test (make-const #f a))
-                   db env ctx))
-           ;; (if FOO #t #f) => FOO for boolean-valued FOO.
-           (($ <conditional> src
-               (? (cut boolean-valued-expression? <> ctx))
-               ($ <const> _ #t) ($ <const> _ #f))
-            (return test db+))
-           ;; (if FOO #f #t) => (not FOO)
-           (($ <conditional> src _ ($ <const> _ #f) ($ <const> _ #t))
-            (visit (negate test ctx) db env ctx))
-
-           ;; Allow "and"-like conditions to accumulate in test context.
-           ((and c ($ <conditional> _ _ _ ($ <const> _ #f)))
-            (return c (if (eq? ctx 'test) (concat db++ db+) vlist-null)))
-           ((and c ($ <conditional> _ _ ($ <const> _ #f) _))
-            (return c (if (eq? ctx 'test) (concat db-- db-) vlist-null)))
-
-           ;; Conditional bailouts turn expressions into predicates.
-           ((and c ($ <conditional> _ _ _ (? bailout?)))
-            (return c (concat db++ db+)))
-           ((and c ($ <conditional> _ _ (? bailout?) _))
-            (return c (concat db-- db-)))
-
-           (c
-            (return c (intersection (concat db++ db+) (concat db-- db-)))))))
-      (($ <primcall> src primitive args)
-       (let*-values (((args db*) (parallel-visit args db env 'value)))
-         (return (make-primcall src primitive args) db*)))
-      (($ <call> src proc args)
-       (let*-values (((proc db*) (visit proc db env 'value))
-                     ((args db**) (parallel-visit args db env 'value)))
-         (return (make-call src proc args)
-                 (concat db** db*))))
-      (($ <lambda> src meta body)
-       (let*-values (((body _) (if body
-                                   (visit body (control-flow-boundary db)
-                                          env 'values)
-                                   (values #f #f))))
-         (return (make-lambda src meta body)
-                 vlist-null)))
-      (($ <lambda-case> src req opt rest kw inits gensyms body alt)
-       (let*-values (((inits _) (parallel-visit inits db env 'value))
-                     ((body db*) (visit body db env ctx))
-                     ((alt _) (if alt
-                                  (visit alt db env ctx)
-                                  (values #f #f))))
-         (return (make-lambda-case src req opt rest kw inits gensyms body alt)
-                 (if alt vlist-null db*))))
-      (($ <seq> src head tail)
-       (let*-values (((head db*) (visit head db env 'effect)))
-         (cond
-          ((void? head)
-           (visit tail db env ctx))
-          (else
-           (let*-values (((tail db**) (visit tail (concat db* db) env ctx)))
-             (values (make-seq src head tail)
-                     (concat db** db*)))))))
-      (($ <prompt> src escape-only? tag body handler)
-       (let*-values (((tag db*) (visit tag db env 'value))
-                     ((body _) (visit body (concat db* db) env
-                                      (if escape-only? ctx 'value)))
-                     ((handler _) (visit handler (concat db* db) env 'value)))
-         (return (make-prompt src escape-only? tag body handler)
-                 db*)))
-      (($ <abort> src tag args tail)
-       (let*-values (((tag db*) (visit tag db env 'value))
-                     ((args db**) (parallel-visit args db env 'value))
-                     ((tail db***) (visit tail db env 'value)))
-         (return (make-abort src tag args tail)
-                 (concat db* (concat db** db***))))))))
diff --git a/module/language/tree-il/optimize.scm 
b/module/language/tree-il/optimize.scm
index 929f277..d5d4f43 100644
--- a/module/language/tree-il/optimize.scm
+++ b/module/language/tree-il/optimize.scm
@@ -22,7 +22,6 @@
   #:use-module (language tree-il)
   #:use-module (language tree-il primitives)
   #:use-module (language tree-il peval)
-  #:use-module (language tree-il cse)
   #:use-module (language tree-il fix-letrec)
   #:use-module (language tree-il debug)
   #:use-module (ice-9 match)
@@ -33,16 +32,8 @@
                  ((#:partial-eval? #f _ ...)
                   ;; Disable partial evaluation.
                   (lambda (x e) x))
-                 (_ peval)))
-        (cse (match (memq #:cse? opts)
-               ((#:cse? #t _ ...)
-                cse)
-               (_
-                ;; Disable Tree-IL CSE by default.
-                (lambda (x) x)))))
+                 (_ peval))))
     (fix-letrec
      (verify-tree-il
-      (cse
-       (verify-tree-il
-        (peval (expand-primitives (resolve-primitives x env))
-               env)))))))
+      (peval (expand-primitives (resolve-primitives x env))
+             env)))))


hooks/post-receive
-- 
GNU Guile



reply via email to

[Prev in Thread] Current Thread [Next in Thread]