Merge pull request #1650 from clasp-developers/sigwinch-fix

Fixes the observed intermittent crash that happens when you resize the terminal during build.

Moves interrupt servicing from allocation to all Lisp function calls. I'd like to finesse that a bit but I think it's okay as-is for the time being.

include/clasp/gctools/gcalloc.h

@@ -170,7 +170,6 @@ template <class T> struct RootClassAllocator {
     Header_s* base = do_uncollectable_allocation(the_header, size);
     T* obj = HeaderPtrToGeneralPtr<T>(base);
     new (obj) T(std::forward<ARGS>(args)...);
-    handle_all_queued_interrupts();
     gctools::tagged_pointer<T> tagged_obj(obj);
     return tagged_obj;
   }
@@ -234,7 +233,6 @@ template <class Stage, class Cons, class Register> struct ConsAllocator {
     Cons* cons;
     size_t cons_size = ConsSizeCalculator<Stage, Cons, Register>::value();
     cons = do_cons_allocation<Stage, Cons, ARGS...>(cons_size, std::forward<ARGS>(args)...);
-    handle_all_queued_interrupts<Stage>();
     return smart_ptr<Cons>((Tagged)tag_cons(cons));
   }
 
@@ -400,7 +398,6 @@ template <class OT> struct GCObjectAppropriatePoolAllocator<OT, unmanaged> {
     Header_s* base = do_uncollectable_allocation(the_header, size);
     OT* obj = HeaderPtrToGeneralPtr<OT>(base);
     new (obj) OT(std::forward<ARGS>(args)...);
-    handle_all_queued_interrupts();
     gctools::smart_ptr<OT> sp(obj);
     return sp;
   }
@@ -512,7 +509,6 @@ template <class OT> class GCObjectAllocator {
     GCObjectInitializer<OT, /*gctools::*/ GCInfo<OT>::NeedsInitialization>::initializeIfNeeded(sp);
     GCObjectFinalizer<OT, /*gctools::*/ GCInfo<OT>::NeedsFinalization>::finalizeIfNeeded(sp);
     //            printf("%s:%d About to return allocate result ptr@%p\n", __FILE__, __LINE__, sp.px_ref());
-    handle_all_queued_interrupts();
     return sp;
   };
 
@@ -524,7 +520,6 @@ template <class OT> class GCObjectAllocator {
     GCObjectInitializer<OT, GCInfo<OT>::NeedsInitialization>::initializeIfNeeded(sp);
     GCObjectFinalizer<OT, GCInfo<OT>::NeedsFinalization>::finalizeIfNeeded(sp);
     //            printf("%s:%d About to return allocate result ptr@%p\n", __FILE__, __LINE__, sp.px_ref());
-    handle_all_queued_interrupts<Stage>();
     return sp;
   };
 
@@ -545,7 +540,6 @@ template <class OT> class GCObjectAllocator {
             the_header, size, std::forward<ARGS>(args)...);
     GCObjectInitializer<OT, GCInfo<OT>::NeedsInitialization>::initializeIfNeeded(sp);
     GCObjectFinalizer<OT, GCInfo<OT>::NeedsFinalization>::finalizeIfNeeded(sp);
-    handle_all_queued_interrupts();
     return sp;
   };
 
@@ -753,7 +747,6 @@ template <class TY> class GCContainerAllocator /* : public GCAlloc<TY> */ {
     size_t size = sizeof_container_with_header<TY>(num);
     Header_s* base = do_general_allocation(the_header, size);
     container_pointer myAddress = HeaderPtrToGeneralPtr<TY>(base);
-    handle_all_queued_interrupts();
     return gctools::tagged_pointer<container_type>(myAddress);
   }
 
@@ -835,7 +828,6 @@ template <class TY> class GCContainerNonMoveableAllocator /* : public GCAlloc<TY
     // prepend a one pointer header with a pointer to the typeinfo.name
     Header_s* base = do_general_allocation(the_header, size);
     container_pointer myAddress = HeaderPtrToGeneralPtr<TY>(base);
-    handle_all_queued_interrupts();
     return myAddress;
   }
 

include/clasp/gctools/gcalloc_mps.h

@@ -27,7 +27,6 @@ do_cons_allocation(mps_ap_t& allocation_point, const char* ap_name, ARGS&&... ar
     MAYBE_VERIFY_ALIGNMENT((void*)addr);
     //      printf("%s:%d cons_mps_allocation addr=%p size=%lu\n", __FILE__, __LINE__, addr, sizeof(Cons));
   }
-  handle_all_queued_interrupts();
   return tagged_obj;
 };
 
@@ -73,7 +72,6 @@ general_mps_allocation(const Header_s::BadgeStampWtagMtag& the_header, size_t si
 #ifdef DEBUG_VALIDATE_GUARD
   header->validate();
 #endif
-  handle_all_queued_interrupts();
   globalMpsMetrics.totalMemoryAllocated += allocate_size;
   return tagged_obj;
 };
@@ -101,7 +99,6 @@ inline PTR_TYPE do_weak_allocation(size_t allocate_size, mps_ap_t& allocation_po
   } while (!mps_commit(allocation_point, addr, allocate_size));
   MAYBE_VERIFY_ALIGNMENT((void*)addr);
   my_thread_low_level->_Allocations.registerAllocation(STAMPWTAG_null, allocate_size);
-  handle_all_queued_interrupts();
   if (!obj)
     throw_hard_error("Could not allocate from GCBucketAllocator<Buckets<VT,VT,WeakLinks>>");
   GC_LOG(("malloc@%p %zu bytes\n", obj, allocate_size));

src/core/bytecode.cc

@@ -14,6 +14,7 @@
 #include <clasp/core/ql.h>
 #include <clasp/core/designators.h> // calledFunctionDesignator
 #include <clasp/core/evaluator.h>   // eval::funcall
+#include <clasp/gctools/interrupt.h> // handle_all_queued_interrupts
 
 #define VM_CODES
 #include <virtualMachine.h>
@@ -1498,6 +1499,7 @@ extern "C" {
 #define BYTECODE_COMPILE_THRESHOLD 65535
 
 gctools::return_type bytecode_call(unsigned char* pc, core::T_O* lcc_closure, size_t lcc_nargs, core::T_O** lcc_args) {
+  gctools::handle_all_queued_interrupts();
   core::Closure_O* closure = gctools::untag_general<core::Closure_O*>((core::Closure_O*)lcc_closure);
   ASSERT(gc::IsA<core::BytecodeSimpleFun_sp>(closure->entryPoint()));
   auto entry = closure->entryPoint();

src/core/mpPackage.cc

@@ -483,13 +483,23 @@ CL_DEFUN void mp__enqueue_interrupt(Process_sp process, core::T_sp interrupt) {
 
 SYMBOL_EXPORT_SC_(MpPkg, posix_interrupt);
 void posix_signal_interrupt(int sig) {
+  // Save multiple values so that everything's as it was
+  // if we return from these calls.
+  core::MultipleValues& multipleValues = core::lisp_multipleValues();
+  size_t nvals = multipleValues.getSize();
+  core::T_O* mv_temp[nvals];
+  multipleValues.saveToTemp(nvals, mv_temp);
+  // Signal our Lisp signal.
+  // mp:posix-interrupt is defined in clos/conditions.lisp.
   if (_sym_posix_interrupt->fboundp())
     core::eval::funcall(_sym_posix_interrupt->symbolFunction(),
                         core::clasp_make_fixnum(sig));
-  else
-    core::cl__cerror(core::SimpleBaseString_O::make("Ignore signal"),
-                     core::SimpleBaseString_O::make("Received POSIX signal ~d"),
-                     core::Cons_O::createList(core::clasp_make_fixnum(sig)));
+  // If it's too early to call into Lisp, we do nothing
+  // and return. This makes it so that, for example, an ABRT signal
+  // will not be handled and thus terminate the process, rather than
+  // be "handled" so a few dozen ABRTs need to be sent to actually
+  // kill the process.
+  multipleValues.loadFromTemp(nvals, mv_temp);
 }
 
 CL_LAMBDA(&rest values);

src/lisp/kernel/cleavir/translate.lisp

@@ -1805,6 +1805,9 @@
              (source-pos-info (function-source-pos-info ir)))
         ;; Tail call the real function.
         (cmp:with-debug-info-source-position (source-pos-info)
+          ;; but first, check for interrupts now that we have a source
+          (%intrinsic-invoke-if-landing-pad-or-call
+           "cc_signal_interrupts" ())
           (let* ((function-type (llvm-sys:get-function-type (main-function llvm-function-info)))
                  (arguments
                    (mapcar (lambda (arg)

src/lisp/kernel/clos/conditions.lisp

@@ -1511,12 +1511,9 @@ Interrupts are implicitly blocked while signaling an interrupt, and while unwind
 (defun mp:posix-interrupt (sig)
   (let* ((signals (load-time-value (core:signal-code-alist) t))
          (pair (rassoc sig signals)))
-    (mp:signal-interrupt
-     (if pair
-         (make-condition (first pair))
-         (make-condition 'mp:simple-interactive-interrupt
-                         :format-control "Received POSIX signal: ~d"
-                         :format-arguments (list sig))))))
+    (if pair
+        (mp:raise (first pair))
+        (mp:raise "Received POSIX signal: ~d" sig))))
 
 ;;; ----------------------------------------------------------------------
 ;;; ECL's interface to the toplevel and debugger

src/lisp/kernel/cmp/primitives.lisp

@@ -272,6 +272,7 @@
          ;; While this obviously unwinds, it does so by SJLJ and will
          ;; never throw an exception.
          (primitive         "cc_sjlj_continue_unwinding" :void nil :does-not-return t)
+         (primitive-unwinds "cc_signal_interrupts" :void (list))
          (primitive         "cc_saveMultipleValue0" :void (list :tmv))
          (primitive         "cc_restoreMultipleValue0" :return-type nil)
          (primitive         "llvm.frameaddress.p0" :i8* (list :i32))

src/llvmo/link_intrinsics.cc

@@ -70,6 +70,7 @@ extern "C" {
 #include <clasp/gctools/gc_interface.fwd.h>
 #include <clasp/core/exceptions.h>
 #include <clasp/core/unwind.h>
+#include <clasp/gctools/interrupt.h>
 
 #if defined(_TARGET_OS_DARWIN)
 #include <mach-o/ldsyms.h>
@@ -978,6 +979,10 @@ void debugFileScopeHandle(int* sourceFileInfoHandleP) {
   printf("%s:%d debugFileScopeHandle[%d] --> %s\n", __FILE__, __LINE__, sfindex, _rep_(sfi).c_str());
   NO_UNWIND_END();
 }
+
+void cc_signal_interrupts() {
+  gctools::handle_all_queued_interrupts();
+}
 };
 
 extern "C" {