--- a/ObjMem.st Thu Nov 23 02:52:35 1995 +0100
+++ b/ObjMem.st Thu Nov 23 03:01:22 1995 +0100
@@ -11,30 +11,61 @@
"
Object subclass:#ObjectMemory
- instanceVariableNames:''
- classVariableNames:'InternalErrorHandler UserInterruptHandler TimerInterruptHandler
- SpyInterruptHandler StepInterruptHandler ExceptionInterruptHandler
- ErrorInterruptHandler MemoryInterruptHandler SignalInterruptHandler
- ChildSignalInterruptHandler DisposeInterruptHandler
- RecursionInterruptHandler IOInterruptHandler
- CustomInterruptHandler
- RegisteredErrorInterruptHandlers
- InterruptLatencyMonitor
-
- AllocationFailureSignal MallocFailureSignal LowSpaceSemaphore
- IncrementalGCLimit FreeSpaceGCLimit FreeSpaceGCAmount
- BackgroundCollectProcess BackgroundFinalizationProcess
- FinalizationSemaphore
- Dependents
- ImageName ChangeFileName
-
- MaxInterruptLatency InterruptLatencyGoal'
- poolDictionaries:''
- category:'System-Support'
+ instanceVariableNames:''
+ classVariableNames:'InternalErrorHandler UserInterruptHandler TimerInterruptHandler
+ SpyInterruptHandler StepInterruptHandler
+ ExceptionInterruptHandler ErrorInterruptHandler
+ MemoryInterruptHandler SignalInterruptHandler
+ ChildSignalInterruptHandler DisposeInterruptHandler
+ RecursionInterruptHandler IOInterruptHandler
+ CustomInterruptHandler RegisteredErrorInterruptHandlers
+ InterruptLatencyMonitor AllocationFailureSignal
+ MallocFailureSignal LowSpaceSemaphore IncrementalGCLimit
+ FreeSpaceGCLimit FreeSpaceGCAmount BackgroundCollectProcess
+ BackgroundFinalizationProcess FinalizationSemaphore Dependents
+ ImageName ChangeFileName MaxInterruptLatency InterruptLatencyGoal'
+ poolDictionaries:''
+ category:'System-Support'
!
!ObjectMemory class methodsFor:'documentation'!
+caching
+"
+ The system uses various caches to speed up method-lookup.
+ Currently, there is a three-level cache hierarchy:
+
+ inline-cache keeps the target of the last send at the caller-
+ side (i.e. every send goes through its private
+ 1-slot inline-cache, where the address of the last
+ called function at this call location is kept.)
+
+ polymorph-inline-cache keeps a limited list of all targets ever reached
+ at this call location. The list is automatically
+ flushed if it grows too large, or the overall number
+ of poly-chache entries exceeds a limit.
+
+ method-lookup-cache a global cache. Hashes on class-selector pairs,
+ returning the target method.
+
+ Whenever methods are added or removed from the system, or the inheritance
+ hierarchy changes, some or all caches have to be flushed.
+ The flushXXX methods perform the task of flushing various caches.
+ All standard methods in Behavior call for cache flushing, when things change;
+ however, if you use the low level access methods in Behavior
+ (for example: #setSuperclass:) special care has to be taken.
+
+ In some situations, not all caches need flushing, for example a change
+ in an interpreted method (currently) needs no flushing of the inline caches.
+ Also, flushing can be limited to entries for a specific class for most changes.
+
+ To be 'on the brigth side of live', use ObjectMemory>>flushCaches (which
+ flushes all of them), when in doubt of which caches should be flushed.
+ It is better flush too much - otherwise you may end up in a wrong method after
+ a send.
+"
+!
+
copyright
"
COPYRIGHT (c) 1992 by Claus Gittinger
@@ -49,10 +80,6 @@
"
!
-version
- ^ '$Header: /cvs/stx/stx/libbasic/Attic/ObjMem.st,v 1.77 1995-11-13 09:08:12 stefan Exp $'
-!
-
documentation
"
This class contains access methods to the system memory and the VM.
@@ -145,98 +172,6 @@
"
!
-caching
-"
- The system uses various caches to speed up method-lookup.
- Currently, there is a three-level cache hierarchy:
-
- inline-cache keeps the target of the last send at the caller-
- side (i.e. every send goes through its private
- 1-slot inline-cache, where the address of the last
- called function at this call location is kept.)
-
- polymorph-inline-cache keeps a limited list of all targets ever reached
- at this call location. The list is automatically
- flushed if it grows too large, or the overall number
- of poly-chache entries exceeds a limit.
-
- method-lookup-cache a global cache. Hashes on class-selector pairs,
- returning the target method.
-
- Whenever methods are added or removed from the system, or the inheritance
- hierarchy changes, some or all caches have to be flushed.
- The flushXXX methods perform the task of flushing various caches.
- All standard methods in Behavior call for cache flushing, when things change;
- however, if you use the low level access methods in Behavior
- (for example: #setSuperclass:) special care has to be taken.
-
- In some situations, not all caches need flushing, for example a change
- in an interpreted method (currently) needs no flushing of the inline caches.
- Also, flushing can be limited to entries for a specific class for most changes.
-
- To be 'on the brigth side of live', use ObjectMemory>>flushCaches (which
- flushes all of them), when in doubt of which caches should be flushed.
- It is better flush too much - otherwise you may end up in a wrong method after
- a send.
-"
-!
-
-interrupts
-"
- Handling of interrupts (i.e. unix-signals) is done via handler objects, which
- get a #XXXInterrupt-message sent. This is more flexible than (say) signalling
- a semaphore, since the handler-object may do anything to react on the signal
- (of course, it can also signal a semaphore to emulate the above behavior).
-
- Another reason for having handler objects is that they allow interrupt handling
- without any context switch, for high speed interrupt response.
- However, if you do this, special care is needed, since it is not defined,
- which process gets the interrupt and will do the processing (therefore,
- the default setup installs handlers which simply signal a semaphore and
- continue the running process).
-
- Typically, the handlers are set during early initialization of the system
- by sending 'ObjectMemory XXXInterruptHandler:aHandler' and not changed later.
- (see Smalltalk>>initialize or ProcessorScheduler>>initialize).
- To setup your own handler, create some object which responds to #xxxInterrupt,
- and make it the handler using the above method.
-
- Interrupt messages sent to handlers are:
- internalError:<someString> - internal interpreter/GC errors
- userInterrupt - ^C interrupt
- customInterrupt - custom interrupt
- ioInterrupt - SIGIO interrupt
- timerInterrupt - alarm timer (SIGALRM)
- errorInterrupt:<id> - errors from other primitives/subsystems
- (DisplayError)
- spyInterrupt - spy timer interrupt (SIGVTALARM)
- stepInterrupt - single step interrupt
- disposeInterrupt - finalization required
- recursionInterrupt - recursion (stack) overflow
- memoryInterrupt - soon running out of memory
- fpExceptionInterrupt - floating point exception (SIGFPE)
- childSignalInterrupt - death of a child process (SIGCHILD)
- signalInterrupt:<number> - unix signal (if other than above signals)
-
- To avoid frustration in case of badly set handlers, these messages
- are also implemented in the Object class - thus anything can be defined
- as interrupt handler. However, the VM will not send any
- interrupt message, if the corresonding handler object is nil
- (which means that nil is a bad choice, if you are interrested in the event).
-
- Interrupt processing is not immediately after the event arrives: there
- are certain ``save-places'' at which this handling is performed
- (message send, method return and loop-heads).
- If not explicitely enabled, primitive code is never interrupted.
-
- Interrupts may be disabled (OperatingSystem blockInterrupts) and reenabled
- (unblockInterrupts) to allow for critical data to be manipulated.
- Every process has its own interrupt-enable state which is switched
- when processes switch control (i.e. you cannot block interrupts across
- a suspend, delay etc.). However, the state will be restored after a resume.
-"
-!
-
garbageCollection
"
Currently, Smalltalk/X uses a two-level memory hierachy (actually, there
@@ -567,6 +502,66 @@
special features you are using - this provides the feedback required to decide
which methods are to be removed, kept or enhanced in future versions.
"
+!
+
+interrupts
+"
+ Handling of interrupts (i.e. unix-signals) is done via handler objects, which
+ get a #XXXInterrupt-message sent. This is more flexible than (say) signalling
+ a semaphore, since the handler-object may do anything to react on the signal
+ (of course, it can also signal a semaphore to emulate the above behavior).
+
+ Another reason for having handler objects is that they allow interrupt handling
+ without any context switch, for high speed interrupt response.
+ However, if you do this, special care is needed, since it is not defined,
+ which process gets the interrupt and will do the processing (therefore,
+ the default setup installs handlers which simply signal a semaphore and
+ continue the running process).
+
+ Typically, the handlers are set during early initialization of the system
+ by sending 'ObjectMemory XXXInterruptHandler:aHandler' and not changed later.
+ (see Smalltalk>>initialize or ProcessorScheduler>>initialize).
+ To setup your own handler, create some object which responds to #xxxInterrupt,
+ and make it the handler using the above method.
+
+ Interrupt messages sent to handlers are:
+ internalError:<someString> - internal interpreter/GC errors
+ userInterrupt - ^C interrupt
+ customInterrupt - custom interrupt
+ ioInterrupt - SIGIO interrupt
+ timerInterrupt - alarm timer (SIGALRM)
+ errorInterrupt:<id> - errors from other primitives/subsystems
+ (DisplayError)
+ spyInterrupt - spy timer interrupt (SIGVTALARM)
+ stepInterrupt - single step interrupt
+ disposeInterrupt - finalization required
+ recursionInterrupt - recursion (stack) overflow
+ memoryInterrupt - soon running out of memory
+ fpExceptionInterrupt - floating point exception (SIGFPE)
+ childSignalInterrupt - death of a child process (SIGCHILD)
+ signalInterrupt:<number> - unix signal (if other than above signals)
+
+ To avoid frustration in case of badly set handlers, these messages
+ are also implemented in the Object class - thus anything can be defined
+ as interrupt handler. However, the VM will not send any
+ interrupt message, if the corresonding handler object is nil
+ (which means that nil is a bad choice, if you are interrested in the event).
+
+ Interrupt processing is not immediately after the event arrives: there
+ are certain ``save-places'' at which this handling is performed
+ (message send, method return and loop-heads).
+ If not explicitely enabled, primitive code is never interrupted.
+
+ Interrupts may be disabled (OperatingSystem blockInterrupts) and reenabled
+ (unblockInterrupts) to allow for critical data to be manipulated.
+ Every process has its own interrupt-enable state which is switched
+ when processes switch control (i.e. you cannot block interrupts across
+ a suspend, delay etc.). However, the state will be restored after a resume.
+"
+!
+
+version
+ ^ '$Header: /cvs/stx/stx/libbasic/Attic/ObjMem.st,v 1.78 1995-11-23 02:01:22 cg Exp $'
! !
!ObjectMemory class methodsFor:'initialization'!
@@ -591,6 +586,67 @@
MemoryInterruptHandler := self
! !
+!ObjectMemory class methodsFor:'ST-80 compatibility'!
+
+availableFreeBytes
+ ^ self freeSpace + self freeListSpace
+
+ "
+ ObjectMemory availableFreeBytes
+ "
+!
+
+bytesPerOOP
+ "return the number of bytes an object reference (for example: an instvar)
+ takes"
+
+%{ /* NOCONTEXT */
+ RETURN(__MKSMALLINT(sizeof(OBJ)));
+%}
+
+ "
+ ObjectMemory bytesPerOOP
+ "
+!
+
+bytesPerOTE
+ "return the number of overhead bytes of an object.
+ i.e. the number of bytes in every objects header."
+
+%{ /* NOCONTEXT */
+ RETURN(__MKSMALLINT(OHDR_SIZE));
+%}
+
+ "
+ ObjectMemory bytesPerOTE
+ "
+!
+
+compactingGC
+ self garbageCollect
+!
+
+current
+ ^ self
+!
+
+globalCompactingGC
+ self garbageCollect
+!
+
+growMemoryBy:numberOfBytes
+ ^ self moreOldSpace:numberOfBytes
+!
+
+numOopsNumBytes
+ ^ Array with:(self numberOfObjects)
+ with:(self bytesUsed)
+
+ "
+ ObjectMemory numOopsNumBytes
+ "
+! !
+
!ObjectMemory class methodsFor:'Signal constants'!
allocationFailureSignal
@@ -607,41 +663,16 @@
^ MallocFailureSignal
! !
-!ObjectMemory class methodsFor:'semaphore access'!
-
-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:'VM messages'!
-infoPrinting:aBoolean
- "turn on/off various informational printouts in the VM.
- For example, the GC activity messages are controlled by
- this flags setting.
- The default is true, since (currently) those messages
- are useful for ST/X developers."
-
-%{ /* NOCONTEXT */
- extern int __infoPrinting;
-
- __infoPrinting = (aBoolean == true);
-%}
-!
-
-infoPrinting
- "return true, if various informational printouts in the VM
+debugPrinting
+ "return true, if various debug printouts in the VM
are turned on, false of off."
%{ /* NOCONTEXT */
- extern int __infoPrinting;
-
- RETURN (__infoPrinting ? true : false);
+ extern int __debugPrinting;
+
+ RETURN (__debugPrinting ? true : false);
%}
!
@@ -660,14 +691,324 @@
%}
!
-debugPrinting
- "return true, if various debug printouts in the VM
+infoPrinting
+ "return true, if various informational printouts in the VM
are turned on, false of off."
%{ /* NOCONTEXT */
- extern int __debugPrinting;
-
- RETURN (__debugPrinting ? true : false);
+ extern int __infoPrinting;
+
+ RETURN (__infoPrinting ? true : false);
+%}
+!
+
+infoPrinting:aBoolean
+ "turn on/off various informational printouts in the VM.
+ For example, the GC activity messages are controlled by
+ this flags setting.
+ The default is true, since (currently) those messages
+ are useful for ST/X developers."
+
+%{ /* NOCONTEXT */
+ extern int __infoPrinting;
+
+ __infoPrinting = (aBoolean == true);
+%}
+! !
+
+!ObjectMemory class methodsFor:'cache management'!
+
+flushCaches
+ "flush method and inline caches for all classes"
+
+%{ /* NOCONTEXT */
+ __flushMethodCache();
+ __flushAllInlineCaches();
+%}
+!
+
+flushCachesFor:aClass
+ "flush method and inline caches for aClass"
+
+%{ /* NOCONTEXT */
+ __flushMethodCacheFor(aClass);
+ __flushInlineCachesFor(aClass);
+%}
+!
+
+flushCachesForSelector:aSelector
+ "flush method and inline caches for aSelector"
+
+%{ /* NOCONTEXT */
+ __flushMethodCacheForSelector(aSelector);
+ __flushInlineCachesForSelector(aSelector);
+%}
+!
+
+flushInlineCaches
+ "flush all inlinecaches"
+
+%{ /* NOCONTEXT */
+ __flushAllInlineCaches();
+%}
+!
+
+flushInlineCachesFor:aClass withArgs:nargs
+ "flush inlinecaches for calls to aClass with nargs arguments"
+
+%{ /* NOCONTEXT */
+ __flushInlineCachesForAndNargs(aClass, _intVal(nargs));
+%}
+!
+
+flushInlineCachesForClass:aClass
+ "flush inlinecaches for calls to aClass."
+
+%{ /* NOCONTEXT */
+ __flushInlineCachesFor(aClass);
+%}
+!
+
+flushInlineCachesForSelector:aSelector
+ "flush inlinecaches for sends of aSelector"
+
+%{ /* NOCONTEXT */
+ __flushInlineCachesForSelector(aSelector);
+%}
+!
+
+flushInlineCachesWithArgs:nargs
+ "flush inlinecaches for calls with nargs arguments"
+
+%{ /* NOCONTEXT */
+ __flushInlineCaches(_intVal(nargs));
+%}
+!
+
+flushMethodCache
+ "flush the method cache"
+
+%{ /* NOCONTEXT */
+ __flushMethodCache();
+%}
+!
+
+flushMethodCacheFor:aClass
+ "flush the method cache for sends to aClass"
+
+%{ /* NOCONTEXT */
+ __flushMethodCacheFor(aClass);
+%}
+!
+
+flushMethodCacheForSelector:aSelector
+ "flush the method cache for sends of aSelector"
+
+%{ /* NOCONTEXT */
+ __flushMethodCacheForSelector(aSelector);
+%}
+!
+
+trapRestrictedMethods:trap
+ "Allow/Deny execution of restricted Methods (see Method>>>restricted:)
+
+ Notice: method restriction is a nonstandard feature, not supported
+ by other smalltalk implementations and not specified in the ANSI spec.
+ This is EXPERIMENTAL - and being evaluated for usability.
+ It may change or even vanish (if it shows to be not useful)."
+
+ |oldTrap|
+
+%{
+ if (__setTrapRestrictedMethods(trap == true))
+ oldTrap = true;
+ else
+ oldTrap = false;
+%}.
+
+ (trap and:[oldTrap not]) ifTrue:[
+ self flushCaches
+ ].
+ ^ oldTrap
+
+ "
+ ObjectMemory trapRestrictedMethods:true
+ ObjectMemory trapRestrictedMethods:false
+ "
+! !
+
+!ObjectMemory class methodsFor:'debug queries'!
+
+addressOf:anObject
+ "return the core address of anObject as an integer
+ - since objects may move around, the returned value is 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 );
+ }
+ if (((int)anObject >= _MIN_INT) && ((int)anObject <= _MAX_INT)) {
+ RETURN ( _MKSMALLINT((int)anObject) );
+ }
+ RETURN ( _MKLARGEINT((int)anObject) );
+%}
+ "
+ |p|
+ p := Point new.
+ ((ObjectMemory addressOf:p) printStringRadix:16) printNL.
+ ObjectMemory scavenge.
+ ((ObjectMemory addressOf:p) printStringRadix:16) printNL.
+ "
+!
+
+ageOf:anObject
+ "return the number of scavenges, an object has survived
+ in new space.
+ For old objects and living contexts, the returned number is invalid.
+ WARNING: this method is for ST/X debugging only
+ it will be removed without notice"
+
+%{ /* NOCONTEXT */
+
+ if (! __isNonNilObject(anObject)) {
+ RETURN ( 0 );
+ }
+ RETURN ( _MKSMALLINT( _GET_AGE(anObject) ) );
+%}
+ "
+ |p|
+ p := Point new.
+ (ObjectMemory ageOf:p) printNL.
+ ObjectMemory tenuringScavenge.
+ (ObjectMemory spaceOf:p) printNL.
+ ObjectMemory tenuringScavenge.
+ (ObjectMemory spaceOf:p) printNL.
+ ObjectMemory tenuringScavenge.
+ (ObjectMemory spaceOf:p) printNL.
+ ObjectMemory tenuringScavenge.
+ (ObjectMemory spaceOf:p) printNL.
+ "
+!
+
+dumpObject:someObject
+ "low level dump an object.
+ WARNING: this method is for ST/X debugging only
+ it will be removed without notice"
+
+%{
+ dumpObject(someObject);
+%}
+ "
+ ObjectMemory dumpObject:true
+ ObjectMemory dumpObject:(Array new:10)
+ ObjectMemory dumpObject:(10@20 corner:30@40)
+ "
+!
+
+flagsOf:anObject
+ "For debugging only.
+ WARNING: this method is for ST/X debugging only
+ it will be removed without notice"
+
+%{ /* NOCONTEXT */
+
+ if (! __isNonNilObject(anObject)) {
+ RETURN ( nil );
+ }
+ RETURN ( _MKSMALLINT( anObject->o_flags ) );
+%}
+ "
+F_ISREMEMBERED 1 /* a new-space thing being refd by some oldSpace thing */
+F_ISFORWARDED 2 /* a forwarded object (you will never see this here) */
+F_DEREFERENCED 4 /* a collection after grow (not currently used) */
+F_ISONLIFOLIST 8 /* a non-lifo-context-referencing-obj already on list */
+F_MARK 16 /* mark bit for background collector */
+ "
+
+ "
+ |arr|
+
+ arr := Array new.
+ arr at:1 put:([thisContext] value).
+ (ObjectMemory flagsOf:anObject) printNL
+ "
+!
+
+objectAt:anAddress
+ "return whatever anAddress points to as object.
+ BIG BIG DANGER ALERT:
+ this method is only to be used for debugging ST/X itself
+ - you can easily (and badly) crash the system.
+ 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)));
+ }
+%}
+!
+
+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);
+%}
+!
+
+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) ) );
%}
! !
@@ -706,150 +1047,8 @@
]
! !
-!ObjectMemory class methodsFor:'cache management'!
-
-flushInlineCachesForClass:aClass
- "flush inlinecaches for calls to aClass."
-
-%{ /* NOCONTEXT */
- __flushInlineCachesFor(aClass);
-%}
-!
-
-flushInlineCachesWithArgs:nargs
- "flush inlinecaches for calls with nargs arguments"
-
-%{ /* NOCONTEXT */
- __flushInlineCaches(_intVal(nargs));
-%}
-!
-
-flushInlineCachesFor:aClass withArgs:nargs
- "flush inlinecaches for calls to aClass with nargs arguments"
-
-%{ /* NOCONTEXT */
- __flushInlineCachesForAndNargs(aClass, _intVal(nargs));
-%}
-!
-
-flushInlineCachesForSelector:aSelector
- "flush inlinecaches for sends of aSelector"
-
-%{ /* NOCONTEXT */
- __flushInlineCachesForSelector(aSelector);
-%}
-!
-
-flushInlineCaches
- "flush all inlinecaches"
-
-%{ /* NOCONTEXT */
- __flushAllInlineCaches();
-%}
-!
-
-flushMethodCacheFor:aClass
- "flush the method cache for sends to aClass"
-
-%{ /* NOCONTEXT */
- __flushMethodCacheFor(aClass);
-%}
-!
-
-flushMethodCacheForSelector:aSelector
- "flush the method cache for sends of aSelector"
-
-%{ /* NOCONTEXT */
- __flushMethodCacheForSelector(aSelector);
-%}
-!
-
-flushMethodCache
- "flush the method cache"
-
-%{ /* NOCONTEXT */
- __flushMethodCache();
-%}
-!
-
-flushCachesFor:aClass
- "flush method and inline caches for aClass"
-
-%{ /* NOCONTEXT */
- __flushMethodCacheFor(aClass);
- __flushInlineCachesFor(aClass);
-%}
-!
-
-flushCachesForSelector:aSelector
- "flush method and inline caches for aSelector"
-
-%{ /* NOCONTEXT */
- __flushMethodCacheForSelector(aSelector);
- __flushInlineCachesForSelector(aSelector);
-%}
-!
-
-flushCaches
- "flush method and inline caches for all classes"
-
-%{ /* NOCONTEXT */
- __flushMethodCache();
- __flushAllInlineCaches();
-%}
-!
-
-trapRestrictedMethods:trap
- "Allow/Deny execution of restricted Methods (see Method>>>restricted:)
-
- Notice: method restriction is a nonstandard feature, not supported
- by other smalltalk implementations and not specified in the ANSI spec.
- This is EXPERIMENTAL - and being evaluated for usability.
- It may change or even vanish (if it shows to be not useful)."
-
- |oldTrap|
-
-%{
- if (__setTrapRestrictedMethods(trap == true))
- oldTrap = true;
- else
- oldTrap = false;
-%}.
-
- (trap and:[oldTrap not]) ifTrue:[
- self flushCaches
- ].
- ^ oldTrap
-
- "
- ObjectMemory trapRestrictedMethods:true
- ObjectMemory trapRestrictedMethods:false
- "
-! !
-
!ObjectMemory class methodsFor:'enumerating'!
-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
-!
-
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
@@ -871,6 +1070,27 @@
^ true
!
+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"
@@ -882,962 +1102,15 @@
^ true
! !
-!ObjectMemory class methodsFor:'interrupt handler access'!
-
-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
-!
-
-userInterruptHandler
- "return the handler for CNTL-C interrupt handling"
-
- ^ UserInterruptHandler
-!
-
-userInterruptHandler:aHandler
- "set the handler for CNTL-C interrupt handling"
-
- UserInterruptHandler := aHandler
-!
-
-timerInterruptHandler
- "return the handler for timer interrupts"
-
- ^ TimerInterruptHandler
-!
-
-timerInterruptHandler:aHandler
- "set the handler for timer interrupts"
-
- TimerInterruptHandler := aHandler
-!
-
-spyInterruptHandler
- "return the handler for spy-timer interrupts"
-
- ^ SpyInterruptHandler
-!
-
-spyInterruptHandler:aHandler
- "set the handler for spy-timer interrupts"
-
- SpyInterruptHandler := aHandler
-!
-
-stepInterruptHandler
- "return the handler for single step interrupts"
-
- ^ StepInterruptHandler
-!
-
-stepInterruptHandler:aHandler
- "set the handler for single step interrupts"
-
- StepInterruptHandler := aHandler
-!
-
-exceptionInterruptHandler
- "return the handler for floating point exception interrupts"
-
- ^ ExceptionInterruptHandler
-!
-
-errorInterruptHandler
- "return the handler for display error interrupts"
-
- ^ ErrorInterruptHandler
-!
-
-errorInterruptHandler:aHandler
- "set the handler for display error interrupts"
-
- ErrorInterruptHandler := aHandler
-!
-
-registeredErrorInterruptHandlers
- "return registered handlers"
-
- ^ RegisteredErrorInterruptHandlers
-!
-
-registerErrorInterruptHandler:aHandler forID:errorIDSymbol
- "register a handler"
-
- RegisteredErrorInterruptHandlers isNil ifTrue:[
- RegisteredErrorInterruptHandlers := IdentityDictionary new
- ].
- RegisteredErrorInterruptHandlers at:errorIDSymbol put:aHandler
-!
-
-signalInterruptHandler
- "return the handler for UNIX-signal interrupts"
-
- ^ SignalInterruptHandler
-!
-
-signalInterruptHandler:aHandler
- "set the handler for UNIX-signal interrupts"
-
- SignalInterruptHandler := aHandler
-!
-
-childSignalInterruptHandler
- "return the handler for UNIX-death-of-a-childprocess-signal interrupts"
-
- ^ ChildSignalInterruptHandler
-!
-
-disposeInterruptHandler
- "return the handler for object disposal interrupts"
-
- ^ DisposeInterruptHandler
-!
-
-disposeInterruptHandler:aHandler
- "set the handler for object disposal interrupts"
-
- DisposeInterruptHandler := aHandler
-!
-
-recursionInterruptHandler
- "return the handler for recursion/stack overflow interrupts"
-
- ^ RecursionInterruptHandler
-!
-
-recursionInterruptHandler:aHandler
- "set the handler for recursion/stack overflow interrupts"
-
- RecursionInterruptHandler := aHandler
-!
-
-ioInterruptHandler
- "return the handler for I/O available signal interrupts (SIGIO/SIGPOLL)"
-
- ^ IOInterruptHandler
-!
-
-ioInterruptHandler:aHandler
- "set the handler for I/O available signal interrupts (SIGIO/SIGPOLL)"
-
- IOInterruptHandler := aHandler
-!
-
-customInterruptHandler
- "return the handler for custom interrupts"
-
- ^ CustomInterruptHandler
-!
-
-customInterruptHandler:aHandler
- "set the handler for custom interrupts"
-
- CustomInterruptHandler := aHandler
-! !
-
-!ObjectMemory class methodsFor:'interrupt statistics'!
-
-interruptLatencyMonitor
- "return the interrupt-latency-monitor if any.
- See comment in #interruptLatencyMonitor:.
- This is a non-standard debugging/realtime instrumentation entry."
-
- ^ InterruptLatencyMonitor
-!
-
-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
-!
-
-interruptLatency:ms receiver:rec class:cls selector:sel vmActivity:vmActivity
- "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"
-!
-
-resetMaxInterruptLatency
- "reset the maximum accumulated interrupt latency probe time.
- DEMO Example."
-
- MaxInterruptLatency := 0
-!
-
-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.
- ]
+!ObjectMemory class methodsFor:'garbage collection'!
+
+backgroundCollectorRunning
+ "return true, if a backgroundCollector is running"
+
+ ^ BackgroundCollectProcess notNil
"
- ObjectMemory interruptLatencyGoal:50
- "
-!
-
-maxInterruptLatency
- "return the maximum accumulated interrupt latency in millis.
- DEMO Example."
-
- ^ MaxInterruptLatency
-! !
-
-!ObjectMemory class methodsFor:'queries'!
-
-newSpaceSize
- "return the total size of the new space - this is usually fix"
-
-%{ /* NOCONTEXT */
- extern unsigned __newSpaceSize();
-
- RETURN ( _MKSMALLINT(__newSpaceSize()) );
-%}
- "
- ObjectMemory newSpaceSize
- "
-!
-
-oldSpaceSize
- "return the total size of the old space. - may grow slowly"
-
-%{ /* NOCONTEXT */
- extern unsigned __oldSpaceSize();
-
- RETURN ( _MKSMALLINT(__oldSpaceSize()) );
-%}
- "
- ObjectMemory oldSpaceSize
- "
-!
-
-symSpaceSize
- "return the total size of the sym space."
-
-%{ /* NOCONTEXT */
- extern unsigned __symSpaceSize();
-
- RETURN ( _MKSMALLINT(__symSpaceSize()) );
-%}
- "
- ObjectMemory symSpaceSize
- "
-!
-
-fixSpaceSize
- "return the total size of the fix space."
-
-%{ /* NOCONTEXT */
- extern unsigned __fixSpaceSize();
-
- RETURN ( _MKSMALLINT(__fixSpaceSize()) );
-%}
- "
- ObjectMemory fixSpaceSize
- "
-!
-
-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
- "
-!
-
-oldSpaceUsed
- "return the number of bytes allocated for old objects.
- (This includes the free lists)"
-
-%{ /* NOCONTEXT */
- extern unsigned __oldSpaceUsed();
-
- RETURN ( _MKSMALLINT(__oldSpaceUsed()) );
-%}
- "
- ObjectMemory oldSpaceUsed
- "
-!
-
-symSpaceUsed
- "return the number of bytes allocated for old objects in sym space."
-
-%{ /* NOCONTEXT */
- extern unsigned __symSpaceUsed();
-
- RETURN ( _MKSMALLINT(__symSpaceUsed()) );
-%}
- "
- ObjectMemory symSpaceUsed
- "
-!
-
-fixSpaceUsed
- "return the number of bytes allocated for old objects in fix space."
-
-%{ /* NOCONTEXT */
- extern unsigned __fixSpaceUsed();
-
- RETURN ( _MKSMALLINT(__fixSpaceUsed()) );
-%}
- "
- ObjectMemory fixSpaceUsed
- "
-!
-
-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
- "
-!
-
-freeListSpace
- "return the number of bytes in the free lists.
- (which is included in oldSpaceUsed)"
-
-%{ /* NOCONTEXT */
- extern unsigned __freeListSpace();
-
- RETURN ( _MKSMALLINT(__freeListSpace()) );
-%}
- "
- ObjectMemory 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
- "
-!
-
-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
- "
-!
-
-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()) );
-%}
-!
-
-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
- "
-!
-
-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
- "
-!
-
-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
- "
-!
-
-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
- "
-!
-
-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()));
-%}
-!
-
-scavengeCount
- "return the number of scavenges that occurred since startup"
-
-%{ /* NOCONTEXT */
- extern int __scavengeCount();
-
- RETURN (_MKSMALLINT(__scavengeCount()));
-%}
- "
- ObjectMemory scavengeCount
- "
-!
-
-markAndSweepCount
- "return the number of mark&sweep collects that occurred since startup"
-
-%{ /* NOCONTEXT */
- extern int __markAndSweepCount();
-
- RETURN (_MKSMALLINT(__markAndSweepCount()));
-%}
- "
- ObjectMemory markAndSweepCount
- "
-!
-
-garbageCollectCount
- "return the number of compressing collects that occurred since startup"
-
-%{ /* NOCONTEXT */
- extern int __garbageCollectCount();
-
- RETURN (_MKSMALLINT(__garbageCollectCount()));
-%}
- "
- ObjectMemory garbageCollectCount
- "
-!
-
-incrementalGCCount
- "return the number of incremental collects that occurred since startup"
-
-%{ /* NOCONTEXT */
- extern int __incrementalGCCount();
-
- RETURN (_MKSMALLINT(__incrementalGCCount()));
-%}
- "
- ObjectMemory incrementalGCCount
- "
-!
-
-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
- "
-!
-
-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
- "
-!
-
-lifoRememberedSet
- "return the lifoRemSet.
- This is pure VM debugging and will vanish without notice."
-
-%{ /* NOCONTEXT */
- extern OBJ __lifoRememberedSet();
-
- RETURN ( __lifoRememberedSet() );
-%}
- "
- ObjectMemory lifoRememberedSet
- "
-!
-
-numberOfWeakObjects
- "return the number of weak objects in the system"
-
-%{ /* NOCONTEXT */
- extern int __weakListSize();
-
- RETURN ( __MKSMALLINT(__weakListSize()) );
-%}
- "
- ObjectMemory numberOfWeakObjects
- "
-!
-
-numberOfObjects
- "return the number of objects in the system."
-
- |tally "{ Class: SmallInteger }"|
-
- tally := 0.
- self allObjectsDo:[:obj | tally := tally + 1].
- ^ tally
-
- "
- ObjectMemory numberOfObjects
- "
-!
-
-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
-!
-
-whoReferences:anObject
- "return a collection of objects referencing the argument, anObject"
-
- ^ self collectObjectsWhich:[:o | o references:anObject]
-
- "
- (ObjectMemory whoReferences:Transcript) 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
- "
-!
-
-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
- "
-!
-
-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
- "
-! !
-
-!ObjectMemory class methodsFor:'debug queries'!
-
-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);
-%}
-!
-
-dumpObject:someObject
- "low level dump an object.
- WARNING: this method is for ST/X debugging only
- it will be removed without notice"
-
-%{
- dumpObject(someObject);
-%}
- "
- ObjectMemory dumpObject:true
- ObjectMemory dumpObject:(Array new:10)
- ObjectMemory dumpObject:(10@20 corner:30@40)
- "
-!
-
-addressOf:anObject
- "return the core address of anObject as an integer
- - since objects may move around, the returned value is 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 );
- }
- if (((int)anObject >= _MIN_INT) && ((int)anObject <= _MAX_INT)) {
- RETURN ( _MKSMALLINT((int)anObject) );
- }
- RETURN ( _MKLARGEINT((int)anObject) );
-%}
- "
- |p|
- p := Point new.
- ((ObjectMemory addressOf:p) printStringRadix:16) printNL.
- ObjectMemory scavenge.
- ((ObjectMemory addressOf:p) printStringRadix:16) printNL.
- "
-!
-
-objectAt:anAddress
- "return whatever anAddress points to as object.
- BIG BIG DANGER ALERT:
- this method is only to be used for debugging ST/X itself
- - you can easily (and badly) crash the system.
- 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)));
- }
-%}
-!
-
-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
- "
-!
-
-ageOf:anObject
- "return the number of scavenges, an object has survived
- in new space.
- For old objects and living contexts, the returned number is invalid.
- WARNING: this method is for ST/X debugging only
- it will be removed without notice"
-
-%{ /* NOCONTEXT */
-
- if (! __isNonNilObject(anObject)) {
- RETURN ( 0 );
- }
- RETURN ( _MKSMALLINT( _GET_AGE(anObject) ) );
-%}
- "
- |p|
- p := Point new.
- (ObjectMemory ageOf:p) printNL.
- ObjectMemory tenuringScavenge.
- (ObjectMemory spaceOf:p) printNL.
- ObjectMemory tenuringScavenge.
- (ObjectMemory spaceOf:p) printNL.
- ObjectMemory tenuringScavenge.
- (ObjectMemory spaceOf:p) printNL.
- ObjectMemory tenuringScavenge.
- (ObjectMemory spaceOf:p) printNL.
- "
-!
-
-flagsOf:anObject
- "For debugging only.
- WARNING: this method is for ST/X debugging only
- it will be removed without notice"
-
-%{ /* NOCONTEXT */
-
- if (! __isNonNilObject(anObject)) {
- RETURN ( nil );
- }
- RETURN ( _MKSMALLINT( anObject->o_flags ) );
-%}
- "
-F_ISREMEMBERED 1 /* a new-space thing being refd by some oldSpace thing */
-F_ISFORWARDED 2 /* a forwarded object (you will never see this here) */
-F_DEREFERENCED 4 /* a collection after grow (not currently used) */
-F_ISONLIFOLIST 8 /* a non-lifo-context-referencing-obj already on list */
-F_MARK 16 /* mark bit for background collector */
- "
-
- "
- |arr|
-
- arr := Array new.
- arr at:1 put:([thisContext] value).
- (ObjectMemory flagsOf:anObject) 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:'garbage collection'!
-
-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);
-%}
-
- "
- ObjectMemory scavenge
- "
-!
-
-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);
-%}
-
- "
- ObjectMemory tenuringScavenge
- "
-!
-
-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 ...
- "
-!
-
-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
-
- "
- ObjectMemory garbageCollect
+ ObjectMemory backgroundCollectorRunning
"
!
@@ -1859,32 +1132,18 @@
"
!
-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);
-%}
+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
"
- ObjectMemory markAndSweep
- "
-!
-
-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);
-%}
- "
- ObjectMemory reclaimSymbols
+ ObjectMemory garbageCollect
"
!
@@ -1901,6 +1160,42 @@
%}
!
+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|
+
+ Object 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
+ ]
+ ].
+ ].
+ ^ done not
+!
+
incrementalGC
"perform one round of incremental GC steps.
The overall effect of this method is (almost) the same as calling
@@ -1937,70 +1232,53 @@
"
!
-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|
-
- Object 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
- ]
- ].
- ].
- ^ done not
-!
-
-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
- ]
+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);
+%}
"
- ObjectMemory verboseGarbageCollect
+ ObjectMemory markAndSweep
+ "
+!
+
+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);
+%}
+ "
+ ObjectMemory reclaimSymbols
+ "
+!
+
+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);
+%}
+
+ "
+ ObjectMemory scavenge
"
!
@@ -2074,170 +1352,100 @@
"
!
-backgroundCollectorRunning
- "return true, if a backgroundCollector is running"
-
- ^ BackgroundCollectProcess notNil
+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 backgroundCollectorRunning
+ ObjectMemory tenure
+ "
+ "
+ ... build up long living objects ...
+ ObjectMemory scavenge.
+ ObjectMemory tenure
+ ... continue - objects created above are now in oldSpace ...
+ "
+!
+
+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);
+%}
+
+ "
+ 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'!
-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.
- "
-!
-
-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.
- "
-!
-
-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
-
- "
- ObjectMemory freeSpaceGCLimit
- "
-!
-
-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
+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
+ ]
+ ]
"
- ObjectMemory freeSpaceGCAmount
- "
-!
-
-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'
- "
-!
-
-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
-
- "
- ObjectMemory incrementalGCLimit
- "
-!
-
-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
- ]
- ].
- ].
-!
-
-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);
-%}
- "
- ObjectMemory moreOldSpace:1000000
+ ObjectMemory announceOldSpaceNeed:1000000
"
!
@@ -2268,85 +1476,50 @@
"
!
-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
- ]
- ]
-
- "
- ObjectMemory announceOldSpaceNeed:1000000
- "
-!
-
-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."
+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 */
- extern unsigned __oldSpaceIncrement();
-
- RETURN (_MKSMALLINT( __oldSpaceIncrement(-1) ));
+ __avoidTenure(flag == true ? 1 : 0);
%}
- "
- ObjectMemory oldSpaceIncrement
- "
!
-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."
+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 unsigned __oldSpaceIncrement();
+ extern int __checkForFastNew();
if (__isSmallInteger(amount)) {
- RETURN (_MKSMALLINT( __oldSpaceIncrement(_intVal(amount)) ));
+ if (! __checkForFastNew(_intVal(amount))) {
+ RETURN (false);
+ }
}
-%}
- "to change increment to 1Meg:"
- "
- ObjectMemory oldSpaceIncrement:1024*1024
- "
+
+%}.
+ ^ true
!
-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
- "
-!
-
fastMoreOldSpaceAllocation:aBoolean
"this method turns on/off fastMoreOldSpace allocation.
By default, this is turned off (false), which means that in case of
@@ -2421,80 +1594,108 @@
"
!
-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
+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
+
+ "
+ ObjectMemory freeSpaceGCAmount
+ "
+!
+
+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.
+ "
+!
+
+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
+
+ "
+ ObjectMemory freeSpaceGCLimit
+ "
!
-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);
-%}
+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.
+ "
!
-turnGarbageCollectorOn
- "turn garbage collector on again (see ObjectMemory>>turnGarbageCollectorOff)"
-
-%{ /* NOCONTEXT */
- __allocForceSpace(9999);
-%}
+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
+
+ "
+ ObjectMemory incrementalGCLimit
+ "
!
-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
-!
-
-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);
-%}.
+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'
+ "
!
lockTenure:flag
@@ -2526,39 +1727,67 @@
%}
!
-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);
+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
+!
+
+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);
%}
+ "
+ ObjectMemory moreOldSpace:1000000
+ "
!
-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);
-%}
+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
+ ]
+ ].
+ ].
!
newSpaceSize:newSize
@@ -2595,15 +1824,386 @@
ObjectMemory newSpaceSize:400*1024
"
+!
+
+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
+ "
+!
+
+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
+ "
+!
+
+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
+ "
+!
+
+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);
+%}.
+!
+
+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);
+%}
+!
+
+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 ignoredMethodsFor:'object finalization'!
-
-allShadowObjectsDo:aBlock
- "evaluate the argument, aBlock for all known shadow objects"
-%{
- __allShadowObjectsDo(&aBlock COMMA_CON);
-%}
+!ObjectMemory class methodsFor:'interrupt handler access'!
+
+childSignalInterruptHandler
+ "return the handler for UNIX-death-of-a-childprocess-signal interrupts"
+
+ ^ ChildSignalInterruptHandler
+!
+
+customInterruptHandler
+ "return the handler for custom interrupts"
+
+ ^ CustomInterruptHandler
+!
+
+customInterruptHandler:aHandler
+ "set the handler for custom interrupts"
+
+ CustomInterruptHandler := aHandler
+!
+
+disposeInterruptHandler
+ "return the handler for object disposal interrupts"
+
+ ^ DisposeInterruptHandler
+!
+
+disposeInterruptHandler:aHandler
+ "set the handler for object disposal interrupts"
+
+ DisposeInterruptHandler := aHandler
+!
+
+errorInterruptHandler
+ "return the handler for display error interrupts"
+
+ ^ ErrorInterruptHandler
+!
+
+errorInterruptHandler:aHandler
+ "set the handler for display error interrupts"
+
+ ErrorInterruptHandler := aHandler
+!
+
+exceptionInterruptHandler
+ "return the handler for floating point exception interrupts"
+
+ ^ ExceptionInterruptHandler
+!
+
+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
+!
+
+ioInterruptHandler
+ "return the handler for I/O available signal interrupts (SIGIO/SIGPOLL)"
+
+ ^ IOInterruptHandler
+!
+
+ioInterruptHandler:aHandler
+ "set the handler for I/O available signal interrupts (SIGIO/SIGPOLL)"
+
+ IOInterruptHandler := aHandler
+!
+
+recursionInterruptHandler
+ "return the handler for recursion/stack overflow interrupts"
+
+ ^ RecursionInterruptHandler
+!
+
+recursionInterruptHandler:aHandler
+ "set the handler for recursion/stack overflow interrupts"
+
+ RecursionInterruptHandler := aHandler
+!
+
+registerErrorInterruptHandler:aHandler forID:errorIDSymbol
+ "register a handler"
+
+ RegisteredErrorInterruptHandlers isNil ifTrue:[
+ RegisteredErrorInterruptHandlers := IdentityDictionary new
+ ].
+ RegisteredErrorInterruptHandlers at:errorIDSymbol put:aHandler
+!
+
+registeredErrorInterruptHandlers
+ "return registered handlers"
+
+ ^ RegisteredErrorInterruptHandlers
+!
+
+signalInterruptHandler
+ "return the handler for UNIX-signal interrupts"
+
+ ^ SignalInterruptHandler
+!
+
+signalInterruptHandler:aHandler
+ "set the handler for UNIX-signal interrupts"
+
+ SignalInterruptHandler := aHandler
+!
+
+spyInterruptHandler
+ "return the handler for spy-timer interrupts"
+
+ ^ SpyInterruptHandler
+!
+
+spyInterruptHandler:aHandler
+ "set the handler for spy-timer interrupts"
+
+ SpyInterruptHandler := aHandler
+!
+
+stepInterruptHandler
+ "return the handler for single step interrupts"
+
+ ^ StepInterruptHandler
+!
+
+stepInterruptHandler:aHandler
+ "set the handler for single step interrupts"
+
+ StepInterruptHandler := aHandler
+!
+
+timerInterruptHandler
+ "return the handler for timer interrupts"
+
+ ^ TimerInterruptHandler
+!
+
+timerInterruptHandler:aHandler
+ "set the handler for timer interrupts"
+
+ TimerInterruptHandler := aHandler
+!
+
+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'!
+
+interruptLatency:ms receiver:rec class:cls selector:sel vmActivity:vmActivity
+ "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"
+!
+
+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.
+ ]
+
+ "
+ ObjectMemory interruptLatencyGoal:50
+ "
+!
+
+interruptLatencyMonitor
+ "return the interrupt-latency-monitor if any.
+ See comment in #interruptLatencyMonitor:.
+ This is a non-standard debugging/realtime instrumentation entry."
+
+ ^ InterruptLatencyMonitor
+!
+
+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
+!
+
+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'!
+
+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."
+
+ Smalltalk allBehaviorsDo:[:aClass |
+ aClass lowSpaceCleanup
+ ].
+
+"/ self error:'almost out of memory'
+ 'almost out of memory' errorPrintNL.
+
+ LowSpaceSemaphore signalIf.
! !
!ObjectMemory class methodsFor:'object finalization'!
@@ -2616,14 +2216,6 @@
%}
!
-finalize
- "tell all weak objects that something happened."
-
- self allChangedShadowObjectsDo:[:aShadowArray |
- aShadowArray lostPointer.
- ]
-!
-
disposeInterrupt
"this is triggered by the garbage collector,
whenever any shadowArray looses a pointer."
@@ -2641,6 +2233,14 @@
]
!
+finalize
+ "tell all weak objects that something happened."
+
+ self allChangedShadowObjectsDo:[:aShadowArray |
+ aShadowArray lostPointer.
+ ]
+!
+
startBackgroundFinalizationAt:aPriority
"start a process doing finalization work in the background.
Can be used to reduce the pauses created by finalization.
@@ -2707,6 +2307,18 @@
!ObjectMemory class methodsFor:'physical memory access'!
+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
+!
+
newSpacePagesDo:aBlock
"evaluates aBlock for all pages in the newSpace, passing
the pages address as argument.
@@ -2731,18 +2343,6 @@
^ true
!
-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
-!
-
pageIsInCore:aPageNumber
"return true, if the page (as enumerated via oldSpacePagesDo:)
is in memory; false, if currently paged out. For internal
@@ -2770,6 +2370,472 @@
^ true
! !
+!ObjectMemory class methodsFor:'queries'!
+
+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
+!
+
+fixSpaceSize
+ "return the total size of the fix space."
+
+%{ /* NOCONTEXT */
+ extern unsigned __fixSpaceSize();
+
+ RETURN ( _MKSMALLINT(__fixSpaceSize()) );
+%}
+ "
+ ObjectMemory fixSpaceSize
+ "
+!
+
+fixSpaceUsed
+ "return the number of bytes allocated for old objects in fix space."
+
+%{ /* NOCONTEXT */
+ extern unsigned __fixSpaceUsed();
+
+ RETURN ( _MKSMALLINT(__fixSpaceUsed()) );
+%}
+ "
+ ObjectMemory fixSpaceUsed
+ "
+!
+
+freeListSpace
+ "return the number of bytes in the free lists.
+ (which is included in oldSpaceUsed)"
+
+%{ /* NOCONTEXT */
+ extern unsigned __freeListSpace();
+
+ RETURN ( _MKSMALLINT(__freeListSpace()) );
+%}
+ "
+ ObjectMemory freeListSpace
+ "
+!
+
+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
+ "
+!
+
+garbageCollectCount
+ "return the number of compressing collects that occurred since startup"
+
+%{ /* NOCONTEXT */
+ extern int __garbageCollectCount();
+
+ RETURN (_MKSMALLINT(__garbageCollectCount()));
+%}
+ "
+ ObjectMemory garbageCollectCount
+ "
+!
+
+incrementalGCCount
+ "return the number of incremental collects that occurred since startup"
+
+%{ /* NOCONTEXT */
+ extern int __incrementalGCCount();
+
+ RETURN (_MKSMALLINT(__incrementalGCCount()));
+%}
+ "
+ ObjectMemory incrementalGCCount
+ "
+!
+
+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()));
+%}
+!
+
+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
+ "
+!
+
+lifoRememberedSet
+ "return the lifoRemSet.
+ This is pure VM debugging and will vanish without notice."
+
+%{ /* NOCONTEXT */
+ extern OBJ __lifoRememberedSet();
+
+ RETURN ( __lifoRememberedSet() );
+%}
+ "
+ ObjectMemory lifoRememberedSet
+ "
+!
+
+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
+ "
+!
+
+markAndSweepCount
+ "return the number of mark&sweep collects that occurred since startup"
+
+%{ /* NOCONTEXT */
+ extern int __markAndSweepCount();
+
+ RETURN (_MKSMALLINT(__markAndSweepCount()));
+%}
+ "
+ ObjectMemory markAndSweepCount
+ "
+!
+
+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
+ "
+!
+
+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
+ "
+!
+
+newSpaceSize
+ "return the total size of the new space - this is usually fix"
+
+%{ /* NOCONTEXT */
+ extern unsigned __newSpaceSize();
+
+ RETURN ( _MKSMALLINT(__newSpaceSize()) );
+%}
+ "
+ ObjectMemory newSpaceSize
+ "
+!
+
+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
+ "
+!
+
+numberOfObjects
+ "return the number of objects in the system."
+
+ |tally "{ Class: SmallInteger }"|
+
+ tally := 0.
+ self allObjectsDo:[:obj | tally := tally + 1].
+ ^ tally
+
+ "
+ ObjectMemory numberOfObjects
+ "
+!
+
+numberOfWeakObjects
+ "return the number of weak objects in the system"
+
+%{ /* NOCONTEXT */
+ extern int __weakListSize();
+
+ RETURN ( __MKSMALLINT(__weakListSize()) );
+%}
+ "
+ ObjectMemory numberOfWeakObjects
+ "
+!
+
+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
+ "
+!
+
+oldSpaceSize
+ "return the total size of the old space. - may grow slowly"
+
+%{ /* NOCONTEXT */
+ extern unsigned __oldSpaceSize();
+
+ RETURN ( _MKSMALLINT(__oldSpaceSize()) );
+%}
+ "
+ ObjectMemory oldSpaceSize
+ "
+!
+
+oldSpaceUsed
+ "return the number of bytes allocated for old objects.
+ (This includes the free lists)"
+
+%{ /* NOCONTEXT */
+ extern unsigned __oldSpaceUsed();
+
+ RETURN ( _MKSMALLINT(__oldSpaceUsed()) );
+%}
+ "
+ ObjectMemory oldSpaceUsed
+ "
+!
+
+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
+ "
+!
+
+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
+ "
+!
+
+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
+ "
+!
+
+scavengeCount
+ "return the number of scavenges that occurred since startup"
+
+%{ /* NOCONTEXT */
+ extern int __scavengeCount();
+
+ RETURN (_MKSMALLINT(__scavengeCount()));
+%}
+ "
+ ObjectMemory scavengeCount
+ "
+!
+
+symSpaceSize
+ "return the total size of the sym space."
+
+%{ /* NOCONTEXT */
+ extern unsigned __symSpaceSize();
+
+ RETURN ( _MKSMALLINT(__symSpaceSize()) );
+%}
+ "
+ ObjectMemory symSpaceSize
+ "
+!
+
+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()) );
+%}
+!
+
+whoReferences:anObject
+ "return a collection of objects referencing the argument, anObject"
+
+ ^ self collectObjectsWhich:[:o | o references:anObject]
+
+ "
+ (ObjectMemory whoReferences:Transcript) printNL
+ "
+!
+
+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'!
+
+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:'statistics'!
ageStatistic
@@ -2779,224 +2845,8 @@
%}
! !
-!ObjectMemory class methodsFor:'low memory handling'!
-
-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."
-
- Smalltalk allBehaviorsDo:[:aClass |
- aClass lowSpaceCleanup
- ].
-
-"/ self error:'almost out of memory'
- 'almost out of memory' errorPrintNL.
-
- LowSpaceSemaphore signalIf.
-! !
-
!ObjectMemory class methodsFor:'system management'!
-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
- ]
- ]
-!
-
-imageName
- "return the filename of the current image, or nil
- if not running from an image."
-
- ^ ImageName
-
- "
- ObjectMemory imageName
- "
-!
-
-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
-
- "
- ObjectMemory imageBaseName
- "
-!
-
-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'
-
- "
- ObjectMemory nameForSources
- "
-!
-
-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'
-
- "
- ObjectMemory nameForChanges
- "
-!
-
-nameForChanges:aFilename
- "set the name of the file where changes are stored into."
-
- ChangeFileName := aFilename
-
- "
- ObjectMemory nameForChanges:'myChanges'
- "
-!
-
-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|
-
- "
- 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.
- ImageName := aFileName.
- ok := self primSnapShotOn:aFileName.
- ImageName := oldImageName.
-
- 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'
- "
-!
-
-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
-!
-
allBinaryModulesDo:aBlock
"internal private method - walk over all known binary
modules and evaluate aBlock for each entry.
@@ -3119,159 +2969,203 @@
"
"Modified: 30.8.1995 / 17:29:30 / claus"
-! !
-
-!ObjectMemory class ignoredMethodsFor:'system management'!
-
-applicationImageOn:aFileName for:startupClass selector:startupSelector
- "create a snapshot which will come up without any views
- but starts up an application by sending startupClass the startupSelector.
- This exists to nail down an idea I tried once.
- It is absolutely EXPERIMENTAL and unfinished. Dont use this method."
-
- |viewsKnown savedIdleBlocks savedTimeoutBlocks savedTranscript
- savedRoot|
-
- viewsKnown := Display knownViews.
- savedTranscript := Transcript.
- savedRoot := RootView.
-
- "a kludge: save image with modified knownViews,
- and also Transcript set to StdErr ..."
-
- Display knownViews:nil.
- RootView := nil.
-
- Transcript := Stderr.
- Smalltalk startupClass:startupClass selector:startupSelector arguments:nil.
- self snapShotOn:aFileName.
- Smalltalk startupClass:nil selector:nil arguments:nil.
-
- RootView := savedRoot.
- Transcript := savedTranscript.
- Display knownViews:viewsKnown.
+!
+
+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
+
+ "
+ ObjectMemory imageBaseName
+ "
+!
+
+imageName
+ "return the filename of the current image, or nil
+ if not running from an image."
+
+ ^ ImageName
"
- ObjectMemory applicationImageOn:'draw.img' for:DrawTool selector:#start
+ ObjectMemory imageName
"
!
-minimumApplicationImageOn:aFileName for:startupClass selector:startupSelector
- "create a snapshot which will come up without any views
- but starts up an application by sending startupClass the startupSelector.
- All unneeded info is stripped from the saved image.
- This exists to nail down an idea I tried once.
- It is absolutely EXPERIMENTAL and unfinished. Dont use this method."
-
- "create a temporary image, for continuation"
- self snapShotOn:'temp.img'.
-
- Display knownViews do:[:aView |
- aView notNil ifTrue:[
- aView superView isNil ifTrue:[
- aView destroy
- ]
+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
]
- ].
-
- self stripImage.
-
- self applicationImageOn:aFileName for:startupClass selector:startupSelector.
-
- "continue in old image"
-
- OperatingSystem exec:(Arguments at:1)
- withArguments:#('smalltalk' '-i' 'temp.img') , (Arguments copyFrom:2)
+ ]
+!
+
+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'
"
- ObjectMemory minimumApplicationImageOn:'draw1.img' for:DrawTool selector:#start
- ObjectMemory applicationImageOn:'draw2.img' for:DrawTool selector:#start
+ ObjectMemory nameForChanges
+ "
+!
+
+nameForChanges:aFilename
+ "set the name of the file where changes are stored into."
+
+ ChangeFileName := aFilename
+
+ "
+ ObjectMemory nameForChanges:'myChanges'
+ "
+!
+
+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
"
!
-stripImage
- "remove all unneeded stuff from the image - much more is possible here.
- EXPERIMENTAL and unfinished. Dont use this method."
-
- "remove all class comments & source"
-
- Smalltalk allBehaviorsDo:[:aClass |
- aClass setComment:nil.
- aClass methodArray do:[:aMethod |
- aMethod source:''.
- aMethod category:#none
- ]
- ].
-
- "remove some developpers classes"
-
- Smalltalk at:#Compiler put:Parser.
- Smalltalk at:#Debugger put:MiniDebugger.
- Smalltalk at:#Inspector put:MiniInspector.
- Smalltalk at:#FileBrowser put:nil.
- Smalltalk at:#SystemBrowser put:nil.
- Debugger newDebugger.
-
- self garbageCollect
-! !
-
-!ObjectMemory class methodsFor:'ST-80 compatibility'!
-
-availableFreeBytes
- ^ self freeSpace + self freeListSpace
+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'
"
- ObjectMemory availableFreeBytes
+ ObjectMemory nameForSources
+ "
+!
+
+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
"
!
-current
- ^ self
-!
-
-growMemoryBy:numberOfBytes
- ^ self moreOldSpace:numberOfBytes
-!
-
-numOopsNumBytes
- ^ Array with:(self numberOfObjects)
- with:(self bytesUsed)
+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|
+
+ "
+ 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
"
- ObjectMemory numOopsNumBytes
+ ST-80 compatibility; send #preSnapshot to all classes
"
-!
-
-bytesPerOOP
- "return the number of bytes an object reference (for example: an instvar)
- takes"
-
-%{ /* NOCONTEXT */
- RETURN(__MKSMALLINT(sizeof(OBJ)));
-%}
+ Smalltalk allBehaviorsDo:[:aClass |
+ aClass preSnapshot
+ ].
"
- ObjectMemory bytesPerOOP
+ save the name with it ...
"
-!
-
-bytesPerOTE
- "return the number of overhead bytes of an object.
- i.e. the number of bytes in every objects header."
-
-%{ /* NOCONTEXT */
- RETURN(__MKSMALLINT(OHDR_SIZE));
-%}
+ oldImageName := ImageName.
+ ImageName := aFileName.
+ ok := self primSnapShotOn:aFileName.
+ ImageName := oldImageName.
+
+ ok ifTrue:[
+ Class addChangeRecordForSnapshot:aFileName.
+ ].
+
"
- ObjectMemory bytesPerOTE
+ ST-80 compatibility; send #postSnapshot to all classes
"
-!
-
-globalCompactingGC
- self garbageCollect
-!
-
-compactingGC
- self garbageCollect
+ Smalltalk allBehaviorsDo:[:aClass |
+ aClass postSnapshot
+ ].
+ self changed:#finishedSnapshot. "/ ST-80 compatibility
+ ^ ok
+
+ "
+ ObjectMemory snapShotOn:'myimage.img'
+ "
! !
+
+ObjectMemory initialize!