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@ussc9-mail01.qwaq.com/INBOX.imapmbox/Messages' destination: 'eng@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@ussc9-mail01.qwaq.com/INBOX.imapmbox/Messages' destination: 'eng@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@netjam.org' 'skysound@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@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!
vm-dev@lists.squeakfoundation.org