!=========================================================================
! Copyright (C) VMware, Inc. 1986-2011.  All Rights Reserved.
!
! $Id: gsmethod.gs,v 1.37 2008-01-09 22:50:11 stever Exp $
!
! Superclass Hierarchy:
!   GsMethod, Object.
!
!   GsMethod is an indexable subclass of Object
!
!=========================================================================

! 5.0: GsMethod created in bom.c

! remove existing behavior from GsMethod
removeallmethods GsMethod
removeallclassmethods GsMethod

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

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

txt := (GsDocText new) details:
'A GsMethod is a compiled form of a GemStone Smalltalk method.' .
doc documentClassWith: txt.

txt := (GsDocText new) details:
'A SmallInteger . least significant 8 bits are an 8 bit unsigned compiler 
 version. remaining bits are the signed number of invocations of this method 
 during this session since the last time invocation counts were reset
 by profiling methods.  Invocations counts are not maintained in 
 all configurations of the system, 
 and are subject to change in future releases.' .
doc documentInstVar: #invocationCount with: txt.

txt := (GsDocText new) details:
'A SmallInteger count of breakpoints defined on the method.' .
doc documentInstVar: #numBreakpoints with: txt.

txt := (GsDocText new) details:
'A Symbol that defines the method''s selector.' .
doc documentInstVar: #selector with: txt.

txt := (GsDocText new) details:
'A SmallInteger that gives the index where literals are stored in an
 instance.' .
doc documentInstVar: #literalsOffset with: txt.

txt := (GsDocText new) details:
'A SmallInteger that defines the number of arguments that the method expects.' .
doc documentInstVar: #numArgs with: txt.

txt := (GsDocText new) details:
'The Behavior (a Class or Metaclass) for which the method was compiled.' .
doc documentInstVar: #inClass with: txt.

txt := (GsDocText new) details:
'For GemStone internal use.' .
doc documentInstVar: #numSends with: txt.

txt := (GsDocText new) details:
'A CharacterCollection containing the source code of the method.' .
doc documentInstVar: #sourceString with: txt.

txt := (GsDocText new) details:
'An Array that captures information that is useful in debugging.' .
doc documentInstVar: #debugInfo with: txt.
  "see opalcls.ht  for documentation of the debugInfo "

self description: doc.
%

! ------------------- Class methods for GsMethod
! ------------------- Instance methods for GsMethod
category: 'Execution'
method: GsMethod
_executeInContext: anObject

"The receiver should be a zero argument GsMethod obtained by invoking
 String/_compileInContext:symbolList: and the argument should be the argument
 passed to the _compileInContext: keyword for that compilation.

 Returns the result of executing the receiver."

^ self _primitiveExecuteInContext: anObject
%

category: 'Private'
method: GsMethod
_primitiveExecuteInContext: anObject

"Private.

 This method may only be invoked by _executeInContext: .  Invoking it
 from any other method may result in execution failures due to premature
 garbage collection of the receiver.

 The receiver should be a zero argument GsMethod.
 Returns the result of executing the receiver."

<primitive: 908>
^ self _primitiveFailed: #_primitiveExecuteInContext:
%

category: 'Debugging Support'
classmethod: GsMethod
_sourceWithErrors: compilerError fromString: aString

"This method returns an instance of aString's class containing the text in a
 string with compiler errors marked, plus the error text for each error.

 The argument compilerError is the result Array from either the 
 Behavior | compileMethod:dictionaries:category:  method or the
 GsMethod | _recompileWithSource: method.

 The argument aString is the source string which was an input to either the
 Behavior | compileMethod:dictionaries:category: method or the
 GsMethod | _recompileWithSource: method."

| lineFeed result aStringSize offsets errNumbers thisErr pos
  markerArray errDict errMsgs auxMsgs |

"initialize"
lineFeed := Character lf.
"only ask for source size once for efficiency for Japanese"
aStringSize:= aString size.
offsets := Array new: compilerError size.
errNumbers := Array new: compilerError size.
errMsgs := Array new: compilerError size.
auxMsgs := Array new: compilerError size.

"get an Array of source offsets with errors, and an Array of error numbers"
1 to: compilerError size do: [:i |
   thisErr := compilerError at: i.
   offsets at: i put: (thisErr at: 2 "source offset").
   errNumbers at: i put: (thisErr at: 1 "error number") .
   thisErr size >= 3 ifTrue:[
     errMsgs at: i put: (thisErr at: 3"error message String") . 
     thisErr size >= 4 ifTrue:[
       auxMsgs at: i put: (thisErr at: 4 "additional message text")
       ].
     ].
   ].

"build an Array parallel to the source that contains nil if no error at
 that source position, and an index into offsets if there is an error at
 that source position"
markerArray:= self _buildMarkersFrom: offsets ofSize: aStringSize.

result:= self _buildMarkedSourceFrom: aString
                          sourceSize: aStringSize
                             markers: markerArray.

"add error strings"
errDict := GemStoneError at: System myUserProfile nativeLanguage.
1 to: errNumbers size do: [:i | | msg |
  result add: lineFeed.
  result addAll: i asString.
  result addAll: ': ['.
  pos := errNumbers at: i.
  result addAll: pos asString.
  result addAll: '] '.
  msg := errMsgs at: i .
  msg == nil ifTrue:[
    pos > errDict size
      ifTrue: [ msg := '(unknown error number)']
      ifFalse: [ msg := (errDict at: pos) asString].
    ].
  result addAll: msg .
  (auxMsgs at: i) ~~ nil ifTrue:[ result addAll: (auxMsgs at: i) ].
  ].
result add: lineFeed.

^result
%

category: 'Debugging Support'
classmethod: GsMethod
_buildMarkedSourceFrom: sourceStr sourceSize: aSize markers: markerArray

"Given a source string, its size (passed in for efficiency), and a marker
 Array, returns an instance of sourceStr's class containing the marked source."

| lineFeed tab space
  placesMarked     "an Array of markers marked on the current line"
  markerLineIndex "index into the current marker line"
  result          "the result of this method"
  markerLine      "the current marker line"
  aChar           "one Character of the source"
  displayWidth    "the number of positions it takes to display aChar"
  lineSz          
|

"initialize"
lineFeed := Character lf.
tab:= Character tab.
space:= Character space.

placesMarked:= Array new.
markerLineIndex:= 1.
result:= sourceStr class new .
result addAll: '   ' .
lineSz := 0 .
markerLine:= String new .
markerLine add: $  .
1 to: aSize do: [:i |
   aChar:= sourceStr at: i.  "fetch a char"
   displayWidth:= aChar displayWidth.

   "Add the char to the result"
   (aChar == tab)
   ifTrue: [
      displayWidth:= 8 - (lineSz \\ 8).
      displayWidth timesRepeat: [result add: space].
      lineSz := lineSz + displayWidth .
   ]
   ifFalse: [
      result add: aChar.
      lineSz := lineSz + displayWidth .
      ((i == aSize) _and: [aChar ~~ lineFeed]) ifTrue: [
        result add: lineFeed .
      ].
   ].

   ((markerArray at: i) == nil) "no marker at this position"
   ifTrue: [
      displayWidth timesRepeat: [markerLine add: space].
   ]
   ifFalse: [ "found an error at this position"
      placesMarked add: #[markerLineIndex + 1, markerArray at: i].
      markerLine add: $^ .
      displayWidth - 1 timesRepeat: [markerLine add: space].
   ].
   markerLineIndex:= markerLineIndex + displayWidth.

   ((aChar == lineFeed) _or: [i == aSize])
   ifTrue: [ "we are at end of line"
      "add error identifiers to marker line "
      (placesMarked size ~~ 0) ifTrue: [
         self _addMarkerIds: #[placesMarked, markerLine, markerLineIndex].
         result add: $  ; add: $* .
         result add: markerLine.
         ] .

      (i == aSize) ifFalse: [
         result addAll: '   ' .
         lineSz := 0 .
      ].
      markerLine size: 1.
      markerLineIndex:= 1.
      placesMarked size: 0.
   ]
].
^result
%

category: 'Debugging Support'
classmethod: GsMethod
_buildMarkersFrom: sourceOffsets ofSize: sizeArg

"Given an Array of source offsets, build an Array of size sizeArg containing
 the index into anArray at the position corresponding to anArray's element.
 The remainder of the Array contains nil.  Negative offsets denote disabled
 breakpoints."

| markerArray anOffset posOffset aSize |
aSize := 1 max: sizeArg .                          "fix bug 14976"
markerArray:= Array new: aSize.
1 to: sourceOffsets size do: [:i |
  anOffset := sourceOffsets at: i .
  anOffset == nil ifFalse:[
    posOffset:= (anOffset abs max: 1) min: aSize.  "limit within range"
    (markerArray at: posOffset) == nil ifTrue:[
       anOffset < 0 ifTrue:[ markerArray at: posOffset put: i negated ]
		    ifFalse:[ markerArray at: posOffset put: i ]
       ]
    ]
  ].
^markerArray
%

category: 'Debugging Support'
classmethod: GsMethod
_addMarkerIds: anArray

""

| placesMarked markerLine markerLineSize space addToEnd markPosition
  aStr neededSize subStr |

placesMarked:= anArray at: 1.
markerLine:= anArray at: 2.
space:= Character space.

"have the source marked at each error with ^; now add marker identifier"
addToEnd:= false.
1 to: (placesMarked size) do: [:i |
   markPosition:= (placesMarked at: i) at: 1.
   aStr:= ((placesMarked at: i) at: 2) asString.
   neededSize:= markPosition + aStr size.
   markerLineSize := markerLine size .
   (markerLineSize < neededSize)
   ifTrue: [
       markerLine size: neededSize.
       markerLineSize + 1 to: neededSize do: [:i |
          markerLine at: i put: space].
       markerLineSize:= neededSize.
   ].

   (addToEnd)
   ifFalse: [
      subStr:= markerLine copyFrom: markPosition + 1
                                to: (markPosition + aStr size).
      subStr do: [:each | (each = $ ) ifFalse: [addToEnd:= true]].
   ].
   (addToEnd)
   ifTrue: [ markerLine add: aStr.
             (i == placesMarked size)
             ifFalse: [ markerLine add: ',']]
   ifFalse: [ aStr copyFrom: 1 to: (aStr size) into: markerLine
                   startingAt: markPosition + 1.]
].
(68 - markerLine size) timesRepeat:[ markerLine add: $ ].
(75 - markerLine size) timesRepeat:[ markerLine add: $* ] .
markerLine add: Character lf.
^ true
%

category: 'Instance Creation'
classmethod: GsMethod
new: anInteger

"Disallowed.  You cannot create new instances of GsMethod."

self shouldNotImplement: #new:
%

category: 'Instance Creation'
classmethod: GsMethod
new

"Disallowed.  You cannot create new instances of GsMethod."

self shouldNotImplement: #new
%


category: 'Debugging Support'
method: GsMethod
_buildMarkerArray: allSteps ofSize: aSize

"This method builds a marker Array for the receiver's source code string.

 allSteps == true , show all steps
          == false, show steps where a breakpoint currently exists
          a SmallInteger, show just that step point 

 The result Array is the same size as the source string and 
 contains step numbers at offsets corresponding to the source string."

| srcOffsets stepToDisplay |

srcOffsets := self _sourceOffsets  .
(allSteps _isSmallInteger ) ifTrue:[ 
    stepToDisplay := allSteps .
    1 to: srcOffsets size do:[ :j |
       j == stepToDisplay ifFalse:[ srcOffsets at: j put: nil ].
    ] 
  ]
  ifFalse:[
    allSteps ifFalse:[ self _setBreakpointsInSourceOffsets: srcOffsets ].
  ].

^ GsMethod _buildMarkersFrom: srcOffsets ofSize: aSize
%

category: 'Debugging Support'
method: GsMethod
_buildIpMarkerArray

"This method builds a marker Array for the receiver's source code string.
 containing IPs of all step points.

 The result Array is the same size as the source string and 
 contains IP numbers at offsets corresponding to the source string."

| srcOffsets ipsArr srcSize mrkSize markerArray bias |

srcOffsets := self _sourceOffsets  .  "source offsets of the step points"
ipsArr := self _ipSteps .             "relative IPs of each step point"
srcSize := self sourceString size .

mrkSize := 1 max: srcSize .                          "fix bug 14976"
markerArray:= Array new: mrkSize .
bias := self class instSize .
1 to: srcOffsets size do: [:i | | anOffset anIp posOffset|
  anOffset := srcOffsets at: i .
  anIp := (ipsArr at: i ) + bias .
  posOffset := (anOffset abs max: 1) min: mrkSize.  "limit within range"
  (markerArray at: posOffset) == nil ifTrue:[
     markerArray at: posOffset put: anIp 
  ]
].
^markerArray
%

category: 'Debugging Support'
method: GsMethod
_sourceAtIp: anIp

"Return the source string with marker for step point closest to
 the specified IP . 
 Assumes that the IP is from a frame that is Not at top of Stack."

| aStep |
aStep := self _previousStepPointForIp: anIp quick: false .
^ self _sourceWithSteps: aStep
%
category: 'Debugging Support'
method: GsMethod
_sourceAtTosIp: anIp

"Return the source string with marker for step point closest to
 the specified IP . 
 Assumes that the IP is from a frame that IS at top of Stack."

| aStep |
aStep := self _nextStepPointForIp: anIp quick: false .
^ self _sourceWithSteps: aStep
%

category: 'Debugging Support'
method: GsMethod
_lineNumberForIp: targetIp

"Returns the line number in the receiver's source string for the
 specifed IP value within the receiver.
 Assumes that the IP is from a frame that is Not at top of Stack."

| stepPoint |
stepPoint := self _previousStepPointForIp: targetIp quick: false .
^ self _lineNumberForStep: stepPoint 
%

category: 'Debugging Support'
method: GsMethod
_lineNumberForTosIp: targetIp

"Returns the line number in the receiver's source string for the
 specifed IP value within the receiver.
 Assumes that the IP is from a frame that IS at top of Stack ."

| stepPoint |
stepPoint := self _nextStepPointForIp: targetIp quick: false .
^ self _lineNumberForStep: stepPoint 
%

category: 'Debugging Support'
method: GsMethod
_sourceWithSteps: allSteps

"This method returns the source string with intermixed control information
 indicating where step points are.  

 allSteps == true , show all steps
          == false, show steps where a breakpoint currently exists
          a SmallInteger, show just that step point 
 "

| markerArray "A parallel Array to the source string.  It is filled with nils
               except for locations pointed to by the sourceOffsets Array."
  aSize "the size of the source"
  result |

aSize:= sourceString size.
  "only ask for the source size once for efficiency for Japanese"
markerArray := self _buildMarkerArray: allSteps ofSize: aSize.
result := GsMethod _buildMarkedSourceFrom: sourceString
                             sourceSize: aSize
                                markers: markerArray .
				"deleted   'reduce garbage' code"
^ result
%

category: 'Debugging Support'
method: GsMethod
_sourceWithStepIps

"This method returns the source string with intermixed control information
 indicating IP values of each step point.  
 "

| markerArray "A parallel Array to the source string.  It is filled with nils
               except for locations pointed to by the sourceOffsets Array."
  aSize "the size of the source"
  result |

aSize:= sourceString size.
  "only ask for the source size once for efficiency for Japanese"
markerArray := self _buildIpMarkerArray .
result := GsMethod _buildMarkedSourceFrom: sourceString
                             sourceSize: aSize
                                markers: markerArray .
^ result
%

category: 'Debugging Support'
method: GsMethod
_sourceOffsets

"Returns an InvariantArray (that holds SmallIntegers) which is a list
 of offsets into sourceString, corresponding in order to the step points."

| offset numIpSteps numSrcOffsets |
numIpSteps := self _numIpSteps .
numSrcOffsets := self _numSourceOffsets .
(numIpSteps == 0 _or:[ numSrcOffsets == 0]) 
   ifTrue:[ ^ #( 1 ) ].  "handle certain primitive methods"

offset := 
  self _debugInfoHeaderSize + 1 + self _numArgsAndTemps + numIpSteps .
^ debugInfo copyFrom: offset to: (offset + numSrcOffsets - 1) 
%

category: 'Debugging Support'
method: GsMethod
_sourceOffsetsAt: aStepPoint

"Returns the source offset for the step point with number aStepPoint.
 Returns nil if aStepPoint is out of range."

| numIpSteps numSrcOffsets |
numIpSteps := self _numIpSteps .
numSrcOffsets := self _numSourceOffsets .
(numIpSteps == 0 _or:[ numSrcOffsets == 0]) ifTrue:[ 
  "handle certain primitive methods, whose source offsets is #( 1 ) "
  aStepPoint == 1 ifFalse:[ ^ nil ].
  ^ 1 
  ].  

(aStepPoint < 1 _or:[ aStepPoint > numSrcOffsets ]) ifTrue:[ ^ nil ].

^ debugInfo at: 
  self _debugInfoHeaderSize + aStepPoint + self _numArgsAndTemps + numIpSteps .
%

category: 'Debugging Support'
method: GsMethod
_lineNumberForStep: aStepPoint

"Returns the line number in the receiver's source string for the
 step point with number aStepPoint.
 Returns 1 if aStepPoint is out of range."

| sourceOffset offset lf  lineNumber|
sourceOffset := self _sourceOffsetsAt: aStepPoint .
sourceOffset == nil ifTrue:[ ^ 1 ].

" find the first end-of-line which is at or after the sourceOffset of the step point"
lf := Character lf .
offset := 1 .
lineNumber := 0 .
[ offset <= sourceOffset ] whileTrue:[
  lineNumber := lineNumber + 1 .
  offset := sourceString indexOf: lf startingAt: offset .
  offset == 0 ifTrue:[ ^ lineNumber ].
  offset := offset + 1 .
  ].
^ lineNumber .
%

category: 'Accessing'
method: GsMethod
argsAndTemps

"Returns an Array of Symbols which are the names of arguments and
 temporaries for this method."

| offset numArgsTmps |
numArgsTmps := self _numArgsAndTemps .
numArgsTmps < 1 ifTrue:[ ^  #()  ].

offset := self _debugInfoHeaderSize + 1.
^ debugInfo copyFrom: offset to: (offset + numArgsTmps - 1)
%

category: 'Accessing'
method: GsMethod
_ipSteps

"Returns an Array containing the step points for the portable code for the
 method."

| offset |
offset := self _debugInfoHeaderSize + 1 + self _numArgsAndTemps  .
^ debugInfo copyFrom: offset to: (offset + self _numIpSteps - 1)
%

category: 'Debugging Support'
method: GsMethod
_numArgsAndTemps

""

^ debugInfo at: 1
%

category: 'Debugging Support'
method: GsMethod
_numArgs

""

^ debugInfo at: 2
%

category: 'Debugging Support'
method: GsMethod
_numIpSteps

""

^ debugInfo at: 3
%

category: 'Debugging Support'
method: GsMethod
_numSourceOffsets

""

^ debugInfo at: 4
%

category: 'Debugging Support'
method: GsMethod
_debugInfoHeaderSize

""

^ 4
%

category: 'Debugging Support'
method: GsMethod
_breakPointKind: anIp

"This method infers the kind of action associated with a given bytecode."

self pause "not implemented"
%

category: 'Debugging Support'
method: GsMethod
_setBreakpointsInSourceOffsets: sourceOffsets

"Given all the source offsets for the receiver, replace with nil those
 that do not correspond to a breakpoint.  Negate those which correspond
 to a disabled breakpoint."

| breakIpsSet numIpSteps ipStepsBase j sortedBreaks posBreakIp anIp aSrcOffset |

breakIpsSet := self _breakpointIpOffsets .
breakIpsSet == nil ifTrue:[ ^ sourceOffsets size: 0 ].

"convert to a sorted list of Associations; true means enabled breakpoint."
sortedBreaks := SortedCollection new .
breakIpsSet do:[:anIp | | assoc |
  anIp >= 0 
    ifTrue:[ assoc := Association newWithKey: anIp value: true] 
   ifFalse:[ assoc := Association newWithKey: anIp negated value: false].
  sortedBreaks add: assoc .
  ]. 

numIpSteps := self _numIpSteps .
numIpSteps == sourceOffsets size ifFalse:[ self _halt:'inconsistent size'].

ipStepsBase := self _numArgsAndTemps + self _debugInfoHeaderSize .
j := 1 . "index into ipSteps and sourceOffsets"
1 to: sortedBreaks size do:[:k | | assoc breakIp isEnabled |
  assoc := sortedBreaks at: k .
  breakIp := assoc key .
  isEnabled := assoc value .
  posBreakIp := breakIp - 1 . "convert to zero based"
      
  [ anIp := debugInfo at: ipStepsBase + j .  
    anIp < posBreakIp 
    ] 
  whileTrue:[
    sourceOffsets at: j put: nil . "clear source offset for which no breakpoint"
    j := j + 1 . 
    j > numIpSteps ifTrue:[
      "have searched all ipSteps, so we are done"
      k < sortedBreaks size ifTrue:[ 
	"synthesize source offset for break at end of method"
	sourceOffsets add: sourceString size  
	].
      ^ self 
      ].
    ].
  aSrcOffset := sourceOffsets at: j .
  isEnabled ifFalse:[ sourceOffsets at: j put: aSrcOffset negated ].
  j := j + 1 .
  ].
"clear source offsets beyond last breakpoint"
sourceOffsets size: j - 1 .
^ self
%

category: 'Debugging Support'
method: GsMethod
_stepPointsFromBreakIpOffsets: breakIps

"breakIps is an Array of breakpoint ipOffsets to stepPoint numbers. 
 The ipOffsets are one-based with negative ipOffsets denoting 
 disabled breakpoints.  Disabled breakpoints are translated to 
 negative step point numbers, for use in a breakpoint report."

| result numIpSteps ipStepsBase sourceOffsetsBase j aBreakIp anIp 
  posBreakIp lastDisabledBreak |

breakIps == nil ifTrue:[ ^ #() ] .
result := Array new .

numIpSteps := self _numIpSteps .
ipStepsBase := self _numArgsAndTemps + self _debugInfoHeaderSize .
sourceOffsetsBase := ipStepsBase + numIpSteps .
j := 1 .
lastDisabledBreak := false .
1 to: breakIps size do:[ :k |
  aBreakIp := breakIps _at: k .
  posBreakIp := aBreakIp .
  lastDisabledBreak ifFalse:[ 
    aBreakIp > 0 ifTrue:[ j := 1 . lastDisabledBreak := true ]
                 ifFalse:[ posBreakIp := aBreakIp negated. ].
    ].
  posBreakIp := posBreakIp - 1 . "convert to zero based"

  [ anIp := debugInfo at: ipStepsBase + j .  anIp < posBreakIp ] 
      whileTrue:[ j := j + 1 . j > numIpSteps ifTrue:[ ^ result ]].

  aBreakIp < 0 ifTrue:[ result add: j negated ] 
              ifFalse:[ result add: j ].
  ].

^ result.
%

category: 'Debugging Support'
method: GsMethod
_nextStepPointForIp: anIp quick: isQuick

"Returns the offset in the ipSteps Array of the receiver which represents
 the step point at or just after the given instruction pointer offset.  If
 anIp is after the last step point, returns an integer one greater than
 the last step point.

 The anIp argument is a zero-based offset relative to first named instance
 variable in the receiver."

"This method is useful when doing low-level debugging of the virtual machine."

| numIpSteps aStep offset j  bias posIp |
numIpSteps := self _numIpSteps .
offset := self _numArgsAndTemps + self _debugInfoHeaderSize .

"search backwards so that if anIp points at the last element of an in-line
 send cache, we get the right answer. 

 steps in debugInfo are zero based relative to first instruction in portable
 code ."

bias := GsMethod instSize .
posIp := anIp abs .
(isQuick _and:[ numIpSteps > 50]) ifTrue:[
  aStep := (debugInfo at: (offset + numIpSteps - 50)) + bias .
  posIp < aStep ifTrue:[ ^ nil ].
  ].
j := numIpSteps.
[j >= 1] whileTrue:[
  aStep := (debugInfo at: (offset + j )) + bias .
  aStep <= posIp ifTrue:[ 
     aStep == posIp ifTrue:[ ^ j ].
     ^ j + 1 .
     ] .
  j := j - 1 .
  ].
^ 1 .
%

category: 'Debugging Support'
method: GsMethod
_previousStepPointForIp: anIp quick: isQuick

"Returns the offset in the ipSteps Array of the receiver which represents
 the step point preceding the the given instruction pointer offset.

 The anIp argument is a zero-based offset relative to first named instance
 variable in the receiver."

"This method is useful when doing low-level debugging of the virtual machine."

| numIpSteps aStep offset bias posIp |
numIpSteps := self _numIpSteps .
offset := self _numArgsAndTemps + self _debugInfoHeaderSize .

"search forwards.
 steps in debugInfo are zero based relative to first instruction in portable
 code ."

bias := GsMethod instSize .
posIp := anIp abs .
(isQuick _and:[ numIpSteps > 50]) ifTrue:[
  aStep := (debugInfo at: (offset + 50 )) + bias .
  posIp > aStep ifTrue:[ ^ nil ].
  ].

1 to: numIpSteps do:[ :j |
  aStep := (debugInfo at: (offset + j )) + bias .
  aStep >= posIp ifTrue:[ 
     j > 1 ifTrue:[ ^ j - 1 ].
     ^ j 
     ] .
  ].
^ numIpSteps 
%

category: 'Debugging Support'
method: GsMethod
_stepPointForIp: ipOffset level: aLevel quick: isQuick

""
"ipOffset is zero-based relative to first named instance variable."

aLevel == 1 ifTrue:[  "top of stack"
   ^ self _nextStepPointForIp: ipOffset quick: isQuick 
    ]
 ifFalse:[
   ^ self _previousStepPointForIp: ipOffset quick: isQuick 
    ]
%

category: 'Debugging Support'
method: GsMethod
_sourceOffsetOfSendAt: instrOffset 

"Returns the source offset of the step point for the send using the selector
 found at instrOffset.

 The instrOffset argument is one-based relative to first indexable instance
 variable."

| ipOffset stepPoint |

ipOffset := instrOffset + self class instSize "convert to zero-based" .
stepPoint := self _previousStepPointForIp: ipOffset quick: false .
^ self _sourceOffsetsAt: stepPoint 
%

category: 'Reporting'
method: GsMethod
_sourceOffsetOfFirstSendOf: aSymbol

"Returns the source offset of the step point for the first send in the receiver
 that sends aSymbol.  If the receiver is not a sender of aSymbol, or if aSymbol
 is not a Symbol, returns nil."
 
1 to: literalsOffset - 1 do:[:j |
  (self at: j) == aSymbol ifTrue:[ 
     ^ self _sourceOffsetOfSendAt: j .
     ].
  ].
^ nil
%

category: 'Debugging Support'
method: GsMethod
_ipForStepPoint: aStepPoint

"Return zero-based offset of instruction relative to the first indexable
 instance variable in the portable code."

| offset aStep |

aStepPoint == 0 ifTrue:[ ^ 0 "method entry"] .
aStep := aStepPoint abs .
aStepPoint > self _numIpSteps ifTrue:[ ^ nil ].

offset := self _numArgsAndTemps + self _debugInfoHeaderSize .
^ debugInfo at: (offset + aStepPoint)
%

category: 'Debugging Support'
method: GsMethod
setBreakAtStepPoint: aStepPoint

"Set method breakpoint at specified step point."

| ip |
ip := self _ipForStepPoint: aStepPoint abs .
ip == nil ifTrue:[ ^ nil ].
self _setBreakAtIp: ip operation: 0
%

! edits to fix 31953
category: 'Debugging Support'
classmethod: GsMethod
_deleteBreakNumber: aNumber 

"Delete the breakpoint listed with number aNumber in the result of
 GsMethod (C) | _breakReport:."

"Used by Topaz"

| reportArray |
reportArray := (self _breakReport: true ) at: 2 .

1 to: reportArray size by: 5 do:[:j|
  (reportArray at: j) = aNumber ifTrue:[  | aMethod stepPoint |
    aMethod := reportArray at: j + 4 .
    stepPoint := reportArray at: j + 3 .
    aMethod clearBreakAtStepPoint: stepPoint .
    ^ true
    ].
  ].
^ false
%

category: 'Debugging Support'
classmethod: GsMethod
_disableBreakNumber: aNumber 

"disable the breakpoint listed with number aNumber in the result of
 GsMethod (C) | _breakReport:."

"Used by Topaz"

| reportArray |
reportArray := (self _breakReport: true ) at: 2 .

1 to: reportArray size by: 5 do:[:j|
  (reportArray at: j) = aNumber ifTrue:[  | aMethod stepPoint |
    aMethod := reportArray at: j + 4 .
    stepPoint := reportArray at: j + 3 .
    aMethod disableBreakAtStepPoint: stepPoint .
    ^ true
    ].
  ].
^ false
%

category: 'Debugging Support'
classmethod: GsMethod
_enableBreakNumber: aNumber 

"Enable the breakpoint listed with number aNumber in the result of
 GsMethod (C) | _breakReport:."
 
"Used by Topaz"

| reportArray |
reportArray := (self _breakReport: true ) at: 2 .

1 to: reportArray size by: 5 do:[:j| 
  (reportArray at: j) = aNumber ifTrue:[ | aMethod stepPoint |
    aMethod := reportArray at: j + 4 .
    stepPoint := reportArray at: j + 3 .
    aMethod setBreakAtStepPoint: stepPoint .
    ^ true
    ].
  ].
^ false
%

category: 'Debugging Support'
classmethod: GsMethod
_enableAllBreaks

"Enable all breakpoints listed in the result of GsMethod (C) | _breakReport:."

| reportArray |
reportArray := (self _breakReport: true ) at: 2 .

1 to: reportArray size by: 5 do:[:j| | aMethod stepPoint |
  aMethod := reportArray at: j + 4 .
  stepPoint := reportArray at: j + 3 .
  aMethod setBreakAtStepPoint: stepPoint .
  ].
%

category: 'Debugging Support'
classmethod: GsMethod
_disableAllBreaks

"Disable all breakpoints listed in the result of GsMethod (C) | _breakReport:."

| reportArray |
reportArray := (self _breakReport: true ) at: 2 .

1 to: reportArray size by: 5 do:[:j| | aMethod stepPoint |
  aMethod := reportArray at: j + 4 .
  stepPoint := reportArray at: j + 3 .
  aMethod disableBreakAtStepPoint: stepPoint .
  ].
%

category: 'Debugging Support'
classmethod: GsMethod
_deleteAllBreaks

"Delete all breakpoints listed in the result of GsMethod (C) | _breakReport:."

| reportArray |
reportArray := (self _breakReport: true ) at: 2 .

1 to: reportArray size by: 5 do:[:j| |aMethod stepPoint |
  aMethod := reportArray at: j + 4 .
  stepPoint := reportArray at: j + 3 .
  aMethod clearBreakAtStepPoint: stepPoint .
  ].
%

category: 'Debugging Support'
classmethod: GsMethod
clearBreakInClass: aClass selector: aSelector stepPoint: aStepPoint

"Clear the breakpoint at aStepPoint in method aSelector of class aClass."

(aClass compiledMethodAt: aSelector) clearBreakAtStepPoint: aStepPoint
%

category: 'Debugging Support'
classmethod: GsMethod
enableBreakInClass: aClass selector: aSelector stepPoint: aStepPoint

"Set or reenable the breakpoint previously set at aStepPoint in method
 aSelector of class aClass."

(aClass compiledMethodAt: aSelector) setBreakAtStepPoint: aStepPoint
%

category: 'Debugging Support'
classmethod: GsMethod
disableBreakInClass: aClass selector: aSelector stepPoint: aStepPoint

"Disable the breakpoint previously set at aStepPoint in method aSelector of
 class aClass."

(aClass compiledMethodAt: aSelector) disableBreakAtStepPoint: aStepPoint 
%

category: 'Debugging Support'
method: GsMethod
clearBreakAtStepPoint: aStepPoint

"Clear method breakpoint at specified step point."

| ip |
ip := self _ipForStepPoint: aStepPoint abs .
ip == nil ifTrue:[ ^ nil ].
self _setBreakAtIp: ip operation: 2
%

category: 'Debugging Support'
method: GsMethod
disableBreakAtStepPoint: aStepPoint

"Disable method breakpoint at specified step point."

| ip |
ip := self _ipForStepPoint: aStepPoint abs .
ip == nil ifTrue:[ ^ nil ].
self _setBreakAtIp: ip operation: 4
%

category: 'Debugging Support'
method: GsMethod
clearAllBreaks

"Clear all method breakpoints in the receiver."

self _setBreakAtIp: -1 operation: 2
%

category: 'Debugging Support'
classmethod: GsMethod
clearAllBreaks

"Clear all method breakpoints that have been set in any methods."

self _setBreakAtIp: -1 operation: 2
%

category: 'Debugging Support'
method: GsMethod
disableAllBreaks

"Disable all method breakpoints in the receiver."

self _setBreakAtIp: -1 operation: 4
%

category: 'Debugging Support'
method: GsMethod
_sendCount: anIp

"This method returns the number of arguments (excluding receiver)
 associated with the message send at this offset."

self pause "not implemented yet"
%

! at:put: allowed, protected by invariance of methods.
! size: now allowed.

category: 'Accessing'
method: GsMethod
_inClass

"Returns the class in which this method was compiled."

^ inClass
%

category: 'Accessing'
method: GsMethod
_nArgs

"Returns the number of arguments expected by the method."

^ numArgs
%

category: 'Accessing'
method: GsMethod
_selector

"Returns the value of the instance variable named selector."

^ selector
%

category: 'Accessing'
method: GsMethod
_sourceString

"Returns the value of the instance variable sourceString."

^ sourceString
%

category: 'Clustering'
method: GsMethod
clusterDepthFirst

"This method clusters the receiver, its bytecodes, its selector pool, and its
 selector in depth-first order.  Returns true if the receiver has already been
 clustered during the current transaction; returns false otherwise."

| savedBucket systm |

systm := System .
savedBucket := systm clusterBucket.
systm clusterBucket: 6.  "kernel miscellany bucket"
debugInfo cluster.
sourceString cluster.
systm clusterBucket: savedBucket.

self cluster
ifTrue: [ ^ true ]
ifFalse: [
  1 + literalsOffset to: self size do:[:j | | aLiteral |
    aLiteral := self at: j .
    aLiteral _isSymbol ifFalse:[
      (aLiteral _class ~~ SymbolAssociation _and:[ systm canWrite: aLiteral ]) ifTrue:[
         aLiteral clusterDepthFirst 
      ].
    ].
  ].
].
^ false
%

category: 'Copying'
method: GsMethod
copy

"Disallowed.  You may not create new instances of GsMethod."

self shouldNotImplement: #copy
%

category: 'Private'
method: GsMethod
_forceNative

"Forces a method to native code. Not supported in this release"

<primitive: 457>

^ self _primitiveFailed: #_forceNative:
%

category: 'Private'
method: GsMethod
_forcePortable

"Forces a method to portable code."

<primitive: 458>

^ self _primitiveFailed: #_forceNative:
%

category: 'Private for Class Modification'
method: GsMethod
_copyForRecompilation

""
self _validatePrivilege.
^ super copy
%

category: 'Private for Class Modification'
method: GsMethod
_inClass: aClass

"for use only by _copyToForceRecompilation"

self _validatePrivilege.

inClass := aClass 
%

! added send of immediateInvariant with fix 32811 
category: 'Private for Class Modification'
method: GsMethod
_copyToForceRecompilation

"Returns a copy of the receiver, with bytecodes that will force
 recompilation of the receiver prior to subsequent execution."

| newMethod |
self _validatePrivilege.
newMethod := (GsMethod compiledMethodAt: #_methodNeedingRecompilation)
                _copyForRecompilation .
newMethod _sourceString: self _sourceString .
newMethod _inClass: self _inClass .
newMethod immediateInvariant . "required to pass assertions in object manager"
^ newMethod
%

category: 'Error Handling'
method: GsMethod
_methodNeedingRecompilation

"Generate an error for a method that needs to be recompiled.

 During schema modification, this method is copied, 
 the sourceString in the copy replaced with the sourceString
 of a method needing recompilation, and the copy then installed
 in the modified class' method dictionary as the value for the
 selector needing recompilation.  See also _copyToForceRecompilation . "

| srcPrefix prefixSize thisMeth |
thisMeth := GsProcess _methodInFrameContents:(GsProcess _frameContentsAt:1).
prefixSize := thisMeth sourceString size min: 40 .
srcPrefix := thisMeth sourceString copyFrom:1 to: prefixSize .
srcPrefix addAll: '...' .
self _error: #rtErrUncompiledMethod args:#[ srcPrefix , thisMeth inClass ]. 
self _uncontinuableError
%

category: 'Private for Class Modification'
method: GsMethod
_sourceString: anObj

"Private."

self _validatePrivilege.
sourceString := anObj
%

category: 'Accessing'
method: GsMethod
_stackBase

"Private."

self pause "not implemented yet"
%

category: 'Accessing'
method: GsMethod
sourceString

"Returns a CharacterCollection that contains the source code of the receiver."

^ sourceString
%

category: 'Accessing'
method: GsMethod
literals

"Returns an Array containing the literal pool of the receiver."

| y |

y := Array new.
literalsOffset to: self size do: [:i |
  y add: (self at: i)
  ].
^y
%

category: 'Stripping Sources'
method: GsMethod
removeAllSourceButFirstComment

"Installs a new source string for the receiver so that only the method signature
 and the first comment (if it exists) are left.  For use in stripping a method
 in place in GemStone.  Bypasses the invariance of the receiver."

self _validatePrivilege.
self _unsafeAt: 8 put: self _sourceToFirstComment
%

category: 'Stripping Sources'
method: GsMethod
emptySource

"Returns nil in place of the source string.  The #emptySource selector may be
 used as an argument to the stripWith: keyword of the method
 GsMethod>>decompileForCategory:classRef:stripWith:classMethod:, where it causes
 the string 'source not available...' to be used as the source string when
 reloading the decompiled method."

^ nil 
%

category: 'Stripping Sources'
method: GsMethod
fullSource

"Returns the complete source string.  The #fullSource selector may be used as an
 argument to the stripWith: keyword of the method
 GsMethod>>decompileForCategory:classRef:stripWith:classMethod:."

^ sourceString
%

category: 'Stripping Sources'
method: GsMethod
sourceToFirstComment

"Returns a new source string for the receiver that contains only the method
 signature and the first comment (if it exists).  Does not modify the
 receiver.  The #sourceToFirstComment selector may be used as an argument to
 the stripWith: keyword of the method
 GsMethod>>decompileForCategory:classRef:stripWith:classMethod:."

| i tmpString sz |

i := 0.
sz := sourceString size.
(selector occurrencesOf: $:) timesRepeat: [
    i := sourceString indexOf: $: startingAt: i + 1.
].
" check if it's a binary selector (it has an argument but no colons) "
(i == 0 _and: [ numArgs == 1 ])
  ifTrue: [ i := selector size ].
" i is the offset of the last colon in the signature, or the last character
of a binary selector, or zero "
i := i + 1.

" scan past any white space "
[ (sourceString at: i) isSeparator ] whileTrue: [ i := i + 1 ].

" scan past any non-white space to get to end of argument to last keyword"
[ (sourceString at: i) isSeparator not ] whileTrue: [ i := i + 1 ].
" i is now the offset of the first white space past the signature "

" scan past any white space "
[ i <= sz _and: [ (sourceString at: i) isSeparator ] ] whileTrue: [ i := i + 1 ].
" i is now the offset of the initial comment or first line of code "

i > sz
  ifTrue: [ ^ sourceString copy ].

" if i is the offset of the initial comment, jump to the end of the comment "
(sourceString at: i) == $"
  ifTrue: [ i := sourceString indexOf: $" startingAt: i + 1 ]
  ifFalse: [ i := i - 1 ].

" create the string to replace the original source with "
tmpString := String new: i .
sourceString copyFrom: 1 to: i into: tmpString startingAt: 1.

tmpString addAll: '

< source code not available >'.

^ tmpString
%
category: 'Stripping Sources'
method: GsMethod
isSourceStripped

    "Answer true if the source code has been stripped for the
    receiver. Otherwise answer false. Determine this by asking the
    class if the method's selector is one of the known stripped
    selectors."

    ^inClass isMeta
        ifTrue:  [(inClass thisClass _strippedMethodSelectors at: 2) includesIdentical: selector]
        ifFalse: [(inClass _strippedMethodSelectors at: 1) includesIdentical: selector]
%
category: 'Decompiling without Sources'
method: GsMethod
decompileForCategory: aCategory
classRef: classRefExpression
stripWith: sourceStripSelector
classMethod: isMeta

"Decompiles the receiver to produce a Topaz run command that will
 regenerate it."

| LF result theClass |

LF := Character lf .

isMeta ifTrue:[ theClass := inClass class ]
      ifFalse:[ theClass := inClass ] .

result := String withAll:'expectvalue %GsMethod' .
result add: LF .
result addAll: 'run ' ; add: LF .

result
  addAll: 'GsMethod ' ;
  addAll: ' _newInClass: ' ;
      add: '( ' ; addAll: classRefExpression ; addAll: ' )' ; add: LF ;
  addAll: ' classMethod: ' ; addAll: isMeta _asSource ; add: LF ;
  addAll: ' category: ' ; addAll: aCategory _asSource ; add: LF ;
  addAll: ' selector: ' ; addAll: selector _asSource ; add: LF ;
  addAll: ' source: ' ;
     addAll: (self perform: sourceStripSelector) _asSource ;
     add: LF ;

  addAll: ' nargs: ' ; addAll: numArgs asString ; 
  addAll: ' pcodeInstr: ' ; addAll: self _instructionsString ; add: LF ;
   " _instructionsString result is of form '  #() blockLiterals: #() '  "
  addAll: ' literals: ' ; addAll: self _litArrayString.
  "debugInfo will be regenerated as empty "

result add: LF .
result add: $% .
result add: LF .
^ result
%

category: 'Backward Compatibility'
method: GsMethod
_decompileForCategory: aCategory
classRef: classRefExpression
stripWith: sourceStripSelector
classMethod: isMeta

""
^ self decompileForCategory: aCategory
   classRef: classRefExpression
   stripWith: sourceStripSelector
   classMethod: isMeta
%

category: 'Backward Compatibility'
method: GsMethod
_removeAllSourceButFirstComment

""
^ self removeAllSourceButFirstComment
%

category: 'Backward Compatibility'
method: GsMethod
_emptySource

""

^ self emptySource
%

category: 'Backward Compatibility'
method: GsMethod
_fullSource

""

^ self fullSource
%

category: 'Backward Compatibility'
method: GsMethod
_sourceToFirstComment

""
^ self sourceToFirstComment
%


! delete _new

category: 'Storing and Loading'
method: GsMethod
writeTo: aPassiveObject

"Instances of GsMethod cannot be converted to passive form.  This method writes
 nil to aPassiveObject and stops GemStone Smalltalk execution with a notifier."

aPassiveObject writeObject: nil.
self _error: #rtErrAttemptToPassivateInvalidObject.
%

category: 'Debugging Support'
method: GsMethod
_setBreakAtIp: ipOffset operation: opcode

"Set breakpoint at specified ipOffset.  ipOffset is zero-based relative
 to first indexable instance variable of receiver.

 opcode  action
   0	 set or reenable method breakpoint
   1     set single step breakpoint (takes precedence over method break)
   2     delete method breakpoint or disabled method breakpoint
   3     delete single step breakpoint
   4     disable method breakpoint, no action if breakpoint not set

  If ipOffset == -1, then apply the action to all step points within the
  method."

<primitive: 190>
self _primitiveFailed: #_setBreakAtIp:operation: .
%

category: 'Debugging Support'
classmethod: GsMethod
_setBreakAtIp: ipOffset operation: opcode

"Apply the following action to all methods that contain breakpoints.

 opcode  action
   2     delete all method breakpoints and disabled method breakpoints
   3     delete single step breakpoints

 Other opcodes that are defined for the instance method version of this
 primitive are illegal when used as a class method.

 ipOffset must be == -1 . "

<primitive: 190>
self _primitiveFailed: #_setBreakAtIp:operation: .
%

category: 'Debugging Support'
method: GsMethod
_setAllStepBreaks

""

self _setBreakAtIp: -1 operation: 1
%

category: 'Debugging Support'
method: GsMethod
_clearAllStepBreaks

""

self _setBreakAtIp: -1 operation: 3
%

! changed result to include <gsMethod> for each breakpoint, to fix 31953
! result of this method also used by GBS , be careful with changes
category: 'Debugging Support'
classmethod: GsMethod
_breakReport: withLineNumbersBool

"Returns an Array describing all method breakpoints currently set.
 The Array contains a string report of all breakpoints and an Array
 of 5 elements per breakpoint.  For each breakpoint,
 stepPoint < 0 means that the breakpoint is currently disabled.

 The Array is #[ <break report string as displayed in topaz, one line
		  per breakpoint>,
                 #[ <breakNumber>, <class> , <selector>, <stepPoint>, <gsMethod>,
                     ...
                    <breakNumber>, <class> , <selector>, <stepPoint>, <gsMethod>
                  ]
               ]

 All methods currently in-memory are checked for breakpoints.

 If a method is no longer in the current transactional view of
 the method dictionary of its class, any breakpoints in the method
 are deleted and not reported.

 Note that if a method has breakpoints set, it will be kept in-memory
 until those breakpoints are cleared.
"

| allBreaks allBreaksRaw allBreaksToSort sortedBreaks
  report descriptors |

allBreaksRaw := GsMethod _allMethodBreakpoints .
allBreaksRaw size == 0 ifTrue:[ ^ #[ 'No breaks set' + Character lf , #[]] ] .

allBreaks := Array new .
allBreaksRaw do:[: methodBreakArray | 
  1 to: methodBreakArray size by: 3 do:[ :j |
    allBreaks add: #[  (methodBreakArray at:j), (methodBreakArray at:j + 1),
		       (methodBreakArray at:j + 2) ].
    ].
  ].

allBreaksToSort := IdentitySet new .
allBreaks do:[ :aBreakArray |
  allBreaksToSort add: 
    (Association newWithKey: (aBreakArray at:1 "breakNumber")
                 value: aBreakArray ) .
  ].
sortedBreaks := 
  (allBreaksToSort sortAscending: #key ) collect:[:assoc | assoc value] .

report := String new .
descriptors := Array new .
sortedBreaks do:[:aBreakArray| 
  | breakNumber aMethod breakIp theClass selector className 
    stepPoint |
  breakNumber := aBreakArray at: 1 .
  aMethod := aBreakArray at: 2 .
  breakIp := aBreakArray at: 3 . 

  theClass := aMethod inClass .
  selector := aMethod selector .
  className := theClass name .
  stepPoint := aMethod _nextStepPointForIp: breakIp quick: false .
  withLineNumbersBool ifTrue:[ 
    report addAll: breakNumber asString; addAll:': ' .
      ] .
  report addAll: className; addAll: ' >> ' ;
	 addAll: selector;  addAll: ' @ ' ;
	 addAll: stepPoint asString .
  breakIp < 0 ifTrue:[ stepPoint := stepPoint negated .
 			report addAll: ' (disabled)' ].
  report add: Character lf .

  descriptors add: breakNumber; add: theClass ; add: selector; add: stepPoint;
		add: aMethod .
  ].
^ #[ report, descriptors ]
%

category: 'Accessing'
method: GsMethod
numArgs

"Returns the value of the instance variable named numArgs."

^ numArgs
%

category: 'Accessing'
method: GsMethod
literalsOffset

"Returns the value of the instance variable named literalsOffset."

^ literalsOffset
%

category: 'Accessing'
method: GsMethod
inClass

"Returns the class in which the receiver was compiled."

selector == nil ifTrue:[ ^ nil "anonymous method, as from GciExecute" ].
^ inClass 
%

category: 'Accessing'
method: GsMethod
invocationCount

"If method profiling has been enabled,
 returns number of invocations of this method, otherwise probably returns zero.
 Detailed method profiling behavior subject to change in future release.
 "

^ invocationCount bitShift: -8 
%

! see bugmail for 35004  for more details on conversion of methods
category: 'Accessing'
method: GsMethod
methodCompilerVersion

"Returns the method compiler version.
 2 indicates a method compiled by Gs64 v2.0 or above method compiler,
 1 indicates a method compiled in a previous version and processed by
   repository conversion.

 Any other value indicates a method from a previous version that
 did not get converted.  However the faulting-in of such a method
 will cause an error 2261, so normally you can't send this message
 to such unconverted methods."

"extract bottom 8 bits as a unsigned value"
^ invocationCount bitAnd: 16rFF 
%

category: 'Accessing'
method: GsMethod
selector

"Returns the value of the instance variable named selector."

^ selector
%

category: 'Decompiling without Sources'
method: GsMethod
_instructionsString

"Returns a string representation of the instructions Array."

 | result LF instr blockLiterals |
result := String new .
LF := Character lf .
result addAll: '#( ' ;
       addAll: numSends asString ; add: $  .

blockLiterals := Array new .
1 to: literalsOffset do:[:j|
  instr := self at: j .
  instr _isSmallInteger
    ifTrue:[ result addAll: instr asString ; add: $  . ]
    ifFalse:[ 
      instr == nil 
        ifTrue:[ result addAll: 'nil ' ]
        ifFalse:[
          (instr _class == Symbol)
            ifTrue:[ result addAll: instr _asSource ; add: $  . ]
            ifFalse:[
              (instr isKindOf: ExecutableBlock) 
                ifTrue:[ result addAll: 'nil ' .
                         blockLiterals add: j; add: instr 
                       ]
                ifFalse:[ self _halt: 'GsMethod object is corrupt' ].
    ]]].
  j \\ 10 == 0 ifTrue:[ result add: LF ; addAll: '   ' ].
  ].
result addAll:' ) ' .
blockLiterals size > 0 
  ifTrue:[
    result add: LF ; addAll:'blockLiterals: #[ ' .
    1 to: blockLiterals size by: 2 do:[:j|
      result add: (blockLiterals at: j) asString "in-line literal offset"; 
             addAll: ' , ' ; 
             addAll: (blockLiterals at: j + 1) _asSource ;
             addAll: ' , ' ; add: LF . 
      ].
    result size: (result size - 3) . "strip last ', <LF>' "
    result addAll:' ] '; add: LF .
    ]
  ifFalse:[ result addAll:' blockLiterals:#() ';  add: LF  
    ].
^ result
%

category: 'Decompiling without Sources'
method: GsMethod
_litArrayString

"Returns a String containing an Array-builder production describing the literal
 pool of the receiver."

| result lastSize aLit j literalsSize |
literalsSize := self size - literalsOffset .
literalsSize <= 0 ifTrue:[ ^ ' #() ' ] .

result := String new .
result addAll: '#[ ' .
lastSize := result size .
j := 1 + literalsOffset .
literalsSize timesRepeat:[
  aLit := self at: j .
  (aLit isKindOf: SymbolAssociation)
    ifTrue:[ 
       result addAll: true _asSource ; "flag next as key of a literal variable"
              addAll: ' , ' ; 
              addAll: aLit key _asSource.
       ]
    ifFalse:[
       "a block or other kind of literal"
       aLit == true ifTrue:[ self _halt:'true not expected as a literal' ].
       result addAll: aLit _asSource 
       ] .
  lastSize := result size .
  result addAll: ' ,' ; add: Character lf ; addAll: '   '.
  j := j + 1 .
  ].
result size: lastSize .  "remove the last $, "
result addAll:' ] ' .
^ result
%

category: 'Debugging Support'
method: GsMethod
_opcodeAtIsCallPrimitive: ipOffset 

"ipOffset is obtained from result of GsProcess | __frameContentsAt:.
 ipOffset may be negative if denoting a stack breakpoint
 "

^ ((self _opcodeKindAt: ipOffset abs ) bitAnd: 16r1) ~~ 0
%

category: 'Private'
method: GsMethod
_opcodeKindAt: ipOffset

"primitive will fail if ipOffset is out of range .
 argument ipOffset is zero based .

 result contains these bits
   16r1 if instruction at ipOffset is a call to a primitive,
   16r2 if instruction requires protected mode
"

<primitive: 189> 
self _primitiveFailed: #_opcodeKindAt: .
%

category: 'Private'
method: GsMethod
_isProtected

^ ((self _opcodeKindAt: self class instSize ) bitAnd: 16r2) ~~ 0
%

category: 'Debugging Support'
method: GsMethod
_allBreakpoints

"Returns an Array of the form

       #[ breakpointNumber1 , self, ipOffset1,
          ...
          breakpointNumberN , self, ipOffsetN,
        ]

 The ipOffsets are zero-based relative to first named instance variable in
 the portable code.  Negative ipOffsets denote disabled breakpoints.

 Single step breakpoints managed by GciStep() are not reported.
 Returns nil if no method breakpoints set in the receiver.

 If the receiver is no longer in the current transactional view of
 the method dictionary of its class, any breakpoints in the receiver
 are deleted by this primitive and the result will be nil. In this
 case single step breakpoints will also be cleared. "


<primitive: 193>
self _primitiveFailed: #_allBreakpoints
%

category: 'Debugging Support'
method: GsMethod
_breakpointIpOffsets

"Returns an IdentitySet of ipOffsets for method breakpoints currently set
 in the receiver.  The ipOffsets are one-based relative to first instruction
 the portable code.  Negative ipOffsets denote disabled breakpoints.

 Returns nil if no method breakpoints set in the receiver.
 Single step breakpoints managed by GciStep() are not reported.

 If the receiver is no longer in the current transactional view of
 the method dictionary of its class, any breakpoints in the receiver
 are deleted by this primitive and the result will be nil. In this
 case single step breakpoints will also be cleared. "


| result breakArray bias anIp |
(breakArray := self _allBreakpoints ) == nil ifTrue:[ ^ nil ].
result := IdentitySet new .
bias := self class instSize  - 1.
1 to: breakArray size by: 3 do:[ :j |
  anIp := breakArray at: j + 2 .
  anIp < 0 ifTrue:[ anIp := (anIp negated - bias) negated ]
          ifFalse:[ anIp := anIp - bias ]. 
  result add: anIp .
  ].
^ result
%

category: 'Debugging Support'
classmethod: GsMethod
_allMethodBreakpoints

"Returns an Array of Arrays of the form

  #[ #[ <breakpointNumber>, <aGsMethod1>, <ipOffset>,
        ...
        <breakpointNumber>, <aGsMethod1>, <ipOffset>],
      ...
      #[ <breakpointNumber>, <aGsMethodN>, <ipOffset>
         ...
       ]
   ]

 The interior Arrays are as described for GsMethod | _allBreakpoints.

 If a method is no longer in the current transactional view of
 the method dictionary of its class, any breakpoints in the method
 are deleted by this primitive and not included in the result.

 If no breakpoints are set, returns an Array of size zero." 

<primitive: 194>
self _primitiveFailed: #_allMethodBreakpoints
%

category: 'Reporting'
method: GsMethod
isSenderOf: aSymbol

"Returns true if the receiver sends the message aSymbol.  Returns false
 otherwise."
 
1 to: literalsOffset - 1 do:[:j |
  (self at: j) == aSymbol ifTrue:[ ^ true ].
  ].
^ false
%

! delete duplicate


category: 'Reporting'
method: GsMethod
_selectorPool

"Return a SymbolSet containing the selectors sent by the receiver."

| instr result |

result := SymbolSet new .
1 to: literalsOffset - 1 do:[:j |
  (instr := self at: j) _isSmallInteger ifFalse:[
     instr _class == Symbol ifTrue:[ result add: instr ].
     ].
  ].
^ result
%

category: 'Reporting'
method: GsMethod
_classAndSelectorNameWidth: anInt 

"Return a String of the form className | selector with the className substring
 padded to width anInt."

"Used by ProfMonitor"

|text sel|
selector == nil 
  ifTrue:[sel := 'unbound method']
  ifFalse:[ sel := selector].
inClass == nil 
  ifTrue: [ text := String withAll: 'executed code'.  ]
  ifFalse: [ text := String withAll: inClass name  ].
text width: anInt; addAll: ' >> '; addAll: sel .
^ text
%

category: 'Debugging Support'
method: GsMethod
_recompileWithSource: aString

"Recompiles the receiver using the new source string aString.  If the
 compilation has no errors, installs the new method in the receiver's class's
 method dictionary.  If the new method has the same selector as the receiver,
 returns true.  If the new method has a different selector than the receiver,
 returns false so the debugger can warn the user.

 If there are compilation errors, returns an Array of error descriptors as
 described for the Behavior | compileMethod:dictionaries:category: method, and
 does not install a new method.

 Raises an error and does not recompile if the receiver is an anonymous method."

| newMethod |
self _validatePrivilege.
inClass == nil ifTrue:[
  self _halt: 'Attempt to recompile anonymous method from a debugger.' 
  ].
newMethod := inClass compileMethod: aString 
                    dictionaries: System myUserProfile symbolList
	             category: (inClass categoryOfSelector: selector) 
		     intoMethodDict: nil intoCategories: nil
		     intoPragmas: nil .

newMethod _class == GsMethod ifTrue:[ "compile succeeded"
  "Return true if new method has same selector, false otherwise. Let
   debugger give appropriate messages to the user."

  ^ newMethod selector == selector 
  ].
^ newMethod "return error info"
%

category: 'Repository Conversion'
method: GsMethod
_modifySourceWith: modifyInfo oldSource: oldSource

"Private.  Processes the modification info returned by primitive 228 and
 constructs a new source string for the receiver."

| list limit oldOffset j newSource newName oldName nameDone anOffset |

self _validatePrivilege.
"create a sorted collection of elements of the form
   #[ offset in old source, old name, new name ],
 sorted in ascending order of offset."
list := SortedCollection sortBlock: [:x :y | (x at: 1) < (y at: 1) ] .

j := 1.
limit := modifyInfo size .
modifyInfo at: (limit + 1) put: nil.
newName := modifyInfo at: 2 .
[ j <= limit] whileTrue:[
  oldName := modifyInfo at: j .
  newName := modifyInfo at: j + 1 .
  j := j + 2 .
  nameDone := false.
  [ nameDone ] whileFalse:[
    anOffset := modifyInfo at: j .
    anOffset _isInteger ifTrue:[ 
      list add: #[ anOffset, oldName, newName ].
      j := j + 1 .
      ]
    ifFalse:[ nameDone := true ].
    ].
  ].
newSource := oldSource class new .
oldOffset := 1 .
1 to: list size do:[:j| | listElement wordStart | 
  listElement := list at: j .
  wordStart := listElement at: 1.
  newSource addAll: (oldSource copyFrom: oldOffset to: wordStart - 1 ) .
  oldOffset := wordStart + (listElement at: 2) size . "skip old name"
  newSource addAll: (listElement at: 3).  "append new name"
  ].

(oldOffset <= oldSource size) 
  "There may not be any source code after oldOffset if the last word in
   the source code was transformed. Hence this check."
  ifTrue: [
    newSource addAll: (oldSource copyFrom: oldOffset to: (oldSource size)).
    ].

newSource immediateInvariant.

debugInfo _unsafeAt:(debugInfo size + 1) put: oldSource.
self _unsafeAt: (self _class _ivOffsetOf: #sourceString) put: newSource.
%

category: 'Disassembly'
method: GsMethod
_opcodeInfo: instrWord

"instrWord must be a SmallInteger from the body of A GsMethod, containing
 a valid opcode.  If the instrWord represents a currently installed breakpoint,
 the result is for the instruction that the breakpoint is replacing.

 returns a SmallInteger with the following bit fields 
           16rFF  instruction size in words , including the opcode word and any
	  	  in-line literal words , an unsigned 8-bit int
       16rFFFF00  instVar offset for instVarAccess 
      16r1000000  boolean, 1 means opcode is an instVarAccess
      16r2000000  boolean, 1 means opcode is a pushBlock
   16rFFF0000000  opcode 
 "  
<primitive: 536>
self _primitiveFailed: #_opcodeInfo: .
^ 1
%

category: 'Disassembly'
method: GsMethod
instVarsAccessed

"return a Set of instVarNames that the method accesses."

| pc report  |

"virtual machine constants"
pc := 1 .
report := SymbolSet new .

"iterate over the instructions in the method. pc here is 1 based, 
 literalsOffset is zero based."
[pc <= literalsOffset ] whileTrue:[ | aWord info ivOffset |
  aWord := self at: pc .
  info := self _opcodeInfo: aWord .
  (info bitAnd: 16r1000000) ~~ 0 ifTrue:[
    "get zero-based instance variable offset"
    ivOffset := (info bitAnd: 16rFFFF00) bitShift: -8 .
    report add: (inClass _instVarNames at: (ivOffset + 1) ).
    ].
  "advance to the next instruction."
  pc := pc + (info bitAnd: 16rFF) .
  ].
^ report
%

category: 'Disassembly'
method: GsMethod
blockLiterals

"return an Array of Block Literals that the receiver contains,
 or nil if the reciever contains no block literals.
 literals of for select blocks are not included."
 
| pc blockLits |
 
"virtual machine constants"
pc := 1 .
 
"iterate over the instructions in the method. pc here is 1 based,
 literalsOffset is zero based."
[pc <= literalsOffset ] whileTrue:[ | aWord info |
  aWord := self at: pc .
  info := self _opcodeInfo: aWord .
  (info bitAnd: 16r2000000) ~~ 0 ifTrue:[
    blockLits == nil ifTrue:[ blockLits := Array new ].
    blockLits addLast: ( self at: pc + 1 ).  "a block literal"
    ].
 
  "advance to the next instruction."
  pc := pc + (info bitAnd: 16rFF)
  ].
^ blockLits
%

category: 'Disassembly'
method: GsMethod
hasBlockLiteralsOfCost: aBlockClass

"Return true if the receiver contains a block as costly as, or
 more costly than aBlockClass, return false otherwise.

 For the purposes of this analysis, the block classes are considered
 to have this hierarchy:
    ComplexVCBlock   cost == 3 .
      ComplexBlock   cost == 2 .
        SimpleBlock  cost == 1 .

 Note that the actual implementation hierarchy of the block classes is 
    ExecutableBlock
    ComplexBlock
      ComplexVCBlock
    SimpleBlock  "

| pc argCost |
 
"virtual machine constants"
pc := 1 .
argCost := aBlockClass _cost .
 
"iterate over the instructions in the method. pc here is 1 based,
 literalsOffset is zero based."
[pc <= literalsOffset ] whileTrue:[ | info aWord |
  aWord := self at: pc .
  info := self _opcodeInfo: aWord .
  (info bitAnd: 16r2000000) ~~ 0 ifTrue:[ | aBlockLit |
    aBlockLit :=  self at: pc + 1 .  "a block literal"
    aBlockLit _class _cost >= argCost ifTrue:[ ^ true ].    
    ].
 
  "advance to the next instruction."
  pc := pc + (info bitAnd: 16rFF)
  ].
^ false
%

category: 'CodeModification Override'
method: GsMethod
_at: anIndex put: aValue

self _validatePrivilege.
^ super _at: anIndex put: aValue
%

category: 'CodeModification Override'
method: GsMethod
_basicAt: anIndex put: aValue

self _validatePrivilege.
^ super _basicAt: anIndex put: aValue
%

category: 'CodeModification Override'
method: GsMethod
_primitiveAt: anIndex put: aValue

self _validatePrivilege.
^ super _primitiveAt: anIndex put: aValue
%

category: 'CodeModification Override'
method: GsMethod
_unsafeAt: anIndex put: aValue

self _validatePrivilege.
^ super _unsafeAt: anIndex put: aValue
%

category: 'CodeModification Override'
method: GsMethod
_validatePrivilege

System myUserProfile _validateCodeModificationPrivilege

%

! _finishConvertLargeMethod deleted

! primitives for static opcode usage analysis  implemented in intcodecache.c
category: 'Static opcode usage analysis'
classmethod: GsMethod
bcAnalyzeInit: threeByteSequences

 "malloc and initialize C data structures .
  optional arg  threeByteSequences, if not nil,
   is an array of arrays. 
     each inner array is array of 3 int values specifying 
     a 3-byte sequence that is to be counted.
  if threeByteSequences is nil, all 3-byte sequences are counted
 " 
	
<primitive: 583>
self _primitiveFailed: #bcAnalyzeInit
%

category: 'Static opcode usage analysis'
classmethod: GsMethod
bcAnalyzePrint

 "print report of static opcode usage statistics to stdout
  and free C data structures"
<primitive: 582>
self _primitiveFailed: #bcAnalyzePrint
%

category: 'Static opcode usage analysis'
method: GsMethod
bcAnalyze
  "call this for each GsMethod found by listInstances"
<primitive: 581>
self _primitiveFailed: #bcAnalyze
%

category: 'Static opcode usage analysis'
classmethod: GsMethod 
bcAnalyze: threeBcSequences
| insts meths |
self bcAnalyzeInit: threeBcSequences .
insts := SystemRepository listInstances:#[ GsMethod ].
meths := insts at: 1 .
1 to: meths size do:[:j |
  (meths at: j) bcAnalyze .
  ].
self bcAnalyzePrint .
%

category: 'Repository Conversion'
method: GsMethod
fixRefsAfterConversion

"Default method for fixing references LargePositiveInteger and 
 LargeNegativeInteger instances that can now be represented as
 a SmallInteger and Floats and SmallFloats which can now be represented
 as a SmallDouble."

|myClass|

(System _testIf: self isIn: 45)
	ifTrue:[^false]. "already fixed this one"
System _add: self to: 45.

self sourceString == nil
	ifTrue:[^false].
self inClass == nil
		ifTrue:[^false].

inClass compileMethod: self sourceString 
                    dictionaries: System myUserProfile symbolList
	             category: #RecompiledMethodsAfterConversion
		     intoMethodDict: nil intoCategories: nil
		     intoPragmas: nil .

^true
%

category: 'Pragmas'
method: GsMethod
pragmas
    self inClass == nil ifTrue: [ ^#() ].
    ^self inClass pragmasForMethod: self selector
%
