?? NEWTITLE := 'NAM/VE: Buffer Manager' ??
MODULE nlm$buffer_manager;
?? RIGHT := 110 ??

{ PURPOSE:
{   This module contains the procedures to create and manage NAM/VE's buffers.
{
{ DESIGN:
{   The procedures are grouped into two groups.  The first group contains the
{   XDCLed procedures.  The second group contains the internal procedures.
{   The procedures in each group are in alphabetical order.

?? NEWTITLE := 'Global Declarations Referenced by This Module' ??
?? PUSH (LISTEXT := ON) ??
*copyc cyd$cybil_structure_definitions
*copyc dmt$error_condition_codes
*copyc mme$condition_codes
*copyc nae$initialization_interfaces
*copyc nae$namve_conditions
*copyc nat$data_fragments
*copyc nlc$bm_buffer_pool_index
*copyc nlc$bm_minimum_buffers_for_cpu
*copyc nlc$bm_small_buffer_size
*copyc nlc$small_machine_threshold
*copyc nlt$bm_buffer_list_array
*copyc nlt$bm_message_descriptor
*copyc nlt$bm_message_id
*copyc nlt$bm_pool_index
*copyc osc$space_unavailable_condition
*copyc osc$volume_unavailable_cond
*copyc oss$job_paged_literal
*copyc ost$status
?? POP ??
*copyc i#move
*copyc nap$condition_handler_trace
*copyc nap$namve_system_error
*copyc nlp$bm_get_message_length
*copyc nlp$bm_valid_message_id
*copyc osp$begin_subsystem_activity
*copyc osp$clear_job_signature_lock
*copyc osp$end_subsystem_activity
*copyc osp$establish_condition_handler
*copyc osp$set_job_signature_lock
*copyc osp$set_status_abnormal
*copyc osp$set_status_condition
*copyc osp$set_status_from_condition
*copyc osp$wait_on_condition
*copyc pmp$abort
*copyc pmp$continue_to_cause
*copyc syp$cycle
*copyc nav$global_statistics
*copyc nav$network_paged_heap
*copyc nav$network_wired_heap
*copyc nlv$bm_allocat_buffer_threshold
*copyc nlv$bm_allocated_buffer_maximum
*copyc nlv$bm_allocated_buffer_pool
*copyc nlv$bm_buffer_manager_caller
*copyc nlv$bm_buffer_manager_control
*copyc nlv$bm_buffer_pool
*copyc nlv$bm_buffers_freed
*copyc nlv$bm_large_buffer_size
*copyc nlv$bm_nil_message_id
*copyc nlv$bm_null_message_id
*copyc nlv$cc_grant_credit_trigger
*copyc nlv$cc_maximum_receive_window
*copyc osv$180_memory_limits
*copyc osv$page_size
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by This Module', EJECT ??

  CONST

{ Presentation expected data header size = 0
{ Session expected data header size = 5
{ Transport access agent expected data header size = 5
{ Channel Connection expected data header size = 16 + up to 7 pad bytes

    nlc$bm_expected_header_size = 33;

  CONST
    buffer_initialization = '#';

  TYPE
    aligned_2048 = record
      buffer: ALIGNED [0 MOD 2048] nlt$bm_allocated_memory,
    recend,

    aligned_4096 = record
      buffer: ALIGNED [0 MOD 4096] nlt$bm_allocated_memory,
    recend,

    aligned_8192 = record
      buffer: ALIGNED [0 MOD 8192] nlt$bm_allocated_memory,
    recend,

    aligned_16384 = record
      buffer: ALIGNED [0 MOD 16384] nlt$bm_allocated_memory,
    recend;

  TYPE
    build_container_pointer = record
      case boolean of
      = TRUE =
        pointer: ^nlt$bm_container,
      = FALSE =
        adaptable_string_pointer: cyt$adaptable_string_pointer,
      casend,
    recend;

  VAR
    buffer_sub_pool: record
      case ost$page_size of
      = 2048 =
        aligned_2048: ^aligned_2048,
      = 4096 =
        aligned_4096: ^aligned_4096,
      = 8192 =
        aligned_8192: ^aligned_8192,
      = 16384 =
        aligned_16384: ^aligned_16384,
      casend,
    recend;

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$bm_add_message_prefix', EJECT ??
*copy nlh$bm_add_message_prefix

  PROCEDURE [XDCL] nlp$bm_add_message_prefix
    (    prefix: ^cell;
         prefix_length: nat$data_length;
     VAR message_id { input, output } : nlt$bm_message_id);

    VAR
      descriptor: ^nlt$bm_message_descriptor,
      move_length: nat$data_length,
      new_descriptor: ^nlt$bm_message_descriptor,

{ This declaration exists solely to develop the address for the i#move which moves the prefix
{ from the user's address space to the container.

      prefix_address: ^array [0 .. 0ffffff(16)] of cell,
      remaining_prefix_length: nat$data_length;

?? NEWTITLE := 'create_message_appendage', EJECT ??

{ PURPOSE:
{   This procedure gets a message of length equal to the prefix_length.  The new message is appended
{   to the begining of the current message.  The prefix data is then moved into the new appendage.

    PROCEDURE create_message_appendage
      (    prefix: ^cell;
           prefix_length: nat$data_length;
       VAR message_id { input, output} : nlt$bm_message_id);

      VAR
        actual_data_length: nat$data_length,
        container_length: nlt$bm_buffer_length,
        current_container_capacity: nlt$bm_buffer_length,

{ This declaration exists solely to develop the address for the i#move which moves data from
{ the user's address space to the container.

        data_address: ^array [0 .. 0ffffff(16)] of cell,
        descriptor: ^nlt$bm_message_descriptor,
        first_descriptor: ^nlt$bm_message_descriptor,
        i: integer,
        prefix_data_start: nat$data_length,
        remaining_data_length: nat$data_length;

      osp$begin_subsystem_activity;
      osp$set_job_signature_lock (nlv$bm_buffer_manager_control.lock);
      get_message (prefix_length, {future_data_requirements = } 0, descriptor);
      osp$clear_job_signature_lock (nlv$bm_buffer_manager_control.lock);
      osp$end_subsystem_activity;

      prefix_data_start := 0;
      remaining_data_length := prefix_length;
      current_container_capacity := descriptor^.container_length - descriptor^.data_start;
      first_descriptor := descriptor;
      data_address := prefix;

      WHILE remaining_data_length > 0 DO

{ Move data to Container: Fill or partially fill the current container with the remainder of the data.

        IF remaining_data_length <= current_container_capacity THEN
          i#move (#LOC (data_address^ [prefix_data_start]), #LOC (descriptor^.
                container^ (1 + descriptor^.data_start)), remaining_data_length);
          remaining_data_length := 0;

        ELSE { Fill current container.
          i#move (#LOC (data_address^ [prefix_data_start]), #LOC (descriptor^.
                container^ (1 + descriptor^.data_start)), current_container_capacity);
          prefix_data_start := prefix_data_start + current_container_capacity;
          remaining_data_length := remaining_data_length - current_container_capacity;
          descriptor := descriptor^.link;
          current_container_capacity := descriptor^.container_length - descriptor^.data_start;
        IFEND;
      WHILEND;

      descriptor^.link := message_id.descriptor;
      message_id.descriptor := first_descriptor;
      message_id.sequence_number := first_descriptor^.sequence_number;

    PROCEND create_message_appendage;
?? OLDTITLE ??
?? EJECT ??

    IF (prefix <> NIL) AND (prefix_length > 0) AND nlp$bm_valid_message_id (message_id) THEN
      IF message_id <> nlv$bm_null_message_id THEN
        descriptor := message_id.descriptor;
        descriptor^.sequence_number := (descriptor^.sequence_number + 1) MOD nlc$bm_sequence_space;
        message_id.sequence_number := descriptor^.sequence_number;

{ Find last buffer in the message with space available.

        WHILE (descriptor^.link <> NIL) AND (descriptor^.data_start = descriptor^.container_length) AND
              (descriptor^.link^.data_start > 0) DO
          descriptor := descriptor^.link;
        WHILEND;

{ The complete prefix fits in the current buffer.

        IF descriptor^.data_start >= prefix_length THEN
          descriptor^.data_start := descriptor^.data_start - prefix_length;
          i#move (prefix, #LOC (descriptor^.container^ (1 + descriptor^.data_start)), prefix_length);
        ELSE
          remaining_prefix_length := prefix_length;

{ All or part of the prefix fits in the existing buffers.

          IF descriptor^.data_start > 0 THEN
            move_length := 0;
            prefix_address := prefix;
            WHILE (remaining_prefix_length > 0) AND (descriptor^.data_start > 0) DO
              IF remaining_prefix_length >= descriptor^.data_start THEN
                move_length := descriptor^.data_start;
                descriptor^.data_start := 0;
              ELSE
                move_length := remaining_prefix_length;
                descriptor^.data_start := descriptor^.data_start - remaining_prefix_length;
              IFEND;
              remaining_prefix_length := remaining_prefix_length - move_length;
              i#move (#LOC (prefix_address^ [remaining_prefix_length]),
                    #LOC (descriptor^.container^ (1 + descriptor^.data_start)), move_length);
              IF remaining_prefix_length > 0 THEN

{ Find last buffer in the message with space available.

                descriptor := message_id.descriptor;
                WHILE (descriptor^.link <> NIL)
{             } AND (descriptor^.data_start = descriptor^.container_length)
{             } AND (descriptor^.link^.data_start > 0) DO
                  descriptor := descriptor^.link;
                WHILEND;
              IFEND;
            WHILEND;
          IFEND;

          IF remaining_prefix_length > 0 THEN
            create_message_appendage (prefix, remaining_prefix_length, message_id);
          IFEND;
        IFEND;

      ELSE { Create new message for prefix.
        create_message_appendage (prefix, prefix_length, message_id);
      IFEND;
    ELSE { Bad input parameters.
      nap$namve_system_error (FALSE, nlv$bm_buffer_manager_caller, NIL);
    IFEND;

  PROCEND nlp$bm_add_message_prefix;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$bm_concatenate_messages', EJECT ??
*copy nlh$bm_concatenate_messages

  PROCEDURE [XDCL] nlp$bm_concatenate_messages
    (    component_list { input, output } : array [1 .. * ] of nlt$bm_message_id;
     VAR message_id: nlt$bm_message_id);

    VAR
      component_p: ^nlt$bm_message_id,
      descriptor: ^nlt$bm_message_descriptor,
      i: integer,
      link: ^^nlt$bm_message_descriptor;

    message_id := nlv$bm_null_message_id;
    link := ^message_id.descriptor;

    FOR i := 1 TO UPPERBOUND (component_list) DO
      component_p := ^component_list [i];
      IF NOT nlp$bm_valid_message_id (component_p^) THEN
        nap$namve_system_error (FALSE, nlv$bm_buffer_manager_caller, NIL);
      IFEND;
      IF component_p^ <> nlv$bm_null_message_id THEN
        descriptor := component_p^.descriptor;
        descriptor^.sequence_number := (descriptor^.sequence_number + 1) MOD nlc$bm_sequence_space;
        link^ := descriptor;
        WHILE descriptor^.link <> NIL DO
          descriptor := descriptor^.link;
        WHILEND;
        link := ^descriptor^.link;
      IFEND;
    FOREND;

    IF message_id <> nlv$bm_null_message_id THEN
      message_id.sequence_number := message_id.descriptor^.sequence_number;
      link^ := NIL;
    IFEND;

  PROCEND nlp$bm_concatenate_messages;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$bm_copy_message', EJECT ??
*copy nlh$bm_copy_message

  PROCEDURE [XDCL] nlp$bm_copy_message
    (    from_message_id: nlt$bm_message_id;
     VAR to_message_id: nlt$bm_message_id);

    VAR
      descriptor: ^nlt$bm_message_descriptor,
      from_container_capacity: nlt$bm_buffer_length,
      from_data_start: nlt$bm_buffer_length,
      from_descriptor: ^nlt$bm_message_descriptor,
      i: integer,
      remaining_data_length: integer,
      to_container_capacity: nlt$bm_buffer_length,
      to_data_start: nlt$bm_buffer_length,
      to_descriptor: ^nlt$bm_message_descriptor;


    nlp$bm_get_message_length (from_message_id, remaining_data_length);

    IF remaining_data_length > 0 THEN
      osp$begin_subsystem_activity;
      osp$set_job_signature_lock (nlv$bm_buffer_manager_control.lock);
      get_message (remaining_data_length, {future_data_requirements = } 0, to_descriptor);
      osp$clear_job_signature_lock (nlv$bm_buffer_manager_control.lock);
      osp$end_subsystem_activity;

{ Find the first buffer with data.

      from_descriptor := from_message_id.descriptor;
      WHILE from_descriptor^.container_length = from_descriptor^.data_start DO
        from_descriptor := from_descriptor^.link;
      WHILEND;

      to_message_id.descriptor := to_descriptor;
      to_message_id.sequence_number := to_descriptor^.sequence_number;
      from_container_capacity := from_descriptor^.container_length - from_descriptor^.data_start;
      to_container_capacity := to_descriptor^.container_length - to_descriptor^.data_start;

      IF (from_container_capacity = remaining_data_length) AND
            (remaining_data_length = to_container_capacity) THEN
        i#move (#LOC (from_descriptor^.container^ (1 + from_descriptor^.data_start)),
              #LOC (to_descriptor^.container^ (1 + to_descriptor^.data_start)), remaining_data_length);
      ELSE
        from_data_start := from_descriptor^.data_start;
        to_data_start := to_descriptor^.data_start;

      /copy_message/
        WHILE remaining_data_length > 0 DO

        /move_data_to_container/
          BEGIN

{ Fill the container.

            IF from_container_capacity >= to_container_capacity THEN
              i#move (#LOC (from_descriptor^.container^ (1 + from_data_start)),
                    #LOC (to_descriptor^.container^ (1 + to_data_start)), to_container_capacity);
              remaining_data_length := remaining_data_length - to_container_capacity;

              { Get the next to_descriptor.

              IF remaining_data_length > 0 THEN
                from_container_capacity := from_container_capacity - to_container_capacity;
                from_data_start := from_data_start + to_container_capacity;
                to_descriptor := to_descriptor^.link;
                to_data_start := to_descriptor^.data_start;
                to_container_capacity := to_descriptor^.container_length - to_data_start;
              ELSE { The message is complete.
                EXIT /copy_message/; {----->
              IFEND;

            ELSE { Partially fill the container.
              i#move (#LOC (from_descriptor^.container^ (1 + from_data_start)),
                    #LOC (to_descriptor^.container^ (1 + to_data_start)), from_container_capacity);
              to_container_capacity := to_container_capacity - from_container_capacity;
              to_data_start := to_data_start + from_container_capacity;
              remaining_data_length := remaining_data_length - from_container_capacity;
              from_container_capacity := 0;
            IFEND;
          END /move_data_to_container/;

        /get_next_buffer/
          WHILE from_container_capacity = 0 DO
            from_descriptor := from_descriptor^.link;
            from_data_start := from_descriptor^.data_start;
            from_container_capacity := from_descriptor^.container_length - from_data_start;
          WHILEND /get_next_buffer/;

        WHILEND /copy_message/;
      IFEND;
    ELSE
      to_message_id := nlv$bm_null_message_id;
    IFEND;
  PROCEND nlp$bm_copy_message;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$bm_create_message', EJECT ??
*copy nlh$bm_create_message

  PROCEDURE [XDCL] nlp$bm_create_message
    (    data: nat$data_fragments;
     VAR message_id: nlt$bm_message_id;
     VAR status: ost$status);

?? NEWTITLE := 'create_condition_handler', EJECT ??

{ NOTES:
{   Set the condition status to TRUE to prevent the task from terminating.  This deviates from
{   the coding standards.  The problem with this approach is that the condition is lost.  A
{   possible future solution might be to keep track of the conditions and restart the conditons
{   after leaving NAM/VE.

    PROCEDURE create_condition_handler
      (    condition: pmt$condition;
           ignore_condition_descriptor: ^pmt$condition_handler;
           sa: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      VAR
        ignore_status: ost$status;

      nap$condition_handler_trace (condition, sa);
      CASE condition.selector OF
      = pmc$system_conditions, mmc$segment_access_condition =
        osp$begin_subsystem_activity;
        osp$set_job_signature_lock (nlv$bm_buffer_manager_control.lock);
        release_message (message_id.descriptor);
        osp$clear_job_signature_lock (nlv$bm_buffer_manager_control.lock);
        osp$end_subsystem_activity;
        pmp$continue_to_cause (pmc$inhibit_standard_procedure, condition_status);
        osp$set_status_from_condition (nac$status_id, condition, sa, status, ignore_status);
        EXIT nlp$bm_create_message; {----->
      = pmc$user_defined_condition =
        IF condition.user_condition_name = osc$volume_unavailable_cond THEN
          osp$wait_on_condition (mme$volume_unavailable);
        ELSEIF condition.user_condition_name = osc$space_unavailable_condition THEN
          osp$wait_on_condition (dme$unable_to_alloc_all_space);
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND create_condition_handler;
?? OLDTITLE, EJECT ??

    VAR
      current_container_capacity: nlt$bm_buffer_length,

{ Data address exists solely to develop the address for the i#move which moves data from
{ the user's address space to the container.

      data_address: ^array [0 .. 0ffffff(16)] of cell,
      data_area_p: ^nat$data_fragment,
      data_start: nat$data_length,
      descriptor: ^nlt$bm_message_descriptor,
      fragment: integer,
      fragment_data_start: nat$data_length,
      i: integer,
      remaining_data_in_fragment: nat$data_length,
      remaining_data_length: integer;

    status.normal := TRUE;
    remaining_data_length := 0;

  /get_total_data_length/
    FOR i := 1 TO UPPERBOUND (data) DO
      data_area_p := ^data [i];
      IF (data_area_p^.length > 0) AND (data_area_p^.address <> NIL) THEN
        IF remaining_data_length = 0 THEN
          fragment := i; { First non zero fragment.
          remaining_data_in_fragment := data_area_p^.length;
        IFEND;
        remaining_data_length := remaining_data_length + data_area_p^.length;
      IFEND;
    FOREND /get_total_data_length/;

    IF remaining_data_length > 0 THEN
      osp$establish_condition_handler (^create_condition_handler, FALSE);
      osp$begin_subsystem_activity;
      osp$set_job_signature_lock (nlv$bm_buffer_manager_control.lock);
      get_message (remaining_data_length, nlc$bm_expected_header_size, descriptor);
      osp$clear_job_signature_lock (nlv$bm_buffer_manager_control.lock);
      osp$end_subsystem_activity;

      message_id.descriptor := descriptor;
      message_id.sequence_number := descriptor^.sequence_number;
      #SPOIL (message_id);

{ Find buffer to hold the first part of the new message.
{ NOTE the first buffers may be empty to allow for a future prefix.

      WHILE (descriptor^.link <> NIL) AND (descriptor^.data_start = descriptor^.container_length) DO
        descriptor := descriptor^.link;
      WHILEND;
      current_container_capacity := descriptor^.container_length - descriptor^.data_start;
      data_address := data [fragment].address;

{ The whole message is in one fragment and that fragment fits in to one buffer.

      IF (data [fragment].length = remaining_data_length) AND
            (remaining_data_length = current_container_capacity) THEN
        i#move (#LOC (data_address^ [0]), #LOC (descriptor^.container^ (1 + descriptor^.data_start)),
              remaining_data_length);

      ELSE
        data_start := descriptor^.data_start;
        fragment_data_start := 0;

      /create_message/
        WHILE remaining_data_length > 0 DO

        /move_data_to_container/
          BEGIN

{ Fill the container.

            IF remaining_data_in_fragment >= current_container_capacity THEN
              i#move (#LOC (data_address^ [fragment_data_start]),
                    #LOC (descriptor^.container^ (1 + data_start)), current_container_capacity);
              remaining_data_length := remaining_data_length - current_container_capacity;

{ Get the next descriptor.

              IF remaining_data_length > 0 THEN
                remaining_data_in_fragment := remaining_data_in_fragment - current_container_capacity;
                fragment_data_start := fragment_data_start + current_container_capacity;
                descriptor := descriptor^.link;
                data_start := descriptor^.data_start;
                current_container_capacity := descriptor^.container_length - data_start;
              ELSE { The message is complete.
                EXIT /create_message/; {----->
              IFEND;

            ELSE { Partially fill the container.
              i#move (#LOC (data_address^ [fragment_data_start]),
                    #LOC (descriptor^.container^ (1 + data_start)), remaining_data_in_fragment);
              current_container_capacity := current_container_capacity - remaining_data_in_fragment;
              remaining_data_length := remaining_data_length - remaining_data_in_fragment;
              data_start := data_start + remaining_data_in_fragment;
              remaining_data_in_fragment := 0;
            IFEND;
          END /move_data_to_container/;

        /get_next_fragment/
          WHILE remaining_data_in_fragment = 0 DO
            fragment := fragment + 1;
            data_area_p := ^data [fragment];
            IF (data_area_p^.length > 0) AND (data_area_p^.address <> NIL) THEN
              remaining_data_in_fragment := data_area_p^.length;
              fragment_data_start := 0;
              data_address := data_area_p^.address;
            IFEND;
          WHILEND /get_next_fragment/;

        WHILEND /create_message/;
      IFEND;
    ELSE
      message_id := nlv$bm_null_message_id;
    IFEND;
  PROCEND nlp$bm_create_message;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$bm_deliver_message', EJECT ??
*copy nlh$bm_deliver_message

  PROCEDURE [XDCL] nlp$bm_deliver_message
    (VAR data_area { input, output } : nat$data_fragments;
     VAR message_id { input, output } : nlt$bm_message_id;
     VAR data_length: integer;
     VAR buffers_released: nat$data_length);

?? NEWTITLE := 'deliver_condition_handler', EJECT ??

{ NOTES:
{   Set the condition status to TRUE to prevent the task from terminating.  This deviates from
{   the coding standards.  The problem with this approach is that the condition is lost.  A
{   possible future solution might be to keep track of the conditions and restart the conditons
{   after leaving NAM/VE.

    PROCEDURE deliver_condition_handler
      (    condition: pmt$condition;
           ignore_condition_descriptor: ^pmt$condition_handler;
           sa: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      VAR
        error_status: ost$status,
        ignore_status: ost$status;

      nap$condition_handler_trace (condition, sa);
      CASE condition.selector OF
      = pmc$system_conditions, mmc$segment_access_condition =
        pmp$continue_to_cause (pmc$execute_standard_procedure, condition_status);
        osp$set_status_from_condition (nac$status_id, condition, sa, error_status, ignore_status);
        pmp$abort (error_status);
      = pmc$user_defined_condition =
        IF condition.user_condition_name = osc$volume_unavailable_cond THEN
          osp$wait_on_condition (mme$volume_unavailable);
        ELSEIF condition.user_condition_name = osc$space_unavailable_condition THEN
          osp$wait_on_condition (dme$unable_to_alloc_all_space);
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;
    PROCEND deliver_condition_handler;
?? OLDTITLE, EJECT ??

    VAR
      data_area_length: integer,
      data_area_p: ^nat$data_fragment,
      data_start: nlt$bm_buffer_length,
      descriptor: ^nlt$bm_message_descriptor,
      fragment: integer,
      i: integer,
      message_length: integer,
      release_descriptor: ^nlt$bm_message_descriptor,
      release_descriptor_link: ^^nlt$bm_message_descriptor,
      remaining_data_in_container: nlt$bm_buffer_length;

    buffers_released := 0;
    data_length := 0;
    data_area_length := 0;

  /get_total_data_area_length/
    FOR i := 1 TO UPPERBOUND (data_area) DO
      data_area_p := ^data_area [i];
      IF (data_area_p^.length > 0) AND (data_area_p^.address <> NIL) THEN
        IF data_area_length = 0 THEN
          fragment := i; { First non zero fragment.
        IFEND;
        data_area_length := data_area_length + data_area_p^.length;
      IFEND;
    FOREND /get_total_data_area_length/;
    data_area_p := ^data_area [fragment];

    nlp$bm_get_message_length (message_id, message_length);
    IF (message_length > 0) AND (data_area_length > 0) THEN
      descriptor := message_id.descriptor;
      descriptor^.sequence_number := (descriptor^.sequence_number + 1) MOD nlc$bm_sequence_space;
      message_id.sequence_number := descriptor^.sequence_number;
      osp$establish_condition_handler (^deliver_condition_handler, FALSE);
      IF ((descriptor^.container_length - descriptor^.data_start) = message_length) AND
            (data_area_p^.length >= message_length) THEN
        data_length := message_length;
        i#move (#LOC (descriptor^.container^ (1 + descriptor^.data_start)), data_area_p^.
              address, message_length);
        release_descriptor := message_id.descriptor;
        message_id := nlv$bm_null_message_id;
        buffers_released := 1;
        data_area_p^.length := data_area_p^.length - message_length;
        data_area_p^.address := #ADDRESS (#RING (data_area_p^.address),
              #SEGMENT (data_area_p^.address), (#OFFSET (data_area_p^.address) +
              message_length));
      ELSE
        data_start := descriptor^.data_start;
        remaining_data_in_container := descriptor^.container_length - data_start;
        release_descriptor := message_id.descriptor;
        release_descriptor_link := ^release_descriptor;

      /deliver_message/
        WHILE (data_length < message_length) AND (data_length < data_area_length) DO

          WHILE (data_area_p^.length = 0) OR (data_area_p^.address = NIL) DO
            fragment := fragment + 1;
            data_area_p := ^data_area [fragment];
          WHILEND;

{ Fill the fragment.

          IF remaining_data_in_container > data_area_p^.length THEN
            i#move (#LOC (descriptor^.container^ (1 + data_start)), data_area_p^.
                  address, data_area_p^.length);
            data_length := data_length + data_area_p^.length;
            data_start := data_start + data_area_p^.length;
            remaining_data_in_container := remaining_data_in_container - data_area_p^.length;
            data_area_p^.length := 0;

          ELSE { Partially fill fragment with the remainder of the current container.
            i#move (#LOC (descriptor^.container^ (1 + data_start)), data_area_p^.
                  address, remaining_data_in_container);
            data_length := data_length + remaining_data_in_container;
            data_area_p^.address := #ADDRESS (#RING (data_area_p^.address),
                  #SEGMENT (data_area_p^.address), #OFFSET (data_area_p^.address) +
                  remaining_data_in_container);
            data_area_p^.length := data_area_p^.length - remaining_data_in_container;
            remaining_data_in_container := 0;
          IFEND;

          WHILE remaining_data_in_container = 0 DO
            buffers_released := buffers_released + 1;
            release_descriptor_link := ^descriptor^.link;
            descriptor := descriptor^.link;
            IF descriptor <> NIL THEN
              data_start := descriptor^.data_start;
              remaining_data_in_container := descriptor^.container_length - data_start;
            ELSE
              EXIT /deliver_message/; {----->
            IFEND;
          WHILEND;
        WHILEND /deliver_message/;
        IF descriptor <> NIL THEN
          descriptor^.data_start := data_start;
          message_id.descriptor := descriptor;
          message_id.sequence_number := descriptor^.sequence_number;
        ELSE
          message_id := nlv$bm_null_message_id;
        IFEND;
        release_descriptor_link^ := NIL;
      IFEND;
      IF release_descriptor <> NIL THEN
        osp$begin_subsystem_activity;
        osp$set_job_signature_lock (nlv$bm_buffer_manager_control.lock);
        release_message (release_descriptor);
        osp$clear_job_signature_lock (nlv$bm_buffer_manager_control.lock);
        osp$end_subsystem_activity;
      IFEND;
    IFEND;

  PROCEND nlp$bm_deliver_message;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$bm_extract_message_prefix', EJECT ??
*copy nlh$bm_extract_message_prefix

  PROCEDURE [XDCL] nlp$bm_extract_message_prefix
    (    prefix: ^cell;
         prefix_length: nat$data_length;
     VAR message_id: nlt$bm_message_id;
     VAR bytes_moved: nat$data_length);

    VAR
      descriptor: ^nlt$bm_message_descriptor,
      move_length: nat$data_length,

{ This declaration exists solely to develop the address for the i#move which moves the prefix
{ from the container to the user's address space.

      prefix_address: ^array [0 .. 0ffffff(16)] of cell,
      prefix_data_start: nat$data_length,
      release_descriptor: ^nlt$bm_message_descriptor,
      release_descriptor_link: ^^nlt$bm_message_descriptor,
      remaining_prefix_length: nat$data_length;

    IF (prefix <> NIL) AND (prefix_length > 0) AND (message_id.descriptor <> NIL) AND
          (message_id.sequence_number = message_id.descriptor^.sequence_number) THEN
      descriptor := message_id.descriptor;
      descriptor^.sequence_number := (descriptor^.sequence_number + 1) MOD nlc$bm_sequence_space;
      message_id.sequence_number := descriptor^.sequence_number;
      remaining_prefix_length := prefix_length;
      release_descriptor := message_id.descriptor;
      release_descriptor_link := ^release_descriptor;
      prefix_address := prefix;
      prefix_data_start := 0;

      REPEAT

{ Fill the prefix with the current buffer.

        IF (descriptor^.container_length - descriptor^.data_start) >= remaining_prefix_length THEN
          move_length := remaining_prefix_length;
        ELSE { Partially fill the prefix.
          move_length := descriptor^.container_length - descriptor^.data_start;
        IFEND;

        i#move (#LOC (descriptor^.container^ (1 + descriptor^.data_start)),
              #LOC (prefix_address^ [prefix_data_start]), move_length);
        descriptor^.data_start := descriptor^.data_start + move_length;
        prefix_data_start := prefix_data_start + move_length;
        remaining_prefix_length := remaining_prefix_length - move_length;

        IF descriptor^.data_start = descriptor^.container_length THEN
          release_descriptor_link := ^descriptor^.link;
          descriptor := descriptor^.link;
        IFEND;
      UNTIL (remaining_prefix_length = 0) OR (descriptor = NIL);

      bytes_moved := prefix_length - remaining_prefix_length;

      IF descriptor <> NIL THEN
        message_id.descriptor := descriptor;
        message_id.sequence_number := descriptor^.sequence_number;
      ELSE
        message_id := nlv$bm_null_message_id;
      IFEND;
      release_descriptor_link^ := NIL;

      IF release_descriptor <> NIL THEN
        osp$begin_subsystem_activity;
        osp$set_job_signature_lock (nlv$bm_buffer_manager_control.lock);
        release_message (release_descriptor);
        osp$clear_job_signature_lock (nlv$bm_buffer_manager_control.lock);
        osp$end_subsystem_activity;
      IFEND;
    ELSEIF message_id = nlv$bm_null_message_id THEN
      bytes_moved := 0;
    ELSE { Bad input parameters.
      nap$namve_system_error (FALSE, nlv$bm_buffer_manager_caller, NIL);
    IFEND;

  PROCEND nlp$bm_extract_message_prefix;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$bm_flush_message', EJECT ??
*copy nlh$bm_flush_message

  PROCEDURE [XDCL] nlp$bm_flush_message
    (    data_area: nat$data_fragments;
     VAR message_id: nlt$bm_message_id;
     VAR data_length: integer;
     VAR status: ost$status);

    VAR
      current_data_area_capacity: nat$data_length,

{ This declaration exists solely to develop the address for the i#move which moves data from
{ the container to the user's address space.

      data_address: ^array [0 .. 0ffffff(16)] of cell,
      data_area_length: integer,
      data_area_p: ^nat$data_fragment,
      data_start: nlt$bm_buffer_length,
      descriptor: ^nlt$bm_message_descriptor,
      fragment: nat$data_length,
      fragment_data_start: nat$data_length,
      i: integer,
      message_length: integer,
      remaining_data_in_container: nlt$bm_buffer_length;

?? NEWTITLE := 'flush_condition_handler', EJECT ??

{ NOTES:
{   Set the condition status to TRUE to prevent the task from terminating.  This deviates from
{   the coding standards.  The problem with this approach is that the condition is lost.  A
{   possible future solution might be to keep track of the conditions and restart the conditons
{   after leaving NAM/VE.

    PROCEDURE flush_condition_handler
      (    condition: pmt$condition;
           ignore_condition_descriptor: ^pmt$condition_handler;
           sa: ^ost$stack_frame_save_area;
       VAR condition_status: ost$status);

      VAR
        ignore_status: ost$status;

      nap$condition_handler_trace (condition, sa);
      CASE condition.selector OF
      = pmc$system_conditions, mmc$segment_access_condition =
        pmp$continue_to_cause (pmc$execute_standard_procedure, ignore_status);
        osp$set_status_from_condition (nac$status_id, condition, sa, status, ignore_status);
        pmp$abort (status);
      = pmc$user_defined_condition =
        IF condition.user_condition_name = osc$volume_unavailable_cond THEN
          osp$wait_on_condition (mme$volume_unavailable);
        ELSEIF condition.user_condition_name = osc$space_unavailable_condition THEN
          osp$wait_on_condition (dme$unable_to_alloc_all_space);
        IFEND;
        condition_status.normal := TRUE;
      ELSE
        condition_status.normal := TRUE;
      CASEND;

    PROCEND flush_condition_handler;
?? OLDTITLE ??
?? EJECT ??

    status.normal := TRUE;
    nlp$bm_get_message_length (message_id, message_length);
    data_area_length := 0;
    data_length := 0;

  /get_total_data_area_length/
    FOR i := 1 TO UPPERBOUND (data_area) DO
      data_area_p := ^data_area [i];
      IF (data_area_p^.length > 0) AND (data_area_p^.address <> NIL) THEN
        IF data_area_length = 0 THEN
          fragment := i; { First non empty fragment.
          current_data_area_capacity := data_area_p^.length;
        IFEND;
        data_area_length := data_area_length + data_area_p^.length;
      IFEND;
    FOREND /get_total_data_area_length/;

    IF message_length <= data_area_length THEN
      IF message_length > 0 THEN
        descriptor := message_id.descriptor;
        osp$establish_condition_handler (^flush_condition_handler, FALSE);

{ The whole message is contained in one buffer.  It fits into the first fragment.

        IF ((descriptor^.container_length - descriptor^.data_start) = message_length) AND
              (current_data_area_capacity >= message_length) THEN
          data_length := message_length;
          data_address := data_area [fragment].address;
          i#move (#LOC (descriptor^.container^ (1 + descriptor^.data_start)), #LOC (data_address^ [0]),
                message_length);
        ELSE
          data_start := descriptor^.data_start;
          fragment_data_start := 0;
          remaining_data_in_container := descriptor^.container_length - data_start;

        /flush_message/
          WHILE data_length < message_length DO

{ Find next non empty fragment if current is empty.

            WHILE current_data_area_capacity = 0 DO
              fragment := fragment + 1;
              data_area_p := ^data_area [fragment];
              IF (data_area_p^.length > 0) AND (data_area_p^.address <> NIL) THEN
                current_data_area_capacity := data_area_p^.length;
                fragment_data_start := 0;
              IFEND;
            WHILEND;

{ Get next descriptor.

            IF remaining_data_in_container = 0 THEN
              descriptor := descriptor^.link;
              data_start := descriptor^.data_start;
              remaining_data_in_container := descriptor^.container_length - data_start;
            IFEND;
            data_address := data_area [fragment].address;

{ Fill the current fragment.

            IF remaining_data_in_container >= current_data_area_capacity THEN
              i#move (#LOC (descriptor^.container^ (1 + data_start)),
                    #LOC (data_address^ [fragment_data_start]), current_data_area_capacity);
              data_length := data_length + current_data_area_capacity;
              remaining_data_in_container := remaining_data_in_container - current_data_area_capacity;
              data_start := data_start + current_data_area_capacity;
              current_data_area_capacity := 0;

            ELSE { Partially fill current fragment with remainder of current container.
              i#move (#LOC (descriptor^.container^ (1 + data_start)),
                    #LOC (data_address^ [fragment_data_start]), remaining_data_in_container);
              data_length := data_length + remaining_data_in_container;
              current_data_area_capacity := current_data_area_capacity - remaining_data_in_container;
              fragment_data_start := fragment_data_start + remaining_data_in_container;
              remaining_data_in_container := 0;
            IFEND;
          WHILEND /flush_message/;
        IFEND;
        message_id.descriptor^.sequence_number := (message_id.descriptor^.sequence_number + 1) MOD
              nlc$bm_sequence_space;
        osp$begin_subsystem_activity;
        osp$set_job_signature_lock (nlv$bm_buffer_manager_control.lock);
        release_message (message_id.descriptor);
        osp$clear_job_signature_lock (nlv$bm_buffer_manager_control.lock);
        osp$end_subsystem_activity;
        message_id := nlv$bm_nil_message_id;
      IFEND;
    ELSE { Data area too small.
      osp$set_status_condition (nae$data_area_too_small, status);
    IFEND;

  PROCEND nlp$bm_flush_message;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$bm_free_buffer_pools', EJECT ??
*copy nlh$bm_free_buffer_pools

  PROCEDURE [XDCL] nlp$bm_free_buffer_pools;

    VAR
      buffer_p: ^nlt$bm_buffer_pool_descriptor,
      i: integer,
      index: nlt$bm_sub_pool_index,
      pool: ^nlt$bm_allocated_pool_descr,
      sub_pool: ^nlt$bm_allocatd_buffer_sub_pool;

    FOR i := UPPERBOUND (nlv$bm_buffer_pool) DOWNTO LOWERBOUND (nlv$bm_buffer_pool) DO
      buffer_p := ^nlv$bm_buffer_pool [i];
      IF buffer_p^.allocated_memory <> NIL THEN
        FREE buffer_p^.allocated_memory IN nav$network_wired_heap^;
        nlv$bm_buffers_freed := TRUE;
        nav$global_statistics.buffer_manager.containers_freed [i] :=
              nav$global_statistics.buffer_manager.containers_freed [i] + 1;
      IFEND;

      pool := ^nlv$bm_allocated_buffer_pool [i];
      pool^.last_lowest_available_sub_pool := 1;
      pool^.highest_allocated_sub_pool := 1;

      FOR index := LOWERBOUND (pool^.sub_pool^) TO UPPERBOUND (pool^.sub_pool^) DO
        sub_pool := ^pool^.sub_pool^ [index];
        IF sub_pool^.allocated_memory <> NIL THEN
          FREE sub_pool^.allocated_memory IN nav$network_wired_heap^;
          sub_pool^.head := NIL;
          nlv$bm_buffers_freed := TRUE;
          nav$global_statistics.buffer_manager.containers_freed [i] :=
                nav$global_statistics.buffer_manager.containers_freed [i] + 1;
        IFEND;
      FOREND;

      buffer_p^.dynamic_buffers := 0;
      buffer_p^.count := 0;

    FOREND;

  PROCEND nlp$bm_free_buffer_pools;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$bm_get_buffer_list', EJECT ??
*copy nlh$bm_get_buffer_list

  PROCEDURE [XDCL] nlp$bm_get_buffer_list
    (VAR buffer_list { input, output } : nlt$bm_buffer_list_array;
     VAR buffers_acquired: boolean);

    VAR
      buffer_list_p: ^nlt$bm_buffer_list,
      pool: nlt$bm_pool_index;

    buffers_acquired := FALSE;
    osp$begin_subsystem_activity;
    osp$set_job_signature_lock (nlv$bm_buffer_manager_control.lock);

    FOR pool := nlc$bm_small_buffer_index TO nlc$bm_large_buffer_index DO
      buffer_list_p := ^buffer_list [pool];
      IF buffer_list_p^.buffer_list <> NIL THEN
        get_buffer_list (pool, buffer_list_p^.count, buffer_list_p^.buffer_list^);
        IF buffer_list_p^.count > 0 THEN
          buffers_acquired := TRUE;
        IFEND;
      IFEND;
    FOREND;

    osp$clear_job_signature_lock (nlv$bm_buffer_manager_control.lock);
    osp$end_subsystem_activity;

  PROCEND nlp$bm_get_buffer_list;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$bm_get_message_prefix', EJECT ??
*copy nlh$bm_get_message_prefix

  PROCEDURE [XDCL] nlp$bm_get_message_prefix
    (    prefix: ^cell;
         prefix_length: nat$data_length;
         message_id: nlt$bm_message_id;
     VAR status: ost$status);

    VAR
      descriptor: ^nlt$bm_message_descriptor,
      message_length: integer,
      move_length: nat$data_length,
      prefix_address: ^array [0 .. 0ffffff(16)] of cell,
      prefix_data_start: nat$data_length,
      remaining_prefix_length: nat$data_length;

    status.normal := TRUE;

    IF (prefix <> NIL) AND (prefix_length > 0) THEN
      nlp$bm_get_message_length (message_id, message_length);

      IF prefix_length <= message_length THEN
        descriptor := message_id.descriptor;
        prefix_data_start := 0;
        remaining_prefix_length := prefix_length;
        prefix_address := prefix;

        REPEAT
          IF (descriptor^.container_length - descriptor^.data_start) >= remaining_prefix_length THEN
            move_length := remaining_prefix_length;
          ELSE
            move_length := descriptor^.container_length - descriptor^.data_start;
          IFEND;
          i#move (#LOC (descriptor^.container^ (1 + descriptor^.data_start)),
                #LOC (prefix_address^ [prefix_data_start]), move_length);
          remaining_prefix_length := remaining_prefix_length - move_length;
          IF remaining_prefix_length > 0 THEN
            descriptor := descriptor^.link;
            prefix_data_start := prefix_data_start + move_length;
          IFEND;
        UNTIL remaining_prefix_length = 0;

      ELSE { insufficient buffer size
        osp$set_status_condition (nae$insufficient_data, status);
      IFEND;
    ELSE { Bad input parameters.
      nap$namve_system_error (FALSE, nlv$bm_buffer_manager_caller, NIL);
    IFEND;

  PROCEND nlp$bm_get_message_prefix;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$bm_initialize_buffer_pools', EJECT ??
*copy nlh$bm_initialize_buffer_pools

  PROCEDURE [XDCL] nlp$bm_initialize_buffer_pools
    (VAR status: ost$status);

    CONST
      heap_manager_overhead = 6 * 16,
      pp_buffer_preallocation = 16; {preallocated buffers to allow for PP buffer pool.

    VAR
      descriptor: ^^nlt$bm_message_descriptor,
      i: integer,
      large_buffer_count: integer,
      preallocated_buffers: integer,
      remaining_space: integer;

    status.normal := TRUE;
    CASE osv$page_size OF
    = 2048, 4096 =
      nlv$bm_large_buffer_size := osv$page_size;
    = 8192, 16384 =
      nlv$bm_large_buffer_size := 8192
    ELSE { Unsupported page size.
      osp$set_status_abnormal (nac$status_id, nae$initialization_fatal, 'unsupported page size', status);
      RETURN; {----->
    CASEND;

{ Buffer counts, sizes and credits are smaller for small machines to reduce wired memory usage.

    IF (osv$180_memory_limits.upper - osv$180_memory_limits.lower) < nlc$small_machine_threshold THEN
      large_buffer_count := 44;
      nlv$cc_maximum_receive_window := 10;
      nlv$cc_grant_credit_trigger := 4;
      nlv$bm_large_buffer_size := 2048;
    ELSE
      large_buffer_count := 256;
    IFEND;

{ If the size of nlv$bm_buffer_pool is changed, the statistics nat$buffer_manager_statistics and
{ nat$pp_buffer_pool_statistics must also be changed.
{
{ The number of buffers allocated in each pool and subpool is calculated to make optimum use of wired
{ memory. Space is reserved for the buffers, descriptors and heap manager overhead. Minimum heap manager
{ space consists of 6 times the size of type ost$hp_heap_space_desc (6 * 16 bytes). Since this type is
{ defined internally within module osm$heap_manager, it cannot be referenced symbolically.

    remaining_space := osv$page_size - (((nlc$bm_small_buffer_size + #SIZE (nlt$bm_message_descriptor)) *
          (large_buffer_count * 2)) + heap_manager_overhead) MOD osv$page_size;
    nlv$bm_buffer_pool [nlc$bm_small_buffer_index].count := large_buffer_count * 2 +
          (remaining_space DIV (nlc$bm_small_buffer_size + #SIZE (nlt$bm_message_descriptor)));

    preallocated_buffers := large_buffer_count + pp_buffer_preallocation;
    remaining_space := osv$page_size - (((nlv$bm_large_buffer_size + #SIZE (nlt$bm_message_descriptor)) *
          preallocated_buffers) + heap_manager_overhead) MOD osv$page_size;
    nlv$bm_buffer_pool [nlc$bm_large_buffer_index].length := nlv$bm_large_buffer_size;
    nlv$bm_buffer_pool [nlc$bm_large_buffer_index].count := preallocated_buffers +
          (remaining_space DIV (nlv$bm_large_buffer_size + #SIZE (nlt$bm_message_descriptor)));

  /initialize_buffer_pool/
    FOR i := nlc$bm_small_buffer_index TO nlc$bm_large_buffer_index DO
      allocate_buffer_pool (nlv$bm_buffer_pool [i].length, nlv$bm_buffer_pool [i].count, {sub_pool_index =} 0,
            {touch_pages =} TRUE, nlv$bm_buffer_pool [i].head, nlv$bm_buffer_pool [i].allocated_memory);
      IF nlv$bm_buffer_pool [i].allocated_memory = NIL THEN
        osp$set_status_condition (nae$initialization_fatal, status);
        nlp$bm_free_buffer_pools;
        EXIT /initialize_buffer_pool/; {----->
      IFEND;
      descriptor := ^nlv$bm_buffer_pool [i].head;
      WHILE descriptor^ <> NIL DO
        descriptor := ^descriptor^^.link;
      WHILEND;
      nlv$bm_buffer_pool [i].tail := descriptor;
    FOREND /initialize_buffer_pool/;

{ Initialize allocation buffer pool.

    remaining_space := osv$page_size - (((nlc$bm_small_buffer_size + #SIZE (nlt$bm_message_descriptor)) *
          large_buffer_count) + heap_manager_overhead) MOD osv$page_size;
    nlv$bm_allocated_buffer_pool [nlc$bm_small_buffer_index].sub_pool_allocation_size :=
          large_buffer_count + (remaining_space DIV (nlc$bm_small_buffer_size +
          #SIZE (nlt$bm_message_descriptor)));
    remaining_space := osv$page_size - (((nlv$bm_large_buffer_size + #SIZE (nlt$bm_message_descriptor)) *
          (large_buffer_count DIV 2)) + heap_manager_overhead) MOD osv$page_size;
    nlv$bm_allocated_buffer_pool [nlc$bm_large_buffer_index].buffer_length := nlv$bm_large_buffer_size;
    nlv$bm_allocated_buffer_pool [nlc$bm_large_buffer_index].sub_pool_allocation_size :=
          (large_buffer_count DIV 2) + (remaining_space DIV (nlv$bm_large_buffer_size +
          #SIZE (nlt$bm_message_descriptor)));

    IF nlv$bm_allocated_buffer_maximum > (nlv$bm_allocated_buffer_pool [nlc$bm_large_buffer_index].
          sub_pool_allocation_size * UPPERBOUND (nlv$bm_allocated_buffer_pool [nlc$bm_large_buffer_index].
          sub_pool^)) THEN
      nlv$bm_allocated_buffer_maximum := nlv$bm_allocated_buffer_pool [nlc$bm_large_buffer_index].
            sub_pool_allocation_size * UPPERBOUND (nlv$bm_allocated_buffer_pool [nlc$bm_large_buffer_index].
            sub_pool^);
      nlv$bm_allocat_buffer_threshold := nlv$bm_allocated_buffer_maximum - nlc$bm_minimum_buffers_for_cpu;
    IFEND;

  PROCEND nlp$bm_initialize_buffer_pools;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$bm_release_message', EJECT ??
*copy nlh$bm_release_message

  PROCEDURE [XDCL] nlp$bm_release_message
    (VAR message_id {input, output} : nlt$bm_message_id);

    IF nlp$bm_valid_message_id (message_id) THEN
      IF message_id <> nlv$bm_null_message_id THEN
        osp$begin_subsystem_activity;
        osp$set_job_signature_lock (nlv$bm_buffer_manager_control.lock);
        message_id.descriptor^.sequence_number := (message_id.descriptor^.sequence_number + 1) MOD
              nlc$bm_sequence_space;
        release_message (message_id.descriptor);
        osp$clear_job_signature_lock (nlv$bm_buffer_manager_control.lock);
        osp$end_subsystem_activity;
      IFEND;
      message_id := nlv$bm_nil_message_id;
    ELSE
      nap$namve_system_error (FALSE, nlv$bm_buffer_manager_caller, NIL);
    IFEND;
  PROCEND nlp$bm_release_message;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] nlp$bm_release_messages', EJECT ??
*copy nlh$bm_release_messages

  PROCEDURE [XDCL] nlp$bm_release_messages
    (VAR message_id { input, output } : array [1 .. * ] of nlt$bm_message_id);

    VAR
      message_p: ^nlt$bm_message_id,
      m: integer;

    osp$begin_subsystem_activity;
    osp$set_job_signature_lock (nlv$bm_buffer_manager_control.lock);
    FOR m := 1 TO UPPERBOUND (message_id) DO
      message_p := ^message_id [m];
      IF nlp$bm_valid_message_id (message_p^) THEN
        IF message_p^ <> nlv$bm_null_message_id THEN
          message_p^.descriptor^.sequence_number := (message_p^.descriptor^.sequence_number + 1) MOD
                nlc$bm_sequence_space;
          release_message (message_p^.descriptor);
        IFEND;
        message_p^ := nlv$bm_nil_message_id;
      ELSE
        nap$namve_system_error (FALSE, nlv$bm_buffer_manager_caller, NIL);
      IFEND;
    FOREND;
    osp$clear_job_signature_lock (nlv$bm_buffer_manager_control.lock);
    osp$end_subsystem_activity;

  PROCEND nlp$bm_release_messages;
?? OLDTITLE ??
?? NEWTITLE := 'allocate_buffer', EJECT ??

{ PURPOSE:
{   This procedure checks for a buffer that has previously been allocated.  If a buffer is not found
{   Allocate Buffer Pool is called which allocates a block of buffers.
{ DESIGN:
{   The search for a previously allocated buffer is bounded by the current value of last_lowest_
{   available_sub_pool and highest_allocated_sub_pool.  The last_lowest_available_sub_pool represents
{   where the last available buffer was found.
{ NOTES:
{   The pool size must be at least 2.  The buffer manager operation lock must be locked before this
{   procedure is called.

  PROCEDURE allocate_buffer
    (    i: nlt$bm_pool_index;
     VAR descriptor: ^nlt$bm_message_descriptor);

    VAR
      index: nlt$bm_sub_pool_index,
      pool: ^nlt$bm_allocated_pool_descr,
      sub_pool: ^nlt$bm_allocatd_buffer_sub_pool;

    descriptor := NIL;
    pool := ^nlv$bm_allocated_buffer_pool [i];

{ Search nlv$bm_allocated_buffer_pool [i] for an available buffer.

    FOR index := pool^.last_lowest_available_sub_pool TO pool^.highest_allocated_sub_pool DO
      sub_pool := ^pool^.sub_pool^ [index];
      IF sub_pool^.head <> NIL THEN
        descriptor := sub_pool^.head;
        sub_pool^.head := descriptor^.link;
        descriptor^.link := NIL;
        sub_pool^.count := sub_pool^.count - 1;
        pool^.last_lowest_available_sub_pool := index;
        nlv$bm_buffer_pool [i].dynamic_buffers := nlv$bm_buffer_pool [i].dynamic_buffers + 1;

{ Touch container to ensure it is wired in memory.

        descriptor^.container^ (1) := buffer_initialization;
        RETURN; {----->
      IFEND;
    FOREND;

{ Find unallocated sub pool.

    FOR index := LOWERBOUND (pool^.sub_pool^) TO UPPERBOUND (pool^.sub_pool^) DO
      sub_pool := ^pool^.sub_pool^ [index];
      IF sub_pool^.allocated_memory = NIL THEN
        allocate_buffer_pool (pool^.buffer_length, pool^.sub_pool_allocation_size, {sub_pool_index =} index,
              {touch_pages =} FALSE, sub_pool^.head, sub_pool^.allocated_memory);
        IF sub_pool^.allocated_memory <> NIL THEN
          descriptor := sub_pool^.head;
          sub_pool^.head := descriptor^.link;
          sub_pool^.count := pool^.sub_pool_allocation_size - 1;
          descriptor^.link := NIL;
          pool^.last_lowest_available_sub_pool := index;
          IF pool^.highest_allocated_sub_pool < index THEN
            pool^.highest_allocated_sub_pool := index;
          IFEND;
          nlv$bm_buffer_pool [i].dynamic_buffers := nlv$bm_buffer_pool [i].dynamic_buffers + 1;

{ Touch container to ensure it is wired in memory.

          descriptor^.container^ (1) := buffer_initialization;
        IFEND;
        RETURN; {----->
      IFEND;
    FOREND;
    pool^.last_lowest_available_sub_pool := UPPERBOUND (pool^.sub_pool^);
  PROCEND allocate_buffer;
?? OLDTITLE ??
?? NEWTITLE := 'allocate_buffer_pool', EJECT ??

{ PURPOSE:
{   This procedure allocates a block of buffers.
{ DESIGN:
{   This procedure is designed to allocate a block of buffers to reduce the amount of memory fragmention.
{   Currently, memory manager stores control information before each allocated block.
{   If each buffer was allocated seperately each buffer would have the memory manager control information.
{   This problem is magnified when allocating page size buffers aligned on a page boundary because each buffer
{   allocation would use two pages.  One page for the buffer and another part of a page for the control
{   information.

  PROCEDURE allocate_buffer_pool
    (    buffer_length: nlt$bm_buffer_length;
         buffer_count: nlt$bm_buffer_count;
         sub_pool_index: nlt$bm_sub_pool_index;
         touch_pages: boolean;
     VAR first_descriptor: ^nlt$bm_message_descriptor;
     VAR allocated_memory: ^nlt$bm_allocated_memory);

    VAR
      container: build_container_pointer,
      container_index: integer,
      descriptor: ^nlt$bm_message_descriptor,
      descriptor_index: integer,
      i: integer,
      pool_index: nlt$bm_pool_index;

    CASE osv$page_size OF
    = 2048 =
      ALLOCATE buffer_sub_pool.aligned_2048: [1 .. ((buffer_length + #SIZE (nlt$bm_message_descriptor)) *
            buffer_count)] IN nav$network_wired_heap^;
      allocated_memory := ^buffer_sub_pool.aligned_2048^.buffer;
    = 4096 =
      ALLOCATE buffer_sub_pool.aligned_4096: [1 .. ((buffer_length + #SIZE (nlt$bm_message_descriptor)) *
            buffer_count)] IN nav$network_wired_heap^;
      allocated_memory := ^buffer_sub_pool.aligned_4096^.buffer;
    = 8192 =
      ALLOCATE buffer_sub_pool.aligned_8192: [1 .. ((buffer_length + #SIZE (nlt$bm_message_descriptor)) *
            buffer_count)] IN nav$network_wired_heap^;
      allocated_memory := ^buffer_sub_pool.aligned_8192^.buffer;
    = 16384 =
      ALLOCATE buffer_sub_pool.aligned_16384: [1 .. ((buffer_length + #SIZE (nlt$bm_message_descriptor)) *
            buffer_count)] IN nav$network_wired_heap^;
      allocated_memory := ^buffer_sub_pool.aligned_16384^.buffer;
    ELSE
      nap$namve_system_error (FALSE, 'Unsupported page size.', NIL);
    CASEND;

    IF allocated_memory <> NIL THEN
      container_index := 1;
      descriptor_index := buffer_length * buffer_count + 1;
      first_descriptor := #LOC (allocated_memory^ [descriptor_index]);
      descriptor := first_descriptor;
      IF buffer_length = nlc$bm_small_buffer_size THEN
        pool_index := nlc$bm_small_buffer_index;
      ELSE
        pool_index := nlc$bm_large_buffer_index;
      IFEND;
      container.adaptable_string_pointer.length := buffer_length;

      FOR i := 1 TO buffer_count - 1 DO
        container.adaptable_string_pointer.pva := #LOC (allocated_memory^ [container_index]);

        IF touch_pages THEN
          container.pointer^ (1) := buffer_initialization;
        IFEND;
        descriptor^.container := container.pointer;
        descriptor^.container_length := buffer_length;
        descriptor^.pool_index := pool_index;
        descriptor^.sub_pool_index := sub_pool_index;
        descriptor^.sequence_number := 0;
        descriptor_index := descriptor_index + #SIZE (nlt$bm_message_descriptor);
        descriptor^.link := #LOC (allocated_memory^ [descriptor_index]);
        descriptor := descriptor^.link;
        container_index := container_index + buffer_length;
      FOREND;
      container.adaptable_string_pointer.pva := #LOC (allocated_memory^ [container_index]);

      IF touch_pages THEN
        container.pointer^ (1) := buffer_initialization;
      IFEND;
      descriptor^.container := container.pointer;
      descriptor^.container_length := buffer_length;
      descriptor^.pool_index := pool_index;
      descriptor^.sub_pool_index := sub_pool_index;
      descriptor^.sequence_number := 0;
      descriptor^.link := NIL;
      nav$global_statistics.buffer_manager.containers_allocated [pool_index] :=
            nav$global_statistics.buffer_manager.containers_allocated [pool_index] + 1;
    IFEND;
  PROCEND allocate_buffer_pool;
?? OLDTITLE ??
?? NEWTITLE := 'free_buffer', EJECT ??

{ PURPOSE:
{   This procedure releases previously allocated buffers.
{ DESIGN:
{   Buffers will be requeued onto the allocated buffer sub pool unless the current buffer would
{   fill the queue, in which case whole sub pool is freed.

  PROCEDURE [INLINE] free_buffer
    (VAR buffer { input, output } : ^nlt$bm_message_descriptor);

    VAR
      pool: ^nlt$bm_allocated_pool_descr,
      pool_index: nlt$bm_pool_index,
      sub_pool: ^nlt$bm_allocatd_buffer_sub_pool,
      sub_pool_index: integer;

    pool_index := buffer^.pool_index;
    sub_pool_index := buffer^.sub_pool_index;
    pool := ^nlv$bm_allocated_buffer_pool [pool_index];
    sub_pool := ^pool^.sub_pool^ [sub_pool_index];

    sub_pool^.count := sub_pool^.count + 1;
    IF sub_pool^.count < pool^.sub_pool_allocation_size THEN {Allocated sub pool is not full.
      buffer^.link := sub_pool^.head;
      sub_pool^.head := buffer;
      IF pool^.last_lowest_available_sub_pool > sub_pool_index THEN
        pool^.last_lowest_available_sub_pool := sub_pool_index;
      IFEND;
    ELSE { Allocated buffer is full.
      IF (pool^.highest_allocated_sub_pool = sub_pool_index) AND
            (sub_pool_index > LOWERBOUND (pool^.sub_pool^)) THEN { Find highest allocated sub pool.
        sub_pool_index := sub_pool_index - 1;
        WHILE (sub_pool_index > LOWERBOUND (pool^.sub_pool^)) AND
              (pool^.sub_pool^ [sub_pool_index].allocated_memory = NIL) DO
          sub_pool_index := sub_pool_index - 1;
        WHILEND;
        pool^.highest_allocated_sub_pool := sub_pool_index;
      IFEND;
      sub_pool^.head := NIL;
      FREE sub_pool^.allocated_memory IN nav$network_wired_heap^;
      nlv$bm_buffers_freed := TRUE;
      nav$global_statistics.buffer_manager.containers_freed [pool_index] :=
            nav$global_statistics.buffer_manager.containers_freed [pool_index] + 1;
    IFEND;
    nlv$bm_buffer_pool [pool_index].dynamic_buffers := nlv$bm_buffer_pool [pool_index].dynamic_buffers - 1;

  PROCEND free_buffer;
?? OLDTITLE ??
?? NEWTITLE := 'P$CYCLE_LOCK', EJECT ??

{PURPOSE:
{  Short Wait with Lock Set: Clear-Lock, Cycle, Set-Lock
{  This request is solely to not make a "slow process" inline.

  PROCEDURE p$cycle_lock;

    osp$clear_job_signature_lock (nlv$bm_buffer_manager_control.lock);
    osp$end_subsystem_activity;
    syp$cycle;
    osp$begin_subsystem_activity;
    osp$set_job_signature_lock (nlv$bm_buffer_manager_control.lock);

  PROCEND p$cycle_lock;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] get_buffer', EJECT ??

{ DESIGN:
{   This procedure will always return a buffer.

  PROCEDURE [INLINE] get_buffer
    (    pool: nlt$bm_pool_index;
     VAR buffer: ^nlt$bm_message_descriptor);

    IF nlv$bm_buffer_pool [pool].head <> NIL THEN
      buffer := nlv$bm_buffer_pool [pool].head;
      nlv$bm_buffer_pool [pool].head := buffer^.link;
      buffer^.link := NIL;
      nlv$bm_buffer_pool [pool].count := nlv$bm_buffer_pool [pool].count - 1;
      IF nlv$bm_buffer_pool [pool].head = NIL THEN
        nlv$bm_buffer_pool [pool].tail := ^nlv$bm_buffer_pool [pool].head;
      IFEND;
    ELSE { No buffers are available.
      REPEAT
        allocate_buffer (pool, buffer);
        IF buffer = NIL THEN { Loop until a buffer is available.
          p$cycle_lock
        IFEND
      UNTIL buffer <> NIL;
    IFEND;

  PROCEND get_buffer;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] get_buffer_list', EJECT ??

{ NOTES:
{   The buffer manager operation lock must be set before this procedure is called.

  PROCEDURE [INLINE] get_buffer_list
    (    pool: nlt$bm_pool_index;
     VAR count { input, output } : 0 .. 0ffff(16);
     VAR buffer_list: array [1 .. * ] of ^nlt$bm_message_descriptor);

    VAR
      available_buffers: integer,
      descriptor: ^nlt$bm_message_descriptor,
      i: integer,
      next_descriptor: ^nlt$bm_message_descriptor;

    IF pool = nlc$bm_large_buffer_index THEN
      available_buffers := (nlv$bm_buffer_pool [nlc$bm_large_buffer_index].count +
            (nlv$bm_allocat_buffer_threshold - nlv$bm_buffer_pool [nlc$bm_large_buffer_index].
            dynamic_buffers));

      IF available_buffers < count THEN
        IF available_buffers > 0 THEN
          count := available_buffers;
        ELSE
          count := 0;
        IFEND;
      IFEND;
    IFEND;

    descriptor := nlv$bm_buffer_pool [pool].head;
    next_descriptor := descriptor;

  /get_buffer/
    BEGIN
      i := 1;
      WHILE (i <= count) AND (descriptor <> NIL) DO
        next_descriptor := descriptor^.link;
        descriptor^.link := NIL;
        buffer_list [i] := descriptor;
        descriptor := next_descriptor;
        i := i + 1;
      WHILEND;
      WHILE i <= count DO
        allocate_buffer (pool, buffer_list [i]);
        IF buffer_list [i] <> NIL THEN
          buffer_list [i]^.link := NIL;
        ELSE
          EXIT /get_buffer/; {----->
        IFEND;
        i := i + 1;
      WHILEND;
    END /get_buffer/;

    count := i - 1;
    nlv$bm_buffer_pool [pool].head := next_descriptor;
    IF nlv$bm_buffer_pool [pool].head <> NIL THEN
      nlv$bm_buffer_pool [pool].count := nlv$bm_buffer_pool [pool].count - count;
    ELSE
      nlv$bm_buffer_pool [pool].tail := ^nlv$bm_buffer_pool [pool].head;
      nlv$bm_buffer_pool [pool].count := 0;
    IFEND;

  PROCEND get_buffer_list;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] get_message', EJECT ??

{ PURPOSE:
{   This procedure returns a linked list of descriptor container pairs.
{
{ NOTES:
{   The number of buffers returned in the message will be based on the required_data_length plus
{   future_data_requirements.  Future_data_requirements is an estimate of the amount
{   of additional space that will be needed during the life time of the message.
{   The descriptor's data starts are initialized based on the required_data_length.
{   The buffer manager operation lock must be locked before this procedure is called.

  PROCEDURE [INLINE] get_message
    (    required_data_length: integer;
         future_data_requirements: nat$data_length;
     VAR message: ^nlt$bm_message_descriptor);

    VAR
      count: array [nlt$bm_pool_index] of nlt$bm_buffer_count,
      descriptor: ^nlt$bm_message_descriptor,
      empty_space: nat$data_length,
      i: integer,
      link: ^^nlt$bm_message_descriptor,
      pool: nlt$bm_pool_index,
      remaining_data: nat$data_length;

{ Determine the number of buffers needed.

    count [nlc$bm_large_buffer_index] := (required_data_length + future_data_requirements) DIV
          nlv$bm_large_buffer_size;
    remaining_data := (required_data_length + future_data_requirements) MOD nlv$bm_large_buffer_size;
    IF remaining_data > (3 * nlc$bm_small_buffer_size) THEN
      count [nlc$bm_large_buffer_index] := count [nlc$bm_large_buffer_index] + 1;
      count [nlc$bm_small_buffer_index] := 0;
    ELSE { Need small_buffers.
      count [nlc$bm_small_buffer_index] := remaining_data DIV nlc$bm_small_buffer_size;
      IF remaining_data MOD nlc$bm_small_buffer_size > 0 THEN
        count [nlc$bm_small_buffer_index] := count [nlc$bm_small_buffer_index] + 1;
      IFEND;
    IFEND;

{ Get buffers.

    empty_space := (count [nlc$bm_large_buffer_index] * nlv$bm_large_buffer_size) +
          (count [nlc$bm_small_buffer_index] * nlc$bm_small_buffer_size) - required_data_length;
    link := ^message;
    FOR pool := nlc$bm_small_buffer_index TO nlc$bm_large_buffer_index DO
      FOR i := 1 TO count [pool] DO
        get_buffer (pool, descriptor);
        IF empty_space = 0 THEN
          descriptor^.data_start := 0;
        ELSEIF empty_space < nlv$bm_buffer_pool [pool].length THEN
          descriptor^.data_start := empty_space;
          empty_space := 0;
        ELSE
          descriptor^.data_start := nlv$bm_buffer_pool [pool].length;
          empty_space := empty_space - nlv$bm_buffer_pool [pool].length;
        IFEND;
        link^ := descriptor;
        link := ^descriptor^.link;
      FOREND;
    FOREND;
    link^ := NIL;
  PROCEND get_message;
?? OLDTITLE ??
?? NEWTITLE := '[INLINE] release_message', EJECT ??

{ DESIGN:
{   This procedure queues the static message buffers on the buffer pool. The
{   buffers in the last allocated block are freed more aggressively than those in the other
{   sub pools.
{   If buffer count is less than the threshold the dynamic message buffers are queued on the
{   buffer pool.

  PROCEDURE [INLINE] release_message
    (VAR buffer { input, output } : ^nlt$bm_message_descriptor);

    VAR
      count: nlt$bm_buffer_count,
      limit: nlt$bm_buffer_count,
      next_buffer: ^nlt$bm_message_descriptor,
      pool_index: nlt$bm_pool_index,
      pool_p: ^nlt$bm_buffer_pool_descriptor,
      sub_pool_index: integer;

    WHILE buffer <> NIL DO
      next_buffer := buffer^.link;
      pool_index := buffer^.pool_index;
      sub_pool_index := buffer^.sub_pool_index;

      pool_p := ^nlv$bm_buffer_pool [pool_index];
      count := pool_p^.count;
      limit := pool_p^.pool_limit;

{ Return buffer.

      IF (sub_pool_index = 0) OR (count < (limit DIV 4)) OR
            ((count < limit) AND (sub_pool_index < nlv$bm_allocated_buffer_pool [pool_index].
            highest_allocated_sub_pool)) THEN
        pool_p^.count := count + 1;
        pool_p^.tail^ := buffer;
        buffer^.link := NIL;
        pool_p^.tail := ^buffer^.link;
      ELSE
        free_buffer (buffer);
      IFEND;
      buffer := next_buffer;
    WHILEND

  PROCEND release_message;
?? OLDTITLE ??
MODEND nlm$buffer_manager;
