From ca74e3fae52dd23f8e8f12194d07041e207f68e7 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 16 Nov 2016 22:37:54 +0100 Subject: [PATCH] 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(-) create mode 100644 module/language/cps/handle-interrupts.scm 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))