## run-at.pkg
#
# Compare to:
# src/lib/std/src/nj/run-at--premicrothread.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 mps = microthread_preemptive_scheduler;
package tsr = 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 run_at
: (weak)
api {
include api Run_At; # Run_At is from src/lib/src/lib/thread-kit/src/core-thread-kit/run-at.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 package maildrop; # maildrop is from src/lib/src/lib/thread-kit/src/core-thread-kit/maildrop.pkg include package timeout_mailop; # timeout_mailop is from src/lib/src/lib/thread-kit/src/core-thread-kit/timeout-mailop.pkg include package microthread; # microthread is from src/lib/src/lib/thread-kit/src/core-thread-kit/microthread.pkg When = COMPILER_STARTUP # Initialization of a program that is being run under RunTHREADKIT::do_it.
| 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 RunTHREADKIT::do_it.
| APP_SHUTDOWN # Normal program exit of a stand-alone threadkit program.
; #
# The threadkit clean-up times are somewhat different than the run_at times. # run_at src/lib/std/src/nj/run-at--premicrothread.pkg #
# 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 run_at (SPAWN_TO_DISK actions are the most useful).
fun when_to_string COMPILER_STARTUP => "COMPILER_STARTUP";
when_to_string APP_STARTUP => "APP_STARTUP";
when_to_string THREADKIT_SHUTDOWN => "THREADKIT_SHUTDOWN";
when_to_string APP_SHUTDOWN => "APP_SHUTDOWN";
end;
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
#
# my _ = printf "creating lock_maildrop -- run-at.pkg\n";
lock_maildrop = make_full_maildrop ();
#
herein
# fun lock () = empty lock_maildrop;
# fun unlock () = fill (lock_maildrop, ());
fun lock ()
=
{
take_from_maildrop lock_maildrop;
};
fun unlock ()
=
{
put_in_maildrop (lock_maildrop, ());
};
fun exclusively f x
=
case *tsr::thread_scheduler_is_running_as_pid # Calling tsr::thread_scheduler_is_running () would be too expensive here,
# # I think, due to the wxp::get_process_id () syscall. -- 2012-08-06 CrT
NULL =>
{
f x;
};
_ => {
lock ();
result
=
f x
except
any_x = {
unlock ();
raise exception any_x;
};
unlock ();
result;
};
esac;
end; # stipulate
# Return the list of actions
# that apply at 'when':
#
fun filter_actions 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
#
(COMPILER_STARTUP | APP_STARTUP) => list::reverse (filter_actions (\\ w = w == when));
_ => filter_actions (\\ w = w == when);
esac;
fun init_fn_pred APP_SHUTDOWN => TRUE;
init_fn_pred _ => FALSE;
end;
fun do_cleaner (fname, _, f) # Ignored arg is List(When).
=
mop::do_one_mailop [
#
thread_done__mailop (make_thread' [ THREAD_NAME ("@" + (when_to_string when) + ": " + fname) ] f when),
timeout_in' 1.0
];
/*DEBUG
fun doCleaner (tag, _, f) = (
Debug::sayDebugTS (cat ["do Cleaner \"", tag, "\"\n"]);
mop::do_one_mailop [
mop::wrap (thread_done__mailop (make_thread' [ THREAD_NAME "threadkit...hooks debug" ] f when), \\ _ => Debug::sayDebugTS " done\n"),
mop::wrap (timeout_in (tim::from_seconds 1), \\ _ => Debug::sayDebugTS " timeout\n")
])
DEBUG*/
# Remove unnecessary actions:
#
# case when
# #
# APP_STARTUP => actions := filter_actions 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
=
{
# printf "forget/AAA -- run-at.pkg\n";
list := drop_it_from *list;
# printf "forget/ZZZ -- run-at.pkg\n";
}
where
fun drop_it_from []
=>
{
# printf "forget/BBB: Raising exception NO_SUCH_ACTION. -- run-at.pkg\n";
raise exception NO_SUCH_ACTION;
};
drop_it_from ((x as ITEM { name, ... }) ! rest)
=>
{
# printf "forget/BBB: Raising exception NO_SUCH_ACTION. -- run-at.pkg\n";
if (name == name_to_forget) rest;
else x ! (drop_it_from rest);
fi;
};
end;
end;
fun start_up_all list
=
list::apply
(\\ ITEM { at_startup, ... } = at_startup ())
# (\\ ITEM { at_startup, name, ... } = { printf "start_up_all running %s.at_startup ...\n" name; at_startup (); })
(list::reverse *list);
fun forget_all_mailslots_mailqueues_and_imps ()
=
{ mailslots := [];
mailqueues := [];
imps := [];
};
forget_mailslot
=
{
# printf "outer forget_mailslot/TOP -- run-at.pkg\n";
result =
exclusively (forget mailslots);
# printf "outer forget_mailslot/BOTTOM -- run-at.pkg\n";
result;
} except
any_exception = {
# printf "outer forget_mailslot/EXCEPTION -- run-at.pkg\n";
raise exception any_exception;
};
fun note_mailslot (name, mailslot)
=
{
# printf "note_mailslot/AAA -- run-at.pkg\n";
fun f ()
=
ms::reset_mailslot mailslot;
# printf "note_mailslot/BBB -- run-at.pkg\n";
forget mailslots name # Doing forget_mailslot name here will deadlock due to nested 'exclusively's. -- Voice Of Experience.
except
NO_SUCH_ACTION
=
{
# printf "note_mailslot/CCC: Caught NO_SUCH_ACTION. -- run-at.pkg\n";
();
};
# printf "note_mailslot/DDD -- run-at.pkg\n";
mailslots
:=
ITEM { name, at_startup=>f, at_shutdown=>f }
!
*mailslots;
# printf "note_mailslot/ZZZ -- run-at.pkg\n";
};
note_mailslot
=
\\ x = exclusively note_mailslot x;
forget_mailqueue
=
exclusively (forget mailqueues);
fun note_mailqueue (name, mail_queue)
=
{ fun f ()
=
mq::reset_mailqueue mail_queue;
forget mailqueues name # Doing forget_mailqueue name here will deadlock due to nested 'exclusively's. -- Voice Of Experience.
except
NO_SUCH_ACTION = ();
mailqueues
:=
ITEM { name, at_startup=>f, at_shutdown=>f }
!
*mailqueues;
};
note_mailqueue
=
\\ x = exclusively note_mailqueue x;
forget_imp
=
exclusively (forget imps);
fun note_imp { name, at_startup, at_shutdown }
=
{ forget imps name # Doing forget_imp name here will deadlock due to nested 'exclusively's. -- Voice Of Experience.
except
NO_SUCH_ACTION = ();
imps := ITEM { name, at_startup, at_shutdown }
!
*imps;
# printf "note_imp { %s, ... }: list::length(*imps) now d=%d -- run-at.pkg\n" name (list::length(*imps));
if (tsr::thread_scheduler_is_running ())
#
# printf "note_imp { %s, ... }: calling at_startup() -- run-at.pkg\n" name;
at_startup (); # Better late than never! :-)
fi;
};
note_imp = exclusively note_imp;
fun start_imps ()
=
{
# printf "start_imps/AAA list::length(*imps) d=%d -- run-at.pkg\n" (list::length *imps);
result =
start_up_all imps;
# printf "start_imps/ZZZ -- run-at.pkg\n";
result;
};
fun shut_down_imps ()
=
apply shut_down *imps
where
fun shut_down (ITEM { name, at_shutdown, ... } )
=
mop::do_one_mailop [
thread_done__mailop (make_thread "tkhooks shutdown imps" at_shutdown),
timeout_in' 2.0
];
end;
fun clean_imps COMPILER_STARTUP
=>
{
# printf "clean_imps(COMPILER_STARTUP/AAA: mode d=%d start_imps(); -- run-at.pkg\n" (mps::get_uninterruptible_scope_nesting_depth());
start_imps ();
# printf "clean_imps(COMPILER_STARTUP/ZZZ: mode d=%d -- run-at.pkg\n" (mps::get_uninterruptible_scope_nesting_depth());
};
clean_imps APP_STARTUP
=>
{
# printf "clean_imps(APP_STARTUP/AAA: start_imps(); -- run-at.pkg\n";
start_imps ();
# printf "clean_imps(APP_STARTUP/ZZZ: -- run-at.pkg\n";
};
clean_imps APP_SHUTDOWN
=>
{
# printf "clean_imps(APP_SHUTDOWN/AAA: shut_down_imps(); -- run-at.pkg\n";
shut_down_imps ();
# printf "clean_imps(APP_SHUTDOWN/ZZZ -- run-at.pkg\n";
};
clean_imps THREADKIT_SHUTDOWN
=>
{
# printf "clean_imps(THREADKIT_SHUTDOWN/AAA: shut_down_imps(); -- run-at.pkg\n";
shut_down_imps ();
# printf "clean_imps(THREADKIT_SHUTDOWN/ZZZ -- run-at.pkg\n";
};
end;
# Clear our lists of known
# mailslots and mailqueues.
#
fun clear_mailslots_and_mailqueues _
=
{
# printf "clear_mailslots_and_mailqueues/AAA: mode d=%d\n" (mps::get_uninterruptible_scope_nesting_depth());
start_up_all mailslots;
# printf "clear_mailslots_and_mailqueues/BBB: mode d=%d\n" (mps::get_uninterruptible_scope_nesting_depth());
start_up_all mailqueues;
# printf "clear_mailslots_and_mailqueues/ZZZ: mode d=%d\n" (mps::get_uninterruptible_scope_nesting_depth());
};
# The standard actions:
#
standard_mailslot_and_mailqueue_cleaner = ("mailslots & mailqueues", [COMPILER_STARTUP, THREADKIT_SHUTDOWN], clear_mailslots_and_mailqueues);
standard_imp_cleaner = ("imps", [ APP_SHUTDOWN, THREADKIT_SHUTDOWN, COMPILER_STARTUP, APP_STARTUP ], clean_imps);
#
# Above two referenced only in src/lib/src/lib/thread-kit/src/glue/initialize-run-at.pkg # as
# cu::note_startup_or_shutdown_action cu::standard_mailslot_and_mailqueue_cleaner;
# cu::note_startup_or_shutdown_action cu::standard_imp_cleaner;
# where
# cu == run_at
# Remove useless actions and
# clear the mailslot and mailqueue lists
# prior to exporting a stand-alone
# threadkit program.
#
fun export_fn_cleanup () # This gets called (only) from src/lib/src/lib/thread-kit/src/glue/thread-scheduler-control-g.pkg =
{
# fun export_fn_predicate (APP_STARTUP | APP_SHUTDOWN) => TRUE;
# export_fn_predicate _ => FALSE;
# end;
clear_mailslots_and_mailqueues ();
# mailslots := [];
# mailqueues := [];
# actions := filter_actions export_fn_predicate;
};
}; # package run_at
end;