 ?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE Program Management: Stack Frame Popper', ??
MODULE pmm$stack_frame_popper;
?? RIGHT := 110 ??

{  PURPOSE:
{    This module contains procedures which attempt to pop all outstanding stack frames at
{    program termination.  The purpose of this is to activate any established block_exit
{    condition handlers.
{  DESIGN:
{    Since CYBIL does not support the POP instruction, the actual popping of stack frames
{    does not occur in this module.  However, in order to minimize the amount of code
{    written in assembly language, most of the work of the stack frame popper is carried
{    out by procedures in this module.  The activities undertaken by this module include:
{
{        - Initiating block_exit condition handlers in a controlled environment.
{
{        - Managing ring_crossings within the stack frame thread.
{
{        - Detecting conditions which indicate that the stack has been destroyed.

?? NEWTITLE := '    Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc mmt$page_map_offsets
*copyc oss$job_paged_literal
*copyc osc$processor_defined_registers
*copyc pme$execution_exceptions
?? POP ??
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$set_status_from_condition
*copyc osp$generate_log_message
*copyc i#ptr
*copyc i#enable_traps
*copyc pmp$disestablish_cond_handler
*copyc pmp$establish_condition_handler
*copyc pmp$establish_ch_in_block
*copyc pmp$continue_to_cause
*copyc pmp$exit
*copyc pmp$task_debug_mode_on
*copyc pmp$debug_abort_file_specified
*copyc pmp$task_debug_ring
*copyc pmp$end_debug_should_be_called
*copyc pmp$call_end_debug
*copyc pmp$find_stack_segment
*copyc pmp$build_outward_call_sfsa
*copyc pmp$return_to_outward_call_sfsa
*copyc pmp$call_ring_crossing_proc
*copyc pmp$ring_crossing_proc_return
*copyc pmp$ring_crossing_procedure
*copyc pmp$rtn_to_outwrd_call_sfsa_sff
*copyc pmp$set_task_execution_phase
*copyc pmp$pop_3_stack_frames

  TYPE
    pmt$established_handler_pair = record
      error: pmt$established_handler,
      block_exit: pmt$established_handler,
    recend;

  VAR
    error_conditions: [STATIC, READ, oss$job_paged_literal] pmt$condition :=
          [pmc$condition_combination, $pmt$condition_combination
          [pmc$system_conditions, mmc$segment_access_condition, pmc$user_defined_condition]];

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

{  PURPOSE:
{    This procedure initiates the process of popping all stack frames.  If called in or
{    above the debug_ring and debug_mode is active, then the termination procedure of the
{    debug facility is called.

  PROCEDURE [XDCL] pmp$pop_all_stack_frames;

    VAR
      end_debug_should_be_called: boolean,
      established_handler: pmt$established_handler,
      local_status: ost$status;

    pmp$establish_condition_handler (error_conditions, ^error_condition_handler, ^established_handler,
          local_status);
    IF NOT local_status.normal THEN {stack is destroyed}
      pmp$terminate_popper (local_status);
    IFEND;

    pmp$end_debug_should_be_called (end_debug_should_be_called);

    IF end_debug_should_be_called THEN
      pmp$call_end_debug;
    IFEND;

    pmp$set_task_execution_phase (pmc$task_popping_stack_frames);

    pmp$intra_ring_popper (NIL);

  PROCEND pmp$pop_all_stack_frames;

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

{  PURPOSE:
{    This procedure is responsible for directing the process of popping all stack frames
{    within a ring and performing an outward call to the ring_crossing_popper when a
{    ring crossing is detected.  The primary functions of intra_ring popping are to provide
{    controlled activation of block_exit condition handlers and to detect stack frame
{    inconsistencies which block further popping activity.
{  NOTE:
{    This procedure and PMP$POP_3_STACK_FRAMES operate as coroutines which POP all of
{    the stack frames in the ring in which they are activated.  The intra_ring_popper
{    is partitioned into coroutines in order to minimize the amount of code written
{    in assembley language.

  PROCEDURE [XDCL] pmp$intra_ring_popper
    (    established_handler_pair: ^pmt$established_handler_pair);

    CONST
      minimum_stack_frame_size = 8;

    VAR
      converter: record
        case 0 .. 1 of
        = 0 =
          pointer_to_procedure: ^procedure,
        = 1 =
          code_base_pointer: ^ost$external_code_base_pointer,
        casend,
      recend,

      established_handler: pmt$established_handler,
      of_execution: cell,
      block_exit_condition: pmt$condition,
      target_sfsa: ^ost$stack_frame_save_area,
      preceding_sfsa: ^ost$stack_frame_save_area,
      ring_crossing_procedure_pva: ^cell,
      ring_crossing_return_pva: ^cell,
      stack_segment: ^pmt$stack_segment,
      popper_cbp: ^ost$external_code_base_pointer,
      popper_sfsa: ^ost$stack_frame_save_area,
      trap_enables: 0 .. 3,
      local_status: ost$status;

?? EJECT ??
    target_sfsa := #PREVIOUS_SAVE_AREA ();
    converter.pointer_to_procedure := ^pmp$call_ring_crossing_proc;
    ring_crossing_procedure_pva := converter.code_base_pointer^.code_pva;
    converter.pointer_to_procedure := ^pmp$ring_crossing_proc_return;
    ring_crossing_return_pva := converter.code_base_pointer^.code_pva;

{ If the target frame to pop is a user's frame, a condition handler to catch
{ system conditions is necessary.  If we let things fall to the default handler
{ it will call pmp$abort and an infinite loop will occur.

    IF established_handler_pair <> NIL THEN
      pmp$establish_ch_in_block (error_conditions, ^error_condition_handler, target_sfsa,
            ^established_handler_pair^.error, local_status);
      IF NOT local_status.normal THEN {stack is destroyed}
        pmp$terminate_popper (local_status);
      IFEND;
    ELSE
      pmp$establish_condition_handler (error_conditions, ^error_condition_handler, ^established_handler,
            local_status);
      IF NOT local_status.normal THEN {stack is destroyed}
        pmp$terminate_popper (local_status);
      IFEND;
    IFEND;

{ Are we about to pop original caller??

    preceding_sfsa := target_sfsa^.minimum_save_area.a2_previous_save_area;
    IF preceding_sfsa = NIL THEN
      local_status.normal := TRUE;
      pmp$terminate_popper (local_status);

    ELSE
{     IF target_sfsa^.minimum_save_area.frame_descriptor.critical_frame_flag THEN
{       block_exit_condition.selector := pmc$block_exit_processing;
{       block_exit_condition.reason := - $pmt$block_exit_reason [];
{       pmp$establish_ch_in_block (block_exit_condition, ^block_exit_handler, target_sfsa,
{             ^established_handler_pair^.block_exit, local_status);
{       IF NOT local_status.normal THEN {stack is destroyed}
{         pmp$terminate_popper (local_status);
{       IFEND;
{     IFEND;

{  If a ring crossing procedure frame exists for this stack then call ring_crossing_popper
{  to assure that delayed conditions and preemptive communications processed.

      IF preceding_sfsa^.minimum_save_area.p_register.pva.seg = #SEGMENT (ring_crossing_procedure_pva) THEN
        IF preceding_sfsa^.minimum_save_area.p_register.pva.offset >=
              #OFFSET (ring_crossing_procedure_pva) THEN
          IF preceding_sfsa^.minimum_save_area.p_register.pva.offset < #OFFSET (ring_crossing_return_pva) THEN
            preceding_sfsa := preceding_sfsa^.minimum_save_area.a2_previous_save_area;
            IF preceding_sfsa = NIL THEN
              local_status.normal := TRUE;
              pmp$terminate_popper (local_status);
            IFEND;
          IFEND;
        IFEND;
      IFEND;

      IF #RING (preceding_sfsa) = #RING (^of_execution) THEN
        pmp$pop_3_stack_frames (#SIZE (pmt$established_handler_pair));
      ELSE
        pmp$find_stack_segment (#RING (preceding_sfsa), stack_segment);
        converter.pointer_to_procedure := ^ring_crossing_popper;
        popper_cbp := converter.code_base_pointer;
        pmp$build_outward_call_sfsa (popper_cbp, #RING (preceding_sfsa), NIL, preceding_sfsa,
              minimum_stack_frame_size + #SIZE (pmt$established_handler), stack_segment, popper_sfsa);
{       pmp$establish_ch_in_block (error_conditions, ^error_condition_handler, popper_sfsa, i#ptr
{             (minimum_stack_frame_size, popper_sfsa^.minimum_save_area.a1_current_stack_frame),
{             local_status);
{       IF NOT local_status.normal THEN
{         pmp$terminate_popper (local_status);
{       IFEND;

        pmp$return_to_outward_call_sfsa (popper_sfsa);
      IFEND;
    IFEND;

  PROCEND pmp$intra_ring_popper;
?? TITLE := '   ring_crossing_popper', EJECT ??

{  PURPOSE:
{    This procedure serves as the target of an outward call when the stack frame thread
{    crosses ring boundaries.  It is responsible for initiating the intra_ring_popper
{    process in the ring just entered.  If the entered ring is at or above the debug_ring and
{    debug_mode is active, then the termination procedure of the debug facility is called.

  PROCEDURE ring_crossing_popper;

    VAR
      established_handler: pmt$established_handler,
      end_debug_should_be_called: boolean,
      local_status: ost$status;

{   The following must be the first thing done by this procedure (in order to disestablish
{   the pre_established condition_handler after the ring_crossing.

{   #write_register (osc$pr_clear_on_condition, 0);

    pmp$establish_condition_handler (error_conditions, ^error_condition_handler, ^established_handler,
          local_status);
    IF NOT local_status.normal THEN {stack is destroyed}
      pmp$terminate_popper (local_status);
    IFEND;

    pmp$end_debug_should_be_called (end_debug_should_be_called);

    IF end_debug_should_be_called THEN
      pmp$call_end_debug;
    IFEND;

    pmp$intra_ring_popper (NIL);

  PROCEND ring_crossing_popper;
?? TITLE := '  block_exit_handler', EJECT ??

  PROCEDURE block_exit_handler
    (    condition: pmt$condition;
         descriptor: ^pmt$condition_information;
         save_area: ^ost$stack_frame_save_area;
     VAR status: ost$status);

{  PURPOSE:
{    This procedure exists to control the scope of user_program block_exit condition handlers.
{    It prohibits them from performing non_local exits.

    PROCEDURE internal_condition_handler
      (    condition: pmt$condition;
           descriptor: ^pmt$condition_information;
           save_area: ^ost$stack_frame_save_area;
       VAR internal_status: ost$status);

      IF (condition.selector = pmc$block_exit_processing) THEN
        status.normal := TRUE;
        EXIT block_exit_handler {----->
      ELSE
        pmp$continue_to_cause (pmc$execute_standard_procedure, status);
        status.normal := TRUE;
      IFEND;

    PROCEND internal_condition_handler;

    VAR
      internal_conditions: [STATIC, READ, oss$job_paged_literal] pmt$condition :=
            [pmc$condition_combination, $pmt$condition_combination
            [pmc$system_conditions, pmc$block_exit_processing, mmc$segment_access_condition,
            ifc$interactive_condition, pmc$user_defined_condition]],
      established_handler: pmt$established_handler;

    pmp$establish_condition_handler (internal_conditions, ^internal_condition_handler, ^established_handler,
          status);
    IF NOT status.normal THEN {stack is destroyed}
      pmp$terminate_popper (status);
    IFEND;
    pmp$continue_to_cause (pmc$inhibit_standard_procedure, status);
    status.normal := TRUE;

  PROCEND block_exit_handler;
?? TITLE := '  error_condition_handler', EJECT ??

  PROCEDURE error_condition_handler
    (    condition: pmt$condition;
         descriptor: ^pmt$condition_information;
         save_area: ^ost$stack_frame_save_area;
     VAR status: ost$status);

    VAR
      local_status: ost$status;

    osp$set_status_from_condition ('PM', condition, save_area, local_status, status);
    pmp$terminate_popper (local_status);

  PROCEND error_condition_handler;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] pmp$terminate_popper', EJECT ??
*copy pmh$terminate_popper

  PROCEDURE [XDCL] pmp$terminate_popper
    (    message_status: ost$status);

    PROCEDURE reset_psa_to_nil;

      VAR
        psa: ^ost$minimum_save_area;

      psa := #PREVIOUS_SAVE_AREA ();
      psa^.a2_previous_save_area := NIL;
    PROCEND reset_psa_to_nil;

    VAR
      local_status: ost$status;

    reset_psa_to_nil;
    IF message_status.normal THEN
      pmp$exit (message_status);
    ELSE
      osp$generate_log_message ($pmt$ascii_logset [pmc$job_log], message_status, local_status);
      osp$set_status_condition (pme$stack_frame_popper_aborted, local_status);
      pmp$exit (local_status);
    IFEND;

  PROCEND pmp$terminate_popper;
MODEND pmm$stack_frame_popper;
