wSyntax10.Scn.FntSyntax10i.Scn.FntMarkElemsAlloc"StampElemsAlloc13 Oct 98InfoElemsAllocVSyntax10.Scn.FntStampElemsAlloc13 Oct 98T"Title": Defragmentizer "Author": Martin Rammerstorfer (MR) "Abstract": "Keywords": Heap, Defragmentize "Version": 1 "From": 20.02.97 "Until":  "Changes": RLI 13.10.1998 Win32TypePatternDesc removed for Linux version "Hints":{pVersionElemsAllocBeg#Syntax10.Scn.Fnt Windows LinuxLinuxWindows$Syntax10i.Scn.Fnt(* Windows Version *)Linux pVersionElemsAllocEndSyntax10b.Scn.Fnt4\ 0PopupElemsAllocDefragmentizeSyntax10.Scn.Fnt Syntax10b.Scn.Fnt                           Defragmentizer.InstallTask ~ Defragmentizer.RemoveTask ~ Defragmentizer.Defragmentize ~ Defragmentizer.Defragmentize -1~ Defragmentizer.Defragmentize 2 ~ Defragmentizer.Defragmentize -2 ~ Defragmentizer.Defragmentize 5 ~ Defragmentizer.Defragmentize -5 ~ Defragmentizer.Defragmentize 10 ~ Defragmentizer.Defragmentize -10 ~ Defragmentizer.Defragmentize 20 ~ Defragmentizer.Defragmentize -20 ~ Defragmentizer.Defragmentize 40 ~ Defragmentizer.Defragmentize -40 ~[0PrintXSyntax10.Scn.Fnt Syntax10b.Scn.Fnt     HDefragmentizer.PrintObj Defragmentizer.PrintPtr Defragmentizer.PrintStat\ 0Unload modules<Syntax10b.Scn.Fnt Syntax10.Scn.Fnt%System.Free Defragmentizer Platform~0Compile#Syntax10.Scn.Fnt33Folds.Compile Platform.Mod/s Defragmentizer.Mod/s ~I,0AsciiCoder.CodeFilesCSyntax10.Scn.Fnt Syntax10b.Scn.Fnt L`AsciiCoder.CodeFiles % Defragmentizer.Mod Platform.Mod Defragmentizer.Text Defragmentizer.Tool ~x 0HeapInspectorJSyntax10.Scn.FntSyntax10b.Scn.Fnt1HeapInspector.HeapMap Kernel iOPT Win32 Texts* ~ `8FoldElemsNewSyntax10.Scn.FntSyntax10i.Scn.FntSyntax10b.Scn.Fnt    5m (* arrayBit = X.arrayBit;*) markBit = X.markBit; B = X.B; MP = 1; RP = 2; FO = 3; SP = 4; AP = 5; TM = 6; IM = 7; Ok = {}; Reset = Ok; StackAnchored = 0; NoDefrag = 1; TooLarge = 2; TooMuchPointers = 3; (* Options for Object *) IsArrayObj = 4; N = 9; NrOfLocks* = 32; NrOfObjects* = 512; NrOfPointers* = 8192; DNotInstalled = 0; DAfterGC = 1; DTask = 2;8Q8Syntax10.Scn.Fnt&8FoldElemsNew#Syntax10.Scn.Fnt]] oldAdr: ADDRESS; newAdr: ADDRESS; size: LONGINT; ref: INTEGER; options: SET; END;8;8#Syntax10.Scn.Fnt:: pAdr: ADDRESS; objNr: INTEGER; kind: INTEGER; END;8q38CSyntax10.Scn.FntSyntax10i.Scn.Fnt#R FinObjNode = RECORD (* Copied from Kernel.FinObjNode *) next: FinObj; obj: LONGINT; marked: BOOLEAN; fin: Kernel.Finalizer END; Syntax10i.Scn.Fnt8 8#Syntax10.Scn.Fnt== StackDesc = RECORD beg, end: LONGINT; next: Stack END;8 8#Syntax10.Scn.FntDD BlockDesc = RECORD lastElem, reserved, firstElem: ADDRESS; END;81 ADDRESS = LONGINT; Object = RECORD  ObjectList = ARRAY NrOfObjects OF Object; RPtr = RECORD  PtrList = ARRAY NrOfPointers OF RPtr; LockList = ARRAY NrOfLocks OF ADDRESS; FinObj = POINTER TO FinObjNode;  Like Kernel.FinObj  Stack = POINTER TO StackDesc;  Block = POINTER TO BlockDesc;  88|p#Syntax10.Scn.Fnt Windows LinuxLinuxWindows#Syntax10.Scn.FntWin32TypePatternDesc,Linux p|8M8CSyntax10.Scn.FntSyntax10i.Scn.FntVq (* Forward declarations *) PROCEDURE ^Init2 (); PROCEDURE ^InitObjs (); PROCEDURE ^CountFreeBlocks (): LONGINT; 8 b 8#Syntax10.Scn.Fnt:: VAR i, pos: INTEGER; BEGIN Out.String ("Printing moved objects:"); Out.Ln; pos := lBeg; FOR i := 0 TO nrOfObjs - 1 DO Out.Int (i, 5); Out.Int (objs [pos].oldAdr, 10); Out.Int (objs [pos].newAdr, 10); Out.Int (objs [pos].size, 10); Out.Int (objs [pos].ref, 5); IF StackAnchored IN objs [pos].options THEN Out.String (" Stack anchored") END; IF NoDefrag IN objs [pos].options THEN Out.String (" No defrag") END; IF TooLarge IN objs [pos].options THEN Out.String (" Too large") END; IF TooMuchPointers IN objs [pos].options THEN Out.String (" Too much pointers") END; IF IsArrayObj IN objs [pos].options THEN Out.String (" Array") END; IF (objs [pos].newAdr = 0) & (objs [pos].options = {}) THEN Out.String (" Defragmentation complete") END; Out.Ln; pos := (pos + 1) MOD NrOfObjects END END PrintObj; 8 b 98#Syntax10.Scn.Fnt VAR i, pos: INTEGER; BEGIN Out.String ("Printing addresses of anchoring pointers:"); Out.Ln; pos := 0; FOR i := 0 TO nrOfPtrs - 1 DO Out.Int (i, 5); Out.Int (ptrs [pos].pAdr, 10); Out.Int (ptrs [pos].objNr, 5); CASE ptrs [pos].kind OF MP: Out.String (" Module global pointer") | RP: Out.String (" Pointer in record") | FO: Out.String (" Pointer in finalize object") | SP: Out.String (" Pointer on the stack") | AP: Out.String (" Pointer in array") | TM: Out.String (" Modulepointer in typedesc") | IM: Out.String (" Modulepointer in importlist") ELSE Out.String (" ???") END; Out.Ln; pos := (pos + 1) MOD NrOfPointers END END PrintPtr; 8 b Z8#Syntax10.Scn.Fnt BEGIN Out.String ("Printing statistics:"); Out.Ln; Out.String ("Moved objects: "); Out.Int (objsMoved, 0); Out.Ln; Out.String ("Not moved objects: "); Out.Int (objsNMoved, 0); Out.Ln; Out.String ("Moved bytes: "); Out.Int (bytesMoved, 0); Out.Ln; Out.String ("Registered pointers: "); Out.Int (regPtrs, 0); Out.Ln; Out.String ("Max. registered pointers: "); Out.Int (regPtrsMax, 0); Out.Ln; Out.String ("Min. registered pointers: "); Out.Int (regPtrsMin, 0); Out.Ln; Out.String ("Number of free blocks: "); Out.Int (CountFreeBlocks (), 0); Out.Ln; Out.String ("Task-defragmentation done: "); Out.Int (cTask, 0); Out.Ln END PrintStat; 8 b8CSyntax10.Scn.FntSyntax10i.Scn.Fnt" VAR r: Ref.Rider; i, cnt: LONGINT; free: X.TypeFreeBlk; BEGIN Ref.OpenVars ("Kernel", r); WHILE (r.mode # Ref.End) & (r.name # "A") DO r.Next () END; IF r.mode = Ref.End THEN Out.String ("Variable: Kernel.A not found"); Out.Ln; HALT (99) END; r.Zoom (r); r.Next (); (* Go to first element of array *) cnt := 0; WHILE r.mode # Ref.End DO S.GET (r.base + r.off, free); WHILE free # NIL DO INC (cnt); free := S.VAL (X.TypeFreeBlk, free.next) END; r.Next () END; RETURN cnt END CountFreeBlocks; 8 bM$8 Syntax10.Scn.Fnt>Syntax10b.Scn.Fnt lSyntax10i.Scn.FntFFFFFFF8p h  " VAR i, j: INTEGER; BEGIN IF pVal < objs [0].oldAdr THEN RETURN FALSE ELSE j := NrOfObjects DIV 2; i := 0; IF objs [j].oldAdr <= pVal THEN INC (i, j) END; j := j DIV 2; (* 0 *) IF objs [i + j].oldAdr <= pVal THEN INC (i, j) END; j := j DIV 2; (* 1 *) IF objs [i + j].oldAdr <= pVal THEN INC (i, j) END; j := j DIV 2; (* 2 *) IF objs [i + j].oldAdr <= pVal THEN INC (i, j) END; j := j DIV 2; (* 3 *) IF objs [i + j].oldAdr <= pVal THEN INC (i, j) END; j := j DIV 2; (* 4 *) IF objs [i + j].oldAdr <= pVal THEN INC (i, j) END; j := j DIV 2; (* 5 *) IF objs [i + j].oldAdr <= pVal THEN INC (i, j) END; j := j DIV 2; (* 6 *) IF objs [i + j].oldAdr <= pVal THEN INC (i, j) END; j := j DIV 2; (* 7 *) IF objs [i + j].oldAdr <= pVal THEN INC (i, j) END; (* 8 *) (* i := 0; WHILE (i < nrOfObjs) & ((objs [i].oldAdr > pVal) OR ((objs [i].oldAdr + objs [i].size) <= pVal)) DO INC (i) END; *) oNr := i; IF (objs [i].oldAdr = pVal) & ((objs [i].options - {IsArrayObj}) = Ok) THEN lock := FALSE; RETURN TRUE ELSIF (objs [i].oldAdr <= pVal) & ((objs [i].oldAdr + objs [i].size) > pVal) THEN lock := TRUE; RETURN TRUE ELSE oNr := -1; RETURN FALSE END END END IsPtrToRegObj; 8 b"8-Yp#Syntax10.Scn.Fnt Windows LinuxLinuxWindows1Syntax10.Scn.Fnt'*OR (checkType = Win32TypePatternDesc)Linux p 8 b8%Syntax10.Scn.FntB8FoldElemsNew#Syntax10.Scn.Fntp, end: X.Blockm4Ptr; tdesc: X.Tag; kind, iterator: INTEGER; isDefrag: BOOLEAN; size, tAdr, freeSize, freeSizeC, freeCnt, maxFSize, objCnt, pFSC: LONGINT;8 VAR  BEGIN iterator := 0; isDefrag := FALSE; tAdr := 0; freeSize := 0; freeSizeC := 0; pFSC := 0; WHILE X.GetNextMemBlock (p, end, iterator) DO WHILE p # end DO tAdr := S.VAL (LONGINT, p) + 4; kind := X.GetObjType (S.VAL (S.PTR, tAdr), tdesc, size); IF (kind IN {X.TObj, X.TArrP}) & ~IsToLock (tAdr) THEN IF isDefrag & (maxFSize >= size) THEN INC (freeSizeC, pFSC); pFSC := 0; IF freeSizeC > 0 THEN INC (objCnt); DEC (freeSizeC, size); IF (freeSize DIV freeCnt) < size THEN maxFSize := (3 * maxFSize + freeSize DIV freeCnt) DIV 4 END END END ELSIF kind = X.TFree THEN INC (freeSize, size); INC (pFSC, size); INC (freeCnt); IF isDefrag THEN IF maxFSize < size THEN maxFSize := size END ELSE maxFSize := size; isDefrag := TRUE END END; INC (S.VAL (LONGINT, p), S.VAL (LONGINT, S.VAL (SET, size + B-1) - S.VAL (SET, B-1))) END END; RETURN (objCnt > 400) END CheckRegisterObjs; 8 b8Syntax10.Scn.Fnt]8FoldElemsNew#Syntax10.Scn.Fntp, end: X.Blockm4Ptr; tdesc: X.Tag; size, tAdr: LONGINT; i, k, kind, iterator: INTEGER; isDefrag: BOOLEAN; modType: Types.Type;8+8#Syntax10.Scn.FntGG VAR hlEnd, hlBeg, hNrOfObjects: LONGINT; BEGIN IF nrOfObjs = NrOfObjects THEN lBeg := (lBeg + 1) MOD NrOfObjects ELSE INC (nrOfObjs) END; hlEnd := lEnd; hlBeg := lBeg; hNrOfObjects := NrOfObjects; ASSERT (lEnd < NrOfObjects); objs [lEnd].newAdr := ptr; lEnd := (lEnd + 1) MOD NrOfObjects END RegisterObject; 89Syntax10i.Scn.FntA VAR  PROCEDURE RegisterObject (ptr: ADDRESS);  BEGIN modType := X.TypeOf (X.GetModules ()); iterator := 0; isDefrag := FALSE; tAdr := 0; WHILE X.GetNextMemBlock (p, end, iterator) DO WHILE p # end DO tAdr := S.VAL (LONGINT, p) + 4; kind := X.GetObjType (S.VAL (S.PTR, tAdr), tdesc, size); IF (kind IN {X.TObj, X.TArrP}) & ~IsToLock (tAdr) THEN IF isDefrag THEN RegisterObject (tAdr) END ELSIF kind = X.TFree THEN isDefrag := TRUE END; INC (S.VAL (LONGINT, p), S.VAL (LONGINT, S.VAL (SET, size + B-1) - S.VAL (SET, B-1))) END END; tdesc := NIL; end := NIL; p := NIL; modType := NIL; FOR i := 0 TO nrOfObjs - 1 DO (* Sort pointers (= Shift) *) k := (lBeg + i) MOD NrOfObjects; objs [i].oldAdr := objs [k].newAdr; objs [k].newAdr := 0; kind := X.GetObjType (S.VAL (S.PTR, objs [i].oldAdr), tdesc, size); IF kind = X.TArrP THEN objs [i].options := objs [i].options + {IsArrayObj} END; objs [i].size := size - 4; IF objs [i].size > 32000 THEN objs [i].options := objs [i].options + {TooLarge} END END; lEnd := i; lBeg := 0 END RegisterObjs; 8 b8ZSyntax10.Scn.FntR18FoldElemsNewSyntax10.Scn.Fnt8FoldElemsNew#Syntax10.Scn.Fnt\\ VAR i, max: INTEGER; BEGIN Out.Ln; Out.String ("Overflow: too much pointers to object:"); Out.Ln; max := 0; FOR i := 0 TO nrOfObjs DO objs [i].options := objs [i].options + {TooMuchPointers}; IF objs [i].ref > objs [max].ref THEN max := i END END; locks [nrOfLks] := objs [max].oldAdr; INC (nrOfLks) END LockObjects; 8iSyntax10b.Scn.FntK PROCEDURE LockObjects ();  BEGIN IF (nrOfPtrs > 0) & (ptrs [nrOfPtrs - 1].pAdr = pAdr) & (ptrs [nrOfPtrs - 1].kind = kind) THEN RETURN END; ptrs [nrOfPtrs].pAdr := pAdr; ptrs [nrOfPtrs].objNr := objNr; ptrs [nrOfPtrs].kind := kind; IF objNr >= 0 THEN INC (objs [objNr].ref); IF lock THEN objs [objNr].options := objs [objNr].options + {StackAnchored} END END; INC (nrOfPtrs); IF nrOfPtrs = NrOfPointers THEN LockObjects () END END RegisterPointer; 8N8#Syntax10.Scn.Fnt VAR mod: X.Module; n, i, objNr: INTEGER; pAdr, pVal: LONGINT; lock: BOOLEAN; BEGIN mod := X.GetModules (); WHILE mod # NIL DO n := X.GetNoOfPtrsInMod (mod); FOR i := 0 TO n - 1 DO pAdr := X.GetPtrInMod (mod, i); S.GET (pAdr, pVal); IF IsPtrToRegObj (pVal, objNr, lock) THEN RegisterPointer (pAdr, objNr, MP, lock) END; END; mod := mod.next END END RegModPtrs; 88%Syntax10.Scn.FntB8FoldElemsNew#Syntax10.Scn.Fntp, end: X.Blockm4Ptr; tdesc, size, val, pAdr, pVal, ptr, nOfElems, i, pOff, elemSize: LONGINT; kind, iterator, objNr: INTEGER; lock: BOOLEAN; arr: Block;87 VAR  BEGIN iterator := 0; WHILE X.GetNextMemBlock (p, end, iterator) DO WHILE p # end DO p.tag := S.VAL (X.Tag, S.VAL (SET, p.tag) - {markBit}); ptr := S.VAL (LONGINT, p) + 4; kind := X.GetObjType (S.VAL (S.PTR, ptr), S.VAL (X.Tag, tdesc), size); IF kind IN {X.TObj, X.TArrP} THEN IF kind = X.TArrP THEN arr := S.VAL (Block, ptr); S.GET (tdesc, elemSize); elemSize := S.VAL (LONGINT, S.VAL (SET, elemSize + 3) - S.VAL (SET, 3)); nOfElems := (arr.lastElem - arr.firstElem) DIV elemSize + 1; FOR i := 1 TO nOfElems DO S.GET (tdesc + 4, val); pOff := 4; WHILE val >= 0 DO pAdr := ptr + val; S.GET (pAdr, pVal); IF IsPtrToRegObj (pVal, objNr, lock) THEN RegisterPointer (pAdr, objNr, AP, lock) END; INC (pOff, 4); S.GET (tdesc + pOff, val) END; INC (ptr, elemSize) END ELSE INC (tdesc, 4); S.GET (tdesc, val); WHILE val >= 0 DO pAdr := ptr + val; S.GET (pAdr, pVal); IF IsPtrToRegObj (pVal, objNr, lock) THEN RegisterPointer (pAdr, objNr, RP, lock) END; INC (tdesc, 4); S.GET (tdesc, val) END END END; INC (S.VAL (LONGINT, p), S.VAL (LONGINT, S.VAL (SET, size + B-1) - S.VAL (SET, B-1))) END END END RegObjPtrs; 8B8QSyntax10.Scn.FntHSyntax10b.Scn.Fntjn VAR r: Ref.Rider; fin: FinObj; type: Types.Type; tdesc: X.Tag; size: LONGINT; objNr: INTEGER; lock: BOOLEAN; BEGIN Ref.OpenVars ("Kernel", r); WHILE (r.mode # Ref.End) & (r.name # "finObjs") DO r.Next () END; IF r.mode = Ref.End THEN Out.String ("Variable finObjs in module Kernel not found."); Out.Ln; HALT (99) END; r.ReadPtr (fin); WHILE fin # NIL DO IF X.GetObjType (S.VAL (S.PTR, fin.obj), tdesc, size) IN {X.TObj, X.TArrP} THEN IF IsPtrToRegObj (fin.obj, objNr, lock) THEN RegisterPointer (S.ADR (fin.obj), objNr, FO, lock) END END; fin := fin.next END END RegFinObjs; 88#Syntax10.Scn.Fnt VAR sp, p, i, beg: LONGINT; s, curStack, firstStack: Stack; r: Ref.Rider; objNr: INTEGER; lock: BOOLEAN; BEGIN Ref.OpenVars ("Kernel", r); WHILE (r.mode # Ref.End) & (r.name # "curStack") DO r.Next () END; ASSERT (r.mode # Ref.End); r.ReadPtr (curStack); Ref.OpenVars ("Kernel", r); WHILE (r.mode # Ref.End) & (r.name # "firstStack") DO r.Next () END; ASSERT (r.mode # Ref.End); r.ReadPtr (firstStack); S.GETREG (4, sp); curStack.end := sp; s := firstStack; WHILE s # NIL DO i := s.end; beg := s.beg; WHILE i < beg DO S.GET(i, p); IF IsPtrToRegObj (p, objNr, lock) THEN RegisterPointer (p, objNr, SP, TRUE) END; INC(i, 4) END; s := s.next END; END RegStackPtrs; 88&Syntax10.Scn.Fnts8FoldElemsNew#Syntax10.Scn.Fntkkr: Ref.Rider; type: Types.Type; tdesc: X.Tag; ptr, ptrAdr, size: LONGINT; objNr: INTEGER; lock: BOOLEAN;8Syntax10b.Scn.FntSyntax10i.Scn.Fnt.6 VAR  BEGIN Ref.OpenVars ("Files", r); WHILE (r.mode # Ref.End) & (r.name # "fileTab") DO r.Next () END; IF r.mode = Ref.End THEN Out.String ("Variable fileTab in module Files not found."); Out.Ln; HALT (99) END; r.Zoom (r); (* Zoom into array *) WHILE r.mode # Ref.End DO r.ReadLInt (ptr); ptrAdr := r.base + r.off; IF (ptr # 0) & (X.GetObjType (S.VAL (S.PTR, ptr), tdesc, size) = X.TObj) THEN IF IsPtrToRegObj (ptr, objNr, lock) THEN RegisterPointer (ptrAdr, objNr, FO, lock) END END; r.Next () END END RegFileObjs; 88Syntax10.Scn.Fnt}8FoldElemsNew#Syntax10.Scn.Fnt77 VAR i, n, adr: LONGINT; type: Types.Type; BEGIN n := X.GetNoOfTDsInMod (mod); adr := X.GetTDsInMod (mod); FOR i := 0 TO n - 1 DO S.GET (adr, type); S.GET (S.VAL (LONGINT, type) - 4, type); RegisterPointer (S.ADR (type.module), objNr, TM, lock); INC (adr, 4) END END RegModTypes; 8,>8CSyntax10.Scn.FntSyntax10i.Scn.Fnt VAR i, n, adr, imp: LONGINT; type: Types.Type; objNr: INTEGER; lock: BOOLEAN; BEGIN n := X.GetNoOfImportsInMod (mod); adr := X.GetImportsInMod (mod) + 4 * 4; (* ARRAY OF LONGINT *) FOR i := 0 TO n - 1 DO S.GET (adr, imp); IF IsPtrToRegObj (imp, objNr, lock) THEN RegisterPointer (adr, objNr, IM, lock) END; INC (adr, 4) END END RegModImports; 8 VAR mod: X.Module; objNr: INTEGER; lock: BOOLEAN; PROCEDURE RegModTypes (mod: X.Module; objNr: INTEGER; lock: BOOLEAN);  PROCEDURE RegModImports (mod: X.Module);  BEGIN mod := X.GetModules (); WHILE mod # NIL DO IF IsPtrToRegObj (S.VAL (ADDRESS, mod), objNr, lock) THEN RegModTypes (mod, objNr, lock) END; RegModImports (mod); mod := mod.next END END RegModDescs; 8 PROCEDURE RegisterPointer (pAdr: ADDRESS; objNr, kind: INTEGER; lock: BOOLEAN);  PROCEDURE RegModPtrs ();  PROCEDURE RegObjPtrs ();  PROCEDURE RegFinObjs ();  PROCEDURE RegStackPtrs ();  PROCEDURE RegFileObjs ();  PROCEDURE RegModDescs ();  BEGIN RegModPtrs (); RegObjPtrs (); RegFinObjs (); RegStackPtrs (); RegFileObjs (); (* RegModDescs (); *) INC (regPtrs, nrOfPtrs); IF nrOfPtrs > regPtrsMax THEN regPtrsMax := nrOfPtrs END; IF nrOfPtrs < regPtrsMin THEN regPtrsMin := nrOfPtrs END; END RegisterPtrs; 8 bp8Syntax10.Scn.Fnt\8FoldElemsNew#Syntax10.Scn.Fntr: Ref.Rider; p, end: X.Blockm4Ptr; tdesc: X.Tag; size: LONGINT; kind, iterator, i: INTEGER; lastFree, firstFree: X.TypeFreeBlk;8Syntax10i.Scn.Fnt[t VAR  BEGIN Ref.OpenVars ("Kernel", r); WHILE (r.mode # Ref.End) & (r.name # "A") DO r.Next () END; IF r.mode = Ref.End THEN Out.String ("Variable: Kernel.A not found"); Out.Ln END; r.Zoom (r); i := 0; WHILE i < N DO r.WriteLInt (0); r.Next (); INC (i) END; (* Clear all *) iterator := 0; firstFree := NIL; lastFree := NIL; WHILE X.GetNextMemBlock (p, end, iterator) DO WHILE p # end DO kind := X.GetObjType (S.VAL (S.PTR, S.VAL (LONGINT, p) + 4), tdesc, size); IF kind = X.TFree THEN IF firstFree = NIL THEN firstFree := S.VAL (X.TypeFreeBlk, p) END; IF lastFree # NIL THEN lastFree.next := S.VAL (LONGINT, p) END; lastFree := S.VAL (X.TypeFreeBlk, p) END; INC (S.VAL (LONGINT, p), S.VAL (LONGINT, S.VAL (SET, size + B-1) - S.VAL (SET, B-1))) END END; ASSERT (r.mode # Ref.End); r.WriteLInt (S.VAL (LONGINT, firstFree)) END SetNewToFirstFit; 8 b8qSyntax10.Scn.FntSyntax10i.Scn.FntSyntax10b.Scn.Fnt   VAR r: Ref.Rider; i: INTEGER; lastFree, curFree, sortFree: X.TypeFreeBlk; hh: INTEGER; BEGIN hh := 0; Ref.OpenVars ("Kernel", r); WHILE (r.mode # Ref.End) & (r.name # "A") DO r.Next () END; IF r.mode = Ref.End THEN Out.String ("Variable: Kernel.A not found"); Out.Ln END; r.Zoom (r); i := 0; sortFree := NIL; WHILE i < N DO IF sortFree = NIL THEN r.ReadLInt (S.VAL (LONGINT, sortFree)); r.WriteLInt (0) END; r.Next (); INC (i) END; (* Clear all (max 1 set) *) IF sortFree = NIL THEN hh := 1; r.ReadLInt (S.VAL (LONGINT, sortFree)); r.WriteLInt (sortFree.next) END; r.ReadLInt (S.VAL (LONGINT, curFree)); lastFree := NIL; WHILE (curFree # NIL) & (S.VAL (LONGINT, curFree) < S.VAL (LONGINT, sortFree)) DO lastFree := curFree; curFree := S.VAL (X.TypeFreeBlk, curFree.next) END; IF lastFree # NIL THEN lastFree.next := S.VAL (LONGINT, sortFree); sortFree.next := S.VAL (LONGINT, curFree); RETURN TRUE ELSE RETURN FALSE END END SortFreeBlks; 8 b8QSyntax10.Scn.FntSyntax10b.Scn.Fnt* VAR i, kind: INTEGER; type: Types.Type; tdesc, size, ptr, nOfDim, nOfElem, elemSize: LONGINT; arr: Block; BEGIN FOR i := nrOfObjs - 1 TO 0 BY -1 DO kind := X.GetObjType (S.VAL (S.PTR, objs [i].oldAdr), S.VAL (X.Tag, tdesc), size); IF (kind IN {X.TObj, X.TArrP}) & ((objs [i].options - {IsArrayObj}) = Ok) THEN type := Types.TypeOf (S.VAL (Kernel.Block, objs [i].oldAdr)); IF kind = X.TObj THEN Kernel.NewRec (S.VAL (Kernel.Tag, tdesc), objs [i].newAdr); ELSE arr := S.VAL (Block, objs [i].oldAdr); S.GET (tdesc, elemSize); elemSize := S.VAL (LONGINT, S.VAL (SET, elemSize + 3) - S.VAL (SET, 3)); nOfElem := (arr.lastElem - arr.firstElem) DIV elemSize + 1; nOfDim := (arr.firstElem - S.ADR (arr.firstElem) - 4) DIV 4; Kernel.NewArr (nOfDim, nOfElem, S.VAL (Kernel.Tag, tdesc), objs [i].newAdr) END; IF objs [i].newAdr > objs [i].oldAdr THEN IF ~SortFreeBlks () THEN RETURN END END END END END DuplicateRecs; 8 b8#Syntax10.Scn.Fnt++ VAR i, cnt: INTEGER; BEGIN cnt := 0; FOR i := 0 TO nrOfObjs - 1 DO IF objs [i].oldAdr < objs [i].newAdr THEN objs [i].options := objs [i].options + {NoDefrag}; objs [i].newAdr := 0 END; IF objs [i].newAdr = 0 THEN INC (cnt) END END; RETURN cnt < (nrOfObjs - 50) END CheckFragObjs; 8 b8#Syntax10.Scn.Fnt   VAR i, objNr: INTEGER; ptr: LONGINT; lock: BOOLEAN; BEGIN FOR i := 0 TO nrOfPtrs - 1 DO S.GET (ptrs [i].pAdr, ptr); IF IsPtrToRegObj (ptr, objNr, lock) & (objs [objNr].newAdr # 0) THEN S.PUT (ptrs [i].pAdr, objs [objNr].newAdr) END END END UpdatePtrs; 8 b 81Syntax10.Scn.Fnt VAR i: INTEGER; type: Types.Type; tdesc, size, ptr, diff: LONGINT; kind: INTEGER; arrO, arrN: Block; BEGIN FOR i := 0 TO nrOfObjs - 1 DO kind := X.GetObjType (S.VAL (S.PTR, objs [i].oldAdr), S.VAL (X.Tag, tdesc), size); IF (kind IN {X.TObj, X.TArrP}) & ((objs [i].options - {IsArrayObj}) = Ok) & (objs [i].newAdr # 0) THEN S.MOVE (objs [i].oldAdr, objs [i].newAdr, size - 4); INC (bytesMoved, size); INC (objsMoved); IF kind = X.TArrP THEN diff := objs [i].oldAdr - objs [i].newAdr; arrO := S.VAL (Block, objs [i].oldAdr); arrN := S.VAL (Block, objs [i].newAdr); arrN.lastElem := arrO.lastElem - diff; arrN.firstElem := arrO.firstElem - diff; END ELSE INC (objsNMoved) END END END CopyRecs; 8 b 8 Syntax10.Scn.FntR8FoldElemsNew#Syntax10.Scn.Fnt;; IF task # NIL THEN task.time := Input.Time () + 500 END;Syntax10i.Scn.Fnt8Syntax10b.Scn.Fnt2 VAR defragOk: BOOLEAN; n: INTEGER; BEGIN n := 0; IF ~CheckRegisterObjs () THEN  nothing to defragmentize  RETURN END; INC (cTask); n := 1; objsMoved := 0; regPtrs := 0; regPtrsMax := 0; regPtrsMin := MAX (INTEGER); bytesMoved := 0; objsNMoved := 0; Init2 (); n := 10; RegisterObjs (); RegisterPtrs (); SetNewToFirstFit (); DuplicateRecs (); (* After next GC => Best fit *) defragOk := CheckFragObjs (); n := 30; UpdatePtrs (); CopyRecs (); Kernel.GC; n := 40; IF task # NIL THEN task.time := Input.Time () + 1000 END; n := 50 END DefragAuto; 8 6M  +8cSyntax10.Scn.FntSyntax10b.Scn.FntSyntax10i.Scn.Fnt,s BEGIN IF isInGC THEN RETURN END; isInGC := TRUE; (* Critical Area *) DefragAuto; isInGC := FALSE END AfterGC; 8 bU8#Syntax10.Scn.Fnt VAR n, i: INTEGER; printIt, defragOk: BOOLEAN; BEGIN IF installedAs = DAfterGC THEN Kernel.afterQ.Remove (AfterGC) END; objsMoved := 0; regPtrs := 0; regPtrsMax := 0; regPtrsMin := MAX (INTEGER); nrOfLks := 0; bytesMoved := 0; objsNMoved := 0; lEnd := 0; lBeg := 0; nrOfObjs := 0; In.Open; IF In.Next () = In.int THEN In.Int (n) ELSE n := 1 END; printIt := n < 0; IF printIt THEN n := -n END; i := 1; defragOk := TRUE; WHILE (i <= n) & defragOk DO Init2 (); Kernel.GC; RegisterObjs (); RegisterPtrs (); SetNewToFirstFit (); DuplicateRecs (); defragOk := CheckFragObjs (); UpdatePtrs (); CopyRecs (); IF printIt THEN Out.Char ('.') END; IF ~defragOk THEN Out.String ("Memory is completely defragmented."); Out.Ln END; INC (i) END; IF printIt & defragOk THEN Out.Ln END; Kernel.GC; IF installedAs = DAfterGC THEN Kernel.afterQ.Add (AfterGC) END; END Defragmentize; 8 b J8CSyntax10.Scn.FntiSyntax10b.Scn.Fntt BEGIN IF installedAs # DNotInstalled THEN Out.String ("Defragmentizer is already installed."); Out.Ln; RETURN END; installedAs := DTask; IF task # NIL THEN HALT (99) END; NEW (task); task.safe := FALSE; task.handle := DefragAuto; task.time := Input.Time () + 1000; Oberon.Install (task); Out.String ("Installing Defragmentizer as task."); Out.Ln END InstallTask; 8 b 8CSyntax10.Scn.FnteSyntax10b.Scn.Fnto BEGIN IF installedAs # DTask THEN Out.String ("Defragmentizer is not as Task installed."); Out.Ln; RETURN END; installedAs := DNotInstalled; IF task # NIL THEN Oberon.Remove (task); task := NIL END END RemoveTask; 8 be8cSyntax10.Scn.FntiSyntax10b.Scn.FntASyntax10i.Scn.Fnt!h9 BEGIN IF installedAs # DNotInstalled THEN Out.String ("Defragmentizer is already installed."); Out.Ln; RETURN END; installedAs := DAfterGC; Kernel.afterQ.Remove (AfterGC); (* If it was already installed *) Kernel.afterQ.Add (AfterGC); Out.String ("Installing Defragmentizer after GC."); Out.Ln END Install; 8 b8CSyntax10.Scn.FntiSyntax10b.Scn.FntQ BEGIN IF installedAs # DAfterGC THEN Out.String ("Defragmentizer is not after GC installed."); Out.Ln; RETURN END; installedAs := DNotInstalled; Kernel.afterQ.Remove (AfterGC) END Remove; 8 b i8#Syntax10.Scn.Fntuu BEGIN CASE installedAs OF DTask: RemoveTask | DAfterGC: Remove ELSE (* Not installed *) END END TermHandler; 8 b 8#Syntax10.Scn.Fnt VAR i: INTEGER; BEGIN FOR i := 0 TO NrOfObjects - 1 DO objs [i].oldAdr := S.VAL (ADDRESS, NIL); objs [i].newAdr := S.VAL (ADDRESS, NIL); objs [i].size := 0; objs [i].ref := 0; objs [i].options := Reset END; lBeg := 0; lEnd := 0; nrOfObjs := 0; END InitObjs; 8 b !8#Syntax10.Scn.Fnt VAR i: INTEGER; BEGIN InitObjs (); FOR i := 0 TO NrOfPointers - 1 DO ptrs [i].pAdr := S.VAL (ADDRESS, NIL); ptrs [i].objNr := 0; ptrs [i].kind := 0; END; nrOfPtrs := 0 END Init2; 8 b 8-p#Syntax10.Scn.Fnt Windows LinuxLinuxWindows*Syntax10.Scn.Fnt Ref.OpenTypes ("Win32", r); WHILE (r.mode # Ref.End) & (r.name # "PatternDesc") DO r.Next () END; IF r.mode = Ref.End THEN Out.String ("Type: Win32.PatternDesc not found"); Out.Ln END; Win32TypePatternDesc := r.type;Linux p8$MODULE Defragmentizer; (* Defragmentizer by MR, 20 Feb 97 -   *) (* Powered by Linux *)       IMPORT S := SYSTEM, X := Platform, Kernel, Modules, Types, Ref, Oberon, Out, In, Input; CONST  TYPE  VAR  objs: ObjectList; lBeg, lEnd, nrOfObjs: INTEGER; ptrs: PtrList; nrOfPtrs: INTEGER; locks: LockList; nrOfLks: INTEGER; objsMoved, objsNMoved, regPtrs, regPtrsMax, regPtrsMin: INTEGER; cTask, bytesMoved: LONGINT;  FilesTypeFile, TypeModule: Types.Type; freeBlksOld: LONGINT; task: Oberon.Task; isInGC: BOOLEAN; installedAs: INTEGER;   (* Forward declarations *)  PROCEDURE PrintObj*;  PROCEDURE PrintPtr*;  PROCEDURE PrintStat*;  PROCEDURE CountFreeBlocks (): LONGINT;  PROCEDURE IsPtrToRegObj (pVal: ADDRESS; VAR oNr: INTEGER; VAR lock: BOOLEAN): BOOLEAN;  PROCEDURE IsToLock (ptr: ADDRESS): BOOLEAN;  VAR checkType: Types.Type; i: INTEGER; BEGIN i := 0; WHILE (i < nrOfLks) & (locks [i] # S.VAL (LONGINT, ptr)) DO INC (i) END; checkType := X.TypeOf (S.VAL (S.PTR, ptr)); RETURN (i < nrOfLks) OR (TypeModule = X.TypeOf (S.VAL (S.PTR, ptr)))  (* File "Win32.Mod": Pattern* = LONGINT (* = PatternPtr *); *) END IsToLock;  PROCEDURE CheckRegisterObjs (): BOOLEAN;  PROCEDURE RegisterObjs ();  PROCEDURE RegisterPtrs ();  PROCEDURE SetNewToFirstFit*;  PROCEDURE SortFreeBlks (): BOOLEAN;  PROCEDURE DuplicateRecs ();  PROCEDURE CheckFragObjs (): BOOLEAN;  PROCEDURE UpdatePtrs ();  PROCEDURE CopyRecs ();  PROCEDURE DefragAuto;  PROCEDURE AfterGC;  PROCEDURE Defragmentize*;  PROCEDURE InstallTask*;  PROCEDURE RemoveTask*;  PROCEDURE Install*;  PROCEDURE Remove*;  PROCEDURE TermHandler;  PROCEDURE InitObjs ();  PROCEDURE Init2 ();  PROCEDURE Init ();  VAR r: Ref.Rider; BEGIN Out.String ("Defragmentizer by MR."); Out.Ln; Init2 (); cTask := 0; Ref.OpenTypes ("Files", r); WHILE (r.mode # Ref.End) & (r.name # "Handle") DO r.Next () END; IF r.mode = Ref.End THEN Out.String ("Type: Files.Handle not found"); Out.Ln END; FilesTypeFile := r.type;  TypeModule := X.TypeOf (X.GetModules ()); X.InstallTermHandler (TermHandler, NIL, NIL); isInGC := FALSE; installedAs := DNotInstalled END Init;  BEGIN Init () END Defragmentizer.