The Inbox: System-ul.686.mcz

A new version of System was added to project The Inbox:
http://source.squeak.org/inbox/System-ul.686.mcz

==================== Summary ====================

Name: System-ul.686
Author: ul
Time: 24 October 2014, 3:33:38.886 am
UUID: 541b7ffb-c492-417f-b8b1-2c9de93b76a6
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, and #newExternalSemaphores: provide 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/24/2014 03:24' 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. For Semaphores I their indexInExternalObjectsArray instance variable. For other objects I use my own indexesByObjects IdentityDictionary. The latter could work for all objects, but the former is faster, and easier to use.
+ 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.
+ I can grow the externalObjectsArray (see #ensureFreeSlot), but I never shrink it.
+
+ Original comment:
- !ExternalSemaphoreTable commentStamp: '<historical>' prior: 0!
  By John M McIntosh [hidden email]
  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 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 it."
+
+ ^self current newExternalSemaphore!

Item was added:
+ ----- Method: ExternalSemaphoreTable class>>newExternalSemaphores: (in category 'accessing') -----
+ newExternalSemaphores: count
+ "Create and register multiple Semaphores, and return an array containing them."
+
+ ^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 synchronizeExternalObjectsArrayAndForceUpdate: false ]!

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 := OrderedCollection new: externalObjectsArray size.
+ indexesByObjects := IdentityDictionary new.
+ 1 to: externalObjectsArray size do: [ :index |
+ (anArray at: index)
+ ifNil: [ freeSlotIndexes add: index ]
+ ifNotNil: [ :object |
+ object class == Semaphore
+ ifTrue: [ object indexInExternalObjectsArray: index ]
+ ifFalse: [ indexesByObjects at: object put: index ] ] ]!

Item was added:
+ ----- Method: ExternalSemaphoreTable>>initialize (in category 'initialize-release') -----
+ initialize
+
+ semaphore := Semaphore forMutualExclusion!

Item was added:
+ ----- Method: ExternalSemaphoreTable>>newExternalSemaphore (in category 'accessing') -----
+ newExternalSemaphore
+ "Create and register a new Semaphore, and return it."
+
+ | newSemaphore |
+ newSemaphore := Semaphore new.
+ semaphore critical: [
+ self
+ synchronizeExternalObjectsArrayAndForceUpdate: false;
+ safelyRegisterNewExternalSemaphore: newSemaphore ].
+ ^newSemaphore!

Item was added:
+ ----- Method: ExternalSemaphoreTable>>newExternalSemaphores: (in category 'accessing') -----
+ newExternalSemaphores: count
+ "Create and register multiple Semaphores, and return an array containing them."
+
+ | semaphores |
+ semaphores := Array new: count.
+ 1 to: count do: [ :index |
+ semaphores at: index put: Semaphore new ].
+ semaphore critical: [
+ self synchronizeExternalObjectsArrayAndForceUpdate: false.
+ semaphores do: [ :newSemaphore |
+ self safelyRegisterNewExternalSemaphore: newSemaphore ] ].
+ ^semaphores!

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 |
+ anObject class == Semaphore ifTrue: [ ^self safelyRegisterExternalSemaphore: anObject ].
+ (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 ensureFreeSlot.
+ index := freeSlotIndexes removeLast.
+ (externalObjectsArray at: index) ifNotNil: [
+ "Free slot is not empty. Try again."
+ ^self
+ synchronizeExternalObjectsArrayAndForceUpdate: true;
+ safelyRegisterExternalObject: anObject ].
+ externalObjectsArray at: index put: anObject.
+ indexesByObjects at: anObject put: index.
+ ^index!

Item was added:
+ ----- Method: ExternalSemaphoreTable>>safelyRegisterExternalSemaphore: (in category 'private') -----
+ safelyRegisterExternalSemaphore: aSemaphore
+
+ aSemaphore indexInExternalObjectsArray ifNotNil: [ :index |
+ (externalObjectsArray at: index) == aSemaphore ifTrue: [ ^index ].
+ aSemaphore indexInExternalObjectsArray: nil. "Avoid infinite recursion."
+ "We can be out of sync. Try again."
+ ^self
+ synchronizeExternalObjectsArrayAndForceUpdate: true;
+ safelyRegisterExternalSemaphore: aSemaphore ].
+ ^self safelyRegisterNewExternalSemaphore: aSemaphore!

Item was added:
+ ----- Method: ExternalSemaphoreTable>>safelyRegisterNewExternalSemaphore: (in category 'private') -----
+ safelyRegisterNewExternalSemaphore: aSemaphore
+
+ | index |
+ self ensureFreeSlot.
+ index := freeSlotIndexes removeLast.
+ (externalObjectsArray at: index) ifNotNil: [
+ "Free slot is not empty. Try again."
+ ^self
+ synchronizeExternalObjectsArrayAndForceUpdate: true;
+ safelyRegisterNewExternalSemaphore: aSemaphore ].
+ aSemaphore indexInExternalObjectsArray: index.
+ externalObjectsArray at: index put: aSemaphore.
+ ^index!

Item was added:
+ ----- Method: ExternalSemaphoreTable>>safelyUnregisterExternalObject: (in category 'private') -----
+ safelyUnregisterExternalObject: anObject
+
+ anObject class == Semaphore ifTrue: [ ^self safelyUnregisterExternalSemaphore: 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>>safelyUnregisterExternalSemaphore: (in category 'private') -----
+ safelyUnregisterExternalSemaphore: aSemaphore
+
+ aSemaphore indexInExternalObjectsArray
+ ifNotNil: [ :index |
+ aSemaphore indexInExternalObjectsArray: nil. "Remove the index to avoid infinite recursion."
+ (externalObjectsArray at: index) == aSemaphore ifFalse: [
+ "We're not in sync. Try again."
+ ^self
+ synchronizeExternalObjectsArrayAndForceUpdate: true;
+ safelyUnregisterExternalSemaphore: aSemaphore ].
+ externalObjectsArray at: index put: nil.
+ freeSlotIndexes add: index ]
+ ifNil: [
+ "Check if we're just out of sync."
+ (externalObjectsArray instVarsInclude: aSemaphore) ifFalse: [ ^self ].
+ "We're not in sync. Try again."
+ ^self
+ synchronizeExternalObjectsArrayAndForceUpdate: true;
+ safelyUnregisterExternalSemaphore: aSemaphore ]!

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!