?? RIGHT := 110 ??
?? NEWTITLE := 'NOS/VE : Program Management - VX/VE program state processor' ??
MODULE pmm$program_state_processor;

{ PURPOSE:
{   This module contains the routines necessary to support the VX/VE Fork.
{
{ DESIGN:
{   The procedures in this module execute in the ring of the caller (2DD).

?? NEWTITLE := 'Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc lot$loader_type_definitions
*copyc osd$virtual_address
*copyc ost$caller_identifier
*copyc ost$stack_frame_save_area
*copyc ost$status
*copyc pmc$program_management_id
*copyc pmd$program_state
*copyc pme$program_state_exceptions
?? POP ??
*copyc i#current_sequence_position
*copyc i#move
*copyc mmp$get_segment_length
*copyc mmp$preset_page_streaming
*copyc osp$set_status_condition
*copyc lov$allocated_segments
*copyc lov$highest_segment_index
?? OLDTITLE ??
?? NEWTITLE := '[XDCL, #GATE] pmp$restore_program_state', EJECT ??
*copyc pmh$restore_program_state

  PROCEDURE [XDCL, #GATE] pmp$restore_program_state
    (    p_state_container: ^SEQ ( * );
         p_parameter: ^cell;
         parameter_length: 0 .. 0ffff(16);
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      container_p: ^SEQ ( * ),
      directory_p: ^pmt$segment_directory,
      ring: ost$valid_ring,
      save_area_p: ^cell,
      segment_count: pmt$segment_count,
      segment_length: ^array [ * ] of ost$segment_length,
      stack_expansion: integer,
      stack_expansion_p: ^SEQ ( * );

    #CALLER_ID (caller_id);
    container_p := p_state_container;

    ring := #RING (container_p);
    IF (caller_id.ring > ring) THEN
      ring := caller_id.ring;
    IFEND;
    validate_program_write (ring, lov$allocated_segments, lov$highest_segment_index, status);

    IF status.normal THEN
      validate_program_state (container_p, save_area_p, directory_p, status);
    IFEND;

    IF status.normal THEN
      segment_count := lov$highest_segment_index - LOWERBOUND (lov$allocated_segments^) + 1;
      PUSH segment_length: [1 .. segment_count];
      verify_program_identity (lov$allocated_segments, lov$highest_segment_index, directory_p, segment_count,
            segment_length, status);
    IFEND;

    IF status.normal THEN
      get_stack_expansion (directory_p, stack_expansion);
      IF (stack_expansion > 0) THEN
        PUSH stack_expansion_p: [[REP stack_expansion OF cell]];
      IFEND;
      restore_segment_info (directory_p, container_p, save_area_p, p_parameter, parameter_length,
            segment_count, segment_length);
    IFEND;

  PROCEND pmp$restore_program_state;
?? OLDTITLE ??
?? NEWTITLE := '[XDLC, #GATE] pmp$save_program_state', EJECT ??
*copyc pmh$save_program_state

  PROCEDURE [XDCL, #GATE] pmp$save_program_state
    (VAR p_state_container: ^SEQ ( * );
     VAR original_program: boolean;
     VAR status: ost$status);

    VAR
      caller_id: ost$caller_identifier,
      container_p: ^SEQ ( * ),
      program_state_p: ^pmt$program_state,
      ring: ost$valid_ring;

    #CALLER_ID (caller_id);
    status.normal := TRUE;
    original_program := FALSE;
    container_p := p_state_container;

    ring := #RING (container_p);
    IF (caller_id.ring > ring) THEN
      ring := caller_id.ring;
    IFEND;
    validate_program_read (ring, lov$allocated_segments, lov$highest_segment_index, status);

    IF status.normal THEN
      NEXT program_state_p IN container_p;
      IF (program_state_p = NIL) THEN
        osp$set_status_condition (pme$state_container_full, status);
      ELSE
        program_state_p^.p_save_area := #PREVIOUS_SAVE_AREA ();
        program_state_p^.segment_count := lov$highest_segment_index - LOWERBOUND (lov$allocated_segments^) +
              1;
        save_segment_info (lov$allocated_segments, program_state_p^.segment_count, container_p, status);
      IFEND;
    IFEND;

    original_program := TRUE;
    IF status.normal THEN
      p_state_container := container_p;
    IFEND;

  PROCEND pmp$save_program_state;
?? OLDTITLE ??
?? NEWTITLE := 'get_stack_expansion', EJECT ??

  PROCEDURE get_stack_expansion
    (    directory_p: ^pmt$segment_directory;
     VAR stack_expansion: integer);

    VAR
      directory_index: ost$segment,
      save_area_p: ^cell,
      stack_segment: ost$segment;

    save_area_p := #PREVIOUS_SAVE_AREA ();
    stack_segment := #SEGMENT (save_area_p);
    FOR directory_index := 1 TO UPPERBOUND (directory_p^) DO
      IF (stack_segment = directory_p^ [directory_index].segment_allocation.segment) THEN
        stack_expansion := directory_p^ [directory_index].saved_length - #OFFSET (save_area_p);
        RETURN;
      IFEND;
    FOREND;
    stack_expansion := 0;
  PROCEND get_stack_expansion;
?? OLDTITLE ??
?? NEWTITLE := 'move_bytes', EJECT ??

{ PURPOSE:
{   This procedure will move data from the source to the destination address.

  PROCEDURE move_bytes
    (    source_p: ^cell;
         destination_p: ^cell;
         length: 0 .. 7fffffff(16));

    CONST
      maximum_nonstreamed_size = 65536,
      prestreaming_transfer_size = 65536;

    VAR
      destination_free_behind: boolean,
      destination_status_p: ^ost$status,
      destination_transfer_size: 0 .. 15,
      source_free_behind: boolean,
      source_status_p: ^ost$status,
      source_transfer_size: 0 .. 15;

    IF length > maximum_nonstreamed_size THEN
      PUSH source_status_p;
      PUSH destination_status_p;
      mmp$preset_page_streaming ({ preset_and_save_ts_fb } TRUE, source_p, prestreaming_transfer_size,
            source_transfer_size, source_free_behind, source_status_p^);
      mmp$preset_page_streaming ({ preset_and_save_ts_fb } TRUE, destination_p, prestreaming_transfer_size,
            destination_transfer_size, destination_free_behind, destination_status_p^);
    IFEND;

    i#move (source_p, destination_p, length);

    IF length > maximum_nonstreamed_size THEN
      IF source_status_p^.normal THEN
        mmp$preset_page_streaming ({ preset_and_save_ts_fb } FALSE, source_p, prestreaming_transfer_size,
              source_transfer_size, source_free_behind, source_status_p^);
      IFEND;
      IF destination_status_p^.normal THEN
        mmp$preset_page_streaming ({ preset_and_save_ts_fb } FALSE, destination_p, prestreaming_transfer_size,
              destination_transfer_size, destination_free_behind, destination_status_p^);
      IFEND;
    IFEND;
  PROCEND move_bytes;
?? OLDTITLE ??
?? NEWTITLE := 'restore_segment', EJECT ??

  PROCEDURE restore_segment
    (    segment: ost$segment;
         ring: ost$valid_ring;
     VAR saved_segment_p: ^SEQ ( * );
         parameter_p: ^cell;
         parameter_length: 0 .. 0ffff(16));

    VAR
      destination_p: ^cell,
      first_length: integer,
      last_length: integer,
      source_p: ^SEQ ( * ),
      parameter: boolean,
      segment_length: ost$segment_length;

    destination_p := #ADDRESS (ring, segment, 0);
    segment_length := #SIZE (saved_segment_p^);
    parameter := (parameter_p <> NIL) AND (parameter_length > 0) AND (segment = #SEGMENT (parameter_p));
    IF parameter THEN
      first_length := #OFFSET (parameter_p);
      last_length := segment_length - first_length - parameter_length;
      RESET saved_segment_p;
      IF (first_length > 0) THEN
        NEXT source_p: [[REP first_length OF cell]] IN saved_segment_p;
        move_bytes (#LOC (source_p^), destination_p, first_length);
      IFEND;
      IF (last_length > 0) THEN
        NEXT source_p: [[REP parameter_length OF cell]] IN saved_segment_p;
        NEXT source_p: [[REP last_length OF cell]] IN saved_segment_p;
        destination_p := #ADDRESS (ring, segment, first_length + parameter_length);
        move_bytes (#LOC (source_p^), destination_p, last_length);
      IFEND;
    ELSE
      move_bytes (#LOC (saved_segment_p^), destination_p, segment_length);
    IFEND;
  PROCEND restore_segment;
?? OLDTITLE ??
?? NEWTITLE := 'restore_segment_info', EJECT ??

  PROCEDURE restore_segment_info
    (    directory_p: ^pmt$segment_directory;
         state_container_p: ^SEQ ( * );
         save_area_p: ^cell;
         parameter_p: ^cell;
         parameter_length: 0 .. 0ffff(16);
         segment_count: pmt$segment_count;
         segment_length: ^array [ * ] of ost$segment_length);

    VAR
      container_p: ^SEQ ( * ),
      directory_entry: pmt$segment_directory_entry,
      directory_index: ost$segment,
      ring: ost$valid_ring,
      saved_length: ost$segment_length,
      saved_segment_p: ^SEQ ( * ),
      segment: ost$segment,
      segment_allocation: lot$segment_allocation,
      temp_directory_p: ^pmt$segment_directory, { these temp variables are used so that the values get
      temp_save_area_p: ^cell, { copied into the procedure so they do not get overwritten
      temp_parameter_p: ^cell, { when the stack segment gets restored.
      temparameter_p_length: 0 .. 0ffff(16),
      temp_segment_count: pmt$segment_count,
      temp_segment_length: ^array [ * ] of ost$segment_length,
      writable_segment: boolean;

    temp_directory_p := directory_p;
    temp_save_area_p := save_area_p;
    temp_parameter_p := parameter_p;
    temparameter_p_length := parameter_length;
    temp_segment_count := segment_count;
    PUSH temp_segment_length: [1 .. temp_segment_count];
    temp_segment_length^ := segment_length^;
    container_p := state_container_p;
    set_save_area (NIL);
    FOR directory_index := 1 TO temp_segment_count DO
      directory_entry := temp_directory_p^ [directory_index];
      segment_allocation := directory_entry.segment_allocation;
      writable_segment := (segment_allocation.attributes.access_control.write_privilege <> osc$non_writable);
      saved_length := temp_segment_length^ [directory_index];
      IF (writable_segment AND (saved_length > 0)) THEN
        segment := segment_allocation.segment;
        ring := segment_allocation.attributes.r1;
        RESET container_p TO temp_directory_p;
        NEXT saved_segment_p: [[REP directory_entry.segment_offset OF cell]] IN container_p;
        NEXT saved_segment_p: [[REP saved_length OF cell]] IN container_p;
        restore_segment (segment, ring, saved_segment_p, temp_parameter_p, temparameter_p_length);
      IFEND;
    FOREND;
    set_save_area (temp_save_area_p);
  PROCEND restore_segment_info;
?? OLDTITLE ??
?? NEWTITLE := 'save_segment_info', EJECT ??

  PROCEDURE save_segment_info
    (    allocated_segments_p: ^array [ * ] of lot$segment_allocation;
         segment_count: pmt$segment_count;
     VAR container_p: ^SEQ ( * );
     VAR status: ost$status);

    VAR
      directory_offset: ost$segment_length,
      directory_p: ^pmt$segment_directory,
      directory_index: ost$segment,
      index_offset: integer,
      segment_allocation: lot$segment_allocation,
      saved_length: ost$segment_length,
      segment_p: ^cell,
      saved_segment_p: ^SEQ ( * );

    status.normal := TRUE;
    index_offset := LOWERBOUND (allocated_segments_p^) - 1;
    directory_offset := i#current_sequence_position (container_p);

    NEXT directory_p: [1 .. segment_count] IN container_p;
    IF (directory_p = NIL) THEN
      osp$set_status_condition (pme$state_container_full, status);
      RETURN;
    IFEND;

    FOR directory_index := 1 TO segment_count DO
      segment_allocation := allocated_segments_p^ [directory_index + index_offset];
      segment_p := #ADDRESS (segment_allocation.attributes.r2, segment_allocation.segment, 0);
      IF (segment_allocation.attributes.access_control.write_privilege = osc$non_writable) THEN
        saved_length := 0;
      ELSEIF (segment_allocation.attributes.extensible OR segment_allocation.attributes.stack) THEN
        mmp$get_segment_length (segment_p, segment_allocation.attributes.r2, saved_length, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
      ELSE
        saved_length := segment_allocation.current_length;
      IFEND;

      directory_p^ [directory_index].segment_allocation := segment_allocation;
      directory_p^ [directory_index].saved_length := saved_length;
      IF (saved_length = 0) THEN
        directory_p^ [directory_index].segment_offset := 0;
      ELSE
        directory_p^ [directory_index].segment_offset := i#current_sequence_position (container_p) -
              directory_offset;
        NEXT saved_segment_p: [[REP saved_length OF cell]] IN container_p;
        IF (saved_segment_p = NIL) THEN
          osp$set_status_condition (pme$state_container_full, status);
          RETURN;
        IFEND;
        move_bytes (segment_p, #LOC (saved_segment_p^), saved_length);
      IFEND;
    FOREND;
  PROCEND save_segment_info;
?? OLDTITLE ??
?? NEWTITLE := 'set_save_area', EJECT ??

  PROCEDURE set_save_area
    (    save_area_p: ^cell);

    VAR
      caller_p_save_area: ^ost$minimum_save_area;

    caller_p_save_area := #PREVIOUS_SAVE_AREA ();
    caller_p_save_area^.a2_previous_save_area := save_area_p;
  PROCEND set_save_area;
?? OLDTITLE ??
?? NEWTITLE := 'validate_program_read', EJECT ??

  PROCEDURE validate_program_read
    (    ring: ost$valid_ring;
         allocated_segments_p: ^array [ * ] of lot$segment_allocation;
         highest_segment_index: lot$allocated_segments_index;
     VAR status: ost$status);

    VAR
      index: lot$allocated_segments_index;

    status.normal := TRUE;
    IF (allocated_segments_p <> NIL) THEN
      FOR index := LOWERBOUND (allocated_segments_p^) TO highest_segment_index DO
        IF (ring > allocated_segments_p^ [index].attributes.r2) AND
              (allocated_segments_p^ [index].attributes.access_control.write_privilege <> osc$non_writable)
              THEN
          osp$set_status_condition (pme$unreadable_program_state, status);
          RETURN;
        IFEND;
      FOREND;
    IFEND;
  PROCEND validate_program_read;
?? OLDTITLE ??
?? NEWTITLE := 'validate_program_state', EJECT ??

  PROCEDURE validate_program_state
    (VAR container_p: ^SEQ ( * );
     VAR save_area_p: ^cell;
     VAR directory_p: ^pmt$segment_directory;
     VAR status: ost$status);

    VAR
      program_state_p: ^pmt$program_state,
      saved_segment_p: ^SEQ ( * ),
      directory_index: ost$segment,
      saved_length: ost$segment_length,
      segment_offset: ost$segment_length;

    status.normal := TRUE;
    NEXT program_state_p IN container_p;
    IF (program_state_p = NIL) THEN
      osp$set_status_condition (pme$invalid_program_state, status);
      RETURN;
    IFEND;
    save_area_p := program_state_p^.p_save_area;

    NEXT directory_p: [1 .. program_state_p^.segment_count] IN container_p;
    IF (directory_p = NIL) THEN
      osp$set_status_condition (pme$invalid_program_state, status);
      RETURN;
    IFEND;

    FOR directory_index := 1 TO UPPERBOUND (directory_p^) DO
      saved_length := directory_p^ [directory_index].saved_length;
      IF (saved_length > 0) THEN
        segment_offset := directory_p^ [directory_index].segment_offset;
        RESET container_p TO directory_p;
        NEXT saved_segment_p: [[REP (segment_offset + saved_length) OF cell]] IN container_p;
        IF (saved_segment_p = NIL) THEN
          osp$set_status_condition (pme$invalid_program_state, status);
          RETURN;
        IFEND;
      IFEND;
    FOREND;
  PROCEND validate_program_state;
?? OLDTITLE ??
?? NEWTITLE := 'validate_program_write', EJECT ??

  PROCEDURE validate_program_write
    (    ring: ost$valid_ring;
         allocated_segments_p: ^array [ * ] of lot$segment_allocation;
         highest_segment_index: lot$allocated_segments_index;
     VAR status: ost$status);

    VAR
      index: lot$allocated_segments_index;

    status.normal := TRUE;
    IF (allocated_segments_p <> NIL) THEN
      FOR index := LOWERBOUND (allocated_segments_p^) TO highest_segment_index DO
        IF (ring > allocated_segments_p^ [index].attributes.r1) AND
              (allocated_segments_p^ [index].attributes.access_control.write_privilege <> osc$non_writable)
              THEN
          osp$set_status_condition (pme$unwritable_program_state, status);
          RETURN;
        IFEND;
      FOREND;
    IFEND;
  PROCEND validate_program_write;
?? OLDTITLE ??
?? NEWTITLE := 'verify_program_identity', EJECT ??

  PROCEDURE verify_program_identity
    (    allocated_segments_p: ^array [ * ] of lot$segment_allocation;
         highest_segment_index: lot$allocated_segments_index;
         directory_p: ^pmt$segment_directory;
         segment_count: pmt$segment_count;
     VAR segment_length: ^array [ * ] of ost$segment_length;
     VAR status: ost$status);

    VAR
      directory_index: ost$segment,
      index_offset: integer;

    status.normal := TRUE;
    IF (segment_count > UPPERBOUND (directory_p^)) THEN
      osp$set_status_condition (pme$program_mismatch, status);
      RETURN;
    IFEND;
    index_offset := LOWERBOUND (allocated_segments_p^) - 1;
    FOR directory_index := 1 TO segment_count DO
      IF ((directory_p^ [directory_index].segment_allocation.attributes <>
            allocated_segments_p^ [directory_index + index_offset].attributes) OR
            (directory_p^ [directory_index].segment_allocation.segment <>
            allocated_segments_p^ [directory_index + index_offset].segment) OR
            (directory_p^ [directory_index].segment_allocation.current_length <
            allocated_segments_p^ [directory_index + index_offset].current_length) OR
            (directory_p^ [directory_index].segment_allocation.maximum_length <>
            allocated_segments_p^ [directory_index + index_offset].maximum_length)) THEN
        osp$set_status_condition (pme$program_mismatch, status);
        RETURN;
      IFEND;

      IF ((directory_p^ [directory_index].segment_allocation.attributes.extensible) OR
            (directory_p^ [directory_index].segment_allocation.attributes.stack)) THEN
        segment_length^ [directory_index] := directory_p^ [directory_index].saved_length;
      ELSE
        segment_length^ [directory_index] := allocated_segments_p^ [directory_index +
              index_offset].current_length;
      IFEND;
    FOREND;
  PROCEND verify_program_identity;
?? OLDTITLE ??
MODEND pmm$program_state_processor;
