15.4.925  src/lib/src/lib/thread-kit/src/lib/thread-deathwatch.pkg

# thread-deathwatch.pkg

# Compiled by:
#     src/lib/std/standard.lib

# This package is adapted from
# Cliff Krumvieda's threadkit
# debug utility.
#
# See also:
#     src/lib/src/lib/thread-kit/src/lib/logger.pkg
#     src/lib/src/lib/thread-kit/src/lib/threadkit-uncaught-exception-reporting.pkg

stipulate
    include threadkit;                                                  # threadkit             is from   src/lib/src/lib/thread-kit/src/core-thread-kit/threadkit.pkg
    include logger;                                                     # logger                is from   src/lib/src/lib/thread-kit/src/lib/logger.pkg
    #
    package tc = thread_scheduler_control;
herein


    package   thread_deathwatch
    : (weak)  Thread_Deathwatch                                         # Thread_Deathwatch     is from   src/lib/src/lib/thread-kit/src/lib/thread-deathwatch.api
    {

        ################################################################################
        # Thread deathwatches.

        # Controls printing of thread deathwatch messages: 
        #
        logging
            =
            make_logtree_leaf
              { parent => file::all_logging,
                name   => "thread_deathwatch::logging"
              };
        #
                                            my _ = 
        enable  logging;

        Deathwatch_Mail
          = START_DEATHWATCH  (Thread,         Mailslot(Void))
          |  STOP_DEATHWATCH  (Thread, Oneshot_Maildrop(Void))
          ;


        my deathwatch_mailqueue:  Mailqueue( Deathwatch_Mail )
            =
            make_mailqueue ();


        # Stop watching the named thread:
        #
        fun stop_thread_deathwatch  thread
            =
            {   ack_drop = make_oneshot_maildrop ();

                push (deathwatch_mailqueue, STOP_DEATHWATCH (thread, ack_drop));

                get ack_drop;
            };


        # Watch the given thread for unexpected termination:
        #
        fun start_thread_deathwatch (thread_name, thread)
            =
            {   unwatch_slot = make_mailslot ();

                fun handle_termination ()
                    =
                    {   log_if logging .{

                            cat [ "WARNING!  Watched thread ", thread_name, thread_to_string  thread,
                                  " has died."
                                ];
                        };

                        stop_thread_deathwatch  thread;
                    };

                fun deathwatch_thread ()
                    =
                    {
                        push (deathwatch_mailqueue, START_DEATHWATCH (thread, unwatch_slot));

                        select [
                            take'  unwatch_slot,

                            thread_death_mailop  thread
                                ==>
                                handle_termination
                        ];
                    };

                make_thread  "thread_deathwatch"  deathwatch_thread;

                ();
            };


        package tht
            =
            typelocked_hashtable_g (
                #
                Hash_Key   = Thread;
                hash_value = hash_thread;
                same_key   = same_thread;
            );


        # The deathwatch imp:
        #
        fun start_deathwatch_imp ()
            =
            {   table = tht::make_hashtable { size_hint => 32, not_found_exception => FAIL "start_deathwatch_imp" };

                fun loop ()
                    =
                    for (;;) {
                        #
                        case (pull  deathwatch_mailqueue)
                            #
                            START_DEATHWATCH arg
                                =>
                                tht::set table arg;

                            STOP_DEATHWATCH (thread, ack_1shot)
                                =>
                                {
                                    # Notify the watcher that the thread is no longer being
                                    # watched, and then acknowledge the unwatch command.
                                    #
                                    give (tht::remove  table  thread, ())
                                    except
                                        _ = ();

                                    # Acknowledge that the thread has been removed:
                                    #
                                    set (ack_1shot, ());
                                };
                        esac;
                    };

                make_thread  "thread_deathwatch imp"  loop;

                ();
            };


        my _ =  {   tc::note_mailqueue
                      (
                        "logging: deathwatch-mailqueue",
                        deathwatch_mailqueue
                      );

                    tc::note_imp
                      {
                        name => "logging: deathwatch-imp",
                        #
                        at_startup  =>  start_deathwatch_imp,
                        at_shutdown =>  (fn () = ())
                      };
                };
    };                                          # package thread_deathwatch
end;