"

 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

                           AllocationFailureSignal

                           IncrementalGCLimit

                           Dependents'

       poolDictionaries:''

       category:'System-Support'

!

ObjectMemory comment:'

COPYRIGHT (c) 1992 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.

Many methods here are for debuging purposes only, and not standard.

(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, 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 soon-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.

Dependents                      keep my dependents locally (its faster) for

                                all those registries

"

! !

!ObjectMemory class methodsFor:'initialization'!

initialize

    AllocationFailureSignal isNil ifTrue:[

        AllocationFailureSignal := (Signal new) mayProceed:true.

        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"

    |work|

%{  /* NOREGISTER - work may not be placed into a register here */

    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

    "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

! !

!ObjectMemory class methodsFor:'queries'!

newSpaceSize

    "return the total size of the new space - this is usually fix"

%{  /* NOCONTEXT */

    RETURN ( _MKSMALLINT(__newSpaceSize()) );

%}

    "ObjectMemory newSpaceSize"

!

oldSpaceSize

    "return the total size of the old space. - may grow slowly"

%{  /* NOCONTEXT */

    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 */

    RETURN ( _MKSMALLINT(__newSpaceUsed()) );

%}

    "ObjectMemory newSpaceUsed"

!

oldSpaceUsed

    "return the number of bytes allocated for old objects.

     (This includes the free lists)"

%{  /* NOCONTEXT */

    RETURN ( _MKSMALLINT(__oldSpaceUsed()) );

%}

    "ObjectMemory oldSpaceUsed"

!

freeSpace

    "return the number of bytes in the free lists.

     (which is included in oldSpaceUsed)"

%{  /* NOCONTEXT */

    RETURN ( _MKSMALLINT(__freeSpace()) );

%}

    "ObjectMemory freeSpace"

!

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() - __freeSpace()) );

%}

    "ObjectMemory bytesUsed"

!

oldSpaceAllocatedSinceLastGC

    "return the number of bytes allocated for old objects since the

     last garbage collect occured"

%{  /* NOCONTEXT */

    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 - will vanish.

     use 'whoReferences:anObject' below (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) printNewline.

    ObjectMemory scavenge.

    (ObjectMemory addressOf:p) printNewline.

    "

!

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 printNewline.

     big printNewline

    "

!

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."