[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 02/02: Improve handle-interrupts placement
From: |
Andy Wingo |
Subject: |
[Guile-commits] 02/02: Improve handle-interrupts placement |
Date: |
Sun, 18 Dec 2016 22:06:39 +0000 (UTC) |
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)))))