[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 02/08: Revert "Minor CSE run-time optimization"
From: |
Mark H. Weaver |
Subject: |
[Guile-commits] 02/08: Revert "Minor CSE run-time optimization" |
Date: |
Mon, 11 Jun 2018 10:22:23 -0400 (EDT) |
mhw pushed a commit to branch stable-2.2
in repository guile.
commit df93752479ab88446f5db4b1d6ebf53a85c7593f
Author: Mark H Weaver <address@hidden>
Date: Mon May 28 02:11:46 2018 -0400
Revert "Minor CSE run-time optimization"
Fixes <https://bugs.gnu.org/30020>.
Reported by David Thompson <address@hidden>.
This reverts commit d4883307ca64a7028b9a6cd072974437306c19d3.
---
module/language/cps/cse.scm | 139 ++++++++++++++++++++++----------------------
1 file changed, 69 insertions(+), 70 deletions(-)
diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm
index dc67f42..a7a7713 100644
--- a/module/language/cps/cse.scm
+++ b/module/language/cps/cse.scm
@@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
-;; Copyright (C) 2013, 2014, 2015, 2017 Free Software Foundation, Inc.
+;; Copyright (C) 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
@@ -209,9 +209,9 @@ false. It could be that both true and false proofs are
available."
(($ $call proc args) #f)
(($ $callk k proc args) #f)
(($ $primcall name args)
- (cons* name (subst-vars var-substs args)))
+ (cons* 'primcall name (subst-vars var-substs args)))
(($ $branch _ ($ $primcall name args))
- (cons* name (subst-vars var-substs args)))
+ (cons* 'primcall name (subst-vars var-substs args)))
(($ $branch) #f)
(($ $values args) #f)
(($ $prompt escape? tag handler) #f)))
@@ -225,61 +225,61 @@ false. It could be that both true and false proofs are
available."
(hash-set! equiv-set aux-key
(acons label (list var) equiv))))
(match exp-key
- (('box val)
+ (('primcall 'box val)
(match defs
((box)
(add-def! `(primcall box-ref ,(subst box)) val))))
- (('box-set! box val)
+ (('primcall 'box-set! box val)
(add-def! `(primcall box-ref ,box) val))
- (('cons car cdr)
+ (('primcall 'cons car cdr)
(match defs
((pair)
(add-def! `(primcall car ,(subst pair)) car)
(add-def! `(primcall cdr ,(subst pair)) cdr))))
- (('set-car! pair car)
+ (('primcall 'set-car! pair car)
(add-def! `(primcall car ,pair) car))
- (('set-cdr! pair cdr)
+ (('primcall 'set-cdr! pair cdr)
(add-def! `(primcall cdr ,pair) cdr))
- (((or 'make-vector 'make-vector/immediate) len fill)
+ (('primcall (or 'make-vector 'make-vector/immediate) len fill)
(match defs
((vec)
(add-def! `(primcall vector-length ,(subst vec)) len))))
- (('vector-set! vec idx val)
+ (('primcall 'vector-set! vec idx val)
(add-def! `(primcall vector-ref ,vec ,idx) val))
- (('vector-set!/immediate vec idx val)
+ (('primcall 'vector-set!/immediate vec idx val)
(add-def! `(primcall vector-ref/immediate ,vec ,idx) val))
- (((or 'allocate-struct 'allocate-struct/immediate)
+ (('primcall (or 'allocate-struct 'allocate-struct/immediate)
vtable size)
(match defs
((struct)
(add-def! `(primcall struct-vtable ,(subst struct))
vtable))))
- (('struct-set! struct n val)
+ (('primcall 'struct-set! struct n val)
(add-def! `(primcall struct-ref ,struct ,n) val))
- (('struct-set!/immediate struct n val)
+ (('primcall 'struct-set!/immediate struct n val)
(add-def! `(primcall struct-ref/immediate ,struct ,n) val))
- (('scm->f64 scm)
+ (('primcall 'scm->f64 scm)
(match defs
((f64)
(add-def! `(primcall f64->scm ,f64) scm))))
- (('f64->scm f64)
+ (('primcall 'f64->scm f64)
(match defs
((scm)
(add-def! `(primcall scm->f64 ,scm) f64))))
- (('scm->u64 scm)
+ (('primcall 'scm->u64 scm)
(match defs
((u64)
(add-def! `(primcall u64->scm ,u64) scm))))
- (('u64->scm u64)
+ (('primcall 'u64->scm u64)
(match defs
((scm)
(add-def! `(primcall scm->u64 ,scm) u64)
(add-def! `(primcall scm->u64/truncate ,scm) u64))))
- (('scm->s64 scm)
+ (('primcall 'scm->s64 scm)
(match defs
((s64)
(add-def! `(primcall s64->scm ,s64) scm))))
- (('s64->scm s64)
+ (('primcall 's64->scm s64)
(match defs
((scm)
(add-def! `(primcall scm->s64 ,scm) s64))))
@@ -288,56 +288,55 @@ false. It could be that both true and false proofs are
available."
(define (visit-label label equiv-labels var-substs)
(match (intmap-ref conts label)
(($ $kargs names vars ($ $continue k src exp))
- (match (compute-exp-key var-substs exp)
- (#f (values equiv-labels var-substs))
- (exp-key
- (let* ((equiv (hash-ref equiv-set exp-key '()))
- (fx (intmap-ref effects label))
- (avail (intmap-ref avail label)))
- (define (finish equiv-labels var-substs)
- ;; If this expression defines auxiliary definitions,
- ;; as `cons' does for the results of `car' and `cdr',
- ;; define those. Do so after finding equivalent
- ;; expressions, so that we can take advantage of
- ;; subst'd output vars.
- (add-auxiliary-definitions! label var-substs exp-key)
- (values equiv-labels var-substs))
- (let lp ((candidates equiv))
- (match candidates
- (()
- ;; No matching expressions. Add our expression
- ;; to the equivalence set, if appropriate. Note
- ;; that expressions that allocate a fresh object
- ;; or change the current fluid environment can't
- ;; be eliminated by CSE (though DCE might do it
- ;; if the value proves to be unused, in the
- ;; allocation case).
- (when (and (not (causes-effect? fx &allocation))
- (not (effect-clobbers? fx (&read-object
&fluid))))
- (let ((defs (and (intset-ref singly-referenced k)
- (intmap-ref defs label))))
- (when defs
- (hash-set! equiv-set exp-key
- (acons label defs equiv)))))
- (finish equiv-labels var-substs))
- (((and head (candidate . vars)) . candidates)
- (cond
- ((not (intset-ref avail candidate))
- ;; This expression isn't available here; try
- ;; the next one.
- (lp candidates))
- (else
- ;; Yay, a match. Mark expression as equivalent. If
- ;; we provide the definitions for the successor, mark
- ;; the vars for substitution.
- (finish (intmap-add equiv-labels label head)
- (let ((defs (and (intset-ref singly-referenced
k)
- (intmap-ref defs label))))
- (if defs
- (fold (lambda (def var var-substs)
- (intmap-add var-substs def var))
- var-substs defs vars)
- var-substs))))))))))))
+ (let* ((exp-key (compute-exp-key var-substs exp))
+ (equiv (hash-ref equiv-set exp-key '()))
+ (fx (intmap-ref effects label))
+ (avail (intmap-ref avail label)))
+ (define (finish equiv-labels var-substs)
+ ;; If this expression defines auxiliary definitions,
+ ;; as `cons' does for the results of `car' and `cdr',
+ ;; define those. Do so after finding equivalent
+ ;; expressions, so that we can take advantage of
+ ;; subst'd output vars.
+ (add-auxiliary-definitions! label var-substs exp-key)
+ (values equiv-labels var-substs))
+ (let lp ((candidates equiv))
+ (match candidates
+ (()
+ ;; No matching expressions. Add our expression
+ ;; to the equivalence set, if appropriate. Note
+ ;; that expressions that allocate a fresh object
+ ;; or change the current fluid environment can't
+ ;; be eliminated by CSE (though DCE might do it
+ ;; if the value proves to be unused, in the
+ ;; allocation case).
+ (when (and exp-key
+ (not (causes-effect? fx &allocation))
+ (not (effect-clobbers? fx (&read-object &fluid))))
+ (let ((defs (and (intset-ref singly-referenced k)
+ (intmap-ref defs label))))
+ (when defs
+ (hash-set! equiv-set exp-key
+ (acons label defs equiv)))))
+ (finish equiv-labels var-substs))
+ (((and head (candidate . vars)) . candidates)
+ (cond
+ ((not (intset-ref avail candidate))
+ ;; This expression isn't available here; try
+ ;; the next one.
+ (lp candidates))
+ (else
+ ;; Yay, a match. Mark expression as equivalent. If
+ ;; we provide the definitions for the successor, mark
+ ;; the vars for substitution.
+ (finish (intmap-add equiv-labels label head)
+ (let ((defs (and (intset-ref singly-referenced k)
+ (intmap-ref defs label))))
+ (if defs
+ (fold (lambda (def var var-substs)
+ (intmap-add var-substs def var))
+ var-substs defs vars)
+ var-substs))))))))))
(_ (values equiv-labels var-substs))))
;; Traverse the labels in fun in reverse post-order, which will
- [Guile-commits] branch stable-2.2 updated (9a72e21 -> ac9f083), Mark H. Weaver, 2018/06/11
- [Guile-commits] 01/08: Fix typo in comment within numbers.c, Mark H. Weaver, 2018/06/11
- [Guile-commits] 05/08: goops: Fix 'instance?' to work on objects that aren't structs., Mark H. Weaver, 2018/06/11
- [Guile-commits] 06/08: Fix error reporting in 'load-thunk-from-memory'., Mark H. Weaver, 2018/06/11
- [Guile-commits] 02/08: Revert "Minor CSE run-time optimization",
Mark H. Weaver <=
- [Guile-commits] 08/08: Add copyright header for (language elisp falias), and fix typo., Mark H. Weaver, 2018/06/11
- [Guile-commits] 07/08: elisp: Fix cross-compilation support., Mark H. Weaver, 2018/06/11
- [Guile-commits] 03/08: Fix type inference for bitwise logical operators., Mark H. Weaver, 2018/06/11
- [Guile-commits] 04/08: Avoid inexact arithmetic in the type inferrer for 'sqrt'., Mark H. Weaver, 2018/06/11