The Inbox: System-dtl.985.mcz

David T. Lewis uploaded a new version of System to project The Inbox:
http://source.squeak.org/inbox/System-dtl.985.mcz

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

Name: System-dtl.985
Author: dtl
Time: 14 December 2017, 6:56:38.560599 pm
UUID: e4a2ebbf-bb5c-43f3-8ffb-a967644e1794
Ancestors: System-dtl.984, System-eem.983

Clear the EmergencyRecoveryRequested recursion guard in enter:revert:saveForRevert: rather than in finalExitActions:. This removes Morphic and ST80 dependencies and clears the flag at the single point of normal project entry.

Merge with System-eem.983.

=============== Diff against System-dtl.984 ===============

Item was added:
+ ----- Method: Object>>isPrimitiveOSError (in category '*System-Support-error handling') -----
+ isPrimitiveOSError
+ ^false!

Item was added:
+ Object subclass: #PrimitiveOSError
+ instanceVariableNames: 'errorName errorCode'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'System-Support'!
+
+ !PrimitiveOSError commentStamp: 'eem 12/7/2017 19:31' prior: 0!
+ A PrimitiveOSError is used to answer a primitive failure code that has an associated operating system/library error.
+
+ Instance Variables
+ errorName: <Symbol>
+ errorValue: <Integer>
+
+ errorName
+ - typically #'operating system error'
+
+ errorValue
+ - the value of the error, a signed 64-bit value, a representation imposed by the VM; specific clients must map this error value into an unsigned value as appropriate if required!

Item was added:
+ ----- Method: PrimitiveOSError>>errorCode (in category 'accessing') -----
+ errorCode
+
+ ^errorCode!

Item was added:
+ ----- Method: PrimitiveOSError>>errorCode: (in category 'accessing') -----
+ errorCode: anObject
+
+ errorCode := anObject!

Item was added:
+ ----- Method: PrimitiveOSError>>errorName (in category 'accessing') -----
+ errorName
+
+ ^errorName!

Item was added:
+ ----- Method: PrimitiveOSError>>errorName: (in category 'accessing') -----
+ errorName: anObject
+
+ errorName := anObject!

Item was added:
+ ----- Method: PrimitiveOSError>>isPrimitiveOSError (in category 'testing') -----
+ isPrimitiveOSError
+ ^true!

Item was changed:
  ----- Method: Project>>enter:revert:saveForRevert: (in category 'enter') -----
  enter: returningFlag revert: revertFlag saveForRevert: saveForRevert
  "Install my ChangeSet, Transcript, and scheduled views as current globals. If returningFlag is true, we will return to the project from whence the current project was entered; don't change its previousProject link in this case.
  If saveForRevert is true, save the ImageSegment of the project being left.
  If revertFlag is true, make stubs for the world of the project being left.
  If revertWithoutAsking is true in the project being left, then always revert."
 
  | leavingProject forceRevert response seg |
 
  self isIncompletelyLoaded
  ifTrue: [^ self loadFromServer: true].
  self isCurrentProject
  ifTrue: [^ self].
 
+ EmergencyRecoveryRequested := false. "normal project entry clears recursion guard"
  forceRevert := false.
  CurrentProject rawParameters
  ifNil: [revertFlag ifTrue: [^ self inform: 'nothing to revert to' translated]]
  ifNotNil: [saveForRevert ifFalse: [
  forceRevert := CurrentProject projectParameters
  at: #revertWithoutAsking ifAbsent: [false]]].
  forceRevert not & revertFlag ifTrue: [
  response := (UIManager default chooseFrom: {
  'Revert to saved version' translated.
  'Cancel' translated.
  } title: 'Are you sure you want to destroy this Project\ and revert to an older version?\\(From the parent project, click on this project''s thumbnail.)' translated withCRs) = 1.
  response ifFalse: [^ self]].
 
  revertFlag | forceRevert
  ifTrue: [seg := CurrentProject projectParameters at: #revertToMe ifAbsent: [
  ^ self inform: 'nothing to revert to' translated]]
  ifFalse: [
  CurrentProject makeThumbnail.
  returningFlag == #specialReturn
  ifTrue:
  [ProjectHistory forget: CurrentProject. "this guy is irrelevant"
  Project forget: CurrentProject]
  ifFalse:
  [ProjectHistory remember: CurrentProject]].
 
  (revertFlag | saveForRevert | forceRevert) ifFalse: [
  (Preferences valueOfFlag: #projectsSentToDisk)
  ifTrue: [
  self inform: 'Project serialization via image segments\does not work at the moment. Disabling the\preference #projectsSentToDisk now...' withCRs.
  Preferences disable: #projectsSentToDisk.
  "self storeToMakeRoom"]].
 
  "Update display depth for leaving and entring project."
  CurrentProject displayDepth: Display depth.
  displayDepth == nil ifTrue: [displayDepth := Display depth].
  self installNewDisplay: Display extent depth: displayDepth.
 
  returningFlag == #specialReturn ifTrue: [
  CurrentProject removeChangeSetIfPossible. "keep this stuff from accumulating"
  nextProject := nil
  ] ifFalse: [
  returningFlag
  ifTrue: [nextProject := CurrentProject]
  ifFalse: [previousProject := CurrentProject].
  ].
 
  CurrentProject world triggerEvent: #aboutToLeaveWorld.
  CurrentProject abortResourceLoading.
  CurrentProject finalExitActions: self.
  CurrentProject saveState.
 
  "********** SWITCHING CURRENT PROJECT **********"
  leavingProject := CurrentProject.
  CurrentProject := self.
  ProjectHistory remember: self.
  "********** SWITCHING CURRENT PROJECT **********"
 
  self loadState.
  self finalEnterActions: leavingProject.
  self addDeferredUIMessage: [self startResourceLoading].
  self world triggerEvent: #aboutToEnterWorld.
 
  "Save project for revert."
  saveForRevert ifTrue: [
  Smalltalk garbageCollect. "let go of pointers"
  leavingProject storeSegment.
  "result :=" leavingProject world isInMemory
  ifTrue: ['Can''t seem to write the project.']
  ifFalse: [leavingProject projectParameters at: #revertToMe put:
  leavingProject world xxxSegment shallowCopy].
  'Project written.'].
  "original is for coming back in and continuing."
  revertFlag | forceRevert ifTrue: [
  seg shallowCopy revert]. "non-cloned one is for reverting again later"
  self removeParameter: #exportState.
 
  "Now that everything is set up, we can show zoom animation."
  self showZoom
  ifTrue: [self displayZoom: leavingProject parent ~~ self "Entering?"]
  ifFalse: [self restore].
 
  "Update processes at last."
  self scheduleProcessForEnter.
  leavingProject terminateProcessForLeave.
  !

Item was changed:
  ----- Method: Project>>enterForEmergencyRecovery (in category 'enter - recovery') -----
  enterForEmergencyRecovery
  "Stripped down verion of #enter:revert:saveForRevert:. More error handling. Less features."
 
  | leavingProject process titleForDebuggerWindow |
  self isCurrentProject ifTrue: [^ self].
  EmergencyRecoveryRequested == true ifTrue: [^ self].
+ EmergencyRecoveryRequested := true. "set recursion guard"
- EmergencyRecoveryRequested := true.
 
  titleForDebuggerWindow := 'FATAL PROJECT ERROR: Project was ''', CurrentProject name, ''''.
  ProjectHistory remember: CurrentProject.
  nextProject := CurrentProject.
 
  [ CurrentProject world triggerEvent: #aboutToLeaveWorld.
  CurrentProject abortResourceLoading.
  CurrentProject finalExitActions: self.
  CurrentProject saveState ] on: Error do: [:ex | "Ignore." ].
 
  "********** SWITCHING CURRENT PROJECT **********"
  leavingProject := CurrentProject.
  CurrentProject := self.
  ProjectHistory remember: self.
  "********** SWITCHING CURRENT PROJECT **********"
 
  self loadState.
  self finalEnterActions: leavingProject.
  self addDeferredUIMessage: [self startResourceLoading].
  self world triggerEvent: #aboutToEnterWorld.
 
  "Now that everything is set up, we can show zoom animation.
  Do we really need this in case of an emergency?"
  self showZoom
  ifTrue: [self displayZoom: leavingProject parent ~~ self "Entering?"]
  ifFalse: [self restore].
 
  "Update processes at last."
  self scheduleProcessForEnter.
 
  "Do not terminate but suspend the projects ui process to support debugging."
  process := leavingProject uiProcess.
  self addDeferredUIMessage: [process debugWithTitle: titleForDebuggerWindow].
  leavingProject suspendProcessForDebug.!

Item was changed:
  ----- Method: Project>>finalExitActions: (in category 'enter') -----
  finalExitActions: enteringProject
 
+ SoundService stop.!
- EmergencyRecoveryRequested := false. "clear fence variable if previously set due to error"
- !

Item was changed:
  ----- Method: Project>>storeOnServer (in category 'file in/out') -----
  storeOnServer
 
  "Save to disk as an Export Segment.  Then put that file on the server I came from, as a new version.  Version is literal piece of file name.  Mime encoded and http encoded."
 
  world setProperty: #optimumExtentFromAuthor toValue: world extent.
  self validateProjectNameIfOK: [:details |
+ details ifNotNil: [self acceptProjectDetails: details].
- self acceptProjectDetails: details.
  self isCurrentProject ifTrue: ["exit, then do the command"
  ^ self
  armsLengthCommand: #storeOnServerAssumingNameValid
  withDescription: 'Publishing' translated
  ].
  self storeOnServerWithProgressInfo.
  ].!

Item was changed:
  ----- Method: SmalltalkImage>>recreateSpecialObjectsArray (in category 'special objects') -----
  recreateSpecialObjectsArray
  "Smalltalk recreateSpecialObjectsArray"
 
  "To external package developers:
  **** DO NOT OVERRIDE THIS METHOD.  *****
  If you are writing a plugin and need additional special object(s) for your own use,
  use addGCRoot() function and use own, separate special objects registry "
 
  "The Special Objects Array is an array of objects used by the Squeak virtual machine.
  Its contents are critical and accesses to it by the VM are unchecked, so don't even
  think of playing here unless you know what you are doing."
  | newArray |
  newArray := Array new: 60.
+ "Nil false and true get used throughout the VM"
- "Nil false and true get used throughout the interpreter"
  newArray at: 1 put: nil.
  newArray at: 2 put: false.
  newArray at: 3 put: true.
  "This association holds the active process (a ProcessScheduler)"
  newArray at: 4 put: (self specialObjectsArray at: 4) "(self bindingOf: #Processor) but it answers an Alias".
  "Numerous classes below used for type checking and instantiation"
  newArray at: 5 put: Bitmap.
  newArray at: 6 put: SmallInteger.
  newArray at: 7 put: ByteString.
  newArray at: 8 put: Array.
  newArray at: 9 put: Smalltalk.
  newArray at: 10 put: BoxedFloat64.
  newArray at: 11 put: (self globals at: #Context).
  newArray at: 12 put: nil. "was BlockContext."
  newArray at: 13 put: Point.
  newArray at: 14 put: LargePositiveInteger.
  newArray at: 15 put: Display.
  newArray at: 16 put: Message.
  newArray at: 17 put: CompiledMethod.
  newArray at: 18 put: ((self specialObjectsArray at: 18) ifNil: [Semaphore new]). "low space Semaphore"
  newArray at: 19 put: Semaphore.
  newArray at: 20 put: Character.
  newArray at: 21 put: #doesNotUnderstand:.
  newArray at: 22 put: #cannotReturn:.
  newArray at: 23 put: nil. "This is the process signalling low space."
  "An array of the 32 selectors that are compiled as special bytecodes,
  paired alternately with the number of arguments each takes."
  newArray at: 24 put: #( #+ 1 #- 1 #< 1 #> 1 #<= 1 #>= 1 #= 1 #~= 1
  #* 1 #/ 1 #\\ 1 #@ 1 #bitShift: 1 #// 1 #bitAnd: 1 #bitOr: 1
  #at: 1 #at:put: 2 #size 0 #next 0 #nextPut: 1 #atEnd 0 #== 1 #class 0
  #~~ 1 #value 0 #value: 1 #do: 1 #new 0 #new: 1 #x 0 #y 0 ).
  "An array of the 255 Characters in ascii order.
  Cog inlines table into machine code at: prim so do not regenerate it.
  This is nil in Spur, which has immediate Characters."
  newArray at: 25 put: (self specialObjectsArray at: 25).
  newArray at: 26 put: #mustBeBoolean.
  newArray at: 27 put: ByteArray.
  newArray at: 28 put: Process.
  "An array of up to 31 classes whose instances will have compact headers; an empty array in Spur"
  newArray at: 29 put: self compactClassesArray.
  newArray at: 30 put: ((self specialObjectsArray at: 30) ifNil: [Semaphore new]). "delay Semaphore"
  newArray at: 31 put: ((self specialObjectsArray at: 31) ifNil: [Semaphore new]). "user interrupt Semaphore"
  "Entries 32 - 34 unreferenced. Previously these contained prototype instances to be copied for fast initialization"
  newArray at: 32 put: nil. "was the prototype Float"
  newArray at: 33 put: nil. "was the prototype 4-byte LargePositiveInteger"
  newArray at: 34 put: nil. "was the prototype Point"
  newArray at: 35 put: #cannotInterpret:.
  newArray at: 36 put: nil. "was the prototype MethodContext"
  newArray at: 37 put: BlockClosure.
  newArray at: 38 put: nil. "was the prototype BlockContext"
  "array of objects referred to by external code"
  newArray at: 39 put: (self specialObjectsArray at: 39). "external semaphores"
  newArray at: 40 put: nil. "Reserved for Mutex in Cog VMs"
  newArray at: 41 put: ((self specialObjectsArray at: 41) ifNil: [LinkedList new]). "Reserved for a LinkedList instance for overlapped calls in CogMT"
  newArray at: 42 put: ((self specialObjectsArray at: 42) ifNil: [Semaphore new]). "finalization Semaphore"
  newArray at: 43 put: LargeNegativeInteger.
  "External objects for callout.
  Note: Written so that one can actually completely remove the FFI."
  newArray at: 44 put: (self at: #ExternalAddress ifAbsent: []).
  newArray at: 45 put: (self at: #ExternalStructure ifAbsent: []).
  newArray at: 46 put: (self at: #ExternalData ifAbsent: []).
  newArray at: 47 put: (self at: #ExternalFunction ifAbsent: []).
  newArray at: 48 put: (self at: #ExternalLibrary ifAbsent: []).
  newArray at: 49 put: #aboutToReturn:through:.
  newArray at: 50 put: #run:with:in:.
  "51 reserved for immutability message"
  newArray at: 51 put: #attemptToAssign:withIndex:.
  newArray at: 52 put: #(nil "nil => generic error" #'bad receiver'
  #'bad argument' #'bad index'
  #'bad number of arguments'
  #'inappropriate operation'  #'unsupported operation'
  #'no modification' #'insufficient object memory'
  #'insufficient C memory' #'not found' #'bad method'
  #'internal error in named primitive machinery'
  #'object may move' #'resource limit exceeded'
  #'object is pinned' #'primitive write beyond end of object'
+ #'object moved' #'object not pinned' #'callback error'),
+ {PrimitiveOSError new errorName: #'operating system error'; yourself}.
- #'object moved' #'object not pinned' #'callback error').
  "53 to 55 are for Alien"
  newArray at: 53 put: (self at: #Alien ifAbsent: []).
  newArray at: 54 put: #invokeCallbackContext:. "use invokeCallback:stack:registers:jmpbuf: for old Alien callbacks."
  newArray at: 55 put: (self at: #UnsafeAlien ifAbsent: []).
 
  "Used to be WeakFinalizationList for WeakFinalizationList hasNewFinalization, obsoleted by ephemeron support."
  newArray at: 56 put: nil.
 
  "reserved for foreign callback process"
  newArray at: 57 put: (self specialObjectsArray at: 57 ifAbsent: []).
 
  newArray at: 58 put: #unusedBytecode.
  "59 reserved for Sista counter tripped message"
  newArray at: 59 put: #conditionalBranchCounterTrippedOn:.
  "60 reserved for Sista class trap message"
  newArray at: 60 put: #classTrapFor:.
 
+ "Now replace the virtual machine's reference in one atomic operation"
- "Now replace the interpreter's reference in one atomic operation"
  self specialObjectsArray becomeForward: newArray!

Item was changed:
+ (PackageInfo named: 'System') postscript: '(Smalltalk specialSelectorNames includes: #~~) ifFalse:
+ ["Re-create the specialObjectsArray to let the jit optimize #~~. Also add the new primitive error codes if they are not there yet."
+ | senders |
+ senders := #(#~~ #blockCopy:) gather: [ :selector |
+ "Recompile senders blockCopy: too, just in case."
+ SystemNavigation default allCallsOn: selector ].
+ Smalltalk recreateSpecialObjectsArray.
+ VariableNode initialize.
+ Decompiler initialize.
+ senders
+ do: [ :methodReference |
+ | class |
+ class := methodReference actualClass.
+ class recompile: methodReference selector from: class ]
+ displayingProgress: ''Recompiling...''].
+ "If PrimitiveOSError is not in the primitiveErrorTable, add it."
+ Smalltalk primitiveErrorTable size < 21 ifTrue:
+ [Smalltalk recreateSpecialObjectsArray]'!
- (PackageInfo named: 'System') postscript: '| senders |
- "Re-create the specialObjectsArray to let the jit optimize #~~. Also add the new primitive error codes if they are not there yet."
- senders := #(#~~ #blockCopy:) gather: [ :selector |
- "Recompile senders blockCopy: too, just in case."
- SystemNavigation default allCallsOn: selector ].
- Smalltalk recreateSpecialObjectsArray.
- VariableNode initialize.
- Decompiler initialize.
- senders
- do: [ :methodReference |
- | class |
- class := methodReference actualClass.
- class recompile: methodReference selector from: class ]
- displayingProgress: ''Recompiling...''.'!