s%Syntax10.Scn.Fnt! Z StyleElemsAlloc comment  Z  commentq Z  commentSyntax10b.Scn.Fnt Z  comment8FoldElemsNew>Syntax10.Scn.Fnt StyleElemsAlloc commentPictureK82KeplerElemsAllocKeplerGraphsGraphDescKeplerGraphsStarDesc } }|| z} | } }| |{}{|| {zKeplerFramesCaptionDescuser pointerSyntax10.Scn.FntKepler1RectangleDesctagSyntax10.Scn.FntKepler1AttrDesc  sizeSyntax10.Scn.Fnt pointer offsetsSyntax10.Scn.Fnt array/recordSyntax10.Scn.Fnt type desctiptorSyntax10.Scn.Fnt/.  8 Z  comment'8Syntax10.Scn.Fnt StyleElemsAlloc commentPictureWFAKeplerElemsAllocKeplerGraphsGraphDescKeplerGraphsStarDesc}|| | ||}||}| } | } |}|}|KeplerFramesCaptionDescMarkSyntax10.Scn.FntArraySyntax10.Scn.FntFreeSyntax10.Scn.FntSubobjectSyntax10.Scn.FntUnusedSyntax10.Scn.FntKepler1LineDesc    4  8 Z ParcElemsAlloc  Z  comment8Syntax10.Scn.Fnt StyleElemsAlloc commentPictureo,!\$KeplerElemsAllocKeplerGraphsGraphDescKeplerGraphsStarDesc~ ~~ {{ {{ yy w z { ~ { { } }zzzKepler1RectangleDesc KeplerFramesCaptionDescsubobjectSyntax10.Scn.Fnt tagSyntax10.Scn.Fnt tagSyntax10.Scn.Fnt Kepler1LineDesc Kepler1AttrDescaddress MOD 16=8Syntax10.Scn.Fnt){  8 Z  comment Z  comment?8Syntax10.Scn.Fnt StyleElemsAlloc commentPicture5KeplerElemsAllocKeplerGraphsGraphDescKeplerGraphsStarDesc { {z{ x{ { { {{ {y{zzz yx |{ ~| ~~ { { } }~~}}KeplerFramesCaptionDescuser pointerSyntax10.Scn.FntKepler1RectangleDesctagSyntax10.Scn.FntKepler1AttrDesc  sizeSyntax10.Scn.Fnt pointer offsetsSyntax10.Scn.Fnt array/recordSyntax10.Scn.Fnt type desctiptorSyntax10.Scn.FntKepler1LineDesc?|'  8 Z  comment  Z  commentW8:Syntax10.Scn.Fnt Z StyleElemsAlloc commentPictureOA"!KeplerElemsAllocKeplerGraphsGraphDescKeplerGraphsStarDesc{{{zzy{{zzzzzzxzzz{yx~~~~}~~~}}|}}{{Kepler1RectangleDescKepler1LineDescKepler1AttrDesc KeplerFramesCaptionDescsizeSyntax10.Scn.Fnt nextSyntax10.Scn.Fnt   "future user pointer"Syntax10.Scn.Fnt"tag"Syntax10.Scn.FntsizeSyntax10.Scn.FntnextSyntax10.Scn.Fnt "tag"Syntax10.Scn.Fnt!"#$%%&&'()freeLists[i]Syntax10.Scn.Fnt*?w  8 Z  commentC Z  comment Z  comment Z  comment Z  comment Z  comment Z  commentP8Syntax10.Scn.Fnt StyleElemsAlloc commentPictureKeplerElemsAllocKeplerGraphsGraphDescdd  8 Z  comment Z  comment Z u Z  comment Z  comment Z  comment 8Syntax10.Scn.Fnt Z StyleElemsAlloc commentPictures$94KeplerElemsAllocKeplerGraphsGraphDescKeplerGraphsStarDesc~ ~ ~ ~    ~~ ~ |y ~ {{{| y} | }|~ } ~} } } } } { {}}{{Kepler1RectangleDescKeplerFramesCaptionDescsizeSyntax10.Scn.FntnextSyntax10.Scn.FntKepler1AttrDesc   sizeSyntax10.Scn.FntnextSyntax10.Scn.FntheapSyntax10.Scn.FntheapSyntax10.Scn.FntheapSyntax10.Scn.Fnt Kepler1LineDesc!""##$%&&''(osChunksSyntax10.Scn.Fnt){Y  8 Z  comment< Z  comment2 Z  commentb Z  comment Z  comment Z  comment+sd  $H7   :      ' .*  ;:Q:Syntax10i.Scn.Fnt '-oJi Z  F  8/E1=UF| MarkElemsAllocd8zQ'DV3) ^(4&%\Tp{oO{1)"5ac0iJR",40)![?  XX.Q(q;5:L,,AA1O&<xe C!fYv /.H"uN'+<+X+L'ML<'7q,4<R=C3#l**~p?#":":r) ZXi:.Sp"E#:BpW,^8A]CKA N-1.t     D*eD ;AoD':_Y G,q6 4o \x} 5DL#P6W^ k!&i:G-}O,  %= 4;KVMODULE Kernel; (* RC 2.12.93 *) (* Kernel performs several tasks. It manages the memory resources. As such it contains procedure for allocating memory, and the garbage collector. Memory management Each memory block starts with a tag, i.e. a pointer to a type desctiptor followed by the memory allocated for the user. Thus the tag is effectivly at a negative offset relative to the user address.Figure The tag itself is a mixture of an address and some extra bits. The lowest few bits are reserved for the garbage collection and for flags. Thus an allignment of memory on special boundaries is required, to make the lowest few bits of the address equal to zero. The meanig of the special bits are:Figure Bitpos Name Description 0 Mark Used by garbage collector. Set in mark phase, reset in sweep phase. 1 Array Differentiate array from record blocks. 2 Free Block linked into one of the free lists. 3 Reserved Is 1 if the type descriptor is a subobject (usually it is). Subobjects are memory regions within an allocated block, which have a tag too. When the garbage collector sees a pointer to a subobject during mark phase, it does not set the mark bit in the subobject tag, but in the tag of the whole block. Thus it guarantees, that the block is not collected, when only pointers to the subobjects exists. It finds the tag of the whole block because the subobject tag points to the first word of it.Figure A pointer to a subobject is identified by the fact, that its address satisfies address MOD 16=8. As tags itself are often pointers to a sub object, bit 3 is reserved. The tag of a record or array is itself a pointer to a subobject. The full type descriptor contains additional information (e.g. the type name), which preceeds the part seen in the above picture. Thus in front of the size field there is a pointer pointing to the real start of the block. This real start is of course again preceeded by a tag, which in this case point also to the real start, so this is what it looks like:Figure Free list Blocks in the free list consist of a "tag" a size and a pointer to the next free block.Figure When a block is allocated, the "tag" be comes a real tag, pointing to a type descriptor, and the address returned to the user will be the address of the first word after it. As the address seen by the user needs to satisfy the alignment condition address MOD Blocksize=0, all free blocks start at an address satisfying the confition: freeBlockStart MOD Blocksize=(-pointerSize) MOD Blocksize. The size of an allocated block is always an integer multiple of Blocksize. The size field stores the size of the free block including size and next field, but excluding the "tag" field. Blocks in the free bit are specially marked, using the free bit. This is currently used only in Candidates and in Boot. Maybe one could get rid of it, freeing one flag in the tag. Records The type descriptor for a record type starts with the size of the record. It is followde by a list of offsets which indicate to the garbage collector at where within the record there is a pointer to follow. Those offets are relative to the start of a record. After the list, there is one word with value -pointerSize*(numberOfPointerOffsets+1). For the garbage collector, this negative value indicates the end of the pointer list. NewRec is used to allocated storage for a POINTER TO Record type. The size of the block is taken from the type descriptor, and augmented by the size needed for the tag. Arrays Figure Heap This implementation manages memory within heap blocks it request from the base operating system on demand. This scheme was used in the hope to get two advantages: 1. Allocation/freeing of blocks is done without a (costly ?) call to the base operating system. 2. The memory requested from the base OS can be adapted gradually. In contrast to other Oberon implementations, one does not have to indicate at startup how much memory has to be requested. Request to the base OS are done in larger chunks, to avoid too much OS calls. Currently the chunk size is set so large, that effectively only one chunk is allocated. This is done to keep the current UV4 implementation stable even though the code is not yet considered safe. This is also to be change in the future. Variable heap points into the first chunk. It does not point at the start but at the beginning of the memory area used for allocating Oberon memory. The chunks are linked together sorted by their address. Thus heap is the lowest address possibly allocated via Kernel. Figure size is the total size allocated from the base OS. It is stored so that it is available, if it is needed on deallocation. heap points to the start of the area used by Oberon. The start is determined so, that the address fulfils the alignment for free blocks, i.e. address MOD BlockSize=(-pointerSize) MOD BlockSize. Usage of pointer variables in Kernel and elsewhere If a global variable is declared of type POINTER TO, then it is recorded in the module's pointer list. As a result of this, it is used as starting point for the mark phase.To make sure nothing goes wrong, pointer variables should only contain NIL or addresses generated by NEW, SYSTEM.NEW or obtained by direct application of SYSTEM.ADR() to a variable. Pointers which shall contain values which are not generated by the above mentioned proper means, should be stored in variables of type HostSYS.ADDRESS. There is a further reason for using ADDRESS instead of proper pointers, namely when a pointer should not prevent an object from being collected. It is not known, if variables on the stack are pointers or not. They are guessed. I'm not yet sure, if this guessing is really safe. The assumption is, that at worst memory blocks are marked even though they shouldn't. But I suspect, that this has become unsafe with the introduction of subobjects. *) (* WARNING: do not use NEW nor SYSTEM.NEW in this module !! use NewRec, NewArr or NewSys instead *) IMPORT SYSTEM ,Counters,HostSYS,Unix; CONST MarkBit*=0; pointerSize=4; BlockSize=16; (* must be a mutiple of 16, to not interfere with the flags in a tag *) tagSize=pointerSize; (* Size of the tag field *) tagOffset=-tagSize; (* Position of tag relative to user address of block *) TYPE Tag*=POINTER TO TypeDesc; Ptr*=POINTER TO Block; KeyCmd*=PROCEDURE; Finalizer*=PROCEDURE(obj:SYSTEM.PTR); FinObject=POINTER TO FinObjectDesc; FinObjectDesc=RECORD next:FinObject; obj:LONGINT; finalize:Finalizer; END; VAR ptrElemTag*:LONGINT; (* Tag of a pointer type. Initialised by module Modules *) heapAdr-:LONGINT; TrapHandlingLevel*:LONGINT; GCenabled*:BOOLEAN; FindRoots*:PROCEDURE; FindAmbRoots*:PROCEDURE; nofiles*:INTEGER; (* number of open files *) curSigCtxt*:LONGINT; (* for GC during trap handling *) jmpBuf*:Unix.JmpBuf; readSet*,readySet*:Unix.FdSet; (* input event handling *) sysStackTop-,sysStackBot-:LONGINT; SystemStack:ARRAY 4096 OF LONGINT; (* 16KB *) (* I'm still wondering, why this is here and not in Input. *) FKey*:ARRAY 16 OF KeyCmd; TYPE (* TypeDesc describes the always present part of a type descriptor. The tag points to this descriptor. It contains the size of the type followed by pointer offsets. The number of offsets is varibale, so after the last one, there is a sentinel element, which is the only negative one. Its value is -4*(numberOfPointer+1). *) TypeDesc=RECORD size:LONGINT; ptroff:LONGINT; END; (* Each free block contains at its beginning a FreeBlock record. The first word is a tag which points to the size of the free block itself and has the free flag set.Thus it makes it possible to find the size of any block, free or not, to be found by following the tag after masking out the flags. The second word contains the size of the free block minus 4, i.e. the tag field itself is not counted in. The third word points to the tag field of the next free block. *) FreePtr=POINTER TO FreeBlock; FreeBlock=RECORD tag:Tag; size:LONGINT; next:HostSYS.ADDRESS; END; Block=RECORD lastElemToMark:Ptr; currElem:Ptr; firstElem:Ptr; END; Blockm4Ptr=POINTER TO Blockm4; Blockm4=RECORD tag:Tag; lastElemToMark,currElem,firstElem:LONGINT END; InitPtr=POINTER TO RECORD tag:Tag; z0,z1,z2,z3,z4,z5:LONGINT; END; OSChunkPtr=POINTER TO OSChunk; OSChunk=RECORD (* allocated from base OS *) next:OSChunkPtr; (* address of next HeapBlock *) size:LONGINT; (* size of this heap block *) heap:HostSYS.ADDRESS; (* Start of Oberon part *) END; CONST OSBlockSize=5000000; (* Chunk to request each time from base OS *) nofLists=9; nil=0; ArrayBit=1; FreeBit=2; SubObjBit=3; ReserveSize=100000; VAR heap:HostSYS.ADDRESS; (* List of memory blocks allocated from the host operating system. This list is somehow unusual, as heap doesn't point to the real beginning of a block. Instead it points to an address after the header, where the "Oberon managed portion" of the block starts. The list is sorted so that blocks at a lower memory address preceed blocks with a larger memory address.  *) osChunks:HostSYS.ADDRESS; heapSize-:LONGINT; (* Record the total size requested from the host operating system. *) allocated-:LONGINT; (* Record the size of all allocations within Oberon. *) freeLists:ARRAY nofLists+1 OF HostSYS.ADDRESS; (* 0: unused, 1<=i0); *) (* first sort them in increasing order using shellsort *) h:=1; REPEAT h:=h*3 + 1 UNTIL h>nofcand; REPEAT h:=h DIV 3; i:=h; WHILE i < nofcand DO p:=candidates[i]; j:=i; WHILE (j >= h) & (candidates[j-h]>p) DO candidates[j]:=candidates[j-h]; j:=j-h; END; candidates[j]:=p; INC(i) END UNTIL h=1; (* mark phase *) heapBlock:=SYSTEM.VAL(OSChunkPtr,osChunks); heapBlockEnd:=heapBlock.size+SYSTEM.ADR(heapBlock^); block:=SYSTEM.VAL(Blockm4Ptr,heap); i:=0; p:=candidates[i]; LOOP WHILE p>=heapBlockEnd DO (* find OS block containing candidate *) heapBlock:=heapBlock.next; IF heapBlock=NIL THEN (* no more OS blocks where candidate could be *) EXIT; ELSE block:=SYSTEM.VAL(Blockm4Ptr,heapBlock.heap); heapBlockEnd:=heapBlock.size+SYSTEM.ADR(heapBlock^); END; END; IF p <= SYSTEM.VAL(HostSYS.ADDRESS,block) + 4 THEN IF p=SYSTEM.VAL(HostSYS.ADDRESS,block) + 4 THEN Mark(SYSTEM.VAL(Ptr,p)) END; INC(i); IF i=nofcand THEN EXIT END; (* no more candidates to check *) p:=candidates[i]; ELSE (* go to next block. Because of the WHILE p>=heapBlockEnd we know, there is a next block *) notmarked:=SYSTEM.VAL(Tag,SYSTEM.VAL(SET,block^.tag)-{MarkBit,FreeBit}); tdesc:=SYSTEM.VAL(Tag,SYSTEM.VAL(SET,notmarked)-{ArrayBit}); IF notmarked#tdesc THEN (* array block *) h:=block^.lastElemToMark+tdesc^.size-SYSTEM.VAL(HostSYS.ADDRESS,block); ELSE h:=tdesc^.size+4; END; INC(SYSTEM.VAL(HostSYS.ADDRESS,block),(h+BlockSize-1) MOD BlockSize); IF block=SYSTEM.VAL(Blockm4Ptr,heapEnd) THEN EXIT; END; END END; nofcand:=0; END MarkCandidates; PROCEDURE Candidate*(p:LONGINT); (* Test if p could be a pointer. Calls MarkCandidates, if candidates array is full. *) VAR tag:LONGINT; BEGIN IF ((p MOD BlockSize=0) OR (p MOD 16=8)) & (heap<=p) & (p0 THEN MarkCandidates; END; (* Clear all free lists. Prepare lasFreeList, an array pointing to the current "next-pointer" for the list. A hackish way to implmement insert at end of list. *) FOR i:=1 TO nofLists DO freeLists[i]:=nil; lastFreeLists[i]:=SYSTEM.ADR(freeLists[i]); END; allocated:=0; (* Walk through all blocks and rebuild free list. Note: heapBlock and this point to the start of the whole block. heap points to the start of the Oberon managed part. adr points to the current Oberon block within the Oberon managed part. *) heapBlock:=osChunks; prev:=NIL; WHILE heapBlock#nil DO (* Go through all block allocated from the base OS *) lastsize:=0; this:=SYSTEM.VAL(OSChunkPtr,heapBlock); (* Go through all Oberon managed blocks within this memory block. *) p:=SYSTEM.VAL(Blockm4Ptr,this.heap); end:=SYSTEM.VAL(Blockm4Ptr,SYSTEM.ADR(this^)+this.size); WHILE p#end DO tag:=SYSTEM.VAL(Tag,SYSTEM.VAL(SET,p^.tag)-{FreeBit}); notmarked:=SYSTEM.VAL(Tag,SYSTEM.VAL(SET,tag)-{MarkBit}); tdesc:=SYSTEM.VAL(Tag,SYSTEM.VAL(SET,notmarked)-{ArrayBit}); (* Find the size of this block *) IF notmarked#tdesc THEN (* array block is special *) size:=p^.lastElemToMark+tdesc^.size-SYSTEM.VAL(HostSYS.ADDRESS,p); ELSE size:=tdesc^.size+4; END; INC(size,(-size) MOD BlockSize); IF tag=notmarked THEN (* Just remember the stretch of unmarked blocks. *) IF lastsize=0 THEN lastp:=SYSTEM.VAL(FreePtr,p); END; INC(lastsize,size); ELSE p^.tag:=notmarked; IF lastsize>0 THEN (* This block was preceeded by one or more free blocks. Add the whole stretch of free blocks into the appropriate free list. *) lastp^.size:=lastsize-4; lastp^.tag:=SYSTEM.VAL(Tag,SYSTEM.VAL(SET,SYSTEM.ADR(lastp^.size))+{FreeBit}); i:=lastsize DIV BlockSize; IF i>nofLists THEN i:=nofLists; END; lastp^.next:=nil; SYSTEM.PUT(lastFreeLists[i],lastp); lastFreeLists[i]:=SYSTEM.ADR(lastp^.next); lastsize:=0; END; INC(allocated,size); END; INC(SYSTEM.VAL(HostSYS.ADDRESS,p),size); END; next:=this.next; IF lastsize=(SYSTEM.VAL(HostSYS.ADDRESS,end)-this.heap) THEN (* No marked blocks, so return this to the base OS. *) IF this=SYSTEM.VAL(OSChunkPtr,osChunks) THEN (* first block in list *) osChunks:=SYSTEM.VAL(HostSYS.ADDRESS,this.next); IF this.next=NIL THEN (* Wow, we freed all memory. *) heapEnd:=nil; heap:=nil; ELSE heap:=this.next.heap; END; ELSE prev.next:=this.next; IF this.next=NIL THEN (* last block, thus adjust heap end *) heapEnd:=SYSTEM.ADR(prev^)+prev.size; END; END; DEC(heapSize,this.size); HostSYS.Deallocate(SYSTEM.VAL(HostSYS.ADDRESS,this),this.size); ELSIF lastsize>0 THEN (* The last (few) block(S) were free blocks, so we have to put them into the free list. *) lastp^.size:=lastsize - 4; lastp^.tag:=SYSTEM.VAL(Tag,SYSTEM.VAL(SET,SYSTEM.ADR(lastp^.size))+{FreeBit}); i:=lastsize DIV BlockSize; IF i>nofLists THEN i:=nofLists; END; lastp^.next:=nil; SYSTEM.PUT(lastFreeLists[i],lastp); (* Add at the end of the list *) prev:=this; END; this:=next; END; END Sweep; PROCEDURE ^GC*(markStack:BOOLEAN); PROCEDURE OSAlloc(size:LONGINT):BOOLEAN; (* Request a new heap chunk from base OS and insert it into the free list of Oberon. *) VAR adr:HostSYS.ADDRESS; alloc:LONGINT; freePtr:FreePtr; i:LONGINT; next:OSChunkPtr; ok:BOOLEAN; osHeap:OSChunkPtr; prev:OSChunkPtr; this:OSChunkPtr; BEGIN (* Determine, how much has to be allocated. If the requested size fits in a standard block, then try allocate a standard block but at least BlockSize*nofLists. Otherwise allocate a block which, accounting for the header, is big enough to just satisfy the request. The block is adjusted, so that it contains an integral number of subblocks of size BlockSize. *) INC(size,-size MOD BlockSize); (* Adjust size to be a multiple of BlockSize *) INC(size,SIZE(OSChunk)+BlockSize-pointerSize); (* Account for header and adjustment to fulfil free block alignment *) IF size<=OSBlockSize THEN (* The standard block is enough *) alloc:=OSBlockSize; ELSE (* We need more *) alloc:=size; END; (* An allocation is tried. The requested length is reduced from alloc downto no less then size, if low memory condition or high fragmentation request for it. *) REPEAT adr:=HostSYS.Allocate(alloc); alloc:=alloc DIV 2; ok:=adr#nil; UNTIL ok OR (allocnofLists THEN i:=nofLists; END; freePtr.next:=freeLists[i]; (* link it at the beginning of the appropriate free list *) freeLists[i]:=SYSTEM.ADR(freePtr^); END; RETURN ok; END OSAlloc; PROCEDURE NewBlock(size:LONGINT):InitPtr; (* size MOD B=0 *) (* NewBlock allocates a memory block of the needed size. This implementation does allocation itself. One could choose, to replace the whole procedure by a direct call to an equivalent memory allocator of the base OS. Note It is assumed, that the size is a multiple of BlockSize.. *) TYPE HugePtr=POINTER TO ARRAY MAX(LONGINT) DIV 4 OF LONGINT; VAR freePtr:FreePtr; i:LONGINT; i0:LONGINT; ok:BOOLEAN; ptr:InitPtr; previous:FreePtr; rest:LONGINT; restptr:FreePtr; unsafePtr:HugePtr; BEGIN (* Don't yet know what's the meaning of this statement, as MAX(LONGINT) is NOT smaller than zero. *) IF size<0 (* NEW(p,MAX(LONGINT)) *) THEN HALT1 END; (* Find the appropriate free list. *) i0:=size DIV BlockSize; i:=i0; IF i>nofLists THEN i:=nofLists; END; WHILE (i0 THEN (* We don't need the whole block, so let's return the remaining part to the appropriate free list. *) restptr:=SYSTEM.VAL(FreePtr,SYSTEM.VAL(HostSYS.ADDRESS,freePtr)+size); restptr^.tag:=SYSTEM.VAL(Tag,SYSTEM.VAL(SET,SYSTEM.ADR(restptr^.size))+{FreeBit}); restptr^.size:=rest-tagSize; i:=rest DIV BlockSize; IF i>nofLists THEN i:=nofLists; END; restptr^.next:=freeLists[i]; freeLists[i]:=SYSTEM.VAL(HostSYS.ADDRESS,restptr); END; (* The block is cleared with zeroes. *) unsafePtr:=SYSTEM.VAL(HugePtr,freePtr); FOR i:=0 TO size DIV 4 DO unsafePtr[i]:=0; END; RETURN SYSTEM.VAL(InitPtr,freePtr); END NewBlock; PROCEDURE NewRec*(tag:Tag):HostSYS.ADDRESS; (* NewRec is called for NEW(recordPtr) where recordPtr is of type POINTER TO RECORD ... END. NewRec receives a tag as input and allocates and correctly initializes the memory needed for the record type. *) VAR ptr:InitPtr; BEGIN (* Call NewBlock to request a block which has room for the requested type plus a tag. *) ptr:=NewBlock(((tag^.size+tagSize)+(BlockSize-1)) MOD BlockSize); (* The tag shall point to the given tag, which describes this type. *) ptr^.tag:=tag; RETURN SYSTEM.VAL(HostSYS.ADDRESS,ptr)+tagSize; END NewRec; PROCEDURE NewSys*(size:LONGINT):HostSYS.ADDRESS; (* implementation of SYSTEM.NEW(ptr,size) *) (* NewSys is called for SYSTEM.NEW(size). Why are 28 bytes reserved, when 16 would do it? *) CONST ownTagSize=28; VAR ptr:InitPtr; BEGIN (* Call NewBlock to request a block which has room for the requested size plus a tag and a tag descriptor. *) ptr:=NewBlock(((size+ownTagSize)+(BlockSize-1)) MOD BlockSize); ptr.tag:=SYSTEM.VAL(Tag,SYSTEM.ADR(ptr^.z0)); ptr.z0:=size-4; ptr.z1:=-4; ptr.z2:=0; (* ??? *) ptr.z3:=0; (* ??? *) ptr.z4:=0; (* ??? *) ptr.z5:=SYSTEM.ADR(ptr.z0); RETURN SYSTEM.VAL(HostSYS.ADDRESS,ptr)+ownTagSize; END NewSys; PROCEDURE NewArr*(eltag:Tag; nofelem,nofdim:LONGINT):HostSYS.ADDRESS; (* implementation of NEW(ptr,dim0,dim1,...) *) (* NewArr is called for NEW(arrayPtr,dim1,..,dimN) where arrayPtr is of type POINTER TO ARRAY OF .... The number of parameters of NEW for arrays is variable. Before calling this procedure, the parameters are transformed to reduce them to 3. eltag contains the tag for the base type. nofelem is the total number of elements, thus its dim1*dim2*...*dimN, while nofdim is the number of dimensions. *) VAR firstElem,elSize,arrSize,vectSize:LONGINT; ptr:InitPtr; BEGIN (* The original comment (* ARRAY OF POINTER *) indicates, that the following statement is needed in case the element type is a pointer. Note: ptrElemTag is initialised by Modules during initalisation of the bootfile body parts. *) IF eltag=NIL THEN eltag:=SYSTEM.VAL(Tag,ptrElemTag); END; (* *) elSize:=eltag^.size; arrSize:=nofelem*elSize; vectSize:=8*(nofdim DIV 2)+4; (* -> ADR(firstElem) MOD 8=0 *) IF eltag^.ptroff=-4 THEN (* no pointers in element type *) RETURN NewSys(arrSize+vectSize+12); ELSE ptr:=NewBlock(((arrSize+vectSize+16)+(BlockSize-1)) MOD BlockSize); ptr^.tag:=SYSTEM.VAL(Tag,SYSTEM.VAL(SET,eltag)+{ArrayBit}); firstElem:=SYSTEM.ADR(ptr^.z3)+vectSize; ptr^.z0:=firstElem+arrSize-elSize; (* ptr^.z1 is reserved for Mark phase *) ptr^.z2:=firstElem; RETURN SYSTEM.VAL(HostSYS.ADDRESS,ptr)+4; END; END NewArr; PROCEDURE RegisterObject*(obj:SYSTEM.PTR; finalize:Finalizer); (* Register an object and its finalisation procedure. *) VAR f:FinObject; BEGIN IF obj#NIL THEN f:=SYSTEM.VAL(FinObject,NewRec(SYSTEM.VAL(Tag,TYPEOF(FinObjectDesc)))); f.obj:=SYSTEM.VAL(LONGINT,obj); f.finalize:=finalize; f.next:=fin; fin:=f; END; END RegisterObject; PROCEDURE CheckFin; (* Move unmarked object into the list of objects to be finalized. *) VAR f,prev,next:FinObject; tag:SET; BEGIN (* For each object in the finalization list, check if it is marked. If not, mark it to prevent Sweep() from freeing it, and move the finalization object to the list of finalizations which have to be performed. *) f:=fin; prev:=NIL; WHILE f#NIL DO next:=f.next; SYSTEM.GET(f.obj-tagSize,tag); IF ~(MarkBit IN tag) THEN (* garbage object, put it into to-be-finalized list *) Mark(SYSTEM.VAL(Ptr,f.obj)); (* mark f.obj and all objects accessible from it *) IF prev=NIL THEN fin:=next; ELSE prev.next:=next; END; f.next:=toBeFin; toBeFin:=f; ELSE prev:=f; END; f:=next; END; END CheckFin; PROCEDURE Finalize; (* Call finalization procdure for all objects in the list of objects to be finalized. *) VAR f:FinObject; BEGIN WHILE toBeFin#NIL DO f:=toBeFin; toBeFin:=toBeFin.next; f.finalize(SYSTEM.VAL(SYSTEM.PTR,f.obj)) END; END Finalize; PROCEDURE FinalizeAll; (* Finalize all objects in the finalization list. This is typically used on OS Based implementations, to clean up before Oberon terminates. *) VAR f:FinObject; BEGIN f:=fin; WHILE f#NIL DO f.finalize(SYSTEM.VAL(SYSTEM.PTR, f.obj)); f:=f.next; END; END FinalizeAll; PROCEDURE GC*(markStack:BOOLEAN); (* markStack, i.e. search also the stack for possible pointers. *) VAR oldmask:SET; BEGIN IF GCenabled THEN oldmask:=Unix.Sigsetmask({2}); (* mask interrupts except SIGINT *) FindRoots; (* callback to Modules.FindRoot, which in turn calls Mark for global pointers *) nofcand:=0; IF markStack THEN FindAmbRoots; END; (* callback to Modules.FindAmbRoot, which in turn calls Candidate for stack pointers *) CheckFin; Sweep; (* If the reserve got used for an emergency situation, we now try to reallocate it. *) Finalize; IF (reserve=NIL) & firstTry THEN reserve:=SYSTEM.VAL(Ptr,NewSys(ReserveSize)); END; oldmask:=Unix.Sigsetmask(oldmask); (* restore interrupts *) END END GC; PROCEDURE Select*(delay:LONGINT); (* Don't really get it. Somehow wait until some filhandle is ready for read, or the delay was reached. *) VAR n:LONGINT; rs,ws,xs:Unix.FdSet; tv:Unix.Timeval; BEGIN rs:=readSet; n:=0; WHILE n=0 THEN readySet:=rs; END END Select; PROCEDURE GetClock*(VAR time,date:LONGINT); (* Get system date and time. *) VAR clock:LONGINT; t:Unix.TmPtr; BEGIN clock:=Unix.Time(clock); t:=Unix.Localtime(clock); time:=t.sec+ASH(t.min,6)+ASH(t.hour,12); date:=t.mday+ASH(t.mon+1,5)+ASH(t.year MOD 128,9) END GetClock; PROCEDURE SetClock*(time,date:LONGINT); (* Set system date and time. This is a NOP, as normal users usually are not allowed to set the time. *) END SetClock; PROCEDURE Boot*; (* is called from Modules immediately after booting. *) VAR size:LONGINT; p:Blockm4Ptr; rest:FreePtr; tag,tdesc:Tag; BEGIN Counters.ResetAll; Unix.Init; IF ~booted THEN booted:=TRUE; (* avoid additional calls, expecially from user programs *) (* Get heap address and size from the boot loader. Transform that into a maximum size block which satisfies the alignment requirments. *) Unix.dlsym(0,"heapAdr",SYSTEM.VAL(LONGINT,heapAdr)); Unix.dlsym(0,"heapSize",SYSTEM.VAL(LONGINT,heapSize)); firstBlock:=heapAdr+((-heapAdr-4) MOD BlockSize); size:=heapAdr + heapSize - firstBlock; DEC(size,size MOD BlockSize); endBlock:=firstBlock + size; (* "Traverse" the heap and mark all blocks which are not free. This is some simplified mark phase, to find all blocks allocated during boot time, up to now. *) p:=SYSTEM.VAL(Blockm4Ptr,firstBlock); tag:=p^.tag; WHILE tag#NIL DO IF ~(FreeBit IN SYSTEM.VAL(SET,tag)) THEN INCL(SYSTEM.VAL(SET,p^.tag),MarkBit) END; tdesc:=SYSTEM.VAL(Tag,SYSTEM.VAL(SET,tag) - {ArrayBit,FreeBit,MarkBit}); IF ArrayBit IN SYSTEM.VAL(SET,tag) THEN (* array block *) size:=p^.lastElemToMark+tdesc^.size-SYSTEM.VAL(HostSYS.ADDRESS,p); ELSE size:=tdesc^.size+4; END; size:=SYSTEM.VAL(LONGINT,SYSTEM.VAL(SET,size + BlockSize-1)-SYSTEM.VAL(SET,BlockSize-1)); INC(SYSTEM.VAL(HostSYS.ADDRESS,p),size); tag:=p^.tag; END; rest:=SYSTEM.VAL(FreePtr,p); rest^.tag:=SYSTEM.VAL(Tag,SYSTEM.VAL(SET,SYSTEM.ADR(rest^.size))+{FreeBit}); rest^.size:=SYSTEM.VAL(LONGINT,endBlock) - SYSTEM.VAL(LONGINT,rest) - 4; firstTry:=TRUE; sysStackTop:=SYSTEM.ADR(SystemStack); sysStackBot:=sysStackTop + 4*LEN(SystemStack) - 32(*args*); (* Collect. This creates the lists of free blocks. *) Sweep; (* Run with garbage collection disabled. *) GCenabled:=FALSE; (* Set aside some space to use in case of traps. *) reserve:=SYSTEM.VAL(Ptr,NewSys(ReserveSize)) END END Boot; END Kernel.