PreviousUpNext

15.4.914  src/lib/src/lib/thread-kit/src/core-thread-kit/threadkit-startup-and-shutdown-hooks.pkg

## threadkit-startup-and-shutdown-hooks.pkg

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


stipulate
    package mop =  mailop;                                      # mailop                                is from   src/lib/src/lib/thread-kit/src/core-thread-kit/mailop.pkg
    package mq  =  mailqueue;                                   # mailqueue                             is from   src/lib/src/lib/thread-kit/src/core-thread-kit/mailqueue.pkg
    package ms  =  mailslot;                                    # mailslot                              is from   src/lib/src/lib/thread-kit/src/core-thread-kit/mailslot.pkg
    package sir =  thread_scheduler_is_running;                 # thread_scheduler_is_running           is from   src/lib/src/lib/thread-kit/src/core-thread-kit/thread-scheduler-is-running.pkg
    package tim =  time;                                        # time                                  is from   src/lib/std/time.pkg
herein

    package threadkit_startup_and_shutdown_hooks
    : (weak)
    api {
        include Threadkit_Startup_And_Shutdown_Hooks;           # Threadkit_Startup_And_Shutdown_Hooks  is from   src/lib/src/lib/thread-kit/src/core-thread-kit/threadkit-startup-and-shutdown-hooks.api
        #
        do_actions_for:  When -> Void;

        export_fn_cleanup:  Void -> Void;

        standard_mailslot_and_mailqueue_cleaner:  (String, List(When), (When -> Void));
        standard_imp_cleaner:                     (String, List(When), (When -> Void));
    } {
        include maildrop;                                       # maildrop                              is from   src/lib/src/lib/thread-kit/src/core-thread-kit/maildrop.pkg
        include timeout_mailop;                                 # timeout_mailop                        is from   src/lib/src/lib/thread-kit/src/core-thread-kit/timeout-mailop.pkg
        include thread;                                         # thread                                is from   src/lib/src/lib/thread-kit/src/core-thread-kit/thread.pkg

        thread_scheduler_is_running
            =
            sir::thread_scheduler_is_running;

        When = STARTUP
             | APP_STARTUP
             | THREADKIT_SHUTDOWN
             | SHUTDOWN
             ;

            # The threadkit clean-up times are somewhat different than the Lib7
            # times.
            #
            #   STARTUP         initialization of a program that is being run
            #                   under thread_scheduler_control::start_up_thread_scheduler
            #   APP_STARTUP     initialization of a stand-alone program that was
            #                   generated by spawn_to_disk.
            #   THREADKIT_SHUTDOWN      normal program exit of a threadkit program running
            #                   under thread_scheduler_control::start_up_thread_scheduler.
            #   SHUTDOWN                normal program exit of a stand-alone threadkit program.
            #
            # Note that the clean-up routines run while threadkit is still active.  It
            # may also be useful for an application to register clean-up routines
            # with Lib7 (SPAWN_TO_DISK actions are the most useful).


        # At all times 
        #
        at_all = [ SHUTDOWN, THREADKIT_SHUTDOWN, STARTUP, APP_STARTUP ];

        actions = REF ([]: List( (String, List(When), When -> Void) ));


        # 'exclusively' implements mutual exclusion:
        # It evaluates the given f(x) while guaranteeing
        # that no other 'exclusively' is running at the same time:
        #
        stipulate
            #
            lock_maildrop = make_full_maildrop ();
            #
        herein

            fun lock   () =  empty  lock_maildrop;
            fun unlock () =  fill  (lock_maildrop, ());

            fun exclusively f x
                =
                if *thread_scheduler_is_running
                    #
                    lock ();

                    result
                        =
                        f x
                        except
                            ex =  {   unlock ();
                                      raise exception ex;
                                  };

                    unlock ();
                    result;
                else
                    f x;
                fi;
        end;


        # Return the list of actions
        # that apply at 'when':
        #       
        fun filter when
            =
            f *actions
            where
                fun f [] =>   [];
                    #
                    f ((item as (_, when_lst, _)) ! r)
                        =>
                        if (list::exists when when_lst)   item ! (f r);
                        else                                 (f r);
                        fi;
                end;
            end;

        # Apply the hook action for 'when'.
        # In some cases this causes the list
        # of actions to be redefined.
        #
        # We reverse the order of invocation
        # at initialization time.
        #
        fun do_actions_for  when
            =
            {   lock ();
                #
                clean_fns
                    =
                    case when
                        (STARTUP | APP_STARTUP) =>  list::reverse (filter (fn w =  w == when));
                        _                       =>  filter (fn w =  w == when);
                    esac;


                fun init_fn_pred SHUTDOWN =>  TRUE;
                    init_fn_pred _        =>  FALSE;
                end;

                fun do_cleaner (_, _, f)
                    =
                    mop::select
                      [
                        thread_death_mailop (make_thread' "threadkit_startup_and_shutdown_hooks do_actions" f when),
                        timeout_in' (tim::from_seconds 1)
                      ];

      /*DEBUG
      fun doCleaner (tag, _, f) = (
      Debug::sayDebugTS (cat ["do Cleaner \"", tag, "\"\n"]);
      mop::select [
      mop::wrap (thread_death_mailop (make_thread' "threadkit_startup_and_shutdown_hooks debug" f when), fn _ => Debug::sayDebugTS "  done\n"),
      mop::wrap (timeout_in (tim::from_seconds 1), fn _ => Debug::sayDebugTS "  timeout\n")
      ])
      DEBUG*/

                # Remove unnecessary actions:
                #
                case when
                    #
                    APP_STARTUP =>   actions := filter init_fn_pred;
                    _           =>   ();
                esac;

                unlock();

                # Now apply the clean-up routines:
                #
                list::apply do_cleaner clean_fns;
            };

        # Find and remove the named action
        # from the action list.
        #
        # Return the action and the new action list.
        #
        # Return NULL if the named action doesn't exist.
        #
        fun remove_action  name
            =
            remove *actions
            where
                fun remove []
                        =>
                        NULL;

                    remove ((action as (name', when_lst, clean_g)) ! rest)
                        =>
                        if (name == name')
                            #
                            THE((when_lst, clean_g), rest);
                        else
                            case (remove rest)
                                #
                                THE (action', rest')
                                    =>
                                    THE (action', action ! rest');

                                NULL => NULL;
                            esac;
                        fi;
                end;
            end;

        # Record the named action.
        # Return the previous definition, or NULL. 
        #
        fun note_startup_or_shutdown_action (arg as (name, _, _))
            =
            case (remove_action name)
                #
                THE (old_action, action_list)
                    =>
                    {   actions := arg ! action_list; 
                        #
                        THE old_action;
                    };

                NULL =>
                    {   actions := arg ! *actions;
                        NULL;
                    };
            esac;

        note_startup_or_shutdown_action
            =
            exclusively  note_startup_or_shutdown_action;

        # Remove and return the named action.
        # Return NULL if it is not found.
        #
        fun forget_startup_or_shutdown_action  name
            =
            case (remove_action name)
                #
                THE (old_action, action_list)
                    =>
                    {   actions := action_list;
                        THE old_action;
                    };

                NULL => NULL;
            esac;

        forget_startup_or_shutdown_action
            =
            exclusively  forget_startup_or_shutdown_action;

        exception NO_SUCH_ACTION;

        Item = ITEM { name:         String,
                      #
                      at_startup:   Void -> Void,
                      at_shutdown:  Void -> Void
                    };

        mailslots  = REF ([] : List( Item ));
        mailqueues = REF ([] : List( Item ));
        imps       = REF ([] : List( Item ));

        # Remove 'name' from 'list':
        #
        fun forget  list  name_to_forget
            =
            list := drop_it_from *list
            where
                fun drop_it_from []
                        =>
                        raise exception NO_SUCH_ACTION;

                    drop_it_from ((x as ITEM { name, ... })  !  rest)
                        =>
                        if (name == name_to_forget)  rest;
                        else                         x ! (drop_it_from rest);
                        fi;
                end;
            end;

        fun start_up_all  list
            =
            list::apply
                (fn ITEM { at_startup, ... } =  at_startup ())
                (list::reverse *list);

        fun forget_all_mailslots_mailqueues_and_imps ()
            =
            {   mailslots  := [];
                mailqueues := [];
                imps       := [];
            };

        forget_mailslot
            =
            exclusively (forget  mailslots);

        fun note_mailslot (name, mailslot)
            =
            {   fun f ()
                    =
                    ms::reset_mailslot  mailslot;

                forget_mailslot  name
                except
                    NO_SUCH_ACTION = ();

                mailslots
                    :=
                    ITEM { name, at_startup=>f, at_shutdown=>f }
                    !
                    *mailslots;
            };

        note_mailslot
            =
            fn x =  exclusively  note_mailslot  x;

        forget_mailqueue
            =
            exclusively (forget  mailqueues);

        fun note_mailqueue (name, mail_queue)
            =
            {   fun f ()
                    =
                    mq::reset_mailqueue  mail_queue;

                forget_mailqueue  name
                except
                    NO_SUCH_ACTION = ();

                mailqueues
                    :=
                    ITEM { name, at_startup=>f, at_shutdown=>f }
                    !
                    *mailqueues;
            };

        note_mailqueue
            =
            fn x =  exclusively  note_mailqueue  x;

        forget_imp
            =
            exclusively (forget  imps);

        fun note_imp { name, at_startup, at_shutdown }
            =
            {   forget_imp  name
                except
                    NO_SUCH_ACTION = ();

                imps := ITEM { name, at_startup, at_shutdown }
                        !
                        *imps;
            };

        note_imp =   exclusively  note_imp;

        fun start_imps ()
            =
            start_up_all  imps;

        fun shut_down_imps ()
            =
            apply shut_down *imps
            where
                fun shut_down (ITEM { name, at_shutdown, ... } )
                    =
                    mop::select [
                      thread_death_mailop (make_thread "threadkit_startup_and_shutdown_hooks shut_down_imps"  at_shutdown),
                      timeout_in' (tim::from_seconds 2)
                    ];

            end;

        fun clean_imps (STARTUP  | APP_STARTUP)        =>  start_imps ();
            clean_imps (SHUTDOWN | THREADKIT_SHUTDOWN) =>  shut_down_imps ();
        end;

        # Clear our lists of known
        # mailslots and mailqueues. 
        #
        fun clear_mailslots_and_mailqueues _
            =
            {  start_up_all  mailslots;
               start_up_all  mailqueues;
            };

        # The standard actions:
        #
        standard_mailslot_and_mailqueue_cleaner =  ("mailslots&mailqueues", [STARTUP, THREADKIT_SHUTDOWN], clear_mailslots_and_mailqueues);
        standard_imp_cleaner                    =  ("imps", at_all, clean_imps);

        # Remove useless actions and
        # clear the mailslot and mailqueue lists
        # prior to exporting a stand-alone
        # threadkit program.
        #
        fun export_fn_cleanup ()
            =
            {   fun export_fn_predicate (APP_STARTUP | SHUTDOWN) =>  TRUE;
                    export_fn_predicate _                        =>  FALSE;
                end;

                clear_mailslots_and_mailqueues ();

                mailslots  :=  [];
                mailqueues :=  [];

                actions :=  filter  export_fn_predicate;
            };

    };                                                          # package threadkit_startup_and_shutdown_hooks
end;


Comments and suggestions to: bugs@mythryl.org

PreviousUpNext