mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-22 04:30:19 +02:00
Code Activity

Revert "Minor CSE run-time optimization"

Browse source 
Fixes <https://bugs.gnu.org/30020>.
Reported by David Thompson <dthompson2@worcester.edu>.

This reverts commit d4883307ca.
This commit is contained in:
Mark H Weaver 2018-05-28 02:11:46 -04:00
parent 1951edff58
commit df93752479
No known key found for this signature in database
GPG key ID: 7CEF29847562C516
1 changed files with 69 additions and 70 deletions
Download patch file Download diff file Expand all files Collapse all files

139
module/language/cps/cse.scm
View file

@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL) ;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; 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) (($ $call proc args) #f)
(($ $callk k proc args) #f) (($ $callk k proc args) #f)
(($ $primcall name args) (($ $primcall name args)
(cons* name (subst-vars var-substs args))) (cons* 'primcall name (subst-vars var-substs args)))
(($ $branch _ ($ $primcall name args)) (($ $branch _ ($ $primcall name args))
(cons* name (subst-vars var-substs args))) (cons* 'primcall name (subst-vars var-substs args)))
(($ $branch) #f) (($ $branch) #f)
(($ $values args) #f) (($ $values args) #f)
(($ $prompt escape? tag handler) #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 (hash-set! equiv-set aux-key
(acons label (list var) equiv)))) (acons label (list var) equiv))))
(match exp-key (match exp-key
(('box val) (('primcall 'box val)
(match defs (match defs
((box) ((box)
(add-def! `(primcall box-ref ,(subst box)) val)))) (add-def! `(primcall box-ref ,(subst box)) val))))
(('box-set! box val) (('primcall 'box-set! box val)
(add-def! `(primcall box-ref ,box) val)) (add-def! `(primcall box-ref ,box) val))
(('cons car cdr) (('primcall 'cons car cdr)
(match defs (match defs
((pair) ((pair)
(add-def! `(primcall car ,(subst pair)) car) (add-def! `(primcall car ,(subst pair)) car)
(add-def! `(primcall cdr ,(subst pair)) cdr)))) (add-def! `(primcall cdr ,(subst pair)) cdr))))
(('set-car! pair car) (('primcall 'set-car! pair car)
(add-def! `(primcall car ,pair) car)) (add-def! `(primcall car ,pair) car))
(('set-cdr! pair cdr) (('primcall 'set-cdr! pair cdr)
(add-def! `(primcall 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 (match defs
((vec) ((vec)
(add-def! `(primcall vector-length ,(subst vec)) len)))) (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)) (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)) (add-def! `(primcall vector-ref/immediate ,vec ,idx) val))
(((or 'allocate-struct 'allocate-struct/immediate) (('primcall (or 'allocate-struct 'allocate-struct/immediate)
vtable size) vtable size)
(match defs (match defs
((struct) ((struct)
(add-def! `(primcall struct-vtable ,(subst struct)) (add-def! `(primcall struct-vtable ,(subst struct))
vtable)))) vtable))))
(('struct-set! struct n val) (('primcall 'struct-set! struct n val)
(add-def! `(primcall struct-ref ,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)) (add-def! `(primcall struct-ref/immediate ,struct ,n) val))
(('scm->f64 scm) (('primcall 'scm->f64 scm)
(match defs (match defs
((f64) ((f64)
(add-def! `(primcall f64->scm ,f64) scm)))) (add-def! `(primcall f64->scm ,f64) scm))))
(('f64->scm f64) (('primcall 'f64->scm f64)
(match defs (match defs
((scm) ((scm)
(add-def! `(primcall scm->f64 ,scm) f64)))) (add-def! `(primcall scm->f64 ,scm) f64))))
(('scm->u64 scm) (('primcall 'scm->u64 scm)
(match defs (match defs
((u64) ((u64)
(add-def! `(primcall u64->scm ,u64) scm)))) (add-def! `(primcall u64->scm ,u64) scm))))
(('u64->scm u64) (('primcall 'u64->scm u64)
(match defs (match defs
((scm) ((scm)
(add-def! `(primcall scm->u64 ,scm) u64) (add-def! `(primcall scm->u64 ,scm) u64)
(add-def! `(primcall scm->u64/truncate ,scm) u64)))) (add-def! `(primcall scm->u64/truncate ,scm) u64))))
(('scm->s64 scm) (('primcall 'scm->s64 scm)
(match defs (match defs
((s64) ((s64)
(add-def! `(primcall s64->scm ,s64) scm)))) (add-def! `(primcall s64->scm ,s64) scm))))
(('s64->scm s64) (('primcall 's64->scm s64)
(match defs (match defs
((scm) ((scm)
(add-def! `(primcall scm->s64 ,scm) s64)))) (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) (define (visit-label label equiv-labels var-substs)
(match (intmap-ref conts label) (match (intmap-ref conts label)
(($ $kargs names vars ($ $continue k src exp)) (($ $kargs names vars ($ $continue k src exp))
(match (compute-exp-key var-substs exp) (let* ((exp-key (compute-exp-key var-substs exp))
(#f (values equiv-labels var-substs)) (equiv (hash-ref equiv-set exp-key '()))
(exp-key (fx (intmap-ref effects label))
(let* ((equiv (hash-ref equiv-set exp-key '())) (avail (intmap-ref avail label)))
(fx (intmap-ref effects label)) (define (finish equiv-labels var-substs)
(avail (intmap-ref avail label))) ;; If this expression defines auxiliary definitions,
(define (finish equiv-labels var-substs) ;; as `cons' does for the results of `car' and `cdr',
;; If this expression defines auxiliary definitions, ;; define those. Do so after finding equivalent
;; as `cons' does for the results of `car' and `cdr', ;; expressions, so that we can take advantage of
;; define those. Do so after finding equivalent ;; subst'd output vars.
;; expressions, so that we can take advantage of (add-auxiliary-definitions! label var-substs exp-key)
;; subst'd output vars. (values equiv-labels var-substs))
(add-auxiliary-definitions! label var-substs exp-key) (let lp ((candidates equiv))
(values equiv-labels var-substs)) (match candidates
(let lp ((candidates equiv)) (()
(match candidates ;; No matching expressions. Add our expression
(() ;; to the equivalence set, if appropriate. Note
;; No matching expressions. Add our expression ;; that expressions that allocate a fresh object
;; to the equivalence set, if appropriate. Note ;; or change the current fluid environment can't
;; that expressions that allocate a fresh object ;; be eliminated by CSE (though DCE might do it
;; or change the current fluid environment can't ;; if the value proves to be unused, in the
;; be eliminated by CSE (though DCE might do it ;; allocation case).
;; if the value proves to be unused, in the (when (and exp-key
;; allocation case). (not (causes-effect? fx &allocation))
(when (and (not (causes-effect? fx &allocation)) (not (effect-clobbers? fx (&read-object &fluid))))
(not (effect-clobbers? fx (&read-object &fluid)))) (let ((defs (and (intset-ref singly-referenced k)
(let ((defs (and (intset-ref singly-referenced k) (intmap-ref defs label))))
(intmap-ref defs label)))) (when defs
(when defs (hash-set! equiv-set exp-key
(hash-set! equiv-set exp-key (acons label defs equiv)))))
(acons label defs equiv))))) (finish equiv-labels var-substs))
(finish equiv-labels var-substs)) (((and head (candidate . vars)) . candidates)
(((and head (candidate . vars)) . candidates) (cond
(cond ((not (intset-ref avail candidate))
((not (intset-ref avail candidate)) ;; This expression isn't available here; try
;; This expression isn't available here; try ;; the next one.
;; the next one. (lp candidates))
(lp candidates)) (else
(else ;; Yay, a match. Mark expression as equivalent. If
;; Yay, a match. Mark expression as equivalent. If ;; we provide the definitions for the successor, mark
;; we provide the definitions for the successor, mark ;; the vars for substitution.
;; the vars for substitution. (finish (intmap-add equiv-labels label head)
(finish (intmap-add equiv-labels label head) (let ((defs (and (intset-ref singly-referenced k)
(let ((defs (and (intset-ref singly-referenced k) (intmap-ref defs label))))
(intmap-ref defs label)))) (if defs
(if defs (fold (lambda (def var var-substs)
(fold (lambda (def var var-substs) (intmap-add var-substs def var))
(intmap-add var-substs def var)) var-substs defs vars)
var-substs defs vars) var-substs))))))))))
var-substs))))))))))))
(_ (values equiv-labels var-substs)))) (_ (values equiv-labels var-substs))))
;; Traverse the labels in fun in reverse post-order, which will ;; Traverse the labels in fun in reverse post-order, which will