[Vm-dev] VM Maker: Cog-eem.44.mcz
commits at source.squeak.org
commits at source.squeak.org
Wed Oct 12 16:00:30 UTC 2011
Eliot Miranda uploaded a new version of Cog to project VM Maker:
http://source.squeak.org/VMMaker/Cog-eem.44.mcz
==================== Summary ====================
Name: Cog-eem.44
Author: eem
Time: 8 January 2011, 2:32:43.949 pm
UUID: f3c6694c-7678-4fd9-98f3-8f406565043e
Ancestors: Cog-eem.43
Support for multi-processors instead of the dreadful old hack.
Provide a read/execute write-protect code zone.
Refactor disassembly decoration.
Use unsignedLongAt: to get retpcs etc.
Don't print the fp regs if they're empty.
Support for smashing caller-saved registers.
ShootoutTests take stdio from StandardFileStream not OSProcess.
==================== Snapshot ====================
SystemOrganization addCategory: #'Cog-Morphing Bytecode Set'!
SystemOrganization addCategory: #'Cog-Scripts'!
SystemOrganization addCategory: #'Cog-Scripting'!
SystemOrganization addCategory: #'Cog-Benchmarks'!
SystemOrganization addCategory: #'Cog-Processors'!
SystemOrganization addCategory: #'Cog-ProcessorPlugins'!
SystemOrganization addCategory: #'Cog-Processors-Tests'!
SystemOrganization addCategory: #'Cog-Tests'!
AbstractLauncher subclass: #CommandLineLauncher
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Cog-Scripting'!
----- Method: CommandLineLauncher class>>activate (in category 'activation') -----
activate
"Register this launcher with the auto start class"
self autoStarter addLauncherFirst: self!
----- Method: CommandLineLauncher class>>extractParameters (in category 'accessing') -----
extractParameters
| pName value index globals |
globals := Dictionary new.
index := 2.
[pName := Smalltalk getSystemAttribute: index.
pName isEmptyOrNil] whileFalse:[
index := index + 1.
value := Smalltalk getSystemAttribute: index.
value ifNil: [value := ''].
globals at: pName asLowercase put: value.
index := index + 1].
^globals!
----- Method: CommandLineLauncher class>>initialize (in category 'class initialization') -----
initialize
self activate!
----- Method: CommandLineLauncher>>parameters: (in category 'running') -----
parameters: startupParameters
"AnstractLauncher class>>extractParameters extracts from the wrong index for Mac OS"
super parameters: self class extractParameters!
----- Method: CommandLineLauncher>>startUp (in category 'running') -----
startUp
"UnixProcess stdOut print: parameters; nl."
(parameters includesKey: '-doit') ifTrue:
[Compiler evaluate: (parameters at: '-doit').
Smalltalk quitPrimitive]!
----- Method: MethodContext>>xray (in category '*Cog-Tests-xrays') -----
xray
"Lift the veil from a context and answer an integer describing its interior state.
Used for e.g. VM tests so they can verify they're testing what they think they're testing.
0 implies a vanilla heap context.
Bit 0 = is or was married to a frame
Bit 1 = is still married to a frame
Bit 2 = frame is executing machine code
Bit 3 = has machine code pc (as opposed to nil or a bytecode pc)
Bit 4 = method is currently compiled to machine code"
<primitive: 213>
^0 "Can only fail if unimplemented; therefore simply answer 0"!
----- Method: MethodContext>>xrayIsDivorced (in category '*Cog-Tests-xrays') -----
xrayIsDivorced
^(self xray bitAnd: 3) = 1!
----- Method: MethodContext>>xrayIsExecutingMachineCode (in category '*Cog-Tests-xrays') -----
xrayIsExecutingMachineCode
^self xray anyMask: 4!
----- Method: MethodContext>>xrayIsMarried (in category '*Cog-Tests-xrays') -----
xrayIsMarried
^self xray anyMask: 2!
----- Method: MethodContext>>xrayLastExecutedMachineCode (in category '*Cog-Tests-xrays') -----
xrayLastExecutedMachineCode
^self xray anyMask: 8!
----- Method: MethodContext>>xrayMethodIsCompiledToMachineCode (in category '*Cog-Tests-xrays') -----
xrayMethodIsCompiledToMachineCode
^self xray anyMask: 16!
Alien variableByteSubclass: #BochsIA32Alien
instanceVariableNames: ''
classVariableNames: 'OpcodeExceptionMap PostBuildStackDelta'
poolDictionaries: ''
category: 'Cog-Processors'!
!BochsIA32Alien commentStamp: '<historical>' prior: 0!
I am a wrapper around the Bochs C++ IA32 CPU emulator. Note that currently I provide no access to the x87/mmx FPU state, only providing access to the SSE/xmm registers.
Here is the configure script for the configuration this code assumes. Offsets of fields will change with different configurations so they must agree.
----8<---- conf.COG ----8<----
#!!/bin/sh
# this sets up the compile for Cog. Disable as much inessential stuff
# as possible leaving only the cpu/fpu & memory interface
set echo
# CFLAGS="-pipe -O3 -fomit-frame-pointer -finline-functions -falign-loops=16 -falign-jumps=16 -falign-functions=16 -falign-labels=16 -falign-loops-max-skip=15 -falign-jumps-max-skip=15 -fprefetch-loop-arrays $CFLAGS"
CFLAGS="-m32 $CFLAGS"
CFLAGS="-Dlongjmp=_longjmp -Dsetjmp=_setjmp $CFLAGS"
CFLAGS="-pipe -O3 -fomit-frame-pointer -finline-functions $CFLAGS"
CFLAGS="-g $CFLAGS"
CPATH="/sw/include"
CPPFLAGS=""
CXXFLAGS="$CFLAGS"
LDFLAGS="-L/sw/lib"
export CFLAGS
export CPATH
export CPPFLAGS
export CXXFLAGS
export LDFLAGS
./configure --enable-Cog \
--enable-cpu-level=6 \
--enable-sse=2 \
--enable-assert-checks \
--with-nogui \
--disable-x86-64 \
--disable-pae \
--disable-large-pages \
--disable-global-pages \
--disable-mtrr \
--disable-sb16 \
--disable-ne2000 \
--disable-pci \
--disable-acpi \
--disable-apic \
--disable-clgd54xx \
--disable-usb \
--disable-plugins \
${CONFIGURE_ARGS}
# apic == Advanced programmable Interrupt Controller
# acpi == Advanced Configuration and Power Interface
# pci == Peripheral Component Interconnect local bus
# clgd54xx == Cirrus Logic GD54xx video card
----8<---- conf.COG ----8<----!
----- Method: BochsIA32Alien class>>dataSize (in category 'instance creation') -----
dataSize
^19184!
----- Method: BochsIA32Alien class>>initialize (in category 'class initialization') -----
initialize
"BochsIA32Alien initialize"
PostBuildStackDelta := 0.
OpcodeExceptionMap := Array new: 256 withAll: #handleExecutionPrimitiveFailureAt:in:readOnlyBelow:.
OpcodeExceptionMap
at: 1 + self basicNew callOpcode put: #handleCallFailureAt:in:readOnlyBelow:;
at: 1 + self basicNew jmpOpcode put: #handleJmpFailureAt:in:readOnlyBelow:;
at: 1 + self basicNew retOpcode put: #handleRetFailureAt:in:readOnlyBelow:;
at: 1 + self basicNew movALObOpcode put: #handleMovALObFailureAt:in:readOnlyBelow:;
at: 1 + self basicNew movObALOpcode put: #handleMovObALFailureAt:in:readOnlyBelow:;
at: 1 + self basicNew movGvEvOpcode put: #handleMovGvEvFailureAt:in:readOnlyBelow:;
at: 1 + self basicNew movEvGvOpcode put: #handleMovEvGvFailureAt:in:readOnlyBelow:;
at: 1 + self basicNew movGbEbOpcode put: #handleMovGbEbFailureAt:in:readOnlyBelow:;
at: 1 + self basicNew movEbGbOpcode put: #handleMovEbGbFailureAt:in:readOnlyBelow:!
----- Method: BochsIA32Alien class>>new (in category 'instance creation') -----
new
^(self atAddress: self primitiveNewCPU) reset!
----- Method: BochsIA32Alien class>>primitiveNewCPU (in category 'primitives') -----
primitiveNewCPU
"Answer the address of a new Bochs C++ class bx_cpu_c/BX_CPU_C x86 CPU emulator instance."
<primitive: 'primitiveNewCPU' module: 'BochsIA32Plugin'>
^self primitiveFailed!
----- Method: BochsIA32Alien class>>setStackAlignmentDelta: (in category 'accessing') -----
setStackAlignmentDelta: stackAlignmentDelta
self assert: stackAlignmentDelta isPowerOfTwo.
PostBuildStackDelta := stackAlignmentDelta > 8
ifTrue: [stackAlignmentDelta - 8]
ifFalse: [0]!
----- Method: BochsIA32Alien>>abstractInstructionCompilerClass (in category 'Cog API') -----
abstractInstructionCompilerClass
^CogIA32Compiler!
----- Method: BochsIA32Alien>>al (in category 'accessing') -----
al
^self eax bitAnd: 16rFF!
----- Method: BochsIA32Alien>>al: (in category 'accessing') -----
al: aByte
self eax: ((self eax bitAnd: -16rFF) + aByte).
^aByte!
----- Method: BochsIA32Alien>>bitsInWord (in category 'Cog API') -----
bitsInWord
^32!
----- Method: BochsIA32Alien>>bl (in category 'accessing') -----
bl
^self ebx bitAnd: 16rFF!
----- Method: BochsIA32Alien>>bl: (in category 'accessing') -----
bl: aByte
self ebx: ((self ebx bitAnd: -16rFF) + aByte).
^aByte!
----- Method: BochsIA32Alien>>cResultRegister (in category 'accessing-abstract') -----
cResultRegister
^self eax!
----- Method: BochsIA32Alien>>cResultRegister: (in category 'accessing-abstract') -----
cResultRegister: aValue
^self eax: aValue!
----- Method: BochsIA32Alien>>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: BochsIA32Alien>>cl (in category 'accessing') -----
cl
^self ecx bitAnd: 16rFF!
----- Method: BochsIA32Alien>>cl: (in category 'accessing') -----
cl: aByte
self ecx: ((self ecx bitAnd: -16rFF) + aByte).
^aByte!
----- Method: BochsIA32Alien>>cr0 (in category 'accessing') -----
cr0
^self unsignedLongLongAt: 1009!
----- Method: BochsIA32Alien>>cr0: (in category 'accessing') -----
cr0: anUnsignedInteger
^self unsignedLongLongAt: 1009 put: anUnsignedInteger!
----- Method: BochsIA32Alien>>cr1 (in category 'accessing') -----
cr1
^self unsignedLongLongAt: 1013!
----- Method: BochsIA32Alien>>cr1: (in category 'accessing') -----
cr1: anUnsignedInteger
^self unsignedLongLongAt: 1013 put: anUnsignedInteger!
----- Method: BochsIA32Alien>>cr2 (in category 'accessing') -----
cr2
^self unsignedLongLongAt: 1017!
----- Method: BochsIA32Alien>>cr2: (in category 'accessing') -----
cr2: anUnsignedInteger
^self unsignedLongLongAt: 1017 put: anUnsignedInteger!
----- Method: BochsIA32Alien>>cr3 (in category 'accessing') -----
cr3
^self unsignedLongLongAt: 1021!
----- Method: BochsIA32Alien>>cr3: (in category 'accessing') -----
cr3: anUnsignedInteger
^self unsignedLongLongAt: 1021 put: anUnsignedInteger!
----- Method: BochsIA32Alien>>cr4 (in category 'accessing') -----
cr4
^self unsignedLongLongAt: 1029!
----- Method: BochsIA32Alien>>cr4: (in category 'accessing') -----
cr4: anUnsignedInteger
^self unsignedLongLongAt: 1029 put: anUnsignedInteger!
----- Method: BochsIA32Alien>>decorateDisassembly:for: (in category 'disassembly') -----
decorateDisassembly: anInstructionString for: aSymbolManager "<Cogit>"
| string i1 i2 v |
string := anInstructionString.
(i1 := string indexOfSubCollection: '%ds:0x') > 0 ifTrue:
[i2 := i1 + 6.
['0123456789abcdef' includes: (string at: i2)] whileTrue: [i2 := i2 + 1].
string := string
copyReplaceFrom: i1 + 4
to: i2 - 1
with: (aSymbolManager lookupCHexString: (string copyFrom: i1 + 4 to: i2 - 1))].
(i1 := string indexOfSubCollection: '%ss:0x') > 0 ifTrue:
[i2 := i1 + 6.
['0123456789abcdef' includes: (string at: i2)] whileTrue: [i2 := i2 + 1].
((string at: i2) = $(
and: [(string at: i2 + 1) = $%]) ifTrue:
[v := Integer readFrom: (ReadStream on: string from: i1 + 6 to: i2 - 1) base: 16.
string := string
copyReplaceFrom: i1
to: i2 - 1
with: ((v bitAnd: (1 bitShift: 31) - 1) - (v bitAnd: (1 bitShift: 31))) printString]].
(i1 := string indexOfSubCollection: '$0x') > 0 ifTrue:
[i2 := i1 + 3.
['0123456789abcdef' includes: (string at: i2)] whileTrue: [i2 := i2 + 1].
string := string
copyReplaceFrom: i1 + 1
to: i2 - 1
with: (aSymbolManager lookupCHexString: (string copyFrom: i1 + 1 to: i2 - 1))].
((i1 := string indexOf: $() > 1
and: [(string at: i1 + 1) isDigit
and: [i1 < (i2 := string indexOf: $))]]) ifTrue:
[string := string
copyReplaceFrom: i1 + 1
to: i2 - 1
with: (aSymbolManager lookupCHexString: (string copyFrom: i1 + 1 to: i2 - 1))].
^string!
----- Method: BochsIA32Alien>>disassembleFrom:to:in:for:labels:on: (in category 'disassembly') -----
disassembleFrom: startAddress to: endAddress in: memory for: aSymbolManager "<Cogit>" labels: labelDictionary on: aStream
| address |
address := startAddress.
[address <= endAddress] whileTrue:
[[:size :string|
(aSymbolManager labelForPC: address) ifNotNil:
[:label| aStream nextPutAll: label; nextPut: $:; cr].
(labelDictionary at: address ifAbsent: []) ifNotNil:
[:label| aStream nextPutAll: label; nextPut: $:; cr].
aStream nextPutAll: (self decorateDisassembly: string for: aSymbolManager); cr; flush.
address := address + size]
valueWithArguments: (self
primitiveDisassembleAt: address
inMemory: memory)]!
----- Method: BochsIA32Alien>>disassembleFrom:to:in:on: (in category 'disassembly') -----
disassembleFrom: startAddress to: endAddress in: memory on: aStream
| address |
address := startAddress.
[address < endAddress] whileTrue:
[[:size :string|
aStream nextPutAll: string; cr; flush.
address := address + size]
valueWithArguments: (self
primitiveDisassembleAt: address
inMemory: memory)]!
----- Method: BochsIA32Alien>>disassembleInstructionAt:In: (in category 'disassembly') -----
disassembleInstructionAt: pc In: memory
^(self primitiveDisassembleAt: pc inMemory: memory) last!
----- Method: BochsIA32Alien>>disassembleInstructionAt:In:into: (in category 'disassembly') -----
disassembleInstructionAt: ip In: memory into: aBlock
| lenAndDi |
lenAndDi := self primitiveDisassembleAt: ip inMemory: memory.
^aBlock value: lenAndDi last value: lenAndDi first!
----- Method: BochsIA32Alien>>disassembleNextInstructionIn: (in category 'disassembly') -----
disassembleNextInstructionIn: memory
^(self primitiveDisassembleAt: self eip inMemory: memory) last!
----- Method: BochsIA32Alien>>disassembleNextInstructionIn:for: (in category 'disassembly') -----
disassembleNextInstructionIn: memory for: aSymbolManager "<Cogit|nil>"
| string |
string := (self primitiveDisassembleAt: self eip inMemory: memory) last.
^aSymbolManager
ifNil: [string]
ifNotNil: [self decorateDisassembly: string for: aSymbolManager]!
----- Method: BochsIA32Alien>>dl (in category 'accessing') -----
dl
^self edx bitAnd: 16rFF!
----- Method: BochsIA32Alien>>dl: (in category 'accessing') -----
dl: aByte
self edx: ((self edx bitAnd: -16rFF) + aByte).
^aByte!
----- Method: BochsIA32Alien>>eax (in category 'accessing') -----
eax
^self unsignedLongAt: 469!
----- Method: BochsIA32Alien>>eax: (in category 'accessing') -----
eax: anUnsignedInteger
^self unsignedLongAt: 469 put: anUnsignedInteger!
----- Method: BochsIA32Alien>>ebp (in category 'accessing') -----
ebp
^self unsignedLongAt: 489!
----- Method: BochsIA32Alien>>ebp: (in category 'accessing') -----
ebp: anUnsignedInteger
^self unsignedLongAt: 489 put: anUnsignedInteger!
----- Method: BochsIA32Alien>>ebx (in category 'accessing') -----
ebx
^self unsignedLongAt: 481!
----- Method: BochsIA32Alien>>ebx: (in category 'accessing') -----
ebx: anUnsignedInteger
^self unsignedLongAt: 481 put: anUnsignedInteger!
----- Method: BochsIA32Alien>>ecx (in category 'accessing') -----
ecx
^self unsignedLongAt: 473!
----- Method: BochsIA32Alien>>ecx: (in category 'accessing') -----
ecx: anUnsignedInteger
^self unsignedLongAt: 473 put: anUnsignedInteger!
----- Method: BochsIA32Alien>>edi (in category 'accessing') -----
edi
^self unsignedLongAt: 497!
----- Method: BochsIA32Alien>>edi: (in category 'accessing') -----
edi: anUnsignedInteger
^self unsignedLongAt: 497 put: anUnsignedInteger!
----- Method: BochsIA32Alien>>edx (in category 'accessing') -----
edx
^self unsignedLongAt: 477!
----- Method: BochsIA32Alien>>edx: (in category 'accessing') -----
edx: anUnsignedInteger
^self unsignedLongAt: 477 put: anUnsignedInteger!
----- Method: BochsIA32Alien>>eflags (in category 'accessing') -----
eflags
^self unsignedLongAt: 513!
----- Method: BochsIA32Alien>>eflags: (in category 'accessing') -----
eflags: anUnsignedInteger
^self unsignedLongAt: 513 put: anUnsignedInteger!
----- Method: BochsIA32Alien>>eip (in category 'accessing') -----
eip
^self unsignedLongAt: 501!
----- Method: BochsIA32Alien>>eip: (in category 'accessing') -----
eip: anUnsignedInteger
^self unsignedLongAt: 501 put: anUnsignedInteger!
----- Method: BochsIA32Alien>>endianness (in category 'accessing-abstract') -----
endianness
^#little!
----- Method: BochsIA32Alien>>esi (in category 'accessing') -----
esi
^self unsignedLongAt: 493!
----- Method: BochsIA32Alien>>esi: (in category 'accessing') -----
esi: anUnsignedInteger
^self unsignedLongAt: 493 put: anUnsignedInteger!
----- Method: BochsIA32Alien>>esp (in category 'accessing') -----
esp
^self unsignedLongAt: 485!
----- Method: BochsIA32Alien>>esp: (in category 'accessing') -----
esp: anUnsignedInteger
^self unsignedLongAt: 485 put: anUnsignedInteger!
----- Method: BochsIA32Alien>>flushICacheFrom:to: (in category 'execution') -----
flushICacheFrom: startAddress "<Integer>" to: endAddress "<Integer>"
self primitiveFlushICacheFrom: startAddress To: endAddress!
----- Method: BochsIA32Alien>>fp (in category 'accessing-abstract') -----
fp
^self ebp!
----- Method: BochsIA32Alien>>fp: (in category 'accessing-abstract') -----
fp: anAddress
"Set whatever the processor considers its frame pointer to anAddress."
self ebp: anAddress!
----- Method: BochsIA32Alien>>frameBuildDeltaBytes (in category 'execution') -----
frameBuildDeltaBytes
"Answer how many words are pushed when a frame is built. This is for the Cogit's stack alignment checking code."
^4 "4 bytes pushed for $ebp"!
----- Method: BochsIA32Alien>>handleCallFailureAt:in:readOnlyBelow: (in category 'error handling') -----
handleCallFailureAt: pc "<Integer>" in: memoryArray "<Bitmap|ByteArray>" readOnlyBelow: minimumWritableAddress "<Integer>"
"Convert an execution primitive failure for a call into a ProcessorSimulationTrap signal."
| relativeJump |
relativeJump := memoryArray longAt: pc + 2 bigEndian: false.
^(ProcessorSimulationTrap
pc: pc
nextpc: pc + 5
address: (pc + 5 + relativeJump) signedIntToLong
type: #call)
signal!
----- Method: BochsIA32Alien>>handleExecutionPrimitiveFailureAt:in:readOnlyBelow: (in category 'error handling') -----
handleExecutionPrimitiveFailureAt: pc "<Integer>" in: memoryArray "<Bitmap|ByteArray>" readOnlyBelow: minimumWritableAddress "<Integer>"
"Handle an execution primitive failure for an unhandled opcode."
^self reportPrimitiveFailure!
----- Method: BochsIA32Alien>>handleExecutionPrimitiveFailureIn:minimumAddress:readOnlyBelow: (in category 'error handling') -----
handleExecutionPrimitiveFailureIn: memoryArray "<Bitmap|ByteArray>" minimumAddress: minimumAddress "<Integer>" readOnlyBelow: minimumWritableAddress "<Integer>"
"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:
[opcode := memoryArray byteAt: pc + 1.
^self
perform: (OpcodeExceptionMap at: opcode + 1)
with: pc
with: memoryArray
with: minimumWritableAddress].
^self reportPrimitiveFailure!
----- Method: BochsIA32Alien>>handleJmpFailureAt:in:readOnlyBelow: (in category 'error handling') -----
handleJmpFailureAt: pc "<Integer>" in: memoryArray "<Bitmap|ByteArray>" readOnlyBelow: minimumWritableAddress "<Integer>"
"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: BochsIA32Alien>>handleMovALObFailureAt:in:readOnlyBelow: (in category 'error handling') -----
handleMovALObFailureAt: pc "<Integer>" in: memoryArray "<Bitmap|ByteArray>" readOnlyBelow: minimumWritableAddress "<Integer>"
"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: BochsIA32Alien>>handleMovEbGbFailureAt:in:readOnlyBelow: (in category 'error handling') -----
handleMovEbGbFailureAt: pc "<Integer>" in: memoryArray "<Bitmap|ByteArray>" readOnlyBelow: minimumWritableAddress "<Integer>"
"Convert an execution primitive failure for a byte register write into a ProcessorSimulationTrap signal."
| modrmByte |
^(((modrmByte := memoryArray byteAt: pc + 2) bitAnd: 16rC0) = 16r80) "ModRegRegDisp32"
ifTrue:
[(ProcessorSimulationTrap
pc: pc
nextpc: pc + 6
address: ((self perform: (#(eax ecx edx ebx esp ebp esi edi) at: (modrmByte bitAnd: 7) + 1))
+ (memoryArray unsignedLongAt: pc + 3 bigEndian: false)
bitAnd: 16rFFFFFFFF)
type: #write
accessor: (#(al cl dl bl ah ch dh bh) at: ((modrmByte >> 3 bitAnd: 7) + 1)))
signal]
ifFalse:
[self handleExecutionPrimitiveFailureAt: pc
in: memoryArray
readOnlyBelow: minimumWritableAddress]!
----- Method: BochsIA32Alien>>handleMovEvGvFailureAt:in:readOnlyBelow: (in category 'error handling') -----
handleMovEvGvFailureAt: pc "<Integer>" in: memoryArray "<Bitmap|ByteArray>" readOnlyBelow: minimumWritableAddress "<Integer>"
"Convert an execution primitive failure for a register write into a ProcessorSimulationTrap signal."
| modrmByte address |
^(((modrmByte := memoryArray byteAt: pc + 2) bitAnd: 16rC7) = 16r5 "ModRegInd & disp32"
and: [(address := memoryArray unsignedLongAt: pc + 3 bigEndian: false) >= minimumWritableAddress])
ifTrue:
[(ProcessorSimulationTrap
pc: pc
nextpc: pc + 6
address: address
type: #write
accessor: (#(eax ecx edx ebx esp ebp esi edi) at: ((modrmByte >> 3 bitAnd: 7) + 1)))
signal]
ifFalse:
[self handleExecutionPrimitiveFailureAt: pc
in: memoryArray
readOnlyBelow: minimumWritableAddress]!
----- Method: BochsIA32Alien>>handleMovGbEbFailureAt:in:readOnlyBelow: (in category 'error handling') -----
handleMovGbEbFailureAt: pc "<Integer>" in: memoryArray "<Bitmap|ByteArray>" readOnlyBelow: minimumWritableAddress "<Integer>"
"Convert an execution primitive failure for a byte register load into a ProcessorSimulationTrap signal."
| modrmByte |
^(((modrmByte := memoryArray byteAt: pc + 2) bitAnd: 16rC0) = 16r80) "ModRegRegDisp32"
ifTrue:
[(ProcessorSimulationTrap
pc: pc
nextpc: pc + 6
address: ((self perform: (#(eax ecx edx ebx esp ebp esi edi) at: (modrmByte bitAnd: 7) + 1))
+ (memoryArray unsignedLongAt: pc + 3 bigEndian: false)
bitAnd: 16rFFFFFFFF)
type: #read
accessor: (#(al: cl: dl: bl: ah: ch: dh: bh:) at: ((modrmByte >> 3 bitAnd: 7) + 1)))
signal]
ifFalse:
[self handleExecutionPrimitiveFailureAt: pc
in: memoryArray
readOnlyBelow: minimumWritableAddress]!
----- Method: BochsIA32Alien>>handleMovGvEvFailureAt:in:readOnlyBelow: (in category 'error handling') -----
handleMovGvEvFailureAt: pc "<Integer>" in: memoryArray "<Bitmap|ByteArray>" readOnlyBelow: minimumWritableAddress "<Integer>"
"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 handleExecutionPrimitiveFailureAt: pc
in: memoryArray
readOnlyBelow: minimumWritableAddress]!
----- Method: BochsIA32Alien>>handleMovObALFailureAt:in:readOnlyBelow: (in category 'error handling') -----
handleMovObALFailureAt: pc "<Integer>" in: memoryArray "<Bitmap|ByteArray>" readOnlyBelow: minimumWritableAddress "<Integer>"
"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: BochsIA32Alien>>handleRetFailureAt:in:readOnlyBelow: (in category 'error handling') -----
handleRetFailureAt: pc "<Integer>" in: memoryArray "<Bitmap|ByteArray>" readOnlyBelow: minimumWritableAddress "<Integer>"
"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: BochsIA32Alien>>integerRegisterState (in category 'accessing-abstract') -----
integerRegisterState
^{ self eax. self ebx. self ecx. self edx. self esp. self ebp. self esi. self edi.
self eip. self eflags }!
----- Method: BochsIA32Alien>>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: BochsIA32Alien>>leafRetpcIn: (in category 'accessing-abstract') -----
leafRetpcIn: aMemory
^aMemory unsignedLongAt: self esp + 1 bigEndian: false!
----- Method: BochsIA32Alien>>lockPrefix (in category 'opcodes') -----
lockPrefix
^16rF0!
----- Method: BochsIA32Alien>>movALObOpcode (in category 'opcodes') -----
movALObOpcode
"[1] IA-32 Intel® Architecture Software Developer's Manual Volume 2B: Instruction Set Reference, N-Z.
table A2, pA7"
^16rA1!
----- Method: BochsIA32Alien>>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: BochsIA32Alien>>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: BochsIA32Alien>>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: BochsIA32Alien>>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: BochsIA32Alien>>movObALOpcode (in category 'opcodes') -----
movObALOpcode
"[1] IA-32 Intel® Architecture Software Developer's Manual Volume 2B: Instruction Set Reference, N-Z.
table A2, pA7"
^16rA3!
----- Method: BochsIA32Alien>>nopOpcode (in category 'opcodes') -----
nopOpcode
^16r90!
----- Method: BochsIA32Alien>>pc (in category 'accessing-abstract') -----
pc
"Return whatever the processor considers its program counter."
^self eip!
----- Method: BochsIA32Alien>>pc: (in category 'accessing-abstract') -----
pc: anAddress
"Set whatever the processor considers its program counter to anAddress."
self eip: anAddress!
----- Method: BochsIA32Alien>>popWordIn: (in category 'accessing-abstract') -----
popWordIn: aMemory
| sp word |
word := aMemory unsignedLongAt: (sp := self esp) + 1 bigEndian: false.
self esp: sp + 4.
^word!
----- Method: BochsIA32Alien>>postCallArgumentsNumArgs:in: (in category 'execution') -----
postCallArgumentsNumArgs: numArgs "<Integer>" in: memory "<ByteArray|Bitmap>"
"Answer an argument vector of the requested size after a vanilla
ABI call. On IA32 this typically means accessing stacked arguments
beyond the pushed return address and saved frame pointer.
For compatibility with Cog/Slang we answer unsigned values."
^(9 to: numArgs * 4 + 5 by: 4) collect:
[:i|
memory unsignedLongAt: self ebp + i bigEndian: false]!
----- Method: BochsIA32Alien>>primitiveDisassembleAt:inMemory: (in category 'primitives') -----
primitiveDisassembleAt: address inMemory: memoryArray "<Bitmap|ByteArray>"
"Answer an Array of the size and the disassembled code string for the instruction at the current instruction pointer in memory."
<primitive: 'primitiveDisassembleAtInMemory' module: 'BochsIA32Plugin'>
^self primitiveFailed!
----- Method: BochsIA32Alien>>primitiveErrorAndLog (in category 'primitives') -----
primitiveErrorAndLog
"Answer an array of the current error code and log contents"
<primitive: 'primitiveErrorAndLog' module: 'BochsIA32Plugin'>
^self primitiveFailed!
----- Method: BochsIA32Alien>>primitiveFlushICacheFrom:To: (in category 'primitives') -----
primitiveFlushICacheFrom: startAddress "<Integer>" To: endAddress "<Integer>"
"Flush the icache in the requested range"
<primitive: 'primitiveFlushICacheFromTo' module: 'BochsIA32Plugin'>
^self primitiveFailed!
----- Method: BochsIA32Alien>>primitiveResetCPU (in category 'primitives') -----
primitiveResetCPU
"Reset the receiver to registers all zero, and protected 32-bit mode."
<primitive: 'primitiveResetCPU' module: 'BochsIA32Plugin'>
^self reportPrimitiveFailure!
----- Method: BochsIA32Alien>>primitiveRunInMemory:minimumAddress:readOnlyBelow: (in category 'primitives') -----
primitiveRunInMemory: memoryArray "<Bitmap|ByteArray>" minimumAddress: minimumAddress "<Integer>" readOnlyBelow: minimumWritableAddress "<Integer>"
"Run the receiver using the argument as the store. Origin the argument at 0. i.e. the first byte of the
memoryArray is address 0. Make addresses below minimumAddress illegal. Convert out-of-range
call, jump and memory read/writes into register instructions into ProcessorSimulationTrap signals."
<primitive: 'primitiveRunInMemoryMinimumAddressReadWrite' module: 'BochsIA32Plugin' error: ec>
^ec == #'inappropriate operation'
ifTrue: [self handleExecutionPrimitiveFailureIn: memoryArray
minimumAddress: minimumAddress
readOnlyBelow: minimumWritableAddress]
ifFalse: [self reportPrimitiveFailure]
"self printRegistersOn: Transcript"!
----- Method: BochsIA32Alien>>primitiveSingleStepInMemory:minimumAddress:readOnlyBelow: (in category 'primitives') -----
primitiveSingleStepInMemory: memoryArray "<Bitmap|ByteArray>" minimumAddress: minimumAddress "<Integer>" readOnlyBelow: minimumWritableAddress "<Integer>"
"Single-step the receiver using the argument as the store. Origin the argument at 0. i.e. the first byte of the
memoryArray is address 0. Make addresses below minimumAddress illegal. Convert out-of-range
call, jump and memory read/writes into register instructions into ProcessorSimulationTrap signals."
<primitive: 'primitiveSingleStepInMemoryMinimumAddressReadWrite' module: 'BochsIA32Plugin' error: ec>
^ec == #'inappropriate operation'
ifTrue: [self handleExecutionPrimitiveFailureIn: memoryArray
minimumAddress: minimumAddress
readOnlyBelow: minimumWritableAddress]
ifFalse: [self reportPrimitiveFailure]!
----- Method: BochsIA32Alien>>printIntegerRegistersOn: (in category 'printing') -----
printIntegerRegistersOn: aStream
self printRegisterState: self integerRegisterState on: aStream.
aStream flush!
----- Method: BochsIA32Alien>>printRegisterState:on: (in category 'printing') -----
printRegisterState: registerStateVector on: aStream
| rsvs fields|
aStream ensureCr.
rsvs := registerStateVector readStream.
fields := (registerStateVector size < 18
or: [(11 to: 18) allSatisfy: [:i| (registerStateVector at: i) isZero]])
ifTrue:
[#( eax ebx ecx edx cr
esp ebp esi edi cr
eip eflags cr )]
ifFalse:
[#( eax ebx ecx edx cr
esp ebp esi edi cr
eip eflags cr
xmm0low xmm1low cr
xmm2low xmm3low cr
xmm4low xmm5low cr
xmm6low xmm7low cr )].
fields withIndexDo:
[:sym :index| | val |
sym = #cr
ifTrue: [aStream cr]
ifFalse:
[(val := rsvs next) isNil ifTrue: [^self].
(sym beginsWith: 'xmm')
ifTrue:
[aStream nextPutAll: sym; nextPut: $:; space.
val printOn: aStream base: 16 length: 16 padded: true.
aStream space; nextPut: $(.
"At the image level Float is apparently in big-endian format"
((Float basicNew: 2)
at: 2 put: (val bitAnd: 16rFFFFFFFF);
at: 1 put: (val bitShift: -32);
yourself)
printOn: aStream.
aStream nextPut: $)]
ifFalse:
[aStream nextPutAll: sym; nextPut: $:; space.
val printOn: aStream base: 16 length: 8 padded: true.
#eflags == sym
ifTrue:
[aStream space.
'C-P-A-ZS---O' withIndexDo:
[:flag :bitIndex|
flag ~= $- ifTrue:
[aStream nextPut: flag; nextPutAll: 'F='; print: (val bitAnd: 1 << (bitIndex - 1)) >> (bitIndex - 1); space]]]
ifFalse:
[val > 16 ifTrue:
[aStream space; nextPut: $(.
val printOn: aStream base: 10 length: 1 padded: false.
aStream nextPut: $)]]].
(fields at: index + 1) ~~ #cr ifTrue:
[aStream tab]]]!
----- Method: BochsIA32Alien>>printRegistersOn: (in category 'printing') -----
printRegistersOn: aStream
self printRegisterState: self registerState on: aStream.
aStream flush!
----- Method: BochsIA32Alien>>pushWord:in: (in category 'execution') -----
pushWord: aValue in: aMemory
| sp |
sp := (self esp: self esp - 4).
aMemory longAt: sp + 1 put: aValue bigEndian: false!
----- Method: BochsIA32Alien>>registerAt: (in category 'accessing') -----
registerAt: index
^self perform: (#(eax ecx edx ebx esp ebp esi edi) at: index + 1)!
----- Method: BochsIA32Alien>>registerState (in category 'accessing-abstract') -----
registerState
^{ self eax. self ebx. self ecx. self edx. self esp. self ebp. self esi. self edi.
self eip. self eflags.
self xmm0low. self xmm1low. self xmm2low. self xmm3low.
self xmm4low. self xmm5low. self xmm6low. self xmm7low }!
----- Method: BochsIA32Alien>>registerStatePCIndex (in category 'accessing-abstract') -----
registerStatePCIndex
^9!
----- Method: BochsIA32Alien>>reportPrimitiveFailure (in category 'error handling') -----
reportPrimitiveFailure
| errorAndLog |
errorAndLog := self primitiveErrorAndLog.
self error: 'Error ', errorAndLog first printString, (errorAndLog last ifNil: [''] ifNotNil: [:log| ' ', log])!
----- Method: BochsIA32Alien>>reset (in category 'execution') -----
reset
self primitiveResetCPU.
"Enable SSE extensions by setting the OSFXSR (Operating System FXSAVE/FXRSTOR Support) bit"
self cr4: (self cr4 bitOr: 1 << 9)!
----- Method: BochsIA32Alien>>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: BochsIA32Alien>>retpcIn: (in category 'accessing-abstract') -----
retpcIn: aMemory
^aMemory unsignedLongAt: self ebp + 5 bigEndian: false!
----- Method: BochsIA32Alien>>runInMemory: (in category 'execution') -----
runInMemory: aMemory
| result |
result := self primitiveRunInMemory: aMemory minimumAddress: 0 readOnlyBelow: 0.
result ~~ self ifTrue:
[self error: 'eek!!']!
----- Method: BochsIA32Alien>>runInMemory:minimumAddress:readOnlyBelow: (in category 'execution') -----
runInMemory: aMemory minimumAddress: minimumAddress readOnlyBelow: minimumWritableAddress
| result |
result := self primitiveRunInMemory: aMemory
minimumAddress: minimumAddress
readOnlyBelow: minimumWritableAddress.
result ~~ self ifTrue:
[self error: 'eek!!']!
----- Method: BochsIA32Alien>>runInMemory:readExecuteOnlyBelow: (in category 'execution') -----
runInMemory: aMemory readExecuteOnlyBelow: minWriteMaxExecAddr
| result |
result := self primitiveRunInMemory: aMemory minimumAddress: 0 readOnlyBelow: minWriteMaxExecAddr.
result ~~ self ifTrue:
[self error: 'eek!!']!
----- Method: BochsIA32Alien>>saveEip (in category 'accessing') -----
saveEip
^self unsignedLongAt: 1533!
----- Method: BochsIA32Alien>>saveEsp (in category 'accessing') -----
saveEsp
^self unsignedLongAt: 1537!
----- Method: BochsIA32Alien>>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: BochsIA32Alien>>setRegisterState: (in category 'accessing-abstract') -----
setRegisterState: aRegisterStateArray
"N.B. keep in sync with voidRegisterState"
self eax: (aRegisterStateArray at: 1).
self ebx: (aRegisterStateArray at: 2).
self ecx: (aRegisterStateArray at: 3).
self edx: (aRegisterStateArray at: 4).
self esp: (aRegisterStateArray at: 5).
self ebp: (aRegisterStateArray at: 6).
self esi: (aRegisterStateArray at: 7).
self edi: (aRegisterStateArray at: 8).
self eip: (aRegisterStateArray at: 9).
self eflags: (aRegisterStateArray at: 10).
self xmm0low: (aRegisterStateArray at: 11).
self xmm1low: (aRegisterStateArray at: 12).
self xmm2low: (aRegisterStateArray at: 13).
self xmm3low: (aRegisterStateArray at: 14).
self xmm4low: (aRegisterStateArray at: 15).
self xmm5low: (aRegisterStateArray at: 16).
self xmm6low: (aRegisterStateArray at: 17).
self xmm7low: (aRegisterStateArray at: 18)!
----- Method: BochsIA32Alien>>simulateCallOf:nextpc:memory: (in category 'execution') -----
simulateCallOf: address nextpc: nextpc memory: aMemory
"Simulate a frame-building call of address. Build a frame since
a) this is used for calls into the run-time which are unlikely to be leaf-calls, and
b) stack alignment needs to be realistic for assert checking for platforms such as Mac OS X"
self pushWord: nextpc in: aMemory.
self pushWord: self ebp in: aMemory.
self ebp: self esp.
PostBuildStackDelta ~= 0 ifTrue:
[self esp: self esp - PostBuildStackDelta].
self eip: address!
----- Method: BochsIA32Alien>>simulateJumpCallOf:memory: (in category 'execution') -----
simulateJumpCallOf: address memory: aMemory
"Simulate a frame-building jump call of address (i.e. do not push the return pc
as this has already been done). Build a frame since
a) this is used for calls into the run-time which are unlikely to be leaf-calls, and
b) stack alignment needs to be realistic for assert checking for platforms such as Mac OS X"
self pushWord: self ebp in: aMemory.
self ebp: self esp.
PostBuildStackDelta ~= 0 ifTrue:
[self esp: self esp - PostBuildStackDelta].
self eip: address!
----- Method: BochsIA32Alien>>simulateLeafCallOf:nextpc:memory: (in category 'execution') -----
simulateLeafCallOf: address nextpc: nextpc memory: aMemory
self pushWord: nextpc in: aMemory.
self eip: address!
----- Method: BochsIA32Alien>>simulateLeafReturnIn: (in category 'execution') -----
simulateLeafReturnIn: aMemory
self eip: (self popWordIn: aMemory)!
----- Method: BochsIA32Alien>>simulateReturnIn: (in category 'execution') -----
simulateReturnIn: aMemory
PostBuildStackDelta ~= 0 ifTrue:
[self esp: self esp + PostBuildStackDelta].
self ebp: (self popWordIn: aMemory).
self eip: (self popWordIn: aMemory)!
----- Method: BochsIA32Alien>>singleStepIn: (in category 'execution') -----
singleStepIn: aMemory
| result |
result := self primitiveSingleStepInMemory: aMemory minimumAddress: 0 readOnlyBelow: aMemory size.
result ~~ self ifTrue:
[self error: 'eek!!']!
----- Method: BochsIA32Alien>>singleStepIn:minimumAddress:readOnlyBelow: (in category 'execution') -----
singleStepIn: aMemory minimumAddress: minimumAddress readOnlyBelow: minimumWritableAddress
| result |
result := self primitiveSingleStepInMemory: aMemory
minimumAddress: minimumAddress
readOnlyBelow: minimumWritableAddress.
result ~~ self ifTrue:
[self error: 'eek!!']!
----- Method: BochsIA32Alien>>singleStepIn:readExecuteOnlyBelow: (in category 'execution') -----
singleStepIn: aMemory readExecuteOnlyBelow: minWriteMaxExecAddr
| result |
result := self primitiveSingleStepInMemory: aMemory minimumAddress: 0 readOnlyBelow: minWriteMaxExecAddr.
result ~~ self ifTrue:
[self error: 'eek!!']!
----- Method: BochsIA32Alien>>smashCallerSavedRegistersWithValuesFrom:by: (in category 'accessing-abstract') -----
smashCallerSavedRegistersWithValuesFrom: base by: step
#(eax: ecx: edx:)
withIndexDo:
[:accessor :index|
self perform: accessor with: index - 1 * step + base]!
----- Method: BochsIA32Alien>>smashRegistersWithValuesFrom:by: (in category 'accessing-abstract') -----
smashRegistersWithValuesFrom: base by: step
#(eax: ebx: ecx: edx: esi: edi:)
withIndexDo:
[:accessor :index|
self perform: accessor with: index - 1 * step + base]!
----- Method: BochsIA32Alien>>sp (in category 'accessing-abstract') -----
sp
^self esp!
----- Method: BochsIA32Alien>>sp: (in category 'accessing-abstract') -----
sp: anAddress
"Set whatever the processor considers its stack pointer to anAddress."
self esp: anAddress!
----- Method: BochsIA32Alien>>stopReason (in category 'accessing') -----
stopReason
^self unsignedByteAt: 1577!
----- Method: BochsIA32Alien>>voidRegisterState (in category 'accessing-abstract') -----
voidRegisterState
"N.B. keep in sync with setRegisterState:"
self setRegisterState: (Array new: 18 withAll: 0)!
----- Method: BochsIA32Alien>>withStackPointersInRegisterState:do: (in category 'accessing-abstract') -----
withStackPointersInRegisterState: registerState do: aBinaryBlock
^aBinaryBlock value: (registerState at: 5) value: (registerState at: 6)!
----- Method: BochsIA32Alien>>xmm0high (in category 'accessing') -----
xmm0high
^self unsignedLongLongAt: 1185!
----- Method: BochsIA32Alien>>xmm0high: (in category 'accessing') -----
xmm0high: anUnsignedInteger
^self unsignedLongLongAt: 1185 put: anUnsignedInteger!
----- Method: BochsIA32Alien>>xmm0low (in category 'accessing') -----
xmm0low
^self unsignedLongLongAt: 1177!
----- Method: BochsIA32Alien>>xmm0low: (in category 'accessing') -----
xmm0low: anUnsignedInteger
^self unsignedLongLongAt: 1177 put: anUnsignedInteger!
----- Method: BochsIA32Alien>>xmm1high (in category 'accessing') -----
xmm1high
^self unsignedLongLongAt: 1201!
----- Method: BochsIA32Alien>>xmm1high: (in category 'accessing') -----
xmm1high: anUnsignedInteger
^self unsignedLongLongAt: 1201 put: anUnsignedInteger!
----- Method: BochsIA32Alien>>xmm1low (in category 'accessing') -----
xmm1low
^self unsignedLongLongAt: 1193!
----- Method: BochsIA32Alien>>xmm1low: (in category 'accessing') -----
xmm1low: anUnsignedInteger
^self unsignedLongLongAt: 1193 put: anUnsignedInteger!
----- Method: BochsIA32Alien>>xmm2high (in category 'accessing') -----
xmm2high
^self unsignedLongLongAt: 1217!
----- Method: BochsIA32Alien>>xmm2high: (in category 'accessing') -----
xmm2high: anUnsignedInteger
^self unsignedLongLongAt: 1217 put: anUnsignedInteger!
----- Method: BochsIA32Alien>>xmm2low (in category 'accessing') -----
xmm2low
^self unsignedLongLongAt: 1209!
----- Method: BochsIA32Alien>>xmm2low: (in category 'accessing') -----
xmm2low: anUnsignedInteger
^self unsignedLongLongAt: 1209 put: anUnsignedInteger!
----- Method: BochsIA32Alien>>xmm3high (in category 'accessing') -----
xmm3high
^self unsignedLongLongAt: 1233!
----- Method: BochsIA32Alien>>xmm3high: (in category 'accessing') -----
xmm3high: anUnsignedInteger
^self unsignedLongLongAt: 1233 put: anUnsignedInteger!
----- Method: BochsIA32Alien>>xmm3low (in category 'accessing') -----
xmm3low
^self unsignedLongLongAt: 1225!
----- Method: BochsIA32Alien>>xmm3low: (in category 'accessing') -----
xmm3low: anUnsignedInteger
^self unsignedLongLongAt: 1225 put: anUnsignedInteger!
----- Method: BochsIA32Alien>>xmm4high (in category 'accessing') -----
xmm4high
^self unsignedLongLongAt: 1249!
----- Method: BochsIA32Alien>>xmm4high: (in category 'accessing') -----
xmm4high: anUnsignedInteger
^self unsignedLongLongAt: 1249 put: anUnsignedInteger!
----- Method: BochsIA32Alien>>xmm4low (in category 'accessing') -----
xmm4low
^self unsignedLongLongAt: 1241!
----- Method: BochsIA32Alien>>xmm4low: (in category 'accessing') -----
xmm4low: anUnsignedInteger
^self unsignedLongLongAt: 1241 put: anUnsignedInteger!
----- Method: BochsIA32Alien>>xmm5high (in category 'accessing') -----
xmm5high
^self unsignedLongLongAt: 1265!
----- Method: BochsIA32Alien>>xmm5high: (in category 'accessing') -----
xmm5high: anUnsignedInteger
^self unsignedLongLongAt: 1265 put: anUnsignedInteger!
----- Method: BochsIA32Alien>>xmm5low (in category 'accessing') -----
xmm5low
^self unsignedLongLongAt: 1257!
----- Method: BochsIA32Alien>>xmm5low: (in category 'accessing') -----
xmm5low: anUnsignedInteger
^self unsignedLongLongAt: 1257 put: anUnsignedInteger!
----- Method: BochsIA32Alien>>xmm6high (in category 'accessing') -----
xmm6high
^self unsignedLongLongAt: 1281!
----- Method: BochsIA32Alien>>xmm6high: (in category 'accessing') -----
xmm6high: anUnsignedInteger
^self unsignedLongLongAt: 1281 put: anUnsignedInteger!
----- Method: BochsIA32Alien>>xmm6low (in category 'accessing') -----
xmm6low
^self unsignedLongLongAt: 1273!
----- Method: BochsIA32Alien>>xmm6low: (in category 'accessing') -----
xmm6low: anUnsignedInteger
^self unsignedLongLongAt: 1273 put: anUnsignedInteger!
----- Method: BochsIA32Alien>>xmm7high (in category 'accessing') -----
xmm7high
^self unsignedLongLongAt: 1297!
----- Method: BochsIA32Alien>>xmm7high: (in category 'accessing') -----
xmm7high: anUnsignedInteger
^self unsignedLongLongAt: 1297 put: anUnsignedInteger!
----- Method: BochsIA32Alien>>xmm7low (in category 'accessing') -----
xmm7low
^self unsignedLongLongAt: 1289!
----- Method: BochsIA32Alien>>xmm7low: (in category 'accessing') -----
xmm7low: anUnsignedInteger
^self unsignedLongLongAt: 1289 put: anUnsignedInteger!
Object subclass: #BytecodeEncoderPutschEditor
instanceVariableNames: 'xlator xlation kwdxlation ranges index output codeIndex'
classVariableNames: ''
poolDictionaries: ''
category: 'Cog-Morphing Bytecode Set'!
!BytecodeEncoderPutschEditor commentStamp: '<historical>' prior: 0!
I am a MethodNode that uses the size and emit methods that use the BytecodeEncoder hierarchy's bytecode generation facilities. This means my nodes no longer need encode specifics about the bytecode set.
To compile edited versions of the size* and emit* methods use
BytecodeEncoderPutschEditor new edit
In 3.8:
To get the source of the new version of MethodNode>>generate: for BytecodeAgnosticMethodNode use
BytecodeEncoderPutschEditor new
editCode: (MethodNode sourceCodeAt: #generate:) asString
inClass: BytecodeAgnosticMethodNode
withSelector: #generate:
In 3.9:
To get the source of the new version of MethodNode>>generateWith:using: for BytecodeAgnosticMethodNode use
BytecodeEncoderPutschEditor new
editCode: (BytecodeAgnosticMethodNode sourceCodeAt: #generateWith:using:) asString
inClass: BytecodeAgnosticMethodNode
withSelector: #generateWith:using:!
----- Method: BytecodeEncoderPutschEditor>>edit (in category 'code editing') -----
edit
| sn |
sn := SystemNavigation default.
xlation keysAndValuesDo:
[:s :t|
(sn allImplementorsOf: s localTo: ParseNode) do:
[:md|
md actualClass
compile: (self editCode: md sourceString inClass: md actualClass withSelector: md methodSymbol)
classified: 'code generation (new scheme)']]!
----- Method: BytecodeEncoderPutschEditor>>editCode:inClass:withSelector: (in category 'code editing') -----
editCode: code inClass: class withSelector: selector
| codeString |
ranges := SHParserST80 new rangesIn: code classOrMetaClass: class workspace: nil environment: nil.
index := 1.
codeIndex := 1.
output := String new writeStream.
codeString := code asString.
self process: codeString while: [:ign| true].
"(StringHolder new textContents:
(TextDiffBuilder buildDisplayPatchFrom: code to: output contents))
openLabel: class name , '>>', selector."
^output contents!
----- Method: BytecodeEncoderPutschEditor>>initialize (in category 'initialize-release') -----
initialize
xlator := [:s|
((((s allButFirst: 4) beginsWith: 'For') or: [((s allButFirst: 4) beginsWith: 'Except') or: [s fifth = $:]])
ifTrue: [(s first: 4), 'Code', (s allButFirst: 4)]
ifFalse: [(s first: 4), 'CodeFor', (s allButFirst: 4)]) copyReplaceAll: ':on:' with: ':encoder:'].
xlation := Dictionary new.
(((ParseNode withAllSubclasses removeAll: Encoder withAllSubclasses; yourself)
inject: Set new
into: [:s :c| s addAll: c selectors. s])
select:
[:s| ((s beginsWith: 'emit') or: [s beginsWith: 'size'])
and: [(s includesSubstring: 'Code' caseSensitive: true) not]]) do:
[:s|xlation at: s put: (xlator value: s) asSymbol].
kwdxlation := Dictionary new.
xlation keysAndValuesDo: [:k :v| kwdxlation at: k keywords first put: v keywords first]!
----- Method: BytecodeEncoderPutschEditor>>process:while: (in category 'code editing') -----
process: code while: aBlock
| range mapOnToEncoder kwd |
mapOnToEncoder := false.
[index <= ranges size] whileTrue:
[range := ranges at: index.
(aBlock value: range) ifFalse:
[^self].
index := index + 1.
[codeIndex < range start] whileTrue:
[output nextPut: (code at: codeIndex).
codeIndex := codeIndex + 1].
range type == #assignment
ifTrue: [output nextPutAll: ':='.
codeIndex := range end + 1]
ifFalse:
[(#(keyword patternKeyword) includes: range type) ifTrue:
[kwd := code copyFrom: range start to: range end.
(mapOnToEncoder and: [kwd = 'on:'])
ifTrue:
[output nextPutAll: 'encoder: encoder'.
mapOnToEncoder := false.
codeIndex := (ranges at: index) end + 1.
index := index + 1]
ifFalse:
[(kwdxlation includesKey: kwd) ifTrue:
[(kwd beginsWith: 'emit') ifTrue:
[mapOnToEncoder := true].
output nextPutAll: (kwdxlation at: kwd).
codeIndex := range end + 1]]]
ifFalse:
[[codeIndex <= range end] whileTrue:
[output nextPut: (code at: codeIndex).
codeIndex := codeIndex + 1].
"kill whitespace after up-arrow in ^ expr"
(range type == #return and: [index <= ranges size]) ifTrue:
[codeIndex := (ranges at: index) start]]]]!
Object subclass: #ClassHierarchyDuplicator
instanceVariableNames: 'xlator classes prefix'
classVariableNames: ''
poolDictionaries: ''
category: 'Cog-Morphing Bytecode Set'!
----- Method: ClassHierarchyDuplicator>>edit (in category 'code editing') -----
edit
(ChangeSet superclassOrder: classes asArray) do:
[:class| | newClass |
newClass := class subclassDefinerClass evaluate: (self editClassDefinitionOf: class).
{ class. class class }
with: { newClass. newClass class }
do: [:b :nb|
b selectors do:
[:s|
nb
compile: (self editCode: (b sourceCodeAt: s) inClass: b withSelector: s)
classified: (class organization categoryOfElement: s)]]]
"self new edit"!
----- Method: ClassHierarchyDuplicator>>editClassDefinitionOf: (in category 'code editing') -----
editClassDefinitionOf: aClass
| classDef categoryString |
categoryString := 'category: '''.
classDef := self editCode: aClass definition inClass: nil withSelector: nil.
classDef := classDef
copyReplaceAll: categoryString
with: categoryString, prefix.
^classDef
copyReplaceAll: aClass classVariablesString
with: (String streamContents: [:s| aClass classVariablesString subStrings do: [:ea| s nextPutAll: prefix; nextPutAll: ea; space]])
"self new editClassDefinitionOf: MessageNode"!
----- Method: ClassHierarchyDuplicator>>editCode:inClass:withSelector: (in category 'code editing') -----
editCode: sourceText inClass: class withSelector: selector
| ranges index codeIndex output codeString range |
ranges := SHParserST80 new
rangesIn: (codeString := sourceText asString)
classOrMetaClass: class
workspace: nil
environment: nil.
index := codeIndex := 1.
output := (String new: codeString size) writeStream.
[index <= ranges size] whileTrue:
[range := ranges at: index.
index := index + 1.
[codeIndex < range start] whileTrue:
[output nextPut: (codeString at: codeIndex).
codeIndex := codeIndex + 1].
range type == #assignment
ifTrue: [output nextPutAll: ':='.
codeIndex := range end + 1]
ifFalse:
[(#(globalVar classVar) includes: range type)
ifTrue:
[output nextPutAll: (xlator value: (codeString copyFrom: range start to: range end)).
codeIndex := range end + 1]
ifFalse:
[#symbol == range type
ifTrue:
[output
nextPut: (codeString at: range start); "#"
nextPutAll: (xlator value: (codeString copyFrom: range start + 1 to: range end)).
codeIndex := range end + 1]
ifFalse:
[[codeIndex <= range end] whileTrue:
[output nextPut: (codeString at: codeIndex).
codeIndex := codeIndex + 1].
"kill whitespace after up-arrow in ^ expr"
(range type == #return and: [index <= ranges size]) ifTrue:
[codeIndex := (ranges at: index) start]]]]].
^output contents
"SHParserST80 new
rangesIn: (ClassHierarchyDuplicator sourceCodeAt: #editCode:inClass:withSelector:) asString
classOrMetaClass: ClassHierarchyDuplicator
workspace: nil
environment: nil"
"SHParserST80 new
rangesIn: ClassHierarchyDuplicator definition asString
classOrMetaClass: nil
workspace: nil
environment: nil"
"ClassHierarchyDuplicator new editCode: LeafNode definition inClass: nil withSelector: nil"
"ClassHierarchyDuplicator new editCode: (MessageNode sourceCodeAt: #emitToDo:on:value:) inClass: MethodNode withSelector: #emitToDo:on:value:"
"ClassHierarchyDuplicator new editCode: (MessageNode class sourceCodeAt: #initialize) inClass: MessageNode class withSelector: #initialize"!
----- Method: ClassHierarchyDuplicator>>initialize (in category 'initialize-release') -----
initialize
| globalNames |
prefix := 'XXX'.
classes := Set new.
((SystemOrganization categories reject: [:c| c beginsWith: prefix]) select:
[:c| ('*Compiler*' match: c) and: [#'Compiler-Morphing Bytecode Set' ~= c]]) do:
[:cat|
(SystemOrganization listAtCategoryNamed: cat) do:
[:cn|
classes add: (Smalltalk at: cn)]].
globalNames := classes collect: [:ea| ea name asString].
classes do: [:c| c classPool keys do: [:sym| globalNames add: sym asString]].
xlator := [:s| (globalNames includes: s) ifTrue: [prefix, s] ifFalse: [s]]
"self new edit"!
Object subclass: #ClosureLabelsPrintEditor
instanceVariableNames: 'xlator xlation kwdxlation ranges index output codeIndex'
classVariableNames: ''
poolDictionaries: ''
category: 'Cog-Morphing Bytecode Set'!
----- Method: ClosureLabelsPrintEditor>>edit: (in category 'code editing') -----
edit: generateViewBar
"self new edit: true"
| sn |
sn := SystemNavigation default.
xlation keysAndValuesDo:
[:s :t|
(sn allImplementorsOf: s localTo: ParseNode) do:
[:md| | newCode |
newCode := self editCode: md sourceString inClass: md actualClass withSelector: md methodSymbol.
generateViewBar
ifTrue: [md actualClass compile: newCode classified: 'printing']
ifFalse:
[(StringHolder new textContents:
(CodeDiffBuilder buildDisplayPatchFrom: md sourceString to: newCode))
openLabel: md printString]]]!
----- Method: ClosureLabelsPrintEditor>>editCode:inClass:withSelector: (in category 'code editing') -----
editCode: code inClass: class withSelector: selector
| codeString |
ranges := SHParserST80 new rangesIn: code classOrMetaClass: class workspace: nil environment: nil.
index := 1.
codeIndex := 1.
output := String new writeStream.
codeString := code asString.
self process: codeString.
^output contents!
----- Method: ClosureLabelsPrintEditor>>initialize (in category 'initialize-release') -----
initialize
xlator := [:s| s copyReplaceAll: 'print' with: 'printWithClosureAnalysis'].
xlation := Dictionary new.
(((ParseNode withAllSubclasses removeAll: Encoder withAllSubclasses; yourself)
inject: Set new
into: [:s :c| s addAll: c selectors. s]) select:
[:s| s beginsWith: 'print']) do:
[:s|xlation at: s put: (xlator value: s) asSymbol].
kwdxlation := Dictionary new.
xlation keysAndValuesDo: [:k :v| kwdxlation at: k keywords first put: v keywords first]!
----- Method: ClosureLabelsPrintEditor>>process: (in category 'code editing') -----
process: code
| range kwd |
[index <= ranges size] whileTrue:
[range := ranges at: index.
index := index + 1.
[codeIndex < range start] whileTrue:
[output nextPut: (code at: codeIndex).
codeIndex := codeIndex + 1].
range type == #assignment
ifTrue: [output nextPutAll: ':='.
codeIndex := range end + 1]
ifFalse:
[(#(keyword patternKeyword) includes: range type) ifTrue:
[kwd := code copyFrom: range start to: range end.
(kwdxlation includesKey: kwd) ifTrue:
[output nextPutAll: (kwdxlation at: kwd).
codeIndex := range end + 1]]
ifFalse:
[[codeIndex <= range end] whileTrue:
[output nextPut: (code at: codeIndex).
codeIndex := codeIndex + 1].
"kill whitespace after up-arrow in ^ expr"
(range type == #return and: [index <= ranges size]) ifTrue:
[codeIndex := (ranges at: index) start]]]]!
Object subclass: #CogScripts
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Cog-Scripts'!
----- Method: CogScripts class>>bootstrapClosures (in category 'closure scripts') -----
bootstrapClosures
"CogScripts bootstrapClosures"
| rep |
Transcript clear.
rep := false
ifTrue: [MCCacheRepository default]
ifFalse:
[MCHttpRepository
location: 'http://dev.qwaq.com/ss/Oinq'
user: 'qwaq'
password: ''].
"This changes load order in Monticello such that additions come in before modifications."
(rep loadVersionFromFileNamed: 'Monticello-eem.302.mcz') load.
"This adds some prereqs the compiler uses that are loaded in later packages:
Fix the ClassBuilder so redefining CompiledMethod can add and remove class variables.
Add Object/Array>>isArray.
Add new interface for accessing inst vars & fields on initializing the compiler (Encoder)."
self bootstrapClosuresCompilerPreloadCode readStream fileIn.
"This temporarily stops Monticello from unloading code on load and warning about overwriting changes.
Since changes span multiple packages need all additions in before any deletions occur.
Can't warn about anything until the new debugger api is installed."
ChangeSet
newChangesFromStream: self bootstrapClosuresNeuterMonticelloCode readStream
named: 'neuterMonticello'.
Smalltalk at: #DoNotUnload put: true.
1 to: 2 do:
[:i|
#( 'Compiler-eem.30.mcz'
'Files-eem.21.mcz'
'Exceptions-eem.14.mcz'
'Collections-eem.55.mcz'
'Tools-eem.45.mcz'
'Kernel-eem.82.mcz'
'System-eem.53.mcz'
'Brad-eem.51.mcz'
'Morphic-eem.38.mcz'
'Tweak-Compiler-eem.36.mcz'
'Tweak-Hacks-eem.30.mcz'
'Tweak-Basic-eem.151.mcz'
'Tweak-Core-Proto-eem.56.mcz') do:
[:pn|
Transcript clear; nextPutAll: pn; space; nextPut: $(; print: i; nextPut: $); endEntry.
(rep loadVersionFromFileNamed: pn) load].
Smalltalk at: #DoNotUnload put: false].
"Now remove the temporary hacks to Monticello"
(ChangeSet named: 'neuterMonticello') changedMessageList do:
[:mr| | changeRecords |
changeRecords := mr actualClass changeRecordsAt: mr methodSymbol.
changeRecords second fileIn].
"Install BlockClosure in the specialObjectsArray"
Smalltalk recreateSpecialObjectsArray.
"Throw the switch to compile to closures"
self bootstrapClosuresClosureCompilerSwitchCode readStream fileIn.
"Recompile the system except the one method we can't yet deal with in GeniePlugin (1 too many literals)"
(Smalltalk forgetDoIts allClasses reject: [:c| c name == #GeniePlugin]) do:
[:c|
{ c. c class } do:
[:b|
Transcript cr; print: b; endEntry.
b selectors asSortedCollection do:
[:s|
b recompile: s from: b]]].
UsefulScripts postRecompileCleanup.
self inform: 'Save and quit and then run UsefulScripts postRecompileCleanup.\Rinse and repeat' withCRs!
----- Method: CogScripts class>>bootstrapClosuresClosureCompilerSwitchCode (in category 'closure scripts') -----
bootstrapClosuresClosureCompilerSwitchCode
^'
!!Parser methodsFor: ''public access'' stamp: ''eem 5/15/2008 15:44''!!
encoder
encoder isNil ifTrue:
[encoder := EncoderForV3PlusClosures new].
^encoder!! !!'!
----- Method: CogScripts class>>bootstrapClosuresCompilerPreloadCode (in category 'closure scripts') -----
bootstrapClosuresCompilerPreloadCode
^'
!!ClassBuilder methodsFor: ''class format'' stamp: ''eem 6/13/2008 10:03''!!
computeFormat: type instSize: newInstSize forSuper: newSuper ccIndex: ccIndex
"Compute the new format for making oldClass a subclass of newSuper.
Return the format or nil if there is any problem."
| instSize isVar isWords isPointers isWeak |
type == #compiledMethod
ifTrue:[^CompiledMethod format].
instSize := newInstSize + (newSuper ifNil:[0] ifNotNil:[newSuper instSize]).
instSize > 254 ifTrue:[
self error: ''Class has too many instance variables ('', instSize printString,'')''.
^nil].
type == #normal ifTrue:[isVar := isWeak := false. isWords := isPointers := true].
type == #bytes ifTrue:[isVar := true. isWords := isPointers := isWeak := false].
type == #words ifTrue:[isVar := isWords := true. isPointers := isWeak := false].
type == #variable ifTrue:[isVar := isPointers := isWords := true. isWeak := false].
type == #weak ifTrue:[isVar := isWeak := isWords := isPointers := true].
(isPointers not and:[instSize > 0]) ifTrue:[
self error:''A non-pointer class cannot have instance variables''.
^nil].
^(self format: instSize
variable: isVar
words: isWords
pointers: isPointers
weak: isWeak) + (ccIndex bitShift: 11).!! !!
!!ClassBuilder methodsFor: ''public'' stamp: ''eem 6/13/2008 10:00''!!
superclass: aClass
variableByteSubclass: t instanceVariableNames: f
classVariableNames: d poolDictionaries: s category: cat
"This is the standard initialization message for creating a new class as a
subclass of an existing class in which the subclass is to
have indexable byte-sized nonpointer variables."
| oldClassOrNil actualType |
(aClass instSize > 0)
ifTrue: [^self error: ''cannot make a byte subclass of a class with named fields''].
(aClass isVariable and: [aClass isWords])
ifTrue: [^self error: ''cannot make a byte subclass of a class with word fields''].
(aClass isVariable and: [aClass isPointers])
ifTrue: [^self error: ''cannot make a byte subclass of a class with pointer fields''].
oldClassOrNil := aClass environment at: t ifAbsent:[nil].
actualType := (oldClassOrNil notNil
and: [oldClassOrNil typeOfClass == #compiledMethod])
ifTrue: [#compiledMethod]
ifFalse: [#bytes].
^self
name: t
inEnvironment: aClass environment
subclassOf: aClass
type: actualType
instanceVariableNames: f
classVariableNames: d
poolDictionaries: s
category: cat!! !!
!!Array methodsFor: ''testing'' stamp: ''eem 5/8/2008 11:13''!!
isArray
^true!! !!
!!Object methodsFor: ''testing'' stamp: ''eem 5/8/2008 11:13''!!
isArray
^false!! !!
!!Behavior methodsFor: ''compiling'' stamp: ''eem 5/13/2008 09:50''!!
instVarNamesAndOffsetsDo: aBinaryBlock
"This is part of the interface between the compiler and a class''s instance or field names.
The class should enumerate aBinaryBlock with the instance variable name strings and
their integer offsets. The order is important. Names evaluated later will override the
same names occurring earlier."
"Nothing to do here; ClassDescription introduces named instance variables"
^self!! !!
!!ClassDescription methodsFor: ''compiling'' stamp: ''eem 5/13/2008 09:48''!!
instVarNamesAndOffsetsDo: aBinaryBlock
"This is part of the interface between the compiler and a class''s instance or field names.
The class should enumerate aBinaryBlock with the instance variable name strings and
their integer offsets. The order is important. Names evaluated later will override the
same names occurring earlier."
| superInstSize |
(superInstSize := superclass notNil ifTrue: [superclass instSize] ifFalse: [0]) > 0 ifTrue:
[superclass instVarNamesAndOffsetsDo: aBinaryBlock].
1 to: self instSize - superInstSize do:
[:i| aBinaryBlock value: (instanceVariables at: i) value: i + superInstSize]!! !!
!!Behavior methodsFor: ''compiling'' stamp: ''eem 5/13/2008 09:50''!!
variablesAndOffsetsDo: aBinaryBlock
"This is the interface between the compiler and a class''s instance or field names. The
class should enumerate aBinaryBlock with the field definitions (with nil offsets) followed
by the instance variable name strings and their integer offsets. The order is important.
Names evaluated later will override the same names occurring earlier."
"Only need to do instance variables here. CProtoObject introduces field definitions."
self instVarNamesAndOffsetsDo: aBinaryBlock!! !!
!!CProtoObject class methodsFor: ''compiling'' stamp: ''eem 5/13/2008 09:53''!!
variablesAndOffsetsDo: aBinaryBlock
"This is the interface between the compiler and a class''s instance or field names. The
class should enumerate aBinaryBlock with the field definitions (with nil offsets) followed
by the instance variable name strings and their integer offsets. The order is important.
Names evaluated later will override the same names occurring earlier."
self allFieldsReverseDo: [:field| aBinaryBlock value: field value: nil].
self instVarNamesAndOffsetsDo: aBinaryBlock!! !!'!
----- Method: CogScripts class>>bootstrapClosuresNeuterMonticelloCode (in category 'closure scripts') -----
bootstrapClosuresNeuterMonticelloCode
^'
!!MCVersionLoader methodsFor: ''checking'' stamp: ''eem 6/12/2008 17:30''!!
checkForModifications
| modifications |
modifications := versions select: [:ea | ea package workingCopy modified].
true ifTrue: [^true].
modifications isEmpty ifFalse: [self warnAboutLosingChangesTo: modifications].!! !!
!!MCClassDefinition methodsFor: ''installing'' stamp: ''eem 6/12/2008 17:53''!!
unload
(Smalltalk at: #DoNotUnload ifAbsent: [false]) ifTrue: [^self].
Smalltalk removeClassNamed: name!! !!
!!MCMethodDefinition methodsFor: ''installing'' stamp: ''eem 6/12/2008 17:53''!!
unload
| previousVersion |
(Smalltalk at: #DoNotUnload ifAbsent: [false]) ifTrue: [^self].
self isOverrideMethod ifTrue: [previousVersion := self scanForPreviousVersion].
previousVersion
ifNil: [self actualClass ifNotNilDo: [:class | class removeSelector: selector]]
ifNotNil: [previousVersion fileIn] !! !!
!!MCOrganizationDefinition methodsFor: ''as yet unclassified'' stamp: ''eem 6/12/2008 18:06''!!
postloadOver: oldDefinition
[SystemOrganization categories:
(self
reorderCategories: SystemOrganization categories
original: (oldDefinition ifNil: [#()] ifNotNil: [oldDefinition categories]))]
on: Error
do: [:ex| Transcript cr; print: ex messageText; endEntry]!! !!
!!MCPackageLoader methodsFor: ''private'' stamp: ''eem 6/12/2008 21:32''!!
tryToLoad: aDefinition
[aDefinition loadOver: (self obsoletionFor: aDefinition)]
on: Error
do: [:ex| self halt. errorDefinitions add: aDefinition]!! !!'!
----- Method: CogScripts class>>browseExclusiveMethodImportsForPrimitiveClass: (in category 'separate vm scripts') -----
browseExclusiveMethodImportsForPrimitiveClass: primClass
"Browse methods used by the class holding VM primitives and unused elsewhere."
"self browseExclusiveMethodImportsForPrimitiveClass: StackInterpreterSPrimitives"
Cursor execute showWhile:
["The algorithm computes a fixed point of the methods used
by the parcel which are unused outside it. The algorithm is
compute messages sent within parcel
repeat until at a fixed point:
compute intersection of this with methods implemented outside parcel
compute messages sent outside parcel not within the intersection
remove these from intersection"
| parcelMessages "<IdentitySet of: Symbol>
messages sent within this parcel"
externalMethods "<Set of: MethodDescription>
methods implemented outside this parcel"
danglingMethods "<Set of: MethodDescription>
methods importeded only by this parcel"
previousDangling "<Set of: MethodDescription>
intermediate value of danglingMethods (for determining if fixed point is reached)"
danglingMessages "<Set of: Symbol> selectors of methods in danglingMethods"
noLongerDangling "<Set of: Symbol> selectors to be moved from dangling" |
parcelMessages := IdentitySet new.
primClass methodsDo:
[:meth| parcelMessages addAll: meth messages].
"compute starting points for danglingMethods and externalMethods"
danglingMethods := Set new: 50.
externalMethods := Set new: 20000.
(PackageInfo named: 'VMMaker') classes do:
[:aBehavior| | extends |
(aBehavior = primClass or: [aBehavior inheritsFrom: primClass]) ifFalse:
[aBehavior selectorsAndMethodsDo:
[:sel :meth|
(primClass includesSelector: sel) ifFalse:
[((parcelMessages includes: sel)
ifTrue: [danglingMethods]
ifFalse: [externalMethods])
add: (MethodReference class: aBehavior selector: sel)]]]].
["Now iterate to the fixed-point. Any method in dangling with a selector sent
in external must be moved into external until dangling reaches its fixed point."
previousDangling := danglingMethods copy.
danglingMessages := danglingMethods collect: [:md| md selector].
noLongerDangling := Set new: danglingMethods size.
externalMethods do:
[:md|
md compiledMethod messages do:
[:l|
(danglingMessages includes: l) ifTrue:
[noLongerDangling add: l]]].
externalMethods := danglingMethods select: [:md| noLongerDangling includes: md selector].
danglingMethods removeAll: externalMethods.
danglingMethods size ~= previousDangling size] whileTrue.
SystemNavigation default
browseMessageList: danglingMethods asSortedCollection
name: 'Methods Used Only by ', primClass name, ' but not in ', primClass name]!
----- Method: CogScripts class>>changedMethodsForObjectMemorySends (in category 'separate vm scripts') -----
changedMethodsForObjectMemorySends
"Answer the methods in StackInterpreter and subclasses that change if sends to self for methods implemented
in ObjectMemory, NewObjectMemory (& NewObjectMemorySE ?) become sends to objectMemory."
"CogScripts changedMethodsForObjectMemorySends"
| selectors rules model environment sortedChanges |
selectors := { ObjectMemory. NewObjectMemory. "NewObjectMemorySE" }
inject: Set new
into: [:sels :class| sels addAll: class selectors; yourself].
rules := RBParseTreeRewriter new.
rules
replace: 'self `@method: ``@args'
with: 'objectMemory `@method: ``@args'
when: [:node| selectors includes: node selector].
#( 'nilObj' 'trueObj' 'falseObj')
do: [:instVar|
rules
replace: instVar, ' := ``@args' with: 'objectMemory ', instVar, 'ect: ``@args';
replace: instVar with: 'objectMemory ', instVar, 'ect'].
self readWriteVars do: [:instVar|
rules
replace: instVar, ' := ``@args' with: 'objectMemory ', instVar, ': ``@args';
replace: instVar with: 'objectMemory ', instVar].
self readOnlyVars do: [:instVar|
rules replace: instVar with: 'objectMemory ', instVar].
model := RBNamespace new.
environment := BrowserEnvironment new forClasses:
{ StackInterpreter. CoInterpreter. CoInterpreterMT.
StackInterpreterSimulator. CogVMSimulator }.
environment classesAndSelectorsDo:
[ :class :selector | | tree |
"(class == StackInterpreter and: [selector == #isContextHeader:]) ifTrue: [self halt]."
"(class == StackInterpreter and: [selector == #isIndexable:]) ifTrue: [self halt]."
"(class == StackInterpreter and: [selector == #printContextCallStackOf:]) ifTrue: [self halt]."
tree := class parseTreeFor: selector.
(rules executeTree: tree) ifTrue:
[model compile: rules tree newSource in: class classified: (class whichCategoryIncludesSelector: selector)]].
false ifTrue: [model changes inspect].
false ifTrue: "shortest change:"
[(model changes changes inject: model changes changes first into: [:c1 :c2| c1 printString size < c2 printString size ifTrue: [c1] ifFalse: [c2]]) inspect].
sortedChanges := model changes changes asSortedCollection:
[:c1 :c2|
c1 changeClass == c2 changeClass
ifTrue: [c1 selector <= c2 selector]
ifFalse: [c2 changeClass inheritsFrom: c1 changeClass]].
true ifTrue:
[MessageSetTextDifferencer
openMessageList: (sortedChanges collect: [:mr| { MethodReference class: mr changeClass selector: mr selector. TextReference new text: mr source class: mr class selector: mr selector }])
name: 'self foo <-> objectMemory foo et al'
autoSelect: nil].
^sortedChanges!
----- Method: CogScripts class>>createObjMemSims (in category 'separate vm scripts') -----
createObjMemSims
"self createObjMemSims"
{ NewObjectMemory. NewCoObjectMemory } do:
[:c| | sc oc nc |
sc := Compiler evaluate: ((Class templateForSubclassOf: c category: c category, 'Simulation') copyReplaceAll: 'NameOfSubclass' with: c name, 'Simulator').
false ifTrue:
[oc := NewObjectMemorySimulator.
oc selectors do:
[:s| [sc compile: (oc sourceCodeAt: s) asString
classified: (oc whichCategoryIncludesSelector: s)
withStamp: (oc >> s) timeStamp
notifying: nil] on: Error do: [:ex|]]].
nc := Compiler evaluate: ((Class templateForSubclassOf: sc category: sc category) copyReplaceAll: 'NameOfSubclass' with: sc name, 'LSB').
oc := nc selectors size > 0 ifTrue: [nc] ifFalse: [NewObjectMemorySimulatorLSB].
oc selectors do:
[:s| | aoc |
aoc := (CogVMSimulatorLSB includesSelector: s) ifTrue: [CogVMSimulatorLSB] ifFalse: [NewObjectMemorySimulatorLSB].
nc compile: (aoc sourceCodeAt: s) asString
classified: (aoc whichCategoryIncludesSelector: s)
withStamp: (aoc >> s) timeStamp
notifying: nil].
nc := Compiler evaluate: ((Class templateForSubclassOf: sc category: sc category) copyReplaceAll: 'NameOfSubclass' with: sc name, 'MSB').
oc := NewObjectMemorySimulatorMSB.
oc selectors do:
[:s| nc compile: (oc sourceCodeAt: s) asString
classified: (oc whichCategoryIncludesSelector: s)
withStamp: (oc >> s) timeStamp
notifying: nil]]!
----- Method: CogScripts class>>createSVMTree (in category 'separate vm scripts') -----
createSVMTree
"Create the parallel StackInterpreterS, CoInterpreterS tree in which
objectMemory is an inst var rather than ObjectMemory et al being a superclass"
"CogScripts createSVMTree"
| changes map |
changes := Cursor execute showWhile: [self changedMethodsForObjectMemorySends].
map := Cursor execute showWhile: [self createStackInterpreterSHierarchy].
(ChangeSet superclassOrder: (StackInterpreter withAllSubclasses select: [:c| map includesKey: c]) asArray) do:
[:sourceClass|
sourceClass selectors do:
[:sel| | destClass source stamp |
destClass := map
at: (((sel beginsWith: 'primitive')
and: [sel last ~~ $:
and: [sel ~~ #primitiveFail]])
ifTrue: [{sourceClass. #primitives}]
ifFalse: [sourceClass])
ifAbsent: [map at: sourceClass].
(changes detect: [:c| c changeClass == sourceClass and: [c selector = sel]] ifNone: [])
ifNotNil:
[:change|
source := change source.
stamp := Utilities changeStamp copyReplaceAll: Utilities authorInitials with: Utilities authorInitials, ' (objmem refactor)']
ifNil:
[source := sourceClass sourceCodeAt: sel.
stamp := (sourceClass >> sel) timeStamp].
[destClass
compile: source
classified: (sourceClass whichCategoryIncludesSelector: sel)
withStamp: stamp
notifying: nil]
on: SyntaxErrorNotification
do: [:ex| | newBrowser |
newBrowser := Browser new setClass: destClass selector: nil.
newBrowser selectMessageCategoryNamed: (sourceClass whichCategoryIncludesSelector: sel).
Browser
openBrowserView: (newBrowser openMessageCatEditString: source)
label: 'category "', (sourceClass whichCategoryIncludesSelector: sel), '" in ', destClass name]]].
self readWriteVars, self readOnlyVars do:
[:sym|
(NewObjectMemory whichClassIncludesSelector: sym) ifNil:
[(NewObjectMemory whichClassDefinesInstVar: sym asString)
compile: sym, (String with: Character cr with: Character tab with: $^), sym
classified: #accessing]].
self readWriteVars do:
[:sym| | setter | setter := (sym, ':') asSymbol.
(NewObjectMemory whichClassIncludesSelector: setter) ifNil:
[(NewObjectMemory whichClassDefinesInstVar: sym asString)
compile: setter, ' aValue', (String with: Character cr with: Character tab with: $^), sym, ' := aValue'
classified: #accessing]].!
----- Method: CogScripts class>>createStackInterpreterSHierarchy (in category 'separate vm scripts') -----
createStackInterpreterSHierarchy
"Create the parallel StackInterpreterS, CoInterpreterS tree (without methods).
Answer a Dictionary maping source class to dest class with {source. #primitives} -> dest
for the added primitives classes."
| map |
(Smalltalk classNamed: #StackInterpreterS) ifNotNil:
[:sis|
(Object confirm: 'StackInterpreterS exists, nuke?') ifTrue:
[(ChangeSet superclassOrder: sis withAllSubclasses asArray) reverseDo:
[:sissc| sissc removeFromSystemUnlogged]]].
map := Dictionary new.
(ChangeSet superclassOrder: (StackInterpreter withAllSubclasses
remove: SchizophrenicClosureFormatStackInterpreter;
yourself) asArray) do:
[:sisc| | def |
def := sisc definition.
def := sisc == StackInterpreter
ifTrue: [((def copyReplaceAll: sisc superclass name, ' ' with: ObjectMemory superclass name, ' ')
copyReplaceAll: 'instanceVariableNames: ''' with: 'instanceVariableNames: ''objectMemory ')
copyReplaceAll: 'poolDictionaries: ''' with: 'poolDictionaries: ''', (ObjectMemory poolDictionaryNames fold: [:a :b| a, ' ', b]), ' ']
ifFalse: [def copyReplaceAll: sisc superclass name, ' ' with: sisc superclass name, 'S '].
def := def copyReplaceAll: sisc name printString with: sisc name printString, 'S'.
map at: sisc put: (Compiler evaluate: def)].
map at: {StackInterpreter. #primitives}
put: (Compiler
evaluate: 'StackInterpreterS subclass: #StackInterpreterSPrimitives
instanceVariableNames: ''''
classVariableNames: ''''
poolDictionaries: ''''
category: ''VMMaker-Interpreter''');
at: {CoInterpreter. #primitives}
put: (Compiler
evaluate: 'CoInterpreterS subclass: #CoInterpreterSPrimitives
instanceVariableNames: ''''
classVariableNames: ''''
poolDictionaries: ''''
category: ''VMMaker-Interpreter''');
at: {StackInterpreter. #objmem}
put: (Compiler
evaluate: 'NewObjectMemory subclass: #NewObjectMemoryS
instanceVariableNames: ''coInterpreter''
classVariableNames: ''''
poolDictionaries: ''''
category: ''VMMaker-Interpreter''');
at: {CoInterpreter. #objmem}
put: (Compiler
evaluate: 'NewObjectMemoryS subclass: #NewCoObjectMemoryS
instanceVariableNames: ''''
classVariableNames: ''''
poolDictionaries: ''''
category: ''VMMaker-Interpreter''').
"reparent subclasses underneath StackInterpreterSPrimitives & CoInterpreterSPrimitives"
#(StackInterpreterS CoInterpreterS) do:
[:cn|
((Smalltalk classNamed: cn) subclasses reject: [:c| c name endsWith: 'Primitives']) do:
[:sisc| | def |
def := sisc definition.
def := def copyReplaceAll: cn, ' ' with: cn, 'Primitives '.
Compiler evaluate: def]].
^map!
----- Method: CogScripts class>>doClassSide (in category 'separate vm scripts') -----
doClassSide
"self doClassSide"
| classes rules model env sortedChanges |
classes := (PackageInfo named: 'VMMaker') classes.
classes := classes select: [:c| classes anySatisfy: [:d| d name last = $S and: [d name allButLast = c name]]].
rules := RBParseTreeRewriter new.
model := RBNamespace new.
env := BrowserEnvironment new forClasses: classes.
classes do: [:c| rules replace: c name with: c name, 'S'].
env classesAndSelectorsDo:
[:class :selector| | tree |
class isMeta ifTrue:
[tree := class parseTreeFor: selector.
rules executeTree: tree.
model compile: rules tree newSource in: class classified: (class whichCategoryIncludesSelector: selector)]].
false ifTrue: [model changes inspect].
false ifTrue: "shortest change:"
[(model changes changes inject: model changes changes first into: [:c1 :c2| c1 printString size < c2 printString size ifTrue: [c1] ifFalse: [c2]]) inspect].
sortedChanges := model changes changes asSortedCollection:
[:c1 :c2|
c1 changeClass == c2 changeClass
ifTrue: [c1 selector <= c2 selector]
ifFalse: [c2 changeClass inheritsFrom: c1 changeClass]].
true ifTrue:
[MessageSetTextDifferencer
openMessageList: (sortedChanges collect: [:mr| { MethodReference class: mr changeClass selector: mr selector. TextReference new text: mr source class: mr class selector: mr selector }])
name: 'class side'
autoSelect: nil].
sortedChanges do:
[:mr|
(Smalltalk classNamed: (mr changeClass theNonMetaClass name, 'S') asSymbol) class
compile: mr source
classified: (mr changeClass whichCategoryIncludesSelector: mr selector)
withStamp: (mr source asString = (mr changeClass sourceCodeAt: mr selector) asString
ifTrue: [(mr changeClass >> mr selector) timeStamp]
ifFalse: [Utilities changeStamp copyReplaceAll: Utilities authorInitials with: Utilities authorInitials, ' (objmem refactor)'])
notifying: nil]!
----- Method: CogScripts class>>readOnlyVars (in category 'separate vm scripts') -----
readOnlyVars
^#(#checkForLeaks #fullGCLock #gcStartUsecs #memoryLimit #scavengeThreshold #youngStart
#statCompMoveCount #statFullGCUsecs #statFullGCs #statGCEndUsecs #statGrowMemory #statIGCDeltaUsecs
#statIncrGCUsecs #statIncrGCs #statMarkCount #statMkFwdCount #statRootTableCount #statRootTableOverflows
#statShrinkMemory #statSpecialMarkCount #statSurvivorCount #statSweepCount #statTenures)!
----- Method: CogScripts class>>readWriteVars (in category 'separate vm scripts') -----
readWriteVars
^#(#specialObjectsOop
#edenBytes #endOfMemory #forceTenureFlag #freeStart #needGCFlag
#gcBiasToGrow #gcBiasToGrowGCLimit #gcBiasToGrowThreshold
#growHeadroom #lastHash #lowSpaceThreshold #memory
#remapBuffer #remapBufferCount #rootTable #rootTableCount
#signalLowSpace #shrinkThreshold tenuringThreshold)!
----- Method: CogScripts>>seeClassSide (in category 'look on class side') -----
seeClassSide
"All the code is on the class side"!
Object subclass: #CrashReportsMailer
instanceVariableNames: 'mailDirectory destination startDate endDate rs causes soloTime meetingTime'
classVariableNames: ''
poolDictionaries: 'ChronologyConstants'
category: 'Cog-Scripts'!
!CrashReportsMailer commentStamp: '<historical>' prior: 0!
This class generates an almost complete crash report that still needs editing for categories and then posts it after editing.!
----- Method: CrashReportsMailer class>>mailDirectory:destination:week: (in category 'instance creation') -----
mailDirectory: aFileDirectoryOrString destination: anEmailAddress week: startDate
^self new
mailDirectory: aFileDirectoryOrString
destination: anEmailAddress
startDate: (TimeStamp fromSeconds: startDate asDate asSeconds)
endDate: (TimeStamp fromSeconds: (startDate asDate addDays: 7) asSeconds)
"(self mailDirectory: '/Users/eliot/Library/Mail/IMAP-emiranda at ussc9-mail01.qwaq.com/INBOX.imapmbox/Messages'
destination: 'eng at teleplace.com'
week: '05/15/2010') generateReport"!
----- Method: CrashReportsMailer class>>mailDirectory:destination:week:soloTime:meetingTime: (in category 'instance creation') -----
mailDirectory: aFileDirectoryOrString destination: anEmailAddress week: startDateString soloTime: soloDurationOrString meetingTime: meetingDurationOrString
| startDate |
startDate := ((startDateString includes: $-)
ifTrue: [(#(2 3 1) collect: [:i| (startDateString subStrings: '-') at: i]) fold: [:a :b| a,'/',b]]
ifFalse: [startDateString]) asDate.
^self new
mailDirectory: aFileDirectoryOrString
destination: anEmailAddress
startDate: (TimeStamp fromSeconds: startDate asSeconds)
endDate: (TimeStamp fromSeconds: (startDate addDays: 7) asSeconds - 1)
soloTime: soloDurationOrString asDuration
meetingTime: meetingDurationOrString asDuration
"(self mailDirectory: '/Users/eliot/Library/Mail/IMAP-emiranda at ussc9-mail01.qwaq.com/INBOX.imapmbox/Messages'
destination: 'eng at teleplace.com'
week: '05/15/2010'
soloTime: '20:19:38:55'
meetingTime: '7:23:44:45') generateReport"!
----- Method: CrashReportsMailer>>addReportFor: (in category 'reporting') -----
addReportFor: lines
rs resetContents;
tab;
nextPutAll: ((lines detect: [:l| l beginsWith: 'Subject:']) ifNotNil:
[:l| l allButFirst: (l indexOfSubCollection: ' Teleplace Bug')]);
crtab: 2;
nextPutAll: (lines detect: [:l| l beginsWith: 'Date:']);
cr.
((lines anySatisfy: [:l| (l beginsWith: 'OS Version') and: [l includesSubString: 'Mac OS X']])
ifTrue: [self reportForMacOS: lines]
ifFalse: [(lines anySatisfy: [:l| l beginsWith: 'Module:'])
ifTrue: [self reportForOldWin32: lines]
ifFalse: [self reportForNewWin32: lines]]) ifNotNil:
[:cause|
(causes at: cause ifAbsentPut: [OrderedCollection new])
addLast: rs contents]!
----- Method: CrashReportsMailer>>breakIntoLines: (in category 'parsing') -----
breakIntoLines: aString
^self pruneBogusEmptyLines:
(Array streamContents:
[:os| | is ss char |
is := aString readStream.
ss := ReadWriteStream on: String new.
[is atEnd] whileFalse:
[(char := is next) = Character lf
ifTrue:
[os nextPut: ss contents.
ss resetContents]
ifFalse: [ss nextPut: char]].
ss position > 0 ifTrue:
[os nextPut: ss contents]])!
----- Method: CrashReportsMailer>>candidateMessagesDo: (in category 'parsing') -----
candidateMessagesDo: aBlock
"Evaluate aBlock with the file names of every file newer than the start date minus some slop"
| start |
start := (startDate minusDays: 7) asSeconds.
mailDirectory entries do:
[:dirEntry|
((dirEntry name endsWith: '.emlx')
and: [dirEntry creationTime > start]) ifTrue:
[aBlock value: dirEntry name]]!
----- Method: CrashReportsMailer>>collectReportSummaries (in category 'reporting') -----
collectReportSummaries
self candidateMessagesDo:
[:fn|
self ifCrashReport: fn do:
[:lines|
self addReportFor: lines]]!
----- Method: CrashReportsMailer>>generateFinalReport (in category 'reporting') -----
generateFinalReport
| count numMac ws |
count := causes inject: 0 into: [:sum :collection| sum + collection size].
rs reset.
rs print: count; nextPutAll: ' VM Crashes. ? OpenGL. ? Audio plugin. ? Video plugin. ? Python plugin. ? core VM. ? unknown.'; cr.
numMac := (causes keys select: [:k| k beginsWith: 'Mac:']) size.
rs nextPutAll: 'win: '; print: count- numMac; cr.
rs nextPutAll: 'mac: '; print: numMac; cr; cr.
self reportCrashRates: count.
causes keys asSortedCollection do:
[:k|
(causes at: k) do:
[:report| rs nextPutAll: report].
rs nextPutAll: k; cr; cr].
(ws := Workspace new contents: rs contents)
acceptAction: [:s| (UIManager default confirm: 'Sure you want to send?') ifTrue:
[self mailReport: s.
ws acceptAction:
[(UIManager default confirm: 'You''ve already sent this. Sure you want to send again?') ifTrue:
[self mailReport: s]]]];
openLabel: 'Customer VM Crashes ', startDate date printString, ' to ', endDate date printString;
shouldStyle: false!
----- Method: CrashReportsMailer>>generateReport (in category 'reporting') -----
generateReport
causes := Dictionary new.
self collectReportSummaries.
self generateFinalReport!
----- Method: CrashReportsMailer>>ifCrashReport:do: (in category 'parsing') -----
ifCrashReport: fileName do: aBlock
"Answer the evaluation of aBlock with the lines for fileName if it is a crash report, or nil if not."
| file lines subject |
file := mailDirectory oldFileNamed: fileName.
lines := [file contentsOfEntireFile]
on: Error
do: [:ex|
file close.
Transcript nextPutAll: fileName; nextPutAll: ': '; nextPutAll: ex messageText; flush.
^nil].
lines := self breakIntoLines: lines.
subject := lines detect: [:l| l beginsWith: 'Subject:'] ifNone: [^nil].
(subject includesSubString: 'Teleplace Bug Report: ') ifFalse: [^nil].
#('@qwaq.com' '@teleplace.com' '@chonkaa.com' 'craig at netjam.org' 'skysound at mac.com') do:
[:localEmail| (subject includesSubstring: localEmail caseSensitive: false) ifTrue: [^nil]].
(lines anySatisfy:
[:l|
((l beginsWith: 'OS Version') and: [l includesSubString: 'Mac OS X'])
or: [l beginsWith: 'Operating System:']]) ifFalse: [^nil].
^aBlock value: lines!
----- Method: CrashReportsMailer>>macOSDateFor: (in category 'reporting') -----
macOSDateFor: dateString
| tokens |
tokens := dateString subStrings: ' -.+'.
^TimeStamp
date: (Date year: tokens first asInteger month: tokens second asInteger day: tokens third asInteger)
time: tokens fourth asTime!
----- Method: CrashReportsMailer>>mailDirectory:destination:startDate:endDate: (in category 'initialize-release') -----
mailDirectory: aFileDirectoryOrString destination: anEmailAddress startDate: startTimestamp endDate: endTimestamp
mailDirectory := aFileDirectoryOrString isString
ifTrue: [FileDirectory on: aFileDirectoryOrString]
ifFalse: [aFileDirectoryOrString].
destination := anEmailAddress.
startDate := startTimestamp.
endDate := endTimestamp.
rs := ReadWriteStream on: (String new: 256)!
----- Method: CrashReportsMailer>>mailDirectory:destination:startDate:endDate:soloTime:meetingTime: (in category 'initialize-release') -----
mailDirectory: aFileDirectoryOrString destination: anEmailAddress startDate: startTimestamp endDate: endTimestamp soloTime: soloDuration meetingTime: meetingDuration
mailDirectory := aFileDirectoryOrString isString
ifTrue: [FileDirectory on: aFileDirectoryOrString]
ifFalse: [aFileDirectoryOrString].
destination := anEmailAddress.
startDate := startTimestamp.
endDate := endTimestamp.
soloTime := soloDuration.
meetingTime := meetingDuration.
rs := ReadWriteStream on: (String new: 256)!
----- Method: CrashReportsMailer>>mailReport: (in category 'mailing') -----
mailReport: aText
| msg |
msg := MailMessage new
setField: 'from' toString: 'eliot at teleplace.com';
setField: 'to' toString: destination;
setField: 'subject' toString: 'Customer VM Crashes ',
(startDate date printFormat: #(3 2 1 $/ 1 2)),
' - ',
((endDate - 1 seconds) date printFormat: #(3 2 1 $/ 1 2));
body: (MIMEDocument contentType: 'text/plain' content: aText asString).
SMTPClient
deliverMailFrom: msg from
to: (Array with: msg to)
text: msg text
usingServer: MailComposition new smtpServer!
----- Method: CrashReportsMailer>>pruneBogusEmptyLines: (in category 'parsing') -----
pruneBogusEmptyLines: lines
"Eliminate duplicate empty lines from broken CR-LF to LF-LF conversions."
| firstEmpty lastEmpty |
(firstEmpty := lines findFirst: [:l| l isEmpty]) = 0 ifTrue:
[^lines].
lastEmpty := firstEmpty.
[(lines at: lastEmpty + 2) isEmpty] whileTrue:
[lastEmpty := lastEmpty + 2].
^(lines copyFrom: 1 to: firstEmpty - 1),
((firstEmpty + 1 to: lastEmpty - 1 by: 2) collect: [:i| lines at: i]),
(lines copyFrom: lastEmpty + 1 to: lines size)!
----- Method: CrashReportsMailer>>reportCrashRates: (in category 'reporting') -----
reportCrashRates: count
{ soloTime. meetingTime }
with: #('solo hours: ' 'meeting hours: ')
do: [:time :label|
rs nextPutAll: label; print: (time asSeconds / SecondsInHour) rounded;
space; nextPut: $(; print: time; nextPut: $); cr].
rs cr.
{ soloTime. meetingTime }
with: #('solo' 'meeting')
do: [:time :label|
{ SecondsInHour. SecondsInDay }
with: #('hour' 'day')
do: [:period :periodLabel| | rate |
rate := count / (time asSeconds / period).
rs print: (rate roundTo: (rate >= 1 ifTrue: [0.1] ifFalse: [0.001]));
nextPutAll: ' crashes per '; nextPutAll: label; space; nextPutAll: periodLabel; cr]].
rs cr; cr!
----- Method: CrashReportsMailer>>reportForMacOS: (in category 'reporting') -----
reportForMacOS: lines
| thread dateAndTime cStackTop cstIdx |
thread := Integer readFrom: ((lines detect: [:l| l beginsWith: 'Crashed Thread: ']) allButFirst: 15) readStream skipSeparators.
thread := 'Thread ', thread printString, ' Crashed'.
lines withIndexDo:
[:l :i|
(l beginsWith: 'Date/Time:') ifTrue:
[dateAndTime := l allButFirst: 11].
((l beginsWith: thread)
and: [i < lines size]) ifTrue:
[cStackTop := lines at: (cstIdx := i + 1)]].
[cstIdx <= lines size
and: [(lines at: cstIdx) notEmpty]] whileTrue:
[(((lines at: cstIdx) includesSubString: ' _sigtramp ')
and: [((lines at: cstIdx + 1) includesSubString: ' ??? ')
and: [((lines at: cstIdx + 1) includesSubString: '0xffffffff 0 + 4294967295')]]) ifTrue:
[cStackTop := lines at: cstIdx + 2.
cstIdx := lines size].
cstIdx := cstIdx + 1].
dateAndTime := self macOSDateFor: dateAndTime.
(dateAndTime between: startDate and: endDate) ifFalse:
[^nil].
^'Mac:', (cStackTop allButFirst: (cStackTop indexOf: Character space))!
----- Method: CrashReportsMailer>>reportForNewWin32: (in category 'reporting') -----
reportForNewWin32: lines
| dateAndTime reason stStackTop cStackTop |
lines withIndexDo:
[:l :i|
(l beginsWith: 'Session Summary:') ifTrue:
[^nil]. "Not a VM bug report, ignore it."
(dateAndTime isNil
and: [(l beginsWith: '--------------------')
and: [i < lines size]]) ifTrue:
[dateAndTime := lines at: i + 1].
((l beginsWith: 'Smalltalk stack dump:')
and: [i < lines size]) ifTrue:
[stStackTop := lines at: i + 1].
((l beginsWith: 'Stack backtrace:')
and: [i < lines size]) ifTrue:
[cStackTop := lines at: i + 1]].
dateAndTime isNil ifTrue:
[^nil].
dateAndTime := self win32DateFor: dateAndTime.
(dateAndTime between: startDate and: endDate) ifFalse:
[^nil].
reason := (lines detect: [:l| l beginsWith: 'Reason: '] ifNone: []) ifNotNil: [:rl| rl allButFirst: 8].
"a stack entry looks like
0x9c2490 I NetNameResolver class>localHostAddress 271185968: a(n) NetNameResolver class
t293325136 s BlockClosure>on:do:"
stStackTop ifNotNil:
[stStackTop := (stStackTop subStrings: ' ') allButFirst: 2.
stStackTop := stStackTop first: (stStackTop findFirst: [:t| t first isDigit]) - 1.
stStackTop := stStackTop fold: [:a :b| a, ' ', b]].
^String streamContents:
[:s|
reason ifNotNil: [s nextPutAll: reason; cr].
stStackTop ifNotNil: [s nextPutAll: stStackTop; cr].
cStackTop ifNotNil: [s nextPutAll: cStackTop]]!
----- Method: CrashReportsMailer>>reportForOldWin32: (in category 'reporting') -----
reportForOldWin32: lines
| dateAndTime module idx stackTop |
lines withIndexDo:
[:l :i|
(dateAndTime isNil
and: [(l beginsWith: '--------------------')
and: [i < lines size]]) ifTrue:
[dateAndTime := lines at: i + 1].
((l beginsWith: 'Stack dump:')
and: [i < lines size]) ifTrue:
"Occasionally there is a bogus blank line between the label and the first entry"
[(stackTop := (lines at: i + 1) isEmpty) ifTrue:
[stackTop := lines at: i + 2]]].
dateAndTime := self win32DateFor: dateAndTime.
(dateAndTime between: startDate and: endDate) ifFalse:
[^nil].
module := (lines detect: [:l| l beginsWith: 'Module: ']) allButFirst: 8.
(idx := module indexOfSubCollection: '\Teleplace') > 0 ifTrue:
[module := module copyFrom: idx to: module size].
(module first isLetter and: [module second = $:]) ifTrue:
[module := module allButFirst: 2].
"a stack entry looks like
0x9c2490 I NetNameResolver class>localHostAddress 271185968: a(n) NetNameResolver class
293325136 s BlockClosure>on:do:
but if there is no stack there may be any old crap after Stack dump: so squash errors."
[stackTop := (stackTop subStrings: ' ') allButFirst: 2.
stackTop := stackTop first: (stackTop findFirst: [:t| t first isDigit]) - 1.
stackTop := stackTop fold: [:a :b| a, ' ', b]]
on: Error
do: [:ex| stackTop := '?'].
^stackTop, ' in ', module!
----- Method: CrashReportsMailer>>win32DateFor: (in category 'reporting') -----
win32DateFor: dateAndTimeString
"transform 'Thu Jun 24 14:11:18 2010' to 'Jun 24 2010 14:11:18' to allow parsing"
| tokens |
tokens := dateAndTimeString subStrings: ' '.
^({ tokens second. tokens third. tokens fifth. tokens fourth } fold: [:a :b| a, ' ', b]) asTimeStamp!
Object subclass: #MultiProcessor
instanceVariableNames: 'mutex processor guardedProcessorProtocol unguardedProcessorProtocol owner registerState coInterpreter threadIndex'
classVariableNames: ''
poolDictionaries: ''
category: 'Cog-Processors'!
----- Method: MultiProcessor class>>for:coInterpreter: (in category 'instance creation') -----
for: aProcessorAlien coInterpreter: coInterpreter
^self new
processor: aProcessorAlien;
coInterpreter: coInterpreter;
yourself!
----- Method: MultiProcessor>>coInterpreter: (in category 'initialize-release') -----
coInterpreter: aCoInterpreter
coInterpreter := aCoInterpreter!
----- Method: MultiProcessor>>doesNotUnderstand: (in category 'message forwarding') -----
doesNotUnderstand: aMessage
"Forward a message to the actual processor, managing a thread-switch if necessary.
Catch ProcessorSimulationTraps and raise them outside of the critical section to
avoid deadlock when reentering the VM from a trap and switching threads in the run-time."
| selector result trap |
selector := aMessage selector.
(guardedProcessorProtocol includes: selector) ifFalse:
[^(unguardedProcessorProtocol includes: selector)
ifTrue: [processor perform: selector withArguments: aMessage arguments]
ifFalse: [super doesNotUnderstand: aMessage]].
result := [mutex critical:
[owner ~~ mutex owningProcess ifTrue:
[owner ifNotNil:
[registerState at: owner put: processor registerState].
(registerState at: (owner := mutex owningProcess) ifAbsent: nil)
ifNil: [coInterpreter initializeProcessorForThreadIndex: (threadIndex := threadIndex + 1)]
ifNotNil: [:newState| processor setRegisterState: newState]].
processor perform: selector withArguments: aMessage arguments]]
on: ProcessorSimulationTrap, Error
do: [:ex| trap := ex].
^trap ifNil: [result] ifNotNil: [trap signal]!
----- Method: MultiProcessor>>initialize (in category 'initialize-release') -----
initialize
registerState := WeakIdentityKeyDictionary new.
mutex := Mutex new.
threadIndex := 0.
guardedProcessorProtocol := unguardedProcessorProtocol := Set new!
----- Method: MultiProcessor>>processor: (in category 'initialize-release') -----
processor: aProcessor
processor := aProcessor.
guardedProcessorProtocol := aProcessor class selectors asSet.
unguardedProcessorProtocol := #(#'Cog API' #opcodes #disassembly #printing)
inject: Set new
into: [ :protocol :category|
protocol
addAll: (aProcessor class organization listAtCategoryNamed: category);
yourself].
guardedProcessorProtocol removeAll: unguardedProcessorProtocol!
Object subclass: #ShootoutBody
instanceVariableNames: 'x y z vx vy vz mass'
classVariableNames: ''
poolDictionaries: ''
category: 'Cog-Benchmarks'!
----- Method: ShootoutBody class>>daysPerYear (in category 'constants') -----
daysPerYear
^365.24!
----- Method: ShootoutBody class>>jupiter (in category 'constants') -----
jupiter
^self new
x: 4.84143144246472090
y: -1.16032004402742839
z: -1.03622044471123109e-1
vx: 1.66007664274403694e-3 * self daysPerYear
vy: 7.69901118419740425e-3 * self daysPerYear
vz: -6.90460016972063023e-5 * self daysPerYear
mass: 9.54791938424326609e-4 * self solarMass!
----- Method: ShootoutBody class>>neptune (in category 'constants') -----
neptune
^self new
x: 1.53796971148509165e1
y: -2.59193146099879641e1
z: 1.79258772950371181e-1
vx: 2.68067772490389322e-3 * self daysPerYear
vy: 1.62824170038242295e-3 * self daysPerYear
vz: -9.51592254519715870e-5 * self daysPerYear
mass: 5.15138902046611451e-5 * self solarMass!
----- Method: ShootoutBody class>>pi (in category 'constants') -----
pi
^3.141592653589793!
----- Method: ShootoutBody class>>saturn (in category 'constants') -----
saturn
^self new
x: 8.34336671824457987
y: 4.12479856412430479
z: -4.03523417114321381e-1
vx: -2.76742510726862411e-3 * self daysPerYear
vy: 4.99852801234917238e-3 * self daysPerYear
vz: 2.30417297573763929e-5 * self daysPerYear
mass: 2.85885980666130812e-4 * self solarMass!
----- Method: ShootoutBody class>>solarMass (in category 'constants') -----
solarMass
^4.0 * self pi * self pi!
----- Method: ShootoutBody class>>sun (in category 'constants') -----
sun
^self new
x: 0.0
y: 0.0
z: 0.0
vx: 0.0
vy: 0.0
vz: 0.0
mass: self solarMass!
----- Method: ShootoutBody class>>uranus (in category 'constants') -----
uranus
^self new
x: 1.28943695621391310e1
y: -1.51111514016986312e1
z: -2.23307578892655734e-1
vx: 2.96460137564761618e-3 * self daysPerYear
vy: 2.37847173959480950e-3 * self daysPerYear
vz: -2.96589568540237556e-5 * self daysPerYear
mass: 4.36624404335156298e-5 * self solarMass!
----- Method: ShootoutBody>>addMomentumTo: (in category 'nbody') -----
addMomentumTo: anArray
anArray at: 1 put: (anArray at: 1) + (vx * mass).
anArray at: 2 put: (anArray at: 2) + (vy * mass).
anArray at: 3 put: (anArray at: 3) + (vz * mass).
^anArray!
----- Method: ShootoutBody>>and:velocityAfter: (in category 'nbody') -----
and: aBody velocityAfter: dt
| dx dy dz distance mag |
dx := x - aBody x.
dy := y - aBody y.
dz := z - aBody z.
distance := ((dx*dx) + (dy*dy) + (dz*dz)) sqrt.
mag := dt / (distance * distance * distance).
self decreaseVelocity: dx y: dy z: dz m: aBody mass * mag.
aBody increaseVelocity: dx y: dy z: dz m: mass * mag!
----- Method: ShootoutBody>>decreaseVelocity:y:z:m: (in category 'nbody') -----
decreaseVelocity: dx y: dy z: dz m: m
vx := vx - (dx * m).
vy := vy - (dy * m).
vz := vz - (dz * m)!
----- Method: ShootoutBody>>increaseVelocity:y:z:m: (in category 'nbody') -----
increaseVelocity: dx y: dy z: dz m: m
vx := vx + (dx * m).
vy := vy + (dy * m).
vz := vz + (dz * m)!
----- Method: ShootoutBody>>kineticEnergy (in category 'nbody') -----
kineticEnergy
^0.5 * mass * ((vx * vx) + (vy * vy) + (vz * vz))!
----- Method: ShootoutBody>>mass (in category 'accessing') -----
mass
^mass!
----- Method: ShootoutBody>>offsetMomentum: (in category 'nbody') -----
offsetMomentum: anArray
| m |
m := self class solarMass.
vx := (anArray at: 1) negated / m.
vy := (anArray at: 2) negated / m.
vz := (anArray at: 3) negated / m!
----- Method: ShootoutBody>>positionAfter: (in category 'nbody') -----
positionAfter: dt
x := x + (dt * vx).
y := y + (dt * vy).
z := z + (dt * vz)!
----- Method: ShootoutBody>>potentialEnergy: (in category 'nbody') -----
potentialEnergy: aBody
| dx dy dz distance |
dx := x - aBody x.
dy := y - aBody y.
dz := z - aBody z.
distance := ((dx*dx) + (dy*dy) + (dz*dz)) sqrt.
^mass * aBody mass / distance!
----- Method: ShootoutBody>>x (in category 'accessing') -----
x
^x!
----- Method: ShootoutBody>>x:y:z:vx:vy:vz:mass: (in category 'accessing') -----
x: d1 y: d2 z: d3 vx: d4 vy: d5 vz: d6 mass: d7
x := d1.
y := d2.
z := d3.
vx := d4.
vy := d5.
vz := d6.
mass := d7!
----- Method: ShootoutBody>>y (in category 'accessing') -----
y
^y!
----- Method: ShootoutBody>>z (in category 'accessing') -----
z
^z!
Object subclass: #ShootoutChameneosColour
instanceVariableNames: 'color'
classVariableNames: 'Blue Red Yellow'
poolDictionaries: ''
category: 'Cog-Benchmarks'!
----- Method: ShootoutChameneosColour class>>blue (in category 'accessing') -----
blue
^Blue!
----- Method: ShootoutChameneosColour class>>blue: (in category 'accessing') -----
blue: anObject
Blue := anObject!
----- Method: ShootoutChameneosColour class>>createBlue (in category 'initialize-release') -----
createBlue
"comment stating purpose of message"
^super new color: #blue!
----- Method: ShootoutChameneosColour class>>createRed (in category 'initialize-release') -----
createRed
"comment stating purpose of message"
^super new color: #red!
----- Method: ShootoutChameneosColour class>>createYellow (in category 'initialize-release') -----
createYellow
"comment stating purpose of message"
^super new color: #yellow!
----- Method: ShootoutChameneosColour class>>generateReportOfColoursOn: (in category 'printing') -----
generateReportOfColoursOn: readOut
| colours |
colours := Array
with: Blue
with: Red
with: Yellow.
colours do:
[:aColour |
colours do:
[:anotherColour |
aColour printOn: readOut.
readOut nextPutAll: ' + '.
anotherColour printOn: readOut.
readOut nextPutAll: ' -> '.
(aColour complementaryColourFor: anotherColour) printOn: readOut.
readOut nl]].
^readOut!
----- Method: ShootoutChameneosColour class>>initialize (in category 'initialize-release') -----
initialize
"self initialize"
Red := self createRed.
Blue := self createBlue.
Yellow := self createYellow!
----- Method: ShootoutChameneosColour class>>red (in category 'accessing') -----
red
^Red!
----- Method: ShootoutChameneosColour class>>red: (in category 'accessing') -----
red: anObject
Red := anObject!
----- Method: ShootoutChameneosColour class>>yellow (in category 'accessing') -----
yellow
^Yellow!
----- Method: ShootoutChameneosColour class>>yellow: (in category 'accessing') -----
yellow: anObject
Yellow := anObject!
----- Method: ShootoutChameneosColour>>color (in category 'accessing') -----
color
^color!
----- Method: ShootoutChameneosColour>>color: (in category 'accessing') -----
color: aColor
color := aColor!
----- Method: ShootoutChameneosColour>>complementaryColourFor: (in category 'as yet unclassified') -----
complementaryColourFor: aChameneosColour
"determine the complementary colour defined as..."
self == aChameneosColour ifTrue: [^self].
self isBlue
ifTrue:
[aChameneosColour isRed
ifTrue: [^self class yellow]
ifFalse: [^self class red]].
self isRed
ifTrue:
[aChameneosColour isBlue
ifTrue: [^self class yellow]
ifFalse: [^self class blue]].
aChameneosColour isBlue
ifTrue: [^self class red]
ifFalse: [^self class blue]!
----- Method: ShootoutChameneosColour>>hasSameColorAs: (in category 'testing') -----
hasSameColorAs: aChameneos
^self color == aChameneos color!
----- Method: ShootoutChameneosColour>>isBlue (in category 'testing') -----
isBlue
^self == self class blue!
----- Method: ShootoutChameneosColour>>isRed (in category 'testing') -----
isRed
^self == self class red!
----- Method: ShootoutChameneosColour>>isYellow (in category 'testing') -----
isYellow
^self == self class yellow!
----- Method: ShootoutChameneosColour>>printOn: (in category 'printing') -----
printOn: aStream
aStream nextPutAll: self color!
Object subclass: #ShootoutCreature
instanceVariableNames: 'creatureName colour selfMet creaturesMet'
classVariableNames: ''
poolDictionaries: ''
category: 'Cog-Benchmarks'!
----- Method: ShootoutCreature class>>withName:colour: (in category 'initialize-release') -----
withName: aName colour: aColour
^(ShootoutCreature new initialize)
name: aName;
colour: aColour!
----- Method: ShootoutCreature>>colour (in category 'accessing') -----
colour
^colour!
----- Method: ShootoutCreature>>colour: (in category 'accessing') -----
colour: anObject
colour := anObject!
----- Method: ShootoutCreature>>creaturesMet (in category 'accessing') -----
creaturesMet
^creaturesMet!
----- Method: ShootoutCreature>>creaturesMet: (in category 'accessing') -----
creaturesMet: anObject
creaturesMet := anObject!
----- Method: ShootoutCreature>>initialize (in category 'initialize-release') -----
initialize
selfMet := 0.
creaturesMet := 0!
----- Method: ShootoutCreature>>name (in category 'accessing') -----
name
^creatureName!
----- Method: ShootoutCreature>>name: (in category 'accessing') -----
name: anObject
creatureName := anObject!
----- Method: ShootoutCreature>>selfMet (in category 'accessing') -----
selfMet
^selfMet!
----- Method: ShootoutCreature>>selfMet: (in category 'accessing') -----
selfMet: anObject
^selfMet := anObject!
----- Method: ShootoutCreature>>visitMall: (in category 'controlling') -----
visitMall: mall
[| partner |
partner := mall visitWith: self.
partner ifNotNil:
[colour := colour complementaryColourFor: partner colour.
self == partner ifTrue: [selfMet := selfMet + 1].
creaturesMet := creaturesMet + 1].
partner isNil]
whileFalse!
Object subclass: #ShootoutMall
instanceVariableNames: 'guard maxRendezvous open process queue cache pairCache'
classVariableNames: 'Units'
poolDictionaries: ''
category: 'Cog-Benchmarks'!
----- Method: ShootoutMall class>>createAllowing: (in category 'initialize-release') -----
createAllowing: maxRendezvous
"Private"
^self basicNew initialize maxRendezvous: maxRendezvous!
----- Method: ShootoutMall class>>createCreaturesWith: (in category 'initialize-release') -----
createCreaturesWith: aCollectionOfColours
"Private"
| aName |
aName := 0.
^aCollectionOfColours collect:
[:aColour |
aName := aName + 1.
ShootoutCreature withName: aName colour: aColour]!
----- Method: ShootoutMall class>>generateReportFor:printOn: (in category 'printing') -----
generateReportFor: creatures printOn: stream
| sum |
sum := creatures inject: 0 into: [:accum :each | accum + each creaturesMet].
creatures do:
[:aCreature |
aCreature creaturesMet printOn: stream.
stream
space;
nextPutAll: (self units at: aCreature selfMet + 1);
nl].
stream space.
sum printString
do: [:el | stream nextPutAll: (self units at: el digitValue + 1)]
separatedBy: [stream space].
^stream!
----- Method: ShootoutMall class>>generateReportForColours:printOn: (in category 'printing') -----
generateReportForColours: colours printOn: stream
stream space.
colours do: [:colour | colour printOn: stream] separatedBy: [stream space].
^stream!
----- Method: ShootoutMall class>>initialize (in category 'initialize-release') -----
initialize
"self initialize"
Units := #('zero' 'one' 'two' 'three' 'four' 'five' 'six' 'seven' 'eight' 'nine')!
----- Method: ShootoutMall class>>new (in category 'initialize-release') -----
new
^self shouldNotImplement!
----- Method: ShootoutMall class>>openMall:forCreatures:usingGuard: (in category 'private') -----
openMall: aMall forCreatures: creatures usingGuard: sema
| processes |
processes := creatures
collect: [:aCreature |
[aCreature visitMall: aMall.
sema signal] newProcess].
processes do:
[:proc |
proc priority: Processor userBackgroundPriority.
proc resume]!
----- Method: ShootoutMall class>>openMallWith:forNumberOfMeets: (in category 'initialize-release') -----
openMallWith: aCollectionOfColours forNumberOfMeets: aNumber
| mall creatures guard |
mall := self createAllowing: aNumber.
mall run.
creatures := self createCreaturesWith: aCollectionOfColours.
guard := Semaphore new.
self
openMall: mall
forCreatures: creatures
usingGuard: guard.
self
waitForClosingOfMall: mall
withCreatures: creatures
usingGuard: guard.
^creatures!
----- Method: ShootoutMall class>>runBenchMark:on: (in category 'public') -----
runBenchMark: number on: anOutputStream
"self runBenchMark: 60000 on: Transcript."
| firstTestColours secondTestColours blue red yellow creatures |
blue := ShootoutChameneosColour blue.
red := ShootoutChameneosColour red.
yellow := ShootoutChameneosColour yellow.
firstTestColours := Array
with: blue
with: red
with: yellow.
secondTestColours := (OrderedCollection new)
add: blue;
add: red;
add: yellow;
add: red;
add: yellow;
add: blue;
add: red;
add: yellow;
add: red;
add: blue;
yourself.
(ShootoutChameneosColour generateReportOfColoursOn: anOutputStream) nl.
(self generateReportForColours: firstTestColours printOn: anOutputStream)
nl.
creatures := ShootoutMall openMallWith: firstTestColours forNumberOfMeets: number.
(self generateReportFor: creatures printOn: anOutputStream)
nl;
nl.
(self generateReportForColours: secondTestColours printOn: anOutputStream)
nl.
creatures := ShootoutMall openMallWith: secondTestColours forNumberOfMeets: number.
(self generateReportFor: creatures printOn: anOutputStream)
nl;
nl!
----- Method: ShootoutMall class>>units (in category 'accessing') -----
units
^Units!
----- Method: ShootoutMall class>>waitForClosingOfMall:withCreatures:usingGuard: (in category 'private') -----
waitForClosingOfMall: aMall withCreatures: creatures usingGuard: guard
creatures size timesRepeat: [guard wait].
aMall close!
----- Method: ShootoutMall>>close (in category 'controlling') -----
close
open := false!
----- Method: ShootoutMall>>initialize (in category 'initialize-release') -----
initialize
guard := Semaphore forMutualExclusion.
queue := SharedQueue new.
cache := OrderedCollection new.
1 to: 10 do: [:x | cache add: ShootoutPair new]!
----- Method: ShootoutMall>>maxRendezvous: (in category 'accessing') -----
maxRendezvous: max
maxRendezvous := max!
----- Method: ShootoutMall>>obtainPair (in category 'private') -----
obtainPair
^cache removeFirst!
----- Method: ShootoutMall>>processVisitors (in category 'private') -----
processVisitors
[open] whileTrue:
[1 to: maxRendezvous
do:
[:x |
| first second |
first := queue next.
second := queue next.
self setPartnersOn: first and: second.
first signal.
second signal].
[queue isEmpty] whileFalse: [queue next signal]].
process terminate.
process := nil!
----- Method: ShootoutMall>>releasePair: (in category 'private') -----
releasePair: pair
pair release.
cache addFirst: pair!
----- Method: ShootoutMall>>run (in category 'initialize-release') -----
run
open := true.
process ifNil:
[process := [self processVisitors] newProcess.
process priority: Processor userBackgroundPriority -1 ].
process resume!
----- Method: ShootoutMall>>setPartnersOn:and: (in category 'private') -----
setPartnersOn: first and: second
first partner: second me.
second partner: first me.
!
----- Method: ShootoutMall>>shutdown (in category 'private') -----
shutdown
[queue isEmpty] whileFalse: [queue next signal].
process terminate.
process := nil!
----- Method: ShootoutMall>>visitWith: (in category 'controlling') -----
visitWith: aChameneos
| pair partner |
pair := self obtainPair.
pair me: aChameneos.
queue nextPut: pair.
pair wait.
partner := pair partner.
self releasePair: pair.
^partner!
Object subclass: #ShootoutNBodySystem
instanceVariableNames: 'bodies'
classVariableNames: ''
poolDictionaries: ''
category: 'Cog-Benchmarks'!
----- Method: ShootoutNBodySystem>>after: (in category 'nbody') -----
after: dt
1 to: bodies size do: [:i|
i+1 to: bodies size do: [:j|
(bodies at: i) and: (bodies at: j) velocityAfter: dt].
].
bodies do: [:each| each positionAfter: dt]!
----- Method: ShootoutNBodySystem>>energy (in category 'nbody') -----
energy
| e |
e := 0.0.
1 to: bodies size do: [:i|
e := e + (bodies at: i) kineticEnergy.
i+1 to: bodies size do: [:j|
e := e - ((bodies at: i) potentialEnergy: (bodies at: j))].
].
^e!
----- Method: ShootoutNBodySystem>>initialize (in category 'initialize-release') -----
initialize
bodies := (OrderedCollection new
add: ShootoutBody sun; add: ShootoutBody jupiter; add: ShootoutBody saturn;
add: ShootoutBody uranus; add: ShootoutBody neptune; yourself) asArray.
bodies first offsetMomentum:
(bodies inject: (Array with: 0.0 with: 0.0 with: 0.0)
into: [:m :each | each addMomentumTo: m])!
Object subclass: #ShootoutPair
instanceVariableNames: 'partner me sema'
classVariableNames: ''
poolDictionaries: ''
category: 'Cog-Benchmarks'!
----- Method: ShootoutPair class>>new (in category 'instance creation') -----
new
"Answer a newly created and initialized instance."
^super new initialize.!
----- Method: ShootoutPair class>>with: (in category 'instance creation') -----
with: me
"Answer a newly created and initialized instance."
self halt.
^super new initialize me: me!
----- Method: ShootoutPair>>initialize (in category 'initialize-release') -----
initialize
"Initialize a newly created instance. This method must answer the receiver."
partner := nil.
me := nil.
sema := Semaphore new.
^self!
----- Method: ShootoutPair>>me (in category 'accessing') -----
me
^me!
----- Method: ShootoutPair>>me: (in category 'accessing') -----
me: anObject
me := anObject!
----- Method: ShootoutPair>>partner (in category 'accessing') -----
partner
^partner!
----- Method: ShootoutPair>>partner: (in category 'accessing') -----
partner: anObject
partner := anObject!
----- Method: ShootoutPair>>release (in category 'initialize-release') -----
release
partner:=nil.!
----- Method: ShootoutPair>>signal (in category 'initialize-release') -----
signal
sema signal!
----- Method: ShootoutPair>>wait (in category 'initialize-release') -----
wait
sema wait!
Object subclass: #ShootoutTests
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Cog-Benchmarks'!
----- Method: ShootoutTests class>>arg (in category 'platform') -----
arg
3 to: 5 do:
[:i|
(SmalltalkImage current getSystemAttribute: i) ifNotNil:
[:aString|
aString asInteger ifNotNil:
[:arg| ^arg]]].
^nil!
----- Method: ShootoutTests class>>binarytrees (in category 'benchmark scripts') -----
binarytrees
self binarytrees: self arg to: self stdout.
^''!
----- Method: ShootoutTests class>>binarytrees:to: (in category 'benchmarking') -----
binarytrees: n to: output
| minDepth maxDepth stretchDepth check longLivedTree iterations |
minDepth := 4.
maxDepth := minDepth + 2 max: n.
stretchDepth := maxDepth + 1.
check := (ShootoutTreeNode bottomUpTree: 0 depth: stretchDepth) itemCheck.
output
nextPutAll: 'stretch tree of depth '; print: stretchDepth; tab;
nextPutAll: ' check: '; print: check; nl.
longLivedTree := ShootoutTreeNode bottomUpTree: 0 depth: maxDepth.
minDepth to: maxDepth by: 2 do: [:depth|
iterations := 1 bitShift: maxDepth - depth + minDepth.
check := 0.
1 to: iterations do: [:i|
check := check + (ShootoutTreeNode bottomUpTree: i depth: depth) itemCheck.
check := check + (ShootoutTreeNode bottomUpTree: -1*i depth: depth) itemCheck
].
output
print: (2*iterations); tab;
nextPutAll: ' trees of depth '; print: depth; tab;
nextPutAll: ' check: '; print: check; nl
].
output
nextPutAll: 'long lived tree of depth '; print: maxDepth; tab;
nextPutAll: ' check: '; print: longLivedTree itemCheck; nl!
----- Method: ShootoutTests class>>chameneosredux2 (in category 'benchmark scripts') -----
chameneosredux2
self chameneosredux: self arg to: self stdout.
^''!
----- Method: ShootoutTests class>>chameneosredux:to: (in category 'benchmarking') -----
chameneosredux: arg to: aStream
ShootoutMall runBenchMark: arg on: aStream!
----- Method: ShootoutTests class>>collectReferenceTimes (in category 'benchmark scripts') -----
collectReferenceTimes
"Run the benchmarks 3 times and take their average, e.g. suitable
for filling in values for referenceTimesForClosureInterpreter"
"ShootoutTests collectReferenceTimes"
| n refs |
Transcript clear.
n := 3.
refs := (1 to: n) collect: [:i| ShootoutTests runAllToInternalStream].
^{ refs.
(1 to: refs first size) collect:
[:i|
((refs inject: 0 into: [:sum :ref| (ref at: i) + sum]) / n) rounded] }!
----- Method: ShootoutTests class>>nbody (in category 'benchmark scripts') -----
nbody
self nbody: self arg to: self stdout!
----- Method: ShootoutTests class>>nbody:to: (in category 'benchmarking') -----
nbody: count to: output
| bodies |
bodies := ShootoutNBodySystem new initialize.
output print: bodies energy digits: 9; cr.
count timesRepeat: [bodies after: 0.01].
output print: bodies energy digits: 9; cr.
^''!
----- Method: ShootoutTests class>>profileAll (in category 'profiling') -----
profileAll
"self profileAll"
| stream |
stream := DummyStream new.
self nbody: 200000 "20000000" to: stream.
self binarytrees: 15 to: stream.
self chameneosredux: 260000 to: stream.
self threadring: 10000000 to: stream!
----- Method: ShootoutTests class>>referenceTimesForClosureInterpreter (in category 'benchmark scripts') -----
referenceTimesForClosureInterpreter
"ClosureVM (QF 1.2.23 + Closure Bytecodes) on Eliot's 2010 vintage 2.66GHz Intel Core i7 MacBook Pro"
^Dictionary new
at: #nbody put: 4543;
at: #binarytrees put: 6944;
at: #chameneosredux put: 5799;
at: #threadring put: 5623;
yourself
"ClosureVM (QF 1.2.23 + Closure Bytecodes) on Eliot's 2006 vintage 2.16GHz Intel Core Duo MacBook Pro"
"^Dictionary new
at: #nbody put: 7660;
at: #binarytrees put: 14417;
at: #chameneosredux put: 8478;
at: #threadring put: 8718;
yourself"!
----- Method: ShootoutTests class>>referenceTimesForSqueakVM (in category 'benchmark scripts') -----
referenceTimesForSqueakVM
"Squeak VM (4.2.2beta1 + Closure Bytecodes) on Eliot's 2010 vintage 2.66GHz Intel Core i7 MacBook Pro"
^Dictionary new
at: #nbody put: 4917;
at: #binarytrees put: 8593;
at: #chameneosredux put: 5405;
at: #threadring put: 3789;
yourself!
----- Method: ShootoutTests class>>report:time:reference:on: (in category 'reporting') -----
report: name time: millisecs reference: reference on: aStream
aStream
cr;
nextPutAll: name; cr;
nextPutAll: ' took '; print: millisecs / 1000.0; nextPutAll: ' seconds'; cr; flush;
nextPutAll: 'ratio: '; print: ((millisecs / reference) roundTo: 0.001);
nextPutAll: ' % change: '; print: ((millisecs - reference * 100 / reference) roundTo: 0.01); nextPut: $%;
cr; flush!
----- Method: ShootoutTests class>>runAllToDummyStream (in category 'benchmark scripts') -----
runAllToDummyStream
"Transcript clear.
self runAllToDummyStream"
^self runAllToDummyStreamVs: self referenceTimesForClosureInterpreter!
----- Method: ShootoutTests class>>runAllToDummyStreamVs: (in category 'benchmark scripts') -----
runAllToDummyStreamVs: referenceTimes
"Transcript clear.
self runAllToDummyStreamVs: self referenceTimesForClosureInterpreter"
"Transcript clear.
self runAllToDummyStreamVs: self referenceTimesForSqueakVM"
| stream times ratios geometricMean |
stream := DummyStream new.
times := Array new writeStream.
ratios := Array new writeStream.
{ [self nbody: 200000 "20000000" to: stream].
[self binarytrees: 15 to: stream].
[self chameneosredux: 260000 to: stream].
[self threadring: 10000000 to: stream] } do:
[:block | | benchmark reference t |
benchmark := (self selectorForSimpleBlock: block) copyUpTo: $:.
reference := referenceTimes at: benchmark asSymbol.
Smalltalk garbageCollect.
times nextPut: (t := Time millisecondsToRun: block).
ratios nextPut: t asFloat / reference.
self report: block decompile printString time: t reference: reference on: Transcript].
geometricMean := (ratios contents inject: 1 into: [:m :n| m * n]) raisedTo: 1 / ratios position.
Transcript
nextPutAll: 'geometric mean '; print: (geometricMean roundTo: 0.001);
nextPutAll: ' average speedup '; print: ((geometricMean - 1 * 100) roundTo: 0.01); nextPut: $%; cr; cr; flush.
^times contents!
----- Method: ShootoutTests class>>runAllToInternalStream (in category 'benchmark scripts') -----
runAllToInternalStream
"Transcript clear.
self runAllToInternalStream"
^self runAllToInternalStreamVs: self referenceTimesForClosureInterpreter!
----- Method: ShootoutTests class>>runAllToInternalStreamVs: (in category 'benchmark scripts') -----
runAllToInternalStreamVs: referenceTimes
"Transcript clear.
self runAllToInternalStreamVs: self referenceTimesForClosureInterpreter"
"Transcript clear.
self runAllToInternalStreamVs: self referenceTimesForSqueakVM"
| stream times ratios geometricMean |
stream := (ByteString new: 10000) writeStream.
times := Array new writeStream.
ratios := Array new writeStream.
{ [self nbody: 200000 "20000000" to: stream].
[self binarytrees: 15 to: stream].
[self chameneosredux: 260000 to: stream].
[self threadring: 10000000 to: stream] } do:
[:block | | benchmark reference t |
benchmark := (self selectorForSimpleBlock: block) copyUpTo: $:.
reference := referenceTimes at: benchmark asSymbol.
Smalltalk garbageCollect.
times nextPut: (t := Time millisecondsToRun: block).
ratios nextPut: t asFloat / reference.
self report: block decompile printString time: t reference: reference on: Transcript].
geometricMean := (ratios contents inject: 1 into: [:m :n| m * n]) raisedTo: 1 / ratios position.
Transcript
nextPutAll: 'geometric mean '; print: (geometricMean roundTo: 0.001);
nextPutAll: ' average speedup '; print: ((geometricMean - 1 * 100) roundTo: 0.01); nextPut: $%; cr; cr; flush.
^times contents!
----- Method: ShootoutTests class>>runAllToTranscript (in category 'benchmark scripts') -----
runAllToTranscript
"Transcript clear.
self runAllToTranscript"
^self runAllToTranscriptVs: self referenceTimesForClosureInterpreter!
----- Method: ShootoutTests class>>runAllToTranscriptVs: (in category 'benchmark scripts') -----
runAllToTranscriptVs: referenceTimes
"Transcript clear.
self runAllToTranscriptVs: self referenceTimesForClosureInterpreter"
"Transcript clear.
self runAllToTranscriptVs: self referenceTimesForSqueakVM"
| times ratios geometricMean |
times := Array new writeStream.
ratios := Array new writeStream.
{ [self nbody: 200000 "20000000" to: Transcript].
[self binarytrees: 15 to: Transcript].
[self chameneosredux: 260000 to: Transcript].
[self threadring: 10000000 to: Transcript] } do:
[:block | | benchmark reference t |
benchmark := (self selectorForSimpleBlock: block) copyUpTo: $:.
reference := referenceTimes at: benchmark asSymbol.
Smalltalk garbageCollect.
times nextPut: (t := Time millisecondsToRun: block).
ratios nextPut: t asFloat / reference.
self report: block decompile printString time: t reference: reference on: Transcript].
geometricMean := (ratios contents inject: 1 into: [:m :n| m * n]) raisedTo: 1 / ratios position.
Transcript
nextPutAll: 'geometric mean '; print: (geometricMean roundTo: 0.001);
nextPutAll: ' average speedup '; print: ((geometricMean - 1 * 100) roundTo: 0.01); nextPut: $%; cr; cr; flush.
^times contents!
----- Method: ShootoutTests class>>selectorForSimpleBlock: (in category 'benchmark scripts') -----
selectorForSimpleBlock: aBlock
| is |
is := InstructionStream on: aBlock method.
is pc: aBlock startpc.
is scanFor:
[:x| | selectorOrScanner |
(selectorOrScanner := is selectorToSendOrSelf) ~~ is ifTrue:
[^selectorOrScanner].
false].
^nil!
----- Method: ShootoutTests class>>stdin (in category 'platform') -----
stdin
^StandardFileStream stdIn!
----- Method: ShootoutTests class>>stdout (in category 'platform') -----
stdout
^StandardFileStream stdOut!
----- Method: ShootoutTests class>>threadRing:output: (in category 'benchmarking') -----
threadRing: aSemaphore output: output
| first last |
503 to: 1 by: -1 do: [:i|
first := ShootoutThread named: i next: first done: aSemaphore output: output.
last isNil ifTrue: [ last := first ].
].
last nextThread: first.
^first !
----- Method: ShootoutTests class>>threadring (in category 'benchmark scripts') -----
threadring
self threadring: self arg to: self stdout.
^''!
----- Method: ShootoutTests class>>threadring:to: (in category 'benchmarking') -----
threadring: arg to: output
| done |
(self threadRing: (done := Semaphore new) output: output) takeToken: arg.
done wait!
Object subclass: #ShootoutThread
instanceVariableNames: 'name nextThread token semaphore done output'
classVariableNames: ''
poolDictionaries: ''
category: 'Cog-Benchmarks'!
----- Method: ShootoutThread class>>named:next:done:output: (in category 'instance creation') -----
named: anInteger next: aThread done: aSemaphore output: aStream
^self new name: anInteger; nextThread: aThread; done: aSemaphore; output: aStream; fork !
----- Method: ShootoutThread class>>new (in category 'instance creation') -----
new
^self basicNew semaphore: Semaphore new !
----- Method: ShootoutThread>>done: (in category 'accessing') -----
done: aSemaphore
done := aSemaphore !
----- Method: ShootoutThread>>fork (in category 'accessing') -----
fork
[ self run ] fork !
----- Method: ShootoutThread>>name: (in category 'accessing') -----
name: anInteger
name := anInteger !
----- Method: ShootoutThread>>nextThread: (in category 'accessing') -----
nextThread: aThread
nextThread := aThread !
----- Method: ShootoutThread>>output: (in category 'accessing') -----
output: anObject
"Set the value of output"
output := anObject!
----- Method: ShootoutThread>>run (in category 'accessing') -----
run
[ self tokenNotDone ] whileTrue: [ nextThread takeToken: token - 1 ].
output print: name.
output name = 'stdout'
ifTrue: [output nl]
ifFalse: [output cr; flush].
done signal !
----- Method: ShootoutThread>>semaphore: (in category 'accessing') -----
semaphore: aSemaphore
semaphore := aSemaphore !
----- Method: ShootoutThread>>takeToken: (in category 'accessing') -----
takeToken: x
token := x.
semaphore signal !
----- Method: ShootoutThread>>tokenNotDone (in category 'accessing') -----
tokenNotDone
semaphore wait.
^token > 0 !
Object subclass: #ShootoutTreeNode
instanceVariableNames: 'left right item'
classVariableNames: ''
poolDictionaries: ''
category: 'Cog-Benchmarks'!
----- Method: ShootoutTreeNode class>>bottomUpTree:depth: (in category 'instance creation') -----
bottomUpTree: anItem depth: anInteger
^(anInteger > 0)
ifTrue: [
self
left: (self bottomUpTree: 2*anItem - 1 depth: anInteger - 1)
right: (self bottomUpTree: 2*anItem depth: anInteger - 1)
item: anItem
]
ifFalse: [self left: nil right: nil item: anItem]!
----- Method: ShootoutTreeNode class>>left:right:item: (in category 'instance creation') -----
left: leftChild right: rightChild item: anItem
^(super new) left: leftChild right: rightChild item: anItem!
----- Method: ShootoutTreeNode>>itemCheck (in category 'accessing') -----
itemCheck
^left isNil
ifTrue: [item] ifFalse: [item + (left itemCheck - right itemCheck)]!
----- Method: ShootoutTreeNode>>left:right:item: (in category 'initialize-release') -----
left: leftChild right: rightChild item: anItem
left := leftChild.
right := rightChild.
item := anItem!
Object subclass: #TempScopeEditor
instanceVariableNames: 'method methodNode out tempMap blockNodes sourceString soFar'
classVariableNames: ''
poolDictionaries: ''
category: 'Cog-Scripts'!
----- Method: TempScopeEditor class>>edit (in category 'as yet unclassified') -----
edit
"Trawl the system for methods containing misdeclared temps and correct these methods."
SystemNavigation default allSelect:
[:m| | scanner |
(m isQuick not
and: [(scanner := InstructionStream on: m) scanFor:
[:b| b = 143 and: [scanner followingByte >= 16]]]) ifTrue:
[(self new forMethod: m) edit].
false]!
----- Method: TempScopeEditor>>anyScopes:outsideExtent: (in category 'editing') -----
anyScopes: referenceScopeDict outsideExtent: blockExtent
^referenceScopeDict notNil
and: [referenceScopeDict notEmpty
and: [referenceScopeDict anySatisfy:
[:set|
set anySatisfy: [:location| (blockExtent rangeIncludes: location) not]]]]!
----- Method: TempScopeEditor>>blockNode:isEnclosingScopeFor: (in category 'editing') -----
blockNode: aBlockNode isEnclosingScopeFor: aTempVariableNode
^((self
anyScopes: (aTempVariableNode instVarNamed: 'readingScopes')
outsideExtent: aBlockNode blockExtent)
or: [self
anyScopes: (aTempVariableNode instVarNamed: 'writingScopes')
outsideExtent: aBlockNode blockExtent]) not!
----- Method: TempScopeEditor>>buildTempMap (in category 'editing') -----
buildTempMap
"Build the map for moving remote temps. Each remote temp
that should be moved is entered into the map referencing its
smallest enclosing scope. This may seem backwards but it
means that the map is one-to-one, not one-to-many."
| readBeforeWritten |
readBeforeWritten := (methodNode accept: ReadBeforeWrittenVisitor new) readBeforeWritten.
blockNodes do:
[:blockNode|
(blockNode temporaries notEmpty
and: [blockNode temporaries last isIndirectTempVector]) ifTrue:
[blockNode temporaries last remoteTemps do:
[:remoteTemp| | enclosingScopes smallestEnclosingBlockScope |
(readBeforeWritten includes: remoteTemp) ifFalse:
[enclosingScopes := blockNodes select: [:blockScope|
self blockNode: blockScope
isEnclosingScopeFor: remoteTemp].
enclosingScopes notEmpty ifTrue:
[smallestEnclosingBlockScope := enclosingScopes last.
smallestEnclosingBlockScope ~~ blockNode ifTrue:
[tempMap at: remoteTemp put: smallestEnclosingBlockScope]]]]]]!
----- Method: TempScopeEditor>>copyMethodMovingTemps (in category 'editing') -----
copyMethodMovingTemps
| methodBodyStart tempsToKeep tempsStart tempsEnd |
methodBodyStart := method methodClass parserClass new
parseMethodComment: sourceString setPattern: [:ignored|];
startOfNextToken.
tempsStart := sourceString indexOf: $| startingAt: methodBodyStart.
tempsEnd := sourceString indexOf: $| startingAt: tempsStart + 1.
(tempsToKeep := self tempsToKeepAtMethodLevel) isEmpty
ifTrue:
[| startOfFirstBlock |
startOfFirstBlock := (methodNode encoder sourceRangeFor: blockNodes second closureCreationNode) first.
tempsStart < startOfFirstBlock
ifTrue:
[out next: tempsStart - 1 putAll: sourceString.
soFar := tempsEnd + 1]
ifFalse:
[soFar := 1]]
ifFalse:
[out next: tempsStart putAll: sourceString.
tempsToKeep do: [:t| out space; nextPutAll: t name].
soFar := tempsEnd.
(sourceString at: soFar - 1) isSeparator ifTrue:
[soFar := soFar - 1]].
blockNodes allButFirst do:
[:blockNode|
self processBlockNode: blockNode].
out next: sourceString size - soFar + 1 putAll: sourceString startingAt: soFar!
----- Method: TempScopeEditor>>edit (in category 'editing') -----
edit
self buildTempMap.
tempMap notEmpty ifTrue:
[| mr |
mr := method methodReference.
self copyMethodMovingTemps.
Transcript cr; show: mr actualClass name, ' >> ', mr methodSymbol.
method methodClass compile: out contents classified: mr category]!
----- Method: TempScopeEditor>>editNoCompile (in category 'editing') -----
editNoCompile
self buildTempMap.
^tempMap isEmpty ifFalse:
[self copyMethodMovingTemps.
out contents]!
----- Method: TempScopeEditor>>forMethod: (in category 'initialize-release') -----
forMethod: aCompiledMethod
method := aCompiledMethod.
sourceString := aCompiledMethod getSourceFromFile asString.
methodNode := method methodClass parserClass new
parse: sourceString
class: method methodClass.
methodNode ensureClosureAnalysisDone.
blockNodes := (methodNode accept: BlockNodeCollectingVisitor new)
blockNodes reject: [:bn| bn optimized].
out := (String new: sourceString size) writeStream.
tempMap := IdentityDictionary new
"(TempScopeEditor new forMethod: SARInstaller class>>#ensurePackageWithId:) edit"!
----- Method: TempScopeEditor>>processBlockNode: (in category 'editing') -----
processBlockNode: blockNode
| tempsToMoveHere startOfBlock endOfArgs maybeBlockTempsStart blockTempsInSource |
tempsToMoveHere := (tempMap select: [:aBlockNode| aBlockNode == blockNode]) keys.
tempsToMoveHere isEmpty ifTrue: [^self].
startOfBlock := (methodNode encoder sourceRangeFor: blockNode closureCreationNode) first.
endOfArgs := blockNode arguments isEmpty
ifTrue: [startOfBlock]
ifFalse: [sourceString indexOf: $| startingAt: startOfBlock].
out next: endOfArgs - soFar + 1 putAll: sourceString startingAt: soFar.
maybeBlockTempsStart := sourceString indexOf: $| startingAt: endOfArgs + 1 ifAbsent: sourceString size + 1.
blockTempsInSource := (sourceString copyFrom: endOfArgs + 1 to: maybeBlockTempsStart - 1) allSatisfy:
[:c| c isSeparator].
blockTempsInSource
ifTrue:
[out next: maybeBlockTempsStart - endOfArgs putAll: sourceString startingAt: endOfArgs + 1.
(self tempsToKeepFor: blockNode) do:
[:tempNode| out space; nextPutAll: tempNode name].
tempsToMoveHere do: [:t| out space; nextPutAll: t name].
soFar := sourceString indexOf: $| startingAt: maybeBlockTempsStart + 1.
(sourceString at: soFar - 1) isSeparator ifTrue:
[soFar := soFar - 1]]
ifFalse:
[out space; nextPut: $|.
tempsToMoveHere do: [:t| out space; nextPutAll: t name].
out space; nextPut: $|.
soFar := endOfArgs + 1]!
----- Method: TempScopeEditor>>tempsToKeepAtMethodLevel (in category 'editing') -----
tempsToKeepAtMethodLevel
^(self tempsToKeepFor: blockNodes first) select:
[:t|t scope >= 0]!
----- Method: TempScopeEditor>>tempsToKeepFor: (in category 'editing') -----
tempsToKeepFor: blockNode
| tempsToKeep |
tempsToKeep := OrderedCollection new.
blockNode temporaries do:
[:t|
t isIndirectTempVector
ifTrue:
[t remoteTemps do:
[:rt|
(tempMap includesKey: rt) ifFalse:
[tempsToKeep addLast: rt]]]
ifFalse:
[tempsToKeep addLast: t]].
^tempsToKeep!
----- Method: DummyStream>>nl (in category '*Cog-Benchmarks-platform') -----
nl
"do nothing"!
----- Method: DummyStream>>print:digits: (in category '*Cog-Benchmarks-platform') -----
print: number digits: decimalPlaces
"do nothing"!
----- Method: DummyStream>>print:paddedTo: (in category '*Cog-Benchmarks-platform') -----
print: number paddedTo: width
"do nothing"!
Error subclass: #ProcessorSimulationTrap
instanceVariableNames: 'pc nextpc address type registerAccessor'
classVariableNames: ''
poolDictionaries: ''
category: 'Cog-Processors'!
----- Method: ProcessorSimulationTrap class>>pc:nextpc:address:type: (in category 'instance creation') -----
pc: pc nextpc: nextpc address: address type: type
^self new
pc: pc;
nextpc: nextpc;
address: address;
type: type!
----- Method: ProcessorSimulationTrap class>>pc:nextpc:address:type:accessor: (in category 'instance creation') -----
pc: pc nextpc: nextpc address: address type: type accessor: regAccessorMessage
^self new
pc: pc;
nextpc: nextpc;
address: address;
type: type;
registerAccessor: regAccessorMessage!
----- Method: ProcessorSimulationTrap>>address (in category 'accessing') -----
address
"Answer the value of address"
^ address!
----- Method: ProcessorSimulationTrap>>address: (in category 'accessing') -----
address: anObject
"Set the value of address"
address := anObject!
----- Method: ProcessorSimulationTrap>>nextpc (in category 'accessing') -----
nextpc
"Answer the value of nextpc"
^ nextpc!
----- Method: ProcessorSimulationTrap>>nextpc: (in category 'accessing') -----
nextpc: anObject
"Set the value of nextpc"
nextpc := anObject!
----- Method: ProcessorSimulationTrap>>pc (in category 'accessing') -----
pc
"Answer the value of pc"
^ pc!
----- Method: ProcessorSimulationTrap>>pc: (in category 'accessing') -----
pc: anObject
"Set the value of pc"
pc := anObject!
----- Method: ProcessorSimulationTrap>>printOn: (in category 'printing') -----
printOn: aStream
super printOn: aStream.
aStream nextPutAll: ' (pc: '; print: pc.
aStream nextPutAll: ' nextpc: '; print: nextpc.
aStream nextPutAll: ' address: '; print: address.
aStream nextPutAll: ' type: '; print: type.
aStream nextPutAll: ' accessor: '; print: registerAccessor; nextPut: $)!
----- Method: ProcessorSimulationTrap>>registerAccessor (in category 'accessing') -----
registerAccessor
"Answer the value of registerAccessor"
^ registerAccessor!
----- Method: ProcessorSimulationTrap>>registerAccessor: (in category 'accessing') -----
registerAccessor: anObject
"Set the value of registerAccessor"
registerAccessor := anObject!
----- Method: ProcessorSimulationTrap>>type (in category 'accessing') -----
type
"Answer the value of type"
^ type!
----- Method: ProcessorSimulationTrap>>type: (in category 'accessing') -----
type: anObject
"Set the value of type"
type := anObject!
InstructionClient subclass: #ETC
instanceVariableNames: 'scanner blockEnd joinOffsets sends contextStack currentContext blockEndStack topIsVector'
classVariableNames: ''
poolDictionaries: ''
category: 'Cog-Scripts'!
!ETC commentStamp: '<historical>' prior: 0!
I am a quick-hack type-checker (Eliot's Type Checker) that answers a dictionary of receiver to selector sets for a given method.!
----- Method: ETC class>>sendsForMethod: (in category 'utilities') -----
sendsForMethod: aMethod
^(self new setMethod: aMethod) sends!
----- Method: ETC class>>sendsToInstVar:in: (in category 'utilities') -----
sendsToInstVar: instVarName in: class
"Answer all selectors sent to instVarName in class's methods"
| idx ref selectors |
idx := class instVarIndexFor: instVarName ifAbsent: [^Set new].
ref := {#inst. idx}.
selectors := Set new.
class methodsDo:
[:m| selectors addAll: ((self sendsForMethod: m) at: ref ifAbsent: [#()])].
^selectors!
----- Method: ETC>>blockReturnTop (in category 'instruction decoding') -----
blockReturnTop
"Return Top Of Stack bytecode."
currentContext pop.
scanner pc < blockEnd
ifTrue: [self doJoin]
ifFalse: [currentContext := contextStack removeLast.
blockEnd := blockEndStack removeLast]!
----- Method: ETC>>doDup (in category 'instruction decoding') -----
doDup
currentContext doDup!
----- Method: ETC>>doJoin (in category 'private') -----
doJoin
scanner pc < blockEnd ifTrue:
[currentContext instVarNamed: 'stackp' put: (joinOffsets at: scanner pc)]!
----- Method: ETC>>doPop (in category 'instruction decoding') -----
doPop
currentContext doPop!
----- Method: ETC>>jump: (in category 'instruction decoding') -----
jump: offset
"Unconditional Jump bytecode."
offset > 0 ifTrue:
[joinOffsets at: scanner pc + offset put: currentContext stackPtr.
self doJoin]!
----- Method: ETC>>jump:if: (in category 'instruction decoding') -----
jump: offset if: condition
"Conditional Jump bytecode."
currentContext pop.
offset > 0 ifTrue:
[joinOffsets at: scanner pc + offset put: currentContext stackPtr]!
----- Method: ETC>>methodReturnConstant: (in category 'instruction decoding') -----
methodReturnConstant: value
currentContext isExecutingBlock
ifTrue: [currentContext push: value.
self blockReturnTop]
ifFalse: [self doJoin]!
----- Method: ETC>>methodReturnReceiver (in category 'instruction decoding') -----
methodReturnReceiver
currentContext isExecutingBlock
ifTrue: [self pushReceiver.
self blockReturnTop]
ifFalse: [self doJoin]!
----- Method: ETC>>methodReturnTop (in category 'instruction decoding') -----
methodReturnTop
currentContext isExecutingBlock
ifTrue: [self blockReturnTop]
ifFalse: [currentContext pop.
self doJoin]!
----- Method: ETC>>popIntoLiteralVariable: (in category 'instruction decoding') -----
popIntoLiteralVariable: anAssociation
currentContext pop!
----- Method: ETC>>popIntoReceiverVariable: (in category 'instruction decoding') -----
popIntoReceiverVariable: offset
currentContext pop!
----- Method: ETC>>popIntoRemoteTemp:inVectorAt: (in category 'instruction decoding') -----
popIntoRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex
currentContext pop!
----- Method: ETC>>popIntoTemporaryVariable: (in category 'instruction decoding') -----
popIntoTemporaryVariable: offset
| vector |
topIsVector
ifTrue:
[vector := currentContext top.
1 to: vector size do:
[:i|
vector
at: i
put: 'remote ', i printString,
' @ ', (offset + 1) printString,
' in ', currentContext startpc printString].
currentContext popIntoTemporaryVariable: offset]
ifFalse:
[currentContext pop]!
----- Method: ETC>>pushActiveContext (in category 'instruction decoding') -----
pushActiveContext
currentContext pushActiveContext!
----- Method: ETC>>pushClosureCopyNumCopiedValues:numArgs:blockSize: (in category 'instruction decoding') -----
pushClosureCopyNumCopiedValues: numCopied numArgs: numArgs blockSize: blockSize
"Push Closure bytecode. Either compute the end of the block if this is
the block we're analysing, or skip it, adjusting the stack as appropriate."
| blockClosure j |
blockEndStack addLast: blockEnd.
blockEnd := scanner pc + blockSize.
contextStack addLast: currentContext.
currentContext
pc: scanner pc;
pushClosureCopyNumCopiedValues: numCopied numArgs: numArgs blockSize: blockSize.
blockClosure := currentContext top.
currentContext := blockClosure asContext.
1 to: numArgs do:
[:i| currentContext push: 'blkarg', i printString].
1 to: numCopied do:
[:i| currentContext push: (blockClosure at: i)].
j := numArgs + numCopied.
[scanner nextByte = ParseNode pushNilCode] whileTrue:
[scanner interpretNextInstructionFor: self.
currentContext at: currentContext stackPtr put: 'blktmp', (j := j + 1) printString]
"ETC sendsForMethod: (ETC compiledMethodAt: #pushClosureCopyNumCopiedValues:numArgs:blockSize:)"!
----- Method: ETC>>pushConsArrayWithElements: (in category 'instruction decoding') -----
pushConsArrayWithElements: numElements
currentContext pushConsArrayWithElements: numElements!
----- Method: ETC>>pushConstant: (in category 'instruction decoding') -----
pushConstant: value
currentContext pushConstant: value!
----- Method: ETC>>pushLiteralVariable: (in category 'instruction decoding') -----
pushLiteralVariable: anAssociation
currentContext push: anAssociation!
----- Method: ETC>>pushNewArrayOfSize: (in category 'instruction decoding') -----
pushNewArrayOfSize: numElements
currentContext pushNewArrayOfSize: numElements.
scanner willStorePop ifTrue:
[topIsVector := true.
scanner interpretNextInstructionFor: self.
topIsVector := false]!
----- Method: ETC>>pushReceiver (in category 'instruction decoding') -----
pushReceiver
currentContext push: #self!
----- Method: ETC>>pushReceiverVariable: (in category 'instruction decoding') -----
pushReceiverVariable: offset
currentContext push: {#inst. offset + 1}!
----- Method: ETC>>pushRemoteTemp:inVectorAt: (in category 'instruction decoding') -----
pushRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex
currentContext pushRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex!
----- Method: ETC>>pushTemporaryVariable: (in category 'instruction decoding') -----
pushTemporaryVariable: offset
currentContext pushTemporaryVariable: offset!
----- Method: ETC>>send:super:numArgs: (in category 'instruction decoding') -----
send: selector super: supered numArgs: numArgs
numArgs timesRepeat: [currentContext pop].
currentContext pop ifNotNil:
[:top|
((top isArray and: [top size = 2 and: [top first == #inst]])
or: [top == #self]) ifTrue:
[(sends at: top ifAbsentPut: [Set new]) add: selector]].
currentContext push: 'send ', selector!
----- Method: ETC>>sends (in category 'results') -----
sends
[scanner atEnd] whileFalse:
[scanner interpretNextInstructionFor: self].
^sends!
----- Method: ETC>>setMethod: (in category 'initialize-release') -----
setMethod: aCompiledMethod
scanner := InstructionStream new method: aCompiledMethod pc: aCompiledMethod initialPC.
contextStack := OrderedCollection new.
currentContext := MethodContext
sender: nil
receiver: nil
method: aCompiledMethod
arguments: ((1 to: aCompiledMethod numArgs) collect:
[:i| 'arg', i printString]).
aCompiledMethod numArgs + 1 to: aCompiledMethod numTemps do:
[:i| currentContext at: i put: 'tmp', (i - aCompiledMethod numArgs) printString].
sends := Dictionary new.
joinOffsets := Dictionary new.
blockEndStack := OrderedCollection new.
blockEnd := aCompiledMethod endPC.
topIsVector := false!
----- Method: Stream>>nl (in category '*Cog-Benchmarks-platform') -----
nl
self nextPut: Character lf!
----- Method: Stream>>print:digits: (in category '*Cog-Benchmarks-platform') -----
print: number digits: decimalPlaces
| precision rounded |
decimalPlaces <= 0 ifTrue: [^ number rounded printString].
precision := Utilities floatPrecisionForDecimalPlaces: decimalPlaces.
rounded := number roundTo: precision.
self nextPutAll:
((rounded asScaledDecimal: decimalPlaces) printString copyUpTo: $s)!
----- Method: Stream>>print:paddedTo: (in category '*Cog-Benchmarks-platform') -----
print: number paddedTo: width
self nextPutAll: (number printStringLength: width padded: false)!
TestCase subclass: #BochsIA32AlienTests
instanceVariableNames: 'processor'
classVariableNames: ''
poolDictionaries: ''
category: 'Cog-Processors-Tests'!
----- Method: BochsIA32AlienTests>>callTrapPerformance: (in category 'tests') -----
callTrapPerformance: n
"Call a function that is out-of-range. Ensure the call is trapped."
"self new testCallTrap"
| memory |
"The address is out of range of memory every which way (whether relative or absolute and whether big-endian or little."
memory := ByteArray new: 1024.
memory replaceFrom: 1 to: 5 with: { self processor callOpcode. 0. 16r80. 16r80. 0. } asByteArray.
self processor
eip: 0;
esp: (memory size - 4). "Room for return address"
1 to: n do:
[:ign|
[self processor singleStepIn: memory]
on: ProcessorSimulationTrap
do: [:ex|]].
"QSystemProfiler spyOn: [BochsIA32AlienTests new callTrapPerformance: 1024*128]"
"Time millisecondsToRun: [BochsIA32AlienTests new callTrapPerformance: 1024*128] 2463"
"Time millisecondsToRun: [1 to: 1024*1024*64 do: [:ign| nil yourself]] 636"
"Time millisecondsToRun: [1 to: 1024*1024*64 do: [:ign| nil perform: #ifNotNilDo: with: nil]] 3639"
"Time millisecondsToRun: [1 to: 1024*1024*64 do: [:ign| nil perform: #ifNotNilDo:ifNil: with: nil with: nil]] 12401"!
----- Method: BochsIA32AlienTests>>nfib (in category 'accessing') -----
nfib
"long fib(long n) { return n <= 1 ? 1 : fib(n-1) + fib(n-2) + 1; }
as compiled by Microsoft Visual C++ V6 (12.00.8804) cl /O2 /Fc"
"| bat nfib ip |
bat := BochsIA32AlienTests new.
nfib := bat nfib asByteArray.
ip := 0.
20 timesRepeat:
[bat processor disassembleInstructionAt: ip In: nfib into:
[:da :len|
Transcript nextPutAll: da; cr; flush.
ip := ip + len]]"
^#("00000" 16r56 "push esi"
"00001" 16r8B 16r74 16r24 16r08 "mov esi, DWORD PTR _n$[esp]"
"00005" 16r83 16rFE 16r01 "cmp esi, 1"
"00008" 16r7F 16r07 "jg SHORT $L528"
"0000a" 16rB8 16r01 16r00 16r00 16r00 "mov eax, 1"
"0000f" 16r5E "pop esi"
"00010" 16rC3 "ret 0"
"
$L528:"
"00011" 16r8D 16r46 16rFE "lea eax, DWORD PTR [esi-2]"
"00014" 16r57 "push edi"
"00015" 16r50 "push eax"
"00016" 16rE8 16rE5 16rFF 16rFF 16rFF "call _fib"
"0001b" 16r4E "dec esi"
"0001c" 16r8B 16rF8 "mov edi, eax"
"0001e" 16r56 "push esi"
"0001f" 16rE8 16rDC 16rFF 16rFF 16rFF "call _fib"
"00024" 16r83 16rC4 16r08 "add esp, 8"
"00027" 16r8D 16r44 16r07 16r01 "lea eax, DWORD PTR [edi+eax+1]"
"0002b" 16r5F "pop edi"
"0002c" 16r5E "pop esi"
"0002d" 16rC3 "ret 0")!
----- Method: BochsIA32AlienTests>>processor (in category 'accessing') -----
processor
processor ifNil:
[processor := BochsIA32Alien new].
^processor!
----- Method: BochsIA32AlienTests>>registerGetters (in category 'accessing') -----
registerGetters
^#(eax ecx edx ebx esp ebp esi edi eip)!
----- Method: BochsIA32AlienTests>>registerSetters (in category 'accessing') -----
registerSetters
^#(eax: ecx: edx: ebx: esp: ebp: esi: edi: eip:)!
----- Method: BochsIA32AlienTests>>runNFib:disassemble:printRegisters: (in category 'execution') -----
runNFib: n disassemble: disassemble printRegisters: printRegisters
"Run nfib wth the argument. Answer the result."
"self new runNFib: 5 disassemble: true printRegisters: true"
| memory |
memory := ByteArray new: 4096 * 2 withAll: self processor nopOpcode.
memory
replaceFrom: 1 to: self nfib size with: self nfib asByteArray startingAt: 1;
longAt: memory size - 3 put: n bigEndian: false; "argument n"
longAt: memory size - 7 put: self nfib size bigEndian: false. "return address"
self processor
eip: 0;
esp: (memory size - 8). "Room for return address and argument n"
printRegisters ifTrue:
[self processor printRegistersOn: Transcript.
Transcript cr; flush].
"run until something goes wrong."
self processor runInMemory: memory readExecuteOnlyBelow: memory size / 2.
printRegisters ifTrue:
[self processor printRegistersOn: Transcript.
Transcript cr; flush].
^self processor eax!
----- Method: BochsIA32AlienTests>>singleStepNFib:disassemble:printRegisters: (in category 'execution') -----
singleStepNFib: n disassemble: disassemble printRegisters: printRegisters
"Run nfib wth the argument. Answer the result."
"self new runNFib: 5 disassemble: true printRegisters: true"
| memory finalSP |
memory := ByteArray new: 4096 * 2 withAll: self processor nopOpcode.
finalSP := memory size - 4. "Stop when we return to the nop following nfib"
memory
replaceFrom: 1 to: self nfib size with: self nfib asByteArray startingAt: 1;
longAt: memory size - 3 put: n bigEndian: false; "argument n"
longAt: memory size - 7 put: self nfib size bigEndian: false. "return address"
self processor
eip: 0;
esp: (memory size - 8). "Room for return address and argument n"
printRegisters ifTrue:
[self processor printRegistersOn: Transcript.
Transcript cr; flush].
[disassemble ifTrue:
[Transcript nextPutAll: (self processor disassembleNextInstructionIn: memory); cr; flush].
self processor singleStepIn: memory readExecuteOnlyBelow: memory size / 2.
printRegisters ifTrue:
[self processor printRegistersOn: Transcript.
Transcript cr; flush].
self processor esp ~= finalSP] whileTrue.
^self processor eax!
----- Method: BochsIA32AlienTests>>testCPUHasSSE2 (in category 'tests') -----
testCPUHasSSE2
"Use the CPUID instruction to check if SSE2 is supported. Cog
uses SSE2 instructions for machine-code floating-point primitives."
self processor eax: 0. "get vendor identfication string"
self processor eip: 0; singleStepIn: (ByteArray with: 16r0F with: 16rA2 with: 16r90) "cpuid;nop".
self assert: self processor eip = 2.
self assert: self processor eax >= 1.
self processor eax: 1.
self processor eip: 0; singleStepIn: (ByteArray with: 16r0F with: 16rA2 with: 16r90) "cpuid;nop".
self assert: self processor eip = 2.
self assert: (self processor edx bitAnd: 1 << 26) ~= 0
"self new testCPUHasSSE2"!
----- Method: BochsIA32AlienTests>>testCPUID (in category 'tests') -----
testCPUID
| vendorString |
self processor
eip: 0;
eax: 0. "get vendor identfication string"
self processor singleStepIn: (ByteArray with: 16r0F with: 16rA2 with: 16r90) "cpuid;nop".
self assert: self processor eip = 2.
self assert: self processor eax ~= 0.
vendorString := (ByteArray new: 12)
longAt: 1 put: self processor ebx bigEndian: false;
longAt: 5 put: self processor edx bigEndian: false;
longAt: 9 put: self processor ecx bigEndian: false;
asString.
self assert: (vendorString = 'GenuineIntel'
or: [vendorString = 'AuthenticAMD'])!
----- Method: BochsIA32AlienTests>>testCallTrap (in category 'tests') -----
testCallTrap
"Call a function that is out-of-range. Ensure the call is trapped."
"self new testCallTrap"
| memory |
"The address is out of range of memory every which way (whether relative or absolute and whether big-endian or little."
memory := ByteArray new: 1024.
memory replaceFrom: 1 to: 5 with: { self processor callOpcode. 0. 16r80. 16r80. 0. } asByteArray.
self processor
eip: 0;
esp: (memory size - 4). "Room for return address"
self should: [self processor singleStepIn: memory]
raise: ProcessorSimulationTrap
withExceptionDo:
[:pst|
self assert: pst address = ((memory longAt: 2 bigEndian: false) + 5 "length of call instr").
self assert: pst pc = 0.
self assert: pst type = #call].
"| memory |
memory := ByteArray new: 1024.
memory replaceFrom: 1 to: 5 with: { BochsIA32Alien new callOpcode. 0. 16r80. 16r80. 0. } asByteArray.
BochsIA32AlienTests new processor
eip: 0;
esp: (memory size - 4);
singleStepIn: memory;
printRegistersOn: Transcript.
Transcript flush"!
----- Method: BochsIA32AlienTests>>testExecutionTrap (in category 'tests') -----
testExecutionTrap
"Execute a run of nops. test executing beyond the executable limit is trapped."
"self new testExecutionTrap"
| memory |
"The address is out of range of memory every which way (whether relative or absolute and whether big-endian or little."
memory := ByteArray new: 4096 * 2 withAll: self processor nopOpcode.
self processor
eip: 0;
esp: (memory size - 4). "Room for return address"
self should: [self processor runInMemory: memory minimumAddress: 0 readOnlyBelow: memory size / 2]
raise: Error
withExceptionDo:
[:err|
self assert: self processor pc = (memory size / 2).
self assert: ('*EIP*> CS.limit*' match: err messageText)].
self processor eip: 0.
self should: [[self processor singleStepIn: memory minimumAddress: 0 readOnlyBelow: memory size / 2] repeat]
raise: Error
withExceptionDo:
[:err|
self assert: self processor pc = (memory size / 2).
self assert: ('*EIP*> CS.limit*' match: err messageText)]!
----- Method: BochsIA32AlienTests>>testMOVSD (in category 'tests') -----
testMOVSD
"Test MOVSD indirecting through edx."
"self new testMOVSD"
self processor
edx: 0;
eip: 0;
singleStepIn: {16rF2. 16r0F. 16r10. 16r42. 16r04. 16r90. 16r01. 16r02. 16r03. 16r04. 16r05. 16r06} asByteArray "movsd %ds:0x4(%edx), %xmm0;nop;garbage".
self assert: self processor eip = 5.
self assert: self processor xmm0low = 16r0605040302019004!
----- Method: BochsIA32AlienTests>>testNfib1 (in category 'tests') -----
testNfib1
"self new testNfib1"
self should: [self runNFib: 1 disassemble: false printRegisters: false]
raise: Error.
self deny: (self processor eip between: 1 and: self nfib size).
self assert: self processor eax = 1 benchFib!
----- Method: BochsIA32AlienTests>>testNfib16 (in category 'tests') -----
testNfib16
"self new testNfib16"
self should: [self runNFib: 16 disassemble: false printRegisters: false]
raise: Error.
self deny: (self processor eip between: 1 and: self nfib size).
self assert: self processor eax = 16 benchFib!
----- Method: BochsIA32AlienTests>>testNfib2 (in category 'tests') -----
testNfib2
"self new testNfib2"
self should: [self runNFib: 2 disassemble: false printRegisters: false]
raise: Error.
self deny: (self processor eip between: 1 and: self nfib size).
self assert: self processor eax = 2 benchFib!
----- Method: BochsIA32AlienTests>>testNfib4 (in category 'tests') -----
testNfib4
"self new testNfib4"
self should: [self runNFib: 4 disassemble: false printRegisters: false]
raise: Error.
self deny: (self processor eip between: 1 and: self nfib size).
self assert: self processor eax = 4 benchFib!
----- Method: BochsIA32AlienTests>>testResetCPU (in category 'tests') -----
testResetCPU
"self new testResetCPU"
self registerSetters do:
[:setter|
self processor perform: setter with: 16r55555555].
self registerGetters do:
[:getter|
self assert: 16r55555555 = (self processor perform: getter)].
self processor reset.
self registerGetters do:
[:getter|
self assert: 0 = (self processor perform: getter)]!
----- Method: BochsIA32AlienTests>>testStepNfib1 (in category 'tests') -----
testStepNfib1
"self new testNfib1"
self singleStepNFib: 1 disassemble: false printRegisters: false.
self assert: self processor eip = self nfib size.
self assert: self processor eax = 1 benchFib!
----- Method: BochsIA32AlienTests>>testStepNfib2 (in category 'tests') -----
testStepNfib2
"self new testNfib2"
self singleStepNFib: 2 disassemble: false printRegisters: false.
self assert: self processor eip = self nfib size.
self assert: self processor eax = 2 benchFib!
----- Method: BochsIA32AlienTests>>testStepNfib4 (in category 'tests') -----
testStepNfib4
"self new testNfib4"
self singleStepNFib: 4 disassemble: false printRegisters: false.
self assert: self processor eip = self nfib size.
self assert: self processor eax = 4 benchFib!
TestCase subclass: #CogVMTests
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Cog-Tests'!
----- Method: CogVMTests>>recurse (in category 'support') -----
recurse
self recurse!
----- Method: CogVMTests>>runningOnCogit (in category 'support') -----
runningOnCogit
"CogVMTests new runningOnCogit"
^(1 to: 3) anySatisfy: [:each| thisContext xrayIsExecutingMachineCode]!
----- Method: CogVMTests>>testMultiplicativeOperators (in category 'tests') -----
testMultiplicativeOperators
"CogVMTests new setUp testMultiplicativeOperators"
self runningOnCogit ifTrue:
[thisContext xrayIsExecutingMachineCode ifFalse:
[^self testMultiplicativeOperators]].
1 to: 3 do: "Running 3 times should ensure all operators are compiled to machine code"
[:ignored| | values |
self assert: (1 / 2 literalEqual: (Fraction numerator: 1 denominator: 2)).
self assert: 1 // 2 == 0.
self assert: (1 quo: 2) == 0.
self assert: 3 * 4 == 12.
self assert: 65536 / 2 == 32768.
self assert: 65536 // 2 == 32768.
self assert: (65536 quo: 2) == 32768.
self assert: 65536 * 2 == 131072.
#(1 2 4 8 16 32 64 128 256 512 1024 2048 4096 8192 16384 32768 65536
131072 262144 524288 1048576 2097152 4194304 8388608 16777216 33554432
67108864 134217728 268435456 536870912 1073741824 2147483648 4294967296) withIndexDo:
[:value :index| | power | "test that integer overflow is detected in multiplication"
power := index - 1.
self assert: value * value = (2 raisedTo: power + power)].
self assert: SmallInteger minVal / -1 = (SmallInteger maxVal + 1).
self assert: SmallInteger minVal // -1 = (SmallInteger maxVal + 1).
self assert: (SmallInteger minVal quo: -1) = (SmallInteger maxVal + 1).
self assert: (SmallInteger minVal \\ -1) = 0.
values := Integer primesUpTo: 1000.
values := (values reverse collect: [:ea| ea negated]), values.
values do:
[:dividend|
values do:
[:divisor|
self assert: (dividend quo: divisor) * divisor + (dividend rem: divisor) = dividend.
self assert: (dividend // divisor) * divisor + (dividend \\ divisor) = dividend]]]!
----- Method: CogVMTests>>testPCAccessForActivation (in category 'tests') -----
testPCAccessForActivation
"self new testPCAccessForActivation"
| runningOnCogit theProcess block run pc executingMachineCode scanner blockCount |
runningOnCogit := self runningOnCogit.
run := true.
theProcess := Processor activeProcess.
"Fork a process that will sample the pc of the following recursive block."
[(Delay forMilliseconds: 1) wait.
pc := theProcess suspendedContext pc.
executingMachineCode := theProcess suspendedContext xrayIsExecutingMachineCode.
run := false] forkAt: Processor userInterruptPriority.
"The only suspension point in this block is on activation (assuming
ifTrue: is inlined) so its pc must be the first bytecode in the block."
block := [run ifTrue: [block value]].
block value.
"Find the first bytecode of the second block in this method."
blockCount := 0.
(scanner := InstructionStream on: thisContext method)
scanFor:
[:b| blockCount = 2 or: [b == 143 and: [blockCount := blockCount + 1. false]]].
self assert: pc = scanner pc.
self assert: executingMachineCode = runningOnCogit.
"Fork a process that will use recurse: to infinitely recurse.
The only suspension point in this call is on activation (assuming
ifTrue: is inlined) so its pc must be the first bytecode in the method."
theProcess := [self recurse] forkAt: Processor activePriority - 1.
(Delay forMilliseconds: 1) wait.
pc := theProcess suspendedContext pc.
executingMachineCode := theProcess suspendedContext xrayIsExecutingMachineCode.
theProcess terminate.
self assert: pc = (self class compiledMethodAt: #recurse) initialPC.
self assert: executingMachineCode = runningOnCogit!
----- Method: CogVMTests>>testPCAccessForSends (in category 'tests') -----
testPCAccessForSends
"self new testPCAccessForSends"
| runningOnCogit |
runningOnCogit := self runningOnCogit.
#("Method-level pc maping"
( '{ thisContext pc.
thisContext xrayIsExecutingMachineCode.
thisContext method }'
pc)
( '{ thisContext perform: #perform:withArguments: with: #pc with: Array new.
thisContext xrayIsExecutingMachineCode.
thisContext method }'
perform:with:with: )
( '{ [:ctxt :msg :ign1| ctxt perform: msg] value: thisContext value: #pc value: nil.
thisContext xrayIsExecutingMachineCode.
thisContext method }'
value:value:value: )
"Block-level pc maping"
( '[:method|
{ thisContext pc.
thisContext xrayIsExecutingMachineCode.
method } ] value: thisContext method'
pc)
( '[:method|
{ (thisContext perform: #perform:withArguments: with: #pc with: Array new).
thisContext xrayIsExecutingMachineCode.
method } ] value: thisContext method'
perform:with:with:)
( '[:method|
{ [:ctxt :msg :ign1| ctxt perform: msg] value: thisContext value: #pc value: nil.
thisContext xrayIsExecutingMachineCode.
method } ] value: thisContext method'
value:value:value: ) ) do:
[:case|
[:actualPc :executingMachineCode :method| | flag scanner expectedPc |
flag := false.
(scanner := InstructionStream on: method)
scanFor:
[:b| flag or: [flag := scanner selectorToSendOrSelf == case second. false]].
expectedPc := scanner pc.
self assert: actualPc = expectedPc.
self assert: executingMachineCode = runningOnCogit]
valueWithArguments: (Compiler evaluate: case first logged: false)]!
SmartSyntaxInterpreterPlugin subclass: #BochsIA32Plugin
instanceVariableNames: 'prevInterruptCheckChain'
classVariableNames: ''
poolDictionaries: 'VMBasicConstants'
category: 'Cog-ProcessorPlugins'!
!BochsIA32Plugin commentStamp: '<historical>' prior: 0!
I provide access to the Bochs C++ IA32 processor emulator.!
----- Method: BochsIA32Plugin class>>declareCVarsIn: (in category 'translation') -----
declareCVarsIn: aCCodeGenerator
"prevInterruptCheckChain lives in sqBochsIA32Plugin.c"
super declareCVarsIn: aCCodeGenerator.
aCCodeGenerator removeVariable: 'prevInterruptCheckChain'!
----- Method: BochsIA32Plugin class>>hasHeaderFile (in category 'translation') -----
hasHeaderFile
"We need a header to declare newcpu and pull in bochs.h & cpu.h"
^true!
----- Method: BochsIA32Plugin>>forceStopOnInterrupt (in category 'interruption') -----
forceStopOnInterrupt
interpreterProxy getInterruptPending ifTrue:
[self forceStopRunning]!
----- Method: BochsIA32Plugin>>primitiveDisassembleAt:InMemory: (in category 'primitives') -----
"cpuAlien <BochsIA32Alien>" primitiveDisassembleAt: address "<Integer>" InMemory: memory "<Bitmap|ByteArray|WordArray>"
"Return an Array of the instruction length and its decompilation as a string for the instruction at address in memory."
| cpuAlien cpu instrLenOrErr resultObj log logLen logObj logObjData |
<var: #cpu type: #'void *'>
cpuAlien := self primitive: #primitiveDisassembleAtInMemory
parameters: #(Unsigned WordsOrBytes)
receiver: #Oop.
(cpu := self startOfData: cpuAlien) = 0 ifTrue:
[^interpreterProxy primitiveFailFor: PrimErrBadReceiver].
instrLenOrErr := self disassembleFor: cpu
At: address
In: memory
Size: (interpreterProxy byteSizeOf: memory cPtrAsOop).
instrLenOrErr < 0 ifTrue:
[^interpreterProxy primitiveFailFor: PrimErrInappropriate].
log := self getlog: (self cCode: [self addressOf: logLen] inSmalltalk: [logLen := 0]).
resultObj := interpreterProxy instantiateClass: interpreterProxy classArray indexableSize: 2.
resultObj = 0 ifTrue:
[^interpreterProxy primitiveFailFor: PrimErrNoMemory].
"Easier keeping the damn thing on the stack than using pushRemappableOop:/popRemappableOop.
Where is topRemappableOop when you need it?"
interpreterProxy pushRemappableOop: resultObj.
logObj := interpreterProxy
instantiateClass: interpreterProxy classString
indexableSize: logLen.
interpreterProxy failed ifTrue:
[interpreterProxy popRemappableOop.
^interpreterProxy primitiveFailFor: PrimErrNoMemory].
logObjData := interpreterProxy arrayValueOf: logObj.
self cCode: 'memcpy(logObjData, log, logLen)' inSmalltalk: [logObjData. log].
resultObj := interpreterProxy popRemappableOop.
interpreterProxy
storePointer: 0
ofObject: resultObj
withValue: (interpreterProxy integerObjectOf: instrLenOrErr).
interpreterProxy storePointer: 1 ofObject: resultObj withValue: logObj.
^resultObj!
----- Method: BochsIA32Plugin>>primitiveErrorAndLog (in category 'primitives') -----
primitiveErrorAndLog
| log logLen resultObj logObj logObjData |
<var: #log type: #'char *'>
<var: #logObjData type: #'char *'>
self primitive: #primitiveErrorAndLog parameters: #().
log := self getlog: (self cCode: [self addressOf: logLen] inSmalltalk: [logLen := 0]).
resultObj := interpreterProxy instantiateClass: interpreterProxy classArray indexableSize: 2.
resultObj = 0 ifTrue:
[^interpreterProxy primitiveFailFor: PrimErrNoMemory].
interpreterProxy
storePointer: 0
ofObject: resultObj
withValue: (interpreterProxy integerObjectOf: self errorAcorn).
logLen > 0 ifTrue:
[interpreterProxy pushRemappableOop: resultObj.
logObj := interpreterProxy
instantiateClass: interpreterProxy classString
indexableSize: logLen.
interpreterProxy failed ifTrue:
[interpreterProxy popRemappableOop.
^interpreterProxy primitiveFailFor: PrimErrNoMemory].
resultObj := interpreterProxy popRemappableOop.
logObjData := interpreterProxy arrayValueOf: logObj.
self cCode: 'memcpy(logObjData, log, logLen)' inSmalltalk: [logObjData. log].
interpreterProxy storePointer: 1 ofObject: resultObj withValue: logObj].
interpreterProxy pop: 1 thenPush: resultObj!
----- Method: BochsIA32Plugin>>primitiveFlushICacheFrom:To: (in category 'primitives') -----
"cpuAlien <BochsIA32Alien>" primitiveFlushICacheFrom: startAddress "<Integer>" To: endAddress "<Integer>"
"Flush the icache in the requested range"
| cpuAlien cpu |
<var: #cpu type: 'void *'>
cpuAlien := self primitive: #primitiveFlushICacheFromTo
parameters: #(Unsigned Unsigned)
receiver: #Oop.
(cpu := self startOfData: cpuAlien) = 0 ifTrue:
[^interpreterProxy primitiveFailFor: PrimErrBadReceiver].
self flushICache: cpu From: startAddress To: endAddress!
----- Method: BochsIA32Plugin>>primitiveNewCPU (in category 'primitives') -----
primitiveNewCPU
| cpu |
<var: #cpu type: 'void *'>
self primitive: #primitiveNewCPU parameters: #().
cpu := self cCode: 'newCPU()' inSmalltalk: [0].
cpu = 0 ifTrue:
[^interpreterProxy primitiveFail].
interpreterProxy
pop: 1
thenPush: (interpreterProxy positive32BitIntegerFor:
(self cCoerceSimple: cpu
to: 'unsigned long'))!
----- Method: BochsIA32Plugin>>primitiveResetCPU (in category 'primitives') -----
primitiveResetCPU
| cpuAlien cpu maybeErr |
<var: #cpu type: 'void *'>
cpuAlien := self primitive: #primitiveResetCPU parameters: #() receiver: #Oop.
(cpu := self startOfData: cpuAlien) = 0 ifTrue:
[^interpreterProxy primitiveFailFor: PrimErrBadReceiver].
maybeErr := self resetCPU: cpu.
maybeErr ~= 0 ifTrue:
[^interpreterProxy primitiveFailFor: PrimErrInappropriate].
^cpuAlien!
----- Method: BochsIA32Plugin>>primitiveRunInMemory:minimumAddress:readOnlyBelow: (in category 'primitives') -----
"cpuAlien <BochsIA32Alien>" primitiveRunInMemory: memory "<Bitmap|ByteArray|WordArray>" minimumAddress: minAddress "<Integer>" readOnlyBelow: minWriteMaxExecAddress "<Integer>"
"Run the cpu using the first argument as the memory and the following arguments defining valid addresses, running until it halts or hits an exception."
| cpuAlien cpu maybeErr |
<var: #cpu type: #'void *'>
cpuAlien := self primitive: #primitiveRunInMemoryMinimumAddressReadWrite
parameters: #(WordsOrBytes Unsigned Unsigned)
receiver: #Oop.
(cpu := self startOfData: cpuAlien) = 0 ifTrue:
[^interpreterProxy primitiveFailFor: PrimErrBadReceiver].
prevInterruptCheckChain := interpreterProxy setInterruptCheckChain: #forceStopOnInterrupt asSymbol.
prevInterruptCheckChain = #forceStopOnInterrupt asSymbol ifTrue:
[prevInterruptCheckChain = 0].
maybeErr := self runCPU: cpu
In: memory
Size: (interpreterProxy byteSizeOf: memory cPtrAsOop)
MinAddressRead: minAddress
Write: minWriteMaxExecAddress.
interpreterProxy setInterruptCheckChain: prevInterruptCheckChain.
maybeErr ~= 0 ifTrue:
[^interpreterProxy primitiveFailFor: PrimErrInappropriate].
^cpuAlien!
----- Method: BochsIA32Plugin>>primitiveSingleStepInMemory:minimumAddress:readOnlyBelow: (in category 'primitives') -----
"cpuAlien <BochsIA32Alien>" primitiveSingleStepInMemory: memory "<Bitmap|ByteArray|WordArray>" minimumAddress: minAddress "<Integer>" readOnlyBelow: minWriteMaxExecAddress "<Integer>"
"Single-step the cpu using the first argument as the memory and the following arguments defining valid addresses."
| cpuAlien cpu maybeErr |
<var: #cpu type: #'void *'>
cpuAlien := self primitive: #primitiveSingleStepInMemoryMinimumAddressReadWrite
parameters: #(WordsOrBytes Unsigned Unsigned)
receiver: #Oop.
(cpu := self startOfData: cpuAlien) = 0 ifTrue:
[^interpreterProxy primitiveFailFor: PrimErrBadReceiver].
maybeErr := self singleStepCPU: cpu
In: memory
Size: (interpreterProxy byteSizeOf: memory cPtrAsOop)
MinAddressRead: minAddress
Write: minWriteMaxExecAddress.
maybeErr ~= 0 ifTrue:
[^interpreterProxy primitiveFailFor: PrimErrInappropriate].
^cpuAlien!
----- Method: BochsIA32Plugin>>sizeField: (in category 'alien support') -----
sizeField: rcvr
"Answer the first field of rcvr which is assumed to be an Alien of at least 8 bytes"
<inline: true>
^self longAt: rcvr + BaseHeaderSize!
----- Method: BochsIA32Plugin>>startOfData: (in category 'alien support') -----
startOfData: rcvr "<Alien oop> ^<Integer>"
"Answer the start of rcvr's data. For direct aliens this is the address of
the second field. For indirect and pointer aliens it is what the second field points to."
<inline: true>
^(self sizeField: rcvr) > 0
ifTrue: [rcvr + BaseHeaderSize + BytesPerOop]
ifFalse: [self longAt: rcvr + BaseHeaderSize + BytesPerOop]!
ParseNodeVisitor subclass: #BlockNodeCollectingVisitor
instanceVariableNames: 'blockNodes'
classVariableNames: ''
poolDictionaries: ''
category: 'Cog-Scripts'!
----- Method: BlockNodeCollectingVisitor>>blockNodes (in category 'accessing') -----
blockNodes
^blockNodes!
----- Method: BlockNodeCollectingVisitor>>visitBlockNode: (in category 'visiting') -----
visitBlockNode: aBlockNode
(blockNodes ifNil: [blockNodes := OrderedCollection new]) addLast: aBlockNode.
super visitBlockNode: aBlockNode!
ParseNodeVisitor subclass: #ReadBeforeWrittenVisitor
instanceVariableNames: 'readBeforeWritten written'
classVariableNames: ''
poolDictionaries: ''
category: 'Cog-Scripts'!
!ReadBeforeWrittenVisitor commentStamp: '<historical>' prior: 0!
Answer the set of temporary variables that are read before they are written.!
----- Method: ReadBeforeWrittenVisitor>>readBeforeWritten (in category 'accessing') -----
readBeforeWritten
^readBeforeWritten ifNil: [IdentitySet new]!
----- Method: ReadBeforeWrittenVisitor>>visitAssignmentNode: (in category 'visiting') -----
visitAssignmentNode: anAssignmentNode
anAssignmentNode value accept: self.
anAssignmentNode variable isTemp
ifTrue:
[written ifNil: [written := IdentitySet new].
written add: anAssignmentNode variable]
ifFalse:
[anAssignmentNode variable accept: self]!
----- Method: ReadBeforeWrittenVisitor>>visitBlockNode: (in category 'visiting') -----
visitBlockNode: aBlockNode
| savedWritten |
savedWritten := written copy.
super visitBlockNode: aBlockNode.
written := savedWritten!
----- Method: ReadBeforeWrittenVisitor>>visitTempVariableNode: (in category 'visiting') -----
visitTempVariableNode: aTempVariableNode
(aTempVariableNode isArg
or: [written notNil
and: [written includes: aTempVariableNode]]) ifTrue:
[^self].
readBeforeWritten ifNil:
[readBeforeWritten := IdentitySet new].
readBeforeWritten add: aTempVariableNode!
More information about the Vm-dev
mailing list