<<>>
    <<AllocImpl.mesa>>
        <<Copyright Ó 1985, 1986, 1987, 1988, 1989, 1991 by Xerox Corporation.  All rights reserved.>>
        <<Sweet, 19-Aug-81 12:15:12>>
        <<Satterthwaite, June 10, 1986 3:02:12 pm PDT>>
    <<Russ Atkinson (RRA) July 11, 1989 2:06:34 pm PDT>>
        <<JKF October 13, 1988 12:34:28 pm PDT>>
        <<>>
        DIRECTORY
            Alloc USING [addrSpan, Base, BaseSeq, Index, Notifier, OrderedIndex, Selector, TableInfo],
            MimZones USING [permZone],
            OSMiscOps USING [Copy, Fill],
            VM USING [AddressForPageNumber, Free, Interval, PagesForWords, PageNumberForAddress, SimpleAllocate, WordsForPages];
AllocImpl: MONITOR LOCKS h.LOCK USING h: Handle
    IMPORTS MimZones, OSMiscOps, VM 
    EXPORTS Alloc = { OPEN Alloc;

    <<types>>

        Handle: TYPE = REF InstanceData;

        InstanceData: PUBLIC TYPE = MONITORED RECORD [
            notifiers: NotifyChainHandle Ź NIL,
            bases: REF BaseSeq,        -- tag codes subtracted
            offsets: REF OffsetSeq,        -- (shifted) tag codes
            vm: REF SpaceSeq,
            chunks: REF ChunkSeq,
            top: REF SizeSeq,        -- tag codes added
            limit: REF BoundSeq,        -- tag codes added
            vmPages: REF SizeSeq,
            maxPages: REF PageSeq,
            nTables: NAT];

        OffsetSeq: TYPE = RECORD [SEQUENCE length: NAT OF CARD];
        SizeSeq: TYPE = RECORD [SEQUENCE length: NAT OF CARD];
        Bound: TYPE = CARD;
        BoundSeq: TYPE = RECORD [SEQUENCE length: NAT OF Bound];
        PageCount: TYPE = CARD;
        PageSeq: TYPE = RECORD [SEQUENCE length: NAT OF PageCount];
        SpaceSeq: TYPE = RECORD [SEQUENCE length: NAT OF LocalInterval];
        ChunkSeq: TYPE = RECORD [SEQUENCE length: NAT OF ChunkHandle];

        unitsPerWord: NAT = WORD.SIZE;

        clearObjects: BOOL = TRUE;

    <<signals>>

        Failure: PUBLIC ERROR [h: Handle, table: Selector] = CODE;
        Overflow: PUBLIC SIGNAL [h: Handle, table: Selector] RETURNS [extra: CARD] = CODE;

    <<VM utilities>>

        wordsPerPage: NAT = 256;
        unitsPerPage: NAT = wordsPerPage*unitsPerWord;
            <<Don't use the VM page size since that can cause funny swings in the amount allocated.>>
            <<>>
        LocalInterval: TYPE = RECORD [base: LONG POINTER Ź NIL, units: CARD Ź 0];

        UnitsForPages: PROC [pages: PageCount] RETURNS [CARD] = {
            units: CARD = CARD[pages]*unitsPerPage;
            RETURN [units];
            };

        PagesForUnits: PROC [units: CARD] RETURNS [PageCount] = {
            pages: CARD = CARD[units+unitsPerPage-1]/unitsPerPage;
            RETURN [pages];
            };

        AllocateVM: PROC [units: CARD] RETURNS [LocalInterval] = {
            words: CARD = units/unitsPerWord;
            vmInterval: VM.Interval Ź VM.SimpleAllocate[VM.PagesForWords[words]];
            interval: LocalInterval Ź [
                VM.AddressForPageNumber[vmInterval.page],
                VM.WordsForPages[vmInterval.count]*unitsPerWord];
            RETURN [interval];
            };

        FreeVM: PROC [interval: LocalInterval] = {
            IF interval.units # 0 THEN {
                vmInterval: VM.Interval Ź [
                    VM.PageNumberForAddress[interval.base],
                    VM.PagesForWords[interval.units/unitsPerWord]
                    ];
                VM.Free[vmInterval];
                };
            };

    <<stack allocation from subzones>>

        Units: PUBLIC ENTRY PROC [h: Handle, table: Selector, size: CARDINAL]
        RETURNS [x: OrderedIndex] = {
            ENABLE UNWIND => {};
            RETURN [UnitsInternal[h, table, size ! Failure => {GO TO Fail}]]
            EXITS Fail => {RETURN WITH ERROR Failure[h, table]}
            };

        UnitsInternal: INTERNAL PROC [h: Handle, table: Selector, size: CARDINAL]
        RETURNS [OrderedIndex] = {
            index: CARD = h.top[table];
            newTop: Bound = index + size;
            IF unitsPerWord # 1 AND (size MOD unitsPerWord) # 0 THEN ERROR;
                <<No one should ask to be put on a non-word boundary!>>
            IF newTop > h.limit[table] THEN {
                IF newTop-h.offsets[table] > UnitsForPages[h.maxPages[table]] THEN
                    ERROR Failure[h, table];
                GrowTable[h, table, newTop];
                };
            h.top[table] Ź newTop;
            IF clearObjects THEN {
                ptr: LONG POINTER Ź @h.bases[table][OrderedIndex.FIRST + index];
                OSMiscOps.Fill[ptr, size / unitsPerWord, 0];
                };
            RETURN [OrderedIndex.FIRST + index];
            };

        GrowTable: INTERNAL PROC [h: Handle, table: Selector, newTop: Bound] = {
            newPages: CARD = PagesForUnits[newTop-h.offsets[table]];
            IF newPages > h.vmPages[table] THEN {
                extra: CARD = MAX[newPages/2, 16];
                newVMPages: CARD = MIN[h.maxPages[table], newPages + extra];
                newVM: LocalInterval = AllocateVM[UnitsForPages[newVMPages]];
                oldVM: LocalInterval = h.vm[table];
                IF oldVM # [NIL, 0] THEN {
                    OSMiscOps.Copy[
                    from: oldVM.base, nwords: oldVM.units/unitsPerWord, to: newVM.base];
                    FreeVM[oldVM];
                    };
                h.vm[table] Ź newVM;
                h.bases[table] Ź LOOPHOLE[newVM.base-h.offsets[table]];
                h.limit[table] Ź newVM.units+h.offsets[table];
                h.vmPages[table] Ź newVMPages;
                RunNotifierChain[h];
                };
            };

    <<linked list allocation>>

        Chunk: TYPE = MACHINE DEPENDENT RECORD [
            free: BOOL,
            size: NAT15,
            pad: CARD16 Ź 0,
            fLink: CIndex,
            bLink: CIndex
            ];
            chunkSize: NAT = SIZE[Chunk];

        CIndex: TYPE = Base RELATIVE LONG POINTER TO Chunk;    -- tag codes added

        ChunkHandle: TYPE = REF ChunkObject;
        ChunkObject: TYPE = RECORD [
            chunkRover: CIndex,
            nullChunkIndex: CIndex,
            firstSmall: NAT,
            smallLists: SEQUENCE nSmall: NAT OF CIndex
            ];

        GetChunk: PUBLIC ENTRY PROC
        [h: Handle, size: CARDINAL, table: Selector] RETURNS [Index] = {
            ENABLE UNWIND => {};
            ch: ChunkHandle = h.chunks[table];
            cb: Base = h.bases[table];
            q: CIndex Ź ch.nullChunkIndex;
            IF ch = NIL THEN RETURN WITH ERROR Failure[h, table];
            size Ź MAX[size, chunkSize];
            {
                IF size IN [ch.firstSmall..NAT[ch.firstSmall+ch.nSmall]) THEN { 
                    offset: CARDINAL = size - ch.firstSmall;
                    q Ź ch.smallLists[offset];
                    IF q # ch.nullChunkIndex THEN {ch.smallLists[offset] Ź cb[q].fLink; GO TO old};
                    };
                q Ź GetRoverChunk[cb, h.top[table], ch, size];
                IF q # ch.nullChunkIndex THEN GO TO old;
                {
                    q Ź UnitsInternal[h: h, table: table, size: size ! Failure => GO TO oops];
                    <<A new object which does not need to be cleared.>>
                    EXITS oops => {
                        <<none the right size, no space at the end, and no big ones to split>>
                        FOR s: NAT IN [ch.firstSmall.. ch.firstSmall+ch.nSmall) DO
                            offset: NAT = s - ch.firstSmall;
                            r: CIndex Ź ch.smallLists[offset];
                            WHILE r # ch.nullChunkIndex DO
                                next: CIndex = cb[r].fLink;
                                FreeRoverChunk[cb, ch, r, s];
                                r Ź next;
                                ENDLOOP;
                            ch.smallLists[offset] Ź ch.nullChunkIndex;
                            ENDLOOP;
                        <<now all possible merges of free nodes can happen>>
                        q Ź GetRoverChunk[cb, h.top[table], ch, size];
                        IF q # ch.nullChunkIndex THEN GO TO old;
                        RETURN WITH ERROR Failure[h, table];
                        };
                    };
                EXITS
                    old => IF clearObjects THEN {
                        <<Old object needs to be cleared>>
                        ptr: LONG POINTER Ź @h.bases[table][q];
                        OSMiscOps.Fill[ptr, size / unitsPerWord, 0];
                        };
                };
            IF LOOPHOLE[FALSE, CARDINAL] # 0 OR NOT clearObjects THEN
                <<RRA: just to be silly.  FALSE had better be 0!>>
                h.bases[table][q].free Ź FALSE;
            RETURN [q];
            };

        GetRoverChunk: INTERNAL PROC
        [cb: Base, top: Bound, ch: ChunkHandle, size: CARDINAL] RETURNS [Index] = {
            p, q, next: CIndex;
            nodeSize: INTEGER;
            n: INTEGER;
            {
                IF (p Ź ch.chunkRover) = ch.nullChunkIndex THEN GO TO notFound;
                <<search for a chunk to allocate>>
                DO
                    nodeSize Ź cb[p].size;
                    WHILE CARD[(next Ź p + nodeSize) - CIndex.FIRST] # top AND cb[next].free DO
                        cb[cb[next].bLink].fLink Ź cb[next].fLink;
                        cb[cb[next].fLink].bLink Ź cb[next].bLink;
                        cb[p].size Ź nodeSize Ź nodeSize + cb[next].size;
                        ch.chunkRover Ź p; -- in case next = chunkRover
                        ENDLOOP;
                    SELECT (n Ź nodeSize-size) FROM
                        = 0 => {
                            IF cb[p].fLink = p
                                THEN ch.chunkRover Ź ch.nullChunkIndex
                                ELSE {
                                    ch.chunkRover Ź cb[cb[p].bLink].fLink Ź cb[p].fLink;
                                    cb[cb[p].fLink].bLink Ź cb[p].bLink;
                                    };
                            q Ź p;
                            GO TO found;
                            };
                        >= chunkSize => {
                            cb[p].size Ź n;
                            ch.chunkRover Ź p;
                            q Ź p + n;
                            GO TO found;
                            };
                        ENDCASE;
                    IF (p Ź cb[p].fLink) = ch.chunkRover THEN GO TO notFound;
                    ENDLOOP;
                EXITS
                    found => NULL;
                    notFound => q Ź ch.nullChunkIndex;
                };
            RETURN [q];
            };

        neverFree: BOOL Ź FALSE;
            <<Useful for debugging>>
        FreeChunk: PUBLIC ENTRY PROC [h: Handle, index: Index, size: CARDINAL, table: Selector] = {
            ENABLE UNWIND => {};
            ch: ChunkHandle = h.chunks[table];
            cb: Base = h.bases[table];
            p: CIndex = LOOPHOLE[index];
            IF ch = NIL THEN RETURN WITH ERROR Failure[h, table];
            IF neverFree THEN RETURN;
            cb[p].size Ź size Ź MAX[size, chunkSize];
            IF size IN [ch.firstSmall..NAT[ch.firstSmall+ch.nSmall])
                THEN {
                    offset: NAT = size - ch.firstSmall;
                    cb[p].fLink Ź ch.smallLists[offset];
                    ch.smallLists[offset] Ź p;
                    <<don't set cb[p].free _ TRUE; to avoid coalescing nodes>>
                    cb[p].bLink Ź ch.nullChunkIndex; -- note, only singly linked
                    }
                ELSE FreeRoverChunk[cb, ch, index, size];
            };

        FreeRoverChunk: INTERNAL PROC
        [cb: Base, ch: ChunkHandle, index: Index, size: CARDINAL] = {
            p: CIndex = LOOPHOLE[index];
            cb[p].size Ź size Ź MAX[size, chunkSize];
            IF ch.chunkRover = ch.nullChunkIndex
                THEN
                    ch.chunkRover Ź cb[p].fLink Ź cb[p].bLink Ź p
                ELSE {
                    rover: CIndex = ch.chunkRover;
                    cb[p].fLink Ź cb[rover].fLink;
                    cb[cb[p].fLink].bLink Ź p;
                    cb[p].bLink Ź rover;
                    cb[rover].fLink Ź p};
            cb[p].free Ź TRUE;
            };

    <<queries>>

        Bounds: PUBLIC ENTRY PROC [h: Handle, table: Selector] RETURNS [base: Base, size: CARD] = {
            RETURN [h.bases[table], h.top[table]-h.offsets[table]];
            };

        Top: PUBLIC ENTRY PROC [h: Handle, table: Selector] RETURNS [OrderedIndex] = {
            RETURN [OrderedIndex.FIRST + h.top[table]];
            };

        Bias: PUBLIC ENTRY PROC [h: Handle, table: Selector] RETURNS [CARD] = {
            RETURN [h.offsets[table]];
            };

    <<initialization, expansion and termination>>

        Create: PUBLIC PROC
        [weights: DESCRIPTOR FOR ARRAY OF TableInfo] RETURNS [h: Handle] = {
            cnt: CARDINAL = weights.LENGTH;
            h Ź MimZones.permZone.NEW[InstanceData Ź [
                nTables: cnt,
                notifiers: NIL,
                bases: MimZones.permZone.NEW[BaseSeq[cnt]],
                offsets: MimZones.permZone.NEW[OffsetSeq[cnt]],
                vm: MimZones.permZone.NEW[SpaceSeq[cnt]],
                chunks: MimZones.permZone.NEW[ChunkSeq[cnt]],
                top: MimZones.permZone.NEW[SizeSeq[cnt]],
                limit: MimZones.permZone.NEW[BoundSeq[cnt]],
                vmPages: MimZones.permZone.NEW[SizeSeq[cnt]],
                maxPages: MimZones.permZone.NEW[PageSeq[cnt]]]];
            FOR i: CARDINAL IN [0..cnt) DO InitTable[h, i, weights[i]] ENDLOOP;
            };

        InitTable: PROC [h: Handle, table: Selector, info: TableInfo] = {
            base: Base Ź NIL;
            units: CARD Ź 0;
            interval: LocalInterval Ź h.vm[table];
            iPages: CARD = info.initialPages;
            h.maxPages[table] Ź MIN[CARD[info.maxPages], CARD[PagesForUnits[addrSpan]]];
            IF iPages > h.maxPages[table] THEN ERROR Failure[h, table];
            IF iPages*unitsPerPage > interval.units THEN {
                <<We need to allocate a new interval>>
                h.vm[table] Ź [];
                FreeVM[interval];
                interval Ź AllocateVM[UnitsForPages[iPages]];
                h.vm[table] Ź interval;
                h.vmPages[table] Ź iPages;
                };
            h.offsets[table] Ź info.tag*addrSpan;
            h.top[table] Ź 0 + h.offsets[table];
            h.limit[table] Ź interval.units + h.offsets[table];
            h.bases[table] Ź LOOPHOLE[interval.base - h.offsets[table]];
            h.chunks[table] Ź NIL;
            };

        ResetTable: PUBLIC ENTRY PROC [h: Handle, table: Selector, info: TableInfo] = {
            ENABLE UNWIND => {};
            InitTable[h, table, info];
            RunNotifierChain[h];
            };

        Destroy: PUBLIC ENTRY PROC [h: Handle] = {
            ENABLE UNWIND => {};
            FOR i: NAT IN [0..h.nTables) DO h.bases[i] Ź Base.NIL-h.offsets[i] ENDLOOP;
            RunNotifierChain[h];
            FOR i: NAT IN [0..h.nTables) DO
                interval: LocalInterval = h.vm[i];
                IF interval # [] THEN {
                    h.vm[i] Ź [];
                    h.vmPages[i] Ź 0;
                    FreeVM[interval];
                    };
                ENDLOOP;
            };

        Reset: PUBLIC ENTRY PROC [h: Handle] = {
            ENABLE UNWIND => {};
            FOR i: NAT IN [0..h.nTables) DO 
                h.top[i] Ź 0 + h.offsets[i];
                ResetChunkInternal[h, i];
                ENDLOOP;
            };

        Chunkify: PUBLIC ENTRY PROC [h: Handle, table: Selector, firstSmall, nSmall: NAT] = {
            ENABLE UNWIND => {};
            ch: ChunkHandle Ź h.chunks[table];
            IF ch # NIL THEN RETURN WITH ERROR Failure[h, table];
            ch Ź MimZones.permZone.NEW[ChunkObject[nSmall]];
            ch.firstSmall Ź firstSmall;
            ch.nullChunkIndex Ź CIndex.FIRST + h.offsets[table];    -- set tag
            h.chunks[table] Ź ch;
            ResetChunkInternal[h, table];
            };

        UnChunkify: PUBLIC ENTRY PROC [h: Handle, table: Selector] = {
            ENABLE UNWIND => {};
            h.chunks[table] Ź NIL;
            };

        Trim: PUBLIC ENTRY PROC [h: Handle, table: Selector, size: CARD] = {
            ENABLE UNWIND => {};
            newTop: CARD = size + h.offsets[table];
            IF newTop <= h.top[table]
                THEN {h.top[table] Ź newTop; ResetChunkInternal[h, table]}
                ELSE RETURN WITH ERROR Failure[h, table];
            };

        ResetChunk: PUBLIC ENTRY PROC [h: Handle, table: Selector] = {
            ResetChunkInternal[h, table ! UNWIND => {}];
            };

        ResetChunkInternal: INTERNAL PROC [h: Handle, table: Selector] = {
            ch: ChunkHandle = h.chunks[table];
            IF ch # NIL THEN {
                ch.chunkRover Ź ch.nullChunkIndex;
                FOR i: NAT IN [0..ch.nSmall) DO ch.smallLists[i] Ź ch.nullChunkIndex ENDLOOP;
                }
            };

    <<Notifier stuff>>

        NotifyNode: TYPE = RECORD [notifier: Notifier, link: NotifyChainHandle];
        NotifyChainHandle: TYPE = REF NotifyNode;

        AddNotify: PUBLIC ENTRY PROC [h: Handle, proc: Notifier] = {
            ENABLE UNWIND => {};
            p: NotifyChainHandle = MimZones.permZone.NEW[NotifyNode Ź
            [notifier: proc, link: h.notifiers]];
            h.notifiers Ź p;
            proc[h.bases];
            };

        DropNotify: PUBLIC ENTRY PROC [h: Handle, proc: Notifier] = {
            ENABLE UNWIND => {};
            IF h.notifiers # NIL THEN {
                p: NotifyChainHandle Ź h.notifiers;
                IF p.notifier = proc
                    THEN h.notifiers Ź p.link
                    ELSE
                        DO
                            lag: NotifyChainHandle Ź p;
                            p Ź p.link;
                            IF p = NIL THEN RETURN;
                            IF p.notifier = proc THEN {lag.link Ź p.link; EXIT};
                            ENDLOOP;
                MimZones.permZone.FREE[@p];
                };
            };

        RunNotifierChain: INTERNAL PROC [h: Handle] = {
            FOR p: NotifyChainHandle Ź h.notifiers, p.link UNTIL p = NIL DO
                p.notifier[h.bases];
                ENDLOOP
            };

    }.