"

 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

'!

!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