Packages February 2024

packages@lists.squeakfoundation.org

1 participants
58 discussions

The Trunk: Kernel-ct.1355.mcz
by commits＠source.squeak.org 24 Feb '24

24 Feb '24

Christoph Thiede uploaded a new version of Kernel to project The Trunk: http://source.squeak.org/trunk/Kernel-ct.1355.mcz ==================== Summary ==================== Name: Kernel-ct.1355 Author: ct Time: 24 October 2020, 12:39:11.860058 am UUID: 32ca6b45-a632-e743-8a51-10d5d9dee1b3 Ancestors: Kernel-mt.1353 Fixes source logging when fixing a SyntaxError. In the past, the old source was stored in the logs instead of the new one. =============== Diff against Kernel-mt.1353 =============== Item was changed: ----- Method: ClassDescription>>compileCue:classified:withStamp:logSource: (in category 'compiling') ----- compileCue: compilationCue classified: category withStamp: changeStamp logSource: logSource | methodAndNode methodNode selector | methodNode := self newCompiler compile: compilationCue ifFail: [^nil]. methodAndNode := CompiledMethodWithNode generateMethodFromNode: methodNode trailer: (compilationCue methodTrailer ifNil: [self defaultMethodTrailerIfLogSource: logSource]). selector := methodAndNode selector. logSource ifTrue: [self + logMethodSource: methodNode sourceText - logMethodSource: compilationCue source forMethodWithNode: methodAndNode inCategory: category withStamp: changeStamp notifying: compilationCue requestor. RecentMessages default recordSelector: selector forClass: methodAndNode method methodClass inEnvironment: compilationCue environment]. self addAndClassifySelector: selector withMethod: methodAndNode method inProtocol: category notifying: compilationCue requestor. self instanceSide noteCompilationOf: selector meta: self isClassSide. ^selector!

1 0

The Trunk: KernelTests-ct.387.mcz
by commits＠source.squeak.org 24 Feb '24

24 Feb '24

Christoph Thiede uploaded a new version of KernelTests to project The Trunk: http://source.squeak.org/trunk/KernelTests-ct.387.mcz ==================== Summary ==================== Name: KernelTests-ct.387 Author: ct Time: 24 October 2020, 12:40:40.526058 am UUID: aa73c56f-88e1-3b4d-9d59-fb29df3363a7 Ancestors: KernelTests-ul.386 Adds regression test for Kernel-ct.1355 (source logging after SyntaxError). Should I invest further complexity into this test for the purpose of keeping the production source logs clean? =============== Diff against KernelTests-ul.386 =============== Item was added: + ----- Method: ClassDescriptionTest>>testLogSourceAfterReparseSyntaxError (in category 'testing') ----- + testLogSourceAfterReparseSyntaxError + + | class source | + SystemChangeNotifier uniqueInstance doSilently: [[ + class := Object newSubclass. + source := 'foo [x'. + [class compile: source] + on: SyntaxErrorNotification do: [:error | + error resume: (source := source , ']')]. + self assert: source equals: (class sourceCodeAt: #foo) asString. + ] ensure: [class removeFromSystem]].! Item was changed: + ----- Method: ClassDescriptionTest>>testOrganization (in category 'testing') ----- - ----- Method: ClassDescriptionTest>>testOrganization (in category 'tests') ----- testOrganization | aClassOrganizer | aClassOrganizer := ClassDescription organization. self assert: (aClassOrganizer isKindOf: ClassOrganizer).!

1 0

The Trunk: Compiler-ct.496.mcz
by commits＠source.squeak.org 24 Feb '24

24 Feb '24

Christoph Thiede uploaded a new version of Compiler to project The Trunk: http://source.squeak.org/trunk/Compiler-ct.496.mcz ==================== Summary ==================== Name: Compiler-ct.496 Author: ct Time: 24 February 2024, 9:33:48.264459 pm UUID: 8600e29a-71b6-3347-9990-efef5c84e76d Ancestors: Compiler-mt.495 Fixes source logging after fixing a syntax error. In the past, the old source was stored in the logs instead of the new one. =============== Diff against Compiler-mt.495 =============== Item was changed: ----- Method: Compiler>>compiledMethodFor:in:to:notifying:ifFail: (in category 'public access') ----- compiledMethodFor: textOrStream in: aContext to: receiver notifying: aRequestor ifFail: failBlock - "Compiles the sourceStream into a parse tree, then generates code - into a method, and answers it. If receiver is not nil, then the text can - refer to instance variables of that receiver (the Inspector uses this). - If aContext is not nil, the text can refer to temporaries in that context - (the Debugger uses this). If aRequestor is not nil, then it will receive a - notify:at: message before the attempt to evaluate is aborted." + ^ self + compiledMethodFor: textOrStream + in: aContext + to: receiver - | methodNode method | - methodNode := self - compileNoPattern: textOrStream - in: (self classForReceiver: receiver context: aContext) - context: aContext notifying: aRequestor + ifFail: failBlock + logged: false! - ifFail: [^failBlock value]. - method := self interactive - ifTrue: [ methodNode generateWithTempNames ] - ifFalse: [ methodNode generate ]. - ^method! Item was changed: ----- Method: Compiler>>compiledMethodFor:in:to:notifying:ifFail:logged: (in category 'public access logging') ----- compiledMethodFor: textOrStream in: aContext to: receiver notifying: aRequestor ifFail: failBlock logged: logFlag "Compiles the sourceStream into a parse tree, then generates code into a method, and answers it. If receiver is not nil, then the text can refer to instance variables of that receiver (the Inspector uses this). If aContext is not nil, the text can refer to temporaries in that context (the Debugger uses this). If aRequestor is not nil, then it will receive a notify:at: message before the attempt to evaluate is aborted." + | methodNode method | + methodNode := self + compileNoPattern: textOrStream + in: (self classForReceiver: receiver context: aContext) + context: aContext - | method | - method := self - compiledMethodFor: textOrStream - in: aContext - to: receiver notifying: aRequestor ifFail: [^failBlock value]. + method := self interactive + ifTrue: [ methodNode generateWithTempNames ] + ifFalse: [ methodNode generate ]. + logFlag ifTrue: + [SystemChangeNotifier uniqueInstance + evaluated: (methodNode basicSourceText ifNil: [cue stringToLog]) "honor possible source updates (e.g., due to ReparseAfterSourceEditing)" + context: aContext]. + - [SystemChangeNotifier uniqueInstance evaluated: cue stringToLog context: aContext]. ^method! Item was changed: ----- Method: Compiler>>evaluateCue:ifFail: (in category 'private') ----- evaluateCue: aCue ifFail: failBlock - "Compiles the cue source into a parse tree, then generates code into - a method. Finally, the compiled method is invoked from here via withArgs:executeMethod:, hence the system no longer creates Doit method - litter on errors." + ^ self + evaluateCue: aCue + ifFail: failBlock + logged: false! - | methodNode method value | - methodNode := self compileCue: aCue noPattern: true ifFail: [^failBlock value]. - - method := self interactive - ifTrue: [methodNode generateWithTempNames] - ifFalse: [methodNode generate]. - - value := cue receiver - withArgs: (cue context ifNil: [#()] ifNotNil: [{cue context}]) - executeMethod: method. - ^ value - ! Item was changed: ----- Method: Compiler>>evaluateCue:ifFail:logged: (in category 'private') ----- evaluateCue: aCue ifFail: failBlock logged: logFlag "Compiles the cue source into a parse tree, then generates code into a method. Finally, the compiled method is invoked from here via withArgs:executeMethod:, hence the system no longer creates Doit method litter on errors." + | methodNode method value | + methodNode := self compileCue: aCue noPattern: true ifFail: [^failBlock value]. + + method := self interactive + ifTrue: [methodNode generateWithTempNames] + ifFalse: [methodNode generate]. + + value := cue receiver + withArgs: (cue context ifNil: [#()] ifNotNil: [{cue context}]) + executeMethod: method. + - | value | - value := self evaluateCue: aCue ifFail: [^failBlock value]. logFlag ifTrue: + [SystemChangeNotifier uniqueInstance + evaluated: (methodNode basicSourceText ifNil: [cue stringToLog]) "honor possible source updates (e.g., due to ReparseAfterSourceEditing)" + context: cue context]. + + ^ value! - [SystemChangeNotifier uniqueInstance evaluated: cue stringToLog context: cue context]. - ^ value - ! Item was added: + ----- Method: MethodNode>>basicSourceText (in category 'printing') ----- + basicSourceText + + ^ sourceText!

1 0

The Trunk: Kernel-ct.1554.mcz
by commits＠source.squeak.org 24 Feb '24

24 Feb '24

Christoph Thiede uploaded a new version of Kernel to project The Trunk: http://source.squeak.org/trunk/Kernel-ct.1554.mcz ==================== Summary ==================== Name: Kernel-ct.1554 Author: ct Time: 24 February 2024, 9:33:37.855459 pm UUID: 8840e255-a1eb-3044-85ed-e7186b5c252f Ancestors: Kernel-ct.1553, Kernel-ct.1301, Kernel-ct.1355 Complements Compiler-ct.496. Merges Kernel-ct.1355. Revision: If parserClass does not store sourceText in the methodNode, preserve original formatting from the cue. Reuse existing #stringToLog like Compiler>>#evaluateCue:ifFail:logged:. =============== Diff against Kernel-ct.1553 =============== Item was changed: ----- Method: ClassDescription>>compileCue:classified:withStamp:logSource: (in category 'compiling') ----- compileCue: compilationCue classified: category withStamp: changeStamp logSource: logSource | methodAndNode methodNode selector | methodNode := self newCompiler compile: compilationCue ifFail: [^nil]. methodAndNode := CompiledMethodWithNode generateMethodFromNode: methodNode trailer: (compilationCue methodTrailer ifNil: [self defaultMethodTrailerIfLogSource: logSource]). selector := methodAndNode selector. logSource ifTrue: [self + logMethodSource: (methodNode basicSourceText ifNil: [compilationCue stringToLog]) "honor possible source updates (e.g., due to ReparseAfterSourceEditing)" - logMethodSource: compilationCue source forMethodWithNode: methodAndNode inCategory: category withStamp: changeStamp notifying: compilationCue requestor. RecentMessages default recordSelector: selector forClass: methodAndNode method methodClass inEnvironment: compilationCue environment]. self addAndClassifySelector: selector withMethod: methodAndNode method inProtocol: category notifying: compilationCue requestor. self instanceSide noteCompilationOf: selector meta: self isClassSide. ^selector!

1 0

The Trunk: KernelTests-ct.452.mcz
by commits＠source.squeak.org 24 Feb '24

24 Feb '24

Christoph Thiede uploaded a new version of KernelTests to project The Trunk: http://source.squeak.org/trunk/KernelTests-ct.452.mcz ==================== Summary ==================== Name: KernelTests-ct.452 Author: ct Time: 24 February 2024, 9:33:33.756459 pm UUID: bd37e2b7-1de0-ac4f-8130-78ccabfdb249 Ancestors: KernelTests-ct.451, KernelTests-ct.376, KernelTests-ct.387 KernelTests-ct.387: Adds regression test for Kernel-ct.1355 (source logging after SyntaxError). Revision: Document side effect to changes file. =============== Diff against KernelTests-ct.451 =============== Item was added: + ----- Method: ClassDescriptionTest>>testLogSourceAfterReparseSyntaxError (in category 'tests') ----- + testLogSourceAfterReparseSyntaxError + + | class source | + SystemChangeNotifier uniqueInstance doSilently: "NB: this silences logging of subclass creation/deletion but not logging of #compile:, which is part of the functionality under test" + [[class := Object newSubclass. + source := 'foo [x'. + [class compile: source] + on: SyntaxErrorNotification do: [:error | + error retryWithNewSource: (source := source , ']')]. + self assert: source equals: (class sourceCodeAt: #foo) asString] + ensure: [class removeFromSystem]].!

1 0

The Trunk: Kernel-ct.1293.mcz
by commits＠source.squeak.org 24 Feb '24

24 Feb '24

Christoph Thiede uploaded a new version of Kernel to project The Trunk: http://source.squeak.org/trunk/Kernel-ct.1293.mcz ==================== Summary ==================== Name: Kernel-ct.1293 Author: ct Time: 8 January 2020, 11:11:21.431206 am UUID: 86f4d70b-c53c-5a45-97f3-1bff2d65cdb4 Ancestors: Kernel-nice.1292 Elaborate method comment in Object >> #copyFrom: =============== Diff against Kernel-nice.1292 =============== Item was changed: ----- Method: Object>>copyFrom: (in category 'copying') ----- copyFrom: anotherObject + "Copy to myself all instance variables I have in common with anotherObject, i. e. those which have the same index in both class definitions. This is dangerous because it ignores an object's control over its own inst vars." - "Copy to myself all instance variables I have in common with anotherObject. This is dangerous because it ignores an object's control over its own inst vars. " | mine his | <primitive: 168> mine := self class allInstVarNames. his := anotherObject class allInstVarNames. 1 to: (mine size min: his size) do: [:ind | (mine at: ind) = (his at: ind) ifTrue: [ self instVarAt: ind put: (anotherObject instVarAt: ind)]]. self class isVariable & anotherObject class isVariable ifTrue: [ 1 to: (self basicSize min: anotherObject basicSize) do: [:ind | self basicAt: ind put: (anotherObject basicAt: ind)]].! Item was changed: ----- Method: Object>>copySameFrom: (in category 'copying') ----- copySameFrom: otherObject + "Copy to myself all instance variables named the same in otherObject. This is dangerous because it ignores an object's control over its own inst vars." - "Copy to myself all instance variables named the same in otherObject. - This ignores otherObject's control over its own inst vars." | myInstVars otherInstVars | myInstVars := self class allInstVarNames. otherInstVars := otherObject class allInstVarNames. myInstVars doWithIndex: [:each :index | | match | (match := otherInstVars indexOf: each) > 0 ifTrue: [self instVarAt: index put: (otherObject instVarAt: match)]]. 1 to: (self basicSize min: otherObject basicSize) do: [:i | self basicAt: i put: (otherObject basicAt: i)]. !

1 0

The Trunk: Kernel-ct.1553.mcz
by commits＠source.squeak.org 24 Feb '24

24 Feb '24

Christoph Thiede uploaded a new version of Kernel to project The Trunk: http://source.squeak.org/trunk/Kernel-ct.1553.mcz ==================== Summary ==================== Name: Kernel-ct.1553 Author: ct Time: 24 February 2024, 8:42:15.180459 pm UUID: bfcd6789-4af9-cc41-8278-5a27709723d5 Ancestors: Kernel-mt.1551, Kernel-ct.1293 Merges and revises Kernel-ct.1293: Elaborate method comment in Object >> #copyFrom: See: https://lists.squeakfoundation.org/archives/list/squeak-dev@lists.squeakfou… =============== Diff against Kernel-mt.1551 =============== Item was changed: ----- Method: CompiledCode>>copyFrom: (in category 'copying') ----- copyFrom: anotherObject + "Copy to myself all slots I have in common with anotherObject, i.e., all variables names which have the same index in both classes and all element indices which are available in both classes. + This is dangerous because it ignores an object's control over its own inst vars." - "Copy to myself all instance variables I have in common with anotherObject. - This is dangerous because it ignores an object's control over its own inst vars." <primitive: 168> anotherObject isCompiledCode ifTrue: [1 to: self numLiterals do: [:i| self literalAt: i put: (anotherObject literalAt: i)]] ifFalse: [1 to: self numLiterals do: [:i| self literalAt: i put: (anotherObject at: i)]]. self initialPC to: (self basicSize min: anotherObject basicSize) do: [:i| self basicAt: i put: (anotherObject basicAt: i)]! Item was changed: ----- Method: Object>>copyFrom: (in category 'copying') ----- copyFrom: anotherObject + "Copy to myself all slots I have in common with anotherObject, i.e., all variables names which have the same index in both classes and all element indices which are available in both classes. + This is dangerous because it ignores an object's control over its own inst vars." - "Copy to myself all instance variables I have in common with anotherObject. This is dangerous because it ignores an object's control over its own inst vars. " | mine his | <primitive: 168> mine := self class allInstVarNames. his := anotherObject class allInstVarNames. 1 to: (mine size min: his size) do: [:ind | (mine at: ind) = (his at: ind) ifTrue: [ self instVarAt: ind put: (anotherObject instVarAt: ind)]]. self class isVariable & anotherObject class isVariable ifTrue: [ 1 to: (self basicSize min: anotherObject basicSize) do: [:ind | self basicAt: ind put: (anotherObject basicAt: ind)]].! Item was changed: ----- Method: Object>>copySameFrom: (in category 'copying') ----- copySameFrom: otherObject "Copy to myself all instance variables named the same in otherObject. + This is dangerous because it ignores an object's control over its own inst vars." - This ignores otherObject's control over its own inst vars." | myInstVars otherInstVars | myInstVars := self class allInstVarNames. otherInstVars := otherObject class allInstVarNames. myInstVars withIndexDo: [:each :index | | match | (match := otherInstVars indexOf: each) > 0 ifTrue: [self instVarAt: index put: (otherObject instVarAt: match)]]. 1 to: (self basicSize min: otherObject basicSize) do: [:i | self basicAt: i put: (otherObject basicAt: i)]. !

1 0

The Trunk: JSON-cmm.62.mcz
by commits＠source.squeak.org 24 Feb '24

24 Feb '24

Chris Muller uploaded a new version of JSON to project The Trunk: http://source.squeak.org/trunk/JSON-cmm.62.mcz ==================== Summary ==================== Name: JSON-cmm.62 Author: cmm Time: 24 February 2024, 1:21:44.121899 am UUID: 8a043f53-c158-4a2a-b29a-0fb20d53d6a9 Ancestors: JSON-cmm.61 - Prefix json extension methods to indicate they're intended for Json outputs. - Better comments, implementations and tests for new path accessing functions. - Fix and a test an Array of Associations to be a Json object. =============== Diff against JSON-cmm.61 =============== Item was removed: - ----- Method: Collection>>atPath: (in category '*json') ----- - atPath: anArray - "Assume I'm a set of nested HashedCollections and/or SequenceableCollections. Answer the object at the path of indices and/or keys identified in anArray." - ^ self - atPath: anArray - ifLost: [ : last | self error: 'path lost after' , last asString ]! Item was removed: - ----- Method: Collection>>atPath:ifLost: (in category '*json') ----- - atPath: anArray ifLost: aBlock - "Assume I'm a set of nested HashedCollections and/or SequenceableCollections. Answer the object at the path of indices and/or keys identified in anArray. If the full path specified by anArray isn't present, cull aBlock with the last element present along the path." - | last | - ^ (self - path: anArray - do: [ : elem : node | last := node ]) - ifNil: [ aBlock cull: last ] - ifNotNil: [ last ]! Item was added: + ----- Method: Collection>>jsonAtPath: (in category '*json') ----- + jsonAtPath: anArray + "Assume I'm Json output. Answer the object at the path of indices and/or keys identified in anArray. If the full path specified by anArray isn't found, signal an Error." + ^ self + jsonAtPath: anArray + ifLost: [ : last | self error: 'path lost after index ' , last asString ]! Item was added: + ----- Method: Collection>>jsonAtPath:ifLost: (in category '*json') ----- + jsonAtPath: anArray ifLost: aBlock + "Assume I'm a Json object. Answer the sub-object at the path of indices and/or keys identified in anArray. If the full path specified by anArray isn't present, stop, and answer the value of aBlock culled with the index of the element within anArray that isn't found." + | last index | + index := 0. + ^ (self + jsonPath: anArray + do: + [ : elem : node | index := index + 1. + last := node ]) + ifNil: [ aBlock cull: index+1] + ifNotNil: [ last ]! Item was added: + ----- Method: Collection>>jsonPath:do: (in category '*json') ----- + jsonPath: anArray do: aBlock + "Assume I'm a Json output. Value aBlock with each object along the path of keys and/or indices identified in anArray. If a path element isn't found, stop, and return nil, otherwise, return self." + | current | + current := self. + anArray do: + [ : eachKey | "Json doesn't have Characters, allow pathing into Json objects only." + (current isArray or: [ current isDictionary ]) + ifTrue: + [ current + at: eachKey + ifPresent: + [ : eachValue | aBlock + value: eachKey + value: eachValue. + current := eachValue ] + ifAbsent: [ ^ nil ] ] + ifFalse: [ ^ nil ] ]. + ^ self! Item was added: + ----- Method: Collection>>jsonWriteListOn: (in category '*json') ----- + jsonWriteListOn: aStream + "By default, use array braces " + aStream nextPut: $[. + + self do: [:each | + each jsonWriteOn: aStream + ] separatedBy: [ aStream nextPut: $, ]. + + aStream nextPut: $]! Item was added: + ----- Method: Collection>>jsonWriteObjectOn: (in category '*json') ----- + jsonWriteObjectOn: aStream + + | needComma | + needComma := false. + aStream nextPut: ${. + self associationsDo: [ :assoc | + needComma + ifTrue: [ aStream nextPut: $, ] + ifFalse: [ needComma := true ]. + assoc key jsonWriteOn: aStream. + aStream nextPut: $:. + assoc value jsonWriteOn: aStream ]. + aStream nextPut: $}.! Item was changed: ----- Method: Collection>>jsonWriteOn: (in category '*json') ----- jsonWriteOn: aStream + (self notEmpty and: [self anyOne isVariableBinding]) + ifTrue: [ self jsonWriteObjectOn: aStream ] + ifFalse: [ self jsonWriteListOn: aStream ]! - "By default, use array braces " - aStream nextPut: $[. - - self do: [:each | - each jsonWriteOn: aStream - ] separatedBy: [ aStream nextPut: $, ]. - - aStream nextPut: $]! Item was removed: - ----- Method: Collection>>path:do: (in category '*json') ----- - path: anArray do: aBlock - "Assume I'm a set of nested HashedCollections and/or SequenceableCollections. Value aBlock with each object along the path of indices and/or keys identified in anArray. If a path element isn't found, stop, and return nil, otherwise, return self." - anArray - inject: self - into: - [ : dictOrArray : pathElem | dictOrArray - at: pathElem - ifPresent: [ : node | aBlock value: pathElem value: node ] - ifAbsent: [ ^ nil ] ]. - ^ self! Item was added: + ----- Method: JsonTests>>testNonDictionaryJsonObject (in category 'tests') ----- + testNonDictionaryJsonObject + self + render: {'a' -> 1. 'b' -> 2} + equals: '{"a":1,"b":2}'! Item was added: + ----- Method: JsonTests>>testPathAccess (in category 'tests') ----- + testPathAccess + | json lost | json := Json readFrom: '{ + "smalltalk" : { + "platformName":"unix", + "classes" : [ + { "id" : 3557, "name":"Integer" }, + { "id" : 3558, "name":"Float" }, + { "id" : 3559, "name":"Fraction" } + ] + } + }' readStream. + self assert: (json jsonAtPath: #('smalltalk' 'platformName')) = 'unix'. + "With array in the path." + self assert: (json jsonAtPath: #('smalltalk' 'classes' 1 'id')) = 3557. + self assert: (json jsonAtPath: #('smalltalk' 'classes' 2 'name')) = 'Float'. + "No pathing into byte objects, only Json objects." + self + should: [json jsonAtPath: #('smalltalk' 'classes' 2 'name' "Not allowed --->" 1)] + raise: Error. + "Key not found." + self + should: [ json jsonAtPath: #('smalltalk' 'wordSize') ] + raise: Error. + lost := false. + json + jsonAtPath: #('smalltalk' 'wordSize') + ifLost: [ : lostPosition | lost := true. self assert: lostPosition = 2 ]. + self assert: lost. + "Index OOB" + self + should: [ json jsonAtPath: #('smalltalk' 'classes' 99) ] + raise: Error. + lost := false. + json + jsonAtPath: #('smalltalk' 'classes' 99) + ifLost: [ : lostPosition | lost := true. self assert: lostPosition = 3 ]. + self assert: lost!

1 0

The Treated Inbox: System-dtl.1447.mcz
by commits＠source.squeak.org 22 Feb '24

22 Feb '24

David T. Lewis uploaded a new version of System to project The Treated Inbox: http://source.squeak.org/treated/System-dtl.1447.mcz ==================== Summary ==================== Name: System-dtl.1447 Author: dtl Time: 18 February 2024, 10:30:07.309835 am UUID: 532176ff-7a46-4306-a373-252ca1cc09f2 Ancestors: System-codefrau.1446 Move the low space watcher from SmalltalkImage to new class LowSpaceWatcher having a singleton with responsibility for the low space semaphore and low space watcher process. Add class and method comments and split lowSpaceWatcher into smaller methods to clarify steps in the process. Add #registerCleaner for adding savvy memory hogs to the memory hog registry. For organization and documentation only, no functional change to the low space watcher or memory policies. =============== Diff against System-codefrau.1446 =============== Item was added: + Object subclass: #LowSpaceWatcher + instanceVariableNames: 'lowSpaceProcess lowSpaceSemaphore' + classVariableNames: 'Default MemoryHogs' + poolDictionaries: '' + category: 'System-Support'! + + !LowSpaceWatcher commentStamp: 'dtl 1/28/2024 17:56' prior: 0! + LowSpaceWatcher is responsible for responding to a notification from the virtual machine that memory is low and that it (the VM) may soon be unable to support additional object memory allocations. A single default instance for the image manages both the low space semaphore and the process that waits on the semaphore to handle low space conditions. When the low space watcher is notified that memory is low, it attempts to identify the process likely associated with the low space condition and to provide a notifier to allow the problem condition to be corrected. + + If a low space condition is detected in the virtual machine, the low space semaphore is signalled either directly by the VM or indirectly through an OutOfMemory error following a failed primitive invocation. The VM is responsible for identifying low space conditions, and its behavior will vary depending on both the VM implementation and the memory system of the underlying platform operating system. In particular, on a virtual machine operating system the VM may continue to receive memory allocations from the operating system while the operating system attempts to support the memory requests by increased swapping to disk. Under these conditions, the low space semaphore may not be signalled because system memory still appears to be available, even though performance is severely degraded due to swapping. + + The VM may provide control of its memory usage, typically through command line parameters or VM parameters that can be set from the image. These parameters will affect when and if the low space watcher is signalled by the VM. + + A registry is maintained in class variable MemoryHogs to identify objects (classes) know how to release unneeded memory when sent the message #freeSomeSpace. The low space watcher process will send this message when a low spaced condition is encountered. + + To signal the low space watcher and simulate a low space condition, evaluate "LowSpaceWatcher default signalLowSpace".! Item was added: + ----- Method: LowSpaceWatcher class>>default (in category 'instance creation') ----- + default + "The singleton low space watcher." + + ^ Default ifNil: [ Default := self new start ] + ! Item was added: + ----- Method: LowSpaceWatcher class>>install (in category 'instance creation') ----- + install + "Start a process to watch for low-space conditions." + "Smalltalk installLowSpaceWatcher" + + self default stop; start + + ! Item was added: + ----- Method: LowSpaceWatcher class>>registerCleaner: (in category 'memory hog registry') ----- + registerCleaner: memoryCleaner + "Add memoryCleaner to the MemoryHog list where memoryCleaner is an object or class that responds to #freeSomeSpace." + + (memoryCleaner respondsTo: #freeSomeSpace) + ifFalse: [ ^ self error: memoryCleaner asString, ' does not understand #freeSomeSpace' ]. + (self default memoryHogs includes: memoryCleaner) + ifFalse: [ MemoryHogs add: memoryCleaner ].! Item was added: + ----- Method: LowSpaceWatcher class>>signalLowSpace (in category 'signal low space') ----- + signalLowSpace + "Signal the low-space semaphore to alert the user that space is running low." + + ^ self default signalLowSpace.! Item was added: + ----- Method: LowSpaceWatcher>>disableVirtualMachineNotifications (in category 'process steps') ----- + disableVirtualMachineNotifications + "Ask the virtual machine to stop sending low space interrupts, and forget the current semaphore and watcher process." + + self primSignalAtBytesLeft: 0. "disable low space interrupts" + self primLowSpaceSemaphore: nil. + lowSpaceProcess := nil. + ! Item was added: + ----- Method: LowSpaceWatcher>>findPreemptedProcess (in category 'process steps') ----- + findPreemptedProcess + "Find the process that was active at the time of the low space interrupt. Check + first if the virtual machine has recorded the process that was active at the time + that it detected the low space detection, otherwise answer the process that was + most recently preempted when the semaphore was signalled." + + | preemptedProcess | + preemptedProcess := (Smalltalk specialObjectsArray at: 23) + ifNil: [Processor preemptedProcess "if in-image signal of OutOfMemory"]. + Smalltalk specialObjectsArray at: 23 put: nil. + ^ preemptedProcess + + ! Item was added: + ----- Method: LowSpaceWatcher>>handleLowSpaceCondition (in category 'process') ----- + handleLowSpaceCondition + "A low space condition has been detected. Do whatever may be necessary to free + some memory in the image before proceeding." + + | preemptedProcess | + preemptedProcess := self findPreemptedProcess. + self notifyMemoryHogs ifFalse: [ + self logError: preemptedProcess. + self notifyUser: preemptedProcess ]. + + ! Item was added: + ----- Method: LowSpaceWatcher>>initializeVirtualMachineNotifications (in category 'process steps') ----- + initializeVirtualMachineNotifications + "Let the virtual machine know how to notify the image of low space conditions." + + Smalltalk specialObjectsArray at: 23 put: nil. "process causing low space will be saved here" + lowSpaceSemaphore := Semaphore new. + self primLowSpaceSemaphore: lowSpaceSemaphore. + self primSignalAtBytesLeft: Smalltalk lowSpaceThreshold. "enable low space interrupts" + ! Item was added: + ----- Method: LowSpaceWatcher>>logError: (in category 'process steps') ----- + logError: preemptedProcess + + Preferences logDebuggerStackToFile ifTrue: [ + Smalltalk + logError: 'Space is low' + inContext: preemptedProcess suspendedContext + to: 'LowSpaceDebug.log' ]. + ! Item was added: + ----- Method: LowSpaceWatcher>>lowSpaceChoices (in category 'memory space') ----- + lowSpaceChoices + "Return a notifier message string to be presented when space is running low." + + ^ 'Warning!! Squeak is almost out of memory!! + + Low space detection is now disabled. It will be restored when you close or proceed from this error notifier. Don''t panic, but do proceed with caution. + + Here are some suggestions: + + If you suspect an infinite recursion (the same methods calling each other again and again), then close this debugger, and fix the problem. + + If you want this computation to finish, then make more space available (read on) and choose "proceed" in this debugger. Here are some ways to make more space available... + > Close any windows that are not needed. + > Get rid of some large objects (e.g., images). + > Leave this window on the screen, choose "save as..." from the screen menu, quit, restart the Squeak VM with a larger memory allocation, then restart the image you just saved, and choose "proceed" in this window. + + If you want to investigate further, choose "debug" in this window. Do not use the debugger "fullStack" command unless you are certain that the stack is not very deep. (Trying to show the full stack will definitely use up all remaining memory if the low-space problem is caused by an infinite recursion!!). + + ' + ! Item was added: + ----- Method: LowSpaceWatcher>>lowSpaceWatcher (in category 'process') ----- + lowSpaceWatcher + "Wait until the low space semaphore is signalled, then take appropriate actions. This + method is run once in the low space watcher process. Before terminating, it schedules + a new process to handle the next low space condition." + + self safeToInstall ifFalse: [ ^ Beeper beep]. + self initializeVirtualMachineNotifications. + lowSpaceSemaphore wait. + self disableVirtualMachineNotifications; handleLowSpaceCondition. + self start. "schedule a new process to handle the next low space condition" + + ! Item was added: + ----- Method: LowSpaceWatcher>>lowSpaceWatcherProcess (in category 'process') ----- + lowSpaceWatcherProcess + "Answer the process in which lowSpaceWatcher is running. A process browser + can use this to identify and label the system wide low space watcher process." + ^lowSpaceProcess! Item was added: + ----- Method: LowSpaceWatcher>>memoryHogs (in category 'memory space') ----- + memoryHogs + "Answer the list of objects to notify with #freeSomeSpace if memory gets full." + + ^ MemoryHogs ifNil: [MemoryHogs := OrderedCollection new]! Item was added: + ----- Method: LowSpaceWatcher>>notifyMemoryHogs (in category 'process steps') ----- + notifyMemoryHogs + "Try to clean up memory hogs. Answer true if sufficient memory was released." + + | free | + self memoryHogs isEmpty + ifTrue: [ ^ false ] + ifFalse: [ free := Smalltalk bytesLeft. + self memoryHogs + do: [ :hog | hog freeSomeSpace ]. + ^ Smalltalk bytesLeft > free ] + + ! Item was added: + ----- Method: LowSpaceWatcher>>notifyUser: (in category 'process steps') ----- + notifyUser: preemptedProcess + "Interrupt the user to allow the low space condition to be corrected. The user + is now unprotected until the low space watcher is re-installed." + + Project current + interruptName: 'Space is low' + message: self lowSpaceChoices + preemptedProcess: preemptedProcess. + ! Item was added: + ----- Method: LowSpaceWatcher>>primLowSpaceSemaphore: (in category 'primitive access') ----- + primLowSpaceSemaphore: aSemaphore + "Primitive. Register the given Semaphore to be signalled when the + number of free bytes drops below some threshold. Disable low-space + interrupts if the argument is nil." + + <primitive: 124> + self primitiveFailed! Item was added: + ----- Method: LowSpaceWatcher>>primSignalAtBytesLeft: (in category 'primitive access') ----- + primSignalAtBytesLeft: numBytes + "Tell the interpreter the low-space threshold in bytes. When the free + space falls below this threshold, the interpreter will signal the low-space + semaphore, if one has been registered. Disable low-space interrupts if the + argument is zero. Fail if numBytes is not an Integer." + + <primitive: 125> + self primitiveFailed! Item was added: + ----- Method: LowSpaceWatcher>>safeToInstall (in category 'process steps') ----- + safeToInstall + "Free space must be above threshold before starting low space watcher" + + ^Smalltalk garbageCollectMost > Smalltalk lowSpaceThreshold + or: [Smalltalk garbageCollect > Smalltalk lowSpaceThreshold] + + ! Item was added: + ----- Method: LowSpaceWatcher>>signalLowSpace (in category 'memory space') ----- + signalLowSpace + "Signal the low-space semaphore to alert the user that space is running low." + + lowSpaceSemaphore signal.! Item was added: + ----- Method: LowSpaceWatcher>>start (in category 'initialize-release') ----- + start + "Start a new low space watcher process that will register a semaphore with the + virtual machine and wait for the semaphore to be signalled if a low space condition + is detected." + + lowSpaceProcess := [self lowSpaceWatcher] forkAt: Processor lowIOPriority. + ! Item was added: + ----- Method: LowSpaceWatcher>>stop (in category 'initialize-release') ----- + stop. + "Ask the virtual machine to disable low space interrupts, then terminate the watcher process." + + self primSignalAtBytesLeft: 0. "disable low-space interrupts" + lowSpaceProcess == nil ifFalse: [lowSpaceProcess terminate]. + lowSpaceProcess := lowSpaceSemaphore := nil. + ! Item was changed: Object subclass: #SmalltalkImage instanceVariableNames: 'globals' + classVariableNames: 'EndianCache LastImageName LastQuitLogPosition LastStats PlatformNameCache ShutDownList SourceFileVersionString StartUpList StartupStamp VMMakerVersion WordSize' - classVariableNames: 'EndianCache LastImageName LastQuitLogPosition LastStats LowSpaceProcess LowSpaceSemaphore MemoryHogs PlatformNameCache ShutDownList SourceFileVersionString StartUpList StartupStamp VMMakerVersion WordSize' poolDictionaries: '' category: 'System-Support'! !SmalltalkImage commentStamp: 'dtl 3/6/2010 14:00' prior: 0! I represent the current image and runtime environment, including system organization, the virtual machine, object memory, plugins and source files. My instance variable #globals is a reference to the system dictionary of global variables and class names. My singleton instance is called Smalltalk.! Item was changed: ----- Method: SmalltalkImage>>installLowSpaceWatcher (in category 'memory space') ----- installLowSpaceWatcher "Start a process to watch for low-space conditions." "Smalltalk installLowSpaceWatcher" + LowSpaceWatcher install - self primSignalAtBytesLeft: 0. "disable low-space interrupts" - LowSpaceProcess == nil ifFalse: [LowSpaceProcess terminate]. - LowSpaceProcess := [self lowSpaceWatcher] newProcess. - LowSpaceProcess priority: Processor lowIOPriority. - LowSpaceProcess resume. ! Item was removed: - ----- Method: SmalltalkImage>>lowSpaceChoices (in category 'memory space') ----- - lowSpaceChoices - "Return a notifier message string to be presented when space is running low." - - ^ 'Warning!! Squeak is almost out of memory!! - - Low space detection is now disabled. It will be restored when you close or proceed from this error notifier. Don''t panic, but do proceed with caution. - - Here are some suggestions: - - If you suspect an infinite recursion (the same methods calling each other again and again), then close this debugger, and fix the problem. - - If you want this computation to finish, then make more space available (read on) and choose "proceed" in this debugger. Here are some ways to make more space available... - > Close any windows that are not needed. - > Get rid of some large objects (e.g., images). - > Leave this window on the screen, choose "save as..." from the screen menu, quit, restart the Squeak VM with a larger memory allocation, then restart the image you just saved, and choose "proceed" in this window. - - If you want to investigate further, choose "debug" in this window. Do not use the debugger "fullStack" command unless you are certain that the stack is not very deep. (Trying to show the full stack will definitely use up all remaining memory if the low-space problem is caused by an infinite recursion!!). - - ' - ! Item was removed: - ----- Method: SmalltalkImage>>lowSpaceWatcher (in category 'memory space') ----- - lowSpaceWatcher - "Wait until the low space semaphore is signalled, then take appropriate actions." - - | free preemptedProcess | - self garbageCollectMost <= self lowSpaceThreshold - ifTrue: [self garbageCollect <= self lowSpaceThreshold - ifTrue: ["free space must be above threshold before - starting low space watcher" - ^ Beeper beep]]. - - Smalltalk specialObjectsArray at: 23 put: nil. "process causing low space will be saved here" - LowSpaceSemaphore := Semaphore new. - self primLowSpaceSemaphore: LowSpaceSemaphore. - self primSignalAtBytesLeft: self lowSpaceThreshold. "enable low space interrupts" - - LowSpaceSemaphore wait. "wait for a low space condition..." - - self primSignalAtBytesLeft: 0. "disable low space interrupts" - self primLowSpaceSemaphore: nil. - LowSpaceProcess := nil. - - "The process that was active at the time of the low space interrupt." - preemptedProcess := (Smalltalk specialObjectsArray at: 23) - ifNil: [Processor preemptedProcess "if in-image signal of OutOfMemory"]. - Smalltalk specialObjectsArray at: 23 put: nil. - - "Note: user now unprotected until the low space watcher is re-installed" - - self memoryHogs isEmpty - ifFalse: [free := self bytesLeft. - self memoryHogs - do: [ :hog | hog freeSomeSpace ]. - self bytesLeft > free - ifTrue: [ ^ self installLowSpaceWatcher ]]. - - Preferences logDebuggerStackToFile ifTrue: [ - self - logError: 'Space is low' - inContext: preemptedProcess suspendedContext - to: 'LowSpaceDebug.log']. - - Project current - interruptName: 'Space is low' - message: self lowSpaceChoices - preemptedProcess: preemptedProcess - ! Item was changed: ----- Method: SmalltalkImage>>lowSpaceWatcherProcess (in category 'memory space') ----- lowSpaceWatcherProcess + ^LowSpaceWatcher default ifNotNil: [ :watcher | watcher lowSpaceWatcherProcess ]! - ^LowSpaceProcess! Item was removed: - ----- Method: SmalltalkImage>>memoryHogs (in category 'memory space') ----- - memoryHogs - "Answer the list of objects to notify with #freeSomeSpace if memory gets full." - - ^ MemoryHogs ifNil: [MemoryHogs := OrderedCollection new]! Item was removed: - ----- Method: SmalltalkImage>>primLowSpaceSemaphore: (in category 'memory space') ----- - primLowSpaceSemaphore: aSemaphore - "Primitive. Register the given Semaphore to be signalled when the - number of free bytes drops below some threshold. Disable low-space - interrupts if the argument is nil." - - <primitive: 124> - self primitiveFailed! Item was removed: - ----- Method: SmalltalkImage>>primSignalAtBytesLeft: (in category 'memory space') ----- - primSignalAtBytesLeft: numBytes - "Tell the interpreter the low-space threshold in bytes. When the free - space falls below this threshold, the interpreter will signal the low-space - semaphore, if one has been registered. Disable low-space interrupts if the - argument is zero. Fail if numBytes is not an Integer." - - <primitive: 125> - self primitiveFailed! Item was removed: - ----- Method: SmalltalkImage>>signalLowSpace (in category 'memory space') ----- - signalLowSpace - "Signal the low-space semaphore to alert the user that space is running low." - - LowSpaceSemaphore signal.!

1 0

The Trunk: System-dtl.1448.mcz
by commits＠source.squeak.org 22 Feb '24

22 Feb '24

David T. Lewis uploaded a new version of System to project The Trunk: http://source.squeak.org/trunk/System-dtl.1448.mcz ==================== Summary ==================== Name: System-dtl.1448 Author: dtl Time: 21 February 2024, 7:08:38.598872 pm UUID: 109c5158-c1b6-4b7b-891a-380b5b9ee3de Ancestors: System-cmm.1447 Move the low space watcher from SmalltalkImage to new class LowSpaceWatcher having a singleton with responsibility for the low space semaphore and low space watcher process. Add class and method comments and split lowSpaceWatcher into smaller methods to clarify steps in the process. Add #registerCleaner for adding savvy memory hogs to the memory hog registry. For organization and documentation only, no functional change to the low space watcher or memory policies. =============== Diff against System-cmm.1447 =============== Item was added: + Object subclass: #LowSpaceWatcher + instanceVariableNames: 'lowSpaceProcess lowSpaceSemaphore' + classVariableNames: 'Default MemoryHogs' + poolDictionaries: '' + category: 'System-Support'! + + !LowSpaceWatcher commentStamp: 'dtl 1/28/2024 17:56' prior: 0! + LowSpaceWatcher is responsible for responding to a notification from the virtual machine that memory is low and that it (the VM) may soon be unable to support additional object memory allocations. A single default instance for the image manages both the low space semaphore and the process that waits on the semaphore to handle low space conditions. When the low space watcher is notified that memory is low, it attempts to identify the process likely associated with the low space condition and to provide a notifier to allow the problem condition to be corrected. + + If a low space condition is detected in the virtual machine, the low space semaphore is signalled either directly by the VM or indirectly through an OutOfMemory error following a failed primitive invocation. The VM is responsible for identifying low space conditions, and its behavior will vary depending on both the VM implementation and the memory system of the underlying platform operating system. In particular, on a virtual machine operating system the VM may continue to receive memory allocations from the operating system while the operating system attempts to support the memory requests by increased swapping to disk. Under these conditions, the low space semaphore may not be signalled because system memory still appears to be available, even though performance is severely degraded due to swapping. + + The VM may provide control of its memory usage, typically through command line parameters or VM parameters that can be set from the image. These parameters will affect when and if the low space watcher is signalled by the VM. + + A registry is maintained in class variable MemoryHogs to identify objects (classes) know how to release unneeded memory when sent the message #freeSomeSpace. The low space watcher process will send this message when a low spaced condition is encountered. + + To signal the low space watcher and simulate a low space condition, evaluate "LowSpaceWatcher default signalLowSpace".! Item was added: + ----- Method: LowSpaceWatcher class>>default (in category 'instance creation') ----- + default + "The singleton low space watcher." + + ^ Default ifNil: [ Default := self new start ] + ! Item was added: + ----- Method: LowSpaceWatcher class>>install (in category 'instance creation') ----- + install + "Start a process to watch for low-space conditions." + "Smalltalk installLowSpaceWatcher" + + self default stop; start + + ! Item was added: + ----- Method: LowSpaceWatcher class>>registerCleaner: (in category 'memory hog registry') ----- + registerCleaner: memoryCleaner + "Add memoryCleaner to the MemoryHog list where memoryCleaner is an object or class that responds to #freeSomeSpace." + + (memoryCleaner respondsTo: #freeSomeSpace) + ifFalse: [ ^ self error: memoryCleaner asString, ' does not understand #freeSomeSpace' ]. + (self default memoryHogs includes: memoryCleaner) + ifFalse: [ MemoryHogs add: memoryCleaner ].! Item was added: + ----- Method: LowSpaceWatcher class>>signalLowSpace (in category 'signal low space') ----- + signalLowSpace + "Signal the low-space semaphore to alert the user that space is running low." + + ^ self default signalLowSpace.! Item was added: + ----- Method: LowSpaceWatcher>>disableVirtualMachineNotifications (in category 'process steps') ----- + disableVirtualMachineNotifications + "Ask the virtual machine to stop sending low space interrupts, and forget the current semaphore and watcher process." + + self primSignalAtBytesLeft: 0. "disable low space interrupts" + self primLowSpaceSemaphore: nil. + lowSpaceProcess := nil. + ! Item was added: + ----- Method: LowSpaceWatcher>>findPreemptedProcess (in category 'process steps') ----- + findPreemptedProcess + "Find the process that was active at the time of the low space interrupt. Check + first if the virtual machine has recorded the process that was active at the time + that it detected the low space detection, otherwise answer the process that was + most recently preempted when the semaphore was signalled." + + | preemptedProcess | + preemptedProcess := (Smalltalk specialObjectsArray at: 23) + ifNil: [Processor preemptedProcess "if in-image signal of OutOfMemory"]. + Smalltalk specialObjectsArray at: 23 put: nil. + ^ preemptedProcess + + ! Item was added: + ----- Method: LowSpaceWatcher>>handleLowSpaceCondition (in category 'process') ----- + handleLowSpaceCondition + "A low space condition has been detected. Do whatever may be necessary to free + some memory in the image before proceeding." + + | preemptedProcess | + preemptedProcess := self findPreemptedProcess. + self notifyMemoryHogs ifFalse: [ + self logError: preemptedProcess. + self notifyUser: preemptedProcess ]. + + ! Item was added: + ----- Method: LowSpaceWatcher>>initializeVirtualMachineNotifications (in category 'process steps') ----- + initializeVirtualMachineNotifications + "Let the virtual machine know how to notify the image of low space conditions." + + Smalltalk specialObjectsArray at: 23 put: nil. "process causing low space will be saved here" + lowSpaceSemaphore := Semaphore new. + self primLowSpaceSemaphore: lowSpaceSemaphore. + self primSignalAtBytesLeft: Smalltalk lowSpaceThreshold. "enable low space interrupts" + ! Item was added: + ----- Method: LowSpaceWatcher>>logError: (in category 'process steps') ----- + logError: preemptedProcess + + Preferences logDebuggerStackToFile ifTrue: [ + Smalltalk + logError: 'Space is low' + inContext: preemptedProcess suspendedContext + to: 'LowSpaceDebug.log' ]. + ! Item was added: + ----- Method: LowSpaceWatcher>>lowSpaceChoices (in category 'memory space') ----- + lowSpaceChoices + "Return a notifier message string to be presented when space is running low." + + ^ 'Warning!! Squeak is almost out of memory!! + + Low space detection is now disabled. It will be restored when you close or proceed from this error notifier. Don''t panic, but do proceed with caution. + + Here are some suggestions: + + If you suspect an infinite recursion (the same methods calling each other again and again), then close this debugger, and fix the problem. + + If you want this computation to finish, then make more space available (read on) and choose "proceed" in this debugger. Here are some ways to make more space available... + > Close any windows that are not needed. + > Get rid of some large objects (e.g., images). + > Leave this window on the screen, choose "save as..." from the screen menu, quit, restart the Squeak VM with a larger memory allocation, then restart the image you just saved, and choose "proceed" in this window. + + If you want to investigate further, choose "debug" in this window. Do not use the debugger "fullStack" command unless you are certain that the stack is not very deep. (Trying to show the full stack will definitely use up all remaining memory if the low-space problem is caused by an infinite recursion!!). + + ' + ! Item was added: + ----- Method: LowSpaceWatcher>>lowSpaceWatcher (in category 'process') ----- + lowSpaceWatcher + "Wait until the low space semaphore is signalled, then take appropriate actions. This + method is run once in the low space watcher process. Before terminating, it schedules + a new process to handle the next low space condition." + + self safeToInstall ifFalse: [ ^ Beeper beep]. + self initializeVirtualMachineNotifications. + lowSpaceSemaphore wait. + self disableVirtualMachineNotifications; handleLowSpaceCondition. + self start. "schedule a new process to handle the next low space condition" + + ! Item was added: + ----- Method: LowSpaceWatcher>>lowSpaceWatcherProcess (in category 'process') ----- + lowSpaceWatcherProcess + "Answer the process in which lowSpaceWatcher is running. A process browser + can use this to identify and label the system wide low space watcher process." + ^lowSpaceProcess! Item was added: + ----- Method: LowSpaceWatcher>>memoryHogs (in category 'memory space') ----- + memoryHogs + "Answer the list of objects to notify with #freeSomeSpace if memory gets full." + + ^ MemoryHogs ifNil: [MemoryHogs := OrderedCollection new]! Item was added: + ----- Method: LowSpaceWatcher>>notifyMemoryHogs (in category 'process steps') ----- + notifyMemoryHogs + "Try to clean up memory hogs. Answer true if sufficient memory was released." + + | free | + self memoryHogs isEmpty + ifTrue: [ ^ false ] + ifFalse: [ free := Smalltalk bytesLeft. + self memoryHogs + do: [ :hog | hog freeSomeSpace ]. + ^ Smalltalk bytesLeft > free ] + + ! Item was added: + ----- Method: LowSpaceWatcher>>notifyUser: (in category 'process steps') ----- + notifyUser: preemptedProcess + "Interrupt the user to allow the low space condition to be corrected. The user + is now unprotected until the low space watcher is re-installed." + + Project current + interruptName: 'Space is low' + message: self lowSpaceChoices + preemptedProcess: preemptedProcess. + ! Item was added: + ----- Method: LowSpaceWatcher>>primLowSpaceSemaphore: (in category 'primitive access') ----- + primLowSpaceSemaphore: aSemaphore + "Primitive. Register the given Semaphore to be signalled when the + number of free bytes drops below some threshold. Disable low-space + interrupts if the argument is nil." + + <primitive: 124> + self primitiveFailed! Item was added: + ----- Method: LowSpaceWatcher>>primSignalAtBytesLeft: (in category 'primitive access') ----- + primSignalAtBytesLeft: numBytes + "Tell the interpreter the low-space threshold in bytes. When the free + space falls below this threshold, the interpreter will signal the low-space + semaphore, if one has been registered. Disable low-space interrupts if the + argument is zero. Fail if numBytes is not an Integer." + + <primitive: 125> + self primitiveFailed! Item was added: + ----- Method: LowSpaceWatcher>>safeToInstall (in category 'process steps') ----- + safeToInstall + "Free space must be above threshold before starting low space watcher" + + ^Smalltalk garbageCollectMost > Smalltalk lowSpaceThreshold + or: [Smalltalk garbageCollect > Smalltalk lowSpaceThreshold] + + ! Item was added: + ----- Method: LowSpaceWatcher>>signalLowSpace (in category 'memory space') ----- + signalLowSpace + "Signal the low-space semaphore to alert the user that space is running low." + + lowSpaceSemaphore signal.! Item was added: + ----- Method: LowSpaceWatcher>>start (in category 'initialize-release') ----- + start + "Start a new low space watcher process that will register a semaphore with the + virtual machine and wait for the semaphore to be signalled if a low space condition + is detected." + + lowSpaceProcess := [self lowSpaceWatcher] forkAt: Processor lowIOPriority. + ! Item was added: + ----- Method: LowSpaceWatcher>>stop (in category 'initialize-release') ----- + stop. + "Ask the virtual machine to disable low space interrupts, then terminate the watcher process." + + self primSignalAtBytesLeft: 0. "disable low-space interrupts" + lowSpaceProcess == nil ifFalse: [lowSpaceProcess terminate]. + lowSpaceProcess := lowSpaceSemaphore := nil. + ! Item was changed: Object subclass: #SmalltalkImage instanceVariableNames: 'globals' + classVariableNames: 'EndianCache LastImageName LastQuitLogPosition LastStats PlatformNameCache ShutDownList SourceFileVersionString StartUpList StartupStamp VMMakerVersion WordSize' - classVariableNames: 'EndianCache LastImageName LastQuitLogPosition LastStats LowSpaceProcess LowSpaceSemaphore MemoryHogs PlatformNameCache ShutDownList SourceFileVersionString StartUpList StartupStamp VMMakerVersion WordSize' poolDictionaries: '' category: 'System-Support'! !SmalltalkImage commentStamp: 'dtl 3/6/2010 14:00' prior: 0! I represent the current image and runtime environment, including system organization, the virtual machine, object memory, plugins and source files. My instance variable #globals is a reference to the system dictionary of global variables and class names. My singleton instance is called Smalltalk.! Item was changed: ----- Method: SmalltalkImage>>installLowSpaceWatcher (in category 'memory space') ----- installLowSpaceWatcher "Start a process to watch for low-space conditions." "Smalltalk installLowSpaceWatcher" + LowSpaceWatcher install - self primSignalAtBytesLeft: 0. "disable low-space interrupts" - LowSpaceProcess == nil ifFalse: [LowSpaceProcess terminate]. - LowSpaceProcess := [self lowSpaceWatcher] newProcess. - LowSpaceProcess priority: Processor lowIOPriority. - LowSpaceProcess resume. ! Item was removed: - ----- Method: SmalltalkImage>>lowSpaceChoices (in category 'memory space') ----- - lowSpaceChoices - "Return a notifier message string to be presented when space is running low." - - ^ 'Warning!! Squeak is almost out of memory!! - - Low space detection is now disabled. It will be restored when you close or proceed from this error notifier. Don''t panic, but do proceed with caution. - - Here are some suggestions: - - If you suspect an infinite recursion (the same methods calling each other again and again), then close this debugger, and fix the problem. - - If you want this computation to finish, then make more space available (read on) and choose "proceed" in this debugger. Here are some ways to make more space available... - > Close any windows that are not needed. - > Get rid of some large objects (e.g., images). - > Leave this window on the screen, choose "save as..." from the screen menu, quit, restart the Squeak VM with a larger memory allocation, then restart the image you just saved, and choose "proceed" in this window. - - If you want to investigate further, choose "debug" in this window. Do not use the debugger "fullStack" command unless you are certain that the stack is not very deep. (Trying to show the full stack will definitely use up all remaining memory if the low-space problem is caused by an infinite recursion!!). - - ' - ! Item was removed: - ----- Method: SmalltalkImage>>lowSpaceWatcher (in category 'memory space') ----- - lowSpaceWatcher - "Wait until the low space semaphore is signalled, then take appropriate actions." - - | free preemptedProcess | - self garbageCollectMost <= self lowSpaceThreshold - ifTrue: [self garbageCollect <= self lowSpaceThreshold - ifTrue: ["free space must be above threshold before - starting low space watcher" - ^ Beeper beep]]. - - Smalltalk specialObjectsArray at: 23 put: nil. "process causing low space will be saved here" - LowSpaceSemaphore := Semaphore new. - self primLowSpaceSemaphore: LowSpaceSemaphore. - self primSignalAtBytesLeft: self lowSpaceThreshold. "enable low space interrupts" - - LowSpaceSemaphore wait. "wait for a low space condition..." - - self primSignalAtBytesLeft: 0. "disable low space interrupts" - self primLowSpaceSemaphore: nil. - LowSpaceProcess := nil. - - "The process that was active at the time of the low space interrupt." - preemptedProcess := (Smalltalk specialObjectsArray at: 23) - ifNil: [Processor preemptedProcess "if in-image signal of OutOfMemory"]. - Smalltalk specialObjectsArray at: 23 put: nil. - - "Note: user now unprotected until the low space watcher is re-installed" - - self memoryHogs isEmpty - ifFalse: [free := self bytesLeft. - self memoryHogs - do: [ :hog | hog freeSomeSpace ]. - self bytesLeft > free - ifTrue: [ ^ self installLowSpaceWatcher ]]. - - Preferences logDebuggerStackToFile ifTrue: [ - self - logError: 'Space is low' - inContext: preemptedProcess suspendedContext - to: 'LowSpaceDebug.log']. - - Project current - interruptName: 'Space is low' - message: self lowSpaceChoices - preemptedProcess: preemptedProcess - ! Item was changed: ----- Method: SmalltalkImage>>lowSpaceWatcherProcess (in category 'memory space') ----- lowSpaceWatcherProcess + ^LowSpaceWatcher default ifNotNil: [ :watcher | watcher lowSpaceWatcherProcess ]! - ^LowSpaceProcess! Item was removed: - ----- Method: SmalltalkImage>>memoryHogs (in category 'memory space') ----- - memoryHogs - "Answer the list of objects to notify with #freeSomeSpace if memory gets full." - - ^ MemoryHogs ifNil: [MemoryHogs := OrderedCollection new]! Item was removed: - ----- Method: SmalltalkImage>>primLowSpaceSemaphore: (in category 'memory space') ----- - primLowSpaceSemaphore: aSemaphore - "Primitive. Register the given Semaphore to be signalled when the - number of free bytes drops below some threshold. Disable low-space - interrupts if the argument is nil." - - <primitive: 124> - self primitiveFailed! Item was removed: - ----- Method: SmalltalkImage>>primSignalAtBytesLeft: (in category 'memory space') ----- - primSignalAtBytesLeft: numBytes - "Tell the interpreter the low-space threshold in bytes. When the free - space falls below this threshold, the interpreter will signal the low-space - semaphore, if one has been registered. Disable low-space interrupts if the - argument is zero. Fail if numBytes is not an Integer." - - <primitive: 125> - self primitiveFailed! Item was removed: - ----- Method: SmalltalkImage>>signalLowSpace (in category 'memory space') ----- - signalLowSpace - "Signal the low-space semaphore to alert the user that space is running low." - - LowSpaceSemaphore signal.!

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

Packages February 2024