[Guile-commits] 02/02: Improve handle-interrupts placement

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 0ce8a9a5e01d3a12d83fea85968e1abb602c9298
Author: Andy Wingo <address@hidden>
Date:   Sun Dec 18 23:00:07 2016 +0100

    Improve handle-interrupts placement
    
    * module/language/cps/handle-interrupts.scm (compute-safepoints): New
      function.
      (add-handle-interrupts): Add safepoints at backedge targets, not
      backedges.  Gives better register allocation, loop rotation, and code
      size.
---
 module/language/cps/handle-interrupts.scm |   53 +++++++++++++++++------------
 1 file changed, 32 insertions(+), 21 deletions(-)

diff --git a/module/language/cps/handle-interrupts.scm 
b/module/language/cps/handle-interrupts.scm
index e686ceb..55d25f2 100644
--- a/module/language/cps/handle-interrupts.scm
+++ b/module/language/cps/handle-interrupts.scm
@@ -29,30 +29,41 @@
   #:use-module (language cps utils)
   #:use-module (language cps with-cps)
   #:use-module (language cps intmap)
+  #:use-module (language cps intset)
   #:use-module (language cps renumber)
   #:export (add-handle-interrupts))
 
-(define (add-handle-interrupts cps)
-  (define (visit-cont label cont cps)
+(define (compute-safepoints cps)
+  (define (visit-cont label cont safepoints)
     (match cont
       (($ $kargs names vars ($ $continue k src exp))
-       (if (or (<= k label)
-               (match exp
-                 (($ $call) #t)
-                 (($ $callk) #t)
-                 (($ $values)
-                  (match (intmap-ref cps k)
-                    (($ $ktail) #t)
-                    (_ #f)))
-                 (_ #f)))
-           (with-cps cps
-             (letk k* ($kargs () () ($continue k src ,exp)))
-             (setk label
-                   ($kargs names vars
-                     ($continue k* src
-                       ($primcall 'handle-interrupts ())))))
-           cps))
-      (_ cps)))
-  (let ((cps (renumber cps)))
+       (let ((safepoints (if (<= k label)
+                             (intset-add! safepoints k)
+                             safepoints)))
+         (if (match exp
+               (($ $call) #t)
+               (($ $callk) #t)
+               (($ $values)
+                (match (intmap-ref cps k)
+                  (($ $ktail) #t)
+                  (_ #f)))
+               (_ #f))
+             (intset-add! safepoints label)
+             safepoints)))
+      (_ safepoints)))
+  (persistent-intset (intmap-fold visit-cont cps empty-intset)))
+
+(define (add-handle-interrupts cps)
+  (define (add-safepoint label cps)
+    (match (intmap-ref cps label)
+      (($ $kargs names vars ($ $continue k src exp))
+       (with-cps cps
+         (letk k* ($kargs () () ($continue k src ,exp)))
+         (setk label
+               ($kargs names vars
+                 ($continue k* src
+                   ($primcall 'handle-interrupts ()))))))))
+  (let* ((cps (renumber cps))
+         (safepoints (compute-safepoints cps)))
     (with-fresh-name-state cps
-      (persistent-intmap (intmap-fold visit-cont cps cps)))))
+      (persistent-intmap (intset-fold add-safepoint safepoints cps)))))