--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/ObjectMemory.st Fri Jul 16 11:39:45 1993 +0200
@@ -0,0 +1,367 @@
+"
+ 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:''
+ poolDictionaries:''
+ category:'System-Support'
+!
+
+ObjectMemory comment:'
+
+COPYRIGHT (c) 1992 -93 by Claus Gittinger
+ All Rights Reserved
+
+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.
+
+%W% %E%
+'!
+
+!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();
+%}
+!
+
+flushCaches
+ "flush method and inline caches"
+
+%{ /* NOCONTEXT */
+ __flushMethodCache();
+ __flushAllInlineCaches();
+%}
+! !
+
+!ObjectMemory class methodsFor:'enumeration'!
+
+allObjectsDo:aBlock
+ "evaluate the argument, aBlock for all objects in the system"
+%{
+#ifdef THIS_CONTEXT
+ __allObjectsDo(&aBlock);
+#else
+ __allObjectsDo(&aBlock, __context);
+#endif
+%}
+! !
+
+!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"
+!
+
+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
+ "forcae 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);
+%}
+!
+
+turnOffGarbageCollector
+ "turn off garbage collector.
+ 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 waranty"
+%{
+ allocForceSpace(0);
+%}
+!
+
+turnOnGarbageCollector
+ "turn it 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|
+
+ viewsKnown := Display knownViews.
+ savedIdleBlocks := Display idleBlocks.
+ savedTimeoutBlocks := Display timeOutBlocks.
+ savedTranscript := Transcript.
+
+ "a kludge: save image with modified knownViews ..."
+
+ Display knownViews:nil.
+ Display idleBlocks:nil.
+ Display timeOutBlocks:nil.
+ Transcript := Stderr.
+ StartupClass := startupClass.
+ StartupSelector := startupSelector.
+
+ self snapShotOn:aFileName.
+
+ StartupClass := nil.
+ StartupSelector := nil.
+ 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"
+
+ Smalltalk allClassesDo:[:aClass |
+ aClass setComment:nil.
+ aClass methodDictionary do:[:aMethod |
+ aMethod source:''.
+ aMethod category:#none
+ ]
+ ].
+ self garbageCollect
+! !