?? RIGHT := 110 ??
?? TITLE := 'Heap Management' ??
MODULE osm$heap_manager;
?? RIGHT := 110 ??

{ PURPOSE:
{   This module contains procedures to manage system heaps.  Its specific
{   functions are to allocate space in a heap, free space in a heap, reset a
{   heap, and verify a heap.

?? NEWTITLE := 'Global Declarations Referenced by this module' ??
?? PUSH (LISTEXT := ON) ??
*copyc dmt$error_condition_codes
*copyc oss$mainframe_pageable
*copyc ost$hardware_subranges
*copyc ost$heap
*copyc ost$heap_map
*copyc ost$prevalidate_free_result
*copyc ost$signature_lock
*copyc ost$stack_frame_save_area
?? POP ??
*copyc i#real_memory_address
*copyc mmp$assign_contiguous_memory
*copyc mmp$free_pages
*copyc mmp$os_preallocate_file_space
*copyc mmp$verify_no_space_available
*copyc osp$initialize_sig_lock
*copyc osp$system_error
*copyc pmp$delay
*copyc pmp$get_executing_task_gtid
*copyc pmp$zero_out_table
*copyc osv$page_size
*copyc mmv$tables_initialized
*copyc syv$enable_heap_trace
*copyc syv$verify_heap_linkage

*copyc i#disable_traps
*copyc i#restore_traps
*copyc osp$clear_job_signature_lock
*copyc osp$clear_mainframe_sig_lock
*copyc osp$set_job_signature_lock
*copyc osp$set_mainframe_sig_lock
?? OLDTITLE ??
?? NEWTITLE := 'Global Declarations Declared by this module', EJECT ??

  CONST
    c$min_algorithm = 0,
    c$traps_enabled_algorithm = c$min_algorithm + 0,
    c$os_heap_algorithm = c$min_algorithm + 1,
    c$namve_algorithm = c$min_algorithm + 2,

    c$max_algorithm = c$namve_algorithm;

  CONST
    c$allocation_id = -45723,
    c$trace_allocation_id = 19813,
    c$heap_id = 213651(16), { used to validate heap pointer
    c$min_fragment_size = 3, { minimum size of fragment
    c$min_allocation_size = 2;

  TYPE
    ost$hp_heap_space_desc = record
      link: ost$halfword,
      length: ost$halfword,
      case (free_b, busy_b, busy_b_trace) of
      = free_b =
        fwd: ost$halfword,
        bkw: ost$halfword,
      = busy_b =
        c$allocation_id: integer,
      = busy_b_trace =
        p_register: ost$pva,
        c$trace_allocation_id: 0 .. 0ffff(16),
      casend,
    recend,

    ost$hp_heap = record
      lock: ALIGNED [0 MOD 32] ost$signature_lock,
{     unused: string (16), {Retain for compatibility with previous systems.}
      allocate_call_count: integer,
      free_call_count: integer,
      id: ost$halfword,
      base: ost$halfword,
      desc_per_page: ost$halfword,
      lock_option: boolean,
      algorithm: t$algorithm,
      small_block_ceiling: ost$halfword,
      min_fragment_size: ost$halfword,
      min_allocation_size: ost$halfword,
      chain_search_count: integer,
      sd: ALIGNED [0 MOD 32] array [0 .. 10000000] of ost$hp_heap_space_desc,
    recend;

  TYPE
    t$algorithm = packed record
      avoid_small_block: boolean,
      value: 0 .. 7F(16),
    recend;

  TYPE
    ptr_variant = record
      case t: (ptr, cy80, stringp) of
      = ptr =
        ptr: ^ost$hp_heap,
      = cy80 =
        ringseg: 0 .. 0ffff(16),
        bytenum: ost$halfword,
      = stringp =
        sp: ^string (255),
      casend,
    recend;

?? OLDTITLE ??
?? NEWTITLE := 'P$CHECK_HEAP', EJECT ??

  PROCEDURE p$check_heap
    (    hp: ^ost$hp_heap;
     VAR ok: boolean);

    VAR
      inext: integer;

    ok := TRUE;
    inext := 1;
    WHILE inext <> hp^.sd [0].bkw DO
      IF hp^.sd [hp^.sd [inext].length + inext].link <> inext THEN
        ok := FALSE;
        RETURN; {----->
      IFEND;
      inext := hp^.sd [inext].length + inext;
    WHILEND;

  PROCEND p$check_heap;
?? OLDTITLE ??
?? NEWTITLE := 'P$PREALLOCATE_HEAP_SPACE', EJECT ??

  PROCEDURE p$preallocate_heap_space
    (    block_index: ost$halfword;
         ptr_heap: {i^/o^} ^ost$hp_heap;
     VAR ok: boolean);

    CONST
      max_attempts = 3;

    VAR
      attempt: 1 .. max_attempts,
      maximum_wait_seconds: integer,
      no_space_available: boolean,
      status: ost$status;

    maximum_wait_seconds := 1;

  /preallocate_file_space/
    FOR attempt := 1 TO max_attempts DO
      mmp$os_preallocate_file_space (ptr_heap, #OFFSET (^ptr_heap^.sd [block_index]),
            maximum_wait_seconds, status);
      IF status.normal THEN
        ok := TRUE;
        RETURN; {----->
      ELSEIF status.condition = dme$unable_to_alloc_all_space THEN
        mmp$verify_no_space_available (ptr_heap, no_space_available, status);
        IF NOT status.normal THEN
          EXIT /preallocate_file_space/; {----->
        ELSEIF no_space_available THEN
          EXIT /preallocate_file_space/; {----->
        IFEND;
      IFEND;

      maximum_wait_seconds := 60;
      pmp$delay (2000 {2 seconds} , status);
    FOREND /preallocate_file_space/;

    ok := FALSE;

  PROCEND p$preallocate_heap_space;
?? OLDTITLE ??
?? NEWTITLE := '[inline] P$REMOVE_BLOCK_FROM_FREE_CHAIN', EJECT ??

{ This procedure is used to remove a block from the free chain.

  PROCEDURE [INLINE] p$remove_block_from_free_chain
    (    i: integer;
         hp: ^ost$hp_heap);

    VAR
      inext: integer,
      iprev: integer;

    inext := hp^.sd [i].fwd;
    iprev := hp^.sd [i].bkw;
    hp^.sd [inext].bkw := iprev;
    hp^.sd [iprev].fwd := inext;

  PROCEND p$remove_block_from_free_chain;
?? OLDTITLE ??
?? NEWTITLE := '[xdcl, #gate] CYP$ALLOCATE', EJECT ??

  PROCEDURE [XDCL, #GATE] cyp$allocate
    (VAR up: ^ost$hp_heap_space_desc;
         length: ost$halfword;
         hp: ^ost$hp_heap;
         alignment_base: ost$halfword);

    VAR
      alloc_size: integer,
      desc_in_page: integer,
      enable_heap_trace: boolean,
      i: integer,
      iprev: integer,
      ok: boolean,
      old_te: 0 .. 3,
      pagecross_size: integer,
      preg: ost$pva,
      psa: ^ost$stack_frame_save_area,
      search_count: integer,
      seg: 0 .. 0ffffff(16),
      system_error_message: string (80);

{ Check heap id.  Abort if id is incorrect.  An incorrect id is caused by the user corrupting the heap
{ pointer, passing an incorrect pointer, or failing to reset the heap.

    IF hp^.id <> c$heap_id THEN
      osp$system_error ('HEAPMGR - bad heap pointer', NIL);
    IFEND;

    search_count := 0;

{ Calculate the amount of space to allocate.  Space length is expressed in terms of number of descs of space
{ rounded to a multiple of the minimum allocatable unit of descs.  Block control info is included in the
{ length.

    alloc_size := ((length + 47) DIV 32) * 2;
    IF hp^.algorithm.avoid_small_block AND (alloc_size < hp^.min_allocation_size) THEN
      alloc_size := hp^.min_allocation_size;
    IFEND;
    pagecross_size := alignment_base;
    IF pagecross_size <= 32 THEN
      pagecross_size := 0;
    ELSE
      IF pagecross_size > length THEN
        pagecross_size := length;
      IFEND;
{     IF pagecross_size > osv$page_size THEN
{       osp$system_error ('HEAPMGR - block gt pagesize', NIL);
{     IFEND;
      pagecross_size := ((pagecross_size + 47) DIV 32) * 2;
    IFEND;


{ Set the serialization lock on the heap.
    enable_heap_trace := (hp^.algorithm.value = c$os_heap_algorithm) AND syv$enable_heap_trace;
    IF hp^.algorithm.value > 0 THEN
      i#disable_traps (old_te);
    IFEND;
    IF hp^.lock_option THEN
      IF #RING (hp) = 1 THEN
        osp$set_mainframe_sig_lock (hp^.lock);
      ELSE
        osp$set_job_signature_lock (hp^.lock);
      IFEND;
    IFEND;
    IF syv$verify_heap_linkage THEN
      p$check_heap (hp, ok);
      IF NOT ok THEN
        osp$system_error ('HEAPMGR - heap linkage bad', NIL);
      IFEND;
    IFEND;

{ Search the free blocks in the heap for the first block that is greater than or equal to the required size.
{ Don't let the block cross a page boundary unless the user says it is ok.  If the block being assigned is the
{ last block in the heap and the preceding block is free, combine the two blocks.

    i := hp^.sd [0].fwd;

  /scanloop/
    WHILE i <> 0 DO
      search_count := search_count + 1;
      IF hp^.sd [i].length >= alloc_size THEN
        IF pagecross_size = 0 THEN
          EXIT /scanloop/ {----->
        IFEND;
        desc_in_page := hp^.desc_per_page - ((i + hp^.base) MOD hp^.desc_per_page);
        IF desc_in_page >= pagecross_size THEN
          EXIT /scanloop/ {----->
        IFEND;
        IF (hp^.sd [i].length - desc_in_page) >= alloc_size THEN
          iprev := i;
          i := i + desc_in_page;
          hp^.sd [i].link := iprev;
          IF iprev <> hp^.sd [0].bkw THEN
            hp^.sd [iprev + hp^.sd [iprev].length].link := i;
          IFEND;
          hp^.sd [i].length := hp^.sd [iprev].length - desc_in_page;
          hp^.sd [iprev].length := desc_in_page;
          hp^.sd [i].fwd := hp^.sd [iprev].fwd;
          hp^.sd [iprev].fwd := i;
          hp^.sd [i].bkw := iprev;
          hp^.sd [hp^.sd [i].fwd].bkw := i;
          EXIT /scanloop/; {----->
        IFEND;
      IFEND;
      i := hp^.sd [i].fwd;
    WHILEND /scanloop/;


{ If traps are enabled and more space is needed, then attempt to preallocate the block of space.
    IF i <> 0 THEN
      IF hp^.algorithm.value = c$traps_enabled_algorithm THEN
        IF (#OFFSET (^hp^.sd [i + alloc_size]) DIV 16384) > (#OFFSET (^hp^.sd [hp^.sd [0].bkw]) DIV
              16384) THEN
          p$preallocate_heap_space (i + alloc_size, hp, ok);
          IF NOT ok THEN
            i := 0;
          IFEND;
        IFEND;
      IFEND;
    IFEND;


{ If the free space is about the same size as the required space, remove the block from the free chain.
{ If the block is a lot bigger than required, split it and leave the unused part in the free block chain.
{ If the selected block is the one and only block in the heap and assigning it would leave the free block
{ chain empty, reject the assignment.

    IF i <> 0 THEN
      IF (hp^.sd [i].length < (c$min_fragment_size + alloc_size))
{   } OR (hp^.algorithm.avoid_small_block AND (hp^.sd [i].length < (hp^.min_fragment_size + alloc_size))) THEN
        IF i = hp^.sd [0].bkw THEN
          i := 0;
        ELSE
          p$remove_block_from_free_chain (i, hp);
        IFEND;
      ELSE
        hp^.sd [i + alloc_size].length := hp^.sd [i].length - alloc_size;
        hp^.sd [i + alloc_size].link := i;
        hp^.sd [i + alloc_size].fwd := hp^.sd [i].fwd;
        hp^.sd [i + alloc_size].bkw := hp^.sd [i].bkw;
        IF i <> hp^.sd [0].bkw THEN
          hp^.sd [hp^.sd [i].length + i].link := i + alloc_size;
        IFEND;
        hp^.sd [i].length := alloc_size;
        hp^.sd [hp^.sd [i].fwd].bkw := i + alloc_size;
        hp^.sd [hp^.sd [i].bkw].fwd := i + alloc_size;
      IFEND;
    IFEND;


{ Store a unique identifier in the allocation id field; it helps detect bugs and is used in FREE to determine
{ if a block is allocated or free.

    IF i <> 0 THEN
      IF enable_heap_trace THEN
        hp^.sd [i].c$trace_allocation_id := c$trace_allocation_id;
        psa := #PREVIOUS_SAVE_AREA ();
        hp^.sd [i].p_register := psa^.minimum_save_area.p_register.pva;
      ELSE
        hp^.sd [i].c$allocation_id := c$allocation_id;
      IFEND;
      up := ^hp^.sd [i + 1];
    ELSE
      up := NIL;
    IFEND;

{Debug
    IF hp^.algorithm.value <> c$traps_enabled_algorithm THEN
      hp^.allocate_call_count := hp^.allocate_call_count + 1;
      hp^.chain_search_count := hp^.chain_search_count + search_count;
    IFEND;
{Debug End

{ Clear the serialization lock on the heap.
    IF hp^.lock_option THEN
      IF #RING (hp) = 1 THEN
        osp$clear_mainframe_sig_lock (hp^.lock);
      ELSE
        osp$clear_job_signature_lock (hp^.lock);
      IFEND;
    IFEND;

    IF (i = 0) AND (hp^.algorithm.value = c$os_heap_algorithm) THEN
      psa := #PREVIOUS_SAVE_AREA ();
      preg := psa^.minimum_save_area.p_register.pva;
      STRINGREP (system_error_message, i, ' HEAPMGR - heap ', hp, ' is full - P caller = ', preg.ring: #(16),
            preg.seg: #(16), preg.offset: #(16));
      osp$system_error (system_error_message (1, i), NIL);
    IFEND;

    IF hp^.algorithm.value > 0 THEN
      i#restore_traps (old_te);
    IFEND;

  PROCEND cyp$allocate;
?? OLDTITLE ??
?? NEWTITLE := '[xdcl, #gate] CYP$FREE', EJECT ??

  PROCEDURE [XDCL, #GATE] cyp$free
    (    offset: ost$halfword;
         hp: ^ost$hp_heap);

    VAR
      enable_heap_trace: boolean,
      i: integer,
      inext: integer,
      iprev: integer,
      j: integer,
      ok: boolean,
      old_te: 0 .. 3,
      preg: ost$pva,
      psa: ^ost$stack_frame_save_area,
      seg: 0 .. 0ffffff(16),
      system_error_message: string (128),
      up: ^ost$hp_heap_space_desc;

{ Check heap id.  Abort if id is incorrect.  An incorrect id is caused by the user corrupting the heap
{ pointer, passing an incorrect pointer, or failing to reset the heap.

    IF hp^.id <> c$heap_id THEN
      osp$system_error ('HEAPMGR - bad heap pointer', NIL);
      RETURN; {----->
    IFEND;

{ Generate the index of the block being freed.

    i := (offset - (#SIZE (hp^) - #SIZE (hp^.sd))) DIV 16;


{ Abort if the block does not look like an allocated block.

    enable_heap_trace := (hp^.algorithm.value = c$os_heap_algorithm) AND syv$enable_heap_trace;
    IF ((NOT enable_heap_trace) AND (hp^.sd [i].c$allocation_id <> c$allocation_id)) OR
          (enable_heap_trace AND (hp^.sd [i].c$trace_allocation_id <> c$trace_allocation_id)) THEN
      psa := #PREVIOUS_SAVE_AREA ();
      preg := psa^.minimum_save_area.p_register.pva;
      STRINGREP (system_error_message, j, ' HEAPMGR - heap ', hp, ' illegal free - P caller = ', preg.ring:
            #(16), preg.seg: #(16), preg.offset: #(16), ' block index = ', i, ' Heap offset = ', offset:
            #(16));
      osp$system_error (system_error_message (1, j), NIL);
    IFEND;


{ Set the serialization lock on the heap.

    IF hp^.algorithm.value > 0 THEN
      i#disable_traps (old_te);
    IFEND;
    IF hp^.lock_option THEN
      IF #RING (hp) = 1 THEN
        osp$set_mainframe_sig_lock (hp^.lock);
      ELSE
        osp$set_job_signature_lock (hp^.lock);
      IFEND;
    IFEND;
    IF syv$verify_heap_linkage THEN
      p$check_heap (hp, ok);
      IF NOT ok THEN
        osp$system_error ('HEAPMGR - heap linkage bad', NIL);
      IFEND;
    IFEND;


{ Verify that the block being freed is a valid block.

    iprev := hp^.sd [i].link;
    inext := i + hp^.sd [i].length;
    IF (iprev <> 0) AND ((hp^.sd [iprev].length + iprev) <> i) OR
          (inext <> hp^.sd [0].bkw) AND (hp^.sd [inext].link <> i) THEN
      IF hp^.lock_option THEN
        IF #RING (hp) = 1 THEN
          osp$clear_mainframe_sig_lock (hp^.lock);
        ELSE
          osp$clear_job_signature_lock (hp^.lock);
        IFEND;
      IFEND;
      IF hp^.algorithm.value > 0 THEN
        i#restore_traps (old_te);
      IFEND;
      psa := #PREVIOUS_SAVE_AREA ();
      preg := psa^.minimum_save_area.p_register.pva;
      STRINGREP (system_error_message, i, ' HEAPMGR - heap ', hp, ' bad heap control info - P caller = ',
            preg.ring: #(16), preg.seg: #(16), preg.offset: #(16));
      osp$system_error (system_error_message (1, i), NIL);
    IFEND;


{ If the freed block and the free block immediately preceeding it are adjacent, combine them into one block.

    up := ^hp^.sd [i + 1];

    IF (iprev <> 0) AND (((NOT enable_heap_trace) AND (hp^.sd [iprev].c$allocation_id <> c$allocation_id)) OR
          (enable_heap_trace AND (hp^.sd [iprev].c$trace_allocation_id <> c$trace_allocation_id))) AND
          ((hp^.sd [iprev].fwd <= UPPERBOUND (hp^.sd)) AND (hp^.sd [iprev].bkw <= UPPERBOUND (hp^.sd))) THEN
      hp^.sd [iprev].length := hp^.sd [iprev].length + hp^.sd [i].length;
      p$remove_block_from_free_chain (iprev, hp);
      hp^.sd [hp^.sd [i].length + i].link := iprev;
      hp^.sd [i].c$allocation_id := 0;
      i := iprev;
    IFEND;


{ If the block following the freed block is also free, combine them into a single larger block.  Link the
{ freed block (possibly combined with adjacent free blocks) to the head of the free block chain.
{ EXCEPTION: If the block following the freed block is the last block in the heap, combine the current block
{ with it but leave the resultant block at the end of the chain.

    IF hp^.sd [0].bkw = inext THEN
      hp^.sd [i].fwd := 0;
      hp^.sd [i].length := hp^.sd [i].length + hp^.sd [inext].length;
      hp^.sd [i].bkw := hp^.sd [inext].bkw;
      hp^.sd [hp^.sd [i].bkw].fwd := i;
      hp^.sd [0].bkw := i;
    ELSE
      IF (((NOT enable_heap_trace) AND (hp^.sd [inext].c$allocation_id <> c$allocation_id)) OR
            (enable_heap_trace AND (hp^.sd [inext].c$trace_allocation_id <> c$trace_allocation_id))) AND
            ((hp^.sd [inext].fwd <= UPPERBOUND (hp^.sd)) AND (hp^.sd [inext].bkw <= UPPERBOUND (hp^.sd))) THEN
        hp^.sd [i].length := hp^.sd [i].length + hp^.sd [inext].length;
        p$remove_block_from_free_chain (inext, hp);
        hp^.sd [hp^.sd [inext].length + inext].link := i;
      IFEND;
      hp^.sd [i].fwd := hp^.sd [0].fwd;
      hp^.sd [hp^.sd [0].fwd].bkw := i;
      hp^.sd [0].fwd := i;
      hp^.sd [i].bkw := 0;
    IFEND;

{Debug
    IF hp^.algorithm.value <> c$traps_enabled_algorithm THEN
      hp^.free_call_count := hp^.free_call_count + 1;
    IFEND;
{Debug End

{ Clear the serialization lock on the heap.

    IF hp^.lock_option THEN
      IF #RING (hp) = 1 THEN
        osp$clear_mainframe_sig_lock (hp^.lock);
      ELSE
        osp$clear_job_signature_lock (hp^.lock);
      IFEND;
    IFEND;

    IF hp^.algorithm.value > 0 THEN
      i#restore_traps (old_te);
    IFEND;

  PROCEND cyp$free;
?? OLDTITLE ??
?? NEWTITLE := '[xdcl, #gate] OSP$EXTEND_HEAP', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$extend_heap
    (    size: integer;
         heap_p: ^ost$heap;
     VAR new_page_boundary: ^cell);

    VAR
      hp: ^ost$hp_heap,
      page_boundary: ^cell,
      index: integer,
      status: ost$status,
      old_te: 0 .. 3,
      p: ^cell;

    hp := #LOC (heap_p^);

    IF hp^.algorithm.value > 0 THEN
      i#disable_traps (old_te);
    IFEND;
    IF hp^.lock_option THEN
      IF #RING (hp) = 1 THEN
        osp$set_mainframe_sig_lock (hp^.lock);
      ELSE
        osp$set_job_signature_lock (hp^.lock);
      IFEND;
    IFEND;

    index := hp^.sd [0].bkw;
    p := ^hp^.sd [index + 1];
    page_boundary := #ADDRESS (1, #SEGMENT (p), ((#OFFSET (p) + osv$page_size - 1) DIV osv$page_size) *
          osv$page_size);
    IF mmv$tables_initialized AND (size < 65536) THEN
      IF new_page_boundary <> page_boundary THEN
        mmp$free_pages (page_boundary, size + osv$page_size, osc$nowait, status);
        mmp$assign_contiguous_memory (page_boundary, size, status);
        new_page_boundary := page_boundary;
      IFEND;
    ELSE
      pmp$zero_out_table (page_boundary, size);
    IFEND;

    IF hp^.lock_option THEN
      IF #RING (hp) = 1 THEN
        osp$clear_mainframe_sig_lock (hp^.lock);
      ELSE
        osp$clear_job_signature_lock (hp^.lock);
      IFEND;
    IFEND;

    IF hp^.algorithm.value > 0 THEN
      i#restore_traps (old_te);
    IFEND;

  PROCEND osp$extend_heap;
?? OLDTITLE ??
?? NEWTITLE := '[xdcl, #gate] OSP$FREE_HEAP_PAGES', EJECT ??
*copy osh$free_heap_pages

  PROCEDURE [XDCL, #GATE] osp$free_heap_pages
    (    xhp: ^ost$heap);

    VAR
      desc_in_page: integer,
      hp: ^ost$hp_heap,
      index: integer,
      old_te: 0 .. 3,
      rma: integer,
      status: ost$status;

    status.normal := TRUE;
    hp := #LOC (xhp^);

{ Set the serializaton lock on the heap.

    IF hp^.algorithm.value > 0 THEN
      i#disable_traps (old_te);
    IFEND;
    IF hp^.lock_option THEN
      IF #RING (hp) = 1 THEN
        osp$set_mainframe_sig_lock (hp^.lock);
      ELSE
        osp$set_job_signature_lock (hp^.lock);
      IFEND;
    IFEND;


    index := hp^.sd [0].fwd;

  /scan_free_blocks/
    WHILE index <> 0 DO
      IF hp^.sd [index].length > hp^.desc_per_page THEN
        desc_in_page := hp^.desc_per_page - ((index + hp^.base) MOD hp^.desc_per_page);
        IF (hp^.sd [index].length - desc_in_page) > hp^.desc_per_page THEN
          mmp$free_pages (#LOC (hp^.sd [index]), hp^.sd [index].length * 16, osc$wait, status);
        IFEND;
      IFEND;
      index := hp^.sd [index].fwd;
    WHILEND /scan_free_blocks/;


{ Clear the serialization lock on the heap.

    IF hp^.lock_option THEN
      IF #RING (hp) = 1 THEN
        osp$clear_mainframe_sig_lock (hp^.lock);
      ELSE
        osp$clear_job_signature_lock (hp^.lock);
      IFEND;
    IFEND;

    IF hp^.algorithm.value > 0 THEN
      i#restore_traps (old_te);
    IFEND;

  PROCEND osp$free_heap_pages;
?? OLDTITLE ??
?? NEWTITLE := '[xdcl, #gate] OSP$GENERATE_HEAP_MAP', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$generate_heap_map
    (    xhp: ^ost$heap;
     VAR heap_map: ost$heap_map);

    VAR
      index: integer,
      hp: ^ost$hp_heap,
      old_te: 0 .. 3;

?? NEWTITLE := 'P$GENERATE_HEAP_MAP', EJECT ??

    PROCEDURE p$generate_heap_map
      (    hp: ^ost$hp_heap;
       VAR heap_map: ost$heap_map);

      VAR
        enable_heap_trace: boolean,
        inext: integer,
        size: integer,
        size_index: integer;

      inext := 1;
      size := 0;
      enable_heap_trace := (hp^.algorithm.value = c$os_heap_algorithm) AND syv$enable_heap_trace;

      REPEAT
        IF hp^.sd [hp^.sd [inext].length + inext].link <> inext THEN
          heap_map.status := osc$heap_verification_failure;
          RETURN; {----->
        IFEND;
        inext := inext + size;

        size := hp^.sd [inext].length;
        size_index := size;
        IF size > 1024 THEN
          size_index := 1025;
        IFEND;

        IF ((NOT enable_heap_trace) AND (hp^.sd [inext].c$allocation_id = c$allocation_id)) OR
              (enable_heap_trace AND (hp^.sd [inext].c$trace_allocation_id = c$trace_allocation_id)) THEN
          heap_map.busy_size_total := heap_map.busy_size_total + size;
          heap_map.busy_size_statistic [size_index] := heap_map.busy_size_statistic [size_index] + 1;
          IF size > heap_map.busy_size_max THEN
            heap_map.busy_size_max := size;
          IFEND;
        ELSE
          heap_map.free_size_total := heap_map.free_size_total + size;
          heap_map.free_size_statistic [size_index] := heap_map.free_size_statistic [size_index] + 1;
          IF size > heap_map.free_size_max THEN
            heap_map.free_size_max := size;
          IFEND;
        IFEND;
      UNTIL inext = hp^.sd [0].bkw;

    PROCEND p$generate_heap_map;
?? OLDTITLE ??
?? EJECT ??

    heap_map.status := osc$heap_free_valid;
    heap_map.busy_size_total := 0;
    heap_map.free_size_total := 0;
    heap_map.busy_size_max := 0;
    heap_map.free_size_max := 0;
    FOR index := LOWERBOUND (heap_map.busy_size_statistic) TO UPPERBOUND (heap_map.busy_size_statistic) DO
      heap_map.busy_size_statistic [index] := 0;
      heap_map.free_size_statistic [index] := 0;
    FOREND;

    hp := #LOC (xhp^);
    IF hp^.id <> c$heap_id THEN
      heap_map.status := osc$heap_pointer_invalid;
      RETURN; {----->
    IFEND;

{ Set the serialization lock on the heap.
    IF hp^.algorithm.value > 0 THEN
      i#disable_traps (old_te);
    IFEND;

    IF hp^.lock_option THEN
      IF #RING (hp) = 1 THEN
        osp$set_mainframe_sig_lock (hp^.lock);
      ELSE
        osp$set_job_signature_lock (hp^.lock);
      IFEND;
    IFEND;

    heap_map.allocate_call_count := hp^.allocate_call_count;
    heap_map.free_call_count := hp^.free_call_count;
    heap_map.algorithm := hp^.algorithm.value;
    heap_map.avoid_small_blocks := hp^.algorithm.avoid_small_block;
{   heap_map.small_block_ceiling := hp^.small_block_ceiling;
    heap_map.small_block_ceiling := 0; {not yet implemented
    heap_map.min_fragment_size := hp^.min_fragment_size;
    heap_map.min_allocation_size := hp^.min_allocation_size;
    heap_map.chain_search_count := hp^.chain_search_count;
    p$generate_heap_map (hp, heap_map);

{ Clear the serialization lock on the heap.
    IF hp^.lock_option THEN
      IF #RING (hp) = 1 THEN
        osp$clear_mainframe_sig_lock (hp^.lock);
      ELSE
        osp$clear_job_signature_lock (hp^.lock);
      IFEND;
    IFEND;

    IF hp^.algorithm.value > 0 THEN
      i#restore_traps (old_te);
    IFEND;

  PROCEND osp$generate_heap_map;
?? OLDTITLE ??
?? NEWTITLE := '[xdcl, #gate] OSP$PREVALIDATE_FREE', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$prevalidate_free
    (    offset: ost$halfword;
         xhp: ^ost$heap;
     VAR result: ost$prevalidate_free_result);

    VAR
      enable_heap_trace: boolean,
      heap_locked: boolean,
      hp: ^ost$hp_heap,
      i: integer,
      inext: integer,
      iprev: integer,
      ok: boolean,
      old_te: 0 .. 3,
      traps_disabled: boolean;

    hp := #LOC (xhp^);
    heap_locked := FALSE;
    traps_disabled := FALSE;

    result := osc$heap_free_valid;

  /prevalidate_free/
    BEGIN

{ Return OSC$HEAP_POINTER_INVALID if the heap has an invalid heap id.

      IF hp^.id <> c$heap_id THEN
        result := osc$heap_pointer_invalid;
        EXIT /prevalidate_free/; {----->
      IFEND;

{ Generate the index of the block being freed.

      i := (offset - (#SIZE (hp^) - #SIZE (hp^.sd))) DIV 16;

{ Return OSC$HEAP_ALLOCATION_ID_INVALID if the block has an invalid allocation id.

      enable_heap_trace := syv$enable_heap_trace AND (hp^.algorithm.value = c$os_heap_algorithm);
      IF ((NOT enable_heap_trace) AND (hp^.sd [i].c$allocation_id <> c$allocation_id)) OR
            (enable_heap_trace AND (hp^.sd [i].c$trace_allocation_id <> c$trace_allocation_id)) THEN
        result := osc$heap_allocation_id_invalid;
        EXIT /prevalidate_free/; {----->
      IFEND;

{ Set the serialization lock on the heap.

      IF hp^.algorithm.value > 0 THEN
        i#disable_traps (old_te);
        traps_disabled := TRUE;
      IFEND;
      IF hp^.lock_option THEN
        IF #RING (hp) = 1 THEN
          osp$set_mainframe_sig_lock (hp^.lock);
        ELSE
          osp$set_job_signature_lock (hp^.lock);
        IFEND;
        heap_locked := TRUE;
      IFEND;

{ Return OSC$HEAP_VERIFICATION_FAILURE if verification of heap linkage fails.

      IF syv$verify_heap_linkage THEN
        p$check_heap (hp, ok);
        IF NOT ok THEN
          result := osc$heap_verification_failure;
          EXIT /prevalidate_free/; {----->
        IFEND;
      IFEND;

{ Return OSC$HEAP_LINKAGE_INVALID if the linkage of the block is bad.

      iprev := hp^.sd [i].link;
      inext := i + hp^.sd [i].length;
      IF (iprev <> 0) AND ((hp^.sd [iprev].length + iprev) <> i) OR
            (inext <> hp^.sd [0].bkw) AND (hp^.sd [inext].link <> i) THEN
        result := osc$heap_linkage_invalid;
        EXIT /prevalidate_free/; {----->
      IFEND;

    END /prevalidate_free/;

{ Clear the serialization lock on the heap.

    IF heap_locked THEN
      IF #RING (hp) = 1 THEN
        osp$clear_mainframe_sig_lock (hp^.lock);
      ELSE
        osp$clear_job_signature_lock (hp^.lock);
      IFEND;
    IFEND;

    IF traps_disabled THEN
      IF hp^.algorithm.value > 0 THEN
        i#restore_traps (old_te);
      IFEND;
    IFEND;

  PROCEND osp$prevalidate_free;
?? OLDTITLE ??
?? NEWTITLE := '[xdcl, #gate] OSP$RESET_HEAP', EJECT ??
*copy osh$reset_heap

  PROCEDURE [XDCL, #GATE] osp$reset_heap
    (    xhp: ^ost$heap;
         heap_length: integer;
         lock_option: boolean;
         algorithm: 0 .. 255);

    VAR
      hp: ^ost$hp_heap,
      i: integer,
      p: ptr_variant,
      status: ost$status;

    hp := #LOC (xhp^);


{ Verify heap starts on a 0 MOD 32 byte boundary.

    p.ptr := hp;
    IF (p.bytenum MOD 32) <> 0 THEN
      osp$system_error ('HEAPMGR - heap start not 0 mod 32', NIL);
    IFEND;
    IF (algorithm < c$min_algorithm) OR (algorithm > c$max_algorithm) THEN
      osp$system_error ('HEAPMGR - unsupported algorithm', NIL);
    IFEND;

{ Initialize the control information at the beginning of the heap.

    hp^.id := c$heap_id;
    osp$initialize_sig_lock (hp^.lock);
    hp^.algorithm.avoid_small_block := FALSE;
    hp^.algorithm.value := algorithm;
    hp^.lock_option := lock_option;
    hp^.small_block_ceiling := 0;
    hp^.min_fragment_size := c$min_fragment_size;
    hp^.min_allocation_size := c$min_allocation_size;

    hp^.allocate_call_count := 0;
    hp^.free_call_count := 0;
    hp^.chain_search_count := 0;

    hp^.sd [0].fwd := 1;
    hp^.sd [0].bkw := 1;
    hp^.sd [0].length := 0;
    hp^.sd [0].link := 0;
    hp^.sd [1].fwd := 0;
    hp^.sd [1].bkw := 0;
    hp^.sd [1].link := 0;
    i := heap_length - (#SIZE (hp^) - #SIZE (hp^.sd) + #SIZE (ost$hp_heap_space_desc));
    hp^.sd [1].length := (i - i MOD 32) DIV 16 - 1; {leave 1 entry at end}
    hp^.desc_per_page := osv$page_size DIV 16;
    hp^.base := (p.bytenum MOD osv$page_size) DIV 16 + (#SIZE (hp^) - #SIZE (hp^.sd) +
          #SIZE (ost$hp_heap_space_desc)) DIV 16;

  PROCEND osp$reset_heap;
?? OLDTITLE ??
?? NEWTITLE := '[xdcl, #gate] OSP$RESET_HEAP_EXT', EJECT ??

  PROCEDURE [XDCL, #GATE] osp$reset_heap_ext
    (    xhp: ^ost$heap;
         heap_length: integer;
         lock_option: boolean;
         algorithm: 0 .. 127;
         small_block_ceiling: ost$halfword;
         min_fragment_size: ost$halfword;
         min_allocation_size: ost$halfword);

    VAR
      hp: ^ost$hp_heap,
      i: integer,
      p: ptr_variant,
      status: ost$status;

    hp := #LOC (xhp^);

{ Verify heap starts on a 0 MOD 32 byte boundary.

    p.ptr := hp;
    IF (p.bytenum MOD 32) <> 0 THEN
      osp$system_error ('HEAPMGR - heap start not 0 mod 32', NIL);
    IFEND;
    IF (algorithm < c$min_algorithm) OR (algorithm > c$max_algorithm) THEN
      osp$system_error ('HEAPMGR - unsupported algorithm', NIL);
    IFEND;

{ Initialize the control information at the beginning of the heap.

    hp^.id := c$heap_id;
    osp$initialize_sig_lock (hp^.lock);
    hp^.algorithm.avoid_small_block := TRUE;
    hp^.algorithm.value := algorithm;
    hp^.lock_option := lock_option;
    hp^.small_block_ceiling := small_block_ceiling;
    hp^.min_fragment_size := min_fragment_size;
    hp^.min_allocation_size := min_allocation_size;

    hp^.allocate_call_count := 0;
    hp^.free_call_count := 0;
    hp^.chain_search_count := 0;

    hp^.sd [0].fwd := 1;
    hp^.sd [0].bkw := 1;
    hp^.sd [0].length := 0;
    hp^.sd [0].link := 0;
    hp^.sd [1].fwd := 0;
    hp^.sd [1].bkw := 0;
    hp^.sd [1].link := 0;
    i := heap_length - (#SIZE (hp^) - #SIZE (hp^.sd) + #SIZE (ost$hp_heap_space_desc));
    hp^.sd [1].length := (i - i MOD 32) DIV 16 - 1; {leave 1 entry at end}
    hp^.desc_per_page := osv$page_size DIV 16;
    hp^.base := (p.bytenum MOD osv$page_size) DIV 16 + (#SIZE (hp^) - #SIZE (hp^.sd) +
          #SIZE (ost$hp_heap_space_desc)) DIV 16;

  PROCEND osp$reset_heap_ext;
?? OLDTITLE ??
?? NEWTITLE := '[xdcl, #gate] OSP$VERIFY_HEAP', EJECT ??
*copy osh$verify_heap

  PROCEDURE [XDCL, #GATE] osp$verify_heap
    (    xhp: ^ost$heap;
     VAR ok: boolean);

    VAR
      hp: ^ost$hp_heap,
      old_te: 0 .. 3;

{ Check heap id.  Abort if id is incorrect.  An incorrect id is caused by the user corrupting the heap
{ pointer, passing an incorrect pointer, or failing to reset the heap.

    hp := #LOC (xhp^);
    IF hp^.id <> c$heap_id THEN
      ok := FALSE;
      RETURN; {----->
    IFEND;

{ Set the serialization lock on the heap.
    IF hp^.algorithm.value > 0 THEN
      i#disable_traps (old_te);
    IFEND;

    IF hp^.lock_option THEN
      IF #RING (hp) = 1 THEN
        osp$set_mainframe_sig_lock (hp^.lock);
      ELSE
        osp$set_job_signature_lock (hp^.lock);
      IFEND;
    IFEND;

    p$check_heap (hp, ok);

{ Clear the serialization lock on the heap.
    IF hp^.lock_option THEN
      IF #RING (hp) = 1 THEN
        osp$clear_mainframe_sig_lock (hp^.lock);
      ELSE
        osp$clear_job_signature_lock (hp^.lock);
      IFEND;
    IFEND;

    IF hp^.algorithm.value > 0 THEN
      i#restore_traps (old_te);
    IFEND;

  PROCEND osp$verify_heap;
?? OLDTITLE ??
MODEND osm$heap_manager;
