--- a/ObjMem.st Thu Apr 25 18:07:00 1996 +0200
+++ b/ObjMem.st Thu Apr 25 18:11:23 1996 +0200
@@ -103,7 +103,7 @@
-> interrupts
-> garbageCollection
- [Class variables:]
+ Class variables:
InternalErrorHandler gets informed (by VM), when some runtime
error occurs (usually fatal)
@@ -175,12 +175,6 @@
The InterruptHandler variables are known by the runtime system -
they are the objects that get an interrupt message when the event
occurs. You may not remove any of them.
-
- [author:]
- Claus Gittinger
-
- [see also:]
- ( garbage collection : html:programming/GC.html )
"
!
@@ -1136,97 +1130,267 @@
WARNING: this method is for ST/X debugging only
it will be removed without notice"
- |low high|
-
- low := anAddress bitAnd:16rFFFF.
- high := (anAddress bitShift:16) bitAnd:16rFFFF.
-%{
- if (__bothSmallInteger(low, high)) {
- RETURN ((OBJ)((__intVal(high) << 16) | __intVal(low)));
+%{ /* NOCONTEXT */
+ int addr = __longIntVal(anAddress);
+
+ if (addr) {
+ RETURN ((OBJ)(addr));
}
+ RETURN (nil);
%}
!
-nteger(low, high)) {
- RETURN ((OBJ)((__intVal(high) << 16) | __intVal(low)));
- }
-%}
-!
-
-oReferences: or anObject>>allOwners."
+printReferences:anObject
+ "for debugging: print referents to anObject.
+ WARNING: this method is for ST/X debugging only
+ it will be removed without notice
+ use ObjectMemory>>whoReferences: or anObject>>allOwners."
%{
__printRefChain(__context, anObject);
%}
!
-to:o inRefSets:levels startingAt:1.
+refChainFrom:start to:anObject inRefSets:levels startingAt:index
+ |chain names oClass|
+
+ index > levels size ifTrue:[
+ ^ OrderedCollection with:start
+ ].
+
+"/'set: ' print. (levels at:index) displayString printNL.
+"/'start: ' print. start printNL.
+ (levels at:index) do:[:el |
+"/'trying: ' print. el printNL.
+ (start references:el) ifTrue:[
+"/'yes' printNL.
+ chain := self
+ refChainFrom:el
+ to:anObject
+ inRefSets:levels
+ startingAt:(index+1).
+
+ chain notNil ifTrue:[
+ start == Smalltalk ifTrue:[
+ start keysAndValuesDo:[:key :val |
+ (val == el) ifTrue:[
+ chain addFirst:'Smalltalk:' , key.
+ ^ chain
+ ]
+ ]
+ ] ifFalse:[
+ names := start class allInstVarNames.
+ oClass := start class.
+ 1 to:oClass instSize do:[:i |
+ ((start instVarAt:i) == el) ifTrue:[
+ chain addFirst:(start -> ('[' , (names at:i) , ']')).
+ ^ chain
+ ].
+ ].
+ oClass isVariable ifTrue:[
+ oClass isPointers ifTrue:[
+ 1 to:start basicSize do:[:i |
+ ((start basicAt:i) == el) ifTrue:[
+ chain addFirst:(start -> ('[' , i printString , ']')).
+ ^ chain
+ ]
+ ]
+ ]
+ ].
+ ].
+
+ chain addFirst:start.
+
+ ^ chain
+ ]
+ ].
+ ].
+ ^ nil
+
+
+ "
+ |o a1 a2|
+
+ o := Object new.
+ a1 := Array with:o with:nil with:nil.
+ a2 := Array with:a1 with:nil with:nil.
+ a2 references:a1
+ "
+
+ "
+ |o a1 a2 a3 a4 levels|
+
+ o := Object new.
+ a1 := Array with:o.
+ a2 := Array with:a1.
+ a3 := Array with:a2.
+ a4 := Array with:a3.
+ levels := Array with:(Array with:a3)
+ with:(Array with:a2)
+ with:(Array with:a1).
+
+ self refChainFrom:a4 to:o inRefSets:levels startingAt:1.
"
"Modified: 19.3.1996 / 23:22:41 / cg"
!
-hist at:nw put:(hist at:nw) + 1
+sizeOf:anObject
+ "return the size of anObject in bytes.
+ (this is not the same as 'anObject size').
+ WARNING: this method is for ST/X debugging only
+ it will be removed without notice"
+
+%{ /* NOCONTEXT */
+
+ RETURN ( __isNonNilObject(anObject) ? __MKSMALLINT(__qSize(anObject)) : __MKSMALLINT(0) )
+%}
+ "
+ |hist big nw|
+
+ hist := Array new:100 withAll:0.
+ big := 0.
+ ObjectMemory allObjectsDo:[:o |
+ nw := (ObjectMemory sizeOf:o) // 4 + 1.
+ nw > 100 ifTrue:[
+ big := big + 1
+ ] ifFalse:[
+ hist at:nw put:(hist at:nw) + 1
].
].
hist printNL.
big printNL
"
+!
+
+spaceOf:anObject
+ "return the memory space, in which anObject is.
+ - since objects may move between spaces,
+ the returned value may be invalid after the next scavenge/collect.
+ WARNING: this method is for ST/X debugging only
+ it will be removed without notice"
+
+%{ /* NOCONTEXT */
+
+ if (! __isNonNilObject(anObject)) {
+ RETURN ( nil );
+ }
+ RETURN ( __MKSMALLINT( __qSpace(anObject) ) );
+%}
! !
!ObjectMemory class methodsFor:'dependents access'!
-INT( __qSpace(anObject) ) );
-%}
+dependents
+ "return the colleciton of my dependents"
+
+ ^ Dependents
!
-ts access'!
-
-endents:aCollection
+dependents:aCollection
"set the dependents collection"
Dependents := aCollection
-! !
-
-!ObjectMemory class methodsFor:'enumerating'!
-
-[
+!
+
+dependentsDo:aBlock
+ "evaluate aBlock for all of my dependents.
+ Since this is performed at startup time (under the scheduler),
+ this is redefined here to catch abort signals.
+ Thus, if any error occurs in a #returnFromSnapshot,
+ the user can press abort to continue."
+
+ |deps|
+
+ deps := Dependents.
+ deps notNil ifTrue:[
+ deps do:[:each |
+ AbortSignal handle:[:ex |
+ ex return
+ ] do:[
aBlock value:each
]
]
]
-!
-
-esOfDo(&aClass, &aBlock, &work COMMA_CON) < 0) {
+! !
+
+!ObjectMemory class methodsFor:'enumerating'!
+
+allInstancesOf:aClass do:aBlock
+ "evaluate the argument, aBlock for all instances of aClass in the system.
+ There is one caveat: if a compressing oldSpace collect
+ occurs while looping over the objects, the loop cannot be
+ continued (for some internal reasons). In this case, false
+ is returned."
+
+ |work|
+
+%{ /* NOREGISTER - work may not be placed into a register here */
+ __nonTenuringScavenge(__context);
+ /*
+ * allInstancesDo needs a temporary to hold newSpace objects
+ */
+ if (__allInstancesOfDo(&aClass, &aBlock, &work COMMA_CON) < 0) {
RETURN (false);
}
%}.
^ true
!
-sOfDo((OBJ *)0, &aBlock, &work COMMA_CON) < 0) {
+allObjectsDo:aBlock
+ "evaluate the argument, aBlock for all objects in the system.
+ There is one caveat: if a compressing oldSpace collect
+ occurs while looping over the objects, the loop cannot be
+ continued (for some internal reasons). In this case, false
+ is returned."
+
+ |work|
+
+%{ /* NOREGISTER - work may not be placed into a register here */
+ __nonTenuringScavenge(__context);
+ /*
+ * allObjectsDo needs a temporary to hold newSpace objects
+ */
+ if (__allInstancesOfDo((OBJ *)0, &aBlock, &work COMMA_CON) < 0) {
RETURN (false);
}
%}.
^ true
+!
+
+allOldObjectsDo:aBlock
+ "evaluate the argument, aBlock for all old objects in the system.
+ For debugging and tests only - do not use"
+%{
+ if (__allInstancesOfDo((OBJ *)0, &aBlock, (OBJ *)0 COMMA_CON) < 0) {
+ RETURN (false);
+ }
+%}.
+ ^ true
! !
!ObjectMemory class methodsFor:'garbage collection'!
-(false);
- }
-%}.
- ^ true
-!
-
-kgroundCollectProcess notNil
+backgroundCollectorRunning
+ "return true, if a backgroundCollector is running"
+
+ ^ BackgroundCollectProcess notNil
"
ObjectMemory backgroundCollectorRunning
"
!
-AndSweep(__context);
+compressingGarbageCollect
+ "search for and free garbage in the oldSpace (newSpace is cleaned automatically)
+ performing a COMPRESSING garbage collect.
+ This can take a long time - especially, if paging is involved
+ (when no paging is involved, its faster than I thought :-).
+ If no memory is available for the compress, or the system has been started with
+ the -Msingle option, this does a non-COMPRESSING collect."
+%{
+ if (! __garbageCollect(__context)) {
+ __markAndSweep(__context);
}
%}
@@ -1235,7 +1399,13 @@
"
!
-t to markAndSweep
+garbageCollect
+ "search for and free garbage in the oldSpace.
+ This can take a long time - especially, if paging is involved."
+
+ "/ used to be
+ "/ self compressingGarbageCollect
+ "/ here; changed to default to markAndSweep
self markAndSweep
@@ -1244,13 +1414,46 @@
"
!
-extern int __incrGCstep();
+gcStep
+ "one incremental garbage collect step.
+ Mark or sweep some small number of objects. This
+ method will return after a reasonable (short) time.
+ This is used by the ProcessorScheduler at idle times.
+ Returns true, if an incremental GC cycle has finished."
+%{
+ extern int __incrGCstep();
RETURN (__incrGCstep(__context) ? true : false);
%}
!
-OldSpaceIfUseful
+gcStepIfUseful
+ "If either the IncrementalGCLimit or the FreeSpaceGCLimits have been
+ reached, perform one incremental garbage collect step.
+ Return true, if more gcSteps are required to finish the cycle,
+ false if done with a gc round.
+ If no limit has been reached yet, do nothing and return false.
+ This is called by the ProcessorScheduler at idle times or by the
+ backgroundCollector."
+
+ |done limit|
+
+ AbortSignal handle:[:ex |
+ "/ in case of abort (from the debugger),
+ "/ disable gcSteps.
+ done := true.
+ IncrementalGCLimit := FreeSpaceGCLimit := nil.
+ 'OBJMEM: IGC aborted; turning off incremental GC' errorPrintNL
+ ] do:[
+ limit := IncrementalGCLimit.
+ (limit notNil and:[self oldSpaceAllocatedSinceLastGC > limit]) ifTrue:[
+ done := ObjectMemory gcStep
+ ] ifFalse:[
+ limit := FreeSpaceGCLimit.
+ (limit notNil and:[(self freeSpace + self freeListSpace) < limit]) ifTrue:[
+ done := ObjectMemory gcStep.
+ done ifTrue:[
+ self moreOldSpaceIfUseful
].
] ifFalse:[
done := true
@@ -1260,12 +1463,48 @@
^ done not
!
-ObjectMemory incrementalGC] forkAt:3
+incrementalGC
+ "perform one round of incremental GC steps.
+ The overall effect of this method is (almost) the same as calling
+ markAndSweep. However, #incrementalGC is interruptable while #markAndSweep
+ is atomic and blocks for a while. The code here performs incremental
+ GC steps, until one complete gc-cycle is completed. If running at a higher
+ than userBackground priority, it will give up the CPU after every such
+ step for a while.
+ Thus this method can be called either from a low prio (background) process
+ or from a high prio process.
+ (however, if you have nothing else to do, its better to call for markAndSweep,
+ since it is faster)
+ For example, someone allocating huge amounts of memory could
+ ask for the possibility of a quick allocation using
+ #checkForFastNew: and try a #incrementalGC if not. In many
+ cases, this can avoid a pause (in the higher prio processes) due to
+ a blocking GC."
+
+ |p delay|
+
+ Processor activeProcess priority > Processor userBackgroundPriority ifTrue:[
+ delay := Delay forMilliseconds:1
+ ].
+
+ [self gcStep] whileFalse:[
+ delay notNil ifTrue:[delay wait]
+ ].
+ self moreOldSpaceIfUseful
+
+ "
+ ObjectMemory incrementalGC
+ [ObjectMemory incrementalGC] forkAt:3
[ObjectMemory incrementalGC] forkAt:9
"
!
-ble."
+markAndSweep
+ "mark/sweep garbage collector.
+ perform a full mark&sweep collect.
+ Warning: this may take some time and it is NOT interruptable.
+ If you want to do a collect from a background process, or have
+ other things to do, better use #incrementalGC which is interruptable."
%{
__markAndSweep(__context);
%}
@@ -1275,7 +1514,12 @@
"
!
-."
+reclaimSymbols
+ "reclaim unused symbols;
+ Unused symbols are (currently) not reclaimed automatically,
+ but only upon request with this method.
+ It takes some time to do this ... and it is NOT interruptable.
+ Future versions may do this automatically, while garbage collecting."
%{
__reclaimSymbols(__context);
%}
@@ -1284,7 +1528,18 @@
"
!
-."
+scavenge
+ "collect young objects, without aging (i.e. no tenure).
+ Can be used to quickly get rid of shortly before allocated
+ stuff. This is relatively fast (compared to oldspace collect).
+
+ An example where a non-tenuring scavenge makes sense is when
+ allocating some OperatingSystem resource (a Color, File or View)
+ and the OS runs out of resources. In this case, the scavenge may
+ free some ST-objects and therefore (by signalling the WeakArrays
+ or Registries) free the OS resources too.
+ Of course, only recently allocated resources will be freed this
+ way. If none was freed, a full collect will be needed."
%{
__nonTenuringScavenge(__context);
%}
@@ -1294,12 +1549,69 @@
"
!
-tMemory freeSpaceGCLimit:1000000.
+startBackgroundCollectorAt:aPriority
+ "start a process doing incremental GC in the background.
+ Use this, if you have suspendable background processes which
+ run all the time, and therefore would prevent the idle-collector
+ from running. See documentation in this class for more details."
+
+ |p|
+
+ "/
+ "/ its not useful, to run it more than once
+ "/
+ BackgroundCollectProcess notNil ifTrue:[
+ BackgroundCollectProcess priority:aPriority.
+ ^ self
+ ].
+
+ p :=
+ [
+ [
+ [true] whileTrue:[
+ self gcStepIfUseful ifTrue:[
+ "
+ perform a full cycle
+ "
+ self incrementalGC
+ ].
+ "
+ wait a bit
+ "
+ (Delay forSeconds:5) wait
+ ]
+ ] valueOnUnwindDo:[
+ BackgroundCollectProcess := nil
+ ]
+ ] newProcess.
+ p name:'background collector'.
+ p priority:aPriority.
+ p restartable:true.
+ p resume.
+ BackgroundCollectProcess := p
+
+ "
+ the following lets the backgroundCollector run at prio 5
+ whenever 100000 bytes have been allocated, OR freeSpace drops
+ below 1meg. Having the system keep 1meg as reserve for peak allocation.
+
+ Doing this may reduce pauses due to inevitable collects when running
+ out of freeSpace, if the collector can keep up with allocation rate.
+ "
+
+ "
+ ObjectMemory incrementalGCLimit:100000.
+ ObjectMemory freeSpaceGCLimit:1000000.
ObjectMemory startBackgroundCollectorAt:5
"
!
-oundCollectProcess := nil
+stopBackgroundCollector
+ "stop the background collector"
+
+ BackgroundCollectProcess notNil ifTrue:[
+ BackgroundCollectProcess terminate.
+ BackgroundCollectProcess := nil
]
"
@@ -1307,12 +1619,40 @@
"
!
-tMemory tenure
+tenure
+ "force all living new stuff into old-space - effectively making
+ all living young objects become old objects immediately.
+ This is relatively fast (compared to oldspace collect).
+
+ This method should only be used in very special situations:
+ for example, when building up some long-living data structure
+ in a time critical application.
+ To do so, you have to do a scavenge followed by a tenure after the
+ objects are created. Be careful, to not reference any other chunk-
+ data when calling for a tenure (this will lead to lots of garbage in
+ the oldspace).
+ In normal situations, explicit tenures are not needed."
+%{
+ __tenure(__context);
+%}
+
+ "
+ ObjectMemory tenure
+ "
+ "
+ ... build up long living objects ...
+ ObjectMemory scavenge.
+ ObjectMemory tenure
... continue - objects created above are now in oldSpace ...
"
!
-ect)"
+tenuringScavenge
+ "collect newspace stuff, with aging (i.e. objects old enough
+ will be moved into the oldSpace).
+ Use this for debugging and testing only - the system performs
+ this automatically when the newspace fills up.
+ This is relatively fast (compared to oldspace collect)"
%{
__scavenge(__context);
%}
@@ -1320,15 +1660,54 @@
"
ObjectMemory tenuringScavenge
"
+!
+
+verboseGarbageCollect
+ "perform a compressing garbage collect and show some informational
+ output on the Transcript"
+
+ |nBytesBefore nReclaimed value unit|
+
+ nBytesBefore := self oldSpaceUsed.
+ self compressingGarbageCollect.
+ nReclaimed := nBytesBefore - self oldSpaceUsed.
+ nReclaimed > 0 ifTrue:[
+ nReclaimed > 1024 ifTrue:[
+ nReclaimed > (1024 * 1024) ifTrue:[
+ value := nReclaimed // (1024 * 1024).
+ unit := ' Mb.'
+ ] ifFalse:[
+ value := nReclaimed // 1024.
+ unit := ' Kb.'
+ ]
+ ] ifFalse:[
+ value := nReclaimed.
+ unit := ' bytes.'
+ ].
+ Transcript show:'reclaimed '; show:value printString.
+ Transcript showCr:unit
+ ]
+
+ "
+ ObjectMemory verboseGarbageCollect
+ "
! !
!ObjectMemory class methodsFor:'garbage collector control'!
-oseGarbageCollect
- "
-!
-
-eOldSpace:howMuch
+announceOldSpaceNeed:howMuch
+ "announce to the memory system, that howMuch bytes of memory will be needed
+ soon, which is going to live longer (whatever that means).
+ It first checks if the memory can be allocated without forcing a compressing
+ GC. If not, the oldSpace is increased. This may also lead to a slow compressing
+ collect. However, many smaller increases are avoided afterwards. Calling this
+ method before allocating huge chunks of data may provide better overall performance.
+ Notice: this is a nonstandard interface - use only in special situations."
+
+ (self checkForFastNew:howMuch) ifFalse:[
+ self incrementalGC.
+ (self checkForFastNew:howMuch) ifFalse:[
+ self moreOldSpace:howMuch
]
]
@@ -1337,7 +1716,25 @@
"
!
-moreOldSpace:howMuch
+announceSpaceNeed:howMuch
+ "announce to the memory system, that howMuch bytes of memory will be needed
+ soon. The VM tries to prepare itself for this allocation to be performed
+ with less overhead. For example, it could preallocate some memory in one
+ big chunk (instead of doing many smaller reallocations later).
+ Notice: this is a nonstandard interface - use only in special situations.
+ Also, this does a background collect before the big chunk of memory is
+ allocated, not locking other processes while doing so."
+
+ (howMuch < (self newSpaceSize // 2)) ifTrue:[
+ self scavenge.
+ ].
+ (self checkForFastNew:howMuch) ifFalse:[
+ (howMuch > (self newSpaceSize // 2)) ifFalse:[
+ self scavenge.
+ ].
+ self incrementalGC.
+ (self checkForFastNew:howMuch) ifFalse:[
+ self moreOldSpace:howMuch
]
]
@@ -1346,28 +1743,128 @@
"
!
-ERIMENTAL interface."
+avoidTenure:flag
+ "set/clear the avoidTenure flag. If set, aging of newSpace is turned off
+ as long as the newSpace fill-grade stays below some magic high-water mark.
+ If off (the default), aging is done as usual.
+ If the flag is turned on, scavenge may be a bit slower, due to more
+ objects being copied around. However, chances are high that in an idle
+ or (almost idle) system, less objects are moved into oldSpace.
+ Therefore, this helps to avoid oldSpace colelcts, in systems which go into
+ some standby mode and are reactivated by some external event.
+ (the avoid-flag should be turned off there, and set again once the idle loop
+ is reentered).
+
+ This is an EXPERIMENTAL interface."
%{ /* NOCONTEXT */
__avoidTenure(flag == true ? 1 : 0);
%}
!
+checkForFastNew:amount
+ "this method returns true, if amount bytes could be allocated
+ quickly (i.e. without forcing a full GC or compress).
+ This can be used for smart background processes, which want to
+ allocate big chunks of data without disturbing foreground processes
+ too much. Such a process would check for fast-allocation, and perform
+ incremental GC-steps if required. Thus, avoiding the long blocking pause
+ due to a forced (non-incremental) GC.
+ Especially: doing so will not block higher priority foreground processes.
+ See an example use in Behavior>>niceBasicNew:.
+ This is experimental and not guaranteed to be in future versions."
+
+%{ /* NOCONTEXT */
+ extern int __checkForFastNew();
+
+ if (__isSmallInteger(amount)) {
+ if (! __checkForFastNew(__intVal(amount))) {
+ RETURN (false);
+ }
+ }
+
+%}.
+ ^ true
!
-eAllocation:true.
+fastMoreOldSpaceAllocation:aBoolean
+ "this method turns on/off fastMoreOldSpace allocation.
+ By default, this is turned off (false), which means that in case of
+ a filled-up oldSpace, a GC is tried first before more oldSpace is allocated.
+ This strategy is ok for the normal operation of the system,
+ but behaves badly, if the program allocates huge data structures (say a
+ game tree of 30Mb in size) which survives and therefore will not be reclaimed
+ by a GC.
+ Of course while building this tree, and the memory becomes full, the system
+ would not know in advance, that the GC will not reclaim anything.
+
+ Setting fastOldSpaceIncrement to true will avoid this, by forcing the
+ memory system to allocate more memory right away, without doing a GC first.
+
+ WARNING: make certain that this flag is turned off, after your huge data
+ is allocated, since otherwise the system may continue to increase its
+ virtual memory without ever checking for garbage.
+ This method returns the previous value of the flag; typically this return
+ value should be used to switch back."
+
+%{ /* NOCONTEXT */
+ extern int __fastMoreOldSpaceAllocation();
+
+ RETURN (__fastMoreOldSpaceAllocation(aBoolean == true ? 1 : 0) ? true : false);
+%}
+ "
+ |previousSetting|
+
+ previousSetting := ObjectMemory fastMoreOldSpaceAllocation:true.
+ [
+ ...
+ allocate your huge data
+ ...
+ ] valueNoOrOnUnwindDo:[
+ ObjectMemory fastMoreOldSpaceAllocation:previousSetting
+ ]
+ "
+
+ "
+ |prev this|
+
+ prev := ObjectMemory fastMoreOldSpaceAllocation:true.
ObjectMemory fastMoreOldSpaceAllocation:prev.
^ prev
"
!
-aceLimit:10*1024*1024.
+fastMoreOldSpaceLimit:aNumber
+ "this method sets and returns the fastMoreOldSpace limit.
+ If fastMoreOldSpaceAllocation is true, and the current oldSpace size is
+ below this limit, the memory manager will NOT do a GC when running out of
+ oldSpace, but instead quickly go ahead increasing the size of the oldSpace.
+ Setting the limit to 0 turns off any limit (i.e. it will continue to
+ increase the oldSpace forwever - actually, until the OS refuses to give us
+ more memory). The returned value is the previous setting of the limit."
+
+%{ /* NOCONTEXT */
+ extern int __fastMoreOldSpaceLimit();
+
+ if (__isSmallInteger(aNumber)) {
+ RETURN ( __MKSMALLINT( __fastMoreOldSpaceLimit(__intVal(aNumber))));
+ }
+%}.
+ self primitiveFailed
+
+ "
+ |prev this|
+
+ prev := ObjectMemory fastMoreOldSpaceLimit:10*1024*1024.
ObjectMemory fastMoreOldSpaceLimit:prev.
^ prev
"
!
-riate value"
+freeSpaceGCAmount
+ "return the amount to be allocated if, after an incrementalGC,
+ not at least FreeSpaceGCLimit bytes are available for allocation.
+ The default is nil, which lets the system compute an abbpropriate value"
^ FreeSpaceGCAmount
@@ -1376,14 +1873,37 @@
"
!
-ppropriate amount ...)
+freeSpaceGCAmount:aNumber
+ "set the amount to be allocated if, after an incrementalGC,
+ not at least FreeSpaceGCLimit bytes are available for allocation.
+ The amount should be greater than the limit, otherwise the incremental
+ GC may try over and over to get the memory (actually waisting time)."
+
+ FreeSpaceGCAmount := aNumber
+
+ "
+ the following will try to always keep at least 1meg of free space
+ (in the background) and start to do so, whenever the freeSpace drops
+ below 250k.
+ "
+ "
+ ObjectMemory freeSpaceGCLimit:250000.
+ ObjectMemory freeSpaceGCAmount:1000000.
+ "
+
+ "
+ turn it off (i.e. let the system compute an appropriate amount ...)
"
"
ObjectMemory freeSpaceGCAmount:nil.
"
!
-trigger off."
+freeSpaceGCLimit
+ "return the freeSpace limit for incremental GC activation.
+ The system will start doing incremental background GC, once less than this number
+ of bytes are available in the compact free space.
+ The default is 100000; setting it to nil will turn this trigger off."
^ FreeSpaceGCLimit
@@ -1392,14 +1912,35 @@
"
!
-ystem hit the wall ...)
+freeSpaceGCLimit:aNumber
+ "set the freeSpace limit for incremental GC activation.
+ The system will start doing incremental background GC, once less than this number
+ of bytes are available for allocation.
+ The default is nil; setting it to nil will turn this trigger off."
+
+ FreeSpaceGCLimit := aNumber
+
+ "
+ the following will start the incrementalGC (in the background)
+ whenever the freeSpace drops below 1meg of free space
+ "
+ "
+ ObjectMemory freeSpaceGCLimit:1000000.
+ "
+
+ "
+ turn it off (i.e. let the system hit the wall ...)
"
"
ObjectMemory freeSpaceGCLimit:nil.
"
!
-gger off."
+incrementalGCLimit
+ "return the allocatedSinceLastGC limit for incremental GC activation.
+ The system will start doing incremental background GC, once more than this number
+ of bytes have been allocated since the last GC.
+ The default is 500000; setting it to nil will turn this trigger off."
^ IncrementalGCLimit
@@ -1408,26 +1949,76 @@
"
!
-'do incr. GC very often'
+incrementalGCLimit:aNumber
+ "set the allocatedSinceLastGC limit for incremental GC activation.
+ The system will start doing incremental background GC, once more than this number
+ of bytes have been allocated since the last GC.
+ The default is 500000; setting it to nil will turn this trigger off."
+
+ IncrementalGCLimit := aNumber
+
+ "
+ ObjectMemory incrementalGCLimit:500000. 'do incr. GC very seldom'
+ ObjectMemory incrementalGCLimit:100000. 'medium'
+ ObjectMemory incrementalGCLimit:10000. 'do incr. GC very often'
ObjectMemory incrementalGCLimit:nil. 'never'
"
!
-flag == true) {
+lockTenure:flag
+ "set/clear the tenureLock. If the lock is set, the system
+ completely turns off tenuring, and objects remain in newSpace (forever).
+ Once this lock is set, the system operates only in the newSpace and no memory
+ allocations from oldSpace are allowed (except for explicit tenure calls).
+ If any allocation request cannot be resoved, the VM raises a memory interrupt,
+ clears the lockTenure-flag and returns nil. Thus, it automatically falls back into
+ the normal mode of operation, to avoid big trouble
+ (fail to allocate memory when handling the exception).
+
+ This interface can be used in applications, which are guaranteed to have their
+ working set completely in the newSpace AND want to limit the worst case
+ pause times to the worst case scavenge time
+ (which itself is limitd by the size of the newSpace).
+ I.e. systems which go into some event loop after initial startup,
+ may turn on the tenureLock to make certain that no oldSpace memory is
+ allocated in the future; thereby limiting any GC activity to newSpace scavenges only.
+
+ This is an EXPERIMENTAL interface.
+ "
+
+%{
+ if (flag == true) {
__tenure(__context);
}
__lockTenure(flag == true ? 1 : 0);
%}
!
-if (__moveToOldSpace(anObject, __context) < 0) {
+makeOld:anObject
+ "move anObject into oldSpace.
+ This method is for internal & debugging purposes only -
+ it may vanish. Dont use it."
+%{
+ if (__moveToOldSpace(anObject, __context) < 0) {
RETURN (false);
}
%}.
^ true
!
-lse );
+moreOldSpace:howMuch
+ "allocate howMuch bytes more for old objects; return true if this worked,
+ false if that failed.
+ This is done automatically, when running out of space, but makes
+ sense, if its known in advance that a lot of memory is needed to
+ avoid multiple reallocations and compresses.
+ On systems which do not support the mmap (or equivalent) system call,
+ this (currently) implies a compressing garbage collect - so its slow.
+ Notice: this is a nonstandard interface - use only in special situations."
+
+%{
+ if (__isSmallInteger(howMuch)) {
+ RETURN( __moreOldSpace(__context, __intVal(howMuch)) ? true : false );
}
RETURN (false);
%}
@@ -1436,14 +2027,64 @@
"
!
-ease oldSpace - reset limit' errorPrintNL.
+moreOldSpaceIfUseful
+ "to be called after an incremental GC cycle;
+ if freeSpace is still below limit, allocate more oldSpace"
+
+ |limit free amount|
+
+ limit := FreeSpaceGCLimit.
+ limit notNil ifTrue:[
+ "/ if reclaimed space is below limit, we have to allocate more
+ "/ oldSpace, to avoid excessive gcSteps (due to freeSpaceLimit
+ "/ still not reached)
+ "/
+ free := self freeSpace + self freeListSpace.
+ free < (limit * 3 // 2) ifTrue:[
+ amount := FreeSpaceGCAmount.
+ amount isNil ifTrue:[
+ amount := limit * 3 // 2.
+ ].
+ 'OBJECTMEMORY: moreOldSpace to satisfy free-limit' infoPrintNL.
+ (self moreOldSpace:(amount - free + (64*1024))) ifFalse:[
+ "/
+ "/ could not increase oldspace; reset FreeSpaceGCLimit to avoid
+ "/ useless retries
+ 'OBJECTMEMORY: could not increase oldSpace - reset limit' errorPrintNL.
FreeSpaceGCLimit := nil
]
].
].
!
-Size:200*1024
+newSpaceSize:newSize
+ "change the size of the newSpace. To do this, the current contents
+ of the newSpace may have to be tenured (if size is smaller).
+ Returns false, if it failed for any reason.
+ Experimental: this interface may valish without notice.
+
+ DANGER ALERT:
+ be careful too big of a size may lead to longer scavenge pauses.
+ Too small of a newSpace may lead to more CPU overhead, due to
+ excessive scavenges. You have been warned."
+
+%{
+ extern int __setNewSpaceSize();
+
+ if (__isSmallInteger(newSize)) {
+ RETURN (__setNewSpaceSize(__intVal(newSize)) ? true : false);
+ }
+%}.
+ self primitiveFailed
+
+ " less absolute CPU overhead (but longer pauses):
+
+ ObjectMemory newSpaceSize:800*1024
+ "
+
+ " smaller pauses, but more overall CPU overhead:
+
+ ObjectMemory newSpaceSize:200*1024
"
" the default:
@@ -1452,207 +2093,356 @@
"
!
-T( __compressingGCLimit(-1) ));
+oldSpaceCompressLimit
+ "return the limit for oldSpace compression. If more memory than this
+ limit is in use, the system will not perform compresses on the oldspace,
+ but instead do a mark&sweep GC followed by an oldSpace increase if not enough
+ could be reclaimed. The default is currently some 8Mb, which is ok for workstations
+ with 16..32Mb of physical memory. If your system has much more physical RAM,
+ you may want to increase this limit."
+
+%{ /* NOCONTEXT */
+ extern unsigned __compressingGCLimit();
+
+ RETURN (__MKSMALLINT( __compressingGCLimit(-1) ));
%}
"
ObjectMemory oldSpaceCompressLimit
"
!
-e the limit to 12Mb:"
+oldSpaceCompressLimit:amount
+ "set the limit for oldSpace compression. If more memory than this
+ limit is in use, the system will not perform compresses on the oldspace,
+ but instead do a mark&sweep GC followed by an oldSpace increase if not enough
+ could be reclaimed. The default is currently some 8Mb, which is ok for workstations
+ with 16..32Mb of physical memory. If your system has much more physical RAM,
+ you may want to increase this limit.
+ This method returns the previous increment value."
+
+%{ /* NOCONTEXT */
+ extern unsigned __compressingGCLimit();
+
+ if (__isSmallInteger(amount)) {
+ RETURN (__MKSMALLINT( __compressingGCLimit(__intVal(amount)) ));
+ }
+%}
+ "to change the limit to 12Mb:"
"
ObjectMemory oldSpaceCompressLimit:12*1024*1024
"
!
-LLINT( __oldSpaceIncrement(-1) ));
+oldSpaceIncrement
+ "return the oldSpaceIncrement value. Thats the amount by which
+ more memory is allocated in case the oldSpace gets filled up.
+ In normal situations, the default value used in the VM is fine
+ and there is no need to change it."
+
+%{ /* NOCONTEXT */
+ extern unsigned __oldSpaceIncrement();
+
+ RETURN (__MKSMALLINT( __oldSpaceIncrement(-1) ));
%}
"
ObjectMemory oldSpaceIncrement
"
!
-o change increment to 1Meg:"
+oldSpaceIncrement:amount
+ "set the oldSpaceIncrement value. Thats the amount by which
+ more memory is allocated in case the oldSpace gets filled up.
+ In normal situations, the default value used in the VM is fine
+ and there is no need to change it. This method returns the
+ previous increment value."
+
+%{ /* NOCONTEXT */
+ extern unsigned __oldSpaceIncrement();
+
+ if (__isSmallInteger(amount)) {
+ RETURN (__MKSMALLINT( __oldSpaceIncrement(__intVal(amount)) ));
+ }
+%}
+ "to change increment to 1Meg:"
"
ObjectMemory oldSpaceIncrement:1024*1024
"
!
-e system may behave very strange."
+tenureParameters:magic
+ "this is pure magic and not for public eyes ...
+ This method allows fine tuning the scavenger internals,
+ in cooperation to some statistic & test programs.
+ It is undocumented, secret and may vanish.
+ If you play around here, the system may behave very strange."
%{ /* NOCONTEXT */
__tenureParams(magic);
%}.
!
-n by the time you read this."
+turnGarbageCollectorOff
+ "turn off the generational garbage collector by forcing new objects to be
+ allocated directly in oldSpace (instead of newSpace)
+ WARNING:
+ This is somewhat dangerous: if collector is turned off,
+ and too many objects are created, the system may run into trouble
+ (i.e. oldSpace becomes full) and be forced to perform a full mark&sweep
+ or even a compressing collect - making the overall realtime behavior worse.
+ Use this only for special purposes or when realtime behavior
+ is required for a limited time period.
+
+ OBSOLETE: this is no longer supported
+ - it may be a no-operation by the time you read this."
%{ /* NOCONTEXT */
__allocForceSpace(OLDSPACE);
%}
!
-Memory>>turnGarbageCollectorOff)"
+turnGarbageCollectorOn
+ "turn garbage collector on again (see ObjectMemory>>turnGarbageCollectorOff)"
%{ /* NOCONTEXT */
__allocForceSpace(9999);
%}
+!
+
+watchTenure:flag
+ "set/clear the tenureWatch. If set, an internalError exception will be raised,
+ whenever objects are tenured from newSpace into oldSpace
+ (except for an explicit tenure request).
+ This can be used to validate that no oldSpace objects are created
+ (i.e. the system operates fully in newSpace).
+ Be careful, if the avoidTenure flag is not set,
+ there will almost always be a tenure sooner or later.
+
+ EXPERIMENTAL - no warranty"
+
+%{ /* NOCONTEXT */
+ __watchTenure(flag == true ? 1 : 0);
+%}
! !
!ObjectMemory class methodsFor:'interrupt handler access'!
-lag == true ? 1 : 0);
-%}
-!
-
-for UNIX-death-of-a-childprocess-signal interrupts"
+childSignalInterruptHandler
+ "return the handler for UNIX-death-of-a-childprocess-signal interrupts"
^ ChildSignalInterruptHandler
!
-reated: 22.12.1995 / 14:14:52 / stefan"
+childSignalInterruptHandler:aHandler
+ "set the handler for UNIX-death-of-a-childprocess-signal interrupts"
+
+ ChildSignalInterruptHandler := aHandler
+
+ "Created: 22.12.1995 / 14:14:52 / stefan"
"Modified: 22.12.1995 / 14:15:16 / stefan"
!
-ptHandler
+customInterruptHandler
"return the handler for custom interrupts"
^ CustomInterruptHandler
!
-er
+customInterruptHandler:aHandler
"set the handler for custom interrupts"
CustomInterruptHandler := aHandler
!
-"return the handler for object disposal interrupts"
+disposeInterruptHandler
+ "return the handler for object disposal interrupts"
^ DisposeInterruptHandler
!
-t the handler for object disposal interrupts"
+disposeInterruptHandler:aHandler
+ "set the handler for object disposal interrupts"
DisposeInterruptHandler := aHandler
!
-ler
+errorInterruptHandler
"return the handler for display error interrupts"
^ ErrorInterruptHandler
!
-"set the handler for display error interrupts"
+errorInterruptHandler:aHandler
+ "set the handler for display error interrupts"
ErrorInterruptHandler := aHandler
!
-the handler for floating point exception interrupts"
+exceptionInterruptHandler
+ "return the handler for floating point exception interrupts"
^ ExceptionInterruptHandler
!
-c.
+internalErrorHandler
+ "return the handler for ST/X internal errors.
+ An internal error is reported for example when a methods
+ bytecode is not a ByteArray, the selector table is not an Array
+ etc.
Those should not occur in normal circumstances."
^ InternalErrorHandler
!
-handler for I/O available signal interrupts (SIGIO/SIGPOLL)"
+ioInterruptHandler
+ "return the handler for I/O available signal interrupts (SIGIO/SIGPOLL)"
^ IOInterruptHandler
!
-r I/O available signal interrupts (SIGIO/SIGPOLL)"
+ioInterruptHandler:aHandler
+ "set the handler for I/O available signal interrupts (SIGIO/SIGPOLL)"
IOInterruptHandler := aHandler
!
-the handler for recursion/stack overflow interrupts"
+recursionInterruptHandler
+ "return the handler for recursion/stack overflow interrupts"
^ RecursionInterruptHandler
!
-er for recursion/stack overflow interrupts"
+recursionInterruptHandler:aHandler
+ "set the handler for recursion/stack overflow interrupts"
RecursionInterruptHandler := aHandler
!
-ctionary new
+registerErrorInterruptHandler:aHandler forID:errorIDSymbol
+ "register a handler"
+
+ RegisteredErrorInterruptHandlers isNil ifTrue:[
+ RegisteredErrorInterruptHandlers := IdentityDictionary new
].
RegisteredErrorInterruptHandlers at:errorIDSymbol put:aHandler
!
-rruptHandlers
+registeredErrorInterruptHandlers
"return registered handlers"
^ RegisteredErrorInterruptHandlers
!
-dler
+signalInterruptHandler
"return the handler for UNIX-signal interrupts"
^ SignalInterruptHandler
!
-"set the handler for UNIX-signal interrupts"
+signalInterruptHandler:aHandler
+ "set the handler for UNIX-signal interrupts"
SignalInterruptHandler := aHandler
!
-ptHandler
+spyInterruptHandler
"return the handler for spy-timer interrupts"
^ SpyInterruptHandler
!
-er
+spyInterruptHandler:aHandler
"set the handler for spy-timer interrupts"
SpyInterruptHandler := aHandler
!
-andler
+stepInterruptHandler
"return the handler for single step interrupts"
^ StepInterruptHandler
!
-"set the handler for single step interrupts"
+stepInterruptHandler:aHandler
+ "set the handler for single step interrupts"
StepInterruptHandler := aHandler
!
-ruptHandler
+timerInterruptHandler
"return the handler for timer interrupts"
^ TimerInterruptHandler
!
-dler
+timerInterruptHandler:aHandler
"set the handler for timer interrupts"
TimerInterruptHandler := aHandler
!
-ler
+userInterruptHandler
"return the handler for CNTL-C interrupt handling"
^ UserInterruptHandler
+!
+
+userInterruptHandler:aHandler
+ "set the handler for CNTL-C interrupt handling"
+
+ UserInterruptHandler := aHandler
! !
!ObjectMemory class methodsFor:'interrupt statistics'!
-InterruptHandler := aHandler
-!
-
-"
+interruptLatency:ms receiver:rec class:cls selector:sel vmActivity:vmActivity id:pid
+ "example implementation of latencyTime monitoring:
+ This method simply measures the max-latency time.
+ You may want to use some other handler (see #interruptLatencyMonitor:)
+ and extract more information (blocking context).
+ DEMO Example."
+
+ ms > MaxInterruptLatency ifTrue:[
+ MaxInterruptLatency := ms.
+ 'IRQ-LATENCY: ' infoPrint. rec class infoPrint. ' ' infoPrint. sel infoPrint. '(' infoPrint. vmActivity infoPrint . ') ---> ' infoPrint. ms infoPrintNL.
+ ].
+ (InterruptLatencyGoal notNil and:[ms > InterruptLatencyGoal]) ifTrue:[
+ '*** IRQ REALTIME-DEADLINE MISSED: ' errorPrint.
+ rec isBehavior ifTrue:[
+ rec name errorPrint. 'class' errorPrint.
+ ] ifFalse:[
+ rec class errorPrint
+ ].
+ ' ' errorPrint. sel errorPrint. '(' errorPrint. vmActivity errorPrint . ') ---> ' errorPrint.
+ ms errorPrintNL.
+ ].
+
+ "to enable the demo handler:
+
+ ObjectMemory resetMaxInterruptLatency.
+ ObjectMemory interruptLatencyMonitor:ObjectMemory.
+ "
+ "to disable timing statistics:
+
+ ObjectMemory interruptLatencyMonitor:nil.
+ ObjectMemory maxInterruptLatency printNL.
+ "
"Created: 7.11.1995 / 21:05:50 / cg"
"Modified: 7.11.1995 / 21:13:33 / cg"
!
-ptLatencyMonitor := self.
+interruptLatencyGoal:millis
+ "setup to report an error message, whenever a realtime goal could not be
+ met due to blocked interrupts or long primitives or GC activity.
+ An argument of nil clears the check.
+ DEMO Example."
+
+ InterruptLatencyGoal := millis.
+ millis isNil ifTrue:[
+ InterruptLatencyMonitor := nil.
+ ] ifFalse:[
+ MaxInterruptLatency := 0.
+ InterruptLatencyMonitor := self.
]
"
@@ -1660,46 +2450,86 @@
"
!
-non-standard debugging/realtime instrumentation entry."
+interruptLatencyMonitor
+ "return the interrupt-latency-monitor if any.
+ See comment in #interruptLatencyMonitor:.
+ This is a non-standard debugging/realtime instrumentation entry."
^ InterruptLatencyMonitor
!
-rd debugging/realtime instrumentation entry."
+interruptLatencyMonitor:aHandler
+ "set the interrupt latency monitor. If non-nil, this one will be sent
+ an interruptLatency: message with the millisecond delay between
+ the interrupt and its handling.
+ This is a non-standard debugging/realtime instrumentation entry."
InterruptLatencyMonitor := aHandler
!
-ccumulated interrupt latency in millis.
+maxInterruptLatency
+ "return the maximum accumulated interrupt latency in millis.
DEMO Example."
^ MaxInterruptLatency
+!
+
+resetMaxInterruptLatency
+ "reset the maximum accumulated interrupt latency probe time.
+ DEMO Example."
+
+ MaxInterruptLatency := 0
! !
!ObjectMemory class methodsFor:'low memory handling'!
-MaxInterruptLatency := 0
-!
-
-orPrintNL.
+memoryInterrupt
+ "when a low-memory condition arises, ask all classes to
+ remove possibly cached data. You may help the system a bit,
+ in providing a lowSpaceCleanup method in your classes which have
+ lots of data kept somewhere (usually, cached data).
+ - this may or may not help."
+
+ self performLowSpaceCleanup.
+"/ self error:'almost out of memory'
+ 'almost out of memory' errorPrintNL.
LowSpaceSemaphore signalIf.
"Modified: 12.4.1996 / 14:57:55 / cg"
+!
+
+performLowSpaceCleanup
+ "ask all classes to remove possibly cached data.
+ You may help the system a bit, in providing a lowSpaceCleanup method
+ in your classes which have lots of data kept somewhere (usually, cached data)."
+
+ Smalltalk allBehaviorsDo:[:aClass |
+ aClass lowSpaceCleanup
+ ].
+
+ "Created: 12.4.1996 / 14:57:28 / cg"
! !
!ObjectMemory class methodsFor:'object finalization'!
-d: 12.4.1996 / 14:57:28 / cg"
-!
-
-lost a pointer recently."
+allChangedShadowObjectsDo:aBlock
+ "evaluate the argument, aBlock for all known shadow objects which have
+ lost a pointer recently."
%{
__allChangedShadowObjectsDo(&aBlock COMMA_CON);
%}
!
-tionSemaphore signal
+disposeInterrupt
+ "this is triggered by the garbage collector,
+ whenever any shadowArray looses a pointer."
+
+ FinalizationSemaphore notNil ifTrue:[
+ "/
+ "/ background finalizer is waiting ...
+ "/
+ FinalizationSemaphore signal
] ifFalse:[
"/
"/ do it right here
@@ -1708,169 +2538,399 @@
]
!
-self allChangedShadowObjectsDo:[:aShadowArray |
+finalize
+ "tell all weak objects that something happened."
+
+ self allChangedShadowObjectsDo:[:aShadowArray |
aShadowArray lostPointer.
]
!
-inalizationProcess := p
+startBackgroundFinalizationAt:aPriority
+ "start a process doing finalization work in the background.
+ Can be used to reduce the pauses created by finalization.
+ Normally, these pauses are not noticed; however if you have (say)
+ ten thousands of weak objects, these could become long enough to
+ make background finalization usefull.
+ WARNING: background finalization may lead to much delayed freeing of
+ system resources. Especially, you may temporarily run out of free
+ color table entries or fileDescriptors etc. Use at your own risk (if at all)"
+
+ |p|
+
+ "/
+ "/ its not useful, to run it more than once
+ "/
+ BackgroundFinalizationProcess notNil ifTrue:[
+ BackgroundFinalizationProcess priority:aPriority.
+ ^ self
+ ].
+
+ FinalizationSemaphore := Semaphore new.
+
+ p :=
+ [
+ [
+ [true] whileTrue:[
+ "
+ wait till something to do ...
+ "
+ FinalizationSemaphore wait.
+ "
+ ... and do it
+ "
+ self finalize
+ ]
+ ] valueOnUnwindDo:[
+ BackgroundFinalizationProcess := nil.
+ FinalizationSemaphore := nil
+ ]
+ ] newProcess.
+ p name:'background finalizer'.
+ p priority:aPriority.
+ p restartable:true.
+ p resume.
+ BackgroundFinalizationProcess := p
"
ObjectMemory startBackgroundFinalizationAt:5
"
+!
+
+stopBackgroundFinalization
+ "stop the background finalizer"
+
+ BackgroundFinalizationProcess notNil ifTrue:[
+ BackgroundFinalizationProcess terminate.
+ BackgroundFinalizationProcess := nil
+ ].
+
+ "
+ ObjectMemory stopBackgroundFinalization
+ "
! !
!ObjectMemory class methodsFor:'physical memory access'!
-ckgroundFinalization
- "
-!
-
-llectedOldSpacePagesDo(&aBlock COMMA_CON) < 0) {
+collectedOldSpacePagesDo:aBlock
+ "evaluates aBlock for all pages in the prev. oldSpace, passing
+ the pages address as argument.
+ For internal & debugging use only."
+%{
+ if (__collectedOldSpacePagesDo(&aBlock COMMA_CON) < 0) {
RETURN (false);
}
%}.
^ true
!
-if (__newSpacePagesDo(&aBlock COMMA_CON) < 0) {
+newSpacePagesDo:aBlock
+ "evaluates aBlock for all pages in the newSpace, passing
+ the pages address as argument.
+ For internal & debugging use only."
+%{
+ if (__newSpacePagesDo(&aBlock COMMA_CON) < 0) {
RETURN (false);
}
%}.
^ true
!
-if (__oldSpacePagesDo(&aBlock COMMA_CON) < 0) {
+oldSpacePagesDo:aBlock
+ "evaluates aBlock for all pages in the oldSpace, passing
+ the pages address as argument.
+ For internal & debugging use only."
+%{
+ if (__oldSpacePagesDo(&aBlock COMMA_CON) < 0) {
RETURN (false);
}
%}.
^ true
+!
+
+pageIsInCore:aPageNumber
+ "return true, if the page (as enumerated via oldSpacePagesDo:)
+ is in memory; false, if currently paged out. For internal
+ use / monitors only; may vanish.
+ NOTICE: not all systems provide this information; on those that
+ do not, true is returned for all pages."
+%{
+#ifdef HAS_MINCORE
+ int pageSize = getpagesize();
+ char result[10];
+ INT addr;
+
+ if (__isSmallInteger(aPageNumber)) {
+ addr = __intVal(aPageNumber) & ~(pageSize - 1);
+ } else {
+ addr = ((INT)aPageNumber) & ~(pageSize - 1);
+ }
+ if (mincore(addr, pageSize-1, result) < 0) {
+ RETURN (true);
+ }
+ RETURN ((result[0] & 1) ? true : false);
+#endif
+%}.
+ "OS does not supply this info - assume yes"
+ ^ true
! !
!ObjectMemory class methodsFor:'queries'!
-supply this info - assume yes"
- ^ true
-!
-
-__newSpaceUsed() - __freeListSpace()) );
+bytesUsed
+ "return the number of bytes allocated for objects -
+ this number is not exact, since some objects may already be dead
+ (i.e. not yet reclaimed by the garbage collector).
+ If you need the exact number, you have to loop over all
+ objects and ask for the bytesize using ObjectMemory>>sizeOf:."
+
+%{ /* NOCONTEXT */
+ extern unsigned __oldSpaceUsed(), __newSpaceUsed(), __freeListSpace();
+
+ RETURN ( __MKSMALLINT(__oldSpaceUsed() + __newSpaceUsed() - __freeListSpace()) );
%}
"
ObjectMemory bytesUsed
"
!
-[
+collectObjectsWhich:aBlock
+ "helper for the whoReferences queries. Returns a collection
+ of objects for which aBlock returns true."
+
+ |aCollection|
+
+ aCollection := IdentitySet new.
+ self allObjectsDo:[:o |
+ (aBlock value:o) ifTrue:[
+ aCollection add:o
+ ]
+ ].
+ (aCollection size == 0) ifTrue:[
"actually this cannot happen - there is always one"
^ nil
].
^ aCollection
!
-TURN ( __MKSMALLINT(__fixSpaceSize()) );
+fixSpaceSize
+ "return the total size of the fix space."
+
+%{ /* NOCONTEXT */
+ extern unsigned __fixSpaceSize();
+
+ RETURN ( __MKSMALLINT(__fixSpaceSize()) );
%}
"
ObjectMemory fixSpaceSize
"
!
-TURN ( __MKSMALLINT(__fixSpaceUsed()) );
+fixSpaceUsed
+ "return the number of bytes allocated for old objects in fix space."
+
+%{ /* NOCONTEXT */
+ extern unsigned __fixSpaceUsed();
+
+ RETURN ( __MKSMALLINT(__fixSpaceUsed()) );
%}
"
ObjectMemory fixSpaceUsed
"
!
-RN ( __MKSMALLINT(__freeListSpace()) );
+freeListSpace
+ "return the number of bytes in the free lists.
+ (which is included in oldSpaceUsed)"
+
+%{ /* NOCONTEXT */
+ extern unsigned __freeListSpace();
+
+ RETURN ( __MKSMALLINT(__freeListSpace()) );
%}
"
ObjectMemory freeListSpace
"
!
-INT(__oldSpaceSize() - __oldSpaceUsed()) );
+freeSpace
+ "return the number of bytes in the compact free area.
+ (oldSpaceUsed + freeSpaceSize = oldSpaceSize)"
+
+%{ /* NOCONTEXT */
+ extern unsigned __oldSpaceSize(), __oldSpaceUsed();
+
+ RETURN ( __MKSMALLINT(__oldSpaceSize() - __oldSpaceUsed()) );
%}
"
ObjectMemory freeSpace
"
!
-LLINT(__garbageCollectCount()));
+garbageCollectCount
+ "return the number of compressing collects that occurred since startup"
+
+%{ /* NOCONTEXT */
+ extern int __garbageCollectCount();
+
+ RETURN (__MKSMALLINT(__garbageCollectCount()));
%}
"
ObjectMemory garbageCollectCount
"
!
-SMALLINT(__incrementalGCCount()));
+incrementalGCCount
+ "return the number of incremental collects that occurred since startup"
+
+%{ /* NOCONTEXT */
+ extern int __incrementalGCCount();
+
+ RETURN (__MKSMALLINT(__incrementalGCCount()));
%}
"
ObjectMemory incrementalGCCount
"
!
-EXT */
+incrementalGCPhase
+ "returns the internal state of the incremental GC.
+ The meaning of those numbers is a secret :-).
+ (for the curious: (currently)
+ 2 is idle, 3..11 are various mark phases,
+ 12 is the sweep phase. 0 and 1 are cleanup phases when the
+ incr. GC gets interrupted by a full GC).
+ Do not depend on the values - there may be additional phases in
+ future versions (incremental compact ;-).
+ This is for debugging and monitoring only - and may change or vanish"
+
+%{ /* NOCONTEXT */
extern int __incrGCphase();
RETURN (__MKSMALLINT(__incrGCphase()));
%}
!
-ctMemory lastScavengeReclamation)
+lastScavengeReclamation
+ "returns the number of bytes replacimed by the last scavenge.
+ For statistic only - this may vanish."
+
+%{ /* NOCONTEXT */
+ extern int __newSpaceReclaimed();
+
+ RETURN ( __MKSMALLINT(__newSpaceReclaimed()) );
+%}
+ "percentage of reclaimed objects is returned by:
+
+ ((ObjectMemory lastScavengeReclamation)
/ (ObjectMemory newSpaceSize)) * 100.0
"
!
-RETURN ( __lifoRememberedSet() );
+lifoRememberedSet
+ "return the lifoRemSet.
+ This is pure VM debugging and will vanish without notice."
+
+%{ /* NOCONTEXT */
+ extern OBJ __lifoRememberedSet();
+
+ RETURN ( __lifoRememberedSet() );
%}
"
ObjectMemory lifoRememberedSet
"
!
-NT(__lifoRememberedSetSize()));
+lifoRememberedSetSize
+ "return the size of the lifoRemSet.
+ This is a VM debugging interface and may vanish without notice."
+
+%{ /* NOCONTEXT */
+ extern int __lifoRememberedSetSize();
+
+ RETURN (__MKSMALLINT(__lifoRememberedSetSize()));
%}
"
ObjectMemory lifoRememberedSetSize
"
!
-KSMALLINT(__markAndSweepCount()));
+markAndSweepCount
+ "return the number of mark&sweep collects that occurred since startup"
+
+%{ /* NOCONTEXT */
+ extern int __markAndSweepCount();
+
+ RETURN (__MKSMALLINT(__markAndSweepCount()));
%}
"
ObjectMemory markAndSweepCount
"
!
-HASH__ << __HASH_SHIFT__) );
+maximumIdentityHashValue
+ "for ST-80 compatibility: return the maximum value
+ a hashKey as returned by identityHash can get.
+ Since ST/X uses direct pointers, a field in the objectHeader
+ is used, which is currently 11 bits in size."
+
+%{ /* NOCONTEXT */
+ RETURN ( __MKSMALLINT( __MAX_HASH__ << __HASH_SHIFT__) );
%}
"
ObjectMemory maximumIdentityHashValue
"
!
-T(__newSpaceReclaimedMin()) );
+minScavengeReclamation
+ "returns the number of bytes replacimed by the least effective scavenge.
+ For statistic only - this may vanish."
+
+%{ /* NOCONTEXT */
+ extern int __newSpaceReclaimedMin();
+
+ RETURN ( __MKSMALLINT(__newSpaceReclaimedMin()) );
%}
"
ObjectMemory minScavengeReclamation
"
!
-TURN ( __MKSMALLINT(__newSpaceSize()) );
+newSpaceSize
+ "return the total size of the new space - this is usually fix"
+
+%{ /* NOCONTEXT */
+ extern unsigned __newSpaceSize();
+
+ RETURN ( __MKSMALLINT(__newSpaceSize()) );
%}
"
ObjectMemory newSpaceSize
"
!
-N ( __MKSMALLINT(__newSpaceUsed()) );
+newSpaceUsed
+ "return the number of bytes allocated for new objects.
+ The returned value is usually obsolete as soon as you do
+ something with it ..."
+
+%{ /* NOCONTEXT */
+ extern unsigned __newSpaceUsed();
+
+ RETURN ( __MKSMALLINT(__newSpaceUsed()) );
%}
"
ObjectMemory newSpaceUsed
"
!
-bj | tally := tally + 1].
+numberOfObjects
+ "return the number of objects in the system."
+
+ |tally "{ Class: SmallInteger }"|
+
+ tally := 0.
+ self allObjectsDo:[:obj | tally := tally + 1].
^ tally
"
@@ -1878,117 +2938,224 @@
"
!
-__MKSMALLINT(__weakListSize()) );
+numberOfWeakObjects
+ "return the number of weak objects in the system"
+
+%{ /* NOCONTEXT */
+ extern int __weakListSize();
+
+ RETURN ( __MKSMALLINT(__weakListSize()) );
%}
"
ObjectMemory numberOfWeakObjects
"
!
-atedSinceLastGC()) );
+oldSpaceAllocatedSinceLastGC
+ "return the number of bytes allocated for old objects since the
+ last oldspace garbage collect occured. This information is used
+ by ProcessorScheduler to decide when to start the incremental
+ background GC."
+
+%{ /* NOCONTEXT */
+ extern unsigned __oldSpaceAllocatedSinceLastGC();
+
+ RETURN ( __MKSMALLINT(__oldSpaceAllocatedSinceLastGC()) );
%}
"
ObjectMemory oldSpaceAllocatedSinceLastGC
"
!
-TURN ( __MKSMALLINT(__oldSpaceSize()) );
+oldSpaceSize
+ "return the total size of the old space. - may grow slowly"
+
+%{ /* NOCONTEXT */
+ extern unsigned __oldSpaceSize();
+
+ RETURN ( __MKSMALLINT(__oldSpaceSize()) );
%}
"
ObjectMemory oldSpaceSize
"
!
-RN ( __MKSMALLINT(__oldSpaceUsed()) );
+oldSpaceUsed
+ "return the number of bytes allocated for old objects.
+ (This includes the free lists)"
+
+%{ /* NOCONTEXT */
+ extern unsigned __oldSpaceUsed();
+
+ RETURN ( __MKSMALLINT(__oldSpaceUsed()) );
%}
"
ObjectMemory oldSpaceUsed
"
!
-MKSMALLINT(__rememberedSetSize()));
+rememberedSetSize
+ "return the number of old objects referencing new ones.
+ This is a VM debugging interface and may vanish without notice."
+
+%{ /* NOCONTEXT */
+ extern int __rememberedSetSize();
+
+ RETURN (__MKSMALLINT(__rememberedSetSize()));
%}
"
ObjectMemory rememberedSetSize
"
!
-jectMemory resetMinScavengeReclamation.
+resetMinScavengeReclamation
+ "resets the number of bytes replacimed by the least effective scavenge.
+ For statistic only - this may vanish."
+
+%{ /* NOCONTEXT */
+ extern int __resetNewSpaceReclaimedMin();
+
+ __resetNewSpaceReclaimedMin();
+%}.
+ ^ self
+ "
+ ObjectMemory resetMinScavengeReclamation.
ObjectMemory minScavengeReclamation
"
!
-ngleOldSpace() ? true : false) );
+runsSingleOldSpace
+ "return true, if the system runs in a single oldSpace or
+ false if not.
+ The memory system will always drop the second semispace when
+ running out of virtual memory, or the baker-limit is reached.
+ OBSOLETE:
+ the system may now decide at any time to switch between
+ single and double-space algorithms, depending on the overall memory
+ size. You will now almost always get false as result, since the
+ second semispace is only allocated when needed, and released
+ immediately afterwards.
+ "
+
+%{ /* NOCONTEXT */
+ extern int __runsSingleOldSpace();
+
+ RETURN ( (__runsSingleOldSpace() ? true : false) );
%}
"
ObjectMemory runsSingleOldSpace
"
!
-URN (__MKSMALLINT(__scavengeCount()));
+scavengeCount
+ "return the number of scavenges that occurred since startup"
+
+%{ /* NOCONTEXT */
+ extern int __scavengeCount();
+
+ RETURN (__MKSMALLINT(__scavengeCount()));
%}
"
ObjectMemory scavengeCount
"
!
-TURN ( __MKSMALLINT(__symSpaceSize()) );
+symSpaceSize
+ "return the total size of the sym space."
+
+%{ /* NOCONTEXT */
+ extern unsigned __symSpaceSize();
+
+ RETURN ( __MKSMALLINT(__symSpaceSize()) );
%}
"
ObjectMemory symSpaceSize
"
!
-TURN ( __MKSMALLINT(__symSpaceUsed()) );
+symSpaceUsed
+ "return the number of bytes allocated for old objects in sym space."
+
+%{ /* NOCONTEXT */
+ extern unsigned __symSpaceUsed();
+
+ RETURN ( __MKSMALLINT(__symSpaceUsed()) );
%}
"
ObjectMemory symSpaceUsed
"
!
-*/
+tenureAge
+ "return the current tenure age - thats the number of times
+ an object has to survive scavenges to be moved into oldSpace.
+ For statistic/debugging only - this method may vanish"
+
+%{ /* NOCONTEXT */
extern unsigned __tenureAge();
RETURN ( __MKSMALLINT(__tenureAge()) );
%}
!
-references:anObject]
+whoReferences:anObject
+ "return a collection of objects referencing the argument, anObject"
+
+ ^ self collectObjectsWhich:[:o | o references:anObject]
"
(ObjectMemory whoReferences:Transcript) printNL
"
!
-:aClass]
+whoReferencesDerivedInstancesOf:aClass
+ "return a collection of objects refering to instances
+ of the argument, aClass or a subclass of it."
+
+ ^ self collectObjectsWhich:[:o | o referencesDerivedInstanceOf:aClass]
"
(ObjectMemory whoReferencesDerivedInstancesOf:View) printNL
"
+!
+
+whoReferencesInstancesOf:aClass
+ "return a collection of objects refering to instances
+ of the argument, aClass"
+
+ ^ self collectObjectsWhich:[:o | o referencesInstanceOf:aClass]
+
+ "
+ (ObjectMemory whoReferencesInstancesOf:SystemBrowser) printNL
+ "
! !
!ObjectMemory class methodsFor:'semaphore access'!
-sOf:SystemBrowser) printNL
- "
-! !
-
-!ObjectMemory class methodsFor:'statistics'!
-
-ease object."
+lowSpaceSemaphore
+ "return the semaphore that is signalled when the system detects a
+ low space condition. Usually, some time after this, an allocationFailure
+ will happen. You can have a cleanup process sitting in that semaphore and
+ start to release object."
^ LowSpaceSemaphore
! !
-!ObjectMemory class methodsFor:'system management'!
-
-T */
+!ObjectMemory class methodsFor:'statistics'!
+
+ageStatistic
+%{ /* NOCONTEXT */
__ageStatistics();
%}
-!
-
-ay
+! !
+
+!ObjectMemory class methodsFor:'system management'!
+
+allBinaryModulesDo:aBlock
+ "internal private method - walk over all known binary
+ modules and evaluate aBlock for each entry.
+ Do not depend on the information returned for each - this may
change without notice."
%{
@@ -1996,19 +3163,135 @@
%}
!
-ObjectMemory binaryModuleInfo
+binaryModuleInfo
+ "return a collection of moduleInfo entries.
+ This returns a dictionary (keys are internal moduleIDs)
+ with one entry for each binary package."
+
+ |modules|
+
+ modules := IdentityDictionary new.
+ self allBinaryModulesDo:[:entry |
+ |id name type libName subModuleName module dynamic infoRec pathName
+ typeName nameString|
+
+ id := entry at:1.
+ subModuleName := (entry at:2) asSymbol.
+ libName := (entry at:4).
+
+ id > 0 ifTrue:[
+ pathName := ObjectFileLoader pathNameFromID:id.
+ dynamic := true.
+ typeName := 'dynamic '.
+ name := pathName asFilename baseName
+ ] ifFalse:[
+ dynamic := false.
+ typeName := 'builtIn '.
+ pathName := nil.
+ libName isNil ifTrue:[
+ name := subModuleName
+ ] ifFalse:[
+ name := libName
+ ].
+ ].
+ nameString := typeName.
+ libName isNil ifTrue:[
+ nameString := nameString, 'module '
+ ] ifFalse:[
+ nameString := nameString, 'classLib '
+ ].
+ nameString := nameString , name.
+
+ libName isNil ifTrue:[
+ type := #classObject
+ ] ifFalse:[
+ type := #classLibrary
+ ].
+ infoRec := modules at:id ifAbsent:nil.
+ infoRec notNil ifTrue:[
+ (infoRec at:#classNames) add:subModuleName
+ ] ifFalse:[
+ infoRec := IdentityDictionary new.
+ infoRec at:#id put:id.
+ infoRec at:#classNames put:(Set with:subModuleName).
+ infoRec at:#pathName put:pathName.
+ infoRec at:#name put:nameString.
+ infoRec at:#libraryName put:libName.
+ infoRec at:#dynamic put:dynamic.
+ infoRec at:#type put:type.
+ modules at:id put:infoRec.
+ ].
+ ].
+ ^ modules
+
+ "
+ ObjectMemory binaryModuleInfo
"
"Modified: 17.9.1995 / 16:33:02 / claus"
!
-ObjectMemory fullBinaryModuleInfo
+fullBinaryModuleInfo
+ "return a full collection of moduleInfo entries.
+ This returns a dictionary (keys are component names)
+ with one entry for each component in all binary packages."
+
+ |modules|
+
+ modules := IdentityDictionary new.
+ self allBinaryModulesDo:[:entry |
+ |id name type libName subModuleName module dynamic infoRec pathName
+ t|
+
+ id := entry at:1.
+ subModuleName := (entry at:2) asSymbol.
+ libName := (entry at:4).
+ t := AbsoluteTime fromOSTime:(entry at:5).
+
+ id > 0 ifTrue:[
+ dynamic := true.
+ ] ifFalse:[
+ dynamic := false.
+ ].
+ libName isNil ifTrue:[
+ type := #classObject
+ ] ifFalse:[
+ type := #classLibrary
+ ].
+ infoRec := IdentityDictionary new.
+ infoRec at:#id put:id.
+ infoRec at:#className put:subModuleName.
+ infoRec at:#libraryName put:libName.
+ infoRec at:#dynamic put:dynamic.
+ infoRec at:#type put:type.
+ infoRec at:#timeStamp put:t.
+ modules at:subModuleName put:infoRec.
+ ].
+ ^ modules
+
+ "
+ ObjectMemory fullBinaryModuleInfo
"
"Modified: 30.8.1995 / 17:29:30 / claus"
!
-nm copyWithoutLast:4
+imageBaseName
+ "return a reasonable filename to use as baseName (i.e. without extension).
+ This is the filename of the current image (without '.img') or,
+ if not running from an image, the default name 'st'"
+
+ |nm|
+
+ nm := ImageName.
+ (nm isNil or:[nm isBlank]) ifTrue:[
+ ^ 'st'
+ ].
+ (nm endsWith:'.sav') ifTrue:[
+ nm := nm copyWithoutLast:4
+ ].
+ (nm endsWith:'.img') ifTrue:[
+ ^ nm copyWithoutLast:4
].
^ nm
@@ -2017,7 +3300,9 @@
"
!
-not running from an image."
+imageName
+ "return the filename of the current image, or nil
+ if not running from an image."
^ ImageName
@@ -2026,18 +3311,44 @@
"
!
-g image was saved.
+imageSaveTime
+ "return a timestamp for when the running image was saved.
Return nil if not running from an image."
^ ImageSaveTime
!
-tNil and:[newClass implements:#initialize]) ifTrue:[
+loadClassBinary:aClassName
+ "find the object file for aClassName and -if found - load it;
+ this one loads precompiled object files"
+
+ |fName newClass|
+
+ fName := self fileNameForClass:aClassName.
+ fName notNil ifTrue:[
+ Class withoutUpdatingChangesDo:
+ [
+ self loadBinary:(fName , '.o')
+ ].
+ newClass := self at:(aClassName asSymbol).
+ (newClass notNil and:[newClass implements:#initialize]) ifTrue:[
newClass initialize
]
]
!
+nameForChanges
+ "return a reasonable filename to store the changes into.
+ Currently, this is defined in a classVariable and defaults to 'changes'.
+ In future versions, this will be the basename of the current image with '.img' replaced
+ by '.chg', or, if not running from an image, the default name 'st.chg'."
+
+ ChangeFileName notNil ifTrue:[^ ChangeFileName].
+ ^ 'changes'.
+
+"/ future versions will have:
+"/ (requires some additionas at other places)
+"/
"/ ^ self imageBaseName , '.chg'
"
@@ -2045,21 +3356,32 @@
"
!
-ngeFileName := aFilename
+nameForChanges:aFilename
+ "set the name of the file where changes are stored into."
+
+ ChangeFileName := aFilename
"
ObjectMemory nameForChanges:'myChanges'
"
!
-^ self imageBaseName , '.img'
+nameForSnapshot
+ "return a reasonable filename to store the snapshot image into.
+ This is the filename of the current image or,
+ if not running from an image, the default name 'st.img'"
+
+ ^ self imageBaseName , '.img'
"
ObjectMemory nameForSnapshot
"
!
-"
+nameForSources
+ "return a reasonable filename to store the sources into.
+ This is the basename of the current image with '.img' replaced
+ by '.src', or, if not running from an image, the default name 'st.src'"
^ self imageBaseName , '.src'
@@ -2068,25 +3390,105 @@
"
!
-n(__context, _stringVal(aFileName), funny);
+primSnapShotOn:aFileName
+ "create a snapshot in the given file.
+ Low level entry. Does not notify classes or write an entry to
+ the changes file. Also, no image backup is created. Returns true if
+ the snapshot worked, false if it failed for some reason.
+ This method should not be used in normal cases."
+
+ |ok|
+
+%{ /* STACK:32000 */
+
+ OBJ __snapShotOn();
+ OBJ funny = @symbol(funnySnapshotSymbol);
+
+ if (__isString(aFileName)) {
+ __BLOCKINTERRUPTS();
+ ok = __snapShotOn(__context, _stringVal(aFileName), funny);
__UNBLOCKINTERRUPTS();
}
%}.
^ ok
!
-."
+snapShot
+ "create a snapshot file containing all of the current state."
self snapShotOn:(self nameForSnapshot)
"
ObjectMemory snapShot
"
+!
+
+snapShotOn:aFileName
+ "create a snapshot in the given file.
+ If the file exists, save it for backup.
+ Return true if the snapshot worked, false if it failed for some reason.
+ Notify dependents before and after the snapshot operation."
+
+ |ok oldImageName oldImageTime|
+
+ "
+ keep a save version - just in case something
+ bad happens while writing the image.
+ (could be st/x internal error or file-system errors etc)
+ "
+ (OperatingSystem isValidPath:aFileName) ifTrue:[
+ OperatingSystem renameFile:aFileName to:(aFileName , '.sav').
+ ].
+
+ "
+ give others a chance to fix things
+ "
+ self changed:#save. "/ will vanish ...
+ self changed:#aboutToSnapshot. "/ ... for ST-80 compatibility
+
+ "
+ ST-80 compatibility; send #preSnapshot to all classes
+ "
+ Smalltalk allBehaviorsDo:[:aClass |
+ aClass preSnapshot
+ ].
+
+ "
+ save the name with it ...
+ "
+ oldImageName := ImageName.
+ oldImageTime := ImageSaveTime.
+
+ ImageName := aFileName.
+ ImageSaveTime := AbsoluteTime now.
+
+ ok := self primSnapShotOn:aFileName.
+
+ ImageName := oldImageName.
+ ImageSaveTime := oldImageTime.
+
+ ok ifTrue:[
+ Class addChangeRecordForSnapshot:aFileName.
+ ].
+
+
+ "
+ ST-80 compatibility; send #postSnapshot to all classes
+ "
+ Smalltalk allBehaviorsDo:[:aClass |
+ aClass postSnapshot
+ ].
+ self changed:#finishedSnapshot. "/ ST-80 compatibility
+ ^ ok
+
+ "
+ ObjectMemory snapShotOn:'myimage.img'
+ "
! !
!ObjectMemory class methodsFor:'documentation'!
-mory snapShotOn:'myimage.img'
- "
+version
+ ^ '$Header: /cvs/stx/stx/libbasic/Attic/ObjMem.st,v 1.101 1996-04-25 16:11:23 cg Exp $'
! !
ObjectMemory initialize!