-- RTAllocatorImpl.Mesa
-- Contains a small number of basic allocator procedures plus the quantized allocator

-- last edited On August 30, 1982 10:33 am by Willie-Sue Haugeland
-- last edited On October 19, 1982 11:06 am by Paul Rovner

DIRECTORY
  Inline USING[BITAND],
  PrincOps USING[StateVector],
  RTBases USING[BaseOverhead],
  RTBasic USING[Pointer],
  RTCommon USING[RepAddrPtr],
  RTFlags USING[checking, clearing, takingStatistics, useMicrocode],
  RTOS USING[MyLocalFrame],
  RTQuanta USING[QuantumSizeMULT, QuantumIndex, QuantumSize],
  RTMicrocode USING[ALLOCATEQUANTIZEDNODE, LONGZERO],
  RTRefCounts USING[CreateRef, GCMicrocodeExists, AllocatorTrapStatsRec],
  RTStorageAccounting USING[nObjectsCreated, ConsiderCollection],
  RTStorageOps USING[FreeCollectibleObject],
  RTTypesBasic USING[Type, nullType],
  RTTypesBasicPrivate USING[NPackageRefs],
  Runtime USING[CallDebugger],
  SafeStorage USING[MemoryExhausted, InvalidSize],
  TrapSupport USING[BumpPC, GetTrapParam],
  UnsafeStorage USING[GetSystemUZone],
  RTZones;

RTAllocatorImpl: MONITOR  -- protects zones
  LOCKS zn.LOCK USING zn: PZone
  IMPORTS Inline, RTCommon, RTMicrocode, RTOS, RTQuanta, RTRefCounts,
             RTStorageAccounting, RTStorageOps, RTTypesBasicPrivate, Runtime, SafeStorage,
             TrapSupport, UnsafeStorage, RTZones
          
  EXPORTS RTRefCounts, RTStorageAccounting, RTStorageOps, UnsafeStorage, RTZones
= BEGIN
  OPEN RTMicrocode, RTQuanta, RTRefCounts, RTStorageOps, RTTypesBasic, RTTypesBasicPrivate,
          SafeStorage, UnsafeStorage, RTZones;

-- Types
  Pointer: TYPE = RTBasic.Pointer;
  InsertionOp: TYPE = {normal, rehashing};  -- for arg to MapZnTdSizeSz

-- Signals
  SizeTooBig: SIGNAL[size: CARDINAL] = CODE;
  NeedASZ: ERROR = CODE;
  SuspectPtrSeen: SIGNAL[suspectPtr: Pointer] = CODE;  -- hook for debugging

-- Global variables and constants

  useAllocUCode: BOOLEAN _ RTFlags.useMicrocode;
  checking: BOOLEAN = RTFlags.checking;
  clearing: BOOLEAN = RTFlags.clearing;
  takingStatistics: BOOLEAN = RTFlags.takingStatistics; 
       -- "= FALSE" suppresses compilation of statistics code
  suspectPtr: Pointer _ NIL;  -- for debugging

  AllocatorCallbackProcForSpy: PUBLIC UNSPECIFIED _ 0;

  -- Statistics
  Count: TYPE = LONG CARDINAL;
  Bump: PROC[p: POINTER TO Count, delta: Count _ 1] = INLINE
    BEGIN  IF takingStatistics THEN p^ _ p^+delta  END;

  QuantizedAllocatorTrapStats: PUBLIC RTRefCounts.AllocatorTrapStatsRec _ [];

-- PUBLIC procedures (i.e. exported)

  NewObject: PUBLIC PROC[type: Type, size: CARDINAL, zone: ZONE _ NIL]
                        RETURNS[REF ANY] =
    { IF zone = NIL THEN zone _ zoneSystem;
      WITH zn: LOOPHOLE[zone, Zone] SELECT FROM
        quantized => RETURN[NewQuantizedObject[size: size, self: @zn, type: type]];
        prefixed => RETURN[NewPrefixedObject[size: size, self: @zn, type: type]];
       ENDCASE => ERROR};

  NewQuantizedObject: PUBLIC PROC[self: QuantizedZone, size: CARDINAL, type: Type]
      RETURNS[ref: REF ANY] =
   { IF size < SIZE[FreeList]
      THEN size _ SIZE[FreeList]
      ELSE size _ Inline.BITAND[size+1, 177776B];        -- size even => refs even

     IF AllocatorCallbackProcForSpy # 0
      THEN LOOPHOLE[AllocatorCallbackProcForSpy, PROC[CARDINAL]][size];
     
     ref _ LOOPHOLE[CreateQuantizedObject[LOOPHOLE[self], size, type]];

-- TandS: CreateRef OK outside the monitor if it is idempotent and new storage has been cleared
     CreateRef[NPackageRefs[type], ref]; -- establish initial refCount of 0
     RTStorageAccounting.nObjectsCreated _ RTStorageAccounting.nObjectsCreated + 1;
     IF FALSE  --checking
      THEN FOR i: CARDINAL IN [0..size)
             DO IF (LOOPHOLE[ref, LONG POINTER TO CARDINAL] + i)^ # 0
                 THEN ERROR
            ENDLOOP;
     RTStorageAccounting.ConsiderCollection[size--no overhead--]};

  FreeQuantizedObject: PUBLIC PROC[self: QuantizedZone, object: REF ANY] =
   {FreeCollectibleObject[object]};

  NewUObject: PUBLIC PROC  -- used when NEW won't do, e.g for type-carrying heap objects
                [size: CARDINAL,
                 zone: UNCOUNTED ZONE,
                 type: Type _ nullType] RETURNS[ptr: LONG POINTER] =
    { WITH zn: LOOPHOLE[zone, LONG POINTER TO PZone]^ SELECT FROM
        quantized =>
          { IF size < SIZE[FreeList]
             THEN size _ SIZE[FreeList]
             ELSE size_ Inline.BITAND[size+1, 177776B];        -- size even => refs even
            RETURN[CreateQuantizedObject[zn: @zn, size: size, type: type]]};
        prefixed =>
          { triedAgain: BOOLEAN _ FALSE;
            IF LOOPHOLE[zn.linkage, heap ZoneLinkage].typeRepresentation THEN
             ptr _ CreatePrefixedTypedUObject[type, size, @zn
                      ! MemoryExhausted => IF NOT triedAgain THEN {triedAgain _ TRUE;RETRY}]
            ELSE
             ptr _ CreatePrefixedUObject[size, @zn
                      ! MemoryExhausted => IF NOT triedAgain THEN
                                                  {triedAgain _ TRUE;RETRY}]};
       ENDCASE => ERROR};

  NewQuantizedHeapObject: PUBLIC PROC[self: LONG POINTER TO PQuantizedZone, size: CARDINAL]
      RETURNS[LONG POINTER] =
   {IF size < SIZE[FreeList]
     THEN size _ SIZE[FreeList]
     ELSE size_ Inline.BITAND[size+1, 177776B];        -- size even => refs even;
    RETURN[CreateUQuantizedObject[size, self^]]};

-- ********** special speedy interface for Doug Wyatt
--  NewQuantumNode: PUBLIC PROC[size: CARDINAL, zone: Zone] RETURNS[ptr: Pointer] =
--    { RETURN[CreateQuantizedObject[size, zone]]};
--    { sz: SubZone = MapZnTdSizeSz[LOOPHOLE[zone, QuantumZone], size];
--      WHILE (ptr _ sz.fl) = NIL DO
--        IF NOT AddQuantum[LOOPHOLE[zone, QuantumZone], sz, size] THEN
--           LOOPHOLE[zone, QuantumZone].fullProc[zone, size];
--       ENDLOOP;
--      sz.fl _ LOOPHOLE[ptr, FreeList]^;
--    };

--  FreeQuantumNode: PUBLIC PROC[ptr: Pointer] =
--    { sz: SubZone = MapSziSz[LOOPHOLE[MapPtrZf[ptr], sub MyZone].szi];
--      LOOPHOLE[ptr, FreeList]^ _ sz.fl;
--      sz.fl _ ptr;
--      IF takingStatistics THEN
--       { zn: Zone = MapZiZn[sz.zi];
--         zn.cellsInService _ zn.cellsInService - sz.size;
--         zn.objectsInService _ zn.objectsInService - 1;
--       };
--    };
-- ********** special speedy interface for Doug Wyatt (end)

  -- *** The Quantum Object Allocator
-- this procedure gets called when the microcode can't do it
  CreateQuantizedObjectTrap: PUBLIC PROC[zn: PQuantizedZone, size: CARDINAL, type: Type]
        RETURNS[ptr: Pointer] =
   { state: PrincOps.StateVector;
     param: CARDINAL;
     state _ STATE;   -- incantation

     param _ IF useAllocUCode THEN TrapSupport.GetTrapParam[] ELSE 0;

     IF param < 2 OR param > 4 THEN useAllocUCode _ FALSE;
     
      IF state.stkptr # 0 THEN Runtime.CallDebugger["CreateQuantizedObjectTrap: stack not empty"];
     
     ptr _ DoCreateQuantizedObject[zn, size, type];

     IF takingStatistics
      THEN
       SELECT param FROM
         0 => Bump[@QuantizedAllocatorTrapStats.NoUCodeTraps];
         1 => Bump[@QuantizedAllocatorTrapStats.OldUCodeTraps];
         2 => Bump[@QuantizedAllocatorTrapStats.ZoneLockedTraps];
         3 => Bump[@QuantizedAllocatorTrapStats.NoBlockFoundTraps];
         4 => Bump[@QuantizedAllocatorTrapStats.LongFreeListTraps];
        ENDCASE => Bump[@QuantizedAllocatorTrapStats.UnKnownTraps];

     TrapSupport.BumpPC[2];
     state.dest_ LOOPHOLE[RTOS.MyLocalFrame[]];
     TRANSFER WITH state;   -- incantation
   };

  AllocateQuantizedNodeSDTrap: PUBLIC PROC[zn: PQuantizedZone, size: CARDINAL, type: Type]
        RETURNS[ptr: Pointer] = {RETURN[DoCreateQuantizedObject[zn, size, type]]};

-- PRIVATE procedures (i.e. local to this module)

-- OBJECT ALLOCATION
  -- *** The Quantum Object Allocator
  CreateQuantizedObject: PROC[zn: PQuantizedZone, size: CARDINAL, type: Type _ nullType]
      RETURNS[ptr: Pointer] =
  INLINE BEGIN
      IF useAllocUCode
       THEN RETURN[ALLOCATEQUANTIZEDNODE[zn, size, type]]
       ELSE RETURN[DoCreateQuantizedObject[zn, size, type]];
    END;
    
  DoCreateQuantizedObject: PROC[zn: PQuantizedZone, size: CARDINAL, type: Type _ nullType]
      RETURNS[ptr: Pointer] =
  INLINE BEGIN
      DO
         { WHILE (ptr _ AllocateQuantizedNode[zn, size, type ! NeedASZ => GOTO needASZ]) = NIL DO
              WITH zn.linkage SELECT FROM
                 collectible => fullProc[LOOPHOLE[zn], size];
                 heap => fullProc[LOOPHOLE[LONG[@zn]], size];
                ENDCASE => ERROR;
            ENDLOOP;
           IF checking THEN IF ptr = suspectPtr THEN SIGNAL SuspectPtrSeen[suspectPtr];
           RETURN[ptr];
          EXITS
            needASZ => --the stack is unwound, and the monitor lock is released
             { newnAsz: CARDINAL = (zn.mAsz*2+1)+1;
               newASZ: SubZoneArray _
                   DESCRIPTOR[NewUObject[SIZE[SubZoneRec]*newnAsz, GetSystemUZone[]], newnAsz];
               p: LONG POINTER _ BASE[ExpandASZ[zn, newASZ, newnAsz]--enter the zone's monitor--];
               GetSystemUZone[].FREE[@p];
             };
         };
       ENDLOOP;
    END;

  CreateUQuantizedObject: PROC[size: CARDINAL, zn: PQuantizedZone] RETURNS[ptr: Pointer] =
    INLINE BEGIN
      DO
         BEGIN
           WHILE (ptr _ AllocateUQuantizedNode[zn, size ! NeedASZ => GOTO needASZ]) = NIL DO
              LOOPHOLE[zn.linkage, heap ZoneLinkage].fullProc[LOOPHOLE[LONG[@zn]], size];
            ENDLOOP;
           IF checking THEN IF ptr = suspectPtr THEN SIGNAL SuspectPtrSeen[suspectPtr];
           RETURN[ptr];
          EXITS
            needASZ => --the stack is unwound, and the monitor lock is released
             { newnAsz: CARDINAL = (zn.mAsz*2+1)+1;
               newASZ: SubZoneArray _
                   DESCRIPTOR[NewUObject[SIZE[SubZoneRec]*newnAsz, GetSystemUZone[]], newnAsz];
               p: LONG POINTER _ BASE[ExpandASZ[zn, newASZ, newnAsz]--enter the zone's monitor--];
               GetSystemUZone[].FREE[@p];
             };
         END;
       ENDLOOP;
    END;

  AllocateQuantizedNode: ENTRY PROC[zn: PZone, size: CARDINAL, type: Type _ nullType]
                 RETURNS[ptr: Pointer] =
    { ENABLE UNWIND => NULL;
      sz: SubZone _ MapZnTdSizeSz[LOOPHOLE[zn], size, type];
      IF sz.fl = NIL THEN IF NOT AddQuantum[LOOPHOLE[zn], sz, size] THEN RETURN[NIL];
      ptr _ sz.fl;
      sz.fl _ LOOPHOLE[ptr, FreeList]^;
      IF clearing THEN [] _ LONGZERO[ptr, SIZE[FreeList]];  -- the rest of the object should be clear
      IF takingStatistics THEN
       { zn.cellsInService _ zn.cellsInService + size;
         zn.objectsInService _ zn.objectsInService + 1}};

  AllocateUQuantizedNode: ENTRY PROC[zn: PZone, size: CARDINAL]
                 RETURNS[ptr: Pointer] =
    { ENABLE UNWIND => NULL;
      sz: SubZone _ MapZnSizeSz[LOOPHOLE[zn], size];
      IF sz.fl = NIL THEN IF NOT AddQuantum[LOOPHOLE[zn], sz, size] THEN RETURN[NIL];
      ptr _ sz.fl;
      sz.fl _ LOOPHOLE[ptr, FreeList]^;
      IF takingStatistics THEN
       { zn.cellsInService _ zn.cellsInService + size;
         zn.objectsInService _ zn.objectsInService + 1}};

  AddQuantum: INTERNAL PROC
        [zn: PQuantizedZone, sz: SubZone, size: CARDINAL] RETURNS[ok: BOOLEAN] =
    { q: QuantumIndex = zn.qNext;
      i: QuantumIndex;
      overhead: CARDINAL;
      base: Pointer;
      pFl: LONG POINTER TO FreeList;
      IF q = 0 THEN RETURN[FALSE];  -- no quanta left to allocate
      IF size + RTBases.BaseOverhead > QuantumSize THEN ERROR SafeStorage.InvalidSize[size];
      overhead _ IF q = zn.qFirst THEN RTBases.BaseOverhead ELSE 0;
          -- omit overhead at low end of base
      IF CARDINAL[q+1] > CARDINAL[zn.qLast] THEN RETURN[FALSE];  -- no quanta left to allocate
      zn.qNext _ q + 1;
      IF zn.qNext = zn.qLast THEN zn.qNext _ zn.qLast _ 0;
      base _ RTCommon.RepAddrPtr[QuantumSizeMULT[q] + overhead];
      pFl _ base + ((QuantumSize - overhead)/size - 1) * size;
      IF clearing THEN [] _ LONGZERO[base, QuantumSize - overhead];
      DO
        pFl^ _ sz.fl;
        sz.fl _ pFl;
        IF pFl = base THEN EXIT;
        pFl _ pFl - size;
       ENDLOOP;
      FOR i IN [q..q + 1) DO MapQZf[i] _ [sub[sz.szi]]; ENDLOOP;
      RETURN[TRUE]};

--  GetSZFast: PROC
--        [zn: QuantumZone, size: CARDINAL]
--   RETURNS[sz: SubZone] =
--    INLINE BEGIN
--    asz: SubZoneArray = zn.pAsz;
--    mAsz: CARDINAL = zn.mAsz;
--    i: CARDINAL _ Inline.BITAND[size, mAsz];
--    UNTIL IsSubZoneVacant[sz _ @asz[i]] DO
--      IF sz.size = size THEN RETURN;
--      i _ (IF i = 0 THEN mAsz ELSE i-1);
--      ENDLOOP;
--    IF zn.nAsz < zn.mAsz THEN
--      BEGIN
--      szi: SubZoneIndex = AllocateSzi[];
--      sz^ _ [szi: szi, type: nullType, size: size, zi: zn.zi];
--      MapSziSz[szi] _ sz;
--      zn.nAsz _ zn.nAsz+1;
--      RETURN;
--      END;
--    zn.mAsz _ mAsz*2+1;
--    AllocateAszForQzn[zn];
--    FOR i IN [0..mAsz] DO
--      IF NOT IsSubZoneVacant[@asz[i]] THEN
--        BEGIN
--        sz _ MapZnTdSizeSz[zn, asz[i].size, asz[i].type, rehashing];
--        sz^ _ asz[i];
--        MapSziSz[sz.szi] _ sz;
--        END;
--      ENDLOOP;
--    FreeHeapArray[asz];
--    RETURN[MapZnTdSizeSz[zn, size]];
--    END;

  MapZnSizeSz: INTERNAL PROC[zn: PQuantizedZone, size: CARDINAL, insert: InsertionOp _ normal]
      RETURNS[sz: SubZone] =
    INLINE BEGIN
      mAsz: CARDINAL = zn.mAsz;
      asz: SubZoneArray = zn.pAsz;
      i: CARDINAL _ Inline.BITAND[size, mAsz];  -- hash code
      UNTIL IsSubZoneVacant[sz _ @asz[i]] DO  -- table can not get full, so this must terminate
        IF sz.size = size THEN RETURN;
        i _ (IF i = 0 THEN mAsz ELSE i-1);
       ENDLOOP;
      IF zn.nAsz < zn.mAsz THEN  -- not full yet
        BEGIN
          szi: SubZoneIndex = (IF insert = normal THEN AllocateSzi[] ELSE 0);
          sz^ _ [szi: szi, type: nullType, size: size, zi: zn.zi];
          IF szi # 0 THEN MapSziSz[szi] _ sz;
          zn.nAsz _ zn.nAsz+1;
          RETURN;
        END
      ELSE ERROR NeedASZ;
    END;

  MapZnTdSizeSz: INTERNAL PROC
        [zn: PQuantizedZone, size: CARDINAL, type: Type _ nullType, insert: InsertionOp _ normal]
   RETURNS[sz: SubZone] =
    INLINE BEGIN
      mAsz: CARDINAL = zn.mAsz;
      asz: SubZoneArray = zn.pAsz;
      i: CARDINAL _ Inline.BITAND[size, mAsz];  -- hash code
      UNTIL IsSubZoneVacant[sz _ @asz[i]] DO  -- table can not get full, so this must terminate
        IF sz.type = type AND sz.size = size THEN RETURN;
        i _ (IF i = 0 THEN mAsz ELSE i-1);
       ENDLOOP;
      IF zn.nAsz < zn.mAsz THEN  -- not full yet
        BEGIN
          szi: SubZoneIndex = (IF insert = normal THEN AllocateSzi[] ELSE 0);
          sz^ _ [szi: szi, type: type, size: size, zi: zn.zi];
          IF szi # 0 THEN MapSziSz[szi] _ sz;
          zn.nAsz _ zn.nAsz+1;
          RETURN;
        END
      ELSE ERROR NeedASZ;
    END;

  ExpandASZ: ENTRY PROC[zn: PZone, newASZ: SubZoneArray, newnAsz: CARDINAL]
      RETURNS[SubZoneArray] =
      -- Expand the hash table of subzones for this QuantizedZone
    BEGIN ENABLE UNWIND => NULL;
      qzn: PQuantizedZone = LOOPHOLE[zn];
      mAsz: CARDINAL _ qzn.mAsz;
      oldAsz: SubZoneArray _ qzn.pAsz;

      IF newnAsz < (mAsz*2+1)+1 THEN RETURN[newASZ];  -- it may have been expanded already
      qzn.mAsz _ mAsz*2+1;
      FOR j: CARDINAL IN [0..newnAsz) DO
         newASZ[j] _ [type: nullType, szi: sziVacant, zi: qzn.zi, fl: NIL, size: 0];
       ENDLOOP;
      qzn.nAsz _ 0;
      qzn.pAsz _ newASZ;

      FOR i: CARDINAL IN [0..mAsz] DO  -- copy entries from old hash table
        IF NOT IsSubZoneVacant[@oldAsz[i]] THEN
         { sz: SubZone _ MapZnTdSizeSz[qzn, oldAsz[i].size, oldAsz[i].type, rehashing ! ANY => ERROR];
           sz^ _ oldAsz[i];
           MapSziSz[sz.szi] _ sz};
        ENDLOOP;
      RETURN[oldAsz];  -- for reclamation
    END;
  -- *** The Quantum Object Allocator (end)

 -- start code, for debugging microcode under Pilot

   useAllocUCode _ useAllocUCode AND RTRefCounts.GCMicrocodeExists;

END.