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.

6 files changed, 76 insertions, 4 deletions

diff --git a/am/bootstrap.am b/am/bootstrap.am
index d5f25abfa..e0d4764f5 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 4f66b9e7d..4de1971c2 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 0d1f128f1..67f041d20 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 5157ecb70..5e56b406f 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 000000000..e686cebce
--- /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 a2992b495..96c6a633b 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))