PreviousUpNext

15.4.918  src/lib/src/lib/thread-kit/src/glue/thread-scheduler-control-g.pkg

## thread-scheduler-control-g.pkg
#

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



                                                                                # winix_guts                                            is from   src/lib/std/src/posix/winix-guts.pkg
                                                                                # winix_process__premicrothread                                         is from   src/lib/std/src/posix/winix-process--premicrothread.pkg
stipulate
    package at  =  run_at__premicrothread;                                      # run_at__premicrothread                                is from   src/lib/std/src/nj/run-at--premicrothread.pkg
    package cu  =  run_at;                                                      # run_at                                                is from   src/lib/src/lib/thread-kit/src/core-thread-kit/run-at.pkg
    package fat =  fate;                                                        # fate                                                  is from   src/lib/std/src/nj/fate.pkg
    package is  =  interprocess_signals;                                        # interprocess_signals                                  is from   src/lib/std/src/nj/interprocess-signals.pkg
    package itt =  internal_threadkit_types;                                    # internal_threadkit_types                              is from   src/lib/src/lib/thread-kit/src/core-thread-kit/internal-threadkit-types.pkg
    package ri  =  runtime_internals;                                           # runtime_internals                                     is from   src/lib/std/src/nj/runtime-internals.pkg
    package th  =  microthread;                                                 # microthread                                           is from   src/lib/src/lib/thread-kit/src/core-thread-kit/microthread.pkg
    package mps =  microthread_preemptive_scheduler;                            # microthread_preemptive_scheduler                      is from   src/lib/src/lib/thread-kit/src/core-thread-kit/microthread-preemptive-scheduler.pkg
    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 uns =  unsafe;                                                      # unsafe                                                is from   src/lib/std/src/unsafe/unsafe.pkg
    package wnx =  winix__premicrothread;                                       # winix__premicrothread                                 is from   src/lib/std/winix--premicrothread.pkg
    package wxp =  winix__premicrothread::process;                              # winix__premicrothread::process                        is from   src/lib/std/src/posix/winix-process--premicrothread.pkg
    #
    package ci  =  unsafe::mythryl_callable_c_library_interface;                # unsafe                                                is from   src/lib/std/src/unsafe/unsafe.pkg
                                                                                # mythryl_callable_c_library_interface                  is from   src/lib/std/src/unsafe/mythryl-callable-c-library-interface.pkg
    fun cfun  fun_name
        =
        ci::find_c_function  { lib_name => "heap",  fun_name };                 # "heap"                                                def in    src/c/lib/heap/libmythryl-heap.c
            #
            ###############################################################
            # 'cfun' here is used only for spawn_to_disk which should be called
            # only on a quiescient system with only one active posix thread, so
            # our usual latency-minimization reasons for indirecting
            # syscalls through other posix threads do not apply.
            #
            # Consequently I'm not taking the time and effort to switch it
            # over from using find_c_function() to using find_c_function'().
            #                              -- 2012-04-21 CrT
herein

    # This generic is invoked (only) by:
    #
    #     src/lib/src/lib/thread-kit/src/posix/thread-scheduler-control.pkg
    #
    generic package  thread_scheduler_control_g   (
        #            ==========================
        #
        drv:  Threadkit_Driver_For_Os                                           # Threadkit_Driver_For_Os                               is from   src/lib/src/lib/thread-kit/src/posix/threadkit-driver-for-os.api
                                                                                # threadkit_driver_for_posix                            is from   src/lib/src/lib/thread-kit/src/posix/threadkit-driver-for-posix.pkg
    )
    : (weak) Thread_Scheduler_Control                                           # Thread_Scheduler_Control                              is from   src/lib/src/lib/thread-kit/src/glue/thread-scheduler-control.api
    {

                                                                                # initialize_run_at     is from   src/lib/src/lib/thread-kit/src/glue/initialize-run-at.pkg

        # These all get re-exported to clients:
        #
        exception NO_SUCH_ACTION                =  cu::NO_SUCH_ACTION;
        When                                    == cu::When;
        when_to_string                          =  cu::when_to_string;
        note_startup_or_shutdown_action         =  cu::note_startup_or_shutdown_action;
        forget_startup_or_shutdown_action       =  cu::forget_startup_or_shutdown_action;
        note_mailqueue                          =  cu::note_mailqueue;
        forget_mailqueue                        =  cu::forget_mailqueue;
        note_mailslot                           =  cu::note_mailslot;
        forget_mailslot                         =  cu::forget_mailslot;
        forget_all_mailslots_mailqueues_and_imps=  cu::forget_all_mailslots_mailqueues_and_imps;
        note_imp                                =  cu::note_imp;
        forget_imp                              =  cu::forget_imp;

        stipulate
            # Force hook initialization
            # to link (and thus execute):
            #
            package iss =  initialize_run_at;   # initialize_run_at     is from   src/lib/src/lib/thread-kit/src/glue/initialize-run-at.pkg

            package bas =  threadkit_base_for_os_g( drv );                      # threadkit_base_for_os_g                               is from   src/lib/src/lib/thread-kit/src/glue/threadkit-base-for-os-g.pkg
        herein                                                                  # 


            saved_interrupt_handler =  REF is::IGNORE;

            saved_print_function    =  REF *ri::print_hook;                     # runtime_internals             is from   src/lib/std/src/nj/runtime-internals.pkg

#           is_running
#               =
#               tsr::thread_scheduler_is_running;


#           fun thread_scheduler_is_running ()
#               =
#               tsr::thread_scheduler_is_running ();

            #
            fun shut_down_thread_scheduler  status                              # This is currently called at the end of all threadkit-using applications.
                =
                if (tsr::thread_scheduler_is_running ()
                and (not *tsr::started_thread_scheduler_shutdown))
                    #
                    fat::switch_to_fate  *mps::thread_scheduler_shutdown_hook  (TRUE, status);  # 
                else
                    raise exception FAIL "threadkit is not running";            # It is too hard to avoid calling this redundantly during shutdown, at least at the moment.    -- 2012-08-02 CrT
                fi;

            #
            fun dummy_print _                                                   # Dummy print function, in case the user's program doesn't reference threadkit's file package directly.
                =
                raise exception  FAIL "print called without loading threadkit's file  -- thread-scheduler-control-g.pkg";


            interrupt_fate
                =
                fat::make_isolated_fate  (fn _ =  shut_down_thread_scheduler  wnx::process::failure)
                :
                fat::Fate( Void );

            #
            fun start_up_thread_scheduler''                                     # This is an internal routine -- not externally visible.
                ( first_thread_thunk,                                           # Thunk for initial thread to run.
                  time_quantum                                                  # THE timeslicing time quantum. If NULL, defaults to 20 milliseconds.
                )
                =
                {   saved_interrupt_handler
                        :=
                        is::get_signal_handler   is::SIGINT;

                    saved_print_function
                        :=
                        *ri::print_hook;                                        # runtime_internals             is from   src/lib/std/src/nj/runtime-internals.pkg


                    if (tsr::thread_scheduler_is_running ())
                        #
                        raise exception FAIL "threadkit is already running";
                    fi;

                    tsr::thread_scheduler_is_running_as_pid                     # Remember that thread scheduler is now running.
                        :=
                        THE (wxp::get_process_id ());

                    tsr::started_thread_scheduler_shutdown
                        :=
                        FALSE;

                    th::reset_thread_package { running => TRUE };

                    drv::start_threadkit_driver ();                     # Empty out the timeout queue.
                                                                        # threadkit_driver_for_posix                                                    is from   src/lib/src/lib/thread-kit/src/posix/threadkit-driver-for-posix.pkg

                                                                        # wake_sleeping_threads_and_schedule_fd_io_and_harvest_dead_subprocesses__usend__fate   is from   src/lib/src/lib/thread-kit/src/glue/threadkit-base-for-os-g.pkg
                                                                        # no_runnable_threads_left__fate                                                is from   src/lib/src/lib/thread-kit/src/glue/threadkit-base-for-os-g.pkg

                    mps::run_next_runnable_thread__usend__hook :=  bas::wake_sleeping_threads_and_schedule_fd_io_and_harvest_dead_subprocesses__usend__fate;
                    mps::no_runnable_threads_left__hook :=  bas::no_runnable_threads_left__fate;

                    my  (clean_up, status)
                        =
                        fat::call_with_current_fate
                            (   fn done_fate
                                    =
                                    {   is::set_signal_handler
                                            ( is::SIGINT,
                                              is::HANDLER (fn _ =  interrupt_fate)
                                            );

                                        mps::thread_scheduler_shutdown_hook :=   done_fate;

                                        ri::print_hook    :=   dummy_print;

                                        case time_quantum
                                            #
                                            THE time_quantum =>  mps::start_thread_scheduler_timer  time_quantum;
                                            _                =>  mps::restart_thread_scheduler_timer ();
                                        esac;


                                        cu::do_actions_for  cu::COMPILER_STARTUP;


                                        #####################################
                                        # This is where we actually enter
                                        # concurrent programming mode,
                                        # initially with a single thread
                                        # running the first_thread_thunk:
                                        #####################################
                                        #
#                                       th::make_thread  "default thread"  first_thread_thunk;

                                        itt::default_task -> itt::APPTASK { alive_threads_count, ... };

                                        log::uninterruptible_scope_mutex := 1;
                                        #
                                        alive_threads_count :=  *alive_threads_count + 1;

                                        th::run_thread__xu  itt::default_thread  first_thread_thunk  ();

                                        #
                                        mps::dispatch_next_thread__noreturn ();
                                    }
                            );

                    #####################################
                    # At this point we have exited
                    # concurrent programming mode
                    # and are returning to vanilla
                    # single-threaded operation.
                    #####################################

                    if (tsr::thread_scheduler_is_running ()                     # Try to be robust against different shutdown sequences etc.
                    and (not *tsr::started_thread_scheduler_shutdown)
                    )   
                        #
                        tsr::started_thread_scheduler_shutdown :=  TRUE;
                                                                                # Compare this block with corresponding block in   wrap_for_export()   from   src/lib/src/lib/thread-kit/src/glue/threadkit-base-for-os-g.pkg
                                                                                #
                        cu::do_actions_for  cu::THREADKIT_SHUTDOWN;             # Lets various imps clean up, for example by closing X sockets in   src/lib/x-kit/xclient/src/wire/socket-closer-imp.pkg
                        drv::stop_threadkit_driver      ();                     # Merely clears the timeout-mailop.pkg list of threads waiting for timeouts.
                        #                                                       #
                        mps::stop_thread_scheduler_timer ();                    # Stops 50Hz SIGALRM, sets alarm_signal handler to IGNORE.
                        th::reset_thread_package { running => FALSE };          # microthread.pkg:  tid_count :=  0;   microthread-preemptive-scheduler.pkg: Clears hooks, queues, cached time, current thread.

                        tsr::thread_scheduler_is_running_as_pid                 # Thread scheduler is no longer running.
                            :=
                            NULL;


                        ri::print_hook
                            :=
                            *saved_print_function;


                        is::set_signal_handler
                            #
                            (is::SIGINT, *saved_interrupt_handler);

                        ();
# else
# printf "start_up_thread_scheduler'' shutdown half/BBB  mode d=%d:   thread scheduler was not running.\n"  (mps::get_uninterruptible_scope_nesting_depth()); 
                    fi;
# printf "start_up_thread_scheduler'' shutdown half/ZZZ  mode d=%d\n"   (mps::get_uninterruptible_scope_nesting_depth()); 

                    status;
                };

            #
            fun start_up_thread_scheduler                                       # Exported.
                    (first_thread_thunk: Void -> Void)
                =
{
# printf "start_up_thread_scheduler/TOP mode d=%d -- thread-scheduler-control-g.pkg\n"  (mps::get_uninterruptible_scope_nesting_depth());
                if (tsr::thread_scheduler_is_running ())
                    #
# printf "start_up_thread_scheduler/AAA: mode d=%d thread scheduler is running, calling first_thread_thunk -- thread-scheduler-control-g.pkg\n"  (mps::get_uninterruptible_scope_nesting_depth());
                    {   first_thread_thunk ();
# printf "start_up_thread_scheduler/BBB: mode d=%d  thread scheduler is running, back from calling first_thread_thunk -- thread-scheduler-control-g.pkg\n"  (mps::get_uninterruptible_scope_nesting_depth());
                        winix__premicrothread::process::success;
                    }
                    except
                        _ = winix__premicrothread::process::failure;

                else
# printf "start_up_thread_scheduler/MMM: mode d=%d thread scheduler is NOT running, calling start_up_thread_scheduler''  thunk -- thread-scheduler-control-g.pkg\n"  (mps::get_uninterruptible_scope_nesting_depth());
result =
                    start_up_thread_scheduler'' 
                      ( first_thread_thunk,                                     # Thunk for initial thread to run.
                        NULL                                                    # THE timeslicing time quantum. If NULL, defaults to 20 milliseconds.
                      );
# printf "start_up_thread_scheduler/NNN: mode d=%d thread scheduler is NOT running, back from calling start_up_thread_scheduler''  thunk -- thread-scheduler-control-g.pkg\n"  (mps::get_uninterruptible_scope_nesting_depth());
result;
                fi;
};

            #
            fun start_up_thread_scheduler'                                      # Exported.
                    time 
                    (first_thread_thunk: Void -> Void)
                =
                if (tsr::thread_scheduler_is_running ())
                    #
                    {   first_thread_thunk ();
                        winix__premicrothread::process::success;
                    }
                    except
                        _ = winix__premicrothread::process::failure;
                else
                    start_up_thread_scheduler'' 
                      ( first_thread_thunk,                                     # Thunk for initial thread to run.
                        THE time                                                # THE timeslicing time quantum. If NULL, defaults to 20 milliseconds.
                      );
                fi;

            # Run given first_thread_thunk with
            # threadkit concurrency support.
            #
            # Make life easy for the user by
            # nesting cleanly -- we start up
            # threadkit only if needed, if it
            # is already running we just run
            # the thunk and return:
            #
            fun run_under_thread_scheduler
                    first_thread_thunk
                =
                if (tsr::thread_scheduler_is_running ())
                    #
                    first_thread_thunk ();

                    ();
                else
                    start_up_thread_scheduler  .{
                        #
                        first_thread_thunk ();

                        shut_down_thread_scheduler  0;
                    };

                    ();                         # Return Void.
                fi;



            #################################################################3
            # This stuff added 2012-07-29 CrT to make Mythryl
            # multi-threaded by default instead of optionally:
            #
                                                                                                my _ =
            {
 if TRUE
                fun start_up_thread_scheduler''' ()
                    =
                    fat::call_with_current_fate
                        (fn my_fate
                            =
                            {   fun my_thunk ()
                                    =
                                    fat::switch_to_fate  my_fate  ();
 
# printf "start_up_thread_scheduler''' calling start_up_thread_scheduler'' ... \n";
                                result
                                    =
                                    start_up_thread_scheduler'' (my_thunk, NULL);
# printf "start_up_thread_scheduler''' back from calling start_up_thread_scheduler'', now calling  ====> winix__premicrothread::process::exit <====... \n";

                                winix__premicrothread::process::exit  result;
 
                                ();
                            }
                        );

                fun start_up_thread_scheduler'''' _                                             # The ignored arg here will be at::STARTUP_PHASE_12_START_THREAD_SCHEDULER.
                    =
{
# printf "start_up_thread_scheduler''''/top mode d=%d\n" (mps::get_uninterruptible_scope_nesting_depth());
                    start_up_thread_scheduler''' ();
};
 
                fun shut_down_thread_scheduler'''' _                                            # The ignored arg here will be at::SHUTDOWN_PHASE_3_STOP_THREAD_SCHEDULER.
                    =
                    {
# printf "shut_down_thread_scheduler''''/TOP\n"; 
                        if (tsr::thread_scheduler_is_running ()                 # Try to be robust against different shutdown sequences etc.
                        and (not *tsr::started_thread_scheduler_shutdown)
                        )       
                            #
                            tsr::started_thread_scheduler_shutdown :=  TRUE;
                                                                                    # Compare this block with corresponding block in   wrap_for_export()   from   src/lib/src/lib/thread-kit/src/glue/threadkit-base-for-os-g.pkg
                                                                                    #
# printf "shut_down_thread_scheduler''''/AAA:   cu::do_actions_for  cu::THREADKIT_SHUTDOWN\n"; 
                            cu::do_actions_for  cu::THREADKIT_SHUTDOWN;         # Lets various imps clean up, for example by closing X sockets in   src/lib/x-kit/xclient/src/wire/socket-closer-imp.pkg
# printf "shut_down_thread_scheduler''''/BBB:   drv::stop_threadkit_driver      ()\n"; 
                            drv::stop_threadkit_driver      ();                 # Merely clears the timeout-mailop.pkg list of threads waiting for timeouts.
                            #                                                   #
# printf "shut_down_thread_scheduler''''/CCC:   mps::stop_thread_scheduler_timer ()\n"; 
                            mps::stop_thread_scheduler_timer ();                        # Stops 50Hz SIGALRM, sets alarm_signal handler to IGNORE.
#  printf "shut_down_thread_scheduler''''/DDD:   th::reset_thread_package { running => FALSE }\n"; 
                            th::reset_thread_package { running => FALSE };              # microthread.pkg:  tid_count :=  0;   microthread-preemptive-scheduler.pkg: Clears hooks, queues, cached time, current thread.

                            tsr::thread_scheduler_is_running_as_pid                     # Thread scheduler is no longer running.
                                :=
                                NULL;


                            ri::print_hook
                                :=
                                *saved_print_function;


                            is::set_signal_handler
                                #
                                (is::SIGINT, *saved_interrupt_handler);

# printf "shut_down_thread_scheduler''''/ZZZ\n"; 
                            ();
                        fi;
                    };
# OLD -- doesn't return, and to run all shutdown actions in sequence various places we need this to return
#                   shut_down_thread_scheduler  winix__premicrothread::process::success;        
 
                at::schedule  ("thread-scheduler-control-g.pkg:   start up thread scheduler",      [ at::STARTUP_PHASE_12_START_THREAD_SCHEDULER ],  start_up_thread_scheduler''''      );
                at::schedule  ("thread-scheduler-control-g.pkg:   shut down thread scheduler",     [ at::SHUTDOWN_PHASE_3_STOP_THREAD_SCHEDULER  ],  shut_down_thread_scheduler''''     );
 (); fi;
            };
            #
            #################################################################3



            stipulate
                Cmdt = bas::Pair (String, List( String ))
                       ->
                       wnx::process::Status;
            herein
                #
                spawn_to_disk' =   cfun "spawn_to_disk" :   (String, Cmdt) -> Void;
            end;

            #
            fun spawn_to_disk (file_name, main, time_q)
                =
                {   if (tsr::thread_scheduler_is_running ())   raise exception  FAIL "Cannot spawn_to_disk while threadkit is running";   fi;
                    #
                    tsr::thread_scheduler_is_running_as_pid                                             # Remember that thread scheduler is now running.
                        :=                                                                              # (WTF?! -- 2012-07-21 CrT)
                        THE (wxp::get_process_id ());

                    is::mask_signals  is::MASK_ALL;

                    ri::at::run_functions_scheduled_to_run   ri::at::SPAWN_TO_DISK;                     # Avoid some space-leaks.

                    cu::export_fn_cleanup ();                                                           # Strip out any unecessary stuff from the threadkit Cleanup state.

                    ri::print_hook :=   (fn _ = ());                                                    # Unlink the SML print function. 

                    uns::pervasive_package_pickle_list__global                                          # Clear the pervasive package list of picklehash-pickle pairs.
                        :=
                        uns::p::NIL;

                    spawn_to_disk'  (file_name,  bas::wrap_for_export (main, time_q));                  # Export the wrapped main function.
                };
        end;                                                                                            # stipulate
    };
end;


Comments and suggestions to: bugs@mythryl.org

PreviousUpNext