Vm-dev October 2011

vm-dev@lists.squeakfoundation.org

25 participants
55 discussions

a problem trying to build in jenkins
by Esteban Lorenzano 17 Oct '11

17 Oct '11

Hi, I'm trying to build a new cocoa vm, with some minor fixes... and I'm having this problem: I uploaded a new version of ConfigurationOfCog to metacello repository (EstebanLorenzano.46), and then I start a build... and the generator.image is loading EstebanLorenzano.45... :( any idea why this can be happening? cheers, Esteban

1 0

VM Maker: CMakeVMMaker-EstebanLorenzano.140.mcz
by commits＠source.squeak.org 17 Oct '11

17 Oct '11

Esteban Lorenzano uploaded a new version of CMakeVMMaker to project VM Maker: http://source.squeak.org/VMMaker/CMakeVMMaker-EstebanLorenzano.140.mcz ==================== Summary ==================== Name: CMakeVMMaker-EstebanLorenzano.140 Author: EstebanLorenzano Time: 17 October 2011, 12:02:18 pm UUID: 2327f839-9a17-43bb-89d7-085a5b38c99b Ancestors: CMakeVMMaker-EstebanLorenzano.139 UnixOSProcessPlugin is still built as internal =============== Diff against CMakeVMMaker-EstebanLorenzano.139 =============== Item was changed: ----- Method: CogFamilyCocoaIOSConfig>>defaultExternalPlugins (in category 'plugins') ----- defaultExternalPlugins ^(self versionExternalPlugins), #( UUIDPlugin FloatMathPlugin AsynchFilePlugin SerialPlugin Mpeg3Plugin CroquetPlugin JoystickTabletPlugin MIDIPlugin B3DAcceleratorPlugin LocalePlugin ObjectiveCPlugin QuicktimePlugin TestOSAPlugin + "UnixOSProcessPlugin" - UnixOSProcessPlugin )! Item was changed: ----- Method: CogFamilyCocoaIOSConfig>>defaultInternalPlugins (in category 'plugins') ----- defaultInternalPlugins ^ #( ADPCMCodecPlugin BMPReadWriterPlugin BalloonEnginePlugin BitBltSimulation ClipboardExtendedPlugin DSAPlugin DeflatePlugin DropPlugin FFTPlugin FilePlugin FloatArrayPlugin GeniePlugin HostWindowPlugin JPEGReadWriter2Plugin JPEGReaderPlugin KlattSynthesizerPlugin LargeIntegersPlugin "MacMenubarPlugin" "This plugin is not yet ported" Matrix2x3Plugin MiscPrimitivePlugin RePlugin SecurityPlugin SocketPlugin SoundCodecPlugin SoundGenerationPlugin SoundPlugin StarSqueakPlugin SurfacePlugin + UnixOSProcessPlugin - "UnixOSProcessPlugin" )!

1 0

VM Maker: CMakeVMMaker-EstebanLorenzano.139.mcz
by commits＠source.squeak.org 17 Oct '11

17 Oct '11

Esteban Lorenzano uploaded a new version of CMakeVMMaker to project VM Maker: http://source.squeak.org/VMMaker/CMakeVMMaker-EstebanLorenzano.139.mcz ==================== Summary ==================== Name: CMakeVMMaker-EstebanLorenzano.139 Author: EstebanLorenzano Time: 17 October 2011, 10:09:20 am UUID: 472888bd-c8bf-4707-bfb3-d9728e343dca Ancestors: CMakeVMMaker-EstebanLorenzano.138 -added logic for English.lproj =============== Diff against CMakeVMMaker-EstebanLorenzano.138 =============== Item was changed: ----- Method: CocoaIOSConfig>>extraSources (in category 'source files') ----- extraSources ^'${buildDir}/', self prefixHeaderFileName, ' + ${resources} ', + '${buildDir}/', self prefixHeaderFileName, ' + ${resourcesLocaleEnglish}'! - ${resources}'! Item was changed: ----- Method: CocoaIOSConfig>>extraVMSettings: (in category 'settings') ----- extraVMSettings: maker maker set: 'CMAKE_OSX_ARCHITECTURES' to: 'i386'. maker set: 'resourceDir' toString: self resourcesDir, '/ProjectBuilder'. maker set: 'resources' to: '"${resourceDir}/Squeak VM.r" "${resourceDir}/Squeak.icns" "${resourceDir}/Cog.icns" "${resourceDir}/SqueakChanges.icns" "${resourceDir}/SqueakImage.icns" "${resourceDir}/SqueakPlugin.icns" "${resourceDir}/SqueakScript.icns" "${resourceDir}/SqueakGeneric.icns" "${resourceDir}/SqueakProject.icns" + "${resourceDir}/SqueakSources.icns"'. + + maker set: 'resourcesLocaleEnglish' to: + '"${resourceDir}/English.lproj/InfoPlist.strings" + "${resourceDir}/English.lproj/MainMenu.nib"' - "${resourceDir}/SqueakSources.icns" - "${resourceDir}/MainMenu.nib"' ! Item was changed: ----- Method: CocoaIOSConfig>>plistFile (in category 'bundle strings') ----- plistFile | plist | plist := self plistTemplate. #( CFBundleExecutable CFBundleGetInfoString CFBundleName CFBundleShortVersionString CFBundleVersion CFBundleIconFile CFBundleIdentifier NSMainNibFile SqueakDebug) do: [:key | plist := plist copyReplaceAll: '@' , key , '@' with: (self perform: key) asString ]. ^ self fixLineEndsOf: plist! Item was changed: ----- Method: CocoaIOSConfig>>plistTemplate (in category 'bundle strings') ----- (excessive size, no diff calculated) Item was changed: ----- Method: CogFamilyCocoaIOSConfig>>defaultExternalPlugins (in category 'plugins') ----- defaultExternalPlugins ^(self versionExternalPlugins), #( UUIDPlugin FloatMathPlugin AsynchFilePlugin SerialPlugin Mpeg3Plugin CroquetPlugin JoystickTabletPlugin MIDIPlugin B3DAcceleratorPlugin LocalePlugin ObjectiveCPlugin QuicktimePlugin TestOSAPlugin + UnixOSProcessPlugin )! Item was changed: ----- Method: CogFamilyCocoaIOSConfig>>defaultInternalPlugins (in category 'plugins') ----- defaultInternalPlugins ^ #( ADPCMCodecPlugin BMPReadWriterPlugin BalloonEnginePlugin BitBltSimulation ClipboardExtendedPlugin DSAPlugin DeflatePlugin DropPlugin FFTPlugin FilePlugin FloatArrayPlugin GeniePlugin HostWindowPlugin JPEGReadWriter2Plugin JPEGReaderPlugin KlattSynthesizerPlugin LargeIntegersPlugin "MacMenubarPlugin" "This plugin is not yet ported" Matrix2x3Plugin MiscPrimitivePlugin RePlugin SecurityPlugin SocketPlugin SoundCodecPlugin SoundGenerationPlugin SoundPlugin StarSqueakPlugin SurfacePlugin + "UnixOSProcessPlugin" - UnixOSProcessPlugin )! Item was changed: ----- Method: CogFamilyCocoaIOSConfig>>setExtraTargetProperties: (in category 'settings') ----- setExtraTargetProperties: maker | plist | maker addFrameworks: self frameworks. " generated and add Info.plist file " plist := self plistFile. (maker buildDir forceNewFileNamed: 'Info.plist') nextPutAll: plist; close. maker addProperty: 'MACOSX_BUNDLE_INFO_PLIST' value: '${buildDir}/Info.plist'. maker cmd: 'set_source_files_properties' params: '${resources} PROPERTIES MACOSX_PACKAGE_LOCATION Resources'. + + maker + cmd: 'set_source_files_properties' + params: '${resourcesLocaleEnglish} PROPERTIES MACOSX_PACKAGE_LOCATION Resources/English.lproj'. + + + maker + cmd: 'set_source_files_properties' + params: '${ENGLISH_RESOURCES} PROPERTIES MACOSX_PACKAGE_LOCATION Resources/English.lproj'. (maker buildDir forceNewFileNamed: self prefixHeaderFileName) nextPutAll: self precompiledHeaders; close. maker addXCodeProperty: 'GCC_PREFIX_HEADER' value: '${buildDir}/', self prefixHeaderFileName. maker addXCodeProperty: 'PER_ARCH_CFLAGS_i386' value: '-DLSB_FIRST -mfpmath=sse -finline-functions -fno-cse-follow-jumps -fno-gcse -mtune=prescott -march=pentium-m -falign-functions=16'. maker addXCodeProperty: 'GCC_VERSION' value: '4.2'. maker cmd: 'set_target_properties' params: self executableName, ' PROPERTIES COMPILE_FLAGS "-include \"', (self buildDir / self prefixHeaderFileName) fullName, '\""'. maker set: 'EXECUTABLE_OUTPUT_PATH' toString: self outputDir. maker set: 'RUNTIME_OUTPUT_DIRECTORY' toString: self outputDir.!

1 0

VM Maker: VMMaker-oscog-EstebanLorenzano.124.mcz
by commits＠source.squeak.org 17 Oct '11

17 Oct '11

Esteban Lorenzano uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker-oscog-EstebanLorenzano.124.mcz ==================== Summary ==================== Name: VMMaker-oscog-EstebanLorenzano.124 Author: EstebanLorenzano Time: 17 October 2011, 9:53:29 am UUID: b8813537-9a89-4053-a61a-b744d186f63e Ancestors: VMMaker-oscog-IgorStasenko.123 integrated BytesPerWorld changes by Dave =============== Diff against VMMaker-oscog-IgorStasenko.123 =============== Item was changed: ----- Method: CCodeGenerator>>emitCConstantsOn: (in category 'C code generator') ----- emitCConstantsOn: aStream "Store the global variable declarations on the given stream." | unused constList | unused := constants keys asSet. methods do: [:meth| meth parseTree nodesDo: [:n| n isConstant ifTrue: [unused remove: n name ifAbsent: []]]]. unused copy do: [:const| (variableDeclarations anySatisfy: [:value| value includesSubString: const]) ifTrue: [unused remove: const ifAbsent: []]]. "Don't generate any defines for the externally defined constants, STACKVM, COGVM, COGMTVM et al." (VMClass class>>#initializeMiscConstantsWith:) literalsDo: [:lit| lit isVariableBinding ifTrue: [unused add: lit key]]. + unused remove: #BytesPerWord ifAbsent: []. "force inclusion of BytesPerWord declaration" constList := constants keys reject:[:any| unused includes: any]. aStream cr; nextPutAll: '/*** Constants ***/'; cr. (self sortStrings: constList) do: [:varName| | node default value | node := constants at: varName. node name isEmpty ifFalse: ["Allow the class to provide an alternative definition, either of just the value or the whole shebang" default := self cLiteralFor: node value name: varName. value := vmClass ifNotNil: [(vmClass specialValueForConstant: node name default: default) ifNotNil: [:specialDef| specialDef] ifNil: [default]] ifNil: [default]. value first ~= $# ifTrue: [aStream nextPutAll: '#define '; nextPutAll: node name; space]. aStream nextPutAll: value; cr]]. aStream cr! Item was added: + ----- Method: CCodeGenerator>>generateBaseHeaderSize:on:indent: (in category 'C translation') ----- + generateBaseHeaderSize: msgNode on: aStream indent: level + "Generate the C code for this message onto the given stream." + + aStream nextPutAll: 'BaseHeaderSize' + ! Item was added: + ----- Method: CCodeGenerator>>generateBytesPerWord:on:indent: (in category 'C translation') ----- + generateBytesPerWord: msgNode on: aStream indent: level + "Generate the C code for this message onto the given stream." + + aStream nextPutAll: 'BytesPerWord'! Item was changed: ----- Method: CCodeGenerator>>initializeCTranslationDictionary (in category 'C translation') ----- initializeCTranslationDictionary "Initialize the dictionary mapping message names to actions for C code generation." | pairs | + translationDict := Dictionary new: 200. pairs := #( #& #generateAnd:on:indent: #| #generateOr:on:indent: #and: #generateSequentialAnd:on:indent: #or: #generateSequentialOr:on:indent: #not #generateNot:on:indent: #+ #generatePlus:on:indent: #- #generateMinus:on:indent: #negated #generateNegated:on:indent: #* #generateTimes:on:indent: #/ #generateDivide:on:indent: #// #generateDivide:on:indent: #\\ #generateModulo:on:indent: #<< #generateShiftLeft:on:indent: #>> #generateShiftRight:on:indent: #min: #generateMin:on:indent: #max: #generateMax:on:indent: #between:and: #generateBetweenAnd:on:indent: #bitAnd: #generateBitAnd:on:indent: #bitOr: #generateBitOr:on:indent: #bitXor: #generateBitXor:on:indent: #bitShift: #generateBitShift:on:indent: #signedBitShift: #generateSignedBitShift:on:indent: #bitInvert32 #generateBitInvert32:on:indent: #bitClear: #generateBitClear:on:indent: #< #generateLessThan:on:indent: #<= #generateLessThanOrEqual:on:indent: #= #generateEqual:on:indent: #> #generateGreaterThan:on:indent: #>= #generateGreaterThanOrEqual:on:indent: #~= #generateNotEqual:on:indent: #== #generateEqual:on:indent: #~~ #generateNotEqual:on:indent: #isNil #generateIsNil:on:indent: #notNil #generateNotNil:on:indent: #whileTrue: #generateWhileTrue:on:indent: #whileFalse: #generateWhileFalse:on:indent: #whileTrue #generateDoWhileTrue:on:indent: #whileFalse #generateDoWhileFalse:on:indent: #to:do: #generateToDo:on:indent: #to:by:do: #generateToByDo:on:indent: #repeat #generateRepeat:on:indent: #ifTrue: #generateIfTrue:on:indent: #ifFalse: #generateIfFalse:on:indent: #ifTrue:ifFalse: #generateIfTrueIfFalse:on:indent: #ifFalse:ifTrue: #generateIfFalseIfTrue:on:indent: #ifNotNil: #generateIfNotNil:on:indent: #ifNil: #generateIfNil:on:indent: #ifNotNil:ifNil: #generateIfNotNilIfNil:on:indent: #ifNil:ifNotNil: #generateIfNilIfNotNil:on:indent: #at: #generateAt:on:indent: #at:put: #generateAtPut:on:indent: #basicAt: #generateAt:on:indent: #basicAt:put: #generateAtPut:on:indent: #integerValueOf: #generateIntegerValueOf:on:indent: #integerObjectOf: #generateIntegerObjectOf:on:indent: #isIntegerObject: #generateIsIntegerObject:on:indent: #cCode: #generateInlineCCode:on:indent: #cCode:inSmalltalk: #generateInlineCCode:on:indent: #cPreprocessorDirective: #generateInlineCPreprocessorDirective:on:indent: #cppIf:ifTrue:ifFalse: #generateInlineCppIfElse:on:indent: #cppIf:ifTrue: #generateInlineCppIfElse:on:indent: #cCoerce:to: #generateCCoercion:on:indent: #cCoerceSimple:to: #generateCCoercion:on:indent: #addressOf: #generateAddressOf:on:indent: #signedIntFromLong #generateSignedIntFromLong:on:indent: #signedIntToLong #generateSignedIntToLong:on:indent: #signedIntFromShort #generateSignedIntFromShort:on:indent: #signedIntToShort #generateSignedIntToShort:on:indent: #preIncrement #generatePreIncrement:on:indent: #preDecrement #generatePreDecrement:on:indent: #inline: #generateInlineDirective:on:indent: #asFloat #generateAsFloat:on:indent: #asInteger #generateAsInteger:on:indent: #asUnsignedInteger #generateAsUnsignedInteger:on:indent: #asSymbol #generateAsSymbol:on:indent: #anyMask: #generateBitAnd:on:indent: #raisedTo: #generateRaisedTo:on:indent: #touch: #generateTouch:on:indent: + #bytesPerWord #generateBytesPerWord:on:indent: + #baseHeaderSize #generateBaseHeaderSize:on:indent: + #sharedCodeNamed:inCase: #generateSharedCodeDirective:on:indent: #perform: #generatePerform:on:indent: #perform:with: #generatePerform:on:indent: #perform:with:with: #generatePerform:on:indent: #perform:with:with:with: #generatePerform:on:indent: #perform:with:with:with:with: #generatePerform:on:indent: #perform:with:with:with:with:with: #generatePerform:on:indent: #value #generateValue:on:indent: #value: #generateValue:on:indent: #value:value: #generateValue:on:indent: #shouldNotImplement #generateSmalltalkMetaError:on:indent: #shouldBeImplemented #generateSmalltalkMetaError:on:indent: ). 1 to: pairs size by: 2 do: [:i | translationDict at: (pairs at: i) put: (pairs at: i + 1)]. pairs := #( #ifTrue: #generateIfTrueAsArgument:on:indent: #ifFalse: #generateIfFalseAsArgument:on:indent: #ifTrue:ifFalse: #generateIfTrueIfFalseAsArgument:on:indent: #ifFalse:ifTrue: #generateIfFalseIfTrueAsArgument:on:indent: #ifNotNil: #generateIfNotNilAsArgument:on:indent: #ifNil: #generateIfNilAsArgument:on:indent: #ifNotNil:ifNil: #generateIfNotNilIfNilAsArgument:on:indent: #ifNil:ifNotNil: #generateIfNilIfNotNilAsArgument:on:indent: #cCode: #generateInlineCCodeAsArgument:on:indent: #cCode:inSmalltalk: #generateInlineCCodeAsArgument:on:indent: #cppIf:ifTrue:ifFalse: #generateInlineCppIfElseAsArgument:on:indent: #cppIf:ifTrue: #generateInlineCppIfElseAsArgument:on:indent: ). asArgumentTranslationDict := Dictionary new: 8. 1 to: pairs size by: 2 do: [:i | asArgumentTranslationDict at: (pairs at: i) put: (pairs at: i + 1)]. !

1 0

VM Maker: VMMaker-dtl.256.mcz
by commits＠source.squeak.org 16 Oct '11

16 Oct '11

David T. Lewis uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker-dtl.256.mcz ==================== Summary ==================== Name: VMMaker-dtl.256 Author: dtl Time: 16 October 2011, 11:04:41.732 am UUID: 4d8d78f4-a9f1-419b-a8ab-cb392e067016 Ancestors: VMMaker-dtl.255 VMMaker 4.7.13 Add Eliot's primitiveNotIdentical as primitive 169 =============== Diff against VMMaker-dtl.255 =============== Item was changed: ----- Method: Interpreter class>>initializePrimitiveTable (in category 'initialization') ----- initializePrimitiveTable "This table generates a C function address table use in primitiveResponse along with dispatchFunctionPointerOn:in:" "NOTE: The real limit here is 2047 because of the method header layout but there is no point in going over the needed size" MaxPrimitiveIndex := 575. PrimitiveTable := Array new: MaxPrimitiveIndex + 1. self table: PrimitiveTable from: #( "Integer Primitives (0-19)" (0 primitiveFail) (1 primitiveAdd) (2 primitiveSubtract) (3 primitiveLessThan) (4 primitiveGreaterThan) (5 primitiveLessOrEqual) (6 primitiveGreaterOrEqual) (7 primitiveEqual) (8 primitiveNotEqual) (9 primitiveMultiply) (10 primitiveDivide) (11 primitiveMod) (12 primitiveDiv) (13 primitiveQuo) (14 primitiveBitAnd) (15 primitiveBitOr) (16 primitiveBitXor) (17 primitiveBitShift) (18 primitiveMakePoint) (19 primitiveFail) "Guard primitive for simulation -- *must* fail" "LargeInteger Primitives (20-39)" (20 primitiveFail) (21 primitiveAddLargeIntegers) (22 primitiveSubtractLargeIntegers) (23 primitiveLessThanLargeIntegers) (24 primitiveGreaterThanLargeIntegers) (25 primitiveLessOrEqualLargeIntegers) (26 primitiveGreaterOrEqualLargeIntegers) (27 primitiveEqualLargeIntegers) (28 primitiveNotEqualLargeIntegers) (29 primitiveMultiplyLargeIntegers) (30 primitiveDivideLargeIntegers) (31 primitiveModLargeIntegers) (32 primitiveDivLargeIntegers) (33 primitiveQuoLargeIntegers) (34 primitiveBitAndLargeIntegers) (35 primitiveBitOrLargeIntegers) (36 primitiveBitXorLargeIntegers) (37 primitiveBitShiftLargeIntegers) (38 primitiveFail) (39 primitiveFail) "Float Primitives (40-59)" (40 primitiveAsFloat) (41 primitiveFloatAdd) (42 primitiveFloatSubtract) (43 primitiveFloatLessThan) (44 primitiveFloatGreaterThan) (45 primitiveFloatLessOrEqual) (46 primitiveFloatGreaterOrEqual) (47 primitiveFloatEqual) (48 primitiveFloatNotEqual) (49 primitiveFloatMultiply) (50 primitiveFloatDivide) (51 primitiveTruncated) (52 primitiveFractionalPart) (53 primitiveExponent) (54 primitiveTimesTwoPower) (55 primitiveSquareRoot) (56 primitiveSine) (57 primitiveArctan) (58 primitiveLogN) (59 primitiveExp) "Subscript and Stream Primitives (60-67)" (60 primitiveAt) (61 primitiveAtPut) (62 primitiveSize) (63 primitiveStringAt) (64 primitiveStringAtPut) (65 primitiveFail) "was primitiveNext which no longer pays its way (normal Smalltalk code is faster)" (66 primitiveFail) "was primitiveNextPut which no longer pays its way (normal Smalltalk code is faster)" (67 primitiveFail) "was primitiveAtEnd which no longer pays its way (normal Smalltalk code is faster)" "StorageManagement Primitives (68-79)" (68 primitiveObjectAt) (69 primitiveObjectAtPut) (70 primitiveNew) (71 primitiveNewWithArg) (72 primitiveArrayBecomeOneWay) "Blue Book: primitiveBecome" (73 primitiveInstVarAt) (74 primitiveInstVarAtPut) (75 primitiveAsOop) (76 primitiveStoreStackp) "Blue Book: primitiveAsObject" (77 primitiveSomeInstance) (78 primitiveNextInstance) (79 primitiveNewMethod) "Control Primitives (80-89)" (80 primitiveBlockCopy) (81 primitiveValue) (82 primitiveValueWithArgs) (83 primitivePerform) (84 primitivePerformWithArgs) (85 primitiveSignal) (86 primitiveWait) (87 primitiveResume) (88 primitiveSuspend) (89 primitiveFlushCache) "Input/Output Primitives (90-109)" (90 primitiveMousePoint) (91 primitiveTestDisplayDepth) "Blue Book: primitiveCursorLocPut" (92 primitiveSetDisplayMode) "Blue Book: primitiveCursorLink" (93 primitiveInputSemaphore) (94 primitiveGetNextEvent) "Blue Book: primitiveSampleInterval" (95 primitiveInputWord) (96 primitiveFail) "primitiveCopyBits" (97 primitiveSnapshot) (98 primitiveStoreImageSegment) (99 primitiveLoadImageSegment) (100 primitivePerformInSuperclass) "Blue Book: primitiveSignalAtTick" (101 primitiveBeCursor) (102 primitiveBeDisplay) (103 primitiveScanCharacters) (104 primitiveFail) "primitiveDrawLoop" (105 primitiveStringReplace) (106 primitiveScreenSize) (107 primitiveMouseButtons) (108 primitiveKbdNext) (109 primitiveKbdPeek) "System Primitives (110-119)" (110 primitiveEquivalent) (111 primitiveClass) (112 primitiveBytesLeft) (113 primitiveQuit) (114 primitiveExitToDebugger) (115 primitiveChangeClass) "Blue Book: primitiveOopsLeft" (116 primitiveFlushCacheByMethod) (117 primitiveExternalCall) (118 primitiveDoPrimitiveWithArgs) (119 primitiveFlushCacheSelective) "Squeak 2.2 and earlier use 119. Squeak 2.3 and later use 116. Both are supported for backward compatibility." "Miscellaneous Primitives (120-127)" (120 primitiveCalloutToFFI) (121 primitiveImageName) (122 primitiveNoop) "Blue Book: primitiveImageVolume" (123 primitiveValueUninterruptably) "@@@: Remove this when all VMs have support" (124 primitiveLowSpaceSemaphore) (125 primitiveSignalAtBytesLeft) "Squeak Primitives Start Here" "Squeak Miscellaneous Primitives (128-149)" (126 primitiveDeferDisplayUpdates) (127 primitiveShowDisplayRect) (128 primitiveArrayBecome) (129 primitiveSpecialObjectsOop) (130 primitiveFullGC) (131 primitiveIncrementalGC) (132 primitiveObjectPointsTo) (133 primitiveSetInterruptKey) (134 primitiveInterruptSemaphore) (135 primitiveMillisecondClock) (136 primitiveSignalAtMilliseconds) (137 primitiveSecondsClock) (138 primitiveSomeObject) (139 primitiveNextObject) (140 primitiveBeep) (141 primitiveClipboardText) (142 primitiveVMPath) (143 primitiveShortAt) (144 primitiveShortAtPut) (145 primitiveConstantFill) "NOTE: When removing the obsolete indexed primitives, the following two should go become #primitiveIntegerAt / atPut" (146 primitiveFail) "primitiveReadJoystick" (147 primitiveFail) "primitiveWarpBits" (148 primitiveClone) (149 primitiveGetAttribute) "File Primitives (150-169) - NO LONGER INDEXED" (150 159 primitiveFail) (160 primitiveAdoptInstance) (161 164 primitiveFail) (165 primitiveIntegerAt) "hacked in here for now" (166 primitiveIntegerAtPut) (167 primitiveYield) (168 primitiveCopyObject) + (169 primitiveNotIdentical) - (169 primitiveFail) "Sound Primitives (170-199) - NO LONGER INDEXED" (170 185 primitiveFail) "Old closure primitives" (186 primitiveFail) "was primitiveClosureValue" (187 primitiveFail) "was primitiveClosureValueWithArgs" "Perform method directly" (188 primitiveExecuteMethodArgsArray) (189 primitiveExecuteMethod) "Sound Primitives (continued) - NO LONGER INDEXED" (190 194 primitiveFail) "Unwind primitives" (195 primitiveFindNextUnwindContext) (196 primitiveTerminateTo) (197 primitiveFindHandlerContext) (198 primitiveMarkUnwindMethod) (199 primitiveMarkHandlerMethod) "new closure primitives (were Networking primitives)" (200 primitiveClosureCopyWithCopiedValues) (201 primitiveClosureValue) "value" (202 primitiveClosureValue) "value:" (203 primitiveClosureValue) "value:value:" (204 primitiveClosureValue) "value:value:value:" (205 primitiveClosureValue) "value:value:value:value:" (206 primitiveClosureValueWithArgs) "valueWithArguments:" (207 209 primitiveFail) "reserved for Cog primitives" (210 primitiveAt) "Compatibility with Cog StackInterpreter Context primitives" (211 primitiveAtPut) "Compatibility with Cog StackInterpreter Context primitives" (212 primitiveSize) "Compatibility with Cog StackInterpreter Context primitives" (213 219 primitiveFail) "reserved for Cog primitives" (220 primitiveFail) "reserved for Cog primitives" (221 primitiveClosureValueNoContextSwitch) "valueNoContextSwitch" (222 primitiveClosureValueNoContextSwitch) "valueNoContextSwitch:" (223 229 primitiveFail) "reserved for Cog primitives" (230 primitiveRelinquishProcessor) (231 primitiveForceDisplayUpdate) (232 primitiveFormPrint) (233 primitiveSetFullScreen) (234 primitiveFail) "primBitmapdecompressfromByteArrayat" (235 primitiveFail) "primStringcomparewithcollated" (236 primitiveFail) "primSampledSoundconvert8bitSignedFromto16Bit" (237 primitiveFail) "primBitmapcompresstoByteArray" (238 241 primitiveFail) "serial port primitives" (242 primitiveFail) (243 primitiveFail) "primStringtranslatefromtotable" (244 primitiveFail) "primStringfindFirstInStringinSetstartingAt" (245 primitiveFail) "primStringindexOfAsciiinStringstartingAt" (246 primitiveFail) "primStringfindSubstringinstartingAtmatchTable" (247 primitiveSnapshotEmbedded) (248 primitiveInvokeObjectAsMethod) (249 primitiveArrayBecomeOneWayCopyHash) "VM Implementor Primitives (250-255)" (250 clearProfile) (251 dumpProfile) (252 startProfiling) (253 stopProfiling) (254 primitiveVMParameter) (255 primitiveInstVarsPutFromStack) "Never used except in Disney tests. Remove after 2.3 release." "Quick Push Const Methods" (256 primitivePushSelf) (257 primitivePushTrue) (258 primitivePushFalse) (259 primitivePushNil) (260 primitivePushMinusOne) (261 primitivePushZero) (262 primitivePushOne) (263 primitivePushTwo) "Quick Push Const Methods" (264 519 primitiveLoadInstVar) "These ranges used to be used by obsiolete indexed primitives." (520 529 primitiveFail) (530 539 primitiveFail) (540 549 primitiveFail) (550 559 primitiveFail) (560 569 primitiveFail) "External primitive support primitives" (570 primitiveFlushExternalPrimitives) (571 primitiveUnloadModule) (572 primitiveListBuiltinModule) (573 primitiveListExternalModule) (574 primitiveFail) "reserved for addl. external support prims" "Unassigned Primitives" (575 primitiveFail)). ! Item was added: + ----- Method: Interpreter>>pop:thenPushBool: (in category 'contexts') ----- + pop: nItems thenPushBool: trueOrFalse + "A few places pop a few items off the stack and then push a boolean. Make it convenient" + | sp | + self longAt: (sp := stackPointer - ((nItems - 1) * self bytesPerWord)) + put:(trueOrFalse ifTrue: [trueObj] ifFalse: [falseObj]). + stackPointer := sp! Item was added: + ----- Method: InterpreterPrimitives>>primitiveNotIdentical (in category 'object access primitives') ----- + primitiveNotIdentical + "is the receiver/first argument not the same object as the (last) argument?. + pop argumentCount because this can be used as a mirror primitive." + | thisObject otherObject | + otherObject := self stackValue: 1. + thisObject := self stackTop. + self pop: argumentCount + 1 thenPushBool: thisObject ~= otherObject! Item was changed: ----- Method: VMMaker class>>versionString (in category 'version testing') ----- versionString "VMMaker versionString" + ^'4.7.13'! - ^'4.7.12'!

1 0

Re: [Vm-beginners] Re: Got "Error: basicNew: failed" when running InterpreterSimulator
by Mariano Martinez Peck 13 Oct '11

13 Oct '11

On Thu, Oct 13, 2011 at 5:26 AM, Nick. <nick.lsts(a)gmail.com> wrote: > Hi Mariano, > > Thanks for the advice. > I want to update this post with the results of some tests I've been doing, > so it's useful to anyone trying to run the simulator. > > I got stuck with an error I describe in the "About running > StackInterpreterSimulator in Pharo" section. > Hope someone could give me a clue on fixing that one :) > > Wow Nick. Your experience is really really helpful. > *Simulator in Squeak 2.6/2.7 is working* > First of all, if all you need is a simulator for learning/experimenting > purposes grab a Squeak 2.6 or 2.7 release (yes, /that/ old). The simulator > works right out of the box in those ones. See > http://wiki.squeak.org/squeak/2465 for instructions on how to archieve > that. > > *About running StackInterpreterSimulator in Pharo* > Taking Mariano's image as base (grab it here: > https://gforge.inria.fr/frs/download.php/28513/Pharo-1.2.1.cog.zip) I > found > the following issues and fixed them: > > To begin, I saved a copy of the image to a new file named > "simulated.image". > Closed the image and reopened the first one. > > 1) First problem: "Error: basicNew: failed" > Then, I evaluated the following from the original: > (StackInterpreterSimulator new openOn: 'source.image') test. > The error I've got is the one I described in my first post: "Error: > basicNew: failled" for "ArrayClass>>new". > Inspecting the stack trace I found that RootTableSize was an instance of > UndefinedObject in ObjectMemory>>initialize. > Taking a deeper look, it seemed that RootTableSize was setted in > ObjectMemory>>initializeWithOptions, wich wasn't called from > StackInterpreterSimulator>>initialize. Instead, ObjectMemory>>initialize > was > called, but that message didn't initialize RootTableSize. > So, I replaced the call form objectMemoryClass initialize to > objectMemoryClass initializeWithOptions: Dictionary new. to get > RootTableSize initialized properly. > > 2) Second problem: same situation with MethodCacheSize > Proceeding with StackInterpreterSimulator's execution, I came across a > similar situation with MethodCacheSize in ArrayClass>>basicNew:. > Following the same procedure as before, I found MethodCacheSize > uninitialized, and setted it property replacing, in > StackInterpreterSimulator>>initialize, the call from StackInterpreter > initialize. to StackInterpreter initializeWithOptions: Dictionary new. > > 3) Third problem: missing method from UtilityClass > Proceeding again, I came across an MNU saying that UtilityClass does not > understands "informUser:during:" message. After a message selector search, > I > replaced the call (that was being done in > StackInterpreterSimulator>>openOn:extraMemory:) with UIManager default > informUser: (...) during: (...) > > 4) Fourth problem: "the receiver of / is nil" > Originated from InterpreterStackPage>>headFP:. The cause was that > LargeContextBytes was an instance of UndefinedObject. > Once again, using the Method Finder (great tool!) I fixed the problem > evaluating: InterpreterStackPage initialize. as said in that method's > comment. > > Can you put the exact code to initialize all this points of 1) 2) and 4) ? I mean, can you provide the final script you had to use before being able to do the (StackInterpreterSimulator new openOn: 'source.image') test. > 5) Fifth problem: Two MNUs in StackInterpreter > Those came up: isContextNonInt:, generated from > commonVariable:at:chacheIndex: and commonVaraible:at:put:cacheIndex:. > I fixed those issues by replacing calls from self isContextNonInt: to self > objectMemory isContextNonInt:. > > 6) Sixth problem: MNU in StackInterpreter > The selector was isContextHeader: and it was used in > StackInterpreter>>stObject:at:. > I replaced calls from self isContextHeader: to self objectMemory > isContextHeader:. > for 5) and 6) .. which version of VMMaker are you using? because maybe this was already fixed in new versions? > > 7) Seventh problem: primitive clone failed in CArrayAccesor. > I fixes that by adding the clone message in CArrayAccessor as follows: > clone > <primitive: 148> > ^ self primitiveFailed > > 8) Lastly, restarting the simulation again I found that the desktop from > the > simulation image was beign rendered (Pharo logo, some Workpaces that were > saved, etc.) and then this error came up: "primitive failed: > setGCBiasToGrowGCLimit:". > The thing is that the VM that hosts the simulated one didn't open the > debugger on that halt, it was like the simulated image was frozen (I > suppose, because that error was in the call stack of > snapshot:andQuit:embedded:). > > And here is when I wanted to ask you for some help guys, as I couldn't > debug > the host machine to invesitgate the cause and fix the problem. > > Do you have any clue/idea to detect the cause/fix this issue? > > No, I have no idea :( but maybe someone does. > *FileOut of the changes described* > > http://forum.world.st/file/n3900467/ChangesSoFarToMakeSimulatorWorkInPharo-… > ChangesSoFarToMakeSimulatorWorkInPharo-1.2.1.zip > > Excellent! At the end you can also provide an image (that mine) with those changes + a workspace with all the needed initialize code and the snippet to start the simulator. Cheers > Cheers and thanks in advance! > > Nick > > > > > > -- > View this message in context: > http://forum.world.st/Got-Error-basicNew-failed-when-running-InterpreterSim… > Sent from the Smalltalk VM - Beginners mailing list archive at Nabble.com. > _______________________________________________ > VM-beginners mailing list > VM-beginners(a)lists.squeakfoundation.org > http://lists.squeakfoundation.org/mailman/listinfo/vm-beginners > -- Mariano http://marianopeck.wordpress.com

1 0

VM Maker: Cog-eem.45.mcz
by commits＠source.squeak.org 12 Oct '11

12 Oct '11

Eliot Miranda uploaded a new version of Cog to project VM Maker: http://source.squeak.org/VMMaker/Cog-eem.45.mcz ==================== Summary ==================== Name: Cog-eem.45 Author: eem Time: 24 July 2011, 12:37:45.539 pm UUID: 5b38d4e4-2a1f-477e-b79a-a82e37e0403a Ancestors: Cog-eem.44 Cog needs to live somewhere, and VMMaker is where that somewhere should be. Update error handling for SISTA support. =============== Diff against Cog-eem.44 =============== Item was added: + ----- Method: BochsIA32Alien class>>defaultIntegerBaseInDebugger (in category 'debugger') ----- + defaultIntegerBaseInDebugger + ^16! Item was changed: ----- 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 reportPrimitiveFailure]! - [self handleExecutionPrimitiveFailureAt: pc - in: memoryArray - readOnlyBelow: minimumWritableAddress]! Item was changed: ----- 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 | + ^((modrmByte := memoryArray byteAt: pc + 2) bitAnd: 16rC7) = 16r5 "ModRegInd & disp32" - | 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: (memoryArray unsignedLongAt: pc + 3 bigEndian: false) - address: address type: #write accessor: (#(eax ecx edx ebx esp ebp esi edi) at: ((modrmByte >> 3 bitAnd: 7) + 1))) signal] ifFalse: + [self reportPrimitiveFailure]! - [self handleExecutionPrimitiveFailureAt: pc - in: memoryArray - readOnlyBelow: minimumWritableAddress]! Item was changed: ----- 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 reportPrimitiveFailure]! - [self handleExecutionPrimitiveFailureAt: pc - in: memoryArray - readOnlyBelow: minimumWritableAddress]! Item was changed: ----- 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 reportPrimitiveFailure]! - [self handleExecutionPrimitiveFailureAt: pc - in: memoryArray - readOnlyBelow: minimumWritableAddress]!

1 0

VM Maker: Cog-eem.44.mcz
by commits＠source.squeak.org 12 Oct '11

12 Oct '11

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(a)ussc9-mail01.qwaq.com/INBOX.imapmbox/Messages' destination: 'eng(a)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(a)ussc9-mail01.qwaq.com/INBOX.imapmbox/Messages' destination: 'eng(a)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(a)netjam.org' 'skysound(a)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(a)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!

1 0

Re: [squeak-dev] Re: [Pharo-project] CogDroid Status Update
by Mariano Martinez Peck 11 Oct '11

11 Oct '11

Congratulations! continue with your work :) On Mon, Oct 10, 2011 at 8:57 PM, Stéphane Ducasse <stephane.ducasse(a)inria.fr > wrote: > Thanks a lot Dimitry. What you are doing is great! > > Stef > On Oct 10, 2011, at 7:06 PM, Dimitry Golubovsky wrote: > > > Hi, > > > > I would like to update the Squeak/Pharo community on the CogDroid > > development status, summarize the changes made since the first public > > alpha release, and discuss further directions of the development. > > > > I have uploaded two new alpha release packages: > > > > for ARM devices: > > http://squeakvm-tablet.googlecode.com/files/CogDroid-alpha-20111009.apk > > > > for Android-x86: > > > http://squeakvm-tablet.googlecode.com/files/CogDroid86-alpha-20111010.apk > > > > I have created a wiki page [1] which summarizes the changes made to > > CogDroid since the first public alpha release. > > > > Briefly, these changes are: > > > > - Partial integration with Android intent system, so CogDroid can be > > launched with a specified Smalltalk image file and a startup script by > > tapping a home screen shortcut icon. Such icons can be created from > > Smalltalk code running in CogDroid. See also [2] for technical > > details. > > > > - Added build for the x86 Android platform. Android-x86 can run on > > Intel-compatible CPUs in desktops and netbooks, and also in virtual > > machines. > > > > - Using a PC with physical keyboard and mouse attached brings some > > benefits in terms of user input, so functionality was added to support > > special keys such as Ctrl- and Shift- modifiers, and also arrow and > > home/end keys. This may be also of use on ARM tablets with keyboard > > and mouse attached, or on dockable phones. I am unable to test this > > myself, but your feedback is always welcome. > > > > At this moment, I am going to change the direction of my efforts > > towards deeper studying of Android itself, which may give me some > > ideas how to integrate CogDroid better with Android services (e. g. > > sound interface is an open question, but I need to study more, whether > > OSS/ALSA is available under the hood, or some Java wrapper is needed). > > > > This means that for some time I will be pushing updates less > > frequently, except for bugs and critical issues, if reported. OTOH > > this is a better time to integrate my developer's branch with the > > mainline. So, Igor and Eliot please contact me to discuss the > > technical moments. > > > > I would like to thank the whole Squeak/Pharo community for helping me > > with the development and testing. The Benchmark page [3] is a source > > of information people may find helpful choosing an Android device to > > run CogDroid on. > > > > Your feedback is always welcome. Please add your comments to the Alpha > > Progress page [1], including your ideas of Android applications that > > might be created with CogDroid, and what functionality you think needs > > to be added. > > > > Thanks again, and hope to hear from you! > > > > ------------------- > > [1] http://code.google.com/p/squeakvm-tablet/wiki/CogDroidAlphaProgress > > [2] > http://code.google.com/p/squeakvm-tablet/wiki/CogDroidIntentsAndShortcuts > > [3] http://code.google.com/p/squeakvm-tablet/wiki/TinyBenchmark > > > > -- > > Dimitry Golubovsky > > > > Anywhere on the Web > > > > > -- Mariano http://marianopeck.wordpress.com

1 0

new Cog VM available at...
by Eliot Miranda 11 Oct '11

11 Oct '11

http://www.mirandabanda.org/files/Cog/VM/VM.r2499/. CogVM binaries as per VMMaker.oscog-eem.133/r2499. Tiny performance tweak to bytecodePrimMultiply. Added findStringBeginningWith: debugging facility. Fix yet another slip in Cogit>>lookup:for:methodAndErrorSelectorInto: for cannotInterpret: cases. Fixes Mariano's crash as of 2011/10/03. Add -numextsems command-line argument to set size of external semaphore table on start-up. Enjoy -- best, Eliot

2 1

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

Vm-dev October 2011