Vm-dev September 2013

vm-dev@lists.squeakfoundation.org

31 participants
155 discussions

Re: [Pharo-dev] blog post
by Eliot Miranda 06 Sep '13

06 Sep '13

Hi Stéph, On Fri, Sep 6, 2013 at 9:35 AM, Stéphane Ducasse <stephane.ducasse(a)inria.fr>wrote: > Hi eliot > > This is really good that you write this blog. I read and I saw ephemerons > (excellent because we were discussing them again today with esteban and > igor) > I have some questions that may be are stupid. > - I was wondering if you plan to have a dedicated class space. > Clement told me that in Chrome (but I may be wrong) they have that and in > the class space the classes are not moved. But with the table you are sure > that your index do not change so may be the gain is not important. > exactly. > - Did I get it rid that you want to have a become: that does not > require scanning the full memory? > yes, this is very important for the FFI. I want to be able to pin objects very cheaply, and I think that the way to do that is to a) become: objects in newSpace into pinned objects in oldSpace, and b) have an incremental collector/compactor in oldSpace that doesn't move pinned objects. If objects can be pinned in newSpace I think newSpace will fill up. So... > But with a body as in VW. This is what you mean with the > lazyBecome: and the forwarding pointer? > Here are the relevant paragraphs in SpurMemoryManager's class comment: - lazy become. The JIT's use of inline cacheing provides a cheap way of avoiding scanning the heap as part of a become (which is the simple approach to implementing become in a system with direct pointers). A becomeForward: on a (set of) non-zero-sized object(s) turns the object into a "corpse" or "forwarding object" whose first (non-header) word/slot is replaced by a pointer to the target of the becomeForward:. The corpse's class index is set to one that identifies corpses (let's say classIndex 1), and, because it is a special, hidden class index, will always fail an inline cache test. The inline cache failure code is then responsible for following the forwarding pointer chain (these are Iliffe vectors :) ) and resolving to the actual target. (In the interpreter there needs to be a similar check when probing the method cache). It has yet to be determined exactly how this is done (e.g. change the receiver register and/or stack contents and retry the send, perhaps scanning the current activation). See below on how we deal with becomes on objects with named inst vars. We insist that objects are at least 16 bytes in size (see 8-byte alignment below) so that there will always be space for a forwarding pointer. Since none of the immediate classes can have non-immediate instances and since we allocate the immediate class indices corresponding to their tag pattern (SmallInteger = 1 & 3, Character = 2, SmallFloat = 5?) we can use all the class indices from 0 to 7 for special uses, 0 = free, and e.g. 1 = isForwarded. (and later on) As described earlier the basic idea behind lazy become is to use corpses (forwarding objects) that are followed lazily during GC and inline cache miss. However, a lazy scheme cannot be used on objects with named inst vars without adding checking to all inst var accesses, which we judge too expensive. Instead, when becomming objects with named inst vars, we scan all activations in the stack zone, eagerly becomming these references, and we check for corpses when faulting in a context into the stack zone. Essentially, the invariant is that there are no references to corpses from the receiver slots of stack activations. A detail is whether we allow or forbid pinning of closure indirection vectors, or scan the entire stack of each activation. Using a special class index pun for indirection vectors is a cheap way of preventing their becomming/pinning etc. Although "don't do that" (don't attempt to pin/become indirection vectors) is also an acceptable response. - For Characters since they are immediate (if I got it right) we > could use Unicode directly or am'I wrong? > That's right. This should speed up string access and mean that all characters are unique, so one can use #==. > > Stef > > > > Hi All, > > > > I've just written a blog post on progress with Spur, which is my > nickname for a new memory manager for the Cog VM. I hope it'll be > interesting. > > -- > > best, > > Eliot > > > -- best, Eliot

1 0

VM Maker: Cog-eem.72.mcz
by commits＠source.squeak.org 06 Sep '13

06 Sep '13

Eliot Miranda uploaded a new version of Cog to project VM Maker: http://source.squeak.org/VMMaker/Cog-eem.72.mcz ==================== Summary ==================== Name: Cog-eem.72 Author: eem Time: 5 September 2013, 5:16:44.576 pm UUID: 54b8e936-886e-42ec-8e5e-3442901c6107 Ancestors: Cog-eem.71 Map class format (instSpec) from old to new encoding. Add to the class side of SpurBootstrap prototypes for image methods that must change to function with the new image format. Next step is for the bootstrap to install these methods appropriately. =============== Diff against Cog-eem.71 =============== Item was added: + ----- Method: SpurBootstrap class>>BehaviorPROTOTYPEidentityHash (in category 'method prototypes') ----- + BehaviorPROTOTYPEidentityHash + "Answer a SmallInteger whose value is related to the receiver's identity. + This method must not be overridden. + Primitive. Fails if the receiver is not a Behavior. Essential. + See Object documentation whatIsAPrimitive. + + Do not override." + + <primitive: 175> + self primitiveFailed! Item was added: + ----- Method: SpurBootstrap class>>BehaviorPROTOTYPEinstSize (in category 'method prototypes') ----- + BehaviorPROTOTYPEinstSize + "Answer the number of named instance variables + (as opposed to indexed variables) of the receiver. + Above Cog Spur the class format is + <5 bits inst spec><16 bits inst size>" + ^format bitAnd: 16rFFFF! Item was added: + ----- Method: SpurBootstrap class>>BehaviorPROTOTYPEisBits (in category 'method prototypes') ----- + BehaviorPROTOTYPEisBits + "Answer whether the receiver contains just bits (not pointers). + Above Cog Spur the class format is + <5 bits inst spec><16 bits inst size> + where the 5-bit inst spec is + 0 = 0 sized objects (UndefinedObject True False et al) + 1 = non-indexable objects with inst vars (Point et al) + 2 = indexable objects with no inst vars (Array et al) + 3 = indexable objects with inst vars (MethodContext AdditionalMethodState et al) + 4 = weak indexable objects with inst vars (WeakArray et al) + 5 = weak non-indexable objects with inst vars (ephemerons) (Ephemeron) + 6,7,8 unused + 9 (?) 64-bit indexable + 10 - 11 32-bit indexable + 12 - 15 16-bit indexable + 16 - 23 byte indexable + 24 - 31 compiled method" + ^self instSpec >= 9! Item was added: + ----- Method: SpurBootstrap class>>BehaviorPROTOTYPEisBytes (in category 'method prototypes') ----- + BehaviorPROTOTYPEisBytes + "Answer whether the receiver has 8-bit instance variables. + Above Cog Spur the class format is + <5 bits inst spec><16 bits inst size> + where the 5-bit inst spec is + 0 = 0 sized objects (UndefinedObject True False et al) + 1 = non-indexable objects with inst vars (Point et al) + 2 = indexable objects with no inst vars (Array et al) + 3 = indexable objects with inst vars (MethodContext AdditionalMethodState et al) + 4 = weak indexable objects with inst vars (WeakArray et al) + 5 = weak non-indexable objects with inst vars (ephemerons) (Ephemeron) + 6,7,8 unused + 9 (?) 64-bit indexable + 10 - 11 32-bit indexable + 12 - 15 16-bit indexable + 16 - 23 byte indexable + 24 - 31 compiled method" + ^self instSpec >= 16! Item was added: + ----- Method: SpurBootstrap class>>BehaviorPROTOTYPEisVariable (in category 'method prototypes') ----- + BehaviorPROTOTYPEisVariable + "Answer whether the receiver has indexable variables. + Above Cog Spur the class format is + <5 bits inst spec><16 bits inst size> + where the 5-bit inst spec is + 0 = 0 sized objects (UndefinedObject True False et al) + 1 = non-indexable objects with inst vars (Point et al) + 2 = indexable objects with no inst vars (Array et al) + 3 = indexable objects with inst vars (MethodContext AdditionalMethodState et al) + 4 = weak indexable objects with inst vars (WeakArray et al) + 5 = weak non-indexable objects with inst vars (ephemerons) (Ephemeron) + 6,7,8 unused + 9 (?) 64-bit indexable + 10 - 11 32-bit indexable + 12 - 15 16-bit indexable + 16 - 23 byte indexable + 24 - 31 compiled method" + | instSpec | + instSpec := self instSpec. + ^instSpec >= 2 and: [instSpec ~= 5]! Item was added: + ----- Method: SpurBootstrap class>>CharacterPROTOTYPEasciiValue (in category 'method prototypes') ----- + CharacterPROTOTYPEasciiValue + <primitive: 171> + ^self primitiveFailed! Item was added: + ----- Method: SpurBootstrap class>>CharacterclassPROTOTYPEvalue: (in category 'method prototypes') ----- + CharacterclassPROTOTYPEvalue: anInteger + <primitive: 170> + ^self primitiveFailed! Item was added: + ----- Method: SpurBootstrap class>>ClassBuilderPROTOTYPEformat:variable:words:pointers:weak: (in category 'method prototypes') ----- + ClassBuilderPROTOTYPEformat: nInstVars variable: isVar words: isWords pointers: isPointers weak: isWeak + "Compute the format for the given instance specfication. + Above Cog Spur the class format is + <5 bits inst spec><16 bits inst size> + where the 5-bit inst spec is + 0 = 0 sized objects (UndefinedObject True False et al) + 1 = non-indexable objects with inst vars (Point et al) + 2 = indexable objects with no inst vars (Array et al) + 3 = indexable objects with inst vars (MethodContext AdditionalMethodState et al) + 4 = weak indexable objects with inst vars (WeakArray et al) + 5 = weak non-indexable objects with inst vars (ephemerons) (Ephemeron) + 6,7,8 unused + 9 (?) 64-bit indexable + 10 - 11 32-bit indexable + 12 - 15 16-bit indexable + 16 - 23 byte indexable + 24 - 31 compiled method" + | instSpec | + instSpec := isWeak + ifTrue: [4] + ifFalse: + [isPointers + ifTrue: + [isVar + ifTrue: [nInstVars > 0 ifTrue: [3] ifFalse: [2]] + ifFalse: [nInstVars > 0 ifTrue: [1] ifFalse: [0]]] + ifFalse: [isWords ifTrue: [12] ifFalse: [16]]]. + ^instSpec << 16 + nInstVars! Item was added: + ----- Method: SpurBootstrap class>>ProtoObjectPROTOTYPEscaledIdentityHash (in category 'method prototypes') ----- + ProtoObjectPROTOTYPEscaledIdentityHash + "For identityHash values returned by primitive 75, answer + such values times 2^18. Otherwise, match the existing + identityHash implementation" + + ^self identityHash * 256 "bitShift: 8"! Item was added: + ----- Method: SpurBootstrap class>>SmallIntegerPROTOTYPEasCharacter (in category 'method prototypes') ----- + SmallIntegerPROTOTYPEasCharacter + <primitive: 170> + ^self primitiveFailed! Item was added: + ----- Method: SpurBootstrap class>>SmalltalkImagePROTOTYPEmaxIdentityHash (in category 'method prototypes') ----- + SmalltalkImagePROTOTYPEmaxIdentityHash + "Answer the maximum identityHash value supported by the VM." + <primitive: 176> + ^self primitiveFailed! Item was added: + ----- Method: SpurBootstrap class>>SystemDictionaryPROTOTYPEmaxIdentityHash (in category 'method prototypes') ----- + SystemDictionaryPROTOTYPEmaxIdentityHash + "Answer the maximum identityHash value supported by the VM." + <primitive: 176> + ^self primitiveFailed! Item was changed: ----- Method: SpurBootstrap>>allocateClassTable (in category 'bootstrap') ----- allocateClassTable "Allocate the root of the classTable plus enough pages to accomodate all classes in + the classToIndex map. Don't fill in the entries yet; the classes have yet to be cloned." - the classToIndex map. Don;t fill in the entries yet; the classes have yet to be cloned." | tableRootSize tableRoot page maxSize numPages | tableRootSize := self classTableSize / newHeap classTablePageSize. tableRoot := newHeap allocateSlots: tableRootSize format: newHeap arrayFormat classIndex: newHeap arrayClassIndexPun. self assert: (newHeap numSlotsOf: tableRoot) = tableRootSize. self assert: (newHeap formatOf: tableRoot) = newHeap arrayFormat. self assert: (newHeap classIndexOf: tableRoot) = newHeap arrayClassIndexPun. newHeap nilFieldsOf: tableRoot. "first page is strong" page := newHeap allocateSlots: newHeap classTablePageSize format: newHeap arrayFormat classIndex: newHeap arrayClassIndexPun. self assert: (newHeap numSlotsOf: page) = newHeap classTablePageSize. self assert: (newHeap formatOf: tableRoot) = newHeap arrayFormat. self assert: (newHeap classIndexOf: tableRoot) = newHeap arrayClassIndexPun. + self assert: (newHeap objectAfter: tableRoot limit: newHeap freeStart) = page. - self assert: (newHeap objectAfter: tableRoot limit: newHeap freeStart) = page.. lastClassTablePage := page. newHeap nilFieldsOf: page. newHeap storePointer: 0 ofObject: tableRoot withValue: page. newHeap classTableRootObj: tableRoot. maxSize := classToIndex inject: 0 into: [:a :b| a max: b]. numPages := (maxSize + newHeap classTableMinorIndexMask / newHeap classTablePageSize) truncated. 2 to: numPages do: [:i| page := newHeap allocateSlots: newHeap classTablePageSize format: newHeap weakArrayFormat classIndex: newHeap weakArrayClassIndexPun. self assert: (newHeap numSlotsOf: page) = newHeap classTablePageSize. self assert: (newHeap formatOf: page) = newHeap weakArrayFormat. self assert: (newHeap classIndexOf: page) = newHeap weakArrayClassIndexPun. newHeap nilFieldsOf: page. newHeap storePointer: i - 1 ofObject: tableRoot withValue: page. self assert: (newHeap objectAfter: (newHeap fetchPointer: i - 2 ofObject: tableRoot) limit: newHeap freeStart) = page. lastClassTablePage := page]! Item was changed: ----- Method: SpurBootstrap>>fillInPointerObject:from: (in category 'bootstrap') ----- fillInPointerObject: newObj from: oldObj 0 to: (oldHeap lastPointerOf: oldObj) / oldHeap bytesPerWord - 1 do: [:i| | oldValue newValue | oldValue := oldHeap fetchPointer: i ofObject: oldObj. newValue := (oldHeap isIntegerObject: oldValue) ifTrue: [oldValue] ifFalse: [map at: oldValue ifAbsent: [oldValue = oldHeap characterTable ifTrue: [newHeap nilObject] ifFalse: [self assert: (oldHeap fetchClassOfNonImm: oldValue) = oldHeap classCharacter. newHeap characterObjectOf: (oldHeap integerValueOf: (oldHeap fetchPointer: CharacterValueIndex ofObject: oldValue))]]]. newHeap storePointerUnchecked: i ofObject: newObj + withValue: newValue]. + (classToIndex includesKey: oldObj) ifTrue: + [newHeap + storePointerUnchecked: InstanceSpecificationIndex + ofObject: newObj + withValue: (self newClassFormatFor: oldObj)]! - withValue: newValue]! Item was added: + ----- Method: SpurBootstrap>>newClassFormatFor: (in category 'bootstrap') ----- + newClassFormatFor: oldClassObj + "OLD: <2 bits=instSize//64><5 bits=cClass><4 bits=instSpec><6 bits=instSize\\64><1 bit=0> + NEW: <5 bits inst spec><16 bits inst size>" + | oldFormat instSize newInstSpec | + oldFormat := oldHeap formatOfClass: oldClassObj. "N.B. SmallInteger with tag bit cleared" + oldFormat := oldFormat >> 1. + instSize := ((oldFormat bitShift: -10) bitAnd: 16rC0) + ((oldFormat bitShift: -1) bitAnd: 16r3F) - 1. + newInstSpec := #(0 1 2 3 4 5 6 7 16 16 16 16 24 24 24 24) at: ((oldFormat bitShift: -7) bitAnd: 16rF) + 1. + ^newHeap integerObjectOf: newInstSpec << 16 + instSize!

1 0

VM Maker: VMMaker.oscog-eem.351.mcz
by commits＠source.squeak.org 06 Sep '13

06 Sep '13

Eliot Miranda uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker.oscog-eem.351.mcz ==================== Summary ==================== Name: VMMaker.oscog-eem.351 Author: eem Time: 5 September 2013, 4:53:56.386 pm UUID: 46f2620a-7a44-4fb9-98c7-ffa9ee43f01f Ancestors: VMMaker.oscog-eem.350 Add primitives for encoding and decoding immediate characters. Base VM knowing whether immediate characters exist or not on CharacterTableIndex being nil or not. =============== Diff against VMMaker.oscog-eem.350 =============== Item was added: + ----- Method: InterpreterPrimitives>>primitiveAsCharacter (in category 'object access primitives') ----- + primitiveAsCharacter + | characterCode characterObject | + characterCode := self stackTop. + ((objectMemory isIntegerObject: characterCode) + and: [characterCode := objectMemory integerValueOf: characterCode. + objectMemory isInRangeCharacterCode: characterCode]) ifFalse: + [^self primitiveFailFor: (argumentCount = 0 + ifTrue: [PrimErrBadReceiver] + ifFalse: [PrimErrBadArgument])]. + characterObject := self characterForAscii: characterCode. + self pop: argumentCount + 1 thenPush: characterObject! Item was added: + ----- Method: InterpreterPrimitives>>primitiveCharacterValue (in category 'object access primitives') ----- + primitiveCharacterValue + | characterCode characterObject | + characterObject := self stackTop. + characterCode := CharacterTable + ifNil: [objectMemory integerObjectOf: (objectMemory characterValueOf: characterObject)] + ifNotNil: [objectMemory fetchPointer: CharacterValueIndex ofObject: characterObject]. + "the Character must be the receiver for safety" + self pop: 1 thenPush: characterCode! Item was added: + ----- Method: ObjectMemory>>isInRangeCharacterCode: (in category 'interpreter access') ----- + isInRangeCharacterCode: characterCode + ^characterCode >= 0 and: [characterCode <= 255]! Item was added: + ----- Method: SpurMemoryManager>>characterValueOf: (in category 'immediates') ----- + characterValueOf: oop + "Immediate characters are unsigned" + ^(self cCoerceSimple: oop to: #'unsigned long') >> self numTagBits! Item was added: + ----- Method: SpurMemoryManager>>isInRangeCharacterCode: (in category 'immediates') ----- + isInRangeCharacterCode: characterCode + ^characterCode >= 0 and: [characterCode < (2 raisedTo: 30)]! Item was changed: ----- Method: StackInterpreter class>>initializePrimitiveTable (in category 'initialization') ----- (excessive size, no diff calculated) Item was changed: ----- Method: StackInterpreter>>characterForAscii: (in category 'indexing primitive support') ----- + characterForAscii: ascii "Above ObjectMemory, arg must lie in range 0-255!!" - characterForAscii: ascii "Arg must lie in range 0-255!!" <inline: true> + ^CharacterTable + ifNil: [objectMemory characterObjectOf: ascii] + ifNotNil: [objectMemory fetchPointer: ascii ofObject: objectMemory characterTable]! - ^ objectMemory fetchPointer: ascii ofObject: (objectMemory splObj: CharacterTable)!

1 0

Re: [squeak-dev] SqueakSSL plugin that ships with Cog faulty? was: Re: all-in-one not loading the SqueakSSL plugin (or webclient + ssl not working in all-in-one)
by Eliot Miranda 06 Sep '13

06 Sep '13

On Thu, Sep 5, 2013 at 2:07 PM, Paul DeBruicker <pdebruic(a)gmail.com> wrote: > the SqueakSSL plugin that ships with the VM doesn't load into the image > when > using Cog 2714, 2732, or 2776 on linux or xp with Squeak or Pharo 1.4. > > > If I use the one from here: https://code.google.com/p/squeakssl/ then > everything works fine. > > > Not sure why that is or what to do about it. > Help me fix it, please!! i.e. help me change the code in VMMaker.oscog and/or http://www.squeakvm.org/svn/squeak/branches/Cog so that the damn thing works :-) > > I think in the next all-in-one I can add in the google code version of the > plugin. > > > > > > > -- > View this message in context: > http://forum.world.st/all-in-one-not-loading-the-SqueakSSL-plugin-or-webcli… > Sent from the Squeak - Dev mailing list archive at Nabble.com. > > -- best, Eliot

1 0

VM Maker: VMMaker.oscog-eem.350.mcz
by commits＠source.squeak.org 06 Sep '13

06 Sep '13

Eliot Miranda uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker.oscog-eem.350.mcz ==================== Summary ==================== Name: VMMaker.oscog-eem.350 Author: eem Time: 5 September 2013, 3:09:03.974 pm UUID: 10d870ce-a680-45bb-a981-a55a5f6dfe9f Ancestors: VMMaker.oscog-eem.349 Replace explicit enumeration by inlined allObjectsDo: now that a) Slang inlines literal blocks, and b) Spur has a segmented memory, preventing simple enumeration. Remove C code from printOopShortInner: so that it's inlined as requested. =============== Diff against VMMaker.oscog-eem.349 =============== Item was removed: - ----- Method: CogVMSimulator>>allObjectsDo: (in category 'debug support') ----- - allObjectsDo: objBlock - - | oop | - oop := objectMemory firstObject. - [oop < objectMemory freeStart] whileTrue: - [(objectMemory isFreeObject: oop) ifFalse: - [objBlock value: oop]. - oop := objectMemory objectAfter: oop]! Item was changed: ----- Method: CogVMSimulator>>testPCMapping (in category 'testing') ----- testPCMapping + objectMemory allObjectsDo: - self allObjectsDo: [:o| ((objectMemory isCompiledMethod: o) and: [self methodShouldBeCogged: o]) ifTrue: [(self methodHasCogMethod: o) ifFalse: [[([cogit cog: o selector: objectMemory nilObject] on: Error do: [:ex| ex messageText = 'This won''t work...' ifTrue: [ex resumeUnchecked: nil]. ex pass]) isNil and: [cogCompiledCodeCompactionCalledFor]] whileTrue: [cogMethodZone clearCogCompiledCode. cogCompiledCodeCompactionCalledFor := false]]. (self methodHasCogMethod: o) ifTrue: [transcript nextPut: $.; flush. cogit testMcToBcPcMappingForMethod: (self cogMethodOf: o)] ifFalse: [transcript nextPutAll: 'failed to compile method '; print: o; cr; flush]]]! Item was removed: - ----- Method: InterpreterSimulator>>allObjectsDo: (in category 'debug support') ----- - allObjectsDo: objBlock - - | oop | - oop := self firstObject. - [oop < endOfMemory] whileTrue: - [(self isFreeObject: oop) - ifFalse: [objBlock value: oop]. - oop := self objectAfter: oop]. - ! Item was changed: + ----- Method: NewObjectMemory>>allObjectsDo: (in category 'object enumeration') ----- - ----- Method: NewObjectMemory>>allObjectsDo: (in category 'debug support') ----- allObjectsDo: aBlock + <inline: true> - <doNotGenerate> | oop | oop := self firstObject. [oop < freeStart] whileTrue: [(self isFreeObject: oop) ifFalse: [aBlock value: oop]. oop := self objectAfterWhileForwarding: oop]! Item was removed: - ----- Method: NewspeakInterpreterSimulator>>allObjectsDo: (in category 'debug support') ----- - allObjectsDo: objBlock - - | oop | - oop := self firstObject. - [oop < endOfMemory] whileTrue: - [(self isFreeObject: oop) - ifFalse: [objBlock value: oop]. - oop := self objectAfter: oop]. - ! Item was added: + ----- Method: ObjectMemory>>allObjectsDo: (in category 'object enumeration') ----- + allObjectsDo: aBlock + <inline: true> + | oop | + oop := self firstObject. + [oop < freeBlock] whileTrue: + [(self isFreeObject: oop) ifFalse: + [aBlock value: oop]. + oop := self objectAfterWhileForwarding: oop]! Item was changed: ----- Method: SpurMemoryManager>>allNewSpaceObjectsDo: (in category 'object enumeration') ----- allNewSpaceObjectsDo: aBlock + <inline: true> | prevObj prevPrevObj objOop limit | prevPrevObj := prevObj := nil. "After a scavenge eden is empty, futureSpace is empty, and all newSpace objects are in pastSpace. Objects are allocated in eden. So enumerate only eden and pastSpace." objOop := self objectStartingAt: scavenger eden start. [objOop < freeStart] whileTrue: [(self isFreeObject: objOop) ifFalse: [aBlock value: objOop]. prevPrevObj := prevObj. prevObj := objOop. objOop := self objectAfter: objOop limit: freeStart]. objOop := self objectStartingAt: scavenger pastSpace start. limit := scavenger pastSpace limit. [objOop < limit] whileTrue: [(self isFreeObject: objOop) ifFalse: [aBlock value: objOop]. prevPrevObj := prevObj. prevObj := objOop. objOop := self objectAfter: objOop limit: limit]. prevPrevObj class. prevObj class! Item was changed: ----- Method: SpurMemoryManager>>allObjectsDo: (in category 'object enumeration') ----- allObjectsDo: aBlock + <inline: true> self allOldSpaceObjectsDo: aBlock. self allNewSpaceObjectsDo: aBlock! Item was changed: ----- Method: SpurMemoryManager>>allOldSpaceObjectsDo: (in category 'object enumeration') ----- allOldSpaceObjectsDo: aBlock + <inline: true> - <doNotGenerate> | prevObj prevPrevObj objOop | prevPrevObj := prevObj := nil. objOop := self firstObject. [self assert: objOop \\ self allocationUnit = 0. objOop < freeOldSpaceStart] whileTrue: [(self isFreeObject: objOop) ifFalse: [aBlock value: objOop]. prevPrevObj := prevObj. prevObj := objOop. objOop := self objectAfter: objOop limit: freeOldSpaceStart]. prevPrevObj class. prevObj class! Item was changed: ----- Method: StackInterpreter>>allAccessibleObjectsOkay (in category 'debug support') ----- allAccessibleObjectsOkay "Ensure that all accessible objects in the heap are okay." + | ok | - | ok oop | ok := true. + objectMemory allObjectsDo: + [:oop| + ok := ok & (self okayFields: oop)]. - oop := objectMemory firstAccessibleObject. - [oop = nil] whileFalse: - [ok := ok & (self okayFields: oop). - oop := objectMemory accessibleObjectAfter: oop]. ^ok! Item was changed: ----- Method: StackInterpreter>>checkAllAccessibleObjectsOkay (in category 'debug support') ----- checkAllAccessibleObjectsOkay "Ensure that all accessible objects in the heap are okay." <api> + | ok | - | ok oop | ok := true. + objectMemory allObjectsDo: + [:oop| ok := ok & (self checkOkayFields: oop)]. - oop := objectMemory firstAccessibleObject. - [oop = nil] whileFalse: - [ok := ok & (self checkOkayFields: oop). - oop := objectMemory accessibleObjectAfter: oop]. ^ok! Item was changed: ----- Method: StackInterpreter>>printOopShortInner: (in category 'debug printing') ----- printOopShortInner: oop | classOop name nameLen | <var: #name type: #'char *'> <inline: true> (objectMemory isImmediate: oop) ifTrue: [(objectMemory isImmediateCharacter: oop) ifTrue: + [self printChar: $$; + printChar: (objectMemory characterValueOf: oop); + printChar: $(; + printHex: (objectMemory integerValueOf: oop); + printChar: $). - [self - cCode: 'printf("$%c(%ld)", (long)characterValueOf(oop), (long)characterValueOf(oop))' - inSmalltalk: - [self printChar: $$; - printChar: (objectMemory characterValueOf: oop); - printChar: $(; - printHex: (objectMemory integerValueOf: oop); - printChar: $)]. ^nil]. self printNum: (objectMemory integerValueOf: oop); printChar: $(; printHex: (objectMemory integerValueOf: oop); printChar: $). ^nil]. (objectMemory addressCouldBeObj: oop) ifFalse: [self print: ((oop bitAnd: objectMemory allocationUnit - 1) ~= 0 ifTrue: [' is misaligned'] ifFalse: [' is not on the heap']); cr. ^nil]. (self isFloatObject: oop) ifTrue: [self printFloat: (self dbgFloatValueOf: oop). ^nil]. classOop := objectMemory fetchClassOfNonImm: oop. (objectMemory addressCouldBeObj: classOop) ifFalse: [self print: 'a ??'. ^nil]. (objectMemory sizeBitsOf: classOop) = metaclassSizeBits ifTrue: [self printNameOfClass: oop count: 5. ^nil]. oop = objectMemory nilObject ifTrue: [self print: 'nil'. ^nil]. oop = objectMemory trueObject ifTrue: [self print: 'true'. ^nil]. oop = objectMemory falseObject ifTrue: [self print: 'false'. ^nil]. nameLen := self lengthOfNameOfClass: classOop. nameLen = 0 ifTrue: [self print: 'a ??'. ^nil]. name := self nameOfClass: classOop. nameLen = 10 ifTrue: [(self str: name n: 'ByteString' cmp: 10) not "strncmp is weird" ifTrue: [self printChar: $'; printStringOf: oop; printChar: $'. ^nil]. (self str: name n: 'ByteSymbol' cmp: 10) not "strncmp is weird" ifTrue: [self printChar: $#; printStringOf: oop. ^nil]]. (nameLen = 9 and: [(self str: name n: 'Character' cmp: 9) not]) ifTrue: [self printChar: $$; printChar: (objectMemory integerValueOf: (objectMemory fetchPointer: 0 ofObject: oop)). ^nil]. + self print: 'a(n) '. + 1 to: nameLen do: [:i| self printChar: (name at: i)]. - self cCode: [self prin: 'a(n) %.*s' t: nameLen f: name] - inSmalltalk: [self print: 'a(n) '; print: name]. "Try to spot association-like things; they're all subclasses of LookupKey" ((objectMemory instanceSizeOf: classOop) = (ValueIndex + 1) and: [(self superclassOf: classOop) = (self superclassOf: (objectMemory fetchClassOfNonImm: (objectMemory splObj: SchedulerAssociation))) and: [objectMemory isBytes: (objectMemory fetchPointer: KeyIndex ofObject: oop)]]) ifTrue: [self space; printOopShort: (objectMemory fetchPointer: KeyIndex ofObject: oop); print: ' -> '; printHex: (objectMemory fetchPointer: ValueIndex ofObject: oop)]! Item was removed: - ----- Method: StackInterpreterSimulator>>allObjectsDo: (in category 'debug support') ----- - allObjectsDo: objBlock - - | oop | - oop := objectMemory firstObject. - [oop < objectMemory endOfMemory] whileTrue: - [(objectMemory isFreeObject: oop) - ifFalse: [objBlock value: oop]. - oop := objectMemory objectAfter: oop]. - !

1 0

VM Maker: VMMaker.oscog-eem.349.mcz
by commits＠source.squeak.org 05 Sep '13

05 Sep '13

Eliot Miranda uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker.oscog-eem.349.mcz ==================== Summary ==================== Name: VMMaker.oscog-eem.349 Author: eem Time: 5 September 2013, 2:21:47.363 pm UUID: bdefa809-bedc-4e5d-ae05-854c29e3dfde Ancestors: VMMaker.oscog-eem.348 Fix a bad bug with Spur's identityHash (was assigning the classIndex!!). Add more protocol (e.g. is:instanceOf:compactClassIndex:). Fix more printing code in the interpreter to use addressCouldBeObj: et al, instead of explicit between: startOfMemory and: freeStart. Add StackInterpreter inst var methodDictionaryLinearSearchLimit to allow an un-rehashed image to run. =============== Diff against VMMaker.oscog-eem.348 =============== Item was changed: CogClass subclass: #SpurMemoryManager (excessive size, no diff calculated) Item was added: + ----- Method: SpurMemoryManager class>>initializeObjectHeaderConstants (in category 'class initialization') ----- + initializeObjectHeaderConstants + + BytesPerWord ifNil: [BytesPerWord := 4]. "May get called on fileIn, so supply default" + BaseHeaderSize := 8 "Alas so much of the VM uses BaseheaderSize explicitly we don't (yet) make it a message."! Item was changed: ----- Method: SpurMemoryManager class>>initializeWithOptions: (in category 'class initialization') ----- initializeWithOptions: optionsDictionary "SpurMemoryManager initializeWithOptions: Dictionary new" self initBytesPerWord: (self == SpurMemoryManager ifTrue: [optionsDictionary at: #BytesPerWord ifAbsent: [4]] ifFalse: [self bytesPerWord]). BytesPerOop := optionsDictionary at: #BytesPerOop ifAbsent: [BytesPerWord]. self initializeSpecialObjectIndices. self initializeCompactClassIndices. + self initializePrimitiveErrorCodes. + self initializeObjectHeaderConstants! - self initializePrimitiveErrorCodes.! Item was added: + ----- Method: SpurMemoryManager>>fetchByte:ofObject: (in category 'object access') ----- + fetchByte: byteIndex ofObject: objOop + <api> + ^self byteAt: objOop + self baseHeaderSize + byteIndex! Item was changed: ----- Method: SpurMemoryManager>>fetchClassOf: (in category 'object access') ----- fetchClassOf: oop | tagBits | + (tagBits := oop bitAnd: self tagMask) ~= 0 ifTrue: - (tagBits := oop bitAnd: self tagMask) = 0 ifTrue: [^self fetchPointer: tagBits ofObject: classTableFirstPage]. ^self classAtIndex: (self classIndexOf: oop)! Item was added: + ----- Method: SpurMemoryManager>>fixedFieldsOf:format:length: (in category 'object format') ----- + fixedFieldsOf: objOop format: fmt length: wordLength + " + NOTE: This code supports the backward-compatible extension to 8 bits of instSize. + When we revise the image format, it should become... + ^ (classFormat >> 2 bitAnd: 16rFF) - 1 + " + | class classFormat | + <inline: true> + <asmLabel: false> + ((fmt > 4) or: [fmt = 2]) ifTrue: [^0]. "indexable fields only" + fmt < 2 ifTrue: [^wordLength]. "fixed fields only (zero or more)" + self flag: #fixme. "Must munge class formats now..." + "fmt = 3 or 4: mixture of fixed and indexable fields, so must look at class format word" + class := self fetchClassOfNonImm: objOop. + classFormat := self formatOfClass: class. + ^(classFormat >> 11 bitAnd: 16rC0) + (classFormat >> 2 bitAnd: 16r3F) - 1! Item was changed: ----- Method: SpurMemoryManager>>hashBitsOf: (in category 'header access') ----- hashBitsOf: objOop self flag: #endianness. + ^(self longAt: objOop + 4) bitAnd: self identityHashHalfWordMask! - ^(self longAt: objOop) bitAnd: self identityHashHalfWordMask! Item was changed: ----- Method: SpurMemoryManager>>headerForSlots:format:classIndex: (in category 'header format') ----- headerForSlots: numSlots format: formatField classIndex: classIndex "The header format in LSB is + MSB: | 8: numSlots | (on a byte boundary) - MSB: | 8: slotSize | (on a byte boundary) | 2 bits | | 22: identityHash | (on a word boundary) | 3 bits | | 5: format | (on a byte boundary) | 2 bits | | 22: classIndex | (on a word boundary) : LSB The remaining bits (7) need to be used for isGrey isMarked isRemembered isPinned isImmutable leaving 2 unused bits." + <returnTypeC: #usqLong> ^ (numSlots << self numSlotsFullShift) + (formatField << self formatShift) + classIndex! Item was added: + ----- Method: SpurMemoryManager>>is:instanceOf:compactClassIndex: (in category 'object access') ----- + is: oop instanceOf: classOop compactClassIndex: compactClassIndex + "Answer if oop is an instance of the given class. If the class has a (non-zero) + compactClassIndex use that to speed up the check. N.B. Inlining should + result in classOop not being accessed if oop's compact class index and + compactClassIndex are non-zero." + + <inline: true> + (self isImmediate: oop) ifTrue: + [^false]. + + ^self isClassOfNonImm: oop equalTo: classOop compactClassIndex: compactClassIndex! Item was added: + ----- Method: SpurMemoryManager>>isClassOfNonImm:equalTo:compactClassIndex: (in category 'object access') ----- + isClassOfNonImm: oop equalTo: classOop compactClassIndex: knownClassIndex + "Answer if the given (non-immediate) object is an instance of the given class + that may have a knownClassIndex (if knownClassIndex is non-zero). This method + is misnamed given SPur's architecture (where all objects have ``compact'' class indices) + but is so-named for compatibility with ObjectMemory. + N.B. Inlining and/or compiler optimization should result in classOop not being + accessed if knownClassIndex is non-zero." + + | ccIndex | + <inline: true> + <asmLabel: false> + self assert: (self isImmediate: oop) not. + + ccIndex := self classIndexOf: oop. + knownClassIndex ~= 0 ifTrue: + [^knownClassIndex = ccIndex]. + ^classOop = (self classAtIndex: ccIndex)! Item was added: + ----- Method: SpurMemoryManager>>isImmediateCharacter: (in category 'object testing') ----- + isImmediateCharacter: oop + ^(oop bitAnd: self tagMask) = 2! Item was changed: ----- Method: SpurMemoryManager>>isIntegerObject: (in category 'object testing') ----- isIntegerObject: oop (#( makeBaseFrameFor: quickFetchInteger:ofObject: frameOfMarriedContext: addressCouldBeClassObj: + isMarriedOrWidowedContext: + shortPrint:) includes: thisContext sender method selector) ifFalse: - isMarriedOrWidowedContext:) includes: thisContext sender method selector) ifFalse: [self halt]. ^(oop bitAnd: 1) ~= 0! Item was changed: ----- Method: SpurMemoryManager>>setHashBitsOf:to: (in category 'header access') ----- setHashBitsOf: objOop to: hash + self flag: #endianness. self assert: (hash between: 0 and: self identityHashHalfWordMask). + self longAt: objOop + 4 + put: ((self longAt: objOop + 4) bitClear: self identityHashHalfWordMask) + hash! - self longAt: objOop - put: ((self longAt: objOop) bitClear: self identityHashHalfWordMask) + hash! Item was changed: InterpreterPrimitives subclass: #StackInterpreter + instanceVariableNames: 'currentBytecode bytecodeSetSelector localFP localIP localSP stackLimit stackPage stackPages method instructionPointer stackPointer framePointer localReturnValue extA extB primitiveFunctionPointer methodCache atCache lkupClass methodDictLinearSearchLimit highestRunnableProcessPriority nextWakeupUsecs nextPollUsecs inIOProcessEvents interruptKeycode interruptPending savedWindowSize imageHeaderFlags fullScreenFlag deferDisplayUpdates pendingFinalizationSignals extraVMMemory interpreterProxy showSurfaceFn primitiveTable externalPrimitiveTable externalPrimitiveTableFirstFreeIndex overflowedPage extraFramesToMoveOnOverflow globalSessionID jmpBuf jmpDepth suspendedCallbacks suspendedMethods numStackPages desiredNumStackPages desiredEdenBytes classNameIndex thisClassIndex metaclassSizeBits interruptCheckChain suppressHeartbeatFlag breakSelector breakSelectorLength longRunningPrimitiveCheckMethod longRunningPrimitiveCheckSemaphore longRunningPrimitiveStartUsecs longRunningPrimitiveStopUsecs longRunningPrimitiveGCUsecs longRunningPrimitiveCheckSequenceNumber longRunningPrimitiveSignalUndelivered tempOop statForceInterruptCheck statStackOverflow statStackPageDivorce statCheckForEvents statProcessSwitch statIOProcessEvents theUnknownShort imageFloatsBigEndian maxExtSemTabSizeSet lastMethodCacheProbeWrite statPendingFinalizationSignals gcSemaphoreIndex classByteArrayCompactIndex' - instanceVariableNames: 'currentBytecode bytecodeSetSelector localFP localIP localSP stackLimit stackPage stackPages method instructionPointer stackPointer framePointer localReturnValue extA extB primitiveFunctionPointer methodCache atCache lkupClass highestRunnableProcessPriority nextWakeupUsecs nextPollUsecs inIOProcessEvents interruptKeycode interruptPending savedWindowSize imageHeaderFlags fullScreenFlag deferDisplayUpdates pendingFinalizationSignals extraVMMemory interpreterProxy showSurfaceFn primitiveTable externalPrimitiveTable externalPrimitiveTableFirstFreeIndex overflowedPage extraFramesToMoveOnOverflow globalSessionID jmpBuf jmpDepth suspendedCallbacks suspendedMethods numStackPages desiredNumStackPages desiredEdenBytes classNameIndex thisClassIndex metaclassSizeBits interruptCheckChain suppressHeartbeatFlag breakSelector breakSelectorLength longRunningPrimitiveCheckMethod longRunningPrimitiveCheckSemaphore longRunningPrimitiveStartUsecs longRunningPrimitiveStopUsecs longRunningPrimitiveGCUsecs longRunningPrimitiveCheckSequenceNumber longRunningPrimitiveSignalUndelivered tempOop statForceInterruptCheck statStackOverflow statStackPageDivorce statCheckForEvents statProcessSwitch statIOProcessEvents theUnknownShort imageFloatsBigEndian maxExtSemTabSizeSet lastMethodCacheProbeWrite statPendingFinalizationSignals gcSemaphoreIndex classByteArrayCompactIndex' classVariableNames: 'AtCacheEntries AtCacheFixedFields AtCacheFmt AtCacheMask AtCacheOop AtCacheSize AtCacheTotalSize AtPutBase BytecodeTable CacheProbeMax DirBadPath DirEntryFound DirNoMoreEntries DumpStackOnLowSpace EnclosingMixinIndex EnclosingObjectIndex FailImbalancedPrimitives HeaderFlagBitPosition MaxExternalPrimitiveTableSize MaxJumpBuf MaxPrimitiveIndex MaxQuickPrimitiveIndex MixinIndex PrimitiveExternalCallIndex PrimitiveTable' poolDictionaries: 'VMBasicConstants VMMethodCacheConstants VMObjectIndices VMSqueakClassIndices VMSqueakV3BytecodeConstants VMSqueakV3ObjectRepresentationConstants VMStackFrameOffsets' category: 'VMMaker-Interpreter'! !StackInterpreter commentStamp: '<historical>' prior: 0! This class is a complete implementation of the Smalltalk-80 virtual machine, derived originally from the Blue Book specification but quite different in some areas. This VM supports Closures but *not* old-style BlockContexts. It has been modernized with 32-bit pointers, better management of Contexts (see next item), and attention to variable use that allows the CCodeGenerator (qv) to keep, eg, the instruction pointer and stack pointer in registers as well as keeping most simple variables in a global array that seems to improve performance for most platforms. The VM does not use Contexts directly. Instead Contexts serve as proxies for a more conventional stack format that is invisible to the image. There is considerable explanation at http://www.mirandabanda.org/cogblog/2009/01/14/under-cover-contexts-and-the…. The VM maintains a fixed-size stack zone divided into pages, each page being capable of holding several method/block activations. A send establishes a new frame in the current stack page, a return returns to the previous frame. This eliminates allocation/deallocation of contexts and the moving of receiver and arguments from caller to callee on each send/return. Contexts are created lazily when an activation needs a context (creating a block, explicit use of thisContext, access to sender when sender is a frame, or linking of stack pages together). Contexts are either conventional and heap-resident ("single") or "married" and serve as proxies for their corresponding frame or "widowed", meaning that their spouse frame has been returned from (died). A married context is specially marked (more details in the code) and refers to its frame. Likewise a married frame is specially marked and refers to its context. In addition to SmallInteger arithmetic and Floats, the VM supports logic on 32-bit PositiveLargeIntegers, thus allowing it to simulate itself much more effectively than would otherwise be the case. NOTE: Here follows a list of things to be borne in mind when working on this code, or when making changes for the future. 1. There are a number of things that should be done the next time we plan to release a completely incompatible image format. These include unifying the instanceSize field of the class format word -- see instantiateClass:indexableSize:, and unifying the bits of the method primitive index (if we decide we need more than 512, after all) -- see primitiveIndexOf:. Also, contexts should be given a special format code (see next item). 2. There are several fast checks for contexts (see isContextHeader: and isMethodContextHeader:) which will fail if the compact class indices of BlockContext or MethodContext change. This is necessary because the oops may change during a compaction when the oops are being adjusted. It's important to be aware of this when writing a new image using the SystemTracer. A better solution would be to reserve one of the format codes for Contexts only. 3. We have made normal files tolerant to size and positions up to 32 bits. This has not been done for async files, since they are still experimental. The code in size, at: and at:put: should work with sizes and indices up to 31 bits, although I have not tested it (di 12/98); it might or might not work with 32-bit sizes. 4. Note that 0 is used in a couple of places as an impossible oop. This should be changed to a constant that really is impossible (or perhaps there is code somewhere that guarantees it --if so it should be put in this comment). The places include the method cache and the at cache. 5. Moving to a 2 bit immediate tag and having immediate Characters is a good choice for Unicode and the JIT 6. If Eliot Miranda's 2 word header scheme is acceptable in terms of footprint (we estimate about a 10% increase in image size with about 35 reclaimed by better representation of CompiledMethod - loss of MethodProperties) then the in-line cache for the JIT is simplified, class access is faster and header access is the same in 32-bit and full 64-bit images.! Item was changed: ----- Method: StackInterpreter>>initializeInterpreter: (in category 'initialization') ----- initializeInterpreter: bytesToShift "Initialize Interpreter state before starting execution of a new image." interpreterProxy := self sqGetInterpreterProxy. self dummyReferToProxy. objectMemory initializeObjectMemory: bytesToShift. self checkAssumedCompactClasses. primFailCode := 0. self initializeExtraClassInstVarIndices. stackLimit := 0. "This is also the initialization flag for the stack system." stackPage := overflowedPage := 0. extraFramesToMoveOnOverflow := 0. method := objectMemory nilObject. self cCode: [self cppIf: MULTIPLEBYTECODESETS ifTrue: [bytecodeSetSelector := 0]] inSmalltalk: [bytecodeSetSelector := 0]. messageSelector := objectMemory nilObject. newMethod := objectMemory nilObject. lkupClass := objectMemory nilObject. + methodDictLinearSearchLimit := 8. self flushMethodCache. self flushAtCache. self initialCleanup. highestRunnableProcessPriority := 0. nextProfileTick := 0. profileSemaphore := objectMemory nilObject. profileProcess := objectMemory nilObject. profileMethod := objectMemory nilObject. nextPollUsecs := 0. nextWakeupUsecs := 0. tempOop := 0. interruptKeycode := 2094. "cmd-. as used for Mac but no other OS" interruptPending := false. inIOProcessEvents := 0. deferDisplayUpdates := false. pendingFinalizationSignals := statPendingFinalizationSignals := 0. globalSessionID := 0. [globalSessionID = 0] whileTrue: [globalSessionID := self cCode: 'time(NULL) + ioMSecs()' inSmalltalk: [(Random new next * SmallInteger maxVal) asInteger]]. jmpDepth := 0. longRunningPrimitiveStartUsecs := longRunningPrimitiveStopUsecs := 0. maxExtSemTabSizeSet := false. statForceInterruptCheck := 0. statStackOverflow := 0. statCheckForEvents := 0. statProcessSwitch := 0. statIOProcessEvents := 0. statStackPageDivorce := 0! Item was changed: ----- Method: StackInterpreter>>lookupMethodInDictionary: (in category 'message sending') ----- lookupMethodInDictionary: dictionary + "This method lookup tolerates integers as Dictionary keys to support - "This method lookup tolerates integers as Dictionary keys to suoport execution of images in which Symbols have been compacted out." | length index mask wrapAround nextSelector methodArray | <inline: true> <asmLabel: false> length := objectMemory fetchWordLengthOf: dictionary. mask := length - SelectorStart - 1. + "Use linear search on small dictionaries; its cheaper. + Also the limit can be set to force linear search of all dictionaries, which supports the + booting of images that need rehashing (e.g. because a tracer has generated an image + with different hashes but hasn't rehashed it yet.)" + mask <= methodDictLinearSearchLimit ifTrue: + [index := 0. + [index <= mask] whileTrue: + [nextSelector := objectMemory fetchPointer: index ofObject: dictionary. + nextSelector = messageSelector ifTrue: + [methodArray := objectMemory fetchPointer: MethodArrayIndex ofObject: dictionary. + newMethod := objectMemory fetchPointer: index - SelectorStart ofObject: methodArray. + ^true]. + index := index + 1]. + ^false]. + index := SelectorStart + (mask bitAnd: ((objectMemory isImmediate: messageSelector) - index := SelectorStart + (mask bitAnd: ((objectMemory isIntegerObject: messageSelector) ifTrue: [objectMemory integerValueOf: messageSelector] ifFalse: [objectMemory hashBitsOf: messageSelector])). "It is assumed that there are some nils in this dictionary, and search will stop when one is encountered. However, if there are no nils, then wrapAround will be detected the second time the loop gets to the end of the table." wrapAround := false. [true] whileTrue: [nextSelector := objectMemory fetchPointer: index ofObject: dictionary. nextSelector = objectMemory nilObject ifTrue: [^ false]. nextSelector = messageSelector ifTrue: [methodArray := objectMemory fetchPointer: MethodArrayIndex ofObject: dictionary. newMethod := objectMemory fetchPointer: index - SelectorStart ofObject: methodArray. ^true]. index := index + 1. index = length ifTrue: [wrapAround ifTrue: [^false]. wrapAround := true. index := SelectorStart]]. + ^false "for Slang"! Item was changed: ----- Method: StackInterpreter>>printNameOfClass:count: (in category 'debug printing') ----- printNameOfClass: classOop count: cnt "Details: The count argument is used to avoid a possible infinite recursion if classOop is a corrupted object." <inline: false> (classOop = 0 or: [cnt <= 0]) ifTrue: [^self print: 'bad class']. ((objectMemory sizeBitsOf: classOop) = metaclassSizeBits + and: [metaclassSizeBits > (thisClassIndex * BytesPerOop)]) "(Metaclass instSize * 4)" - and: [metaclassSizeBits > (thisClassIndex * BytesPerWord)]) "(Metaclass instSize * 4)" ifTrue: [self printNameOfClass: (objectMemory fetchPointer: thisClassIndex ofObject: classOop) count: cnt - 1. self print: ' class'] ifFalse: [self printStringOf: (objectMemory fetchPointer: classNameIndex ofObject: classOop)]! Item was changed: ----- Method: StackInterpreter>>printStringOf: (in category 'debug printing') ----- printStringOf: oop | fmt len cnt max i | <inline: false> (objectMemory isImmediate: oop) ifTrue: [^nil]. + (objectMemory addressCouldBeObj: oop) ifFalse: - (oop between: objectMemory startOfMemory and: objectMemory freeStart) ifFalse: [^nil]. - (oop bitAnd: (BytesPerOop - 1)) ~= 0 ifTrue: - [^nil]. fmt := objectMemory formatOf: oop. fmt < objectMemory firstByteFormat ifTrue: [^nil]. cnt := (max := 128) min: (len := objectMemory lengthOf: oop). i := 0. ((objectMemory is: oop instanceOf: (objectMemory splObj: ClassByteArray) compactClassIndex: classByteArrayCompactIndex) or: [(self isInstanceOfClassLargePositiveInteger: oop) or: [(self isInstanceOfClassLargeNegativeInteger: oop)]]) ifTrue: [[i < cnt] whileTrue: [self printHex: (objectMemory fetchByte: i ofObject: oop). i := i + 1]] ifFalse: [[i < cnt] whileTrue: [self printChar: (objectMemory fetchByte: i ofObject: oop). i := i + 1]]. len > max ifTrue: [self print: '...']. self flush! Item was changed: ----- Method: StackInterpreter>>shortPrintOop: (in category 'debug printing') ----- shortPrintOop: oop <inline: false> self printHex: oop. (objectMemory isImmediate: oop) ifTrue: [(objectMemory isImmediateCharacter: oop) ifTrue: [^self cCode: 'printf("=$%ld ($%c)\n", (long)characterValueOf(oop), (long)characterValueOf(oop))' inSmalltalk: [self print: (self shortPrint: oop); cr]]. ^self cCode: 'printf("=%ld\n", (long)integerValueOf(oop))' inSmalltalk: [self print: (self shortPrint: oop); cr]]. + (objectMemory addressCouldBeObj: oop) ifFalse: + [self print: ((oop bitAnd: objectMemory allocationUnit - 1) ~= 0 + ifTrue: [' is misaligned'] + ifFalse: [' is not on the heap']); cr. - (oop between: objectMemory startOfMemory and: objectMemory freeStart) ifFalse: - [self printHex: oop; print: ' is not on the heap'; cr. ^nil]. - (oop bitAnd: (BytesPerWord - 1)) ~= 0 ifTrue: - [self printHex: oop; print: ' is misaligned'; cr. - ^nil]. self print: ': a(n) '. self printNameOfClass: (objectMemory fetchClassOf: oop) count: 5. self cr! Item was changed: ----- Method: StackInterpreterSimulator>>shortPrint: (in category 'debug support') ----- shortPrint: oop | name classOop | (objectMemory isImmediate: oop) ifTrue: [(objectMemory isImmediateCharacter: oop) ifTrue: [^ '=$' , (objectMemory integerValueOf: oop) printString , ' (' , (String with: (Character value: (objectMemory integerValueOf: oop))) , ')']. (objectMemory isIntegerObject: oop) ifTrue: [^ '=' , (objectMemory integerValueOf: oop) printString , ' (' , (objectMemory integerValueOf: oop) hex , ')']. ^'= UNKNOWN IMMEDIATE', ' (' , (objectMemory integerValueOf: oop) hex , ')']. + (objectMemory addressCouldBeObj: oop) ifFalse: + [^(oop bitAnd: objectMemory allocationUnit - 1) ~= 0 + ifTrue: [' is misaligned'] + ifFalse: [' is not on the heap']]. + classOop := objectMemory fetchClassOfNonImm: oop. + (objectMemory sizeBitsOf: classOop) = metaclassSizeBits ifTrue: + [^'class ' , (self nameOfClass: oop)]. - (oop between: objectMemory startOfMemory and: objectMemory freeStart) ifFalse: - [^' is not on the heap']. - (oop bitAnd: (BytesPerWord - 1)) ~= 0 ifTrue: - [^' is misaligned']. - classOop := objectMemory fetchClassOf: oop. - (objectMemory sizeBitsOf: classOop) = metaclassSizeBits ifTrue: [ - ^ 'class ' , (self nameOfClass: oop)]. name := self nameOfClass: classOop. name size = 0 ifTrue: [name := '??']. name = 'String' ifTrue: [^ (self stringOf: oop) printString]. name = 'ByteString' ifTrue: [^ (self stringOf: oop) printString]. name = 'Symbol' ifTrue: [^ '#' , (self stringOf: oop)]. name = 'ByteSymbol' ifTrue: [^ '#' , (self stringOf: oop)]. + name = 'Character' ifTrue: "SpurMemoryManager has immediate Characters; ObjectMemory does not" + [^ '=' , (Character value: (objectMemory integerValueOf: - name = 'Character' ifTrue: [^ '=' , (Character value: (objectMemory integerValueOf: (objectMemory fetchPointer: 0 ofObject: oop))) printString]. name = 'UndefinedObject' ifTrue: [^ 'nil']. name = 'False' ifTrue: [^ 'false']. name = 'True' ifTrue: [^ 'true']. name = 'Float' ifTrue: [^ '=' , (self dbgFloatValueOf: oop) printString]. name = 'Association' ifTrue: [^ '(' , (self shortPrint: (self longAt: oop + BaseHeaderSize)) , ' -> ' , (self longAt: oop + BaseHeaderSize + BytesPerWord) hex8 , ')']. ('AEIOU' includes: name first) ifTrue: [^ 'an ' , name] ifFalse: [^ 'a ' , name]!

1 0

VM Maker: Cog-eem.71.mcz
by commits＠source.squeak.org 05 Sep '13

05 Sep '13

Eliot Miranda uploaded a new version of Cog to project VM Maker: http://source.squeak.org/VMMaker/Cog-eem.71.mcz ==================== Summary ==================== Name: Cog-eem.71 Author: eem Time: 5 September 2013, 2:13:26.665 pm UUID: 4bd9ed8f-2b14-41c1-b6c3-4bb86633e92c Ancestors: Cog-eem.70 Add asserts to the Spur bootstrap that ed me to realize the image I am using has an invalid specialObjectsArray. GIGO ;-). Change the Spur bootstrap launch to use linear search on method lookup (because nothing's been rehashed yet). The bootstrap now gets to the first instantiation. Needs VMMaker.oscog-eem.349. =============== Diff against Cog-eem.70 =============== Item was changed: Object subclass: #SpurBootstrap + instanceVariableNames: 'oldHeap newHeap map reverseMap classToIndex oldInterpreter lastClassTablePage' - instanceVariableNames: 'oldHeap newHeap map reverseMap classToIndex oldInterpreter pastClassTable' classVariableNames: '' poolDictionaries: 'VMObjectIndices' category: 'Cog-Bootstrapping'! !SpurBootstrap commentStamp: 'eem 9/2/2013 13:26' prior: 0! SpurBootstrap bootstraps an image in CogMemoryManager format from a Squeak V3 + closures format. e.g. (SpurBootstrap32 new on: '/Users/eliot/Cog/startreader.image') transform; launch Instance Variables classToIndex: <Dictionary> map: <Dictionary> newHeap: <CogMemoryManager> oldHeap: <NewObjectMemory> oldInterpreter: <StackInterpreterSimulator> classToIndex - oldClass to new classIndex map map - oldObject to newObject map newHeap - the output, bootstrapped image oldHeap - the input, image oldInterpreter - the interpreter associated with oldHeap, needed for a hack to grab WeakArray ! Item was changed: ----- Method: SpurBootstrap>>allocateClassTable (in category 'bootstrap') ----- allocateClassTable "Allocate the root of the classTable plus enough pages to accomodate all classes in the classToIndex map. Don;t fill in the entries yet; the classes have yet to be cloned." | tableRootSize tableRoot page maxSize numPages | tableRootSize := self classTableSize / newHeap classTablePageSize. tableRoot := newHeap allocateSlots: tableRootSize format: newHeap arrayFormat classIndex: newHeap arrayClassIndexPun. self assert: (newHeap numSlotsOf: tableRoot) = tableRootSize. self assert: (newHeap formatOf: tableRoot) = newHeap arrayFormat. self assert: (newHeap classIndexOf: tableRoot) = newHeap arrayClassIndexPun. newHeap nilFieldsOf: tableRoot. "first page is strong" page := newHeap allocateSlots: newHeap classTablePageSize format: newHeap arrayFormat classIndex: newHeap arrayClassIndexPun. self assert: (newHeap numSlotsOf: page) = newHeap classTablePageSize. self assert: (newHeap formatOf: tableRoot) = newHeap arrayFormat. self assert: (newHeap classIndexOf: tableRoot) = newHeap arrayClassIndexPun. + self assert: (newHeap objectAfter: tableRoot limit: newHeap freeStart) = page.. + lastClassTablePage := page. - self assert: (newHeap objectAfter: tableRoot limit: newHeap freeStart) = page. newHeap nilFieldsOf: page. newHeap storePointer: 0 ofObject: tableRoot withValue: page. newHeap classTableRootObj: tableRoot. maxSize := classToIndex inject: 0 into: [:a :b| a max: b]. numPages := (maxSize + newHeap classTableMinorIndexMask / newHeap classTablePageSize) truncated. 2 to: numPages do: [:i| page := newHeap allocateSlots: newHeap classTablePageSize format: newHeap weakArrayFormat classIndex: newHeap weakArrayClassIndexPun. self assert: (newHeap numSlotsOf: page) = newHeap classTablePageSize. self assert: (newHeap formatOf: page) = newHeap weakArrayFormat. self assert: (newHeap classIndexOf: page) = newHeap weakArrayClassIndexPun. newHeap nilFieldsOf: page. newHeap storePointer: i - 1 ofObject: tableRoot withValue: page. + self assert: (newHeap objectAfter: (newHeap fetchPointer: i - 2 ofObject: tableRoot) limit: newHeap freeStart) = page. + lastClassTablePage := page]! - self assert: (newHeap objectAfter: (newHeap fetchPointer: i - 2 ofObject: tableRoot) limit: newHeap freeStart) = page]. - pastClassTable := newHeap freeStart.! Item was changed: ----- Method: SpurBootstrap>>buildClassMap (in category 'bootstrap') ----- buildClassMap "enumerate all objects asking isBehavior:? (class == Metaclass or class class == Metaclass) doesn't work for Newspeak" "Build a map from all classes in oldHeap to a class index. ONLY DEALS WITH CLASSES THAT HAVE INSTANCES!!!! (can walk superclass chain? Can walk subclasses set? Can ask class == Metaclass or class class == Metaclass class?)" | classes classTableIndex | self defineKnownClassIndices. classes := classToIndex keys asSet. + classTableIndex := classToIndex inject: 0 into: [:a :b| a max: b]. - classTableIndex := newHeap classTablePageSize. oldHeap allObjectsDo: [:oldObj| | oldClass | oldClass := oldHeap fetchClassOfNonImm: oldObj. + self assert: (oldHeap isPointersNonImm: oldClass). (classes includes: oldClass) ifFalse: [classes add: oldClass. classToIndex at: oldClass put: (classTableIndex := classTableIndex + 1)]]! Item was changed: ----- Method: SpurBootstrap>>defineKnownClassIndices (in category 'class indices') ----- defineKnownClassIndices "The classTable is laid out - to make it easy to map immediates to classes; the tag pattern of an immediate is its class index. hence there are two entries for SmallInteger - to assign small indices to well-known classes such as Array, Message et al - to leave plenty of room for new known classes; hence the first page contains only well-known classes - to enable overlaps and avoid conflicts with indices in the specialObjectsArray (?really? eem) - to provide a WeakArray pun for the pages of the table itself so that these do not show up as instances of WeakArray" | classMethodContext classBlockClosure classMessage "no api method for these" | classMessage := oldHeap splObj: (VMObjectIndices bindingOf: #ClassMessage) value. classMethodContext := oldHeap splObj: (VMObjectIndices bindingOf: #ClassMethodContext) value. classBlockClosure := oldHeap splObj: (VMObjectIndices bindingOf: #ClassBlockClosure) value. + "c.f. CogMemoryManager class>>intializeCompactClassIndices". + classToIndex keysDo: + [:oldClass| + self assert: (oldInterpreter addressCouldBeClassObj: oldClass)]. - "c.f. CogMemoryManager class>>intializeCompactClassIndices" classToIndex at: oldHeap classSmallInteger put: 1; "N.B. must fill-in index 3 manually" at: oldHeap classCharacter put: 2; "at: oldHeap classSmallInteger put: 3" "N.B. must fill-in index 3 manually" "leave room for up to 15 tagged classes" "leave room for up to 16 puns" at: oldHeap classLargeNegativeInteger put: 32; at: oldHeap classLargePositiveInteger put: 33; at: oldHeap classFloat put: 34; at: "oldHeap" classMessage put: 35; at: "oldHeap" classMethodContext put: 36; at: "oldHeap" classBlockClosure put: 37; at: oldHeap classSemaphore put: 48; at: oldHeap classMutex put: 49; at: oldHeap classByteArray put: 50; at: oldHeap classArray put: 51; at: oldHeap classString put: 52; at: oldHeap classBitmap put: 53; at: oldHeap classPoint put: 54; at: oldHeap classExternalAddress put: 128; at: oldHeap classExternalData put: 129; at: oldHeap classExternalFunction put: 130; at: oldHeap classExternalLibrary put: 131; at: oldHeap classExternalStructure put: 132; at: oldHeap classAlien put: 133; + at: oldHeap classUnsafeAlien put: 134. + classToIndex keysDo: + [:oldClass| + self assert: (oldInterpreter addressCouldBeClassObj: oldClass)]! - at: oldHeap classUnsafeAlien put: 133! Item was changed: ----- Method: SpurBootstrap>>fillInClassTable (in category 'bootstrap') ----- fillInClassTable | firstPage classWeakArray | classToIndex keysAndValuesDo: [:oldClass :index| | newClass page | newClass := map at: oldClass. + self assert: (newHeap isPointersNonImm: newClass). newHeap setHashBitsOf: newClass to: index. page := newHeap fetchPointer: index >> newHeap classTableMajorIndexShift ofObject: newHeap classTableRootObj. newHeap storePointer: (index bitAnd: newHeap classTableMinorIndexMask) ofObject: page + withValue: newClass. + self assert: (newHeap classAtIndex: index) = newClass]. - withValue: newClass]. firstPage := newHeap fetchPointer: 0 ofObject: newHeap classTableRootObj. classWeakArray := classToIndex keys detect: [:oldClass| (oldHeap instSpecOfClass: oldClass) = 4 and: [oldInterpreter classNameOf: oldClass Is: 'WeakArray']]. newHeap storePointer: 1 ofObject: firstPage withValue: (map at: oldHeap classSmallInteger); storePointer: 2 ofObject: firstPage withValue: (map at: oldHeap classCharacter); storePointer: 3 ofObject: firstPage withValue: (map at: oldHeap classSmallInteger); storePointer: newHeap arrayClassIndexPun ofObject: firstPage withValue: (map at: oldHeap classArray); storePointer: newHeap weakArrayClassIndexPun ofObject: firstPage withValue: (map at: classWeakArray)! Item was changed: ----- Method: SpurBootstrap>>launch (in category 'testing') ----- launch | sim | sim := StackInterpreterSimulator onObjectMemory: newHeap. newHeap coInterpreter: sim. sim initializeInterpreter: 0. + sim + ensureDebugAtEachStepBlock; + instVarNamed: 'printBytecodeAtEachStep' put: true; + instVarNamed: 'methodDictLinearSearchLimit' put: SmallInteger maxVal. "for now" sim run! Item was changed: ----- Method: SpurBootstrap>>validate (in category 'bootstrap') ----- validate + | p n duplicates maxClassIndex | + self assert: (reverseMap at: newHeap specialObjectsOop) = oldHeap specialObjectsOop. + self assert: (map at: oldHeap specialObjectsOop) = newHeap specialObjectsOop. + self assert: (reverseMap at: newHeap classTableRootObj ifAbsent: []) isNil. + + duplicates := { 3. newHeap arrayClassIndexPun. newHeap weakArrayClassIndexPun }. + maxClassIndex := classToIndex inject: 0 into: [:a :b| a max: b]. + self assert: ((0 to: maxClassIndex) select: + [:idx| | classObj | + (classObj := newHeap classAtIndex: idx) ~= newHeap nilObject + and: [(newHeap classIndexOf: classObj) = (newHeap hashBitsOf: classObj)]]) isEmpty. + 0 to: maxClassIndex do: + [:index| | classObj | + (classObj := newHeap classAtIndex: index) = newHeap nilObject + ifTrue: + [self assert: (classToIndex keyAtValue: index ifAbsent: []) isNil] + ifFalse: + [self assert: (newHeap classIndexOf: classObj) ~= (newHeap hashBitsOf: classObj). + (duplicates includes: index) ifFalse: + [self assert: (newHeap hashBitsOf: classObj) = index]]]. + classToIndex keysAndValuesDo: + [:oldClass :idx| + self assert: (newHeap hashBitsOf: (map at: oldClass)) = idx. + self assert: oldClass = (reverseMap at: (newHeap classAtIndex: idx))]. + n := 0. - | p i | - i := 0. newHeap allObjectsDo: [:o| + (o <= newHeap trueObject + or: [o > lastClassTablePage]) ifTrue: + [self assert: (reverseMap includesKey: o). + self assert: (newHeap fetchClassOfNonImm: o) = (map at: (oldHeap fetchClassOfNonImm: (reverseMap at: o)))]. + n := n + 1. + p := o]. - o >= pastClassTable ifTrue: - [self assert: (reverseMap includesKey: o)]. - i := i + 1. p := o]. p class. + self assert: (n between: map size and: map size + 5) "+ 5 is room for classTable"! - self assert: (i between: map size and: map size + 5) "+ 5 is room for classTable"!

1 0

VM Maker: VMMaker.oscog-eem.348.mcz
by commits＠source.squeak.org 05 Sep '13

05 Sep '13

Eliot Miranda uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker.oscog-eem.348.mcz ==================== Summary ==================== Name: VMMaker.oscog-eem.348 Author: eem Time: 4 September 2013, 5:27:05.1 pm UUID: 8ba1e038-9d98-46af-b40a-1c663bad8df1 Ancestors: VMMaker.oscog-eem.347 Rename fetchClassOfNonInt: to fetchClassOfNonImm:. Recast SpurMemMgr's isImmediate: et al in terms of self tagMask. Fix various printOop:'s in StackInterpreter to use addressCouldBeObj: to test for correct alignment and avoid assumption that objects are between startOfMemory and freeStart. =============== Diff against VMMaker.oscog-eem.347 =============== Item was changed: ----- Method: CoInterpreter>>bytecodePrimAt (in category 'common selector sends') ----- bytecodePrimAt "BytecodePrimAt will only succeed if the receiver is in the atCache. Otherwise it will fail so that the more general primitiveAt will put it in the cache after validating that message lookup results in a primitive response. Override to insert in the at: cache here. This is necessary since once there is a compiled at: primitive method (which doesn't use the at: cache) the only way something can get installed in the atCache is here." | index rcvr result atIx | index := self internalStackTop. rcvr := self internalStackValue: 1. ((objectMemory isIntegerObject: rcvr) not and: [objectMemory isIntegerObject: index]) ifTrue: [atIx := rcvr bitAnd: AtCacheMask. "Index into atCache = 4N, for N = 0 ... 7" (atCache at: atIx+AtCacheOop) ~= rcvr ifTrue: + [lkupClass := objectMemory fetchClassOfNonImm: rcvr. - [lkupClass := objectMemory fetchClassOfNonInt: rcvr. messageSelector := self specialSelector: 16. (self lookupInMethodCacheSel: messageSelector class: lkupClass) ifFalse: [argumentCount := 1. ^self commonSend]. primitiveFunctionPointer == #primitiveAt ifTrue: [self install: rcvr inAtCache: atCache at: atIx string: false] ifFalse: [primitiveFunctionPointer == #primitiveStringAt ifTrue: [self install: rcvr inAtCache: atCache at: atIx string: true] ifFalse: [argumentCount := 1. ^self commonSend]]]. self successful ifTrue: [result := self commonVariable: rcvr at: (objectMemory integerValueOf: index) cacheIndex: atIx]. self successful ifTrue: [self fetchNextBytecode. ^self internalPop: 2 thenPush: result]. self initPrimCall]. messageSelector := self specialSelector: 16. argumentCount := 1. self normalSend! Item was changed: ----- Method: CoInterpreter>>bytecodePrimAtPut (in category 'common selector sends') ----- bytecodePrimAtPut "BytecodePrimAtPut will only succeed if the receiver is in the atCache. Otherwise it will fail so that the more general primitiveAtPut will put it in the cache after validating that message lookup results in a primitive response. Override to insert in the atCache here. This is necessary since once there is a compiled at:[put:] primitive method (which doesn't use the at: cache) the only way something can get installed in the atCache is here." | index rcvr atIx value | value := self internalStackTop. index := self internalStackValue: 1. rcvr := self internalStackValue: 2. ((objectMemory isIntegerObject: rcvr) not and: [objectMemory isIntegerObject: index]) ifTrue: [atIx := (rcvr bitAnd: AtCacheMask) + AtPutBase. "Index into atPutCache" (atCache at: atIx+AtCacheOop) ~= rcvr ifTrue: + [lkupClass := objectMemory fetchClassOfNonImm: rcvr. - [lkupClass := objectMemory fetchClassOfNonInt: rcvr. messageSelector := self specialSelector: 17. (self lookupInMethodCacheSel: messageSelector class: lkupClass) ifFalse: [argumentCount := 2. ^self commonSend]. primitiveFunctionPointer == #primitiveAtPut ifTrue: [self install: rcvr inAtCache: atCache at: atIx string: false] ifFalse: [primitiveFunctionPointer == #primitiveStringAtPut ifTrue: [self install: rcvr inAtCache: atCache at: atIx string: true] ifFalse: [argumentCount := 2. ^self commonSend]]]. self successful ifTrue: [self commonVariable: rcvr at: (objectMemory integerValueOf: index) put: value cacheIndex: atIx]. self successful ifTrue: [self fetchNextBytecode. ^self internalPop: 3 thenPush: value]. self initPrimCall]. messageSelector := self specialSelector: 17. argumentCount := 2. self normalSend! Item was changed: ----- Method: CoInterpreter>>checkOkayFields: (in category 'debug support') ----- checkOkayFields: oop "Check if the argument is an ok object. If this is a pointers object, check that its fields are all okay oops." | hasYoung i fieldOop | (oop = nil or: [oop = 0]) ifTrue: [ ^true ]. "?? eem 1/16/2013" (objectMemory isIntegerObject: oop) ifTrue: [ ^true ]. (objectMemory checkOkayOop: oop) ifFalse: [ ^false ]. (self checkOopHasOkayClass: oop) ifFalse: [ ^false ]. ((objectMemory isPointersNonInt: oop) or: [objectMemory isCompiledMethod: oop]) ifFalse: [ ^true ]. + hasYoung := objectMemory isYoung: (objectMemory fetchClassOfNonImm: oop). - hasYoung := objectMemory isYoung: (objectMemory fetchClassOfNonInt: oop). (objectMemory isCompiledMethod: oop) ifTrue: [i := (self literalCountOf: oop) + LiteralStart - 1] ifFalse: [(objectMemory isContext: oop) ifTrue: [i := CtxtTempFrameStart + (self fetchStackPointerOf: oop) - 1] ifFalse: [i := (objectMemory lengthOf: oop) - 1]]. [i >= 0] whileTrue: [fieldOop := objectMemory fetchPointer: i ofObject: oop. (objectMemory isNonIntegerObject: fieldOop) ifTrue: [(i = 0 and: [objectMemory isCompiledMethod: oop]) ifTrue: [(cogMethodZone methodFor: (self pointerForOop: fieldOop)) = 0 ifTrue: [self print: 'method '; printHex: oop; print: ' has an invalid cog method reference'. ^false]] ifFalse: [hasYoung := hasYoung or: [objectMemory isYoung: fieldOop]. (objectMemory checkOkayOop: fieldOop) ifFalse: [ ^false ]. (self checkOopHasOkayClass: fieldOop) ifFalse: [ ^false ]]]. i := i - 1]. hasYoung ifTrue: [^objectMemory checkOkayYoungReferrer: oop]. ^true! Item was changed: ----- Method: CoInterpreter>>printFrame:WithSP: (in category 'debug printing') ----- printFrame: theFP WithSP: theSP <api> | theMethod theMethodEnd numArgs numTemps rcvrAddress topThing | <inline: false> <var: #theFP type: #'char *'> <var: #theSP type: #'char *'> <var: #addr type: #'char *'> <var: #rcvrAddress type: #'char *'> <var: #cogMethod type: #'CogBlockMethod *'> <var: #homeMethod type: #'CogMethod *'> self cCode: '' inSmalltalk: [self transcript ensureCr]. (self isMachineCodeFrame: theFP) ifTrue: [| cogMethod homeMethod | cogMethod := self mframeCogMethod: theFP. homeMethod := self mframeHomeMethod: theFP. theMethod := homeMethod asInteger. theMethodEnd := homeMethod asInteger + homeMethod blockSize. numArgs := cogMethod cmNumArgs. numTemps := self temporaryCountOfMethodHeader: homeMethod methodHeader] ifFalse: [theMethod := self frameMethodObject: theFP. theMethodEnd := theMethod + (objectMemory sizeBitsOfSafe: theMethod). numArgs := self iframeNumArgs: theFP. numTemps := self tempCountOf: theMethod]. (self frameIsBlockActivation: theFP) ifTrue: [| rcvrOrClosure | rcvrOrClosure := self pushedReceiverOrClosureOfFrame: theFP. ((objectMemory isNonIntegerObject: rcvrOrClosure) and: [(objectMemory addressCouldBeObj: rcvrOrClosure) + and: [(objectMemory fetchClassOfNonImm: rcvrOrClosure) = (objectMemory splObj: ClassBlockClosure)]]) - and: [(objectMemory fetchClassOfNonInt: rcvrOrClosure) = (objectMemory splObj: ClassBlockClosure)]]) ifTrue: [numTemps := numArgs + (self stSizeOf: rcvrOrClosure)] ifFalse: [numTemps := 0]]. self shortPrintFrame: theFP. (self isBaseFrame: theFP) ifTrue: [self printFrameOop: '(caller ctxt' at: theFP + (self frameStackedReceiverOffset: theFP) + (2 * BytesPerWord). self printFrameOop: '(saved ctxt' at: theFP + (self frameStackedReceiverOffset: theFP) + (1 * BytesPerWord)]. self printFrameOop: 'rcvr/clsr' at: theFP + FoxCallerSavedIP + ((numArgs + 1) * BytesPerWord). numArgs to: 1 by: -1 do: [:i| self printFrameOop: 'arg' index: numArgs - i at: theFP + FoxCallerSavedIP + (i * BytesPerWord)]. self printFrameThing: 'caller ip' at: theFP + FoxCallerSavedIP. self printFrameThing: 'saved fp' at: theFP + FoxSavedFP. self printFrameMethodFor: theFP. (self isMachineCodeFrame: theFP) ifFalse: [self printFrameFlagsForFP: theFP]. self printFrameOop: 'context' at: theFP + FoxThisContext. (self isMachineCodeFrame: theFP) ifTrue: [self printFrameFlagsForFP: theFP]. (self isMachineCodeFrame: theFP) ifTrue: [rcvrAddress := theFP + FoxMFReceiver] ifFalse: [self printFrameThing: 'saved ip' at: theFP + FoxIFSavedIP extra: ((self iframeSavedIP: theFP) = 0 ifTrue: [0] ifFalse: [(self iframeSavedIP: theFP) - theMethod + 2 - BaseHeaderSize]). rcvrAddress := theFP + FoxIFReceiver]. self printFrameOop: 'receiver' at: rcvrAddress. topThing := stackPages longAt: theSP. (topThing between: theMethod and: theMethodEnd) ifTrue: [rcvrAddress - BytesPerWord to: theSP + BytesPerWord by: BytesPerWord negated do: [:addr| | index | index := rcvrAddress - addr / BytesPerWord + numArgs. index <= numTemps ifTrue: [self printFrameOop: 'temp' index: index - 1 at: addr] ifFalse: [self printFrameOop: 'stck' at: addr]]. self printFrameThing: 'frame ip' at: theSP extra: ((self isMachineCodeFrame: theFP) ifTrue: [topThing - theMethod] ifFalse: [topThing - theMethod + 2 - BaseHeaderSize])] ifFalse: [rcvrAddress - BytesPerWord to: theSP by: BytesPerWord negated do: [:addr| | index | index := rcvrAddress - addr / BytesPerWord + numArgs. index <= numTemps ifTrue: [self printFrameOop: 'temp' index: index - 1 at: addr] ifFalse: [self printFrameOop: 'stck' at: addr]]]! Item was changed: ----- Method: CoInterpreterPrimitives>>pathTo:using:followWeak: (in category 'object access primitives') ----- pathTo: goal using: stack followWeak: followWeak "Trace objects and frames from the root, marking visited objects, pushing the current path on stack, until goal is found. If found, unmark, leaving path in stack, and answer 0. Otherwise answer an error: PrimErrBadArgument if stack is not an Array PrimErrBadIndex if search overflows stack PrimErrNotFound if goal cannot be found" | current hdr index next stackSize stackp freeStartAtStart | (objectMemory isArray: stack) ifFalse: [^PrimErrBadArgument]. freeStartAtStart := objectMemory freeStart. "check no allocations during search" objectMemory beRootIfOld: stack. "so no store checks are necessary on stack" stackSize := objectMemory lengthOf: stack. objectMemory mark: stack. "no need. the current context is not reachable from the active process (suspendedContext is nil)" "objectMemory mark: self activeProcess." current := objectMemory specialObjectsOop. objectMemory mark: current. index := objectMemory lengthOf: current. stackp := 0. [[(index := index - 1) >= -1] whileTrue: [next := (stackPages couldBeFramePointer: current) ifTrue: [index >= 0 ifTrue: [self field: index ofFrame: (self cCoerceSimple: current to: #'char *')] ifFalse: [objectMemory nilObject]] ifFalse: [index >= 0 ifTrue: [hdr := objectMemory baseHeader: current. (objectMemory isContextHeader: hdr) ifTrue: [self fieldOrSenderFP: index ofContext: current] ifFalse: [objectMemory fetchPointer: index ofObject: current]] ifFalse: + [objectMemory fetchClassOfNonImm: current]]. - [objectMemory fetchClassOfNonInt: current]]. (stackPages couldBeFramePointer: next) ifTrue: [self assert: (self isFrame: (self cCoerceSimple: next to: #'char *') onPage: (stackPages stackPageFor: (self cCoerceSimple: next to: #'char *')))] ifFalse: [next >= heapBase ifTrue: [self assert: (self checkOkayOop: next)]]. next = goal ifTrue: [self assert: freeStartAtStart = objectMemory freeStart. self unmarkAfterPathTo. objectMemory storePointer: stackp ofObject: stack withValue: current. self pruneStack: stack stackp: stackp. ^0]. ((objectMemory isNonIntegerObject: next) and: [(stackPages couldBeFramePointer: next) ifTrue: [(self frameIsMarked: next) not] ifFalse: [next >= heapBase "exclude Cog methods" and: [(objectMemory isMarked: next) not and: [((objectMemory isPointers: next) or: [objectMemory isCompiledMethod: next]) and: [followWeak or: [(objectMemory isWeakNonInt: next) not]]]]]]) ifTrue: [stackp + 2 > stackSize ifTrue: [self assert: freeStartAtStart = objectMemory freeStart. self unmarkAfterPathTo. objectMemory nilFieldsOf: stack. ^PrimErrBadIndex]. "PrimErrNoMemory ?" objectMemory storePointerUnchecked: stackp ofObject: stack withValue: current; storePointerUnchecked: stackp + 1 ofObject: stack withValue: (objectMemory integerObjectOf: index). stackp := stackp + 2. (stackPages couldBeFramePointer: (self cCoerceSimple: next to: #'char *')) ifTrue: [self markFrame: next. index := self fieldsInFrame: (self cCoerceSimple: next to: #'char *')] ifFalse: [hdr := objectMemory baseHeader: next. objectMemory baseHeader: next put: (hdr bitOr: MarkBit). (objectMemory isCompiledMethodHeader: hdr) ifTrue: [index := (self literalCountOf: next) + LiteralStart] ifFalse: [index := objectMemory lengthOf: next]]. current := next]]. current = objectMemory specialObjectsOop ifTrue: [self assert: freeStartAtStart = objectMemory freeStart. self unmarkAfterPathTo. objectMemory nilFieldsOf: stack. ^PrimErrNotFound]. index := objectMemory integerValueOf: (objectMemory fetchPointer: stackp - 1 ofObject: stack). current := objectMemory fetchPointer: stackp - 2 ofObject: stack. stackp := stackp - 2] repeat! Item was changed: ----- Method: CoInterpreterPrimitives>>primitiveLongRunningPrimitiveSemaphore (in category 'process primitives') ----- primitiveLongRunningPrimitiveSemaphore "Primitive. Install the semaphore to be used for collecting long-running primitives, or nil if no semaphore should be used." | sema flushState activeContext | <export: true> sema := self stackValue: 0. ((objectMemory isIntegerObject: sema) or: [self methodArgumentCount ~= 1]) ifTrue: [^self primitiveFail]. sema = objectMemory nilObject ifTrue: [flushState := longRunningPrimitiveCheckSemaphore notNil. longRunningPrimitiveCheckSemaphore := nil] ifFalse: [flushState := longRunningPrimitiveCheckSemaphore isNil. + (objectMemory fetchClassOfNonImm: sema) = (objectMemory splObj: ClassSemaphore) ifFalse: - (objectMemory fetchClassOfNonInt: sema) = (objectMemory splObj: ClassSemaphore) ifFalse: [^self primitiveFail]. longRunningPrimitiveCheckSemaphore := sema]. "If we've switched checking on or off we must void machine code (and machine code pcs in contexts) since we will start or stop setting newMethod in machine code primitive invocations, and so generate slightly different code from here on in." flushState ifTrue: [self push: instructionPointer. activeContext := self voidVMStateForSnapshot. self marryContextInNewStackPageAndInitializeInterpreterRegisters: activeContext. self assert: (((self stackValue: 0) = objectMemory nilObject and: [longRunningPrimitiveCheckSemaphore isNil]) or: [(self stackValue: 0) = longRunningPrimitiveCheckSemaphore + and: [(objectMemory fetchClassOfNonImm: sema) = (objectMemory splObj: ClassSemaphore)]])]. - and: [(objectMemory fetchClassOfNonInt: sema) = (objectMemory splObj: ClassSemaphore)]])]. self voidLongRunningPrimitive: 'install'. self pop: 1. flushState ifTrue: [self siglong: reenterInterpreter jmp: ReturnToInterpreter]! Item was changed: ----- Method: CoInterpreterPrimitives>>primitiveProfileSemaphore (in category 'process primitives') ----- primitiveProfileSemaphore "Primitive. Install the semaphore to be used for profiling, or nil if no semaphore should be used. See also primitiveProfileStart." | sema flushState activeContext | <export: true> sema := self stackValue: 0. ((objectMemory isIntegerObject: sema) or: [self methodArgumentCount ~= 1]) ifTrue: [^self primitiveFail]. sema = objectMemory nilObject ifTrue: [flushState := profileSemaphore ~= objectMemory nilObject] ifFalse: [flushState := profileSemaphore = objectMemory nilObject. + (objectMemory fetchClassOfNonImm: sema) = (objectMemory splObj: ClassSemaphore) ifFalse: - (objectMemory fetchClassOfNonInt: sema) = (objectMemory splObj: ClassSemaphore) ifFalse: [^self primitiveFail]]. profileSemaphore := sema. "If we've switched profiling on or off we must void machine code (and machine code pcs in contexts) since we will start or stop testing the profile clock in machine code primitive invocations, and so generate slightly different code from here on in." flushState ifTrue: [self push: instructionPointer. activeContext := self voidVMStateForSnapshot. self marryContextInNewStackPageAndInitializeInterpreterRegisters: activeContext. self assert: (((self stackValue: 0) = objectMemory nilObject and: [profileSemaphore = objectMemory nilObject]) or: [(self stackValue: 0) = profileSemaphore + and: [(objectMemory fetchClassOfNonImm: sema) = (objectMemory splObj: ClassSemaphore)]])]. - and: [(objectMemory fetchClassOfNonInt: sema) = (objectMemory splObj: ClassSemaphore)]])]. profileProcess := profileMethod := objectMemory nilObject. self pop: 1. flushState ifTrue: [self siglong: reenterInterpreter jmp: ReturnToInterpreter]! Item was changed: ----- Method: Interpreter>>bytecodePrimValue (in category 'common selector sends') ----- bytecodePrimValue "In-line value for BlockClosure and BlockContext" | maybeBlock rcvrClass | maybeBlock := self internalStackTop. argumentCount := 0. successFlag := true. (self isNonIntegerObject: maybeBlock) ifTrue: + [rcvrClass := self fetchClassOfNonImm: maybeBlock. - [rcvrClass := self fetchClassOfNonInt: maybeBlock. rcvrClass = (self splObj: ClassBlockClosure) ifTrue: [self externalizeIPandSP. self primitiveClosureValue. self internalizeIPandSP] ifFalse: [rcvrClass = (self splObj: ClassBlockContext) ifTrue: [self externalizeIPandSP. self primitiveValue. self internalizeIPandSP] ifFalse: [successFlag := false]]]. successFlag ifFalse: [messageSelector := self specialSelector: 25. ^self normalSend]. self fetchNextBytecode! Item was changed: ----- Method: Interpreter>>bytecodePrimValueWithArg (in category 'common selector sends') ----- bytecodePrimValueWithArg "In-line value: for BlockClosure and BlockContext" | maybeBlock rcvrClass | maybeBlock := self internalStackValue: 1. argumentCount := 1. successFlag := true. (self isNonIntegerObject: maybeBlock) ifTrue: + [rcvrClass := self fetchClassOfNonImm: maybeBlock. - [rcvrClass := self fetchClassOfNonInt: maybeBlock. rcvrClass = (self splObj: ClassBlockClosure) ifTrue: [self externalizeIPandSP. self primitiveClosureValue. self internalizeIPandSP] ifFalse: [rcvrClass = (self splObj: ClassBlockContext) ifTrue: [self externalizeIPandSP. self primitiveValue. self internalizeIPandSP] ifFalse: [successFlag := false]]]. successFlag ifFalse: [messageSelector := self specialSelector: 26. ^self normalSend]. self fetchNextBytecode! Item was changed: ----- Method: Interpreter>>commonAt: (in category 'array primitive support') ----- commonAt: stringy "This code is called if the receiver responds primitively to at:. If this is so, it will be installed in the atCache so that subsequent calls of at: or next may be handled immediately in bytecode primitive routines." | index rcvr atIx result | index := self positive32BitValueOf: (self stackTop). "Sets successFlag" rcvr := self stackValue: 1. successFlag & (self isIntegerObject: rcvr) not ifFalse: [^ self primitiveFail]. "NOTE: The at-cache, since it is specific to the non-super response to #at:. Therefore we must determine that the message is #at: (not, eg, #basicAt:), and that the send is not a super-send, before using the at-cache." (messageSelector = (self specialSelector: 16) + and: [lkupClass = (self fetchClassOfNonImm: rcvr)]) - and: [lkupClass = (self fetchClassOfNonInt: rcvr)]) ifTrue: ["OK -- look in the at-cache" atIx := rcvr bitAnd: AtCacheMask. "Index into atCache = 4N, for N = 0 ... 7" (atCache at: atIx+AtCacheOop) = rcvr ifFalse: ["Rcvr not in cache. Install it..." self install: rcvr inAtCache: atCache at: atIx string: stringy]. successFlag ifTrue: [result := self commonVariable: rcvr at: index cacheIndex: atIx]. successFlag ifTrue: [^ self pop: argumentCount+1 thenPush: result]]. "The slow but sure way..." successFlag := true. result := self stObject: rcvr at: index. successFlag ifTrue: [stringy ifTrue: [result := self characterForAscii: (self integerValueOf: result)]. ^ self pop: argumentCount+1 thenPush: result]! Item was changed: ----- Method: Interpreter>>commonAtPut: (in category 'array primitive support') ----- commonAtPut: stringy "This code is called if the receiver responds primitively to at:Put:. If this is so, it will be installed in the atPutCache so that subsequent calls of at: or next may be handled immediately in bytecode primitive routines." | value index rcvr atIx | value := self stackTop. index := self positive32BitValueOf: (self stackValue: 1). "Sets successFlag" rcvr := self stackValue: 2. successFlag & (self isIntegerObject: rcvr) not ifFalse: [^ self primitiveFail]. "NOTE: The atPut-cache, since it is specific to the non-super response to #at:Put:. Therefore we must determine that the message is #at:Put: (not, eg, #basicAt:Put:), and that the send is not a super-send, before using the at-cache." (messageSelector = (self specialSelector: 17) + and: [lkupClass = (self fetchClassOfNonImm: rcvr)]) - and: [lkupClass = (self fetchClassOfNonInt: rcvr)]) ifTrue: ["OK -- look in the at-cache" atIx := (rcvr bitAnd: AtCacheMask) + AtPutBase. "Index into atPutCache" (atCache at: atIx+AtCacheOop) = rcvr ifFalse: ["Rcvr not in cache. Install it..." self install: rcvr inAtCache: atCache at: atIx string: stringy]. successFlag ifTrue: [self commonVariable: rcvr at: index put: value cacheIndex: atIx]. successFlag ifTrue: [^ self pop: argumentCount+1 thenPush: value]]. "The slow but sure way..." successFlag := true. stringy ifTrue: [self stObject: rcvr at: index put: (self asciiOfCharacter: value)] ifFalse: [self stObject: rcvr at: index put: value]. successFlag ifTrue: [^ self pop: argumentCount+1 thenPush: value]. ! Item was changed: ----- Method: Interpreter>>initializeInterpreter: (in category 'initialization') ----- initializeInterpreter: bytesToShift "Initialize Interpreter state before starting execution of a new image." interpreterProxy := self sqGetInterpreterProxy. self dummyReferToProxy. self initializeObjectMemory: bytesToShift. self initCompilerHooks. self checkAssumedCompactClasses. + metaclassSizeBits := self sizeBitsOf: (self fetchClassOfNonImm: (self splObj: ClassArray)). "determine actual (Metaclass instSize * 4)" - metaclassSizeBits := self sizeBitsOf: (self fetchClassOfNonInt: (self splObj: ClassArray)). "determine actual (Metaclass instSize * 4)" activeContext := nilObj. theHomeContext := nilObj. method := nilObj. receiver := nilObj. messageSelector := nilObj. newMethod := nilObj. lkupClass := nilObj. receiverClass := nilObj. self flushMethodCache. self loadInitialContext. self initialCleanup. interruptCheckCounter := 0. interruptCheckCounterFeedBackReset := 1000. interruptChecksEveryNms := 1. nextProfileTick := 0. profileSemaphore := nilObj. profileProcess := nilObj. profileMethod := nilObj. nextPollTick := 0. nextWakeupTick := 0. lastTick := 0. interruptKeycode := 2094. "cmd-. as used for Mac but no other OS" interruptPending := false. semaphoresUseBufferA := true. semaphoresToSignalCountA := 0. semaphoresToSignalCountB := 0. deferDisplayUpdates := false. pendingFinalizationSignals := statPendingFinalizationSignals := 0. globalSessionID := 0. [globalSessionID = 0] whileTrue: [globalSessionID := self cCode: 'time(NULL) + ioMSecs()' inSmalltalk: [(Random new next * SmallInteger maxVal) asInteger]]. jmpDepth := 0. jmpMax := MaxJumpBuf. "xxxx: Must match the definition of jmpBuf and suspendedCallbacks" statQuickCheckForEvents := 0. statCheckForEvents := 0. statProcessSwitch := 0. statIOProcessEvents := 0 ! Item was changed: ----- Method: Interpreter>>isFloatObject: (in category 'plugin primitive support') ----- isFloatObject: oop ^(self isNonIntegerObject: oop) + and: [(self fetchClassOfNonImm: oop) = self classFloat]! - and: [(self fetchClassOfNonInt: oop) = self classFloat]! Item was changed: ----- Method: Interpreter>>primitiveChangeClass (in category 'object access primitives') ----- primitiveChangeClass "Primitive. Change the class of the receiver into the class of the argument given that the format of the receiver matches the format of the argument's class. Fail if the receiver or argument are SmallIntegers, or the receiver is an instance of a compact class and the argument isn't, or when the argument's class is compact and the receiver isn't, or when the format of the receiver is different from the format of the argument's class, or when the arguments class is fixed and the receiver's size differs from the size that an instance of the argument's class should have." | arg rcvr argClass err | arg := self stackObjectValue: 0. rcvr := self stackObjectValue: 1. self successful ifFalse:[^nil]. + argClass := self fetchClassOfNonImm: arg. - argClass := self fetchClassOfNonInt: arg. err := self changeClassOf: rcvr to: argClass. err = 0 ifTrue: ["Flush at cache because rcvr's class has changed." self flushAtCache. self pop: self methodArgumentCount] ifFalse: [self primitiveFail]. ^nil! Item was changed: ----- Method: Interpreter>>primitiveStopVMProfiling (in category 'process primitives') ----- primitiveStopVMProfiling "Primitive. Stop the VM profiler and either copy the histogram data into the supplied arguments, if they're non-nil. Fail if the arguments are not of the right type or size." | vmHistArrayOrNil vmHist vmBins easHistArrayOrNil easHist easBins | <var: #vmHist type: #'long *'> <var: #vmBins type: #long> <var: #easHist type: #'long *'> <var: #easBins type: #long> self success: argumentCount = 2. vmHistArrayOrNil := self stackObjectValue: 1. easHistArrayOrNil := self stackObjectValue: 0. successFlag ifFalse: [^nil]. "Both args must be either nil or arrays. If they're arrays and the wrong size we incorrectly stop profiling." + ((vmHistArrayOrNil = nilObj or: [(self fetchClassOfNonImm: vmHistArrayOrNil) = (self splObj: ClassArray)]) + and: [(self fetchClassOfNonImm: vmHistArrayOrNil) = (self fetchClassOfNonImm: easHistArrayOrNil)]) ifFalse: - ((vmHistArrayOrNil = nilObj or: [(self fetchClassOfNonInt: vmHistArrayOrNil) = (self splObj: ClassArray)]) - and: [(self fetchClassOfNonInt: vmHistArrayOrNil) = (self fetchClassOfNonInt: easHistArrayOrNil)]) ifFalse: [^self primitiveFail]. self cCode: 'ioControlProfile(0,&vmHist,&vmBins,&easHist,&easBins)' inSmalltalk: [vmHist := vmBins := easHist := easBins := 0]. vmHistArrayOrNil ~= nilObj ifTrue: [((self fetchWordLengthOf: vmHistArrayOrNil) = vmBins and: [(self fetchWordLengthOf: easHistArrayOrNil) = easBins]) ifFalse: [^self primitiveFail]. 0 to: vmBins - 1 do: [:i| self storePointerUnchecked: i ofObject: vmHistArrayOrNil withValue: (self integerObjectOf: (vmHist at: i))]. 0 to: easBins - 1 do: [:i| self storePointerUnchecked: i ofObject: easHistArrayOrNil withValue: (self integerObjectOf: (easHist at: i))]]. self pop: argumentCount! Item was changed: ----- Method: Interpreter>>sendInvokeCallback:Stack:Registers:Jmpbuf: (in category 'callback support') ----- sendInvokeCallback: thunkPtr Stack: stackPtr Registers: regsPtr Jmpbuf: jmpBufPtr "Send the 4 argument callback message invokeCallback:stack:registers:jmpbuf: to Alien class with the supplied args. The arguments are raw C addresses and are converted to integer objects on the way." | where | <export: true> self pushRemappableOop: (self positive32BitIntegerFor: jmpBufPtr). self pushRemappableOop: (self positive32BitIntegerFor: regsPtr). self pushRemappableOop: (self positive32BitIntegerFor: stackPtr). self pushRemappableOop: (self positive32BitIntegerFor: thunkPtr). receiver := self splObj: ClassAlien. + lkupClass := self fetchClassOfNonImm: receiver. - lkupClass := self fetchClassOfNonInt: receiver. messageSelector := self splObj: SelectorInvokeCallback. (self lookupInMethodCacheSel: messageSelector class: lkupClass) ifFalse: [(self lookupMethodNoMNUEtcInClass: lkupClass) ifFalse: [^false]]. primitiveIndex ~= 0 ifTrue: [^false]. self storeContextRegisters: activeContext. self justActivateNewMethod. where := activeContext + BaseHeaderSize + (ReceiverIndex << ShiftForWord). self longAt: where + (1 << ShiftForWord) put: self popRemappableOop. self longAt: where + (2 << ShiftForWord) put: self popRemappableOop. self longAt: where + (3 << ShiftForWord) put: self popRemappableOop. self longAt: where + (4 << ShiftForWord) put: self popRemappableOop. self interpret. "not reached" ^true! Item was changed: ----- Method: Interpreter>>signed64BitValueOf: (in category 'primitive support') ----- signed64BitValueOf: oop "Convert the given object into an integer value. The object may be either a positive ST integer or a eight-byte LargeInteger." | sz value largeClass negative szsqLong | <inline: false> <returnTypeC: #sqLong> <var: #value type: #sqLong> (self isIntegerObject: oop) ifTrue: [^self cCoerce: (self integerValueOf: oop) to: #sqLong]. + largeClass := self fetchClassOfNonImm: oop. - largeClass := self fetchClassOfNonInt: oop. largeClass = self classLargePositiveInteger ifTrue:[negative := false] ifFalse:[largeClass = self classLargeNegativeInteger ifTrue:[negative := true] ifFalse:[^self primitiveFail]]. szsqLong := self sizeof: #sqLong. sz := self lengthOf: oop. sz > szsqLong ifTrue: [^ self primitiveFail]. value := 0. 0 to: sz - 1 do: [:i | value := value + ((self cCoerce: (self fetchByte: i ofObject: oop) to: #sqLong) << (i*8))]. "Filter out values out of range for the signed interpretation such as 16rFFFFFFFF... (positive w/ bit 64 set) and -16rFFFFFFFF... (negative w/ bit 64 set). Since the sign is implicit in the class we require that the high bit of the magnitude is not set which is a simple test here. Note that we have to handle the most negative 64-bit value -9223372036854775808 specially." self cCode: [] inSmalltalk: [(value anyMask: 16r8000000000000000) ifTrue: [value := value - 16r10000000000000000]]. value < 0 ifTrue: [self cCode: [self assert: (self sizeof: value) == 8. self assert: (self sizeof: value << 1) == 8]. "Don't fail for -9223372036854775808/-16r8000000000000000. Alas the simple (negative and: [value - 1 > 0]) isn't adequate since in C the result of signed integer overflow is undefined and hence under optimization this may fail. The shift, however, is well-defined." (negative and: [0 = (self cCode: [value << 1] inSmalltalk: [value << 1 bitAnd: (1 << 64) - 1])]) ifTrue: [^value]. ^self primitiveFail]. ^negative ifTrue:[0 - value] ifFalse:[value]! Item was changed: ----- Method: InterpreterPrimitives>>primitiveChangeClass (in category 'object access primitives') ----- primitiveChangeClass "Primitive. Change the class of the receiver into the class of the argument given that the format of the receiver matches the format of the argument's class. Fail if the receiver or argument are SmallIntegers, or the receiver is an instance of a compact class and the argument isn't, or when the argument's class is compact and the receiver isn't, or when the format of the receiver is different from the format of the argument's class, or when the arguments class is fixed and the receiver's size differs from the size that an instance of the argument's class should have." | arg rcvr argClass err | arg := self stackObjectValue: 0. rcvr := self stackObjectValue: 1. self successful ifFalse:[^nil]. + argClass := objectMemory fetchClassOfNonImm: arg. - argClass := objectMemory fetchClassOfNonInt: arg. err := objectMemory changeClassOf: rcvr to: argClass. err = 0 ifTrue: ["Flush at cache because rcvr's class has changed." self flushAtCache. self pop: self methodArgumentCount] ifFalse: [self primitiveFailFor: err]. ^nil! Item was changed: ----- Method: InterpreterPrimitives>>primitiveCopyObject (in category 'object access primitives') ----- primitiveCopyObject "Primitive. Copy the state of the receiver from the argument. Fail if receiver and argument are of a different class. Fail if the receiver or argument are non-pointer objects. Fail if receiver and argument have different lengths (for indexable objects). " | rcvr arg length | self methodArgumentCount = 1 ifFalse: [^self primitiveFail]. arg := self stackObjectValue: 0. rcvr := self stackObjectValue: 1. self failed ifTrue:[^nil]. (objectMemory isPointers: rcvr) ifFalse: [^self primitiveFail]. + (objectMemory fetchClassOfNonImm: rcvr) = (objectMemory fetchClassOfNonImm: arg) ifFalse: - (objectMemory fetchClassOfNonInt: rcvr) = (objectMemory fetchClassOfNonInt: arg) ifFalse: [^self primitiveFail]. length := objectMemory lengthOf: rcvr. length = (objectMemory lengthOf: arg) ifFalse: [^self primitiveFail]. "Now copy the elements" 0 to: length-1 do:[:i| objectMemory storePointer: i ofObject: rcvr withValue: (objectMemory fetchPointer: i ofObject: arg)]. "Note: The above could be faster for young receivers but I don't think it'll matter" self pop: 1. "pop arg; answer receiver" ! Item was changed: ----- Method: InterpreterPrimitives>>primitiveNextInstance (in category 'object access primitives') ----- primitiveNextInstance + | object subsequentObject | - | object classPointer subsequentObject | object := self stackTop. + (objectMemory isImmediate: object) ifFalse: + [subsequentObject := objectMemory instanceAfter: object. + subsequentObject ifNotNil: + [^self pop: argumentCount+1 thenPush: subsequentObject]]. - (objectMemory isIntegerObject: object) ifFalse: - [classPointer := objectMemory fetchClassOfNonInt: object. - subsequentObject := objectMemory objectAfter: object. - [self oop: subsequentObject isLessThan: objectMemory freeStart] whileTrue: - [((objectMemory isFreeObject: subsequentObject) not - and: [(objectMemory fetchClassOfNonInt: subsequentObject) = classPointer]) ifTrue: - [^self pop: argumentCount+1 thenPush: subsequentObject]. - subsequentObject := objectMemory objectAfter: subsequentObject]]. self primitiveFail! Item was changed: ----- Method: InterpreterPrimitives>>primitiveStopVMProfiling (in category 'process primitives') ----- primitiveStopVMProfiling "Primitive. Stop the VM profiler and either copy the histogram data into the supplied arguments, if they're non-nil. Fail if the arguments are not of the right type or size." | vmHistArrayOrNil vmHist vmBins easHistArrayOrNil easHist easBins | <var: #vmHist type: #'long *'> <var: #vmBins type: #long> <var: #easHist type: #'long *'> <var: #easBins type: #long> self success: argumentCount = 2. vmHistArrayOrNil := self stackObjectValue: 1. easHistArrayOrNil := self stackObjectValue: 0. self successful ifFalse: [^nil]. "Both args must be either nil or arrays. If they're arrays and the wrong size we incorrectly stop profiling." + ((vmHistArrayOrNil = objectMemory nilObject or: [(objectMemory fetchClassOfNonImm: vmHistArrayOrNil) = (objectMemory splObj: ClassArray)]) + and: [(objectMemory fetchClassOfNonImm: vmHistArrayOrNil) = (objectMemory fetchClassOfNonImm: easHistArrayOrNil)]) ifFalse: - ((vmHistArrayOrNil = objectMemory nilObject or: [(objectMemory fetchClassOfNonInt: vmHistArrayOrNil) = (objectMemory splObj: ClassArray)]) - and: [(objectMemory fetchClassOfNonInt: vmHistArrayOrNil) = (objectMemory fetchClassOfNonInt: easHistArrayOrNil)]) ifFalse: [^self primitiveFail]. self cCode: 'ioControlProfile(0,&vmHist,&vmBins,&easHist,&easBins)' inSmalltalk: [vmHist := vmBins := easHist := easBins := 0]. vmHistArrayOrNil ~= objectMemory nilObject ifTrue: [((objectMemory fetchWordLengthOf: vmHistArrayOrNil) = vmBins and: [(objectMemory fetchWordLengthOf: easHistArrayOrNil) = easBins]) ifFalse: [^self primitiveFail]. 0 to: vmBins - 1 do: [:i| objectMemory storePointerUnchecked: i ofObject: vmHistArrayOrNil withValue: (objectMemory integerObjectOf: (vmHist at: i))]. 0 to: easBins - 1 do: [:i| objectMemory storePointerUnchecked: i ofObject: easHistArrayOrNil withValue: (objectMemory integerObjectOf: (easHist at: i))]]. self pop: argumentCount! Item was changed: ----- Method: NewObjectMemory>>lookupAddress: (in category 'simulation') ----- lookupAddress: address "If address appears to be that of a Symbol or a few well-known objects (such as classes) answer it, otherwise answer nil. For code disassembly" <doNotGenerate> | fmt size string class classSize maybeThisClass classNameIndex thisClassIndex | (self addressCouldBeObj: address) ifFalse: [^nil]. fmt := self formatOf: address. size := self lengthOf: address baseHeader: (self baseHeader: address) format: fmt. size = 0 ifTrue: [^address caseOf: { [nilObj] -> ['nil']. [trueObj] -> ['true']. [falseObj] -> ['false'] } otherwise: []]. ((fmt between: 8 and: 11) "indexable byte fields" and: [(size between: 1 and: 64) and: [Scanner isLiteralSymbol: (string := (0 to: size - 1) collect: [:i| Character value: (self fetchByte: i ofObject: address)])]]) ifTrue: [^'#', (ByteString withAll: string)]. + class := self fetchClassOfNonImm: address. - class := self fetchClassOfNonInt: address. ((self addressCouldBeObj: class) and: [(self headerType: class) ~= HeaderTypeShort]) ifFalse: [^nil]. "address is either a class or a metaclass, or an instance of a class or invalid. determine which." classNameIndex := coInterpreter classNameIndex. thisClassIndex := coInterpreter thisClassIndex. ((classSize := self lengthOf: class baseHeader: (self baseHeader: address) format: fmt) <= (classNameIndex max: thisClassIndex) or: [classSize > 255]) ifTrue: [^nil]. "Address could be a class or a metaclass" (fmt = 1 and: [size >= classNameIndex]) ifTrue: ["Is address a class? If so class's thisClass is address." (self lookupAddress: (self fetchPointer: classNameIndex ofObject: address)) ifNotNil: [:maybeClassName| (self fetchPointer: thisClassIndex ofObject: class) = address ifTrue: [^maybeClassName allButFirst]]. "Is address a Metaclass? If so class's name is Metaclass and address's thisClass holds the class name" ((self isBytes: (self fetchPointer: classNameIndex ofObject: class)) and: [(self lookupAddress: (self fetchPointer: classNameIndex ofObject: class)) = '#Metaclass' and: [size >= thisClassIndex]]) ifTrue: [maybeThisClass := self fetchPointer: thisClassIndex ofObject: address. (self lookupAddress: (self fetchPointer: classNameIndex ofObject: maybeThisClass)) ifNotNil: [:maybeThisClassName| ^maybeThisClassName allButFirst, ' class']]]. ^(self lookupAddress: (self fetchPointer: classNameIndex ofObject: class)) ifNotNil: [:maybeClassName| 'a(n) ', maybeClassName allButFirst]! Item was changed: ----- Method: NewObjectMemory>>oopHasAcceptableClass: (in category 'image segment in/out') ----- oopHasAcceptableClass: signedOop "Similar to oopHasOkayClass:, except that it only returns true or false." | oopClass formatMask behaviorFormatBits oopFormatBits oop | <var: #oop type: #usqInt> <var: #oopClass type: #usqInt> (self isIntegerObject: signedOop) ifTrue: [^ true]. oop := self cCoerce: signedOop to: #usqInt. (self addressCouldBeObj: oop) ifFalse: [^ false]. + oopClass := self cCoerce: (self fetchClassOfNonImm: oop) to: #usqInt. - oopClass := self cCoerce: (self fetchClassOfNonInt: oop) to: #usqInt. (self addressCouldBeObj: oopClass) ifFalse: [^ false]. (oopClass + (self sizeBitsOf: oopClass)) <= freeStart ifFalse: [^ false]. ((self isPointersNonInt: oopClass) and: [(self lengthOf: oopClass) >= 3]) ifFalse: [^ false]. formatMask := (self isBytesNonInt: oop) ifTrue: [16rC00] "ignore extra bytes size bits" ifFalse: [16rF00]. behaviorFormatBits := (self formatOfClass: oopClass) bitAnd: formatMask. oopFormatBits := (self baseHeader: oop) bitAnd: formatMask. behaviorFormatBits = oopFormatBits ifFalse: [^ false]. ^ true! Item was changed: ----- Method: NewspeakInterpreter>>bytecodePrimValue (in category 'common selector sends') ----- bytecodePrimValue "In-line value for BlockClosure and BlockContext" | maybeBlock rcvrClass | maybeBlock := self internalStackTop. self initPrimCall. argumentCount := 0. (self isNonIntegerObject: maybeBlock) ifTrue: + [rcvrClass := self fetchClassOfNonImm: maybeBlock. - [rcvrClass := self fetchClassOfNonInt: maybeBlock. rcvrClass = (self splObj: ClassBlockClosure) ifTrue: [self externalizeIPandSP. self primitiveClosureValue. self internalizeIPandSP] ifFalse: [rcvrClass = (self splObj: ClassBlockContext) ifTrue: [self externalizeIPandSP. self primitiveValue. self internalizeIPandSP] ifFalse: [self primitiveFail]]]. self successful ifFalse: [messageSelector := self specialSelector: 25. ^self normalSend]. self fetchNextBytecode! Item was changed: ----- Method: NewspeakInterpreter>>bytecodePrimValueWithArg (in category 'common selector sends') ----- bytecodePrimValueWithArg "In-line value: for BlockClosure and BlockContext" | maybeBlock rcvrClass | maybeBlock := self internalStackValue: 1. self initPrimCall. argumentCount := 1. (self isNonIntegerObject: maybeBlock) ifTrue: + [rcvrClass := self fetchClassOfNonImm: maybeBlock. - [rcvrClass := self fetchClassOfNonInt: maybeBlock. rcvrClass = (self splObj: ClassBlockClosure) ifTrue: [self externalizeIPandSP. self primitiveClosureValue. self internalizeIPandSP] ifFalse: [rcvrClass = (self splObj: ClassBlockContext) ifTrue: [self externalizeIPandSP. self primitiveValue. self internalizeIPandSP] ifFalse: [self primitiveFail]]]. self successful ifFalse: [messageSelector := self specialSelector: 26. ^self normalSend]. self fetchNextBytecode! Item was changed: ----- Method: NewspeakInterpreter>>commonAt: (in category 'indexing primitive support') ----- commonAt: stringy "This code is called if the receiver responds primitively to at:. If this is so, it will be installed in the atCache so that subsequent calls of at: or next may be handled immediately in bytecode primitive routines." | index rcvr atIx result | self initPrimCall. rcvr := self stackObjectValue: 1. self successful ifFalse: [^self primitiveFailFor: PrimErrInappropriate]. index := self positive32BitValueOf: self stackTop. self successful ifFalse: [^self primitiveFailFor: PrimErrBadArgument]. "NOTE: The at-cache, since it is specific to the non-super response to #at:. Therefore we must determine that the message is #at: (not, eg, #basicAt:), and that the send is not a super-send, before using the at-cache." (messageSelector = (self specialSelector: 16) + and: [lkupClass = (self fetchClassOfNonImm: rcvr)]) - and: [lkupClass = (self fetchClassOfNonInt: rcvr)]) ifTrue: ["OK -- look in the at-cache" atIx := rcvr bitAnd: AtCacheMask. "Index into atCache = 4N, for N = 0 ... 7" (atCache at: atIx+AtCacheOop) = rcvr ifFalse: ["Rcvr not in cache. Install it..." self install: rcvr inAtCache: atCache at: atIx string: stringy]. self successful ifTrue: [result := self commonVariable: rcvr at: index cacheIndex: atIx]. self successful ifTrue: [^ self pop: argumentCount+1 thenPush: result]]. "The slow but sure way..." self initPrimCall. result := self stObject: rcvr at: index. self successful ifTrue: [stringy ifTrue: [result := self characterForAscii: (self integerValueOf: result)]. ^ self pop: argumentCount+1 thenPush: result]! Item was changed: ----- Method: NewspeakInterpreter>>commonAtPut: (in category 'indexing primitive support') ----- commonAtPut: stringy "This code is called if the receiver responds primitively to at:Put:. If this is so, it will be installed in the atPutCache so that subsequent calls of at: or next may be handled immediately in bytecode primitive routines." | value index rcvr atIx | self initPrimCall. rcvr := self stackObjectValue: 2. self successful ifFalse: [^self primitiveFailFor: PrimErrInappropriate]. index := self positive32BitValueOf: (self stackValue: 1). self successful ifFalse: [^self primitiveFailFor: PrimErrBadArgument]. (self isOopImmutable: rcvr) ifTrue: [^self primitiveFailFor: PrimErrNoModification]. value := self stackTop. "NOTE: The atPut-cache, since it is specific to the non-super response to #at:Put:. Therefore we must determine that the message is #at:Put: (not, eg, #basicAt:Put:), and that the send is not a super-send, before using the at-cache." (messageSelector = (self specialSelector: 17) + and: [lkupClass = (self fetchClassOfNonImm: rcvr)]) - and: [lkupClass = (self fetchClassOfNonInt: rcvr)]) ifTrue: ["OK -- look in the at-cache" atIx := (rcvr bitAnd: AtCacheMask) + AtPutBase. "Index into atPutCache" (atCache at: atIx+AtCacheOop) = rcvr ifFalse: ["Rcvr not in cache. Install it..." self install: rcvr inAtCache: atCache at: atIx string: stringy]. self successful ifTrue: [self commonVariable: rcvr at: index put: value cacheIndex: atIx]. self successful ifTrue: [^ self pop: argumentCount+1 thenPush: value]]. "The slow but sure way..." self initPrimCall. stringy ifTrue: [self stObject: rcvr at: index put: (self asciiOfCharacter: value)] ifFalse: [self stObject: rcvr at: index put: value]. self successful ifTrue: [^ self pop: argumentCount+1 thenPush: value]. ! Item was changed: ----- Method: NewspeakInterpreter>>dbgFloatValueOf: (in category 'utilities') ----- dbgFloatValueOf: oop "This version answers the value of a float or nil if not a flat *WITHOUT* setting successFlag or any other such nonsense. It is hence safe for use in debug printing. Sheesh." | result | <returnTypeC: #double> <var: #result type: #double> self flag: #Dan. "None of the float stuff has been converted for 64 bits" ((self isNonIntegerObject: oop) + and: [(self fetchClassOfNonImm: oop) = (self splObj: ClassFloat)]) ifTrue: - and: [(self fetchClassOfNonInt: oop) = (self splObj: ClassFloat)]) ifTrue: [self cCode: '' inSmalltalk: [result := Float new: 2]. self fetchFloatAt: oop + BaseHeaderSize into: result. ^result]. ^nil! Item was changed: ----- Method: NewspeakInterpreter>>doSignalSemaphoreWithIndex: (in category 'process primitive support') ----- doSignalSemaphoreWithIndex: index "Signal the external semaphore with the given index. Answer if a context switch occurs as a result. Do not bounds check. This has been done in the caller." <api> | xArray semaphoreClass sema | xArray := self splObj: ExternalObjectsArray. semaphoreClass := self splObj: ClassSemaphore. sema := self fetchPointer: index - 1 ofObject: xArray. "Note: semaphore indices are 1-based" ^(self isNonIntegerObject: sema) + and: [(self fetchClassOfNonImm: sema) = semaphoreClass - and: [(self fetchClassOfNonInt: sema) = semaphoreClass and: [self synchronousSignal: sema]]! Item was changed: ----- Method: NewspeakInterpreter>>initializeExtraClassInstVarIndices (in category 'initialization') ----- initializeExtraClassInstVarIndices "Initialize metaclassSizeBits and thisClassIndex which are used in debug printing, and classNameIndex which is used not only for debug printing but for is:KindOf: & is:MemberOf: via classNameOf:is: (evil but a reality we have to accept)." | classArrayObj classArrayClass | classNameIndex := 6. "default" thisClassIndex := 5. "default" classArrayObj := self splObj: ClassArray. + classArrayClass := self fetchClassOfNonImm: classArrayObj. - classArrayClass := self fetchClassOfNonInt: classArrayObj. metaclassSizeBits := self sizeBitsOf: classArrayClass. "determine actual (Metaclass instSize * 4)" InstanceSpecificationIndex + 1 to: (self lengthOf: classArrayClass) do: [:i| (self fetchPointer: i ofObject: classArrayClass) = classArrayObj ifTrue: [thisClassIndex := i]]. InstanceSpecificationIndex + 1 to: (self lengthOf: classArrayObj) do: [:i| | oop | oop := self fetchPointer: i ofObject: classArrayObj. ((self isBytes: oop) and: [(self lengthOf: oop) = 5 and: [(self str: 'Array' n: (self firstFixedField: oop) cmp: 5) = 0]]) ifTrue: [classNameIndex := i]]! Item was changed: ----- Method: NewspeakInterpreter>>isFloatObject: (in category 'internal interpreter access') ----- isFloatObject: oop ^(self isNonIntegerObject: oop) + and: [(self fetchClassOfNonImm: oop) = self classFloat]! - and: [(self fetchClassOfNonInt: oop) = self classFloat]! Item was changed: ----- Method: NewspeakInterpreter>>primitiveChangeClass (in category 'object access primitives') ----- primitiveChangeClass "Primitive. Change the class of the receiver into the class of the argument given that the format of the receiver matches the format of the argument's class. Fail if the receiver or argument are SmallIntegers, or the receiver is an instance of a compact class and the argument isn't, or when the argument's class is compact and the receiver isn't, or when the format of the receiver is different from the format of the argument's class, or when the arguments class is fixed and the receiver's size differs from the size that an instance of the argument's class should have." | arg rcvr argClass err | arg := self stackObjectValue: 0. rcvr := self stackObjectValue: 1. self successful ifFalse:[^nil]. + argClass := self fetchClassOfNonImm: arg. - argClass := self fetchClassOfNonInt: arg. err := self changeClassOf: rcvr to: argClass. err = 0 ifTrue: ["Flush at cache because rcvr's class has changed." self flushAtCache. self pop: self methodArgumentCount] ifFalse: [self primitiveFailFor: err]. ^nil! Item was changed: ----- Method: NewspeakInterpreter>>printAllStacks (in category 'debug printing') ----- printAllStacks "Print all the stacks of all running processes, including those that are currently suspended." <api> | oop classObj proc semaphoreClass schedLists processList | <inline: false> proc := self activeProcess. self printNameOfClass: (self fetchClassOf: proc) count: 5; space; printHex: proc. self print: ' priority '; printNum: (self quickFetchInteger: PriorityIndex ofObject: proc); cr. self printContextCallStackOf: activeContext. semaphoreClass := self classSemaphore. oop := self firstObject. [self oop: oop isLessThan: freeBlock] whileTrue: + [classObj := self fetchClassOfNonImm: oop. - [classObj := self fetchClassOfNonInt: oop. (classObj = semaphoreClass) ifTrue: [self printProcsOnList: oop]. oop := self objectAfter: oop]. schedLists := self fetchPointer: ProcessListsIndex ofObject: self schedulerPointer. (self fetchWordLengthOf: schedLists) - 1 to: 0 by: -1 do: [:pri| processList := self fetchPointer: pri ofObject: schedLists. (self isEmptyList: processList) ifFalse: [self cr; print: 'processes at priority '; printNum: pri + 1. self printProcsOnList: processList]]! Item was changed: ----- Method: NewspeakInterpreter>>printOop: (in category 'debug printing') ----- printOop: oop | cls fmt lastIndex startIP bytecodesPerLine | <inline: false> self printHex: oop. (self isIntegerObject: oop) ifTrue: [^self cCode: 'printf("=%ld\n", (long)integerValueOf(oop))' inSmalltalk: [self print: (self shortPrint: oop); cr]]. (oop between: self startOfMemory and: freeBlock) ifFalse: [self printHex: oop; print: ' is not on the heap'; cr. ^nil]. (oop bitAnd: (BytesPerWord - 1)) ~= 0 ifTrue: [self printHex: oop; print: ' is misaligned'; cr. ^nil]. (self isFreeObject: oop) ifTrue: [self print: ' free chunk of size '; printNum: (self sizeOfFree: oop); cr. ^nil]. self print: ': a(n) '. + self printNameOfClass: (cls := self fetchClassOfNonImm: oop) count: 5. - self printNameOfClass: (cls := self fetchClassOfNonInt: oop) count: 5. cls = (self splObj: ClassFloat) ifTrue: [self cr; printFloat: (self dbgFloatValueOf: oop); cr. ^nil]. fmt := self formatOf: oop. fmt > 4 ifTrue: [self print: ' nbytes '; printNum: (self byteSizeOf: oop)]. self cr. (fmt > 4 and: [fmt < 12]) ifTrue: [(self isWords: oop) ifTrue: [lastIndex := 64 min: ((self byteSizeOf: oop) / BytesPerWord). lastIndex > 0 ifTrue: [1 to: lastIndex do: [:index| self space; printHex: (self fetchLong32: index - 1 ofObject: oop). (index \\ self elementsPerPrintOopLine) = 0 ifTrue: [self cr]]. (lastIndex \\ self elementsPerPrintOopLine) = 0 ifFalse: [self cr]]. ^nil]. ^self printStringOf: oop; cr]. lastIndex := 64 min: (startIP := (self lastPointerOf: oop) / BytesPerWord). lastIndex > 0 ifTrue: [1 to: lastIndex do: [:index| self cCode: 'printHex(fetchPointerofObject(index - 1, oop)); putchar('' '')' inSmalltalk: [self space; printHex: (self fetchPointer: index - 1 ofObject: oop); space. self print: (self shortPrint: (self fetchPointer: index - 1 ofObject: oop))]. (index \\ self elementsPerPrintOopLine) = 0 ifTrue: [self cr]]. (lastIndex \\ self elementsPerPrintOopLine) = 0 ifFalse: [self cr]]. (self isCompiledMethod: oop) ifFalse: [startIP > 64 ifTrue: [self print: '...'; cr]] ifTrue: [startIP := startIP * BytesPerWord + 1. lastIndex := self lengthOf: oop. lastIndex - startIP > 100 ifTrue: [lastIndex := startIP + 100]. bytecodesPerLine := 10. startIP to: lastIndex do: [:index| | byte | byte := self fetchByte: index - 1 ofObject: oop. self cCode: 'printf(" %02x/%-3d", byte,byte)' inSmalltalk: [self space; print: (byte radix: 16); printChar: $/; printNum: byte]. ((index - startIP + 1) \\ bytecodesPerLine) = 0 ifTrue: [self cr]]. ((lastIndex - startIP + 1) \\ bytecodesPerLine) = 0 ifFalse: [self cr]]! Item was changed: ----- Method: NewspeakInterpreter>>sendInvokeCallback:Stack:Registers:Jmpbuf: (in category 'callback support') ----- sendInvokeCallback: thunkPtr Stack: stackPtr Registers: regsPtr Jmpbuf: jmpBufPtr "Send the 4 argument callback message invokeCallback:stack:registers:jmpbuf: to Alien class with the supplied args. The arguments are raw C addresses and are converted to integer objects on the way." | where | <export: true> self pushRemappableOop: (self positive32BitIntegerFor: jmpBufPtr). self pushRemappableOop: (self positive32BitIntegerFor: regsPtr). self pushRemappableOop: (self positive32BitIntegerFor: stackPtr). self pushRemappableOop: (self positive32BitIntegerFor: thunkPtr). receiver := self splObj: ClassAlien. + lkupClass := self fetchClassOfNonImm: receiver. - lkupClass := self fetchClassOfNonInt: receiver. messageSelector := self splObj: SelectorInvokeCallback. (self lookupInMethodCacheSel: messageSelector class: lkupClass) ifFalse: [(self lookupMethodNoMNUEtcInClass: lkupClass) ifFalse: [^false]]. ((self argumentCountOf: newMethod) = 4 and: [primitiveFunctionPointer = 0]) ifFalse: [^false]. self storeContextRegisters: activeContext. self justActivateNewMethod. where := activeContext + BaseHeaderSize + (ReceiverIndex << ShiftForWord). self longAt: where + (1 << ShiftForWord) put: self popRemappableOop. self longAt: where + (2 << ShiftForWord) put: self popRemappableOop. self longAt: where + (3 << ShiftForWord) put: self popRemappableOop. self longAt: where + (4 << ShiftForWord) put: self popRemappableOop. self interpret. "not reached" ^true! Item was changed: ----- Method: NewspeakInterpreter>>sendInvokeCallbackContext: (in category 'callback support') ----- sendInvokeCallbackContext: vmCallbackContext "Send the calllback message to Alien class with the supplied arg(s). Use either the 1 arg invokeCallbackContext: or the 4 arg invokeCallback:stack:registers:jmpbuf: message, depending on what selector is installed in the specialObjectsArray. Note that if invoking the legacy invokeCallback:stack:registers:jmpbuf: we pass the vmCallbackContext as the jmpbuf argument (see reestablishContextPriorToCallback:). The arguments are raw C addresses and are converted to integer objects on the way." <export: true> <var: #vmCallbackContext type: #'VMCallbackContext *'> | relativeSP | receiver := self splObj: ClassAlien. + lkupClass := self fetchClassOfNonImm: receiver. - lkupClass := self fetchClassOfNonInt: receiver. messageSelector := self splObj: SelectorInvokeCallback. (self lookupInMethodCacheSel: messageSelector class: lkupClass) ifFalse: [(self lookupMethodNoMNUEtcInClass: lkupClass) ~= 0 ifTrue: [^false]]. primitiveFunctionPointer ~= 0 ifTrue: [^false]. self storeContextRegisters: activeContext. self justActivateNewMethod. relativeSP := stackPointer - activeContext. stackPointer := activeContext + BaseHeaderSize + (ReceiverIndex * BytesPerWord). self cppIf: BytesPerWord = 8 ifTrue: [(self argumentCountOf: newMethod) = 4 ifTrue: [self push: (self positive64BitIntegerFor: vmCallbackContext thunkp asUnsignedInteger). self push: (self positive64BitIntegerFor: vmCallbackContext stackp asUnsignedInteger). self push: (self positive64BitIntegerFor: vmCallbackContext intregargsp asUnsignedInteger)]. self push: (self positive64BitIntegerFor: vmCallbackContext asUnsignedInteger)] ifFalse: [(self argumentCountOf: newMethod) = 4 ifTrue: [self push: (self positive32BitIntegerFor: vmCallbackContext thunkp asUnsignedInteger). self push: (self positive32BitIntegerFor: vmCallbackContext stackp asUnsignedInteger). self push: (self positive32BitIntegerFor: vmCallbackContext intregargsp asUnsignedInteger)]. self push: (self positive32BitIntegerFor: vmCallbackContext asUnsignedInteger)]. stackPointer := activeContext + relativeSP. self assert: (self validInstructionPointer: instructionPointer inMethod: method). self interpret. "not reached" ^true! Item was added: + ----- Method: ObjectMemory>>allocationUnit (in category 'allocation') ----- + allocationUnit + ^BytesPerWord! Item was added: + ----- Method: ObjectMemory>>fetchClassOfNonImm: (in category 'interpreter access') ----- + fetchClassOfNonImm: oop + | ccIndex | + <inline: true> + <asmLabel: false> + ^(ccIndex := (self compactClassIndexOf: oop)) = 0 + ifTrue: [(self classHeader: oop) bitAnd: AllButTypeMask] + ifFalse: [self compactClassAt: ccIndex]! Item was removed: - ----- Method: ObjectMemory>>fetchClassOfNonInt: (in category 'interpreter access') ----- - fetchClassOfNonInt: oop - | ccIndex | - <inline: true> - <asmLabel: false> - ^(ccIndex := (self compactClassIndexOf: oop)) = 0 - ifTrue: [(self classHeader: oop) bitAnd: AllButTypeMask] - ifFalse: [self compactClassAt: ccIndex]! Item was added: + ----- Method: ObjectMemory>>firstByteFormat (in category 'header access') ----- + firstByteFormat + ^8! Item was changed: ----- Method: ObjectMemory>>fixedFieldsOf:format:length: (in category 'object format') ----- fixedFieldsOf: oop format: fmt length: wordLength " NOTE: This code supports the backward-compatible extension to 8 bits of instSize. When we revise the image format, it should become... ^ (classFormat >> 2 bitAnd: 16rFF) - 1 " | class classFormat | <inline: true> <asmLabel: false> ((fmt > 4) or: [fmt = 2]) ifTrue: [^0]. "indexable fields only" fmt < 2 ifTrue: [^wordLength]. "fixed fields only (zero or more)" "fmt = 3 or 4: mixture of fixed and indexable fields, so must look at class format word" + class := self fetchClassOfNonImm: oop. - class := self fetchClassOfNonInt: oop. classFormat := self formatOfClass: class. ^(classFormat >> 11 bitAnd: 16rC0) + (classFormat >> 2 bitAnd: 16r3F) - 1! Item was changed: + ----- Method: ObjectMemory>>instanceAfter: (in category 'primitive support') ----- + instanceAfter: objOop + "Answer the next instance of objOop's class in the canonical enumeration order, + if it exists, otherwise answer nil." + | classPointer subsequentObject | + classPointer := self fetchClassOfNonImm: objOop. + subsequentObject := self objectAfter: objOop. + [self oop: subsequentObject isLessThan: self freeStart] whileTrue: + [((self isFreeObject: subsequentObject) not + and: [(self fetchClassOfNonImm: subsequentObject) = classPointer]) ifTrue: + [^subsequentObject]. + subsequentObject := self objectAfter: subsequentObject]. + ^nil! - ----- Method: ObjectMemory>>instanceAfter: (in category 'object enumeration') ----- - instanceAfter: objectPointer - "Support for instance enumeration. Return the next instance - of the class of the given object, or nilObj if the enumeration - is complete." - | classPointer thisObj thisClass | - classPointer := self fetchClassOfNonInt: objectPointer. - thisObj := self accessibleObjectAfter: objectPointer. - [thisObj = nil] whileFalse: - [thisClass := self fetchClassOfNonInt: thisObj. - thisClass = classPointer ifTrue: [^ thisObj]. - thisObj := self accessibleObjectAfter: thisObj]. - ^ nilObj! Item was added: + ----- Method: ObjectMemory>>isPointersNonImm: (in category 'header access') ----- + isPointersNonImm: objOop + "Answer if the argument has only fields that can hold oops. See comment in formatOf:" + + ^(self formatOf: objOop) <= 4! Item was changed: ----- Method: ObjectMemory>>nonWeakFieldsOf: (in category 'object format') ----- nonWeakFieldsOf: oop "Return the number of non-weak fields in oop (i.e. the number of fixed fields). Note: The following is copied from fixedFieldsOf:format:length: since we do know the format of the oop (e.g. format = 4) and thus don't need the length." | class classFormat | self assert: (self isWeakNonInt: oop). "fmt = 3 or 4: mixture of fixed and indexable fields, so must look at class format word" + class := self fetchClassOfNonImm: oop. - class := self fetchClassOfNonInt: oop. classFormat := self formatOfClass: class. ^(classFormat >> 11 bitAnd: 16rC0) + (classFormat >> 2 bitAnd: 16r3F) - 1! Item was changed: ----- Method: ObjectMemory>>oopHasAcceptableClass: (in category 'image segment in/out') ----- oopHasAcceptableClass: signedOop "Similar to oopHasOkayClass:, except that it only returns true or false." | oopClass formatMask behaviorFormatBits oopFormatBits oop | <var: #oop type: #usqInt> <var: #oopClass type: #usqInt> (self isIntegerObject: signedOop) ifTrue: [^ true]. oop := self cCoerce: signedOop to: #usqInt. (self addressCouldBeObj: oop) ifFalse: [^ false]. + oopClass := self cCoerce: (self fetchClassOfNonImm: oop) to: #usqInt. - oopClass := self cCoerce: (self fetchClassOfNonInt: oop) to: #usqInt. (self addressCouldBeObj: oopClass) ifFalse: [^ false]. (oopClass + (self sizeBitsOf: oopClass)) < freeBlock ifFalse: [^ false]. ((self isPointersNonInt: oopClass) and: [(self lengthOf: oopClass) >= 3]) ifFalse: [^ false]. formatMask := (self isBytesNonInt: oop) ifTrue: [16rC00] "ignore extra bytes size bits" ifFalse: [16rF00]. behaviorFormatBits := (self formatOfClass: oopClass) bitAnd: formatMask. oopFormatBits := (self baseHeader: oop) bitAnd: formatMask. behaviorFormatBits = oopFormatBits ifFalse: [^ false]. ^ true! Item was changed: ----- Method: ObjectMemory>>printInstancesOf: (in category 'debug printing') ----- printInstancesOf: aClassOop "Scan the heap printing the oops of any and all objects that are instances of aClassOop" | oop | <api> oop := self firstAccessibleObject. [oop = nil] whileFalse: + [(self fetchClassOfNonImm: oop) = aClassOop ifTrue: - [(self fetchClassOfNonInt: oop) = aClassOop ifTrue: [self printHex: oop; cr]. oop := self accessibleObjectAfter: oop]! Item was added: + ----- Method: Spur32BitMMLESimulator>>byteAtPointer: (in category 'memory access') ----- + byteAtPointer: pointer + "This gets implemented by Macros in C, where its types will also be checked. + pointer is a raw address." + + ^self byteAt: pointer! Item was removed: - ----- Method: Spur32BitMemoryManager>>isImmediate: (in category 'object testing') ----- - isImmediate: oop - ^(oop bitAnd: 3) ~= 0! Item was removed: - ----- Method: Spur32BitMemoryManager>>isNonImmediate: (in category 'object testing') ----- - isNonImmediate: oop - ^(oop bitAnd: 3) = 0! Item was added: + ----- Method: Spur32BitMemoryManager>>tagMask (in category 'word size') ----- + tagMask + ^3! Item was removed: - ----- Method: Spur64BitMemoryManager>>isImmediate: (in category 'object testing') ----- - isImmediate: oop - ^(oop bitAnd: 7) ~= 0! Item was removed: - ----- Method: Spur64BitMemoryManager>>isNonImmediate: (in category 'object testing') ----- - isNonImmediate: oop - ^(oop bitAnd: 7) = 0! Item was added: + ----- Method: Spur64BitMemoryManager>>tagMask (in category 'word size') ----- + tagMask + ^7! Item was changed: ----- Method: SpurGenerationScavenger>>scavengeReferentsOf: (in category 'scavenger') ----- scavengeReferentsOf: referrer "scavengeReferentsOf: referrer inspects all the pointers in referrer. If any are new objects, it has them moved to FutureSurvivorSpace, and returns truth. If there are no new referents, it returns falsity." - <var: #referrer type: #'object *'> | foundNewReferent | + "manager isPointersNonImm: referrer) ifFalse: - "referrer isPointers ifFalse: [^false]." foundNewReferent := false. 0 to: (manager numPointerSlotsOf: referrer) do: [:i| | referent | referent := manager fetchPointer: i ofObject: referrer. ((manager isNonImmediate: referent) and: [manager isYoung: referent]) ifTrue: [foundNewReferent := true. (manager isForwarded: referent) ifFalse: [self copyAndForward: referent]. manager storePointerUnchecked: i ofObject: referrer withValue: (manager forwardingPointerOf: referent)]]. ^foundNewReferent! Item was changed: ----- Method: SpurGenerationScavenger>>scavengeRememberedSetStartingAt: (in category 'scavenger') ----- scavengeRememberedSetStartingAt: n "scavengeRememberedSetStartingAt: n traverses objects in the remembered set starting at the nth one. If the object does not refer to any new objects, it is removed from the set. Otherwise, its new referents are scavenged." | destIndex sourceIndex | sourceIndex := destIndex := n. [sourceIndex < rememberedSetSize] whileTrue: [| referree | referree := rememberedSet at: sourceIndex. (self scavengeReferentsOf: referree) ifTrue: [rememberedSet at: destIndex put: referree. destIndex := destIndex + 1] ifFalse: + [manager setIsRememberedOf: referree to: false]. - [referree isRemembered: false]. sourceIndex := sourceIndex + 1]. rememberedSetSize := destIndex! Item was added: + ----- Method: SpurMemoryManager>>addressCouldBeOop: (in category 'object testing') ----- + addressCouldBeOop: address + ^(self isImmediate: address) + or: [self addressCouldBeObj: address]! Item was added: + ----- Method: SpurMemoryManager>>fetchClassOf: (in category 'object access') ----- + fetchClassOf: oop + | tagBits | + (tagBits := oop bitAnd: self tagMask) = 0 ifTrue: + [^self fetchPointer: tagBits ofObject: classTableFirstPage]. + ^self classAtIndex: (self classIndexOf: oop)! Item was added: + ----- Method: SpurMemoryManager>>fetchClassOfNonImm: (in category 'object access') ----- + fetchClassOfNonImm: objOop + | classIndex | + classIndex := self classIndexOf: objOop. + ^self classAtIndex: classIndex! Item was removed: - ----- Method: SpurMemoryManager>>fetchClassOfNonInt: (in category 'object access') ----- - fetchClassOfNonInt: objOop - | classIndex | - classIndex := self classIndexOf: objOop. - ^self classAtIndex: classIndex! Item was added: + ----- Method: SpurMemoryManager>>fetchWordLengthOf: (in category 'object access') ----- + fetchWordLengthOf: objOop + "NOTE: this gives size appropriate for fetchPointer: n, but not in general for, eg, fetchLong32, etc. + Unlike lengthOf: this does not adjust the length of a context + by the stackPointer and so can be used e.g. by cloneContext:" + ^self numSlotsOf: objOop! Item was changed: ----- Method: SpurMemoryManager>>isImmediate: (in category 'object testing') ----- isImmediate: oop + ^(oop bitAnd: self tagMask) ~= 0! - ^self subclassResponsibility! Item was added: + ----- Method: SpurMemoryManager>>isInOldSpace: (in category 'object testing') ----- + isInOldSpace: address + ^address between: newSpaceLimit and: freeOldSpaceStart! Item was changed: ----- Method: SpurMemoryManager>>isIntegerObject: (in category 'object testing') ----- isIntegerObject: oop (#( makeBaseFrameFor: quickFetchInteger:ofObject: + frameOfMarriedContext: + addressCouldBeClassObj: + isMarriedOrWidowedContext:) includes: thisContext sender method selector) ifFalse: - frameOfMarriedContext:) includes: thisContext sender method selector) ifFalse: [self halt]. ^(oop bitAnd: 1) ~= 0! Item was changed: ----- Method: SpurMemoryManager>>isNonImmediate: (in category 'object testing') ----- isNonImmediate: oop + ^(oop bitAnd: self tagMask) = 0! - ^self subclassResponsibility! Item was added: + ----- Method: SpurMemoryManager>>isOopCompiledMethod: (in category 'object testing') ----- + isOopCompiledMethod: oop + "Answer whether the oop is an object of compiled method format" + <api> + ^(self isNonImmediate: oop) + and: [(self formatOf: oop) >= self firstCompiledMethodFormat]! Item was changed: ----- Method: SpurMemoryManager>>isPointersNonImm: (in category 'object testing') ----- + isPointersNonImm: objOop + "Answer if the argument has only fields that can hold oops. See comment in formatOf:" - isPointersNonImm: objOop ^(self formatOf: objOop) <= 5! Item was changed: ----- Method: SpurMemoryManager>>startOfMemory (in category 'accessing') ----- startOfMemory "Return the start of object memory. This is immediately after the native code zone. N.B. the stack zone is alloca'ed. Use a macro so as not to punish the debug VM." + <cmacro: '() heapBase'> "This is for CoInterpreter, not StackInterpreter" - <cmacro: '() heapBase'> <returnTypeC: #usqInt> + self flag: #fixme. + ^startOfMemory! - ^coInterpreter ifNil: [startOfMemory] ifNotNil: [coInterpreter heapBase]! Item was changed: ----- Method: StackInterpreter>>addressCouldBeClassObj: (in category 'debug support') ----- addressCouldBeClassObj: maybeClassObj "Answer if maybeClassObj looks like a class object" <inline: false> ^(objectMemory addressCouldBeObj: maybeClassObj) + and: [((objectMemory isPointersNonImm: maybeClassObj) and: [(objectMemory lengthOf: maybeClassObj) >= (InstanceSpecificationIndex+1)]) + and: [(objectMemory isPointersNonImm: (objectMemory fetchPointer: SuperclassIndex ofObject: maybeClassObj)) + and: [(objectMemory isPointersNonImm: (objectMemory fetchPointer: MethodDictionaryIndex ofObject: maybeClassObj)) - and: [((objectMemory isPointersNonInt: maybeClassObj) and: [(objectMemory lengthOf: maybeClassObj) >= 3]) - and: [(objectMemory isPointersNonInt: (objectMemory fetchPointer: SuperclassIndex ofObject: maybeClassObj)) - and: [(objectMemory isPointersNonInt: (objectMemory fetchPointer: MethodDictionaryIndex ofObject: maybeClassObj)) and: [(objectMemory isIntegerObject: (objectMemory fetchPointer: InstanceSpecificationIndex ofObject: maybeClassObj))]]]]! Item was changed: ----- Method: StackInterpreter>>checkOkayFields: (in category 'debug support') ----- checkOkayFields: oop "Check if the argument is an ok object. If this is a pointers object, check that its fields are all okay oops." | hasYoung i fieldOop | (oop = nil or: [oop = 0]) ifTrue: [ ^true ]. "?? eem 1/16/2013" (objectMemory isIntegerObject: oop) ifTrue: [ ^true ]. (objectMemory checkOkayOop: oop) ifFalse: [ ^false ]. (self checkOopHasOkayClass: oop) ifFalse: [ ^false ]. ((objectMemory isPointersNonInt: oop) or: [objectMemory isCompiledMethod: oop]) ifFalse: [ ^true ]. + hasYoung := objectMemory isYoung: (objectMemory fetchClassOfNonImm: oop). - hasYoung := objectMemory isYoung: (objectMemory fetchClassOfNonInt: oop). (objectMemory isCompiledMethod: oop) ifTrue: [i := (self literalCountOf: oop) + LiteralStart - 1] ifFalse: [(objectMemory isContext: oop) ifTrue: [i := CtxtTempFrameStart + (self fetchStackPointerOf: oop) - 1] ifFalse: [i := (objectMemory lengthOf: oop) - 1]]. [i >= 0] whileTrue: [fieldOop := objectMemory fetchPointer: i ofObject: oop. (objectMemory isIntegerObject: fieldOop) ifFalse: [hasYoung := hasYoung or: [objectMemory isYoung: fieldOop]. (objectMemory checkOkayOop: fieldOop) ifFalse: [ ^false ]. (self checkOopHasOkayClass: fieldOop) ifFalse: [ ^false ]]. i := i - 1]. hasYoung ifTrue: [^objectMemory checkOkayYoungReferrer: oop]. ^true! Item was changed: ----- Method: StackInterpreter>>checkOopHasOkayClass: (in category 'debug support') ----- checkOopHasOkayClass: obj "Attempt to verify that the given obj has a reasonable behavior. The class must be a valid, non-integer oop and must not be nilObj. It must be a pointers object with three or more fields. Finally, the instance specification field of the behavior must match that of the instance. If OK answer true. If not, print reason and answer false." <api> <var: #oop type: #usqInt> | objClass formatMask behaviorFormatBits objFormatBits | <var: #oopClass type: #usqInt> (objectMemory checkOkayOop: obj) ifFalse: [^false]. + objClass := self cCoerce: (objectMemory fetchClassOfNonImm: obj) to: #usqInt. - objClass := self cCoerce: (objectMemory fetchClassOfNonInt: obj) to: #usqInt. (objectMemory isIntegerObject: objClass) ifTrue: [self print: 'obj '; printHex: obj; print: ' a SmallInteger is not a valid class or behavior'; cr. ^false]. (objectMemory okayOop: objClass) ifFalse: [self print: 'obj '; printHex: obj; print: ' class obj is not ok'; cr. ^false]. ((objectMemory isPointersNonInt: objClass) and: [(objectMemory lengthOf: objClass) >= 3]) ifFalse: [self print: 'obj '; printHex: obj; print: ' a class (behavior) must be a pointers object of size >= 3'; cr. ^false]. formatMask := (objectMemory isBytes: obj) ifTrue: [16rC00] "ignore extra bytes size bits" ifFalse: [16rF00]. behaviorFormatBits := (objectMemory formatOfClass: objClass) bitAnd: formatMask. objFormatBits := (objectMemory baseHeader: obj) bitAnd: formatMask. behaviorFormatBits = objFormatBits ifFalse: [self print: 'obj '; printHex: obj; print: ' and its class (behavior) formats differ'; cr. ^false]. ^true! Item was changed: ----- Method: StackInterpreter>>commonAt: (in category 'indexing primitive support') ----- commonAt: stringy "This code is called if the receiver responds primitively to at:. If this is so, it will be installed in the atCache so that subsequent calls of at: or next may be handled immediately in bytecode primitive routines." | index rcvr atIx result | self initPrimCall. rcvr := self stackValue: 1. (objectMemory isNonIntegerObject: rcvr) ifFalse: [^self primitiveFailFor: PrimErrInappropriate]. index := self stackTop. "No need to test for large positive integers here. No object has 1g elements" (objectMemory isIntegerObject: index) ifFalse: [^self primitiveFailFor: PrimErrBadArgument]. index := objectMemory integerValueOf: index. "NOTE: The at-cache, since it is specific to the non-super response to #at:. Therefore we must determine that the message is #at: (not, eg, #basicAt:), and that the send is not a super-send, before using the at-cache." (messageSelector = (self specialSelector: 16) + and: [lkupClass = (objectMemory fetchClassOfNonImm: rcvr)]) - and: [lkupClass = (objectMemory fetchClassOfNonInt: rcvr)]) ifTrue: ["OK -- look in the at-cache" atIx := rcvr bitAnd: AtCacheMask. "Index into atCache = 4N, for N = 0 ... 7" (atCache at: atIx+AtCacheOop) = rcvr ifFalse: ["Rcvr not in cache. Attempt to install it..." (self install: rcvr inAtCache: atCache at: atIx string: stringy) ifFalse: [self assert: (objectMemory isContextNonInt: rcvr). self initPrimCall. ^self primitiveContextAt]]. self successful ifTrue: [result := self commonVariable: rcvr at: index cacheIndex: atIx]. self successful ifTrue: [^ self pop: argumentCount+1 thenPush: result]]. "The slow but sure way..." self initPrimCall. result := self stObject: rcvr at: index. self successful ifTrue: [stringy ifTrue: [result := self characterForAscii: (objectMemory integerValueOf: result)]. ^ self pop: argumentCount+1 thenPush: result]! Item was changed: ----- Method: StackInterpreter>>commonAtPut: (in category 'indexing primitive support') ----- commonAtPut: stringy "This code is called if the receiver responds primitively to at:Put:. If this is so, it will be installed in the atPutCache so that subsequent calls of at: or next may be handled immediately in bytecode primitive routines." | value index rcvr atIx | value := self stackTop. self initPrimCall. rcvr := self stackValue: 2. (objectMemory isNonIntegerObject: rcvr) ifFalse: [^self primitiveFailFor: PrimErrInappropriate]. index := self stackValue: 1. "No need to test for large positive integers here. No object has 1g elements" (objectMemory isIntegerObject: index) ifFalse: [^self primitiveFailFor: PrimErrBadArgument]. index := objectMemory integerValueOf: index. "NOTE: The atPut-cache, since it is specific to the non-super response to #at:Put:. Therefore we must determine that the message is #at:Put: (not, eg, #basicAt:Put:), and that the send is not a super-send, before using the at-cache." (messageSelector = (self specialSelector: 17) + and: [lkupClass = (objectMemory fetchClassOfNonImm: rcvr)]) - and: [lkupClass = (objectMemory fetchClassOfNonInt: rcvr)]) ifTrue: ["OK -- look in the at-cache" atIx := (rcvr bitAnd: AtCacheMask) + AtPutBase. "Index into atPutCache" (atCache at: atIx+AtCacheOop) = rcvr ifFalse: ["Rcvr not in cache. Attempt to install it..." (self install: rcvr inAtCache: atCache at: atIx string: stringy) ifFalse: [self assert: (objectMemory isContextNonInt: rcvr). self initPrimCall. ^self primitiveContextAtPut]]. self successful ifTrue: [self commonVariable: rcvr at: index put: value cacheIndex: atIx]. self successful ifTrue: [^ self pop: argumentCount+1 thenPush: value]]. "The slow but sure way..." self initPrimCall. stringy ifTrue: [self stObject: rcvr at: index put: (self asciiOfCharacter: value)] ifFalse: [self stObject: rcvr at: index put: value]. self successful ifTrue: [^ self pop: argumentCount+1 thenPush: value]! Item was changed: ----- Method: StackInterpreter>>dbgFloatValueOf: (in category 'utilities') ----- dbgFloatValueOf: oop "This version answers the value of a float or nil if not a flat *WITHOUT* setting successFlag or any other such nonsense. It is hence safe for use in debug printing. Sheesh." | result | <returnTypeC: #double> <var: #result type: #double> self flag: #Dan. "None of the float stuff has been converted for 64 bits" ((objectMemory isNonIntegerObject: oop) + and: [(objectMemory fetchClassOfNonImm: oop) = (objectMemory splObj: ClassFloat)]) ifTrue: - and: [(objectMemory fetchClassOfNonInt: oop) = (objectMemory splObj: ClassFloat)]) ifTrue: [self cCode: '' inSmalltalk: [result := Float new: 2]. objectMemory fetchFloatAt: oop + BaseHeaderSize into: result. ^result]. ^nil! Item was changed: ----- Method: StackInterpreter>>doSignalSemaphoreWithIndex: (in category 'process primitive support') ----- doSignalSemaphoreWithIndex: index "Signal the external semaphore with the given index. Answer if a context switch occurs as a result. Do not bounds check. This has been done in the caller." <api> | xArray semaphoreClass sema | xArray := objectMemory splObj: ExternalObjectsArray. semaphoreClass := objectMemory splObj: ClassSemaphore. sema := objectMemory fetchPointer: index - 1 ofObject: xArray. "Note: semaphore indices are 1-based" ^(objectMemory isNonIntegerObject: sema) + and: [(objectMemory fetchClassOfNonImm: sema) = semaphoreClass - and: [(objectMemory fetchClassOfNonInt: sema) = semaphoreClass and: [self synchronousSignal: sema]]! Item was changed: ----- Method: StackInterpreter>>findApplicationOfTargetMixin:startingAtBehavior: (in category 'newspeak bytecode support') ----- findApplicationOfTargetMixin: targetMixin startingAtBehavior: aBehavior "This is used to implement the innards of the pushImplicitReceiverBytecode, used for outer sends in NS2/NS3. Find the MixinApplcation of which aBehavior is a subclass that is an application of targetMixin. This is an implementation derived from <ContextPart> findApplicationOfTargetMixin: targetMixin startingAtBehavior: aBehavior " | mixinOrMixinApplication mixin | mixinOrMixinApplication := aBehavior. [mixinOrMixinApplication = objectMemory nilObject or: [mixinOrMixinApplication = targetMixin or: [(mixin := objectMemory fetchPointer: MixinIndex ofObject: mixinOrMixinApplication) = targetMixin + or: [(objectMemory fetchClassOfNonImm: mixin) = targetMixin]]]] whileFalse: - or: [(objectMemory fetchClassOfNonInt: mixin) = targetMixin]]]] whileFalse: [mixinOrMixinApplication := objectMemory fetchPointer: SuperclassIndex ofObject: mixinOrMixinApplication]. ^mixinOrMixinApplication! Item was changed: ----- Method: StackInterpreter>>findClassOfMethod:forReceiver: (in category 'debug support') ----- findClassOfMethod: meth forReceiver: rcvr | rclass | (objectMemory addressCouldBeOop: rcvr) ifTrue: [rclass := objectMemory fetchClassOf: rcvr. (self addressCouldBeClassObj: rclass) ifTrue: [rclass := self findClassContainingMethod: meth startingAt: rclass. rclass ~= objectMemory nilObject ifTrue: [^rclass]]]. ((objectMemory addressCouldBeObj: meth) + and: [objectMemory isCompiledMethod: meth]) ifFalse: - and: [self isCompiledMethod: meth]) ifFalse: [^objectMemory nilObject]. ^self findClassContainingMethod: meth startingAt: (self methodClassOf: meth)! Item was changed: ----- Method: StackInterpreter>>initializeExtraClassInstVarIndices (in category 'initialization') ----- initializeExtraClassInstVarIndices "Initialize metaclassSizeBits and thisClassIndex which are used in debug printing, and classNameIndex which is used not only for debug printing but for is:KindOf: & is:MemberOf: via classNameOf:is: (evil but a reality we have to accept)." | classArrayObj classArrayClass | classArrayObj := objectMemory splObj: ClassArray. + classArrayClass := objectMemory fetchClassOfNonImm: classArrayObj. - classArrayClass := objectMemory fetchClassOfNonInt: classArrayObj. metaclassSizeBits := objectMemory sizeBitsOf: classArrayClass. "determine actual (Metaclass instSize * 4)" thisClassIndex := 5. "default" InstanceSpecificationIndex + 1 to: (objectMemory lengthOf: classArrayClass) do: [:i| (objectMemory fetchPointer: i - 1 ofObject: classArrayClass) = classArrayObj ifTrue: [thisClassIndex := i - 1]]. classNameIndex := 6. "default" InstanceSpecificationIndex + 1 to: (objectMemory lengthOf: classArrayObj) do: [:i| | oop | oop := objectMemory fetchPointer: i - 1 ofObject: classArrayObj. ((objectMemory isBytes: oop) and: [(objectMemory lengthOf: oop) = 5 and: [(self str: 'Array' n: (objectMemory firstFixedField: oop) cmp: 5) = 0]]) ifTrue: [classNameIndex := i - 1]]! Item was changed: ----- Method: StackInterpreter>>isFloatObject: (in category 'internal interpreter access') ----- isFloatObject: oop ^(objectMemory isNonIntegerObject: oop) and: [ClassFloatCompactIndex ~= 0 ifTrue: [(objectMemory compactClassIndexOf: oop) = ClassFloatCompactIndex] + ifFalse: [(objectMemory fetchClassOfNonImm: oop) = objectMemory classFloat]]! - ifFalse: [(objectMemory fetchClassOfNonInt: oop) = objectMemory classFloat]]! Item was changed: ----- Method: StackInterpreter>>longPrintOop: (in category 'debug printing') ----- longPrintOop: oop <api> | class fmt lastIndex startIP bytecodesPerLine column | + ((objectMemory isImmediate: oop) + or: [(objectMemory addressCouldBeObj: oop) not + or: [(oop bitAnd: objectMemory allocationUnit - 1) ~= 0 - ((objectMemory isIntegerObject: oop) - or: [(oop between: objectMemory startOfMemory and: objectMemory freeStart) not - or: [(oop bitAnd: (BytesPerWord - 1)) ~= 0 or: [(objectMemory isFreeObject: oop)]]]) ifTrue: [^self printOop: oop]. + class := objectMemory fetchClassOfNonImm: oop. - class := objectMemory fetchClassOfNonInt: oop. self printHex: oop; print: ': a(n) '; printNameOfClass: class count: 5; print: ' ('; printHex: class; print: ')'. fmt := objectMemory formatOf: oop. fmt > 4 ifTrue: [self print: ' nbytes '; printNum: (objectMemory byteLengthOf: oop)]. objectMemory printHeaderTypeOf: oop. self cr. (fmt between: 5 and: 11) ifTrue: [^self]. lastIndex := 256 min: (startIP := (objectMemory lastPointerOf: oop) / BytesPerWord). lastIndex > 0 ifTrue: [1 to: lastIndex do: [:i| | fieldOop | fieldOop := objectMemory fetchPointer: i - 1 ofObject: oop. self space; printNum: i - 1; space; printHex: fieldOop; space. (i = 1 and: [objectMemory isCompiledMethod: oop]) ifTrue: [self printMethodHeaderOop: fieldOop] ifFalse: [self printOopShort: fieldOop]. self cr]]. (objectMemory isCompiledMethod: oop) ifFalse: [startIP > 64 ifTrue: [self print: '...'; cr]] ifTrue: [startIP := startIP * BytesPerWord + 1. lastIndex := objectMemory lengthOf: oop. lastIndex - startIP > 100 ifTrue: [lastIndex := startIP + 100]. bytecodesPerLine := 8. column := 1. startIP to: lastIndex do: [:index| | byte | column = 1 ifTrue: [self cCode: 'printf("0x%08x: ", oop+BaseHeaderSize+index-1)' inSmalltalk: [self print: (oop+BaseHeaderSize+index-1) hex; print: ': ']]. byte := objectMemory fetchByte: index - 1 ofObject: oop. self cCode: 'printf(" %02x/%-3d", byte,byte)' inSmalltalk: [self space; print: (byte radix: 16); printChar: $/; printNum: byte]. column := column + 1. column > bytecodesPerLine ifTrue: [column := 1. self cr]]. column = 1 ifFalse: [self cr]]! Item was changed: ----- Method: StackInterpreter>>printActivationNameForMethod:startClass:isBlock:firstTemporary: (in category 'debug printing') ----- printActivationNameForMethod: aMethod startClass: startClass isBlock: isBlock firstTemporary: maybeMessage | methClass methodSel | <inline: false> isBlock ifTrue: [self print: '[] in ']. self findSelectorAndClassForMethod: aMethod lookupClass: startClass do: [:sel :class| methodSel := sel. methClass := class]. ((self addressCouldBeOop: startClass) and: [methClass notNil]) ifTrue: [startClass = methClass ifTrue: [self printNameOfClass: methClass count: 5] ifFalse: [self printNameOfClass: startClass count: 5. self printChar: $(. self printNameOfClass: methClass count: 5. self printChar: $)]] ifFalse: [self print: 'INVALID CLASS']. self printChar: $>. (objectMemory addressCouldBeOop: methodSel) ifTrue: [(objectMemory isBytes: methodSel) ifTrue: [self printStringOf: methodSel] ifFalse: [self printOopShort: methodSel]] ifFalse: [self print: 'INVALID SELECTOR']. (methodSel = (objectMemory splObj: SelectorDoesNotUnderstand) and: [(objectMemory addressCouldBeObj: maybeMessage) + and: [(objectMemory fetchClassOfNonImm: maybeMessage) = (objectMemory splObj: ClassMessage)]]) ifTrue: - and: [(objectMemory fetchClassOfNonInt: maybeMessage) = (objectMemory splObj: ClassMessage)]]) ifTrue: ["print arg message selector" methodSel := objectMemory fetchPointer: MessageSelectorIndex ofObject: maybeMessage. self print: ' '. self printStringOf: methodSel]! Item was changed: ----- Method: StackInterpreter>>printAllStacks (in category 'debug printing') ----- printAllStacks "Print all the stacks of all running processes, including those that are currently suspended." <api> | oop classObj proc semaphoreClass mutexClass schedLists p processList | <inline: false> proc := self activeProcess. self printNameOfClass: (objectMemory fetchClassOf: proc) count: 5; space; printHex: proc. self print: ' priority '; printNum: (self quickFetchInteger: PriorityIndex ofObject: proc); cr. self printCallStackFP: framePointer. "first the current activation" semaphoreClass := objectMemory classSemaphore. mutexClass := objectMemory classMutex. oop := objectMemory firstObject. [self oop: oop isLessThan: objectMemory freeStart] whileTrue: + [classObj := objectMemory fetchClassOfNonImm: oop. - [classObj := objectMemory fetchClassOfNonInt: oop. (classObj = semaphoreClass or: [classObj = mutexClass]) ifTrue: [self printProcsOnList: oop]. oop := objectMemory objectAfter: oop]. schedLists := objectMemory fetchPointer: ProcessListsIndex ofObject: self schedulerPointer. p := highestRunnableProcessPriority = 0 ifTrue: [objectMemory fetchWordLengthOf: schedLists] ifFalse: [highestRunnableProcessPriority]. p - 1 to: 0 by: -1 do: [:pri| processList := objectMemory fetchPointer: pri ofObject: schedLists. (self isEmptyList: processList) ifFalse: [self cr; print: 'processes at priority '; printNum: pri + 1. self printProcsOnList: processList]]! Item was changed: ----- Method: StackInterpreter>>printOop: (in category 'debug printing') ----- printOop: oop | cls fmt lastIndex startIP bytecodesPerLine column | <inline: false> - self printHex: oop. (objectMemory isImmediate: oop) ifTrue: + [^self shortPrintOop: oop]. + self printHex: oop. + (objectMemory addressCouldBeObj: oop) ifFalse: + [self print: ((oop bitAnd: objectMemory allocationUnit - 1) ~= 0 + ifTrue: [' is misaligned'] + ifFalse: [' is not on the heap']); cr. - [(objectMemory isImmediateCharacter: oop) ifTrue: - [^self - cCode: 'printf("=$%ld ($%c)\n", (long)characterValueOf(oop), (long)characterValueOf(oop))' - inSmalltalk: [self print: (self shortPrint: oop); cr]]. - ^self - cCode: 'printf("=%ld\n", (long)integerValueOf(oop))' - inSmalltalk: [self print: (self shortPrint: oop); cr]]. - (oop between: objectMemory startOfMemory and: objectMemory freeStart) ifFalse: - [self print: ' is not on the heap'; cr. ^nil]. - (oop bitAnd: (BytesPerWord - 1)) ~= 0 ifTrue: - [self print: ' is misaligned'; cr. - ^nil]. (objectMemory isFreeObject: oop) ifTrue: [self print: ' is a free chunk of size '; printNum: (objectMemory sizeOfFree: oop); cr. ^nil]. self print: ': a(n) '. + self printNameOfClass: (cls := objectMemory fetchClassOfNonImm: oop) count: 5. - self printNameOfClass: (cls := objectMemory fetchClassOfNonInt: oop) count: 5. cls = (objectMemory splObj: ClassFloat) ifTrue: [self cr; printFloat: (self dbgFloatValueOf: oop); cr. ^nil]. fmt := objectMemory formatOf: oop. fmt > 4 ifTrue: [self print: ' nbytes '; printNum: (objectMemory byteLengthOf: oop)]. self cr. (fmt > 4 and: [fmt < 12]) ifTrue: ["This will answer false if splObj: ClassAlien is nilObject" (self is: oop KindOfClass: (objectMemory splObj: ClassAlien)) ifTrue: [self print: ' datasize '; printNum: (self sizeOfAlienData: oop). self print: ((self isIndirectAlien: oop) ifTrue: [' indirect @ '] ifFalse: [(self isPointerAlien: oop) ifTrue: [' pointer @ '] ifFalse: [' direct @ ']]). self printHex: (self startOfAlienData: oop) asUnsignedInteger; cr. ^nil]. (objectMemory isWords: oop) ifTrue: [lastIndex := 64 min: ((objectMemory byteLengthOf: oop) / BytesPerWord). lastIndex > 0 ifTrue: [1 to: lastIndex do: [:index| self space; printHex: (objectMemory fetchLong32: index - 1 ofObject: oop). (index \\ self elementsPerPrintOopLine) = 0 ifTrue: [self cr]]. (lastIndex \\ self elementsPerPrintOopLine) = 0 ifFalse: [self cr]]. ^nil]. ^self printStringOf: oop; cr]. lastIndex := 64 min: (startIP := (objectMemory lastPointerOf: oop) / BytesPerWord). lastIndex > 0 ifTrue: [1 to: lastIndex do: [:index| self cCode: [self printHex: (objectMemory fetchPointer: index - 1 ofObject: oop); space] inSmalltalk: [self space; printHex: (objectMemory fetchPointer: index - 1 ofObject: oop); space. self print: (self shortPrint: (objectMemory fetchPointer: index - 1 ofObject: oop))]. (index \\ self elementsPerPrintOopLine) = 0 ifTrue: [self cr]]. (lastIndex \\ self elementsPerPrintOopLine) = 0 ifFalse: [self cr]]. (objectMemory isCompiledMethod: oop) ifFalse: [startIP > 64 ifTrue: [self print: '...'; cr]] ifTrue: [startIP := startIP * BytesPerWord + 1. lastIndex := objectMemory lengthOf: oop. lastIndex - startIP > 100 ifTrue: [lastIndex := startIP + 100]. bytecodesPerLine := 8. column := 1. startIP to: lastIndex do: [:index| | byte | column = 1 ifTrue: [self cCode: 'printf("0x%08x: ", oop+BaseHeaderSize+index-1)' inSmalltalk: [self print: (oop+BaseHeaderSize+index-1) hex; print: ': ']]. byte := objectMemory fetchByte: index - 1 ofObject: oop. self cCode: 'printf(" %02x/%-3d", byte,byte)' inSmalltalk: [self space; print: (byte radix: 16); printChar: $/; printNum: byte]. column := column + 1. column > bytecodesPerLine ifTrue: [column := 1. self cr]]. column = 1 ifFalse: [self cr]]! Item was changed: ----- Method: StackInterpreter>>printOopShortInner: (in category 'debug printing') ----- printOopShortInner: oop | classOop name nameLen | <var: #name type: #'char *'> <inline: true> + (objectMemory isImmediate: oop) ifTrue: + [(objectMemory isImmediateCharacter: oop) ifTrue: + [self + cCode: 'printf("$%c(%ld)", (long)characterValueOf(oop), (long)characterValueOf(oop))' + inSmalltalk: + [self printChar: $$; + printChar: (objectMemory characterValueOf: oop); + printChar: $(; + printHex: (objectMemory integerValueOf: oop); + printChar: $)]. + ^nil]. + self printNum: (objectMemory integerValueOf: oop); - (objectMemory isIntegerObject: oop) ifTrue: - [self printNum: (objectMemory integerValueOf: oop); printChar: $(; printHex: (objectMemory integerValueOf: oop); printChar: $). ^nil]. + (objectMemory addressCouldBeObj: oop) ifFalse: + [self print: ((oop bitAnd: objectMemory allocationUnit - 1) ~= 0 + ifTrue: [' is misaligned'] + ifFalse: [' is not on the heap']); cr. - (oop between: objectMemory startOfMemory and: objectMemory freeStart) ifFalse: - [self printHex: oop; print: ' is not on the heap'. ^nil]. - (oop bitAnd: (BytesPerWord - 1)) ~= 0 ifTrue: - [self printHex: oop; print: ' is misaligned'. - ^nil]. (self isFloatObject: oop) ifTrue: [self printFloat: (self dbgFloatValueOf: oop). ^nil]. + classOop := objectMemory fetchClassOfNonImm: oop. - classOop := objectMemory fetchClassOfNonInt: oop. (objectMemory addressCouldBeObj: classOop) ifFalse: [self print: 'a ??'. ^nil]. (objectMemory sizeBitsOf: classOop) = metaclassSizeBits ifTrue: [self printNameOfClass: oop count: 5. ^nil]. oop = objectMemory nilObject ifTrue: [self print: 'nil'. ^nil]. oop = objectMemory trueObject ifTrue: [self print: 'true'. ^nil]. oop = objectMemory falseObject ifTrue: [self print: 'false'. ^nil]. nameLen := self lengthOfNameOfClass: classOop. nameLen = 0 ifTrue: [self print: 'a ??'. ^nil]. name := self nameOfClass: classOop. nameLen = 10 ifTrue: [(self str: name n: 'ByteString' cmp: 10) not "strncmp is weird" ifTrue: [self printChar: $'; printStringOf: oop; printChar: $'. ^nil]. (self str: name n: 'ByteSymbol' cmp: 10) not "strncmp is weird" ifTrue: [self printChar: $#; printStringOf: oop. ^nil]]. (nameLen = 9 and: [(self str: name n: 'Character' cmp: 9) not]) ifTrue: [self printChar: $$; printChar: (objectMemory integerValueOf: (objectMemory fetchPointer: 0 ofObject: oop)). ^nil]. self cCode: [self prin: 'a(n) %.*s' t: nameLen f: name] inSmalltalk: [self print: 'a(n) '; print: name]. "Try to spot association-like things; they're all subclasses of LookupKey" ((objectMemory instanceSizeOf: classOop) = (ValueIndex + 1) + and: [(self superclassOf: classOop) = (self superclassOf: (objectMemory fetchClassOfNonImm: (objectMemory splObj: SchedulerAssociation))) - and: [(self superclassOf: classOop) = (self superclassOf: (objectMemory fetchClassOfNonInt: (objectMemory splObj: SchedulerAssociation))) and: [objectMemory isBytes: (objectMemory fetchPointer: KeyIndex ofObject: oop)]]) ifTrue: [self space; printOopShort: (objectMemory fetchPointer: KeyIndex ofObject: oop); print: ' -> '; printHex: (objectMemory fetchPointer: ValueIndex ofObject: oop)]! Item was changed: ----- Method: StackInterpreter>>printStringOf: (in category 'debug printing') ----- printStringOf: oop | fmt len cnt max i | <inline: false> + (objectMemory isImmediate: oop) ifTrue: - (objectMemory isIntegerObject: oop) ifTrue: [^nil]. (oop between: objectMemory startOfMemory and: objectMemory freeStart) ifFalse: [^nil]. (oop bitAnd: (BytesPerOop - 1)) ~= 0 ifTrue: [^nil]. fmt := objectMemory formatOf: oop. + fmt < objectMemory firstByteFormat ifTrue: [^nil]. - fmt < 8 ifTrue: [^nil]. cnt := (max := 128) min: (len := objectMemory lengthOf: oop). i := 0. ((objectMemory is: oop instanceOf: (objectMemory splObj: ClassByteArray) compactClassIndex: classByteArrayCompactIndex) or: [(self isInstanceOfClassLargePositiveInteger: oop) or: [(self isInstanceOfClassLargeNegativeInteger: oop)]]) ifTrue: [[i < cnt] whileTrue: [self printHex: (objectMemory fetchByte: i ofObject: oop). i := i + 1]] ifFalse: [[i < cnt] whileTrue: [self printChar: (objectMemory fetchByte: i ofObject: oop). i := i + 1]]. len > max ifTrue: [self print: '...']. self flush! Item was changed: ----- Method: StackInterpreter>>sendInvokeCallback:Stack:Registers:Jmpbuf: (in category 'callback support') ----- sendInvokeCallback: thunkPtr Stack: stackPtr Registers: regsPtr Jmpbuf: jmpBufPtr "Send the 4 argument callback message invokeCallback:stack:registers:jmpbuf: to Alien class with the supplied args. The arguments are raw C addresses and are converted to integer objects on the way." <export: true> self flag: #obsolete. + lkupClass := self fetchClassOfNonImm: (self splObj: ClassAlien). - lkupClass := self fetchClassOfNonInt: (self splObj: ClassAlien). messageSelector := self splObj: SelectorInvokeCallback. argumentCount := 4. (self lookupInMethodCacheSel: messageSelector class: lkupClass) ifFalse: [(self lookupMethodNoMNUEtcInClass: lkupClass) ~= 0 ifTrue: [^false]]. ((self argumentCountOf: newMethod) = 4 and: [primitiveFunctionPointer = 0]) ifFalse: [^false]. self push: (self splObj: ClassAlien). "receiver" self push: (self positive32BitIntegerFor: thunkPtr). self push: (self positive32BitIntegerFor: stackPtr). self push: (self positive32BitIntegerFor: regsPtr). self push: (self positive32BitIntegerFor: jmpBufPtr). self ifAppropriateCompileToNativeCode: newMethod selector: messageSelector. self justActivateNewMethod. (self isMachineCodeFrame: framePointer) ifFalse: [self maybeFlagMethodAsInterpreted: newMethod]. self externalWriteBackHeadFramePointers. self handleStackOverflow. self enterSmalltalkExecutiveFromCallback. "not reached" ^true! Item was changed: ----- Method: StackInterpreter>>sendInvokeCallbackContext: (in category 'callback support') ----- sendInvokeCallbackContext: vmCallbackContext "Send the calllback message to Alien class with the supplied arg(s). Use either the 1 arg invokeCallbackContext: or the 4 arg invokeCallback:stack:registers:jmpbuf: message, depending on what selector is installed in the specialObjectsArray. Note that if invoking the legacy invokeCallback:stack:registers:jmpbuf: we pass the vmCallbackContext as the jmpbuf argument (see reestablishContextPriorToCallback:). The arguments are raw C addresses and are converted to integer objects on the way." <export: true> <var: #vmCallbackContext type: #'VMCallbackContext *'> + lkupClass := self fetchClassOfNonImm: (self splObj: ClassAlien). - lkupClass := self fetchClassOfNonInt: (self splObj: ClassAlien). messageSelector := self splObj: SelectorInvokeCallback. (self lookupInMethodCacheSel: messageSelector class: lkupClass) ifFalse: [(self lookupMethodNoMNUEtcInClass: lkupClass) ~= 0 ifTrue: [^false]]. primitiveFunctionPointer ~= 0 ifTrue: [^false]. self saveCStackStateForCallbackContext: vmCallbackContext. self push: (self splObj: ClassAlien). "receiver" self cppIf: BytesPerWord = 8 ifTrue: [(self argumentCountOf: newMethod) = 4 ifTrue: [self push: (self positive64BitIntegerFor: vmCallbackContext thunkp asUnsignedInteger). self push: (self positive64BitIntegerFor: vmCallbackContext stackp asUnsignedInteger). self push: (self positive64BitIntegerFor: vmCallbackContext intregargsp asUnsignedInteger)]. self push: (self positive64BitIntegerFor: vmCallbackContext asUnsignedInteger)] ifFalse: [(self argumentCountOf: newMethod) = 4 ifTrue: [self push: (self positive32BitIntegerFor: vmCallbackContext thunkp asUnsignedInteger). self push: (self positive32BitIntegerFor: vmCallbackContext stackp asUnsignedInteger). self push: (self positive32BitIntegerFor: vmCallbackContext intregargsp asUnsignedInteger)]. self push: (self positive32BitIntegerFor: vmCallbackContext asUnsignedInteger)]. self ifAppropriateCompileToNativeCode: newMethod selector: messageSelector. self justActivateNewMethod. (self isMachineCodeFrame: framePointer) ifFalse: [self maybeFlagMethodAsInterpreted: newMethod]. self externalWriteBackHeadFramePointers. self handleStackOverflow. self enterSmalltalkExecutiveFromCallback. "not reached" ^true! Item was changed: ----- Method: StackInterpreter>>shortPrintOop: (in category 'debug printing') ----- shortPrintOop: oop <inline: false> self printHex: oop. + (objectMemory isImmediate: oop) ifTrue: + [(objectMemory isImmediateCharacter: oop) ifTrue: + [^self + cCode: 'printf("=$%ld ($%c)\n", (long)characterValueOf(oop), (long)characterValueOf(oop))' + inSmalltalk: [self print: (self shortPrint: oop); cr]]. + ^self + cCode: 'printf("=%ld\n", (long)integerValueOf(oop))' + inSmalltalk: [self print: (self shortPrint: oop); cr]]. - (objectMemory isIntegerObject: oop) ifTrue: - [^self cCode: 'printf("=%ld\n", (long)integerValueOf(oop))' inSmalltalk: [self print: (self shortPrint: oop); cr]]. (oop between: objectMemory startOfMemory and: objectMemory freeStart) ifFalse: [self printHex: oop; print: ' is not on the heap'; cr. ^nil]. (oop bitAnd: (BytesPerWord - 1)) ~= 0 ifTrue: [self printHex: oop; print: ' is misaligned'; cr. ^nil]. self print: ': a(n) '. self printNameOfClass: (objectMemory fetchClassOf: oop) count: 5. self cr! Item was changed: ----- Method: StackInterpreterPrimitives>>pathTo:using:followWeak: (in category 'object access primitives') ----- pathTo: goal using: stack followWeak: followWeak "Trace objects and frames from the root, marking visited objects, pushing the current path on stack, until goal is found. If found, unmark, leaving path in stack, and answer 0. Otherwise answer an error: PrimErrBadArgument if stack is not an Array PrimErrBadIndex if search overflows stack PrimErrNotFound if goal cannot be found" | current hdr index next stackSize stackp freeStartAtStart | (objectMemory isArray: stack) ifFalse: [^PrimErrBadArgument]. freeStartAtStart := objectMemory freeStart. "check no allocations during search" objectMemory beRootIfOld: stack. "so no store checks are necessary on stack" stackSize := objectMemory lengthOf: stack. objectMemory mark: stack. "no need. the current context is not reachable from the active process (suspendedContext is nil)" "objectMemory mark: self activeProcess." current := objectMemory specialObjectsOop. objectMemory mark: current. index := objectMemory lengthOf: current. stackp := 0. [[(index := index - 1) >= -1] whileTrue: [next := (stackPages couldBeFramePointer: current) ifTrue: [index >= 0 ifTrue: [self field: index ofFrame: current] ifFalse: [objectMemory nilObject]] ifFalse: [index >= 0 ifTrue: [hdr := objectMemory baseHeader: current. (objectMemory isContextHeader: hdr) ifTrue: [self fieldOrSenderFP: index ofContext: current] ifFalse: [objectMemory fetchPointer: index ofObject: current]] ifFalse: + [objectMemory fetchClassOfNonImm: current]]. - [objectMemory fetchClassOfNonInt: current]]. (stackPages couldBeFramePointer: next) ifTrue: [self assert: (self isFrame: next onPage: (stackPages stackPageFor: next))] ifFalse: [self assert: (self checkOkayOop: next)]. next = goal ifTrue: [self assert: freeStartAtStart = objectMemory freeStart. self unmarkAfterPathTo. objectMemory storePointer: stackp ofObject: stack withValue: current. self pruneStack: stack stackp: stackp. ^0]. ((objectMemory isNonIntegerObject: next) and: [(stackPages couldBeFramePointer: next) ifTrue: [(self frameIsMarked: next) not] ifFalse: [(objectMemory isMarked: next) not and: [((objectMemory isPointers: next) or: [objectMemory isCompiledMethod: next]) and: [followWeak or: [(objectMemory isWeakNonInt: next) not]]]]]) ifTrue: [stackp + 2 > stackSize ifTrue: [self assert: freeStartAtStart = objectMemory freeStart. self unmarkAfterPathTo. objectMemory nilFieldsOf: stack. ^PrimErrBadIndex]. "PrimErrNoMemory ?" objectMemory storePointerUnchecked: stackp ofObject: stack withValue: current; storePointerUnchecked: stackp + 1 ofObject: stack withValue: (objectMemory integerObjectOf: index). stackp := stackp + 2. (stackPages couldBeFramePointer: (self cCoerceSimple: next to: #'char *')) ifTrue: [self markFrame: next. index := self fieldsInFrame: (self cCoerceSimple: next to: #'char *')] ifFalse: [hdr := objectMemory baseHeader: next. objectMemory baseHeader: next put: (hdr bitOr: MarkBit). (objectMemory isCompiledMethodHeader: hdr) ifTrue: [index := (self literalCountOf: next) + LiteralStart] ifFalse: [index := objectMemory lengthOf: next]]. current := next]]. current = objectMemory specialObjectsOop ifTrue: [self assert: freeStartAtStart = objectMemory freeStart. self unmarkAfterPathTo. objectMemory nilFieldsOf: stack. ^PrimErrNotFound]. index := objectMemory integerValueOf: (objectMemory fetchPointer: stackp - 1 ofObject: stack). current := objectMemory fetchPointer: stackp - 2 ofObject: stack. stackp := stackp - 2] repeat! Item was changed: ----- Method: StackInterpreterPrimitives>>primitiveCopyObject (in category 'object access primitives') ----- primitiveCopyObject "Primitive. Copy the state of the receiver from the argument. Fail if receiver and argument are of a different class. Fail if the receiver or argument are non-pointer objects. Fail if the receiver or argument are contexts (because of context-to-stack mapping). Fail if receiver and argument have different lengths (for indexable objects). " | rcvr arg length | self methodArgumentCount = 1 ifFalse: [^self primitiveFail]. arg := self stackObjectValue: 0. rcvr := self stackObjectValue: 1. self failed ifTrue:[^nil]. (objectMemory isPointers: rcvr) ifFalse: [^self primitiveFail]. ((objectMemory isContextNonInt: rcvr) or: [objectMemory isContextNonInt: arg]) ifTrue: [^self primitiveFail]. + (objectMemory fetchClassOfNonImm: rcvr) = (objectMemory fetchClassOfNonImm: arg) ifFalse: - (objectMemory fetchClassOfNonInt: rcvr) = (objectMemory fetchClassOfNonInt: arg) ifFalse: [^self primitiveFail]. length := objectMemory lengthOf: rcvr. length = (objectMemory lengthOf: arg) ifFalse: [^self primitiveFail]. "Now copy the elements" 0 to: length-1 do: [:i| objectMemory storePointer: i ofObject: rcvr withValue: (objectMemory fetchPointer: i ofObject: arg)]. "Note: The above could be faster for young receivers but I don't think it'll matter" self pop: 1 "pop arg; answer receiver" ! Item was changed: ----- Method: StackInterpreterPrimitives>>primitiveLongRunningPrimitiveSemaphore (in category 'process primitives') ----- primitiveLongRunningPrimitiveSemaphore "Primitive. Install the semaphore to be used for collecting long-running primitives, or nil if no semaphore should be used." | sema | <export: true> sema := self stackValue: 0. ((objectMemory isIntegerObject: sema) or: [self methodArgumentCount ~= 1]) ifTrue: [^self primitiveFail]. sema = objectMemory nilObject ifTrue: [longRunningPrimitiveCheckSemaphore := nil] ifFalse: + [(objectMemory fetchClassOfNonImm: sema) = (objectMemory splObj: ClassSemaphore) ifFalse: - [(objectMemory fetchClassOfNonInt: sema) = (objectMemory splObj: ClassSemaphore) ifFalse: [^self primitiveFail]. longRunningPrimitiveCheckSemaphore := sema]. self voidLongRunningPrimitive: 'install'. self pop: 1! Item was changed: ----- Method: StackInterpreterPrimitives>>primitiveSignalAtMilliseconds (in category 'system control primitives') ----- primitiveSignalAtMilliseconds "Cause the time semaphore, if one has been registered, to be signalled when the microsecond clock is greater than or equal to the given tick value. A tick value of zero turns off timer interrupts." | msecsObj msecs deltaMsecs sema | <var: #msecs type: #usqInt> msecsObj := self stackTop. sema := self stackValue: 1. msecs := self positive32BitValueOf: msecsObj. (self failed or: [objectMemory isIntegerObject: sema]) ifTrue: [self primitiveFail. ^nil]. + (objectMemory fetchClassOfNonImm: sema) = (objectMemory splObj: ClassSemaphore) - (objectMemory fetchClassOfNonInt: sema) = (objectMemory splObj: ClassSemaphore) ifTrue: [objectMemory splObj: TheTimerSemaphore put: sema. deltaMsecs := msecs - (self ioMSecs bitAnd: MillisecondClockMask). deltaMsecs < 0 ifTrue: [deltaMsecs := deltaMsecs + MillisecondClockMask + 1]. nextWakeupUsecs := self ioUTCMicroseconds + (deltaMsecs * 1000)] ifFalse: [objectMemory storePointer: TheTimerSemaphore ofObject: objectMemory specialObjectsOop withValue: objectMemory nilObject. nextWakeupUsecs := 0]. self pop: 2! Item was changed: ----- Method: StackInterpreterPrimitives>>primitiveSignalAtUTCMicroseconds (in category 'system control primitives') ----- primitiveSignalAtUTCMicroseconds "Cause the time semaphore, if one has been registered, to be signalled when the microsecond clock is greater than or equal to the given tick value. A tick value of zero turns off timer interrupts." | usecsObj sema usecs | <var: #usecs type: #usqLong> usecsObj := self stackTop. sema := self stackValue: 1. usecs := self positive64BitValueOf: usecsObj. (self failed or: [objectMemory isIntegerObject: sema]) ifTrue: [self primitiveFail. ^nil]. + (objectMemory fetchClassOfNonImm: sema) = (objectMemory splObj: ClassSemaphore) - (objectMemory fetchClassOfNonInt: sema) = (objectMemory splObj: ClassSemaphore) ifTrue: [objectMemory splObj: TheTimerSemaphore put: sema. nextWakeupUsecs := usecs] ifFalse: [objectMemory storePointer: TheTimerSemaphore ofObject: objectMemory specialObjectsOop withValue: objectMemory nilObject. nextWakeupUsecs := 0]. self pop: 2!

1 0

VM Maker: Cog-eem.70.mcz
by commits＠source.squeak.org 05 Sep '13

05 Sep '13

Eliot Miranda uploaded a new version of Cog to project VM Maker: http://source.squeak.org/VMMaker/Cog-eem.70.mcz ==================== Summary ==================== Name: Cog-eem.70 Author: eem Time: 4 September 2013, 5:28:45.984 pm UUID: 1cf5db5c-444b-434d-bd7e-3deae50eee2a Ancestors: Cog-eem.69 Rename fetchClassOfNonInt: to fetchClassOfNonImm:. =============== Diff against Cog-eem.69 =============== Item was changed: ----- Method: SpurBootstrap>>buildClassMap (in category 'bootstrap') ----- buildClassMap "enumerate all objects asking isBehavior:? (class == Metaclass or class class == Metaclass) doesn't work for Newspeak" "Build a map from all classes in oldHeap to a class index. ONLY DEALS WITH CLASSES THAT HAVE INSTANCES!!!! (can walk superclass chain? Can walk subclasses set? Can ask class == Metaclass or class class == Metaclass class?)" | classes classTableIndex | self defineKnownClassIndices. classes := classToIndex keys asSet. classTableIndex := newHeap classTablePageSize. oldHeap allObjectsDo: [:oldObj| | oldClass | + oldClass := oldHeap fetchClassOfNonImm: oldObj. - oldClass := oldHeap fetchClassOfNonInt: oldObj. (classes includes: oldClass) ifFalse: [classes add: oldClass. classToIndex at: oldClass put: (classTableIndex := classTableIndex + 1)]]! Item was changed: ----- Method: SpurBootstrap>>cloneNilTrueAndFalse (in category 'bootstrap') ----- cloneNilTrueAndFalse { oldHeap nilObject. oldHeap falseObject. oldHeap trueObject. } with: (self firstOrdinaryClassIndex to: self firstOrdinaryClassIndex + 2) do: [:obj :classIndex| + classToIndex at: (oldHeap fetchClassOfNonImm: obj) put: classIndex. - classToIndex at: (oldHeap fetchClassOfNonInt: obj) put: classIndex. self clone: obj classIndex: classIndex]. newHeap nilObject: (map at: oldHeap nilObject); "needed for nilling objects etc" falseObject: (map at: oldHeap falseObject); trueObject: (map at: oldHeap trueObject)! Item was changed: ----- Method: SpurBootstrap>>cloneObjects (in category 'bootstrap') ----- cloneObjects | characterClass characterTable oldObj oldClass | characterClass := oldHeap classCharacter. characterTable := oldHeap characterTable. oldObj := oldHeap objectAfter: oldHeap trueObject. [oldObj < oldHeap freeStart] whileTrue: + [oldClass := oldHeap fetchClassOfNonImm: oldObj. - [oldClass := oldHeap fetchClassOfNonInt: oldObj. (oldObj ~= characterTable and: [oldClass ~= characterClass]) ifTrue: [self clone: oldObj classIndex: (classToIndex at: oldClass)]. oldObj := oldHeap objectAfter: oldObj]. newHeap specialObjectsOop: (map at: oldHeap specialObjectsOop)! Item was changed: ----- Method: SpurBootstrap>>fillInPointerObject:from: (in category 'bootstrap') ----- fillInPointerObject: newObj from: oldObj 0 to: (oldHeap lastPointerOf: oldObj) / oldHeap bytesPerWord - 1 do: [:i| | oldValue newValue | oldValue := oldHeap fetchPointer: i ofObject: oldObj. newValue := (oldHeap isIntegerObject: oldValue) ifTrue: [oldValue] ifFalse: [map at: oldValue ifAbsent: [oldValue = oldHeap characterTable ifTrue: [newHeap nilObject] ifFalse: + [self assert: (oldHeap fetchClassOfNonImm: oldValue) = oldHeap classCharacter. - [self assert: (oldHeap fetchClassOfNonInt: oldValue) = oldHeap classCharacter. newHeap characterObjectOf: (oldHeap integerValueOf: (oldHeap fetchPointer: CharacterValueIndex ofObject: oldValue))]]]. newHeap storePointerUnchecked: i ofObject: newObj withValue: newValue]!

1 0

VM Maker: Cog-eem.69.mcz
by commits＠source.squeak.org 04 Sep '13

04 Sep '13

Eliot Miranda uploaded a new version of Cog to project VM Maker: http://source.squeak.org/VMMaker/Cog-eem.69.mcz ==================== Summary ==================== Name: Cog-eem.69 Author: eem Time: 4 September 2013, 2:22:08.497 pm UUID: d6786922-3487-4e64-bb5c-95a935cbd3c3 Ancestors: Cog-eem.68 Update bootstrap to facilitate setting up new space and the scavenger after image conversion. =============== Diff against Cog-eem.68 =============== Item was changed: ----- Method: SpurBootstrap>>allocateClassTable (in category 'bootstrap') ----- allocateClassTable "Allocate the root of the classTable plus enough pages to accomodate all classes in the classToIndex map. Don;t fill in the entries yet; the classes have yet to be cloned." | tableRootSize tableRoot page maxSize numPages | tableRootSize := self classTableSize / newHeap classTablePageSize. tableRoot := newHeap allocateSlots: tableRootSize format: newHeap arrayFormat classIndex: newHeap arrayClassIndexPun. self assert: (newHeap numSlotsOf: tableRoot) = tableRootSize. self assert: (newHeap formatOf: tableRoot) = newHeap arrayFormat. self assert: (newHeap classIndexOf: tableRoot) = newHeap arrayClassIndexPun. newHeap nilFieldsOf: tableRoot. "first page is strong" page := newHeap allocateSlots: newHeap classTablePageSize format: newHeap arrayFormat classIndex: newHeap arrayClassIndexPun. self assert: (newHeap numSlotsOf: page) = newHeap classTablePageSize. self assert: (newHeap formatOf: tableRoot) = newHeap arrayFormat. self assert: (newHeap classIndexOf: tableRoot) = newHeap arrayClassIndexPun. + self assert: (newHeap objectAfter: tableRoot limit: newHeap freeStart) = page. - self assert: (newHeap objectAfter: tableRoot) = page. newHeap nilFieldsOf: page. newHeap storePointer: 0 ofObject: tableRoot withValue: page. newHeap classTableRootObj: tableRoot. maxSize := classToIndex inject: 0 into: [:a :b| a max: b]. numPages := (maxSize + newHeap classTableMinorIndexMask / newHeap classTablePageSize) truncated. 2 to: numPages do: [:i| page := newHeap allocateSlots: newHeap classTablePageSize format: newHeap weakArrayFormat classIndex: newHeap weakArrayClassIndexPun. self assert: (newHeap numSlotsOf: page) = newHeap classTablePageSize. self assert: (newHeap formatOf: page) = newHeap weakArrayFormat. self assert: (newHeap classIndexOf: page) = newHeap weakArrayClassIndexPun. newHeap nilFieldsOf: page. newHeap storePointer: i - 1 ofObject: tableRoot withValue: page. + self assert: (newHeap objectAfter: (newHeap fetchPointer: i - 2 ofObject: tableRoot) limit: newHeap freeStart) = page]. - self assert: (newHeap objectAfter: (newHeap fetchPointer: i - 2 ofObject: tableRoot)) = page]. pastClassTable := newHeap freeStart.! Item was added: + ----- Method: SpurBootstrap>>bootstrapImage (in category 'bootstrap') ----- + bootstrapImage + self cloneNilTrueAndFalse. + self buildClassMap. + self allocateClassTable. + self cloneObjects. + self fillInObjects. + self fillInClassTable! Item was changed: ----- Method: SpurBootstrap>>launch (in category 'testing') ----- launch | sim | sim := StackInterpreterSimulator onObjectMemory: newHeap. newHeap coInterpreter: sim. - newHeap initializePostBootstrap. sim initializeInterpreter: 0. sim run! Item was changed: ----- Method: SpurBootstrap>>transform (in category 'bootstrap') ----- transform + self bootstrapImage. + newHeap initializePostBootstrap. - self cloneNilTrueAndFalse. - self buildClassMap. - self allocateClassTable. - self cloneObjects. - self fillInObjects. - self fillInClassTable. self validate!

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

Vm-dev September 2013