?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE : Tasking : Ring 2 support' ??
MODULE pmm$tasking_support_ring_2;

{  PURPOSE:
{    This module contains ring 2 procedures and data structures necessary to support tasking.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc pmt$task_id
*copyc pmh$tmm$manage_signals_and_flag
*copyc pmt$task_control_block
*copyc clc$standard_file_names
*copyc pme$execution_exceptions
*copyc pmt$program_description
*copyc pmt$loader_seq_descriptor
*copyc pmt$max_number_of_tasks
*copyc pmt$program_parameters
*copyc pmt$os_stack_frame_word
*copyc pmt$task_status
*copyc osd$virtual_address
*copyc ost$status
*copyc ose$heap_full_exceptions
*copyc pme$debug_exceptions
*copyc pme$execution_exceptions
*copyc oss$job_pageable
*copyc ost$signature_lock_status
*copyc ost$stack_frame_save_area
?? POP ??
*copyc clp$find_current_job_synch_task
*copyc jmp$job_monitor_xcb
*copyc osp$clear_job_signature_lock
*copyc osp$fetch_locked_variable
*copyc osp$increment_locked_variable
*copyc osp$initialize_sig_lock
*copyc osp$set_job_signature_lock
*copyc osp$system_error
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc pmp$trap_handler
*copyc mmp$change_segment_inheritance
*copyc mmp$close_shared_stack
*copyc mmp$create_inherited_sdt
*copyc mmp$create_segment
*copyc mmp$create_shared_stack
*copyc mmp$delete_inherited_sdt
*copyc mmp$delete_non_inherited_segs
*copyc mmp$task_delete_inherited_sdt
*copyc pmp$create_child_xcb
*copyc pmp$release_child_xcb
*copyc pmp$cycle
*copyc pmp$exit
*copyc pmp$initialize_job_xcb_list
*copyc pmp$find_task_xcb
*copyc pmp$find_executing_task_xcb
*copyc pmp$find_executing_task_tcb
*copyc pmp$get_global_task_id
*copyc pmp$set_system_flag
*copyc sfp$update_job_limit_accum
*copyc tmp$find_ring_crossing_frame
*copyc oss$job_paged_literal
*copyc osv$job_pageable_heap
*copyc osv$task_shared_heap
*copyc pmv$popper_handler_established
*copyc pmv$task_execution_phase


  VAR
    pmv$ada_task_table_lock: [STATIC, oss$job_pageable] ost$signature_lock,
    pmv$job_monitor_tcb_p: [XDCL, #GATE, oss$job_pageable] ^pmt$task_control_block,
    pmv$task_control_block_lock: [STATIC, oss$job_pageable] ost$signature_lock,
    pmv$job_initialization_complete: [XDCL, #GATE, oss$job_pageable] boolean := FALSE,
    mpe_description: [STATIC, oss$job_pageable] pmt$loader_description := [FALSE, * , * ];

?? FMT (FORMAT := OFF) ??

  VAR
    tcb_proto: [STATIC, READ, oss$job_paged_literal] pmt$task_control_block := [
{ task_id                       } 0,
{ parent                        } NIL,
{ first_child                   } NIL,
{ next_sibling                  } NIL,
{ target_ring                   } osc$invalid_ring,
{ condition_environment_stack   } NIL,
{ flag_execution_ring           } [REP osc$maximum_system_flag + 1 of 0],
{ signal_execution_ring         } [0, 0, 0, 0],
{ task_local_signal_list        } [NIL, NIL],
{ task_kill_count               } 0,
{ task_kill_phase               } LOWERVALUE (pmt$task_execution_phase),
{ task_kind                     } osc$tk_nosve_task, [
{   program_description           } NIL,
{   mpe_description               } ^mpe_description,
{   program_parameters            } NIL,
{   termination_status            } NIL,
{   parent_task_status_variable   } NIL,
{   debug_table                   } NIL,
{   debug_input                   } clc$null_file,
{   debug_output                  } clc$null_file,
{   abort_file                    } clc$null_file,
{   initial_debug_mode            } pmc$debug_mode_off,
{   cl_task                       } FALSE,
{   ada_shared_stack_pointer      } [mmc$cell_pointer, NIL],
{   ada_critical_frame            } NIL,
{   ada_starting_procedure        } NIL,
{   ada_task_table                } NIL,
{   task_condition_count          } 0,
{   task_handler_count            } 0,
{   task_io_enabled               } TRUE]];

?? FMT (FORMAT := ON) ??

  VAR
    debug_table_proto: [STATIC, READ, oss$job_paged_literal] pmt$debug_table_info :=
          [[mmc$sequence_pointer, NIL], [mmc$sequence_pointer, NIL], NIL, NIL, NIL, NIL, 0];

?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$initialize_tasking_tables', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$initialize_tasking_tables
    (    job_monitor_initial_ring: ost$ring;
         job_monitor_program_description: ^pmt$program_description;
         job_monitor_parameters: ^pmt$program_parameters);

{  PURPOSE:
{    This procedure is responsible for initializing all tasking tables at job initiation and
{    generating entries in them for the job_monitor task.

    ALLOCATE pmv$job_monitor_tcb_p IN osv$job_pageable_heap^;
    pmv$job_monitor_tcb_p^ := tcb_proto;
    ALLOCATE pmv$job_monitor_tcb_p^.nosve.termination_status IN osv$task_shared_heap^;
    assign_task_id (pmv$job_monitor_tcb_p^.task_id);
    ALLOCATE pmv$job_monitor_tcb_p^.nosve.debug_table IN osv$task_shared_heap^;
    pmv$job_monitor_tcb_p^.nosve.debug_table^ := debug_table_proto;
    pmv$job_monitor_tcb_p^.nosve.program_description := job_monitor_program_description;
    pmv$job_monitor_tcb_p^.nosve.program_parameters := job_monitor_parameters;
    pmv$job_monitor_tcb_p^.nosve.termination_status^.normal := TRUE;
    pmv$job_monitor_tcb_p^.target_ring := job_monitor_initial_ring;
    osp$initialize_sig_lock (pmv$task_control_block_lock);
    osp$initialize_sig_lock (pmv$ada_task_table_lock);
    pmp$initialize_job_xcb_list (pmv$job_monitor_tcb_p^.task_id, pmv$job_monitor_tcb_p, ^pmp$trap_handler);
    pmv$job_initialization_complete := TRUE;
  PROCEND pmp$initialize_tasking_tables;
?? TITLE := '  [XDCL, #GATE] pmp$update_jmtr_tcb_target_ring', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$update_jmtr_tcb_target_ring
    (    job_monitor_initial_ring: ost$ring);

    VAR
      xcb: ^ost$execution_control_block,
      tcb: ^pmt$task_control_block;

    xcb := jmp$job_monitor_xcb ();
    tcb := xcb^.task_control_block;
    tcb^.target_ring := job_monitor_initial_ring;
  PROCEND pmp$update_jmtr_tcb_target_ring;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$create_shared_stack', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$create_shared_stack
    (    segment_attributes: ^array [ * ] of mmt$attribute_descriptor;
     VAR status: ost$status);

    VAR
      tcb: ^pmt$task_control_block,
      entry: pmt$max_number_of_tasks,
      entry1: pmt$max_number_of_tasks,
      task_ids: ^array [1 .. * ] of pmt$task_id;

{ Get the pointer to our task control block.

    pmp$find_executing_task_tcb (tcb);

{  Lock ada_task_table so that it is not altered during stack creation.

    osp$set_job_signature_lock (pmv$ada_task_table_lock);

{ Get task table from task control block.

    PUSH task_ids: [1 .. tcb^.nosve.ada_task_table^.current_entry + 1];
    entry1 := 1;
    FOR entry := 0 TO tcb^.nosve.ada_task_table^.current_entry DO
      task_ids^ [entry1] := tcb^.nosve.ada_task_table^.table [entry];
      entry1 := entry1 + 1;
    FOREND;

{ Call Memory Manager to create the shared stack.

    mmp$create_shared_stack (segment_attributes, mmc$cell_pointer, task_ids,
          tcb^.nosve.ada_shared_stack_pointer, status);

{  Unlock ada_task_table.

    osp$clear_job_signature_lock (pmv$ada_task_table_lock);

  PROCEND pmp$create_shared_stack;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$find_task_tcb', EJECT ??
*copy pmh$find_task_tcb

  PROCEDURE [XDCL, #GATE] pmp$find_task_tcb
    (    task_id: pmt$task_id;
     VAR tcb: ^pmt$task_control_block);

    VAR
      xcb: ^ost$execution_control_block;

    pmp$find_task_xcb (task_id, xcb);
    IF xcb = NIL THEN
      tcb := NIL;
    ELSE
      tcb := xcb^.task_control_block;
    IFEND;
  PROCEND pmp$find_task_tcb;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$create_task_environment', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$create_task_environment
    (    program_description: ^pmt$program_description;
         mpe_description: ^pmt$loader_description;
         program_parameters: ^pmt$program_parameters;
         parent_task_status_variable: ^pmt$task_status;
         target_ring: ost$ring;
         critical_frame: ^ost$stack_frame_save_area;
         starting_procedure: pmt$user_program;
         cl_task: boolean;
     VAR task_id: pmt$task_id;
     VAR status: ost$status);

{  PURPOSE:
{    This procedure is responsible for creating a fundamental task environment for a new
{    child task.

*copyc pmp$task_begin
?? NEWTITLE := '  create_child_tcb', EJECT ??

    PROCEDURE create_child_tcb
      (    task_id: pmt$task_id;
           program_description: ^pmt$program_description;
           mpe_description: ^pmt$loader_description;
           program_parameters: ^pmt$program_parameters;
           parent_task_status_variable: ^pmt$task_status;
           target_ring: ost$ring;
           cl_task: boolean;
       VAR child_tcb: ^pmt$task_control_block);

      VAR
        zero_length_sequence: [oss$job_pageable] SEQ (REP 0 of cell);

{  PURPOSE:
{    This procedure creates a TCB for a new child task.

      ALLOCATE child_tcb IN osv$job_pageable_heap^;
      child_tcb^ := tcb_proto;
      ALLOCATE child_tcb^.nosve.program_description: [[REP #SIZE (program_description^) OF cell]] IN
            osv$job_pageable_heap^;
      ALLOCATE child_tcb^.nosve.mpe_description IN osv$job_pageable_heap^;
      IF #SIZE (program_parameters^) > 0 THEN
        ALLOCATE child_tcb^.nosve.program_parameters: [[REP #SIZE (program_parameters^) OF cell]] IN
              osv$job_pageable_heap^;
      ELSE
        child_tcb^.nosve.program_parameters := ^zero_length_sequence;
      IFEND;
      ALLOCATE child_tcb^.nosve.termination_status IN osv$task_shared_heap^;
      ALLOCATE child_tcb^.nosve.debug_table IN osv$task_shared_heap^;
      child_tcb^.task_id := task_id;
      child_tcb^.nosve.debug_table^ := debug_table_proto;
      pmp$find_executing_task_tcb (child_tcb^.parent);

{  Lock parent_child list.  (Necessary if anyone other than parent scans child list.)

      osp$set_job_signature_lock (pmv$task_control_block_lock);

      child_tcb^.next_sibling := child_tcb^.parent^.first_child;
      child_tcb^.parent^.first_child := child_tcb;

{ The inheritance of the timesharing IO capability needs to be protected by a the lock to ensure that a task
{ does not get disabled from doing IO even after all conditions within the parent synchronous task chain have
{ disappeared.  For example:
{   Task A is the parent of task B.  Task B has IO disabled because of a condition in task A.  Task B begins
{ to create task C's environment.  Task A completes the conditions and begins to update the task environment.
{ There is a risk that task C will get its IO disabled by task B after task A has started updating
{ (re-enabling IO) in the appropriate tasks.

      child_tcb^.nosve.task_io_enabled := child_tcb^.parent^.nosve.task_io_enabled;

{  Unlock parent_child list.

      osp$clear_job_signature_lock (pmv$task_control_block_lock);

      child_tcb^.nosve.program_description^ := program_description^;
      child_tcb^.nosve.mpe_description^ := mpe_description^;
      child_tcb^.nosve.program_parameters^ := program_parameters^;
      child_tcb^.nosve.termination_status^.normal := TRUE;
      child_tcb^.nosve.parent_task_status_variable := parent_task_status_variable;
      child_tcb^.target_ring := target_ring;
      child_tcb^.nosve.cl_task := cl_task;

    PROCEND create_child_tcb;
?? OLDTITLE ??
?? NEWTITLE := ' create_ada_environment', EJECT ??

    PROCEDURE create_ada_environment
      (    child: ^pmt$task_control_block;
       VAR status: ost$status);

{  PURPOSE:
{    This procedure is responsible for adding the ADA asynchronous procedure information
{    into the task control block of a child task.
{

      IF NOT ((child^.parent^.nosve.ada_task_table <> NIL) AND
            (child^.parent^.nosve.ada_task_table^.current_entry <
            UPPERBOUND (child^.parent^.nosve.ada_task_table^.table))) THEN
        osp$set_status_abnormal ('PM', pme$no_available_stacks, '', status);
        osp$clear_job_signature_lock (pmv$ada_task_table_lock);
        RETURN
      IFEND;

      child^.nosve.ada_critical_frame := critical_frame^.minimum_save_area.a1_current_stack_frame;
      child^.nosve.ada_task_table := child^.parent^.nosve.ada_task_table;
      child^.nosve.ada_task_table^.current_entry := child^.nosve.ada_task_table^.current_entry + 1;
      child^.nosve.ada_task_table^.table [child^.nosve.ada_task_table^.current_entry] := task_id;
      child^.nosve.ada_starting_procedure := starting_procedure;
      osp$clear_job_signature_lock (pmv$ada_task_table_lock);

    PROCEND create_ada_environment;
?? OLDTITLE ??
?? NEWTITLE := 'copy_parent_debug_tables', EJECT ??

    PROCEDURE copy_parent_debug_tables
      (    child: ^pmt$task_control_block;
       VAR status: ost$status);

{  PURPOSE:
{    This procedure is responsible for copying the debug table information from the parent's
{    address space into the address space of the asynchronous procedure being initiated.
{

      VAR
        pva: ^cell,
        ring_attributes: array [1 .. 1] of mmt$attribute_descriptor;

{  Copy Parent Task debug tables.

      ring_attributes [1].keyword := mmc$kw_ring_numbers;
      ring_attributes [1].r1 := osc$tsrv_ring;
      ring_attributes [1].r2 := 0f(16);

      IF child^.parent^.nosve.debug_table^.module_segment.seq_pointer <> NIL THEN
        mmp$create_segment (^ring_attributes, mmc$sequence_pointer, 1,
              child^.nosve.debug_table^.module_segment, status);
        IF status.normal THEN
          child^.nosve.debug_table^.last_module_item := ^child^.nosve.debug_table^.
                first_module_address_table_item;
          RESET child^.nosve.debug_table^.module_segment.seq_pointer;
          child^.parent^.nosve.debug_table^.current_module_item :=
                child^.parent^.nosve.debug_table^.first_module_address_table_item;

        /copy_module_segment/
          WHILE child^.parent^.nosve.debug_table^.current_module_item <> NIL DO
            NEXT child^.nosve.debug_table^.current_module_item:
                  [0 .. child^.parent^.nosve.debug_table^.current_module_item^.greatest_section_ordinal] IN
                  child^.nosve.debug_table^.module_segment.seq_pointer;
            IF child^.nosve.debug_table^.current_module_item <> NIL THEN
              child^.nosve.debug_table^.current_module_item^ :=
                    child^.parent^.nosve.debug_table^.current_module_item^;
            ELSE
              osp$set_status_abnormal ('PM', pme$module_segment_overflow, '', status);
              EXIT /copy_module_segment/;
            IFEND;

            child^.nosve.debug_table^.last_module_item^ := child^.nosve.debug_table^.current_module_item;
            child^.nosve.debug_table^.last_module_item := ^child^.nosve.debug_table^.last_module_item^^.
                  next_module;
            child^.parent^.nosve.debug_table^.current_module_item :=
                  child^.parent^.nosve.debug_table^.current_module_item^.next_module;
          WHILEND /copy_module_segment/;

          child^.parent^.nosve.debug_table^.current_module_item := NIL;
          child^.nosve.debug_table^.current_module_item := NIL;

          IF status.normal THEN
            pva := child^.nosve.debug_table^.module_segment.seq_pointer;
            mmp$change_segment_inheritance (pva, mmc$si_transfer_segment, status);
          IFEND;

          IF status.normal AND (child^.parent^.nosve.debug_table^.entry_point_segment.seq_pointer <> NIL) THEN
            mmp$create_segment (^ring_attributes, mmc$sequence_pointer, 1,
                  child^.nosve.debug_table^.entry_point_segment, status);
            IF status.normal THEN
              RESET child^.nosve.debug_table^.entry_point_segment.seq_pointer;
              RESET child^.parent^.nosve.debug_table^.entry_point_segment.seq_pointer;
              NEXT child^.parent^.nosve.debug_table^.entry_point_table:
                    [1 .. child^.parent^.nosve.debug_table^.number_of_entry_point_items] IN
                    child^.parent^.nosve.debug_table^.entry_point_segment.seq_pointer;
              NEXT child^.nosve.debug_table^.entry_point_table:
                    [1 .. child^.parent^.nosve.debug_table^.number_of_entry_point_items] IN
                    child^.nosve.debug_table^.entry_point_segment.seq_pointer;
              IF child^.nosve.debug_table^.entry_point_table <> NIL THEN
                child^.nosve.debug_table^.entry_point_table^ :=
                      child^.parent^.nosve.debug_table^.entry_point_table^;
                child^.nosve.debug_table^.number_of_entry_point_items :=
                      child^.parent^.nosve.debug_table^.number_of_entry_point_items;
                pva := child^.nosve.debug_table^.entry_point_segment.seq_pointer;
                mmp$change_segment_inheritance (pva, mmc$si_transfer_segment, status);
              ELSE
                osp$set_status_abnormal ('PM', pme$entry_pt_segment_overflow, '', status);
              IFEND;
            IFEND;
          IFEND;
        IFEND;
      IFEND;

    PROCEND copy_parent_debug_tables;
?? OLDTITLE, EJECT ??

    VAR
      local_status: ost$status,
      child_tcb: ^pmt$task_control_block,
      ignored_status: ost$status;

    sfp$update_job_limit_accum (avc$task_limit_name, 1, sfc$incremental_update, status);
    IF NOT status.normal THEN
      IF status.condition = sfe$limit_not_activated THEN
        status.normal := TRUE;
      ELSE
        RETURN;
      IFEND;
    IFEND;

    assign_task_id (task_id);
    IF starting_procedure <> NIL THEN
      osp$set_job_signature_lock (pmv$ada_task_table_lock);
    IFEND;

{!! NOTE: The procedure calls in this routine are order dependent.  IF the order is changed
{         without changing the reasons for the current order, the routine is gaurenteed
{         to break!

    create_child_tcb (task_id, program_description, mpe_description, program_parameters,
          parent_task_status_variable, target_ring, cl_task, child_tcb);
    pmp$create_child_xcb (task_id, child_tcb, ^pmp$task_begin, osc$tsrv_ring, child_tcb^.task_kind, status);
    IF status.normal THEN
      IF starting_procedure <> NIL THEN
        copy_parent_debug_tables (child_tcb, status);
      IFEND;
      IF status.normal THEN
        mmp$create_inherited_sdt (task_id, status);
        IF status.normal THEN
          IF starting_procedure <> NIL THEN
            create_ada_environment (child_tcb, status);

{!! NOTE:  Procedure create_ada_environment unlocks the ada_task_table.

          IFEND;
          IF status.normal THEN
            RETURN
          IFEND;
          mmp$delete_inherited_sdt (task_id, local_status);
          IF NOT local_status.normal THEN
            osp$system_error ('Error in clean up after create_ada_environment failed',
                  ^local_status);
          IFEND;
        IFEND;
      IFEND;
      pmp$release_child_xcb (task_id, child_tcb);
    IFEND;
    release_child_tcb (child_tcb);
    sfp$update_job_limit_accum (avc$task_limit_name, -1, sfc$incremental_update, ignored_status);

  PROCEND pmp$create_task_environment;
?? TITLE := '  assign_task_id', EJECT ??

  PROCEDURE assign_task_id
    (VAR task_id: pmt$task_id);

{  PURPOSE:
{    This procedure selects a task_id for assignment to a new task.

    TYPE
      pmt$task_id_last_assigned = record
        value: ALIGNED [0 MOD 8] ost$compare_swap_lock,
      recend;

    VAR
      initial_value: integer,
      new_task_id: integer,
      xcb: ^ost$execution_control_block,
      task_id_last_assigned: [STATIC] pmt$task_id_last_assigned := [UPPERVALUE (pmt$task_id)];

    REPEAT
      osp$fetch_locked_variable (task_id_last_assigned.value, initial_value);
      osp$increment_locked_variable (task_id_last_assigned.value, initial_value, new_task_id);
      task_id := new_task_id;
      pmp$find_task_xcb (task_id, xcb);
    UNTIL xcb = NIL;
  PROCEND assign_task_id;
?? TITLE := '  [XDCL, #GATE] pmp$fix_initial_debug' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$fix_initial_debug
    (    task_debug_mode: pmt$debug_mode;
         debug_input: amt$local_file_name;
         debug_output: amt$local_file_name;
         abort_file: amt$local_file_name);

    VAR
      tcb: ^pmt$task_control_block;

    pmp$find_executing_task_tcb (tcb);
    tcb^.nosve.initial_debug_mode := task_debug_mode;
    tcb^.nosve.debug_input := debug_input;
    tcb^.nosve.debug_output := debug_output;
    tcb^.nosve.abort_file := abort_file;
  PROCEND pmp$fix_initial_debug;
?? TITLE := '  [XDCL, #GATE] pmp$delete_non_inherited_segs' ??
?? EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$delete_non_inherited_segs
    (VAR status: ost$status);

{  PURPOSE:
{    This procedure is responsible for releasing all non-inherited segments
{    from the terminating task.


    VAR
      tcb: ^pmt$task_control_block;


    pmp$find_executing_task_tcb (tcb);
    IF tcb^.nosve.ada_starting_procedure <> NIL THEN
      unlink_ada_environment (tcb);
    IFEND;
    mmp$delete_non_inherited_segs (status);
  PROCEND pmp$delete_non_inherited_segs;
?? TITLE := '  [XDCL, #GATE] pmp$release_task_environment', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$release_task_environment
    (    task_id: pmt$task_id);

{  PURPOSE:
{    This procedure is responsible for releasing the space occupied by a terminated child
{    task's fundamental task environment.

    VAR
      child_tcb: ^pmt$task_control_block,
      xcb: ^ost$execution_control_block,
      ignored_status: ost$status,
      local_status: ost$status;


    pmp$find_task_xcb (task_id, xcb);
    WHILE NOT xcb^.task_has_terminated DO
      pmp$cycle (local_status);
    WHILEND;

    mmp$task_delete_inherited_sdt (task_id, local_status);
    IF NOT local_status.normal THEN
      osp$system_error ('unexpected abnormal status', ^local_status);
    IFEND;
    pmp$release_child_xcb (task_id, child_tcb);
    release_child_tcb (child_tcb);
    sfp$update_job_limit_accum (avc$task_limit_name, -1, sfc$incremental_update, ignored_status);
  PROCEND pmp$release_task_environment;
?? TITLE := '  release_child_tcb', EJECT ??

  PROCEDURE release_child_tcb
    (VAR child_tcb: ^pmt$task_control_block);

{  PURPOSE:
{    This procedure releases the space occupied by a child task's TCB.

    VAR
      sibling: ^^pmt$task_control_block;

{  Lock parent_child list.  (Necessary if anyone other than parent scans child list.)

    osp$set_job_signature_lock (pmv$task_control_block_lock);

    sibling := ^child_tcb^.parent^.first_child;

  /delink_parent_child_tree/
    WHILE (sibling^ <> NIL) AND (sibling^ <> child_tcb) DO
      sibling := ^sibling^^.next_sibling;
    WHILEND /delink_parent_child_tree/;
    IF sibling^ = NIL THEN

{ Unlock parent_child list.

      osp$clear_job_signature_lock (pmv$task_control_block_lock);

      osp$system_error ('parent_child relationship', NIL);
    ELSE
      sibling^ := child_tcb^.next_sibling;
      FREE child_tcb^.nosve.termination_status IN osv$task_shared_heap^;
      FREE child_tcb^.nosve.debug_table IN osv$task_shared_heap^;
      FREE child_tcb^.nosve.program_description IN osv$job_pageable_heap^;
      FREE child_tcb^.nosve.mpe_description IN osv$job_pageable_heap^;
      IF #SIZE (child_tcb^.nosve.program_parameters^) > 0 THEN
        FREE child_tcb^.nosve.program_parameters IN osv$job_pageable_heap^;
      IFEND;

      IF (child_tcb^.nosve.ada_task_table <> NIL) AND (child_tcb^.nosve.ada_starting_procedure = NIL) THEN
        FREE child_tcb^.nosve.ada_task_table IN osv$task_shared_heap^;
      IFEND;

      FREE child_tcb IN osv$job_pageable_heap^;

{ Unlock parent_child list.

      osp$clear_job_signature_lock (pmv$task_control_block_lock);

    IFEND;
  PROCEND release_child_tcb;
?? OLDTITLE ??
?? NEWTITLE := 'unlink_ada_environment', EJECT ??

  PROCEDURE unlink_ada_environment
    (    child: ^pmt$task_control_block);

{  PURPOSE:
{    This procedure is responsible for unlinking the ADA asynchronous procedure information
{    from the task control block of the parent task.
{


    VAR
      entry1: pmt$max_number_of_tasks,
      task_ids: ^array [1 .. * ] of pmt$task_id,
      os_stack_frame_word: ^pmt$os_stack_frame_word,
      local_status: ost$status,
      entry_found: boolean,
      entry: pmt$max_number_of_tasks;


{  Lock ada_task_table..  (Necessary to assure synchronization during initiation and termination.)

    osp$set_job_signature_lock (pmv$ada_task_table_lock);

    IF (child^.nosve.ada_task_table = NIL) OR NOT (child^.nosve.ada_task_table^.current_entry <=
          UPPERBOUND (child^.nosve.ada_task_table^.table)) THEN
      osp$clear_job_signature_lock (pmv$ada_task_table_lock);
      osp$system_error ('ada task table error', NIL);
    IFEND;

{ Get task table from task control block.

    PUSH task_ids: [1 .. child^.nosve.ada_task_table^.current_entry + 1];
    entry1 := 1;
    FOR entry := 0 TO child^.nosve.ada_task_table^.current_entry DO
      task_ids^ [entry1] := child^.nosve.ada_task_table^.table [entry];
      entry1 := entry1 + 1;
    FOREND;

{ Call Memory Manager to close the shared stack.

    mmp$close_shared_stack (child^.nosve.ada_shared_stack_pointer, task_ids, local_status);

{ Find this task's task_id entry in the ADA task table.

    entry := 1;
    entry_found := TRUE;

  /find_task_entry/
    BEGIN
      WHILE entry <= child^.nosve.ada_task_table^.current_entry DO
        IF child^.nosve.ada_task_table^.table [entry] = child^.task_id THEN
          EXIT /find_task_entry/;
        IFEND;
        entry := entry + 1;
      WHILEND;
      entry_found := FALSE;
    END /find_task_entry/;

    IF NOT entry_found THEN

{ Unlock ada_task_table.

      osp$clear_job_signature_lock (pmv$ada_task_table_lock);
      osp$system_error ('ada task table error', NIL);
    IFEND;

{ Remove the entry from the list if it is not the last entry in the list.

    IF NOT (entry = child^.nosve.ada_task_table^.current_entry) THEN
      WHILE entry < child^.nosve.ada_task_table^.current_entry DO
        child^.nosve.ada_task_table^.table [entry] := child^.nosve.ada_task_table^.table [entry + 1];
        entry := entry + 1;
      WHILEND;
    IFEND;

    child^.nosve.ada_task_table^.current_entry := child^.nosve.ada_task_table^.current_entry - 1;

{ Unlock ada_task_table.

    osp$clear_job_signature_lock (pmv$ada_task_table_lock);

{ Decrement the caller's critical frame count.  We do not need to lock the frame count since we are
{ executing below the recognition ring.

    IF (child^.nosve.ada_critical_frame <> NIL) THEN
      os_stack_frame_word := child^.nosve.ada_critical_frame;
      IF (os_stack_frame_word^.ada_critical_frame) AND (os_stack_frame_word^.ada_critical_frame_count > 0)
            THEN
        os_stack_frame_word^.ada_critical_frame_count := os_stack_frame_word^.ada_critical_frame_count - 1;
        IF os_stack_frame_word^.ada_critical_frame_count = 0 THEN
          os_stack_frame_word^.ada_critical_frame := FALSE;
        IFEND;
      IFEND;
    IFEND;


  PROCEND unlink_ada_environment;
?? TITLE := ' [XDCL, #GATE] pmp$build_ada_task_table', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$build_ada_task_table
    (    number_of_tasks: pmt$max_number_of_tasks;
     VAR status: ost$status);


    VAR
      tcb: ^pmt$task_control_block;

    pmp$find_executing_task_tcb (tcb);
    IF (tcb^.nosve.ada_starting_procedure <> NIL) OR (tcb^.nosve.ada_task_table <> NIL) THEN
      osp$set_status_abnormal ('PM', pme$illegal_ada_control_task, '', status);
      RETURN;
    IFEND;

    ALLOCATE tcb^.nosve.ada_task_table: [0 .. number_of_tasks] IN osv$task_shared_heap^;

    tcb^.nosve.ada_task_table^.current_entry := 0;
    tcb^.nosve.ada_task_table^.table [tcb^.nosve.ada_task_table^.current_entry] := tcb^.task_id;

  PROCEND pmp$build_ada_task_table;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$disable_ts_io_in_tasks', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$disable_ts_io_in_tasks;

{ Purpose: This procedure is called to disable timesharing (interactive) IO in tasks.
{
{ Assumptions: This procedure is only called from the job monitor task.
{              The job monitor task cannot have any siblings.

    VAR
      job_monitor_xcb_p: ^ost$execution_control_block,
      job_monitor_tcb_p: ^pmt$task_control_block;

?? NEWTITLE := '      disable_io_in_tasks', EJECT ??

    PROCEDURE disable_io_in_tasks
      (    tcb_p: ^pmt$task_control_block);

      VAR
        sibling_tcb_p: ^pmt$task_control_block;

      sibling_tcb_p := tcb_p;
      WHILE sibling_tcb_p <> NIL DO
        sibling_tcb_p^.nosve.task_io_enabled := FALSE;

{ disable io in all the children of this task

        IF sibling_tcb_p^.first_child <> NIL THEN
          disable_io_in_tasks (sibling_tcb_p^.first_child);
        IFEND;

{ go on to disable the next sibling

        sibling_tcb_p := sibling_tcb_p^.next_sibling;
      WHILEND;
    PROCEND disable_io_in_tasks;

?? OLDTITLE, EJECT ??

{  Lock parent_child list.  (Necessary if anyone other than parent scans child list.)

    osp$set_job_signature_lock (pmv$task_control_block_lock);

    job_monitor_xcb_p := jmp$job_monitor_xcb ();
    job_monitor_tcb_p := job_monitor_xcb_p^.task_control_block;

{ Disable IO in all of the child tasks - including the current job synchronous task

    IF job_monitor_tcb_p^.first_child <> NIL THEN
      disable_io_in_tasks (job_monitor_tcb_p^.first_child);
    IFEND;

{ Unlock parent_child list.

    osp$clear_job_signature_lock (pmv$task_control_block_lock);

  PROCEND pmp$disable_ts_io_in_tasks;


?? TITLE := '    PMP$ENABLE_TS_IO_IN_TASKS', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$enable_ts_io_in_tasks;

{ Purpose: This procedure is used to re-enable timesharing (interactive) IO in tasks.
{
{ Assumptions: This procedure is typically called from the current job synchronous task.
{
{ Limitations: If a condition handler in a task with multiple interactive conditions
{              starts an asynchronous task and another condition occurs, the asynchronous
{              task will not be able to perform IO on the connection.  If it attempts to
{              it will "hang" waiting for IO to it to be enabled.

    VAR
      current_job_sync_task_id: pmt$task_id,
      synchronous_tcb_p: ^pmt$task_control_block,
      executing_task_tcb_p: ^pmt$task_control_block;

?? NEWTITLE := '      enable_io_in_tasks', EJECT ??

    PROCEDURE enable_io_in_tasks
      (    tcb_p: ^pmt$task_control_block);

      VAR
        sibling_tcb_p: ^pmt$task_control_block;

      sibling_tcb_p := tcb_p;
      WHILE sibling_tcb_p <> NIL DO
        sibling_tcb_p^.nosve.task_io_enabled := TRUE;

{ enable io in all the children of this task

        IF sibling_tcb_p^.first_child <> NIL THEN
          enable_io_in_tasks (sibling_tcb_p^.first_child);
        IFEND;

{ go on to enable the next sibling

        sibling_tcb_p := sibling_tcb_p^.next_sibling;
      WHILEND;
    PROCEND enable_io_in_tasks;

?? OLDTITLE, EJECT ??

{  Lock parent_child list.  (Necessary if anyone other than parent scans child list.)

    osp$set_job_signature_lock (pmv$task_control_block_lock);

{ Trace the synchronous task chain to determine what tasking subtree to
{ start re-enabling timesharing io in.
{ Trace back until we are at the job monitor task or until the current task's parent
{ is the last task in which interactive conditions have occured.
{   CASE 1.  current task is job monitor
{     a) job monitor has conditions - do nothing - job monitor is the only synchronous task
{                                   - in the job - all others are asynchronous (this is a
{                                   - side-effect from case 2.
{     b) job monitor has no conditions - enable all tasks in the job.
{   CASE 2.  current task's parent has conditions
{     enable io within the current task's parent - it may need to do IO to deal with its conditions.
{     enable io within the current task - it may need to do IO.
{     enable io within the current task's children (the parent's synchronous child and its children) - but
{       do not enable IO within this task's siblings - they are asynchronous and cannot do IO until
{       the parent has dealt with all timesharing (interactive) conditions.

    pmp$find_executing_task_tcb (synchronous_tcb_p);

    WHILE (synchronous_tcb_p^.parent <> NIL) AND (synchronous_tcb_p^.parent^.nosve.task_condition_count = 0)
          DO
      synchronous_tcb_p := synchronous_tcb_p^.parent;
    WHILEND;

{ Are we at the job monitor task - we are if parent = NIL

    IF synchronous_tcb_p^.parent = NIL THEN

{ Should we enable IO in all tasks in the job?

      IF synchronous_tcb_p^.nosve.task_condition_count = 0 THEN
        enable_io_in_tasks (synchronous_tcb_p^.first_child);
      ELSE

{ Do nothing

      IFEND;
    ELSE

{ We are NOT in job monitor.
{ Re-enable IO within the selected task, its parent, and its children - but NOT its siblings.

      synchronous_tcb_p^.parent^.nosve.task_io_enabled := TRUE;
      synchronous_tcb_p^.nosve.task_io_enabled := TRUE;
      enable_io_in_tasks (synchronous_tcb_p^.first_child);
    IFEND;

{ Unlock parent_child list.

    osp$clear_job_signature_lock (pmv$task_control_block_lock);
  PROCEND pmp$enable_ts_io_in_tasks;

?? TITLE := '    PMP$ENABLE_TIMESHARING_IO', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$enable_timesharing_io;

{ Purpose: This interface enables a task such that it can do io on the connection.
{
{ Assumptions: This procedure is called from the current job synchronous task.

    VAR
      executing_task_tcb_p: ^pmt$task_control_block;

    pmp$find_executing_task_tcb (executing_task_tcb_p);
    executing_task_tcb_p^.nosve.task_io_enabled := TRUE;
  PROCEND pmp$enable_timesharing_io;

?? TITLE := '    PMP$BEGIN_TIMESHARING_HANDLER', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$begin_timesharing_handler;

    VAR
      executing_task_tcb_p: ^pmt$task_control_block;

    pmp$find_executing_task_tcb (executing_task_tcb_p);
    executing_task_tcb_p^.nosve.task_handler_count := executing_task_tcb_p^.nosve.task_handler_count + 1;
  PROCEND pmp$begin_timesharing_handler;

?? TITLE := '    PMP$END_TIMESHARING_HANDLER', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$end_timesharing_handler;

    VAR
      executing_task_tcb_p: ^pmt$task_control_block;

    pmp$find_executing_task_tcb (executing_task_tcb_p);
    executing_task_tcb_p^.nosve.task_handler_count := executing_task_tcb_p^.nosve.task_handler_count - 1;

    IF executing_task_tcb_p^.nosve.task_handler_count = 0 THEN
      executing_task_tcb_p^.nosve.task_condition_count := 0;
    IFEND;
  PROCEND pmp$end_timesharing_handler;

?? TITLE := '    PMP$BEGIN_TIMESHARING_CONDITION', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$begin_timesharing_condition;

    VAR
      executing_task_tcb_p: ^pmt$task_control_block;

    pmp$find_executing_task_tcb (executing_task_tcb_p);
    executing_task_tcb_p^.nosve.task_condition_count := executing_task_tcb_p^.nosve.task_condition_count + 1;
  PROCEND pmp$begin_timesharing_condition;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$enable_ts_io_in_job', EJECT ??
*copy pmh$enable_ts_io_in_job

  PROCEDURE [XDCL, #GATE] pmp$enable_ts_io_in_job;

    VAR
      job_monitor_xcb_p: ^ost$execution_control_block,
      job_monitor_tcb_p: ^pmt$task_control_block;

?? NEWTITLE := 'enable_io_in_tasks', EJECT ??

    PROCEDURE enable_io_in_tasks
      (    tcb_p: ^pmt$task_control_block);

      VAR
        sibling_tcb_p: ^pmt$task_control_block;

      sibling_tcb_p := tcb_p;
      WHILE sibling_tcb_p <> NIL DO
        sibling_tcb_p^.nosve.task_io_enabled := TRUE;

{ enable io in all the children of this task

        IF sibling_tcb_p^.first_child <> NIL THEN
          enable_io_in_tasks (sibling_tcb_p^.first_child);
        IFEND;

{ go on to enable the next sibling

        sibling_tcb_p := sibling_tcb_p^.next_sibling;
      WHILEND;
    PROCEND enable_io_in_tasks;

?? OLDTITLE ??
?? EJECT ??

{ Find the job monitor task's Task Control Block.

    job_monitor_xcb_p := jmp$job_monitor_xcb ();
    job_monitor_tcb_p := job_monitor_xcb_p^.task_control_block;

{ Lock parent_child list.  (Necessary if anyone other than parent scans child list.)

    osp$set_job_signature_lock (pmv$task_control_block_lock);

{ Enable terminal IO in the job monitor task and all of the job's other tasks.

    job_monitor_tcb_p^.nosve.task_io_enabled := TRUE;
    enable_io_in_tasks (job_monitor_tcb_p^.first_child);

{ Unlock parent_child list.

    osp$clear_job_signature_lock (pmv$task_control_block_lock);
  PROCEND pmp$enable_ts_io_in_job;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$kill_task_flag_handler', EJECT ??

  PROCEDURE [XDCL, #GATE] pmp$kill_task_flag_handler
    (    flag_id: ost$system_flag);

    VAR
      local_status: ost$status,
      tcb_p: ^pmt$task_control_block;

?? NEWTITLE := 'kill_child_tasks', EJECT ??

{ PURPOSE:
{   This request flags the "endpoint" child tasks with the kill task flag.
{
{ NOTE:
{   The task control block lock must be set when this request is issued.

    PROCEDURE kill_child_tasks
      (    parent_tcb_p: ^pmt$task_control_block);

      VAR
        global_task_id: ost$global_task_id,
        local_status: ost$status,
        tcb_p: ^pmt$task_control_block;

      tcb_p := parent_tcb_p^.first_child;
      WHILE tcb_p <> NIL DO
        IF tcb_p^.first_child <> NIL THEN
          kill_child_tasks (tcb_p);
        ELSE

{ Send the task a KILL flag.

          pmp$get_global_task_id (tcb_p^.task_id, global_task_id, local_status);
          IF local_status.normal THEN
            pmp$set_system_flag (pmc$kill_task_flag, global_task_id, { ignore } local_status);
          IFEND;
        IFEND;
        tcb_p := tcb_p^.next_sibling;
      WHILEND;
    PROCEND kill_child_tasks;
?? OLDTITLE ??
?? NEWTITLE := 'truncate_stack', EJECT ??

{ PURPOSE:
{   The purpose of this request is to truncate the stack at the ring 3 ring
{ crossing frame.

    PROCEDURE truncate_stack;

      VAR
        local_status: ost$status,
        starting_frame_p: ^ost$stack_frame_save_area,
        xing_frame_p: ^ost$stack_frame_save_area;

      local_status.normal := TRUE;

{ Since the popper may be circumvented by truncating the stack clear the
{ popper handler established flag to force the next trap to protect the
{ stack frame popper.

      pmv$popper_handler_established := FALSE;

      starting_frame_p := NIL;
      tmp$find_ring_crossing_frame (starting_frame_p, xing_frame_p, local_status);
      IF NOT local_status.normal THEN
        pmp$exit (local_status);
      IFEND;

      starting_frame_p := xing_frame_p^.minimum_save_area.a2_previous_save_area;
      WHILE ((starting_frame_p <> NIL) AND (#RING (starting_frame_p) <= osc$tsrv_ring) AND
            local_status.normal) DO
        tmp$find_ring_crossing_frame (starting_frame_p, xing_frame_p, local_status);
        starting_frame_p := xing_frame_p^.minimum_save_area.a2_previous_save_area;
      WHILEND;

      IF local_status.normal THEN
        xing_frame_p^.minimum_save_area.a2_previous_save_area := NIL;

      ELSE
        pmp$exit (local_status);
      IFEND;

    PROCEND truncate_stack;
?? OLDTITLE ??

    pmp$find_executing_task_tcb (tcb_p);

{ Is the task an endpoint of the tasking tree - if so, consider it stuck and
{ kill it.

    IF tcb_p^.first_child = NIL THEN
      IF tcb_p^.task_kill_count < pmc$task_kill_count_maximum THEN
        tcb_p^.task_kill_count := tcb_p^.task_kill_count + 1;
      IFEND;

{ If the kill status was executing, simply call exit again.  If the task
{ execution phase has proceeded to another phase, save the new phase and
{ return.  Since the task has progressed in termination, wait until another
{ kill occurs before terminating the task.

      IF tcb_p^.task_kill_phase = pmc$task_executing THEN
        tcb_p^.task_kill_phase := pmv$task_execution_phase;
        osp$set_status_condition (pme$kill_task_requested, local_status);
        pmp$exit (local_status);

      ELSEIF tcb_p^.task_kill_phase < pmv$task_execution_phase THEN
        tcb_p^.task_kill_phase := pmv$task_execution_phase;

      ELSE

{ The task was terminating and has been killed before.  Truncate the stack at
{ the ring 3 (osc$tsrv_ring) ring crossing frame and call exit again.

        truncate_stack;
        osp$set_status_condition (pme$kill_task_requested, local_status);
        pmp$exit (local_status);
      IFEND;

    ELSE

{ Typically, only the job monitor task will execute this code.  It will also
{ be executed by a task that creates a child task before it recognizes a kill
{ flag.

{ Lock parent_child list.  (Necessary if anyone other than parent scans child list.)

      osp$set_job_signature_lock (pmv$task_control_block_lock);

      kill_child_tasks (tcb_p);
      osp$clear_job_signature_lock (pmv$task_control_block_lock);
    IFEND;
  PROCEND pmp$kill_task_flag_handler;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$update_program_description', EJECT ??
*copy pmh$update_program_description

  PROCEDURE [XDCL, #GATE] pmp$update_program_description
    (    new_program_description: pmt$program_description);

    VAR
      tcb_p: ^pmt$task_control_block;

    pmp$find_executing_task_tcb (tcb_p);
    FREE tcb_p^.nosve.program_description IN osv$job_pageable_heap^;

    ALLOCATE tcb_p^.nosve.program_description: [[REP #SIZE (new_program_description) OF cell]] IN
            osv$job_pageable_heap^;
    tcb_p^.nosve.program_description^ := new_program_description;

  PROCEND pmp$update_program_description;
?? OLDTITLE ??
MODEND pmm$tasking_support_ring_2;
