The Trunk: Kernel-mt.1381.mcz

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

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

Name: Kernel-mt.1381
Author: mt
Time: 15 March 2021, 11:19:02.546586 am
UUID: 11976771-8ccb-e941-83da-2ae26c3a9f55
Ancestors: Kernel-mt.1380

Fixes for debugger invocation during code simulation. See http://forum.world.st/Please-try-out-Fixes-for-debugger-invocation-during-code-simulation-td5127684.html

=============== Diff against Kernel-mt.1380 ===============

Item was changed:
  (PackageInfo named: 'Kernel') preamble: '"below, add code to be run before the loading of this package"
+ ProcessorScheduler instVarNames at: 2 put: ''genuineProcess''.'!
- BlockClosure instVarNames at: 2 put: ''startpcOrMethod'''!

Item was changed:
  ----- Method: Context>>cannotReturn: (in category 'private-exceptions') -----
  cannotReturn: result
 
+ closureOrNil ifNotNil: [^ self cannotReturn: result to: self home sender].
+ Processor debugWithTitle: 'Computation has been terminated!!' translated full: false.!
- closureOrNil notNil ifTrue:
- [^self cannotReturn: result to: self home sender].
- Processor activeProcess
- debug: thisContext
- title: 'computation has been terminated'
- full: false.!

Item was changed:
  ----- Method: Context>>doPrimitive:method:receiver:args: (in category 'private') -----
  doPrimitive: primitiveIndex method: meth receiver: receiver args: arguments
  "Simulate a primitive method whose index is primitiveIndex.  The simulated receiver and
  arguments are given as arguments to this message. If successful, push result and return
  resuming context, else ^ {errCode, PrimitiveFailToken}. Any primitive which provokes
  execution needs to be intercepted and simulated to avoid execution running away."
 
  | value |
  "Judicious use of primitive 19 (a null primitive that doesn't do anything) prevents
  the debugger from entering various run-away activities such as spawning a new
  process, etc.  Injudicious use results in the debugger not being able to debug
  interesting code, such as the debugger itself.  Hence use primitive 19 with care :-)"
  "SystemNavigation new browseAllSelect: [:m| m primitive = 19]"
+ primitiveIndex = 19 ifTrue: [
+ [self notify: ('The code being simulated is trying to control a process ({1}). Process controlling cannot be simulated. If you proceed, things may happen outside the observable area of the simulator.' translated format: {meth reference})]
+ ifCurtailed: [self push: nil "Cheap fix of the context's internal state"]].
+
- primitiveIndex = 19 ifTrue:
- [Processor activeProcess
- debug: self
- title:'Code simulation error'
- full: false].
-
  ((primitiveIndex between: 201 and: 222)
  and: [(self objectClass: receiver) includesBehavior: BlockClosure]) ifTrue:
  [(primitiveIndex = 206
   or: [primitiveIndex = 208]) ifTrue: "[Full]BlockClosure>>valueWithArguments:"
  [^receiver simulateValueWithArguments: arguments first caller: self].
  ((primitiveIndex between: 201 and: 209) "[Full]BlockClosure>>value[:value:...]"
   or: [primitiveIndex between: 221 and: 222]) ifTrue: "[Full]BlockClosure>>valueNoContextSwitch[:]"
  [^receiver simulateValueWithArguments: arguments caller: self]].
 
  primitiveIndex = 83 ifTrue: "afr 9/11/1998 19:50" "Object>>perform:[with:...]"
  [^self send: arguments first to: receiver with: arguments allButFirst].
  primitiveIndex = 84 ifTrue: "afr 9/11/1998 19:50 & eem 8/18/2009 17:04" "Object>>perform:withArguments:"
  [^self send: arguments first to: receiver with: (arguments at: 2) lookupIn: (self objectClass: receiver)].
  primitiveIndex = 100 ifTrue: "eem 8/18/2009 16:57" "Object>>perform:withArguments:inSuperclass:"
  [^self send: arguments first to: receiver with: (arguments at: 2) lookupIn: (arguments at: 3)].
 
  "Mutex>>primitiveEnterCriticalSection
  Mutex>>primitiveTestAndSetOwnershipOfCriticalSection"
  (primitiveIndex = 186 or: [primitiveIndex = 187]) ifTrue:
+ [| effective |
+ effective := Processor activeProcess effectiveProcess.
+ "active == effective"
+ value := primitiveIndex = 186
+ ifTrue: [receiver primitiveEnterCriticalSectionOnBehalfOf: effective]
+ ifFalse: [receiver primitiveTestAndSetOwnershipOfCriticalSectionOnBehalfOf: effective].
- ["Transcript
- cr;
- nextPutAll: 'Processor activeProcess ';
- nextPutAll: (Processor activeProcess == receiver owningProcess ifTrue: [#==] ifFalse: [#~~]);
- nextPutAll: ' owner';
- flush."
- value := primitiveIndex = 186
- ifTrue: [receiver primitiveEnterCriticalSectionOnBehalfOf: Processor activeProcess]
- ifFalse: [receiver primitiveTestAndSetOwnershipOfCriticalSectionOnBehalfOf: Processor activeProcess].
  ^(self isPrimFailToken: value)
  ifTrue: [value]
  ifFalse: [self push: value]].
 
  primitiveIndex = 188 ifTrue: "Object>>withArgs:executeMethod:
  CompiledMethod class>>receiver:withArguments:executeMethod:
  VMMirror>>ifFail:object:with:executeMethod: et al"
  [| n args methodArg thisReceiver |
  ((n := arguments size) between: 2 and: 4) ifFalse:
  [^self class primitiveFailTokenFor: #'unsupported operation'].
  ((self objectClass: (args := arguments at: n - 1)) == Array
   and: [(self objectClass: (methodArg := arguments at: n)) includesBehavior: CompiledMethod]) ifFalse:
  [^self class primitiveFailTokenFor: #'bad argument'].
  methodArg numArgs = args size ifFalse:
  [^self class primitiveFailTokenFor: #'bad number of arguments'].
  thisReceiver := arguments at: n - 2 ifAbsent: [receiver].
  methodArg primitive > 0 ifTrue:
  [methodArg isQuick ifTrue:
  [^self push: (methodArg valueWithReceiver: thisReceiver arguments: args)].
  ^self doPrimitive: methodArg primitive method: meth receiver: thisReceiver args: args].
  ^Context
  sender: self
  receiver: thisReceiver
  method: methodArg
  arguments: args].
 
  primitiveIndex = 118 ifTrue: "[receiver:]tryPrimitive:withArgs:; avoid recursing in the VM"
  [(arguments size = 3
   and: [(self objectClass: arguments second) == SmallInteger
   and: [(self objectClass: arguments last) == Array]]) ifTrue:
  [^self doPrimitive: arguments second method: meth receiver: arguments first args: arguments last].
  (arguments size = 2
  and: [(self objectClass: arguments first) == SmallInteger
  and: [(self objectClass: arguments last) == Array]]) ifFalse:
  [^self class primitiveFailTokenFor: nil].
  ^self doPrimitive: arguments first method: meth receiver: receiver args: arguments last].
 
  value := primitiveIndex = 120 "FFI method"
  ifTrue: [(meth literalAt: 1) tryInvokeWithArguments: arguments]
  ifFalse:
  [primitiveIndex = 117 "named primitives"
  ifTrue: [self tryNamedPrimitiveIn: meth for: receiver withArgs: arguments]
  ifFalse: "should use self receiver: receiver tryPrimitive: primitiveIndex withArgs: arguments but this is only in later VMs (and appears to be broken)"
  [receiver tryPrimitive: primitiveIndex withArgs: arguments]].
 
  ^(self isPrimFailToken: value)
  ifTrue: [value]
  ifFalse: [self push: value]!

Item was changed:
  ----- Method: ObjectTracer>>doesNotUnderstand: (in category 'very few messages') -----
  doesNotUnderstand: aMessage
+ "Present a debugger before proceeding to re-send the message. All external messages (those not caused by the re-send) get trapped here."
- "Present a debugger before proceeding to re-send the message"
 
+ self flag: #workaround. "ct: After the selection of buttons in the debugger has been refactored, return to a simple Warning here. See: http://forum.world.st/The-Trunk-Kernel-mt-1303-mcz-tp5112200p5112211.html"
+ Processor
+ debugWithTitle: ('Object Tracer ({1})' translated format: {self identityHash})
- "All external messages (those not caused by the re-send) get trapped here"
- Processor activeProcess
- debugWithTitle: 'Object Tracer (', self identityHash, ')'
  full: false
  contents: ('On an instance of\ {1} ({2})\\About to perform\ {3}\\Using the following arguments\ {4}' translated withCRs
  format: {
  thisContext objectClass: tracedObject.
  tracedObject identityHash.
  aMessage selector storeString.
  aMessage arguments printString}).
+
-
  ^ aMessage sendTo: tracedObject!

Item was changed:
  ----- Method: Process>>evaluate:onBehalfOf: (in category 'private') -----
  evaluate: aBlock onBehalfOf: aProcess
+ "Evaluate aBlock setting effectiveProcess to aProcess. Used in the execution simulation machinery to ensure that Processor activeProcess evaluates correctly when debugging, which is also known as process-faithful debugging."
+
+ | oldEffectiveProcess |
+ aProcess == self ifTrue: [^ aBlock value]. "Optimization"
+
+ oldEffectiveProcess := effectiveProcess.
- "Evaluate aBlock setting effectiveProcess to aProcess, and all other variables other than
- the scheduling ones to those of aProcess.  Used in the execution simulation machinery
- to ensure that Processor activeProcess evaluates correctly when debugging."
- | range savedVariables |
- "range accesses everything after myList, e.g. threadId, effectiveProcess, name, island, env"
- range := 5 to: Process instSize.
- savedVariables := range collect: [:i| self instVarAt: i].
- range do:
- [:i| self instVarAt: i put: (aProcess instVarAt: i)].
  effectiveProcess := aProcess.
+ ^ aBlock ensure: [effectiveProcess := oldEffectiveProcess]!
- ^aBlock ensure:
- ["write back any assigned-to variables."
- range do:
- [:i| | v |
- ((v := self instVarAt: i) ~~ (aProcess instVarAt: i)
- and: [v notNil]) ifTrue:
- [aProcess instVarAt: i put: v]].
- "restore old values"
- range with: savedVariables do:
- [:i :var| self instVarAt: i put: var]]!

Item was changed:
  ----- Method: Process>>terminate (in category 'changing process state') -----
  terminate
  "Stop the process that the receiver represents forever.
  Unwind to execute pending ensure:/ifCurtailed: blocks before terminating.
  If the process is in the middle of a critical: critical section, release it properly."
 
  | ctxt unwindBlock oldList |
  self isActiveProcess ifTrue:
  [ctxt := thisContext.
  [ctxt := ctxt findNextUnwindContextUpTo: nil.
   ctxt ~~ nil] whileTrue:
  [(ctxt tempAt: 2) ifNil:
  ["N.B. Unlike Context>>unwindTo: we do not set complete (tempAt: 2) to true."
  unwindBlock := ctxt tempAt: 1.
  thisContext terminateTo: ctxt.
  unwindBlock value]].
  thisContext terminateTo: nil.
  self suspend.
  "If the process is resumed this will provoke a cannotReturn: error.
  Would self debug: thisContext title: 'Resuming a terminated process' be better?"
  ^self].
 
  "Always suspend the process first so it doesn't accidentally get woken up.
  N.B. If oldList is a LinkedList then the process is runnable. If it is a Semaphore/Mutex et al
  then the process is blocked, and if it is nil then the process is already suspended."
  oldList := self suspend.
  suspendedContext ifNotNil:
  ["Release any method marked with the <criticalSection> pragma.
   The argument is whether the process is runnable."
  self releaseCriticalSection: (oldList isNil or: [oldList class == LinkedList]).
 
  "If terminating a process halfways through an unwind, try to complete that unwind block first."
  (suspendedContext findNextUnwindContextUpTo: nil) ifNotNil:
  [:outer|
  (suspendedContext findContextSuchThat:[:c| c closure == (outer tempAt: 1)]) ifNotNil:
  [:inner| "This is an unwind block currently under evaluation"
  suspendedContext runUntilErrorOrReturnFrom: inner]].
 
  ctxt := self popTo: suspendedContext bottomContext.
  ctxt == suspendedContext bottomContext ifFalse:
+ [self debugWithTitle: 'Unwind error during termination' translated full: false].
- [self debug: ctxt title: 'Unwind error during termination'].
  "Set the context to its endPC for the benefit of isTerminated."
  ctxt pc: ctxt endPC]!

Item was changed:
  Object subclass: #ProcessorScheduler
+ instanceVariableNames: 'quiescentProcessLists genuineProcess'
- instanceVariableNames: 'quiescentProcessLists activeProcess'
  classVariableNames: 'BackgroundProcess HighIOPriority LowIOPriority SystemBackgroundPriority SystemRockBottomPriority TimingPriority UserBackgroundPriority UserInterruptPriority UserSchedulingPriority'
  poolDictionaries: ''
  category: 'Kernel-Processes'!
 
  !ProcessorScheduler commentStamp: '<historical>' prior: 0!
  My single instance, named Processor, coordinates the use of the physical processor by all Processes requiring service.!

Item was changed:
  ----- Method: ProcessorScheduler>>activePriority (in category 'accessing') -----
  activePriority
  "Answer the priority level of the currently running Process."
 
+ ^ self activeProcess priority!
- ^activeProcess effectiveProcess priority!

Item was changed:
  ----- Method: ProcessorScheduler>>activeProcess (in category 'accessing') -----
  activeProcess
+ "Answer the active process (from the user's perspective), which can be simulated by the genuinely running process (from the system's perspective). See Process >> #evaluate:onBehalfOf:."
- "Answer the currently running Process."
 
+ ^genuineProcess effectiveProcess!
- ^activeProcess effectiveProcess!

Item was changed:
  ----- Method: ProcessorScheduler>>terminateActive (in category 'process state change') -----
  terminateActive
  "Terminate the process that is currently running."
 
+ self activeProcess terminate.!
- activeProcess effectiveProcess terminate!