Squeak-dev October 2014

squeak-dev@lists.squeakfoundation.org

46 participants
184 discussions

The Trunk: Monticello-mtf.603.mcz
by commits＠source.squeak.org 26 Oct '14

26 Oct '14

Matthew Fulmer uploaded a new version of Monticello to project The Trunk: http://source.squeak.org/trunk/Monticello-mtf.603.mcz ==================== Summary ==================== Name: Monticello-mtf.603 Author: mtf Time: 26 October 2014, 6:53:22.573 am UUID: a68bf6b3-1e73-4d62-9fce-cc860422ba2e Ancestors: Monticello-ul.602 Print the right thing for class-side traits =============== Diff against Monticello-ul.602 =============== Item was changed: ----- Method: MCClassDefinition>>printClassSideDefinitionOn: (in category 'printing') ----- printClassSideDefinitionOn: stream stream nextPutAll: self className; nextPutAll: ' class '; + cr; tab. + self hasClassTraitComposition ifTrue: [ + stream + nextPutAll: 'uses: '; + nextPutAll: self classTraitCompositionString; + cr; tab ]. + stream - cr; tab; nextPutAll: 'instanceVariableNames: '; store: self classInstanceVariablesString! Item was added: + ----- Method: MCTraitDefinition>>printClassSideDefinitionOn: (in category 'printing') ----- + printClassSideDefinitionOn: stream + stream + nextPutAll: self className; + nextPutAll: ' classTrait '; + cr; tab; + nextPutAll: 'uses: '; + nextPutAll: self classTraitCompositionString!

1 0

Why isn't BlockClosureTest>>testCull failing?
by David T. Lewis 26 Oct '14

26 Oct '14

If we have this: [ :x | ] value: 1 ==> nil And this: ([ :x | ] cull: 1) ==> nil But in BlockClosureTest>>testCull, we have this: self assert: 1 equals: ([ :x | ] cull: 1). The test passes. How is this possible? If I rewrite that line in the test as follows, then it fails as I would expect: foo := [ :x | ] cull: 1. self assert: 1 equals: foo. Ah, but wait. If I revert the test method back to the original, presumably recompiling it in the process, the test now fails exactly as I would have expected. The test also fails in the way I would expect in a 68002 format image, which is what prompted me to ask the question. The previous version of #testCull and related tests seem to pass and look plausibly correct to me. The current (newer) version looks wrong to me, but seems to inexplicably pass until the test is recompiled. Dave

2 1

Daily Commit Log
by commits＠source.squeak.org 26 Oct '14

26 Oct '14

Changes to Trunk (http://source.squeak.org/trunk.html) in the last 24 hours: http://lists.squeakfoundation.org/pipermail/packages/2014-October/007345.ht… Name: Installer-Core-ul.395 Ancestors: Installer-Core-nice.394 - added #squeakInbox and #squeakTrunk accessors =============================================

1 0

The Inbox: Files-ul.140.mcz
by commits＠source.squeak.org 26 Oct '14

26 Oct '14

A new version of Files was added to project The Inbox: http://source.squeak.org/inbox/Files-ul.140.mcz ==================== Summary ==================== Name: Files-ul.140 Author: ul Time: 26 October 2014, 1:45:59.442 am UUID: fd217dff-eddb-40c4-93fa-41da16965596 Ancestors: Files-eem.138 - use the new ExternalSemaphoreTable API =============== Diff against Files-eem.138 =============== Item was changed: ----- Method: AsyncFile>>close (in category 'as yet unclassified') ----- close fileHandle ifNil: [^ self]. "already closed" self primClose: fileHandle. + ExternalSemaphoreTable unregisterExternalObject: semaphore. - Smalltalk unregisterExternalObject: semaphore. semaphore := nil. fileHandle := nil. ! Item was changed: ----- Method: AsyncFile>>open:forWrite: (in category 'as yet unclassified') ----- open: fullFileName forWrite: aBoolean "Open a file of the given name, and return a handle for that file. Answer the receiver if the primitive succeeds, nil otherwise. If openForWrite is true, then: if there is no existing file with this name, then create one else open the existing file in read-write mode otherwise: if there is an existing file with this name, then open it read-only else answer nil." "Note: if an exisiting file is opened for writing, it is NOT truncated. If truncation is desired, the file should be deleted before being opened as an asynchronous file." "Note: On some platforms (e.g., Mac), a file can only have one writer at a time." - | semaIndex | name := fullFileName. writeable := aBoolean. + ^ExternalSemaphoreTable newExternalSemaphoreDo: [ :newSemaphore :index | + fileHandle := self primOpen: name asVmPathName forWrite: writeable semaIndex: index. + fileHandle + ifNotNil: [ + semaphore := newSemaphore. + self ] + ifNil: [ + ExternalSemaphoreTable unregisterExternalObject: newSemaphore. + nil ] ]! - semaphore := Semaphore new. - semaIndex := Smalltalk registerExternalObject: semaphore. - fileHandle := self primOpen: name asVmPathName forWrite: writeable semaIndex: semaIndex. - fileHandle ifNil: [ - Smalltalk unregisterExternalObject: semaphore. - semaphore := nil. - ^ nil]. - ! Item was changed: ----- Method: StandardFileStream>>post:target:url:ifError: (in category 'browser requests') ----- post: data target: target url: url ifError: errorBlock "Post data to the given URL. The returned file stream contains the reply of the server. If Squeak is not running in a browser evaluate errorBlock" + - | sema index request result | self waitBrowserReadyFor: self defaultBrowserReadyWait ifFail: [^errorBlock value]. + ExternalSemaphoreTable newExternalSemaphoreDo: [ :semaphore :index | + | request result | + request := self primURLPost: url target: target data: data semaIndex: index. + request ifNil: [ + ExternalSemaphoreTable unregisterExternalObject: semaphore. + ^errorBlock value ]. + [ semaphore wait. "until something happens" + result := self primURLRequestState: request. + result == nil ] whileTrue. + result ifTrue: [ fileID := self primURLRequestFileHandle: request ]. - sema := Semaphore new. - index := Smalltalk registerExternalObject: sema. - request := self primURLPost: url target: target data: data semaIndex: index. - request == nil ifTrue:[ - - Smalltalk unregisterExternalObject: sema. - ^errorBlock value. - ] ifFalse:[ - [sema wait. "until something happens" - result := self primURLRequestState: request. - result == nil] whileTrue. - result ifTrue:[fileID := self primURLRequestFileHandle: request]. self primURLRequestDestroy: request. + ExternalSemaphoreTable unregisterExternalObject: semaphore ]. + fileID ifNil: [ ^nil ]. - ]. - Smalltalk unregisterExternalObject: sema. - fileID == nil ifTrue:[^nil]. self register. name := url. rwmode := false. buffer1 := String new: 1. + self enableReadBuffering! - self enableReadBuffering - ! Item was changed: ----- Method: StandardFileStream>>requestURL:target:ifError: (in category 'browser requests') ----- requestURL: url target: target ifError: errorBlock "Request to go to the target for the given URL. If Squeak is not running in a browser evaluate errorBlock" - | sema index request result | self waitBrowserReadyFor: self defaultBrowserReadyWait ifFail: [^errorBlock value]. + ExternalSemaphoreTable newExternalSemaphoreDo: [ :semaphore :index | + | request result | + request := self primURLRequest: url target: target semaIndex: index. + request ifNil: [ + ExternalSemaphoreTable unregisterExternalObject: semaphore. + ^errorBlock value ]. + [ semaphore wait. "until something happens" + result := self primURLRequestState: request. + result == nil ] whileTrue. - sema := Semaphore new. - index := Smalltalk registerExternalObject: sema. - request := self primURLRequest: url target: target semaIndex: index. - request == nil ifTrue:[ - - Smalltalk unregisterExternalObject: sema. - ^errorBlock value. - ] ifFalse:[ - [sema wait. "until something happens" - result := self primURLRequestState: request. - result == nil] whileTrue. self primURLRequestDestroy: request. + ExternalSemaphoreTable unregisterExternalObject: semaphore ]. + fileID ifNil: [ ^nil ]. - ]. - Smalltalk unregisterExternalObject: sema. - fileID == nil ifTrue:[^nil]. self register. name := url. rwmode := false. buffer1 := String new: 1. + self enableReadBuffering! - self enableReadBuffering - ! Item was changed: ----- Method: StandardFileStream>>requestURLStream:ifError: (in category 'browser requests') ----- requestURLStream: url ifError: errorBlock "Request a FileStream for the given URL. If Squeak is not running in a browser evaluate errorBlock" "FileStream requestURLStream:'http://www.squeak.org'" + - | sema index request result | self waitBrowserReadyFor: self defaultBrowserReadyWait ifFail: [^errorBlock value]. + ExternalSemaphoreTable newExternalSemaphoreDo: [ :semaphore :index | + | request result | + request := self primURLRequest: url semaIndex: index. + request ifNil: [ + ExternalSemaphoreTable unregisterExternalObject: semaphore. + ^errorBlock value ]. + [ semaphore wait. "until something happens" + result := self primURLRequestState: request. + result == nil ] whileTrue. + result ifTrue: [ fileID := self primURLRequestFileHandle: request ]. - sema := Semaphore new. - index := Smalltalk registerExternalObject: sema. - request := self primURLRequest: url semaIndex: index. - request == nil ifTrue:[ - - Smalltalk unregisterExternalObject: sema. - ^errorBlock value. - ] ifFalse:[ - [sema wait. "until something happens" - result := self primURLRequestState: request. - result == nil] whileTrue. - result ifTrue:[fileID := self primURLRequestFileHandle: request]. self primURLRequestDestroy: request. + ExternalSemaphoreTable unregisterExternalObject: semaphore ]. + fileID ifNil: [ ^nil ]. - ]. - Smalltalk unregisterExternalObject: sema. - fileID == nil ifTrue:[^nil]. self register. name := url. rwmode := false. buffer1 := String new: 1. + self enableReadBuffering! - self enableReadBuffering - !

1 0

The Inbox: Kernel-ul.883.mcz
by commits＠source.squeak.org 26 Oct '14

26 Oct '14

A new version of Kernel was added to project The Inbox: http://source.squeak.org/inbox/Kernel-ul.883.mcz ==================== Summary ==================== Name: Kernel-ul.883 Author: ul Time: 26 October 2014, 1:45:11.609 am UUID: 362f65e8-603d-452d-b26d-6df0bc85022b Ancestors: Kernel-ul.880 - use ExternalSemaphoreTable instead of Smalltalk - added #excessSignals accessor to Semaphore =============== Diff against Kernel-ul.880 =============== Item was changed: ----- Method: EventSensor>>shutDown (in category 'initialize') ----- shutDown + super shutDown. EventTicklerProcess ifNotNil: [ EventTicklerProcess terminate. EventTicklerProcess := nil. ]. + inputSemaphore ifNotNil:[ + ExternalSemaphoreTable unregisterExternalObject: inputSemaphore ]. - inputSemaphore ifNotNil:[Smalltalk unregisterExternalObject: inputSemaphore]. ! Item was changed: ----- Method: EventSensor>>startUp (in category 'initialize') ----- startUp "Run the I/O process" self initialize. + self primSetInputSemaphore: (ExternalSemaphoreTable registerExternalObject: inputSemaphore). - self primSetInputSemaphore: (Smalltalk registerExternalObject: inputSemaphore). super startUp. self installEventTickler. Smalltalk isMorphic ifTrue:[self flushAllButDandDEvents]. "Attempt to discover whether the input semaphore is actually being signaled." hasInputSemaphore := false. inputSemaphore initSignals. ! Item was added: + ----- Method: Semaphore>>excessSignals (in category 'accessing') ----- + excessSignals + + ^excessSignals!

1 0

The Inbox: Network-ul.154.mcz
by commits＠source.squeak.org 26 Oct '14

26 Oct '14

A new version of Network was added to project The Inbox: http://source.squeak.org/inbox/Network-ul.154.mcz ==================== Summary ==================== Name: Network-ul.154 Author: ul Time: 26 October 2014, 1:44:11.795 am UUID: 02f2fb48-c1da-4d22-b691-8b96c1886300 Ancestors: Network-ul.152 - use the new ExternalSemaphoreTable API - unifed socket initialization - unregister ResolverSemaphore when the network initialization fails =============== Diff against Network-ul.152 =============== Item was changed: ----- Method: NetNameResolver class>>initializeNetwork (in category 'network initialization') ----- initializeNetwork "Initialize the network drivers and record the semaphore to be used by the resolver. Do nothing if the network is already initialized. Evaluate the given block if network initialization fails." "NetNameResolver initializeNetwork" - | semaIndex | self resolverStatus = ResolverUninitialized ifFalse: [^HaveNetwork := true]. "network is already initialized" HaveNetwork := false. "in case abort" + ExternalSemaphoreTable newExternalSemaphoreDo: [ :semaphore :index | + ResolverSemaphore := semaphore. + "result is nil if network initialization failed, self if it succeeds" + (self primInitializeNetwork: index) + ifNil: [ + ExternalSemaphoreTable unregisterExternalObject: ResolverSemaphore. + ResolverSemaphore := nil. + NoNetworkError signal: 'failed network initialization'] + ifNotNil: [ HaveNetwork := true ] ]. - ResolverSemaphore := Semaphore new. - semaIndex := Smalltalk registerExternalObject: ResolverSemaphore. + self initializeOldNetworkFlag! - "result is nil if network initialization failed, self if it succeeds" - (self primInitializeNetwork: semaIndex) - ifNil: [NoNetworkError signal: 'failed network initialization'] - ifNotNil: [HaveNetwork := true]. - - self initializeOldNetworkFlag - ! Item was changed: ----- Method: Socket>>acceptFrom: (in category 'initialize-destroy') ----- acceptFrom: aSocket "Initialize a new socket handle from an accept call" - | semaIndex readSemaIndex writeSemaIndex | + self initializeSocketHandleUsing: [ :semaIndex :readSemaIndex :writeSemaIndex | + self + primAcceptFrom: aSocket socketHandle + receiveBufferSize: 8000 + sendBufSize: 8000 + semaIndex: semaIndex + readSemaIndex: readSemaIndex + writeSemaIndex: writeSemaIndex ]! - semaphore := Semaphore new. - readSemaphore := Semaphore new. - writeSemaphore := Semaphore new. - semaIndex := Smalltalk registerExternalObject: semaphore. - readSemaIndex := Smalltalk registerExternalObject: readSemaphore. - writeSemaIndex := Smalltalk registerExternalObject: writeSemaphore. - socketHandle := self primAcceptFrom: aSocket socketHandle - receiveBufferSize: 8000 - sendBufSize: 8000 - semaIndex: semaIndex - readSemaIndex: readSemaIndex - writeSemaIndex: writeSemaIndex. - socketHandle - ifNotNil: [ self register ] - ifNil: [ "socket creation failed" - Smalltalk unregisterExternalObject: semaphore. - Smalltalk unregisterExternalObject: readSemaphore. - Smalltalk unregisterExternalObject: writeSemaphore. - readSemaphore := writeSemaphore := semaphore := nil ] - ! Item was changed: ----- Method: Socket>>destroy (in category 'initialize-destroy') ----- destroy "Destroy this socket. Its connection, if any, is aborted and its resources are freed. Do nothing if the socket has already been destroyed (i.e., if its socketHandle is nil)." socketHandle ifNotNil: [ self isValid ifTrue: [ self primSocketDestroy: socketHandle ]. + ExternalSemaphoreTable unregisterExternalObjects: { + semaphore. + readSemaphore. + writeSemaphore }. - Smalltalk unregisterExternalObject: semaphore. - Smalltalk unregisterExternalObject: readSemaphore. - Smalltalk unregisterExternalObject: writeSemaphore. socketHandle := nil. readSemaphore := writeSemaphore := semaphore := nil. self unregister ]! Item was changed: ----- Method: Socket>>finalize (in category 'finalization') ----- finalize + self primSocketDestroyGently: socketHandle. + ExternalSemaphoreTable unregisterExternalObjects: { + semaphore. + readSemaphore. + writeSemaphore } - Smalltalk unregisterExternalObject: semaphore. - Smalltalk unregisterExternalObject: readSemaphore. - Smalltalk unregisterExternalObject: writeSemaphore. ! Item was changed: ----- Method: Socket>>initialize: (in category 'initialize-destroy') ----- initialize: socketType "Initialize a new socket handle. If socket creation fails, socketHandle will be set to nil." - | semaIndex readSemaIndex writeSemaIndex | + self initializeSocketHandleUsing: [ :semaIndex :readSemaIndex :writeSemaIndex | - semaphore := Semaphore new. - readSemaphore := Semaphore new. - writeSemaphore := Semaphore new. - semaIndex := Smalltalk registerExternalObject: semaphore. - readSemaIndex := Smalltalk registerExternalObject: readSemaphore. - writeSemaIndex := Smalltalk registerExternalObject: writeSemaphore. - socketHandle := self primSocketCreateNetwork: 0 type: socketType receiveBufferSize: 8000 sendBufSize: 8000 semaIndex: semaIndex readSemaIndex: readSemaIndex + writeSemaIndex: writeSemaIndex ]! - writeSemaIndex: writeSemaIndex. - - socketHandle - ifNotNil: [ self register ] - ifNil: [ "socket creation failed" - Smalltalk unregisterExternalObject: semaphore. - Smalltalk unregisterExternalObject: readSemaphore. - Smalltalk unregisterExternalObject: writeSemaphore. - readSemaphore := writeSemaphore := semaphore := nil ] - ! Item was changed: ----- Method: Socket>>initialize:family: (in category 'initialize-destroy') ----- initialize: socketType family: family "Initialize a new socket handle. If socket creation fails, socketHandle will be set to nil." - | semaIndex readSemaIndex writeSemaIndex | + NetNameResolver useOldNetwork ifTrue: [ ^self initialize: socketType ]. + self initializeSocketHandleUsing: [ :semaIndex :readSemaIndex :writeSemaIndex | - NetNameResolver useOldNetwork ifTrue: [^self initialize: socketType]. - semaphore := Semaphore new. - readSemaphore := Semaphore new. - writeSemaphore := Semaphore new. - semaIndex := Smalltalk registerExternalObject: semaphore. - readSemaIndex := Smalltalk registerExternalObject: readSemaphore. - writeSemaIndex := Smalltalk registerExternalObject: writeSemaphore. - socketHandle := self primSocketCreateNetwork: family type: socketType receiveBufferSize: 8000 sendBufSize: 8000 semaIndex: semaIndex readSemaIndex: readSemaIndex + writeSemaIndex: writeSemaIndex ]! - writeSemaIndex: writeSemaIndex. - - socketHandle - ifNotNil: [ self register ] - ifNil: [ "socket creation failed" - Smalltalk unregisterExternalObject: semaphore. - Smalltalk unregisterExternalObject: readSemaphore. - Smalltalk unregisterExternalObject: writeSemaphore. - readSemaphore := writeSemaphore := semaphore := nil ] - ! Item was added: + ----- Method: Socket>>initializeSocketHandleUsing: (in category 'initialize-destroy') ----- + initializeSocketHandleUsing: aBlock + "Initialize a new socket handle. If socket creation fails, socketHandle will be set to nil." + + | semaphoresAndIndexes semaphores indexes | + semaphoresAndIndexes := ExternalSemaphoreTable newExternalSemaphores: 3. + semaphores := semaphoresAndIndexes at: 1. + indexes := semaphoresAndIndexes at: 2. + semaphore := semaphores at: 1. + readSemaphore := semaphores at: 2. + writeSemaphore := semaphores at: 3. + (socketHandle := aBlock valueWithArguments: indexes) + ifNotNil: [ self register ] + ifNil: [ + "socket creation failed" + semaphore := readSemaphore := writeSemaphore := nil. + ExternalSemaphoreTable unregisterExternalObjects: semaphores ]!

1 0

The Inbox: System-ul.687.mcz
by commits＠source.squeak.org 26 Oct '14

26 Oct '14

A new version of System was added to project The Inbox: http://source.squeak.org/inbox/System-ul.687.mcz ==================== Summary ==================== Name: System-ul.687 Author: ul Time: 26 October 2014, 1:43:00.13 am UUID: 1a211671-bea3-4da5-97a1-0e95b851ef58 Ancestors: System-dtl.685 Updated ExternalSemaphoreTable to provide faster registration, and give better support to the current users. Notable changes: - the table is a separate object instead of a few class side methods, but the API is still on the class side - #newExternalSemaphore, #newExternalSemaphoreDo: and #newExternalSemaphores: provide fast and easy creation and registration of Semaphores - #unregisterExternalObjects: can unregister multiple objects faster - #externalObjects will return a copy of the externalObjectsArray - better scalability - the maxExternalSemaphores VM parameter will be incremented as the externalObjectsArray grows =============== Diff against System-dtl.685 =============== Item was changed: Object subclass: #ExternalSemaphoreTable + instanceVariableNames: 'semaphore externalObjectsArray freeSlotIndexes indexesByObjects' + classVariableNames: '' - instanceVariableNames: '' - classVariableNames: 'ProtectTable' poolDictionaries: '' category: 'System-Support'! + ExternalSemaphoreTable class + instanceVariableNames: 'current'! + !ExternalSemaphoreTable commentStamp: 'ul 10/25/2014 18:03' prior: 0! + I'm an enhanced version of JMM's ExternalSemaphoreTable. Despite the name I can store any object but nil. + I'm responsible for maintaining the externalObjectsArray, which can be found at slot 39 of Smalltalk specialObjectsArray. Manipulating the array directly is highly discouraged. + It's safe to use all class-side methods in the accessing category except for #clearExternalObjects - which should only be used during image startUp - and #current, because instance-side methods are not intented to be used by external code. + + If you'd like the create one or more new Semaphores and register them for external use, then you should use either #newExternalSemaphore or #newExternalSemaphores:. If you want to unregister more than one external objects at the same time, then #unregisterExternalObjects: is the method you're looking for. + + Implementation details: + I maintain a single instance (#current), which can automatically synchronize with externalObjectsArray. + All accesses are protected by the semaphore instance variable. + To ensure fast access, I keep track of the indexes of the external objects in the externalObjectArray in my indexesByObjects IdentityDictionary. + To ensure fast insertion, I keep track of the free slots of the externalObjectsArray in the freeSlotIndexes OrderedCollection. The access pattern is LIFO to avoid unnecessary growth and reordering of the OrderedCollection. + I can grow the externalObjectsArray (see #ensureFreeSlot), but I never shrink it. + + Original comment: - !ExternalSemaphoreTable commentStamp: '<historical>' prior: 0! By John M McIntosh johnmci(a)smalltalkconsulting.com This class was written to mange the external semaphore table. When I was writing a Socket test server I discovered various race conditions on the access to the externalSemaphore table. This new class uses class side methods to restrict access using a mutex semaphore. It seemed cleaner to deligate the reponsibility here versus adding more code and another class variable to SystemDictionary Note that in Smalltalk recreateSpecialObjectsArray we still directly play with the table.! + ExternalSemaphoreTable class + instanceVariableNames: 'current'! Item was added: + ----- Method: ExternalSemaphoreTable class>>cleanUp: (in category 'initialize-release') ----- + cleanUp: aggressive + "It's safe to release the instance" + + self reset! Item was changed: ----- Method: ExternalSemaphoreTable class>>clearExternalObjects (in category 'accessing') ----- clearExternalObjects "Clear the array of objects that have been registered for use in non-Smalltalk code." + self current clearExternalObjects - ProtectTable critical: [Smalltalk specialObjectsArray at: 39 put: Array new]. ! Item was added: + ----- Method: ExternalSemaphoreTable class>>current (in category 'accessing') ----- + current + + ^current ifNil: [ + | newInstance | + newInstance := self new. + " Check again, because another process might have registered another instance. " + current ifNil: [ current := newInstance ] ]! Item was changed: ----- Method: ExternalSemaphoreTable class>>externalObjects (in category 'accessing') ----- externalObjects + "Return a copy of the externalObjectsArray." + + ^self current externalObjects! - ^ProtectTable critical: [Smalltalk specialObjectsArray at: 39].! Item was removed: - ----- Method: ExternalSemaphoreTable class>>initialize (in category 'initialize') ----- - initialize - ProtectTable := Semaphore forMutualExclusion! Item was added: + ----- Method: ExternalSemaphoreTable class>>newExternalSemaphore (in category 'accessing') ----- + newExternalSemaphore + "Create and register a new Semaphore, and return an array containing itself and its index." + + ^self current newExternalSemaphore! Item was added: + ----- Method: ExternalSemaphoreTable class>>newExternalSemaphoreDo: (in category 'accessing') ----- + newExternalSemaphoreDo: aBlock + "Create and register a new Semaphore, then evaluate aBlock with it and its index." + + ^self current newExternalSemaphoreDo: aBlock! Item was added: + ----- Method: ExternalSemaphoreTable class>>newExternalSemaphores: (in category 'accessing') ----- + newExternalSemaphores: count + "Create and register multiple Semaphores, and return an array containing the semaphores and their indexes in separate arrays." + + ^self current newExternalSemaphores: count! Item was changed: ----- Method: ExternalSemaphoreTable class>>registerExternalObject: (in category 'accessing') ----- registerExternalObject: anObject + "Register the given object in the external objects array and return its index. If it is already there, just return its index." + + ^self current registerExternalObject: anObject! - ^ ProtectTable critical: [self safelyRegisterExternalObject: anObject] - ! Item was added: + ----- Method: ExternalSemaphoreTable class>>reset (in category 'accessing') ----- + reset + + current := nil! Item was removed: - ----- Method: ExternalSemaphoreTable class>>safelyRegisterExternalObject: (in category 'accessing') ----- - safelyRegisterExternalObject: anObject - "Register the given object in the external objects array and return its index. If it is already there, just return its index." - - | objects firstEmptyIndex obj sz newObjects | - objects := Smalltalk specialObjectsArray at: 39. - - "find the first empty slot" - firstEmptyIndex := 0. - 1 to: objects size do: [:i | - obj := objects at: i. - obj == anObject ifTrue: [^ i]. "object already there, just return its index" - (obj == nil and: [firstEmptyIndex = 0]) ifTrue: [firstEmptyIndex := i]]. - - "if no empty slots, expand the array" - firstEmptyIndex = 0 ifTrue: [ - sz := objects size. - newObjects := objects species new: sz + 20. "grow linearly" - newObjects replaceFrom: 1 to: sz with: objects startingAt: 1. - firstEmptyIndex := sz + 1. - Smalltalk specialObjectsArray at: 39 put: newObjects. - objects := newObjects]. - - objects at: firstEmptyIndex put: anObject. - ^ firstEmptyIndex - ! Item was removed: - ----- Method: ExternalSemaphoreTable class>>safelyUnregisterExternalObject: (in category 'accessing') ----- - safelyUnregisterExternalObject: anObject - "Unregister the given object in the external objects array. Do nothing if it isn't registered. - JMM change to return if we clear the element, since it should only appear once in the array" - - | objects | - anObject ifNil: [^ self]. - objects := Smalltalk specialObjectsArray at: 39. - 1 to: objects size do: [:i | - (objects at: i) == anObject ifTrue: - [objects at: i put: nil. - ^self]]. - ! Item was changed: ----- Method: ExternalSemaphoreTable class>>unregisterExternalObject: (in category 'accessing') ----- unregisterExternalObject: anObject + "Unregister the given object from the external objects array. Do nothing if it isn't registered." + + self current unregisterExternalObject: anObject! - ProtectTable critical: [self safelyUnregisterExternalObject: anObject] - ! Item was added: + ----- Method: ExternalSemaphoreTable class>>unregisterExternalObjects: (in category 'accessing') ----- + unregisterExternalObjects: aCollection + "Unregister the given objects from the external objects array. Do nothing if they aren't registered." + + self current unregisterExternalObjects: aCollection! Item was added: + ----- Method: ExternalSemaphoreTable>>clearExternalObjects (in category 'accessing') ----- + clearExternalObjects + "Clear the array of objects that have been registered for use in non-Smalltalk code." + + semaphore critical: [ + Smalltalk specialObjectsArray at: 39 put: Array new. + self + initializeCaches; + synchronizeExternalObjectsArrayAndForceUpdate: true ]! Item was added: + ----- Method: ExternalSemaphoreTable>>ensureFreeSlot (in category 'private') ----- + ensureFreeSlot + "Make sure there's at least one free slot." + + | oldSize newSize newExternalObjectsArray specialObjectsArray | + freeSlotIndexes isEmpty ifFalse: [ ^self ]. + oldSize := externalObjectsArray size. + newSize := oldSize + 20. "Linear growth is not really a problem, because we never shrink the array." + newExternalObjectsArray := externalObjectsArray species new: newSize. + newExternalObjectsArray + replaceFrom: 1 + to: oldSize + with: externalObjectsArray + startingAt: 1. + specialObjectsArray := Smalltalk specialObjectsArray. + (specialObjectsArray at: 39) == externalObjectsArray + ifFalse: [ + "We're not in sync. Try again." + ^self + synchronizeExternalObjectsArrayAndForceUpdate: true; + ensureFreeSlot ]. + specialObjectsArray at: 39 put: newExternalObjectsArray. + externalObjectsArray := newExternalObjectsArray. + oldSize + 1 to: newSize do: [ :each | + freeSlotIndexes add: each ]. + Smalltalk maxExternalSemaphores ifNotNil: [ :maxExternalSemaphores | + "Make sure that those new external semaphores can be signaled by the VM. This is not entirely safe, but not incrementing at all is worse." + newSize > maxExternalSemaphores ifTrue: [ + Smalltalk maxExternalSemaphores: newSize ] ] + + ! Item was added: + ----- Method: ExternalSemaphoreTable>>externalObjects (in category 'accessing') ----- + externalObjects + "Return a copy of the externalObjectsArray." + + ^semaphore critical: [ + self synchronizeExternalObjectsArrayAndForceUpdate: false. + externalObjectsArray copy ]! Item was added: + ----- Method: ExternalSemaphoreTable>>externalObjectsArray: (in category 'private') ----- + externalObjectsArray: anArray + "Update the index mapping using anArray as the new externalObjectsArray." + + externalObjectsArray := anArray. + freeSlotIndexes reset. + indexesByObjects removeAll. + 1 to: externalObjectsArray size do: [ :index | + (anArray at: index) + ifNil: [ freeSlotIndexes add: index ] + ifNotNil: [ :object | indexesByObjects at: object put: index ] ]! Item was added: + ----- Method: ExternalSemaphoreTable>>initialize (in category 'initialize-release') ----- + initialize + + semaphore := Semaphore forMutualExclusion. + self initializeCaches! Item was added: + ----- Method: ExternalSemaphoreTable>>initializeCaches (in category 'private') ----- + initializeCaches + + freeSlotIndexes := OrderedCollection new. + indexesByObjects := IdentityDictionary new! Item was added: + ----- Method: ExternalSemaphoreTable>>newExternalSemaphore (in category 'accessing') ----- + newExternalSemaphore + "Create and register a new Semaphore, and return an array containing itself and its index." + + | newSemaphore | + ^{ + newSemaphore := Semaphore new. + semaphore critical: [ + self + synchronizeExternalObjectsArrayAndForceUpdate: false; + safelyRegisterNewExternalObject: newSemaphore ] }! Item was added: + ----- Method: ExternalSemaphoreTable>>newExternalSemaphoreDo: (in category 'accessing') ----- + newExternalSemaphoreDo: aBlock + "Create and register a new Semaphore, then evaluate aBlock with it and its index." + + | newSemaphore | + ^aBlock + value: (newSemaphore := Semaphore new) + value: (semaphore critical: [ + self + synchronizeExternalObjectsArrayAndForceUpdate: false; + safelyRegisterNewExternalObject: newSemaphore ])! Item was added: + ----- Method: ExternalSemaphoreTable>>newExternalSemaphores: (in category 'accessing') ----- + newExternalSemaphores: count + "Create and register multiple Semaphores, and return an array containing the semaphores and their indexes in separate arrays." + + | semaphores indexes | + semaphores := Array new: count. + 1 to: count do: [ :index | semaphores at: index put: Semaphore new ]. + indexes := Array new: count. + semaphore critical: [ + self synchronizeExternalObjectsArrayAndForceUpdate: false. + 1 to: count do: [ :index | + indexes at: index put: ( + self safelyRegisterNewExternalObject: (semaphores at: index)) ] ]. + ^{ semaphores. indexes }! Item was added: + ----- Method: ExternalSemaphoreTable>>registerExternalObject: (in category 'accessing') ----- + registerExternalObject: anObject + "Register the given object in the external objects array and return its index. If it is already there, just return its index." + + anObject ifNil: [ ^nil ]. + ^semaphore critical: [ + self + synchronizeExternalObjectsArrayAndForceUpdate: false; + safelyRegisterExternalObject: anObject ]! Item was added: + ----- Method: ExternalSemaphoreTable>>safelyRegisterExternalObject: (in category 'private') ----- + safelyRegisterExternalObject: anObject + + | index | + (index := indexesByObjects at: anObject ifAbsent: nil) ifNotNil: [ + (externalObjectsArray at: index) == anObject ifTrue: [ ^index ]. + "indexesByObjects is out of sync. Try again." + ^self + synchronizeExternalObjectsArrayAndForceUpdate: true; + safelyRegisterExternalObject: anObject ]. + ^self safelyRegisterNewExternalObject: anObject! Item was added: + ----- Method: ExternalSemaphoreTable>>safelyRegisterNewExternalObject: (in category 'private') ----- + safelyRegisterNewExternalObject: anObject + + | index | + self ensureFreeSlot. + index := freeSlotIndexes removeLast. + (externalObjectsArray at: index) ifNotNil: [ + "Free slot is not empty. Try again." + ^self + synchronizeExternalObjectsArrayAndForceUpdate: true; + safelyRegisterNewExternalObject: anObject ]. + externalObjectsArray at: index put: anObject. + indexesByObjects at: anObject put: index. + ^index! Item was added: + ----- Method: ExternalSemaphoreTable>>safelyUnregisterExternalObject: (in category 'private') ----- + safelyUnregisterExternalObject: anObject + + (indexesByObjects removeKey: anObject ifAbsent: nil) + ifNotNil: [ :index | + (externalObjectsArray at: index) == anObject ifFalse: [ + "We're not in sync. Try again." + ^self + synchronizeExternalObjectsArrayAndForceUpdate: true; + safelyUnregisterExternalObject: anObject ]. + externalObjectsArray at: index put: nil. + freeSlotIndexes add: index ] + ifNil: [ + "Check if we're just out of sync." + (externalObjectsArray instVarsInclude: anObject) ifFalse: [ ^self ]. + "We're not in sync. Try again." + ^self + synchronizeExternalObjectsArrayAndForceUpdate: true; + safelyUnregisterExternalObject: anObject ]! Item was added: + ----- Method: ExternalSemaphoreTable>>synchronizeExternalObjectsArrayAndForceUpdate: (in category 'private') ----- + synchronizeExternalObjectsArrayAndForceUpdate: forceUpdate + + | actualExternalObjectsArray | + actualExternalObjectsArray := Smalltalk specialObjectsArray at: 39. + (actualExternalObjectsArray == externalObjectsArray and: [ forceUpdate not ]) + ifTrue: [ ^self ]. + self externalObjectsArray: actualExternalObjectsArray! Item was added: + ----- Method: ExternalSemaphoreTable>>unregisterExternalObject: (in category 'accessing') ----- + unregisterExternalObject: anObject + "Unregister the given object from the external objects array. Do nothing if it isn't registered." + + anObject ifNil: [ ^self ]. + semaphore critical: [ + self + synchronizeExternalObjectsArrayAndForceUpdate: false; + safelyUnregisterExternalObject: anObject ]! Item was added: + ----- Method: ExternalSemaphoreTable>>unregisterExternalObjects: (in category 'accessing') ----- + unregisterExternalObjects: aCollection + "Unregister the given objects from the external objects array. Do nothing if they aren't registered." + + semaphore critical: [ + self synchronizeExternalObjectsArrayAndForceUpdate: false. + aCollection do: [ :each | + each ifNotNil: [ + self safelyUnregisterExternalObject: each ] ] ]! Item was changed: ----- Method: SmalltalkImage>>snapshot:andQuit:withExitCode:embedded: (in category 'snapshot and quit') ----- snapshot: save andQuit: quit withExitCode: exitCode embedded: embeddedFlag "Mark the changes file and close all files as part of #processShutdownList. If save is true, save the current state of this Smalltalk in the image file. If quit is true, then exit to the outer OS shell. If exitCode is not nil, then use it as exit code. The latter part of this method runs when resuming a previously saved image. This resume logic checks for a document file to process when starting up." | resuming msg | Object flushDependents. Object flushEvents. (SourceFiles at: 2) ifNotNil:[ msg := String streamContents: [ :s | s nextPutAll: '----'; nextPutAll: (save ifTrue: [ quit ifTrue: [ 'QUIT' ] ifFalse: [ 'SNAPSHOT' ] ] ifFalse: [quit ifTrue: [ 'QUIT/NOSAVE' ] ifFalse: [ 'NOP' ]]); nextPutAll: '----'; print: Date dateAndTimeNow; space; nextPutAll: (FileDirectory default localNameFor: self imageName); nextPutAll: ' priorSource: '; print: LastQuitLogPosition ]. self assureStartupStampLogged. save ifTrue: [ LastQuitLogPosition := (SourceFiles at: 2) setToEnd; position ]. self logChange: msg. Transcript cr; show: msg ]. Smalltalk processShutDownList: quit. Cursor write show. save ifTrue: [resuming := embeddedFlag ifTrue: [self snapshotEmbeddedPrimitive] ifFalse: [self snapshotPrimitive]. "<-- PC frozen here on image file" resuming == false "guard against failure" ifTrue: ["Time to reclaim segment files is immediately after a save" Smalltalk at: #ImageSegment ifPresent: [:theClass | theClass reclaimObsoleteSegmentFiles]]] ifFalse: [resuming := false]. quit & (resuming == false) ifTrue: [ exitCode ifNil: [ self quitPrimitive ] ifNotNil: [ self quitPrimitive: exitCode ] ]. Cursor normal show. Smalltalk setGCParameters. + resuming == true ifTrue: [ExternalSemaphoreTable clearExternalObjects]. - resuming == true ifTrue: [Smalltalk clearExternalObjects]. Smalltalk processStartUpList: resuming == true. resuming == true ifTrue:[ self setPlatformPreferences. self recordStartupStamp]. Project current wakeUpTopWindow. "Now it's time to raise an error" resuming == nil ifTrue: [self error:'Failed to write image file (disk full?)']. ^ resuming!

1 0

The Inbox: Sound-ul.40.mcz
by commits＠source.squeak.org 26 Oct '14

26 Oct '14

A new version of Sound was added to project The Inbox: http://source.squeak.org/inbox/Sound-ul.40.mcz ==================== Summary ==================== Name: Sound-ul.40 Author: ul Time: 26 October 2014, 1:43:33.816 am UUID: c4759ae3-93c9-4344-bc16-600a8e018ca6 Ancestors: Sound-nice.38 - use the new ExternalSemaphoreTable API =============== Diff against Sound-nice.38 =============== Item was changed: ----- Method: SoundPlayer class>>startPlayerProcessBufferSize:rate:stereo:sound: (in category 'player process') ----- startPlayerProcessBufferSize: bufferSize rate: samplesPerSecond stereo: stereoFlag sound: aSound "Start the sound player process. Terminate the old process, if any." "SoundPlayer startPlayerProcessBufferSize: 1000 rate: 11025 stereo: false" self stopPlayerProcess. aSound ifNil:[ActiveSounds := OrderedCollection new] ifNotNil:[ActiveSounds := OrderedCollection with: aSound]. Buffer := SoundBuffer newStereoSampleCount: (bufferSize // 4) * 4. LastBuffer ifNotNil:[LastBuffer := SoundBuffer basicNew: Buffer basicSize]. PlayerSemaphore := Semaphore forMutualExclusion. SamplingRate := samplesPerSecond. Stereo := stereoFlag. - ReadyForBuffer := Semaphore new. SoundSupported := true. "Assume so" UseReadySemaphore := true. "set to false if ready semaphore not supported by VM" + ExternalSemaphoreTable newExternalSemaphoreDo: [ :semaphore :index | + ReadyForBuffer := semaphore. + self primSoundStartBufferSize: Buffer stereoSampleCount + rate: samplesPerSecond + stereo: Stereo + semaIndex: index ]. - self primSoundStartBufferSize: Buffer stereoSampleCount - rate: samplesPerSecond - stereo: Stereo - semaIndex: (Smalltalk registerExternalObject: ReadyForBuffer). "Check if sound start prim was successful" + SoundSupported ifFalse:[ + ExternalSemaphoreTable unregisterExternalObject: ReadyForBuffer. + ReadyForBuffer := nil. + ^self ]. - SoundSupported ifFalse:[^self]. UseReadySemaphore ifTrue: [PlayerProcess := [SoundPlayer playLoop] newProcess] ifFalse: [PlayerProcess := [SoundPlayer oldStylePlayLoop] newProcess]. UseReverb ifTrue: [self startReverb]. PlayerProcess priority: Processor userInterruptPriority. + PlayerProcess resume! - PlayerProcess resume.! Item was changed: ----- Method: SoundPlayer class>>stopPlayerProcess (in category 'player process') ----- stopPlayerProcess "Stop the sound player process." "SoundPlayer stopPlayerProcess" (PlayerProcess == nil or:[PlayerProcess == Processor activeProcess]) ifFalse:[PlayerProcess terminate]. PlayerProcess := nil. self primSoundStop. ActiveSounds := OrderedCollection new. Buffer := nil. PlayerSemaphore := Semaphore forMutualExclusion. ReadyForBuffer ifNotNil: + [ExternalSemaphoreTable unregisterExternalObject: ReadyForBuffer]. - [Smalltalk unregisterExternalObject: ReadyForBuffer]. ReadyForBuffer := nil. ! Item was changed: ----- Method: SoundRecorder>>startRecording (in category 'recording controls') ----- startRecording "Turn of the sound input driver and start the recording process. Initially, recording is paused." - | semaIndex | recordLevel ifNil: [recordLevel := 0.5]. "lazy initialization" CanRecordWhilePlaying ifFalse: [SoundPlayer shutDown]. recordProcess ifNotNil: [self stopRecording]. paused := true. meteringBuffer := SoundBuffer newMonoSampleCount: 1024. meterLevel := 0. self allocateBuffer. + ExternalSemaphoreTable newExternalSemaphoreDo: [ :semaphore :index | + bufferAvailableSema := semaphore. + self primStartRecordingDesiredSampleRate: samplingRate asInteger + stereo: stereo + semaIndex: index ]. - bufferAvailableSema := Semaphore new. - semaIndex := Smalltalk registerExternalObject: bufferAvailableSema. - self primStartRecordingDesiredSampleRate: samplingRate asInteger - stereo: stereo - semaIndex: semaIndex. RecorderActive := true. samplingRate := self primGetActualRecordingSampleRate. self primSetRecordLevel: (1000.0 * recordLevel) asInteger. recordProcess := [self recordLoop] newProcess. recordProcess priority: Processor userInterruptPriority. + recordProcess resume! - recordProcess resume. - ! Item was changed: ----- Method: SoundRecorder>>stopRecording (in category 'recording controls') ----- stopRecording "Stop the recording process and turn of the sound input driver." recordProcess ifNotNil: [recordProcess terminate]. recordProcess := nil. self primStopRecording. RecorderActive := false. + ExternalSemaphoreTable unregisterExternalObject: bufferAvailableSema. - Smalltalk unregisterExternalObject: bufferAvailableSema. ((currentBuffer ~~ nil) and: [nextIndex > 1]) ifTrue: [self emitPartialBuffer]. self initializeRecordingState. !

1 0

The Trunk: Installer-Core-ul.395.mcz
by commits＠source.squeak.org 26 Oct '14

26 Oct '14

Levente Uzonyi uploaded a new version of Installer-Core to project The Trunk: http://source.squeak.org/trunk/Installer-Core-ul.395.mcz ==================== Summary ==================== Name: Installer-Core-ul.395 Author: ul Time: 25 October 2014, 10:46:30.418 pm UUID: 862c5471-3279-4f41-998f-9f91976860dd Ancestors: Installer-Core-nice.394 - added #squeakInbox and #squeakTrunk accessors =============== Diff against Installer-Core-nice.394 =============== Item was added: + ----- Method: Installer class>>squeakInbox (in category 'repositories') ----- + squeakInbox + + ^self squeak project: 'inbox'! Item was added: + ----- Method: Installer class>>squeakTrunk (in category 'repositories') ----- + squeakTrunk + + ^self squeak project: 'trunk'!

1 0

Daily Commit Log
by commits＠source.squeak.org 25 Oct '14

25 Oct '14

Changes to Trunk (http://source.squeak.org/trunk.html) in the last 24 hours: http://lists.squeakfoundation.org/pipermail/packages/2014-October/007344.ht… Name: KernelTests-dtl.279 Ancestors: KernelTests-ul.278 Add test to document a VM bug (fixed) exposed when running 68002 image format. =============================================

1 0

← Newer
1
...
4
5
6
7
8
9
10
...
19
Older →

Jump to page: