--- a/ObjectMemory.st Tue Feb 04 21:09:59 2014 +0100
+++ b/ObjectMemory.st Wed Apr 01 10:20:10 2015 +0100
@@ -11,6 +11,8 @@
"
"{ Package: 'stx:libbasic' }"
+"{ NameSpace: Smalltalk }"
+
Object subclass:#ObjectMemory
instanceVariableNames:''
classVariableNames:'InternalErrorHandler UserInterruptHandler TimerInterruptHandler
@@ -669,33 +671,35 @@
initialize
"initialize the class"
+ "/ protect against double initialization
AllocationFailureSignal isNil ifTrue:[
- AllocationFailureSignal := AllocationFailure.
- AllocationFailureSignal notifierString:'allocation failure'.
-
- MallocFailureSignal := MallocFailure.
- MallocFailureSignal notifierString:'(malloc) allocation failure'.
-
- LowSpaceSemaphore := Semaphore new name:'LowSpaceSemaphore'
- ].
- DisposeInterruptHandler := self.
-
- "/ BackgroundCollectMaximumInterval := 3600. "/ run it at least once an hour
- BackgroundCollectMaximumInterval := nil. "/ only run when space situation makes it feasable
- IncrementalGCLimit := 500000. "/ run it whenever 500k have been allocated
- FreeSpaceGCLimit := FreeSpaceGCAmount := nil. "/ no minumum-freeSpace trigger.
- MemoryInterruptHandler := self.
- ExceptionInterruptHandler := self.
-
- VMSelectors := #( #noByteCode #invalidCodeObject #invalidByteCode #invalidInstruction
- #tooManyArguments #badLiteralTable #receiverNotBoolean: #typeCheckError
- #integerCheckError #wrongNumberOfArguments: #privateMethodCalled
- #doesNotUnderstand: #invalidReturn: #invalidReturnOrRestart:
- #userInterrupt #internalError: #spyInterrupt #timerInterrupt #stepInterrupt
- #errorInterrupt:with: #disposeInterrupt #recursionInterrupt
- #memoryInterrupt #fpExceptionInterrupt #signalInterrupt: #childSignalInterrupt
- #ioInterrupt #customInterrupt #schedulerInterrupt #contextInterrupt
- #interruptLatency:receiver:class:selector:vmActivity:id:).
+ AllocationFailureSignal := AllocationFailure.
+ AllocationFailureSignal notifierString:'allocation failure'.
+
+ MallocFailureSignal := MallocFailure.
+ MallocFailureSignal notifierString:'(malloc) allocation failure'.
+
+ LowSpaceSemaphore := Semaphore new name:'LowSpaceSemaphore'.
+
+ DisposeInterruptHandler := self.
+
+ "/ BackgroundCollectMaximumInterval := 3600. "/ run it at least once an hour
+ BackgroundCollectMaximumInterval := nil. "/ only run when space situation makes it feasable
+ IncrementalGCLimit := 500000. "/ run it whenever 500k have been allocated
+ FreeSpaceGCLimit := FreeSpaceGCAmount := nil. "/ no minumum-freeSpace trigger.
+ MemoryInterruptHandler := self.
+ ExceptionInterruptHandler := self.
+
+ VMSelectors := #( #noByteCode #invalidCodeObject #invalidByteCode #invalidInstruction
+ #tooManyArguments #badLiteralTable #receiverNotBoolean: #typeCheckError
+ #integerCheckError #wrongNumberOfArguments: #privateMethodCalled
+ #doesNotUnderstand: #invalidReturn: #invalidReturnOrRestart:
+ #userInterrupt #internalError: #spyInterrupt #timerInterrupt #stepInterrupt
+ #errorInterrupt:with: #disposeInterrupt #recursionInterrupt
+ #memoryInterrupt #fpExceptionInterrupt #signalInterrupt: #childSignalInterrupt
+ #ioInterrupt #customInterrupt #schedulerInterrupt #contextInterrupt
+ #interruptLatency:receiver:class:selector:vmActivity:id:).
+ ]
"Modified: / 5.8.1998 / 15:30:12 / cg"
! !
@@ -948,14 +952,14 @@
Occasionally, the VM needs to unwind-protect some C code.
If so, it creates and artificial context on the stack and
marks it for unwind, so stack unwinding logic finds it
- and handles it.
+ and handles it.
Now, only #lookupMethodForSelectorUnwindProtect is supported
(ensures the lookup is popped out from the lookupActications)
"
aContext selector == #lookupMethodForSelectorUnwindHandlerFor: ifTrue:[
- ^[self lookupMethodForSelectorUnwindHandlerFor: (aContext argAt: 1)]
- ].
+ ^[self lookupMethodForSelectorUnwindHandlerFor: (aContext argAt: 1)]
+ ].
self internalError:'Unknown VM unwind protect action'
@@ -1067,6 +1071,15 @@
self flushInlineCachesWithArgs:(aSelector numArgs).
!
+flushCachesForSelector:aSelector numArgs:numArgs
+ "flush method and inline caches for aSelector"
+
+ self flushMethodCacheForSelector:aSelector.
+
+ "/ self flushInlineCachesForSelector:aSelector.
+ self flushInlineCachesWithArgs:numArgs.
+!
+
flushInlineCaches
"flush all inlinecaches"
@@ -1418,9 +1431,8 @@
numObjectsDone := 0.
found := false.
- AbortOperationRequest handle:[]
- do:[
- [self allObjectsIncludingContextsDo:[:o |
+ AbortOperationRequest catch:[
+ self allObjectsIncludingContextsDo:[:o |
|inPrevLevel isOwner|
stop ifTrue:[AbortOperationRequest raise].
@@ -1470,7 +1482,7 @@
]
]
]
- ]] whileFalse.
+ ].
].
progress percentage:100.
@@ -1544,7 +1556,7 @@
progress beInvisible.
chain addFirst:Smalltalk.
- list := OrderedCollection withSize:chain size.
+ list := OrderedCollection newWithSize:chain size.
1 to:chain size-1 do:[:i |
list
at:i
@@ -1791,7 +1803,7 @@
startingAt:(index+1).
chain notNil ifTrue:[
- (levels at:index) saveRemove:el.
+ (levels at:index) safeRemove:el.
chain addFirst:el. "/ (self refNameFor:el in:start).
^ chain.
]
@@ -1850,7 +1862,7 @@
startingAt:(index+1).
chain size > 0 ifTrue:[
- (levels at:index) saveRemove:el.
+ (levels at:index) safeRemove:el.
c := chain copy.
c addFirst:el "(self refNameFor:el in:start)".
@@ -1886,6 +1898,9 @@
] ifFalse:[
names := referent class allInstVarNames.
oClass := referent class.
+ oClass == anObject ifTrue:[
+ ^ oClass name.
+ ].
1 to:oClass instSize do:[:i |
((referent instVarAt:i) == anObject) ifTrue:[
^ '%1 [%2]' bindWith:referent classNameWithArticle with:(names at:i) allBold.
@@ -2316,40 +2331,40 @@
|done limit|
AbortOperationRequest handle:[:ex |
- "/ in case of abort (from the debugger),
- "/ disable gcSteps.
- done := true.
- IncrementalGCLimit := FreeSpaceGCLimit := nil.
- 'ObjectMemory [error]: IGC aborted; turning off incremental GC' errorPrintCR
+ "/ in case of abort (from the debugger),
+ "/ disable gcSteps.
+ done := true.
+ IncrementalGCLimit := FreeSpaceGCLimit := nil.
+ 'ObjectMemory [error]: IGC aborted; turning off incremental GC' errorPrintCR
] do:[
- limit := IncrementalGCLimit.
- (limit notNil and:[self oldSpaceAllocatedSinceLastGC > limit]) ifTrue:[
+ limit := IncrementalGCLimit.
+ (limit notNil and:[self oldSpaceAllocatedSinceLastGC > limit]) ifTrue:[
"/ 'IGC [info]: start since allocatedSinceLastGC > IncrementalGCLimit' infoPrintCR.
- done := ObjectMemory gcStep
- ] ifFalse:[
- limit := FreeSpaceGCLimit.
- (limit notNil and:[(self freeSpace + self freeListSpace) < limit]) ifTrue:[
+ done := ObjectMemory gcStep
+ ] ifFalse:[
+ limit := FreeSpaceGCLimit.
+ (limit notNil and:[(self freeSpace + self freeListSpace) < limit]) ifTrue:[
"/ 'IGC [info]: start since freeSpace < FreeSpaceGCLimit' infoPrintCR.
- done := ObjectMemory gcStep.
- done ifTrue:[
- self moreOldSpaceIfUseful
- ].
- ] ifFalse:[
- limit := DynamicCodeGCTrigger.
- (limit notNil and:[self compiledCodeCounter > limit]) ifTrue:[
+ done := ObjectMemory gcStep.
+ done ifTrue:[
+ self moreOldSpaceIfUseful
+ ].
+ ] ifFalse:[
+ limit := DynamicCodeGCTrigger.
+ (limit notNil and:[self compiledCodeCounter > limit]) ifTrue:[
"/ 'IGC [info]: start since compiledCodeCounter > DynamicCodeGCTrigger' infoPrintCR.
- done := ObjectMemory gcStep.
- ] ifFalse:[
- limit := DynamicCodeLimit.
- (limit notNil and:[self compiledCodeSpaceUsed > limit]) ifTrue:[
+ done := ObjectMemory gcStep.
+ ] ifFalse:[
+ limit := DynamicCodeLimit.
+ (limit notNil and:[self compiledCodeSpaceUsed > limit]) ifTrue:[
"/ 'IGC [info]: start since compiledCodeSpaceUsed > DynamicCodeLimit' infoPrintCR.
- done := ObjectMemory gcStep.
- ] ifFalse:[
- done := true
- ]
- ]
- ]
- ].
+ done := ObjectMemory gcStep.
+ ] ifFalse:[
+ done := true
+ ]
+ ]
+ ]
+ ].
].
^ done not
@@ -2506,7 +2521,7 @@
doGC := self gcStepIfUseful.
doGC ifFalse:[
(BackgroundCollectMaximumInterval notNil
- and:[(Timestamp now getSeconds - timeOfLastGC getSeconds) > BackgroundCollectMaximumInterval])
+ and:[(Timestamp now secondDeltaFrom: timeOfLastGC) > BackgroundCollectMaximumInterval])
ifTrue:[
"/ 'ObjectMemory [info]: start time-triggered background collect.' infoPrintCR.
doGC := true.
@@ -4172,7 +4187,7 @@
self allChangedShadowObjectsDo:[:aShadowArray |
Error handle:[:ex |
- 'ObjectMemory [warning]: cought error in weakArray processing: ' errorPrint.
+ 'ObjectMemory [warning]: caught error in weakArray processing: ' errorPrint.
ex description errorPrintCR.
ex suspendedContext fullPrintAllLevels:10.
"Restart the do block to clean up the rest of the shadow array.
@@ -4385,7 +4400,7 @@
%}
"
- self collectedOldSpaceAddress
+ self collectedOldSpaceAddress
"
!
@@ -4725,7 +4740,7 @@
%}
"
- self oldSpaceAddress
+ self oldSpaceAddress
"
!
@@ -5041,66 +5056,66 @@
modules := IdentityDictionary new.
self allBinaryModulesDo:[:idArg :nameArg :flagsArg :libName :timeStamp |
- |type subModuleName module dynamic infoRec handle pathName
- typeName name nameString|
-
- nameArg class == String ifFalse:[
- 'Error in binaryModuleInfo - skip entry' errorPrintCR.
- ] ifTrue:[
- name := nameArg.
- subModuleName := name asSymbol.
-
- idArg > 0 ifTrue:[
- dynamic := true.
- typeName := 'dynamic '.
- handle := ObjectFileLoader handleFromID:idArg.
- (handle isNil or:[(pathName := handle pathName) isNil]) ifTrue:[
- name := '?'
- ] ifFalse:[
- 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:idArg ifAbsent:nil.
- infoRec notNil ifTrue:[
- infoRec classNames add:subModuleName.
- ] ifFalse:[
- infoRec := BinaryModuleDescriptor
- name:nameString
- type:type
- id:idArg
- dynamic:dynamic
- classNames:( (OrderedSet ? Set) with:subModuleName)
- handle:handle
- pathName:pathName
- libraryName:libName
- timeStamp:nil.
-
- modules at:idArg put:infoRec.
- ].
- ].
+ |type subModuleName module dynamic infoRec handle pathName
+ typeName name nameString|
+
+ nameArg isString ifFalse:[
+ 'Error in binaryModuleInfo - skip entry' errorPrintCR.
+ ] ifTrue:[
+ name := nameArg.
+ subModuleName := name asSymbol.
+
+ idArg > 0 ifTrue:[
+ dynamic := true.
+ typeName := 'dynamic '.
+ handle := ObjectFileLoader handleFromID:idArg.
+ (handle isNil or:[(pathName := handle pathName) isNil]) ifTrue:[
+ name := '?'
+ ] ifFalse:[
+ 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:idArg ifAbsent:nil.
+ infoRec notNil ifTrue:[
+ infoRec classNames add:subModuleName.
+ ] ifFalse:[
+ infoRec := BinaryModuleDescriptor
+ name:nameString
+ type:type
+ id:idArg
+ dynamic:dynamic
+ classNames:( (OrderedSet ? Set) with:subModuleName)
+ handle:handle
+ pathName:pathName
+ libraryName:libName
+ timeStamp:nil.
+
+ modules at:idArg put:infoRec.
+ ].
+ ].
].
^ modules
@@ -5130,6 +5145,30 @@
!ObjectMemory class methodsFor:'system management'!
+directoryForImageAndChangeFile
+ |dir exeDir|
+
+ dir := Filename currentDirectory.
+
+ "/ the current directory is not a good idea, if stx is started via a desktop manager
+ "/ or in osx, by clicking on stx.app.
+ dir isRootDirectory ifTrue:[
+ exeDir := OperatingSystem nameOfSTXExecutable asFilename directory.
+ dir ~= exeDir ifTrue:[
+ "/ Change it to ~/.smalltalk or is executable directory better?
+
+ "/ use executable dir, as otherwise I'd have to change the VM to include an image path...
+ "/ dir := Filename usersPrivateSmalltalkDirectory.
+ dir := exeDir.
+ ].
+ ].
+ ^ dir
+
+ "
+ self directoryForImageAndChangeFile
+ "
+!
+
imageBaseName
"return a reasonable filename to use as baseName (i.e. without extension).
This is the filename of the current image (without '.img') or,
@@ -5173,12 +5212,29 @@
^ ImageSaveTime
!
+initChangeFilename
+ "/ make the changeFilePath an absolute one,
+ "/ in case some stupid windows fileDialog changes the current directory...
+ self
+ nameForChanges:(self directoryForImageAndChangeFile / ObjectMemory nameForChangesLocal)
+ asAbsoluteFilename pathName
+
+ "
+ self initChangeFilename
+ "
+!
+
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'."
-
+ By default, this is the basename of the current image with '.img' replaced
+ by '.chg', or, if not running from an image, the default name 'st.chg'.
+ However, it can be overwritten via the nameForChanges: setter"
+
+ |nm|
+
+ (nm := UserPreferences current changeFileName) notNil ifTrue:[
+ ^ nm
+ ].
ChangeFileName notNil ifTrue:[^ ChangeFileName].
^ self nameForChangesLocal
@@ -5288,7 +5344,11 @@
the changes file must be copied to the new name.
No copy when the changes name is given explicitly."
- ChangeFileName notNil ifTrue: [ ^self].
+ ChangeFileName notNil ifTrue: [
+ ChangeFileName ~= self nameForChangesLocal ifTrue:[
+ ^ self
+ ]
+ ].
oldChangesName asFilename copyTo:self nameForChanges
"Created: / 15.5.2004 / 20:29:03 / masca"
@@ -5342,6 +5402,11 @@
(could be ST/X error or file-system errors etc.)
"
snapshotFilename := aFileName asFilename.
+ snapshotFilename isAbsolute ifFalse:[
+ snapshotFilename := self directoryForImageAndChangeFile
+ / snapshotFilename name.
+ ].
+
tempFilename := (FileStream newTemporaryIn:snapshotFilename directory)
close;
fileName.
@@ -5551,8 +5616,12 @@
!ObjectMemory class methodsFor:'documentation'!
+version
+ ^ '$Header: /cvs/stx/stx/libbasic/ObjectMemory.st,v 1.286 2015-02-20 22:45:22 cg Exp $'
+!
+
version_CVS
- ^ '$Header: /cvs/stx/stx/libbasic/ObjectMemory.st,v 1.272 2013-08-19 10:02:34 stefan Exp $'
+ ^ '$Header: /cvs/stx/stx/libbasic/ObjectMemory.st,v 1.286 2015-02-20 22:45:22 cg Exp $'
!
version_SVN