From f140dbc8b05aa3d341c70436a1920a06df9a0ed4 Mon Sep 17 00:00:00 2001
From: Roberto Di Cosmo <roberto@dicosmo.org>
Date: Sun, 2 May 2021 19:11:46 +0200
Subject: [PATCH] Signal exceptions in the worker to the master process in the
 simplemapper skeleton. Add test to cover exception handling in the workers
 for this case.

---
 src/parmap.ml           | 11 ++++++++++-
 tests/dune              |  4 ++--
 tests/testexceptions.ml | 26 ++++++++++++++++++++++++++
 3 files changed, 38 insertions(+), 3 deletions(-)
 create mode 100644 tests/testexceptions.ml

diff --git a/src/parmap.ml b/src/parmap.ml
index 78d1ab2..edc043a 100644
--- a/src/parmap.ml
+++ b/src/parmap.ml
@@ -203,6 +203,7 @@ let simplemapper (init:int -> unit) (finalize: unit -> unit) ncores' compute opi
     ln !ncores chunksize;
   (* create descriptors to mmap *)
   let fdarr=Array.init !ncores (fun _ -> Utils.tempfd()) in
+  let statusfdarr=Array.init !ncores (fun _ -> Utils.tempfd()) in
   (* run children *)
   run_many !ncores ~in_subprocess:(fun i ->
     init i;  (* call initialization function *)
@@ -214,15 +215,23 @@ let simplemapper (init:int -> unit) (finalize: unit -> unit) ncores' compute opi
         "error at index j=%d in (%d,%d), chunksize=%d of a total of \
          %d got exception %s on core %d \n%!"
         j lo hi chunksize (hi-lo+1) (Printexc.to_string e) i;
+      marshal statusfdarr.(i) false;
       exit 1
     in
     let v = compute al lo hi opid exc_handler in
+    marshal statusfdarr.(i) true;
     marshal fdarr.(i) v);
   (* read in all data *)
   let res = ref [] in
+  let success = ref true in
+  (* check whether an exception has been raised in the subprocesses *)
+  for i = 0 to !ncores - 1 do
+    success:= !success && ((unmarshal statusfdarr.(i)):bool);
+  done;
+  if not !success then failwith "Aborting computation due to exception(s) raised in the workers";
   (* iterate in reverse order, to accumulate in the right order *)
   for i = 0 to !ncores - 1 do
-      res:= ((unmarshal fdarr.((!ncores-1)-i)):'d)::!res;
+    res:= ((unmarshal fdarr.((!ncores-1)-i)):'d)::!res;
   done;
   (* collect all results *)
   collect !res
diff --git a/tests/dune b/tests/dune
index 452ed17..d3eac42 100644
--- a/tests/dune
+++ b/tests/dune
@@ -6,9 +6,9 @@
  (libraries parmap))
 
 (tests
- (names floatscale simplescale simplescale_array simplescalefold
+ (names testexceptions floatscale simplescale simplescale_array simplescalefold
    simplescalemapfold)
- (modules floatscale simplescale simplescale_array simplescalefold
+ (modules testexceptions floatscale simplescale simplescale_array simplescalefold
    simplescalemapfold)
  (flags
   (:standard -w -35-27))
diff --git a/tests/testexceptions.ml b/tests/testexceptions.ml
new file mode 100644
index 0000000..e1ada6d
--- /dev/null
+++ b/tests/testexceptions.ml
@@ -0,0 +1,26 @@
+(**************************************************************************)
+(* Sample use of Parmap, a simple library to perform Map computations on  *)
+(* a multi-core                                                           *)
+(*                                                                        *)
+(*  Author(s):  Roberto Di Cosmo                                          *)
+(*                                                                        *)
+(*  This program is free software: you can redistribute it and/or modify  *)
+(*  it under the terms of the GNU General Public License as               *)
+(*  published by the Free Software Foundation, either version 2 of the    *)
+(*  License, or (at your option) any later version.                       *)
+(**************************************************************************)
+
+Printf.eprintf "Testing capture of exception: this code should exit normally, without segfault.\n%!";;
+
+Parmap.debugging true;;
+
+let _ =
+  try
+    Parmap.parmap
+      (function x ->
+	failwith "should not crash")
+      (Parmap.L [1;2;3;4;5])
+  with _ -> (Printf.printf "Exceptions are properly catched, no SIGSEV"; exit 0)
+
+  
+