The Trunk: Morphic-mt.1521.mcz

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

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

Name: Morphic-mt.1521
Author: mt
Time: 17 September 2019, 12:11:44.272406 pm
UUID: 8f7a9d88-4010-8947-a9a1-7a6174c8e3c9
Ancestors: Morphic-mt.1520

Refactoring of process debugging. Complements System-mt.1093

=============== Diff against Morphic-mt.1520 ===============

Item was removed:
- ----- Method: Debugger class>>morphicOpenOn:context:label:contents:fullView: (in category '*Morphic-opening') -----
- morphicOpenOn: process context: context label: title contents: contentsStringOrNil fullView: full
- "Open a notifier in response to an error, halt, or notify. A notifier view just shows a short view of the sender stack and provides a menu that lets the user open a full debugger."
-
- ErrorRecursionGuard critical: [
-
- | errorWasInUIProcess debugger |
- ErrorRecursion ifTrue: [
- "self assert: process == Project current uiProcess -- DOCUMENTATION ONLY"
- self clearErrorRecursion.
- ^ Project current handleFatalDrawingError: title].
-
- [ErrorRecursion not & Preferences logDebuggerStackToFile
- ifTrue: [Smalltalk logSqueakError: title inContext: context]]
- on: Error
- do: [:ex | ex return: nil].
-
- errorWasInUIProcess := Project current spawnNewProcessIfThisIsUI: process.
-
- "Schedule debugging in deferred UI message because
- 1) If process is the current UI process, it is already broken.
- 2) If process is some other process, it must not execute UI code"
- Project current addDeferredUIMessage: [
- self setErrorRecursion.
-
- debugger := self new process: process controller: nil context: context.
- full
- ifTrue: [debugger openFullNoSuspendLabel: title]
- ifFalse: [debugger openNotifierContents: contentsStringOrNil label: title].
- debugger errorWasInUIProcess: errorWasInUIProcess.
-
- "Try drawing the debugger tool at least once to avoid freeze."
- Project current world displayWorldSafely.
-
- self clearErrorRecursion]].
-
- process suspend.!

Item was removed:
- ----- Method: Debugger class>>openContext:label:contents: (in category '*Morphic-opening') -----
- openContext: aContext label: aString contents: contentsStringOrNil
- "Open a notifier in response to an error, halt, or notify. A notifier view just shows a short view of the sender stack and provides a menu that lets the user open a full debugger."
- "Simulation guard"
- <primitive: 19>
- ErrorRecursionGuard critical:
- [ ErrorRecursion not & Preferences logDebuggerStackToFile ifTrue:
- [ Smalltalk
- logSqueakError: aString
- inContext: aContext ].
- ErrorRecursion ifTrue:
- [ ErrorRecursion := false.
- self primitiveError: aString ].
- ErrorRecursion := true.
- self
- informExistingDebugger: aContext
- label: aString.
- (Debugger context: aContext)
- openNotifierContents: contentsStringOrNil
- label: aString.
- ErrorRecursion := false].
- Processor activeProcess suspend !

Item was removed:
- ----- Method: Debugger class>>openInterrupt:onProcess: (in category '*Morphic-opening') -----
- openInterrupt: aString onProcess: interruptedProcess
- "Open a notifier in response to an interrupt. An interrupt occurs when the user types the interrupt key (cmd-. on Macs, ctrl-c or alt-. on other systems) or when the low-space watcher detects that memory is low."
- | debugger |
- <primitive: 19> "Simulation guard"
- debugger := self new.
- debugger
- process: interruptedProcess
- controller: (ScheduledControllers
- ifNotNil: [:sc |
- "this means we are in an MVC project"
- sc inActiveControllerProcess == interruptedProcess
- ifTrue: [ScheduledControllers activeController]])
- context: interruptedProcess suspendedContext.
- debugger externalInterrupt: true.
-
- Preferences logDebuggerStackToFile ifTrue:
- [(aString includesSubstring: 'Space') & (aString includesSubstring: 'low')
- ifTrue: [Smalltalk logError: aString inContext: debugger interruptedContext to: 'LowSpaceDebug.log']
- "logging disabled for 4.3 release, see
- http://lists.squeak.org/pipermail/squeak-dev/2011-December/162503.html"
- "ifFalse: [Smalltalk logSqueakError: aString inContext: debugger interruptedContext]"].
-
- Preferences eToyFriendly ifTrue: [Project current world stopRunningAll].
- ^debugger
- openNotifierContents: nil label: aString;
- yourself
- !

Item was removed:
- ----- Method: Debugger>>morphicResumeProcess: (in category '*Morphic-opening') -----
- morphicResumeProcess: aTopView
-
- | processToResume |
- processToResume := interruptedProcess.
- interruptedProcess := nil. "Before delete, so release doesn't terminate it"
- aTopView delete.
- Project current world displayWorld. "We have to redraw *before* resuming the old process."
- Smalltalk installLowSpaceWatcher. "restart low space handler"
-
- savedCursor
- ifNotNil: [Cursor currentCursor: savedCursor].
- processToResume isTerminated ifFalse: [
- errorWasInUIProcess
- ifTrue: [Project resumeProcess: processToResume]
- ifFalse: [processToResume resume]].
- "if old process was terminated, just terminate current one"
- errorWasInUIProcess == false
- ifFalse: [Processor terminateActive]!

Item was added:
+ Debugger subclass: #MorphicDebugger
+ instanceVariableNames: 'errorWasInUIProcess'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Morphic-Support'!

Item was added:
+ ----- Method: MorphicDebugger class>>openDrawingErrors: (in category 'opening') -----
+ openDrawingErrors: errors
+ "Open debuggers for all different errors found."
+
+ self setErrorRecursion.
+ errors do: [:processToLabel |
+ (MorphicDebugger new process: processToLabel key context: processToLabel key suspendedContext)
+ errorWasInUIProcess: Processor activeProcess = Project current uiProcess;
+ openNotifierContents: nil label: processToLabel value].
+
+ "Try to draw the debuggers or else there will be no chance to escape from this catch-drawing-error loop."
+ Project current world displayWorld.
+ self clearErrorRecursion.!

Item was added:
+ ----- Method: MorphicDebugger class>>openInterrupt:onProcess: (in category 'opening') -----
+ openInterrupt: aString onProcess: interruptedProcess
+ "Open a notifier in response to an interrupt. An interrupt occurs when the user types the interrupt key (cmd-. on Macs, ctrl-c or alt-. on other systems) or when the low-space watcher detects that memory is low."
+
+ | errorWasInUIProcess debugger |
+ <primitive: 19> "Simulation guard"
+
+ errorWasInUIProcess := Project current spawnNewProcessIfThisIsUI: interruptedProcess.
+ debugger := self new.
+ debugger
+ process: interruptedProcess
+ context: interruptedProcess suspendedContext.
+ debugger
+ externalInterrupt: true;
+ errorWasInUIProcess: errorWasInUIProcess.
+
+ Preferences logDebuggerStackToFile ifTrue:
+ [(aString includesSubstring: 'Space') & (aString includesSubstring: 'low')
+ ifTrue: [Smalltalk logError: aString inContext: debugger interruptedContext to: 'LowSpaceDebug.log']
+ "logging disabled for 4.3 release, see
+ http://lists.squeak.org/pipermail/squeak-dev/2011-December/162503.html"
+ "ifFalse: [Smalltalk logSqueakError: aString inContext: debugger interruptedContext]"].
+
+ Preferences eToyFriendly ifTrue: [Project current world stopRunningAll].
+ ^debugger
+ openNotifierContents: nil label: aString;
+ yourself
+ !

Item was added:
+ ----- Method: MorphicDebugger class>>openOn:context:label:contents:fullView: (in category 'opening') -----
+ openOn: process context: context label: title contents: contentsStringOrNil fullView: full
+ "Open a notifier in response to an error, halt, or notify. A notifier view just shows a short view of the sender stack and provides a menu that lets the user open a full debugger."
+
+ ErrorRecursionGuard critical: [
+
+ | errorWasInUIProcess debugger |
+ ErrorRecursion ifTrue: [
+ "self assert: process == Project current uiProcess -- DOCUMENTATION ONLY"
+ self clearErrorRecursion.
+ ^ Project current handleFatalDrawingError: title].
+
+ [ErrorRecursion not & Preferences logDebuggerStackToFile
+ ifTrue: [Smalltalk logSqueakError: title inContext: context]]
+ on: Error
+ do: [:ex | ex return: nil].
+
+ errorWasInUIProcess := Project current spawnNewProcessIfThisIsUI: process.
+
+ "Schedule debugging in deferred UI message because
+ 1) If process is the current UI process, it is already broken.
+ 2) If process is some other process, it must not execute UI code"
+ Project current addDeferredUIMessage: [
+ self setErrorRecursion.
+
+ self informExistingDebugger: context label: title.
+
+ debugger := self new process: process context: context.
+ full
+ ifTrue: [debugger openFullNoSuspendLabel: title]
+ ifFalse: [debugger openNotifierContents: contentsStringOrNil label: title].
+ debugger errorWasInUIProcess: errorWasInUIProcess.
+
+ "Try drawing the debugger tool at least once to avoid freeze."
+ Project current world displayWorldSafely.
+
+ self clearErrorRecursion]].
+
+ process suspend.!

Item was added:
+ ----- Method: MorphicDebugger class>>openOnMethod:forReceiver:inContext: (in category 'opening') -----
+ openOnMethod: aCompiledMethod forReceiver: anObject inContext: aContextOrNil
+
+ | guineaPig debugger debuggerWindow context |
+ guineaPig :=
+ [aCompiledMethod
+ valueWithReceiver: anObject
+ arguments: (aContextOrNil ifNil: [ #() ] ifNotNil: [ { aContextOrNil } ]).
+ guineaPig := nil "spot the return from aCompiledMethod"] newProcess.
+ context := guineaPig suspendedContext.
+ debugger := self new
+ process: guineaPig
+ context: context.
+ debuggerWindow := debugger openFullNoSuspendLabel: 'Debug it'.
+ "Now step into the expression.  But if it is quick (is implemented as a primtiive, e.g. `0')
+ it will return immediately back to the block that is sent newProcess above.  Guard
+ against that with the check for home being thisContext."
+ [debugger interruptedContext method == aCompiledMethod]
+ whileFalse:
+ [(guineaPig isNil
+  and: [debugger interruptedContext home == thisContext]) ifTrue:
+ [debuggerWindow delete.
+ UIManager default inform: 'Nothing to debug; expression is optimized'.
+ ^self].
+ debugger send]!

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

Item was added:
+ ----- Method: MorphicDebugger>>errorWasInUIProcess: (in category 'accessing') -----
+ errorWasInUIProcess: boolean
+
+ errorWasInUIProcess := boolean!

Item was added:
+ ----- Method: MorphicDebugger>>initialize (in category 'initialize') -----
+ initialize
+
+ super initialize.
+
+ errorWasInUIProcess := false.!

Item was added:
+ ----- Method: MorphicDebugger>>resumeProcess: (in category 'private') -----
+ resumeProcess: debuggerWindow
+
+ | processToResume |
+ processToResume := interruptedProcess.
+
+ interruptedProcess := nil. "Before delete, so release doesn't terminate it"
+ debuggerWindow delete.
+
+ Project current world displayWorld. "We have to redraw *before* resuming the old process."
+ Smalltalk installLowSpaceWatcher. "restart low space handler"
+
+ savedCursor
+ ifNotNil: [Cursor currentCursor: savedCursor].
+ processToResume isTerminated ifFalse: [
+ errorWasInUIProcess
+ ifTrue: [Project resumeProcess: processToResume]
+ ifFalse: [processToResume resume]].
+ "if old process was terminated, just terminate current one"
+ errorWasInUIProcess == false
+ ifFalse: [Processor terminateActive]!

Item was added:
+ ----- Method: MorphicDebugger>>windowIsClosing (in category 'initialize') -----
+ windowIsClosing
+ "Keep track of last debugger extent."
+
+ interruptedProcess ifNil: [ ^ self ].
+
+ SavedExtent ifNotNil:
+ [ self dependents
+ detect:
+ [ : each | each isWindowForModel: self ]
+ ifFound:
+ [ : topWindow | | isDebuggerNotNotifier |
+ isDebuggerNotNotifier := self dependents anySatisfy:
+ [ : each | each isTextView ].
+ isDebuggerNotNotifier ifTrue: [
+ SavedExtent := (topWindow extent / RealEstateAgent scaleFactor) rounded ] ]
+ ifNone: [ "do nothing" ] ].
+
+ super windowIsClosing.!

Item was changed:
+ ----- Method: MorphicProject>>addDeferredUIMessage: (in category 'scheduling & debugging') -----
- ----- Method: MorphicProject>>addDeferredUIMessage: (in category 'scheduling') -----
  addDeferredUIMessage: valuableObject
  "Arrange for valuableObject to be evaluated at a time when the user interface
  is in a coherent state."
 
+ self flag: #discuss. "mt: Why are deferred UI messages shared among all Morphic projects? That's not the case for MVC projects..."
  WorldState addDeferredUIMessage: valuableObject!

Item was removed:
- ----- Method: MorphicProject>>debugMethod:forReceiver:inContext: (in category 'debugging') -----
- debugMethod: aCompiledMethod forReceiver: anObject inContext: aContextOrNil
-
- | guineaPig debugger debuggerWindow context |
- guineaPig :=
- [aCompiledMethod
- valueWithReceiver: anObject
- arguments: (aContextOrNil ifNil: [ #() ] ifNotNil: [ { aContextOrNil } ]).
- guineaPig := nil "spot the return from aCompiledMethod"] newProcess.
- context := guineaPig suspendedContext.
- debugger := Debugger new
- process: guineaPig
- controller: nil
- context: context.
- debuggerWindow := debugger openFullNoSuspendLabel: 'Debug it'.
- "Now step into the expression.  But if it is quick (is implemented as a primtiive, e.g. `0')
- it will return immediately back to the block that is sent newProcess above.  Guard
- against that with the check for home being thisContext."
- [debugger interruptedContext method == aCompiledMethod]
- whileFalse:
- [(guineaPig isNil
-  and: [debugger interruptedContext home == thisContext]) ifTrue:
- [debuggerWindow delete.
- UIManager default inform: 'Nothing to debug; expression is optimized'.
- ^self].
- debugger send]!

Item was added:
+ ----- Method: MorphicProject>>debuggerClass (in category 'scheduling & debugging') -----
+ debuggerClass
+
+ ^ Smalltalk classNamed: #MorphicDebugger!

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

Item was changed:
+ ----- Method: MorphicProject>>interruptName:preemptedProcess: (in category 'scheduling & debugging') -----
- ----- Method: MorphicProject>>interruptName:preemptedProcess: (in category 'utilities') -----
  interruptName: labelString preemptedProcess: theInterruptedProcess
  "Create a Notifier on the active scheduling process with the given label."
 
  | preemptedProcess projectProcess |
  ActiveHand ifNotNil:[ActiveHand interrupted].
  ActiveWorld := world. "reinstall active globals"
  ActiveHand := world primaryHand.
  ActiveHand interrupted. "make sure this one's interrupted too"
  ActiveEvent := nil.
 
  projectProcess := self uiProcess. "we still need the accessor for a while"
  preemptedProcess := theInterruptedProcess ifNil: [Processor preemptedProcess].
  "Only debug preempted process if its priority is >= projectProcess' priority"
  preemptedProcess priority < projectProcess priority
  ifTrue:[preemptedProcess := projectProcess].
  preemptedProcess suspend.
+
+ ToolSet
+ debugInterruptedProcess: preemptedProcess
+ label: labelString.!
- ToolSet interrupt: preemptedProcess label: labelString.!

Item was added:
+ ----- Method: MorphicProject>>syntaxError: (in category 'scheduling & debugging') -----
+ syntaxError: aSyntaxErrorNotification
+
+ | compilerProcess errorWasInUIProcess debugger |
+ debugger := (super syntaxError: aSyntaxErrorNotification) model debugger.
+
+ compilerProcess := Processor activeProcess.
+ errorWasInUIProcess := self spawnNewProcessIfThisIsUI: compilerProcess.
+
+ debugger errorWasInUIProcess: errorWasInUIProcess.
+ compilerProcess suspend.!

Item was removed:
- ----- Method: SyntaxError class>>buildMorphicViewOn: (in category '*Morphic-Support') -----
- buildMorphicViewOn: aSyntaxError
- "Answer an Morphic view on the given SyntaxError."
- | window |
- window := (SystemWindow labelled: 'Syntax Error') model: aSyntaxError.
-
- window addMorph: (PluggableListMorph on: aSyntaxError list: #list
- selected: #listIndex changeSelected: nil menu: #listMenu:)
- frame: (0@0 corner: 1@0.15).
-
- window addMorph: ((PluggableTextMorphPlus on: aSyntaxError text: #contents
- accept: #contents:notifying: readSelection: #contentsSelection
- menu: #codePaneMenu:shifted:)
- useDefaultStyler; updateStyleNow;
- selectionInterval: aSyntaxError errorMessageInterval;
- yourself)
- frame: (0@0.15 corner: 1@1).
-
- ^ window openInWorldExtent: 380@220!

Item was removed:
- ----- Method: SyntaxError class>>morphicOpen: (in category '*Morphic-Support') -----
- morphicOpen: aSyntaxError
- "Answer a view whose model is an instance of me."
-
- self buildMorphicViewOn: aSyntaxError.
- Project current spawnNewProcessIfThisIsUI: Processor activeProcess.
- ^ Processor activeProcess suspend!

Item was changed:
  ----- Method: WorldState>>displayWorldSafely: (in category 'update cycle') -----
  displayWorldSafely: aWorld
  "Update this world's display and keep track of errors during draw methods."
 
  | finished errors previousClasses |
  finished := false.
  errors := nil.
 
  [finished] whileFalse: [
  [aWorld displayWorld. finished := true] on: Error do: [:ex |
  "Handle a drawing error"
  | err rcvr errCtx errMorph |
  err := ex description.
  rcvr := ex receiver.
 
  errCtx := thisContext.
  [
  errCtx := errCtx sender.
  "Search the sender chain to find the morph causing the problem"
  [errCtx notNil and:[(errCtx receiver isMorph) not]]
  whileTrue:[errCtx := errCtx sender].
  "If we're at the root of the context chain then we have a fatal drawing problem"
  errCtx ifNil:[^Project current handleFatalDrawingError: err].
  errMorph := errCtx receiver.
  "If the morph causing the problem has already the #drawError flag set,
  then search for the next morph above in the caller chain."
  errMorph hasProperty: #errorOnDraw
  ] whileTrue.
  errMorph setProperty: #errorOnDraw toValue: true.
 
  "Catch all errors, one for each receiver class."
  errors ifNil: [errors := OrderedCollection new].
  previousClasses ifNil: [previousClasses := IdentitySet new].
  (previousClasses includes: rcvr class) ifFalse: [
  previousClasses add: rcvr class.
  errors add: (Process forContext: ex signalerContext copyStack priority: Processor activeProcess priority) -> err].
  aWorld fullRepaintNeeded.
  ]].
 
+ errors ifNotNil: [MorphicDebugger openDrawingErrors: errors].!
- "Open debuggers for all different errors found."
- errors ifNotNil: [
- Debugger setErrorRecursion.
- errors do: [:ea |
- (Debugger new process: ea key controller: nil context: ea key suspendedContext)
- errorWasInUIProcess: Processor activeProcess = Project current uiProcess;
- openNotifierContents: nil label: ea value].
- "Try to draw the debuggers or else there will be no chance to escape from this catch-drawing-error loop."
- ActiveWorld displayWorld.
- Debugger clearErrorRecursion].!