## threadkit-startup-and-shutdown-hooks.pkg
# Compiled by:
# src/lib/std/standard.libstipulate
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.pkgherein
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;