"

 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

! !