[Guile-commits] 01/02: Add handle-interrupts inst and compiler pass

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit ca74e3fae52dd23f8e8f12194d07041e207f68e7
Author: Andy Wingo <address@hidden>
Date:   Wed Nov 16 22:37:54 2016 +0100

    Add handle-interrupts inst and compiler pass
    
    * libguile/vm-engine.c (vm_engine): Remove initial VM_HANDLE_INTERRUPTS
      call; surely our caller already handled interrupts.  Add
      handle-interrupts opcode.
    * am/bootstrap.am (SOURCES):
    * module/Makefile.am (SOURCES): Add handle-interrupts.scm.
    * module/system/vm/assembler.scm (system):
    * module/language/cps/compile-bytecode.scm (compile-function):
      (lower-cps): Add handle-interrupts support.
    * module/language/cps/handle-interrupts.scm: New file.
---
 am/bootstrap.am                           |    1 +
 libguile/vm-engine.c                      |   13 +++++--
 module/Makefile.am                        |    1 +
 module/language/cps/compile-bytecode.scm  |    6 ++-
 module/language/cps/handle-interrupts.scm |   58 +++++++++++++++++++++++++++++
 module/system/vm/assembler.scm            |    1 +
 6 files changed, 76 insertions(+), 4 deletions(-)

diff --git a/am/bootstrap.am b/am/bootstrap.am
index d5f25ab..e0d4764 100644
--- a/am/bootstrap.am
+++ b/am/bootstrap.am
@@ -81,6 +81,7 @@ SOURCES =                                     \
   language/cps/dce.scm                         \
   language/cps/effects-analysis.scm            \
   language/cps/elide-values.scm                        \
+  language/cps/handle-interrupts.scm           \
   language/cps/licm.scm                                \
   language/cps/peel-loops.scm                  \
   language/cps/primitives.scm                  \
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 4f66b9e..4de1971 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -511,8 +511,6 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
   /* Load VM registers. */
   CACHE_REGISTER ();
 
-  VM_HANDLE_INTERRUPTS;
-
   /* Usually a call to the VM happens on application, with the boot
      continuation on the next frame.  Sometimes it happens after a
      non-local exit however; in that case the VM state is all set up,
@@ -3922,7 +3920,16 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
       NEXT (3);
     }
 
-  VM_DEFINE_OP (183, unused_183, NULL, NOP)
+  /* handle-interrupts _:24
+   *
+   * Handle pending interrupts.
+   */
+  VM_DEFINE_OP (183, handle_interrupts, "handle-interrupts", OP1 (X32))
+    {
+      VM_HANDLE_INTERRUPTS;
+      NEXT (1);
+    }
+
   VM_DEFINE_OP (184, unused_184, NULL, NOP)
   VM_DEFINE_OP (185, unused_185, NULL, NOP)
   VM_DEFINE_OP (186, unused_186, NULL, NOP)
diff --git a/module/Makefile.am b/module/Makefile.am
index 0d1f128..67f041d 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -138,6 +138,7 @@ SOURCES =                                   \
   language/cps/dce.scm                         \
   language/cps/effects-analysis.scm            \
   language/cps/elide-values.scm                        \
+  language/cps/handle-interrupts.scm           \
   language/cps/intmap.scm                      \
   language/cps/intset.scm                      \
   language/cps/licm.scm                                \
diff --git a/module/language/cps/compile-bytecode.scm 
b/module/language/cps/compile-bytecode.scm
index 5157ecb..5e56b40 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -31,6 +31,7 @@
   #:use-module (language cps slot-allocation)
   #:use-module (language cps utils)
   #:use-module (language cps closure-conversion)
+  #:use-module (language cps handle-interrupts)
   #:use-module (language cps optimize)
   #:use-module (language cps reify-primitives)
   #:use-module (language cps renumber)
@@ -364,7 +365,9 @@
         (($ $primcall 'unwind ())
          (emit-unwind asm))
         (($ $primcall 'atomic-box-set! (box val))
-         (emit-atomic-box-set! asm (from-sp (slot box)) (from-sp (slot 
val))))))
+         (emit-atomic-box-set! asm (from-sp (slot box)) (from-sp (slot val))))
+        (($ $primcall 'handle-interrupts ())
+         (emit-handle-interrupts asm))))
 
     (define (compile-values label exp syms)
       (match exp
@@ -580,6 +583,7 @@
   (set! exp (convert-closures exp))
   (set! exp (optimize-first-order-cps exp opts))
   (set! exp (reify-primitives exp))
+  (set! exp (add-handle-interrupts exp))
   (renumber exp))
 
 (define (compile-bytecode exp env opts)
diff --git a/module/language/cps/handle-interrupts.scm 
b/module/language/cps/handle-interrupts.scm
new file mode 100644
index 0000000..e686ceb
--- /dev/null
+++ b/module/language/cps/handle-interrupts.scm
@@ -0,0 +1,58 @@
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 2016 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
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 
USA
+
+;;; Commentary:
+;;;
+;;; A pass to add "handle-interrupts" primcalls before calls, loop
+;;; back-edges, and returns.
+;;;
+;;; Code:
+
+(define-module (language cps handle-interrupts)
+  #:use-module (ice-9 match)
+  #:use-module (language cps)
+  #:use-module (language cps utils)
+  #:use-module (language cps with-cps)
+  #:use-module (language cps intmap)
+  #:use-module (language cps renumber)
+  #:export (add-handle-interrupts))
+
+(define (add-handle-interrupts cps)
+  (define (visit-cont label cont cps)
+    (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)))
+    (with-fresh-name-state cps
+      (persistent-intmap (intmap-fold visit-cont cps cps)))))
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index a2992b4..96c6a63 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -221,6 +221,7 @@
             emit-atomic-box-set!
             emit-atomic-box-swap!
             emit-atomic-box-compare-and-swap!
+            emit-handle-interrupts
 
             emit-text
             link-assembly))