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-67-g5ded849


From: Andy Wingo
Subject: [Guile-commits] GNU Guile branch, master, updated. v2.1.0-67-g5ded849
Date: Thu, 03 Jul 2014 09:47:10 +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=5ded849813ade42854e06cfcc3b78c89ee96e03e

The branch, master has been updated
       via  5ded849813ade42854e06cfcc3b78c89ee96e03e (commit)
       via  7f6aafa5aefe686abbee73e0fefeafbd18a96dc0 (commit)
       via  4296c36ec8cf03ad3f338ac4be93c2fe39237457 (commit)
       via  e9808c14d73b8dbe8ef85b587de1e727065ca840 (commit)
       via  c1a41f96b46869fdaaef86686b8305f3167c8277 (commit)
       via  41296769c7bed829a0fc42d43d8a5516ff0263eb (commit)
      from  93e838423cba836fd90662f9acd362ddf3aa6fb1 (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 5ded849813ade42854e06cfcc3b78c89ee96e03e
Author: Andy Wingo <address@hidden>
Date:   Thu Jul 3 11:24:37 2014 +0200

    Convert slot allocation to use intsets
    
    * module/language/cps/dfg.scm (compute-live-variables): Convert to use
      intsets, and fold in compute-maximum-fixed-point.
      (print-dfa): Update.
    
    * module/language/cps/slot-allocation.scm (dead-after-def?)
      (dead-after-use?, allocate-slots): Convert to use intsets.

commit 7f6aafa5aefe686abbee73e0fefeafbd18a96dc0
Author: Andy Wingo <address@hidden>
Date:   Thu Jul 3 10:37:20 2014 +0200

    Add bitvector->intset.
    
    * module/language/cps/intset.scm (bitvector->intset): New interface.

commit 4296c36ec8cf03ad3f338ac4be93c2fe39237457
Author: Andy Wingo <address@hidden>
Date:   Thu Jul 3 09:37:30 2014 +0200

    Restrict intsets and maps to non-negative integers
    
    * module/language/cps/intmap.scm (intmap-add):
    * module/language/cps/intset.scm (intset-add): Restrict to only hold
      non-negative integers.

commit e9808c14d73b8dbe8ef85b587de1e727065ca840
Author: Andy Wingo <address@hidden>
Date:   Thu Jul 3 09:20:11 2014 +0200

    Adapt visit-prompt-control-flow to use intsets.
    
    * module/language/cps/dfg.scm (compute-reachable): Use intsets.
      (compute-interval): Adapt.
      (visit-prompt-control-flow): Adapt.

commit c1a41f96b46869fdaaef86686b8305f3167c8277
Author: Andy Wingo <address@hidden>
Date:   Thu Jul 3 09:03:45 2014 +0200

    CSE comments
    
    * module/language/cps/cse.scm (compute-available-expressions): Add
      clarifying comment.

commit 41296769c7bed829a0fc42d43d8a5516ff0263eb
Author: Andy Wingo <address@hidden>
Date:   Thu Jul 3 09:02:31 2014 +0200

    Add intset-subtract.
    
    * module/language/cps/intset.scm (intset-subtract): New interface.

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

Summary of changes:
 module/language/cps/cse.scm             |    4 +-
 module/language/cps/dfg.scm             |  194 +++++++++++++++----------------
 module/language/cps/intmap.scm          |    3 +
 module/language/cps/intset.scm          |  102 ++++++++++++++++-
 module/language/cps/slot-allocation.scm |   41 +++----
 5 files changed, 217 insertions(+), 127 deletions(-)

diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm
index 48cf922..ab48290 100644
--- a/module/language/cps/cse.scm
+++ b/module/language/cps/cse.scm
@@ -101,7 +101,9 @@ index corresponds to MIN-LABEL, and so on."
           ;; Fast-path if this expression clobbers nothing.
           in)
          (else
-          ;; Kill clobbered expressions.
+          ;; Kill clobbered expressions.  There is no need to check on
+          ;; any label before than the last dominating label that
+          ;; clobbered everything.
           (let ((first (let lp ((dom label))
                          (let* ((dom (vector-ref idoms (label->idx dom))))
                            (and (< min-label dom)
diff --git a/module/language/cps/dfg.scm b/module/language/cps/dfg.scm
index 6f18075..5b674e1 100644
--- a/module/language/cps/dfg.scm
+++ b/module/language/cps/dfg.scm
@@ -41,6 +41,7 @@
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-26)
   #:use-module (language cps)
+  #:use-module (language cps intset)
   #:export (build-cont-table
             lookup-cont
 
@@ -137,50 +138,41 @@
 
 (define (compute-reachable dfg min-label label-count)
   "Compute and return the continuations that may be reached if flow
-reaches a continuation N.  Returns a vector of bitvectors, whose first
+reaches a continuation N.  Returns a vector of intsets, whose first
 index corresponds to MIN-LABEL, and so on."
-  (let (;; Vector of bitvectors, indicating that continuation N can
+  (let (;; Vector of intsets, indicating that continuation N can
         ;; reach a set M...
         (reachable (make-vector label-count #f)))
 
     (define (label->idx label) (- label min-label))
 
-    ;; All continuations are reachable from themselves.
-    (let lp ((n 0))
-      (when (< n label-count)
-        (let ((bv (make-bitvector label-count #f)))
-          (bitvector-set! bv n #t)
-          (vector-set! reachable n bv)
-          (lp (1+ n)))))
-
     ;; Iterate labels backwards, to converge quickly.
-    (let ((tmp (make-bitvector label-count #f)))
-      (define (add-reachable! succ)
-        (bit-set*! tmp (vector-ref reachable (label->idx succ)) #t))
-      (let lp ((label (+ min-label label-count)) (changed? #f))
-        (cond
-         ((= label min-label)
-          (if changed?
-              (lp (+ min-label label-count) #f)
-              reachable))
-         (else
-          (let* ((label (1- label))
-                 (idx (label->idx label)))
-            (bitvector-fill! tmp #f)
-            (visit-cont-successors
-             (case-lambda
-               (() #t)
-               ((succ0) (add-reachable! succ0))
-               ((succ0 succ1) (add-reachable! succ0) (add-reachable! succ1)))
-             (lookup-cont label dfg))
-            (bitvector-set! tmp idx #t)
-            (bit-set*! tmp (vector-ref reachable idx) #f)
-            (cond
-             ((bit-position #t tmp 0)
-              (bit-set*! (vector-ref reachable idx) tmp #t)
-              (lp label #t))
-             (else
-              (lp label changed?))))))))))
+    (let lp ((label (+ min-label label-count)) (changed? #f))
+      (cond
+       ((= label min-label)
+        (if changed?
+            (lp (+ min-label label-count) #f)
+            reachable))
+       (else
+        (let* ((label (1- label))
+               (idx (label->idx label))
+               (old (vector-ref reachable idx))
+               (new (fold (lambda (succ set)
+                            (cond
+                             ((vector-ref reachable (label->idx succ))
+                              => (lambda (succ-set)
+                                   (intset-union set succ-set)))
+                             (else set)))
+                          (or (vector-ref reachable idx)
+                              (intset-add empty-intset label))
+                          (visit-cont-successors list
+                                                 (lookup-cont label dfg)))))
+          (cond
+           ((eq? old new)
+            (lp label changed?))
+           (else
+            (vector-set! reachable idx new)
+            (lp label #t)))))))))
 
 (define (find-prompts dfg min-label label-count)
   "Find the prompts in DFG between MIN-LABEL and MIN-LABEL +
@@ -201,19 +193,17 @@ pairs."
 
 (define (compute-interval reachable min-label label-count start end)
   "Compute and return the set of continuations that may be reached from
-START, inclusive, but not reached by END, exclusive.  Returns a
-bitvector."
-  (let ((body (make-bitvector label-count #f)))
-    (bit-set*! body (vector-ref reachable (- start min-label)) #t)
-    (bit-set*! body (vector-ref reachable (- end min-label)) #f)
-    body))
+START, inclusive, but not reached by END, exclusive.  Returns an
+intset."
+  (intset-subtract (vector-ref reachable (- start min-label))
+                   (vector-ref reachable (- end min-label))))
 
 (define (find-prompt-bodies dfg min-label label-count)
   "Find all the prompts in DFG from the LABEL-COUNT continuations
 starting at MIN-LABEL, and compute the set of continuations that is
 reachable from the prompt bodies but not from the corresponding handler.
-Returns a list of PROMPT, HANDLER, BODY lists, where the BODY is a
-bitvector."
+Returns a list of PROMPT, HANDLER, BODY lists, where the BODY is an
+intset."
   (match (find-prompts dfg min-label label-count)
     (() '())
     (((prompt . handler) ...)
@@ -246,7 +236,7 @@ body continuation in the prompt."
   (for-each
    (match-lambda
     ((prompt handler body)
-     (define (out-or-back-edge? n)
+     (define (out-or-back-edge? label)
        ;; Most uses of visit-prompt-control-flow don't need every body
        ;; continuation, and would be happy getting called only for
        ;; continuations that postdominate the rest of the body.  Unless
@@ -259,16 +249,15 @@ body continuation in the prompt."
        ;; not continue to the pop if it never terminates.  The pop could
        ;; even be removed by DCE, in that case.
        (or-map (lambda (succ)
-                 (let ((succ (label->idx succ)))
-                   (or (not (bitvector-ref body succ))
-                       (<= succ n))))
-               (lookup-successors (idx->label n) dfg)))
-     (let lp ((n 0))
-       (let ((n (bit-position #t body n)))
-         (when n
-           (when (or complete? (out-or-back-edge? n))
-             (f prompt handler (idx->label n)))
-           (lp (1+ n)))))))
+                 (or (not (intset-ref body succ))
+                     (<= succ label)))
+               (lookup-successors label dfg)))
+     (let lp ((label min-label))
+       (let ((label (intset-next body label)))
+         (when label
+           (when (or complete? (out-or-back-edge? label))
+             (f prompt handler label))
+           (lp (1+ label)))))))
    (find-prompt-bodies dfg min-label label-count)))
 
 (define (analyze-reverse-control-flow fun dfg min-label label-count)
@@ -406,41 +395,6 @@ body continuation in the prompt."
 ;; We'll need it again eventually but for now it can be found in the git
 ;; history.
 
-;; Compute the maximum fixed point of the data-flow constraint problem.
-;;
-;; This always completes, as the graph is finite and the in and out sets
-;; are complete semi-lattices.  If the graph is reducible and the blocks
-;; are sorted in reverse post-order, this completes in a maximum of LC +
-;; 2 iterations, where LC is the loop connectedness number.  See Hecht
-;; and Ullman, "Analysis of a simple algorithm for global flow
-;; problems", POPL 1973, or the recent summary in "Notes on graph
-;; algorithms used in optimizing compilers", Offner 2013.
-(define (compute-maximum-fixed-point preds inv outv killv genv union?)
-  (define (bitvector-copy! dst src)
-    (bitvector-fill! dst #f)
-    (bit-set*! dst src #t))
-  (define (bitvector-meet! accum src)
-    (bit-set*! accum src union?))
-  (let lp ((n 0) (changed? #f))
-    (cond
-     ((< n (vector-length preds))
-      (let ((in (vector-ref inv n))
-            (out (vector-ref outv n))
-            (kill (vector-ref killv n))
-            (gen (vector-ref genv n)))
-        (let ((out-count (or changed? (bit-count #t out))))
-          (for-each
-           (lambda (pred)
-             (bitvector-meet! in (vector-ref outv pred)))
-           (vector-ref preds n))
-          (bitvector-copy! out in)
-          (for-each (cut bitvector-set! out <> #f) kill)
-          (for-each (cut bitvector-set! out <> #t) gen)
-          (lp (1+ n)
-              (or changed? (not (eqv? out-count (bit-count #t out))))))))
-     (changed?
-      (lp 0 #f)))))
-
 ;; Data-flow analysis.
 (define-record-type $dfa
   (make-dfa min-label min-var var-count in out)
@@ -451,9 +405,9 @@ body continuation in the prompt."
   (min-var dfa-min-var)
   ;; Var count in this function.
   (var-count dfa-var-count)
-  ;; Vector of k-idx -> bitvector
+  ;; Vector of k-idx -> intset
   (in dfa-in)
-  ;; Vector of k-idx -> bitvector
+  ;; Vector of k-idx -> intset
   (out dfa-out))
 
 (define (dfa-k-idx dfa k)
@@ -483,6 +437,49 @@ body continuation in the prompt."
   (vector-ref (dfa-out dfa) idx))
 
 (define (compute-live-variables fun dfg)
+  ;; Compute the maximum fixed point of the data-flow constraint problem.
+  ;;
+  ;; This always completes, as the graph is finite and the in and out sets
+  ;; are complete semi-lattices.  If the graph is reducible and the blocks
+  ;; are sorted in reverse post-order, this completes in a maximum of LC +
+  ;; 2 iterations, where LC is the loop connectedness number.  See Hecht
+  ;; and Ullman, "Analysis of a simple algorithm for global flow
+  ;; problems", POPL 1973, or the recent summary in "Notes on graph
+  ;; algorithms used in optimizing compilers", Offner 2013.
+  (define (compute-maximum-fixed-point preds inv outv killv genv)
+    (define (fold f seed l)
+      (if (null? l) seed (fold f (f (car l) seed) (cdr l))))
+    (let lp ((n 0) (changed? #f))
+      (cond
+       ((< n (vector-length preds))
+        (let* ((in (vector-ref inv n))
+               (in* (or
+                     (fold (lambda (pred set)
+                             (cond
+                              ((vector-ref outv pred)
+                               => (lambda (out)
+                                    (if set
+                                        (intset-union set out)
+                                        out)))
+                              (else set)))
+                           in
+                           (vector-ref preds n))
+                     empty-intset)))
+          (if (eq? in in*)
+              (lp (1+ n) changed?)
+              (let ((out* (fold (lambda (gen set)
+                                  (intset-add set gen))
+                                (fold (lambda (kill set)
+                                        (intset-remove set kill))
+                                      in*
+                                      (vector-ref killv n))
+                                (vector-ref genv n))))
+                (vector-set! inv n in*)
+                (vector-set! outv n out*)
+                (lp (1+ n) #t)))))
+       (changed?
+        (lp 0 #f)))))
+
   (unless (and (= (vector-length (dfg-uses dfg)) (dfg-var-count dfg))
                (= (vector-length (dfg-cont-table dfg)) (dfg-label-count dfg)))
     (error "function needs renumbering"))
@@ -519,18 +516,11 @@ body continuation in the prompt."
                           (vector-ref uses n))
                 (lp (1+ n))))))
 
-        ;; Initialize live-in and live-out sets.
-        (let lp ((n 0))
-          (when (< n (vector-length live-out))
-            (vector-set! live-in n (make-bitvector nvars #f))
-            (vector-set! live-out n (make-bitvector nvars #f))
-            (lp (1+ n))))
-
         ;; Liveness is a reverse data-flow problem, so we give
         ;; compute-maximum-fixed-point a reversed graph, swapping in for
         ;; out, usev for defv, and using successors instead of
         ;; predecessors.  Continuation 0 is ktail.
-        (compute-maximum-fixed-point succs live-out live-in defv usev #t)
+        (compute-maximum-fixed-point succs live-out live-in defv usev)
 
         ;; Now rewrite the live-in and live-out sets to be indexed by
         ;; (LABEL - MIN-LABEL).
@@ -550,7 +540,7 @@ body continuation in the prompt."
     (($ $dfa min-label min-var var-count in out)
      (define (print-var-set bv)
        (let lp ((n 0))
-         (let ((n (bit-position #t bv n)))
+         (let ((n (intset-next bv n)))
            (when n
              (format #t " ~A" (+ n min-var))
              (lp (1+ n))))))
diff --git a/module/language/cps/intmap.scm b/module/language/cps/intmap.scm
index 7be27c9..152985a 100644
--- a/module/language/cps/intmap.scm
+++ b/module/language/cps/intmap.scm
@@ -121,6 +121,9 @@
   (match bs
     (($ <intmap> min shift root)
      (cond
+      ((< i 0)
+       ;; The power-of-two spanning trick doesn't work across 0.
+       (error "Intmaps can only map non-negative integers." i))
       ((not val) (intmap-remove bs i))
       ((not root)
        ;; Add first element.
diff --git a/module/language/cps/intset.scm b/module/language/cps/intset.scm
index e8e6df2..8607471 100644
--- a/module/language/cps/intset.scm
+++ b/module/language/cps/intset.scm
@@ -35,7 +35,9 @@
             intset-ref
             intset-next
             intset-union
-            intset-intersect))
+            intset-intersect
+            intset-subtract
+            bitvector->intset))
 
 (define-syntax-rule (define-inline name val)
   (define-syntax name (identifier-syntax val)))
@@ -151,6 +153,9 @@
   (match bs
     (($ <intset> min shift root)
      (cond
+      ((< i 0)
+       ;; The power-of-two spanning trick doesn't work across 0.
+       (error "Intsets can only hold non-negative integers." i))
       ((not root)
        ;; Add first element.
        (let ((min (round-down i shift)))
@@ -454,3 +459,98 @@
           ((eq? root a-root) a)
           ((eq? root b-root) b)
           (else (make-intset/prune a-min a-shift root)))))))))
+
+(define (intset-subtract a b)
+  (define tmp (new-leaf))
+  ;; Intersect leaves.
+  (define (subtract-leaves a b)
+    (logand a (lognot b)))
+  ;; Subtract B from A starting at index I; the result will be fresh.
+  (define (subtract-branches/fresh shift a b i fresh)
+    (let lp ((i 0))
+      (cond
+       ((< i *branch-size*)
+        (let* ((a-child (vector-ref a i))
+               (b-child (vector-ref b i)))
+          (vector-set! fresh i (subtract-nodes shift a-child b-child))
+          (lp (1+ i))))
+       ((branch-empty? fresh) #f)
+       (else fresh))))
+  ;; Subtract B from A.  The result may be eq? to A.
+  (define (subtract-branches shift a b)
+    (let lp ((i 0))
+      (cond
+       ((< i *branch-size*)
+        (let* ((a-child (vector-ref a i))
+               (b-child (vector-ref b i)))
+          (let ((child (subtract-nodes shift a-child b-child)))
+            (cond
+             ((eq? a-child child)
+              (lp (1+ i)))
+             (else
+              (let ((result (clone-branch-and-set a i child)))
+                (subtract-branches/fresh shift a b (1+ i) result)))))))
+       (else a))))
+  (define (subtract-nodes shift a-node b-node)
+    (cond
+     ((or (not a-node) (not b-node)) a-node)
+     ((eq? a-node b-node) #f)
+     ((= shift *leaf-bits*) (subtract-leaves a-node b-node))
+     (else (subtract-branches (- shift *branch-bits*) a-node b-node))))
+
+  (match (cons a b)
+    ((($ <intset> a-min a-shift a-root) . ($ <intset> b-min b-shift b-root))
+     (define (return root)
+       (cond
+        ((eq? root a-root) a)
+        (else (make-intset/prune a-min a-shift root))))
+     (cond
+      ((<= a-shift b-shift)
+       (let lp ((b-min b-min) (b-shift b-shift) (b-root b-root))
+         (if (= a-shift b-shift)
+             (if (= a-min b-min)
+                 (return (subtract-nodes a-shift a-root b-root))
+                 a)
+             (let* ((b-shift (- b-shift *branch-bits*))
+                    (b-idx (ash (- a-min b-min) (- b-shift)))
+                    (b-min (+ b-min (ash b-idx b-shift)))
+                    (b-root (and b-root
+                                 (<= 0 b-idx)
+                                 (< b-idx *branch-size*)
+                                 (vector-ref b-root b-idx))))
+               (lp b-min b-shift b-root)))))
+      (else
+       (return
+        (let lp ((a-min a-min) (a-shift a-shift) (a-root a-root))
+          (if (= a-shift b-shift)
+              (if (= a-min b-min)
+                  (subtract-nodes a-shift a-root b-root)
+                  a-root)
+              (let* ((a-shift (- a-shift *branch-bits*))
+                     (a-idx (ash (- b-min a-min) (- a-shift)))
+                     (a-min (+ a-min (ash a-idx a-shift)))
+                     (old (and a-root
+                               (<= 0 a-idx)
+                               (< a-idx *branch-size*)
+                               (vector-ref a-root a-idx)))
+                     (new (lp a-min a-shift old)))
+                (if (eq? old new)
+                    a-root
+                    (clone-branch-and-set a-root a-idx new)))))))))))
+
+(define (bitvector->intset bv)
+  (define (finish-tail out min tail)
+    (if (zero? tail)
+        out
+        (intset-union out (make-intset min *leaf-bits* tail))))
+  (let lp ((out empty-intset) (min 0) (pos 0) (tail 0))
+    (let ((pos (bit-position #t bv pos)))
+      (cond
+       ((not pos)
+        (finish-tail out min tail))
+       ((< pos (+ min *leaf-size*))
+        (lp out min (1+ pos) (logior tail (ash 1 (- pos min)))))
+       (else
+        (let ((min* (round-down pos *leaf-bits*)))
+          (lp (finish-tail out min tail)
+              min* pos (ash 1 (- pos min*)))))))))
diff --git a/module/language/cps/slot-allocation.scm 
b/module/language/cps/slot-allocation.scm
index 6ba3054..92b6e02 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -29,6 +29,7 @@
   #:use-module (srfi srfi-26)
   #:use-module (language cps)
   #:use-module (language cps dfg)
+  #:use-module (language cps intset)
   #:export (allocate-slots
             lookup-slot
             lookup-maybe-slot
@@ -224,10 +225,10 @@ are comparable with eqv?.  A tmp slot may be used."
                       (loop to-move b (cons s+d moved) last-source))))))))))
 
 (define (dead-after-def? k-idx v-idx dfa)
-  (not (bitvector-ref (dfa-k-in dfa k-idx) v-idx)))
+  (not (intset-ref (dfa-k-in dfa k-idx) v-idx)))
 
 (define (dead-after-use? k-idx v-idx dfa)
-  (not (bitvector-ref (dfa-k-out dfa k-idx) v-idx)))
+  (not (intset-ref (dfa-k-out dfa k-idx) v-idx)))
 
 (define (allocate-slots fun dfg)
   (let* ((dfa (compute-live-variables fun dfg))
@@ -283,7 +284,7 @@ are comparable with eqv?.  A tmp slot may be used."
     (define (recompute-live-slots k nargs)
       (let ((in (dfa-k-in dfa (label->idx k))))
         (let lp ((v 0) (live-slots 0))
-          (let ((v (bit-position #t in v)))
+          (let ((v (intset-next in v)))
             (if v
                 (let ((slot (vector-ref slots v)))
                   (lp (1+ v)
@@ -419,6 +420,8 @@ are comparable with eqv?.  A tmp slot may be used."
         (dfa-k-in dfa n))
       (define (live-after n)
         (dfa-k-out dfa n))
+      (define needs-slot
+        (bitvector->intset needs-slotv))
 
       ;; Walk backwards.  At a call, compute the set of variables that
       ;; have allocated slots and are live before but not after.  This
@@ -429,12 +432,10 @@ are comparable with eqv?.  A tmp slot may be used."
             (($ $kargs names syms body)
              (match (find-expression body)
                ((or ($ $call) ($ $callk))
-                (let ((args (make-bitvector (bitvector-length needs-slotv) 
#f)))
-                  (bit-set*! args (live-before n) #t)
-                  (bit-set*! args (live-after n) #f)
-                  (bit-set*! args no-slot-needed #f)
-                  (if (bit-position #t args 0)
-                      (scan-for-hints (1- n) args)
+                (let* ((args (intset-subtract (live-before n) (live-after n)))
+                       (args-needing-slots (intset-intersect args needs-slot)))
+                  (if (intset-next args-needing-slots #f)
+                      (scan-for-hints (1- n) args-needing-slots)
                       (scan-for-call (1- n)))))
                (_ (scan-for-call (1- n)))))
             (_ (scan-for-call (1- n))))))
@@ -458,11 +459,8 @@ are comparable with eqv?.  A tmp slot may be used."
                        ;; assumptions that slots not allocated are not
                        ;; used.
                        ($ $values (or () (_))))
-                   (let ((dead (make-bitvector (bitvector-length args) #f)))
-                     (bit-set*! dead (live-before n) #t)
-                     (bit-set*! dead (live-after n) #f)
-                     (bit-set*! dead no-slot-needed #f)
-                     (if (bit-position #t dead 0)
+                   (let ((killed (intset-subtract (live-before n) (live-after 
n))))
+                     (if (intset-next (intset-intersect killed needs-slot) #f)
                          (finish-hints n (live-before n) args)
                          (scan-for-hints (1- n) args))))
                   ((or ($ $call) ($ $callk) ($ $values) ($ $branch))
@@ -474,17 +472,14 @@ are comparable with eqv?.  A tmp slot may be used."
       ;; Add definitions ARGS minus KILL to NEED-HINTS, and go back to
       ;; looking for calls.
       (define (finish-hints n kill args)
-        (bit-invert! args)
-        (bit-set*! args kill #t)
-        (bit-invert! args)
-        (bit-set*! needs-hintv args #t)
+        (let ((new-hints (intset-subtract args kill)))
+          (let lp ((n 0))
+            (let ((n (intset-next new-hints n)))
+              (when n
+                (bitvector-set! needs-hintv n #t)
+                (lp (1+ n))))))
         (scan-for-call n))
 
-      (define no-slot-needed
-        (make-bitvector (bitvector-length needs-slotv) #f))
-
-      (bit-set*! no-slot-needed needs-slotv #t)
-      (bit-invert! no-slot-needed)
       (scan-for-call (1- label-count)))
 
     (define (allocate-call label k uses pre-live post-live)


hooks/post-receive
-- 
GNU Guile



reply via email to

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