Smalltalk › Squeak › Squeak VM

VM Maker: GDB-bgs.1.mcz

_‹ Previous Topic Next Topic _›

Classic

List

Threaded

1 message

commits-2

VM Maker: GDB-bgs.1.mcz

Boris Shingarov uploaded a new version of GDB to project VM Maker:
http://source.squeak.org/VMMaker/GDB-bgs.1.mcz

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

Name: GDB-bgs.1
Author: bgs
Time: 12 April 2020, 7:54:25.444451 pm
UUID: 0eba5e72-c35a-4d8c-a192-489728067891
Ancestors:

Initial import of GDB Remote Client interface

==================== Snapshot ====================

SystemOrganization addCategory: #'GDB-RSP'!
SystemOrganization addCategory: #'GDB-TAJ'!
SystemOrganization addCategory: #'GDB-UI'!
SystemOrganization addCategory: #'GDB-Primitives'!
SystemOrganization addCategory: #'GDB-Tests'!
SystemOrganization addCategory: #'GDB-Doodles'!
SystemOrganization addCategory: #'GDB-Cog'!

BorderedMorph subclass: #GdbMTEngineMorph
instanceVariableNames: 'gdb regs'
classVariableNames: ''
poolDictionaries: ''
category: 'GDB-UI'!

!GdbMTEngineMorph commentStamp: 'BorisShingarov 4/25/2016 13:39' prior: 0!
I add a 'Modtalk' tab to the GT Inspector.!

----- Method: GdbMTEngineMorph class>>on: (in category 'instance creation') -----
on: aGDB
^self new
gdb: aGDB;
yourself!

----- Method: GdbMTEngineMorph>>defaultBounds (in category 'as yet unclassified') -----
defaultBounds
"Answer the default bounds for the receiver."

^0 @ 0 corner: 500 @ 300!

----- Method: GdbMTEngineMorph>>drawCurrentBytecodeOn:fromHeight: (in category 'as yet unclassified') -----
drawCurrentBytecodeOn: clippedCanvas fromHeight: y
| bc |
bc := [ gdb currentBytecode printString ]
on: Error do: [ '???' ].
clippedCanvas
drawString: bc
at: (self bounds topLeft + (0 @ y))
font: (LogicalFont familyName: 'Bitmap DejaVu Sans' pointSize: 12)
color: Color black.
^y + 14!

----- Method: GdbMTEngineMorph>>drawCurrentFrameOn:fromHeight: (in category 'as yet unclassified') -----
drawCurrentFrameOn: clippedCanvas fromHeight: y
| fp |
fp := gdb getVRegister: #FP.
self drawFrame: fp withAllSendersOn: clippedCanvas fromHeight: y
!

----- Method: GdbMTEngineMorph>>drawCurrentInstructionOn:fromHeight: (in category 'as yet unclassified') -----
drawCurrentInstructionOn: clippedCanvas fromHeight: y
| pc nativeInstr |
pc := regs at: 'pc'.
nativeInstr := gdb currentInstruction.
clippedCanvas
drawString: nativeInstr printString
at: (self bounds topLeft + (0 @ y))
font: (LogicalFont familyName: 'Bitmap DejaVu Sans' pointSize: 12)
color: Color black.
^y + 14!

----- Method: GdbMTEngineMorph>>drawFrame:on:fromHeight: (in category 'as yet unclassified') -----
drawFrame: fp on: clippedCanvas fromHeight: y
| frame cm |
frame := MTRemoteStackFrame gdb: gdb pointer: fp.
cm := frame method.
clippedCanvas
drawString: cm selector symbol asString
at: (self bounds topLeft + (0 @ y))
font: (LogicalFont familyName: 'Bitmap DejaVu Sans' pointSize: 12)
color: Color black.
^y+20!

----- Method: GdbMTEngineMorph>>drawFrame:withAllSendersOn:fromHeight: (in category 'as yet unclassified') -----
drawFrame: fp withAllSendersOn: clippedCanvas fromHeight: y
| frame yy |
yy := self drawFrame: fp on: clippedCanvas fromHeight: y.
frame := MTRemoteStackFrame gdb: gdb pointer: fp.
frame .
^y+20
!

----- Method: GdbMTEngineMorph>>drawOn: (in category 'as yet unclassified') -----
drawOn: aCanvas
regs := gdb getRegisters.
aCanvas
clipBy: self bounds
during: [:clippedCanvas |
clippedCanvas
fillRectangle: self bounds
color: Color white.
self drawCurrentFrameOn: clippedCanvas fromHeight:
(self drawCurrentBytecodeOn: clippedCanvas fromHeight:
(self drawCurrentInstructionOn: clippedCanvas fromHeight:
(self drawVregsOn: clippedCanvas) + 15)) + 15
].
!

----- Method: GdbMTEngineMorph>>drawSPR:on:fromHeight: (in category 'as yet unclassified') -----
drawSPR: spr on: clippedCanvas fromHeight: y
clippedCanvas
drawString: spr, ' = ', (regs at: spr) printString
at: (self bounds topLeft + (0 @ y))
font: (LogicalFont familyName: 'Bitmap DejaVu Sans' pointSize: 12)
color: Color black.
^y + 14 !

----- Method: GdbMTEngineMorph>>drawSPRsOn:fromHeight: (in category 'as yet unclassified') -----
drawSPRsOn: clippedCanvas fromHeight: y
| yy |
yy := y.
#('pc' 'lr' 'cr' 'ctr' 'msr' 'xer') do: [ :spr |
self drawSPR: spr on: clippedCanvas fromHeight: yy.
yy := yy + 14.
].
^yy!

----- Method: GdbMTEngineMorph>>drawVRegHeaderOn: (in category 'as yet unclassified') -----
drawVRegHeaderOn: clippedCanvas
clippedCanvas
drawString: 'VRegs:'
at: self bounds topLeft
font: (LogicalFont familyName: 'Bitmap DejaVu Sans' pointSize: 14)
color: Color black.
^18 "BOGUS CODE"
!

----- Method: GdbMTEngineMorph>>drawVregsOn: (in category 'as yet unclassified') -----
drawVregsOn: clippedCanvas
| y |
y := self drawVRegHeaderOn: clippedCanvas.
TAJWriter registerMap keysAndValuesDo: [ :vReg :physReg |
| regName |
regName := physReg isInteger ifTrue: ['r', physReg printString]
ifFalse: [ physReg ].

clippedCanvas
drawString: vReg printString, ' = ', (regs at: regName) printString
at: (self bounds topLeft + (0 @ y))
font: (LogicalFont familyName: 'Bitmap DejaVu Sans' pointSize: 12)
color: Color black.
y := y + 14.
].
^y
!

----- Method: GdbMTEngineMorph>>gdb (in category 'accessing') -----
gdb
^ gdb!

----- Method: GdbMTEngineMorph>>gdb: (in category 'accessing') -----
gdb: anObject
gdb := anObject!

BorderedMorph subclass: #GdbRegistersMorph
instanceVariableNames: 'gdb regs'
classVariableNames: ''
poolDictionaries: ''
category: 'GDB-UI'!

!GdbRegistersMorph commentStamp: 'BorisShingarov 4/25/2016 13:39' prior: 0!
I add a 'Registers' tab to the GT Inspector.!

----- Method: GdbRegistersMorph class>>concreteClassFor: (in category 'instance creation') -----
concreteClassFor: aGDB
^Smalltalk classNamed: 'GdbRegistersMorph', aGDB processorDescription architectureName !

----- Method: GdbRegistersMorph class>>on: (in category 'instance creation') -----
on: aGDB
^(self concreteClassFor: aGDB) new
gdb: aGDB;
yourself!

----- Method: GdbRegistersMorph>>defaultBounds (in category 'drawing') -----
defaultBounds
"Answer the default bounds for the receiver."

^0 @ 0 corner: 500 @ 300!

----- Method: GdbRegistersMorph>>drawGPRHeaderOn: (in category 'drawing') -----
drawGPRHeaderOn: clippedCanvas
clippedCanvas
drawString: 'GPR:'
at: self bounds topLeft
font: (LogicalFont familyName: 'Bitmap DejaVu Sans' pointSize: 14)
color: Color black.
^18 "BOGUS CODE"
!

----- Method: GdbRegistersMorph>>drawGPRsOn: (in category 'drawing') -----
drawGPRsOn: clippedCanvas
| y |
y := self drawGPRHeaderOn: clippedCanvas.
0 to: 31 do: [ :r |
| regName |
regName := 'r', r printString.
clippedCanvas
drawString: regName, ' = ', (regs at: regName) printString
at: (self bounds topLeft + (0 @ y))
font: (LogicalFont familyName: 'Bitmap DejaVu Sans' pointSize: 12)
color: Color black.
y := y + 15.
].
^y
!

----- Method: GdbRegistersMorph>>drawOn: (in category 'drawing') -----
drawOn: aCanvas
regs := gdb getRegisters.
aCanvas
clipBy: self bounds
during: [:clippedCanvas |
clippedCanvas
fillRectangle: self bounds
color: Color yellow.
self drawRegistersOn: clippedCanvas
]
!

----- Method: GdbRegistersMorph>>gdb (in category 'accessing') -----
gdb
^ gdb!

----- Method: GdbRegistersMorph>>gdb: (in category 'accessing') -----
gdb: anObject
gdb := anObject!

GdbRegistersMorph subclass: #GdbRegistersMorphIA32
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'GDB-UI'!

----- Method: GdbRegistersMorphIA32>>drawRegistersOn: (in category 'drawing') -----
drawRegistersOn: clippedCanvas
| y |
y := self drawGPRHeaderOn: clippedCanvas.
gdb processorDescription gdb do: [ :r |
| regName |
regName := r regName.
clippedCanvas
drawString: regName, ' = ', (regs at: regName) printString
at: (self bounds topLeft + (0 @ y))
font: (LogicalFont familyName: 'Bitmap DejaVu Sans' pointSize: 12)
color: Color black.
y := y + 15.
].
^y
!

GdbRegistersMorph subclass: #GdbRegistersMorphpowerpc
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'GDB-UI'!

----- Method: GdbRegistersMorphpowerpc>>drawRegistersOn: (in category 'drawing') -----
drawRegistersOn: clippedCanvas
self drawSPRsOn: clippedCanvas fromHeight:
(self drawGPRsOn: clippedCanvas) + 15
!

----- Method: GdbRegistersMorphpowerpc>>drawSPR:on:fromHeight: (in category 'drawing') -----
drawSPR: spr on: clippedCanvas fromHeight: y
clippedCanvas
drawString: spr, ' = ', (regs at: spr) printString
at: (self bounds topLeft + (0 @ y))
font: (LogicalFont familyName: 'Bitmap DejaVu Sans' pointSize: 12)
color: Color black.
^y + 14 !

----- Method: GdbRegistersMorphpowerpc>>drawSPRsOn:fromHeight: (in category 'drawing') -----
drawSPRsOn: clippedCanvas fromHeight: y
| yy |
yy := y.
self sprNames do: [ :spr |
self drawSPR: spr on: clippedCanvas fromHeight: yy.
yy := yy + 15.
]!

----- Method: GdbRegistersMorphpowerpc>>sprNames (in category 'drawing') -----
sprNames
gdb processorDescription architectureName = 'powerpc'
ifTrue: [ ^#('pc' 'lr' 'cr' 'ctr' 'msr' 'xer') ].
^#('pc' 'sr' 'hi' 'lo' 'cause' 'badvaddr')!

Error subclass: #GdbChildExited
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'GDB-RSP'!

Error subclass: #InferiorExited
instanceVariableNames: 'exitCode'
classVariableNames: ''
poolDictionaries: ''
category: 'GDB-RSP'!

----- Method: InferiorExited class>>exitCode: (in category 'instance creation') -----
exitCode: anInteger
^self new exitCode: anInteger; yourself!

----- Method: InferiorExited class>>signalWithExitCode: (in category 'signaling') -----
signalWithExitCode: anInteger

^(self exitCode: anInteger) signal!

----- Method: InferiorExited>>exitCode (in category 'accessing') -----
exitCode
^ exitCode!

----- Method: InferiorExited>>exitCode: (in category 'accessing') -----
exitCode: anObject
exitCode := anObject!

TestCase subclass: #DebugStoppedTestCase
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'GDB-Tests'!

----- Method: DebugStoppedTestCase>>testCreateSEGV (in category 'tests-basic') -----
testCreateSEGV
| sig |
sig := DebugStopped onSignalNum: 11.
self assert: sig signal equals: #SIGSEGV!

----- Method: DebugStoppedTestCase>>testCreateSYS (in category 'tests-basic') -----
testCreateSYS
| sig |
sig := DebugStopped onSignalNum: 31.
self assert: sig signal equals: #SIGSYS!

----- Method: DebugStoppedTestCase>>testCreateTRAP (in category 'tests-basic') -----
testCreateTRAP
| sig |
sig := DebugStopped onSignalNum: 5.
self assert: sig signal equals: #SIGTRAP!

TestCase subclass: #FeatureParserTestCase
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'GDB-Tests'!

----- Method: FeatureParserTestCase>>testParse1 (in category 'tests') -----
testParse1
| regs r1 lr ctr |
regs := (GdbXmlParser endian: FakeProcessorDescriptionPPC endian)
parseString: FakeProcessorDescriptionPPC features.
r1 := regs at: 2.
self assert: r1 regName equals: 'r1'.
self assert: r1 width equals: 32.
self assert: r1 isLittleEndian equals: false.
self assert: r1 regNum equals: 1.

lr := regs at: 68.
self assert: lr regName equals: 'lr'.
self assert: lr width equals: 32.
self assert: lr isLittleEndian equals: false.
self assert: lr regNum equals: 67.

ctr := regs at: 69.
self assert: ctr regName equals: 'ctr'.
self assert: ctr width equals: 32.
self assert: ctr isLittleEndian equals: false.
self assert: ctr regNum equals: 68.
!

TestCase subclass: #GDBSocketTimeoutTest
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'GDB-Tests'!

----- Method: GDBSocketTimeoutTest>>connectGdb (in category 'as yet unclassified') -----
connectGdb
^self debuggerClass
host: self hostIP
port: 7000
processorDescription: FakeProcessorDescriptionPPC new!

----- Method: GDBSocketTimeoutTest>>hostIP (in category 'as yet unclassified') -----
hostIP
^'192.168.75.2'!

----- Method: GDBSocketTimeoutTest>>testBad (in category 'as yet unclassified') -----
testBad
| gdb |
gdb := self connectGdb.
gdb halt.
self should: [ gdb c ] raise: ConnectionClosed
!

----- Method: GDBSocketTimeoutTest>>testGood (in category 'as yet unclassified') -----
testGood
| gdb |
gdb := self connectGdb.
gdb inspect!

TestCase subclass: #RemoteGDBTestCase
instanceVariableNames: 'gdb pdl'
classVariableNames: ''
poolDictionaries: ''
category: 'GDB-Doodles'!

!RemoteGDBTestCase commentStamp: 'bgs 3/22/2020 00:16' prior: 0!
I am deprecated leftover from TA-MT.
!

----- Method: RemoteGDBTestCase>>connectGDB (in category 'as yet unclassified') -----
connectGDB
pdl := AcProcessorDescriptions powerpc.
gdb := RemoteGDBSession
host: '192.168.75.2'
port: 7000
processorDescription: pdl.!

----- Method: RemoteGDBTestCase>>exitSyscall: (in category 'syscall sequences') -----
exitSyscall: rtnInt
| loadSyscallNo loadReturnValue sc |
loadSyscallNo := (pdl instructionAt: #addi) bind: (Dictionary new
at: 'ra' put: 0;
at: 'rt' put: 0;
at: 'd' put: 1;
yourself).
loadReturnValue := (pdl instructionAt: #addi) bind: (Dictionary new
at: 'ra' put: 0;
at: 'rt' put: 3;
at: 'd' put: rtnInt;
yourself).
sc := (pdl instructionAt: #sc) bind: (Dictionary new
at: 'lev' put: 0;
yourself).
^(Array with: loadSyscallNo with: loadReturnValue with: sc)
collect: [ :instr | instr emit ]!

----- Method: RemoteGDBTestCase>>messageBytes (in category 'syscall sequences') -----
messageBytes
^'HELLO!!' asByteArray, #(10 0)!

----- Method: RemoteGDBTestCase>>testManualSyscallInNZone (in category 'as yet unclassified') -----
testManualSyscallInNZone
| memLayout writeInstructions exitInstructions |
self halt.
self connectGDB.
memLayout := ThinshellAddressLayout gdb: gdb.
memLayout executeStartChain.
writeInstructions := self writeSyscall: self messageBytes.
exitInstructions := self exitSyscall: 1.
gdb writeInt32s: writeInstructions, exitInstructions toAddr: memLayout nZone.
gdb writeBytes: self messageBytes toAddr: memLayout heap.

gdb
stepUntil: [ gdb currentInstruction name = 'sc' ];
s. "the actual write syscall"

gdb s; s; s. "exit"
Transcript yourself
!

----- Method: RemoteGDBTestCase>>testSetRegisters (in category 'as yet unclassified') -----
testSetRegisters

| regs1 regs2 |
self halt.
regs1 := gdb getRegisters.
gdb setRegisters: regs1.
regs2 := gdb getRegisters.
self assert: regs1 = regs2.!

----- Method: RemoteGDBTestCase>>writeSyscall: (in category 'syscall sequences') -----
writeSyscall: aByteArray
| loadSyscallNo loadFD loadBuf loadLength sc |
loadSyscallNo := (pdl instructionAt: #addi) bind: (Dictionary new
at: 'ra' put: 0;
at: 'rt' put: 0;
at: 'd' put: 4;
yourself).
loadFD := (pdl instructionAt: #addi) bind: (Dictionary new
at: 'ra' put: 0;
at: 'rt' put: 3;
at: 'd' put: 1;
yourself).
loadBuf := (pdl instructionAt: #addi) bind: (Dictionary new
at: 'ra' put: 17;
at: 'rt' put: 4;
at: 'd' put: 0;
yourself).
loadLength := (pdl instructionAt: #addi) bind: (Dictionary new
at: 'ra' put: 0;
at: 'rt' put: 5;
at: 'd' put: (aByteArray size);
yourself).
sc := (pdl instructionAt: #sc) bind: (Dictionary new
at: 'lev' put: 0;
yourself).
^(Array with: loadSyscallNo with: loadFD with: loadBuf with: loadLength with: sc)
collect: [ :instr | instr emit ]!

Object subclass: #AddressSpaceLayout
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'GDB-TAJ'!

!AddressSpaceLayout commentStamp: 'BorisShingarov 3/7/2020 13:22' prior: 0!
In Target-Agnostic Modtalk, when we are AoT-ing the binary image, somewhere in the address space there is the arena where we construct the object heap, and the nZone. Instances of my concrete subclasses know where these two addresses are.!

----- Method: AddressSpaceLayout>>heap (in category 'accessing') -----
heap
self subclassResponsibility !

----- Method: AddressSpaceLayout>>nZone (in category 'accessing') -----
nZone
self subclassResponsibility !

AddressSpaceLayout subclass: #ThinshellAddressLayout
instanceVariableNames: 'gdb nZone heap stack'
classVariableNames: ''
poolDictionaries: ''
category: 'GDB-TAJ'!

!ThinshellAddressLayout commentStamp: 'BorisShingarov 3/7/2020 14:02' prior: 0!
The TAM Thinshell, as described in the Kilpela-Shingarov report, and available in the shingarov/thinshell GitHub repo, is an ELF binary which doesn't link to the C runtime. Its simple, processor-specific assembly source declares areas for heap, nZone and stack, and a _start entry point leading into a "start chain". The start chain has a few instructions to load the addresses of the heap, nZone and stack into register defined by convention, a magic-point for transfering control to the outer-Smalltalk ProgramBuilder, and a jump to the beginning of the nZone.!

----- Method: ThinshellAddressLayout class>>gdb: (in category 'instance creation') -----
gdb: aGDB
^self basicNew
gdb: aGDB;
initialize!

----- Method: ThinshellAddressLayout class>>registerAssignments (in category 'register conventions') -----
registerAssignments
"This is TAM-specific and probably should not be here."
^
(#R -> 1),
(#A -> 2),
(#A -> 3),
(#FP -> 4),

(#Scratch1 -> 5),
(#Scratch2 -> 6),
(#Scratch3 -> 7),
(#Scratch4 -> 8),
(#Scratch5 -> 9),
(#Scratch6 -> 10),
(#Scratch7 -> 11),
(#Scratch8 -> 12),
(#Scratch9 -> 13),
(#Scratch10 -> 14),

(#NZone -> 16),
(#HEAP -> 2),
(#SP -> 18),
(#VPC -> 19),

(#NativePC -> 'pc')
!

----- Method: ThinshellAddressLayout>>executeStartChain (in category 'initialization') -----
executeStartChain
| regs |
regs := gdb s; "the first nop"
s; s; "lis/ori 16"
s; s;
s; s;
s; s; "2 nops"
getRegisters.

nZone := regs at: (self regNameFor: #NZone).
heap := regs at: (self regNameFor: #HEAP).
stack := regs at: (self regNameFor: #SP).!

----- Method: ThinshellAddressLayout>>gdb (in category 'accessing') -----
gdb
^ gdb!

----- Method: ThinshellAddressLayout>>gdb: (in category 'accessing') -----
gdb: anObject
gdb := anObject!

----- Method: ThinshellAddressLayout>>heap (in category 'accessing') -----
heap
^ heap!

----- Method: ThinshellAddressLayout>>heap: (in category 'accessing') -----
heap: anObject
heap := anObject!

----- Method: ThinshellAddressLayout>>initialize (in category 'initialization') -----
initialize
super initialize.
self executeStartChain!

----- Method: ThinshellAddressLayout>>nZone (in category 'accessing') -----
nZone
^ nZone!

----- Method: ThinshellAddressLayout>>nZone: (in category 'accessing') -----
nZone: anObject
nZone := anObject!

----- Method: ThinshellAddressLayout>>regNameFor: (in category 'cooperation with gdb') -----
regNameFor: vRegName
^'r', (ThinshellAddressLayout registerAssignments at: vRegName) printString!

----- Method: ThinshellAddressLayout>>stack (in category 'accessing') -----
stack
^ stack!

----- Method: ThinshellAddressLayout>>stack: (in category 'accessing') -----
stack: anObject
stack := anObject!

Object subclass: #BasePrimitiveProcessor
instanceVariableNames: 'gdb regs'
classVariableNames: ''
poolDictionaries: ''
category: 'GDB-Primitives'!

----- Method: BasePrimitiveProcessor class>>gdb: (in category 'as yet unclassified') -----
gdb: gdb
^self new
gdb: gdb;
yourself!

----- Method: BasePrimitiveProcessor>>advancePastTrap (in category 'engine') -----
advancePastTrap
regs at: 'pc' put: (regs at: 'pc')+4!

----- Method: BasePrimitiveProcessor>>allocIndexed:md: (in category 'allocating') -----
allocIndexed: size md: md
| ptr obj liveObj mtNil |
ptr := self allocSlots: size serviceSlots: 3.
obj := MTRemoteObject gdb: gdb pointer: ptr.
obj header: (TAJObjectWriter
declareObjectHeaderType: 'IndexedObjectType'
hashFormat: 'NoHash'
numVars: size
hash: 0
meta: 0).
obj md: md.
liveObj := MTRemoteLiveIndexedObject gdb: gdb pointer: ptr.
mtNil := gdb exe externalReferences at: #MT_nil.
1 to: size do: [ :i |
liveObj mtAt: i put: mtNil ].
self return: ptr!

----- Method: BasePrimitiveProcessor>>allocOop:md: (in category 'allocating') -----
allocOop: numVars md: md
| ptr obj mtNil |
ptr := self allocSlots: numVars serviceSlots: 3 "header, md, hash".
obj := MTRemoteObject gdb: gdb pointer: ptr.
obj header: (TAJObjectWriter
declareObjectHeaderType: 'OopObjectType'
hashFormat: 'NoHash'
numVars: numVars hash: 0 meta: 0).
obj md: md.
"nil the slots:"
mtNil := gdb exe externalReferences at: #MT_nil.
1 to: numVars do: [ :idx | obj basicSlotAt: idx+2 put: mtNil ].
^ptr
!

----- Method: BasePrimitiveProcessor>>allocSlots:serviceSlots: (in category 'allocating') -----
allocSlots: numSlots serviceSlots: s
| nBytes p |
false ifTrue: [ ^self allocSlotsFromMTXMemory: numSlots ].

nBytes := (numSlots + s) * 4.
nBytes := nBytes+15 bitAnd: 16rFFFFFFF0.
p := self getVRegister: #HEAP.
self setVRegister: #HEAP to: p + nBytes.
^p!

----- Method: BasePrimitiveProcessor>>allocSlotsFromMTXMemory: (in category 'allocating') -----
allocSlotsFromMTXMemory: numSlots
| nBytes |
nBytes := numSlots * 4.
^self gdb exe objectMemory alloc: nBytes!

----- Method: BasePrimitiveProcessor>>allocString:md: (in category 'allocating') -----
allocString: size md: md
| ptr obj |
ptr := self allocSlots: (size + 2 + 3 // 4) serviceSlots: 3 "header, md, hash".
obj := MTRemoteObject gdb: gdb pointer: ptr.
obj header: (TAJObjectWriter
declareObjectHeaderType: 'ZByteObjectType'
hashFormat: 'StringHash'
numVars: size
hash: 0
meta: 0).
obj md: md.
self return: ptr!

----- Method: BasePrimitiveProcessor>>currentFrame (in category 'engine') -----
currentFrame
"NB -- this is problematic, this parallel implementation with GDB"
^MTRemoteStackFrame gdb: gdb pointer: (self getVRegister: #FP)!

----- Method: BasePrimitiveProcessor>>gdb (in category 'accessing') -----
gdb
^ gdb!

----- Method: BasePrimitiveProcessor>>gdb: (in category 'accessing') -----
gdb: anObject
gdb := anObject!

----- Method: BasePrimitiveProcessor>>getAllRegisters (in category 'engine') -----
getAllRegisters
regs := gdb getRegisters!

----- Method: BasePrimitiveProcessor>>getRegister: (in category 'engine') -----
getRegister: r
^regs at: r!

----- Method: BasePrimitiveProcessor>>getVRegister: (in category 'engine') -----
getVRegister: regSym
| nRegister |
nRegister := TAJWriter vRegister: regSym.
^self getRegister: 'r', nRegister printString!

----- Method: BasePrimitiveProcessor>>processPrimitive: (in category 'engine') -----
processPrimitive: primitiveSelector
self
getAllRegisters;
perform: primitiveSelector;
advancePastTrap;
setAllRegisters!

----- Method: BasePrimitiveProcessor>>setAllRegisters (in category 'engine') -----
setAllRegisters
gdb setRegisters: regs!

----- Method: BasePrimitiveProcessor>>setRegister:to: (in category 'engine') -----
setRegister: r to: x
regs at: r put: x!

----- Method: BasePrimitiveProcessor>>setVRegister:to: (in category 'engine') -----
setVRegister: r to: x
| nRegister |
nRegister := TAJWriter vRegister: r.
nRegister := 'r', nRegister printString.
self setRegister: nRegister to: x!

BasePrimitiveProcessor subclass: #PrimitiveProcessor
instanceVariableNames: 'exceptionEnvSlot'
classVariableNames: ''
poolDictionaries: ''
category: 'GDB-Primitives'!

!PrimitiveProcessor commentStamp: 'BorisShingarov 5/5/2016 17:24' prior: 0!
When the native runtime does not have a native implementation for a primitive, a callback into the outer Smalltalk happens which I then process, surgically operating on the state of the inner VM.!

----- Method: PrimitiveProcessor>>falseObject (in category 'accessing') -----
falseObject
^gdb exe externalReferences at: #MT_false!

----- Method: PrimitiveProcessor>>getExceptionEnvSlot (in category 'accessing') -----
getExceptionEnvSlot
exceptionEnvSlot isNil ifTrue: [ exceptionEnvSlot := self nilObject ].
^exceptionEnvSlot !

----- Method: PrimitiveProcessor>>isTerminationContextFor (in category 'control primitives') -----
isTerminationContextFor
| currentCtx startCtx block blockMarkEnv methodMarkEnv matchesP | self halt.
currentCtx := MTRemoteStackFrame
gdb: gdb
pointer: ((self getVRegister: #R) bitAnd: 2r11 bitInvert32).
startCtx := MTRemoteStackFrame gdb: gdb pointer: ((self getVRegister: #A) bitAnd: 2r11 bitInvert32).
block := startCtx blockClosure.
blockMarkEnv := block env markEnv.
methodMarkEnv := currentCtx env markEnv.
matchesP := (currentCtx method pointer = block compiledBlock homeMethod pointer) and:
[ blockMarkEnv pointer = methodMarkEnv pointer ].
self return: (matchesP
ifTrue: [ self trueObject ]
ifFalse: [ self falseObject ])!

----- Method: PrimitiveProcessor>>isValueMarked (in category 'control primitives') -----
isValueMarked
| frame matchesP |
frame := MTRemoteStackFrame gdb: gdb pointer: (self receiverOop bitAnd: 2r11 bitInvert32).
matchesP := frame method pointer = (gdb exe externalReferences at: #MT_valueMarked).
self return: (matchesP
ifTrue: [ self trueObject ]
ifFalse: [ self falseObject ])!

----- Method: PrimitiveProcessor>>markFail (in category 'engine') -----
markFail
| cr |
self halt.
cr := regs at: 'cr'.
cr := cr bitOr: 2r0010 << (4 * 2). "EQ bit in CR5"
regs at: 'cr' put: cr!

----- Method: PrimitiveProcessor>>markSuccess (in category 'engine') -----
markSuccess
| cr |
cr := regs at: 'cr'.
cr := cr bitAnd: (2r0010 << (4 * 2)) bitInvert32. "EQ bit in CR5"
regs at: 'cr' put: cr!

----- Method: PrimitiveProcessor>>nilObject (in category 'accessing') -----
nilObject
^gdb exe externalReferences at: #MT_nil!

----- Method: PrimitiveProcessor>>primAddSI (in category 'integer primitives') -----
primAddSI
| r a sum |
r := self getVRegister: #R.
(r bitAnd: 2r11) = 2r0001 ifFalse:[ ^self markFail ].
r := gdb exe architecture smallIntegerToInteger: r.
a := self getVRegister: #A.
(a bitAnd: 2r11) = 2r0001 ifFalse:[ ^self markFail ].
a := gdb exe architecture smallIntegerToInteger: a.
sum := r + a.
sum := gdb exe architecture integerToSmallInteger: sum.
self return: sum!

----- Method: PrimitiveProcessor>>primAlignedPointerOopAt (in category 'object access primitives') -----
primAlignedPointerOopAt
| r idx oop |
idx := (self getVRegister: #A) >> 4.
r := (self getVRegister: #R) bitAnd: 2r0011 bitInvert32.
oop := gdb read32At: r + (idx*4).
self return: oop!

----- Method: PrimitiveProcessor>>primAlignedPointerOopAtPut (in category 'object access primitives') -----
primAlignedPointerOopAtPut
| r idx arg2 |
idx := (self getVRegister: #A) >> 4.
r := (self getVRegister: #R) bitAnd: 2r00011 bitInvert32.
arg2 := gdb currentFrame arg: 2.
gdb writeInt32: arg2 toAddr: r + (idx*4).
self markSuccess !

----- Method: PrimitiveProcessor>>primBasicAt (in category 'object access primitives') -----
primBasicAt
| l |
"NB - guards"
l := MTRemoteLiveObject gdb: gdb liveObject: (self getVRegister: #R).
self return: (l mtBasicAt: (self getVRegister: #A) >> 4)!

----- Method: PrimitiveProcessor>>primBasicAtPut (in category 'object access primitives') -----
primBasicAtPut
| l idx arg2 |
"NB - guards"
l := MTRemoteLiveObject gdb: gdb liveObject: (self getVRegister: #R).
idx := (self getVRegister: #A) >> 4.
arg2 := self currentFrame arg: 2.
l mtBasicAt: idx put: arg2.
self markSuccess !

----- Method: PrimitiveProcessor>>primBasicSize (in category 'primitives') -----
primBasicSize
| answer |
" NB: insert prim failure guards here, such as SmallInteger "
answer := (MTRemoteLiveObject gdb: gdb liveObject: self receiverOop) numIndexed.
answer := (answer bitShift: 4) bitOr: 2r0001. "SI"
self return: answer!

----- Method: PrimitiveProcessor>>primCharacterBasicAt (in category 'object access primitives') -----
primCharacterBasicAt
| index char |
index := self getVRegister: #A.
"Guard that the arg is an SI:"
(index bitAnd: 2r00011) = 1 ifFalse: [ ^self markFail ].
index := index >> 4.

char := gdb readByteAt: (self getVRegister: #R) + 8 + index - 1.

"CHAR_TAG=2"
char := char << 4 bitOr: 2.

self return: char!

----- Method: PrimitiveProcessor>>primCharacterBasicAtPut (in category 'object access primitives') -----
primCharacterBasicAtPut
| index char charOop |

index := self getVRegister: #A.
"Guard that the index arg is an SI"
(index bitAnd: 2r00011) = 1 ifFalse: [ ^self markFail ].
index := index >> 4.

charOop := self currentFrame arg: 2.
"Guard that the char arg is a char"
(charOop bitAnd: 2r00011) = 2 ifFalse: [ ^self markFail ].
char := charOop >> 4.

gdb byteAt: (self getVRegister: #R) + 8 + index - 1 put: char.

self return: charOop!

----- Method: PrimitiveProcessor>>primCharacterFromCodePoint (in category 'object access primitives') -----
primCharacterFromCodePoint
| arg |
arg := self getVRegister: #A.
"Remove the SI tag and attach a CHAR tag"
arg := (arg bitAnd: 16rFFFFFFF0) bitOr: 2r00010.
self return: arg!

----- Method: PrimitiveProcessor>>primCharacterValue (in category 'object access primitives') -----
primCharacterValue
| arg |
arg := self getVRegister: #A.
"Remove the CHAR tag and attach a SI tag"
arg := (arg bitAnd: 16rFFFFFFF0) bitOr: 2r00001.
self return: arg!

----- Method: PrimitiveProcessor>>primClass (in category 'primitives') -----
primClass
| rcv md |
rcv := MTRemoteObject gdb: gdb pointer: (self getVRegister: #R).
md := MTRemoteMethodDictionary gdb: gdb pointer: rcv md.
[ md pointer = self nilObject ] whileFalse: [
| clazz |
clazz := md definingClass.
clazz isRemoteNil ifFalse: [ ^self return: clazz pointer ].
md := md superMd ].
^self return: self nilObject !

----- Method: PrimitiveProcessor>>primClassName (in category 'primitives') -----
primClassName
| rcv |
"The argument is a class."
rcv := MTRemoteClass gdb: gdb pointer: (self getVRegister: #R).
self return: rcv name!

----- Method: PrimitiveProcessor>>primCurrentContext (in category 'control primitives') -----
primCurrentContext
| context |
context := self currentFrame senderFrame.
self return: (context pointer bitOr: 3)!

----- Method: PrimitiveProcessor>>primExceptionEnvironment (in category 'control primitives') -----
primExceptionEnvironment
^self return: self getExceptionEnvSlot !

----- Method: PrimitiveProcessor>>primFail (in category 'feature primitives') -----
primFail
self markFail!

----- Method: PrimitiveProcessor>>primHash (in category 'object access primitives') -----
primHash
self return: 2r0001. "SI 0"
!

----- Method: PrimitiveProcessor>>primIntDivSI (in category 'integer primitives') -----
primIntDivSI
| r a d |
r := self getVRegister: #R.
(r bitAnd: 2r111) = 2r0001 ifFalse:[ ^self markFail ].
r := gdb exe architecture smallIntegerToInteger: r.
a := self getVRegister: #A.
(a bitAnd: 2r111) = 2r0001 ifFalse:[ ^self markFail ].
a := gdb exe architecture smallIntegerToInteger: a.
d := r // a.
d := gdb exe architecture integerToSmallInteger: d.
self return: d!

----- Method: PrimitiveProcessor>>primIntRemSI (in category 'integer primitives') -----
primIntRemSI
| r a rem |
r := self getVRegister: #R.
(r bitAnd: 2r11) = 2r0001 ifFalse:[ ^self markFail ].
r := gdb exe architecture smallIntegerToInteger: r.
a := self getVRegister: #A.
(a bitAnd: 2r11) = 2r0001 ifFalse:[ ^self markFail ].
a := gdb exe architecture smallIntegerToInteger: a.
rem := r \\ a.
rem := gdb exe architecture integerToSmallInteger: rem.
self return: rem!

----- Method: PrimitiveProcessor>>primIsBottomOfStack (in category 'control primitives') -----
primIsBottomOfStack
| bottomP frame |
frame := MTRemoteStackFrame gdb: gdb pointer: ((self getVRegister: #R) bitAnd: 2r11 bitInvert32).
bottomP := frame isBottomFrame.
self return: (bottomP
ifTrue: [ self trueObject ]
ifFalse: [ self falseObject ])!

----- Method: PrimitiveProcessor>>primMultiplySI (in category 'integer primitives') -----
primMultiplySI
| r a p |
r := self getVRegister: #R.
(r bitAnd: 2r111) = 2r0001 ifFalse:[ ^self markFail ].
r := gdb exe architecture smallIntegerToInteger: r.
a := self getVRegister: #A.
(a bitAnd: 2r111) = 2r0001 ifFalse:[ ^self markFail ].
a := gdb exe architecture smallIntegerToInteger: a.
p := r * a.
p := gdb exe architecture integerToSmallInteger: p.
self return: p!

----- Method: PrimitiveProcessor>>primNewIndexedObject (in category 'primitives') -----
primNewIndexedObject
| clazz size |
self halt.
size := (self getVRegister: #A) >> 4.
size >= (65536*4) ifTrue:[self halt].
clazz := MTRemoteClass gdb: gdb pointer: self receiverOop.
clazz structure = 5
ifTrue: [ self allocString: size md: clazz instanceMd ]
ifFalse: [ self allocIndexed: size md: clazz instanceMd ]!

----- Method: PrimitiveProcessor>>primNewObject (in category 'primitives') -----
primNewObject
| clazz |
clazz := MTRemoteClass gdb: gdb pointer: self receiverOop.
self return: (self
allocOop: clazz instVarCount
md: clazz instanceMd)!

----- Method: PrimitiveProcessor>>primPerform (in category 'control primitives') -----
primPerform
"Perform a 0-arg send.
Receiver in R, selector in A."
| a selector fp frame jmpTarget |

a := self getVRegister: #A.
fp := self getVRegister: #FP.
frame := MTRemoteStackFrame gdb: gdb pointer: fp.
self setVRegister: #SP to: fp-4.
self setVRegister: #FP to: frame senderFrame pointer.

selector := MTRemoteSymbol gdb: gdb pointer: a.
jmpTarget := (HostAssistedLookup regBase: self ram: gdb) messageSendSelector: selector symbol.
"jmpTarget := gdb messageSendSelector: selector symbol." "correct address to jump to in CTR!!"
"but the contract with the primitive invocation code is that
the address is in scratch1."
self setVRegister: #Scratch1 to: jmpTarget

!

----- Method: PrimitiveProcessor>>primPreviousContext (in category 'control primitives') -----
primPreviousContext
| context prevAddr |
context := self receiverOop.
context := context bitAnd: 3 bitInvert32.
prevAddr := gdb read32At: context.
self return: (prevAddr bitOr: 3)!

----- Method: PrimitiveProcessor>>primPrintString (in category 'feature primitives') -----
primPrintString
| r tag |
self halt.
r := self receiverOop.
tag := r bitAnd: 2r00011.
tag = 0 ifTrue: [
"For pointer oops, assume it's a String"
| rs |
rs := MTRemoteString gdb: gdb pointer: r.
Transcript show: rs string.
^self markSuccess
].
tag = 1 ifTrue: [
Transcript show: (r>>4) printString.
^self markSuccess
].
self halt!

----- Method: PrimitiveProcessor>>primReturnValueFromContext (in category 'control primitives') -----
primReturnValueFromContext
| ctx |
self setVRegister: #R to: (self getVRegister: #A).
ctx := gdb read32At: (self getVRegister: #FP) - 8.
ctx := ctx bitAnd: 2r11 bitInvert32. "strip off context immediate tag"
self setVRegister: #FP to: ctx.
self setVRegister: #SP to: ctx + 4.
self markSuccess !

----- Method: PrimitiveProcessor>>primSIGreaterThan (in category 'integer primitives') -----
primSIGreaterThan
self return: ((self getVRegister: #R) > (self getVRegister: #A)
ifTrue: [ self trueObject ]
ifFalse: [ self falseObject ])!

----- Method: PrimitiveProcessor>>primSIGreaterThanEqual (in category 'integer primitives') -----
primSIGreaterThanEqual
self return: ((gdb getVRegister: #R) >= (gdb getVRegister: #A)
ifTrue: [ self trueObject ]
ifFalse: [ self falseObject ])!

----- Method: PrimitiveProcessor>>primSILessThan (in category 'integer primitives') -----
primSILessThan
self return: ((self getVRegister: #R) < (self getVRegister: #A)
ifTrue: [ self trueObject ]
ifFalse: [ self falseObject ])!

----- Method: PrimitiveProcessor>>primSILessThanEqual (in category 'integer primitives') -----
primSILessThanEqual
self return: ((self getVRegister: #R) <= (self getVRegister: #A)
ifTrue: [ self trueObject ]
ifFalse: [ self falseObject ])!

----- Method: PrimitiveProcessor>>primSay (in category 'feature primitives') -----
primSay
" Show the receiver SI on the host transcript. "
| something tag |
self halt.
something := self getVRegister: #R.
tag := something bitAnd: 2r00011.
tag = 0 ifTrue: [ something := 'oop:', something asString, ' md:', (MTRemoteObject gdb: gdb pointer: something) md printString ].
tag = 1 ifTrue: [ something := gdb exe architecture smallIntegerToInteger: something ].

Transcript show: ('Modtalk says: ', something asString); cr.
self markSuccess.

!

----- Method: PrimitiveProcessor>>primSay2 (in category 'feature primitives') -----
primSay2
" On the class side of ProtoObject. "
self halt.
self markSuccess.

!

----- Method: PrimitiveProcessor>>primSaySomething (in category 'feature primitives') -----
primSaySomething
self halt.
Transcript show: 'It WORKS!!!!!!'; cr!

----- Method: PrimitiveProcessor>>primSaySomethingElse (in category 'feature primitives') -----
primSaySomethingElse
Transcript show: 'It DOES NOT WORK!!!!!!'; cr!

----- Method: PrimitiveProcessor>>primSetExceptionEnvironment (in category 'control primitives') -----
primSetExceptionEnvironment
| ee |
ee := self getVRegister: #A.
self setExceptionEnvSlot: ee;
markSuccess !

----- Method: PrimitiveProcessor>>primStringCompare (in category 'feature primitives') -----
primStringCompare
| r b answer |
r := self getVRegister: #R.
r := MTRemoteString gdb: gdb pointer: r.
r := r string.

b := self getVRegister: #A.
b := MTRemoteString gdb: gdb pointer: b.
b := b string.

answer := r = b ifTrue: [2] ifFalse: [ r < b ifTrue: [1] ifFalse: [3] ].
answer := gdb exe architecture integerToSmallInteger: answer.
self return: answer!

----- Method: PrimitiveProcessor>>primSubSI (in category 'integer primitives') -----
primSubSI
| r a diff |
r := self getVRegister: #R.
(r bitAnd: 2r111) = 2r0001 ifFalse:[ ^self markFail ].
r := gdb exe architecture smallIntegerToInteger: r.
a := self getVRegister: #A.
(a bitAnd: 2r111) = 2r0001 ifFalse:[ ^self markFail ].
a := gdb exe architecture smallIntegerToInteger: a.
diff := r - a.
diff := gdb exe architecture integerToSmallInteger: diff.
self return: diff!

----- Method: PrimitiveProcessor>>primValue (in category 'control primitives') -----
primValue
| addr |
addr := (MTRemoteBlockClosure gdb: gdb pointer: self receiverOop)
compiledBlock codeRef address.
self setVRegister: #Scratch1 to: addr.
self setVRegister: #X to: self receiverOop.
self markSuccess !

----- Method: PrimitiveProcessor>>primValueWith2Args (in category 'control primitives') -----
primValueWith2Args
| arg2 |
arg2 := self currentFrame arg: 2.
gdb push: arg2.
^self primValue!

----- Method: PrimitiveProcessor>>primValueWithArgument (in category 'control primitives') -----
primValueWithArgument
^self primValue "No need to specifically pass the arg because it is already in #A"!

----- Method: PrimitiveProcessor>>primValueWithArguments (in category 'control primitives') -----
primValueWithArguments
self halt!

----- Method: PrimitiveProcessor>>receiverOop (in category 'engine') -----
receiverOop
^self getVRegister: #R!

----- Method: PrimitiveProcessor>>return: (in category 'engine') -----
return: oop
self setVRegister: #R to: oop.
self markSuccess!

----- Method: PrimitiveProcessor>>setExceptionEnvSlot: (in category 'accessing') -----
setExceptionEnvSlot: oop
exceptionEnvSlot := oop!

----- Method: PrimitiveProcessor>>trueObject (in category 'accessing') -----
trueObject
^gdb exe externalReferences at: #MT_true!

BasePrimitiveProcessor subclass: #PrivatePrimitiveProcessor
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'GDB-Primitives'!

----- Method: PrivatePrimitiveProcessor>>primAllocEnv (in category 'primitives') -----
primAllocEnv
| stackFrame count ptr env |
count := gdb currentBytecode count.
stackFrame := self currentFrame.
ptr := self allocSlots: count serviceSlots: 2 "header, hash".
env := MTRemoteIndexedPart gdb: gdb pointer: ptr.
env header: (TAJObjectWriter
declareObjectHeaderType: 'IndexedPartType'
hashFormat: 'NoHash'
numVars: count
hash: 0
meta: 0).
env basicSlotAt: 1 put: stackFrame env pointer.
stackFrame env: env.
self setVRegister: #X to: ptr.
!

----- Method: PrivatePrimitiveProcessor>>primMethodClosure (in category 'primitives') -----
primMethodClosure
| stackFrame method blocks ptr md count block blockClosure numArgs blockClosureMDKey |

count := gdb currentBytecode count.
stackFrame := self currentFrame.
method := stackFrame method.
blocks := method blocks.
block := MTRemoteCompiledBlock gdb: gdb pointer: (blocks at: count).
numArgs := block numArgs.
blockClosureMDKey := (Array
with: #MTZeroArgumentBlockClosure_md
with: #MTOneArgumentBlockClosure_md
with: #MTTwoArgumentBlockClosure_md
) at: numArgs + 1.
md := gdb exe externalReferences at: blockClosureMDKey.
ptr := self allocOop: 4 md: md.
blockClosure := MTRemoteBlockClosure gdb: gdb pointer: ptr.
blockClosure
literals: method literals;
compiledBlock: block;
env:(stackFrame env);
receiver: (MTRemoteObject gdb: gdb pointer: (self getVRegister: #R)).
self setVRegister: #R to: ptr.!

Object subclass: #DebugStopped
instanceVariableNames: 'signal'
classVariableNames: ''
poolDictionaries: ''
category: 'GDB-RSP'!

----- Method: DebugStopped class>>onSignalNum: (in category 'instance creation') -----
onSignalNum: anInteger
^self basicNew
signal: (self signalNames at: anInteger)
yourself!

----- Method: DebugStopped class>>signalNames (in category 'signal numbers') -----
signalNames
^#(
SIGHUP
SIGINT
SIGQUIT
SIGILL
SIGTRAP
SIGABRT
SIGBUS
SIGFPE
SIGKILL
SIGUSR1
SIGSEGV
SIGUSR2
SIGPIPE
SIGALRM
SIGTERM
SIGSTKFLT
SIGCHLD
SIGCONT
SIGSTOP
SIGTSTP
SIGTTIN
SIGTTOU
SIGURG
SIGXCPU
SIGXFSZ
SIGVTALRM
SIGPROF
SIGWINCH
SIGIO
SIGPWR
SIGSYS
SIGRTMIN
)!

----- Method: DebugStopped>>printOn: (in category 'printing') -----
printOn: aStream
aStream nextPutAll: 'Got '; nextPutAll: self signal asString!

----- Method: DebugStopped>>signal (in category 'accessing') -----
signal
^signal!

----- Method: DebugStopped>>signal: (in category 'accessing') -----
signal: aSymbol
signal := aSymbol!

Object subclass: #Doodle
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'GDB-Doodles'!

----- Method: Doodle>>assert:equals: (in category 'as yet unclassified') -----
assert: expected equals: actual
^self
assert: expected = actual
!

Doodle subclass: #GDBDoodle
instanceVariableNames: 'gdb'
classVariableNames: ''
poolDictionaries: ''
category: 'GDB-Doodles'!

GDBDoodle subclass: #AbsoluteZeroPPC
instanceVariableNames: 'memory'
classVariableNames: ''
poolDictionaries: ''
category: 'GDB-Doodles'!

!AbsoluteZeroPPC commentStamp: 'bgs 3/25/2020 06:56' prior: 0!
See thinshell/absolute/power/absolute.s.
This gets built into an exe loaded at absolute address 0.
Execution starts at 0.
gem5 is able to simulate an MMU that can map such address.
!

----- Method: AbsoluteZeroPPC>>connectGdb (in category 'target connection') -----
connectGdb
super connectGdb.
memory := RemoteRAM gdb: gdb!

----- Method: AbsoluteZeroPPC>>hostIP (in category 'target connection') -----
hostIP
^'192.168.75.2'!

----- Method: AbsoluteZeroPPC>>makeAFewSteps (in category 'stepping logic') -----
makeAFewSteps
self assert: gdb pc equals: 0.
self assert: memory currentInstructionEncoding equals: 16r7c631a78.
gdb s.
self assert: gdb pc equals: 4.
self assert: memory currentInstructionEncoding equals: 16r3860002a.
gdb s.
self assert: gdb pc equals: 8.
!

----- Method: AbsoluteZeroPPC>>pdl (in category 'target connection') -----
pdl
^FakeProcessorDescriptionPPC new!

----- Method: AbsoluteZeroPPC>>testAbs (in category 'target connection') -----
testAbs
"
AbsoluteZeroPPC new halt ; testAbs
"
self connectGdb; makeAFewSteps.
[ "then, run at full speed until the exit() syscall"
gdb c
"At this point we expect gem5 to have exited and said,
Exit code is 42"
] on: GdbChildExited do: [ ^self ].
self error!

----- Method: GDBDoodle>>connectGdb (in category 'target connection') -----
connectGdb
gdb := self debuggerClass
host: self hostIP
port: self tcpPort
processorDescription: self pdl.
^gdb!

----- Method: GDBDoodle>>debuggerClass (in category 'target connection') -----
debuggerClass
^RemoteGDBSession!

----- Method: GDBDoodle>>hostIP (in category 'target connection') -----
hostIP
self shouldBeImplemented!

----- Method: GDBDoodle>>pdl (in category 'target connection') -----
pdl
self shouldBeImplemented!

----- Method: GDBDoodle>>tcpPort (in category 'target connection') -----
tcpPort
^7000!

GDBDoodle subclass: #ThinshellDoodle
instanceVariableNames: 'memory'
classVariableNames: ''
poolDictionaries: ''
category: 'GDB-Doodles'!

ThinshellDoodle subclass: #PPCThinshellDoodle
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'GDB-Doodles'!

PPCThinshellDoodle subclass: #P1025ThinshellDoodle
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'GDB-Doodles'!

----- Method: P1025ThinshellDoodle>>hostIP (in category 'target connection') -----
hostIP
^'192.168.75.199'!

----- Method: P1025ThinshellDoodle>>pdl (in category 'target connection') -----
pdl
^FakeProcessorDescriptionP1025 new!

----- Method: P1025ThinshellDoodle>>testStepThoughPreamble (in category 'tests') -----
testStepThoughPreamble
"
P1025ThinshellDoodle new testStepThoughPreamble
"
self connectGdb; stepThroughThinshellPreamble.
[ gdb kill ] on: GdbChildExited do: [ ^self ].
"should be unreachable"
self error!

----- Method: P1025ThinshellDoodle>>testSurgicalJump (in category 'tests') -----
testSurgicalJump
"
P1025ThinshellDoodle new testSurgicalJump
"
self connectGdb; stepThroughThinshellPreamble.

gdb setRegister: 'r1' to: 240.
gdb setRegister: 'pc' to: 16r100000cc.
[ gdb c ] on: InferiorExited do: [ :ex |
"We expect gdbserver to say, Child exited with status 15"
self assert: ex exitCode equals: 15.
"The RSP protocol spec doesn't say what is allowed here,
because targets can vary.
For example, attempting to terminate the gdbserver by sending KILL,
will not work with the normal GNU gdbserver.
However, simply closing the connection will suffice."
^gdb socket close
].

"shouldn't reach here"
self error!

PPCThinshellDoodle subclass: #PPCgem5ThinshellDoodle
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'GDB-Doodles'!

PPCgem5ThinshellDoodle subclass: #HardwareBreakpointDoodle
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'GDB-Doodles'!

----- Method: HardwareBreakpointDoodle>>hostIP (in category 'target connection') -----
hostIP
^'192.168.75.2'!

----- Method: HardwareBreakpointDoodle>>installBrk (in category 'tests') -----
installBrk
gdb insertHWBreakpointAt: self initialPC + 8!

----- Method: HardwareBreakpointDoodle>>pdl (in category 'target connection') -----
pdl
^FakeProcessorDescriptionPPC new!

----- Method: HardwareBreakpointDoodle>>testHWBrk (in category 'tests') -----
testHWBrk
"
HardwareBreakpointDoodle new halt; testHWBrk.
"
self connectGdb;
installBrk.
gdb c.
self assert: gdb pc equals: self initialPC + 8.
self fillNZone.

"No need to advance, because this is not a trap."
[ gdb c ] on: GdbChildExited do: [ ^self ].
self error!

PPCgem5ThinshellDoodle subclass: #PPCIllegalStoreDoodle
instanceVariableNames: 'isHardware'
classVariableNames: ''
poolDictionaries: ''
category: 'GDB-Doodles'!

----- Method: PPCIllegalStoreDoodle class>>onHardware (in category 'instance creation') -----
onHardware
"Set up the test for the real devboard."
^self basicNew isHardware: true!

----- Method: PPCIllegalStoreDoodle class>>onSoftware (in category 'instance creation') -----
onSoftware
"Set up the test for gem5."
^self basicNew isHardware: false!

----- Method: PPCIllegalStoreDoodle>>hostIP (in category 'target connection') -----
hostIP
^isHardware
ifTrue: [ '192.168.75.199' ]
ifFalse: [ '192.168.75.2' ]!

----- Method: PPCIllegalStoreDoodle>>isHardware: (in category 'as yet unclassified') -----
isHardware: whetherToUseP1025
isHardware := whetherToUseP1025.
^self!

----- Method: PPCIllegalStoreDoodle>>pdl (in category 'target connection') -----
pdl
^isHardware
ifTrue: [ FakeProcessorDescriptionP1025 new ]
ifFalse: [ FakeProcessorDescriptionPPC new ]!

----- Method: PPCIllegalStoreDoodle>>stepThroughThinshellPreamble (in category 'as yet unclassified') -----
stepThroughThinshellPreamble

self assert: memory currentInstructionEncoding equals: 16r3920ffff. "li r9,-1"
self halt.
gdb c.
self assert: memory currentInstructionEncoding equals: 16r90090000. "stw r0,0(r9)"
self halt.
gdb s. "Simulation dies"
!

----- Method: PPCIllegalStoreDoodle>>testSTW (in category 'as yet unclassified') -----
testSTW
"
PPCIllegalStoreDoodle onSoftware testSTW.

PPCIllegalStoreDoodle onHardware testSTW.
"
self connectGdb;
stepThroughThinshellPreamble!

----- Method: PPCgem5ThinshellDoodle>>hostIP (in category 'target connection') -----
hostIP
^'192.168.75.2'!

----- Method: PPCgem5ThinshellDoodle>>pdl (in category 'target connection') -----
pdl
^FakeProcessorDescriptionPPC new!

----- Method: PPCgem5ThinshellDoodle>>testManualNZone (in category 'tests') -----
testManualNZone
"
PPCgem5ThinshellDoodle new halt; testManualNZone
"
self connectGdb;
stepThroughThinshellPreamble;
fillNZone.
[ "then, run at full speed until the exit() syscall"
gdb c
"At this point we expect gem5 to have exited and said,
Exit code is 42"
] on: GdbChildExited do: [ ^self ].
self error
!

----- Method: PPCgem5ThinshellDoodle>>testManualNZone2 (in category 'tests') -----
testManualNZone2
"
PPCgem5ThinshellDoodle new testManualNZone2
"
self connectGdb;
stepThroughThinshellPreamble;
fillNZone2.
[ "then, run at full speed until the exit() syscall"
gdb c
"At this point we expect gem5 to have exited and said,
Exit code is 42"
] on: GdbChildExited do: [ ^self ].
self error
!

PPCgem5ThinshellDoodle subclass: #RemoteMemoryDoodle
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'GDB-Doodles'!

----- Method: RemoteMemoryDoodle>>hostIP (in category 'target connection') -----
hostIP
^'192.168.75.2'!

----- Method: RemoteMemoryDoodle>>pdl (in category 'target connection') -----
pdl
^FakeProcessorDescriptionPPC new!

----- Method: RemoteMemoryDoodle>>testLowLevelWrite (in category 'tests-reading') -----
testLowLevelWrite
"
RemoteMemoryDoodle new testLowLevelWrite
"
| goodAddress |
self connectGdb.
goodAddress := self initialPC.
memory writeBytes: #[1 2 3 4] toAddr: goodAddress.

self assert: (memory unsignedLongAtAddr: goodAddress bigEndian: true) equals: 16r01020304.
self assert: (memory unsignedLongAt: goodAddress + 1 bigEndian: true) equals: 16r01020304.
self assert: (memory read: 4 bytesAtAddr: goodAddress) equals: #[1 2 3 4].
self assert: (memory unsignedByteAtAddr: 16r10000080) equals: 1.
self assert: (memory unsignedByteAtAddr: 16r10000081) equals: 2.

[ gdb kill ] on: GdbChildExited do: [ ^self ]
!

----- Method: RemoteMemoryDoodle>>testReadFirstInstruction (in category 'tests-reading') -----
testReadFirstInstruction
"
RemoteMemoryDoodle new testReadFirstInstruction
"
| entry |
self connectGdb.
entry := self initialPC.

self assert: (memory unsignedLongAtAddr: entry bigEndian: true) equals: 16r7c000378.
self assert: (memory unsignedLongAtAddr: entry bigEndian: false) equals: 16r7803007c.
self assert: (memory read: 4 bytesAtAddr: entry) equals: #[124 0 3 120].
self assert: (memory unsignedByteAtAddr: 16r10000080) equals: 124.

[ gdb kill ] on: GdbChildExited do: [ ^self ]
!

RemoteMemoryDoodle subclass: #ShmemDoodle
instanceVariableNames: 'plainRAM'
classVariableNames: ''
poolDictionaries: ''
category: 'GDB-Doodles'!

----- Method: ShmemDoodle>>connectGdb (in category 'target connection') -----
connectGdb
super connectGdb.
memory shmemSize: 536870912. "size of TAM's thinshell process image"
plainRAM := RemoteRAM gdb: gdb.
^gdb!

----- Method: ShmemDoodle>>doodles (in category 'tests-agreement') -----
doodles

ShmemDoodle new testLowLevelWrite.

ShmemDoodle new testReadFirstInstruction.

ShmemDoodle new testManualNZone.

ShmemDoodle new testManualNZone2.

!

----- Method: ShmemDoodle>>remoteMemoryClass (in category 'target connection') -----
remoteMemoryClass
^Gem5SharedRAM!

----- Method: ShmemDoodle>>testSharedToNonShared (in category 'tests-agreement') -----
testSharedToNonShared!

----- Method: ThinshellDoodle>>connectGdb (in category 'target connection') -----
connectGdb
super connectGdb.
self createRAM!

----- Method: ThinshellDoodle>>createRAM (in category 'target connection') -----
createRAM
memory := self remoteMemoryClass gdb: gdb!

----- Method: ThinshellDoodle>>fillNZone (in category 'stepping logic') -----
fillNZone
"Fill the nZone with (programmer-assembled) machine code
that will return the SmallInteger 42.
The Thinshell will convert the TAM SmallInteger in #R
(which is where the Program Initializer is expected to put it)
into a machine integer suitable for passing to the exit() syscall."

memory writeInt32: 16r382002a0 toAddr: self nZone+0. "li r1,672"
memory writeInt32: 16r4e800020 toAddr: self nZone+4. "blr"
!

----- Method: ThinshellDoodle>>fillNZone2 (in category 'stepping logic') -----
fillNZone2
"Same as fillNZone, but in one shot."

memory writeInt32s: #(16r382002a0 16r4e800020) toAddr: self nZone+0!

----- Method: ThinshellDoodle>>initialPC (in category 'facts about thinshell') -----
initialPC
^16r10000080
!

----- Method: ThinshellDoodle>>nZone (in category 'facts about thinshell') -----
nZone
^16r100100E0!

----- Method: ThinshellDoodle>>remoteMemoryClass (in category 'target connection') -----
remoteMemoryClass
^RemoteRAM!

----- Method: ThinshellDoodle>>stepThroughThinshellPreamble (in category 'stepping logic') -----
stepThroughThinshellPreamble
| initialPC nZone |
initialPC := gdb pc.
self assert: initialPC equals: 16r10000080.
self assert: memory currentInstructionEncoding equals: 16r7C000378. "mr r0,r0"
gdb s.
self assert: gdb pc equals: initialPC + 4.
self assert: memory currentInstructionEncoding equals: 16r3E001001. "lis r16,4097"
gdb s.
self assert: gdb pc equals: initialPC + 8.
gdb s; s; s; s; s. "last non-nop"
nZone := gdb getRegisters at: 'r16'.
self assert: nZone equals: self nZone.
gdb s; s; s; s; s; s. "bunch of nops (there are more!!)"
self assert: gdb pc equals: 16r100000B4!

GDBDoodle subclass: #X86JumpDoodle
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'GDB-Doodles'!

----- Method: X86JumpDoodle>>hostIP (in category 'target connection') -----
hostIP
^'192.168.75.2'!

----- Method: X86JumpDoodle>>pdl (in category 'target connection') -----
pdl
^FakeProcessorDescriptionX86 new!

----- Method: X86JumpDoodle>>tcpPort (in category 'target connection') -----
tcpPort
^7000!

----- Method: X86JumpDoodle>>testAtomicSimpleCPU (in category 'tests') -----
testAtomicSimpleCPU
"
X86JumpDoodle new testAtomicSimpleCPU
"
self halt; connectGdb.
gdb pc: 17.
gdb s.
gdb pc.
gdb getRegisters at: 'eax'.
gdb getRegisters at: 'ebp'.!

Object subclass: #FakeProcessorDescription
instanceVariableNames: 'regsInGPacket'
classVariableNames: ''
poolDictionaries: ''
category: 'GDB-Doodles'!

----- Method: FakeProcessorDescription>>endian (in category 'accessing') -----
endian
^self class endian!

----- Method: FakeProcessorDescription>>initRegsInGPacket (in category 'accessing') -----
initRegsInGPacket
"Do not try to use the real GdbXmlParser.
On some Smalltalks under development, there is no XML."
| regNum |
regNum := 0.
regsInGPacket := self class fakeFeatures collect: [ :reg |
| rt |
rt := RSPOneRegisterTransfer new
regName: (reg first);
width: (reg second);
isLittleEndian: (self endian = #little);
regNum: regNum;
yourself.
regNum := regNum + 1.

rt ]!

----- Method: FakeProcessorDescription>>regsInGPacket (in category 'accessing') -----
regsInGPacket
regsInGPacket isNil ifTrue: [ self initRegsInGPacket ].
^regsInGPacket !

FakeProcessorDescription subclass: #FakeProcessorDescriptionPPC
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'GDB-Doodles'!

FakeProcessorDescriptionPPC subclass: #FakeProcessorDescriptionP1025
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'GDB-Doodles'!

!FakeProcessorDescriptionP1025 commentStamp: 'BorisShingarov 3/13/2020 01:27' prior: 0!
This will go away when we implement xi:include!

----- Method: FakeProcessorDescriptionP1025 class>>fakeFeatures (in category 'as yet unclassified') -----
fakeFeatures
^#(
#('r0' 32) #('r1' 32) #('r2' 32) #('r3' 32) #('r4' 32) #('r5' 32) #('r6' 32) #('r7' 32)
#('r8' 32) #('r9' 32) #('r10' 32) #('r11' 32) #('r12' 32) #('r13' 32) #('r14' 32) #('r15' 32)
#('r16' 32) #('r17' 32) #('r18' 32) #('r19' 32) #('r20' 32) #('r21' 32) #('r22' 32) #('r23' 32)
#('r24' 32) #('r25' 32) #('r26' 32) #('r27' 32) #('r28' 32) #('r29' 32) #('r30' 32) #('r31' 32)

#('ev0h' 32) #('ev1h' 32) #('ev2h' 32) #('ev3h' 32) #('ev4h' 32) #('ev5h' 32) #('ev6h' 32) #('ev7h' 32)
#('ev8h' 32) #('ev9h' 32) #('ev10h' 32) #('ev11h' 32) #('ev12h' 32) #('ev13h' 32) #('ev14h' 32) #('ev15h' 32)
#('ev16h' 32) #('ev17h' 32) #('ev18h' 32) #('ev19h' 32) #('ev20h' 32) #('ev21h' 32) #('ev22h' 32) #('ev23h' 32)
#('ev24h' 32) #('ev25h' 32) #('ev26h' 32) #('ev27h' 32) #('ev28h' 32) #('ev29h' 32) #('ev30h' 32) #('ev31h' 32)

#('pc' 32)
#('msr' 32)
#('cr' 32)
#('lr' 32)
#('ctr' 32)
#('xer' 32)

#('orig_r3' 32)
#('trap' 32)
#('acc' 64)
#('spefscr' 32)
)
!

----- Method: FakeProcessorDescriptionPPC class>>endian (in category 'as yet unclassified') -----
endian
^#big!

----- Method: FakeProcessorDescriptionPPC class>>fakeFeatures (in category 'as yet unclassified') -----
fakeFeatures
^#(
#('r0' 32) #('r1' 32) #('r2' 32) #('r3' 32) #('r4' 32) #('r5' 32) #('r6' 32) #('r7' 32)
#('r8' 32) #('r9' 32) #('r10' 32) #('r11' 32) #('r12' 32) #('r13' 32) #('r14' 32) #('r15' 32)
#('r16' 32) #('r17' 32) #('r18' 32) #('r19' 32) #('r20' 32) #('r21' 32) #('r22' 32) #('r23' 32)
#('r24' 32) #('r25' 32) #('r26' 32) #('r27' 32) #('r28' 32) #('r29' 32) #('r30' 32) #('r31' 32)

#('f0' 64) #('f1' 64) #('f2' 64) #('f3' 64) #('f4' 64) #('f5' 64) #('f6' 64) #('f7' 64)
#('f8' 64) #('f9' 64) #('f10' 64) #('f11' 64) #('f12' 64) #('f13' 64) #('f14' 64) #('f15' 64)
#('f16' 64) #('f17' 64) #('f18' 64) #('f19' 64) #('f20' 64) #('f21' 64) #('f22' 64) #('f23' 64)
#('f24' 64) #('f25' 64) #('f26' 64) #('f27' 64) #('f28' 64) #('f29' 64) #('f30' 64) #('f31' 64)

#('pc' 32)
#('msr' 32)
#('cr' 32)
#('lr' 32)
#('ctr' 32)
#('xer' 32)
)
!

----- Method: FakeProcessorDescriptionPPC>>architectureName (in category 'as yet unclassified') -----
architectureName
^'powerpc'!

FakeProcessorDescription subclass: #FakeProcessorDescriptionX86
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'GDB-Doodles'!

----- Method: FakeProcessorDescriptionX86 class>>endian (in category 'as yet unclassified') -----
endian
^#little!

----- Method: FakeProcessorDescriptionX86 class>>fakeFeatures (in category 'as yet unclassified') -----
fakeFeatures
^#(
#('eax' 32) #('ecx' 32) #('edx' 32) #('ebx' 32) #('esp' 32) #('ebp' 32) #('esi' 32) #('edi' 32)
#('eip' 32) #('eflags' 32) #('cs' 32) #('ss' 32) #('ds' 32) #('es' 32) #('fs' 32) #('gs' 32)
)
"
#('st0' 80) #('st1' 80) #('st2' 80) #('st3' 80) #('st4' 80) #('st5' 80) #('st6' 80) #('st7' 80)

#('fctrl' 32)
#('fstat' 32)
#('ftag' 32)
#('fiseg' 32)
#('fioff' 32)
#('foseg' 32)
#('fooff' 32)
#('fop' 32)
)
"!

----- Method: FakeProcessorDescriptionX86>>architectureName (in category 'as yet unclassified') -----
architectureName
^'x86'!

----- Method: FakeProcessorDescriptionX86>>pcRegisterName (in category 'as yet unclassified') -----
pcRegisterName
^'eip'!

Object subclass: #GdbXmlParser
instanceVariableNames: 'isLittleEndian'
classVariableNames: ''
poolDictionaries: ''
category: 'GDB-RSP'!

----- Method: GdbXmlParser class>>endian: (in category 'API') -----
endian: aSymbol
| le |
aSymbol == #big ifTrue: [ le := false ]
ifFalse: [ aSymbol == #little ifTrue: [ le := true ] ifFalse: [ self error: 'Endian must be big or little' ]].
^self basicNew
isLittleEndian: le!

----- Method: GdbXmlParser class>>new (in category 'API') -----
new
self error: 'Please use #endian:'!

----- Method: GdbXmlParser class>>parseFile:in:assumeEndian: (in category 'API') -----
parseFile: fileName in: path assumeEndian: aSymbol
| f s |
f := FileStream fileNamed:
path, '/', fileName.
s := f contentsOfEntireFile.
f close.
^ (self endian: aSymbol) parseString: s!

----- Method: GdbXmlParser>>isLittleEndian: (in category 'private') -----
isLittleEndian: aBoolean
isLittleEndian := aBoolean.
^self!

----- Method: GdbXmlParser>>parseString: (in category 'API') -----
parseString: s
| parser |
parser := XMLDOMParser on: s.
^self processXML: parser parseDocument root.!

----- Method: GdbXmlParser>>processXML: (in category 'private') -----
processXML: root
| oneRegTransfers regNum feature regs |
feature := root nodesDetect: [ :aChild | aChild isElementNamed: 'feature' ].
regs := feature nodesSelect: [ :aChild | aChild isElementNamed: 'reg' ].
regNum := 0.
oneRegTransfers := regs collect: [ :regNode |
| rt |
rt := RSPOneRegisterTransfer new
regName: (regNode attributeAt: 'name');
width: ((regNode attributeAt: 'bitsize') asInteger);
isLittleEndian: isLittleEndian;
regNum: regNum;
yourself.
regNum := regNum + 1.
rt ].

oneRegTransfers := oneRegTransfers asOrderedCollection sorted: [ :rA :rB | rA regNum <= rB regNum ].

"Verify that we got all registers from 0 to the total number, without holes."
regNum := 0.
oneRegTransfers do: [ :rt |
rt regNum == regNum ifFalse: [ self error ].
regNum := regNum + 1 ].
^oneRegTransfers!

Object subclass: #HostAssistedLookup
instanceVariableNames: 'regBase ram'
classVariableNames: ''
poolDictionaries: ''
category: 'GDB-RSP'!

----- Method: HostAssistedLookup class>>regBase:ram: (in category 'instance creation') -----
regBase: regBase ram: ram
^self new
regBase: regBase;
ram: ram;
yourself!

----- Method: HostAssistedLookup>>activateCM: (in category 'API') -----
activateCM: cm
| jmpTarget |
jmpTarget := cm codeRef address.
regBase
setRegister: 'ctr' to: jmpTarget; "we should do something about it"
setVRegister: #X to: cm pointer.
^jmpTarget!

----- Method: HostAssistedLookup>>messageSendSelector: (in category 'API') -----
messageSendSelector: selectorSymbol
| receiver mdRef md cm |
receiver := regBase getVRegister: #R.
mdRef := ram mdFor: receiver.
md := MTRemoteMethodDictionary gdb: ram pointer: mdRef.
cm := md lookupSelector: selectorSymbol.
^self activateCM: cm!

----- Method: HostAssistedLookup>>ram (in category 'accessing') -----
ram
^ ram!

----- Method: HostAssistedLookup>>ram: (in category 'accessing') -----
ram: anObject
ram := anObject!

----- Method: HostAssistedLookup>>regBase (in category 'accessing') -----
regBase
^ regBase!

----- Method: HostAssistedLookup>>regBase: (in category 'accessing') -----
regBase: anObject
regBase := anObject!

Object subclass: #MTXMemory
instanceVariableNames: 'ram layout currentHeapAllocPtr setup'
classVariableNames: ''
poolDictionaries: ''
category: 'GDB-TAJ'!

----- Method: MTXMemory class>>jumpTableSize (in category 'as yet unclassified') -----
jumpTableSize
" In entries as opposed to bytes "
^1024
!

----- Method: MTXMemory>>alloc: (in category 'as yet unclassified') -----
alloc: nBytes
^self baseAlloc: nBytes + 4 "for the hash on 32-bit machines"!

----- Method: MTXMemory>>architecture (in category 'as yet unclassified') -----
architecture
^self targetSetup architecture!

----- Method: MTXMemory>>baseAlloc: (in category 'as yet unclassified') -----
baseAlloc: nBytes
| evenBytes answer |
answer := currentHeapAllocPtr.
nBytes \\ 16 = 0
ifTrue: [ evenBytes := nBytes ]
ifFalse: [ evenBytes := (nBytes bitOr: 16r0F) + 1 ].
currentHeapAllocPtr := currentHeapAllocPtr + evenBytes.
^answer!

----- Method: MTXMemory>>currentGrade (in category 'as yet unclassified') -----
currentGrade!

----- Method: MTXMemory>>initialize (in category 'as yet unclassified') -----
initialize
self initializeGDB.
^self!

----- Method: MTXMemory>>initializeGDB (in category 'as yet unclassified') -----
initializeGDB
setup := TAJTargetSetup current.
ram := setup gdbClass
host: setup host
port: setup port
processorDescription: setup architecture isa.
layout := ThinshellAddressLayout gdb: ram.
currentHeapAllocPtr := layout heap + (self class jumpTableSize * 4).
^self!

----- Method: MTXMemory>>jumpTable (in category 'as yet unclassified') -----
jumpTable
^layout heap
!

----- Method: MTXMemory>>layout (in category 'as yet unclassified') -----
layout
^layout!

----- Method: MTXMemory>>newChunk (in category 'as yet unclassified') -----
newChunk!

----- Method: MTXMemory>>ram (in category 'as yet unclassified') -----
ram
^ram!

----- Method: MTXMemory>>startAllocatingOnTarget (in category 'as yet unclassified') -----
startAllocatingOnTarget
ram setVRegister: #HEAP to: currentHeapAllocPtr!

----- Method: MTXMemory>>targetSetup (in category 'as yet unclassified') -----
targetSetup
^setup!

Object subclass: #MagicSurgeon
instanceVariableNames: 'gdb'
classVariableNames: ''
poolDictionaries: ''
category: 'GDB-RSP'!

!MagicSurgeon commentStamp: 'BorisShingarov 3/7/2020 20:00' prior: 0!
Execution of the inner (target) Smalltalk VM stopped at a surgery point.!

MagicSurgeon subclass: #MTHostCallback
instanceVariableNames: 'primitiveProcessor privatePrimitiveProcessor'
classVariableNames: ''
poolDictionaries: ''
category: 'GDB-TAJ'!

----- Method: MTHostCallback class>>gdb: (in category 'instance creation') -----
gdb: gdb
^self new
gdb: gdb;
yourself!

----- Method: MTHostCallback>>call (in category 'surgery') -----
call
| methodDef cmRef regs |
methodDef := gdb currentBytecode method value.
regs := gdb getRegisters.
regs at: 'ctr' put: (gdb exe externalReferences at: methodDef codeRuntimeName).
cmRef := gdb exe externalReferences at: methodDef globalName.
regs at: (TAJWriter registerMap at: #X) put: cmRef.
gdb setRegisters: regs.
gdb s!

----- Method: MTHostCallback>>getRegisters (in category 'surgery') -----
getRegisters
self halt!

----- Method: MTHostCallback>>handleDNU (in category 'surgery') -----
handleDNU
| regs receiver selector className |
regs := gdb getRegisters.
receiver := regs at: 'r1'.
receiver := MTRemoteObject gdb: gdb pointer: receiver.
className := receiver mdObject definingClass name symbol.
selector := regs at: 'r7'.
selector := MTRemoteSymbol gdb: gdb pointer: selector.
selector := selector symbol.
self halt!

----- Method: MTHostCallback>>inspectionPoint (in category 'surgery') -----
inspectionPoint
self halt.
" selectorOop := self getRegisters at: 'r7'.
primSaySelector := exe externalReferences at: #Symbol_primSay.
selectorOop = primSaySelector ifTrue: [
siOOP := self getVRegister: #R.
self pharoObjectForOop: siOOP.
self halt.
siMD := self mdFor: siOOP.
superMD := (MTRemoteMethodDictionary gdb: self pointer: siMD) superMd.
superSuperMD := superMD superMd.
]."
"anotherWay := self currentBytecode selector value."
"gdb s"!

----- Method: MTHostCallback>>messageSend (in category 'surgery') -----
messageSend
^self messageSendSelector: gdb currentBytecode selector value!

----- Method: MTHostCallback>>primitive (in category 'surgery') -----
primitive
self primitiveProcessor
processPrimitive: gdb currentBytecode selector value
!

----- Method: MTHostCallback>>primitiveProcessor (in category 'accessing') -----
primitiveProcessor
primitiveProcessor isNil ifTrue: [ primitiveProcessor := PrimitiveProcessor gdb: gdb ].
^primitiveProcessor !

----- Method: MTHostCallback>>privatePrimitive (in category 'accessing') -----
privatePrimitive
self privatePrimitiveProcessor
processPrimitive: gdb currentBytecode selector value
!

----- Method: MTHostCallback>>privatePrimitiveProcessor (in category 'accessing') -----
privatePrimitiveProcessor
privatePrimitiveProcessor isNil ifTrue: [ privatePrimitiveProcessor := PrivatePrimitiveProcessor gdb: gdb ].
^privatePrimitiveProcessor !

----- Method: MTHostCallback>>process (in category 'API') -----
process
| callNo |
callNo := gdb getRegisters at: 'r22'. "cf. TAJWriter>>nextPutMagic:"
callNo = 1 ifTrue: [ ^self messageSend ].
callNo = 2 ifTrue: [ ^self primitive ].
callNo = 3 ifTrue: [ ^self return ].
callNo = 4 ifTrue: [ ^self privatePrimitive ].
callNo = 5 ifTrue: [ ^self call ].
callNo = 6 ifTrue: [ ^self handleDNU ].
callNo = 7 ifTrue: [ ^self inspectionPoint ].
self error: 'Unknown callback'!

----- Method: MTHostCallback>>return (in category 'surgery') -----
return
| cm numToDrop |
self halt.
cm := MTRemoteCompiledMethod gdb: self pointer: (self getVRegister: #X).
numToDrop := cm numArgs - 1 max: 0.
numToDrop = 0 ifFalse: [ self setVRegister: #SP to: (self getVRegister: #SP) - (numToDrop * 4) ]
!

----- Method: MagicSurgeon>>gdb (in category 'accessing') -----
gdb
^ gdb!

----- Method: MagicSurgeon>>gdb: (in category 'accessing') -----
gdb: anObject
gdb := anObject!

----- Method: MagicSurgeon>>process (in category 'API') -----
process
self subclassResponsibility !

Object subclass: #RSPOneRegisterTransfer
instanceVariableNames: 'regName width isLittleEndian regNum'
classVariableNames: ''
poolDictionaries: ''
category: 'GDB-RSP'!

----- Method: RSPOneRegisterTransfer>>isLittleEndian (in category 'accessing') -----
isLittleEndian
^ isLittleEndian!

----- Method: RSPOneRegisterTransfer>>isLittleEndian: (in category 'accessing') -----
isLittleEndian: anObject
isLittleEndian := anObject!

----- Method: RSPOneRegisterTransfer>>readFrom: (in category 'reading') -----
readFrom: aStream
| text int |
text := aStream next: width//4.
int := Integer readFrom: text base: 16.
isLittleEndian ifTrue: [ int := int byteSwap32 ].
"TODO - Different types (e.g. IEEE-754)"
^int!

----- Method: RSPOneRegisterTransfer>>regName (in category 'accessing') -----
regName
^ regName!

----- Method: RSPOneRegisterTransfer>>regName: (in category 'accessing') -----
regName: anObject
regName := anObject!

----- Method: RSPOneRegisterTransfer>>regNum (in category 'accessing') -----
regNum
^ regNum!

----- Method: RSPOneRegisterTransfer>>regNum: (in category 'accessing') -----
regNum: anObject
regNum := anObject!

----- Method: RSPOneRegisterTransfer>>width (in category 'accessing') -----
width
^ width!

----- Method: RSPOneRegisterTransfer>>width: (in category 'accessing') -----
width: anObject
width := anObject!

----- Method: RSPOneRegisterTransfer>>write:to: (in category 'writing') -----
write: aDictionary to: aStream
| value bytes |
value := aDictionary at: self regName.
isLittleEndian ifTrue: [ value := value byteSwap32 ].
bytes := value printStringBase: 16 length: self width // 4 padded: true.
aStream nextPutAll: bytes!

Object subclass: #RemoteGDBTransport
instanceVariableNames: 'socket'
classVariableNames: ''
poolDictionaries: ''
category: 'GDB-RSP'!

RemoteGDBTransport subclass: #RemoteGDB
instanceVariableNames: 'packetSize processorDescription tStatus why supported vCont'
classVariableNames: ''
poolDictionaries: ''
category: 'GDB-RSP'!

----- Method: RemoteGDB class>>host:port:processorDescription: (in category 'instance creation') -----
host: h port: p processorDescription: pd
"Create an instance, connect to the remote server, and fully prepare the debugging session."
^(self host: h port: p)
processorDescription: pd;
prepareSession;
yourself!

----- Method: RemoteGDB>>analyzeContinueAnswer: (in category 'stop codes') -----
analyzeContinueAnswer: answer
answer isEmpty ifTrue: [ self error: 'Empty Stop-Reply packet' ].
answer first = $S ifTrue: [ ^self analyzeContinueAnswerS: answer allButFirst ].
answer first = $T ifTrue: [ ^self analyzeContinueAnswerT: answer allButFirst ].
answer first = $W ifTrue: [ ^self inferiorExited: answer ].
"Something unknown / as-yet-unimplemented"
self error: answer!

----- Method: RemoteGDB>>analyzeContinueAnswerS: (in category 'stop codes') -----
analyzeContinueAnswerS: answer
"The program received signal number AA (a two-digit hexadecimal number).
This is equivalent to a T response with no n:r pairs."
^DebugStopped onSignalNum: (self signalNumberFrom: answer)
!

----- Method: RemoteGDB>>analyzeContinueAnswerT: (in category 'stop codes') -----
analyzeContinueAnswerT: answer
| signal textPairs importantRegs thread core stopReason stopArgument |
signal := self signalNumberFrom: answer.
textPairs := answer copyFrom: 3 to: answer size.
textPairs := textPairs findTokens: ';'.
importantRegs := Dictionary new.
core := nil.
thread := nil.
stopReason := nil.
stopArgument := nil.
textPairs do: [ :textPair |
| pair k v |
pair := textPair findTokens: ':'.
k := pair first.
v := pair second.
(self recognizedStopCodes includes: k)
ifTrue: [ stopReason := k. stopArgument := v ] ifFalse: [
k = 'thread' ifTrue: [ thread := v ] ifFalse: [
k = 'core' ifTrue: [ core := v ] ifFalse: [
importantRegs at: k put: (Integer readFrom: k base: 16)
"TODO: Missing the reserved case;
this will be handled by catching exception in #readFrom: and discarding it"
]]]].
self shouldBeImplemented "In TAM, this simply returns; processing is done in the sender after this call."
!

----- Method: RemoteGDB>>c (in category 'RSP commands') -----
c
" Continue. "
| answer |
answer := self q: 'c'. "NB: on some platforms, we have wanted 'vCont;c'. I forgot why."
^self analyzeContinueAnswer: answer!

----- Method: RemoteGDB>>decodeGPacket: (in category 'private') -----
decodeGPacket: aStream
| registerTransfers regs |
registerTransfers := processorDescription regsInGPacket.
regs := Dictionary new.
registerTransfers do: [ :rt |
| nextValue |
aStream atEnd ifTrue: [ ^regs ].
nextValue := rt readFrom: aStream.
regs at: rt regName put: nextValue ].
^regs

!

----- Method: RemoteGDB>>getRegisters (in category 'RSP commands') -----
getRegisters
| answer stream |
answer := self q: 'g'.
stream := ReadStream on: answer
from: 1
to: answer size.
^self decodeGPacket: stream!

----- Method: RemoteGDB>>gtInspectorPreviewIn: (in category 'private') -----
gtInspectorPreviewIn: composite
<gtInspectorPresentationOrder: 20>
composite morph
title: 'Registers';
morph: [ GdbRegistersMorph on: self ]!

----- Method: RemoteGDB>>inferiorExited: (in category 'stop codes') -----
inferiorExited: fullAnswer
| exitCode |
exitCode := Integer readFrom: fullAnswer copyWithoutFirst base: 16.
InferiorExited signalWithExitCode: exitCode !

----- Method: RemoteGDB>>insertHWBreakpointAt: (in category 'general query commands') -----
insertHWBreakpointAt: addr
| answer |
answer := self q: 'Z1,',
addr printStringHex,
',4'.
answer = 'OK' ifFalse: [ self error ]!

----- Method: RemoteGDB>>insertSWBreakpointAt: (in category 'general query commands') -----
insertSWBreakpointAt: addr
| answer |
answer := self q: 'Z1,',
addr printStringHex,
',4'.
answer = 'OK' ifFalse: [ self error ]!

----- Method: RemoteGDB>>kill (in category 'RSP commands') -----
kill
[ | answer |
answer := self q: 'k'.
answer = 'OK' ifFalse: [ self error: answer ].
^self ] on: ConnectionClosed do: [ ^self ]
!

----- Method: RemoteGDB>>nameForInspector (in category 'private') -----
nameForInspector
^'GDB'!

----- Method: RemoteGDB>>packetSize (in category 'general query commands') -----
packetSize
packetSize isNil ifTrue: [
| ps |
ps := supported detect: [ :q | q beginsWith: 'PacketSize=' ].
ps := ps copyFrom: 12 to: ps size.
packetSize := SmallInteger readFrom: ps base: 16 ].
^packetSize !

----- Method: RemoteGDB>>processorDescription (in category 'private') -----
processorDescription
^processorDescription!

----- Method: RemoteGDB>>processorDescription: (in category 'private') -----
processorDescription: descr
processorDescription := descr!

----- Method: RemoteGDB>>q: (in category 'private') -----
q: q
^self
send: q;
receive!

----- Method: RemoteGDB>>qOffsets (in category 'general query commands') -----
qOffsets
^self q: 'qOffsets'!

----- Method: RemoteGDB>>qStatus (in category 'general query commands') -----
qStatus
^self q: 'qStatus'!

----- Method: RemoteGDB>>qSupported (in category 'general query commands') -----
qSupported
supported := self q: 'qSupported:swbreak+'.
supported isEmpty ifTrue: [ ^self error: 'qSupported returned empty string' ].
supported := supported findTokens: ';'!

----- Method: RemoteGDB>>qTStatus (in category 'general query commands') -----
qTStatus
tStatus := self q: 'qTStatus'!

----- Method: RemoteGDB>>recognizedStopCodes (in category 'stop codes') -----
recognizedStopCodes
^#(
'watch' 'rwatch' 'awatch'
'syscall_entry' 'syscall_return'
'library' 'replaying'
'swbreak' 'hwbreak'
'fork' 'vfork' 'vforkdone'
'exec' 'create'
)!

----- Method: RemoteGDB>>s (in category 'RSP commands') -----
s
"Single step.
Return control with signal 5 (TRAP),
or if the execution of the current instruction failed, with whatever signal happened."
| answer |
answer := self q: 's'.
^self analyzeContinueAnswer: answer
!

----- Method: RemoteGDB>>setRegisters: (in category 'RSP commands') -----
setRegisters: aDict
| answer stream registerTransfers |
stream := WriteStream on: String new.
registerTransfers := processorDescription regsInGPacket.
registerTransfers do: [ :rt |
rt write: aDict to: stream ].

answer := self q: 'G', stream contents.
answer = 'OK' ifFalse: [self error: answer]!

----- Method: RemoteGDB>>setThread:t: (in category 'RSP commands') -----
setThread: c t: t
" Hxyyyy family of commands (e.g. Hc-1 or Hg0). "
| answer |
answer := self q: 'H', c, t printStringHex.
answer = 'OK' "ifFalse: [ self error: answer ]" "I've seen this happen in normal operation of the GNU GDB and silently ignored"
!

----- Method: RemoteGDB>>signalNumberFrom: (in category 'stop codes') -----
signalNumberFrom: answer
^Integer readFrom: (answer copyFrom: 1 to: 2) base: 16
!

----- Method: RemoteGDB>>vCont (in category 'RSP commands') -----
vCont
"Stepping mechanisms supported by the server"
vCont := self q: 'vCont?'!

----- Method: RemoteGDB>>why (in category 'RSP commands') -----
why
why := self q: '?'!

----- Method: RemoteGDB>>writeBytes:toAddr: (in category 'RSP commands') -----
writeBytes: aByteArray toAddr: addr
| textualAddr currAddr answer |
currAddr := addr.
aByteArray do: [ :byte |
| data |
data := byte printStringBase: 16 length: 2 padded: true.
textualAddr := currAddr printStringBase: 16 length: 8 padded: true.
answer := self
q: 'M', textualAddr, ',1:', data.
answer = 'OK' ifFalse: [ self error: answer ].
currAddr := currAddr + 1
]!

RemoteGDB subclass: #RemoteGDBSession
instanceVariableNames: 'qXfer vFile'
classVariableNames: ''
poolDictionaries: ''
category: 'GDB-RSP'!

RemoteGDBSession subclass: #ExecutableAwareGDB
instanceVariableNames: 'exe'
classVariableNames: ''
poolDictionaries: ''
category: 'GDB-TAJ'!

----- Method: ExecutableAwareGDB>>currentBytecode (in category 'representation') -----
currentBytecode
| def vPC |
def := self exe whereAmI.
vPC := self getVRegister: #VPC.
^def ir instructions at: vPC+1!

----- Method: ExecutableAwareGDB>>currentFrame (in category 'representation') -----
currentFrame
^MTRemoteStackFrame gdb: self pointer: (self getVRegister: #FP)!

----- Method: ExecutableAwareGDB>>exe (in category 'accessing') -----
exe
^ exe!

----- Method: ExecutableAwareGDB>>exe: (in category 'accessing') -----
exe: anObject
exe := anObject!

----- Method: ExecutableAwareGDB>>findPreviousCallers:from: (in category 'debug support') -----
findPreviousCallers: maxCallersToFind from: spOrNil
| sp |
maxCallersToFind < 1 ifTrue: [ ^OrderedCollection new ].
sp := spOrNil isNil ifTrue: [ self getVRegister: #SP ] ifFalse: [ spOrNil ].
[ self isInStack: sp ] whileTrue: [
| slot |
slot := self read32At: sp.
sp := sp - 4.
(self isInNZone: slot) ifTrue: [ ^(self findPreviousCallers: maxCallersToFind - 1 from: sp) addFirst: (exe whereIsPC: slot); yourself ]
].
^OrderedCollection new!

----- Method: ExecutableAwareGDB>>getVRegister: (in category 'representation') -----
getVRegister: r
| nRegister |
nRegister := TAJWriter vRegister: r.
^self getRegisters at: 'r', nRegister printString!

----- Method: ExecutableAwareGDB>>isInNZone: (in category 'debug support') -----
isInNZone: anAddress
^(anAddress < 272699392) and: [ anAddress > 268505088 ]!

----- Method: ExecutableAwareGDB>>isInStack: (in category 'debug support') -----
isInStack: anAddress
^(anAddress >= 272699392) and: [ anAddress < 273747968 ]!

----- Method: ExecutableAwareGDB>>isMTNil: (in category 'representation') -----
isMTNil: anOop
^anOop = (self exe externalReferences at: #MT_nil)!

----- Method: ExecutableAwareGDB>>mdFor: (in category 'representation') -----
mdFor: oop
| tagBits |
tagBits := oop bitAnd: 3.
tagBits == 1 ifTrue: [
"SmallInteger"
^exe externalReferences at: #MTSmallInteger_md ].
tagBits == 3 ifTrue: [
"Context"
^exe externalReferences at: #MTContext_md ].
^self read32At: oop + 4!

----- Method: ExecutableAwareGDB>>pharoObjectForOop: (in category 'representation') -----
pharoObjectForOop: oop
| tag |
tag := oop bitAnd: 2r111.
tag == 0 ifTrue: [ ^MTRemoteObject gdb: self pointer: oop ].
tag == 1 ifTrue: [ ^exe architecture oop >> 4 ]. "SmallInteger; this code better delegate to the Target"
tag == 3 ifTrue: [ ^MTRemoteObject gdb: self pointer: (oop bitAnd: 16rFFFFFFF0) ].
self halt "I don't know what tag this is"!

----- Method: ExecutableAwareGDB>>pharoObjectForVReg: (in category 'representation') -----
pharoObjectForVReg: vReg
^self pharoObjectForOop: (self getVRegister: vReg)!

----- Method: ExecutableAwareGDB>>processCallback (in category 'surgery') -----
processCallback
(MTHostCallback gdb: self) process
!

----- Method: ExecutableAwareGDB>>push: (in category 'representation') -----
push: oop
| sp |
sp := self getVRegister: #SP.
self writeInt32: oop toAddr: sp+4.
self setVRegister: #SP to: sp+4!

----- Method: ExecutableAwareGDB>>setVRegister:to: (in category 'representation') -----
setVRegister: r to: x
| nRegister |
nRegister := TAJWriter vRegister: r.
self setRegister: nRegister to: x!

----- Method: ExecutableAwareGDB>>tryRunning (in category 'surgery') -----
tryRunning
self runWithMagickCallback: [ self processCallback ]!

----- Method: ExecutableAwareGDB>>tryRunningSteps (in category 'surgery') -----
tryRunningSteps
self runStepsWithMagickCallback: [ self processCallback ]!

----- Method: RemoteGDBSession>>advancePastTrap (in category 'magick') -----
advancePastTrap
| regs |
regs := self getRegisters.
regs at: 'pc' put: (regs at: 'pc') + 4.
self setRegisters: regs.!

----- Method: RemoteGDBSession>>askFeatures (in category 'RSP commands') -----
askFeatures
" Ask the stub for the target feature descriptor, and return it.
If the stub doesn't provide it, return nil. "
self supportsFeatures
ifTrue: [ ^self qXfer features: 'target.xml' ]
ifFalse: [ ^nil ]
!

----- Method: RemoteGDBSession>>currentInstruction (in category 'RSP commands') -----
currentInstruction
^processorDescription disassemble: self currentInstructionEncoding
!

----- Method: RemoteGDBSession>>getRegister: (in category 'accessing') -----
getRegister: r
| regs |
regs := self getRegisters.
^regs at: r!

----- Method: RemoteGDBSession>>pc (in category 'RSP commands') -----
pc
^self getRegisters at: self processorDescription pcRegisterName !

----- Method: RemoteGDBSession>>pc: (in category 'RSP commands') -----
pc: newPC
^self setRegister: self processorDescription pcRegisterName to: newPC!

----- Method: RemoteGDBSession>>prepareSession (in category 'RSP commands') -----
prepareSession
self qSupported.
self packetSize.
self setThread: 'g' t: 0.
self qStatus = '' ifFalse: [ self error: 'Bad status' ].
self vCont.

self askFeatures ifNotNil: [ :xml | processorDescription regsInGPacket: (GdbXmlParser new processXML: xml) ]
!

----- Method: RemoteGDBSession>>printRegistersOn: (in category 'printing') -----
printRegistersOn: aStream
| allRegisters |
allRegisters := self getRegisters.
allRegisters keysAndValuesDo: [ :regName :regValue |
(#('ds' 'ss' 'cs' 'es' 'fs' 'gs') includes: regName) ifFalse: [
aStream nextPutAll: regName; nextPutAll: ': '.
regValue printOn: aStream base: 16 length: 8 padded: true.
aStream cr
]]!

----- Method: RemoteGDBSession>>qXfer (in category 'RSP Helpers') -----
qXfer
qXfer isNil ifTrue: [ qXfer := RemoteGdbXFER gdb: self ].
^ qXfer!

----- Method: RemoteGDBSession>>runStepsWithMagickCallback: (in category 'magick') -----
runStepsWithMagickCallback: magicCallbackBlock
[ true ] whileTrue: [ self stepUntilMagick. magicCallbackBlock value ] !

----- Method: RemoteGDBSession>>runUntil: (in category 'RSP commands') -----
runUntil: aBlock
[ self c ] doWhileFalse: aBlock!

----- Method: RemoteGDBSession>>runUntilMagick (in category 'magick') -----
runUntilMagick
self runUntil: [ self currentInstructionEncoding = (Integer readFrom: self exe objectMemory targetSetup magicInstruction radix: 2) ]!

----- Method: RemoteGDBSession>>runWithMagickCallback: (in category 'magick') -----
runWithMagickCallback: magicCallbackBlock
[ true ] whileTrue: [ self runUntilMagick. magicCallbackBlock value ] !

----- Method: RemoteGDBSession>>setRegister:to: (in category 'accessing') -----
setRegister: r to: x
| regs |
regs := self getRegisters.
regs at: r put: x.
self setRegisters: regs!

----- Method: RemoteGDBSession>>stepUntil: (in category 'RSP commands') -----
stepUntil: aBlock
[ self s.
Transcript show: ((self getRegisters at: 'r19') printString); cr.
] doWhileFalse: aBlock!

----- Method: RemoteGDBSession>>stepUntilMagick (in category 'magick') -----
stepUntilMagick
self stepUntil: [ self currentInstructionEncoding = self exe objectMemory targetSetup magicInstruction ]!

----- Method: RemoteGDBSession>>supportsFeatures (in category 'RSP commands') -----
supportsFeatures
" Answer whether the stub supports target feature descriptors. "
| features |
features := supported detect: [ :s | s beginsWith: 'qXfer:features:' ] ifNone: [ ^false ].
features = 'qXfer:features:read+' ifFalse: [ self error: 'Havent encountered such a CPU yet; investigate' ].
"In reality the following line must be, ^true."
^false "disabled for now, before we have xi:include in the XML parser"
!

----- Method: RemoteGDBSession>>vFile (in category 'RSP Helpers') -----
vFile
vFile isNil ifTrue: [ vFile := RemoteGdbVFILE gdb: self ].
^ vFile!

----- Method: RemoteGDBTransport class>>host: (in category 'as yet unclassified') -----
host: h
^self host: h port: self wellKnownPort !

----- Method: RemoteGDBTransport class>>host:port: (in category 'as yet unclassified') -----
host: h port: p
| socket |
socket := Socket newTCP
connectTo: (NetNameResolver addressForName: h) port: p.
^self onSocket: socket!

----- Method: RemoteGDBTransport class>>onSocket: (in category 'as yet unclassified') -----
onSocket: aSocket
^self new socket: aSocket !

----- Method: RemoteGDBTransport class>>wellKnownPort (in category 'as yet unclassified') -----
wellKnownPort
^2159!

----- Method: RemoteGDBTransport>>assemblePacket: (in category 'private') -----
assemblePacket: packetDataString
| s cksum |
s := '$', (self escape: packetDataString), '#'.
cksum := packetDataString inject: 0 into: [ :soFar :c | soFar + c asciiValue \\ 256 ].
^s, (cksum printStringBase: 16 nDigits: 2) asLowercase
!

----- Method: RemoteGDBTransport>>disconnect (in category 'target connection') -----
disconnect
self socket close!

----- Method: RemoteGDBTransport>>escape: (in category 'private') -----
escape: aString
^aString inject: '' into: [ :soFar :c | soFar, (self escapeChar: c) ].
!

----- Method: RemoteGDBTransport>>escapeChar: (in category 'private') -----
escapeChar: c
"Where the characters '#' or '$' appear in the packet data,
they must be escaped.
The escape character is ASCII 0x7d ('}'),
and is followed by the original character XORed with 0x20.
The character '}' itself must also be escaped."

((c == $# or: [c == $$]) or: [c == $}]) ifTrue: [
^String with: $} with: (Character value: (c asciiValue bitXor: 16r20))
] ifFalse: [ ^String with: c ]!

----- Method: RemoteGDBTransport>>readAndVerifyCksum: (in category 'private') -----
readAndVerifyCksum: anInteger
"Read next two characters from the TCP stream and verify that they represent the same hext number as anInteger."
| cksumFromServer |

cksumFromServer := Integer
readFrom: (String with: self receiveByte with: self receiveByte)
radix: 16.
"cksumFromServer = anInteger ifFalse: [ self error: 'Wrong checksum' ]"!

----- Method: RemoteGDBTransport>>receive (in category 'API') -----
receive
| c stream cksum cc |
"Receive and decode the server's response.
It may come in chunks on the TCP stream; in that sense, the word Packet may be confusing."

self receiveByte = $$ ifFalse: [ self error: 'Packet does not start with $' ].

stream := WriteStream with: ''.
cksum := 0.
[ c := self receiveChar. c = $# ] whileFalse: [
cksum := cksum + c asInteger \\ 256.
c = $* ifTrue: [
| nChar |
nChar := self receiveChar asciiValue.
cksum := cksum + nChar \\ 256.
nChar - 29 timesRepeat: [ stream nextPut: cc. ]
"RLE"
] ifFalse: [ stream nextPut: c. cc := c. ]].
"TODO: escaping"
self readAndVerifyCksum: cksum.
socket sendData: '+'.

^stream contents
!

----- Method: RemoteGDBTransport>>receiveByte (in category 'API') -----
receiveByte
| buf1 |
"Receive exactly one byte, waiting for it if neccesary.
This is at a level lower than escaping; see #receiveChar for the escaped version."
buf1 := ByteString new: 1.
(socket receiveDataInto: buf1) == 1 ifFalse: [GdbChildExited new signal].
^buf1 first!

----- Method: RemoteGDBTransport>>receiveChar (in category 'API') -----
receiveChar
"Receive the next char from the TCP stream."

| byte |
byte := self receiveByte.
"Do NOT escape at this level; check for RLE, and then escaping is above."
^byte!

----- Method: RemoteGDBTransport>>send: (in category 'API') -----
send: aString
| packet ack n |
packet := self assemblePacket: aString.
socket sendData: packet.
ack := '*'.
n := socket receiveDataInto: ack.
ack = '+' ifFalse: [ self error: 'gdb server answered ', ack ]
!

----- Method: RemoteGDBTransport>>socket (in category 'accessing') -----
socket
^ socket!

----- Method: RemoteGDBTransport>>socket: (in category 'accessing') -----
socket: aSocket
socket := aSocket!

Object subclass: #RemoteGdbAbstractHelper
instanceVariableNames: 'gdb'
classVariableNames: ''
poolDictionaries: ''
category: 'GDB-RSP'!

----- Method: RemoteGdbAbstractHelper class>>gdb: (in category 'instance creation') -----
gdb: aRemoteGDB
^self new
gdb: aRemoteGDB ;
yourself !

----- Method: RemoteGdbAbstractHelper>>gdb (in category 'accessing') -----
gdb
^ gdb!

----- Method: RemoteGdbAbstractHelper>>gdb: (in category 'accessing') -----
gdb: anObject
gdb := anObject!

RemoteGdbAbstractHelper subclass: #RemoteGdbVFILE
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'GDB-RSP'!

RemoteGdbAbstractHelper subclass: #RemoteGdbXFER
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'GDB-RSP'!

----- Method: RemoteGdbXFER>>features: (in category 'as yet unclassified') -----
features: filename
| answer |
answer := self readFeatureDocument: filename.
answer isEmpty ifTrue: [ ^nil ]. " stub has indicated he does not understand this request "
answer first == $l ifFalse: [ ^self error ].
answer := answer allButFirst.
^self parseFeatures: answer!

----- Method: RemoteGdbXFER>>parseFeatures: (in category 'as yet unclassified') -----
parseFeatures: aStringOfXML
self shouldBeImplemented

"The below code used to work,
back when we had PPXmlParser.

| xml gdbXmlParser |

gdbXmlParser := GdbXmlParser endian: gdb processorDescription endian.
gdbXmlParser parseString: aStringOfXML.
self halt.
xml baseURI: (RemoteGdbFeatureURIProvider gdb: gdb).
^xml rootElement copy"!

----- Method: RemoteGdbXFER>>readFeatureDocument: (in category 'as yet unclassified') -----
readFeatureDocument: filename
^gdb q: 'qXfer:features:read:', filename, ':0,fff'!

Object subclass: #RemoteGdbFeatureURIProvider
instanceVariableNames: 'gdb'
classVariableNames: ''
poolDictionaries: ''
category: 'GDB-RSP'!

----- Method: RemoteGdbFeatureURIProvider class>>gdb: (in category 'as yet unclassified') -----
gdb: aGDB
^self new
gdb: aGDB;
yourself !

----- Method: RemoteGdbFeatureURIProvider>>gdb (in category 'accessing') -----
gdb
^ gdb!

----- Method: RemoteGdbFeatureURIProvider>>gdb: (in category 'accessing') -----
gdb: anObject
gdb := anObject!

----- Method: RemoteGdbFeatureURIProvider>>get: (in category 'API') -----
get: filename
^gdb qXfer features: filename!

Object subclass: #ShmemUFFI
instanceVariableNames: 'ptr'
classVariableNames: ''
poolDictionaries: ''
category: 'GDB-RSP'!

!ShmemUFFI commentStamp: 'BorisShingarov 5/23/2019 04:12' prior: 0!
FFI interface to Shared Memory.!

----- Method: ShmemUFFI class>>allocate: (in category 'NB interface to SHM') -----
allocate: nBytes
| ptr |
ptr := self shmaddr: nBytes.
^ShmemUFFI new
ptr: ptr;
yourself !

----- Method: ShmemUFFI class>>shmaddr: (in category 'NB interface to SHM') -----
shmaddr: size
" ShmemUFFI shmaddr: 1024000 "

^ self
ffiCall: #( void* shmaddr (int size) )
module: self soName!

----- Method: ShmemUFFI class>>soName (in category 'NB interface to SHM') -----
soName
^'/home/boris/work/thinshell/HelloNB.so'!

----- Method: ShmemUFFI>>ptr (in category 'accessing') -----
ptr
^ ptr!

----- Method: ShmemUFFI>>ptr: (in category 'accessing') -----
ptr: anObject
ptr := anObject!

Object subclass: #SimulationAddressSpace
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'GDB-RSP'!

SimulationAddressSpace subclass: #RemoteRAM
instanceVariableNames: 'gdb'
classVariableNames: ''
poolDictionaries: ''
category: 'GDB-RSP'!

RemoteRAM subclass: #BufferingRemoteRAM
instanceVariableNames: 'buffer minAddr leftFinger queuedBreakpoints'
classVariableNames: ''
poolDictionaries: ''
category: 'GDB-RSP'!

----- Method: BufferingRemoteRAM>>buffer (in category 'accessing') -----
buffer
buffer isNil ifTrue: [ buffer := ByteArray new: (4*1024*1024) + (1024*1024) + (80*1024*1024) ].
^buffer!

----- Method: BufferingRemoteRAM>>chunkSize (in category 'flushing') -----
chunkSize
"In bytes"
^2048 "maybe? this was always 4096, I have no idea why this started breaking in Maribor"!

----- Method: BufferingRemoteRAM>>flushRAM (in category 'flushing') -----
flushRAM
| firstUnallocatedAddress |
firstUnallocatedAddress := self getVRegister: #HEAP.
leftFinger := 1.
'Injecting program'
displayProgressFrom: minAddr to: firstUnallocatedAddress during:
[ :bar | self transmitBelow: firstUnallocatedAddress updating: bar ]
!

----- Method: BufferingRemoteRAM>>insertSWBreakpointAt: (in category 'API') -----
insertSWBreakpointAt: addr
self queuedBreakpoints add: addr

!

----- Method: BufferingRemoteRAM>>minAddr (in category 'accessing') -----
minAddr
minAddr isNil ifTrue: [ minAddr := self getVRegister: #NZone ].
^minAddr!

----- Method: BufferingRemoteRAM>>queuedBreakpoints (in category 'accessing') -----
queuedBreakpoints
queuedBreakpoints isNil ifTrue: [ queuedBreakpoints := OrderedCollection new ].
^queuedBreakpoints!

----- Method: BufferingRemoteRAM>>read32At: (in category 'API') -----
read32At: addr
leftFinger isNil ifTrue: [
^(((self buffer at: addr - self minAddr + 1) << 24
bitOr: (self buffer at: addr - self minAddr + 2) << 16)
bitOr: (self buffer at: addr - self minAddr + 3) << 8)
bitOr: (self buffer at: addr - self minAddr + 4)
].
^super read32At: addr!

----- Method: BufferingRemoteRAM>>transmitBelow:updating: (in category 'flushing') -----
transmitBelow: firstUnallocatedAddress updating: aProgressBar
| bytes thisChunk |
bytes := firstUnallocatedAddress - self minAddr.
bytes = 0 ifTrue: [ buffer := nil. ^self ].
bytes > self chunkSize ifTrue: [ bytes := self chunkSize ].

thisChunk := buffer copyFrom: leftFinger to: leftFinger + bytes - 1.
aProgressBar value: minAddr.
self writeBytes: thisChunk toAddr: minAddr.
minAddr := minAddr + bytes.
leftFinger := leftFinger + bytes.
self transmitBelow: firstUnallocatedAddress updating: aProgressBar !

----- Method: BufferingRemoteRAM>>writeBytes:toAddr: (in category 'API') -----
writeBytes: aByteArray toAddr: addr
| start stop |
leftFinger isNil ifTrue: [
start := addr - self minAddr + 1.
stop := start + aByteArray size - 1.
^self buffer replaceFrom: start to: stop with: aByteArray startingAt: 1 ].
^super writeBytes: aByteArray toAddr: addr!

----- Method: BufferingRemoteRAM>>writeInt32:toAddr: (in category 'API') -----
writeInt32: int toAddr: addr
leftFinger isNil ifTrue: [
^self buffer
at: addr - self minAddr + 1 put: ((int bitAnd: 16rFF000000) >> 24);
at: addr - self minAddr + 2 put: ((int bitAnd: 16r00FF0000) >> 16);
at: addr - self minAddr + 3 put: ((int bitAnd: 16r0000FF00) >> 8);
at: addr - self minAddr + 4 put: (int bitAnd: 16r000000FF) ].
super writeInt32: int toAddr: addr
!

RemoteRAM subclass: #Gem5SharedRAM
instanceVariableNames: 'tlb hostPtr shmemSize'
classVariableNames: ''
poolDictionaries: ''
category: 'GDB-RSP'!

----- Method: Gem5SharedRAM class>>gem5: (in category 'FFI') -----
gem5: nBytes
"Answer the void* pointer to the backing store of the gem5 guest memory."
| fd addr |
fd := self shmOpen: '/gem5'
with: 64"O_CREAT" | 2"O_RDWR"
with: 8r666. "mode"
addr := self mmap: 0
with: nBytes
with: 1"PROT_READ" | 2"PROT_WRITE"
with: 1 "MAP_SHARED"
with: fd
with: 0.
^addr

"
Gem5SharedRAM halt; gem5: 5000
"
!

----- Method: Gem5SharedRAM class>>mmap:with:with:with:with:with: (in category 'FFI') -----
mmap: addr with: length with: prot with: flags with: fd with: offset
<cdecl: void* 'mmap' (longlong longlong long long long longlong) module: '/lib/x86_64-linux-gnu/libc.so.6'>
^self externalCallFailed
!

----- Method: Gem5SharedRAM class>>mmuPageSize (in category 'granularity') -----
mmuPageSize
^4096!

----- Method: Gem5SharedRAM class>>offsetMask (in category 'granularity') -----
offsetMask
^self mmuPageSize - 1!

----- Method: Gem5SharedRAM class>>pageMask (in category 'granularity') -----
pageMask
^16rFFFFFFFF bitXor: self offsetMask
!

----- Method: Gem5SharedRAM class>>shmOpen:with:with: (in category 'FFI') -----
shmOpen: name with: oflag with: mode
<cdecl: ulong 'shm_open' (char* ulong ulong) module: '/lib/x86_64-linux-gnu/librt.so.1'>
^self externalCallFailed
!

----- Method: Gem5SharedRAM>>byteAtAddr:put: (in category 'writing') -----
byteAtAddr: byteAddress put: byte
| ptr |
byteAddress = 16r109014 ifTrue: [self halt].
ptr := self translate: byteAddress.
ptr unsignedByteAt: 1 put: byte!

----- Method: Gem5SharedRAM>>fillFromStream:startingAt:count: (in category 'writing') -----
fillFromStream: aFileStream startingAt: startAddress count: count
| contents |
contents := aFileStream next: count.
self writeBytes: contents toAddr: startAddress.
^contents size!

----- Method: Gem5SharedRAM>>forceRead32At: (in category 'address translation') -----
forceRead32At: addr
| x |
self halt. "I don't remember why this was needed."
x := super read32At: addr.
tlb := self getTLB.
^x
!

----- Method: Gem5SharedRAM>>forceReadAt:nBytes: (in category 'address translation') -----
forceReadAt: addr nBytes: n
super readAt: addr nBytes: n.
tlb := self getTLB!

----- Method: Gem5SharedRAM>>forceWriteBytes:toAddr: (in category 'address translation') -----
forceWriteBytes: aByteArray toAddr: addr
| x |
x := super writeBytes: aByteArray toAddr: addr.
tlb := self getTLB.
^x
!

----- Method: Gem5SharedRAM>>forceWriteInt32:toAddr: (in category 'address translation') -----
forceWriteInt32: int toAddr: addr
| x |
x := super writeInt32: int toAddr: addr.
tlb := self getTLB.
^x
!

----- Method: Gem5SharedRAM>>getTLB (in category 'RSP') -----
getTLB
| answer |
answer := self gdb q: '.'.
answer isEmpty ifTrue: [ self error: 'GDB failed to return TLB' ].
^Dictionary newFromAssociations:
(((answer findTokens: ';')
collect: [ :s | s findTokens: ':' ])
collect: [ :pair | (Integer readFrom: pair first base: 16) -> (Integer readFrom: pair last base: 16) ])!

----- Method: Gem5SharedRAM>>hostPtr (in category 'shmem') -----
hostPtr
hostPtr isNil ifTrue: [ hostPtr := Gem5SharedRAM gem5: shmemSize ].
^hostPtr!

----- Method: Gem5SharedRAM>>longAtAddr:put:bigEndian: (in category 'writing') -----
longAtAddr: addr put: aValue bigEndian: bigEndian
| ptr int |
int := bigEndian
ifTrue: [ aValue byteSwap32 ]
ifFalse: [ aValue ].
ptr := self translate: addr.
ptr unsignedLongAt: 1 put: int

!

----- Method: Gem5SharedRAM>>read:bytesAtAddr: (in category 'reading') -----
read: n bytesAtAddr: addr
| backingAddr |
backingAddr := self translate: addr.
^((1 to: n) collect: [ :idx| backingAddr byteAt: idx ]) asByteArray
!

----- Method: Gem5SharedRAM>>shmemSize (in category 'shmem') -----
shmemSize
^shmemSize!

----- Method: Gem5SharedRAM>>shmemSize: (in category 'shmem') -----
shmemSize: howBig
shmemSize := howBig!

----- Method: Gem5SharedRAM>>tlb (in category 'address translation') -----
tlb
tlb isNil ifTrue: [ tlb := self getTLB ].
^tlb!

----- Method: Gem5SharedRAM>>translate: (in category 'address translation') -----
translate: addr
| pageAddr |
pageAddr := self virt2phys: addr.
pageAddr isNil ifTrue: [ ^ self error forceRead32At: addr ].
^self hostPtr getHandle + pageAddr.
!

----- Method: Gem5SharedRAM>>unsignedLongAtAddr:bigEndian: (in category 'reading') -----
unsignedLongAtAddr: addr bigEndian: bigEndian
| backingAddr int |
backingAddr := self translate: addr.
int := backingAddr unsignedLongAt: 1.
bigEndian ifTrue: [ int := int byteSwap32].
^int!

----- Method: Gem5SharedRAM>>virt2phys: (in category 'address translation') -----
virt2phys: anAddress
" Answer the physical address for the given virtual address,
if it is mapped, nil otherwise. "
| pageVirt pagePhys |
pageVirt := anAddress bitAnd: self class pageMask.
pagePhys := self tlb at: pageVirt ifAbsent: [ ^nil ].
^pagePhys bitOr: (anAddress bitAnd: self class offsetMask)!

----- Method: Gem5SharedRAM>>writeBytes:toAddr: (in category 'writing') -----
writeBytes: aByteArray toAddr: addr
| ptr |
addr = 16r109014 ifTrue: [self halt].
ptr := self translate: addr.
aByteArray doWithIndex: [ :x :idx | ptr unsignedByteAt: idx put: x ] "is there a faster way?"
!

Gem5SharedRAM subclass: #Gem5SharedRAM8K
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'GDB-RSP'!

----- Method: Gem5SharedRAM8K class>>mmuPageSize (in category 'granularity') -----
mmuPageSize
"GEM5 MIPS. Sweetman claims this should not happen."
^8192!

----- Method: RemoteRAM class>>gdb: (in category 'instance creation') -----
gdb: aRemoteGDB
^self basicNew
gdb: aRemoteGDB;
yourself !

----- Method: RemoteRAM>>byteAt: (in category 'reading') -----
byteAt: index
"Compatibe with the ByteArray.
Index is measured in bytes, and is 1-based.
The return value is always unsigned."
^self byteAtAddr: index - 1!

----- Method: RemoteRAM>>byteAt:put: (in category 'writing') -----
byteAt: index put: byte
self byteAtAddr: index - 1 put: byte!

----- Method: RemoteRAM>>byteAtAddr: (in category 'reading') -----
byteAtAddr: addr
^self unsignedByteAtAddr: addr!

----- Method: RemoteRAM>>byteAtAddr:put: (in category 'writing') -----
byteAtAddr: byteAddress put: byte
| textualAddr data |
data := byte printStringBase: 16 length: 2 padded: true.
textualAddr := byteAddress printStringBase: 16 length: 8 padded: true.
^ self writeBytesHex: data toAddrHex: textualAddr hexSize: '1'!

----- Method: RemoteRAM>>flush (in category 'target synchronization') -----
flush
"Do nothing because I write directly to the target's memory"!

----- Method: RemoteRAM>>gdb (in category 'debugger access') -----
gdb
^ gdb!

----- Method: RemoteRAM>>gdb: (in category 'debugger access') -----
gdb: anObject
gdb := anObject!

----- Method: RemoteRAM>>long64At:put: (in category 'reading') -----
long64At: byteIndex put: aValue
| lowBits mask wordIndex |
(lowBits := byteIndex - 1 \\ 4) = 0 ifTrue:
[self "N.B. Do the access that can fail first, before altering the receiver"
longAt: byteIndex + 4 put: (aValue bitShift: -32);
unsignedLongAt: byteIndex put: (aValue bitAnd: 16rffffffff).
^aValue].
"There will always be three accesses; two partial words and a full word in the middle"
wordIndex := byteIndex - 1 // 4 + 1.
aValue < 0
ifTrue:
[(aValue bitShift: -32) < -2147483648 ifTrue:
[^self errorImproperStore]]
ifFalse:
[16r7FFFFFFF < (aValue bitShift: -32) ifTrue:
[^self errorImproperStore]].
mask := 16rFFFFFFFF bitShift: 4 - lowBits * -8.
self at: wordIndex put: (((self at: wordIndex) bitAnd: mask) bitXor: ((aValue bitShift: lowBits * 8) bitAnd: mask bitInvert32)).
self at: wordIndex + 1 put: ((aValue bitShift: 4 - lowBits * -8) bitAnd: 16rFFFFFFFF).
self at: wordIndex + 2 put: (((self at: wordIndex + 2) bitAnd: mask bitInvert32) bitXor: ((aValue bitShift: 4 - lowBits + 4 * -8) bitAnd: mask)).
^aValue!

----- Method: RemoteRAM>>longAt:put: (in category 'writing') -----
longAt: byteIndex put: int
^self unsignedLongAt: byteIndex put: int
!

----- Method: RemoteRAM>>longAt:put:bigEndian: (in category 'writing') -----
longAt: byteIndex put: aValue bigEndian: bigEndian
"Compatibility with the ByteArray method of the same name."
self longAtAddr: byteIndex - 1 put: aValue bigEndian: bigEndian!

----- Method: RemoteRAM>>longAtAddr:put:bigEndian: (in category 'writing') -----
longAtAddr: addr put: aValue bigEndian: bigEndian
"Compatibility with the ByteArray method of the same name."
| textualAddr data textualData |
textualAddr := addr printStringBase: 16 length: 8 padded: true.
data := bigEndian
ifTrue: [ aValue ]
ifFalse: [ aValue byteSwap32 ].
textualData := data printStringBase: 16 length: 8 padded: true.
self writeBytesHex: textualData
toAddrHex: textualAddr
hexSize: '4'!

----- Method: RemoteRAM>>read:bytesAsHexAt: (in category 'RSP protocol') -----
read: n bytesAsHexAt: addr
"Answer the hex string the gdbserver will return to represent the n bytes read from address addr.
All read operations are implemented on top of this primitive."
^self gdb q: 'm',
addr printStringHex,
',',
n printStringHex
!

----- Method: RemoteRAM>>read:bytesAt: (in category 'reading') -----
read: n bytesAt: index
^self read: n bytesAtAddr: index - 1!

----- Method: RemoteRAM>>read:bytesAtAddr: (in category 'reading') -----
read: n bytesAtAddr: addr
| answer stream |
answer := self read: n bytesAsHexAt: addr.
stream := ReadStream on: answer
from: 1
to: answer size.
answer := ByteArray new: n.
1 to: n do: [ :idx |
| b |
b := stream next: 2.
answer at: idx put: (Integer readFrom: b base: 16) ].
^answer!

----- Method: RemoteRAM>>readInt32fromAddr: (in category 'remote endian') -----
readInt32fromAddr: addr
"Read, using the REMOTE TARGET endianness."
^self unsignedLongAtAddr: addr bigEndian: self isBigEndian!

----- Method: RemoteRAM>>signedLong64At: (in category 'reading') -----
signedLong64At: byteIndex
^(self unsignedLong64At: byteIndex) signedIntFromLong64
!

----- Method: RemoteRAM>>unsignedByteAt: (in category 'reading') -----
unsignedByteAt: index
^self unsignedByteAtAddr: index - 1!

----- Method: RemoteRAM>>unsignedByteAtAddr: (in category 'reading') -----
unsignedByteAtAddr: addr
^(self read: 1 bytesAtAddr: addr) first!

----- Method: RemoteRAM>>unsignedLong64At: (in category 'reading') -----
unsignedLong64At: byteIndex
^self unsignedLong64AtAddr: byteIndex - 1!

----- Method: RemoteRAM>>unsignedLong64AtAddr: (in category 'reading') -----
unsignedLong64AtAddr: addr
| hiWord loWord |
addr \\ 8 ~= 0 ifTrue: [self unalignedAccessError].
loWord := self unsignedLongAtAddr: addr bigEndian: false.
hiWord := self unsignedLongAtAddr: addr + 4 bigEndian: false.
^hiWord = 0
ifTrue: [loWord]
ifFalse: [(hiWord bitShift: 32) + loWord]!

----- Method: RemoteRAM>>unsignedLongAt:bigEndian: (in category 'reading') -----
unsignedLongAt: byteIndex bigEndian: bigEndian
^self unsignedLongAtAddr: byteIndex - 1 bigEndian: bigEndian!

----- Method: RemoteRAM>>unsignedLongAt:put: (in category 'writing') -----
unsignedLongAt: byteIndex put: int
self longAtAddr: byteIndex - 1 put: int bigEndian: self isBigEndian!

----- Method: RemoteRAM>>unsignedLongAtAddr:bigEndian: (in category 'reading') -----
unsignedLongAtAddr: addr bigEndian: bigEndian
| string int |
string := self read: 4 bytesAsHexAt: addr.
int := Integer readFrom: string radix: 16.
bigEndian ifFalse: [ int := int byteSwap32 ].
^int!

----- Method: RemoteRAM>>unsignedShortAtAddr:bigEndian: (in category 'reading') -----
unsignedShortAtAddr: addr bigEndian: bigEndian
| string int |
string := self read: 2 bytesAsHexAt: addr.
int := Integer readFrom: string radix: 16.
bigEndian ifFalse: [ int := int byteSwap16 ].
^int!

----- Method: RemoteRAM>>writeBytes:toAddr: (in category 'writing') -----
writeBytes: aByteArray toAddr: addr
| buffer textualAddr textualSize |
buffer := WriteStream on: (String new: aByteArray size * 2).
aByteArray do: [ :aByte |
| data |
data := aByte printStringBase: 16 length: 2 padded: true.
buffer nextPutAll: data
].
textualAddr := addr printStringBase: 16 length: 8 padded: true.
textualSize := aByteArray size printStringBase: 16.
self writeBytesHex: buffer contents
toAddrHex: textualAddr
hexSize: textualSize!

----- Method: RemoteRAM>>writeBytesHex:toAddrHex:hexSize: (in category 'RSP protocol') -----
writeBytesHex: aString toAddrHex: addr hexSize: s
| answer |
answer := gdb
q: 'M', addr, ',', s, ':', aString.
answer = 'OK' ifFalse: [ self error: 'RSP protocol failure' ].

!

----- Method: RemoteRAM>>writeInt32:toAddr: (in category 'writing') -----
writeInt32: int toAddr: addr
"Use the REMOTE TARGET's endianness."
self longAtAddr: addr put: int bigEndian: self isBigEndian!

----- Method: RemoteRAM>>writeInt32s:toAddr: (in category 'writing') -----
writeInt32s: arrayOfInt32s toAddr: addr
"Using the remote endianness."
self writeInt32s: arrayOfInt32s toAddr: addr bigEndian: self isBigEndian
!

----- Method: RemoteRAM>>writeInt32s:toAddr:bigEndian: (in category 'writing') -----
writeInt32s: arrayOfInt32s toAddr: addr bigEndian: bigEndian
"Using the remote endianness."
| buffer textualAddr textualSize |
buffer := WriteStream on: ''.
arrayOfInt32s do: [ :anInt32 |
| data textualData |
data := bigEndian
ifTrue: [ anInt32 ]
ifFalse: [ anInt32 byteSwap32 ].
textualData := data printStringBase: 16 length: 8 padded: true.
buffer nextPutAll: textualData
].
textualAddr := addr printStringBase: 16 length: 8 padded: true.
textualSize := arrayOfInt32s size * 4 printStringBase: 16.
self writeBytesHex: buffer contents
toAddrHex: textualAddr
hexSize: textualSize!

----- Method: SimulationAddressSpace class>>bytesPerElement (in category 'as yet unclassified') -----
bytesPerElement
^1!

----- Method: SimulationAddressSpace class>>new: (in category 'as yet unclassified') -----
new: bytes
"I really hate this design.
The only reason #new: is here is because there is no concept of conneciton
between the processor and memory."
| instance |
instance := self gdb: TargetAwareX86 current gdb.
instance shmemSize: 120*1024*1024.
^instance!

----- Method: SimulationAddressSpace>>currentInstructionEncoding (in category 'as yet unclassified') -----
currentInstructionEncoding
^self readInt32fromAddr: self gdb pc!

----- Method: SimulationAddressSpace>>endianness (in category 'as yet unclassified') -----
endianness
"Answer the endianness OF THE REMOTE TARGET."
^self gdb processorDescription endian!

----- Method: SimulationAddressSpace>>isBigEndian (in category 'as yet unclassified') -----
isBigEndian
^self endianness == #big!

Object subclass: #TAJTargetSetup
instanceVariableNames: 'gdbClass host port architecture processor magicInstruction instructionStreamClass breakpointKind'
classVariableNames: ''
poolDictionaries: ''
category: 'GDB-TAJ'!

----- Method: TAJTargetSetup class>>current (in category 'settings') -----
current
^self gem5PPC !

----- Method: TAJTargetSetup class>>gem5MIPS (in category 'settings') -----
gem5MIPS
| arch |
arch := self tajMIPSArchitecture.
^self new
gdbClass: Gem5SharedRAM8K;
host: '192.168.75.2';
port: 7000;
architecture: arch;
instructionStreamClass: TargetAgnosticInstructionStream;
breakpointKind: #hard;
magicInstruction: (((arch isa instructionAt: #sll) bind: (Dictionary new
at: 'rs' put: 0;
at: 'rt' put: 0;
at: 'rd' put: 0;
at: 'shamt' put: 0;
yourself)) emit);
yourself!

----- Method: TAJTargetSetup class>>gem5PPC (in category 'settings') -----
gem5PPC
| arch |
arch := self tajPOWERArchitecture.
^self new
gdbClass: Gem5SharedRAM;
host: '127.0.0.1';
port: 7000;
architecture: arch;
instructionStreamClass: TargetAgnosticInstructionStream;
breakpointKind: #hard;
magicInstruction: (((arch isa instructionAt: #ore) bind: (Dictionary new
at: 'ra' put: 1;
at: 'rb' put: 1;
at: 'rs' put: 1;
at: 'rc' put: 0;
yourself)) emit);
yourself!

----- Method: TAJTargetSetup class>>gem86 (in category 'settings') -----
gem86
| arch |
arch := self tajIA32Architecture.
^self new
gdbClass: BufferingRemoteRAM;
host: '192.168.75.2';
port: 7000;
architecture: arch;
instructionStreamClass: TargetAgnosticInstructionStream;

"bogus, I still don't what it should be on x86"
magicInstruction: 16r0;
breakpointKind: #trap;
yourself!

----- Method: TAJTargetSetup class>>mpc5125 (in category 'settings') -----
mpc5125
| arch |
arch := self tajPOWERArchitecture.
^self new
gdbClass: BufferingRemoteRAM;
host: '192.168.75.39';
port: 7000;
architecture: arch;
instructionStreamClass: TargetAgnosticInstructionStream;

"twge r2,r2; see gdb/gdbserver/linux-ppc-low.c.
ptrace will happily send SIGTRAP for any tw,
but gdb's breakpoint_at() will be confused unless
the memory contents are exactly what it thinks
the SW break instruction is."
magicInstruction: 16r7D821008;
breakpointKind: #trap;
yourself!

----- Method: TAJTargetSetup class>>p1025 (in category 'settings') -----
p1025
"Freescale TWR-P1025 PowerPC e500v2"
| arch |
arch := self tajPOWERArchitecture.
^self new
gdbClass: BufferingRemoteRAM;
host: '192.168.75.199';
port: 7000;
architecture: arch;
instructionStreamClass: TargetAgnosticInstructionStream;

"twge r2,r2; see gdb/gdbserver/linux-ppc-low.c.
ptrace will happily send SIGTRAP for any tw,
but gdb's breakpoint_at() will be confused unless
the memory contents are exactly what it thinks
the SW break instruction is."
magicInstruction: 16r7D821008;
breakpointKind: #trap;
yourself!

----- Method: TAJTargetSetup class>>tajIA32Architecture (in category 'TAJArchitectures') -----
tajIA32Architecture
^"TAJIA32Architecture"0 resetDefault!

----- Method: TAJTargetSetup class>>tajMIPSArchitecture (in category 'TAJArchitectures') -----
tajMIPSArchitecture
^"TAJMIPSArchitecture"0 resetDefault!

----- Method: TAJTargetSetup class>>tajPOWERArchitecture (in category 'TAJArchitectures') -----
tajPOWERArchitecture
^"TAJPowerArchitecture"0 resetDefault!

----- Method: TAJTargetSetup>>architecture (in category 'accessing') -----
architecture
^ architecture!

----- Method: TAJTargetSetup>>architecture: (in category 'accessing') -----
architecture: anObject
architecture := anObject!

----- Method: TAJTargetSetup>>breakpointKind (in category 'accessing') -----
breakpointKind
^ breakpointKind!

----- Method: TAJTargetSetup>>breakpointKind: (in category 'accessing') -----
breakpointKind: anObject
breakpointKind := anObject!

----- Method: TAJTargetSetup>>gdbClass (in category 'accessing') -----
gdbClass
^ gdbClass!

----- Method: TAJTargetSetup>>gdbClass: (in category 'accessing') -----
gdbClass: anObject
gdbClass := anObject!

----- Method: TAJTargetSetup>>host (in category 'accessing') -----
host
^ host!

----- Method: TAJTargetSetup>>host: (in category 'accessing') -----
host: anObject
host := anObject!

----- Method: TAJTargetSetup>>instructionStreamClass (in category 'accessing') -----
instructionStreamClass
^ instructionStreamClass!

----- Method: TAJTargetSetup>>instructionStreamClass: (in category 'accessing') -----
instructionStreamClass: anObject
instructionStreamClass := anObject!

----- Method: TAJTargetSetup>>magicInstruction (in category 'accessing') -----
magicInstruction
^ magicInstruction!

----- Method: TAJTargetSetup>>magicInstruction: (in category 'accessing') -----
magicInstruction: anObject
magicInstruction := anObject!

----- Method: TAJTargetSetup>>port (in category 'accessing') -----
port
^ port!

----- Method: TAJTargetSetup>>port: (in category 'accessing') -----
port: anObject
port := anObject!

Object subclass: #TargetAwareX86
instanceVariableNames: 'gdb'
classVariableNames: 'Current ExtendedOpcodeExceptionMap OpcodeExceptionMap PostBuildStackDelta'
poolDictionaries: ''
category: 'GDB-Cog'!

----- Method: TargetAwareX86 class>>current (in category 'instance creation') -----
current
^Current!

----- Method: TargetAwareX86 class>>initialize (in category 'class initialization') -----
initialize
"TargetAwareX86 initialize"
| it |
it := self basicNew.
PostBuildStackDelta := 0.
OpcodeExceptionMap := Array new: 256 withAll: #handleExecutionPrimitiveFailureAt:in:.
OpcodeExceptionMap
at: 1 + it callOpcode put: #handleCallFailureAt:in:;
at: 1 + it jmpOpcode put: #handleJmpFailureAt:in:;
at: 1 + it retOpcode put: #handleRetFailureAt:in:;
at: 1 + it movALObOpcode put: #handleMovALObFailureAt:in:;
at: 1 + it movAXOvOpcode put: #handleMovAXOvFailureAt:in:;
at: 1 + it movObALOpcode put: #handleMovObALFailureAt:in:;
at: 1 + it movOvAXOpcode put: #handleMovOvAXFailureAt:in:;
at: 1 + it movGvEvOpcode put: #handleMovGvEvFailureAt:in:;
at: 1 + it movEvGvOpcode put: #handleMovEvGvFailureAt:in:;
at: 1 + it movGbEbOpcode put: #handleMovGbEbFailureAt:in:;
at: 1 + it movEbGbOpcode put: #handleMovEbGbFailureAt:in:.
ExtendedOpcodeExceptionMap := Array new: 256 withAll: #handleExecutionPrimitiveFailureAt:in:.
ExtendedOpcodeExceptionMap
at: 1 + it movGvEbOpcode put: #handleMovGvEbFailureAt:in:!

----- Method: TargetAwareX86 class>>new (in category 'instance creation') -----
new
"
TargetAwareX86 new
"
Current := super new connectGdb.
^Current!

----- Method: TargetAwareX86>>cResultRegister (in category 'accessing-abstract') -----
cResultRegister
^self eax!

----- Method: TargetAwareX86>>callOpcode (in category 'opcodes') -----
callOpcode
"[1] IA-32 Intel® Architecture Software Developer's Manual Volume 2B: Instruction Set Reference, N-Z.
table A2, pA8"
^16rE8!

----- Method: TargetAwareX86>>connectGdb (in category 'target connection') -----
connectGdb
gdb := self debuggerClass
host: self hostIP
port: self tcpPort
processorDescription: self pdl.
^self "not gdb; #new needs the instance"!

----- Method: TargetAwareX86>>debuggerClass (in category 'target connection') -----
debuggerClass
^RemoteGDBSession!

----- Method: TargetAwareX86>>eax (in category 'intel registers') -----
eax
^gdb getRegister: 'eax'!

----- Method: TargetAwareX86>>eax: (in category 'intel registers') -----
eax: anUnsignedInteger
gdb setRegister: 'eax' to: anUnsignedInteger.
^anUnsignedInteger!

----- Method: TargetAwareX86>>ebp (in category 'intel registers') -----
ebp
^gdb getRegister: 'ebp'!

----- Method: TargetAwareX86>>ebp: (in category 'intel registers') -----
ebp: anUnsignedInteger
gdb setRegister: 'ebp' to: anUnsignedInteger.
^anUnsignedInteger!

----- Method: TargetAwareX86>>ebx (in category 'intel registers') -----
ebx
^gdb getRegister: 'ebx'!

----- Method: TargetAwareX86>>ebx: (in category 'intel registers') -----
ebx: anUnsignedInteger
gdb setRegister: 'ebx' to: anUnsignedInteger.
^anUnsignedInteger!

----- Method: TargetAwareX86>>ecx (in category 'intel registers') -----
ecx
^gdb getRegister: 'ecx'!

----- Method: TargetAwareX86>>ecx: (in category 'intel registers') -----
ecx: anUnsignedInteger
gdb setRegister: 'ecx' to: anUnsignedInteger.
^anUnsignedInteger!

----- Method: TargetAwareX86>>edi (in category 'intel registers') -----
edi
^gdb getRegister: 'edi'!

----- Method: TargetAwareX86>>edi: (in category 'intel registers') -----
edi: anUnsignedInteger
gdb setRegister: 'edi' to: anUnsignedInteger.
^anUnsignedInteger!

----- Method: TargetAwareX86>>edx (in category 'intel registers') -----
edx
^gdb getRegister: 'edx'!

----- Method: TargetAwareX86>>edx: (in category 'intel registers') -----
edx: anUnsignedInteger
gdb setRegister: 'edx' to: anUnsignedInteger.
^anUnsignedInteger!

----- Method: TargetAwareX86>>eip (in category 'intel registers') -----
eip
^gdb getRegister: 'eip'!

----- Method: TargetAwareX86>>eip: (in category 'intel registers') -----
eip: anUnsignedInteger
gdb setRegister: 'eip' to: anUnsignedInteger.
^anUnsignedInteger!

----- Method: TargetAwareX86>>esi (in category 'intel registers') -----
esi
^gdb getRegister: 'esi'!

----- Method: TargetAwareX86>>esi: (in category 'intel registers') -----
esi: anUnsignedInteger
gdb setRegister: 'esi' to: anUnsignedInteger.
^anUnsignedInteger!

----- Method: TargetAwareX86>>esp (in category 'intel registers') -----
esp
^gdb getRegister: 'esp'!

----- Method: TargetAwareX86>>esp: (in category 'intel registers') -----
esp: anUnsignedInteger
gdb setRegister: 'esp' to: anUnsignedInteger.
^anUnsignedInteger!

----- Method: TargetAwareX86>>fp (in category 'accessing-abstract') -----
fp
^self ebp!

----- Method: TargetAwareX86>>gdb (in category 'target connection') -----
gdb
^gdb!

----- Method: TargetAwareX86>>handleCallFailureAt:in: (in category 'error handling') -----
handleCallFailureAt: pc "<Integer>" in: memoryArray "<Bitmap|ByteArray>"
"Convert an execution primitive failure for a call into a ProcessorSimulationTrap signal."
| relativeJump |
relativeJump := memoryArray longAt: pc + 2 bigEndian: false.
"NB: CRAP!! CRAP!! CRAP!! The real CPU already pushed the return address!!"
self esp: self esp + 4.

^(ProcessorSimulationTrap
pc: pc
nextpc: pc + 5
address: (pc + 5 + relativeJump) signedIntToLong
type: #call)
signal!

----- Method: TargetAwareX86>>handleExecutionPrimitiveFailureAt:in: (in category 'error handling') -----
handleExecutionPrimitiveFailureAt: pc "<Integer>" in: memoryArray "<Bitmap|ByteArray>"
"Handle an execution primitive failure for an unhandled opcode."
^self reportPrimitiveFailure!

----- Method: TargetAwareX86>>handleExecutionPrimitiveFailureIn:minimumAddress: (in category 'execution') -----
handleExecutionPrimitiveFailureIn: memoryArray minimumAddress: minimumAddress
"NB: THIS SHOULD GO INTO A COMMON SemihostABI CLASS -- bgs"
"Handle an execution primitive failure. Convert out-of-range call and absolute
memory read into register instructions into ProcessorSimulationTrap signals."
"self printIntegerRegistersOn: Transcript"
"self printRegistersOn: Transcript"
| pc opcode |
pc := self eip.
" (() between: minimumAddress and: memoryArray byteSize - 1) ifTrue: self reportPrimitiveFailure -- TODO"
opcode := memoryArray byteAt: pc + 1.
opcode ~= 16r0f ifTrue:
[^self
perform: (OpcodeExceptionMap at: opcode + 1)
with: pc
with: memoryArray].
opcode := memoryArray byteAt: pc + 2.
^self
perform: (ExtendedOpcodeExceptionMap at: opcode + 1)
with: pc
with: memoryArray!

----- Method: TargetAwareX86>>handleJmpFailureAt:in: (in category 'error handling') -----
handleJmpFailureAt: pc "<Integer>" in: memoryArray "<Bitmap|ByteArray>"
"Convert an execution primitive failure for a jmp into a ProcessorSimulationTrap signal."
| relativeJump |
relativeJump := memoryArray longAt: pc + 2 bigEndian: false.
^(ProcessorSimulationTrap
pc: pc
nextpc: pc + 5
address: (pc + 5 + relativeJump) signedIntToLong
type: #jump)
signal!

----- Method: TargetAwareX86>>handleMovALObFailureAt:in: (in category 'error handling') -----
handleMovALObFailureAt: pc "<Integer>" in: memoryArray "<Bitmap|ByteArray>"
"Convert an execution primitive failure for a read into al into a ProcessorSimulationTrap signal."
^(ProcessorSimulationTrap
pc: pc
nextpc: pc + 5
address: (memoryArray unsignedLongAt: pc + 2 bigEndian: false)
type: #read
accessor: #al:)
signal!

----- Method: TargetAwareX86>>handleMovAXOvFailureAt:in: (in category 'error handling') -----
handleMovAXOvFailureAt: pc "<Integer>" in: memoryArray "<Bitmap|ByteArray>"
"Convert an execution primitive failure for a read into eax into a ProcessorSimulationTrap signal."
^(ProcessorSimulationTrap
pc: pc
nextpc: pc + 5
address: (memoryArray unsignedLongAt: pc + 2 bigEndian: false)
type: #read
accessor: #eax:)
signal!

----- Method: TargetAwareX86>>handleMovEbGbFailureAt:in: (in category 'error handling') -----
handleMovEbGbFailureAt: pc "<Integer>" in: memoryArray "<Bitmap|ByteArray>"
"Convert an execution primitive failure for a byte register write into a ProcessorSimulationTrap signal."
| modrmByte address |
modrmByte := memoryArray byteAt: pc + 2.
(modrmByte bitAnd: 7) ~= 4 ifTrue: "MoveRMbr with r = ESP requires an SIB byte"
[address := (modrmByte bitAnd: 16rC0)
caseOf: {
[0 "ModRegInd"]
-> [memoryArray unsignedLongAt: pc + 3 bigEndian: false].
[16r80 "ModRegRegDisp32"]
-> [(self perform: (#(eax ecx edx ebx esp ebp esi edi) at: (modrmByte bitAnd: 7) + 1))
+ (memoryArray unsignedLongAt: pc + 3 bigEndian: false)
bitAnd: 16rFFFFFFFF] }
otherwise: [^self reportPrimitiveFailure].
^(ProcessorSimulationTrap
pc: pc
nextpc: pc + 6
address: address
type: #write
accessor: (#(al cl dl bl ah ch dh bh) at: ((modrmByte >> 3 bitAnd: 7) + 1)))
signal].
^self reportPrimitiveFailure!

----- Method: TargetAwareX86>>handleMovEvGvFailureAt:in: (in category 'error handling') -----
handleMovEvGvFailureAt: pc "<Integer>" in: memoryArray "<Bitmap|ByteArray>"
"Convert an execution primitive failure for a register write into a ProcessorSimulationTrap signal."
| modrmByte |
^((modrmByte := memoryArray byteAt: pc + 2) bitAnd: 16rC7) = 16r5 "ModRegInd & disp32"
ifTrue:
[(ProcessorSimulationTrap
pc: pc
nextpc: pc + 6
address: (memoryArray unsignedLongAt: pc + 3 bigEndian: false)
type: #write
accessor: (#(eax ecx edx ebx esp ebp esi edi) at: ((modrmByte >> 3 bitAnd: 7) + 1)))
signal]
ifFalse:
[self reportPrimitiveFailure]!

----- Method: TargetAwareX86>>handleMovGbEbFailureAt:in: (in category 'error handling') -----
handleMovGbEbFailureAt: pc "<Integer>" in: memoryArray "<Bitmap|ByteArray>"
"Convert an execution primitive failure for a byte register load into a ProcessorSimulationTrap signal."
| modrmByte address |
modrmByte := memoryArray byteAt: pc + 2.
address := (modrmByte bitAnd: 16rC0)
caseOf: {
[0 "ModRegInd"]
-> [memoryArray unsignedLongAt: pc + 3 bigEndian: false].
[16r80 "ModRegRegDisp32"]
-> [(self perform: (#(eax ecx edx ebx esp ebp esi edi) at: (modrmByte bitAnd: 7) + 1))
+ (memoryArray unsignedLongAt: pc + 3 bigEndian: false)
bitAnd: 16rFFFFFFFF] }
otherwise: [^self reportPrimitiveFailure].
^(ProcessorSimulationTrap
pc: pc
nextpc: pc + 6
address: address
type: #read
accessor: (#(al: cl: dl: bl: ah: ch: dh: bh:) at: ((modrmByte >> 3 bitAnd: 7) + 1)))
signal!

----- Method: TargetAwareX86>>handleMovGvEbFailureAt:in: (in category 'error handling') -----
handleMovGvEbFailureAt: pc "<Integer>" in: memoryArray "<Bitmap|ByteArray>"
"Convert an execution primitive failure for a register load into a ProcessorSimulationTrap signal."
| modrmByte mode srcIsSP srcVal dst offset |
modrmByte := memoryArray byteAt: pc + 3.
mode := modrmByte >> 6 bitAnd: 3.
dst := #(eax: ecx: edx: ebx: esp: ebp: esi: edi:) at: ((modrmByte >> 3 bitAnd: 7) + 1).
mode = 0 ifTrue: "ModRegInd"
[offset := memoryArray unsignedLongAt: pc + 4. "1-relative"
^(ProcessorSimulationTrap
pc: pc
nextpc: pc + 7
address: offset
type: #read
accessor: dst)
signal].
srcIsSP := (modrmByte bitAnd: 7) = 4.
srcVal := self perform: (#(eax ecx edx ebx esp ebp esi edi) at: (modrmByte bitAnd: 7) + 1).
mode = 1 ifTrue: "ModRegRegDisp8"
[offset := memoryArray byteAt: pc + (srcIsSP ifTrue: [5] ifFalse: [4]). "1-relative"
offset > 127 ifTrue: [offset := offset - 256].
^(ProcessorSimulationTrap
pc: pc
nextpc: pc + (srcIsSP ifTrue: [5] ifFalse: [4])
address: (srcVal + offset bitAnd: 16rFFFFFFFF)
type: #read
accessor: dst)
signal].
mode = 2 ifTrue: "ModRegRegDisp32"
[offset := memoryArray unsignedLongAt: pc + (srcIsSP ifTrue: [5] ifFalse: [4]). "1-relative"
^(ProcessorSimulationTrap
pc: pc
nextpc: pc + (srcIsSP ifTrue: [8] ifFalse: [7])
address: (srcVal + offset bitAnd: 16rFFFFFFFF)
type: #read
accessor: dst)
signal].
^self reportPrimitiveFailure!

----- Method: TargetAwareX86>>handleMovGvEvFailureAt:in: (in category 'error handling') -----
handleMovGvEvFailureAt: pc "<Integer>" in: memoryArray "<Bitmap|ByteArray>"
"Convert an execution primitive failure for a register load into a ProcessorSimulationTrap signal."
| modrmByte |
^(((modrmByte := memoryArray byteAt: pc + 2) bitAnd: 16rC7) = 16r5) "ModRegInd & disp32"
ifTrue:
[(ProcessorSimulationTrap
pc: pc
nextpc: pc + 6
address: (memoryArray unsignedLongAt: pc + 3 bigEndian: false)
type: #read
accessor: (#(eax: ecx: edx: ebx: esp: ebp: esi: edi:) at: ((modrmByte >> 3 bitAnd: 7) + 1)))
signal]
ifFalse:
[self reportPrimitiveFailure]!

----- Method: TargetAwareX86>>handleMovObALFailureAt:in: (in category 'error handling') -----
handleMovObALFailureAt: pc "<Integer>" in: memoryArray "<Bitmap|ByteArray>"
"Convert an execution primitive failure for a byte write of al into a ProcessorSimulationTrap signal."
^(ProcessorSimulationTrap
pc: pc
nextpc: pc + 5
address: (memoryArray unsignedLongAt: pc + 2 bigEndian: false)
type: #write
accessor: #al)
signal!

----- Method: TargetAwareX86>>handleMovOvAXFailureAt:in: (in category 'error handling') -----
handleMovOvAXFailureAt: pc "<Integer>" in: memoryArray "<Bitmap|ByteArray>"
"Convert an execution primitive failure for a write of eax into a ProcessorSimulationTrap signal."
^(ProcessorSimulationTrap
pc: pc
nextpc: pc + 5
address: (memoryArray unsignedLongAt: pc + 2 bigEndian: false)
type: #write
accessor: #eax)
signal!

----- Method: TargetAwareX86>>handleRetFailureAt:in: (in category 'error handling') -----
handleRetFailureAt: pc "<Integer>" in: memoryArray "<Bitmap|ByteArray>"
"Convert an execution primitive failure for a ret into a ProcessorSimulationTrap signal."
^(ProcessorSimulationTrap
pc: pc
nextpc: pc + 1
address: (memoryArray unsignedLongAt: self esp + 1)
type: #return
accessor: #eip:)
signal!

----- Method: TargetAwareX86>>hostIP (in category 'target connection') -----
hostIP
^'192.168.75.2'!

----- Method: TargetAwareX86>>integerRegisterState (in category 'accessing-abstract') -----
integerRegisterState
| registerState |
registerState := gdb getRegisters.
^{ 'eax'. 'ebx'. 'ecx'. 'edx'. 'esp'. 'ebp'. 'esi'. 'edi'. 'eip'. 'eflags'} collect: [ :aRegName |
registerState at: aRegName ]
!

----- Method: TargetAwareX86>>jmpOpcode (in category 'opcodes') -----
jmpOpcode
"[1] IA-32 Intel® Architecture Software Developer's Manual Volume 2B: Instruction Set Reference, N-Z.
table A2, pA8"
^16rE9!

----- Method: TargetAwareX86>>lockPrefix (in category 'opcodes') -----
lockPrefix
^16rF0!

----- Method: TargetAwareX86>>movALObOpcode (in category 'opcodes') -----
movALObOpcode
"[1] IA-32 Intel® Architecture Software Developer's Manual Volume 2B: Instruction Set Reference, N-Z.
table A2, pA7"
^16rA0!

----- Method: TargetAwareX86>>movAXOvOpcode (in category 'opcodes') -----
movAXOvOpcode
"[1] IA-32 Intel® Architecture Software Developer's Manual Volume 2B: Instruction Set Reference, N-Z.
table A2, pA7"
^16rA1!

----- Method: TargetAwareX86>>movEbGbOpcode (in category 'opcodes') -----
movEbGbOpcode
"[1] IA-32 Intel® Architecture Software Developer's Manual Volume 2B: Instruction Set Reference, N-Z.
table A2"
^16r88!

----- Method: TargetAwareX86>>movEvGvOpcode (in category 'opcodes') -----
movEvGvOpcode
"[1] IA-32 Intel® Architecture Software Developer's Manual Volume 2B: Instruction Set Reference, N-Z.
table A2, pA8"
^16r89!

----- Method: TargetAwareX86>>movGbEbOpcode (in category 'opcodes') -----
movGbEbOpcode
"[1] IA-32 Intel® Architecture Software Developer's Manual Volume 2B: Instruction Set Reference, N-Z.
table A2"
^16r8A!

----- Method: TargetAwareX86>>movGvEbOpcode (in category 'opcodes') -----
movGvEbOpcode
"[1] IA-32 Intel® Architecture Software Developer's Manual Volume 2B: Instruction Set Reference, N-Z.
table A3, pA14"
^16rB6!

----- Method: TargetAwareX86>>movGvEvOpcode (in category 'opcodes') -----
movGvEvOpcode
"[1] IA-32 Intel® Architecture Software Developer's Manual Volume 2B: Instruction Set Reference, N-Z.
table A2, pA8"
^16r8B!

----- Method: TargetAwareX86>>movObALOpcode (in category 'opcodes') -----
movObALOpcode
"[1] IA-32 Intel® Architecture Software Developer's Manual Volume 2B: Instruction Set Reference, N-Z.
table A2, pA7"
^16rA2!

----- Method: TargetAwareX86>>movOvAXOpcode (in category 'opcodes') -----
movOvAXOpcode
"[1] IA-32 Intel® Architecture Software Developer's Manual Volume 2B: Instruction Set Reference, N-Z.
table A2, pA7"
^16rA3!

----- Method: TargetAwareX86>>nopOpcode (in category 'opcodes') -----
nopOpcode
^16r90!

----- Method: TargetAwareX86>>pc (in category 'accessing-abstract') -----
pc
^self eip!

----- Method: TargetAwareX86>>pc: (in category 'accessing-abstract') -----
pc: newPC
^self eip: newPC!

----- Method: TargetAwareX86>>pdl (in category 'target connection') -----
pdl
^FakeProcessorDescriptionX86 new!

----- Method: TargetAwareX86>>printOn: (in category 'printing') -----
printOn: aStream
self gdb printRegistersOn: aStream
!

----- Method: TargetAwareX86>>pushWord:in: (in category 'cog') -----
pushWord: aValue in: aMemory
| sp |
sp := (self esp: self esp - 4).
aMemory longAt: sp + 1 put: aValue bigEndian: false!

----- Method: TargetAwareX86>>remoteMemoryClass (in category 'target connection') -----
remoteMemoryClass
^Gem5SharedRAM!

----- Method: TargetAwareX86>>retOpcode (in category 'opcodes') -----
retOpcode
"[1] IA-32 Intel® Architecture Software Developer's Manual Volume 2B: Instruction Set Reference, N-Z.
table A2, pA7"
^16rC3!

----- Method: TargetAwareX86>>runInMemory:minimumAddress:readOnlyBelow: (in category 'execution') -----
runInMemory: aMemory minimumAddress: minimumAddress readOnlyBelow: minimumWritableAddress
| stopReason |
stopReason := gdb c.
stopReason signal = #SIGSEGV ifFalse: [ self shouldBeImplemented ].
^self
handleExecutionPrimitiveFailureIn: aMemory
minimumAddress: minimumAddress!

----- Method: TargetAwareX86>>setFramePointer:stackPointer: (in category 'accessing-abstract') -----
setFramePointer: framePointer stackPointer: stackPointer
"Initialize the processor's frame and stack pointers"
self ebp: framePointer.
self esp: stackPointer!

----- Method: TargetAwareX86>>simulateLeafCallOf:nextpc:memory: (in category 'cog') -----
simulateLeafCallOf: address nextpc: nextpc memory: aMemory
"this should go back to the alien"
self pushWord: nextpc in: aMemory.
self eip: address!

----- Method: TargetAwareX86>>singleStepIn:minimumAddress:readOnlyBelow: (in category 'execution') -----
singleStepIn: aMemory minimumAddress: minimumAddress readOnlyBelow: minimumWritableAddress
| stopReason |
stopReason := gdb s.
stopReason signal = #SIGTRAP ifTrue: [ ^self "no fault" ].
^self
handleExecutionPrimitiveFailureIn: aMemory
minimumAddress: minimumAddress!

----- Method: TargetAwareX86>>smashRegisterAccessors (in category 'accessing-abstract') -----
smashRegisterAccessors
^#(eax: ebx: ecx: edx: esi: edi:)!

----- Method: TargetAwareX86>>smashRegistersWithValuesFrom:by: (in category 'accessing-abstract') -----
smashRegistersWithValuesFrom: base by: step
self smashRegisterAccessors
withIndexDo:
[:accessor :index|
self perform: accessor with: index - 1 * step + base]!

----- Method: TargetAwareX86>>sp (in category 'accessing-abstract') -----
sp
^self esp!

----- Method: TargetAwareX86>>sp: (in category 'accessing-abstract') -----
sp: anAddress
"Set whatever the processor considers its stack pointer to anAddress."
self esp: anAddress!

----- Method: TargetAwareX86>>tcpPort (in category 'target connection') -----
tcpPort
^7000!

----- Method: TargetAwareX86>>topOfStackIn: (in category 'printing') -----
topOfStackIn: aMemory
"The 32-bit word at the stack top"
^aMemory unsignedLongAtAddr: self esp bigEndian: false!