"
COPYRIGHT (c) 1992-93 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
AllocationFailureSignal
IncrementalGCLimit'
poolDictionaries:''
category:'System-Support'
!
ObjectMemory comment:'
COPYRIGHT (c) 1992 -93 by Claus Gittinger
All Rights Reserved
$Header: /cvs/stx/stx/libbasic/Attic/ObjMem.st,v 1.3 1993-10-13 00:16:47 claus Exp $
'!
!ObjectMemory class methodsFor:'documentation'!
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.
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, when some runtime error occurs
(usually fatal)
UserInterruptHandler gets informed when CNTL-C is pressed
TimerInterruptHandler gets alarm timer interrupts
SpyInterruptHandler another alarm timer
StepInterruptHandler gets single step interrupts
ExceptionInterruptHandler gets floating point exceptions
ErrorInterruptHandler gets graphic device errors
MemoryInterruptHandler gets out of memory conditions
SignalInterruptHandler gets unix signals
ChildSignalInterruptHandler gets child death signals
DisposeInterruptHandler gets informed, when an object is disposed from
a shadowArray
RecursionInterruptHandler gets recursion limit violations
IOInterruptHandler get SIGIO unix signals
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.
"
! !
!ObjectMemory class methodsFor:'initialization'!
initialize
AllocationFailureSignal isNil ifTrue:[
AllocationFailureSignal := (Signal new) mayProceed:true.
AllocationFailureSignal notifierString:'allocation failure'.
].
IncrementalGCLimit := 500000.
! !
!ObjectMemory class methodsFor:'signal access'!
allocationFailureSignal
^ AllocationFailureSignal
! !
!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"
|work|
%{
nonTenuringScavenge(__context);
/*
* allObjectsDo needs a temporary to hold newSpace objects
*/
__allObjectsDo(&aBlock, &work COMMA_CON);
%}
!
allOldObjectsDo:aBlock
"evaluate the argument, aBlock for all old objects in the system.
For debugging and tests only - do not use"
%{
__allObjectsDo(&aBlock, (OBJ *)0 COMMA_CON);
%}
! !
!ObjectMemory class methodsFor:'handler access'!
internalErrorHandler
^ InternalErrorHandler
!
userInterruptHandler
^ UserInterruptHandler
!
userInterruptHandler:aHandler
UserInterruptHandler := aHandler
!
timerInterruptHandler
^ TimerInterruptHandler
!
spyInterruptHandler
^ SpyInterruptHandler
!
spyInterruptHandler:aHandler
SpyInterruptHandler := aHandler
!
stepInterruptHandler
^ StepInterruptHandler
!
stepInterruptHandler:aHandler
StepInterruptHandler := aHandler
!
exceptionInterruptHandler
^ ExceptionInterruptHandler
!
errorInterruptHandler
^ ErrorInterruptHandler
!
errorInterruptHandler:aHandler
ErrorInterruptHandler := aHandler
!
memoryInterruptHandler
^ MemoryInterruptHandler
!
signalInterruptHandler
^ SignalInterruptHandler
!
childSignalInterruptHandler
^ ChildSignalInterruptHandler
!
disposeInterruptHandler
^ DisposeInterruptHandler
!
disposeInterruptHandler:aHandler
DisposeInterruptHandler := aHandler
!
recursionInterruptHandler
^ RecursionInterruptHandler
!
ioInterruptHandler
^ IOInterruptHandler
!
ioInterruptHandler:aHandler
IOInterruptHandler := aHandler
! !
!ObjectMemory class methodsFor:'queries'!
newSpaceUsed
"return the number of bytes allocated for new objects"
%{ /* NOCONTEXT */
RETURN ( _MKSMALLINT(__newSpaceUsed()) );
%}
"ObjectMemory newSpaceUsed"
!
oldSpaceUsed
"return the number of bytes allocated for old objects"
%{ /* NOCONTEXT */
RETURN ( _MKSMALLINT(__oldSpaceUsed()) );
%}
"ObjectMemory oldSpaceUsed"
!
bytesUsed
"return the number of bytes allocated for objects -
this number is not exact, since some objects may be dead"
%{ /* NOCONTEXT */
RETURN ( _MKSMALLINT(__oldSpaceUsed() + __newSpaceUsed()) );
%}
"ObjectMemory bytesUsed"
!
oldSpaceAllocatedSinceLastGC
"return the number of bytes allocated for old objects since the
last garbage collect occured"
%{ /* NOCONTEXT */
RETURN ( _MKSMALLINT(__oldSpaceAllocatedSinceLastGC()) );
%}
"ObjectMemory oldSpaceAllocatedSinceLastGC"
!
incrementalGCLimit
"return the limit for incremental GC activation"
^ IncrementalGCLimit
"ObjectMemory incrementalGCLimit"
!
numberOfObjects
"return the number of objects in the system"
|tally|
tally := 0.
self allObjectsDo:[:obj | tally := tally + 1].
^ tally
"ObjectMemory numberOfObjects"
!
printReferences:anObject
"debugging: print referents to anObject"
%{
_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
! !
!ObjectMemory class methodsFor:'garbage collector control'!
garbageCollect
"search for and free garbage in the oldSpace
(newSpace is cleaned automatically)
- can take a long time if paging is involved
- when no paging is involved, its faster than I thought :-)"
%{
__garbageCollect(__context);
%}
"ObjectMemory garbageCollect"
!
scavenge
"for debugging only - collect newspace stuff"
%{
nonTenuringScavenge(__context);
%}
"ObjectMemory scavenge"
!
tenure
"force all new stuff into old-space"
%{
tenure(__context);
%}
"ObjectMemory tenure"
!
markAndSweep
"mark/sweep garbage collector"
%{
markAndSweep(__context);
%}
"ObjectMemory markAndSweep"
!
gcStep
"one incremental garbage collect step"
%{
incrGCstep(__context);
%}
!
incrementalGCLimit:aNumber
"set the limit for incremental GC activation"
IncrementalGCLimit := aNumber
"ObjectMemory incrementalGCLimit:100000"
!
turnGarbageCollectorOff
"turn off garbage collector by forcing new objects to be
allocated in oldSpace (instead of newSpace)
this method is somewhat dangerous: if collector is turned off,
and too many objects are created, the system may run into trouble.
Use this only for measurement purposes or when realtime behavior
is required for a limited time period. No warranty"
%{
allocForceSpace(0);
%}
!
turnGarbageCollectorOn
"turn garbage collector on again"
%{
allocForceSpace(1);
%}
! !
!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
]
]
!
snapShot
"create a snapshot"
ImageName isNil ifTrue:[
ImageName := 'st.img'
].
self snapShotOn:ImageName
"ObjectMemory snapShot"
!
snapShotOn:aFileName
"create a snapshot in the given file"
"give others a chance to fix things"
self changed:#save.
%{
OBJ __snapShotOn();
if (_isString(aFileName)) {
RETURN ( __snapShotOn(__context, _stringVal(aFileName)) );
}
%}
.
^ self primitiveFailed
"ObjectMemory snapShotOn:'myimage.img'"
!
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"
|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 ..."
Display knownViews:nil.
Display idleBlocks:nil.
Display timeOutBlocks:nil.
RootView := nil.
Transcript := Stderr.
StartupClass := startupClass.
StartupSelector := startupSelector.
self snapShotOn:aFileName.
StartupClass := nil.
StartupSelector := 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."
"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"
"remove all class comments & source"
Smalltalk allBehaviorsDo:[:aClass |
aClass setComment:nil.
aClass methodDictionary do:[:aMethod |
aMethod source:''.
aMethod category:#none
]
].
self garbageCollect
! !