"
COPYRIGHT (c) 1992 by Claus Gittinger
All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
inclusion of the above copyright notice. This software may not
be provided or otherwise made available to, or used by, any
other person. No title to or ownership of the software is
hereby transferred.
"
Object subclass:#ObjectMemory
instanceVariableNames:''
classVariableNames:'InternalErrorHandler UserInterruptHandler TimerInterruptHandler
SpyInterruptHandler StepInterruptHandler ExceptionInterruptHandler
ErrorInterruptHandler MemoryInterruptHandler SignalInterruptHandler
ChildSignalInterruptHandler DisposeInterruptHandler
RecursionInterruptHandler IOInterruptHandler
CustomInterruptHandler
AllocationFailureSignal
IncrementalGCLimit
Dependents
ImageName'
poolDictionaries:''
category:'System-Support'
!
ObjectMemory comment:'
COPYRIGHT (c) 1992 by Claus Gittinger
All Rights Reserved
$Header: /cvs/stx/stx/libbasic/ObjectMemory.st,v 1.15 1994-10-10 00:26:56 claus Exp $
'!
!ObjectMemory class methodsFor:'documentation'!
copyright
"
COPYRIGHT (c) 1992 by Claus Gittinger
All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
inclusion of the above copyright notice. This software may not
be provided or otherwise made available to, or used by, any
other person. No title to or ownership of the software is
hereby transferred.
"
!
version
"
$Header: /cvs/stx/stx/libbasic/ObjectMemory.st,v 1.15 1994-10-10 00:26:56 claus Exp $
"
!
documentation
"
This class contains access methods to the system memory -
in previous versions this stuff used to be in the Smalltalk class.
It has been separated for better overall structure.
Many methods here are for debuging purposes only, and not standard.
Do not depend on them being there - some may vanish ...
(especially those, that depend on a specific GC implementation)
kludge:
The InterruptHandler variables are known by the runtime system -
they are the objects that get an interrupt message when the event
occurs.
ClassVariables:
InternalErrorHandler gets informed (by VM), when some runtime
error occurs (usually fatal)
UserInterruptHandler gets informed (by VM) when CNTL-C is pressed
TimerInterruptHandler gets alarm timer interrupts (from VM)
SpyInterruptHandler another alarm timer (from VM)
StepInterruptHandler gets single step interrupts (from VM)
ExceptionInterruptHandler gets floating point exceptions (from VM)
ErrorInterruptHandler gets graphic device errors (from VM)
MemoryInterruptHandler gets soon-out-of-memory conditions (from VM)
SignalInterruptHandler gets unix signals (from VM)
ChildSignalInterruptHandler gets child death signals (from VM)
DisposeInterruptHandler gets informed, when an object is disposed from
a shadowArray (from VM)
RecursionInterruptHandler gets recursion limit violations (from VM)
IOInterruptHandler gets SIGIO unix signals (from VM)
CustomInterruptHandler gets custom interrupts (from VM)
AllocationFailureSignal signal raised when a new fails (see Behavior)
IngrementalGCLimit number of bytes, that must be allocated since
last full garbage collect to turn on incremental
collector.
Dependents keep my dependents locally (its faster) for
all those registries
"
!
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 reched
at this call location. The list is flushed if it
grows too large or the total 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 - to be
'on the brigth side of live', use ObjectMemory>>flushCaches, when in dooubt
of which caches should be flushed. 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).
Typically, the handlers are set during early initialization of the system
by sending 'ObjectMemory XXXInterruptHandler:aHandler'.
(see Smalltalk>>initialize or ProcessorScheduler>>initialize)
"
!
garbageCollection
"
Currently, Smalltalk/X uses a two-level memory hierachy.
Objects are created in a so-called newSpace, which is relatively small.
This newSpace is cleaned by a scavenge-operation whenever becoming
full. Scavenging means, that all still-live objects (i.e. referenced by some
other) are copied over to another memory area, leaving all unreferenced
objects as garbage behind. Once an object survives enough of these copying
operations, the next scavenge will move it into the so called oldSpace,
which is much larger. This movement of an object from newSpace to oldSpace
is called 'tenure'.
Scavenging occurs automatically, and is usually done fast enough to go
unnoticed (typically, it takes some 5 to 50ms to perform a scavenge,
depending on how many live objects are in the newspace).
Interrestingly, the scavenger performs better, if many garbage objects
are to be reclaimed, since less object-copying has to be done. Therefore,
the best case scavenge times are almost zero, if there is only garbage in
the newSpace, while the worst case is when all newSpace objects are still
living. To honor this situation, the systems uses an adaptive tenure-count,
which adjusts the number of scavenges needed for tenure according to the
fill-grade of the newSpace.
To reclaim oldspace, the system uses three algorithms: mark&sweep, a copying
(and compressing) baker-type collector and an incremental mark&sweep.
The mark&sweep runs whenever the oldspace becomes full, putting dead objects
onto a free list. If a memory request cannot be served from this freelist,
and the total size of objects on the freelist exceeds a threshold, the system
will compress the oldspace to make the free-space into one big area.
Since a compressing oldspace collect leads to a noticable pause of the system,
the memory manager tries hard to avoid oldspace compression.
The incremental mark&sweep runs in the background, whenever the system is idle
(see ProcessorSceduler>>waitForEventOrTimeout). Like the normal mark&sweep,
this incremental collector follows object references and marks reachable objects
on its way. This is done 'a few objects-at-a-time', to not disrupt the system
noticable. Incremental collection is controlled by the variable
'IncrementalGCLimit'. The ProcessorScheduler will be perform incremental GC steps
if the total space used by objects allocated since the last full collect exceeds
this number. Its default is set in ObjectMemory>>initialize and can be changed in
your startup 'smalltalk.rc'-file. Setting it to nil will turn incremental GC off.
hints & tricks:
normally, there is no need to call for an explicit garbage collection;
the memory system should adapt reasonable and provide good performance
for a wide range of allocation patterns.
However, there could be situations, in which hints and/or explicit
control over allocation can speedup your programs.
Example 1:
you are about to allocate a huge data structure, which is known to
survive long. In this case, it is better to have these objects move into the
oldspace sooner, to avoid the copying overhead during scavenges.
To do this, you can call ObjectMemory>>tenure after allocation, which
forces all new-objects immediately into the oldspace.
Make certain, that not to many (ideally no) short-living objects are in the
newspace when doing this.
Another alternative is to tell the system that all allocation should be
done directly in the oldspace. This completely avoids the scavenging overhead
for these objects. To do so, use ObjectMemory>>turnGarbageCollectorOff
before the allocation, and ObjectMemory>>turnGarbageCollectorOn afterwards.
Keep in mind, that do-loops may allocate block-objects and other temoraries,
so there is a danger of making things worse due to having all those temoraries
in the oldspace afterwards. (which is not a fatal situation, but will
force the system to do an oldspace collect earlier, which may make things
worse).
Example 2:
you know in advance, that a certain (big) amount of memory will be needed.
For example, the fileBrowser wants to show a huge file in its text-view.
In this case, it is better to tell the memory system in advance, how much
memory will be needed, since otherwise many compresses and reallocations will
occur (the memory system will allocate additional memory in chunks of smaller
256k pieces, if a compress failes. Thus, if you are going to allocate (say) 1Mb of
strings, it will perform 5 compressing GC's).
This is done using ObjectMemory>>moreOldSpace: or ObjectMemory announceOldSpaceNeed:.
In the above example, you would do 'ObjectMemory announceOldSpaceNeed:500000', which
avoids those annoying 5 compressing GC's.
The amount of automatic increase (in case the oldSpace becomes full) is 256k by
default. This number can be changed with ObjectMemory>>oldSpaceIncrement:.
Warning: many of these methods are not standard and may not even be available in
future versions of ST/X. Use them only in very special situations or experiments.
"
! !
!ObjectMemory class methodsFor:'initialization'!
initialize
AllocationFailureSignal isNil ifTrue:[
Object initialize.
AllocationFailureSignal := Object errorSignal newSignalMayProceed:true.
AllocationFailureSignal nameClass:self message:#allocationFailureSignal.
AllocationFailureSignal notifierString:'allocation failure'.
].
IncrementalGCLimit := 500000.
MemoryInterruptHandler := self
! !
!ObjectMemory class methodsFor:'signal access'!
allocationFailureSignal
"return the signal raised when an object allocation failed"
^ AllocationFailureSignal
! !
!ObjectMemory class methodsFor:'dependents access'!
dependents
"return the colleciton of my dependents"
^ Dependents
!
dependents:aCollection
"set the dependents collection"
Dependents := aCollection
! !
!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));
%}
!
flushInlineCaches
"flush all inlinecaches"
%{ /* NOCONTEXT */
__flushAllInlineCaches();
%}
!
flushMethodCacheFor:aClass
"flush the method cache for sends to aClass"
%{ /* NOCONTEXT */
__flushMethodCacheFor(aClass);
%}
!
flushMethodCache
"flush the method cache"
%{ /* NOCONTEXT */
__flushMethodCache();
%}
!
flushCachesFor:aClass
"flush method and inline caches for aClass"
%{ /* NOCONTEXT */
__flushMethodCacheFor(aClass);
__flushInlineCachesFor(aClass);
%}
!
flushCaches
"flush method and inline caches for all classes"
%{ /* NOCONTEXT */
__flushMethodCache();
__flushAllInlineCaches();
%}
! !
!ObjectMemory class methodsFor:'enumeration'!
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 (__allObjectsDo(&aBlock, &work COMMA_CON) < 0) {
RETURN (false);
}
%}.
^ true
!
allOldObjectsDo:aBlock
"evaluate the argument, aBlock for all old objects in the system.
For debugging and tests only - do not use"
%{
if (__allObjectsDo(&aBlock, (OBJ *)0 COMMA_CON) < 0) {
RETURN (false);
}
%}.
^ true
! !
!ObjectMemory class methodsFor:'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
!
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:'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
"
!
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
"
!
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 be dead"
%{ /* 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 garbage collect occured"
%{ /* NOCONTEXT */
extern unsigned __oldSpaceAllocatedSinceLastGC();
RETURN ( _MKSMALLINT(__oldSpaceAllocatedSinceLastGC()) );
%}
"
ObjectMemory oldSpaceAllocatedSinceLastGC
"
!
numberOfObjects
"return the number of objects in the system."
|tally|
tally := 0.
self allObjectsDo:[:obj | tally := tally + 1].
^ tally
"
ObjectMemory numberOfObjects
"
!
printReferences:anObject
"for debugging: print referents to anObject - this will vanish.
use ObjectMemory>>whoReferences: or anObject>>allOwners."
%{
_printRefChain(__context, anObject);
%}
!
whoReferences:anObject
"return a collection of objects referencing the argument, anObject"
|aCollection|
aCollection := IdentitySet new.
self allObjectsDo:[:o |
(o references:anObject) ifTrue:[
aCollection add:o
]
].
(aCollection size == 0) ifTrue:[
"actually this cannot happen - there is always one"
^ nil
].
^ aCollection
!
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.
Use only for debugging."
%{ /* NOCONTEXT */
if (! _isNonNilObject(anObject)) {
RETURN ( nil );
}
RETURN ( _MKSMALLINT( (int)anObject ) );
%}
"
|p|
p := Point new.
(ObjectMemory addressOf:p) printNL.
ObjectMemory scavenge.
(ObjectMemory addressOf:p) 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.
This method will be removed from the final shipping version"
|low high|
low := anAddress bitAnd:16rFFFF.
high := (anAddress bitShift:16) bitAnd:16rFFFF.
%{
if (_isSmallInteger(low)
&& _isSmallInteger(high)) {
RETURN ((OBJ)((_intVal(high) << 16) | _intVal(low)));
}
%}
!
sizeOf:anObject
"return the size of anObject in bytes.
Use only for debugging/memory monitoring."
%{ /* 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, returned value is invalid after the
next scavenge/collect.
Use only for debugging."
%{ /* NOCONTEXT */
if (! _isNonNilObject(anObject)) {
RETURN ( nil );
}
RETURN ( _MKSMALLINT( _qSpace(anObject) ) );
%}
!
flagsOf:anObject
%{ /* NOCONTEXT */
if (! _isNonNilObject(anObject)) {
RETURN ( nil );
}
RETURN ( _MKSMALLINT( anObject->o_flags ) );
%}
"
F_ISREMEMBERED 1 /* a new-space thing on rem-list */
F_ISFORWARDED 2 /* a forwarded object (only valid after scavenge) */
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 */
"
!
ageOf:anObject
"return the number of scavenges, an object has survived
in new space. For old objects, the returned number is invalid.
Use only for debugging."
%{ /* 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.
"
! !
!ObjectMemory class methodsFor:'garbage collector control'!
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.
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 before, and a tenure when 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
"
!
garbageCollect
"search for and free garbage in the oldSpace
(newSpace is cleaned automatically) performing a COMPRESSING
garbage collect.
This can take a long time - especially, if paging is involved
(when no paging is involved, its faster than I thought :-)"
%{
__garbageCollect(__context);
%}
"
ObjectMemory garbageCollect
"
!
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 ...
Future versions may do this while garbage collecting."
%{
__reclaimSymbols(__context);
%}
"
ObjectMemory reclaimSymbols
"
!
markAndSweep
"mark/sweep garbage collector.
perform a full mark&sweep collect.
Warning: this may take some time."
%{
markAndSweep(__context);
%}
"
ObjectMemory markAndSweep
"
!
gcStep
"one incremental garbage collect step.
Mark or sweep some small number of objects. This
method will return after a reasonable (short) time.
This is used by the ProcessorScheduler at idle times.
Returns true, if an incremental GC cycle has finished."
%{
extern int __incrGCstep();
RETURN (__incrGCstep(__context) ? true : false);
%}
!
incrementalGC
"perform one round of incremental GC steps.
The effect of this method is the same as calling markAndSweep.
However, #incrementalGC is interruptable while #markAndSweep
blocks for a while. Thus this method can be called from a low
prio (background) process to collect without disturbing
foreground processes too much.
For example, someone allocating huge amounts of memory could
ask for the possibility of a quick allocation using
#checkForFastNew: and try a #incrementalGC if not. In many
cases, this can avoid a pause due to a blocking GC."
[self gcStep] whileFalse:[]
"
ObjectMemory incrementalGC
"
!
incrementalGCLimit:aNumber
"set the limit for incremental GC activation.
This is used by the ProcessorScheduler."
IncrementalGCLimit := aNumber
"
ObjectMemory incrementalGCLimit:100000
"
!
incrementalGCLimit
"return the limit for incremental GC activation.
This is used by the ProcessorScheduler."
^ IncrementalGCLimit
"
ObjectMemory incrementalGCLimit
"
!
moreOldSpace:howMuch
"allocate howMuch bytes more for old objects.
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.
This (currently) implies a compressing garbage collect - so its slow.
Notice: this is a nonstandard interface - use only in special situations."
%{
if (_isSmallInteger(howMuch))
__moreOldSpace(__context, _intVal(howMuch));
%}
"
ObjectMemory moreOldSpace:1000000
"
!
announceOldSpaceNeed:howMuch
"checks if howMuch memory can be allocated without forcing a compressing
GC. If not, the oldSpace is increased. This will also force 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."
%{
extern unsigned __oldSpaceIncrement();
RETURN (_MKSMALLINT( __oldSpaceIncrement(-1) ));
%}
!
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."
%{
extern unsigned __oldSpaceIncrement();
if (_isSmallInteger(amount)) {
RETURN (_MKSMALLINT( __oldSpaceIncrement(_intVal(amount)) ));
}
%}
!
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 pause due to
a forced (non-incremental) GC.
This is experimental and not guaranteed to be in future versions."
%{
extern __checkForFastNew();
if (_isSmallInteger(amount)) {
if (! __checkForFastNew(_intVal(amount))) {
RETURN (false);
}
}
%}.
^ true
!
turnGarbageCollectorOff
"turn off garbage collector by forcing new objects to be
allocated in oldSpace (instead of newSpace)
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.
Use this only for special purposes or when realtime behavior
is required for a limited time period.
No warranty - the system may run into trouble ..."
%{
__allocForceSpace(OLDSPACE);
%}
!
turnGarbageCollectorOn
"turn garbage collector on again"
%{
__allocForceSpace(9999);
%}
! !
!ObjectMemory class methodsFor:'physical memory access'!
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
!
newSpacePagesDo:aBlock
"evaluates aBlock for all pages in the newSpace, passing
the pages address as argument.
For internal & debugging use only."
%{
if (__newSpacePagesDo(&aBlock COMMA_CON) < 0) {
RETURN (false);
}
%}.
^ true
!
oldSpacePagesDo:aBlock
"evaluates aBlock for all pages in the oldSpace, passing
the pages address as argument.
For internal & debugging use only."
%{
if (__oldSpacePagesDo(&aBlock COMMA_CON) < 0) {
RETURN (false);
}
%}.
^ true
!
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
use / monitors only; may vanish.
NOTICE: not all systems provide this information; on those that
do not, true is returned for all pages."
%{
#ifdef HAS_MINCORE
int pageSize = getpagesize();
char result[10];
INT addr;
if (_isSmallInteger(aPageNumber)) {
addr = _intVal(aPageNumber) & ~(pageSize - 1);
} else {
addr = ((INT)aPageNumber) & ~(pageSize - 1);
}
if (mincore(addr, pageSize-1, result) < 0) {
RETURN (true);
}
RETURN ((result[0] & 1) ? true : false);
#endif
%}.
"OS does not supply this info - assume yes"
^ true
! !
!ObjectMemory class methodsFor:'low memory handling'!
memoryInterrupt
"when a low-memory condition arises, ask all classes to
remove possibly cached data - this may help a bit"
Smalltalk allClasses do:[:aClass |
aClass lowSpaceCleanup
].
self error:'almost out of memory'
! !
!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 upd|
fName := self fileNameForClass:aClassName.
fName notNil ifTrue:[
upd := Class updateChanges:false.
[
self loadBinary:(fName , '.o')
] valueNowOrOnUnwindDo:[
Class updateChanges:upd
].
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
"
!
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'"
(ImageName isNil or:[ImageName isBlank]) ifTrue:[
^ 'st.img'
].
(ImageName endsWith:'.sav') ifTrue:[
^ ImageName copyTo:(ImageName size - 4)
].
^ ImageName
"
ObjectMemory nameForSnapshot
"
!
snapShot
"create a snapshot file containing all of the current state."
"/ ImageName isNil ifTrue:[
"/ ImageName := 'st.img'
"/ ].
self snapShotOn:(self nameForSnapshot)
"
ObjectMemory snapShot
"
!
snapShotOn:aFileName
"create a snapshot in the given file"
|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.
"
ST-80 compatibility; send #preSnapshot to all classes
"
Smalltalk allClassesDo:[: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 allClassesDo:[:aClass |
aClass postSnapshot
].
].
^ 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
!
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.
EXPERIMENTAL and unfinished. Dont use this method."
|viewsKnown savedIdleBlocks savedTimeoutBlocks savedTranscript
savedRoot|
viewsKnown := Display knownViews.
savedIdleBlocks := Display idleBlocks.
savedTimeoutBlocks := Display timeOutBlocks.
savedTranscript := Transcript.
savedRoot := RootView.
"a kludge: save image with modified knownViews, no idle- and timeoutblocks
and also Transcript set to StdErr ..."
Display knownViews:nil.
Display idleBlocks:nil.
Display timeOutBlocks: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.
Display idleBlocks:savedIdleBlocks.
Display timeOutBlocks:savedTimeoutBlocks
"ObjectMemory applicationImageOn:'draw.img' for:DrawTool selector:#start"
"ObjectMemory applicationImageOn:'pm.img' for:PMSimulator selector:#start"
!
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.
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
]
]
].
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)
"ObjectMemory minimumApplicationImageOn:'clock1.img' for:Clock selector:#start"
"ObjectMemory applicationImageOn:'clock2.img' for:Clock selector:#start"
!
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
]
].
self garbageCollect
! !