The Trunk: System-mt.1112.mcz

Marcel Taeumel uploaded a new version of System to project The Trunk:
http://source.squeak.org/trunk/System-mt.1112.mcz

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

Name: System-mt.1112
Author: mt
Time: 7 October 2019, 10:07:46.787231 am
UUID: 3dbbf205-1ee0-3841-ae6b-2d926a4a2055
Ancestors: System-pre.1111

Fixes and clean-up in the debugger infrastructure:

- Adds several tests in DebuggerTests
- Replaces ErrorRecursion and ErrorRecursionGard with a process-local flag to avoid false recursion detection
- Simplifies interrupt-request processing in Project >> #interruptName:preemptedProcess:
- Simplifies "Debug it" invocation. See TextEditor >> #debugIt and Process' class-side messages.
- Move log-file writing for low space to SmalltalkImage >> #lowSpaceWatcher.
- Adds Debugger >> #close, similar to Project >> #close.
- Moves #cmdDotEnabled preference check to StandardToolSet
- Adds a convenient way to debug exceptions without suspending the current process.

=============== Diff against System-pre.1111 ===============

Item was changed:
  ----- Method: Object>>primitiveError: (in category '*System-Recovery-error handling') -----
  primitiveError: aString
+
+ self flag: #discussion. "mt: Is this still required?"
+ Project current primitiveError: aString.!
- Project handlePrimitiveError: aString.!

Item was added:
+ ----- Method: Process class>>forBlock: (in category '*System-debugging') -----
+ forBlock: aBlock
+ "Create a process and step into the block's method."
+
+ ^ self
+ forBlock: aBlock
+ runUntil: [:context | context method == aBlock method]!

Item was added:
+ ----- Method: Process class>>forBlock:runUntil: (in category '*System-debugging') -----
+ forBlock: aBlock runUntil: aConditionBlock
+ "Create a process for the given block. Simulate code execution until the provided condition is fulfilled."
+
+ ^ aBlock newProcess
+ runUntil: aConditionBlock;
+ yourself!

Item was added:
+ ----- Method: Process class>>forMethod:receiver: (in category '*System-debugging') -----
+ forMethod: aCompiledMethod receiver: anObject
+ "Create a process and step into the method."
+
+ ^ self
+ forBlock: [aCompiledMethod valueWithReceiver: anObject arguments: {}]
+ runUntil: [:context | context method == aCompiledMethod]!

Item was added:
+ ----- Method: Process class>>forMethod:receiver:arguments: (in category '*System-debugging') -----
+ forMethod: aCompiledMethod receiver: anObject arguments: someArguments
+ "Create a process and step into the method."
+
+ ^ self
+ forBlock: [aCompiledMethod valueWithReceiver: anObject arguments: someArguments]
+ runUntil: [:context | context method == aCompiledMethod]!

Item was added:
+ ----- Method: Process class>>forMethod:receiver:arguments:runUntil: (in category '*System-debugging') -----
+ forMethod: aCompiledMethod receiver: anObject arguments: someArguments runUntil: aConditionBlock
+
+ ^ self
+ forBlock: [aCompiledMethod valueWithReceiver: anObject arguments: someArguments]
+ runUntil: aConditionBlock!

Item was added:
+ ----- Method: Process>>clearErrorRecursionFlag (in category '*System-debugging') -----
+ clearErrorRecursionFlag
+
+ self environmentAt: #errorRecursionFlag put: false.!

Item was added:
+ ----- Method: Process>>hasRecursiveError (in category '*System-debugging') -----
+ hasRecursiveError
+
+ ^ self environmentAt: #errorRecursionFlag ifAbsent: [false]!

Item was added:
+ ----- Method: Process>>runUntil: (in category '*System-debugging') -----
+ runUntil: aConditionBlock
+ "Simulate code execution until the provided condition is fulfilled."
+
+ [(aConditionBlock isNil
+ or: [self isTerminated])
+ or: [aConditionBlock value: self suspendedContext]
+ ] whileFalse: [self step].
+
+ "If we are already at a send, this next call should do nothing."
+ self stepToSendOrReturn.!

Item was added:
+ ----- Method: Process>>setErrorRecursionFlag (in category '*System-debugging') -----
+ setErrorRecursionFlag
+
+ self environmentAt: #errorRecursionFlag put: true.!

Item was added:
+ ----- Method: Process>>shouldResumeFromDebugger (in category '*System-debugging') -----
+ shouldResumeFromDebugger
+ "Tools can construct processes that might interfere with existing ones. For example, one process can be copied for inspecting the state through that copy later on. Resuming both - original and copy - at some point might result in unexpected interference. To prevent or help In such situations, the copy can be flagged to not be resumable from the debugger. Note that you can always resume a process with #resume even if a tool tells you otherwise."
+
+ ^ self environmentAt: #shouldResumeFromDebugger ifAbsent: [true]!

Item was added:
+ ----- Method: Process>>shouldResumeFromDebugger: (in category '*System-debugging') -----
+ shouldResumeFromDebugger: aBoolean
+
+ self environmentAt: #shouldResumeFromDebugger put: aBoolean.!

Item was removed:
- ----- Method: Project class>>handlePrimitiveError: (in category 'error recovery') -----
- handlePrimitiveError: errorMessage
- "This method is called when the error handling results in a recursion in
- calling on error: or halt or halt:.."
-
- self tryOtherProjectForRecovery: errorMessage.
- self tryEmergencyEvaluatorForRecovery: errorMessage.
-
- Project current restoreDisplay.!

Item was changed:
  ----- Method: Project class>>resumeProcess: (in category 'utilities') -----
  resumeProcess: aProcess
  "Adopt aProcess as the project process -- probably because of proceeding from a debugger"
 
+ self flag: #toRemove. "mt: This seems to be quite specific for MorphicProject... and we have a MorphicDebugger to take care of #resumeProcess: ... Is this hook still needed?"
  self current uiProcess: aProcess.
  aProcess resume!

Item was changed:
  ----- Method: Project class>>tryEmergencyEvaluatorForRecovery: (in category 'error recovery') -----
  tryEmergencyEvaluatorForRecovery: errorMessage
 
  | hasTranscripter transcripter |
+
+ "Make sure to display something."
+ Display deferUpdates: false.
+
  hasTranscripter := (Smalltalk classNamed: #Transcripter)
  ifNotNil: [ :t | transcripter := t. true]
  ifNil: [false].
  (String
  streamContents:
  [:s |
  | context |
  s nextPutAll: '***System error handling failed***'.
  s cr; nextPutAll: errorMessage.
  context := thisContext sender sender.
  20 timesRepeat: [context == nil ifFalse: [s cr; print: (context := context sender)]].
  s cr; nextPutAll: '-------------------------------'.
  hasTranscripter
  ifTrue: [
  s cr; nextPutAll: 'Type CR to enter an emergency evaluator.'.
  s cr; nextPutAll: 'Type any other character to restart.']
  ifFalse: [
  s cr; nextPutAll: 'Type any character to restart.']])
  displayAt: 0 @ 0.
 
  [Sensor keyboardPressed] whileFalse.
 
  Sensor keyboard = Character cr ifTrue: [
  hasTranscripter ifTrue: [transcripter emergencyEvaluator]].!

Item was removed:
- ----- Method: Project>>handleFatalDrawingError: (in category 'displaying') -----
- handleFatalDrawingError: errMsg
- "Handle a fatal drawing error."
-
- Display deferUpdates: false. "Just in case"
- self primitiveError: errMsg.
-
- "Hm... we should jump into a 'safe' worldState here, but how do we find it?!!"!

Item was changed:
  ----- Method: Project>>interruptName: (in category 'scheduling & debugging') -----
  interruptName: labelString
  "Create a Notifier on the active scheduling process with the given label."
 
+ ^ self
+ interruptName: labelString
+ message: nil
+ preemptedProcess: nil!
- ^ self subclassResponsibility
- !

Item was added:
+ ----- Method: Project>>interruptName:message: (in category 'scheduling & debugging') -----
+ interruptName: labelString message: aMessage
+ "Create a Notifier on the active scheduling process with the given label."
+
+ ^ self
+ interruptName: labelString
+ message: aMessage
+ preemptedProcess: nil!

Item was added:
+ ----- Method: Project>>interruptName:message:preemptedProcess: (in category 'scheduling & debugging') -----
+ interruptName: labelString message: aMessage preemptedProcess: theInterruptedProcess
+ "Create a Notifier on the active scheduling process with the given label."
+
+ | preemptedProcess projectProcess |
+ projectProcess := self uiProcess.
+ preemptedProcess := theInterruptedProcess ifNil: [Processor preemptedProcess].
+
+ "Only debug preempted process if its priority is >= projectProcess' priority"
+ preemptedProcess priority < projectProcess priority
+ ifTrue:[preemptedProcess := projectProcess].
+
+ "Give projects a change to clean up."
+ self interruptCleanUpFor: preemptedProcess.
+
+ ^ preemptedProcess debugWithTitle: labelString full: false contents: aMessage!

Item was changed:
  ----- Method: Project>>interruptName:preemptedProcess: (in category 'scheduling & debugging') -----
  interruptName: labelString preemptedProcess: theInterruptedProcess
+
+ self
+ interruptName: labelString
+ message: nil
+ preemptedProcess: theInterruptedProcess.!
- "Create a Notifier on the active scheduling process with the given label."
-
- ^ self subclassResponsibility
- !

Item was added:
+ ----- Method: Project>>primitiveError: (in category 'scheduling & debugging') -----
+ primitiveError: errorMessage
+ "System error handling has failed. Try something else to keep the system alive."
+
+ Project tryOtherProjectForRecovery: errorMessage.
+ Project tryEmergencyEvaluatorForRecovery: errorMessage.
+
+ self restoreDisplay.!

Item was added:
+ ----- Method: Project>>recursiveError: (in category 'scheduling & debugging') -----
+ recursiveError: errorMessage
+ "This method is called when the error handling results in a recursion in calling on error: or halt or halt:, which basically means that the debugger cannot be opened."
+
+ self primitiveError: errorMessage.!

Item was changed:
  ----- Method: SmalltalkImage>>handleUserInterrupt (in category 'miscellaneous') -----
  handleUserInterrupt
+ [ToolSet handleUserInterruptRequest: 'User Interrupt'] fork.!
- Preferences cmdDotEnabled ifTrue:
- [[ToolSet handleUserInterruptRequest: 'User Interrupt'] fork]
- !

Item was added:
+ ----- 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 changed:
  ----- 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.
  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 removed:
- ----- Method: ToolSet class>>debugActiveProcessContext:label:contents: (in category 'debugging - convenience') -----
- debugActiveProcessContext: aContext label: aString contents: contents
-
- ^ self
- debugProcess: Processor activeProcess
- context: aContext
- label: aString
- contents: contents
- fullView: false!

Item was added:
+ ----- Method: ToolSet class>>debugException: (in category 'debugging') -----
+ debugException: anException
+ "For convenience. Enable users to debug an exception that occurred in the active process later on. Note that the active process is the process where the exception was raised, which might not be the current ui process. It is okay to ignore this request in a custom toolset.
+
+ Example print-it:
+
+ [ self halt. 3+4 ]
+ on: Halt do: [:ex | ToolSet debugException: ex. ex resume] "
+
+ ^ self default ifNotNil: [:ts |ts debugException: anException]!

Item was removed:
- ----- Method: ToolSet class>>debugInterruptedProcess:label: (in category 'debugging') -----
- debugInterruptedProcess: aSuspendedProcess label: aString
- "Open a debugger on the given process, which is already suspended."
-
- ^ self default
- ifNil: [(self confirm: 'Debugger request -- proceed?') ifFalse:[aSuspendedProcess terminate]]
- ifNotNil: [:ts | ts debugInterruptedProcess: aSuspendedProcess label: aString]!

Item was removed:
- ----- Method: ToolSet class>>debugMethod:forReceiver:inContext: (in category 'debugging') -----
- debugMethod: aCompiledMethod forReceiver: anObject inContext: aContext
-
- ^ self default
- ifNil: [
- self inform: 'Cannot debug method. It will just be executed.'.
- aCompiledMethod
- valueWithReceiver: anObject
- arguments: (aContext ifNil: [#()] ifNotNil: [{aContext}])]
- ifNotNil: [:ts | ts debugMethod: aCompiledMethod forReceiver: anObject inContext: aContext]!

Item was changed:
  ----- Method: ToolSet class>>debugProcess:context:label:contents:fullView: (in category 'debugging') -----
  debugProcess: aProcess context: aContext label: aString contents: contents fullView: aBool
+ "Open a debugger on the given process, which might be active, suspended, or terminated."
- "Open a debugger on the given process, which  might be active, suspended, or terminated."
 
  ^ self default
  ifNil: [(self confirm: 'Debugger request -- proceed?') ifFalse: [Processor terminateActive]]
  ifNotNil: [:ts | ts debugProcess: aProcess context: aContext label: aString contents: contents fullView: aBool]!

Item was added:
+ ----- Method: ToolSet class>>handleRecursiveError: (in category 'debugging - handlers') -----
+ handleRecursiveError: description
+ "THE ACTIVE PROCESS *IS* WHERE THE RECURSION WAS DETECTED."
+
+ ^ self default
+ ifNil: [Project current primitiveError: description]
+ ifNotNil: [:ts | ts handleRecursiveError: description]!