!=========================================================================
! Copyright (C) VMware, Inc. 1986-2011.  All Rights Reserved.
!
! $Id: gsprocess.gs,v 1.20 2008-01-25 22:05:09 bretlb Exp $
!
! Superclass Hierarchy:
!   GsProcess, Object.
!
!=========================================================================

removeallmethods GsProcess
removeallclassmethods GsProcess

!  Globals at: #Semaphore put: nil    now done in bom.c
!  Globals at: #ProcessorScheduler put: nil    now done in bom.c

! ------------------- Class methods for GsProcess

category: 'For Documentation Installation only'
classmethod: GsProcess
installDocumentation

| doc txt |
doc := GsClassDocumentation newForClass: self.

txt := (GsDocText new) details:
'A GsProcess represents a suspended GemStone Smalltalk call stack, including
 information needed to restart execution.' .
doc documentClassWith: txt.

txt := (GsDocText new) details:
'A positive SmallInteger, the number of active methods on the stack of the
 GsProcess.' .
doc documentInstVar: #stackDepth with: txt.

txt := (GsDocText new) details:
'A GsStackBuffer, the saved control stack.' .
doc documentInstVar: #controlStack with: txt.

txt := (GsDocText new) details:
'A GsStackBuffer, the saved evaluation stack.' .
doc documentInstVar: #arStack with: txt.

txt := (GsDocText new) details:
'A SmallInteger, for GemStone internal use.' .
doc documentInstVar: #inUserActionCount with: txt.

txt := (GsDocText new) details:
'A SmallInteger, for GemStone internal use.' .
doc documentInstVar: #interruptFlag with: txt.

txt := (GsDocText new) details:
'A String, for GemStone internal use.' .
doc documentInstVar: #fltStatus with: txt.

txt := (GsDocText new) details:
'A SmallInteger, for GemStone internal use.' .
doc documentInstVar: #recursionsToStCount with: txt.

txt := (GsDocText new) details:
'A SmallInteger, for GemStone internal use.' .
doc documentInstVar: #protectedMode with: txt.

txt := (GsDocText new) details:
'A Boolean, true if asynchronous events are disabled, false if they are
 enabled.' .
doc documentInstVar: #asyncEventsDisabled with: txt.

txt := (GsDocText new) details:
'For GemStone internal use. 
   _debugMode == 1 means this instance of GsProcess is a Continuation.
   _debugMode == true means  debugging or single stepping is in progress ;
	breakpoints or single step exceptions are handled by the debugger
        and will not be seen by any user-installed Exception handlers.
   _debugMode == false means  debugging or single stepping is completed.
   _debugMode == nil  equivalent to  _debugMode == false .
  Also note that GBJ  uses ( tagAt:1 put: true) to cause any single steps
  or breakpoints hit by a GsProcess to be ignored by the virtual machine.
'.
doc documentInstVar: #_debugMode with: txt.

txt := (GsDocText new) details:'For use by the Process Scheduler only.' .
doc documentInstVar: #signalTime with: txt .

txt := (GsDocText new) details:
'A Boolean, for use by the Process Scheduler.
 isTerminated == true means the process has been terminated.' .
doc documentInstVar: #isTerminated with: txt .

txt := (GsDocText new) details:
'An Integer representing a process group, for use by the Process Scheduler.' .
doc documentInstVar: #group with: txt .

txt := (GsDocText new) details:
'A SmallInteger for use by the Process Scheduler.' .
doc documentInstVar: #priority with: txt .

txt := (GsDocText new) details:
'A BlockClosure or nil, for use by the Process Scheduler implementation.
A block that the GsProcess is to execute.' .
doc documentInstVar: #block with: txt .

txt := (GsDocText new) details:
'An Array of arguments for this GsProcess''s  block, if any.' .
doc documentInstVar: #args with: txt .

txt := (GsDocText new) details:
'No longer used. ' .
doc documentInstVar: #_lastGciProcess with: txt.

self description: doc.
%

category: 'Instance Creation'
classmethod: GsProcess
new

"Disallowed."

self shouldNotImplement: #new
%

! edited to fix 36121
category: 'Debugging Support'
classmethod: GsProcess
_reportWithFrameContents: frameContents

"Return a one line String describing the argument. 
 Example result:  'SmallInteger (Object) | doesNotUnderstand:'."

| gsMethod mclass receiver aself result |

gsMethod := self _methodInFrameContents: frameContents .
receiver := self _receiverInFrameContents: frameContents .

aself := self _selfInFrameContents: frameContents .

gsMethod == nil ifTrue:[ ^ 'User Action' ].

mclass := gsMethod inClass.
result := String new .

"check for being in a block inside a method"
((receiver isKindOf: BlockClosure) _and: [receiver ~~ aself]) ifTrue: [
  result addAll: '[] in ' .
  mclass == nil ifTrue:[ 
    result addAll: 'Executed Code' 
  ] ifFalse:[
    result addAll: mclass name ; addAll: ' | '; addAll: gsMethod _selector.
  ] 
] ifFalse:[
  mclass == nil ifTrue:[ 
    result addAll: 'Executed Code' 
  ] ifFalse:[ | selfCls |
    selfCls := aself class .
    result addAll: selfCls name .
    selfCls ~~ mclass ifTrue: [ 
        result addAll: ' ('; addAll: mclass name; add: $) 
    ].
    result addAll: ' | '; addAll: ( gsMethod _selector ) .
  ].
].
^ result
%

category: 'Debugging Support'
classmethod: GsProcess
_gsiDetailedReportWithFrameContents: frameContents forLevel: aLevel

"Private."
"See _gsiDetailedReportWithFrameContents: for documentation."

| result receiver gsMethod argAndTempNames argAndTempValues aself |

result := Array new: 11 .

result
  at: 1 put: (gsMethod := frameContents at: 1  "virtual machine constant") ; "gsMethod"
  at: 2 put: (receiver := frameContents at: 10 "virtual machine constant" ); "receiver"
  at: 3 put: (aself := frameContents at: 8 "virtual machine constant" ); "self"
  at: 4 put: (gsMethod == nil
    ifTrue: [#'<UserAction>']
    ifFalse: [ gsMethod _selector]); "selector"
  at: 5 put: (gsMethod == nil
    ifTrue: [ 0 ]
    ifFalse: [ gsMethod
      _stepPointForIp: (frameContents at: 2 "virtual machine constant") abs
      level: aLevel
      quick: true ]) ;
  at: 6 put: (gsMethod == nil
    ifTrue: [ #() ]
    ifFalse: [ gsMethod _sourceOffsets ]). "source offsets"

argAndTempNames := frameContents at: 9 "virtual machine constant" .

argAndTempValues := (frameContents size >= 11 "virtual machine constant")
    ifTrue:[ frameContents copyFrom: 11 to: frameContents size]
    ifFalse:[ Array new ].

result  at: 7 put: argAndTempNames ;
        at: 8 put: argAndTempValues ;
        at: 9 put: (gsMethod == nil
          ifTrue: [ 'source not available' ] 
          ifFalse: [ gsMethod sourceString  ]);
        at: 10 put: (frameContents at: 2 "virtual machine constant") abs ;  "ipOffset"
        at: 11 put: (frameContents at: 6 "virtual machine constant"). "markerOrException"

^ result
%

category: 'Debugging Support'
classmethod: GsProcess
_methodInFrameContents: aFrameContentsArray

""

^ aFrameContentsArray at: 1 "virtual machine constant"
%

category: 'Debugging Support'
classmethod: GsProcess
_receiverInFrameContents: aFrameContentsArray

""

^ aFrameContentsArray at: 10 "virtual machine constant"
%

category: 'Debugging Support'
classmethod: GsProcess
_selfInFrameContents: aFrameContentsArray

""

^ aFrameContentsArray at: 8 "virtual machine constant"
%

category: 'Private Debugging Support'
classmethod: GsProcess
_basicFrameContentsAt: aLevel

"Returns an Array describing part of the specified stack level in the 
 currently executing process.  

   aLevel == 1 means top of stack with respect to the 
                 sender of _frameContentsAt:  .
   If aLevel is < 1 or > depth of the stack,  nil is returned.

 For use only in the implementation of GsProcess (C) | _frameContentsAt:."

<primitive: 195>
self _primitiveFailed: #_basicFrameContentsAt: .
%

category: 'Debugging Support'
classmethod: GsProcess
stackReportToLevel: aLevel

"Returns a String describing the currently active stack, starting with
 to the sender of this method (which is considered level 1).  The aLevel
 argument  specifies the depth to which to report the stack. 

 The format of the result is subject to change with each release of GemStone."

| framesArr aFrame report lf gsMethod level receiver |
framesArr := Array new .
level := 1 .
[ level <= aLevel _and:[ (aFrame := self _frameContentsAt: level + 1) ~~ nil] ]
whileTrue:[
  framesArr at: level put: aFrame.
  level := level + 1.
  ].
report := String new .
lf := Character lf .
1 to: framesArr size do:[:j |
  report addAll: j asString; addAll:' ' .
  aFrame := framesArr at: j .
  gsMethod := aFrame at: 1 .
  gsMethod == nil ifTrue:[
    report addAll:'<Reenter marker>'; add: lf .
    ]
  ifFalse:[ | stepPoint |
    receiver := aFrame at: 10 .
    (receiver isKindOf: BlockClosure) ifTrue:[
       report addAll: receiver class name ; addAll:' in '
       ].
    gsMethod inClass == nil ifTrue:[
      report addAll:'Executed Code ' .
      ]
    ifFalse:[
      report addAll: gsMethod inClass name ; addAll:' >> ';
             addAll: gsMethod selector .
      ].
    stepPoint := gsMethod _previousStepPointForIp: (aFrame at: 2) quick: false .
    report addAll:' @' ; addAll: stepPoint asString ;
      addAll: ' line ';
      addAll: (gsMethod _lineNumberForStep: stepPoint) asString ;
      addAll:'  [GsMethod OOP '; addAll: gsMethod asOop asString ; addAll:']'; 
      add: lf .
    ].
  ].
^ report
%

category: 'Debugging Support'
classmethod: GsProcess
_frameContentsAt: aLevel

"Returns an Array describing the specified stack level in the currently
 executing process.  

 aLevel == 1 means top of stack with respect to the 
               sender of _frameContentsAt: .

 If aLevel is out of range, returns nil.

 The contents of the result Array are the same as for the instance method
 GsProcess | _frameContentsAt:, except for :
    element 10 (argAndTempNames) is nil
             8 (self) is nil
             4  varContext is always nil .
             
 "

| result |
result := self _basicFrameContentsAt: aLevel + 1.
result == nil ifTrue:[ ^ result ].

self _finishFrameContents: result forLevel: aLevel .
^ result
% 

category: 'Debugging Support'
classmethod: GsProcess
_selfAt: aLevel

"Returns self at the given level of the currently executing process' stack.

 aLevel == 1 means top of stack with respect to the 
               sender of _selfAt: .

 If aLevel is out of range, returns nil."
 
|frame|
(frame := self _frameContentsAt: aLevel + 1) == nil ifTrue:[ ^ nil ].
^ frame at: 8 "virtual machine constant"
%

category: 'Debugging Support'
classmethod: GsProcess
_receiverAt: aLevel

"Returns the receiver at the given level of the currently executing 
 process' stack.

 aLevel == 1 means top of stack with respect to the
               sender of _selfAt: .

 If aLevel is out of range, returns nil."

|frame|
(frame := self _frameContentsAt: aLevel) == nil ifTrue:[ ^ nil ].
^ frame at: 10 "virtual machine constant"
%

category: 'Private'
classmethod: GsProcess
_finishFrameContents: frameContents forLevel: aLevel

""

| theSelf receiver argAndTempNames numArgsTemps gsMethod |

gsMethod := frameContents at: 1 "virtual machine constant".
gsMethod == nil ifTrue:[ ^ self "nothing to do for a reenter marker" ]. 

receiver := frameContents at: 10 "virtual machine constant".

"fill in self. A ComplexBlock that does not contain an instruction referencing
 self will have nil for self."
(receiver isKindOf: ExecutableBlock) ifTrue:[
  (receiver isKindOf: ComplexBlock) 
    ifTrue:[ theSelf := receiver selfValue ]
    ifFalse:[ theSelf := nil "self in SimpleBlock"].
  ]
  ifFalse:[ theSelf := receiver ] .
frameContents at: 8 "virtual machine constant" put: theSelf. 

argAndTempNames := ((receiver == theSelf) 
    ifTrue:[ (frameContents at: 1 "virtual machine constant") "gsMethod" ] 
    ifFalse:[ receiver "aBlock"]) argsAndTemps  .
argAndTempNames == nil ifTrue:[ argAndTempNames := #( ) ] .

numArgsTemps := frameContents size - 10 .
numArgsTemps > argAndTempNames size ifTrue:[ | k |
  argAndTempNames isInvariant ifTrue:[ argAndTempNames := argAndTempNames copy].
  k := 1 .
  argAndTempNames size + 1 to: numArgsTemps do:[:j |
    argAndTempNames at: j put: '_temp' , k asString .
    k := k + 1 . 
    ].
  aLevel == 1 ifTrue:[
    argAndTempNames at: argAndTempNames size put: '_topOfStack' .
    ].
  ].

(receiver isKindOf: ComplexBlock) ifTrue: [
  | sl |
  argAndTempNames isInvariant ifTrue:[
    argAndTempNames := argAndTempNames copy.
  ].
  sl := receiver staticLink.
  [sl == nil] whileFalse: [
    | slNext cb aAndT |
    (sl size >= 1) ifTrue: [
      cb := sl at: 1.
      (cb isKindOf: ComplexBlock) ifTrue: [
	slNext := cb staticLink.
      ] ifFalse: [
	cb := gsMethod.
	slNext := nil.
      ].
    ] ifFalse: [
      cb := gsMethod.
      slNext := nil.
    ].
    aAndT := cb argsAndTemps.
    (aAndT ~~ nil) ifTrue: [
      | upperLimit |
      upperLimit := aAndT size.
      ((sl size - 1) < upperLimit) ifTrue: [
        upperLimit := (sl size - 1).
      ].
      aAndT from: 1 to: upperLimit doWithIndex: [:e :i |
        (argAndTempNames includesValue: e) ifFalse: [
          argAndTempNames addLast: e.
          frameContents addLast: (sl at: (i+1)).
        ].
      ].
    ].
    sl := slNext.
  ].
  (argAndTempNames size == 0) ifTrue: [
    argAndTempNames := #( ).
  ].
].

frameContents at:9 "virtual machine constant" put: argAndTempNames .

%

! removed GsProcess(C) >> _current  to fix 31305 .
!  It was referencing primitive 492 which is used for a different
!  primitive in ProcessorScheduler .

category: 'Private'
method: GsProcess
_init: aPriority block: aBlock args: aArgs

priority := aPriority.
block := aBlock.
args := aArgs.
(args size ~~ block numberArgs) ifTrue: [
  "Generate an error because we don't have the correct number of args."
  System signal: (ErrorSymbols at: #rtErrBadGsProcessArgCount)
	       args: #[ block, block numberArgs, args size ]
               signalDictionary: GemStoneError.
  block valueWithArguments: args.
].
self _joinGroup: (ProcessorScheduler scheduler activeProcess _group).
^self suspend.
%

category: 'Private'
method: GsProcess
_newinit

args := nil.
priority := ProcessorScheduler scheduler activePriority.
self _newGroup.
^self
%

category: 'Instance Creation'
classmethod: GsProcess
_new
  "create a new process to represent the current GCI active thread."

  ^(super new) _newinit.
%
category: 'Instance Creation'
classmethod: GsProcess
_forBlock: aBlock
  "Answer an instance of the receiver representing a potential
   process on the given block and with normal priority."

  ^(super new) _init: ProcessorScheduler scheduler activePriority
               block: aBlock args: #().
%
! fixed 34080/14756
category: 'Instance Creation'
classmethod: GsProcess
_forBlock: aBlock with: blockArgs
  "Answer an instance of the receiver representing a potential
   process on the given block and with the active priority."

  (blockArgs isKindOf: Array ) ifFalse:[
    blockArgs _error: #rtErrInvalidArgClass args: #[ Array ] .
    self _uncontinuableError .
  ].
  ^(super new) _init: ProcessorScheduler scheduler activePriority
               block: aBlock args: blockArgs.
%

category: 'Instance Creation'
classmethod: GsProcess
continuationFromLevel: numLevels

"Returns an instance of the receiver, that is a copy of the current
 process'  stack , from the stack base to the frame that is the
 specified number of levels above the frame executing this primitive.
 anInt must be >= 1 .

 When  value:   is sent to the result,
 execution resumes in the frame at the top of the instance's saved stack,
 and with top-of-stack value replaced by the argument to value: .

 The result contains copies of all method temps and args from the
 stack it was created from ;  value: sent to the result restores 
 the contents of of all method temps and args to the identical values when
 the instance was created.

 The result has _debugMode set to 1 , to prevent it being used as
 an ordinary instance in process scheduling methods.
"  
<primitive: 47>
numLevels _validateClass: SmallInteger .
numLevels < 1 ifTrue:[ self _errorIndexOutOfRange: numLevels ].
self _primitiveFailed: #continuationFromLevel: .
self _uncontinuableError
%


! ------------------- Instance methods for GsProcess
category: 'Private'
method: GsProcess
_basicControlStackEntrySize

""

<primitive: 313>
self _primitiveFailed: #_controlStackEntrySize .
%

category: 'Virtual Machine Constants'
method: GsProcess
_controlStackEntrySize

""

| result |
(result := self _basicControlStackEntrySize) == 6 ifFalse:[ 
  "Image needs fixes to go with changes in virtual machine.
   Search methods in this class for 'virtual machine constant'"
  self _halt: 'Inconsistent size of control stack entry'
  ].
^ result
%

category: 'Virtual Machine Constants'
method: GsProcess
_ctlStackCodeOffset

""

^ 1
% 

category: 'Accessing'
method: GsProcess
_cannotReturn: aValue

"Raises an error message in the event that the virtual machine cannot 
 resume after the current method or block context."

^ self _error: #rtErrCantReturn
%

category: 'Accessing'
method: GsProcess
stackDepth

"Returns the value of the stackDepth instance variable."

self remoteProcess ~~ nil
  ifTrue: [ ^ remoteProcess stackDepth + stackDepth ].

^ stackDepth
%

category: 'Accessing'
method: GsProcess
methodAt: aLevel

"Returns the GsMethod that is active at aLevel in the receiver, where
 aLevel == 1 is the top of the stack.  Generates an error if aLevel less than
 zero or greater than stackDepth.  Returns nil if there is a reenter marker at
 the specified level."

self remoteProcess ~~ nil
  ifTrue: [
    ^ aLevel > remoteProcess stackDepth
      ifTrue: [
        self localMethodAt: (aLevel - remoteProcess stackDepth)
      ]
      ifFalse: [ remoteProcess methodAt: aLevel ]
  ].

^ self localMethodAt: aLevel
%

category: 'Accessing'
method: GsProcess
localMethodAt: aLevel

"Returns the GsMethod that is active at aLevel in the receiver, where
 aLevel == 1 is the top of the stack.  Generates an error if aLevel less than
 zero or greater than stackDepth.  Returns nil if there is a reenter marker at
 the specified level."

| offset |

(aLevel < 1 _or:[ aLevel > stackDepth ]) ifTrue:[
  aLevel _error: #rtErrArgOutOfRange .
  ].
offset := (stackDepth - aLevel) * self _controlStackEntrySize .
^ controlStack at:( offset + 1 "virtual machine constant" ) .
%

category: 'Accessing'
method: GsProcess
_frameOffsetAt: aLevel

"Private.  Returns the one-based frameOffset at aLevel in the receiver, where
 aLevel == 1 is top of stack.  Returns nil if aLevel is less than zero 
 or greater than stackDepth.  The result is a SmallInteger." 

"In self.arStack at the result is the receiver for aLevel"

self remoteProcess ~~ nil
  ifTrue: [
    ^ aLevel > remoteProcess stackDepth
      ifTrue: [
        self  _localFrameOffsetAt: (aLevel - remoteProcess stackDepth)
      ]
      ifFalse: [ remoteProcess _frameOffsetAt: aLevel ]
  ].

^ self _localFrameOffsetAt: aLevel
%

category: 'Accessing'
method: GsProcess
_localFrameOffsetAt: aLevel

"Private.  Returns the one-based frameOffset at aLevel in the receiver, where
 aLevel == 1 is top of stack.  Returns nil if aLevel is less than zero 
 or greater than stackDepth.  The result is a SmallInteger." 

"In self.arStack at the result is the receiver for aLevel"

| offset |
(aLevel < 1 _or:[ aLevel > stackDepth ]) ifTrue:[ ^ nil.  ].

offset := (stackDepth - aLevel) * self _controlStackEntrySize .
^ (controlStack at:( offset + 3 "virtual machine constant, zero based" )) + 1 .
%

category: 'Copying'
method: GsProcess
copy

"Disallowed."

self shouldNotImplement: #copy
%

category: 'Updating'
method: GsProcess
instVarAt: anIndex put: aValue

"Disallowed."

self shouldNotImplement: #instVarAt:put:
%

category: 'Debugging Support'
method: GsProcess
_reportOfSize: aSize

"Returns an Array describing the receiver up to aSize entries in length.  Each
 element in the result is a String produced by GsProcess | _reportAt:."

| result depth |
result := Array new .
depth := self stackDepth.
(depth ~~ nil) ifTrue: [
  1 to: (depth min: aSize) do:[:j |
    result addLast: (self _reportAt: j)
    ].
].
^ result
%

category: 'Debugging Support'
method: GsProcess
_reportAt: aLevel

"Return a one line String describing the specified level in the receiver.
 aLevel == 1 means top of stack with respect

 If aLevel is out of range,  nil is returned. "

| frameContents result |

(frameContents := self _frameContentsAt: aLevel) == nil ifTrue:[ ^ nil ].
result := String new .
result addAll: (  self class _reportWithFrameContents: frameContents ) .
result add: $  .
result addAll: (self _localStepPointStringAt: aLevel) .
^ result
%

category: 'Debugging Support'
method: GsProcess
_trimStackToLevel: aLevel

self remoteProcess ~~ nil
  ifTrue: [
    ^ aLevel > remoteProcess stackDepth
      ifTrue: [
        self  _trimStackToLevel: (aLevel - remoteProcess stackDepth)
      ]
      ifFalse: [ remoteProcess _trimStackToLevel: aLevel ]
  ].

^ self _localTrimStackToLevel: aLevel
%

category: 'Debugging Support'
method: GsProcess
_localTrimStackToLevel: aLevel

"Deletes stack entries from 1 to (aLevel - 1) inclusive, thus making aLevel the
 new top-of-stack(TOS).  At new TOS, looks in the implementation class of the
 method at TOS, using the selector of the method at TOS.  If that class's method
 dictionary contains a different GsMethod, the GsMethod currently in the method
 dictionary is installed as the method at the TOS.  The saved instruction
 pointer for TOS is set to the entry of the method at TOS.

 Limitations:

   If the new top-of-stack is an anonymous method, it is not possible to
   determine whether that method has been recompiled, and the method at new top
   of stack will not be changed.  Debuggers should use the
   GsMethod | _recompileWithSource method to implement recompilation from a
   debugger pane.  _recompileWithSource: raises an error on attempts to
   recompile an anonymous method.

   Raises an error if the new top-of-stack would represent the entry to an
   ExecutableBlock.  You may only trim a stack to a level representing the start
   of a GsMethod.

 Has no effect if aLevel is out of range."

"If the new TOS had a VariableContext, the VariableContext will be dereferenced
 and the receiver and arguments moved back into the activation stack,
 so that the VariableContext can be recreated when the method restarts.
 Debuggers must not cache or directly manipulate VariableContexts 
 when examining or altering stacks.

 Provides the ability for a debugger to restart execution after recompiling
 a method that is active on the stack of the receiver."

  | oldMethod newTosFrame newTosRcvr newTosOldVC newArSize oldStackDepth 
    mClass newMethod tosBase |

  "check for argument aLevel out of range"
  (aLevel < 1 _or:[ aLevel > stackDepth ]) ifTrue:[ ^ self ].

  oldMethod := self methodAt: aLevel .
  newTosFrame := self _localFrameContentsAt: aLevel .
  newTosRcvr := newTosFrame at: 10 .
  (newTosRcvr isKindOf: ExecutableBlock) ifTrue:[
    ^ self _halt: 'Cannot trim stack to restart an ExecutableBlock.'
    ].
  newTosOldVC := newTosFrame at: 4 .

  "trim the stack"
  newArSize := newTosFrame at: 3"frameOffset" .
  newTosOldVC == nil ifTrue:[ 
    newArSize := newArSize + 1 + oldMethod numArgs .
    ].
  oldStackDepth := stackDepth . "for debugging"
  stackDepth := stackDepth - (aLevel - 1) .
  controlStack size:  stackDepth * self _controlStackEntrySize .
  arStack size: newArSize .

  "check to see whether new TOS method has been recompiled, and if so, 
   install the new method."

  mClass := oldMethod inClass .
  mClass ~~ nil ifTrue:[ "not an anonymous method"
    newMethod := mClass compiledMethodAt: oldMethod selector .
    tosBase := (stackDepth - 1) * self _controlStackEntrySize .

    "set ipOffset to start of the method that will be the new TOS"
    controlStack at: tosBase + 2 "virtual machine constant" 
		  put: GsMethod instSize "new ipOffset" .
    newMethod ~~ oldMethod ifTrue:[
      "method has been recompiled, so install the new one"
      controlStack at: tosBase + 1 "virtual machine constant" put: newMethod ."new GsMethod"
      ].
    newTosOldVC ~~ nil ifTrue:[
      "Transfer receiver and arguments from VariableContext back onto stack,
       so VariableContext can be regenerated when method restarts."

      1 to: newMethod numArgs + 1"receiver" do:[:j |
	arStack addLast: (newTosOldVC at: j ).
	].
      controlStack at: tosBase + 4 "virtual machine constant" 
		  put: nil  . 		"clear the variable context" 
      ].
    controlStack at: tosBase + 6 "virtual machine constant"
                  put: nil .		"clear any activation Exception."
    ].
%

! fixed 32225
category: 'Debugging Support'
method: GsProcess
_gsiStackReportFromLevel: startLevel toLevel: stopLevel

"Returns an Array describing the receiver.  For each stack level in the
 receiver, the result contains 2 elements,  a String describing that
 level, and an Array containing the result of the _gsiDebuggerDetailedReportAt:
 method for that level.

 Level 1 is the top of the stack.  If startLevel is out of range, or if
 stopLevel is less than startLevel, returns nil.  If stopLevel is beyond the end
 of the stack, returns information up to the end of the stack."

|result actualStop myCls frameContents |

stopLevel < startLevel ifTrue:[ ^ nil ].
startLevel > self stackDepth ifTrue:[ ^ nil ].

actualStop := (stopLevel > self stackDepth) 
  ifTrue: [ self stackDepth ] 
  ifFalse: [ stopLevel ].

result := Array new.
myCls := self _class .
startLevel to: actualStop do:[:j| 
  frameContents := self _frameContentsAt: j .
  frameContents == nil ifTrue:[ result addLast: nil; addLast:nil ]
    ifFalse:[ | frameStr |
      frameStr := String new .
      frameStr addAll: (myCls _reportWithFrameContents: frameContents) .
      frameStr add: $  .
      frameStr addAll: (self _localStepPointStringAt: j) .
      result addLast: frameStr ;
             addLast:(myCls _gsiDetailedReportWithFrameContents: frameContents
			    forLevel: j ) .
      ].
  ].
^ result
%

category: 'Debugging Support'
method: GsProcess
_gsiDebuggerDetailedReportAt: aLevel

"If aLevel is less than 1 or greater than stackDepth of the receiver, 
 returns nil.  Otherwise, returns an Array containing:

 offset item
 ------ ----
   1    gsMethod  (a GsMethod)
   2    receiver
   3    self
   4    selector  (a Symbol)
   5    quickStepPoint (SmallInteger index into sourceOffsets, or nil)
   6    sourceOffsets  (Array of SmallIntegers)
   7    argAndTempNames  (Array of Symbols)
   8    argAndTempValues (Array) (may be smaller than argAndTempNames if
	 execution halted at entry to a method, may be larger than
         argAndTempNames if compiler has allocated additional
	 unnamed stack temporaries. For aLevel == 1, Last element is TOS )
   9    sourceString
  10    ipOffset   (SmallInteger)
  11    markerOrException  (SmallInteger in a reenter marker, 
		     or an Exception, or nil )

 The quickStepPoint is the step point in the method, if the method has 
 50 or less step points.  Otherwise, the quickStepPoint will be nil
 and the expression

 gsMethod _stepPointForIp: ipOffset level: aLevel quick: false

 may be used to obtain search for and obtain the step point."
| frameContents |

(frameContents := self _frameContentsAt: aLevel) == nil ifTrue:[ ^ nil ].
^ self class _gsiDetailedReportWithFrameContents: frameContents
             forLevel: aLevel
%

category: 'Debugging Support'
method: GsProcess
_reportString

"Returns a String with each Activation object in the receiver, up to 2000
 levels, described on separate lines."

| s |

s := String new.
s add: self class name.
s add: '(oop=' ; add: self asOop printString ; add: ', ' .

s add: 'status=' ; add: (self _statusString) ; add: ', '.

(clientData ~~ nil) ifTrue: [
  s add: 'clientData=' ; add: (clientData printString) ; add: ', '.
].

(priority ~~ nil) ifTrue: [
  s add: 'priority=' ; add: (priority printString) ; add: ', '.
].

(group ~~ nil) ifTrue: [
  s add: 'group=' ; add: (group printString) ; add: ', '.
].

(block ~~ nil) ifTrue: [
  s add: 'block=' ; add: (block printString) ; add: ', '.
  s add: 'args=' ; add: (args printString) ; add: ', '.
].
s add: Character lf .

(self _reportOfSize: 2000) inject: s into: [:str:rpt |
  str addAll: rpt; add: Character lf ; yourself
].

s add: ')'.
^s
%

category: 'Formatting'
method: GsProcess
printString

"Returns a String whose contents are a displayable representation of the
 receiver."

^ self _reportString
%

category: 'Formatting'
method: GsProcess
printOn: aStream

"Puts a displayable representation of the receiver on the given stream."

aStream nextPutAll: self _reportString
%

category: 'Debugging Support'
method: GsProcess
_frameContentsAt: aLevel

"Private.  Returns an Array describing the specified level in the receiver. 
 aLevel == 1 is top of stack.  If aLevel is less than 1 or greater than
 stackDepth, returns nil.  

 The result Array contains:
 offset item
 -----  -----
   1	gsMethod  (a GsMethod)
   2	ipOffset    (zero-based relative to first named instance variable;
                     negative means a stack breakpoint is present)
   3	frameOffset (zero-based)
   4	varContext
   5    saveProtectedMode
   6    markerOrException
   7    nil    (not used)
   8    self   (possibly nil in a ComplexBlock)
   9    argAndTempNames   (an Array of Symbols or Strings)
  10    receiver
  11    arguments and temps, if any"
 
"Notes to GemStone implementors:

 If result of this method is changed, you must change tpaux.c in the 
 topaz C sources, other methods in this class, and the code for primitive 195.

 Note that if execution stops at a breakpoint at the entry to a method,
 the method temporaries may not be allocated yet and so some or all of
 the method temporaries may be missing from the result."

self remoteProcess ~~ nil
  ifTrue: [
    ^ aLevel > remoteProcess stackDepth
      ifTrue: [
        self _localFrameContentsAt: (aLevel - remoteProcess stackDepth)
      ]
      ifFalse: [ remoteProcess _frameContentsAt: aLevel ]
  ].

^ self _localFrameContentsAt: aLevel
%

category: 'Debugging Support'
method: GsProcess
_localFrameContentsAt: aLevel

"Private.  Returns an Array describing the specified level in the receiver. 
 aLevel == 1 is top of stack.  If aLevel is less than 1 or greater than
 stackDepth, returns nil.  

 The result Array contains:
 offset item
 -----  -----
   1	gsMethod  (a GsMethod)
   2	ipOffset    (zero-based relative to first named instance variable;
                     negative means a stack breakpoint is present)
   3	frameOffset (zero-based)
   4	varContext
   5    saveProtectedMode
   6    markerOrException
   7    nil    (not used)
   8    self   (possibly nil in a ComplexBlock)
   9    argAndTempNames   (an Array of Symbols or Strings)
  10    receiver
  11... arguments and temp values, if any"
 
"Notes to GemStone implementors:

 If result of this method is changed, you must change tpaux.c in the 
 topaz C sources, other methods in this class, and the code for primitive 195.

 Note that if execution stops at a breakpoint at the entry to a method,
 the method temporaries may not be allocated yet and so some or all of
 the method temporaries may be missing from the result."

| result ctlEntrySize ctlOffset frameOffset nextFrameOffset 
  frameSize varContext |

(aLevel < 1 _or:[ aLevel > stackDepth ]) ifTrue:[
  ^ nil .
  ].
ctlEntrySize := self _controlStackEntrySize .
ctlOffset := ((stackDepth - aLevel) * ctlEntrySize) + 1"make it one-based" .
result := Array new: 9 "virtual machine constant" .
controlStack copyFrom: ctlOffset to: (ctlOffset + ctlEntrySize - 1)
             into: result startingAt: 1 .

" copy the AR stack frame containing receiver, args and temps"

varContext := result at:4 "virtual machine constant".
varContext == nil ifTrue:[
  "args and temps on ARstack"
  frameOffset := (result at: 3 "virtual machine constant") + 1"convert to 1-based" .
  aLevel == 1 ifTrue:[ "TOS" nextFrameOffset := arStack size + 1]
       ifFalse:[ "not TOS" nextFrameOffset := self _localFrameOffsetAt: aLevel - 1 ].
  frameSize := nextFrameOffset - frameOffset .
  frameSize >= 1 ifTrue:[
      result size: result size + frameSize .
      arStack copyFrom: frameOffset to: nextFrameOffset - 1
          into: result startingAt: 10 "virtual machine constant" .
      ]
    ifFalse:[ 
      result at: 10   "virtual machine constant"
             put: nil "receiver unknown, or reenter marker"
      ].
  ]
ifFalse:[
  "args and temps in VariableContext"
  frameSize := varContext size .
  1 to: frameSize do:[:j| result addLast: (varContext at: j) ].
  ].

GsProcess _finishFrameContents: result forLevel: aLevel . 

^ result
%

category: 'Debugging Support'
method: GsProcess
_frameAt: aLevel offsetOfTempNamed: aString

"For the method activation at level aLevel, returns a SmallInteger which
 is the 1-based offset of the method argument or temporary with name aString.  
 Returns 0 if no temp exists at aLevel with name aString. 
 
 Generates an error if aLevel is out of range."

self remoteProcess ~~ nil
  ifTrue: [
    ^ aLevel > remoteProcess stackDepth
      ifTrue: [
        self _localFrameAt: (aLevel - remoteProcess stackDepth)
          offsetOfTempNamed: aString
      ]
      ifFalse: [ remoteProcess _frameAt: aLevel offsetOfTempNamed: aString ]
  ].

^ self _localFrameAt: aLevel offsetOfTempNamed: aString
%

category: 'Debugging Support'
method: GsProcess
_localFrameAt: aLevel offsetOfTempNamed: aString

"For the method activation at level aLevel, returns a SmallInteger which
 is the 1-based offset of the method argument or temporary with name aString.  
 Returns 0 if no temp exists at aLevel with name aString. 
 
 Generates an error if aLevel is out of range."

| frameContents aSym tempNames |

(aLevel < 1 _or:[ aLevel > stackDepth ]) ifTrue:[
  aLevel _error: #rtErrArgOutOfRange .
  ].

aSym := Symbol _existingWithAll: aString .
aSym == nil ifTrue:[ ^ 0 ].
frameContents := self _localFrameContentsAt: aLevel .
tempNames := frameContents at: 9 "virtual machine constant" .
^ tempNames indexOf: aSym
%

category: 'Debugging Support'
method: GsProcess
_frameAt: aLevel tempAt: tmpOffset put: aValue

"In the method activation at level aLevel, alter the method argument or
 temporary at anOffset to have value aValue.
 
 Generates an error if aLevel or anOffset is out of range."

self remoteProcess ~~ nil
  ifTrue: [
    ^ aLevel > remoteProcess stackDepth
      ifTrue: [
        self _localFrameAt: aLevel tempAt: tmpOffset put: aValue
      ]
      ifFalse: [ remoteProcess _frameAt: aLevel tempAt: tmpOffset put: aValue ].
  ].

^ self _localFrameAt: aLevel tempAt: tmpOffset put: aValue
%

category: 'Debugging Support'
method: GsProcess
_localFrameAt: aLevel tempAt: tmpOffset put: aValue

"In the method activation at level aLevel, alter the method argument or
 temporary at anOffset to have value aValue.
 
 Generates an error if aLevel or anOffset is out of range."

| frameContents receiver aself gsMethod frameOffset frameSize
  nextFrameOffset realOffset varContext |

(aLevel < 1 _or:[ aLevel > stackDepth ]) ifTrue:[
  aLevel _error: #rtErrArgOutOfRange .
  ].

frameContents := self _localFrameContentsAt: aLevel .
gsMethod := frameContents at: 1 "virtual machine constant" .
gsMethod == nil ifTrue:[ aLevel _error: #rtErrArgOutOfRange "reenter marker" ].
aself := frameContents at: 8 "virtual machine constant" .
receiver := frameContents at: 10 "virtual machine constant" .
frameSize := frameContents size - 10 "virtual machine constant" .

"range checks. tmpOffset == 0 would modify receiver, 
	       tmpOffset > frameSize would modify next frame"
(tmpOffset < 1 _or:[ tmpOffset > frameSize ]) ifTrue:[
  tmpOffset _error: #rtErrArgOutOfRange 
  ].

varContext := frameContents at: 4 "virtual machine constant".
varContext == nil ifTrue:[
  "modify AR Stack"
  frameOffset := (frameContents at: 3 "virtual machine constant") + 1"convert to 1-based".
  aLevel == 1 ifTrue:[ "TOS" nextFrameOffset := arStack size + 1]
       ifFalse:[ "not TOS" nextFrameOffset := self _localFrameOffsetAt: aLevel - 1 ].
  realOffset := frameOffset + tmpOffset .
  realOffset >= nextFrameOffset ifTrue:[
     tmpOffset _error: #rtErrArgOutOfRange
     ] .
  arStack at: realOffset put: aValue .
  ]
ifFalse:[
  "modify VariableContext"
  varContext _basicAt: (1 + tmpOffset) put: aValue.
  ].
%

category: 'Debugging Support'
method: GsProcess
_callUnwindBlocks

"Private.  Evaluate each of the unwind blocks (see ensure: and ifCurtailed:)."

| unwindBlocks |
unwindBlocks := Array new .
stackDepth ~~ nil ifTrue:
  [1 to: stackDepth do:
     [:j | self _addUnwindBlockAt: j to: unwindBlocks.]].
unwindBlocks do: [:each | each value].
%

category: 'Debugging Support'
method: GsProcess
_addUnwindBlockAt: aLevel to: anArray

| ctlEntrySize ctlOffset varContext |

ctlEntrySize := self _controlStackEntrySize .
ctlOffset := ((stackDepth - aLevel) * ctlEntrySize) + 1"make it one-based" .

varContext := controlStack at: (ctlOffset + 3) "virtual machine constant".
varContext ~~ nil ifTrue:
  [ (varContext isKindOf: VariableContext) ifTrue:
    [ | ub |
      ub := varContext.unwindBlock.
      ub ~~ nil ifTrue: [anArray addLast: ub]]]
%

category: 'Debugging Support'
method: GsProcess
_stepPointStringAt: aLevel

"Used by topaz debugger."

self remoteProcess ~~ nil
  ifTrue: [
    ^ aLevel > remoteProcess stackDepth
      ifTrue: [
        self _localStepPointStringAt: (aLevel - remoteProcess stackDepth)
      ]
      ifFalse: [ remoteProcess _stepPointStringAt: aLevel ]
  ].

^ self _localStepPointStringAt: aLevel
%


category: 'Debugging Support'
method: GsProcess
_stepPointAt: aLevel

"Used by topaz debugger,
 returns a stepPoint , or nil if no step point available "

self remoteProcess ~~ nil
  ifTrue: [
    ^ aLevel > remoteProcess stackDepth
      ifTrue: [
        self _localStepPointAt: (aLevel - remoteProcess stackDepth)
      ]
      ifFalse: [ remoteProcess _stepPointAt: aLevel ]
  ].

^ self _localStepPointAt: aLevel
%

category: 'Debugging Support'
method: GsProcess
_localStepPointStringAt: aLevel

"Used by topaz debugger."

| stepPoint offset gsMethod ipOffset result |
(aLevel < 1 _or:[ aLevel > stackDepth ]) ifTrue:[
  aLevel _error: #rtErrArgOutOfRange .
  ].
offset := (stackDepth - aLevel) * self _controlStackEntrySize .
gsMethod := controlStack at:( offset + 1 "virtual machine constant" ) .
gsMethod == nil ifTrue:[ ^  ''  ].

ipOffset := controlStack at:( offset + 2 "virtual machine constant") .

stepPoint := gsMethod _stepPointForIp: ipOffset level: aLevel quick: false .
stepPoint == nil ifTrue: [ ^  ''  ].
result := String new .
result addAll: '@' ; addAll: stepPoint asString ;
       addAll: ' line ' ; addAll: (gsMethod _lineNumberForStep: stepPoint) asString .
^ result
%

category: 'Debugging Support'
method: GsProcess
_localStepPointAt: aLevel

"Used by topaz debugger, 
 returns a stepPoint , or nil if no step point available "

| stepPoint offset gsMethod ipOffset |
(aLevel < 1 _or:[ aLevel > stackDepth ]) ifTrue:[
  aLevel _error: #rtErrArgOutOfRange .
  ].
offset := (stackDepth - aLevel) * self _controlStackEntrySize .
gsMethod := controlStack at:( offset + 1 "virtual machine constant" ) .
gsMethod == nil ifTrue:[ ^  nil  ].

ipOffset := controlStack at:( offset + 2 "virtual machine constant") .

stepPoint := gsMethod _stepPointForIp: ipOffset level: aLevel quick: false .
stepPoint == nil ifTrue: [ ^  nil  ].
^ stepPoint
%

category: 'Private Debugging Support'
method: GsProcess
_setBreaksForStepInto

"Set breakpoints so that a subsequent IntContinue on the receiver will
 execute a step-into.  

 For use only from within implementation of GciStep.

 Return an Array, #[ the GsMethod in which single-step breaks were set;
		     the level at which stack break was set, or zero ]."

"Algorithm
Step Into (is always from TOS == level 1)
  1. set all step breakpoints in TOS.codeOop
  2. if next instruction to execute is BC_CALL_PRIMITIVE,
      set all step breakpoints in level 2 and set stack breakpoint in level 3
    else
      set stack breakpoint at level 2
"

| tosFrame aMethod stackBreakLevel result breakpointsToIgnore |
result := Array new: 3 .
tosFrame := self _frameContentsAt: 1 .
aMethod := tosFrame at: 1 "virtual machine constant" .
(aMethod _opcodeAtIsCallPrimitive: 
    (tosFrame at: 2 "virtual machine constant" "ipOffset")) ifTrue:[
  "next instruction to be executed is a call-primitive"
  aMethod := self methodAt: 2 .
  aMethod  _setAllStepBreaks .
  result at: 1 put: aMethod.
  breakpointsToIgnore := 0.
  stackBreakLevel := 3  .
  ]
ifFalse:[
  "next instruction is not a primitive call"
  aMethod _setAllStepBreaks .
  result at: 1 put: aMethod .
  breakpointsToIgnore := 1.
  stackBreakLevel := 2 .
  ].
stackBreakLevel <= stackDepth 
  ifTrue:[ self _setStackBreakAt: stackBreakLevel ]
  ifFalse:[ stackBreakLevel := 0 "no stack breaks to set" ].
result at: 2 put: stackBreakLevel .
result at: 3 put: breakpointsToIgnore.
^ result 
%

category: 'Private Debugging Support'
method: GsProcess
_setBreaksForStepOverFromLevel: aLevel

"Set breakpoints so that a subsequent IntContinue on the receiver will
 execute a step-over.  

 For use only from within implementation of GciStep.

 Return an Array, #[ the GsMethod in which single-step breaks were set;
		     the level at which stack break was set, or zero;
                     <number of breakpoints to ignore> ]."

"Algorithm

if (aLevel >= 3)
  set stack break at level aLevel .
else if ((aLevel <= 2) and 
         (next instruction to execute at level 1 is BC_CALL_PRIMITIVE))
  set all step breakpoints in level 2 and set stack breakpoint in level 3
else 
  set stack breakpoint at level 2  
"

self remoteProcess ~~ nil
  ifTrue: [
    ^ aLevel > remoteProcess stackDepth
      ifTrue: [
        self _localSetBreaksForStepOverFromLevel: (aLevel - remoteProcess stackDepth)
      ]
      ifFalse: [ remoteProcess _setBreaksForStepOverFromLevel: aLevel ]
  ].

^ self _localSetBreaksForStepOverFromLevel: aLevel
%

category: 'Private Debugging Support'
method: GsProcess
_localSetBreaksForStepOverFromLevel: aLevel

"Set breakpoints so that a subsequent IntContinue on the receiver will
 execute a step-over.  

 For use only from within implementation of GciStep.

 Return an Array, #[ the GsMethod in which single-step breaks were set;
		     the level at which stack break was set, or zero;
                     <number of breakpoints to ignore> ]."

"Algorithm

if (aLevel >= 3)
  set stack break at level aLevel .
else if ((aLevel <= 2) and 
         (next instruction to execute at level 1 is BC_CALL_PRIMITIVE))
  set all step breakpoints in level 2 and set stack breakpoint in level 3
else 
  set stack breakpoint at level 2  
"

| tosFrame tosMethod aMethod stackBreakLevel result breakpointsToIgnore |

result := Array new: 3 .
aLevel >= 3 ifTrue:[
  stackBreakLevel := aLevel .
  breakpointsToIgnore := 1 .
  ]
ifFalse:[ "aLevel is 1 or 2"
  tosFrame := self _frameContentsAt: aLevel .
  tosMethod := tosFrame at: 1 "virtual machine constant" .
  (tosMethod _opcodeAtIsCallPrimitive: 
      (tosFrame at: 2 "virtual machine constant" "ipOffset")) ifTrue:[
    "next instruction to be executed is a call-primitive, so set breaks in
     method where send resolved to a primitive."
    aMethod := self methodAt: 2 .
    aMethod _setAllStepBreaks .
    breakpointsToIgnore := 0 .
    result at: 1 put: aMethod .
    stackBreakLevel := 3  .
    ]
  ifFalse:[
    "next instruction is not a primitive call, set breaks in TOS method"
    tosMethod _setAllStepBreaks .
    result at: 1 put: tosMethod .
    stackBreakLevel := 2.
    breakpointsToIgnore := 1 .
    ].
  ].
stackBreakLevel <= stackDepth 
  ifTrue:[ self _setStackBreakAt: stackBreakLevel ]
  ifFalse:[ stackBreakLevel := 0 "no stack breaks to set" ].
result at: 3 put: breakpointsToIgnore .
result at: 2 put: stackBreakLevel .
^ result 
%

category: 'Private Debugging Support'
method: GsProcess
_clearStackBreakAt: aLevel

"Clear stack breakpoint at specified level.

 Debugger implementations should use GciStep rather than invoking 
 this method directly."

| offset ipOffset |
(aLevel < 1 _or:[ aLevel > stackDepth ]) ifTrue:[
  aLevel _error: #rtErrArgOutOfRange .
  ].
offset := 
  ((stackDepth - aLevel) * self _controlStackEntrySize) + 2 "virtual machine constant" .
ipOffset := controlStack at: offset .
controlStack at: offset put: ipOffset abs 
%

category: 'Private Debugging Support'
method: GsProcess
_clearAllStepBreaksAt: aLevel

"Clears single step breakpoints at the specified level on the stack.  If
 aLevel is 1, clears the step-into bit in the virtual machine flag word, which
 could be left over from a step-into flag argument to a GciPerform* or
 GciExecute* call."

aLevel == 1 ifTrue:[ 
  interruptFlag := interruptFlag bitAnd:( 16r200 bitInvert) 
  ].
^ (self methodAt: aLevel) _clearAllStepBreaks
%

category: 'Private Debugging Support'
method: GsProcess
_setStackBreakAt: aLevel

"Sets a stack breakpoint that is hit when a return from a
 block would return into or across the specified level on the stack.
 When a stack breakpoint is hit, the breakpoint is automatically cleared,
 the return from block is executed, and execution stops with a breakpoint
 error.  If both an unwind block (as installed by valueNowOrOnUnwindDo:)
 and a stack breakpoint are present at the same level in the stack
 the stack breakpoint will be cleared and execution will stop with a
 breakpoint error before executing the unwind block.

 WARNING:  Do not set a stack breakpoint above a method which is
 stopped on a <primitive:nnn>  statement.  Doing so will cause a
 segmentation fault in the virtual machine.  Debugger implementations
 should not set stack breaks directly, but should use GciStep instead."

| offset ipOffset |
(aLevel < 1 _or:[ aLevel > stackDepth ]) ifTrue:[
  aLevel _error: #rtErrArgOutOfRange .
  ].
offset := 
  ((stackDepth - aLevel) * self _controlStackEntrySize) + 2 "virtual machine constant" .
ipOffset := controlStack at: offset .
controlStack at: offset  put: ipOffset abs negated
%

category: 'Accessing'
method: GsProcess
remoteProcess

"Return a remote process if the receiver has one; otherwise return nil."

| aRemoteProcess |
remoteProcess == nil
  ifTrue: [ | systm |
    systm := System .
    aRemoteProcess := systm rcValueCache at: GsProcess otherwise: nil.
    aRemoteProcess ~~ nil
      ifTrue: [
        " Following performed on behalf of GemEnterprise "
        systm rcValueCache removeKey: GsProcess.
        aRemoteProcess showStack
          ifTrue: [
            remoteProcess := aRemoteProcess.
            aRemoteProcess _localProcess: self.
          ]
      ]
  ].
^ remoteProcess
%

category: 'Updating'
method: GsProcess
_removeRemoteProcess

"Set the value of the instance variable 'remoteProcess' to nil. "

remoteProcess := nil
%

category: 'Private'
method: GsProcess
_clientData
  "answer the client data associated with the receiver"
  
  ^clientData
%
category: 'Private'
method: GsProcess
_clientData: anobject
  "set the client data object associated with the receiver"
  
  clientData := anobject
%
category: 'Accessing'
method: GsProcess
createdByApplication
  "Returns true if the receiver was created by the application.
   Returns false if the receiver was created by a Smalltalk method."

  ^(args == nil)
%
category: 'Private'
method: GsProcess
_isTerminated

  ^ (isTerminated == true)
%
category: 'Private'
method: GsProcess
_priorityRangeCheck: p
  (p > ProcessorScheduler scheduler highestPriority) ifTrue: [
    p _error: #rtErrArgOutOfRange .
  ].
  (p < ProcessorScheduler scheduler lowestPriority) ifTrue: [
    p _error: #rtErrArgOutOfRange .
  ].
%

category: 'Accessing'
method: GsProcess
priority
  "Answer the scheduling priority of the receiver"

  (priority == nil) ifTrue: [
    priority := ProcessorScheduler scheduler userSchedulingPriority ].
  ^priority
%

category: 'Accessing'
method: GsProcess
priority: anInt
  "Set the scheduling priority of the receiver"

  | oldPriority |

  self _priorityRangeCheck: anInt.
  oldPriority := priority.
  priority := anInt.

  location ~~ nil ifTrue: [location _changePriority: self from: oldPriority].
%

category: 'Private'
method: GsProcess
_nextToRun
"Tell the scheduler that the next thread to run is the receiver.
 This should only be used with a thread that is in the debug state."

| ps oldPriority |
ps := ProcessorScheduler scheduler.
oldPriority := priority.
priority := (ps highestPriority) + 1.
ps _scheduleProcess: self.
priority := oldPriority.
%

category: 'Private'
method: GsProcess
_location

  ^ location
%
category: 'Private'
method: GsProcess
_location: l

  location := l.
  ^self
%
category: 'Changing Process State'
method: GsProcess
resume
  "Puts the receiver in the queue of ready processes at its priority"

  _debugMode == 1 ifTrue:[ self error:'cannot resume an instance that is a continuation' ].

  ProcessorScheduler scheduler _resumeProcess: self.
  ^self
%
category: 'Changing Process State'
method: GsProcess
suspend
  "Suspends the receiver from processing and does not
   schedule it for further processing."

  _debugMode == 1 ifTrue:[ self error:'cannot suspend an instance that is a continuation' ].

  ProcessorScheduler scheduler _suspendProcess: self location: location.
  ^self
%
category: 'Changing Process State'
method: GsProcess
terminate
  "terminates the receiver and unschedules it"

  _debugMode == 1 ifTrue:[ self error:'cannot terminate an instance that is a continuation' ].

  self remoteProcess ~~ nil
    ifTrue: [ remoteProcess terminate ].

  self _callUnwindBlocks. "see bug 13131"
  (block == nil) ifTrue: [
    stackDepth := 0.
    controlStack := nil.
    arStack := nil.
    inUserActionCount := 0.
    interruptFlag := 0.
    fltStatus := nil.
    recursionsToStCount := 0.
    protectedMode := 0.
    asyncEventsDisabled := false.
    remoteProcess := nil.
  ].
  priority := nil.
  block := nil.
  isTerminated := true.
  ProcessorScheduler scheduler _terminateScheduledProcess: self.
  ^self
%
category: 'Private'
method: GsProcess
_statusString
  "Returns a string that describes the receiver's status as a thread."

  ^ProcessorScheduler scheduler _statusString: self.
%

category: 'Private'
method: GsProcess
_signalTime
  ^signalTime
%
category: 'Private'
method: GsProcess
_signalTime: time

  signalTime := time.
%
category: 'Private'
method: GsProcess
_activate
  "Wake up the receiver"

  signalTime := nil.
  ProcessorScheduler scheduler _scheduleProcess: self.
%
category: 'Private'
method: GsProcess
_wait
  "Suspend the receiver who should be the active process"
  ProcessorScheduler scheduler _reschedule.
  ^self
%
category: 'Private'
method: GsProcess
_reapSignal: signalSource
  "Make the receiver ready to run."

  ProcessorScheduler scheduler _scheduleProcess: self.
%
category: 'Private'
method: GsProcess
_setupReapSignalLocation: anObject
  "Make the receiver ready to be sent _reapSignal:."

  location := anObject.
  ProcessorScheduler scheduler _waiting: self.
%
category: 'Private'
method: GsProcess
_signalAll
  "Wake up the receiver"

  ProcessorScheduler scheduler _scheduleProcess: self.
%
category: 'Private'
method: GsProcess
_start
  "Called from C to start a new process."

  "This method will never return. Once the receiver completes it should
   find another process to run."

  "NYI: need to do something about exceptions"

  self _startPart2.

  (_debugMode == true) ifTrue: [
    "The thread that terminated is being debugged.
     So raise the terminate error.  
     We normally get here when single stepping past end of process' code
     and the 'isTerminated := true' will be done in IntLpSupPrim493()
    "
    System signal: 2368"#rtErrGsProcessTerminated"
         args: #[ ] signalDictionary: GemStoneError.
  ] ifFalse: [
    isTerminated := true.
    ProcessorScheduler scheduler _runNextProcess.
  ].
%

category: 'Private'
method: GsProcess
_startPart2
  "Starts up a thread by sending value to its block.
   Catches the terminate error."

  _debugMode == 1 ifTrue:[ self error:'cannot start an instance that is a continuation' ].

  Exception category: GemStoneError number: 2368"#rtErrGsProcessTerminated" 
  do: [ :ex :cat :num :exargs |
    blockResult := nil.
    priority := nil.
    block := nil.
    location := nil.
    ^false
  ].

  (block ~~ nil) ifTrue: [
    blockResult := block valueWithArguments: args.
    priority := nil.
    block := nil.
    location := nil.
    ^true
  ].
  ^false
%

category: 'Debugger Support'
method: GsProcess
_stepOver
    "Step execution over the next message.
     Returns the receiver unless the receiver completes in which
     case the result of the completion is returned."

  ^ self _stepOverInFrame: 1
%

category: 'Debugger Support'
method: GsProcess
_stepInto
    "Step execution into the next message.
     Returns the receiver unless the receiver completes in which
     case the result of the completion is returned."

  ^ self _stepOverInFrame: 0
%

category: 'Private'
method: GsProcess
_checkIfDebuggable
  "Check to make sure the receiver is debuggable. Currently this
   means that it is in the debug or ready states.
   If it is not debuggable then raise an error."

  | status |

  status := self _statusString.
  ((status = 'ready' _or:[status = 'debug']) _or:[status = 'active']) ifFalse: [
    System signal: (ErrorSymbols at: #rtErrGsProcessNotDebuggable)
         args: #[ self ] signalDictionary: GemStoneError.
  ].
%

category: 'Private'
method: GsProcess
_stepCleanup: saveArray

  | saveStackBreakLevel saveSsBreaksInMethod saveStackDepth
    newStackDepth stackBreakDepth |

  saveSsBreaksInMethod := saveArray at: 1.
  saveStackBreakLevel := saveArray at: 2.
  saveStackDepth := saveArray at: 3.

  _debugMode := false.

  newStackDepth := stackDepth.
  stackBreakDepth := saveStackDepth - (saveStackBreakLevel - 1).
  (saveStackBreakLevel ~~ 0) ifTrue: [
    ((newStackDepth - stackBreakDepth + 1) >= 1) ifTrue: [
      self _clearStackBreakAt: (newStackDepth - stackBreakDepth + 1).
    ].
  ].
  (newStackDepth >= stackBreakDepth) ifTrue: [
    "stack grew, so we probably did a step-into; make sure ss breaks
     are cleared in the new stack frame."
    self _clearAllStepBreaksAt: 1.
  ].
  (saveSsBreaksInMethod ~~ nil) ifTrue: [
    saveSsBreaksInMethod _clearAllStepBreaks.
  ].
  "clear INT_STEP_INTO_FROM_TOS_MASK | INT_STEP_OVER_FROM_TOS_MASK"
  interruptFlag := interruptFlag bitAnd: (16r300 bitInvert).
%

category: 'Debugger Support'
method: GsProcess
_stepOverInFrame: level
    "Step execution so that it stops after the next message send
     in the specified stack level.  If a return causes the
     context at the specified level to be removed from the
     stack, execution will stop immediately after that return.
     If 'raiseException' then debugger exceptions are raised
     so that a GCI app can catch them.
     Returns the receiver unless the receiver completes in which
     case the result of the completion is returned."

  ^ self _stepOverInFrame: level mode: false replace: false tos: nil
%

category: 'Debugger Support'
method: GsProcess
_stepOverInFrame: level return: anObject
    "Step execution so that it stops after the next message send
     in the specified stack frame.  If a return causes the
     context at the specified frame to be removed from the
     stack, execution will stop immediately after that return.
     The argument anObject will be the return value of the
     current top of stack - useful for passing back the return
     value of a client forwarder send.
     Returns the receiver unless the receiver completes in which
     case the result of the completion is returned."

  ^ self _stepOverInFrame: level mode: false replace: true tos: anObject
%

category: 'Private'
method: GsProcess
_stepOverInFrame: level mode: raiseException replace: replaceTos tos: tos
    "Step execution so that it stops after the next message send
     in the specified stack level.  If a return causes the
     context at the specified level to be removed from the
     stack, execution will stop immediately after that return.
     If 'raiseException' then debugger exceptions are raised
     so that a GCI app can catch them.
     Returns the receiver unless the receiver completes in which
     case the result of the completion is returned."

  | actualLevel result saveArray breakpointsToIgnore 
    mySaveArray saveStackDepth status |

  self _checkIfDebuggable.
  status := self _statusString.
  (status = 'ready') ifTrue: [
    self _unscheduleProcess.
  ].

  actualLevel := level.
  (remoteProcess ~~ nil) ifTrue: [
    (level <= self stackDepth) ifTrue: [
      ^remoteProcess _remoteStep: level.
    ] ifFalse: [
      remoteProcess _continue.
      actualLevel := level - stackDepth.
    ].
  ].

  (actualLevel < 0 _or:[ actualLevel > stackDepth ]) ifTrue:[
    level _error: #rtErrArgOutOfRange .
  ].

  saveStackDepth := stackDepth.
  (actualLevel == 0) ifTrue: [
    saveArray := self _setBreaksForStepInto.
    breakpointsToIgnore := (saveArray at: 3).
    "set INT_STEP_INTO_FROM_TOS_MASK bit"
    interruptFlag := interruptFlag bitOr: 16r200.
  ] ifFalse: [
    saveArray := self _setBreaksForStepOverFromLevel: actualLevel.
    (saveArray size >= 3) ifTrue: [
      breakpointsToIgnore := (saveArray at: 3).
    ] ifFalse: [
      "old beta 5.0 dbf"
      (actualLevel <= 1) ifTrue: [
        breakpointsToIgnore := 1.
      ] ifFalse: [
        breakpointsToIgnore := 0.
      ].
    ].
    (level == 1) ifTrue: [
      "step over from TOS, so set the interrupt bit that will cause
       a stack break to be inserted after the next send, to trap return
       from that send."
      "Set INT_STEP_OVER_FROM_TOS_MASK bit"
      interruptFlag := interruptFlag bitOr: 16r100.
    ].
  ].

  (replaceTos) ifTrue: [
    mySaveArray := #[ (saveArray at: 1), (saveArray at: 2), saveStackDepth,
                       tos].
  ] ifFalse: [
    mySaveArray := #[ (saveArray at: 1), (saveArray at: 2), saveStackDepth].
  ].

  _debugMode := true.
  "Make sure the activeProcess exists"
  result := self _primStep: breakpointsToIgnore
                 from: (ProcessorScheduler scheduler activeProcess)
                 with: mySaveArray mode: raiseException.

  (status = 'ready') ifTrue: [
    (result == self) ifTrue: [
      (self _isTerminated) ifFalse: [
        ProcessorScheduler scheduler _scheduleProcess: self.
      ].
    ].
  ].
  "_stepCleanup may run a method that was stepped into (Object>>at:), so run with
   #_performNoDebug:with: to ensure that the cleanup is performed"
  self _performNoDebug: #_stepCleanup: with: mySaveArray.

  ^result
%

category: 'Private'
method: GsProcess
_primStep: breakpointsToIgnore from: procOop with: saveArray mode: raiseExcept

<primitive: 493>
self _primitiveFailed: #_primStep:from:with:mode:.
%


category: 'Debugger Support'
method: GsProcess
_continue
    "Continue execution. Return the result of execution if the receiver
     completes. Otherwise if a breakpoint is hit returns the receiver."

  | result status |

  self _checkIfDebuggable.
  status := self _statusString.
  (status = 'ready') ifTrue: [
    self _unscheduleProcess.
  ].

  _debugMode := true.

  result := self _primContinue: (ProcessorScheduler scheduler activeProcess).

  (status = 'ready') ifTrue: [
    (result == self) ifTrue: [
      (self _isTerminated) ifFalse: [
        ProcessorScheduler scheduler _scheduleProcess: self.
      ].
    ].
  ].
  _debugMode := false.

  ^result
%

category: 'Private'
method: GsProcess
_primContinue: procOop

<primitive: 510>
self _primitiveFailed: #_primContinue.
%

category: 'Private'
method: GsProcess
_unscheduleProcess
  "remove the given process from the queues it is in"

  (signalTime ~~ nil) ifTrue: 
    [ProcessorScheduler scheduler _delayUnschedule: self.
     signalTime := nil.].
  (location ~~ nil) ifTrue: 
    [location _unscheduleProcess: self.
     location := nil.
     ProcessorScheduler scheduler _unscheduleProcess: self.].
%
category: 'Private'
method: GsProcess
_targetProcess
  "Returns the GsProcess that is waiting for the receiver."

  ^self
%

category: 'Process Groups'
method: GsProcess
_newGroup
  "Add the receiver to a new process group. Return the group value."
  self _joinGroup: (ProcessorScheduler scheduler _newGroup).
  ^ self _group
%

category: 'Process Groups'
method: GsProcess
_group
  "Return the process group the receiver is in."
  group == nil ifTrue: [self _newGroup].
  ^group
%

category: 'Process Groups'
method: GsProcess
_joinGroup: anInteger
  "Have the receiver join the specified processor group. Return self."
  group := anInteger.
%

category: 'Process Groups'
method: GsProcess
_groupSameAs: anInteger
  "Return true if the receiver's group is the same as anInteger.
   Otherwise return false."

  "Note we don't use 'self _group' because that would initialize
   group which we don't need done for a same as test."

  ^group = anInteger
%

category: 'Continuations'
method: GsProcess
isContinuation

"Return true if the receiver is a continuation."

^ _debugMode == 1
%

category: 'Continuations'
method: GsProcess
value: anArg

"The receiver must be a continuation, i.e. a result
 from continuationFromLevel: , or an error will be generated.

 Resumes execution of the continuation with top-of-stack
 replaced by anArg . "

<primitive: 916>
self _uncontinuableError  "should never reach here"
%

category: 'Continuations'
method: GsProcess
value

"See value: for documentation "

^ self value: nil

%

