home *** CD-ROM | disk | FTP | other *** search
/ Amiga ISO Collection / AmigaUtilCD2.iso / Programming / Misc / OB3.2D2.DMS / in.adf / Module / GarbageCollector.mod < prev    next >
Encoding:
Text File  |  1994-08-05  |  28.0 KB  |  977 lines
  1. (*-------------------------------------------------------------------------*)
  2. (*                                                                         *)
  3. (*  Amiga Oberon Library Module: GarbageCollector     Date: 02-Nov-92      *)
  4. (*                                                                         *)
  5. (*   © 1992 by Fridtjof Siebert                                            *)
  6. (*                                                                         *)
  7. (*-------------------------------------------------------------------------*)
  8.  
  9.  
  10. MODULE GarbageCollector;
  11.  
  12. IMPORT Intuition,
  13.        Exec*,
  14.        OberonLib,
  15.        SYSTEM*;
  16.  
  17.  
  18. CONST
  19.  
  20. (*
  21.  * many ist einfach eine große Integer-Konstante
  22.  *)
  23.  
  24.   many * = MAX(LONGINT) DIV 8;
  25.  
  26.  
  27. TYPE
  28.  
  29. (*
  30.  * Big ist einfach ein großes Feld von Zeigern oder LONGINT-Werten
  31.  *)
  32.  
  33.   Big * = ARRAY many OF SYSTEM.ADDRESS;
  34.  
  35.  
  36. (* ---  Informationen über Typen:  --- *)
  37.  
  38.  
  39.   ObjectTypePtr * = UNTRACED POINTER TO ObjectType;
  40.   ObjectType * = STRUCT
  41.     id * : LONGINT;       (* Zur Unterscheidung der verschiedenen arten von
  42.                            * allozierten Objekten
  43.                            *)
  44.   END;
  45.  
  46.  
  47. (* ---  Einfache Typen (RECORDs):  --- *)
  48.  
  49.  
  50. CONST
  51.   usualObject * = 1;
  52.  
  53. TYPE
  54.   UsualObjectTypePtr * = UNTRACED POINTER TO UsualObjectType;
  55.   UsualObjectType * = STRUCT
  56.    (bt      * : ObjectType)   (* INVARIANT: bt.id = usualObject                       *)
  57.     size    * : LONGINT;      (* Größe des zu allozierenden Objects                   *)
  58.     numRefs * : LONGINT;      (* Anzahl der von diesem Object ausgehenden Referenzen  *)
  59.     refs    * : Big;          (* Offsets der von diesem Object ausgehenden Referenzen *)
  60.   END;
  61.  
  62.  
  63. (* ---  Offene Felder:  --- *)
  64.  
  65.  
  66. CONST
  67.   openArrayObject * = 2;
  68.  
  69. TYPE
  70.   OpenArrayObjectType * = STRUCT
  71.  
  72.   (*
  73.    * Alle Objecte, die mit diesem Typ alloziert werden, müssen mit
  74.    * AllocOpenArray() alloziert werden.
  75.    *
  76.    * Die Objekte selbst sind dann vom Typ OpenArrayObject und enthalten als
  77.    * ersten Eintrag die Anzahl der Elemente des Feldes.
  78.    *)
  79.  
  80.    (bt      * : ObjectType)   (* INVARIANT: bt.id = openArrayObject                  *)
  81.     size    * : LONGINT;      (* Größe der einzelnen Elemente                        *)
  82.     numRefs * : LONGINT;      (* Anzahl der von jedem Feldelement ausgehenden
  83.                                * Referenzen
  84.                                *)
  85.     refs    * : Big;          (* Offsets der von jedem Feldelement ausgehenden
  86.                                * Referenzen
  87.                                *)
  88.   END;
  89.  
  90.  
  91. (* ---  Interne Liste der ObjectTypes:  --- *)
  92.  
  93.  
  94.   MutatorPtr * = UNTRACED POINTER TO Mutator;
  95.  
  96.   InternalObjectTypePtr * = UNTRACED POINTER TO InternalObjectType;
  97.   InternalObjectType * = STRUCT
  98.     next     : InternalObjectTypePtr; (* Link                                   *)
  99.     usecount : LONGINT;               (* Referenzenzzählter auf diese Struktur
  100.                                        * Da InternalObjectTypes nicht auf
  101.                                        * ihresgleichen zeigen können, können
  102.                                        * keine Zykel entstehen, so daß mit einem
  103.                                        * Referenzzähler leicht ihre Lebensdauer
  104.                                        * bestimmt werden kann.
  105.                                        * Solange der Mutator exisitiert, ist
  106.                                        * auf jeden Fall usecount >= 1.
  107.                                        *)
  108.     mutator  : MutatorPtr;            (* Mutator, dem dieser Typ gehört         *)
  109.     bt      -: ObjectType;            (* Die eigentliche ObjectType-Struktur, je
  110.                                        * nach bt.id erweitert.
  111.                                        *)
  112.   END;
  113.  
  114.  
  115. (* ---  Informationen über Variablen:  --- *)
  116.  
  117.  
  118. (* Dieses Record muß innerhald des betroffenen Variablenbereichs liegen.
  119.  * die in Vars.typ enthaltenen Offsets für Zeiger sind relativ zu
  120.  * ADR(Vars)!
  121.  *)
  122.  
  123.   VarsPtr * = UNTRACED POINTER TO Vars;
  124.   Vars * = STRUCT
  125.     next*: VarsPtr;       (* internal link *)
  126.     typ *: UsualObjectTypePtr;
  127.                           (* Typinformationen. Da ein Variablenbereich nicht
  128.                            * länger existieren darf als der dazugehörende
  129.                            * Mutator, zeigt typ direkt auf den ObjectType,
  130.                            * nicht auf ein extra alloziertes Typ-Objekt.
  131.                            *)
  132.   END;
  133.  
  134.  
  135. (* ---  Informationen über Mutatoren:  --- *)
  136.  
  137.  
  138.   Mutator * = STRUCT
  139.     next       ,
  140.     prev       : MutatorPtr;           (* wird bei AddMutator() gesetzt    *)
  141.     globals   *: VarsPtr;              (* Liste der globalen Variablen     *)
  142.     locals    *: VarsPtr;              (* Liste der lokalen Variablen      *)
  143.     blockinfos : InternalObjectTypePtr;
  144.                                        (* Liste der allozierten ObjectTypes
  145.                                         *)
  146.     replyPort  : Exec.MsgPortPtr;      (* Zur Kommuniktion mit dem Garbage-
  147.                                         * Collector-Task
  148.                                         *)
  149.     msg        : Exec.MessagePtr;
  150.   END;
  151.  
  152.  
  153. (* ---  Informationen über allozierte Objekte:  --- *)
  154.  
  155.  
  156.   ObjectPtr * = UNTRACED POINTER TO Object;
  157.   Object * = STRUCT
  158.  
  159.     next  -: ObjectPtr;    (* über diesen Zeiger sind die Objekte
  160.                             * einer Liste miteinander verbunden.
  161.                             *)
  162.  
  163.     flags *: SET;          (* Flags, können mit AllocFlag() alloziert
  164.                             * werden, um global Objekte zu markieren.
  165.                             *)
  166.  
  167.     shade *: SET;          (* Schattierung dieses Objektes. "0 IN shade"
  168.                             * gibt an, ob das Objekt grau ist.
  169.                             * "shade * (-{0})" ist die pink-Schattierung des
  170.                             * Objektes (shade muß dabei vorzeichenlos
  171.                             * interpretiert werden).
  172.                             *)
  173.  
  174.     typ   -: InternalObjectTypePtr;
  175.                            (* Typ dieses Objekts. Da ein Objekt länger leben
  176.                             * kann als der Mutator, der es alloziert hat,
  177.                             *)
  178.  
  179.     mem   *: Big;          (* hier beginnt der Speicher für den User.
  180.                             * Alloc() und AllocOpenArray() ergeben einen
  181.                             * Zeiger auf dieses Element.
  182.                             *)
  183.  
  184.   END;
  185.  
  186.  
  187. (* ---  Informationen über allozierte Objekte:  --- *)
  188.  
  189.  
  190.   OpenArrayObjectPtr * = UNTRACED POINTER TO OpenArrayObject;
  191.   OpenArrayObject * = STRUCT
  192.  
  193.     length - : LONGINT;    (* Anzahl Elemente dieses Objekts.
  194.                             *)
  195.  
  196.     object * : Object;     (* Das eigentliche Object, enthält auch den eigentlichen
  197.                             * Speicher.
  198.                             *
  199.                             * invariant
  200.                             *   object.typ.bt.id = openArrayType
  201.                             *
  202.                             *)
  203.  
  204.   END;
  205.  
  206.  
  207. CONST
  208.  
  209.   shadeOffset    * = - 6;  (* Offset von Object.shade von Object.mem aus.
  210.                             * Beim Pink-schattieren muß
  211.                             *
  212.                             *   ADDQ.W  #pink,shadeOffset(Object)
  213.                             *
  214.                             * ausgeführt werden, wobei 'Object' ein Adreß-
  215.                             * register ist, das einen Zeiger auf ein Objekt
  216.                             * enthält.
  217.                             *)
  218.   byteGrayOffset * = - 5;  (* Offset des untersten Bytes von Objekt.flags.
  219.                             * Beim Grauschattiren muß
  220.                             *
  221.                             *   BSET.B  #gray,byteGrayOffset(Object)
  222.                             *
  223.                             * ausgeführt werden, wobei 'Object' ein Adreß-
  224.                             * register ist, das einen Zeiger auf ein Objekt
  225.                             * enthält.
  226.                             *)
  227.  
  228.  
  229. (* Objekt.shades *)
  230.   gray      * = 0;         (* Bitnummer des Grau-Bits                      *)
  231.   pink      * = 2;         (* Beim pink-Schattieren zu addierender Wert    *)
  232.  
  233.   black       = 15;
  234.   (* Gesetzt bei allen Objekten, die schwarz markiert sind. Dabei muß
  235.    * folgende Bedingung immer erfüllt sein:
  236.    *
  237.    *   P: Kein schwarzes Element darf auf ein weißes Element zeigen.
  238.    *
  239.    * Um dies zu erreichen, müssen
  240.    *
  241.    *   a) Alle Mutatoren vor einer Zuweisung "p := q" q grau markieren
  242.    *
  243.    *   b) Es muß sichergestellt sein, das der Collector q nicht weiß
  244.    *      markiert, bevor eine Zuweisung "p := q" vollständig aus-
  245.    *      geführt ist (d.h. slange q pink schattiert ist)
  246.    *
  247.    *   c) Während des Markierungsprozeßes werden alle Objekte, auf die ein
  248.    *      graues Objekt zeigt, mit grau markiert, bevor das Objekt selbst
  249.    *      schwarz markiert wird.
  250.    *
  251.    *)
  252.  
  253.  
  254.  
  255.  
  256.  
  257. (*
  258.  * Der Mutator (das Programm, das Speicher vom Garbage-Collector alloziert)
  259.  * muß bei jeder Zuweisung
  260.  *
  261.  *   p := q;
  262.  *
  263.  * bei der p und q verfolgte Referenzen sind, folgenden Code erzeugen:
  264.  *
  265.  *       move.l   q,Ax;
  266.  *       addq.w   #pink,shade(Ax);
  267.  *       bset.b   #gray,byteGrayOffset(Ax);
  268.  *       move.l   Ax,p;
  269.  *       subq.w   #pink,shade(Ax);
  270.  *
  271.  * oder, wenn q NIL sein kann:
  272.  *
  273.  *       move.l   q,Ax;
  274.  *       move.l   Ax,Dy
  275.  *       beq.s    nil;
  276.  *       addq.w   #pink,shade(Ax);
  277.  *       bset.b   #gray,byteGrayOffset(Ax);
  278.  * nil:  move.l   Ax,p;
  279.  *       move.l   Ax,Dy;                       (+)
  280.  *       beq.s    nil2;
  281.  *       subq.w   #pink,shade(Ax);
  282.  * nil2:
  283.  *
  284.  * (Die Anweisung (+) kann weggelassen werden, wenn p kein Adreßregister ist)
  285.  *
  286.  * Dieser Code ist wichtig, da sonst hängende Referenzen entstehen können, da
  287.  * der Garbage-Collector evtl. nicht erkennen kann, das hier eine neue
  288.  * Referenz auf q entsteht.
  289.  *
  290.  * Folgendes muß erfüllt sein:
  291.  *
  292.  * R: a) Bevor in q Grau gesetzt wird, muß q pink schattiert werden. Ansonsten
  293.  *       wird die grau-Markierung sofort wieder ungültig.
  294.  *    b) zwischen der grau-Markierung und der Zuweisung an p darf die pink-
  295.  *       Schattierung nicht entfernt werden, da sonst die grau-Markierung
  296.  *       ungültig wird
  297.  *    c) nach der Zuweisung muß die pink-Schattierung wieder entfernt werden
  298.  *    d) Es dürfen keine zwei Objekte vom gleichen Mutator gleichzeitig pink
  299.  *       schattiert sein.
  300.  *    e) Das selbe Objekt darf nicht mehrmals vom gleichen Mutator pink
  301.  *       schattiert sein.
  302.  *
  303.  *)
  304.  
  305.  
  306. (* ---  Globale Variablen:  --- *)
  307.  
  308. (*
  309.  * Die Variablen dürfen nur innerhalb von Forbid() und Permit() verändert
  310.  * werden.
  311.  *)
  312.  
  313. CONST
  314.  
  315.   MaxMutators * = 3FFFH;
  316.   (*
  317.    * Es darf maximal MaxMutators Mutatoren geben.
  318.    *)
  319.  
  320.  
  321. TYPE
  322.  
  323. (*
  324.  * Unsere Library-Base-Struktur.
  325.  *)
  326.  
  327.   GarbageCollectorBasePtr * = UNTRACED POINTER TO GarbageCollectorBase;
  328.  
  329.   GarbageCollectorBase * = STRUCT
  330.  
  331.    (libNode       - : Exec.Library)    (* gewöhnlicher Library-Knoten    *)
  332.  
  333.   (*
  334.    * Folgende Elemente dienen nur der Statistik und der Untersuchung
  335.    * des Laufzeitverhaltens des Collectors und der Mutatoren:
  336.    *)
  337.  
  338.     activeObjects - : LONGINT;         (* derzeit lebendige Objekte      *)
  339.     deadObjects   - : LONGINT;         (* derzeit tote Objekte           *)
  340.     totalMem      - : LONGINT;         (* insgesamt allozierter Speicher *)
  341.  
  342.     cycleCount    - : LONGINT;         (* Nummer dieses GC-Zyklus        *)
  343.  
  344.   END;
  345.  
  346.  
  347. VAR
  348.  
  349.   base - : GarbageCollectorBasePtr;
  350.  
  351.   mutator * : Mutator;
  352.  
  353.   mutatorValid - : BOOLEAN;
  354.  
  355.  
  356. (*-------------------------------------------------------------------------*)
  357. (*                                                                         *)
  358. (*                               Macros:                                   *)
  359. (*                                                                         *)
  360. (*-------------------------------------------------------------------------*)
  361.  
  362.  
  363. (* ---  AddGlobals:  --- *)
  364.  
  365.  
  366. PROCEDURE AddGlobals*(VAR mutator{8}: Mutator; adr{9}: VarsPtr);
  367. (* Fügt einen globalen Bereich mit verfolgten Referenzen hinzu.
  368.  * Alle Referenzen müssen mit NIL vorinitialisiert sein.
  369.  * adr      muß in den Bereich der Variablen auf eine Vars-Struktur zeigen.
  370.  * adr.typ  muß auf eine ObjectType-Struktur zeigen. Die Offsets in ObjectType
  371.  *          sind relativ zu adr.
  372.  * adr.next Wird als Link zum nächsten Variablen-Feld verwendet und von
  373.  *          dieser Prozedur verändert.
  374.  *)
  375.  
  376. BEGIN
  377.   adr.next   := mutator.globals;
  378.   mutator.globals := adr;
  379. END AddGlobals;
  380.  
  381.  
  382. (* ---  RemGlobals:  --- *)
  383.  
  384.  
  385. PROCEDURE RemGlobals*(VAR mutator{8}: Mutator);
  386. (* entfernt den zuletzt mit AddGlobalss() hinzugefügten Variablenbereich
  387.  *)
  388.  
  389. BEGIN
  390.   mutator.globals := mutator.globals.next;
  391. END RemGlobals;
  392.  
  393.  
  394. (* ---  AddLocals:  --- *)
  395.  
  396.  
  397. PROCEDURE AddLocals*(VAR mutator{8}: Mutator; adr{9}: VarsPtr);
  398. (* Fügt einen lokalen Bereich mit verfolgten Referenzen hinzu.
  399.  * Alle Referenzen müssen mit NIL vorinitialisiert sein.
  400.  * adr      muß in den Bereich der Variablen auf eine Vars-Struktur zeigen.
  401.  * adr.typ  muß auf eine ObjectType-Struktur zeigen. Die Offsets in ObjectType
  402.  *          sind relativ zu adr.
  403.  * adr.next Wird als Link zum nächsten Variablen-Feld verwendet und von
  404.  *          dieser Prozedur verändert.
  405.  *)
  406.  
  407. BEGIN
  408.   adr.next  := mutator.locals;
  409.   mutator.locals := adr;
  410. END AddLocals;
  411.  
  412.  
  413. (* ---  RemLocals:  --- *)
  414.  
  415.  
  416. PROCEDURE RemLocals*(VAR mutator{8}: Mutator);
  417. (* Entfernt den zuletzt mit AddLocals() hinzugefügten Variablenbbereich
  418.  *)
  419.  
  420. BEGIN
  421.   mutator.locals := mutator.locals.next;
  422. END RemLocals;
  423.  
  424.  
  425. (* ---  RemLocals:  --- *)
  426.  
  427.  
  428. PROCEDURE RemAllLocals*(VAR mutator{8}: Mutator);
  429. (* Entfernt alle mit AddLocals() hinzugefügten Variablenbbereiche
  430.  *)
  431.  
  432. BEGIN
  433.   mutator.locals := NIL;
  434. END RemAllLocals;
  435.  
  436.  
  437. (* ---  Routinen der Library:  --- *)
  438.  
  439.  
  440. PROCEDURE AddGlobalsLib   * {base,-   30}(VAR  mutator{8}: Mutator;
  441.                                                adr{9}: VarsPtr);
  442. PROCEDURE RemGlobalsLib   * {base,-   36}(VAR  mutator{8}: Mutator);
  443. PROCEDURE AddLocalsLib    * {base,-   42}(VAR  mutator{8}: Mutator;
  444.                                                adr{9}: VarsPtr);
  445. PROCEDURE RemLocalsLib    * {base,-   48}(VAR  mutator{8}: Mutator);
  446. PROCEDURE RemAllLocalsLib * {base,-   54}(VAR  mutator{8}: Mutator);
  447.  
  448.  
  449. (* ---  AddMutator / RemMutator:  --- *)
  450.  
  451.  
  452. PROCEDURE AddMutator        * {base,-   60}(VAR  mutator{8}: Mutator): BOOLEAN;
  453. (* Mutator ist für die identifikation der Variablen eines Tasks nötig.
  454.  * Bevor es verwendet werden kann, muß es mit AddMutator dem Garbage-Collector
  455.  * übergeben werden.
  456.  *)
  457.  
  458. PROCEDURE RemMutator        * {base,-   66}(VAR  mutator{8}: Mutator);
  459. (* Entfernt Mutator aus der Mutator-Liste.
  460.  * RemMutator darf nur aufgerufen, nachdem es mit AddMutator() zur Mutator-Liste hinzugefügt
  461.  * wurde.
  462.  * Nach RemMutator darf mutator nicht mehr als mutator-Parameter für die anderen Prozeduren,
  463.  * mit der Ausnahme von AddMutator(), verwendet werden.
  464.  *)
  465.  
  466.  
  467. (* ---  AllocType:  --- *)
  468.  
  469.  
  470. PROCEDURE AllocType    * {base,-   72}(VAR mutator {8}: Mutator;
  471.                                            typ{9}: ObjectTypePtr): InternalObjectTypePtr;
  472. (*
  473.  * Es wird Speicher für eine InternalObjectType-Struktur alloziert. Diese
  474.  * Wird beim Allozieren von Objekten mit Alloc() nötig.
  475.  *
  476.  * Da die allozierten Objekte länger leben können als die Programme, die sie
  477.  * alloziert haben, dürfen die ObjectTypes nicht im Datenbereich der Programme
  478.  * liegen, sondern müssen extra alloziert werden.
  479.  *
  480.  * Ihr Speicher wird automatisch freigegeben, sobald der angegebene Mutator mit
  481.  * RemMutator(mutator) entfernt wurde und keine Objekt mehr von diesem Typ ist.
  482.  *
  483.  * Hat das System keinen freien Speicher mehr, wird das Ergebnis auf NIL
  484.  * gesetzt. Bevor dies geschieht, wird der aktuelle Garbage-Collection-Zyklus
  485.  * beendet, d.h. das ein Aufruf dieser Prozedur bei Speichermangel
  486.  * (SEHR) lange dauern kann.
  487.  *)
  488.  
  489.  
  490. (* ---  Alloc:  --- *)
  491.  
  492.  
  493. PROCEDURE Alloc        * {base,-   78}(    typ{8}: InternalObjectTypePtr;
  494.                                        VAR adr{9}: SYSTEM.ADDRESS);
  495. (*
  496.  * Alloziert ein Object des gewählten Typs
  497.  *
  498.  * adr MUSS dabei eine verfolgte Variable sein, da die Adresse sonst
  499.  * sofort wieder ungültig wäre, da das Object bei der nächsten Garbage-.
  500.  * Collection gleich wieder eingesammelt wird.
  501.  *
  502.  * Hat das System keinen freien Speicher mehr, wird adr auf NIL gesetzt.
  503.  * Bevor dies geschieht, wird der aktuelle Garbage-Collection-Zyklus
  504.  * beendet, d.h. das ein Aufruf dieser Prozedur bei Speichermangel
  505.  * (SEHR) lange dauern kann.
  506.  *)
  507.  
  508.  
  509. (* ---  NewPreferences:  --- *)
  510.  
  511.  
  512. PROCEDURE NewPreferences*{base,-   84};
  513. (*
  514.  * Teilt der Library mit, daß es neue Preferences in ENV: gibt und daß diese
  515.  * baldmöglichst geladen werden sollen.
  516.  *
  517.  * Die neuen Preferences werden immer dann geladen, wenn die Library das erste
  518.  * mal geöffnet wird, dh. wenn ihr OpenCnt von 0 auf 1 springt.
  519.  *
  520.  *)
  521.  
  522.  
  523. (* ---  AllocOpenArray:  --- *)
  524.  
  525.  
  526. PROCEDURE AllocOpenArray*{base,-   90}(    typ{8}: InternalObjectTypePtr;
  527.                                        VAR adr{9}: SYSTEM.ADDRESS;
  528.                                         length{2}: LONGINT);
  529. (*
  530.  * Alloziert ein Object eine offenen Feldtyps mit size Elementen.
  531.  *
  532.  * adr MUSS dabei eine verfolgte Variable sein, da die Adresse sonst
  533.  * sofort wieder ungültig wäre, da das Object bei der nächsten Garbage-.
  534.  * Collection gleich wieder eingesammelt wird.
  535.  *
  536.  * Hat das System keinen freien Speicher mehr, wird adr auf NIL gesetzt.
  537.  * Bevor dies geschieht, wird der aktuelle Garbage-Collection-Zyklus
  538.  * beendet, d.h. das ein Aufruf dieser Prozedur bei Speichermangel
  539.  * (SEHR) lange dauern kann.
  540.  *)
  541.  
  542.  
  543. (* ---  WaitForCollector:  --- *)
  544.  
  545.  
  546. PROCEDURE WaitForCollector * {base,-   96}(id{8}: MutatorPtr);
  547. (*
  548.  * Wartet bis der nächste Garbage-Collector-Zyklus beendet ist. Dabei wird
  549.  * die Priorität des Collectors bis der Zyklus beendet ist auf die dieses
  550.  * Tasks gesetzt.
  551.  *
  552.  * Wenn man sicher gehen möchte, daß man mindestens einen kompletten Zyklus
  553.  * wartet, muß man diese Routine 2 mal nacheinander aufrufen.
  554.  *)
  555.  
  556.  
  557. (* ---  AllocFlag:  --- *)
  558.  
  559.  
  560. PROCEDURE AllocFlag* {base,-  102} (): LONGINT;
  561. (*
  562.  * Ein Flag wird alloziert. Dieses Flag kann zum Kennzeichnen von Objekten
  563.  * verwendet werden. Das allozierte Flag ist bei jedem von dieser Library
  564.  * alloziertem Objekt gelöscht.
  565.  *
  566.  * Eine Mögliche Anwendungen der Flags ist das Durchwandern des von Objekten
  567.  * aufgebauten Grafen, um diesen z.B. zu speichern.
  568.  *
  569.  * Das Flag kann mit
  570.  *
  571.  *  move.l  object,A0
  572.  *  move.l  flag,D0
  573.  *  bset.w  flag,-8(A0)
  574.  *
  575.  * gesetzt und entsprechend auch gelöscht werden.
  576.  *
  577.  * Das Ergebnis ist bei Erfolg zwischen 0 und 15.
  578.  * Sind keine Flags mehr frei, ist das Ergebnis -1.
  579.  *
  580.  * Da es insgesamt nur 16 Flags gibt und ein Flag nur global für alle Objekte
  581.  * alloziert werden kann, sollten immer möglichst wenig Flags über eine
  582.  * möglichst kurze Zeit alloziert werden. Es sollte kein Programm über seine
  583.  * gesamte Laufzeit eines oder mehrere Flags allozieren, von solchen
  584.  * Programmen könnten dann nur maximal 16 gleichzeitig gestartet werden, was
  585.  * meist eine grobe Einschränkung ist.
  586.  *
  587.  * Diese Routine kann in zukünftigen Versionen des Compilers in manchen Fällen
  588.  * lange dauern.
  589.  *)
  590.  
  591.  
  592. (* ---  FreeFlag:  --- *)
  593.  
  594.  
  595. PROCEDURE FreeFlag * {base,-  108} (flag{2}: INTEGER);
  596. (*
  597.  * Das mit AllocFlag() allozierte Flag wird wieder freigegeben.
  598.  *
  599.  * Das Flag muß vorher bei allen Objekten, bei denen es gesetzt wurde,
  600.  * wieder gelöscht werden.
  601.  *
  602.  * Future Enhancements:
  603.  *   Wenn mir jemand eine Anwendung zeigt, bei der es eine große Erleichterung
  604.  *   wäre, wenn das Flag automatisch gelöscht würde, werde ich diese Routine
  605.  *   so verbessern, daß das Flag nicht gelöscht werden muß. Das Löschen würde
  606.  *   dann vom Collector übernommen.
  607.  *)
  608.  
  609.  
  610. (* ---  AssignRef:  --- *)
  611.  
  612.  
  613. PROCEDURE AssignRef * {base,-  114}(ref{8}: SYSTEM.ADDRESS;
  614.                                     to {9}: SYSTEM.ADDRESS);
  615.  
  616. (*
  617.  * Kopiert den verfolgten Zeiger ref nach to^ (Wie bei to^ := ref).
  618.  *
  619.  * Ist ref#NIL, wird ref^ pink und grau markiert, wie dies bei
  620.  * Zeigerzuweisungen nötig ist.
  621.  *
  622.  * ensure
  623.  *   to^ = ref
  624.  *)
  625.  
  626.  
  627. (* ---  Assign:  --- *)
  628.  
  629.  
  630. PROCEDURE Assign * {base,-  120}(from{8},to{9} : SYSTEM.ADDRESS;
  631.                                  type{10}      : ObjectTypePtr);
  632.  
  633. (*
  634.  * Kopiert from^ nach to^ (Wie bei from^ := to^).
  635.  *
  636.  * Der Typ von to ist type. Alle von to erreichbaren Objekte werden grau markiert.
  637.  * from und typ müssen dabei keine mit Alloc() allozierten Objekte sein, sondern
  638.  * können auch einfache globale oder lokale Variablen sein.
  639.  *
  640.  * ACHTUNG: Diese Routine darf nicht gleichzeitig von mehreren Prozessen mit dem
  641.  *          selben Zielobjekt aufgerufen werden.
  642.  *
  643.  * require
  644.  *   type.id = usualObject;
  645.  *   from # NIL;
  646.  *   to # NIL;
  647.  * ensure
  648.  *   from^ = to^
  649.  *
  650.  *)
  651.  
  652.  
  653. (* ---  AssignOpenArray:  --- *)
  654.  
  655.  
  656. PROCEDURE AssignOpenArray * {base,-  126}(from{8},to{9}  : SYSTEM.ADDRESS;
  657.                                           elementType{10}: UsualObjectTypePtr;
  658.                                           length{2}      : LONGINT);
  659.  
  660. (*
  661.  * Kopiert offenes Feld mit length Elementen und dem Elementtyp elementType
  662.  * von from^ nach to^ (Wie bei from^ := to^).
  663.  *
  664.  * Alle von to erreichbaren Objekte werden grau markiert. from und typ müssen
  665.  * dabei keine mit Alloc() allozierten Objekte sein, sondern können auch
  666.  * einfache globale oder lokale Variablen sein.
  667.  *
  668.  * ACHTUNG: Diese Routine darf nicht gleichzeitig von mehreren Prozessen mit dem
  669.  *          selben Zielobjekt aufgerufen werden.
  670.  *
  671.  * require
  672.  *   elementType.id = usualObject;
  673.  *   from # NIL;
  674.  *   to # NIL;
  675.  *   length > 0;
  676.  * ensure
  677.  *   from^ = to^
  678.  *
  679.  *)
  680.  
  681.  
  682. (* ---  AssignRefs:  --- *)
  683.  
  684.  
  685. PROCEDURE AssignRefs * {base,-  132}(from{8},to{9} : SYSTEM.ADDRESS;
  686.                                      type{10}      : ObjectTypePtr);
  687.  
  688. (*
  689.  * Kopiert alle Referenzen von from^ nach to^.
  690.  *
  691.  * Der Typ von to ist type. Alle von to erreichbaren Objekte werden grau markiert.
  692.  * from und typ müssen dabei keine mit Alloc() allozierten Objekte sein, sondern
  693.  * können auch einfache globale oder lokale Variablen sein.
  694.  *
  695.  * Diese Routine wird bei Zuweisungen in Hochsprachen benötigt, bei denen Teile
  696.  * des Zielobjekts unverändert bleiben müssen, da diese z.B. Informationen
  697.  * über das Objekt selbst enthalten, die unverändert bleiben müssen.
  698.  *
  699.  * Nach dem Aufruf dieser Routine können alle nicht zugewiesenen Werte z.B. mit
  700.  * Exec.CopyMem zugewiesen werden (da die Referenzen bereits kopiert wurden,
  701.  * macht es nichts, wenn sie nochmal kopiert werden, es sei denn, dies geschieht
  702.  * gleichzeitig von mehreren Prozessen aus).
  703.  *
  704.  * require
  705.  *   type.id = usualObject;
  706.  *   from # NIL;
  707.  *   to # NIL;
  708.  * ensure
  709.  *   -- Alle Referenzen in from^ sind gleich mit denen in to^
  710.  *
  711.  *)
  712.  
  713.  
  714. (* ---  CallAssign:  --- *)
  715.  
  716.  
  717. PROCEDURE CallAssign * (from,to : SYSTEM.ADDRESS;
  718.                         type    : ObjectTypePtr);         (* $SaveAllRegs+ *)
  719. (*
  720.  * Wie Assign, nur mit Stack-Parametern. Wird vom Oberon-Compiler benutzt.
  721.  *)
  722.  
  723. BEGIN
  724.   Assign(from,to,type);
  725. END CallAssign;
  726.  
  727.  
  728. (* ---  AssignOpenArray:  --- *)
  729.  
  730.  
  731. PROCEDURE CallAssignOpenArray * (from,to    : SYSTEM.ADDRESS;
  732.                                  elementType: UsualObjectTypePtr;
  733.                                  length     : LONGINT);   (* $SaveAllRegs+ *)
  734. (*
  735.  * Wie AssignOpenArray, nur mit Stack-Parametern. Wird vom Oberon-Compiler
  736.  * benutzt.
  737.  *)
  738.  
  739. BEGIN
  740.   AssignOpenArray(from,to,elementType,length);
  741. END CallAssignOpenArray;
  742.  
  743.  
  744. (* ---  AssignRecord:  --- *)
  745.  
  746.  
  747. PROCEDURE AssignRecord * (from,to : SYSTEM.ADDRESS;
  748.                           type    : UsualObjectTypePtr);  (* $SaveAllRegs+ *)
  749. (*
  750.  * Vom Oberon-Compiler verwendet, um Variablen eines erweiterbaren RECORD-Typs
  751.  * einander zuzuweisen. Dabei werden alle Elemente bis auf den Zeiger auf
  752.  * den Typedescriptor zugewiesen.
  753.  *)
  754.  
  755. BEGIN
  756.   AssignRefs(from,to,type);
  757.   Exec.CopyMemAPTR(SYSTEM.VAL(LONGINT,from)+4,
  758.                    SYSTEM.VAL(LONGINT,to  )+4,type.size - 4);
  759. END AssignRecord;
  760.  
  761.  
  762. (* ---  New:  --- *)
  763.  
  764.  
  765. PROCEDURE New * (VAR adr: SYSTEM.ADDRESS;
  766.                      typ: InternalObjectTypePtr);
  767. (*
  768.  * Ruft Alloc() auf. Kann Alloc() das Object nicht allozieren, wird
  769.  * OberonLib.OutOfMemHandler() aufgerufen und noch einmal versucht,
  770.  * das Object zu allozieren. Dies geschieht so lange, bis das Programm
  771.  * abgebrochen wird oder das Allozieren erfolgreich war.
  772.  *
  773.  * ensure
  774.  *   adr#NIL
  775.  *)
  776.  
  777. BEGIN
  778.   REPEAT
  779.     Alloc(typ,adr);
  780.     IF adr=NIL THEN
  781.       OberonLib.OutOfMemHandler();
  782.     END;
  783.   UNTIL adr#NIL;
  784. END New;
  785.  
  786.  
  787. (* ---  NewOpenArray:  --- *)
  788.  
  789.  
  790. PROCEDURE NewOpenArray * (VAR adr: SYSTEM.ADDRESS;
  791.                               typ: InternalObjectTypePtr;
  792.                              size: LONGINT);
  793. (*
  794.  * Ruft AllocOpenArray() auf. Kann AllocOpenArray() das Object nicht
  795.  * allozieren, wird OberonLib.OutOfMemHandler() aufgerufen und noch einmal
  796.  * versucht, das Object zu allozieren. Dies geschieht so lange, bis das
  797.  * Programm abgebrochen wird oder das Allozieren erfolgreich war.
  798.  *
  799.  * ensure
  800.  *   adr#NIL
  801.  *)
  802.  
  803. BEGIN
  804.   REPEAT
  805.     AllocOpenArray(typ,adr,size);
  806.     IF adr=NIL THEN
  807.       OberonLib.OutOfMemHandler();
  808.     END;
  809.   UNTIL adr#NIL;
  810. END NewOpenArray;
  811.  
  812.  
  813. (* ---  New:  --- *)
  814.  
  815.  
  816. PROCEDURE Allocate * (VAR adr: SYSTEM.ADDRESS;
  817.                       typ: InternalObjectTypePtr);
  818. (*
  819.  * Ruft Alloc() auf. Kann Alloc() das Object nicht allozieren, wird
  820.  * NIL zurückgegeben.
  821.  *)
  822.  
  823. BEGIN
  824.   Alloc(typ,adr);
  825. END Allocate;
  826.  
  827.  
  828. (* ---  NewOpenArray:  --- *)
  829.  
  830.  
  831. PROCEDURE AllocateOpenArray * (VAR adr: SYSTEM.ADDRESS;
  832.                               typ: InternalObjectTypePtr;
  833.                              size: LONGINT);
  834. (*
  835.  * Ruft AllocOpenArray() auf. Kann AllocOpenArray() das Object nicht
  836.  * allozieren, wird NIL zurückgegeben.
  837.  *)
  838.  
  839. BEGIN
  840.   AllocOpenArray(typ,adr,size);
  841. END AllocateOpenArray;
  842.  
  843.  
  844. (* ---  DuplicateOpenArray:  --- *)
  845.  
  846.  
  847. PROCEDURE DuplicateOpenArray * (VAR from,to: ARRAY 100000H OF SYSTEM.ADDRESS;
  848.                                         typ: InternalObjectTypePtr;
  849.                                  elementTyp: UsualObjectTypePtr;
  850.                                        dims: INTEGER);
  851. (* $SaveAllRegs+ *)
  852.  
  853. (*
  854.  * Alloziert eine Kopie des offenen Feldes an adr[0..dims] und kopiert diese
  855.  * nach to[0..dims]. to[dims] muß dem GC als verfolgte Referenz mitgeteilt
  856.  * werden.
  857.  *
  858.  * Diese Routine wird vom Oberon-Compiler für das Kopieren von Offenen-Feld-
  859.  * Parametern verwendet, wenn die Felder verfolgte Referenzen enthalten.
  860.  *
  861.  * ensure
  862.  *   to[0..dims-1] = adr[0..dims-1]
  863.  *   to[dims]      # adr[dims]
  864.  *   to[dims]^     = adr[dims]^
  865.  *)
  866.  
  867. VAR
  868.   length: LONGINT;
  869.   i: INTEGER;
  870.  
  871. BEGIN
  872.   length := 1;
  873.   i:=dims;
  874.   REPEAT
  875.     DEC(i);
  876.     length := length * SYSTEM.VAL(LONGINT,from[i]);
  877.     to[i] := from[i];
  878.   UNTIL i=0;
  879.   NewOpenArray(to[dims],typ,length);
  880.   AssignOpenArray(from[dims],to[dims],elementTyp,length);
  881. END DuplicateOpenArray;
  882.  
  883.  
  884. (* ---  AddType:  --- *)
  885.  
  886.  
  887. PROCEDURE AddType * (VAR to : SYSTEM.ADDRESS;
  888.                          typ: ObjectTypePtr);
  889. (*
  890.  * Ruft AllocType() auf. Kann AllocType() keinen Typ allozieren, wird
  891.  * OberonLib.OutOfMemHandler() aufgerufen und noch einmal versucht,
  892.  * den Typ zu allozieren. Dies geschieht so lange, bis das Programm
  893.  * abgebrochen wird oder das Allozieren erfolgreich war.
  894.  *
  895.  * ensure
  896.  *   ot#NIL
  897.  *)
  898.  
  899. VAR
  900.   execBase[4]: UNTRACED POINTER TO STRUCT dummy: ARRAY 276 OF CHAR;
  901.     thisTask : UNTRACED POINTER TO STRUCT dummy: ARRAY 46 OF CHAR;
  902.       trapData : UNTRACED POINTER TO STRUCT
  903.         mutator : MutatorPtr;
  904.       END;
  905.     END;
  906.   END;
  907.  
  908. BEGIN
  909.   REPEAT
  910.     to := AllocType(execBase.thisTask.trapData.mutator^,typ);
  911.     IF to=NIL THEN
  912.       OberonLib.OutOfMemHandler();
  913.     END;
  914.   UNTIL to#NIL;
  915. END AddType;
  916.  
  917.  
  918. (* ---  Halt:  --- *)
  919.  
  920.  
  921. VAR
  922.   OldHaltProc: PROCEDURE;
  923.  
  924. PROCEDURE Halt;
  925. (*
  926.  * Entfernt die GC-Informationen über die lokalen Variablen und ruft die alte
  927.  * HALT-Prozedur auf.
  928.  *)
  929. BEGIN
  930.   mutator.locals := NIL;
  931.   OldHaltProc;
  932. END Halt;
  933.  
  934.  
  935. (* ---  Init:  --- *)
  936.  
  937.  
  938. BEGIN
  939.  
  940. (* $IF GarbageCollector *)
  941.  
  942.   base := Exec.OpenLibrary("garbagecollector.library",2);
  943.   IF base=NIL THEN
  944.     SYSTEM.SETREG(0,Intuition.DisplayAlert(
  945.                       0,"\x00\x64\x14missing garbagecollector.library V2\o\o",50));
  946.     HALT(0);
  947.   END;
  948.  
  949.   IF AddMutator(mutator) THEN
  950.  
  951.     mutatorValid := TRUE;
  952.     OberonLib.execBase.thisTask.trapData.mutator := SYSTEM.ADR(mutator);
  953.     OldHaltProc := OberonLib.execBase.thisTask.trapData.haltProc;
  954.     OberonLib.execBase.thisTask.trapData.haltProc := Halt;
  955.  
  956.   ELSE
  957.  
  958.     HALT(20);  (* Etwas ging schief, normalerweise nur bei zu wenig Speicher *)
  959.  
  960.   END;
  961.  
  962. CLOSE
  963.  
  964.   IF mutatorValid  THEN RemMutator(mutator)     END;
  965.  
  966.   IF base#NIL      THEN Exec.CloseLibrary(base) END;
  967.  
  968. (* $END *)
  969.  
  970. END GarbageCollector.
  971.  
  972.  
  973.  
  974.  
  975.  
  976.  
  977.