"

 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

			   CustomInterruptHandler

                           AllocationFailureSignal

                           IncrementalGCLimit

                           Dependents

			   ImageName'

       poolDictionaries:''

       category:'System-Support'

!

ObjectMemory comment:'

COPYRIGHT (c) 1992 by Claus Gittinger

             All Rights Reserved

'!

!ObjectMemory class methodsFor:'documentation'!

copyright

"

 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.

"

!

version

"

$Header: /cvs/stx/stx/libbasic/Attic/ObjMem.st,v 1.12 1994-06-02 16:21:03 claus Exp $

"

!

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.

    Do not depend on them being there - some may vanish ...

    (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              gets SIGIO unix signals

        CustomInterruptHandler          gets custom interrupts

        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.

     There is one caveat: if a compressing oldSpace collect

     occurs while looping over the objects, the loop cannot be

     continued (for some internal reasons). In this case, false

     is returned."

    |work|

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

    nonTenuringScavenge(__context);

    /*

     * allObjectsDo needs a temporary to hold newSpace objects

     */

    if (__allObjectsDo(&aBlock, &work COMMA_CON) < 0) {

	RETURN (false);

    }

%}.

    ^ true

!

allOldObjectsDo:aBlock

    "evaluate the argument, aBlock for all old objects in the system.

     For debugging and tests only - do not use"

%{

    if (__allObjectsDo(&aBlock, (OBJ *)0 COMMA_CON) < 0) {

        RETURN (false);

    }

%}. 

    ^ true

! !

!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

!

customInterruptHandler

    "return the handler for custom interrupts"

    ^ CustomInterruptHandler

!

customInterruptHandler:aHandler

    "set the handler for custom interrupts"

    CustomInterruptHandler := 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)) {