Esteban Lorenzano uploaded a new version of Cog to project VM Maker: http://source.squeak.org/VMMaker/Cog.pharo-EstebanLorenzano.199.mcz
==================== Summary ====================
Name: Cog.pharo-EstebanLorenzano.199 Author: EstebanLorenzano Time: 26 August 2014, 1:58:10.563781 pm UUID: 900e8bda-7c0f-4468-9636-a6c2855c3b69 Ancestors: Cog-EstebanLorenzano.198
- merge - last moment fixes
=============== Diff against Cog-eem.197 ===============
Item was changed: + SystemOrganization addCategory: #Cog! + SystemOrganization addCategory: 'Cog-Benchmarks-DeltaBlue'! + SystemOrganization addCategory: 'Cog-Benchmarks-Richards'! + SystemOrganization addCategory: 'Cog-Benchmarks-SMark'! + SystemOrganization addCategory: 'Cog-Benchmarks-Shootout'! + SystemOrganization addCategory: 'Cog-Bootstrapping'! + SystemOrganization addCategory: 'Cog-Morphing Bytecode Set'! + SystemOrganization addCategory: 'Cog-ProcessorPlugins'! + SystemOrganization addCategory: 'Cog-Processors'! + SystemOrganization addCategory: 'Cog-Processors-Tests'! + SystemOrganization addCategory: 'Cog-Scripting'! + SystemOrganization addCategory: 'Cog-Scripts'! + SystemOrganization addCategory: 'Cog-Tests'! - SystemOrganization addCategory: #'Cog-Benchmarks-DeltaBlue'! - SystemOrganization addCategory: #'Cog-Benchmarks-Richards'! - SystemOrganization addCategory: #'Cog-Benchmarks-SMark'! - SystemOrganization addCategory: #'Cog-Benchmarks-Shootout'! - SystemOrganization addCategory: #'Cog-Bootstrapping'! - SystemOrganization addCategory: #'Cog-Morphing Bytecode Set'! - SystemOrganization addCategory: #'Cog-ProcessorPlugins'! - SystemOrganization addCategory: #'Cog-Processors'! - SystemOrganization addCategory: #'Cog-Processors-Tests'! - SystemOrganization addCategory: #'Cog-Scripting'! - SystemOrganization addCategory: #'Cog-Scripts'! - SystemOrganization addCategory: #'Cog-Tests'!
Item was changed: ----- Method: CompiledMethod class>>CompiledMethodclassPROTOTYPEinitialize (in category '*Cog-method prototypes') ----- CompiledMethodclassPROTOTYPEinitialize "CompiledMethod initialize" "Initialize class variables specifying the size of the temporary frame needed to run instances of me."
SmallFrame := 16. "Context range for temps+stack" LargeFrame := 56. PrimaryBytecodeSetEncoderClass ifNil: [PrimaryBytecodeSetEncoderClass := EncoderForV3PlusClosures]. SecondaryBytecodeSetEncoderClass ifNil: [SecondaryBytecodeSetEncoderClass := EncoderForV3PlusClosures]!
Item was changed: ----- Method: CompiledMethod class>>CompiledMethodclassPROTOTYPEinstallPrimaryBytecodeSet: (in category '*Cog-method prototypes') ----- CompiledMethodclassPROTOTYPEinstallPrimaryBytecodeSet: aBytecodeEncoderSubclass PrimaryBytecodeSetEncoderClass == aBytecodeEncoderSubclass ifTrue: [^self]. (aBytecodeEncoderSubclass inheritsFrom: BytecodeEncoder) ifFalse: [self error: 'A bytecode set encoder is expected to be a subclass of BytecodeEncoder']. (self allSubInstances detect: [:m| m header >= 0 and: [m encoderClass ~~ aBytecodeEncoderSubclass]] ifNone: []) ifNotNil: [Warning signal: 'There are existing CompiledMethods with a different encoderClass.']. PrimaryBytecodeSetEncoderClass := aBytecodeEncoderSubclass!
Item was changed: ----- Method: ContextPart>>ContextPartPROTOTYPEdoPrimitive:method:receiver:args: (in category '*Cog-method prototypes') ----- ContextPartPROTOTYPEdoPrimitive: primitiveIndex method: meth receiver: receiver args: arguments "Simulate a primitive method whose index is primitiveIndex. The simulated receiver and arguments are given as arguments to this message. If successful, push result and return resuming context, else ^ {errCode, PrimitiveFailToken}. Any primitive which provokes execution needs to be intercepted and simulated to avoid execution running away."
| value | "Judicious use of primitive 19 (a null primitive that doesn't do anything) prevents the debugger from entering various run-away activities such as spawning a new process, etc. Injudicious use results in the debugger not being able to debug interesting code, such as the debugger itself. hence use primitive 19 with care :-)" "SystemNavigation new browseAllSelect: [:m| m primitive = 19]" primitiveIndex = 19 ifTrue: + [ Smalltalk tools debugger + openContext: self - [ToolSet - debugContext: self label:'Code simulation error' contents: nil].
((primitiveIndex between: 201 and: 222) and: [(self objectClass: receiver) includesBehavior: BlockClosure]) ifTrue: [((primitiveIndex between: 201 and: 205) "BlockClosure>>value[:value:...]" or: [primitiveIndex between: 221 and: 222]) ifTrue: "BlockClosure>>valueNoContextSwitch[:]" [^receiver simulateValueWithArguments: arguments caller: self]. primitiveIndex = 206 ifTrue: "BlockClosure>>valueWithArguments:" [^receiver simulateValueWithArguments: arguments first caller: self]].
primitiveIndex = 83 ifTrue: "afr 9/11/1998 19:50" "Object>>perform:[with:...]" [^self send: arguments first to: receiver with: arguments allButFirst super: false]. primitiveIndex = 84 ifTrue: "afr 9/11/1998 19:50 & eem 8/18/2009 17:04" "Object>>perform:withArguments:" [^self send: arguments first to: receiver with: (arguments at: 2) lookupIn: (self objectClass: receiver)]. primitiveIndex = 100 ifTrue: "eem 8/18/2009 16:57" "Object>>perform:withArguments:inSuperclass:" [^self send: arguments first to: receiver with: (arguments at: 2) lookupIn: (arguments at: 3)].
"Mutex>>primitiveEnterCriticalSection Mutex>>primitiveTestAndSetOwnershipOfCriticalSection" (primitiveIndex = 186 or: [primitiveIndex = 187]) ifTrue: [| active effective | active := Processor activeProcess. effective := active effectiveProcess. "active == effective" value := primitiveIndex = 186 ifTrue: [receiver primitiveEnterCriticalSectionOnBehalfOf: effective] ifFalse: [receiver primitiveTestAndSetOwnershipOfCriticalSectionOnBehalfOf: effective]. ^(self isPrimFailToken: value) ifTrue: [value] ifFalse: [self push: value]].
primitiveIndex = 188 ifTrue: "eem 5/27/2008 11:10 Object>>withArgs:executeMethod:" [^MethodContext sender: self receiver: receiver method: (arguments at: 2) arguments: (arguments at: 1)].
"Closure primitives" (primitiveIndex = 200 and: [self == receiver]) ifTrue: "ContextPart>>closureCopy:copiedValues:; simulated to get startpc right" [^self push: (BlockClosure outerContext: receiver startpc: pc + 2 numArgs: arguments first copiedValues: arguments last)].
primitiveIndex = 118 ifTrue: "tryPrimitive:withArgs:; avoid recursing in the VM" [(arguments size = 2 and: [arguments first isInteger and: [(self objectClass: arguments last) == Array]]) ifFalse: [^ContextPart primitiveFailTokenFor: nil]. ^self doPrimitive: arguments first method: meth receiver: receiver args: arguments last].
value := primitiveIndex = 120 "FFI method" ifTrue: [(meth literalAt: 1) tryInvokeWithArguments: arguments] ifFalse: [primitiveIndex = 117 "named primitives" ifTrue: [self tryNamedPrimitiveIn: meth for: receiver withArgs: arguments] ifFalse: [receiver tryPrimitive: primitiveIndex withArgs: arguments]].
^(self isPrimFailToken: value) ifTrue: [value] ifFalse: [self push: value]!
Item was changed: + ----- Method: SpurBootstrap class>>CharacterPROTOTYPEshallowCopy (in category 'method prototypes pharo') ----- - ----- Method: SpurBootstrap class>>CharacterPROTOTYPEshallowCopy (in category 'method prototypes') ----- CharacterPROTOTYPEshallowCopy "Answer the receiver, because Characters are unique." ^self!
Item was changed: + ----- Method: SpurBootstrap class>>ContextPartPROTOTYPEactivateReturn:value: (in category 'method prototypes squeak') ----- - ----- Method: SpurBootstrap class>>ContextPartPROTOTYPEactivateReturn:value: (in category 'method prototypes') ----- ContextPartPROTOTYPEactivateReturn: aContext value: value "Activate 'aContext return: value' in place of self, so execution will return to aContext's sender"
^MethodContext sender: self receiver: aContext method: MethodContext theReturnMethod arguments: {value}!
Item was changed: + ----- Method: SpurBootstrap class>>ContextPartPROTOTYPEdoPrimitive:method:receiver:args: (in category 'method prototypes squeak') ----- - ----- Method: SpurBootstrap class>>ContextPartPROTOTYPEdoPrimitive:method:receiver:args: (in category 'method prototypes') ----- ContextPartPROTOTYPEdoPrimitive: primitiveIndex method: meth receiver: receiver args: arguments <indirect>!
Item was changed: + ----- Method: SpurBootstrap class>>ContextPartPROTOTYPEisPrimFailToken: (in category 'method prototypes squeak') ----- - ----- Method: SpurBootstrap class>>ContextPartPROTOTYPEisPrimFailToken: (in category 'method prototypes') ----- ContextPartPROTOTYPEisPrimFailToken: anObject <indirect>!
Item was changed: + ----- Method: SpurBootstrap class>>ContextPartPROTOTYPEsend:to:with:lookupIn: (in category 'method prototypes squeak') ----- - ----- Method: SpurBootstrap class>>ContextPartPROTOTYPEsend:to:with:lookupIn: (in category 'method prototypes') ----- ContextPartPROTOTYPEsend: selector to: rcvr with: arguments lookupIn: lookupClass "Simulate the action of sending a message with selector and arguments to rcvr. The argument, lookupClass, is the class in which to lookup the message. This is the receiver's class for normal messages, but for super messages it will be some specific class related to the source method."
| meth primIndex val ctxt | (meth := lookupClass lookupSelector: selector) ifNil: [^self send: #doesNotUnderstand: to: rcvr with: {Message selector: selector arguments: arguments} lookupIn: lookupClass]. (primIndex := meth primitive) > 0 ifTrue: [val := self doPrimitive: primIndex method: meth receiver: rcvr args: arguments. (self isPrimFailToken: val) ifFalse: [^val]]. (selector == #doesNotUnderstand: and: [lookupClass == ProtoObject]) ifTrue: [^self error: 'Simulated message ', arguments first selector, ' not understood']. ctxt := MethodContext sender: self receiver: rcvr method: meth arguments: arguments. primIndex > 0 ifTrue: [ctxt failPrimitiveWith: val]. ^ctxt!
Item was changed: + ----- Method: SpurBootstrap class>>ContextPartPROTOTYPEsend:to:with:super: (in category 'method prototypes squeak') ----- - ----- Method: SpurBootstrap class>>ContextPartPROTOTYPEsend:to:with:super: (in category 'method prototypes') ----- ContextPartPROTOTYPEsend: selector to: rcvr with: arguments super: superFlag "Simulate the action of sending a message with selector arguments to rcvr. The argument, superFlag, tells whether the receiver of the message was specified with 'super' in the source method."
^self send: selector to: rcvr with: arguments lookupIn: (superFlag ifTrue: [self method methodClassAssociation value superclass] ifFalse: [self objectClass: rcvr])!
Item was changed: + ----- Method: SpurBootstrap class>>ContextPartPROTOTYPEtryNamedPrimitiveIn:for:withArgs: (in category 'method prototypes squeak') ----- - ----- Method: SpurBootstrap class>>ContextPartPROTOTYPEtryNamedPrimitiveIn:for:withArgs: (in category 'method prototypes') ----- ContextPartPROTOTYPEtryNamedPrimitiveIn: aCompiledMethod for: aReceiver withArgs: arguments "Invoke the named primitive for aCompiledMethod, answering its result, or, if the primiitve fails, answering the error code." <primitive: 218 error: ec> ec ifNotNil: ["If ec is an integer other than -1 there was a problem with primitive 218, not with the external primitive itself. -1 indicates a generic failure (where ec should be nil) but ec = nil means primitive 218 is not implemented. So interpret -1 to mean the external primitive failed with a nil error code." ec isInteger ifTrue: [ec = -1 ifTrue: [ec := nil] ifFalse: [self primitiveFailed]]]. ^self class primitiveFailTokenFor: ec!
Item was changed: + ----- Method: SpurBootstrap class>>InstructionStreamPROTOTYPEinterpretV3ClosuresExtension:in:for: (in category 'method prototypes old squeak') ----- - ----- Method: SpurBootstrap class>>InstructionStreamPROTOTYPEinterpretV3ClosuresExtension:in:for: (in category 'method prototypes') ----- InstructionStreamPROTOTYPEinterpretV3ClosuresExtension: offset in: method for: client "Since this method has inst var refs the prototype must live in the actual class."
<indirect>!
Item was changed: ----- Method: SpurBootstrap class>>bootstrapPharoImage: (in category 'utilities') ----- bootstrapPharoImage: imageFileBaseName + | oldCompilerClass | + + oldCompilerClass := SmalltalkImage compilerClass. + [ + SmalltalkImage compilerClass: Compiler. + self bootstrapImage: imageFileBaseName type: 'pharo' ] + ensure: [ SmalltalkImage compilerClass: oldCompilerClass ]. + ! - self bootstrapImage: imageFileBaseName type: 'pharo'!
Item was changed: ----- Method: SpurBootstrap>>addMissingClassVars: (in category 'bootstrap image') ----- addMissingClassVars: classVars "Add any missing class vars given classVars, a Dictionary from nonMetaClass to binding. Initialize any classes that get inst vars added." | addClassVarNameSym bindingOfSym | classVars isEmpty ifTrue: [^self]. addClassVarNameSym := self findSymbol: #addClassVarName:. + addClassVarNameSym ifNil: + [addClassVarNameSym := self findSymbol: #addClassVarNamed:]. bindingOfSym := self findSymbol: #bindingOf:. classVars keysAndValuesDo: [:binding :class| Transcript cr; nextPutAll: 'ADDING CLASS VAR '; store: binding key; nextPutAll: ' TO '; print: class; flush. self interpreter: oldInterpreter object: (self oldClassOopFor: class) perform: addClassVarNameSym withArguments: {oldHeap stringForCString: binding key}. literalMap at: binding put: (self interpreter: oldInterpreter object: (self oldClassOopFor: class) perform: bindingOfSym withArguments: {self findSymbol: binding key})]. toBeInitialized := classVars asSet!
Item was changed: ----- Method: SpurBootstrap>>bootstrapImageUsingFileReference: (in category 'public access') ----- bootstrapImageUsingFileReference: imageName | dirName baseName dir | dirName := imageName asFileReference parent fullName. baseName := (imageName endsWith: '.image') ifTrue: [ imageName asFileReference base ] ifFalse: [ (imageName, '.image') asFileReference base ]. dir := dirName asFileReference. self on: (dir / (baseName, '.image')) fullName. [self transform] on: Halt do: [:ex| "suppress halts from the usual suspects (development time halts)" (#(fullGC compactImage) includes: ex signalerContext sender selector) ifTrue: [ex resume] ifFalse: [ex pass]]. self writeSnapshot: (dir / (baseName, '-spur.image')) fullName ofTransformedImage: newHeap headerFlags: oldInterpreter getImageHeaderFlags screenSize: oldInterpreter savedWindowSize. (dir / (baseName, '.changes')) copyTo: (dir / (baseName, '-spur.changes'))!
Item was changed: ----- Method: SpurBootstrap>>checkReshapeOf: (in category 'bootstrap image') ----- checkReshapeOf: ourMethodClasses "Check the shape of all our method classes match the shape of those in the image to be bootstrapped. Use the simulator to redefine any that need it. Does /not/ reshape metaclasses; these we assume are ok." | toReshape | toReshape := Set new. ourMethodClasses do: + [:mc| + (literalMap at: mc binding ifAbsent: []) ifNotNil: + [:binding| + (mc ~~ Character "Character will reshape anyway" + and: [mc instSize ~= (oldHeap instanceSizeOf: (oldHeap fetchPointer: ValueIndex ofObject: binding))]) ifTrue: + [toReshape add: mc]]]. - [:mc| | binding | - binding := literalMap at: mc binding. - self assert: binding ~= oldHeap nilObject. - (mc ~~ Character "Character will reshape anyway" - and: [mc instSize ~= (oldHeap instanceSizeOf: (oldHeap fetchPointer: ValueIndex ofObject: binding))]) ifTrue: - [toReshape add: mc]]. toReshape isEmpty ifTrue: [^self]. "Assume only one class in any subtree needs reshaping. Fast and loose but gets us there for now." toReshape copy do: [:class| toReshape removeAll: (toReshape select: [:ea| ea inheritsFrom: class])]. toReshape do: [:class| Transcript cr; nextPutAll: 'RESHAPING '; print: class; flush. self interpreter: oldInterpreter object: (self oldClassOopFor: Compiler) perform: (self findSymbol: #evaluate:) withArguments: {oldHeap stringForCString: class definition}]!
Item was changed: ----- Method: SpurBootstrap>>findRequiredGlobals (in category 'bootstrap image') ----- findRequiredGlobals "Look for the necessary gobal bindings in the prototype methods in the old image. This has to be done early by sending bindingOf: to Smalltalk. Collect the class hierarchy of all prototypes that access inst vars (non-local prototypes) to check their shapes. Also find out Metaclass, needed for identifying classes." | globals ourMethodClasses classVars bindingOfSym | globals := Set new. ourMethodClasses := Set new. classVars := Dictionary new. self prototypeClassNameMetaSelectorMethodDo: + [:c :m :s :method| | allNonMetaSupers | + (Smalltalk classNamed: c) ifNotNil: + [ :nonMetaClass| + allNonMetaSupers := nonMetaClass withAllSuperclasses. + method methodClass ~= SpurBootstrap class ifTrue: + [ourMethodClasses addAll: allNonMetaSupers]. + globals addAll: (allNonMetaSupers collect: [:sc| sc binding]). + method literals do: + [:l| + (l isVariableBinding and: [l key isSymbol]) ifTrue: + [(Smalltalk bindingOf: l key) == l + ifTrue: [globals add: l] + ifFalse: + [self assert: (nonMetaClass bindingOf: l key) == l. + classVars at: l put: nonMetaClass]]]]]. - [:c :m :s :method| | nonMetaClass allNonMetaSupers | - allNonMetaSupers := (nonMetaClass := Smalltalk classNamed: c) withAllSuperclasses. - method methodClass ~= SpurBootstrap class ifTrue: - [ourMethodClasses addAll: allNonMetaSupers]. - globals addAll: (allNonMetaSupers collect: [:sc| sc binding]). - method literals do: - [:l| - (l isVariableBinding and: [l key isSymbol]) ifTrue: - [(Smalltalk bindingOf: l key) == l - ifTrue: [globals add: l] - ifFalse: - [self assert: (nonMetaClass bindingOf: l key) == l. - classVars at: l put: nonMetaClass]]]]. globals add: Compiler binding. "For potential reshaping in checkReshapeOf:" bindingOfSym := self findSymbol: #bindingOf:. self withExecutableInterpreter: oldInterpreter do: [| toBeAdded | globals do: [:global| | bindingOop | bindingOop := self interpreter: oldInterpreter object: (oldHeap splObj: 8) "Smalltalk" perform: bindingOfSym withArguments: {self findSymbol: global key}. + bindingOop ~= oldHeap nilObject ifTrue: + [literalMap at: global put: bindingOop]]. - self assert: bindingOop ~= oldHeap nilObject. - literalMap at: global put: bindingOop]. toBeAdded := Dictionary new. classVars keysAndValuesDo: [:var :class| | val | (self findSymbol: var key) "New class inst vars may not yet be interned." ifNil: [toBeAdded at: var put: class] ifNotNil: [:varName| val := self interpreter: oldInterpreter object: (self oldClassOopFor: class) perform: bindingOfSym withArguments: {varName}. val ~= oldHeap nilObject ifTrue: [literalMap at: var put: val] ifFalse: [toBeAdded at: var put: class]]]. "May have to redefine to add missing inst vars and/or add any missing class vars." self checkReshapeOf: ourMethodClasses. self addMissingClassVars: toBeAdded]!