[Vm-dev] VM Maker: VMMaker.oscog-eem.378.mcz
commits at source.squeak.org
commits at source.squeak.org
Sat Sep 14 00:59:58 UTC 2013
Eliot Miranda uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker.oscog-eem.378.mcz
==================== Summary ====================
Name: VMMaker.oscog-eem.378
Author: eem
Time: 13 September 2013, 5:57:00.316 pm
UUID: 8324b3df-0dc1-4ebe-bbbf-d9eb6ca929c3
Ancestors: VMMaker.oscog-eem.377
Improve the message send forwarded object trap, scanning the
current frame and receiver.
Change becommedPointerObjects to becomeEffectsFlags and set
them appropriately. Implement class table scanning.
Add VMSpurObjectRepresentationConstants and keep the flags
there-in.
Recategorize the become methods, api vs implementation.
Change the isForwardedObjectClassIndexPun so it can't be confused
with SmallInteger's classTag.
Beef up printActivationNameFor:receiver:isBlock:firstTemporary: in
face of forwarded objects.
Add a vm parameter to answer stackPage bytes (#66).
=============== Diff against VMMaker.oscog-eem.377 ===============
Item was changed:
----- Method: CoInterpreter>>postBecomeAction: (in category 'object memory support') -----
+ postBecomeAction: becomeEffectsFlags
- postBecomeAction: updateReceiversInStackZone
"Clear the gcMode var and let the Cogit do its post GC checks."
+ super postBecomeAction: becomeEffectsFlags.
- super postBecomeAction: updateReceiversInStackZone.
cogit cogitPostGCAction: gcMode.
lastCoggableInterpretedBlockMethod := lastUncoggableInterpretedBlockMethod := nil.
gcMode := 0!
Item was changed:
----- Method: NewObjectMemory>>become:with:twoWay:copyHash: (in category 'become') -----
become: array1 with: array2 twoWay: twoWayFlag copyHash: copyHashFlag
"All references to each object in array1 are swapped with all references to the corresponding object in array2. That is, all pointers to one object are replaced with with pointers to the other. The arguments must be arrays of the same length.
Returns PrimNoErr if the primitive succeeds."
"Implementation: Uses forwarding blocks to update references as done in compaction."
| start |
self leakCheckBecome ifTrue:
[self runLeakCheckerForFullGC: true].
(self isArray: array1) ifFalse:
[^PrimErrBadReceiver].
((self isArray: array2)
and: [(self lastPointerOf: array1) = (self lastPointerOf: array2)]) ifFalse:
[^PrimErrBadArgument].
(twoWayFlag or: [copyHashFlag])
ifTrue: [(self containOnlyOops: array1 and: array2) ifFalse: [^PrimErrInappropriate]]
ifFalse: [(self containOnlyOops: array1) ifFalse: [^PrimErrInappropriate]].
(self prepareForwardingTableForBecoming: array1 with: array2 twoWay: twoWayFlag) ifFalse:
[^PrimErrNoMemory]. "fail; not enough space for forwarding table"
(self allYoung: array1 and: array2)
ifTrue: [start := youngStart"sweep only the young objects plus the roots"]
ifFalse: [start := self startOfMemory"sweep all objects"].
coInterpreter preBecomeAction.
self mapPointersInObjectsFrom: start to: freeStart.
twoWayFlag
ifTrue: [self restoreHeadersAfterBecoming: array1 with: array2]
ifFalse: [self restoreHeadersAfterForwardBecome: copyHashFlag].
+ coInterpreter postBecomeAction: 0.
- coInterpreter postBecomeAction: false.
self initializeMemoryFirstFree: freeStart. "re-initialize memory used for forwarding table"
self leakCheckBecome ifTrue:
[self runLeakCheckerForFullGC: true].
^PrimNoErr "success"!
Item was added:
+ ----- Method: ObjectMemory>>isForwardedClassTag: (in category 'interpreter access') -----
+ isForwardedClassTag: classTag
+ "Compatibility wth SpurMemoryManager. In ObjectMemory, no forwarding pointers
+ are visible to the VM."
+ <inline: true>
+ ^false!
Item was added:
+ ----- Method: ObjectMemory>>isOopForwarded: (in category 'interpreter access') -----
+ isOopForwarded: oop
+ "Compatibility wth SpurMemoryManager. In ObjectMemory, no forwarding pointers
+ are visible to the VM."
+ <inline: true>
+ ^false!
Item was added:
+ ----- Method: Spur32BitMMLESimulator>>forward:to: (in category 'become') -----
+ forward: obj1 to: obj2
+ "(obj1 = 16r150CD8 or: [obj1 = 16r1510B8
+ or: [obj2 = 16r150CD8 or: [obj2 = 16r1510B8]]]) ifTrue:
+ [self halt]."
+ ^super forward: obj1 to: obj2!
Item was changed:
CogClass subclass: #SpurMemoryManager
(excessive size, no diff calculated)
Item was added:
+ ----- Method: SpurMemoryManager class>>initializeSpurObjectRepresentationConstants (in category 'class initialization') -----
+ initializeSpurObjectRepresentationConstants
+ "SpurMemoryManager initializeSpurObjectRepresentationConstants"
+ BecameClassFlag := 1.
+ BecameCompiledMethodFlag := 2.
+ BecamePointerObjectFlag := 4!
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 wordSize]).
BytesPerOop := optionsDictionary at: #BytesPerOop ifAbsent: [BytesPerWord].
+ self initializeSpurObjectRepresentationConstants.
self initializeSpecialObjectIndices.
self initializeCompactClassIndices.
self initializePrimitiveErrorCodes.
self initializeObjectHeaderConstants.
SpurGenerationScavenger initialize!
Item was added:
+ ----- Method: SpurMemoryManager>>allExistingNewSpaceObjectsDo: (in category 'object enumeration') -----
+ allExistingNewSpaceObjectsDo: 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.
+ limit := freeStart.
+ [objOop < limit] 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 added:
+ ----- Method: SpurMemoryManager>>allExistingObjectsDo: (in category 'object enumeration') -----
+ allExistingObjectsDo: aBlock
+ "Enumerate all objects, excluding any objects created
+ during the execution of allExistingObjectsDo:."
+ <inline: true>
+ self allExistingOldSpaceObjectsDo: aBlock.
+ self allExistingNewSpaceObjectsDo: aBlock!
Item was added:
+ ----- Method: SpurMemoryManager>>allExistingOldSpaceObjectsDo: (in category 'object enumeration') -----
+ allExistingOldSpaceObjectsDo: aBlock
+ "Enumerate all old space objects, excluding any objects created
+ during the execution of allExistingOldSpaceObjectsDo:."
+ <inline: true>
+ | oldSpaceLimit prevObj prevPrevObj objOop |
+ prevPrevObj := prevObj := nil.
+ objOop := self firstObject.
+ oldSpaceLimit := freeOldSpaceStart.
+ [self assert: objOop \\ self allocationUnit = 0.
+ objOop < oldSpaceLimit] 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: SpurMemoryManager>>allNewSpaceObjectsDo: (in category 'object enumeration') -----
allNewSpaceObjectsDo: aBlock
+ "Enumerate all new space objects, excluding any objects created
+ during the execution of allNewSpaceObjectsDo:."
<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>>become:with:twoWay:copyHash: (in category 'become api') -----
- ----- Method: SpurMemoryManager>>become:with:twoWay:copyHash: (in category 'become') -----
become: array1 with: array2 twoWay: twoWayFlag copyHash: copyHashFlag
"All references to each object in array1 are swapped with all references to the
corresponding object in array2. That is, all pointers to one object are replaced
with with pointers to the other. The arguments must be arrays of the same length.
Answers PrimNoErr if the primitive succeeds, otherwise a relevant error code."
"Implementation: Uses lazy forwarding to defer updating references until message send."
+ self assert: becomeEffectsFlags = 0.
self leakCheckBecome ifTrue:
[self runLeakCheckerForFullGC: true].
(self isArray: array1) ifFalse:
[^PrimErrBadReceiver].
((self isArray: array2)
and: [(self numSlotsOf: array1) = (self numSlotsOf: array2)]) ifFalse:
[^PrimErrBadArgument].
(twoWayFlag or: [copyHashFlag])
ifTrue: [(self containOnlyOops: array1 and: array2) ifFalse: [^PrimErrInappropriate]]
ifFalse: [(self containOnlyOops: array1) ifFalse: [^PrimErrInappropriate]].
coInterpreter preBecomeAction.
twoWayFlag
ifTrue:
[self innerBecomeObjectsIn: array1 with: array2 twoWay: twoWayFlag copyHash: copyHashFlag]
ifFalse:
[self innerBecomeObjectsIn: array1 to: array2 twoWay: twoWayFlag copyHash: copyHashFlag].
+ self postBecomeScanClassTable.
+ coInterpreter postBecomeAction: becomeEffectsFlags.
+ becomeEffectsFlags := 0.
- coInterpreter postBecomeAction: becommedPointerObjects.
- becommedPointerObjects := false.
self leakCheckBecome ifTrue:
[self runLeakCheckerForFullGC: true].
^PrimNoErr "success"!
Item was added:
+ ----- Method: SpurMemoryManager>>becomeEffectFlagsFor: (in category 'become implementation') -----
+ becomeEffectFlagsFor: objOop
+ "Answer the appropriate become effect flags for objOop, or 0 if none.
+ The effect flags affect how much work is done after the become in
+ following forwarding pointers."
+ <inline: false>
+ ^(self isPointersNonImm: objOop)
+ ifTrue:
+ [| hash |
+ (hash := self rawHashBitsOf: objOop) = 0
+ ifTrue: "Can't identify an abstract class by the class table; it may not be there-in."
+ [(coInterpreter objCouldBeClassObj: objOop)
+ ifTrue: [BecamePointerObjectFlag + BecameClassFlag]
+ ifFalse: [BecamePointerObjectFlag]]
+ ifFalse: "if an object has a hash and it's a class it must be in the table."
+ [(self classAtIndex: hash) = objOop
+ ifTrue: [BecamePointerObjectFlag + BecameClassFlag]
+ ifFalse: [BecamePointerObjectFlag]]]
+ ifFalse:
+ [(self isCompiledMethod: objOop)
+ ifTrue: [BecameCompiledMethodFlag]
+ ifFalse: [0]]!
Item was changed:
----- Method: SpurMemoryManager>>classAtIndex: (in category 'class table') -----
classAtIndex: classIndex
| classTablePage |
+ self assert: (classIndex <= self tagMask or: [classIndex >= self arrayClassIndexPun]).
classTablePage := self fetchPointer: classIndex >> self classTableMajorIndexShift
ofObject: classTableRootObj.
classTablePage = nilObj ifTrue:
[^nil].
^self
fetchPointer: (classIndex bitAnd: self classTableMinorIndexMask)
ofObject: classTablePage!
Item was changed:
+ ----- Method: SpurMemoryManager>>containOnlyOops: (in category 'become implementation') -----
- ----- Method: SpurMemoryManager>>containOnlyOops: (in category 'become') -----
containOnlyOops: array
"Answer if the array contains only non-immediates. You can't become: immediates!!"
+ | fieldOffset effectsFlags oop |
- | fieldOffset containsPointerObjs oop |
fieldOffset := self lastPointerOf: array.
+ effectsFlags := 0.
- containsPointerObjs := false.
"same size as array2"
[fieldOffset >= self baseHeaderSize] whileTrue:
[oop := self longAt: array + fieldOffset.
(self isImmediate: oop) ifTrue: [^false].
(self isForwarded: oop) ifTrue:
[oop := self followForwarded: oop.
self longAt: array + fieldOffset put: oop].
+ effectsFlags := effectsFlags bitOr: (self becomeEffectFlagsFor: oop).
- (self isPointersNonImm: oop) ifTrue:
- [containsPointerObjs := true].
fieldOffset := fieldOffset - BytesPerOop].
+ "only set flags after checking all args."
+ becomeEffectsFlags := effectsFlags.
- "only set becommedPointerObjects after checking all args."
- containsPointerObjs ifTrue:
- [becommedPointerObjects := true].
^true!
Item was changed:
+ ----- Method: SpurMemoryManager>>containOnlyOops:and: (in category 'become implementation') -----
- ----- Method: SpurMemoryManager>>containOnlyOops:and: (in category 'become') -----
containOnlyOops: array1 and: array2
"Answer if neither array contains only non-immediates. You can't become: immediates!!"
+ | fieldOffset effectsFlags oop |
- | fieldOffset containsPointerObjs oop |
fieldOffset := self lastPointerOf: array1.
+ effectsFlags := 0.
- containsPointerObjs := false.
"same size as array2"
[fieldOffset >= self baseHeaderSize] whileTrue:
[oop := self longAt: array1 + fieldOffset.
(self isImmediate: oop) ifTrue: [^false].
(self isForwarded: oop) ifTrue:
[oop := self followForwarded: oop.
self longAt: array1 + fieldOffset put: oop].
+ effectsFlags := effectsFlags bitOr: (self becomeEffectFlagsFor: oop).
- (self isPointersNonImm: oop) ifTrue:
- [containsPointerObjs := true].
oop := self longAt: array2 + fieldOffset.
(self isImmediate: oop) ifTrue: [^false].
(self isForwarded: oop) ifTrue:
[oop := self followForwarded: oop.
self longAt: array2 + fieldOffset put: oop].
+ effectsFlags := effectsFlags bitOr: (self becomeEffectFlagsFor: oop).
- (self isPointersNonImm: oop) ifTrue:
- [containsPointerObjs := true].
fieldOffset := fieldOffset - BytesPerOop].
+ "only set flags after checking all args."
+ becomeEffectsFlags := effectsFlags.
- "only set becommedPointerObjects after checking all args."
- containsPointerObjs ifTrue:
- [becommedPointerObjects := true].
^true!
Item was changed:
+ ----- Method: SpurMemoryManager>>doBecome:with:copyHash: (in category 'become implementation') -----
- ----- Method: SpurMemoryManager>>doBecome:with:copyHash: (in category 'become') -----
doBecome: obj1 with: obj2 copyHash: copyHashFlag
((self isClassInClassTable: obj1)
or: [self isClassInClassTable: obj1]) ifTrue:
[self halt].
(self numSlotsOf: obj1) = (self numSlotsOf: obj2)
ifTrue:
[self inPlaceBecome: obj1 and: obj2 copyHashFlag: copyHashFlag]
ifFalse:
[self outOfPlaceBecome: obj1 and: obj2 copyHashFlag: copyHashFlag]!
Item was changed:
+ ----- Method: SpurMemoryManager>>followForwarded: (in category 'become api') -----
- ----- Method: SpurMemoryManager>>followForwarded: (in category 'become') -----
followForwarded: objOop
| referent |
self assert: (self isForwarded: objOop).
referent := self fetchPointer: 0 ofForwardedOrFreeObject: objOop.
self assert: (self isForwarded: referent) not.
^referent!
Item was added:
+ ----- Method: SpurMemoryManager>>followForwardedObjectFields:toDepth: (in category 'become api') -----
+ followForwardedObjectFields: objOop toDepth: depth
+ "follow pointers in the object to depth.
+ How to avoid cyclic structures?? A temproary mark bit?"
+ | oop |
+ depth < 0 ifTrue:
+ [^self].
+ self assert: (self isPointers: objOop).
+ 0 to: (self numSlotsOf: objOop) - 1 do:
+ [:i|
+ oop := self fetchPointer: i ofObject: objOop.
+ ((self isNonImmediate: oop)
+ and: [self isForwarded: oop]) ifTrue:
+ [oop := self followForwarded: oop.
+ self storePointer: i ofObject: objOop withValue: oop].
+ self followForwardedObjectFields: objOop toDepth: depth - 1]!
Item was changed:
+ ----- Method: SpurMemoryManager>>followMaybeForwarded: (in category 'become implementation') -----
- ----- Method: SpurMemoryManager>>followMaybeForwarded: (in category 'become') -----
followMaybeForwarded: objOop
^(self isForwarded: objOop)
ifTrue: [self followForwarded: objOop]
ifFalse: [objOop]!
Item was changed:
+ ----- Method: SpurMemoryManager>>forward:to: (in category 'become implementation') -----
- ----- Method: SpurMemoryManager>>forward:to: (in category 'become') -----
forward: obj1 to: obj2
self setFormatOf: obj1 to: self forwardedFormat.
self setClassIndexOf: obj1 to: self isForwardedObjectClassIndexPun.
self storePointer: 0 ofForwardedOrFreeObject: obj1 withValue: obj2!
Item was changed:
+ ----- Method: SpurMemoryManager>>inPlaceBecome:and:copyHashFlag: (in category 'become implementation') -----
- ----- Method: SpurMemoryManager>>inPlaceBecome:and:copyHashFlag: (in category 'become') -----
inPlaceBecome: obj1 and: obj2 copyHashFlag: copyHashFlag
| headerTemp temp |
<var: 'headerTemp' type: #usqLong>
self assert: (self numSlotsOf: obj1) = (self numSlotsOf: obj2).
(self isRemembered: obj1)
ifTrue:
[(self isRemembered: obj1) ifFalse:
[scavenger
replace: obj1
inRememberedTableWith: obj2]]
ifFalse:
[(self isRemembered: obj2) ifTrue:
[scavenger
replace: obj2
inRememberedTableWith: obj1]].
headerTemp := self longLongAt: obj1.
self longLongAt: obj1 put: (self longLongAt: obj2).
self longLongAt: obj2 put: headerTemp.
copyHashFlag ifFalse: "undo hash copy"
[temp := self rawHashBitsOf: obj1.
self setHashBitsOf: obj1 to: (self rawHashBitsOf: obj2).
self setHashBitsOf: obj2 to: temp].
0 to: (self numSlotsOf: obj1) - 1 do:
[:i|
temp := self fetchPointer: i ofObject: obj1.
self storePointerUnchecked: i
ofObject: obj1
withValue: (self fetchPointer: i ofObject: obj2).
self storePointerUnchecked: i
ofObject: obj2
withValue: temp]!
Item was changed:
----- Method: SpurMemoryManager>>initialize (in category 'initialization') -----
initialize
freeLists := CArrayAccessor on: (Array new: NumFreeLists withAll: 0).
checkForLeaks := 0.
+ needGCFlag := signalLowSpace := false.
+ becomeEffectsFlags := 0.
- needGCFlag := signalLowSpace := becommedPointerObjects := false.
heapMap := self wordSize = 4 ifTrue: [CogCheck32BitHeapMap new]!
Item was changed:
+ ----- Method: SpurMemoryManager>>innerBecomeObjectsIn:to:twoWay:copyHash: (in category 'become implementation') -----
- ----- Method: SpurMemoryManager>>innerBecomeObjectsIn:to:twoWay:copyHash: (in category 'become') -----
innerBecomeObjectsIn: array1 to: array2 twoWay: twoWayFlag copyHash: copyHashFlag
| fieldOffset |
fieldOffset := self lastPointerOf: array1.
[fieldOffset >= self baseHeaderSize] whileTrue:
+ [self doBecome: (self longAt: array1 + fieldOffset)
- [self become: (self longAt: array1 + fieldOffset)
to: (self longAt: array2 + fieldOffset)
copyHash: copyHashFlag.
fieldOffset := fieldOffset - BytesPerOop]!
Item was changed:
+ ----- Method: SpurMemoryManager>>innerBecomeObjectsIn:with:twoWay:copyHash: (in category 'become implementation') -----
- ----- Method: SpurMemoryManager>>innerBecomeObjectsIn:with:twoWay:copyHash: (in category 'become') -----
innerBecomeObjectsIn: array1 with: array2 twoWay: twoWayFlag copyHash: copyHashFlag
| fieldOffset |
fieldOffset := self lastPointerOf: array1.
[fieldOffset >= self baseHeaderSize] whileTrue:
[self doBecome: (self longAt: array1 + fieldOffset)
with: (self longAt: array2 + fieldOffset)
copyHash: copyHashFlag.
fieldOffset := fieldOffset - BytesPerOop]!
Item was changed:
+ ----- Method: SpurMemoryManager>>isClassInClassTable: (in category 'become implementation') -----
- ----- Method: SpurMemoryManager>>isClassInClassTable: (in category 'become') -----
isClassInClassTable: objOop
| hash |
hash := self rawHashBitsOf: objOop.
hash = 0 ifTrue:
[false].
^(self classAtIndex: hash) = objOop!
Item was added:
+ ----- Method: SpurMemoryManager>>isForwardedClassTag: (in category 'class table') -----
+ isForwardedClassTag: classIndex
+ ^classIndex = self isForwardedObjectClassIndexPun!
Item was changed:
----- Method: SpurMemoryManager>>isForwardedObjectClassIndexPun (in category 'class table') -----
isForwardedObjectClassIndexPun
+ ^8 "Not to be confused with that of any immediate class"!
- ^1!
Item was changed:
----- Method: SpurMemoryManager>>isIntegerObject: (in category 'object testing') -----
isIntegerObject: oop
"This list records the valid senders of isIntegerObject: as we replace uses of
isIntegerObject: by isImmediate: where appropriate."
(#( makeBaseFrameFor:
quickFetchInteger:ofObject:
frameOfMarriedContext:
+ objCouldBeClassObj:
- addressCouldBeClassObj:
isMarriedOrWidowedContext:
shortPrint:
bytecodePrimAt
+ bytecodePrimAtPut
commonAt:
+ commonAtPut:
loadFloatOrIntFrom:
positive32BitValueOf:
primitiveExternalCall
checkedIntegerValueOf:
bytecodePrimAtPut
commonAtPut:
primitiveVMParameter
checkIsStillMarriedContext:currentFP:
displayBitsOf:Left:Top:Right:Bottom:
fetchStackPointerOf:
primitiveContextAt
primitiveContextAtPut
subscript:with:storing:format:) includes: thisContext sender method selector) ifFalse:
[self halt].
^(oop bitAnd: 1) ~= 0!
Item was added:
+ ----- Method: SpurMemoryManager>>isOopForwarded: (in category 'object testing') -----
+ isOopForwarded: oop
+ ^(self isNonImmediate: oop)
+ and: [(self classIndexOf: oop) = self isForwardedObjectClassIndexPun]!
Item was changed:
+ ----- Method: SpurMemoryManager>>outOfPlaceBecome:and:copyHashFlag: (in category 'become implementation') -----
- ----- Method: SpurMemoryManager>>outOfPlaceBecome:and:copyHashFlag: (in category 'become') -----
outOfPlaceBecome: obj1 and: obj2 copyHashFlag: copyHashFlag
"Allocate two new objects, n1 & n2. Copy the contents appropriately. Convert
obj1 and obj2 into forwarding objects pointing to n2 and n1 respectively"
| clone1 clone2 |
clone1 := (self isContextNonImm: obj1)
ifTrue: [coInterpreter cloneContext: obj1]
ifFalse: [self clone: obj1].
clone2 := (self isContextNonImm: obj2)
ifTrue: [coInterpreter cloneContext: obj2]
ifFalse: [self clone: obj2].
copyHashFlag
ifTrue:
[self setHashBitsOf: clone1 to: (self rawHashBitsOf: obj2).
self setHashBitsOf: clone2 to: (self rawHashBitsOf: obj1)]
ifFalse:
[self setHashBitsOf: clone1 to: (self rawHashBitsOf: obj1).
self setHashBitsOf: clone2 to: (self rawHashBitsOf: obj2)].
self
forward: obj1 to: clone2;
forward: obj2 to: clone1!
Item was added:
+ ----- Method: SpurMemoryManager>>postBecomeScanClassTable (in category 'become implementation') -----
+ postBecomeScanClassTable
+ "Scan the class table post-become (iff a pointer object was becommed)"
+ (becomeEffectsFlags anyMask: BecamePointerObjectFlag) ifFalse: [^self].
+
+ 0 to: (self numSlotsOf: classTableRootObj) - 1 do:
+ [:i| | page |
+ page := self fetchPointer: i ofObject: classTableRootObj.
+ 0 to: (self numSlotsOf: page) - 1 do:
+ [:j| | classOrNil |
+ classOrNil := self fetchPointer: j ofObject: page.
+ classOrNil ~= nilObj ifTrue:
+ [(self isForwarded: classOrNil) ifTrue:
+ [classOrNil := self followForwarded: classOrNil.
+ self storePointer: j ofObject: page withValue: classOrNil].
+ self scanClassPostBecome: classOrNil]]]!
Item was added:
+ ----- Method: SpurMemoryManager>>scanClassPostBecome: (in category 'become implementation') -----
+ scanClassPostBecome: classObj
+ "Scan a class in the class table post-become. Make sure the superclass
+ chain contains no forwarding pointers, and that the method dictionaries
+ are not forwarded either."
+
+ | obj |
+ self assert: (self rawHashBitsOf: nilObj) ~= 0.
+
+ obj := self fetchPointer: MethodDictionaryIndex ofObject: classObj.
+ self assert: (self isNonImmediate: obj).
+ (self isForwarded: obj) ifTrue:
+ [obj := self followForwarded: obj.
+ self storePointer: MethodDictionaryIndex ofObject: classObj withValue: obj].
+
+ obj := self fetchPointer: SuperclassIndex ofObject: classObj.
+ self assert: (self isNonImmediate: obj).
+ (self isForwarded: obj) ifTrue:
+ [obj := self followForwarded: obj.
+ self storePointer: SuperclassIndex ofObject: classObj withValue: obj].
+
+ "If the superclass has an identityHash then either it is nil, or is in the class table.
+ Tail recurse."
+ (self rawHashBitsOf: obj) = 0 ifTrue:
+ [self scanClassPostBecome: obj]!
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 lkupClassTag 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'
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 VMSpurObjectRepresentationConstants VMSqueakClassIndices VMSqueakV3BytecodeConstants VMSqueakV3ObjectRepresentationConstants VMStackFrameOffsets'
- poolDictionaries: 'VMBasicConstants VMMethodCacheConstants VMObjectIndices VMSqueakClassIndices VMSqueakV3BytecodeConstants VMSqueakV3ObjectRepresentationConstants VMStackFrameOffsets'
category: 'VMMaker-Interpreter'!
!StackInterpreter commentStamp: 'eem 9/11/2013 18:30' 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-big-frame-up. 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. An even better solution is to eliminate compact classes altogether (see 6.).
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. [Late news, the support has been extended to 64-bit file 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. We can still have 31-bit SmallIntegers by allowing two tag patterns for SmallInteger.
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. [Late breaking news, the 2-word header scheme is more compact, by over 2%]. See SpurMemorymanager's class comment.!
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: [self objCouldBeClassObj: maybeClassObj]!
- and: [((objectMemory isPointersNonImm: maybeClassObj) and: [(objectMemory lengthOf: maybeClassObj) >= (InstanceSpecificationIndex+1)])
- and: [(objectMemory isPointers: (objectMemory fetchPointer: SuperclassIndex ofObject: maybeClassObj))
- and: [(objectMemory isPointers: (objectMemory fetchPointer: MethodDictionaryIndex ofObject: maybeClassObj))
- and: [(objectMemory isIntegerObject: (objectMemory fetchPointer: InstanceSpecificationIndex ofObject: maybeClassObj))]]]]!
Item was changed:
----- Method: StackInterpreter>>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 isNonImmediate: rcvr)
- ((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:
[lkupClassTag := objectMemory fetchClassTagOfNonImm: rcvr.
messageSelector := self specialSelector: 16.
(self lookupInMethodCacheSel: messageSelector classTag: lkupClassTag) 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: StackInterpreter>>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 isNonImmediate: rcvr)
- ((objectMemory isIntegerObject: rcvr) not
and: [objectMemory isIntegerObject: index]) ifTrue:
[atIx := (rcvr bitAnd: AtCacheMask) + AtPutBase. "Index into atPutCache"
(atCache at: atIx+AtCacheOop) ~= rcvr ifTrue:
[lkupClassTag := objectMemory fetchClassTagOfNonImm: rcvr.
messageSelector := self specialSelector: 17.
(self lookupInMethodCacheSel: messageSelector classTag: lkupClassTag) 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: StackInterpreter>>findClassOfMethod:forReceiver: (in category 'debug support') -----
findClassOfMethod: meth forReceiver: rcvr
| rclass |
+ ((objectMemory addressCouldBeOop: rcvr)
+ and: [(objectMemory isOopForwarded: rcvr) not]) ifTrue:
- (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:
[^objectMemory nilObject].
^self findClassContainingMethod: meth startingAt: (self methodClassOf: meth)!
Item was changed:
----- Method: StackInterpreter>>findNewMethodInClassTag: (in category 'message sending') -----
findNewMethodInClassTag: classTag
"Find the compiled method to be run when the current
messageSelector is sent to the given class, setting the values
of 'newMethod' and 'primitiveIndex'."
| ok class |
<inline: false>
ok := self lookupInMethodCacheSel: messageSelector classTag: classTag.
ok ifFalse: "entry was not found in the cache; look it up the hard way "
+ [class := self sendFaultFor: classTag.
- [class := objectMemory classForClassTag: classTag.
- objectMemory hasSpurMemoryManagerAPI ifTrue:
- [| oop |
- oop := self stackValue: argumentCount.
- ((objectMemory isNonImmediate: oop)
- and: [objectMemory isForwarded: oop]) ifTrue:
- [self stackValue: argumentCount put: (objectMemory followForwarded: oop)]].
self lookupMethodInClass: class.
self addNewMethodToCache: class]!
Item was added:
+ ----- Method: StackInterpreter>>followForwardedFrameContents:stackPointer: (in category 'lazy become') -----
+ followForwardedFrameContents: theFP stackPointer: theSP
+ "follow pointers in the current stack frame up to theSP."
+ <var: #theFP type: #'char *'>
+ <var: #theSP type: #'char *'>
+ theFP + (self frameStackedReceiverOffset: theFP)
+ to: theFP + FoxCallerSavedIP + BytesPerWord
+ by: BytesPerWord
+ do: [:ptr| | oop |
+ oop := stackPages longAt: ptr.
+ ((objectMemory isNonImmediate: oop)
+ and: [objectMemory isForwarded: oop]) ifTrue:
+ [stackPages longAt: ptr put: (objectMemory followForwarded: oop)]].
+ theSP
+ to: theFP + FoxReceiver
+ by: BytesPerWord
+ do: [:ptr| | oop |
+ oop := stackPages longAt: ptr.
+ ((objectMemory isNonImmediate: oop)
+ and: [objectMemory isForwarded: oop]) ifTrue:
+ [stackPages longAt: ptr put: (objectMemory followForwarded: oop)]].
+ self assert: (objectMemory isForwarded: (self frameMethod: theFP)) not.
+ (self frameHasContext: theFP) ifTrue:
+ [self assert: (objectMemory isForwarded: (self frameContext: theFP)) not]!
Item was removed:
- ----- Method: StackInterpreter>>followForwardingPointersInStackZone (in category 'object memory support') -----
- followForwardingPointersInStackZone
- "Spur's become: is lazy, turning the becommed object into a forwarding object to the other.
- The read-barrier is minimised by arranging that forwarding pointers will fail a method cache probe,
- since notionally objects' internals are accessed only via sending messages to them (the exception
- is primitives that access the internals of the non-receiver argument(s)..
- To avoid a read barrier on bytecode, literal and inst var fetch we scan the receivers and methods
- in the stack zone and follow any forwarded ones. This is of course way cheaper than scanning all
- of memory as in the old become."
- | theIPPtr |
- <inline: false>
- <var: #thePage type: #'StackPage *'>
- <var: #theSP type: #'char *'>
- <var: #theFP type: #'char *'>
- <var: #callerFP type: #'char *'>
- <var: #theIPPtr type: #'char *'>
-
- (objectMemory isForwarded: method) ifTrue:
- [theIPPtr := instructionPointer - method.
- method := objectMemory followForwarded: method.
- instructionPointer := method + theIPPtr].
- (objectMemory isForwarded: newMethod) ifTrue:
- [newMethod := objectMemory followForwarded: newMethod].
-
- "Need to write back the frame pointers unless all pages are free (as in snapshot)"
- self assert: stackPage ~= 0.
- self externalWriteBackHeadFramePointers.
- 0 to: numStackPages - 1 do:
- [:i| | thePage theSP theFP callerFP theIP oop |
- thePage := stackPages stackPageAt: i.
- thePage isFree ifFalse:
- [theSP := thePage headSP.
- theFP := thePage headFP.
- "Skip the instruction pointer on top of stack of inactive pages."
- thePage = stackPage
- ifTrue: [theIPPtr := 0]
- ifFalse:
- [theIPPtr := theSP.
- theSP := theSP + BytesPerWord].
- [self assert: (thePage addressIsInPage: theFP).
- self assert: (theIPPtr = 0 or: [thePage addressIsInPage: theIPPtr]).
- oop := stackPages longAt: theFP + FoxReceiver.
- ((objectMemory isNonImmediate: oop)
- and: [(objectMemory isForwarded: oop)]) ifTrue:
- [stackPages
- longAt: theFP + FoxReceiver
- put: (objectMemory followForwarded: oop)].
- theIP := theFP + (self frameStackedReceiverOffset: theFP). "reuse theIP; its just an offset here"
- oop := stackPages longAt: theIP.
- ((objectMemory isNonImmediate: oop)
- and: [(objectMemory isForwarded: oop)]) ifTrue:
- [stackPages
- longAt: theIP
- put: (objectMemory followForwarded: oop)].
- ((self frameHasContext: theFP)
- and: [(objectMemory isForwarded: (self frameContext: theFP))]) ifTrue:
- [stackPages
- longAt: theFP + FoxThisContext
- put: (objectMemory followForwarded: (self frameContext: theFP))].
- (objectMemory isForwarded: (self frameMethod: theFP)) ifTrue:
- [theIPPtr ~= 0 ifTrue:
- [self assert: (stackPages longAt: theIPPtr) > (self frameMethod: theFP).
- theIP := (stackPages longAt: theIPPtr) - (self frameMethod: theFP)].
- stackPages
- longAt: theFP + FoxMethod
- put: (objectMemory followForwarded: (self frameMethod: theFP)).
- theIPPtr ~= 0 ifTrue:
- [stackPages longAt: theIPPtr put: theIP + (self frameMethod: theFP)]].
- (callerFP := self frameCallerFP: theFP) ~= 0] whileTrue:
- [theIPPtr := theFP + FoxCallerSavedIP.
- theFP := callerFP]]]!
Item was added:
+ ----- Method: StackInterpreter>>followForwardingPointersInStackZone: (in category 'object memory support') -----
+ followForwardingPointersInStackZone: becomeEffectsFlags
+ "Spur's become: is lazy, turning the becommed object into a forwarding object to the other.
+ The read-barrier is minimised by arranging that forwarding pointers will fail a method cache probe,
+ since notionally objects' internals are accessed only via sending messages to them (the exception
+ is primitives that access the internals of the non-receiver argument(s)..
+ To avoid a read barrier on bytecode, literal and inst var fetch we scan the receivers and methods
+ in the stack zone and follow any forwarded ones. This is of course way cheaper than scanning all
+ of memory as in the old become."
+ | theIPPtr |
+ <inline: false>
+ <var: #thePage type: #'StackPage *'>
+ <var: #theSP type: #'char *'>
+ <var: #theFP type: #'char *'>
+ <var: #callerFP type: #'char *'>
+ <var: #theIPPtr type: #'char *'>
+
+ "NEEDS MORE THOUGHT!! WHAT ABOUT methodClassAssociation etc
+ examine becomeEffectsFlags"
+ (becomeEffectsFlags anyMask: BecameCompiledMethodFlag) ifTrue:
+ [(objectMemory isForwarded: method) ifTrue:
+ [theIPPtr := instructionPointer - method.
+ method := objectMemory followForwarded: method.
+ instructionPointer := method + theIPPtr].
+ (objectMemory isForwarded: newMethod) ifTrue:
+ [newMethod := objectMemory followForwarded: newMethod]].
+
+ "Need to write back the frame pointers unless all pages are free (as in snapshot)"
+ self assert: stackPage ~= 0.
+ self externalWriteBackHeadFramePointers.
+ 0 to: numStackPages - 1 do:
+ [:i| | thePage theSP theFP callerFP theIP oop |
+ thePage := stackPages stackPageAt: i.
+ thePage isFree ifFalse:
+ [theSP := thePage headSP.
+ theFP := thePage headFP.
+ "Skip the instruction pointer on top of stack of inactive pages."
+ thePage = stackPage
+ ifTrue: [theIPPtr := 0]
+ ifFalse:
+ [theIPPtr := theSP.
+ theSP := theSP + BytesPerWord].
+ [self assert: (thePage addressIsInPage: theFP).
+ self assert: (theIPPtr = 0 or: [thePage addressIsInPage: theIPPtr]).
+ oop := stackPages longAt: theFP + FoxReceiver.
+ ((objectMemory isNonImmediate: oop)
+ and: [(objectMemory isForwarded: oop)]) ifTrue:
+ [stackPages
+ longAt: theFP + FoxReceiver
+ put: (objectMemory followForwarded: oop)].
+ theIP := theFP + (self frameStackedReceiverOffset: theFP). "reuse theIP; its just an offset here"
+ oop := stackPages longAt: theIP.
+ ((objectMemory isNonImmediate: oop)
+ and: [(objectMemory isForwarded: oop)]) ifTrue:
+ [stackPages
+ longAt: theIP
+ put: (objectMemory followForwarded: oop)].
+ ((self frameHasContext: theFP)
+ and: [(objectMemory isForwarded: (self frameContext: theFP))]) ifTrue:
+ [stackPages
+ longAt: theFP + FoxThisContext
+ put: (objectMemory followForwarded: (self frameContext: theFP))].
+ (objectMemory isForwarded: (self frameMethod: theFP)) ifTrue:
+ [theIPPtr ~= 0 ifTrue:
+ [self assert: (stackPages longAt: theIPPtr) > (self frameMethod: theFP).
+ theIP := (stackPages longAt: theIPPtr) - (self frameMethod: theFP)].
+ stackPages
+ longAt: theFP + FoxMethod
+ put: (objectMemory followForwarded: (self frameMethod: theFP)).
+ theIPPtr ~= 0 ifTrue:
+ [stackPages longAt: theIPPtr put: theIP + (self frameMethod: theFP)]].
+ (callerFP := self frameCallerFP: theFP) ~= 0] whileTrue:
+ [theIPPtr := theFP + FoxCallerSavedIP.
+ theFP := callerFP]]]!
Item was changed:
----- Method: StackInterpreter>>internalFindNewMethod (in category 'message sending') -----
internalFindNewMethod
"Find the compiled method to be run when the current messageSelector is sent to the class 'lkupClass', setting the values of 'newMethod' and 'primitiveIndex'."
| ok |
<inline: true>
ok := self lookupInMethodCacheSel: messageSelector classTag: lkupClassTag.
ok ifFalse: "entry was not found in the cache; look it up the hard way"
+ [self externalizeIPandSP.
+ lkupClass := self sendFaultFor: lkupClassTag.
- [lkupClass := objectMemory classForClassTag: lkupClassTag.
- objectMemory hasSpurMemoryManagerAPI ifTrue:
- [| oop |
- oop := self internalStackValue: argumentCount.
- ((objectMemory isNonImmediate: oop)
- and: [objectMemory isForwarded: oop]) ifTrue:
- [self internalStackValue: argumentCount put: (objectMemory followForwarded: oop)]].
- self externalizeIPandSP.
self lookupMethodInClass: lkupClass.
self internalizeIPandSP.
self addNewMethodToCache: lkupClass]!
Item was added:
+ ----- Method: StackInterpreter>>objCouldBeClassObj: (in category 'debug support') -----
+ objCouldBeClassObj: objOop
+ "Answer if objOop looks like a class object"
+ <inline: false>
+ ^(objectMemory isPointersNonImm: objOop)
+ and: [(objectMemory numSlotsOf: objOop) >= (InstanceSpecificationIndex+1)
+ and: [(objectMemory isPointers: (objectMemory fetchPointer: SuperclassIndex ofObject: objOop))
+ and: [(objectMemory isPointers: (objectMemory fetchPointer: MethodDictionaryIndex ofObject: objOop))
+ and: [(objectMemory isIntegerObject: (objectMemory fetchPointer: InstanceSpecificationIndex ofObject: objOop))]]]]!
Item was changed:
----- Method: StackInterpreter>>postBecomeAction: (in category 'object memory support') -----
+ postBecomeAction: becomeEffectsFlags
+ becomeEffectsFlags ~= 0 ifTrue:
+ [self followForwardingPointersInStackZone: becomeEffectsFlags]!
- postBecomeAction: updateReceiversInStackZone
- updateReceiversInStackZone ifTrue:
- [self followForwardingPointersInStackZone]!
Item was changed:
----- Method: StackInterpreter>>printActivationNameFor:receiver:isBlock:firstTemporary: (in category 'debug printing') -----
printActivationNameFor: aMethod receiver: anObject isBlock: isBlock firstTemporary: maybeMessage
| methClass methodSel classObj |
<inline: false>
isBlock ifTrue:
[self print: '[] in '].
methClass := self findClassOfMethod: aMethod forReceiver: anObject.
methodSel := self findSelectorOfMethod: aMethod.
((objectMemory addressCouldBeOop: anObject)
+ and: [(objectMemory isForwarded: anObject) not
+ and: [self addressCouldBeClassObj: (classObj := objectMemory fetchClassOf: anObject)]])
- and: [self addressCouldBeClassObj: (classObj := objectMemory fetchClassOf: anObject)])
ifTrue:
[classObj = methClass
ifTrue: [self printNameOfClass: methClass count: 5]
ifFalse:
[self printNameOfClass: classObj count: 5.
self print: '('.
self printNameOfClass: methClass count: 5.
self print: ')']]
ifFalse:
[self cCode: '' inSmalltalk: [self halt].
self print: 'INVALID RECEIVER'].
self print: '>'.
(objectMemory addressCouldBeOop: methodSel)
ifTrue:
[methodSel = objectMemory nilObject
ifTrue: [self print: '?']
ifFalse: [self printStringOf: methodSel]]
ifFalse: [self print: 'INVALID SELECTOR'].
(methodSel = (objectMemory splObj: SelectorDoesNotUnderstand)
and: [(objectMemory addressCouldBeObj: maybeMessage)
and: [(objectMemory fetchClassOf: 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>>printOop: (in category 'debug printing') -----
printOop: oop
| cls fmt lastIndex startIP bytecodesPerLine column |
<inline: false>
(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.
^nil].
(objectMemory isFreeObject: oop) ifTrue:
[self print: ' is a free chunk of size '; printNum: (objectMemory sizeOfFree: oop); cr.
^nil].
(objectMemory isForwarded: oop) ifTrue:
[self
print: ' is a forwarded object to '; printHex: (objectMemory followForwarded: oop);
+ print: ' of slot size '; printNum: (objectMemory numSlotsOfAny: oop); cr.
- print: ' of slot size '; printNum: (objectMemory numSlotsOf: oop); cr.
^nil].
self print: ': a(n) '.
self printNameOfClass: (cls := objectMemory fetchClassOfNonImm: oop) count: 5.
cls = (objectMemory splObj: ClassFloat) ifTrue:
[self cr; printFloat: (self dbgFloatValueOf: oop); cr.
^nil].
fmt := objectMemory formatOf: oop.
fmt > objectMemory lastPointerFormat ifTrue:
[self print: ' nbytes '; printNum: (objectMemory byteLengthOf: oop)].
self cr.
(fmt between: objectMemory firstLongFormat and: objectMemory firstCompiledMethodFormat - 1) 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].
"this is nonsense. apologies."
startIP := (objectMemory lastPointerOf: oop) + BytesPerOop - objectMemory baseHeaderSize / BytesPerOop.
lastIndex := 256 min: startIP.
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 added:
+ ----- Method: StackInterpreter>>sendFaultFor: (in category 'message sending') -----
+ sendFaultFor: classTag
+ "Handle a send fault that may be due to a send to a forwarded object.
+ Unforward the receiver on the stack and answer its actual class."
+ | rcvr |
+ (objectMemory isForwardedClassTag: classTag) ifFalse:
+ [^objectMemory classForClassTag: classTag].
+
+ rcvr := self stackValue: argumentCount.
+ "should *not* be a super send, so te receiver should be forwarded."
+ self assert: (objectMemory isOopForwarded: rcvr).
+ rcvr := objectMemory followForwarded: rcvr.
+ self stackValue: argumentCount put: rcvr.
+ self followForwardedFrameContents: framePointer
+ stackPointer: stackPointer + (argumentCount + 1 * BytesPerWord). "don't repeat effort"
+ (objectMemory isPointers: (self frameReceiver: framePointer)) ifTrue:
+ [objectMemory
+ followForwardedObjectFields: (self frameReceiver: framePointer)
+ toDepth: 0].
+ ^objectMemory fetchClassOf: rcvr!
Item was changed:
----- Method: StackInterpreterPrimitives>>primitiveVMParameter (in category 'system control primitives') -----
(excessive size, no diff calculated)
Item was changed:
----- Method: StackInterpreterSimulator>>primitiveAtPut (in category 'indexing primitives') -----
primitiveAtPut
+ "16r1510B8 = (self stackValue: 2) ifTrue:
+ [self halt]."
- 16r1510B8 = (self stackValue: 2) ifTrue:
- [self halt].
^super primitiveAtPut!
Item was added:
+ VMBasicConstants subclass: #VMSpurObjectRepresentationConstants
+ instanceVariableNames: ''
+ classVariableNames: 'BecameClassFlag BecameCompiledMethodFlag BecamePointerObjectFlag'
+ poolDictionaries: ''
+ category: 'VMMaker-Interpreter'!
More information about the Vm-dev
mailing list