IMPLEMENTATION MODULE GMem;

(************************************************************************)
(*                                                                      *)
(*  Gideon Memory Manager                                               *)
(*  Version 5.0.0                                                       *)
(*                                                                      *)
(*  (C) 2003 Gideon Software Ontwikkeling, All rights reserved.         *)
(*                                                                      *)
(************************************************************************)

IMPORT GState,Gll,GErr,Gtm;

(* 00000 IVT, BIOS, Drivers, DOS, ChaOS.
   yyyy0 HEAP
   90000 Process-Stack
   98000 DMA Buffer 1
   9C000 DMA Buffer 2
   A0000 VGA Memory
   B0000 Still to determine ;)
   B8000 EGA Text Memory
   C0000 BIOS
*)

(* Memory-Descriptor layout
    0 = Allocated blocks: card
    2 = Previous block: card
    4 = process: LONGCARD
    8 = prevfree: card
 0A 10 = nextfree: card
 0C 12 = volume: LONGCARD (8bit ident (87=empty/78=full) + 24 bit length)
    END 16 BEGIN data *)

VAR HeapFree: CARDINAL;

PROCEDURE MakeHeap;
VAR b: Block;
BEGIN
  IF GState.InitMem THEN
    b.blocks:=CARDINAL(GState.HeapLen>>4);
    b.prev:=0;     (* 0 = no prev block *)
    b.process:=0;  (* 0 = system *)
    b.prevfree:=0; (* 0 = all occupated in 1 block *)
    b.nextfree:=0; (* 0 = all occupated in 1 block *)
    b.volume:=87000000H+GState.HeapLen-16;
    HeapFree:=GState.HeapSeg;
    Gll.Copy(Seg(b),Ofs(b),GState.HeapSeg,0,8)
  ELSE
    GErr.FatalError("GMem.MakeHeap: This function needs GInit.mod!")
  END
END MakeHeap;

PROCEDURE DestroyHeap;
VAR lp: LONGCARD; s,o: CARDINAL;
BEGIN
  IF GState.InitMem THEN
    s:=GState.HeapSeg; o:=0;
    FOR lp:=1 TO GState.HeapLen>>1 DO
      [s:o]^:=0; INC(o,2); IF o>15 THEN INC(s); o:=0 END
    END
  END
END DestroyHeap;

PROCEDURE CalcVol(badr: CARDINAL): LONGCARD;
BEGIN
  RETURN LONGCARD(CARDINAL([badr:0EH]^) AND 0FFH)<<16+LONGCARD([badr:0CH]^)
END CalcVol;

PROCEDURE TotalMem(): LONGCARD;
BEGIN
  RETURN GState.HeapLen
END TotalMem;

PROCEDURE FreeMem(): LONGCARD;
VAR bl: CARDINAL; tot: LONGCARD;
BEGIN
  bl:=HeapFree; tot:=0;
  WHILE (bl <> 0) DO
    INC(tot,CalcVol(bl));
    bl:=[bl:0AH]^
  END;
  RETURN tot
END FreeMem;

PROCEDURE MaxAlloc(): LONGCARD;
VAR bl: CARDINAL; ma,cur: LONGCARD;
BEGIN
  bl:=HeapFree; ma:=0;
  WHILE (bl <> 0) DO
    cur:=CalcVol(bl);
    IF cur>ma THEN ma:=cur END;
    bl:=[bl:0AH]^
  END;
  RETURN ma
END MaxAlloc;

PROCEDURE CalcSlack(): LONGCARD;
VAR bl: CARDINAL; ma,tot: LONGCARD;
BEGIN
  bl:=GState.HeapSeg; ma:=0; tot:=0;
  WHILE (bl <> 0) AND (bl < 09000H) DO
    INC(tot,CalcVol(bl)); INC(ma,LONGCARD([bl:0]^)<<4); INC(bl,[bl:0]^)
  END;
  RETURN ma-tot
END CalcSlack;

PROCEDURE ReadBlock(badr: CARDINAL): Block;
BEGIN
  (* Direct mem transfer *)
  RETURN Block([badr:0]^);
END ReadBlock;

PROCEDURE ValidBlock(badr: CARDINAL): BOOLEAN;
VAR id: CARDINAL;
BEGIN
  id:=CARDINAL([badr:0EH]^)>>8; GErr.Code:=id;
  RETURN (id = 87H) OR (id = 78H)
END ValidBlock;

PROCEDURE Alloc(bytes: LONGCARD): CARDINAL;
VAR nb,pgn,pgf,try,rb,prev,next,lst: CARDINAL; vol:LONGCARD;
BEGIN
  IF bytes=0 THEN RETURN 0 END;
  (* calculate actual paragraphs needed *)
  pgn:=1+CARDINAL(bytes>>4); IF bytes AND 15 > 0 THEN INC(pgn) END;
  try:=HeapFree;
  IF try>0 THEN
    REPEAT
      pgf:=[try:00H]^; IF pgf<pgn THEN try:=[try:08H]^ END
    UNTIL (pgf>=pgn) OR (try=0)
  END;
  IF try=0 THEN
    GErr.ProcessError("Memory: Could not allocate block")
  END;
  (* found a free block *)
  IF (pgn=pgf) OR (pgn+1=pgf) THEN
    (* convert empty block into full -> link prevfree and nextfree *)
    rb:=try;
    prev:=[rb:08H]^; next:=[rb:0AH]^;
    IF prev>0 THEN
      lst:=prev;
      REPEAT
        [lst:0AH]^:=next; lst:=[lst:2]^
      UNTIL (lst=0) OR (CARDINAL([lst:2]^) <> rb)
    END;
    IF next < 09000H THEN
      lst:=next;
      REPEAT
        [lst:8]^:=prev; INC(lst,CARDINAL([lst:0]^))
      UNTIL (lst >= 09000H) OR (CARDINAL([lst:8]^) <>rb)
    END;
    [rb:04H]^:=CARDINAL(GState.ProcessID AND 0FFFFH);
    [rb:06H]^:=CARDINAL(GState.ProcessID>>16);
    [rb:0CH]^:=CARDINAL(bytes AND 0FFFFH);
    [rb:0EH]^:=7800H+(CARDINAL(bytes>>16) AND 255);
    IF HeapFree=try THEN HeapFree:=next END
  ELSE
    (* Block is large enough to split up *)
    (* pgn+1 would only leave space for a header.. (not enough) *)
    (* first determine where new block will come.. try will be current *)
    (* e.g.   FREE-BLOCK becomes 2 BLOCKES: FREEFREEFREE-FULL *)
    rb:=try+(pgf-pgn);

    (* Set up this block *)
    [rb:00H]^:=pgn;                    (* pages needed *)
    [rb:02H]^:=try;                    (* previous block = try *)
    nb:=rb+pgn; IF nb<09000H THEN [nb:02H]^:=rb END;
                                       (* set next.prev block if present *)
    [rb:04H]^:=CARDINAL(GState.ProcessID AND 0FFFFH);
    [rb:06H]^:=CARDINAL(GState.ProcessID >> 16);
                                       (* current process *)
    [rb:08H]^:=try;                    (* try becomes new first free block *)
    [rb:0AH]^:=[try:0AH]^;             (* next free block is try.next *)
    [rb:0CH]^:=CARDINAL(bytes AND 0FFFFH);
    [rb:0EH]^:=7800H+(CARDINAL(bytes >> 16) AND 255);
                                       (* store ident/ Real-allocated space *)

    (* modulate try (free) block to adjust to this newly created block *)
    [try:00H]^:=pgf-pgn;               (* pages still free *)
    vol:=LONGCARD(pgf-pgn-1)<<4;
    [try:0CH]^:=CARDINAL(vol AND 0FFFFH);
    [try:0EH]^:=8700H+CARDINAL(vol >> 16);
                                       (* ident + new volume avail in block *)
  END;
  RETURN rb
END Alloc;

PROCEDURE DeAlloc(badr: CARDINAL);
(* Never allow two free blocks next to eachother *)
VAR rb: LONGCARD; pb,nb,fc,pbl,pnp: CARDINAL; nsz: LONGCARD;
BEGIN
  IF NOT ValidBlock(badr) THEN
    GErr.FatalError("GMem.DeAlloc: Illegal memory-handle")
  END;
  IF CARDINAL([badr:0EH]^)>>8 <> 78H THEN
    GErr.FatalError("GMem.DeAlloc: Trying to deallocate a free block")
  END;
  (* First make block free -> remove slack *)
  rb:=(LONGCARD([badr:0]^)-1)<<4;
  [badr:0CH]^:=CARDINAL(rb AND 0FFFFH);
  [badr:0EH]^:=8700H+CARDINAL(rb >> 16);

  (* Check if previous block is free or full *)
  pb:=[badr:2]^; nb:=badr+CARDINAL([badr:0]^);
  IF pb > 0 THEN
    fc:=[pb:0EH]^; fc:=fc>>8;
    IF fc=87H THEN
      (* E[F]XY -> EXY *)
      (* found free block at previous -> connect to it! *)
      (* Set up previous block *)
      [pb:0]^:=CARDINAL([pb:0]^)+CARDINAL([badr:0]^);
      nsz:=(LONGCARD([pb:0]^)<<4)-16;
      [pb:0CH]^:=CARDINAL(nsz AND 0FFFFH);
      [pb:0EH]^:=8700H+CARDINAL(nsz >> 16);
      (* Set next.prev of next block and next.prevfree of next blocks *)
      IF (nb < 09000H) THEN
        fc:=[nb:0EH]^; fc:=fc>>8;
        IF fc=87H THEN
          (* E[F]EF -> EF *)
          (* Next block is empty -> connect to it! *)
          [pb:0]^:=CARDINAL([pb:0]^)+CARDINAL([nb:0]^);
          nsz:=(LONGCARD([pb:0]^)<<4)-16;
          [pb:0CH]^:=CARDINAL(nsz AND 0FFFFH);
          [pb:0EH]^:=8700H+CARDINAL(nsz >> 16);
          [pb:0AH]^:=[nb:0AH]^;
          (* Destroy block *)
          pbl:=nb+CARDINAL([nb:0]^);
          pnp:=nb; (* search for nb in prevfree of next blocks (pbl) *)
          [nb:0EH]^:=0; [nb:0]^:=0;
          (* Set prev of pbl and prevfree of list from pbl on *)
          IF pbl<09000H THEN
            [pbl:2]^:=pb;
            REPEAT
              [pbl:8]^:=pb; pbl:=pbl+CARDINAL([pbl:0]^);
            UNTIL (pbl >= 09000H) OR (CARDINAL([pbl:8]^) <> pnp)
          END
        ELSE
          (* E[F]FX -> EFX *)
          (* Next block is full -> change next.prev *)
          (* NB from X and on: prevfree already points to pb *)
          [nb:2]^:=pb;
        END
      END;
      (* Destroy current block *)
      [badr:0]^:=0; [badr:0EH]^:=0;
      (* all done *)
      RETURN
    END
  END;
  (* F[F]XY -> FEXY *)
  (* previous block is full or there is no previous block *)
  IF pb > 0 THEN
    (* there are previous blocks; mark nextfree in prev-list *)
    pbl:=pb; pnp:=[pbl:0AH]^; (* searching for whatever nextfree was (XYZ..) *)
    REPEAT
      [pbl:0AH]^:=badr; pbl:=[pbl:2]^;
    UNTIL (pbl=0) OR (CARDINAL([pbl:0AH]^) <> pnp);
    (* Check next block out (no two empty blocks next to eachother!! *)
    IF nb<09000H THEN
      fc:=[nb:0EH]^; fc:=fc>>8;
      IF fc = 87H THEN
        (* F[F]EF -> FEF *)
        (* Next block = empty -> connect to it *)
        (* set next.prev to badr *)
        pbl:=nb+CARDINAL([nb:0]^);
        IF pbl<09000H THEN
          [pbl:2]^:=badr;
          REPEAT
            [pbl:8]^:=badr; INC(pbl,CARDINAL([pbl:0]^))
          UNTIL (pbl >= 09000H) OR (CARDINAL([pbl:8]^) <> nb)
        END;
        (* Adjust badr-block merged with nb *)
        [badr:0]^:=CARDINAL([badr:0]^)+CARDINAL([nb:0]^);
        nsz:=(LONGCARD([badr:0]^)<<4)-16;
        [badr:0CH]^:=CARDINAL(nsz AND 0FFFFH);
        [badr:0EH]^:=8700H+CARDINAL(nsz >> 16);
        [badr:0AH]^:=[nb:0AH]^;
        (* Destroy nb-block *)
        [nb:0]^:=0; [nb:0EH]^:=0
      ELSE
        (* F[F]FX -> FEFX *)
        (* Next block = full -> prev still valid / set prevfree of list *)
        pnp:=[nb:8]^; pbl:=nb;
        REPEAT
          [pbl:8]^:=badr; INC(pbl,CARDINAL([pbl:0]^))
        UNTIL (pbl >= 09000H) OR (CARDINAL([pbl:8]^) <> pnp)
        (* Block already marked free -> all done. *)
      END
    END (* ELSE -> there is only one block; now marked empty *)
  END
END DeAlloc;

PROCEDURE GetAdr(badr: CARDINAL): ADDRESS;
BEGIN
  RETURN [badr+1:0]
END GetAdr;

PROCEDURE IncAdr(a: ADDRESS; b: LONGCARD): ADDRESS;
VAR s,o: CARDINAL;
BEGIN
  s:=Seg(a^); o:=Ofs(a^);
  INC(s,o>>4); o:=(o AND 15)+CARDINAL(b AND 15);
  s:=s+CARDINAL(b>>4)+(o>>4); o:=o AND 15;
  RETURN [s:o]
END IncAdr;

PROCEDURE DecAdr(a: ADDRESS; b: LONGCARD): ADDRESS;
VAR s,o,bo: CARDINAL;
BEGIN
  s:=Seg(a^); o:=Ofs(a^); bo:=CARDINAL(b AND 15);
  IF bo>o THEN o:=15-o; DEC(s) END;
  DEC(s,CARDINAL(b>>4));
  RETURN [s:o]
END DecAdr;

PROCEDURE Write(badr: CARDINAL; ofs: LONGCARD; dat: ARRAY OF WORD);
VAR a: ADDRESS; sz: LONGCARD; w,t: CARDINAL;
BEGIN
  IF NOT ValidBlock(badr) THEN
    GErr.FatalError("GMem.Write: Invalid memory-handle.")
  END;
  sz:=CalcVol(badr);
  IF LONGCARD(SIZE(dat))+ofs>sz THEN
    GErr.FatalError("GMem.Write: memory block segment overflow")
  END;
  a:=[badr+1:0]; a:=IncAdr(a,ofs); t:=SIZE(dat)>>1;
  FOR w:=0 TO t-1 DO
    a^:=dat[w]; a:=IncAdr(a,2)
  END
END Write;

PROCEDURE Read(badr: CARDINAL; ofs: LONGCARD; VAR dat: ARRAY OF WORD);
VAR a: ADDRESS; sz: LONGCARD; w,t: CARDINAL;
BEGIN
  IF NOT ValidBlock(badr) THEN
    GErr.FatalError("GMem.Read: Invalid memory-handle.")
  END;
  sz:=CalcVol(badr);
  IF LONGCARD(SIZE(dat))+ofs>sz THEN
    GErr.FatalError("GMem.Read: memory block segment overflow")
  END;
  a:=[badr+1:0]; a:=IncAdr(a,ofs); t:=SIZE(dat)>>1;
  FOR w:=0 TO t-1 DO
    dat[w]:=a^; a:=IncAdr(a,2)
  END
END Read;

PROCEDURE GetSize(badr: CARDINAL): LONGCARD;
BEGIN
  IF NOT ValidBlock(badr) THEN
    GErr.FatalError("GMem.GetSize: Invalid memory-handle")
  END;
  RETURN LONGCARD([badr:0EH]^)<<16+LONGCARD([badr:0CH]^)
END GetSize;

PROCEDURE TestBlock(badr: CARDINAL);
VAR b: Block; s: LONGREAL; sl: LONGCARD;
BEGIN
  Gtm.nl; Gtm.wrs("Testing block at segment "); Gtm.wrhex(badr); Gtm.nl;
  Gtm.wrsr("Validation .. ",30); Gtm.wrb(ValidBlock(badr)); Gtm.nl;
  b:=ReadBlock(badr);
  Gtm.wrsr("00",10); Gtm.wrsr("Paragraphes .. ",20); Gtm.wrc(b.blocks); Gtm.nl;
  Gtm.wrsr("02",10); Gtm.wrsr("Previous block .. ",20); Gtm.wrhex(b.prev); Gtm.nl;
  Gtm.wrsr("04",10); Gtm.wrsr("Process-id .. ",20); Gtm.wrlc(b.process); Gtm.nl;
  Gtm.wrsr("08",10); Gtm.wrsr("Prev free block .. ",20); Gtm.wrhex(b.prevfree); Gtm.nl;
  Gtm.wrsr("0A",10); Gtm.wrsr("Next free block .. ",20); Gtm.wrhex(b.nextfree); Gtm.nl;
  Gtm.wrsr("0C",10); Gtm.wrsr("Real length .. ",20); Gtm.wrlc(b.volume AND 00FFFFFFH); Gtm.nl;
  Gtm.wrsr("0F",10); Gtm.wrsr("Identification .. ",20); Gtm.wrlhex(b.volume >> 24); Gtm.nl;
  sl:=LONGCARD(b.blocks)<<4-(b.volume AND 00FFFFFFH);
  s:=LONGREAL(b.blocks)*16.0;
  Gtm.wrsr("Slack .. ",30); Gtm.wrlc(sl); Gtm.wrs(" bytes (");
  s:=100.0*LONGREAL(sl)/s; Gtm.wrlr(s,2); Gtm.wrs("%)"); Gtm.nl;
END TestBlock;

PROCEDURE MemDump;
VAR b: CARDINAL; bl: Block; id: SHORTCARD; s: LONGCARD;
BEGIN
  Gtm.nl; Gtm.wrs("        --- Memory Table ---"); Gtm.nl; Gtm.nl;
  Gtm.wrsr("Total Memory .. ",30); Gtm.wrlcr(GState.HeapLen,6); Gtm.nl;
  Gtm.wrsr("Total Free Memory .. ",30); Gtm.wrlcr(FreeMem(),6); Gtm.nl;
  Gtm.wrsr("Largest Free Block .. ",30); Gtm.wrlcr(MaxAlloc(),6); Gtm.nl;
  Gtm.wrsr("Total Slack .. ",30); s:=CalcSlack();
  Gtm.wrlr(100.0*LONGREAL(s)/LONGREAL(GState.HeapLen),3);
  Gtm.wrs("% ("); Gtm.wrlc(s); Gtm.wrs(" bytes)"); Gtm.nl; Gtm.nl;
  b:=GState.HeapSeg;
  Gtm.wrs("   ADR   Prev   ID       NumPar   Process    Volume   Prev   Next"); Gtm.nl;
  WHILE (b<>0) AND (b<09000H) DO
    bl:=ReadBlock(b); id:=SHORTCARD(bl.volume>>24);
    Gtm.wrhex(b); Gtm.wrs(" "); Gtm.wrhex(bl.prev);
    Gtm.wrs(" "); Gtm.wrshex(id);
    IF id = 78H THEN Gtm.wrs("  full ") ELSE Gtm.wrs(" empty ") END;
    Gtm.wrcr(bl.blocks,6); Gtm.wrs(" ");
    Gtm.wrlcr(bl.process,9); Gtm.wrs(" ");
    Gtm.wrlcr(bl.volume AND 00FFFFFFH,9); Gtm.wrs(" ");
    Gtm.wrhex(bl.prevfree); Gtm.wrs(" ");
    Gtm.wrhex(bl.nextfree); Gtm.wrs(" "); Gtm.nl;
    b:=b+bl.blocks
  END
END MemDump;

BEGIN
  GState.InitMem:=FALSE;
  GState.HeapLen:=0;
  GState.SS:=Gll.GetStackSegment();
  GState.HeapSeg:=(GState.SS+040FH) AND 0FF0H;
  GState.HeapLen:=LONGCARD(09000H-GState.HeapSeg)<<4;
END GMem.