--- a/ExtAddr.st Thu Apr 25 13:16:22 1996 +0200
+++ b/ExtAddr.st Thu Apr 25 18:02:18 1996 +0200
@@ -52,6 +52,9 @@
allow you to access bytes via indexed at:/at:put: messages.
ExternallAddresses do not allow such accesses (they are meant to remain
anonymous).
+
+ [author:]
+ Claus Gittinger
"
!
@@ -159,5 +162,5 @@
!ExternalAddress class methodsFor:'documentation'!
version
- ^ '$Header: /cvs/stx/stx/libbasic/Attic/ExtAddr.st,v 1.3 1996-04-23 14:40:00 cg Exp $'
+ ^ '$Header: /cvs/stx/stx/libbasic/Attic/ExtAddr.st,v 1.4 1996-04-25 16:01:18 cg Exp $'
! !
--- a/ExtBytes.st Thu Apr 25 13:16:22 1996 +0200
+++ b/ExtBytes.st Thu Apr 25 18:02:18 1996 +0200
@@ -226,33 +226,33 @@
AllocatedInstances class variable to nil (thus releasing those refs).
Example (automatic freeing as soon as ref to buffer is gone):
- |buffer|
+ |buffer|
- buffer := ExternalBytes unprotectedNew:100.
- ...
+ buffer := ExternalBytes unprotectedNew:100.
+ ...
Example (manual freeing - never freed, if ref to buffer is gone):
- |buffer|
+ |buffer|
- buffer := ExternalBytes new:100.
- ...
- buffer free
+ buffer := ExternalBytes new:100.
+ ...
+ buffer free
Example (delayed automatic freeing as soon as ref to buffer is gone):
- |buffer|
+ |buffer|
- buffer := ExternalBytes new:100.
- ...
- buffer unregister
+ buffer := ExternalBytes new:100.
+ ...
+ buffer unregister
This class only supports unstructured external data
- see the companion class ExternalStructure for more.
Notice: support for external data is still being developed -
- a parser for C structure syntax and typedefs is on the way,
- making shared data with C programs much easier in the future.
+ a parser for C structure syntax and typedefs is on the way,
+ making shared data with C programs much easier in the future.
Also notice, that this class may not be available or behave different
in other smalltalk systems, making code using it very unportable.
@@ -268,21 +268,24 @@
for byteArrays; it is meant for shared data with external C-functions ONLY.
Debugging:
- since all manual memory systems are subject of obscure errors,
- you may want to turn malloc-tracing on; this traces all allocations/frees
- done here. To do this, evaluate: 'ExternalBytes mallocTrace:true'.
+ since all manual memory systems are subject of obscure errors,
+ you may want to turn malloc-tracing on; this traces all allocations/frees
+ done here. To do this, evaluate: 'ExternalBytes mallocTrace:true'.
- In addition, you may turn on full debugging (with 'ExternalBytes mallocDebug:true');
- if turned on, all malloc/realloc requests are remembered and later free / realloc
- requests validated against this list (i.e. to detect freeing unallocated chunks).
+ In addition, you may turn on full debugging (with 'ExternalBytes mallocDebug:true');
+ if turned on, all malloc/realloc requests are remembered and later free / realloc
+ requests validated against this list (i.e. to detect freeing unallocated chunks).
- To benefit from this in C-code, we recommend you use __stx_malloc() / __stx_free()
- instead of malloc() / free(). To do so, redefine them in a header file (or cc comand line)
- and recompile your external c-libraries with this.
+ To benefit from this in C-code, we recommend you use __stx_malloc() / __stx_free()
+ instead of malloc() / free(). To do so, redefine them in a header file (or cc comand line)
+ and recompile your external c-libraries with this.
- I used this here to find memory leaks in the Xt libraries (there are still some in
- the HTML widget ...). If mallocDebug is on, #dumpMallocChunks will print out what is
- leftOver. This may help to find trouble spots in your C-code.
+ I used this here to find memory leaks in the Xt libraries (there are still some in
+ the HTML widget ...). If mallocDebug is on, #dumpMallocChunks will print out what is
+ leftOver. This may help to find trouble spots in your C-code.
+
+ [author:]
+ Claus Gittinger
"
!
@@ -1062,6 +1065,6 @@
!ExternalBytes class methodsFor:'documentation'!
version
- ^ '$Header: /cvs/stx/stx/libbasic/Attic/ExtBytes.st,v 1.6 1996-04-23 14:40:11 cg Exp $'
+ ^ '$Header: /cvs/stx/stx/libbasic/Attic/ExtBytes.st,v 1.7 1996-04-25 16:01:23 cg Exp $'
! !
ExternalBytes initialize!
--- a/ExtFunc.st Thu Apr 25 13:16:22 1996 +0200
+++ b/ExtFunc.st Thu Apr 25 18:02:18 1996 +0200
@@ -94,6 +94,9 @@
- however, this is still in construction and NOT yet published for
general use. For now, either use inline C-code, or use the customFunction call
mechanism.
+
+ [author:]
+ Claus Gittinger
"
! !
@@ -412,6 +415,6 @@
!ExternalFunction class methodsFor:'documentation'!
version
- ^ '$Header: /cvs/stx/stx/libbasic/Attic/ExtFunc.st,v 1.7 1996-04-23 14:39:52 cg Exp $'
+ ^ '$Header: /cvs/stx/stx/libbasic/Attic/ExtFunc.st,v 1.8 1996-04-25 15:59:43 cg Exp $'
! !
ExternalFunction initialize!
--- a/ExternalAddress.st Thu Apr 25 13:16:22 1996 +0200
+++ b/ExternalAddress.st Thu Apr 25 18:02:18 1996 +0200
@@ -52,6 +52,9 @@
allow you to access bytes via indexed at:/at:put: messages.
ExternallAddresses do not allow such accesses (they are meant to remain
anonymous).
+
+ [author:]
+ Claus Gittinger
"
!
@@ -159,5 +162,5 @@
!ExternalAddress class methodsFor:'documentation'!
version
- ^ '$Header: /cvs/stx/stx/libbasic/ExternalAddress.st,v 1.3 1996-04-23 14:40:00 cg Exp $'
+ ^ '$Header: /cvs/stx/stx/libbasic/ExternalAddress.st,v 1.4 1996-04-25 16:01:18 cg Exp $'
! !
--- a/ExternalBytes.st Thu Apr 25 13:16:22 1996 +0200
+++ b/ExternalBytes.st Thu Apr 25 18:02:18 1996 +0200
@@ -226,33 +226,33 @@
AllocatedInstances class variable to nil (thus releasing those refs).
Example (automatic freeing as soon as ref to buffer is gone):
- |buffer|
+ |buffer|
- buffer := ExternalBytes unprotectedNew:100.
- ...
+ buffer := ExternalBytes unprotectedNew:100.
+ ...
Example (manual freeing - never freed, if ref to buffer is gone):
- |buffer|
+ |buffer|
- buffer := ExternalBytes new:100.
- ...
- buffer free
+ buffer := ExternalBytes new:100.
+ ...
+ buffer free
Example (delayed automatic freeing as soon as ref to buffer is gone):
- |buffer|
+ |buffer|
- buffer := ExternalBytes new:100.
- ...
- buffer unregister
+ buffer := ExternalBytes new:100.
+ ...
+ buffer unregister
This class only supports unstructured external data
- see the companion class ExternalStructure for more.
Notice: support for external data is still being developed -
- a parser for C structure syntax and typedefs is on the way,
- making shared data with C programs much easier in the future.
+ a parser for C structure syntax and typedefs is on the way,
+ making shared data with C programs much easier in the future.
Also notice, that this class may not be available or behave different
in other smalltalk systems, making code using it very unportable.
@@ -268,21 +268,24 @@
for byteArrays; it is meant for shared data with external C-functions ONLY.
Debugging:
- since all manual memory systems are subject of obscure errors,
- you may want to turn malloc-tracing on; this traces all allocations/frees
- done here. To do this, evaluate: 'ExternalBytes mallocTrace:true'.
+ since all manual memory systems are subject of obscure errors,
+ you may want to turn malloc-tracing on; this traces all allocations/frees
+ done here. To do this, evaluate: 'ExternalBytes mallocTrace:true'.
- In addition, you may turn on full debugging (with 'ExternalBytes mallocDebug:true');
- if turned on, all malloc/realloc requests are remembered and later free / realloc
- requests validated against this list (i.e. to detect freeing unallocated chunks).
+ In addition, you may turn on full debugging (with 'ExternalBytes mallocDebug:true');
+ if turned on, all malloc/realloc requests are remembered and later free / realloc
+ requests validated against this list (i.e. to detect freeing unallocated chunks).
- To benefit from this in C-code, we recommend you use __stx_malloc() / __stx_free()
- instead of malloc() / free(). To do so, redefine them in a header file (or cc comand line)
- and recompile your external c-libraries with this.
+ To benefit from this in C-code, we recommend you use __stx_malloc() / __stx_free()
+ instead of malloc() / free(). To do so, redefine them in a header file (or cc comand line)
+ and recompile your external c-libraries with this.
- I used this here to find memory leaks in the Xt libraries (there are still some in
- the HTML widget ...). If mallocDebug is on, #dumpMallocChunks will print out what is
- leftOver. This may help to find trouble spots in your C-code.
+ I used this here to find memory leaks in the Xt libraries (there are still some in
+ the HTML widget ...). If mallocDebug is on, #dumpMallocChunks will print out what is
+ leftOver. This may help to find trouble spots in your C-code.
+
+ [author:]
+ Claus Gittinger
"
!
@@ -1062,6 +1065,6 @@
!ExternalBytes class methodsFor:'documentation'!
version
- ^ '$Header: /cvs/stx/stx/libbasic/ExternalBytes.st,v 1.6 1996-04-23 14:40:11 cg Exp $'
+ ^ '$Header: /cvs/stx/stx/libbasic/ExternalBytes.st,v 1.7 1996-04-25 16:01:23 cg Exp $'
! !
ExternalBytes initialize!
--- a/ExternalFunction.st Thu Apr 25 13:16:22 1996 +0200
+++ b/ExternalFunction.st Thu Apr 25 18:02:18 1996 +0200
@@ -94,6 +94,9 @@
- however, this is still in construction and NOT yet published for
general use. For now, either use inline C-code, or use the customFunction call
mechanism.
+
+ [author:]
+ Claus Gittinger
"
! !
@@ -412,6 +415,6 @@
!ExternalFunction class methodsFor:'documentation'!
version
- ^ '$Header: /cvs/stx/stx/libbasic/ExternalFunction.st,v 1.7 1996-04-23 14:39:52 cg Exp $'
+ ^ '$Header: /cvs/stx/stx/libbasic/ExternalFunction.st,v 1.8 1996-04-25 15:59:43 cg Exp $'
! !
ExternalFunction initialize!
--- a/Filename.st Thu Apr 25 13:16:22 1996 +0200
+++ b/Filename.st Thu Apr 25 18:02:18 1996 +0200
@@ -44,19 +44,28 @@
for being correct or existing.
Thus, it is possible to do queries such as:
- '/fee/foo/foe' asFilename exists
- '/not_existing' asFilename isDirectory
- '/foo/bar' asFilename isReadable
+ '/fee/foo/foe' asFilename exists
+ '/not_existing' asFilename isDirectory
+ '/foo/bar' asFilename isReadable
(all of the above examples will probably return false on your machine ;-).
examples:
- 'Makefile' asFilename readStream
+ 'Makefile' asFilename readStream
+
+ 'newFile' asFilename writeStream
+
+ Filename newTemporary writeStream
- 'newFile' asFilename writeStream
+ [author:]
+ Claus Gittinger
- Filename newTemporary writeStream
+ [see also:]
+ String
+ FileStream DirectoryStream PipeStream Socket
+ OperatingSystem
+ Date Time
"
!
@@ -1891,5 +1900,5 @@
!Filename class methodsFor:'documentation'!
version
- ^ '$Header: /cvs/stx/stx/libbasic/Filename.st,v 1.55 1996-04-19 12:42:52 cg Exp $'
+ ^ '$Header: /cvs/stx/stx/libbasic/Filename.st,v 1.56 1996-04-25 16:01:07 cg Exp $'
! !
--- a/HRegistry.st Thu Apr 25 13:16:22 1996 +0200
+++ b/HRegistry.st Thu Apr 25 18:02:18 1996 +0200
@@ -11,10 +11,10 @@
"
Registry subclass:#HandleRegistry
- instanceVariableNames:''
- classVariableNames:''
- poolDictionaries:''
- category:'System-Support'
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'System-Support'
!
!HandleRegistry class methodsFor:'documentation'!
@@ -40,6 +40,9 @@
handle as argument, instead of creating a shallow copy and letting it do the finalization.
Use Registry for objects which know themself how to clean up;
use HandleRegistry, if someone else does the cleanup.
+
+ [author:]
+ Claus Gittinger
"
! !
@@ -66,5 +69,5 @@
!HandleRegistry class methodsFor:'documentation'!
version
- ^ '$Header: /cvs/stx/stx/libbasic/Attic/HRegistry.st,v 1.6 1995-11-23 17:10:40 cg Exp $'
+ ^ '$Header: /cvs/stx/stx/libbasic/Attic/HRegistry.st,v 1.7 1996-04-25 15:59:33 cg Exp $'
! !
--- a/HandleRegistry.st Thu Apr 25 13:16:22 1996 +0200
+++ b/HandleRegistry.st Thu Apr 25 18:02:18 1996 +0200
@@ -11,10 +11,10 @@
"
Registry subclass:#HandleRegistry
- instanceVariableNames:''
- classVariableNames:''
- poolDictionaries:''
- category:'System-Support'
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'System-Support'
!
!HandleRegistry class methodsFor:'documentation'!
@@ -40,6 +40,9 @@
handle as argument, instead of creating a shallow copy and letting it do the finalization.
Use Registry for objects which know themself how to clean up;
use HandleRegistry, if someone else does the cleanup.
+
+ [author:]
+ Claus Gittinger
"
! !
@@ -66,5 +69,5 @@
!HandleRegistry class methodsFor:'documentation'!
version
- ^ '$Header: /cvs/stx/stx/libbasic/HandleRegistry.st,v 1.6 1995-11-23 17:10:40 cg Exp $'
+ ^ '$Header: /cvs/stx/stx/libbasic/HandleRegistry.st,v 1.7 1996-04-25 15:59:33 cg Exp $'
! !
--- a/OSProcStat.st Thu Apr 25 13:16:22 1996 +0200
+++ b/OSProcStat.st Thu Apr 25 18:02:18 1996 +0200
@@ -1,5 +1,3 @@
-'From Smalltalk/X, Version:2.10.8 on 29-dec-1995 at 00:14:10' !
-
Object subclass:#OSProcessStatus
instanceVariableNames:'pid status code core'
classVariableNames:''
@@ -14,12 +12,15 @@
This is an auxillary class, that holds information about status changes of
operating system processes (these are no smalltalk processes!!).
- Instance variables are:
+ [Instance variables:]
pid OS-Process identifier
status either #exit #signal #stop #continue
code either exitcode or signalnumber
core true if core has been dumped
+
+ [author:]
+ Stefan Vogel
"
!
@@ -149,6 +150,6 @@
version
"
-$Header: /cvs/stx/stx/libbasic/Attic/OSProcStat.st,v 1.1 1996-01-03 23:29:23 stefan Exp $
+$Header: /cvs/stx/stx/libbasic/Attic/OSProcStat.st,v 1.2 1996-04-25 16:00:48 cg Exp $
"
! !
--- a/ObjMem.st Thu Apr 25 13:16:22 1996 +0200
+++ b/ObjMem.st Thu Apr 25 18:02:18 1996 +0200
@@ -103,7 +103,7 @@
-> interrupts
-> garbageCollection
- Class variables:
+ [Class variables:]
InternalErrorHandler gets informed (by VM), when some runtime
error occurs (usually fatal)
@@ -175,6 +175,12 @@
The InterruptHandler variables are known by the runtime system -
they are the objects that get an interrupt message when the event
occurs. You may not remove any of them.
+
+ [author:]
+ Claus Gittinger
+
+ [see also:]
+ ( garbage collection : html:programming/GC.html )
"
!
@@ -1141,257 +1147,86 @@
%}
!
-printReferences:anObject
- "for debugging: print referents to anObject.
- WARNING: this method is for ST/X debugging only
- it will be removed without notice
- use ObjectMemory>>whoReferences: or anObject>>allOwners."
+nteger(low, high)) {
+ RETURN ((OBJ)((__intVal(high) << 16) | __intVal(low)));
+ }
+%}
+!
+
+oReferences: or anObject>>allOwners."
%{
__printRefChain(__context, anObject);
%}
!
-refChainFrom:start to:anObject inRefSets:levels startingAt:index
- |chain names oClass|
-
- index > levels size ifTrue:[
- ^ OrderedCollection with:start
- ].
-
-"/'set: ' print. (levels at:index) displayString printNL.
-"/'start: ' print. start printNL.
- (levels at:index) do:[:el |
-"/'trying: ' print. el printNL.
- (start references:el) ifTrue:[
-"/'yes' printNL.
- chain := self
- refChainFrom:el
- to:anObject
- inRefSets:levels
- startingAt:(index+1).
-
- chain notNil ifTrue:[
- start == Smalltalk ifTrue:[
- start keysAndValuesDo:[:key :val |
- (val == el) ifTrue:[
- chain addFirst:'Smalltalk:' , key.
- ^ chain
- ]
- ]
- ] ifFalse:[
- names := start class allInstVarNames.
- oClass := start class.
- 1 to:oClass instSize do:[:i |
- ((start instVarAt:i) == el) ifTrue:[
- chain addFirst:(start -> ('[' , (names at:i) , ']')).
- ^ chain
- ].
- ].
- oClass isVariable ifTrue:[
- oClass isPointers ifTrue:[
- 1 to:start basicSize do:[:i |
- ((start basicAt:i) == el) ifTrue:[
- chain addFirst:(start -> ('[' , i printString , ']')).
- ^ chain
- ]
- ]
- ]
- ].
- ].
-
- chain addFirst:start.
-
- ^ chain
- ]
- ].
- ].
- ^ nil
-
-
- "
- |o a1 a2|
-
- o := Object new.
- a1 := Array with:o with:nil with:nil.
- a2 := Array with:a1 with:nil with:nil.
- a2 references:a1
- "
-
- "
- |o a1 a2 a3 a4 levels|
-
- o := Object new.
- a1 := Array with:o.
- a2 := Array with:a1.
- a3 := Array with:a2.
- a4 := Array with:a3.
- levels := Array with:(Array with:a3)
- with:(Array with:a2)
- with:(Array with:a1).
-
- self refChainFrom:a4 to:o inRefSets:levels startingAt:1.
+to:o inRefSets:levels startingAt:1.
"
"Modified: 19.3.1996 / 23:22:41 / cg"
!
-sizeOf:anObject
- "return the size of anObject in bytes.
- (this is not the same as 'anObject size').
- WARNING: this method is for ST/X debugging only
- it will be removed without notice"
-
-%{ /* 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 at:nw put:(hist at:nw) + 1
].
].
hist printNL.
big printNL
"
-!
-
-spaceOf:anObject
- "return the memory space, in which anObject is.
- - since objects may move between spaces,
- the returned value may be invalid after the next scavenge/collect.
- WARNING: this method is for ST/X debugging only
- it will be removed without notice"
-
-%{ /* NOCONTEXT */
-
- if (! __isNonNilObject(anObject)) {
- RETURN ( nil );
- }
- RETURN ( __MKSMALLINT( __qSpace(anObject) ) );
-%}
! !
!ObjectMemory class methodsFor:'dependents access'!
-dependents
- "return the colleciton of my dependents"
-
- ^ Dependents
+INT( __qSpace(anObject) ) );
+%}
!
-dependents:aCollection
+ts access'!
+
+endents:aCollection
"set the dependents collection"
Dependents := aCollection
-!
-
-dependentsDo:aBlock
- "evaluate aBlock for all of my dependents.
- Since this is performed at startup time (under the scheduler),
- this is redefined here to catch abort signals.
- Thus, if any error occurs in a #returnFromSnapshot,
- the user can press abort to continue."
+! !
- |deps|
+!ObjectMemory class methodsFor:'enumerating'!
- deps := Dependents.
- deps notNil ifTrue:[
- deps do:[:each |
- AbortSignal handle:[:ex |
- ex return
- ] do:[
+[
aBlock value:each
]
]
]
-! !
-
-!ObjectMemory class methodsFor:'enumerating'!
+!
-allInstancesOf:aClass do:aBlock
- "evaluate the argument, aBlock for all instances of aClass 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);
- /*
- * allInstancesDo needs a temporary to hold newSpace objects
- */
- if (__allInstancesOfDo(&aClass, &aBlock, &work COMMA_CON) < 0) {
+esOfDo(&aClass, &aBlock, &work COMMA_CON) < 0) {
RETURN (false);
}
%}.
^ true
!
-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 (__allInstancesOfDo((OBJ *)0, &aBlock, &work COMMA_CON) < 0) {
+sOfDo((OBJ *)0, &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 (__allInstancesOfDo((OBJ *)0, &aBlock, (OBJ *)0 COMMA_CON) < 0) {
- RETURN (false);
- }
-%}.
- ^ true
! !
!ObjectMemory class methodsFor:'garbage collection'!
-backgroundCollectorRunning
- "return true, if a backgroundCollector is running"
+(false);
+ }
+%}.
+ ^ true
+!
- ^ BackgroundCollectProcess notNil
+kgroundCollectProcess notNil
"
ObjectMemory backgroundCollectorRunning
"
!
-compressingGarbageCollect
- "search for and free garbage in the oldSpace (newSpace is cleaned automatically)
- performing a COMPRESSING garbage collect.
- This can take a long time - especially, if paging is involved
- (when no paging is involved, its faster than I thought :-).
- If no memory is available for the compress, or the system has been started with
- the -Msingle option, this does a non-COMPRESSING collect."
-%{
- if (! __garbageCollect(__context)) {
- __markAndSweep(__context);
+AndSweep(__context);
}
%}
@@ -1400,13 +1235,7 @@
"
!
-garbageCollect
- "search for and free garbage in the oldSpace.
- This can take a long time - especially, if paging is involved."
-
- "/ used to be
- "/ self compressingGarbageCollect
- "/ here; changed to default to markAndSweep
+t to markAndSweep
self markAndSweep
@@ -1415,46 +1244,13 @@
"
!
-gcStep
- "one incremental garbage collect step.
- Mark or sweep some small number of objects. This
- method will return after a reasonable (short) time.
- This is used by the ProcessorScheduler at idle times.
- Returns true, if an incremental GC cycle has finished."
-%{
- extern int __incrGCstep();
+extern int __incrGCstep();
RETURN (__incrGCstep(__context) ? true : false);
%}
!
-gcStepIfUseful
- "If either the IncrementalGCLimit or the FreeSpaceGCLimits have been
- reached, perform one incremental garbage collect step.
- Return true, if more gcSteps are required to finish the cycle,
- false if done with a gc round.
- If no limit has been reached yet, do nothing and return false.
- This is called by the ProcessorScheduler at idle times or by the
- backgroundCollector."
-
- |done limit|
-
- AbortSignal handle:[:ex |
- "/ in case of abort (from the debugger),
- "/ disable gcSteps.
- done := true.
- IncrementalGCLimit := FreeSpaceGCLimit := nil.
- 'OBJMEM: IGC aborted; turning off incremental GC' errorPrintNL
- ] do:[
- limit := IncrementalGCLimit.
- (limit notNil and:[self oldSpaceAllocatedSinceLastGC > limit]) ifTrue:[
- done := ObjectMemory gcStep
- ] ifFalse:[
- limit := FreeSpaceGCLimit.
- (limit notNil and:[(self freeSpace + self freeListSpace) < limit]) ifTrue:[
- done := ObjectMemory gcStep.
- done ifTrue:[
- self moreOldSpaceIfUseful
+OldSpaceIfUseful
].
] ifFalse:[
done := true
@@ -1464,48 +1260,12 @@
^ done not
!
-incrementalGC
- "perform one round of incremental GC steps.
- The overall effect of this method is (almost) the same as calling
- markAndSweep. However, #incrementalGC is interruptable while #markAndSweep
- is atomic and blocks for a while. The code here performs incremental
- GC steps, until one complete gc-cycle is completed. If running at a higher
- than userBackground priority, it will give up the CPU after every such
- step for a while.
- Thus this method can be called either from a low prio (background) process
- or from a high prio process.
- (however, if you have nothing else to do, its better to call for markAndSweep,
- since it is faster)
- For example, someone allocating huge amounts of memory could
- ask for the possibility of a quick allocation using
- #checkForFastNew: and try a #incrementalGC if not. In many
- cases, this can avoid a pause (in the higher prio processes) due to
- a blocking GC."
-
- |p delay|
-
- Processor activeProcess priority > Processor userBackgroundPriority ifTrue:[
- delay := Delay forMilliseconds:1
- ].
-
- [self gcStep] whileFalse:[
- delay notNil ifTrue:[delay wait]
- ].
- self moreOldSpaceIfUseful
-
- "
- ObjectMemory incrementalGC
- [ObjectMemory incrementalGC] forkAt:3
+ObjectMemory incrementalGC] forkAt:3
[ObjectMemory incrementalGC] forkAt:9
"
!
-markAndSweep
- "mark/sweep garbage collector.
- perform a full mark&sweep collect.
- Warning: this may take some time and it is NOT interruptable.
- If you want to do a collect from a background process, or have
- other things to do, better use #incrementalGC which is interruptable."
+ble."
%{
__markAndSweep(__context);
%}
@@ -1515,12 +1275,7 @@
"
!
-reclaimSymbols
- "reclaim unused symbols;
- Unused symbols are (currently) not reclaimed automatically,
- but only upon request with this method.
- It takes some time to do this ... and it is NOT interruptable.
- Future versions may do this automatically, while garbage collecting."
+."
%{
__reclaimSymbols(__context);
%}
@@ -1529,18 +1284,7 @@
"
!
-scavenge
- "collect young objects, without aging (i.e. no tenure).
- Can be used to quickly get rid of shortly before allocated
- stuff. This is relatively fast (compared to oldspace collect).
-
- An example where a non-tenuring scavenge makes sense is when
- allocating some OperatingSystem resource (a Color, File or View)
- and the OS runs out of resources. In this case, the scavenge may
- free some ST-objects and therefore (by signalling the WeakArrays
- or Registries) free the OS resources too.
- Of course, only recently allocated resources will be freed this
- way. If none was freed, a full collect will be needed."
+."
%{
__nonTenuringScavenge(__context);
%}
@@ -1550,69 +1294,12 @@
"
!
-startBackgroundCollectorAt:aPriority
- "start a process doing incremental GC in the background.
- Use this, if you have suspendable background processes which
- run all the time, and therefore would prevent the idle-collector
- from running. See documentation in this class for more details."
-
- |p|
-
- "/
- "/ its not useful, to run it more than once
- "/
- BackgroundCollectProcess notNil ifTrue:[
- BackgroundCollectProcess priority:aPriority.
- ^ self
- ].
-
- p :=
- [
- [
- [true] whileTrue:[
- self gcStepIfUseful ifTrue:[
- "
- perform a full cycle
- "
- self incrementalGC
- ].
- "
- wait a bit
- "
- (Delay forSeconds:5) wait
- ]
- ] valueOnUnwindDo:[
- BackgroundCollectProcess := nil
- ]
- ] newProcess.
- p name:'background collector'.
- p priority:aPriority.
- p restartable:true.
- p resume.
- BackgroundCollectProcess := p
-
- "
- the following lets the backgroundCollector run at prio 5
- whenever 100000 bytes have been allocated, OR freeSpace drops
- below 1meg. Having the system keep 1meg as reserve for peak allocation.
-
- Doing this may reduce pauses due to inevitable collects when running
- out of freeSpace, if the collector can keep up with allocation rate.
- "
-
- "
- ObjectMemory incrementalGCLimit:100000.
- ObjectMemory freeSpaceGCLimit:1000000.
+tMemory freeSpaceGCLimit:1000000.
ObjectMemory startBackgroundCollectorAt:5
"
!
-stopBackgroundCollector
- "stop the background collector"
-
- BackgroundCollectProcess notNil ifTrue:[
- BackgroundCollectProcess terminate.
- BackgroundCollectProcess := nil
+oundCollectProcess := nil
]
"
@@ -1620,40 +1307,12 @@
"
!
-tenure
- "force all living new stuff into old-space - effectively making
- all living young objects become old objects immediately.
- This is relatively fast (compared to oldspace collect).
-
- This method should only be used in very special situations:
- for example, when building up some long-living data structure
- in a time critical application.
- To do so, you have to do a scavenge followed by a tenure after the
- objects are created. Be careful, to not reference any other chunk-
- data when calling for a tenure (this will lead to lots of garbage in
- the oldspace).
- In normal situations, explicit tenures are not needed."
-%{
- __tenure(__context);
-%}
-
- "
- ObjectMemory tenure
- "
- "
- ... build up long living objects ...
- ObjectMemory scavenge.
- ObjectMemory tenure
+tMemory tenure
... continue - objects created above are now in oldSpace ...
"
!
-tenuringScavenge
- "collect newspace stuff, with aging (i.e. objects old enough
- will be moved into the oldSpace).
- Use this for debugging and testing only - the system performs
- this automatically when the newspace fills up.
- This is relatively fast (compared to oldspace collect)"
+ect)"
%{
__scavenge(__context);
%}
@@ -1661,54 +1320,15 @@
"
ObjectMemory tenuringScavenge
"
-!
-
-verboseGarbageCollect
- "perform a compressing garbage collect and show some informational
- output on the Transcript"
-
- |nBytesBefore nReclaimed value unit|
-
- nBytesBefore := self oldSpaceUsed.
- self compressingGarbageCollect.
- nReclaimed := nBytesBefore - self oldSpaceUsed.
- nReclaimed > 0 ifTrue:[
- nReclaimed > 1024 ifTrue:[
- nReclaimed > (1024 * 1024) ifTrue:[
- value := nReclaimed // (1024 * 1024).
- unit := ' Mb.'
- ] ifFalse:[
- value := nReclaimed // 1024.
- unit := ' Kb.'
- ]
- ] ifFalse:[
- value := nReclaimed.
- unit := ' bytes.'
- ].
- Transcript show:'reclaimed '; show:value printString.
- Transcript showCr:unit
- ]
-
- "
- ObjectMemory verboseGarbageCollect
- "
! !
!ObjectMemory class methodsFor:'garbage collector control'!
-announceOldSpaceNeed:howMuch
- "announce to the memory system, that howMuch bytes of memory will be needed
- soon, which is going to live longer (whatever that means).
- It first checks if the memory can be allocated without forcing a compressing
- GC. If not, the oldSpace is increased. This may also lead to a slow compressing
- collect. However, many smaller increases are avoided afterwards. Calling this
- method before allocating huge chunks of data may provide better overall performance.
- Notice: this is a nonstandard interface - use only in special situations."
+oseGarbageCollect
+ "
+!
- (self checkForFastNew:howMuch) ifFalse:[
- self incrementalGC.
- (self checkForFastNew:howMuch) ifFalse:[
- self moreOldSpace:howMuch
+eOldSpace:howMuch
]
]
@@ -1717,25 +1337,7 @@
"
!
-announceSpaceNeed:howMuch
- "announce to the memory system, that howMuch bytes of memory will be needed
- soon. The VM tries to prepare itself for this allocation to be performed
- with less overhead. For example, it could preallocate some memory in one
- big chunk (instead of doing many smaller reallocations later).
- Notice: this is a nonstandard interface - use only in special situations.
- Also, this does a background collect before the big chunk of memory is
- allocated, not locking other processes while doing so."
-
- (howMuch < (self newSpaceSize // 2)) ifTrue:[
- self scavenge.
- ].
- (self checkForFastNew:howMuch) ifFalse:[
- (howMuch > (self newSpaceSize // 2)) ifFalse:[
- self scavenge.
- ].
- self incrementalGC.
- (self checkForFastNew:howMuch) ifFalse:[
- self moreOldSpace:howMuch
+moreOldSpace:howMuch
]
]
@@ -1744,128 +1346,28 @@
"
!
-avoidTenure:flag
- "set/clear the avoidTenure flag. If set, aging of newSpace is turned off
- as long as the newSpace fill-grade stays below some magic high-water mark.
- If off (the default), aging is done as usual.
- If the flag is turned on, scavenge may be a bit slower, due to more
- objects being copied around. However, chances are high that in an idle
- or (almost idle) system, less objects are moved into oldSpace.
- Therefore, this helps to avoid oldSpace colelcts, in systems which go into
- some standby mode and are reactivated by some external event.
- (the avoid-flag should be turned off there, and set again once the idle loop
- is reentered).
-
- This is an EXPERIMENTAL interface."
+ERIMENTAL interface."
%{ /* NOCONTEXT */
__avoidTenure(flag == true ? 1 : 0);
%}
!
-checkForFastNew:amount
- "this method returns true, if amount bytes could be allocated
- quickly (i.e. without forcing a full GC or compress).
- This can be used for smart background processes, which want to
- allocate big chunks of data without disturbing foreground processes
- too much. Such a process would check for fast-allocation, and perform
- incremental GC-steps if required. Thus, avoiding the long blocking pause
- due to a forced (non-incremental) GC.
- Especially: doing so will not block higher priority foreground processes.
- See an example use in Behavior>>niceBasicNew:.
- This is experimental and not guaranteed to be in future versions."
-
-%{ /* NOCONTEXT */
- extern int __checkForFastNew();
-
- if (__isSmallInteger(amount)) {
- if (! __checkForFastNew(__intVal(amount))) {
- RETURN (false);
- }
- }
-
-%}.
- ^ true
!
-fastMoreOldSpaceAllocation:aBoolean
- "this method turns on/off fastMoreOldSpace allocation.
- By default, this is turned off (false), which means that in case of
- a filled-up oldSpace, a GC is tried first before more oldSpace is allocated.
- This strategy is ok for the normal operation of the system,
- but behaves badly, if the program allocates huge data structures (say a
- game tree of 30Mb in size) which survives and therefore will not be reclaimed
- by a GC.
- Of course while building this tree, and the memory becomes full, the system
- would not know in advance, that the GC will not reclaim anything.
-
- Setting fastOldSpaceIncrement to true will avoid this, by forcing the
- memory system to allocate more memory right away, without doing a GC first.
-
- WARNING: make certain that this flag is turned off, after your huge data
- is allocated, since otherwise the system may continue to increase its
- virtual memory without ever checking for garbage.
- This method returns the previous value of the flag; typically this return
- value should be used to switch back."
-
-%{ /* NOCONTEXT */
- extern int __fastMoreOldSpaceAllocation();
-
- RETURN (__fastMoreOldSpaceAllocation(aBoolean == true ? 1 : 0) ? true : false);
-%}
- "
- |previousSetting|
-
- previousSetting := ObjectMemory fastMoreOldSpaceAllocation:true.
- [
- ...
- allocate your huge data
- ...
- ] valueNoOrOnUnwindDo:[
- ObjectMemory fastMoreOldSpaceAllocation:previousSetting
- ]
- "
-
- "
- |prev this|
-
- prev := ObjectMemory fastMoreOldSpaceAllocation:true.
+eAllocation:true.
ObjectMemory fastMoreOldSpaceAllocation:prev.
^ prev
"
!
-fastMoreOldSpaceLimit:aNumber
- "this method sets and returns the fastMoreOldSpace limit.
- If fastMoreOldSpaceAllocation is true, and the current oldSpace size is
- below this limit, the memory manager will NOT do a GC when running out of
- oldSpace, but instead quickly go ahead increasing the size of the oldSpace.
- Setting the limit to 0 turns off any limit (i.e. it will continue to
- increase the oldSpace forwever - actually, until the OS refuses to give us
- more memory). The returned value is the previous setting of the limit."
-
-%{ /* NOCONTEXT */
- extern int __fastMoreOldSpaceLimit();
-
- if (__isSmallInteger(aNumber)) {
- RETURN ( __MKSMALLINT( __fastMoreOldSpaceLimit(__intVal(aNumber))));
- }
-%}.
- self primitiveFailed
-
- "
- |prev this|
-
- prev := ObjectMemory fastMoreOldSpaceLimit:10*1024*1024.
+aceLimit:10*1024*1024.
ObjectMemory fastMoreOldSpaceLimit:prev.
^ prev
"
!
-freeSpaceGCAmount
- "return the amount to be allocated if, after an incrementalGC,
- not at least FreeSpaceGCLimit bytes are available for allocation.
- The default is nil, which lets the system compute an abbpropriate value"
+riate value"
^ FreeSpaceGCAmount
@@ -1874,37 +1376,14 @@
"
!
-freeSpaceGCAmount:aNumber
- "set the amount to be allocated if, after an incrementalGC,
- not at least FreeSpaceGCLimit bytes are available for allocation.
- The amount should be greater than the limit, otherwise the incremental
- GC may try over and over to get the memory (actually waisting time)."
-
- FreeSpaceGCAmount := aNumber
-
- "
- the following will try to always keep at least 1meg of free space
- (in the background) and start to do so, whenever the freeSpace drops
- below 250k.
- "
- "
- ObjectMemory freeSpaceGCLimit:250000.
- ObjectMemory freeSpaceGCAmount:1000000.
- "
-
- "
- turn it off (i.e. let the system compute an appropriate amount ...)
+ppropriate amount ...)
"
"
ObjectMemory freeSpaceGCAmount:nil.
"
!
-freeSpaceGCLimit
- "return the freeSpace limit for incremental GC activation.
- The system will start doing incremental background GC, once less than this number
- of bytes are available in the compact free space.
- The default is 100000; setting it to nil will turn this trigger off."
+trigger off."
^ FreeSpaceGCLimit
@@ -1913,35 +1392,14 @@
"
!
-freeSpaceGCLimit:aNumber
- "set the freeSpace limit for incremental GC activation.
- The system will start doing incremental background GC, once less than this number
- of bytes are available for allocation.
- The default is nil; setting it to nil will turn this trigger off."
-
- FreeSpaceGCLimit := aNumber
-
- "
- the following will start the incrementalGC (in the background)
- whenever the freeSpace drops below 1meg of free space
- "
- "
- ObjectMemory freeSpaceGCLimit:1000000.
- "
-
- "
- turn it off (i.e. let the system hit the wall ...)
+ystem hit the wall ...)
"
"
ObjectMemory freeSpaceGCLimit:nil.
"
!
-incrementalGCLimit
- "return the allocatedSinceLastGC limit for incremental GC activation.
- The system will start doing incremental background GC, once more than this number
- of bytes have been allocated since the last GC.
- The default is 500000; setting it to nil will turn this trigger off."
+gger off."
^ IncrementalGCLimit
@@ -1950,76 +1408,26 @@
"
!
-incrementalGCLimit:aNumber
- "set the allocatedSinceLastGC limit for incremental GC activation.
- The system will start doing incremental background GC, once more than this number
- of bytes have been allocated since the last GC.
- The default is 500000; setting it to nil will turn this trigger off."
-
- IncrementalGCLimit := aNumber
-
- "
- ObjectMemory incrementalGCLimit:500000. 'do incr. GC very seldom'
- ObjectMemory incrementalGCLimit:100000. 'medium'
- ObjectMemory incrementalGCLimit:10000. 'do incr. GC very often'
+'do incr. GC very often'
ObjectMemory incrementalGCLimit:nil. 'never'
"
!
-lockTenure:flag
- "set/clear the tenureLock. If the lock is set, the system
- completely turns off tenuring, and objects remain in newSpace (forever).
- Once this lock is set, the system operates only in the newSpace and no memory
- allocations from oldSpace are allowed (except for explicit tenure calls).
- If any allocation request cannot be resoved, the VM raises a memory interrupt,
- clears the lockTenure-flag and returns nil. Thus, it automatically falls back into
- the normal mode of operation, to avoid big trouble
- (fail to allocate memory when handling the exception).
-
- This interface can be used in applications, which are guaranteed to have their
- working set completely in the newSpace AND want to limit the worst case
- pause times to the worst case scavenge time
- (which itself is limitd by the size of the newSpace).
- I.e. systems which go into some event loop after initial startup,
- may turn on the tenureLock to make certain that no oldSpace memory is
- allocated in the future; thereby limiting any GC activity to newSpace scavenges only.
-
- This is an EXPERIMENTAL interface.
- "
-
-%{
- if (flag == true) {
+flag == true) {
__tenure(__context);
}
__lockTenure(flag == true ? 1 : 0);
%}
!
-makeOld:anObject
- "move anObject into oldSpace.
- This method is for internal & debugging purposes only -
- it may vanish. Dont use it."
-%{
- if (__moveToOldSpace(anObject, __context) < 0) {
+if (__moveToOldSpace(anObject, __context) < 0) {
RETURN (false);
}
%}.
^ true
!
-moreOldSpace:howMuch
- "allocate howMuch bytes more for old objects; return true if this worked,
- false if that failed.
- This is done automatically, when running out of space, but makes
- sense, if its known in advance that a lot of memory is needed to
- avoid multiple reallocations and compresses.
- On systems which do not support the mmap (or equivalent) system call,
- this (currently) implies a compressing garbage collect - so its slow.
- Notice: this is a nonstandard interface - use only in special situations."
-
-%{
- if (__isSmallInteger(howMuch)) {
- RETURN( __moreOldSpace(__context, __intVal(howMuch)) ? true : false );
+lse );
}
RETURN (false);
%}
@@ -2028,64 +1436,14 @@
"
!
-moreOldSpaceIfUseful
- "to be called after an incremental GC cycle;
- if freeSpace is still below limit, allocate more oldSpace"
-
- |limit free amount|
-
- limit := FreeSpaceGCLimit.
- limit notNil ifTrue:[
- "/ if reclaimed space is below limit, we have to allocate more
- "/ oldSpace, to avoid excessive gcSteps (due to freeSpaceLimit
- "/ still not reached)
- "/
- free := self freeSpace + self freeListSpace.
- free < (limit * 3 // 2) ifTrue:[
- amount := FreeSpaceGCAmount.
- amount isNil ifTrue:[
- amount := limit * 3 // 2.
- ].
- 'OBJECTMEMORY: moreOldSpace to satisfy free-limit' infoPrintNL.
- (self moreOldSpace:(amount - free + (64*1024))) ifFalse:[
- "/
- "/ could not increase oldspace; reset FreeSpaceGCLimit to avoid
- "/ useless retries
- 'OBJECTMEMORY: could not increase oldSpace - reset limit' errorPrintNL.
+ease oldSpace - reset limit' errorPrintNL.
FreeSpaceGCLimit := nil
]
].
].
!
-newSpaceSize:newSize
- "change the size of the newSpace. To do this, the current contents
- of the newSpace may have to be tenured (if size is smaller).
- Returns false, if it failed for any reason.
- Experimental: this interface may valish without notice.
-
- DANGER ALERT:
- be careful too big of a size may lead to longer scavenge pauses.
- Too small of a newSpace may lead to more CPU overhead, due to
- excessive scavenges. You have been warned."
-
-%{
- extern int __setNewSpaceSize();
-
- if (__isSmallInteger(newSize)) {
- RETURN (__setNewSpaceSize(__intVal(newSize)) ? true : false);
- }
-%}.
- self primitiveFailed
-
- " less absolute CPU overhead (but longer pauses):
-
- ObjectMemory newSpaceSize:800*1024
- "
-
- " smaller pauses, but more overall CPU overhead:
-
- ObjectMemory newSpaceSize:200*1024
+Size:200*1024
"
" the default:
@@ -2094,356 +1452,207 @@
"
!
-oldSpaceCompressLimit
- "return the limit for oldSpace compression. If more memory than this
- limit is in use, the system will not perform compresses on the oldspace,
- but instead do a mark&sweep GC followed by an oldSpace increase if not enough
- could be reclaimed. The default is currently some 8Mb, which is ok for workstations
- with 16..32Mb of physical memory. If your system has much more physical RAM,
- you may want to increase this limit."
-
-%{ /* NOCONTEXT */
- extern unsigned __compressingGCLimit();
-
- RETURN (__MKSMALLINT( __compressingGCLimit(-1) ));
+T( __compressingGCLimit(-1) ));
%}
"
ObjectMemory oldSpaceCompressLimit
"
!
-oldSpaceCompressLimit:amount
- "set the limit for oldSpace compression. If more memory than this
- limit is in use, the system will not perform compresses on the oldspace,
- but instead do a mark&sweep GC followed by an oldSpace increase if not enough
- could be reclaimed. The default is currently some 8Mb, which is ok for workstations
- with 16..32Mb of physical memory. If your system has much more physical RAM,
- you may want to increase this limit.
- This method returns the previous increment value."
-
-%{ /* NOCONTEXT */
- extern unsigned __compressingGCLimit();
-
- if (__isSmallInteger(amount)) {
- RETURN (__MKSMALLINT( __compressingGCLimit(__intVal(amount)) ));
- }
-%}
- "to change the limit to 12Mb:"
+e the limit to 12Mb:"
"
ObjectMemory oldSpaceCompressLimit:12*1024*1024
"
!
-oldSpaceIncrement
- "return the oldSpaceIncrement value. Thats the amount by which
- more memory is allocated in case the oldSpace gets filled up.
- In normal situations, the default value used in the VM is fine
- and there is no need to change it."
-
-%{ /* NOCONTEXT */
- extern unsigned __oldSpaceIncrement();
-
- RETURN (__MKSMALLINT( __oldSpaceIncrement(-1) ));
+LLINT( __oldSpaceIncrement(-1) ));
%}
"
ObjectMemory oldSpaceIncrement
"
!
-oldSpaceIncrement:amount
- "set the oldSpaceIncrement value. Thats the amount by which
- more memory is allocated in case the oldSpace gets filled up.
- In normal situations, the default value used in the VM is fine
- and there is no need to change it. This method returns the
- previous increment value."
-
-%{ /* NOCONTEXT */
- extern unsigned __oldSpaceIncrement();
-
- if (__isSmallInteger(amount)) {
- RETURN (__MKSMALLINT( __oldSpaceIncrement(__intVal(amount)) ));
- }
-%}
- "to change increment to 1Meg:"
+o change increment to 1Meg:"
"
ObjectMemory oldSpaceIncrement:1024*1024
"
!
-tenureParameters:magic
- "this is pure magic and not for public eyes ...
- This method allows fine tuning the scavenger internals,
- in cooperation to some statistic & test programs.
- It is undocumented, secret and may vanish.
- If you play around here, the system may behave very strange."
+e system may behave very strange."
%{ /* NOCONTEXT */
__tenureParams(magic);
%}.
!
-turnGarbageCollectorOff
- "turn off the generational garbage collector by forcing new objects to be
- allocated directly in oldSpace (instead of newSpace)
- WARNING:
- This is somewhat dangerous: if collector is turned off,
- and too many objects are created, the system may run into trouble
- (i.e. oldSpace becomes full) and be forced to perform a full mark&sweep
- or even a compressing collect - making the overall realtime behavior worse.
- Use this only for special purposes or when realtime behavior
- is required for a limited time period.
-
- OBSOLETE: this is no longer supported
- - it may be a no-operation by the time you read this."
+n by the time you read this."
%{ /* NOCONTEXT */
__allocForceSpace(OLDSPACE);
%}
!
-turnGarbageCollectorOn
- "turn garbage collector on again (see ObjectMemory>>turnGarbageCollectorOff)"
+Memory>>turnGarbageCollectorOff)"
%{ /* NOCONTEXT */
__allocForceSpace(9999);
%}
-!
-
-watchTenure:flag
- "set/clear the tenureWatch. If set, an internalError exception will be raised,
- whenever objects are tenured from newSpace into oldSpace
- (except for an explicit tenure request).
- This can be used to validate that no oldSpace objects are created
- (i.e. the system operates fully in newSpace).
- Be careful, if the avoidTenure flag is not set,
- there will almost always be a tenure sooner or later.
-
- EXPERIMENTAL - no warranty"
-
-%{ /* NOCONTEXT */
- __watchTenure(flag == true ? 1 : 0);
-%}
! !
!ObjectMemory class methodsFor:'interrupt handler access'!
-childSignalInterruptHandler
- "return the handler for UNIX-death-of-a-childprocess-signal interrupts"
+lag == true ? 1 : 0);
+%}
+!
+
+for UNIX-death-of-a-childprocess-signal interrupts"
^ ChildSignalInterruptHandler
!
-childSignalInterruptHandler:aHandler
- "set the handler for UNIX-death-of-a-childprocess-signal interrupts"
-
- ChildSignalInterruptHandler := aHandler
-
- "Created: 22.12.1995 / 14:14:52 / stefan"
+reated: 22.12.1995 / 14:14:52 / stefan"
"Modified: 22.12.1995 / 14:15:16 / stefan"
!
-customInterruptHandler
+ptHandler
"return the handler for custom interrupts"
^ CustomInterruptHandler
!
-customInterruptHandler:aHandler
+er
"set the handler for custom interrupts"
CustomInterruptHandler := aHandler
!
-disposeInterruptHandler
- "return the handler for object disposal interrupts"
+"return the handler for object disposal interrupts"
^ DisposeInterruptHandler
!
-disposeInterruptHandler:aHandler
- "set the handler for object disposal interrupts"
+t the handler for object disposal interrupts"
DisposeInterruptHandler := aHandler
!
-errorInterruptHandler
+ler
"return the handler for display error interrupts"
^ ErrorInterruptHandler
!
-errorInterruptHandler:aHandler
- "set the handler for display error interrupts"
+"set the handler for display error interrupts"
ErrorInterruptHandler := aHandler
!
-exceptionInterruptHandler
- "return the handler for floating point exception interrupts"
+the handler for floating point exception interrupts"
^ ExceptionInterruptHandler
!
-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.
+c.
Those should not occur in normal circumstances."
^ InternalErrorHandler
!
-ioInterruptHandler
- "return the handler for I/O available signal interrupts (SIGIO/SIGPOLL)"
+handler for I/O available signal interrupts (SIGIO/SIGPOLL)"
^ IOInterruptHandler
!
-ioInterruptHandler:aHandler
- "set the handler for I/O available signal interrupts (SIGIO/SIGPOLL)"
+r I/O available signal interrupts (SIGIO/SIGPOLL)"
IOInterruptHandler := aHandler
!
-recursionInterruptHandler
- "return the handler for recursion/stack overflow interrupts"
+the handler for recursion/stack overflow interrupts"
^ RecursionInterruptHandler
!
-recursionInterruptHandler:aHandler
- "set the handler for recursion/stack overflow interrupts"
+er for recursion/stack overflow interrupts"
RecursionInterruptHandler := aHandler
!
-registerErrorInterruptHandler:aHandler forID:errorIDSymbol
- "register a handler"
-
- RegisteredErrorInterruptHandlers isNil ifTrue:[
- RegisteredErrorInterruptHandlers := IdentityDictionary new
+ctionary new
].
RegisteredErrorInterruptHandlers at:errorIDSymbol put:aHandler
!
-registeredErrorInterruptHandlers
+rruptHandlers
"return registered handlers"
^ RegisteredErrorInterruptHandlers
!
-signalInterruptHandler
+dler
"return the handler for UNIX-signal interrupts"
^ SignalInterruptHandler
!
-signalInterruptHandler:aHandler
- "set the handler for UNIX-signal interrupts"
+"set the handler for UNIX-signal interrupts"
SignalInterruptHandler := aHandler
!
-spyInterruptHandler
+ptHandler
"return the handler for spy-timer interrupts"
^ SpyInterruptHandler
!
-spyInterruptHandler:aHandler
+er
"set the handler for spy-timer interrupts"
SpyInterruptHandler := aHandler
!
-stepInterruptHandler
+andler
"return the handler for single step interrupts"
^ StepInterruptHandler
!
-stepInterruptHandler:aHandler
- "set the handler for single step interrupts"
+"set the handler for single step interrupts"
StepInterruptHandler := aHandler
!
-timerInterruptHandler
+ruptHandler
"return the handler for timer interrupts"
^ TimerInterruptHandler
!
-timerInterruptHandler:aHandler
+dler
"set the handler for timer interrupts"
TimerInterruptHandler := aHandler
!
-userInterruptHandler
+ler
"return the handler for CNTL-C interrupt handling"
^ UserInterruptHandler
-!
-
-userInterruptHandler:aHandler
- "set the handler for CNTL-C interrupt handling"
-
- UserInterruptHandler := aHandler
! !
!ObjectMemory class methodsFor:'interrupt statistics'!
-interruptLatency:ms receiver:rec class:cls selector:sel vmActivity:vmActivity id:pid
- "example implementation of latencyTime monitoring:
- This method simply measures the max-latency time.
- You may want to use some other handler (see #interruptLatencyMonitor:)
- and extract more information (blocking context).
- DEMO Example."
+InterruptHandler := aHandler
+!
- ms > MaxInterruptLatency ifTrue:[
- MaxInterruptLatency := ms.
- 'IRQ-LATENCY: ' infoPrint. rec class infoPrint. ' ' infoPrint. sel infoPrint. '(' infoPrint. vmActivity infoPrint . ') ---> ' infoPrint. ms infoPrintNL.
- ].
- (InterruptLatencyGoal notNil and:[ms > InterruptLatencyGoal]) ifTrue:[
- '*** IRQ REALTIME-DEADLINE MISSED: ' errorPrint.
- rec isBehavior ifTrue:[
- rec name errorPrint. 'class' errorPrint.
- ] ifFalse:[
- rec class errorPrint
- ].
- ' ' errorPrint. sel errorPrint. '(' errorPrint. vmActivity errorPrint . ') ---> ' errorPrint.
- ms errorPrintNL.
- ].
-
- "to enable the demo handler:
-
- ObjectMemory resetMaxInterruptLatency.
- ObjectMemory interruptLatencyMonitor:ObjectMemory.
- "
- "to disable timing statistics:
-
- ObjectMemory interruptLatencyMonitor:nil.
- ObjectMemory maxInterruptLatency printNL.
- "
+"
"Created: 7.11.1995 / 21:05:50 / cg"
"Modified: 7.11.1995 / 21:13:33 / cg"
!
-interruptLatencyGoal:millis
- "setup to report an error message, whenever a realtime goal could not be
- met due to blocked interrupts or long primitives or GC activity.
- An argument of nil clears the check.
- DEMO Example."
-
- InterruptLatencyGoal := millis.
- millis isNil ifTrue:[
- InterruptLatencyMonitor := nil.
- ] ifFalse:[
- MaxInterruptLatency := 0.
- InterruptLatencyMonitor := self.
+ptLatencyMonitor := self.
]
"
@@ -2451,86 +1660,46 @@
"
!
-interruptLatencyMonitor
- "return the interrupt-latency-monitor if any.
- See comment in #interruptLatencyMonitor:.
- This is a non-standard debugging/realtime instrumentation entry."
+non-standard debugging/realtime instrumentation entry."
^ InterruptLatencyMonitor
!
-interruptLatencyMonitor:aHandler
- "set the interrupt latency monitor. If non-nil, this one will be sent
- an interruptLatency: message with the millisecond delay between
- the interrupt and its handling.
- This is a non-standard debugging/realtime instrumentation entry."
+rd debugging/realtime instrumentation entry."
InterruptLatencyMonitor := aHandler
!
-maxInterruptLatency
- "return the maximum accumulated interrupt latency in millis.
+ccumulated interrupt latency in millis.
DEMO Example."
^ MaxInterruptLatency
-!
-
-resetMaxInterruptLatency
- "reset the maximum accumulated interrupt latency probe time.
- DEMO Example."
-
- MaxInterruptLatency := 0
! !
!ObjectMemory class methodsFor:'low memory handling'!
-memoryInterrupt
- "when a low-memory condition arises, ask all classes to
- remove possibly cached data. You may help the system a bit,
- in providing a lowSpaceCleanup method in your classes which have
- lots of data kept somewhere (usually, cached data).
- - this may or may not help."
+MaxInterruptLatency := 0
+!
- self performLowSpaceCleanup.
-"/ self error:'almost out of memory'
- 'almost out of memory' errorPrintNL.
+orPrintNL.
LowSpaceSemaphore signalIf.
"Modified: 12.4.1996 / 14:57:55 / cg"
-!
-
-performLowSpaceCleanup
- "ask all classes to remove possibly cached data.
- You may help the system a bit, in providing a lowSpaceCleanup method
- in your classes which have lots of data kept somewhere (usually, cached data)."
-
- Smalltalk allBehaviorsDo:[:aClass |
- aClass lowSpaceCleanup
- ].
-
- "Created: 12.4.1996 / 14:57:28 / cg"
! !
!ObjectMemory class methodsFor:'object finalization'!
-allChangedShadowObjectsDo:aBlock
- "evaluate the argument, aBlock for all known shadow objects which have
- lost a pointer recently."
+d: 12.4.1996 / 14:57:28 / cg"
+!
+
+lost a pointer recently."
%{
__allChangedShadowObjectsDo(&aBlock COMMA_CON);
%}
!
-disposeInterrupt
- "this is triggered by the garbage collector,
- whenever any shadowArray looses a pointer."
-
- FinalizationSemaphore notNil ifTrue:[
- "/
- "/ background finalizer is waiting ...
- "/
- FinalizationSemaphore signal
+tionSemaphore signal
] ifFalse:[
"/
"/ do it right here
@@ -2539,399 +1708,169 @@
]
!
-finalize
- "tell all weak objects that something happened."
-
- self allChangedShadowObjectsDo:[:aShadowArray |
+self allChangedShadowObjectsDo:[:aShadowArray |
aShadowArray lostPointer.
]
!
-startBackgroundFinalizationAt:aPriority
- "start a process doing finalization work in the background.
- Can be used to reduce the pauses created by finalization.
- Normally, these pauses are not noticed; however if you have (say)
- ten thousands of weak objects, these could become long enough to
- make background finalization usefull.
- WARNING: background finalization may lead to much delayed freeing of
- system resources. Especially, you may temporarily run out of free
- color table entries or fileDescriptors etc. Use at your own risk (if at all)"
-
- |p|
-
- "/
- "/ its not useful, to run it more than once
- "/
- BackgroundFinalizationProcess notNil ifTrue:[
- BackgroundFinalizationProcess priority:aPriority.
- ^ self
- ].
-
- FinalizationSemaphore := Semaphore new.
-
- p :=
- [
- [
- [true] whileTrue:[
- "
- wait till something to do ...
- "
- FinalizationSemaphore wait.
- "
- ... and do it
- "
- self finalize
- ]
- ] valueOnUnwindDo:[
- BackgroundFinalizationProcess := nil.
- FinalizationSemaphore := nil
- ]
- ] newProcess.
- p name:'background finalizer'.
- p priority:aPriority.
- p restartable:true.
- p resume.
- BackgroundFinalizationProcess := p
+inalizationProcess := p
"
ObjectMemory startBackgroundFinalizationAt:5
"
-!
-
-stopBackgroundFinalization
- "stop the background finalizer"
-
- BackgroundFinalizationProcess notNil ifTrue:[
- BackgroundFinalizationProcess terminate.
- BackgroundFinalizationProcess := nil
- ].
-
- "
- ObjectMemory stopBackgroundFinalization
- "
! !
!ObjectMemory class methodsFor:'physical memory access'!
-collectedOldSpacePagesDo:aBlock
- "evaluates aBlock for all pages in the prev. oldSpace, passing
- the pages address as argument.
- For internal & debugging use only."
-%{
- if (__collectedOldSpacePagesDo(&aBlock COMMA_CON) < 0) {
+ckgroundFinalization
+ "
+!
+
+llectedOldSpacePagesDo(&aBlock COMMA_CON) < 0) {
RETURN (false);
}
%}.
^ true
!
-newSpacePagesDo:aBlock
- "evaluates aBlock for all pages in the newSpace, passing
- the pages address as argument.
- For internal & debugging use only."
-%{
- if (__newSpacePagesDo(&aBlock COMMA_CON) < 0) {
- RETURN (false);
- }
-%}.
- ^ true
-!
-
-oldSpacePagesDo:aBlock
- "evaluates aBlock for all pages in the oldSpace, passing
- the pages address as argument.
- For internal & debugging use only."
-%{
- if (__oldSpacePagesDo(&aBlock COMMA_CON) < 0) {
+if (__newSpacePagesDo(&aBlock COMMA_CON) < 0) {
RETURN (false);
}
%}.
^ true
!
-pageIsInCore:aPageNumber
- "return true, if the page (as enumerated via oldSpacePagesDo:)
- is in memory; false, if currently paged out. For internal
- use / monitors only; may vanish.
- NOTICE: not all systems provide this information; on those that
- do not, true is returned for all pages."
-%{
-#ifdef HAS_MINCORE
- int pageSize = getpagesize();
- char result[10];
- INT addr;
-
- if (__isSmallInteger(aPageNumber)) {
- addr = __intVal(aPageNumber) & ~(pageSize - 1);
- } else {
- addr = ((INT)aPageNumber) & ~(pageSize - 1);
+if (__oldSpacePagesDo(&aBlock COMMA_CON) < 0) {
+ RETURN (false);
}
- if (mincore(addr, pageSize-1, result) < 0) {
- RETURN (true);
- }
- RETURN ((result[0] & 1) ? true : false);
-#endif
%}.
- "OS does not supply this info - assume yes"
^ true
! !
!ObjectMemory class methodsFor:'queries'!
-bytesUsed
- "return the number of bytes allocated for objects -
- this number is not exact, since some objects may already be dead
- (i.e. not yet reclaimed by the garbage collector).
- If you need the exact number, you have to loop over all
- objects and ask for the bytesize using ObjectMemory>>sizeOf:."
+supply this info - assume yes"
+ ^ true
+!
-%{ /* NOCONTEXT */
- extern unsigned __oldSpaceUsed(), __newSpaceUsed(), __freeListSpace();
-
- RETURN ( __MKSMALLINT(__oldSpaceUsed() + __newSpaceUsed() - __freeListSpace()) );
+__newSpaceUsed() - __freeListSpace()) );
%}
"
ObjectMemory bytesUsed
"
!
-collectObjectsWhich:aBlock
- "helper for the whoReferences queries. Returns a collection
- of objects for which aBlock returns true."
-
- |aCollection|
-
- aCollection := IdentitySet new.
- self allObjectsDo:[:o |
- (aBlock value:o) ifTrue:[
- aCollection add:o
- ]
- ].
- (aCollection size == 0) ifTrue:[
+[
"actually this cannot happen - there is always one"
^ nil
].
^ aCollection
!
-fixSpaceSize
- "return the total size of the fix space."
-
-%{ /* NOCONTEXT */
- extern unsigned __fixSpaceSize();
-
- RETURN ( __MKSMALLINT(__fixSpaceSize()) );
+TURN ( __MKSMALLINT(__fixSpaceSize()) );
%}
"
ObjectMemory fixSpaceSize
"
!
-fixSpaceUsed
- "return the number of bytes allocated for old objects in fix space."
-
-%{ /* NOCONTEXT */
- extern unsigned __fixSpaceUsed();
-
- RETURN ( __MKSMALLINT(__fixSpaceUsed()) );
+TURN ( __MKSMALLINT(__fixSpaceUsed()) );
%}
"
ObjectMemory fixSpaceUsed
"
!
-freeListSpace
- "return the number of bytes in the free lists.
- (which is included in oldSpaceUsed)"
-
-%{ /* NOCONTEXT */
- extern unsigned __freeListSpace();
-
- RETURN ( __MKSMALLINT(__freeListSpace()) );
+RN ( __MKSMALLINT(__freeListSpace()) );
%}
"
ObjectMemory freeListSpace
"
!
-freeSpace
- "return the number of bytes in the compact free area.
- (oldSpaceUsed + freeSpaceSize = oldSpaceSize)"
-
-%{ /* NOCONTEXT */
- extern unsigned __oldSpaceSize(), __oldSpaceUsed();
-
- RETURN ( __MKSMALLINT(__oldSpaceSize() - __oldSpaceUsed()) );
+INT(__oldSpaceSize() - __oldSpaceUsed()) );
%}
"
ObjectMemory freeSpace
"
!
-garbageCollectCount
- "return the number of compressing collects that occurred since startup"
-
-%{ /* NOCONTEXT */
- extern int __garbageCollectCount();
-
- RETURN (__MKSMALLINT(__garbageCollectCount()));
+LLINT(__garbageCollectCount()));
%}
"
ObjectMemory garbageCollectCount
"
!
-incrementalGCCount
- "return the number of incremental collects that occurred since startup"
-
-%{ /* NOCONTEXT */
- extern int __incrementalGCCount();
-
- RETURN (__MKSMALLINT(__incrementalGCCount()));
+SMALLINT(__incrementalGCCount()));
%}
"
ObjectMemory incrementalGCCount
"
!
-incrementalGCPhase
- "returns the internal state of the incremental GC.
- The meaning of those numbers is a secret :-).
- (for the curious: (currently)
- 2 is idle, 3..11 are various mark phases,
- 12 is the sweep phase. 0 and 1 are cleanup phases when the
- incr. GC gets interrupted by a full GC).
- Do not depend on the values - there may be additional phases in
- future versions (incremental compact ;-).
- This is for debugging and monitoring only - and may change or vanish"
-
-%{ /* NOCONTEXT */
+EXT */
extern int __incrGCphase();
RETURN (__MKSMALLINT(__incrGCphase()));
%}
!
-lastScavengeReclamation
- "returns the number of bytes replacimed by the last scavenge.
- For statistic only - this may vanish."
-
-%{ /* NOCONTEXT */
- extern int __newSpaceReclaimed();
-
- RETURN ( __MKSMALLINT(__newSpaceReclaimed()) );
-%}
- "percentage of reclaimed objects is returned by:
-
- ((ObjectMemory lastScavengeReclamation)
+ctMemory lastScavengeReclamation)
/ (ObjectMemory newSpaceSize)) * 100.0
"
!
-lifoRememberedSet
- "return the lifoRemSet.
- This is pure VM debugging and will vanish without notice."
-
-%{ /* NOCONTEXT */
- extern OBJ __lifoRememberedSet();
-
- RETURN ( __lifoRememberedSet() );
+RETURN ( __lifoRememberedSet() );
%}
"
ObjectMemory lifoRememberedSet
"
!
-lifoRememberedSetSize
- "return the size of the lifoRemSet.
- This is a VM debugging interface and may vanish without notice."
-
-%{ /* NOCONTEXT */
- extern int __lifoRememberedSetSize();
-
- RETURN (__MKSMALLINT(__lifoRememberedSetSize()));
+NT(__lifoRememberedSetSize()));
%}
"
ObjectMemory lifoRememberedSetSize
"
!
-markAndSweepCount
- "return the number of mark&sweep collects that occurred since startup"
-
-%{ /* NOCONTEXT */
- extern int __markAndSweepCount();
-
- RETURN (__MKSMALLINT(__markAndSweepCount()));
+KSMALLINT(__markAndSweepCount()));
%}
"
ObjectMemory markAndSweepCount
"
!
-maximumIdentityHashValue
- "for ST-80 compatibility: return the maximum value
- a hashKey as returned by identityHash can get.
- Since ST/X uses direct pointers, a field in the objectHeader
- is used, which is currently 11 bits in size."
-
-%{ /* NOCONTEXT */
- RETURN ( __MKSMALLINT( __MAX_HASH__ << __HASH_SHIFT__) );
+HASH__ << __HASH_SHIFT__) );
%}
"
ObjectMemory maximumIdentityHashValue
"
!
-minScavengeReclamation
- "returns the number of bytes replacimed by the least effective scavenge.
- For statistic only - this may vanish."
-
-%{ /* NOCONTEXT */
- extern int __newSpaceReclaimedMin();
-
- RETURN ( __MKSMALLINT(__newSpaceReclaimedMin()) );
+T(__newSpaceReclaimedMin()) );
%}
"
ObjectMemory minScavengeReclamation
"
!
-newSpaceSize
- "return the total size of the new space - this is usually fix"
-
-%{ /* NOCONTEXT */
- extern unsigned __newSpaceSize();
-
- RETURN ( __MKSMALLINT(__newSpaceSize()) );
+TURN ( __MKSMALLINT(__newSpaceSize()) );
%}
"
ObjectMemory newSpaceSize
"
!
-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 */
- extern unsigned __newSpaceUsed();
-
- RETURN ( __MKSMALLINT(__newSpaceUsed()) );
+N ( __MKSMALLINT(__newSpaceUsed()) );
%}
"
ObjectMemory newSpaceUsed
"
!
-numberOfObjects
- "return the number of objects in the system."
-
- |tally "{ Class: SmallInteger }"|
-
- tally := 0.
- self allObjectsDo:[:obj | tally := tally + 1].
+bj | tally := tally + 1].
^ tally
"
@@ -2939,224 +1878,117 @@
"
!
-numberOfWeakObjects
- "return the number of weak objects in the system"
-
-%{ /* NOCONTEXT */
- extern int __weakListSize();
-
- RETURN ( __MKSMALLINT(__weakListSize()) );
+__MKSMALLINT(__weakListSize()) );
%}
"
ObjectMemory numberOfWeakObjects
"
!
-oldSpaceAllocatedSinceLastGC
- "return the number of bytes allocated for old objects since the
- last oldspace garbage collect occured. This information is used
- by ProcessorScheduler to decide when to start the incremental
- background GC."
-
-%{ /* NOCONTEXT */
- extern unsigned __oldSpaceAllocatedSinceLastGC();
-
- RETURN ( __MKSMALLINT(__oldSpaceAllocatedSinceLastGC()) );
+atedSinceLastGC()) );
%}
"
ObjectMemory oldSpaceAllocatedSinceLastGC
"
!
-oldSpaceSize
- "return the total size of the old space. - may grow slowly"
-
-%{ /* NOCONTEXT */
- extern unsigned __oldSpaceSize();
-
- RETURN ( __MKSMALLINT(__oldSpaceSize()) );
+TURN ( __MKSMALLINT(__oldSpaceSize()) );
%}
"
ObjectMemory oldSpaceSize
"
!
-oldSpaceUsed
- "return the number of bytes allocated for old objects.
- (This includes the free lists)"
-
-%{ /* NOCONTEXT */
- extern unsigned __oldSpaceUsed();
-
- RETURN ( __MKSMALLINT(__oldSpaceUsed()) );
+RN ( __MKSMALLINT(__oldSpaceUsed()) );
%}
"
ObjectMemory oldSpaceUsed
"
!
-rememberedSetSize
- "return the number of old objects referencing new ones.
- This is a VM debugging interface and may vanish without notice."
-
-%{ /* NOCONTEXT */
- extern int __rememberedSetSize();
-
- RETURN (__MKSMALLINT(__rememberedSetSize()));
+MKSMALLINT(__rememberedSetSize()));
%}
"
ObjectMemory rememberedSetSize
"
!
-resetMinScavengeReclamation
- "resets the number of bytes replacimed by the least effective scavenge.
- For statistic only - this may vanish."
-
-%{ /* NOCONTEXT */
- extern int __resetNewSpaceReclaimedMin();
-
- __resetNewSpaceReclaimedMin();
-%}.
- ^ self
- "
- ObjectMemory resetMinScavengeReclamation.
+jectMemory resetMinScavengeReclamation.
ObjectMemory minScavengeReclamation
"
!
-runsSingleOldSpace
- "return true, if the system runs in a single oldSpace or
- false if not.
- The memory system will always drop the second semispace when
- running out of virtual memory, or the baker-limit is reached.
- OBSOLETE:
- the system may now decide at any time to switch between
- single and double-space algorithms, depending on the overall memory
- size. You will now almost always get false as result, since the
- second semispace is only allocated when needed, and released
- immediately afterwards.
- "
-
-%{ /* NOCONTEXT */
- extern int __runsSingleOldSpace();
-
- RETURN ( (__runsSingleOldSpace() ? true : false) );
+ngleOldSpace() ? true : false) );
%}
"
ObjectMemory runsSingleOldSpace
"
!
-scavengeCount
- "return the number of scavenges that occurred since startup"
-
-%{ /* NOCONTEXT */
- extern int __scavengeCount();
-
- RETURN (__MKSMALLINT(__scavengeCount()));
+URN (__MKSMALLINT(__scavengeCount()));
%}
"
ObjectMemory scavengeCount
"
!
-symSpaceSize
- "return the total size of the sym space."
-
-%{ /* NOCONTEXT */
- extern unsigned __symSpaceSize();
-
- RETURN ( __MKSMALLINT(__symSpaceSize()) );
+TURN ( __MKSMALLINT(__symSpaceSize()) );
%}
"
ObjectMemory symSpaceSize
"
!
-symSpaceUsed
- "return the number of bytes allocated for old objects in sym space."
-
-%{ /* NOCONTEXT */
- extern unsigned __symSpaceUsed();
-
- RETURN ( __MKSMALLINT(__symSpaceUsed()) );
+TURN ( __MKSMALLINT(__symSpaceUsed()) );
%}
"
ObjectMemory symSpaceUsed
"
!
-tenureAge
- "return the current tenure age - thats the number of times
- an object has to survive scavenges to be moved into oldSpace.
- For statistic/debugging only - this method may vanish"
-
-%{ /* NOCONTEXT */
+*/
extern unsigned __tenureAge();
RETURN ( __MKSMALLINT(__tenureAge()) );
%}
!
-whoReferences:anObject
- "return a collection of objects referencing the argument, anObject"
-
- ^ self collectObjectsWhich:[:o | o references:anObject]
+references:anObject]
"
(ObjectMemory whoReferences:Transcript) printNL
"
!
-whoReferencesDerivedInstancesOf:aClass
- "return a collection of objects refering to instances
- of the argument, aClass or a subclass of it."
-
- ^ self collectObjectsWhich:[:o | o referencesDerivedInstanceOf:aClass]
+:aClass]
"
(ObjectMemory whoReferencesDerivedInstancesOf:View) printNL
"
-!
-
-whoReferencesInstancesOf:aClass
- "return a collection of objects refering to instances
- of the argument, aClass"
-
- ^ self collectObjectsWhich:[:o | o referencesInstanceOf:aClass]
-
- "
- (ObjectMemory whoReferencesInstancesOf:SystemBrowser) printNL
- "
! !
!ObjectMemory class methodsFor:'semaphore access'!
-lowSpaceSemaphore
- "return the semaphore that is signalled when the system detects a
- low space condition. Usually, some time after this, an allocationFailure
- will happen. You can have a cleanup process sitting in that semaphore and
- start to release object."
-
- ^ LowSpaceSemaphore
+sOf:SystemBrowser) printNL
+ "
! !
!ObjectMemory class methodsFor:'statistics'!
-ageStatistic
-%{ /* NOCONTEXT */
+ease object."
- __ageStatistics();
-%}
+ ^ LowSpaceSemaphore
! !
!ObjectMemory class methodsFor:'system management'!
-allBinaryModulesDo:aBlock
- "internal private method - walk over all known binary
- modules and evaluate aBlock for each entry.
- Do not depend on the information returned for each - this may
+T */
+
+ __ageStatistics();
+%}
+!
+
+ay
change without notice."
%{
@@ -3164,135 +1996,19 @@
%}
!
-binaryModuleInfo
- "return a collection of moduleInfo entries.
- This returns a dictionary (keys are internal moduleIDs)
- with one entry for each binary package."
-
- |modules|
-
- modules := IdentityDictionary new.
- self allBinaryModulesDo:[:entry |
- |id name type libName subModuleName module dynamic infoRec pathName
- typeName nameString|
-
- id := entry at:1.
- subModuleName := (entry at:2) asSymbol.
- libName := (entry at:4).
-
- id > 0 ifTrue:[
- pathName := ObjectFileLoader pathNameFromID:id.
- dynamic := true.
- typeName := 'dynamic '.
- name := pathName asFilename baseName
- ] ifFalse:[
- dynamic := false.
- typeName := 'builtIn '.
- pathName := nil.
- libName isNil ifTrue:[
- name := subModuleName
- ] ifFalse:[
- name := libName
- ].
- ].
- nameString := typeName.
- libName isNil ifTrue:[
- nameString := nameString, 'module '
- ] ifFalse:[
- nameString := nameString, 'classLib '
- ].
- nameString := nameString , name.
-
- libName isNil ifTrue:[
- type := #classObject
- ] ifFalse:[
- type := #classLibrary
- ].
- infoRec := modules at:id ifAbsent:nil.
- infoRec notNil ifTrue:[
- (infoRec at:#classNames) add:subModuleName
- ] ifFalse:[
- infoRec := IdentityDictionary new.
- infoRec at:#id put:id.
- infoRec at:#classNames put:(Set with:subModuleName).
- infoRec at:#pathName put:pathName.
- infoRec at:#name put:nameString.
- infoRec at:#libraryName put:libName.
- infoRec at:#dynamic put:dynamic.
- infoRec at:#type put:type.
- modules at:id put:infoRec.
- ].
- ].
- ^ modules
-
- "
- ObjectMemory binaryModuleInfo
+ObjectMemory binaryModuleInfo
"
"Modified: 17.9.1995 / 16:33:02 / claus"
!
-fullBinaryModuleInfo
- "return a full collection of moduleInfo entries.
- This returns a dictionary (keys are component names)
- with one entry for each component in all binary packages."
-
- |modules|
-
- modules := IdentityDictionary new.
- self allBinaryModulesDo:[:entry |
- |id name type libName subModuleName module dynamic infoRec pathName
- t|
-
- id := entry at:1.
- subModuleName := (entry at:2) asSymbol.
- libName := (entry at:4).
- t := AbsoluteTime fromOSTime:(entry at:5).
-
- id > 0 ifTrue:[
- dynamic := true.
- ] ifFalse:[
- dynamic := false.
- ].
- libName isNil ifTrue:[
- type := #classObject
- ] ifFalse:[
- type := #classLibrary
- ].
- infoRec := IdentityDictionary new.
- infoRec at:#id put:id.
- infoRec at:#className put:subModuleName.
- infoRec at:#libraryName put:libName.
- infoRec at:#dynamic put:dynamic.
- infoRec at:#type put:type.
- infoRec at:#timeStamp put:t.
- modules at:subModuleName put:infoRec.
- ].
- ^ modules
-
- "
- ObjectMemory fullBinaryModuleInfo
+ObjectMemory fullBinaryModuleInfo
"
"Modified: 30.8.1995 / 17:29:30 / claus"
!
-imageBaseName
- "return a reasonable filename to use as baseName (i.e. without extension).
- This is the filename of the current image (without '.img') or,
- if not running from an image, the default name 'st'"
-
- |nm|
-
- nm := ImageName.
- (nm isNil or:[nm isBlank]) ifTrue:[
- ^ 'st'
- ].
- (nm endsWith:'.sav') ifTrue:[
- nm := nm copyWithoutLast:4
- ].
- (nm endsWith:'.img') ifTrue:[
- ^ nm copyWithoutLast:4
+nm copyWithoutLast:4
].
^ nm
@@ -3301,9 +2017,7 @@
"
!
-imageName
- "return the filename of the current image, or nil
- if not running from an image."
+not running from an image."
^ ImageName
@@ -3312,44 +2026,18 @@
"
!
-imageSaveTime
- "return a timestamp for when the running image was saved.
+g image was saved.
Return nil if not running from an image."
^ ImageSaveTime
!
-loadClassBinary:aClassName
- "find the object file for aClassName and -if found - load it;
- this one loads precompiled object files"
-
- |fName newClass|
-
- fName := self fileNameForClass:aClassName.
- fName notNil ifTrue:[
- Class withoutUpdatingChangesDo:
- [
- self loadBinary:(fName , '.o')
- ].
- newClass := self at:(aClassName asSymbol).
- (newClass notNil and:[newClass implements:#initialize]) ifTrue:[
+tNil and:[newClass implements:#initialize]) ifTrue:[
newClass initialize
]
]
!
-nameForChanges
- "return a reasonable filename to store the changes into.
- Currently, this is defined in a classVariable and defaults to 'changes'.
- In future versions, this will be the basename of the current image with '.img' replaced
- by '.chg', or, if not running from an image, the default name 'st.chg'."
-
- ChangeFileName notNil ifTrue:[^ ChangeFileName].
- ^ 'changes'.
-
-"/ future versions will have:
-"/ (requires some additionas at other places)
-"/
"/ ^ self imageBaseName , '.chg'
"
@@ -3357,32 +2045,21 @@
"
!
-nameForChanges:aFilename
- "set the name of the file where changes are stored into."
-
- ChangeFileName := aFilename
+ngeFileName := aFilename
"
ObjectMemory nameForChanges:'myChanges'
"
!
-nameForSnapshot
- "return a reasonable filename to store the snapshot image into.
- This is the filename of the current image or,
- if not running from an image, the default name 'st.img'"
-
- ^ self imageBaseName , '.img'
+^ self imageBaseName , '.img'
"
ObjectMemory nameForSnapshot
"
!
-nameForSources
- "return a reasonable filename to store the sources into.
- This is the basename of the current image with '.img' replaced
- by '.src', or, if not running from an image, the default name 'st.src'"
+"
^ self imageBaseName , '.src'
@@ -3391,105 +2068,25 @@
"
!
-primSnapShotOn:aFileName
- "create a snapshot in the given file.
- Low level entry. Does not notify classes or write an entry to
- the changes file. Also, no image backup is created. Returns true if
- the snapshot worked, false if it failed for some reason.
- This method should not be used in normal cases."
-
- |ok|
-
-%{ /* STACK:32000 */
-
- OBJ __snapShotOn();
- OBJ funny = @symbol(funnySnapshotSymbol);
-
- if (__isString(aFileName)) {
- __BLOCKINTERRUPTS();
- ok = __snapShotOn(__context, _stringVal(aFileName), funny);
+n(__context, _stringVal(aFileName), funny);
__UNBLOCKINTERRUPTS();
}
%}.
^ ok
!
-snapShot
- "create a snapshot file containing all of the current state."
+."
self snapShotOn:(self nameForSnapshot)
"
ObjectMemory snapShot
"
-!
-
-snapShotOn:aFileName
- "create a snapshot in the given file.
- If the file exists, save it for backup.
- Return true if the snapshot worked, false if it failed for some reason.
- Notify dependents before and after the snapshot operation."
-
- |ok oldImageName oldImageTime|
-
- "
- keep a save version - just in case something
- bad happens while writing the image.
- (could be st/x internal error or file-system errors etc)
- "
- (OperatingSystem isValidPath:aFileName) ifTrue:[
- OperatingSystem renameFile:aFileName to:(aFileName , '.sav').
- ].
-
- "
- give others a chance to fix things
- "
- self changed:#save. "/ will vanish ...
- self changed:#aboutToSnapshot. "/ ... for ST-80 compatibility
-
- "
- ST-80 compatibility; send #preSnapshot to all classes
- "
- Smalltalk allBehaviorsDo:[:aClass |
- aClass preSnapshot
- ].
-
- "
- save the name with it ...
- "
- oldImageName := ImageName.
- oldImageTime := ImageSaveTime.
-
- ImageName := aFileName.
- ImageSaveTime := AbsoluteTime now.
-
- ok := self primSnapShotOn:aFileName.
-
- ImageName := oldImageName.
- ImageSaveTime := oldImageTime.
-
- ok ifTrue:[
- Class addChangeRecordForSnapshot:aFileName.
- ].
-
-
- "
- ST-80 compatibility; send #postSnapshot to all classes
- "
- Smalltalk allBehaviorsDo:[:aClass |
- aClass postSnapshot
- ].
- self changed:#finishedSnapshot. "/ ST-80 compatibility
- ^ ok
-
- "
- ObjectMemory snapShotOn:'myimage.img'
- "
! !
!ObjectMemory class methodsFor:'documentation'!
-version
- ^ '$Header: /cvs/stx/stx/libbasic/Attic/ObjMem.st,v 1.99 1996-04-12 16:32:17 cg Exp $'
+mory snapShotOn:'myimage.img'
+ "
! !
ObjectMemory initialize!
--- a/ObjectMemory.st Thu Apr 25 13:16:22 1996 +0200
+++ b/ObjectMemory.st Thu Apr 25 18:02:18 1996 +0200
@@ -103,7 +103,7 @@
-> interrupts
-> garbageCollection
- Class variables:
+ [Class variables:]
InternalErrorHandler gets informed (by VM), when some runtime
error occurs (usually fatal)
@@ -175,6 +175,12 @@
The InterruptHandler variables are known by the runtime system -
they are the objects that get an interrupt message when the event
occurs. You may not remove any of them.
+
+ [author:]
+ Claus Gittinger
+
+ [see also:]
+ ( garbage collection : html:programming/GC.html )
"
!
@@ -1141,257 +1147,86 @@
%}
!
-printReferences:anObject
- "for debugging: print referents to anObject.
- WARNING: this method is for ST/X debugging only
- it will be removed without notice
- use ObjectMemory>>whoReferences: or anObject>>allOwners."
+nteger(low, high)) {
+ RETURN ((OBJ)((__intVal(high) << 16) | __intVal(low)));
+ }
+%}
+!
+
+oReferences: or anObject>>allOwners."
%{
__printRefChain(__context, anObject);
%}
!
-refChainFrom:start to:anObject inRefSets:levels startingAt:index
- |chain names oClass|
-
- index > levels size ifTrue:[
- ^ OrderedCollection with:start
- ].
-
-"/'set: ' print. (levels at:index) displayString printNL.
-"/'start: ' print. start printNL.
- (levels at:index) do:[:el |
-"/'trying: ' print. el printNL.
- (start references:el) ifTrue:[
-"/'yes' printNL.
- chain := self
- refChainFrom:el
- to:anObject
- inRefSets:levels
- startingAt:(index+1).
-
- chain notNil ifTrue:[
- start == Smalltalk ifTrue:[
- start keysAndValuesDo:[:key :val |
- (val == el) ifTrue:[
- chain addFirst:'Smalltalk:' , key.
- ^ chain
- ]
- ]
- ] ifFalse:[
- names := start class allInstVarNames.
- oClass := start class.
- 1 to:oClass instSize do:[:i |
- ((start instVarAt:i) == el) ifTrue:[
- chain addFirst:(start -> ('[' , (names at:i) , ']')).
- ^ chain
- ].
- ].
- oClass isVariable ifTrue:[
- oClass isPointers ifTrue:[
- 1 to:start basicSize do:[:i |
- ((start basicAt:i) == el) ifTrue:[
- chain addFirst:(start -> ('[' , i printString , ']')).
- ^ chain
- ]
- ]
- ]
- ].
- ].
-
- chain addFirst:start.
-
- ^ chain
- ]
- ].
- ].
- ^ nil
-
-
- "
- |o a1 a2|
-
- o := Object new.
- a1 := Array with:o with:nil with:nil.
- a2 := Array with:a1 with:nil with:nil.
- a2 references:a1
- "
-
- "
- |o a1 a2 a3 a4 levels|
-
- o := Object new.
- a1 := Array with:o.
- a2 := Array with:a1.
- a3 := Array with:a2.
- a4 := Array with:a3.
- levels := Array with:(Array with:a3)
- with:(Array with:a2)
- with:(Array with:a1).
-
- self refChainFrom:a4 to:o inRefSets:levels startingAt:1.
+to:o inRefSets:levels startingAt:1.
"
"Modified: 19.3.1996 / 23:22:41 / cg"
!
-sizeOf:anObject
- "return the size of anObject in bytes.
- (this is not the same as 'anObject size').
- WARNING: this method is for ST/X debugging only
- it will be removed without notice"
-
-%{ /* 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 at:nw put:(hist at:nw) + 1
].
].
hist printNL.
big printNL
"
-!
-
-spaceOf:anObject
- "return the memory space, in which anObject is.
- - since objects may move between spaces,
- the returned value may be invalid after the next scavenge/collect.
- WARNING: this method is for ST/X debugging only
- it will be removed without notice"
-
-%{ /* NOCONTEXT */
-
- if (! __isNonNilObject(anObject)) {
- RETURN ( nil );
- }
- RETURN ( __MKSMALLINT( __qSpace(anObject) ) );
-%}
! !
!ObjectMemory class methodsFor:'dependents access'!
-dependents
- "return the colleciton of my dependents"
-
- ^ Dependents
+INT( __qSpace(anObject) ) );
+%}
!
-dependents:aCollection
+ts access'!
+
+endents:aCollection
"set the dependents collection"
Dependents := aCollection
-!
-
-dependentsDo:aBlock
- "evaluate aBlock for all of my dependents.
- Since this is performed at startup time (under the scheduler),
- this is redefined here to catch abort signals.
- Thus, if any error occurs in a #returnFromSnapshot,
- the user can press abort to continue."
+! !
- |deps|
+!ObjectMemory class methodsFor:'enumerating'!
- deps := Dependents.
- deps notNil ifTrue:[
- deps do:[:each |
- AbortSignal handle:[:ex |
- ex return
- ] do:[
+[
aBlock value:each
]
]
]
-! !
-
-!ObjectMemory class methodsFor:'enumerating'!
+!
-allInstancesOf:aClass do:aBlock
- "evaluate the argument, aBlock for all instances of aClass 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);
- /*
- * allInstancesDo needs a temporary to hold newSpace objects
- */
- if (__allInstancesOfDo(&aClass, &aBlock, &work COMMA_CON) < 0) {
+esOfDo(&aClass, &aBlock, &work COMMA_CON) < 0) {
RETURN (false);
}
%}.
^ true
!
-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 (__allInstancesOfDo((OBJ *)0, &aBlock, &work COMMA_CON) < 0) {
+sOfDo((OBJ *)0, &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 (__allInstancesOfDo((OBJ *)0, &aBlock, (OBJ *)0 COMMA_CON) < 0) {
- RETURN (false);
- }
-%}.
- ^ true
! !
!ObjectMemory class methodsFor:'garbage collection'!
-backgroundCollectorRunning
- "return true, if a backgroundCollector is running"
+(false);
+ }
+%}.
+ ^ true
+!
- ^ BackgroundCollectProcess notNil
+kgroundCollectProcess notNil
"
ObjectMemory backgroundCollectorRunning
"
!
-compressingGarbageCollect
- "search for and free garbage in the oldSpace (newSpace is cleaned automatically)
- performing a COMPRESSING garbage collect.
- This can take a long time - especially, if paging is involved
- (when no paging is involved, its faster than I thought :-).
- If no memory is available for the compress, or the system has been started with
- the -Msingle option, this does a non-COMPRESSING collect."
-%{
- if (! __garbageCollect(__context)) {
- __markAndSweep(__context);
+AndSweep(__context);
}
%}
@@ -1400,13 +1235,7 @@
"
!
-garbageCollect
- "search for and free garbage in the oldSpace.
- This can take a long time - especially, if paging is involved."
-
- "/ used to be
- "/ self compressingGarbageCollect
- "/ here; changed to default to markAndSweep
+t to markAndSweep
self markAndSweep
@@ -1415,46 +1244,13 @@
"
!
-gcStep
- "one incremental garbage collect step.
- Mark or sweep some small number of objects. This
- method will return after a reasonable (short) time.
- This is used by the ProcessorScheduler at idle times.
- Returns true, if an incremental GC cycle has finished."
-%{
- extern int __incrGCstep();
+extern int __incrGCstep();
RETURN (__incrGCstep(__context) ? true : false);
%}
!
-gcStepIfUseful
- "If either the IncrementalGCLimit or the FreeSpaceGCLimits have been
- reached, perform one incremental garbage collect step.
- Return true, if more gcSteps are required to finish the cycle,
- false if done with a gc round.
- If no limit has been reached yet, do nothing and return false.
- This is called by the ProcessorScheduler at idle times or by the
- backgroundCollector."
-
- |done limit|
-
- AbortSignal handle:[:ex |
- "/ in case of abort (from the debugger),
- "/ disable gcSteps.
- done := true.
- IncrementalGCLimit := FreeSpaceGCLimit := nil.
- 'OBJMEM: IGC aborted; turning off incremental GC' errorPrintNL
- ] do:[
- limit := IncrementalGCLimit.
- (limit notNil and:[self oldSpaceAllocatedSinceLastGC > limit]) ifTrue:[
- done := ObjectMemory gcStep
- ] ifFalse:[
- limit := FreeSpaceGCLimit.
- (limit notNil and:[(self freeSpace + self freeListSpace) < limit]) ifTrue:[
- done := ObjectMemory gcStep.
- done ifTrue:[
- self moreOldSpaceIfUseful
+OldSpaceIfUseful
].
] ifFalse:[
done := true
@@ -1464,48 +1260,12 @@
^ done not
!
-incrementalGC
- "perform one round of incremental GC steps.
- The overall effect of this method is (almost) the same as calling
- markAndSweep. However, #incrementalGC is interruptable while #markAndSweep
- is atomic and blocks for a while. The code here performs incremental
- GC steps, until one complete gc-cycle is completed. If running at a higher
- than userBackground priority, it will give up the CPU after every such
- step for a while.
- Thus this method can be called either from a low prio (background) process
- or from a high prio process.
- (however, if you have nothing else to do, its better to call for markAndSweep,
- since it is faster)
- For example, someone allocating huge amounts of memory could
- ask for the possibility of a quick allocation using
- #checkForFastNew: and try a #incrementalGC if not. In many
- cases, this can avoid a pause (in the higher prio processes) due to
- a blocking GC."
-
- |p delay|
-
- Processor activeProcess priority > Processor userBackgroundPriority ifTrue:[
- delay := Delay forMilliseconds:1
- ].
-
- [self gcStep] whileFalse:[
- delay notNil ifTrue:[delay wait]
- ].
- self moreOldSpaceIfUseful
-
- "
- ObjectMemory incrementalGC
- [ObjectMemory incrementalGC] forkAt:3
+ObjectMemory incrementalGC] forkAt:3
[ObjectMemory incrementalGC] forkAt:9
"
!
-markAndSweep
- "mark/sweep garbage collector.
- perform a full mark&sweep collect.
- Warning: this may take some time and it is NOT interruptable.
- If you want to do a collect from a background process, or have
- other things to do, better use #incrementalGC which is interruptable."
+ble."
%{
__markAndSweep(__context);
%}
@@ -1515,12 +1275,7 @@
"
!
-reclaimSymbols
- "reclaim unused symbols;
- Unused symbols are (currently) not reclaimed automatically,
- but only upon request with this method.
- It takes some time to do this ... and it is NOT interruptable.
- Future versions may do this automatically, while garbage collecting."
+."
%{
__reclaimSymbols(__context);
%}
@@ -1529,18 +1284,7 @@
"
!
-scavenge
- "collect young objects, without aging (i.e. no tenure).
- Can be used to quickly get rid of shortly before allocated
- stuff. This is relatively fast (compared to oldspace collect).
-
- An example where a non-tenuring scavenge makes sense is when
- allocating some OperatingSystem resource (a Color, File or View)
- and the OS runs out of resources. In this case, the scavenge may
- free some ST-objects and therefore (by signalling the WeakArrays
- or Registries) free the OS resources too.
- Of course, only recently allocated resources will be freed this
- way. If none was freed, a full collect will be needed."
+."
%{
__nonTenuringScavenge(__context);
%}
@@ -1550,69 +1294,12 @@
"
!
-startBackgroundCollectorAt:aPriority
- "start a process doing incremental GC in the background.
- Use this, if you have suspendable background processes which
- run all the time, and therefore would prevent the idle-collector
- from running. See documentation in this class for more details."
-
- |p|
-
- "/
- "/ its not useful, to run it more than once
- "/
- BackgroundCollectProcess notNil ifTrue:[
- BackgroundCollectProcess priority:aPriority.
- ^ self
- ].
-
- p :=
- [
- [
- [true] whileTrue:[
- self gcStepIfUseful ifTrue:[
- "
- perform a full cycle
- "
- self incrementalGC
- ].
- "
- wait a bit
- "
- (Delay forSeconds:5) wait
- ]
- ] valueOnUnwindDo:[
- BackgroundCollectProcess := nil
- ]
- ] newProcess.
- p name:'background collector'.
- p priority:aPriority.
- p restartable:true.
- p resume.
- BackgroundCollectProcess := p
-
- "
- the following lets the backgroundCollector run at prio 5
- whenever 100000 bytes have been allocated, OR freeSpace drops
- below 1meg. Having the system keep 1meg as reserve for peak allocation.
-
- Doing this may reduce pauses due to inevitable collects when running
- out of freeSpace, if the collector can keep up with allocation rate.
- "
-
- "
- ObjectMemory incrementalGCLimit:100000.
- ObjectMemory freeSpaceGCLimit:1000000.
+tMemory freeSpaceGCLimit:1000000.
ObjectMemory startBackgroundCollectorAt:5
"
!
-stopBackgroundCollector
- "stop the background collector"
-
- BackgroundCollectProcess notNil ifTrue:[
- BackgroundCollectProcess terminate.
- BackgroundCollectProcess := nil
+oundCollectProcess := nil
]
"
@@ -1620,40 +1307,12 @@
"
!
-tenure
- "force all living new stuff into old-space - effectively making
- all living young objects become old objects immediately.
- This is relatively fast (compared to oldspace collect).
-
- This method should only be used in very special situations:
- for example, when building up some long-living data structure
- in a time critical application.
- To do so, you have to do a scavenge followed by a tenure after the
- objects are created. Be careful, to not reference any other chunk-
- data when calling for a tenure (this will lead to lots of garbage in
- the oldspace).
- In normal situations, explicit tenures are not needed."
-%{
- __tenure(__context);
-%}
-
- "
- ObjectMemory tenure
- "
- "
- ... build up long living objects ...
- ObjectMemory scavenge.
- ObjectMemory tenure
+tMemory tenure
... continue - objects created above are now in oldSpace ...
"
!
-tenuringScavenge
- "collect newspace stuff, with aging (i.e. objects old enough
- will be moved into the oldSpace).
- Use this for debugging and testing only - the system performs
- this automatically when the newspace fills up.
- This is relatively fast (compared to oldspace collect)"
+ect)"
%{
__scavenge(__context);
%}
@@ -1661,54 +1320,15 @@
"
ObjectMemory tenuringScavenge
"
-!
-
-verboseGarbageCollect
- "perform a compressing garbage collect and show some informational
- output on the Transcript"
-
- |nBytesBefore nReclaimed value unit|
-
- nBytesBefore := self oldSpaceUsed.
- self compressingGarbageCollect.
- nReclaimed := nBytesBefore - self oldSpaceUsed.
- nReclaimed > 0 ifTrue:[
- nReclaimed > 1024 ifTrue:[
- nReclaimed > (1024 * 1024) ifTrue:[
- value := nReclaimed // (1024 * 1024).
- unit := ' Mb.'
- ] ifFalse:[
- value := nReclaimed // 1024.
- unit := ' Kb.'
- ]
- ] ifFalse:[
- value := nReclaimed.
- unit := ' bytes.'
- ].
- Transcript show:'reclaimed '; show:value printString.
- Transcript showCr:unit
- ]
-
- "
- ObjectMemory verboseGarbageCollect
- "
! !
!ObjectMemory class methodsFor:'garbage collector control'!
-announceOldSpaceNeed:howMuch
- "announce to the memory system, that howMuch bytes of memory will be needed
- soon, which is going to live longer (whatever that means).
- It first checks if the memory can be allocated without forcing a compressing
- GC. If not, the oldSpace is increased. This may also lead to a slow compressing
- collect. However, many smaller increases are avoided afterwards. Calling this
- method before allocating huge chunks of data may provide better overall performance.
- Notice: this is a nonstandard interface - use only in special situations."
+oseGarbageCollect
+ "
+!
- (self checkForFastNew:howMuch) ifFalse:[
- self incrementalGC.
- (self checkForFastNew:howMuch) ifFalse:[
- self moreOldSpace:howMuch
+eOldSpace:howMuch
]
]
@@ -1717,25 +1337,7 @@
"
!
-announceSpaceNeed:howMuch
- "announce to the memory system, that howMuch bytes of memory will be needed
- soon. The VM tries to prepare itself for this allocation to be performed
- with less overhead. For example, it could preallocate some memory in one
- big chunk (instead of doing many smaller reallocations later).
- Notice: this is a nonstandard interface - use only in special situations.
- Also, this does a background collect before the big chunk of memory is
- allocated, not locking other processes while doing so."
-
- (howMuch < (self newSpaceSize // 2)) ifTrue:[
- self scavenge.
- ].
- (self checkForFastNew:howMuch) ifFalse:[
- (howMuch > (self newSpaceSize // 2)) ifFalse:[
- self scavenge.
- ].
- self incrementalGC.
- (self checkForFastNew:howMuch) ifFalse:[
- self moreOldSpace:howMuch
+moreOldSpace:howMuch
]
]
@@ -1744,128 +1346,28 @@
"
!
-avoidTenure:flag
- "set/clear the avoidTenure flag. If set, aging of newSpace is turned off
- as long as the newSpace fill-grade stays below some magic high-water mark.
- If off (the default), aging is done as usual.
- If the flag is turned on, scavenge may be a bit slower, due to more
- objects being copied around. However, chances are high that in an idle
- or (almost idle) system, less objects are moved into oldSpace.
- Therefore, this helps to avoid oldSpace colelcts, in systems which go into
- some standby mode and are reactivated by some external event.
- (the avoid-flag should be turned off there, and set again once the idle loop
- is reentered).
-
- This is an EXPERIMENTAL interface."
+ERIMENTAL interface."
%{ /* NOCONTEXT */
__avoidTenure(flag == true ? 1 : 0);
%}
!
-checkForFastNew:amount
- "this method returns true, if amount bytes could be allocated
- quickly (i.e. without forcing a full GC or compress).
- This can be used for smart background processes, which want to
- allocate big chunks of data without disturbing foreground processes
- too much. Such a process would check for fast-allocation, and perform
- incremental GC-steps if required. Thus, avoiding the long blocking pause
- due to a forced (non-incremental) GC.
- Especially: doing so will not block higher priority foreground processes.
- See an example use in Behavior>>niceBasicNew:.
- This is experimental and not guaranteed to be in future versions."
-
-%{ /* NOCONTEXT */
- extern int __checkForFastNew();
-
- if (__isSmallInteger(amount)) {
- if (! __checkForFastNew(__intVal(amount))) {
- RETURN (false);
- }
- }
-
-%}.
- ^ true
!
-fastMoreOldSpaceAllocation:aBoolean
- "this method turns on/off fastMoreOldSpace allocation.
- By default, this is turned off (false), which means that in case of
- a filled-up oldSpace, a GC is tried first before more oldSpace is allocated.
- This strategy is ok for the normal operation of the system,
- but behaves badly, if the program allocates huge data structures (say a
- game tree of 30Mb in size) which survives and therefore will not be reclaimed
- by a GC.
- Of course while building this tree, and the memory becomes full, the system
- would not know in advance, that the GC will not reclaim anything.
-
- Setting fastOldSpaceIncrement to true will avoid this, by forcing the
- memory system to allocate more memory right away, without doing a GC first.
-
- WARNING: make certain that this flag is turned off, after your huge data
- is allocated, since otherwise the system may continue to increase its
- virtual memory without ever checking for garbage.
- This method returns the previous value of the flag; typically this return
- value should be used to switch back."
-
-%{ /* NOCONTEXT */
- extern int __fastMoreOldSpaceAllocation();
-
- RETURN (__fastMoreOldSpaceAllocation(aBoolean == true ? 1 : 0) ? true : false);
-%}
- "
- |previousSetting|
-
- previousSetting := ObjectMemory fastMoreOldSpaceAllocation:true.
- [
- ...
- allocate your huge data
- ...
- ] valueNoOrOnUnwindDo:[
- ObjectMemory fastMoreOldSpaceAllocation:previousSetting
- ]
- "
-
- "
- |prev this|
-
- prev := ObjectMemory fastMoreOldSpaceAllocation:true.
+eAllocation:true.
ObjectMemory fastMoreOldSpaceAllocation:prev.
^ prev
"
!
-fastMoreOldSpaceLimit:aNumber
- "this method sets and returns the fastMoreOldSpace limit.
- If fastMoreOldSpaceAllocation is true, and the current oldSpace size is
- below this limit, the memory manager will NOT do a GC when running out of
- oldSpace, but instead quickly go ahead increasing the size of the oldSpace.
- Setting the limit to 0 turns off any limit (i.e. it will continue to
- increase the oldSpace forwever - actually, until the OS refuses to give us
- more memory). The returned value is the previous setting of the limit."
-
-%{ /* NOCONTEXT */
- extern int __fastMoreOldSpaceLimit();
-
- if (__isSmallInteger(aNumber)) {
- RETURN ( __MKSMALLINT( __fastMoreOldSpaceLimit(__intVal(aNumber))));
- }
-%}.
- self primitiveFailed
-
- "
- |prev this|
-
- prev := ObjectMemory fastMoreOldSpaceLimit:10*1024*1024.
+aceLimit:10*1024*1024.
ObjectMemory fastMoreOldSpaceLimit:prev.
^ prev
"
!
-freeSpaceGCAmount
- "return the amount to be allocated if, after an incrementalGC,
- not at least FreeSpaceGCLimit bytes are available for allocation.
- The default is nil, which lets the system compute an abbpropriate value"
+riate value"
^ FreeSpaceGCAmount
@@ -1874,37 +1376,14 @@
"
!
-freeSpaceGCAmount:aNumber
- "set the amount to be allocated if, after an incrementalGC,
- not at least FreeSpaceGCLimit bytes are available for allocation.
- The amount should be greater than the limit, otherwise the incremental
- GC may try over and over to get the memory (actually waisting time)."
-
- FreeSpaceGCAmount := aNumber
-
- "
- the following will try to always keep at least 1meg of free space
- (in the background) and start to do so, whenever the freeSpace drops
- below 250k.
- "
- "
- ObjectMemory freeSpaceGCLimit:250000.
- ObjectMemory freeSpaceGCAmount:1000000.
- "
-
- "
- turn it off (i.e. let the system compute an appropriate amount ...)
+ppropriate amount ...)
"
"
ObjectMemory freeSpaceGCAmount:nil.
"
!
-freeSpaceGCLimit
- "return the freeSpace limit for incremental GC activation.
- The system will start doing incremental background GC, once less than this number
- of bytes are available in the compact free space.
- The default is 100000; setting it to nil will turn this trigger off."
+trigger off."
^ FreeSpaceGCLimit
@@ -1913,35 +1392,14 @@
"
!
-freeSpaceGCLimit:aNumber
- "set the freeSpace limit for incremental GC activation.
- The system will start doing incremental background GC, once less than this number
- of bytes are available for allocation.
- The default is nil; setting it to nil will turn this trigger off."
-
- FreeSpaceGCLimit := aNumber
-
- "
- the following will start the incrementalGC (in the background)
- whenever the freeSpace drops below 1meg of free space
- "
- "
- ObjectMemory freeSpaceGCLimit:1000000.
- "
-
- "
- turn it off (i.e. let the system hit the wall ...)
+ystem hit the wall ...)
"
"
ObjectMemory freeSpaceGCLimit:nil.
"
!
-incrementalGCLimit
- "return the allocatedSinceLastGC limit for incremental GC activation.
- The system will start doing incremental background GC, once more than this number
- of bytes have been allocated since the last GC.
- The default is 500000; setting it to nil will turn this trigger off."
+gger off."
^ IncrementalGCLimit
@@ -1950,76 +1408,26 @@
"
!
-incrementalGCLimit:aNumber
- "set the allocatedSinceLastGC limit for incremental GC activation.
- The system will start doing incremental background GC, once more than this number
- of bytes have been allocated since the last GC.
- The default is 500000; setting it to nil will turn this trigger off."
-
- IncrementalGCLimit := aNumber
-
- "
- ObjectMemory incrementalGCLimit:500000. 'do incr. GC very seldom'
- ObjectMemory incrementalGCLimit:100000. 'medium'
- ObjectMemory incrementalGCLimit:10000. 'do incr. GC very often'
+'do incr. GC very often'
ObjectMemory incrementalGCLimit:nil. 'never'
"
!
-lockTenure:flag
- "set/clear the tenureLock. If the lock is set, the system
- completely turns off tenuring, and objects remain in newSpace (forever).
- Once this lock is set, the system operates only in the newSpace and no memory
- allocations from oldSpace are allowed (except for explicit tenure calls).
- If any allocation request cannot be resoved, the VM raises a memory interrupt,
- clears the lockTenure-flag and returns nil. Thus, it automatically falls back into
- the normal mode of operation, to avoid big trouble
- (fail to allocate memory when handling the exception).
-
- This interface can be used in applications, which are guaranteed to have their
- working set completely in the newSpace AND want to limit the worst case
- pause times to the worst case scavenge time
- (which itself is limitd by the size of the newSpace).
- I.e. systems which go into some event loop after initial startup,
- may turn on the tenureLock to make certain that no oldSpace memory is
- allocated in the future; thereby limiting any GC activity to newSpace scavenges only.
-
- This is an EXPERIMENTAL interface.
- "
-
-%{
- if (flag == true) {
+flag == true) {
__tenure(__context);
}
__lockTenure(flag == true ? 1 : 0);
%}
!
-makeOld:anObject
- "move anObject into oldSpace.
- This method is for internal & debugging purposes only -
- it may vanish. Dont use it."
-%{
- if (__moveToOldSpace(anObject, __context) < 0) {
+if (__moveToOldSpace(anObject, __context) < 0) {
RETURN (false);
}
%}.
^ true
!
-moreOldSpace:howMuch
- "allocate howMuch bytes more for old objects; return true if this worked,
- false if that failed.
- This is done automatically, when running out of space, but makes
- sense, if its known in advance that a lot of memory is needed to
- avoid multiple reallocations and compresses.
- On systems which do not support the mmap (or equivalent) system call,
- this (currently) implies a compressing garbage collect - so its slow.
- Notice: this is a nonstandard interface - use only in special situations."
-
-%{
- if (__isSmallInteger(howMuch)) {
- RETURN( __moreOldSpace(__context, __intVal(howMuch)) ? true : false );
+lse );
}
RETURN (false);
%}
@@ -2028,64 +1436,14 @@
"
!
-moreOldSpaceIfUseful
- "to be called after an incremental GC cycle;
- if freeSpace is still below limit, allocate more oldSpace"
-
- |limit free amount|
-
- limit := FreeSpaceGCLimit.
- limit notNil ifTrue:[
- "/ if reclaimed space is below limit, we have to allocate more
- "/ oldSpace, to avoid excessive gcSteps (due to freeSpaceLimit
- "/ still not reached)
- "/
- free := self freeSpace + self freeListSpace.
- free < (limit * 3 // 2) ifTrue:[
- amount := FreeSpaceGCAmount.
- amount isNil ifTrue:[
- amount := limit * 3 // 2.
- ].
- 'OBJECTMEMORY: moreOldSpace to satisfy free-limit' infoPrintNL.
- (self moreOldSpace:(amount - free + (64*1024))) ifFalse:[
- "/
- "/ could not increase oldspace; reset FreeSpaceGCLimit to avoid
- "/ useless retries
- 'OBJECTMEMORY: could not increase oldSpace - reset limit' errorPrintNL.
+ease oldSpace - reset limit' errorPrintNL.
FreeSpaceGCLimit := nil
]
].
].
!
-newSpaceSize:newSize
- "change the size of the newSpace. To do this, the current contents
- of the newSpace may have to be tenured (if size is smaller).
- Returns false, if it failed for any reason.
- Experimental: this interface may valish without notice.
-
- DANGER ALERT:
- be careful too big of a size may lead to longer scavenge pauses.
- Too small of a newSpace may lead to more CPU overhead, due to
- excessive scavenges. You have been warned."
-
-%{
- extern int __setNewSpaceSize();
-
- if (__isSmallInteger(newSize)) {
- RETURN (__setNewSpaceSize(__intVal(newSize)) ? true : false);
- }
-%}.
- self primitiveFailed
-
- " less absolute CPU overhead (but longer pauses):
-
- ObjectMemory newSpaceSize:800*1024
- "
-
- " smaller pauses, but more overall CPU overhead:
-
- ObjectMemory newSpaceSize:200*1024
+Size:200*1024
"
" the default:
@@ -2094,356 +1452,207 @@
"
!
-oldSpaceCompressLimit
- "return the limit for oldSpace compression. If more memory than this
- limit is in use, the system will not perform compresses on the oldspace,
- but instead do a mark&sweep GC followed by an oldSpace increase if not enough
- could be reclaimed. The default is currently some 8Mb, which is ok for workstations
- with 16..32Mb of physical memory. If your system has much more physical RAM,
- you may want to increase this limit."
-
-%{ /* NOCONTEXT */
- extern unsigned __compressingGCLimit();
-
- RETURN (__MKSMALLINT( __compressingGCLimit(-1) ));
+T( __compressingGCLimit(-1) ));
%}
"
ObjectMemory oldSpaceCompressLimit
"
!
-oldSpaceCompressLimit:amount
- "set the limit for oldSpace compression. If more memory than this
- limit is in use, the system will not perform compresses on the oldspace,
- but instead do a mark&sweep GC followed by an oldSpace increase if not enough
- could be reclaimed. The default is currently some 8Mb, which is ok for workstations
- with 16..32Mb of physical memory. If your system has much more physical RAM,
- you may want to increase this limit.
- This method returns the previous increment value."
-
-%{ /* NOCONTEXT */
- extern unsigned __compressingGCLimit();
-
- if (__isSmallInteger(amount)) {
- RETURN (__MKSMALLINT( __compressingGCLimit(__intVal(amount)) ));
- }
-%}
- "to change the limit to 12Mb:"
+e the limit to 12Mb:"
"
ObjectMemory oldSpaceCompressLimit:12*1024*1024
"
!
-oldSpaceIncrement
- "return the oldSpaceIncrement value. Thats the amount by which
- more memory is allocated in case the oldSpace gets filled up.
- In normal situations, the default value used in the VM is fine
- and there is no need to change it."
-
-%{ /* NOCONTEXT */
- extern unsigned __oldSpaceIncrement();
-
- RETURN (__MKSMALLINT( __oldSpaceIncrement(-1) ));
+LLINT( __oldSpaceIncrement(-1) ));
%}
"
ObjectMemory oldSpaceIncrement
"
!
-oldSpaceIncrement:amount
- "set the oldSpaceIncrement value. Thats the amount by which
- more memory is allocated in case the oldSpace gets filled up.
- In normal situations, the default value used in the VM is fine
- and there is no need to change it. This method returns the
- previous increment value."
-
-%{ /* NOCONTEXT */
- extern unsigned __oldSpaceIncrement();
-
- if (__isSmallInteger(amount)) {
- RETURN (__MKSMALLINT( __oldSpaceIncrement(__intVal(amount)) ));
- }
-%}
- "to change increment to 1Meg:"
+o change increment to 1Meg:"
"
ObjectMemory oldSpaceIncrement:1024*1024
"
!
-tenureParameters:magic
- "this is pure magic and not for public eyes ...
- This method allows fine tuning the scavenger internals,
- in cooperation to some statistic & test programs.
- It is undocumented, secret and may vanish.
- If you play around here, the system may behave very strange."
+e system may behave very strange."
%{ /* NOCONTEXT */
__tenureParams(magic);
%}.
!
-turnGarbageCollectorOff
- "turn off the generational garbage collector by forcing new objects to be
- allocated directly in oldSpace (instead of newSpace)
- WARNING:
- This is somewhat dangerous: if collector is turned off,
- and too many objects are created, the system may run into trouble
- (i.e. oldSpace becomes full) and be forced to perform a full mark&sweep
- or even a compressing collect - making the overall realtime behavior worse.
- Use this only for special purposes or when realtime behavior
- is required for a limited time period.
-
- OBSOLETE: this is no longer supported
- - it may be a no-operation by the time you read this."
+n by the time you read this."
%{ /* NOCONTEXT */
__allocForceSpace(OLDSPACE);
%}
!
-turnGarbageCollectorOn
- "turn garbage collector on again (see ObjectMemory>>turnGarbageCollectorOff)"
+Memory>>turnGarbageCollectorOff)"
%{ /* NOCONTEXT */
__allocForceSpace(9999);
%}
-!
-
-watchTenure:flag
- "set/clear the tenureWatch. If set, an internalError exception will be raised,
- whenever objects are tenured from newSpace into oldSpace
- (except for an explicit tenure request).
- This can be used to validate that no oldSpace objects are created
- (i.e. the system operates fully in newSpace).
- Be careful, if the avoidTenure flag is not set,
- there will almost always be a tenure sooner or later.
-
- EXPERIMENTAL - no warranty"
-
-%{ /* NOCONTEXT */
- __watchTenure(flag == true ? 1 : 0);
-%}
! !
!ObjectMemory class methodsFor:'interrupt handler access'!
-childSignalInterruptHandler
- "return the handler for UNIX-death-of-a-childprocess-signal interrupts"
+lag == true ? 1 : 0);
+%}
+!
+
+for UNIX-death-of-a-childprocess-signal interrupts"
^ ChildSignalInterruptHandler
!
-childSignalInterruptHandler:aHandler
- "set the handler for UNIX-death-of-a-childprocess-signal interrupts"
-
- ChildSignalInterruptHandler := aHandler
-
- "Created: 22.12.1995 / 14:14:52 / stefan"
+reated: 22.12.1995 / 14:14:52 / stefan"
"Modified: 22.12.1995 / 14:15:16 / stefan"
!
-customInterruptHandler
+ptHandler
"return the handler for custom interrupts"
^ CustomInterruptHandler
!
-customInterruptHandler:aHandler
+er
"set the handler for custom interrupts"
CustomInterruptHandler := aHandler
!
-disposeInterruptHandler
- "return the handler for object disposal interrupts"
+"return the handler for object disposal interrupts"
^ DisposeInterruptHandler
!
-disposeInterruptHandler:aHandler
- "set the handler for object disposal interrupts"
+t the handler for object disposal interrupts"
DisposeInterruptHandler := aHandler
!
-errorInterruptHandler
+ler
"return the handler for display error interrupts"
^ ErrorInterruptHandler
!
-errorInterruptHandler:aHandler
- "set the handler for display error interrupts"
+"set the handler for display error interrupts"
ErrorInterruptHandler := aHandler
!
-exceptionInterruptHandler
- "return the handler for floating point exception interrupts"
+the handler for floating point exception interrupts"
^ ExceptionInterruptHandler
!
-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.
+c.
Those should not occur in normal circumstances."
^ InternalErrorHandler
!
-ioInterruptHandler
- "return the handler for I/O available signal interrupts (SIGIO/SIGPOLL)"
+handler for I/O available signal interrupts (SIGIO/SIGPOLL)"
^ IOInterruptHandler
!
-ioInterruptHandler:aHandler
- "set the handler for I/O available signal interrupts (SIGIO/SIGPOLL)"
+r I/O available signal interrupts (SIGIO/SIGPOLL)"
IOInterruptHandler := aHandler
!
-recursionInterruptHandler
- "return the handler for recursion/stack overflow interrupts"
+the handler for recursion/stack overflow interrupts"
^ RecursionInterruptHandler
!
-recursionInterruptHandler:aHandler
- "set the handler for recursion/stack overflow interrupts"
+er for recursion/stack overflow interrupts"
RecursionInterruptHandler := aHandler
!
-registerErrorInterruptHandler:aHandler forID:errorIDSymbol
- "register a handler"
-
- RegisteredErrorInterruptHandlers isNil ifTrue:[
- RegisteredErrorInterruptHandlers := IdentityDictionary new
+ctionary new
].
RegisteredErrorInterruptHandlers at:errorIDSymbol put:aHandler
!
-registeredErrorInterruptHandlers
+rruptHandlers
"return registered handlers"
^ RegisteredErrorInterruptHandlers
!
-signalInterruptHandler
+dler
"return the handler for UNIX-signal interrupts"
^ SignalInterruptHandler
!
-signalInterruptHandler:aHandler
- "set the handler for UNIX-signal interrupts"
+"set the handler for UNIX-signal interrupts"
SignalInterruptHandler := aHandler
!
-spyInterruptHandler
+ptHandler
"return the handler for spy-timer interrupts"
^ SpyInterruptHandler
!
-spyInterruptHandler:aHandler
+er
"set the handler for spy-timer interrupts"
SpyInterruptHandler := aHandler
!
-stepInterruptHandler
+andler
"return the handler for single step interrupts"
^ StepInterruptHandler
!
-stepInterruptHandler:aHandler
- "set the handler for single step interrupts"
+"set the handler for single step interrupts"
StepInterruptHandler := aHandler
!
-timerInterruptHandler
+ruptHandler
"return the handler for timer interrupts"
^ TimerInterruptHandler
!
-timerInterruptHandler:aHandler
+dler
"set the handler for timer interrupts"
TimerInterruptHandler := aHandler
!
-userInterruptHandler
+ler
"return the handler for CNTL-C interrupt handling"
^ UserInterruptHandler
-!
-
-userInterruptHandler:aHandler
- "set the handler for CNTL-C interrupt handling"
-
- UserInterruptHandler := aHandler
! !
!ObjectMemory class methodsFor:'interrupt statistics'!
-interruptLatency:ms receiver:rec class:cls selector:sel vmActivity:vmActivity id:pid
- "example implementation of latencyTime monitoring:
- This method simply measures the max-latency time.
- You may want to use some other handler (see #interruptLatencyMonitor:)
- and extract more information (blocking context).
- DEMO Example."
+InterruptHandler := aHandler
+!
- ms > MaxInterruptLatency ifTrue:[
- MaxInterruptLatency := ms.
- 'IRQ-LATENCY: ' infoPrint. rec class infoPrint. ' ' infoPrint. sel infoPrint. '(' infoPrint. vmActivity infoPrint . ') ---> ' infoPrint. ms infoPrintNL.
- ].
- (InterruptLatencyGoal notNil and:[ms > InterruptLatencyGoal]) ifTrue:[
- '*** IRQ REALTIME-DEADLINE MISSED: ' errorPrint.
- rec isBehavior ifTrue:[
- rec name errorPrint. 'class' errorPrint.
- ] ifFalse:[
- rec class errorPrint
- ].
- ' ' errorPrint. sel errorPrint. '(' errorPrint. vmActivity errorPrint . ') ---> ' errorPrint.
- ms errorPrintNL.
- ].
-
- "to enable the demo handler:
-
- ObjectMemory resetMaxInterruptLatency.
- ObjectMemory interruptLatencyMonitor:ObjectMemory.
- "
- "to disable timing statistics:
-
- ObjectMemory interruptLatencyMonitor:nil.
- ObjectMemory maxInterruptLatency printNL.
- "
+"
"Created: 7.11.1995 / 21:05:50 / cg"
"Modified: 7.11.1995 / 21:13:33 / cg"
!
-interruptLatencyGoal:millis
- "setup to report an error message, whenever a realtime goal could not be
- met due to blocked interrupts or long primitives or GC activity.
- An argument of nil clears the check.
- DEMO Example."
-
- InterruptLatencyGoal := millis.
- millis isNil ifTrue:[
- InterruptLatencyMonitor := nil.
- ] ifFalse:[
- MaxInterruptLatency := 0.
- InterruptLatencyMonitor := self.
+ptLatencyMonitor := self.
]
"
@@ -2451,86 +1660,46 @@
"
!
-interruptLatencyMonitor
- "return the interrupt-latency-monitor if any.
- See comment in #interruptLatencyMonitor:.
- This is a non-standard debugging/realtime instrumentation entry."
+non-standard debugging/realtime instrumentation entry."
^ InterruptLatencyMonitor
!
-interruptLatencyMonitor:aHandler
- "set the interrupt latency monitor. If non-nil, this one will be sent
- an interruptLatency: message with the millisecond delay between
- the interrupt and its handling.
- This is a non-standard debugging/realtime instrumentation entry."
+rd debugging/realtime instrumentation entry."
InterruptLatencyMonitor := aHandler
!
-maxInterruptLatency
- "return the maximum accumulated interrupt latency in millis.
+ccumulated interrupt latency in millis.
DEMO Example."
^ MaxInterruptLatency
-!
-
-resetMaxInterruptLatency
- "reset the maximum accumulated interrupt latency probe time.
- DEMO Example."
-
- MaxInterruptLatency := 0
! !
!ObjectMemory class methodsFor:'low memory handling'!
-memoryInterrupt
- "when a low-memory condition arises, ask all classes to
- remove possibly cached data. You may help the system a bit,
- in providing a lowSpaceCleanup method in your classes which have
- lots of data kept somewhere (usually, cached data).
- - this may or may not help."
+MaxInterruptLatency := 0
+!
- self performLowSpaceCleanup.
-"/ self error:'almost out of memory'
- 'almost out of memory' errorPrintNL.
+orPrintNL.
LowSpaceSemaphore signalIf.
"Modified: 12.4.1996 / 14:57:55 / cg"
-!
-
-performLowSpaceCleanup
- "ask all classes to remove possibly cached data.
- You may help the system a bit, in providing a lowSpaceCleanup method
- in your classes which have lots of data kept somewhere (usually, cached data)."
-
- Smalltalk allBehaviorsDo:[:aClass |
- aClass lowSpaceCleanup
- ].
-
- "Created: 12.4.1996 / 14:57:28 / cg"
! !
!ObjectMemory class methodsFor:'object finalization'!
-allChangedShadowObjectsDo:aBlock
- "evaluate the argument, aBlock for all known shadow objects which have
- lost a pointer recently."
+d: 12.4.1996 / 14:57:28 / cg"
+!
+
+lost a pointer recently."
%{
__allChangedShadowObjectsDo(&aBlock COMMA_CON);
%}
!
-disposeInterrupt
- "this is triggered by the garbage collector,
- whenever any shadowArray looses a pointer."
-
- FinalizationSemaphore notNil ifTrue:[
- "/
- "/ background finalizer is waiting ...
- "/
- FinalizationSemaphore signal
+tionSemaphore signal
] ifFalse:[
"/
"/ do it right here
@@ -2539,399 +1708,169 @@
]
!
-finalize
- "tell all weak objects that something happened."
-
- self allChangedShadowObjectsDo:[:aShadowArray |
+self allChangedShadowObjectsDo:[:aShadowArray |
aShadowArray lostPointer.
]
!
-startBackgroundFinalizationAt:aPriority
- "start a process doing finalization work in the background.
- Can be used to reduce the pauses created by finalization.
- Normally, these pauses are not noticed; however if you have (say)
- ten thousands of weak objects, these could become long enough to
- make background finalization usefull.
- WARNING: background finalization may lead to much delayed freeing of
- system resources. Especially, you may temporarily run out of free
- color table entries or fileDescriptors etc. Use at your own risk (if at all)"
-
- |p|
-
- "/
- "/ its not useful, to run it more than once
- "/
- BackgroundFinalizationProcess notNil ifTrue:[
- BackgroundFinalizationProcess priority:aPriority.
- ^ self
- ].
-
- FinalizationSemaphore := Semaphore new.
-
- p :=
- [
- [
- [true] whileTrue:[
- "
- wait till something to do ...
- "
- FinalizationSemaphore wait.
- "
- ... and do it
- "
- self finalize
- ]
- ] valueOnUnwindDo:[
- BackgroundFinalizationProcess := nil.
- FinalizationSemaphore := nil
- ]
- ] newProcess.
- p name:'background finalizer'.
- p priority:aPriority.
- p restartable:true.
- p resume.
- BackgroundFinalizationProcess := p
+inalizationProcess := p
"
ObjectMemory startBackgroundFinalizationAt:5
"
-!
-
-stopBackgroundFinalization
- "stop the background finalizer"
-
- BackgroundFinalizationProcess notNil ifTrue:[
- BackgroundFinalizationProcess terminate.
- BackgroundFinalizationProcess := nil
- ].
-
- "
- ObjectMemory stopBackgroundFinalization
- "
! !
!ObjectMemory class methodsFor:'physical memory access'!
-collectedOldSpacePagesDo:aBlock
- "evaluates aBlock for all pages in the prev. oldSpace, passing
- the pages address as argument.
- For internal & debugging use only."
-%{
- if (__collectedOldSpacePagesDo(&aBlock COMMA_CON) < 0) {
+ckgroundFinalization
+ "
+!
+
+llectedOldSpacePagesDo(&aBlock COMMA_CON) < 0) {
RETURN (false);
}
%}.
^ true
!
-newSpacePagesDo:aBlock
- "evaluates aBlock for all pages in the newSpace, passing
- the pages address as argument.
- For internal & debugging use only."
-%{
- if (__newSpacePagesDo(&aBlock COMMA_CON) < 0) {
- RETURN (false);
- }
-%}.
- ^ true
-!
-
-oldSpacePagesDo:aBlock
- "evaluates aBlock for all pages in the oldSpace, passing
- the pages address as argument.
- For internal & debugging use only."
-%{
- if (__oldSpacePagesDo(&aBlock COMMA_CON) < 0) {
+if (__newSpacePagesDo(&aBlock COMMA_CON) < 0) {
RETURN (false);
}
%}.
^ true
!
-pageIsInCore:aPageNumber
- "return true, if the page (as enumerated via oldSpacePagesDo:)
- is in memory; false, if currently paged out. For internal
- use / monitors only; may vanish.
- NOTICE: not all systems provide this information; on those that
- do not, true is returned for all pages."
-%{
-#ifdef HAS_MINCORE
- int pageSize = getpagesize();
- char result[10];
- INT addr;
-
- if (__isSmallInteger(aPageNumber)) {
- addr = __intVal(aPageNumber) & ~(pageSize - 1);
- } else {
- addr = ((INT)aPageNumber) & ~(pageSize - 1);
+if (__oldSpacePagesDo(&aBlock COMMA_CON) < 0) {
+ RETURN (false);
}
- if (mincore(addr, pageSize-1, result) < 0) {
- RETURN (true);
- }
- RETURN ((result[0] & 1) ? true : false);
-#endif
%}.
- "OS does not supply this info - assume yes"
^ true
! !
!ObjectMemory class methodsFor:'queries'!
-bytesUsed
- "return the number of bytes allocated for objects -
- this number is not exact, since some objects may already be dead
- (i.e. not yet reclaimed by the garbage collector).
- If you need the exact number, you have to loop over all
- objects and ask for the bytesize using ObjectMemory>>sizeOf:."
+supply this info - assume yes"
+ ^ true
+!
-%{ /* NOCONTEXT */
- extern unsigned __oldSpaceUsed(), __newSpaceUsed(), __freeListSpace();
-
- RETURN ( __MKSMALLINT(__oldSpaceUsed() + __newSpaceUsed() - __freeListSpace()) );
+__newSpaceUsed() - __freeListSpace()) );
%}
"
ObjectMemory bytesUsed
"
!
-collectObjectsWhich:aBlock
- "helper for the whoReferences queries. Returns a collection
- of objects for which aBlock returns true."
-
- |aCollection|
-
- aCollection := IdentitySet new.
- self allObjectsDo:[:o |
- (aBlock value:o) ifTrue:[
- aCollection add:o
- ]
- ].
- (aCollection size == 0) ifTrue:[
+[
"actually this cannot happen - there is always one"
^ nil
].
^ aCollection
!
-fixSpaceSize
- "return the total size of the fix space."
-
-%{ /* NOCONTEXT */
- extern unsigned __fixSpaceSize();
-
- RETURN ( __MKSMALLINT(__fixSpaceSize()) );
+TURN ( __MKSMALLINT(__fixSpaceSize()) );
%}
"
ObjectMemory fixSpaceSize
"
!
-fixSpaceUsed
- "return the number of bytes allocated for old objects in fix space."
-
-%{ /* NOCONTEXT */
- extern unsigned __fixSpaceUsed();
-
- RETURN ( __MKSMALLINT(__fixSpaceUsed()) );
+TURN ( __MKSMALLINT(__fixSpaceUsed()) );
%}
"
ObjectMemory fixSpaceUsed
"
!
-freeListSpace
- "return the number of bytes in the free lists.
- (which is included in oldSpaceUsed)"
-
-%{ /* NOCONTEXT */
- extern unsigned __freeListSpace();
-
- RETURN ( __MKSMALLINT(__freeListSpace()) );
+RN ( __MKSMALLINT(__freeListSpace()) );
%}
"
ObjectMemory freeListSpace
"
!
-freeSpace
- "return the number of bytes in the compact free area.
- (oldSpaceUsed + freeSpaceSize = oldSpaceSize)"
-
-%{ /* NOCONTEXT */
- extern unsigned __oldSpaceSize(), __oldSpaceUsed();
-
- RETURN ( __MKSMALLINT(__oldSpaceSize() - __oldSpaceUsed()) );
+INT(__oldSpaceSize() - __oldSpaceUsed()) );
%}
"
ObjectMemory freeSpace
"
!
-garbageCollectCount
- "return the number of compressing collects that occurred since startup"
-
-%{ /* NOCONTEXT */
- extern int __garbageCollectCount();
-
- RETURN (__MKSMALLINT(__garbageCollectCount()));
+LLINT(__garbageCollectCount()));
%}
"
ObjectMemory garbageCollectCount
"
!
-incrementalGCCount
- "return the number of incremental collects that occurred since startup"
-
-%{ /* NOCONTEXT */
- extern int __incrementalGCCount();
-
- RETURN (__MKSMALLINT(__incrementalGCCount()));
+SMALLINT(__incrementalGCCount()));
%}
"
ObjectMemory incrementalGCCount
"
!
-incrementalGCPhase
- "returns the internal state of the incremental GC.
- The meaning of those numbers is a secret :-).
- (for the curious: (currently)
- 2 is idle, 3..11 are various mark phases,
- 12 is the sweep phase. 0 and 1 are cleanup phases when the
- incr. GC gets interrupted by a full GC).
- Do not depend on the values - there may be additional phases in
- future versions (incremental compact ;-).
- This is for debugging and monitoring only - and may change or vanish"
-
-%{ /* NOCONTEXT */
+EXT */
extern int __incrGCphase();
RETURN (__MKSMALLINT(__incrGCphase()));
%}
!
-lastScavengeReclamation
- "returns the number of bytes replacimed by the last scavenge.
- For statistic only - this may vanish."
-
-%{ /* NOCONTEXT */
- extern int __newSpaceReclaimed();
-
- RETURN ( __MKSMALLINT(__newSpaceReclaimed()) );
-%}
- "percentage of reclaimed objects is returned by:
-
- ((ObjectMemory lastScavengeReclamation)
+ctMemory lastScavengeReclamation)
/ (ObjectMemory newSpaceSize)) * 100.0
"
!
-lifoRememberedSet
- "return the lifoRemSet.
- This is pure VM debugging and will vanish without notice."
-
-%{ /* NOCONTEXT */
- extern OBJ __lifoRememberedSet();
-
- RETURN ( __lifoRememberedSet() );
+RETURN ( __lifoRememberedSet() );
%}
"
ObjectMemory lifoRememberedSet
"
!
-lifoRememberedSetSize
- "return the size of the lifoRemSet.
- This is a VM debugging interface and may vanish without notice."
-
-%{ /* NOCONTEXT */
- extern int __lifoRememberedSetSize();
-
- RETURN (__MKSMALLINT(__lifoRememberedSetSize()));
+NT(__lifoRememberedSetSize()));
%}
"
ObjectMemory lifoRememberedSetSize
"
!
-markAndSweepCount
- "return the number of mark&sweep collects that occurred since startup"
-
-%{ /* NOCONTEXT */
- extern int __markAndSweepCount();
-
- RETURN (__MKSMALLINT(__markAndSweepCount()));
+KSMALLINT(__markAndSweepCount()));
%}
"
ObjectMemory markAndSweepCount
"
!
-maximumIdentityHashValue
- "for ST-80 compatibility: return the maximum value
- a hashKey as returned by identityHash can get.
- Since ST/X uses direct pointers, a field in the objectHeader
- is used, which is currently 11 bits in size."
-
-%{ /* NOCONTEXT */
- RETURN ( __MKSMALLINT( __MAX_HASH__ << __HASH_SHIFT__) );
+HASH__ << __HASH_SHIFT__) );
%}
"
ObjectMemory maximumIdentityHashValue
"
!
-minScavengeReclamation
- "returns the number of bytes replacimed by the least effective scavenge.
- For statistic only - this may vanish."
-
-%{ /* NOCONTEXT */
- extern int __newSpaceReclaimedMin();
-
- RETURN ( __MKSMALLINT(__newSpaceReclaimedMin()) );
+T(__newSpaceReclaimedMin()) );
%}
"
ObjectMemory minScavengeReclamation
"
!
-newSpaceSize
- "return the total size of the new space - this is usually fix"
-
-%{ /* NOCONTEXT */
- extern unsigned __newSpaceSize();
-
- RETURN ( __MKSMALLINT(__newSpaceSize()) );
+TURN ( __MKSMALLINT(__newSpaceSize()) );
%}
"
ObjectMemory newSpaceSize
"
!
-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 */
- extern unsigned __newSpaceUsed();
-
- RETURN ( __MKSMALLINT(__newSpaceUsed()) );
+N ( __MKSMALLINT(__newSpaceUsed()) );
%}
"
ObjectMemory newSpaceUsed
"
!
-numberOfObjects
- "return the number of objects in the system."
-
- |tally "{ Class: SmallInteger }"|
-
- tally := 0.
- self allObjectsDo:[:obj | tally := tally + 1].
+bj | tally := tally + 1].
^ tally
"
@@ -2939,224 +1878,117 @@
"
!
-numberOfWeakObjects
- "return the number of weak objects in the system"
-
-%{ /* NOCONTEXT */
- extern int __weakListSize();
-
- RETURN ( __MKSMALLINT(__weakListSize()) );
+__MKSMALLINT(__weakListSize()) );
%}
"
ObjectMemory numberOfWeakObjects
"
!
-oldSpaceAllocatedSinceLastGC
- "return the number of bytes allocated for old objects since the
- last oldspace garbage collect occured. This information is used
- by ProcessorScheduler to decide when to start the incremental
- background GC."
-
-%{ /* NOCONTEXT */
- extern unsigned __oldSpaceAllocatedSinceLastGC();
-
- RETURN ( __MKSMALLINT(__oldSpaceAllocatedSinceLastGC()) );
+atedSinceLastGC()) );
%}
"
ObjectMemory oldSpaceAllocatedSinceLastGC
"
!
-oldSpaceSize
- "return the total size of the old space. - may grow slowly"
-
-%{ /* NOCONTEXT */
- extern unsigned __oldSpaceSize();
-
- RETURN ( __MKSMALLINT(__oldSpaceSize()) );
+TURN ( __MKSMALLINT(__oldSpaceSize()) );
%}
"
ObjectMemory oldSpaceSize
"
!
-oldSpaceUsed
- "return the number of bytes allocated for old objects.
- (This includes the free lists)"
-
-%{ /* NOCONTEXT */
- extern unsigned __oldSpaceUsed();
-
- RETURN ( __MKSMALLINT(__oldSpaceUsed()) );
+RN ( __MKSMALLINT(__oldSpaceUsed()) );
%}
"
ObjectMemory oldSpaceUsed
"
!
-rememberedSetSize
- "return the number of old objects referencing new ones.
- This is a VM debugging interface and may vanish without notice."
-
-%{ /* NOCONTEXT */
- extern int __rememberedSetSize();
-
- RETURN (__MKSMALLINT(__rememberedSetSize()));
+MKSMALLINT(__rememberedSetSize()));
%}
"
ObjectMemory rememberedSetSize
"
!
-resetMinScavengeReclamation
- "resets the number of bytes replacimed by the least effective scavenge.
- For statistic only - this may vanish."
-
-%{ /* NOCONTEXT */
- extern int __resetNewSpaceReclaimedMin();
-
- __resetNewSpaceReclaimedMin();
-%}.
- ^ self
- "
- ObjectMemory resetMinScavengeReclamation.
+jectMemory resetMinScavengeReclamation.
ObjectMemory minScavengeReclamation
"
!
-runsSingleOldSpace
- "return true, if the system runs in a single oldSpace or
- false if not.
- The memory system will always drop the second semispace when
- running out of virtual memory, or the baker-limit is reached.
- OBSOLETE:
- the system may now decide at any time to switch between
- single and double-space algorithms, depending on the overall memory
- size. You will now almost always get false as result, since the
- second semispace is only allocated when needed, and released
- immediately afterwards.
- "
-
-%{ /* NOCONTEXT */
- extern int __runsSingleOldSpace();
-
- RETURN ( (__runsSingleOldSpace() ? true : false) );
+ngleOldSpace() ? true : false) );
%}
"
ObjectMemory runsSingleOldSpace
"
!
-scavengeCount
- "return the number of scavenges that occurred since startup"
-
-%{ /* NOCONTEXT */
- extern int __scavengeCount();
-
- RETURN (__MKSMALLINT(__scavengeCount()));
+URN (__MKSMALLINT(__scavengeCount()));
%}
"
ObjectMemory scavengeCount
"
!
-symSpaceSize
- "return the total size of the sym space."
-
-%{ /* NOCONTEXT */
- extern unsigned __symSpaceSize();
-
- RETURN ( __MKSMALLINT(__symSpaceSize()) );
+TURN ( __MKSMALLINT(__symSpaceSize()) );
%}
"
ObjectMemory symSpaceSize
"
!
-symSpaceUsed
- "return the number of bytes allocated for old objects in sym space."
-
-%{ /* NOCONTEXT */
- extern unsigned __symSpaceUsed();
-
- RETURN ( __MKSMALLINT(__symSpaceUsed()) );
+TURN ( __MKSMALLINT(__symSpaceUsed()) );
%}
"
ObjectMemory symSpaceUsed
"
!
-tenureAge
- "return the current tenure age - thats the number of times
- an object has to survive scavenges to be moved into oldSpace.
- For statistic/debugging only - this method may vanish"
-
-%{ /* NOCONTEXT */
+*/
extern unsigned __tenureAge();
RETURN ( __MKSMALLINT(__tenureAge()) );
%}
!
-whoReferences:anObject
- "return a collection of objects referencing the argument, anObject"
-
- ^ self collectObjectsWhich:[:o | o references:anObject]
+references:anObject]
"
(ObjectMemory whoReferences:Transcript) printNL
"
!
-whoReferencesDerivedInstancesOf:aClass
- "return a collection of objects refering to instances
- of the argument, aClass or a subclass of it."
-
- ^ self collectObjectsWhich:[:o | o referencesDerivedInstanceOf:aClass]
+:aClass]
"
(ObjectMemory whoReferencesDerivedInstancesOf:View) printNL
"
-!
-
-whoReferencesInstancesOf:aClass
- "return a collection of objects refering to instances
- of the argument, aClass"
-
- ^ self collectObjectsWhich:[:o | o referencesInstanceOf:aClass]
-
- "
- (ObjectMemory whoReferencesInstancesOf:SystemBrowser) printNL
- "
! !
!ObjectMemory class methodsFor:'semaphore access'!
-lowSpaceSemaphore
- "return the semaphore that is signalled when the system detects a
- low space condition. Usually, some time after this, an allocationFailure
- will happen. You can have a cleanup process sitting in that semaphore and
- start to release object."
-
- ^ LowSpaceSemaphore
+sOf:SystemBrowser) printNL
+ "
! !
!ObjectMemory class methodsFor:'statistics'!
-ageStatistic
-%{ /* NOCONTEXT */
+ease object."
- __ageStatistics();
-%}
+ ^ LowSpaceSemaphore
! !
!ObjectMemory class methodsFor:'system management'!
-allBinaryModulesDo:aBlock
- "internal private method - walk over all known binary
- modules and evaluate aBlock for each entry.
- Do not depend on the information returned for each - this may
+T */
+
+ __ageStatistics();
+%}
+!
+
+ay
change without notice."
%{
@@ -3164,135 +1996,19 @@
%}
!
-binaryModuleInfo
- "return a collection of moduleInfo entries.
- This returns a dictionary (keys are internal moduleIDs)
- with one entry for each binary package."
-
- |modules|
-
- modules := IdentityDictionary new.
- self allBinaryModulesDo:[:entry |
- |id name type libName subModuleName module dynamic infoRec pathName
- typeName nameString|
-
- id := entry at:1.
- subModuleName := (entry at:2) asSymbol.
- libName := (entry at:4).
-
- id > 0 ifTrue:[
- pathName := ObjectFileLoader pathNameFromID:id.
- dynamic := true.
- typeName := 'dynamic '.
- name := pathName asFilename baseName
- ] ifFalse:[
- dynamic := false.
- typeName := 'builtIn '.
- pathName := nil.
- libName isNil ifTrue:[
- name := subModuleName
- ] ifFalse:[
- name := libName
- ].
- ].
- nameString := typeName.
- libName isNil ifTrue:[
- nameString := nameString, 'module '
- ] ifFalse:[
- nameString := nameString, 'classLib '
- ].
- nameString := nameString , name.
-
- libName isNil ifTrue:[
- type := #classObject
- ] ifFalse:[
- type := #classLibrary
- ].
- infoRec := modules at:id ifAbsent:nil.
- infoRec notNil ifTrue:[
- (infoRec at:#classNames) add:subModuleName
- ] ifFalse:[
- infoRec := IdentityDictionary new.
- infoRec at:#id put:id.
- infoRec at:#classNames put:(Set with:subModuleName).
- infoRec at:#pathName put:pathName.
- infoRec at:#name put:nameString.
- infoRec at:#libraryName put:libName.
- infoRec at:#dynamic put:dynamic.
- infoRec at:#type put:type.
- modules at:id put:infoRec.
- ].
- ].
- ^ modules
-
- "
- ObjectMemory binaryModuleInfo
+ObjectMemory binaryModuleInfo
"
"Modified: 17.9.1995 / 16:33:02 / claus"
!
-fullBinaryModuleInfo
- "return a full collection of moduleInfo entries.
- This returns a dictionary (keys are component names)
- with one entry for each component in all binary packages."
-
- |modules|
-
- modules := IdentityDictionary new.
- self allBinaryModulesDo:[:entry |
- |id name type libName subModuleName module dynamic infoRec pathName
- t|
-
- id := entry at:1.
- subModuleName := (entry at:2) asSymbol.
- libName := (entry at:4).
- t := AbsoluteTime fromOSTime:(entry at:5).
-
- id > 0 ifTrue:[
- dynamic := true.
- ] ifFalse:[
- dynamic := false.
- ].
- libName isNil ifTrue:[
- type := #classObject
- ] ifFalse:[
- type := #classLibrary
- ].
- infoRec := IdentityDictionary new.
- infoRec at:#id put:id.
- infoRec at:#className put:subModuleName.
- infoRec at:#libraryName put:libName.
- infoRec at:#dynamic put:dynamic.
- infoRec at:#type put:type.
- infoRec at:#timeStamp put:t.
- modules at:subModuleName put:infoRec.
- ].
- ^ modules
-
- "
- ObjectMemory fullBinaryModuleInfo
+ObjectMemory fullBinaryModuleInfo
"
"Modified: 30.8.1995 / 17:29:30 / claus"
!
-imageBaseName
- "return a reasonable filename to use as baseName (i.e. without extension).
- This is the filename of the current image (without '.img') or,
- if not running from an image, the default name 'st'"
-
- |nm|
-
- nm := ImageName.
- (nm isNil or:[nm isBlank]) ifTrue:[
- ^ 'st'
- ].
- (nm endsWith:'.sav') ifTrue:[
- nm := nm copyWithoutLast:4
- ].
- (nm endsWith:'.img') ifTrue:[
- ^ nm copyWithoutLast:4
+nm copyWithoutLast:4
].
^ nm
@@ -3301,9 +2017,7 @@
"
!
-imageName
- "return the filename of the current image, or nil
- if not running from an image."
+not running from an image."
^ ImageName
@@ -3312,44 +2026,18 @@
"
!
-imageSaveTime
- "return a timestamp for when the running image was saved.
+g image was saved.
Return nil if not running from an image."
^ ImageSaveTime
!
-loadClassBinary:aClassName
- "find the object file for aClassName and -if found - load it;
- this one loads precompiled object files"
-
- |fName newClass|
-
- fName := self fileNameForClass:aClassName.
- fName notNil ifTrue:[
- Class withoutUpdatingChangesDo:
- [
- self loadBinary:(fName , '.o')
- ].
- newClass := self at:(aClassName asSymbol).
- (newClass notNil and:[newClass implements:#initialize]) ifTrue:[
+tNil and:[newClass implements:#initialize]) ifTrue:[
newClass initialize
]
]
!
-nameForChanges
- "return a reasonable filename to store the changes into.
- Currently, this is defined in a classVariable and defaults to 'changes'.
- In future versions, this will be the basename of the current image with '.img' replaced
- by '.chg', or, if not running from an image, the default name 'st.chg'."
-
- ChangeFileName notNil ifTrue:[^ ChangeFileName].
- ^ 'changes'.
-
-"/ future versions will have:
-"/ (requires some additionas at other places)
-"/
"/ ^ self imageBaseName , '.chg'
"
@@ -3357,32 +2045,21 @@
"
!
-nameForChanges:aFilename
- "set the name of the file where changes are stored into."
-
- ChangeFileName := aFilename
+ngeFileName := aFilename
"
ObjectMemory nameForChanges:'myChanges'
"
!
-nameForSnapshot
- "return a reasonable filename to store the snapshot image into.
- This is the filename of the current image or,
- if not running from an image, the default name 'st.img'"
-
- ^ self imageBaseName , '.img'
+^ self imageBaseName , '.img'
"
ObjectMemory nameForSnapshot
"
!
-nameForSources
- "return a reasonable filename to store the sources into.
- This is the basename of the current image with '.img' replaced
- by '.src', or, if not running from an image, the default name 'st.src'"
+"
^ self imageBaseName , '.src'
@@ -3391,105 +2068,25 @@
"
!
-primSnapShotOn:aFileName
- "create a snapshot in the given file.
- Low level entry. Does not notify classes or write an entry to
- the changes file. Also, no image backup is created. Returns true if
- the snapshot worked, false if it failed for some reason.
- This method should not be used in normal cases."
-
- |ok|
-
-%{ /* STACK:32000 */
-
- OBJ __snapShotOn();
- OBJ funny = @symbol(funnySnapshotSymbol);
-
- if (__isString(aFileName)) {
- __BLOCKINTERRUPTS();
- ok = __snapShotOn(__context, _stringVal(aFileName), funny);
+n(__context, _stringVal(aFileName), funny);
__UNBLOCKINTERRUPTS();
}
%}.
^ ok
!
-snapShot
- "create a snapshot file containing all of the current state."
+."
self snapShotOn:(self nameForSnapshot)
"
ObjectMemory snapShot
"
-!
-
-snapShotOn:aFileName
- "create a snapshot in the given file.
- If the file exists, save it for backup.
- Return true if the snapshot worked, false if it failed for some reason.
- Notify dependents before and after the snapshot operation."
-
- |ok oldImageName oldImageTime|
-
- "
- keep a save version - just in case something
- bad happens while writing the image.
- (could be st/x internal error or file-system errors etc)
- "
- (OperatingSystem isValidPath:aFileName) ifTrue:[
- OperatingSystem renameFile:aFileName to:(aFileName , '.sav').
- ].
-
- "
- give others a chance to fix things
- "
- self changed:#save. "/ will vanish ...
- self changed:#aboutToSnapshot. "/ ... for ST-80 compatibility
-
- "
- ST-80 compatibility; send #preSnapshot to all classes
- "
- Smalltalk allBehaviorsDo:[:aClass |
- aClass preSnapshot
- ].
-
- "
- save the name with it ...
- "
- oldImageName := ImageName.
- oldImageTime := ImageSaveTime.
-
- ImageName := aFileName.
- ImageSaveTime := AbsoluteTime now.
-
- ok := self primSnapShotOn:aFileName.
-
- ImageName := oldImageName.
- ImageSaveTime := oldImageTime.
-
- ok ifTrue:[
- Class addChangeRecordForSnapshot:aFileName.
- ].
-
-
- "
- ST-80 compatibility; send #postSnapshot to all classes
- "
- Smalltalk allBehaviorsDo:[:aClass |
- aClass postSnapshot
- ].
- self changed:#finishedSnapshot. "/ ST-80 compatibility
- ^ ok
-
- "
- ObjectMemory snapShotOn:'myimage.img'
- "
! !
!ObjectMemory class methodsFor:'documentation'!
-version
- ^ '$Header: /cvs/stx/stx/libbasic/ObjectMemory.st,v 1.99 1996-04-12 16:32:17 cg Exp $'
+mory snapShotOn:'myimage.img'
+ "
! !
ObjectMemory initialize!
--- a/Project.st Thu Apr 25 13:16:22 1996 +0200
+++ b/Project.st Thu Apr 25 18:02:18 1996 +0200
@@ -68,6 +68,9 @@
- allow building of whatever the target (as defined by the type) is
(this will allow build of class libs and apps by clicking a button)
- allow removal of project specific classes, methods etc.
+
+ [author:]
+ Claus Gittinger
"
! !
@@ -831,5 +834,5 @@
!Project class methodsFor:'documentation'!
version
-^ '$Header: /cvs/stx/stx/libbasic/Project.st,v 1.38 1996-03-22 14:49:40 cg Exp $'! !
+^ '$Header: /cvs/stx/stx/libbasic/Project.st,v 1.39 1996-04-25 16:00:54 cg Exp $'! !
Project initialize!
--- a/Registry.st Thu Apr 25 13:16:22 1996 +0200
+++ b/Registry.st Thu Apr 25 18:02:18 1996 +0200
@@ -11,10 +11,10 @@
"
Object subclass:#Registry
- instanceVariableNames:'registeredObjects handleArray cleanState'
- classVariableNames:''
- poolDictionaries:''
- category:'System-Support'
+ instanceVariableNames:'registeredObjects handleArray cleanState'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'System-Support'
!
!Registry class methodsFor:'documentation'!
@@ -57,8 +57,15 @@
return a stub (placeHolder) object. (i.e. there is no need for the copy to be
of the same class as the original, as long as it implements disposed and frees
the relevant OS resources ...)
+ Example uses are found in Form, Color, ExternalStream and Font
- See axample uses in Form, Color, ExternalStream and Font
+ [author:]
+ Claus Gittinger
+
+ [see also:]
+ WeakArray WeakIdentityDictionary WeakIdentitySet
+ Font Form Color Cursor ExternalStream
+
"
! !
@@ -214,5 +221,5 @@
!Registry class methodsFor:'documentation'!
version
- ^ '$Header: /cvs/stx/stx/libbasic/Registry.st,v 1.23 1996-04-09 20:49:15 cg Exp $'
+ ^ '$Header: /cvs/stx/stx/libbasic/Registry.st,v 1.24 1996-04-25 15:59:38 cg Exp $'
! !
--- a/Smalltalk.st Thu Apr 25 13:16:22 1996 +0200
+++ b/Smalltalk.st Thu Apr 25 18:02:18 1996 +0200
@@ -50,60 +50,63 @@
It may change to become a subclass of collection at some time ...
- Instance variables:
- none - all handling is done in the VM
-
- Class variables:
-
- ExitBlocks <Collection> blocks to evaluate before system is
- left. Not currently used (GNU-ST compatibility).
-
- SystemPath <Collection> path to search for system files (sources, bitmaps etc)
- Set to a default here, but typically changed from some
- startup.rc file
-
- StartupClass <Class>
- StartupSelector <Symbol>
- StartupArguments <Array>
- class and selector, where the system starts up
- (right after VM initialization)
- If an image is saved while this is nonNil, the image will come up
- there.
-
- CommandLineArguments <Array> command line broken into words
-
- SilentLoading <Boolean> suppresses messages during fileIn and in compiler
- (can be set to true from a customized main)
-
- LogDoits <Boolean> if true, doits are also logged in the changes
- file. Default is false, since the changes file
- may become huge if every tiny doIt is saved there ...
-
- LoadBinaries <Boolean> if true, we attempt to load classes rom a binary
- file, if present. If false, this is always suppressed.
-
- ImageStartTime <AbsoluteTime> timestamp when this system was started the very first time
- (i.e. the time of the initial start without an image)
-
- ImageRestartTime
- <AbsoluteTIme> timestamp when this image was started
+ [Instance variables:]
+ none - all handling is done in the VM
+
+ [Class variables:]
+
+ ExitBlocks <Collection> blocks to evaluate before system is
+ left. Not currently used (GNU-ST compatibility).
+
+ SystemPath <Collection> path to search for system files (sources, bitmaps etc)
+ Set to a default here, but typically changed from some
+ startup.rc file
+
+ StartupClass <Class>
+ StartupSelector <Symbol>
+ StartupArguments <Array>
+ class and selector, where the system starts up
+ (right after VM initialization)
+ If an image is saved while this is nonNil, the image will come up
+ there.
+
+ CommandLineArguments <Array> command line broken into words
+
+ SilentLoading <Boolean> suppresses messages during fileIn and in compiler
+ (can be set to true from a customized main)
+
+ LogDoits <Boolean> if true, doits are also logged in the changes
+ file. Default is false, since the changes file
+ may become huge if every tiny doIt is saved there ...
+
+ LoadBinaries <Boolean> if true, we attempt to load classes rom a binary
+ file, if present. If false, this is always suppressed.
+
+ ImageStartTime <AbsoluteTime> timestamp when this system was started the very first time
+ (i.e. the time of the initial start without an image)
+
+ ImageRestartTime
+ <AbsoluteTIme> timestamp when this image was started
strictly private classVariables (helpers):
- CachedClasses <Collection> known classes (cached for faster class enumeration)
-
- CachedAbbreviations
- <Dictionary> className to filename mappings
-
- SourcePath <Collection> cached names of really existing directories
- BitmapPath These are remembered, since in NFS systems,
- ResourcePath the time to lookup files may become long
- BinaryPath (especially, if some directories are on machines
- FileInPath which are not up ...). Therefore, the set of really
- existing directories is cached when the SystemPath
- is walked the first time.
+ CachedClasses <Collection> known classes (cached for faster class enumeration)
+
+ CachedAbbreviations
+ <Dictionary> className to filename mappings
+
+ SourcePath <Collection> cached names of really existing directories
+ BitmapPath These are remembered, since in NFS systems,
+ ResourcePath the time to lookup files may become long
+ BinaryPath (especially, if some directories are on machines
+ FileInPath which are not up ...). Therefore, the set of really
+ existing directories is cached when the SystemPath
+ is walked the first time.
+
+ [author:]
+ Claus Gittinger
"
! !
@@ -2994,5 +2997,5 @@
!Smalltalk class methodsFor:'documentation'!
version
- ^ '$Header: /cvs/stx/stx/libbasic/Smalltalk.st,v 1.135 1996-04-19 10:49:01 cg Exp $'
+ ^ '$Header: /cvs/stx/stx/libbasic/Smalltalk.st,v 1.136 1996-04-25 16:02:18 cg Exp $'
! !
--- a/Unix.st Thu Apr 25 13:16:22 1996 +0200
+++ b/Unix.st Thu Apr 25 18:02:18 1996 +0200
@@ -748,40 +748,47 @@
Unix are supported, the corresponding class will be bound to the
global variable OperatingSystem.
- Class variables:
-
- HostName <String> remembered hostname
-
- DomainName <String> remembered domainname
-
- LastErrorNumber <Integer> the last value of errno
-
- LastExecStatus <Integer> the returned exec status after
- the last call of system
-
- OSSignals <Array> Array of signals to be raised for corresponding
- OperatingSystem signals.
-
- ForkFailed <Boolean> set if a fork (or popen) has failed;
- ST/X will avoid doing more forks/popens
- if this flag is set, for a slightly
- smoother operation.
-
- SlowFork <Boolean> if set, fork and popen are avoided;
- (more or less obsolete now)
-
-
- ErrorSignal <Signal> Parentsignal of all OS error signals.
- not directly raised.
-
- AccessDeniedErrorSignal
-
- FileNotFoundErrorSignal
-
- LocaleInfo <Dictionary> if non nil, that is taken instead of the operating
- systems locale definitions (allows for overwriting
- these, or provide a compatible info on systems which do
- not support locales)
+ [Class variables:]
+
+ HostName <String> remembered hostname
+
+ DomainName <String> remembered domainname
+
+ LastErrorNumber <Integer> the last value of errno
+
+ LastExecStatus <Integer> the returned exec status after
+ the last call of system
+
+ OSSignals <Array> Array of signals to be raised for corresponding
+ OperatingSystem signals.
+
+ ForkFailed <Boolean> set if a fork (or popen) has failed;
+ ST/X will avoid doing more forks/popens
+ if this flag is set, for a slightly
+ smoother operation.
+
+ SlowFork <Boolean> if set, fork and popen are avoided;
+ (more or less obsolete now)
+
+
+ ErrorSignal <Signal> Parentsignal of all OS error signals.
+ not directly raised.
+
+ AccessDeniedErrorSignal
+
+ FileNotFoundErrorSignal
+
+ LocaleInfo <Dictionary> if non nil, that is taken instead of the operating
+ systems locale definitions (allows for overwriting
+ these, or provide a compatible info on systems which do
+ not support locales)
+
+ [author:]
+ Claus Gittinger
+
+ [see also:]
+ Filename Date Time
+ ExternalStream FileStream PipeStream Socket
"
! !
@@ -7355,6 +7362,6 @@
!OperatingSystem class methodsFor:'documentation'!
version
- ^ '$Header: /cvs/stx/stx/libbasic/Attic/Unix.st,v 1.138 1996-04-25 08:29:51 stefan Exp $'
+ ^ '$Header: /cvs/stx/stx/libbasic/Attic/Unix.st,v 1.139 1996-04-25 16:00:14 cg Exp $'
! !
OperatingSystem initialize!