Google
 

Trailing-Edge - PDP-10 Archives - BB-X117B-SB_1986 - 10,7/nml/nmumem.bli
There are 3 other files named nmumem.bli in the archive. Click here to see a list.
! UPD ID= 233, SNARK:<6.1.NML>NMUMEM.BLI.5,  17-Jan-85 14:33:18 by GLINDELL
!  Replace PROGRAM_ERROR with TASK_ERROR
!
! UPD ID= 194, SNARK:<6.1.NML>NMUMEM.BLI.4,  10-Dec-84 14:54:58 by HALPIN
! Get MONSYM Library file out of default directory, not BLI:
!
! UPD ID= 99, SLICE:<6.1.NML>NMUMEM.BLI.3,  18-Sep-84 15:26:29 by GUNN
! WORK:<GUNN.NML>NMUMEM.BLI.2 21-Aug-84 10:03:18, Edit by GUNN
!
! Change to accomodate new LIBRARY conventions. MONSYM.L36 and JLNKG.L36
! are now explicity declared here rather than in NMULIB.
!
! UPD ID= 32, SNARK:<6.1.NML>NMUMEM.BLI.2,  24-May-84 16:16:21 by GLINDELL
! DSKC:NMUMEM.BLI[10,5665,SOURCE,TOPS10] 20-Oct-83 23:07:05, Edit by GROSSMAN
!
! Move SIZE and BUDDY tables into the hiseg.
! Edit=43
!
! <BRANDT.DEVELOPMENT>NMUMEM.BLI.1 2-Sep-82 11:41:23, Edit by BRANDT
!
!  Ident 18.
!   Change TASK_ERRORS in MEMORY_GET to PROGRAM_ERRORS so NML dies
!   rather than trying to limp along.  This change is useful for the
!   MCB environment where a sick NML is difficult to detect.
!
! NET:<BRANDT.DEVELOPMENT>NMUMEM.BLI.1 21-Jun-82 13:14:32, Edit by BRANDT
!
!  Ident 17.
!   Change "terminator" so that it is an "addressable unit"
!
! NET:<BRANDT.DEVELOPMENT>NMUMEM.BLI.1 9-Jun-82 16:12:32, Edit by BRANDT
!
!  Ident 16.
!   1)  Add a new field MB_LIMIT to the MEMORY_BLOCK.  This field
!       contains the address of the unit beyond the last unit requested
!       by the user.  This "terminator" is initialized to a special
!       value in MEMORY_GET and verified in MEMORY_RELEASE.
!   2)  Add information to error message that reports an inconsistency
!       in the memory database during MEMORY_RELEASE.
!       This is now a fatal program error.
!
! NET:<BRANDT.DEVELOPMENT>NMUMEM.BLI.1 9-Jun-82 10:21:38, Edit by BRANDT
!
!  Ident 15.
!   Interlock critical regions from interrupts since these routines
!   can be called at interrupt level, and it is possible that the memory
!   database is being modified when the interrupt occurs.  When the
!   database is being modified, the semaphore for the memory list will
!   be locked (not -1).  No processing can take place on a memory list
!   until its semaphore is unlocked.  If the interrupt routine needs
!   that particular memory list, we loop forever waiting for the unlock.
!
! NET:<PECKHAM.DEVELOPMENT>NMUMEM.BLI.8 17-Feb-82 17:06:38, Edit by PECKHAM
!
! Ident 14.
! Fix ambitious memory clear in MEMORY_GET.
! Add globals to own variables for MCBDA access.
!
! NET:<PECKHAM.DEVELOPMENT>NMUMEM.BLI.3 17-Feb-82 11:02:11, Edit by PECKHAM
!
! Ident 13.
! Change reference from MEMTOP back to MEMSIZE.
!
! NET:<PECKHAM.DEVELOPMENT>NMUMEM.BLI.7 17-Feb-82 09:20:05, Edit by PECKHAM
!
! Ident 12.
! Add MB_* variables to data structure.
! Optimize header data structure.
! Make sure all address comparisons use address comparison operators.
! Save task name and allocation length on MEMORY_GET and
! verify release length on MEMORY_RELEASE.
! Change MEMSIZE reference to MEMTOP.
!
! NET:<PECKHAM.DEVELOPMENT>NMUMEM.BLI.2  5-Feb-82 09:02:03, Edit by GROSSMAN
!								for PECKHAM
! Ident 11.
! Add code to NMU$MEMORY_GET to complain when memory cannot be gotten. This
! is to help us find TASKs that blindly expect memory_get to always work.
!
! NET:<PECKHAM.DEVELOPMENT>NMUMEM.BLI.2  4-Feb-82 08:44:00, Edit by PECKHAM
!
! Ident 10.
! Fix loop limit in NMU$MEMORY_RESET to use INDEX_LIMIT instead of SIZEINDEX.
!
! NET:<GROSSMAN>NMUMEM.BLI.2  3-Dec-81 03:30:34, Edit by GROSSMAN
!
! Put a $TOPS10 conditional around the UNDECLARE of POINTR in order to
! prevent a nasty message from being printed out while doing TOPS20
! compilations.
!
! 14-Nov-81 19:43:45, Edit by GROSSMAN
!
! Make changes so that this module compiles correctly under Tops-10.
! Undefine the macro POINTR which gets defined in TENDEF.R36, and remove
! the COMMON bliss attribute in the MODULE statement. This module is not
! common bliss under Tops-10 becase the CORE_GET macro includes a CORE
! UUO under Tops-10.
!
! NET:<DECNET20-V3P1.NMU>NMUMEM.BLI.15 30-Apr-81 14:58:17, Edit by GUNN
!
! Fix bug in BUDDY_ADDRESS routine. Buddy index for a right self block
! was being calculated incorrectly.
!
! NET:<DECNET20-V3P1.NMU>NMUMEM.BLI.14 30-Apr-81 12:05:22, Edit by GUNN
!
! Change debug output to use both MEMORY_TRACE and MEMORY_CONSISTENCY.
!
! NET:<DECNET20-V3P1.NMU>NMUMEM.BLI.6 27-Apr-81 17:04:48, Edit by GUNN
!
! Add debug output for buddy calculations and pairings.
!
! NET:<DECNET20-V3P1.NMU>NMUMEM.BLI.5 27-Apr-81 11:09:39, Edit by GUNN
!
! Check to make sure block being released is actually allocated.
! Check status of queue extraction of buddy when releasing a block
! to ensure against internal corruption of free list.
!
! NET:<DECNET20-V3P1.NMU>NMUMEM.BLI.4 24-Apr-81 14:33:17, Edit by GUNN
!
! Set TAG to AVAILABLE in block being released when there is no buddy.
!
! Debugging extensions to memory block header caused polynomial to become
! invalidated; comment out the extra fields for now.
!
! Update copyright date to 1981.
!
! NET:<DECNET20-V3P1.BASELEVEL-2.SOURCES>NMUMEM.BLI.11 25-Mar-81 11:14:21, Edit by SROBINSON
!    Make incr be unsigned for zeroing memory
! <DECNET20-V3P1.BASELEVEL-2.MCB>NMUMEM.BLI.2 16-Mar-81 11:08:25, Edit by SROBINSON
!    Ensure Address Comparisons are Unsigned
! NET:<DECNET20-V3P1.NMU>NMUMEM.BLI.2 10-Mar-81 10:54:24, Edit by JENNESS
!    Add code to improve debuggability and robustness in development.
! NET:<DECNET20-V3P1.NMU>NMUMEM.BLI.3  3-Feb-81 10:10:08, Edit by JENNESS
!    Move memory block definition back into this module for ease of reading.
module NMUMEM (					!Storage Management Module
		ident = 'X00.18'
		) =
begin
!
! COPYRIGHT (C) 1980, 1981
! DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASSACHUSETTS  01754
!
! THIS SOFTWARE IS FURNISHED  UNDER A LICENSE FOR USE ONLY ON A SINGLE
! COMPUTER  SYSTEM AND  MAY BE  COPIED ONLY WITH  THE INCLUSION OF THE
! ABOVE COPYRIGHT NOTICE.  THIS SOFTWARE, OR ANY OTHER COPIES  THEREOF
! MAY NOT BE PROVIDED OR  OTHERWISE MADE AVAILABLE TO ANY OTHER PERSON
! EXCEPT FOR USE ON SUCH SYSTEM AND TO ONE WHO AGREES TO THESE LICENSE
! TERMS.  TITLE TO AND  OWNERSHIP OF THE  SOFTWARE  SHALL AT ALL TIMES
! REMAIN IN DEC.
!
! THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE
! AND SHOULD  NOT BE CONSTRUED  AS A COMMITMENT  BY DIGITAL  EQUIPMENT
! CORPORATION.
!
! DEC ASSUMES  NO  RESPONSIBILITY  FOR  THE USE OR  RELIABILITY OF ITS
! SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DEC.
!

!++
! Facility: LSG DECnet Network Management
!
! Abstract:
!
!	This module offers the storage management functions used for
!	dynamic memory allocation. The alogrithm employed is based upon
!	the article "Buddy Systems" by James L. Peterson and Theodore
!	A. Norman published in Communications of the ACM Volume 20,
!	Number 6 - June 1977.
!
! Environment:	TOPS10 and TOPS20 user mode, MCB RSX task mode
!
! Author: Scott G. Robinson, Creation date: 13-DEC-78
!
! Modified by:
!
!	Scott G. Robinson, 15-JUL-79 : Version X00.01
!	- Convert to XPORT interfaces and make transportable.
!	Steven M. Jenness, 21-Feb-80 : Version X00.02
!       - Change to conform to NM coding standards and needs.
!
!--
!<BLF/PAGE>
!
! Include files
!

library 'NMULIB';			! All required definitions

%if $TOPS20
    %then
	library 'MONSYM';			! Monitor symbols

	library 'JLNKG';			! JSYS linkage definitions
    %fi

!
! Undefine TENDEFs POINTR macro
!

%if $TOPS10 %then
undeclare %quote POINTR;
%fi

!
! Global routines
!

forward routine
    NMU$MEMORY_MANAGER;				! Define global entry points

!
! Local routines
!

forward routine
    BUDDY_ADDRESS;				! Calculate buddy address of memory block

!
! Memory block format
!
! macro:   MEMORY_BLOCK     Defines header for memory block
!

%if not $MCB
%then macro $index = $tiny_integer %;
%else macro $index = $short_integer %;
%fi

$field
    MEMORY_BLOCK_FIELDS =
	set
	QUEUE_INFO = [$sub_block (Q_HEADER_SIZE)],	! Storage list queue linkages
	INDEX = [$index],			! The SIZEINDEX for this block
	TAG = [$bit],				! Indicates ALLOCATED or AVAILABLE
	SELF = [$bit],				! Indicates LEFT or RIGHT Buddy
	PARENT = [$bit],			! Indicates LEFT or RIGHT of The Parent
	  $align (FULLWORD)
	MB_TASK = [$address],			! Address of allocating task
	MB_LIMIT = [$address],			! Address of last unit of memory block
	MB_ALLOCATION = [$short_integer],	! Number of addressable units
	  $align (FULLWORD)
	DATA = [$sub_block (0)]			! Start of useable data portion
	tes;

literal
    MB_LENGTH = $field_set_size,
    ALLOC_OVERHEAD = $field_set_units + 1;	! The length of the block header
						!  plus the terminator

macro
    MEMORY_BLOCK = BLOCK [MB_LENGTH] FIELD (MEMORY_BLOCK_FIELDS)%;

literal
    TERMINATOR = 				! Value for limit word
    %if $MCB					!  of memory block
    %then
	%O'125';				! 8 bit value for MCB
    %else
	%O'252525252525';			! 36 bit value for KL
    %fi

literal
    AVAILABLE = 0,				! Values for TAG field
    ALLOCATED = 1;

literal
    LEFT = 0,					! Values for SELF and PARENT
    RIGHT = 1;

!

literal
    SIZEINDEX = 29,				! Number of Buddy Slots
    INDEX_LIMIT = SIZEINDEX - 1;		! Number of elements to search

!
! Own storage
!

macro
    SIZE_INIT =
     0,0,4,4,4,8,12,16,24,36,52,76,112,164,240,352,
     516,756,1108,1624,2380,3488,5112,7492,10980,16092,
     23584,34564,50656 %,

    BUDDY_INDEX_INIT =
     0,0,0,0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,
     18,19,20,21,22,23,24,25 %;

$field
    ASL_FIELD =
	set
	ASL_QUEUE = [$sub_block (Q_HEADER_SIZE)]
	tes;

$literal
    ASL_FIELD_SIZE = $field_set_size;

own
    SIZE : vector [SIZEINDEX] INITIAL (SIZE_INIT) psect($high$),
    BUDDY_INDEX : vector [SIZEINDEX] INITIAL (BUDDY_INDEX_INIT) psect($high$),
    ASL_LST : blockvector [SIZEINDEX, ASL_FIELD_SIZE] field (ASL_FIELD);

global bind
    BLKSIZ = SIZE,
    BLKBDY = BUDDY_INDEX,
    BLKLST = ASL_LST;

!
! External references
!

external routine
    NMU$QUEUE_MANAGER;				! Queue management routines

!
! Definitions used when debugging
!

external
    %debug_data_base;

    %module_name ('NMUMEM');

!<BLF/SYNONYM %UNQUOTE =>

%global_routine ('NMU$MEMORY_RESET') : novalue =

!++
! Functional description:
!
!	This routine resets the free pool data base to empty.
!
! Formal parameters: none
!
! Routine value: none
! Side effects:
!
!	All queues on the ASL_LST are cleared.
!
!--

    begin

    local
	ASL : ref block field (ASL_FIELD);

%debug (MEMORY_CONSISTENCY,
	(TRACE_INFO ('Available storage list reset')));

    ASL = ASL_LST [0, ASL_QUEUE];

    INTERRUPT_OFF;			! Disable interrupts

    decru COUNT from SIZEINDEX to 1 do
	begin
	NMU$QUEUE_RESET (ASL [ASL_QUEUE]);
	ASL = vector [ASL [ASL_QUEUE], ASL_FIELD_SIZE];
	end;

    INTERRUPT_ON;			! Allow interrupts now

    end;				! End of NMU$MEMORY_RESET

%global_routine ('NMU$MEMORY_INITIALIZE', AMOUNT) : novalue =

!++
! Functional description
!
!	Add the specified amount of memory to the free pool
!	of the storage manager.
!
! Formal parameters
!
!	AMOUNT - the initial amount of storage to allocate
!
! Implicit inputs
!
!	SIZE - the block size array
!	ASL - the Available storage list
!
! Implicit outputs
!
!	ASL - the Available storage list
!
! Routine value: none
!
! Side effects: none
!
!--

    begin

    local
	P : ref MEMORY_BLOCK,			! Allocated block
	I;					! Size index for "P"

    %debug (MEMORY_CONSISTENCY,
            (TRACE_INFO ('Initializing %D. (%O) units in free pool', .AMOUNT, .AMOUNT)));

!
! Find size index for AMOUNT
!
    I = -1;

    incr POINTR from 1 to INDEX_LIMIT do

	if ((.AMOUNT + ALLOC_OVERHEAD) lequ .SIZE [.POINTR])
	then
	    begin
	    I = .POINTR;
	    exitloop;
	    end;

    if (.I lss 0)
    then
	begin
	TASK_ERROR ('Memory block too large to initialize');
	return ;
	end;

!
! Now allocate the block
!
    if (P = CORE_GET (.SIZE [.I])) eqla 0
    then
	begin
	TASK_ERROR ('Operating system refused memory request');
	return ;
	end;
    
    P [INDEX] = .I;
    P [TAG] = AVAILABLE;
    P [SELF] = LEFT;
    P [PARENT] = LEFT;
!  %debug (always,(
!    begin
!    P [MB_ALLOCATION] = .SIZE [.I];
!    P [MB_TASK] = 0;
!    end));

  %debug (MEMORY_CONSISTENCY,
          (TRACE_INFO_C ('Adding %D. (%O) units at %O to free pool',
                         .SIZE [.I], .SIZE [.I], .P)));

    INTERRUPT_OFF;
    NMU$QUEUE_INSERT (ASL_LST [.I, ASL_QUEUE], .P);
    INTERRUPT_ON;
    end;					! End of NMU$MEMORY_INITIALIZE

forward routine MEMORY_GET;

%global_routine ('NMU$MEMORY_GET', AMOUNT) =

begin
    local VALUE;

    INTERRUPT_OFF;
    VALUE = MEMORY_GET(.AMOUNT);
    INTERRUPT_ON;
    .VALUE
end;

%routine ('MEMORY_GET', AMOUNT) =

!++
! Functional description
!
!	Get a block of storage from dynamic memory.
!	Return its address.
!
! Formal parameters
!
!	AMOUNT - Number of words to allocate
!
! Implicit inputs
!
!	ASL - Available Storage List
!	Dynamic Memory
!
! Implicit outputs
!
!	ASL - Available Storage List
!
! Routine value
!
!	The address of the storage block or 0 if no memory available
!
! Side effects: none
!
!--

    begin

    local
	P : ref MEMORY_BLOCK,			! Allocated block
	Q : ref MEMORY_BLOCK,			! Buddy to allocated block
	I,					! Exact index for "AMOUNT"
	J;					! Index actually used from ASL

%debug (MEMORY_TRACE,
	(TRACE_INFO ('Request for %D. units', .AMOUNT)));

!
! Start off with no block allocated
!
    P = 0;
!
! Calculate index for block of size AMOUNT
!
    I = -1;

    incr POINTR from 1 to INDEX_LIMIT do

	if ((.AMOUNT + ALLOC_OVERHEAD) lequ .SIZE [.POINTR])
	then
	    begin
	    I = .POINTR;
	    exitloop;
	    end;

    if (.I lss 0)
    then
	begin
	TASK_ERROR ('Size of Memory Block Requested is too large');
	return 0
	end;

!
! Find first non-empty ASL entry, starting with
! entry pointed to by I (exact index).
!

    INTERRUPT_OFF;				! Lock out interrupts

    incr TEST_INDEX from .I to INDEX_LIMIT do

	if (P = NMU$QUEUE_REMOVE (ASL_LST [.TEST_INDEX, ASL_QUEUE])) neq 0
	then
	    begin
	    J = .TEST_INDEX;
	    exitloop;
	    end;

!
! If no memory already available .. try to initialize
! the appropriate amount from the operating system.
!

    if .P eqla 0
    then
	begin
	NMU$MEMORY_INITIALIZE (.AMOUNT);
	P = NMU$QUEUE_REMOVE (ASL_LST [.I, ASL_QUEUE]);
	J = .I;
	end;

!
! Allocate memory and (optionally) split off buddy
!

    while (.J gtr .I) do
	begin

	if (.SIZE [.BUDDY_INDEX [.J]] neq 0)
	then
	    begin
	    Q = .P + .SIZE [.BUDDY_INDEX [.J]];
	    Q [TAG] = AVAILABLE;
	    Q [PARENT] = .P [PARENT];
	    Q [SELF] = RIGHT;
	    Q [INDEX] = .J - 1;
	    P [TAG] = AVAILABLE;
	    P [PARENT] = .P [SELF];
	    P [SELF] = LEFT;
	    P [INDEX] = .BUDDY_INDEX [.J];

%debug (MEMORY_CONSISTENCY,
	(begin
	 TRACE_INFO_C (' Block at %O Index %O Self= ',.P,.P[INDEX]) ;

         if .P [SELF] eql LEFT
         then TRACE_INFO_CL ('LEFT ')
         else TRACE_INFO_CL ('RIGHT ') ;

         if .P [PARENT] eql LEFT
         then TRACE_INFO_CL ('Parent=LEFT split with')
         else TRACE_INFO_CL ('Parent=RIGHT split with') ;

	 TRACE_INFO_C (' buddy at %O Index %O Self=',.Q,.Q[INDEX]) ;

         if .Q [SELF] eql LEFT
         then TRACE_INFO_CL ('LEFT ')
         else TRACE_INFO_CL ('RIGHT ') ;

         if .Q [PARENT] eql LEFT
         then TRACE_INFO_CL ('Parent=LEFT')
         else TRACE_INFO_CL ('Parent=RIGHT') ;

         end));

	    if (.I leq .BUDDY_INDEX [.J])
	    then
		NMU$QUEUE_INSERT (ASL_LST [.Q [INDEX], ASL_QUEUE], .Q)
	    else
		begin
		NMU$QUEUE_INSERT (ASL_LST [.P [INDEX], ASL_QUEUE], .P);
		P = .Q;
		end;

	    J = .P [INDEX];
	    end
	else
	    exitloop;

	end;

    INTERRUPT_ON;				! Allow interrupts again

    P [TAG] = ALLOCATED;
!
! Return 0 if no memory allocated.
! Return address of zeroed data portion of allocated
!  block if allocation was successful.
!
    %debug (MEMORY_TRACE,
	    (if (.P eqla 0)
	     then TRACE_INFO_C ('Allocation failure')
	     else TRACE_INFO_C ('Allocated %D. units at %O',
                              .SIZE [.P[INDEX]], P [DATA])));

    (if (.P eqla 0) then
	begin
	    TASK_ERROR ('Memory request failed');
	    0
	end
	 else
	begin
	local
	    A : ref block,
	    CNT;

	CNT = .AMOUNT;
	P [MB_TASK] = CURRENT_TASK;
	P [MB_ALLOCATION] = .CNT;
	P [MB_LIMIT] = P [DATA] + .CNT;		! Address of terminator
	P = P [DATA];
	A = .P;

	do (A [0, 0, %bpunit, 0] = 0; A = .A + 1) while (CNT = .CNT - 1) neq 0;

	A [0, 0, %bpunit, 0] = TERMINATOR;	! Mark end of block
	.P
	end
    )
    end;					!End of NMU$MEMORY_GET

forward routine MEMORY_RELEASE : novalue;

%global_routine ('NMU$MEMORY_RELEASE', P, AMOUNT) : novalue =

begin
    INTERRUPT_OFF;
    MEMORY_RELEASE (.P, .AMOUNT);
    INTERRUPT_ON
end;

%routine ('MEMORY_RELEASE', P, AMOUNT) : novalue =

!++
! Functional description
!
!	Returns a block of memory to the ASL.
!
! Formal parameters
!
!	P - address of memory block to return
!	AMOUNT - Size of memory block
!
! Implicit inputs
!
!	ASL - the Available Storage List
!
! Implicit outputs
!
!	ASL - the Available Storage List
!
! Routine value: none
! Side effects:	none
!
!--

    begin

    map
	P : ref MEMORY_BLOCK;

    local
	Q : ref MEMORY_BLOCK,
	R,
	T : ref MEMORY_BLOCK;

    %debug (MEMORY_TRACE,
 	    (TRACE_INFO ('Releasing %D. units at %O',
                         .AMOUNT,.P)));

!
! Remove Allocation Overhead amount to obtain real MEMORY_BLOCK address
!
    T = .P - (ALLOC_OVERHEAD - 1);

!
! Check to make sure block is actually allocated and not corrupted.
!

    if (.T [TAG] neq ALLOCATED) or
       (.T [MB_ALLOCATION] nequ .AMOUNT) or
       (.T [MB_LIMIT] neqa (T [DATA] + .T [MB_ALLOCATION])) or
       (.(.T [MB_LIMIT])<0,%bpunit,0> neq TERMINATOR)
    then
	begin
	%if not $MCB
	%then
	TRACE_INFO ('Error detected while releasing %D. units of memory',
			.AMOUNT);
	TRACE_INFO_C ('Block begins at %O; header starts at %O',
			T [DATA],
			.T);
	TRACE_INFO_C ('Header shows %D. units',
			.T [MB_ALLOCATION]);
	TRACE_INFO_C ('Allocation flag is %O (1=allocated, 0=available)',
			.T [TAG]);
	TRACE_INFO_C ('Header shows units were allocated by task at %O',
			.T [MB_TASK]);
	TRACE_INFO_C ('Header shows limit word:  %O / %O',
			.T [MB_LIMIT],
			..T [MB_LIMIT]);
	TRACE_INFO_C ('Limit word should contain:  %O',
			TERMINATOR);
	%fi
	TASK_ERROR ('Memory database inconsistency');
	return ;
	end;

!
! Tag this block as available now.
!

    T [TAG] = AVAILABLE;

!
! Try to find Buddy and form with it
!
    Q = BUDDY_ADDRESS (.T);

    INTERRUPT_OFF;				! Disable interrupts

    while (.Q neqa 0) do
	begin


%debug (MEMORY_CONSISTENCY,
	(begin

	 TRACE_INFO_C (' Block at %O Index %O Self= ',.T,.T [INDEX]) ;

         if .T [SELF] eql LEFT
         then TRACE_INFO_CL ('LEFT ')
         else TRACE_INFO_CL ('RIGHT ') ;

         if .T [PARENT] eql LEFT
         then TRACE_INFO_CL ('Parent=LEFT merged with')
         else TRACE_INFO_CL ('Parent=RIGHT merged with') ;

         TRACE_INFO_C (' buddy at %O Index %O Self=',.Q,.Q[INDEX]) ;

         if .Q [SELF] eql LEFT
         then TRACE_INFO_CL ('LEFT ')
         else TRACE_INFO_CL ('RIGHT ') ;

         if .Q [PARENT] eql LEFT
         then TRACE_INFO_CL ('Parent=LEFT')
         else TRACE_INFO_CL ('Parent=RIGHT');

         end));
	if not NMU$QUEUE_EXTRACT (ASL_LST [.Q [INDEX], ASL_QUEUE], .Q)
	then
	    begin
	    TASK_ERROR ('Available storage list corrupted');
	    INTERRUPT_ON;			! Interrupts on again
	    return ;
	    end;

	if (.T gtra .Q)
	then
	    begin
	    R = .T;
	    T = .Q;
	    Q = .R
	    end;

	T [TAG] = AVAILABLE;
	T [SELF] = .T [PARENT];
	T [PARENT] = .Q [PARENT];
	T [INDEX] = 1 + .Q [INDEX];
	Q = BUDDY_ADDRESS (.T);
	end;

    NMU$QUEUE_INSERT (ASL_LST [.T [INDEX], ASL_QUEUE], .T);

    INTERRUPT_ON;				! Interrupts on

    end;					! End of NMU$MEMORY_RELEASE

%routine ('BUDDY_ADDRESS', P) =

!++
! Functional description
!
!	Calculate and return address of buddy of Memory block at address P.
!
! Formal parameters
!
!	P - Address of a memory block
!
! Implicit inputs
!
!	SIZE - size of various memory blocks
!	Dynamic Memory
!
! Implicit outputs: none
!
! Routine value:
!
!	The address of the buddy to P or 0 if none
!
! Side effects: none
!
!--

    begin

    map
	P : ref MEMORY_BLOCK;			! Designated block

    local
	Q : ref MEMORY_BLOCK,			! Buddy block
	J;					! Size index for buddy

!
! Process according to whether block is a LEFT
! or RIGHT buddy.
!

    if (.P [SELF] eql LEFT)
    then
	begin
	Q = .P + .SIZE [.P [INDEX]];

	if ((.Q geqa .MEMSIZE) or (.Q [SELF] eql LEFT)) then return 0;

	end
    else
	begin
	J = .BUDDY_INDEX [.P [INDEX] + 1];
	Q = .P - .SIZE [.J];

	if (.Q [INDEX] neq .J) then return 0;

	end;

    if (.Q [TAG] eql ALLOCATED) then return 0;

    .Q
    end;					! End of BUDDY_ADDRESS
end						! End of module MEMORY

eludom
! Local Modes:
! Mode:Fundamental
! Comment Start:! 
! Comment Column:40
! Comment Rounding:+1
! Auto Save Mode:2
! End: