8 be provided or otherwise made available to, or used by, any |
8 be provided or otherwise made available to, or used by, any |
9 other person. No title to or ownership of the software is |
9 other person. No title to or ownership of the software is |
10 hereby transferred. |
10 hereby transferred. |
11 " |
11 " |
12 "{ Package: 'stx:libbasic' }" |
12 "{ Package: 'stx:libbasic' }" |
|
13 |
|
14 "{ NameSpace: Smalltalk }" |
13 |
15 |
14 Object subclass:#ObjectMemory |
16 Object subclass:#ObjectMemory |
15 instanceVariableNames:'' |
17 instanceVariableNames:'' |
16 classVariableNames:'InternalErrorHandler UserInterruptHandler TimerInterruptHandler |
18 classVariableNames:'InternalErrorHandler UserInterruptHandler TimerInterruptHandler |
17 SpyInterruptHandler StepInterruptHandler |
19 SpyInterruptHandler StepInterruptHandler |
667 !ObjectMemory class methodsFor:'initialization'! |
669 !ObjectMemory class methodsFor:'initialization'! |
668 |
670 |
669 initialize |
671 initialize |
670 "initialize the class" |
672 "initialize the class" |
671 |
673 |
|
674 "/ protect against double initialization |
672 AllocationFailureSignal isNil ifTrue:[ |
675 AllocationFailureSignal isNil ifTrue:[ |
673 AllocationFailureSignal := AllocationFailure. |
676 AllocationFailureSignal := AllocationFailure. |
674 AllocationFailureSignal notifierString:'allocation failure'. |
677 AllocationFailureSignal notifierString:'allocation failure'. |
675 |
678 |
676 MallocFailureSignal := MallocFailure. |
679 MallocFailureSignal := MallocFailure. |
677 MallocFailureSignal notifierString:'(malloc) allocation failure'. |
680 MallocFailureSignal notifierString:'(malloc) allocation failure'. |
678 |
681 |
679 LowSpaceSemaphore := Semaphore new name:'LowSpaceSemaphore' |
682 LowSpaceSemaphore := Semaphore new name:'LowSpaceSemaphore'. |
680 ]. |
683 |
681 DisposeInterruptHandler := self. |
684 DisposeInterruptHandler := self. |
682 |
685 |
683 "/ BackgroundCollectMaximumInterval := 3600. "/ run it at least once an hour |
686 "/ BackgroundCollectMaximumInterval := 3600. "/ run it at least once an hour |
684 BackgroundCollectMaximumInterval := nil. "/ only run when space situation makes it feasable |
687 BackgroundCollectMaximumInterval := nil. "/ only run when space situation makes it feasable |
685 IncrementalGCLimit := 500000. "/ run it whenever 500k have been allocated |
688 IncrementalGCLimit := 500000. "/ run it whenever 500k have been allocated |
686 FreeSpaceGCLimit := FreeSpaceGCAmount := nil. "/ no minumum-freeSpace trigger. |
689 FreeSpaceGCLimit := FreeSpaceGCAmount := nil. "/ no minumum-freeSpace trigger. |
687 MemoryInterruptHandler := self. |
690 MemoryInterruptHandler := self. |
688 ExceptionInterruptHandler := self. |
691 ExceptionInterruptHandler := self. |
689 |
692 |
690 VMSelectors := #( #noByteCode #invalidCodeObject #invalidByteCode #invalidInstruction |
693 VMSelectors := #( #noByteCode #invalidCodeObject #invalidByteCode #invalidInstruction |
691 #tooManyArguments #badLiteralTable #receiverNotBoolean: #typeCheckError |
694 #tooManyArguments #badLiteralTable #receiverNotBoolean: #typeCheckError |
692 #integerCheckError #wrongNumberOfArguments: #privateMethodCalled |
695 #integerCheckError #wrongNumberOfArguments: #privateMethodCalled |
693 #doesNotUnderstand: #invalidReturn: #invalidReturnOrRestart: |
696 #doesNotUnderstand: #invalidReturn: #invalidReturnOrRestart: |
694 #userInterrupt #internalError: #spyInterrupt #timerInterrupt #stepInterrupt |
697 #userInterrupt #internalError: #spyInterrupt #timerInterrupt #stepInterrupt |
695 #errorInterrupt:with: #disposeInterrupt #recursionInterrupt |
698 #errorInterrupt:with: #disposeInterrupt #recursionInterrupt |
696 #memoryInterrupt #fpExceptionInterrupt #signalInterrupt: #childSignalInterrupt |
699 #memoryInterrupt #fpExceptionInterrupt #signalInterrupt: #childSignalInterrupt |
697 #ioInterrupt #customInterrupt #schedulerInterrupt #contextInterrupt |
700 #ioInterrupt #customInterrupt #schedulerInterrupt #contextInterrupt |
698 #interruptLatency:receiver:class:selector:vmActivity:id:). |
701 #interruptLatency:receiver:class:selector:vmActivity:id:). |
|
702 ] |
699 |
703 |
700 "Modified: / 5.8.1998 / 15:30:12 / cg" |
704 "Modified: / 5.8.1998 / 15:30:12 / cg" |
701 ! ! |
705 ! ! |
702 |
706 |
703 !ObjectMemory class methodsFor:'Compatibility-ST80'! |
707 !ObjectMemory class methodsFor:'Compatibility-ST80'! |
946 to use. |
950 to use. |
947 |
951 |
948 Occasionally, the VM needs to unwind-protect some C code. |
952 Occasionally, the VM needs to unwind-protect some C code. |
949 If so, it creates and artificial context on the stack and |
953 If so, it creates and artificial context on the stack and |
950 marks it for unwind, so stack unwinding logic finds it |
954 marks it for unwind, so stack unwinding logic finds it |
951 and handles it. |
955 and handles it. |
952 |
956 |
953 Now, only #lookupMethodForSelectorUnwindProtect is supported |
957 Now, only #lookupMethodForSelectorUnwindProtect is supported |
954 (ensures the lookup is popped out from the lookupActications) |
958 (ensures the lookup is popped out from the lookupActications) |
955 " |
959 " |
956 aContext selector == #lookupMethodForSelectorUnwindHandlerFor: ifTrue:[ |
960 aContext selector == #lookupMethodForSelectorUnwindHandlerFor: ifTrue:[ |
957 ^[self lookupMethodForSelectorUnwindHandlerFor: (aContext argAt: 1)] |
961 ^[self lookupMethodForSelectorUnwindHandlerFor: (aContext argAt: 1)] |
958 ]. |
962 ]. |
959 |
963 |
960 self internalError:'Unknown VM unwind protect action' |
964 self internalError:'Unknown VM unwind protect action' |
961 |
965 |
962 "Created: / 01-10-2011 / 19:15:32 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
966 "Created: / 01-10-2011 / 19:15:32 / Jan Vrany <jan.vrany@fit.cvut.cz>" |
963 ! ! |
967 ! ! |
1063 |
1067 |
1064 self flushMethodCacheForSelector:aSelector. |
1068 self flushMethodCacheForSelector:aSelector. |
1065 |
1069 |
1066 "/ self flushInlineCachesForSelector:aSelector. |
1070 "/ self flushInlineCachesForSelector:aSelector. |
1067 self flushInlineCachesWithArgs:(aSelector numArgs). |
1071 self flushInlineCachesWithArgs:(aSelector numArgs). |
|
1072 ! |
|
1073 |
|
1074 flushCachesForSelector:aSelector numArgs:numArgs |
|
1075 "flush method and inline caches for aSelector" |
|
1076 |
|
1077 self flushMethodCacheForSelector:aSelector. |
|
1078 |
|
1079 "/ self flushInlineCachesForSelector:aSelector. |
|
1080 self flushInlineCachesWithArgs:numArgs. |
1068 ! |
1081 ! |
1069 |
1082 |
1070 flushInlineCaches |
1083 flushInlineCaches |
1071 "flush all inlinecaches" |
1084 "flush all inlinecaches" |
1072 |
1085 |
2314 backgroundCollector." |
2329 backgroundCollector." |
2315 |
2330 |
2316 |done limit| |
2331 |done limit| |
2317 |
2332 |
2318 AbortOperationRequest handle:[:ex | |
2333 AbortOperationRequest handle:[:ex | |
2319 "/ in case of abort (from the debugger), |
2334 "/ in case of abort (from the debugger), |
2320 "/ disable gcSteps. |
2335 "/ disable gcSteps. |
2321 done := true. |
2336 done := true. |
2322 IncrementalGCLimit := FreeSpaceGCLimit := nil. |
2337 IncrementalGCLimit := FreeSpaceGCLimit := nil. |
2323 'ObjectMemory [error]: IGC aborted; turning off incremental GC' errorPrintCR |
2338 'ObjectMemory [error]: IGC aborted; turning off incremental GC' errorPrintCR |
2324 ] do:[ |
2339 ] do:[ |
2325 limit := IncrementalGCLimit. |
2340 limit := IncrementalGCLimit. |
2326 (limit notNil and:[self oldSpaceAllocatedSinceLastGC > limit]) ifTrue:[ |
2341 (limit notNil and:[self oldSpaceAllocatedSinceLastGC > limit]) ifTrue:[ |
2327 "/ 'IGC [info]: start since allocatedSinceLastGC > IncrementalGCLimit' infoPrintCR. |
2342 "/ 'IGC [info]: start since allocatedSinceLastGC > IncrementalGCLimit' infoPrintCR. |
2328 done := ObjectMemory gcStep |
2343 done := ObjectMemory gcStep |
2329 ] ifFalse:[ |
2344 ] ifFalse:[ |
2330 limit := FreeSpaceGCLimit. |
2345 limit := FreeSpaceGCLimit. |
2331 (limit notNil and:[(self freeSpace + self freeListSpace) < limit]) ifTrue:[ |
2346 (limit notNil and:[(self freeSpace + self freeListSpace) < limit]) ifTrue:[ |
2332 "/ 'IGC [info]: start since freeSpace < FreeSpaceGCLimit' infoPrintCR. |
2347 "/ 'IGC [info]: start since freeSpace < FreeSpaceGCLimit' infoPrintCR. |
2333 done := ObjectMemory gcStep. |
2348 done := ObjectMemory gcStep. |
2334 done ifTrue:[ |
2349 done ifTrue:[ |
2335 self moreOldSpaceIfUseful |
2350 self moreOldSpaceIfUseful |
2336 ]. |
2351 ]. |
2337 ] ifFalse:[ |
2352 ] ifFalse:[ |
2338 limit := DynamicCodeGCTrigger. |
2353 limit := DynamicCodeGCTrigger. |
2339 (limit notNil and:[self compiledCodeCounter > limit]) ifTrue:[ |
2354 (limit notNil and:[self compiledCodeCounter > limit]) ifTrue:[ |
2340 "/ 'IGC [info]: start since compiledCodeCounter > DynamicCodeGCTrigger' infoPrintCR. |
2355 "/ 'IGC [info]: start since compiledCodeCounter > DynamicCodeGCTrigger' infoPrintCR. |
2341 done := ObjectMemory gcStep. |
2356 done := ObjectMemory gcStep. |
2342 ] ifFalse:[ |
2357 ] ifFalse:[ |
2343 limit := DynamicCodeLimit. |
2358 limit := DynamicCodeLimit. |
2344 (limit notNil and:[self compiledCodeSpaceUsed > limit]) ifTrue:[ |
2359 (limit notNil and:[self compiledCodeSpaceUsed > limit]) ifTrue:[ |
2345 "/ 'IGC [info]: start since compiledCodeSpaceUsed > DynamicCodeLimit' infoPrintCR. |
2360 "/ 'IGC [info]: start since compiledCodeSpaceUsed > DynamicCodeLimit' infoPrintCR. |
2346 done := ObjectMemory gcStep. |
2361 done := ObjectMemory gcStep. |
2347 ] ifFalse:[ |
2362 ] ifFalse:[ |
2348 done := true |
2363 done := true |
2349 ] |
2364 ] |
2350 ] |
2365 ] |
2351 ] |
2366 ] |
2352 ]. |
2367 ]. |
2353 ]. |
2368 ]. |
2354 ^ done not |
2369 ^ done not |
2355 |
2370 |
2356 "Modified: / 14.8.1998 / 13:08:15 / cg" |
2371 "Modified: / 14.8.1998 / 13:08:15 / cg" |
2357 ! |
2372 ! |
4170 finalize |
4185 finalize |
4171 "tell all weak objects that something happened." |
4186 "tell all weak objects that something happened." |
4172 |
4187 |
4173 self allChangedShadowObjectsDo:[:aShadowArray | |
4188 self allChangedShadowObjectsDo:[:aShadowArray | |
4174 Error handle:[:ex | |
4189 Error handle:[:ex | |
4175 'ObjectMemory [warning]: cought error in weakArray processing: ' errorPrint. |
4190 'ObjectMemory [warning]: caught error in weakArray processing: ' errorPrint. |
4176 ex description errorPrintCR. |
4191 ex description errorPrintCR. |
4177 ex suspendedContext fullPrintAllLevels:10. |
4192 ex suspendedContext fullPrintAllLevels:10. |
4178 "Restart the do block to clean up the rest of the shadow array. |
4193 "Restart the do block to clean up the rest of the shadow array. |
4179 This is safe here, because the old executor that triggered the error |
4194 This is safe here, because the old executor that triggered the error |
4180 has already been removed from the Registry" |
4195 has already been removed from the Registry" |
5039 |
5054 |
5040 |modules| |
5055 |modules| |
5041 |
5056 |
5042 modules := IdentityDictionary new. |
5057 modules := IdentityDictionary new. |
5043 self allBinaryModulesDo:[:idArg :nameArg :flagsArg :libName :timeStamp | |
5058 self allBinaryModulesDo:[:idArg :nameArg :flagsArg :libName :timeStamp | |
5044 |type subModuleName module dynamic infoRec handle pathName |
5059 |type subModuleName module dynamic infoRec handle pathName |
5045 typeName name nameString| |
5060 typeName name nameString| |
5046 |
5061 |
5047 nameArg class == String ifFalse:[ |
5062 nameArg isString ifFalse:[ |
5048 'Error in binaryModuleInfo - skip entry' errorPrintCR. |
5063 'Error in binaryModuleInfo - skip entry' errorPrintCR. |
5049 ] ifTrue:[ |
5064 ] ifTrue:[ |
5050 name := nameArg. |
5065 name := nameArg. |
5051 subModuleName := name asSymbol. |
5066 subModuleName := name asSymbol. |
5052 |
5067 |
5053 idArg > 0 ifTrue:[ |
5068 idArg > 0 ifTrue:[ |
5054 dynamic := true. |
5069 dynamic := true. |
5055 typeName := 'dynamic '. |
5070 typeName := 'dynamic '. |
5056 handle := ObjectFileLoader handleFromID:idArg. |
5071 handle := ObjectFileLoader handleFromID:idArg. |
5057 (handle isNil or:[(pathName := handle pathName) isNil]) ifTrue:[ |
5072 (handle isNil or:[(pathName := handle pathName) isNil]) ifTrue:[ |
5058 name := '?' |
5073 name := '?' |
5059 ] ifFalse:[ |
5074 ] ifFalse:[ |
5060 name := pathName asFilename baseName |
5075 name := pathName asFilename baseName |
5061 ] |
5076 ] |
5062 ] ifFalse:[ |
5077 ] ifFalse:[ |
5063 dynamic := false. |
5078 dynamic := false. |
5064 typeName := 'builtIn '. |
5079 typeName := 'builtIn '. |
5065 pathName := nil. |
5080 pathName := nil. |
5066 libName isNil ifTrue:[ |
5081 libName isNil ifTrue:[ |
5067 name := subModuleName |
5082 name := subModuleName |
5068 ] ifFalse:[ |
5083 ] ifFalse:[ |
5069 name := libName |
5084 name := libName |
5070 ]. |
5085 ]. |
5071 ]. |
5086 ]. |
5072 nameString := typeName. |
5087 nameString := typeName. |
5073 libName isNil ifTrue:[ |
5088 libName isNil ifTrue:[ |
5074 nameString := nameString, 'module ' |
5089 nameString := nameString, 'module ' |
5075 ] ifFalse:[ |
5090 ] ifFalse:[ |
5076 nameString := nameString, 'classLib ' |
5091 nameString := nameString, 'classLib ' |
5077 ]. |
5092 ]. |
5078 nameString := nameString , name. |
5093 nameString := nameString , name. |
5079 |
5094 |
5080 libName isNil ifTrue:[ |
5095 libName isNil ifTrue:[ |
5081 type := #classObject |
5096 type := #classObject |
5082 ] ifFalse:[ |
5097 ] ifFalse:[ |
5083 type := #classLibrary |
5098 type := #classLibrary |
5084 ]. |
5099 ]. |
5085 |
5100 |
5086 infoRec := modules at:idArg ifAbsent:nil. |
5101 infoRec := modules at:idArg ifAbsent:nil. |
5087 infoRec notNil ifTrue:[ |
5102 infoRec notNil ifTrue:[ |
5088 infoRec classNames add:subModuleName. |
5103 infoRec classNames add:subModuleName. |
5089 ] ifFalse:[ |
5104 ] ifFalse:[ |
5090 infoRec := BinaryModuleDescriptor |
5105 infoRec := BinaryModuleDescriptor |
5091 name:nameString |
5106 name:nameString |
5092 type:type |
5107 type:type |
5093 id:idArg |
5108 id:idArg |
5094 dynamic:dynamic |
5109 dynamic:dynamic |
5095 classNames:( (OrderedSet ? Set) with:subModuleName) |
5110 classNames:( (OrderedSet ? Set) with:subModuleName) |
5096 handle:handle |
5111 handle:handle |
5097 pathName:pathName |
5112 pathName:pathName |
5098 libraryName:libName |
5113 libraryName:libName |
5099 timeStamp:nil. |
5114 timeStamp:nil. |
5100 |
5115 |
5101 modules at:idArg put:infoRec. |
5116 modules at:idArg put:infoRec. |
5102 ]. |
5117 ]. |
5103 ]. |
5118 ]. |
5104 ]. |
5119 ]. |
5105 ^ modules |
5120 ^ modules |
5106 |
5121 |
5107 " |
5122 " |
5108 ObjectMemory binaryModuleInfo |
5123 ObjectMemory binaryModuleInfo |
5128 " |
5143 " |
5129 ! ! |
5144 ! ! |
5130 |
5145 |
5131 !ObjectMemory class methodsFor:'system management'! |
5146 !ObjectMemory class methodsFor:'system management'! |
5132 |
5147 |
|
5148 directoryForImageAndChangeFile |
|
5149 |dir exeDir| |
|
5150 |
|
5151 dir := Filename currentDirectory. |
|
5152 |
|
5153 "/ the current directory is not a good idea, if stx is started via a desktop manager |
|
5154 "/ or in osx, by clicking on stx.app. |
|
5155 dir isRootDirectory ifTrue:[ |
|
5156 exeDir := OperatingSystem nameOfSTXExecutable asFilename directory. |
|
5157 dir ~= exeDir ifTrue:[ |
|
5158 "/ Change it to ~/.smalltalk or is executable directory better? |
|
5159 |
|
5160 "/ use executable dir, as otherwise I'd have to change the VM to include an image path... |
|
5161 "/ dir := Filename usersPrivateSmalltalkDirectory. |
|
5162 dir := exeDir. |
|
5163 ]. |
|
5164 ]. |
|
5165 ^ dir |
|
5166 |
|
5167 " |
|
5168 self directoryForImageAndChangeFile |
|
5169 " |
|
5170 ! |
|
5171 |
5133 imageBaseName |
5172 imageBaseName |
5134 "return a reasonable filename to use as baseName (i.e. without extension). |
5173 "return a reasonable filename to use as baseName (i.e. without extension). |
5135 This is the filename of the current image (without '.img') or, |
5174 This is the filename of the current image (without '.img') or, |
5136 if not running from an image, the default name 'st'" |
5175 if not running from an image, the default name 'st'" |
5137 |
5176 |
5171 Return nil if not running from an image." |
5210 Return nil if not running from an image." |
5172 |
5211 |
5173 ^ ImageSaveTime |
5212 ^ ImageSaveTime |
5174 ! |
5213 ! |
5175 |
5214 |
|
5215 initChangeFilename |
|
5216 "/ make the changeFilePath an absolute one, |
|
5217 "/ in case some stupid windows fileDialog changes the current directory... |
|
5218 self |
|
5219 nameForChanges:(self directoryForImageAndChangeFile / ObjectMemory nameForChangesLocal) |
|
5220 asAbsoluteFilename pathName |
|
5221 |
|
5222 " |
|
5223 self initChangeFilename |
|
5224 " |
|
5225 ! |
|
5226 |
5176 nameForChanges |
5227 nameForChanges |
5177 "return a reasonable filename to store the changes into. |
5228 "return a reasonable filename to store the changes into. |
5178 Currently, this is defined in a classVariable and defaults to 'changes'. |
5229 By default, this is the basename of the current image with '.img' replaced |
5179 In future versions, this will be the basename of the current image with '.img' replaced |
5230 by '.chg', or, if not running from an image, the default name 'st.chg'. |
5180 by '.chg', or, if not running from an image, the default name 'st.chg'." |
5231 However, it can be overwritten via the nameForChanges: setter" |
5181 |
5232 |
|
5233 |nm| |
|
5234 |
|
5235 (nm := UserPreferences current changeFileName) notNil ifTrue:[ |
|
5236 ^ nm |
|
5237 ]. |
5182 ChangeFileName notNil ifTrue:[^ ChangeFileName]. |
5238 ChangeFileName notNil ifTrue:[^ ChangeFileName]. |
5183 ^ self nameForChangesLocal |
5239 ^ self nameForChangesLocal |
5184 |
5240 |
5185 " |
5241 " |
5186 ObjectMemory nameForChanges |
5242 ObjectMemory nameForChanges |
5286 refreshChangesFrom: oldChangesName |
5342 refreshChangesFrom: oldChangesName |
5287 "The snapshot image name has changed (snapshot saved), |
5343 "The snapshot image name has changed (snapshot saved), |
5288 the changes file must be copied to the new name. |
5344 the changes file must be copied to the new name. |
5289 No copy when the changes name is given explicitly." |
5345 No copy when the changes name is given explicitly." |
5290 |
5346 |
5291 ChangeFileName notNil ifTrue: [ ^self]. |
5347 ChangeFileName notNil ifTrue: [ |
|
5348 ChangeFileName ~= self nameForChangesLocal ifTrue:[ |
|
5349 ^ self |
|
5350 ] |
|
5351 ]. |
5292 oldChangesName asFilename copyTo:self nameForChanges |
5352 oldChangesName asFilename copyTo:self nameForChanges |
5293 |
5353 |
5294 "Created: / 15.5.2004 / 20:29:03 / masca" |
5354 "Created: / 15.5.2004 / 20:29:03 / masca" |
5295 ! |
5355 ! |
5296 |
5356 |
5340 save in a temp file and rename - just in case something |
5400 save in a temp file and rename - just in case something |
5341 bad happens while writing the image. |
5401 bad happens while writing the image. |
5342 (could be ST/X error or file-system errors etc.) |
5402 (could be ST/X error or file-system errors etc.) |
5343 " |
5403 " |
5344 snapshotFilename := aFileName asFilename. |
5404 snapshotFilename := aFileName asFilename. |
|
5405 snapshotFilename isAbsolute ifFalse:[ |
|
5406 snapshotFilename := self directoryForImageAndChangeFile |
|
5407 / snapshotFilename name. |
|
5408 ]. |
|
5409 |
5345 tempFilename := (FileStream newTemporaryIn:snapshotFilename directory) |
5410 tempFilename := (FileStream newTemporaryIn:snapshotFilename directory) |
5346 close; |
5411 close; |
5347 fileName. |
5412 fileName. |
5348 ok := self primSnapShotOn:tempFilename. |
5413 ok := self primSnapShotOn:tempFilename. |
5349 |
5414 |