[Vm-dev] VM Maker: VMMaker.oscog-eem.914.mcz
commits at source.squeak.org
commits at source.squeak.org
Wed Oct 29 23:49:53 UTC 2014
Eliot Miranda uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker.oscog-eem.914.mcz
==================== Summary ====================
Name: VMMaker.oscog-eem.914
Author: eem
Time: 29 October 2014, 4:46:56.613 pm
UUID: bda96e1c-f22e-4b32-9ee1-620740e1fec5
Ancestors: VMMaker.oscog-eem.913
Spur:
Implement safe access to contexts and methods when
creating image segments (since internally married
contexts and jitted methods have hidden state
encoded in odd ways).
As a result:
Fix baaad bug in SpurMemoryManager>>lastPointerOf:
for contexts, caused by transcription from
(New)ObjectMemory where the method works on a
wing and a prayer because
BaseHeaderSize = BytesPerOop.
And I can't be arsed to fix it. It's, cough, grody code.
Refactor decoding of context instruction pointers so
there is only one copy of the code.
Fix baaad bug in accessibleObjectAfter: and add an
assert to primitiveNextObject to catch similar bugs.
Can now enumerate objects in new space, which will
sort-of work, but code should really use allObjects.
Will fix at the image level as time allows.
Eliminate isInSurvivorSpace: in favour of the identical
isInPastSpace:.
All:
Fix the comments in loadImageSegmentFrom:outPointers:;
the array is not truncated to zero length; it retains
its version info.
Fix storeShort16:ofObject:withValue: to accept
negative values.
=============== Diff against VMMaker.oscog-eem.913 ===============
Item was changed:
----- Method: CoInterpreter>>externalInstVar:ofContext: (in category 'frame access') -----
externalInstVar: offset ofContext: aContext
"Fetch an instance variable from a maybe married context.
If the context is still married compute the value of the
relevant inst var from the spouse frame's state.
If the context is single but has a negative instruction pointer
recognise that the instruction pointer is actually into machine
code and convert it to the corresponding bytecode pc."
+ | value |
- | value spouseFP |
- <var: #spouseFP type: #'char *'>
- <var: #thePage type: #'StackPage *'>
- <var: #theFPAbove type: #'char *'>
self assert: (objectMemory isContext: aContext).
- self externalWriteBackHeadFramePointers.
"method, closureOrNil & receiver need no special handling; only
sender, pc & stackp have to be computed for married contexts."
+ ((self isReadMediatedContextInstVarIndex: offset)
- (offset < MethodIndex
and: [self isMarriedOrWidowedContext: aContext]) ifFalse:
[value := objectMemory fetchPointer: offset ofObject: aContext.
^(offset = InstructionPointerIndex
and: [(objectMemory isIntegerObject: value)
and: [value signedIntFromLong < 0]])
ifTrue: [self mustMapMachineCodePC: (objectMemory integerValueOf: value)
context: aContext]
ifFalse: [value]].
+ self externalWriteBackHeadFramePointers.
+ ^(self isStillMarriedContext: aContext)
+ ifTrue: [self fetchPointer: offset ofMarriedContext: aContext]
+ ifFalse: [objectMemory fetchPointer: offset ofObject: aContext]!
- (self isWidowedContext: aContext) ifTrue:
- [^objectMemory fetchPointer: offset ofObject: aContext].
-
- spouseFP := self frameOfMarriedContext: aContext.
- offset = SenderIndex ifTrue:
- [^self ensureCallerContext: spouseFP].
- offset = StackPointerIndex ifTrue:
- [self assert: ReceiverIndex + (self stackPointerIndexForFrame: spouseFP) < (objectMemory lengthOf: aContext).
- ^objectMemory integerObjectOf: (self stackPointerIndexForFrame: spouseFP)].
- offset = InstructionPointerIndex ifTrue:
- [| theIP thePage theFPAbove |
- spouseFP = framePointer
- ifTrue: [theIP := self oopForPointer: instructionPointer]
- ifFalse:
- [thePage := stackPages stackPageFor: spouseFP.
- theFPAbove := self findFrameAbove: spouseFP inPage: thePage.
- theIP := theFPAbove == 0
- ifTrue: [stackPages longAt: thePage headSP]
- ifFalse:[self oopForPointer: (self frameCallerSavedIP: theFPAbove)]].
- value := self contextInstructionPointer: theIP frame: spouseFP.
- ^value signedIntFromLong < 0
- ifTrue: [self mustMapMachineCodePC: (objectMemory integerValueOf: value)
- context: aContext]
- ifFalse: [value]].
- self error: 'bad index'.
- ^0!
Item was changed:
----- Method: CoInterpreter>>instVar:ofContext: (in category 'frame access') -----
instVar: offset ofContext: aContext
"Fetch an instance avriable from a maybe married context.
If the context is still married compute the value of the
relevant inst var from the spouse frame's state.
If the context is single but has a negative instruction pointer
recognise that the instruction pointer is actually into machine
code and convert it to the corresponding bytecode pc."
| value spouseFP |
<var: #spouseFP type: #'char *'>
- <var: #thePage type: #'StackPage *'>
- <var: #theFPAbove type: #'char *'>
<inline: true>
self assert: offset < MethodIndex.
self assert: (objectMemory isContext: aContext).
self writeBackHeadFramePointers.
(self isMarriedOrWidowedContext: aContext) ifFalse:
[value := objectMemory fetchPointer: offset ofObject: aContext.
(offset = InstructionPointerIndex
+ and: [(objectMemory isIntegerObject: value)
- and: ["self halt: value hex." (objectMemory isIntegerObject: value)
and: [value signedIntFromLong < 0]]) ifTrue:
[value := self internalMustMapMachineCodePC: (objectMemory integerValueOf: value)
context: aContext].
^value].
(self isWidowedContext: aContext) ifTrue:
[^objectMemory fetchPointer: offset ofObject: aContext].
spouseFP := self frameOfMarriedContext: aContext.
offset = SenderIndex ifTrue:
[^self ensureCallerContext: spouseFP].
offset = StackPointerIndex ifTrue:
[self assert: ReceiverIndex + (self stackPointerIndexForFrame: spouseFP) < (objectMemory lengthOf: aContext).
^objectMemory integerObjectOf: (self stackPointerIndexForFrame: spouseFP)].
offset = InstructionPointerIndex ifTrue:
+ [^self instructionPointerForFrame: spouseFP currentFP: localFP currentIP: localIP].
- [| theIP thePage theFPAbove |
- spouseFP = localFP
- ifTrue: [theIP := self oopForPointer: localIP]
- ifFalse:
- [thePage := stackPages stackPageFor: spouseFP.
- theFPAbove := self findFrameAbove: spouseFP inPage: thePage.
- theIP := theFPAbove == 0
- ifTrue: [stackPages longAt: thePage headSP]
- ifFalse:[self oopForPointer: (self frameCallerSavedIP: theFPAbove)]].
- value := self contextInstructionPointer: theIP frame: spouseFP.
- value signedIntFromLong < 0 ifTrue:
- [value := self internalMustMapMachineCodePC: (objectMemory integerValueOf: value)
- context: aContext].
- ^value].
self error: 'bad index'.
^0!
Item was added:
+ ----- Method: CoInterpreter>>instructionPointerForFrame:currentFP:currentIP: (in category 'frame access') -----
+ instructionPointerForFrame: spouseFP currentFP: currentFP currentIP: instrPtr
+ "Answer the bytecode pc object (i.e. SmallInteger) for an active frame. The bytecode
+ pc is derived from the frame's pc. If the frame is the top frame on the current stack
+ the frame pc is whatever the current instruction pointer is. If the frame is the top
+ frame on some other stack the frame pc is the value on top of stack. Otherwise the
+ frame pc is the saved pc of the frame above. Once the frame pc is found it must be
+ mapped to a bytecode pc."
+ | value theIP thePage theFPAbove |
+ spouseFP = currentFP
+ ifTrue: [theIP := self oopForPointer: instrPtr]
+ ifFalse:
+ [thePage := stackPages stackPageFor: spouseFP.
+ theFPAbove := self findFrameAbove: spouseFP inPage: thePage.
+ theIP := theFPAbove == 0
+ ifTrue: [stackPages longAt: thePage headSP]
+ ifFalse:[self oopForPointer: (self frameCallerSavedIP: theFPAbove)]].
+ value := self contextInstructionPointer: theIP frame: spouseFP.
+ ^value signedIntFromLong < 0
+ ifTrue: [self mustMapMachineCodePC: (objectMemory integerValueOf: value)
+ context: (self frameContext: spouseFP)]
+ ifFalse: [value]!
Item was changed:
----- Method: CurrentImageCoInterpreterFacade>>isWriteMediatedContextInstVarIndex: (in category 'frame access') -----
isWriteMediatedContextInstVarIndex: index
+ "Writing any inst vars of a context must take account of potentially married contexts
- "Wrining any inst vars of a context must take account of potentially married contexts
and set the state in the frame. Inst vars in subclasses don't need mediation; subclasses
can't marry."
^index <= ReceiverIndex!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveLoadImageSegment (in category 'image segment in/out') -----
primitiveLoadImageSegment
"This primitive is called from Squeak as...
<imageSegment> loadSegmentFrom: aWordArray outPointers: anArray."
+ "This primitive will load a binary image segment created by primitiveStoreImageSegment.
+ It expects the outPointer array to be of the proper size, and the wordArray to be well
+ formed. It will return as its value the original array of roots, and the erstwhile
+ segmentWordArray will have been truncated to a size of one word, i.e. retaining the version
+ stamp. If this primitive should fail, the segmentWordArray will, sadly, have been reduced to
+ an unrecognizable and unusable jumble. But what more could you have done with it anyway?"
- "This primitive will load a binary image segment created by primitiveStoreImageSegment. It expects the outPointer array to be of the proper size, and the wordArray to be well formed. It will return as its value the original array of roots, and the erstwhile segmentWordArray will have been truncated to a size of zero. If this primitive should fail, the segmentWordArray will, sadly, have been reduced to an unrecognizable and unusable jumble. But what more could you have done with it anyway?"
| outPointerArray segmentWordArray result |
outPointerArray := self stackTop.
segmentWordArray := self stackValue: 1.
"Essential type checks"
((objectMemory isArray: outPointerArray) "Must be indexable pointers"
and: [objectMemory isWords: segmentWordArray]) "Must be indexable words"
ifFalse: [^self primitiveFail].
"the engine returns the roots array which was first in the segment, or an error code on failure."
result := objectMemory loadImageSegmentFrom: segmentWordArray outPointers: outPointerArray.
(self oop: result isGreaterThan: segmentWordArray)
ifTrue: [self pop: 3 thenPush: result]
ifFalse: [self primitiveFailFor: result]!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveNextObject (in category 'object access primitives') -----
primitiveNextObject
"Return the object following the receiver in the heap. Return the SmallInteger zero when there are no more objects."
+ (objectMemory accessibleObjectAfter: self stackTop)
+ ifNil: [self pop: argumentCount+1 thenPushInteger: 0]
+ ifNotNil: [:instance|
+ self assert: (objectMemory isInMemory: instance).
+ self pop: argumentCount+1 thenPush: instance]!
- | object instance |
- object := self stackTop.
- instance := objectMemory accessibleObjectAfter: object.
- instance = nil
- ifTrue: [ self pop: argumentCount+1 thenPushInteger: 0 ]
- ifFalse: [ self pop: argumentCount+1 thenPush: instance ].!
Item was changed:
----- Method: NewObjectMemory>>loadImageSegmentFrom:outPointers: (in category 'image segment in/out') -----
loadImageSegmentFrom: segmentWordArray outPointers: outPointerArray
"This primitive is called from Squeak as...
<imageSegment> loadSegmentFrom: aWordArray outPointers: anArray."
+ "This primitive will load a binary image segment created by primitiveStoreImageSegment. It expects the outPointer array to be of the proper size, and the wordArray to be well formed. It will return as its value the original array of roots, and the erstwhile segmentWordArray will have been truncated to a size of one word, i.e. retaining the version stamp. If this primitive should fail, the segmentWordArray will, sadly, have been reduced to an unrecognizable and unusable jumble. But what more could you have done with it anyway?"
- "This primitive will load a binary image segment created by primitiveStoreImageSegment. It expects the outPointer array to be of the proper size, and the wordArray to be well formed. It will return as its value the original array of roots, and the erstwhile segmentWordArray will have been truncated to a size of zero. If this primitive should fail, the segmentWordArray will, sadly, have been reduced to an unrecognizable and unusable jumble. But what more could you have done with it anyway?"
| endSeg segOop fieldPtr fieldOop doingClass lastPtr extraSize mapOop lastOut outPtr hdrTypeBits header data |
<inline: false>
<var: #endSeg type: #usqInt>
<var: #segOop type: #usqInt>
<var: #fieldPtr type: #usqInt>
<var: #lastOut type: #usqInt>
<var: #outPtr type: #usqInt>
<var: #lastPtr type: #usqInt>
DoAssertionChecks ifTrue: [self verifyCleanHeaders].
lastOut := outPointerArray + (self lastPointerOf: outPointerArray).
endSeg := segmentWordArray + (self sizeBitsOf: segmentWordArray) - BaseHeaderSize.
"Version check. Byte order of the WordArray now"
data := self longAt: segmentWordArray + BaseHeaderSize.
(coInterpreter readableFormat: (data bitAnd: 16rFFFF "low 2 bytes")) ifFalse:
"Not readable -- try again with reversed bytes..."
[self reverseBytesFrom: segmentWordArray + BaseHeaderSize to: endSeg + BytesPerWord.
data := self longAt: segmentWordArray + BaseHeaderSize.
(coInterpreter readableFormat: (data bitAnd: 16rFFFF "low 2 bytes")) ifFalse:
"Still NG -- put things back and fail"
[self reverseBytesFrom: segmentWordArray + BaseHeaderSize to: endSeg + BytesPerWord.
DoAssertionChecks ifTrue: [self verifyCleanHeaders].
^PrimErrBadArgument]].
"Reverse the Byte type objects if the data is from opposite endian machine.
Revese the words in Floats if from an earlier version with different Float order.
Test top byte. $d on the Mac or $s on the PC. Rest of word is equal."
(data >> 16) = (self imageSegmentVersion >> 16)
ifTrue:
"Need to swap floats if the segment is being loaded into a little-endian VM from a version
that keeps Floats in big-endian word order as was the case prior to the 6505 image format."
[(self isPlatformFloatOrderVersion: (data bitAnd: 16rFFFF "low 2 bytes")) ifFalse:
[self vmEndianness ~= 1 "~= 1 => little-endian" ifTrue:
[segOop := self oopFromChunk: segmentWordArray + BaseHeaderSize + BytesPerWord.
self wordSwapFloatsFrom: segOop to: endSeg + BytesPerWord]]]
ifFalse: "Reverse the byte-type objects once"
[segOop := self oopFromChunk: segmentWordArray + BaseHeaderSize + BytesPerWord.
"Oop of first embedded object"
self byteSwapByteObjectsFrom: segOop
to: endSeg + BytesPerWord
flipFloatsIf: (self isPlatformFloatOrderVersion: (data bitAnd: 16rFFFF "low 2 bytes"))].
"Proceed through the segment, remapping pointers..."
segOop := self oopFromChunk: segmentWordArray + BaseHeaderSize + BytesPerWord.
[segOop <= endSeg] whileTrue:
[(self headerType: segOop) <= 1
ifTrue: ["This object has a class field (type = 0 or 1) -- start with that."
fieldPtr := segOop - BytesPerWord. doingClass := true]
ifFalse: ["No class field -- start with first data field"
fieldPtr := segOop + BaseHeaderSize. doingClass := false].
lastPtr := segOop + (self lastPointerOf: segOop). "last field"
lastPtr > endSeg ifTrue:
[DoAssertionChecks ifTrue: [self verifyCleanHeaders].
^PrimErrBadIndex "out of bounds"].
"Go through all oops, remapping them..."
[fieldPtr > lastPtr] whileFalse:
["Examine each pointer field"
fieldOop := self longAt: fieldPtr.
doingClass ifTrue:
[hdrTypeBits := self headerType: fieldPtr.
fieldOop := fieldOop - hdrTypeBits].
(self isIntegerObject: fieldOop)
ifTrue:
["Integer -- nothing to do"
fieldPtr := fieldPtr + BytesPerWord]
ifFalse:
[(fieldOop bitAnd: 3) = 0 ifFalse:
[^PrimErrBadIndex "bad oop"].
(fieldOop bitAnd: 16r80000000) = 0
ifTrue: ["Internal pointer -- add segment offset"
mapOop := fieldOop + segmentWordArray]
ifFalse: ["External pointer -- look it up in outPointers"
outPtr := outPointerArray + (fieldOop bitAnd: 16r7FFFFFFF).
outPtr > lastOut ifTrue:
[^PrimErrBadIndex "out of bounds"].
mapOop := self longAt: outPtr].
doingClass
ifTrue: [self longAt: fieldPtr put: mapOop + hdrTypeBits.
fieldPtr := fieldPtr + 8.
doingClass := false]
ifFalse: [self longAt: fieldPtr put: mapOop.
fieldPtr := fieldPtr + BytesPerWord].
segOop < youngStart ifTrue:
[self possibleRootStoreInto: segOop value: mapOop]]].
segOop := self objectAfter: segOop].
"Again, proceed through the segment checking consistency..."
segOop := self oopFromChunk: segmentWordArray + BaseHeaderSize + BytesPerWord.
[segOop <= endSeg] whileTrue:
[(self oopHasAcceptableClass: segOop) ifFalse:
[^PrimErrInappropriate "inconsistency"].
fieldPtr := segOop + BaseHeaderSize. "first field"
lastPtr := segOop + (self lastPointerOf: segOop). "last field"
"Go through all oops, remapping them..."
[fieldPtr > lastPtr] whileFalse:
["Examine each pointer field"
fieldOop := self longAt: fieldPtr.
(self oopHasAcceptableClass: fieldOop) ifFalse:
[^PrimErrInappropriate "inconsistency"].
fieldPtr := fieldPtr + BytesPerWord].
segOop := self objectAfter: segOop].
"Truncate the segment word array to size = BytesPerWord (vers stamp only)"
extraSize := self extraHeaderBytes: segmentWordArray.
hdrTypeBits := self headerType: segmentWordArray.
extraSize = 8
ifTrue: [self longAt: segmentWordArray-extraSize put: BaseHeaderSize + BytesPerWord + hdrTypeBits]
ifFalse: [header := self longAt: segmentWordArray.
self longAt: segmentWordArray
put: header - (header bitAnd: SizeMask) + BaseHeaderSize + BytesPerWord].
"and return the roots array which was first in the segment"
DoAssertionChecks ifTrue: [self verifyCleanHeaders].
^self oopFromChunk: segmentWordArray + BaseHeaderSize + BytesPerWord!
Item was changed:
----- Method: ObjectMemory>>loadImageSegmentFrom:outPointers: (in category 'image segment in/out') -----
loadImageSegmentFrom: segmentWordArray outPointers: outPointerArray
"This primitive is called from Squeak as...
<imageSegment> loadSegmentFrom: aWordArray outPointers: anArray."
+ "This primitive will load a binary image segment created by primitiveStoreImageSegment. It expects the outPointer array to be of the proper size, and the wordArray to be well formed. It will return as its value the original array of roots, and the erstwhile segmentWordArray will have been truncated to a size of one word, i.e. retaining the version stamp. If this primitive should fail, the segmentWordArray will, sadly, have been reduced to an unrecognizable and unusable jumble. But what more could you have done with it anyway?"
- "This primitive will load a binary image segment created by primitiveStoreImageSegment. It expects the outPointer array to be of the proper size, and the wordArray to be well formed. It will return as its value the original array of roots, and the erstwhile segmentWordArray will have been truncated to a size of zero. If this primitive should fail, the segmentWordArray will, sadly, have been reduced to an unrecognizable and unusable jumble. But what more could you have done with it anyway?"
| endSeg segOop fieldPtr fieldOop doingClass lastPtr extraSize mapOop lastOut outPtr hdrTypeBits header data |
<inline: false>
<var: #endSeg type: #usqInt>
<var: #segOop type: #usqInt>
<var: #fieldPtr type: #usqInt>
<var: #lastOut type: #usqInt>
<var: #outPtr type: #usqInt>
<var: #lastPtr type: #usqInt>
DoAssertionChecks ifTrue: [self verifyCleanHeaders].
lastOut := outPointerArray + (self lastPointerOf: outPointerArray).
endSeg := segmentWordArray + (self sizeBitsOf: segmentWordArray) - BaseHeaderSize.
"Version check. Byte order of the WordArray now"
data := self longAt: segmentWordArray + BaseHeaderSize.
(self readableFormat: (data bitAnd: 16rFFFF "low 2 bytes")) ifFalse:
"Not readable -- try again with reversed bytes..."
[self reverseBytesFrom: segmentWordArray + BaseHeaderSize to: endSeg + BytesPerWord.
data := self longAt: segmentWordArray + BaseHeaderSize.
(self readableFormat: (data bitAnd: 16rFFFF "low 2 bytes")) ifFalse:
"Still NG -- put things back and fail"
[self reverseBytesFrom: segmentWordArray + BaseHeaderSize to: endSeg + BytesPerWord.
DoAssertionChecks ifTrue: [self verifyCleanHeaders].
^PrimErrBadArgument]].
"Reverse the Byte type objects if the data is from opposite endian machine.
Test top byte. $d on the Mac or $s on the PC. Rest of word is equal."
(data >> 16) = (self imageSegmentVersion >> 16)
ifFalse: "Reverse the byte-type objects once"
[segOop := self oopFromChunk: segmentWordArray + BaseHeaderSize + BytesPerWord.
"Oop of first embedded object"
self byteSwapByteObjectsFrom: segOop
to: endSeg + BytesPerWord
flipFloatsIf: false].
"Proceed through the segment, remapping pointers..."
segOop := self oopFromChunk: segmentWordArray + BaseHeaderSize + BytesPerWord.
[segOop <= endSeg] whileTrue:
[(self headerType: segOop) <= 1
ifTrue: ["This object has a class field (type = 0 or 1) -- start with that."
fieldPtr := segOop - BytesPerWord. doingClass := true]
ifFalse: ["No class field -- start with first data field"
fieldPtr := segOop + BaseHeaderSize. doingClass := false].
lastPtr := segOop + (self lastPointerOf: segOop). "last field"
lastPtr > endSeg ifTrue:
[DoAssertionChecks ifTrue: [self verifyCleanHeaders].
^PrimErrBadIndex "out of bounds"].
"Go through all oops, remapping them..."
[fieldPtr > lastPtr] whileFalse:
["Examine each pointer field"
fieldOop := self longAt: fieldPtr.
doingClass ifTrue:
[hdrTypeBits := self headerType: fieldPtr.
fieldOop := fieldOop - hdrTypeBits].
(self isIntegerObject: fieldOop)
ifTrue:
["Integer -- nothing to do"
fieldPtr := fieldPtr + BytesPerWord]
ifFalse:
[(fieldOop bitAnd: 3) = 0 ifFalse:
[^PrimErrBadIndex "bad oop"].
(fieldOop bitAnd: 16r80000000) = 0
ifTrue: ["Internal pointer -- add segment offset"
mapOop := fieldOop + segmentWordArray]
ifFalse: ["External pointer -- look it up in outPointers"
outPtr := outPointerArray + (fieldOop bitAnd: 16r7FFFFFFF).
outPtr > lastOut ifTrue:
[^PrimErrBadIndex "out of bounds"].
mapOop := self longAt: outPtr].
doingClass
ifTrue: [self longAt: fieldPtr put: mapOop + hdrTypeBits.
fieldPtr := fieldPtr + 8.
doingClass := false]
ifFalse: [self longAt: fieldPtr put: mapOop.
fieldPtr := fieldPtr + BytesPerWord].
segOop < youngStart ifTrue:
[self possibleRootStoreInto: segOop value: mapOop]]].
segOop := self objectAfter: segOop].
"Again, proceed through the segment checking consistency..."
segOop := self oopFromChunk: segmentWordArray + BaseHeaderSize + BytesPerWord.
[segOop <= endSeg] whileTrue:
[(self oopHasAcceptableClass: segOop) ifFalse:
[^PrimErrInappropriate "inconsistency"].
fieldPtr := segOop + BaseHeaderSize. "first field"
lastPtr := segOop + (self lastPointerOf: segOop). "last field"
"Go through all oops, remapping them..."
[fieldPtr > lastPtr] whileFalse:
["Examine each pointer field"
fieldOop := self longAt: fieldPtr.
(self oopHasAcceptableClass: fieldOop) ifFalse:
[^PrimErrInappropriate "inconsistency"].
fieldPtr := fieldPtr + BytesPerWord].
segOop := self objectAfter: segOop].
"Truncate the segment word array to size = BytesPerWord (vers stamp only)"
extraSize := self extraHeaderBytes: segmentWordArray.
hdrTypeBits := self headerType: segmentWordArray.
extraSize = 8
ifTrue: [self longAt: segmentWordArray-extraSize put: BaseHeaderSize + BytesPerWord + hdrTypeBits]
ifFalse: [header := self longAt: segmentWordArray.
self longAt: segmentWordArray
put: header - (header bitAnd: SizeMask) + BaseHeaderSize + BytesPerWord].
"and return the roots array which was first in the segment"
DoAssertionChecks ifTrue: [self verifyCleanHeaders].
^self oopFromChunk: segmentWordArray + BaseHeaderSize + BytesPerWord!
Item was changed:
----- Method: ObjectMemory>>storeShort16:ofObject:withValue: (in category 'object access') -----
+ storeShort16: shortIndex ofObject: objOop withValue: value
+ ^self
+ shortAt: objOop + BaseHeaderSize + (shortIndex << 1)
+ put: (self cCode: [value] inSmalltalk: [value bitAnd: 16rFFFF])!
- storeShort16: shortIndex ofObject: oop withValue: value
- ^self shortAt: oop + BaseHeaderSize + (shortIndex << 1) put: value!
Item was removed:
- ----- Method: Spur32BitCoMemoryManager>>copyObj:toSegment:addr:stopAt:saveOopAt: (in category 'image segment in/out') -----
- copyObj: objOop toSegment: segmentWordArray addr: limitSeg stopAt: stopAddr saveOopAt: oopPtr
- "Copy objOop into the segment beginning at limitSeg, and forward it to the copy.
- Fail if out of space. Answer the next segmentAddr if successful."
-
- "Copy the object..."
- | bodySize copy |
- <inline: false>
- bodySize := self bytesInObject: objOop.
- (self oop: limitSeg + bodySize isGreaterThanOrEqualTo: stopAddr) ifTrue:
- [^0]. "failure"
- self mem: limitSeg asVoidPointer cp: (self startOfObject: objOop) asVoidPointer y: bodySize.
- copy := self objectStartingAt: limitSeg.
-
- "Clear remebered pinned and mark bits of all headers copied into the segment"
- self
- setIsRememberedOf: copy to: false;
- setIsPinnedOf: copy to: false;
- setIsMarkedOf: copy to: false.
-
- "Make sure Cogged methods have their true header field written to the segment."
- ((self isCompiledMethod: objOop)
- and: [coInterpreter methodHasCogMethod: objOop]) ifTrue:
- [self storePointerUnchecked: HeaderIndex
- ofObject: copy
- withValue: (self methodHeaderOf: objOop)].
-
- "Remember the oop for undoing in case of prim failure."
- self longAt: oopPtr put: objOop.
- self forward: objOop to: copy.
-
- "Return new end of segment"
- ^limitSeg + bodySize!
Item was added:
+ ----- Method: Spur32BitCoMemoryManager>>ifAProxy:updateCopy: (in category 'image segment in/out') -----
+ ifAProxy: objOop updateCopy: copy
+ "If the obejct being copied to the segment is weird and has exotic state,
+ i.e. a married context or a jitted method, update the copy with the vanilla state."
+
+ super ifAProxy: objOop updateCopy: copy.
+ (self isCompiledMethod: objOop) ifTrue:
+ [| methodHeader |
+ methodHeader := coInterpreter rawHeaderOf: objOop.
+ (coInterpreter isCogMethodReference: methodHeader) ifTrue:
+ [self storePointerUnchecked: HeaderIndex
+ ofObject: copy
+ withValue: (coInterpreter cCoerceSimple: methodHeader to: #'CogMethod *') methodHeader]]!
Item was changed:
----- Method: Spur32BitMMLESimulator>>setIsMarkedOf:to: (in category 'header access') -----
setIsMarkedOf: objOop to: aBoolean
"objOop = 16rB26020 ifTrue: [self halt]."
+ "(#(16r1971D0 16r196EE0 16r197048 16r197148) includes: objOop) ifTrue:
+ [self halt]."
super setIsMarkedOf: objOop to: aBoolean.
"(aBoolean
and: [(self isContextNonImm: objOop)
and: [(coInterpreter
checkIsStillMarriedContext: objOop
currentFP: coInterpreter framePointer)
and: [(coInterpreter stackPages stackPageFor: (coInterpreter frameOfMarriedContext: objOop)) trace = 0]]]) ifTrue:
[self halt]"!
Item was changed:
----- Method: SpurMemoryManager>>accessibleObjectAfter: (in category 'object enumeration') -----
accessibleObjectAfter: objOop
"Answer the accessible object following the given object or
free chunk in the heap. Return nil when heap is exhausted.
+ This is for primitiveNextObject subsequent to primtiiveSomeObject.
+ It also tries to handle more general use by ordering objects as
+ eden
+ past
+ old
+ but this is tricky becaus ethe order in memory is
+ past
+ eden
+ old"
- This is for primitiveNextObject subsequent to primtiiveSomeObject."
<inline: false>
| objAfter |
objAfter := objOop.
+ (self oop: objAfter isLessThan: nilObj) ifTrue: "object in new space"
+ [self assert: ((self isInEden: objOop) or: [self isInPastSpace: objOop]).
+ (self oop: objAfter isGreaterThan: pastSpaceStart) ifTrue:
+ ["Obj is in eden. Answer next normal object in eden, if there is one."
+ [objAfter := self objectAfter: objAfter limit: freeStart.
+ self oop: objAfter isLessThan: freeStart] whileTrue:
+ [(self isNormalObject: objAfter) ifTrue:
+ [^objAfter]].
+ "There wasn't a next object in eden. If past space is empty answer nilObj."
+ pastSpaceStart <= scavenger pastSpace start ifTrue:
+ [^nilObj].
+ "If the first object in pastSpace is OK, answer it, otherwise fall through to enumerate past space."
+ objAfter := self objectStartingAt: scavenger pastSpace start.
+ (self isNormalObject: objAfter) ifTrue:
+ [^objAfter]].
+ "Either objOop was in pastSpace, or enumeration exhaused eden, so enumerate past space."
+ [objAfter := self objectAfter: objAfter limit: pastSpaceStart.
+ self oop: objAfter isLessThan: pastSpaceStart] whileTrue:
+ [(self isNormalObject: objAfter) ifTrue:
+ [^objAfter]].
+ ^nilObj].
[objAfter := self objectAfter: objAfter limit: endOfMemory.
objAfter = endOfMemory ifTrue:
[^nil].
(self isNormalObject: objAfter) ifTrue:
[^objAfter]] repeat!
Item was changed:
----- Method: SpurMemoryManager>>addressCouldBeObj: (in category 'debug support') -----
addressCouldBeObj: address
<api>
<inline: false>
^(address bitAnd: self baseHeaderSize - 1) = 0
and: [(self isInOldSpace: address)
or: [(self isInEden: address)
+ or: [(self isInPastSpace: address)
- or: [(self isInSurvivorSpace: address)
or: [scavengeInProgress and: [self isInFutureSpace: address]]]]]!
Item was changed:
----- Method: SpurMemoryManager>>copyObj:toAddr:startAt:stopAt: (in category 'image segment in/out') -----
copyObj: objOop toAddr: segAddr startAt: segStart stopAt: endSeg
"Copy objOop into the segment beginning at segAddr, and forward it to the copy.
If it is a class in the class table, set the copy's hash to 0 for reassignment on load,
and mark it as a class by setting its isRemembered bit.
Answer the next segmentAddr if successful. Answer an appropriate error code if not"
"Copy the object..."
| bodySize copy hash newOop |
<inline: false>
bodySize := self bytesInObject: objOop.
(self oop: segAddr + bodySize isGreaterThanOrEqualTo: endSeg) ifTrue:
[^PrimErrWritePastObject].
self mem: segAddr asVoidPointer cp: (self startOfObject: objOop) asVoidPointer y: bodySize.
copy := self objectStartingAt: segAddr.
"Clear remembered, mark bits of all headers copied into the segment (except classes)"
self
setIsRememberedOf: copy to: false;
setIsMarkedOf: copy to: false.
+
+ self ifAProxy: objOop updateCopy: copy.
+
"If the object is a class, zero its identityHash (which is its classIndex) and set its
isRemembered bit. It will be assigned a new hash and entered into the table on load."
hash := self rawHashBitsOf: objOop.
(hash > self lastClassIndexPun and: [(self classOrNilAtIndex: hash) = objOop]) ifTrue:
[self setHashBitsOf: copy to: 0.
self setIsRememberedOf: copy to: true].
newOop := copy - segStart / self allocationUnit.
newOop > self maxIdentityHash ifTrue:
[^PrimErrLimitExceeded].
self setHashBitsOf: objOop to: copy - segStart / self allocationUnit.
self setIsMarkedOf: objOop to: true.
"Answer the new end of segment"
^segAddr + bodySize!
Item was added:
+ ----- Method: SpurMemoryManager>>ifAProxy:updateCopy: (in category 'image segment in/out') -----
+ ifAProxy: objOop updateCopy: copy
+ "If the obejct being copied to the segment is weird and has exotic state,
+ i.e. a married context or a jitted method, update the copy with the vanilla state."
+
+ ((self isContext: objOop)
+ and: [coInterpreter isMarriedOrWidowedContext: objOop]) ifTrue:
+ [| numMediatedSlots |
+ "Since the context is here via objectsReachableFromRoots: we know it cannot be divorced.
+ I'd like to assert coInterpreter checkIsStillMarriedContext: objOop currentFP: framePointer,
+ here but that requires access to framePointer."
+ numMediatedSlots := coInterpreter numSlotsOfMarriedContext: objOop.
+ 0 to: numMediatedSlots - 1 do:
+ [:i| | oop |
+ oop := coInterpreter fetchPointer: i ofMarriedContext: objOop.
+ self storePointerUnchecked: i ofObject: copy withValue: oop].
+ "And make sure to nil the slots beyond the top of stack..."
+ numMediatedSlots to: (self numSlotsOf: objOop) - 1 do:
+ [:i|
+ self storePointerUnchecked: i ofObject: copy withValue: nilObj]]!
Item was changed:
----- Method: SpurMemoryManager>>instanceAfter: (in category 'object enumeration') -----
instanceAfter: objOop
| actualObj classIndex |
actualObj := objOop.
classIndex := self classIndexOf: objOop.
(self isInEden: objOop) ifTrue:
[[actualObj := self objectAfter: actualObj limit: freeStart.
self oop: actualObj isLessThan: freeStart] whileTrue:
[classIndex = (self classIndexOf: actualObj) ifTrue:
[^actualObj]].
actualObj := (self oop: pastSpaceStart isGreaterThan: scavenger pastSpace start)
ifTrue: [self objectStartingAt: scavenger pastSpace start]
ifFalse: [nilObj]].
+ (self isInPastSpace: actualObj) ifTrue:
- (self isInSurvivorSpace: actualObj) ifTrue:
[[actualObj := self objectAfter: actualObj limit: pastSpaceStart.
self oop: actualObj isLessThan: pastSpaceStart] whileTrue:
[classIndex = (self classIndexOf: actualObj) ifTrue:
[^actualObj]].
actualObj := nilObj].
[actualObj := self objectAfter: actualObj limit: endOfMemory.
self oop:actualObj isLessThan: endOfMemory] whileTrue:
[classIndex = (self classIndexOf: actualObj) ifTrue:
[^actualObj]].
^nil!
Item was changed:
----- Method: SpurMemoryManager>>isInMemory: (in category 'plugin support') -----
isInMemory: address
"Answer if the given address is in ST object memory."
+ (self isInNewSpace: address) ifTrue:
+ [^(self isInEden: address)
+ or: [(self isInPastSpace: address)
+ or: [scavengeInProgress and: [self isInFutureSpace: address]]]].
+ ^segmentManager isInSegments: address!
- ^(self isInNewSpace: address)
- or: [segmentManager isInSegments: address]!
Item was removed:
- ----- Method: SpurMemoryManager>>isInSurvivorSpace: (in category 'object testing') -----
- isInSurvivorSpace: address
- ^self
- oop: address
- isGreaterThanOrEqualTo: scavenger pastSpace start
- andLessThan: pastSpaceStart!
Item was changed:
----- Method: SpurMemoryManager>>lastPointerOf: (in category 'object enumeration') -----
lastPointerOf: objOop
"Answer the byte offset of the last pointer field of the given object.
Works with CompiledMethods, as well as ordinary objects."
<api>
<inline: true>
<asmLabel: false>
| fmt contextSize header |
fmt := self formatOf: objOop.
self assert: fmt ~= self forwardedFormat.
fmt <= self lastPointerFormat ifTrue:
[(fmt = self indexablePointersFormat
and: [self isContextNonImm: objOop]) ifTrue:
["contexts end at the stack pointer"
contextSize := coInterpreter fetchStackPointerOf: objOop.
+ ^CtxtTempFrameStart - 1 + contextSize * BytesPerOop + self baseHeaderSize].
- ^CtxtTempFrameStart + contextSize * BytesPerOop].
^(self numSlotsOf: objOop) - 1 * BytesPerOop + self baseHeaderSize "all pointers"].
fmt < self firstCompiledMethodFormat ifTrue: [^0]. "no pointers"
"CompiledMethod: contains both pointers and bytes"
header := self methodHeaderOf: objOop.
^self lastPointerOfMethodHeader: header!
Item was changed:
----- Method: SpurMemoryManager>>loadImageSegmentFrom:outPointers: (in category 'image segment in/out') -----
loadImageSegmentFrom: segmentWordArray outPointers: outPointerArray
"This primitive is called from Squeak as...
<imageSegment> loadSegmentFrom: aWordArray outPointers: anArray."
"This primitive will load a binary image segment created by primitiveStoreImageSegment.
It expects the outPointer array to be of the proper size, and the wordArray to be well formed.
It will return as its value the original array of roots, and the erstwhile segmentWordArray will
+ have been truncated to a size of one word, i.e. retaining the version stamp. If this primitive
+ should fail, the segmentWordArray will, sadly, have been reduced to an unrecognizable and
+ unusable jumble. But what more could you have done with it anyway?"
- have been truncated to a size of zero. If this primitive should fail, the segmentWordArray will,
- sadly, have been reduced to an unrecognizable and unusable jumble. But what more could you
- have done with it anyway?"
<inline: false>
| segmentLimit segmentStart segVersion errorCode |
+
+ segmentLimit := self numSlotsOf: segmentWordArray.
+ (self objectBytesForSlots: segmentLimit) < (self allocationUnit "version info" + self baseHeaderSize "one object header") ifTrue:
+ [^PrimErrBadArgument].
+
"First thing is to verify format. If Spur is ever ported to big-endian machines then the segment
may have to be byte/word swapped, but so far it only runs on little-endian machines, so for now
just fail if endinanness is wrong."
-
segVersion := self longAt: segmentWordArray + self baseHeaderSize.
(coInterpreter readableFormat: (segVersion bitAnd: 16rFFFF "low 2 bytes")) ifFalse:
[self reverseBytesFrom: segmentWordArray + self baseHeaderSize
to: (self addressAfter: segmentWordArray).
segVersion := self longAt: segmentWordArray + self baseHeaderSize.
(coInterpreter readableFormat: (segVersion bitAnd: 16rFFFF "low 2 bytes")) ifFalse:
[self reverseBytesFrom: segmentWordArray + self baseHeaderSize
to: (self addressAfter: segmentWordArray).
^PrimErrBadArgument]].
segmentStart := segmentWordArray + self baseHeaderSize + self allocationUnit.
+ segmentLimit := segmentLimit * self bytesPerOop + segmentWordArray + self baseHeaderSize.
- segmentLimit := (self numSlotsOf: segmentWordArray) * self bytesPerOop + segmentWordArray + self baseHeaderSize.
"Notionally reverse the Byte type objects if the data is from opposite endian machine.
Test top byte. $d on the Mac or $s on the PC. Rest of word is equal. If Spur is ever
ported to big-endian machines then the segment may have to be byte/word swapped,
but so far it only runs on little-endian machines, so for now just fail if endinanness is wrong."
self flag: #endianness.
(segVersion >> 16) ~= (self imageSegmentVersion >> 16) ifTrue:
"Reverse the byte-type objects once"
[true
ifTrue: [^PrimErrBadArgument]
ifFalse:
[self byteSwapByteObjectsFrom: (self objectStartingAt: segmentStart)
to: segmentLimit
flipFloatsIf: false]].
"scan through mapping oops and validating class references. Defer entering any
class objects into the class table and/or pinning objects until a second pass."
errorCode := self mapOopsAndValidateClassRefsFrom: segmentStart to: segmentLimit outPointers: outPointerArray.
errorCode ~= 0 ifTrue:
[^errorCode].
"Scan for classes contained in the segment, entering them into the class table.
Classes are at the front, after the root array and have the remembered bit set."
errorCode := self enterClassesIntoClassTableFrom: segmentStart to: segmentLimit.
errorCode ~= 0 ifTrue:
[^errorCode].
"Make a final pass, assigning class indices and/or pinning pinned objects"
self assignClassIndicesAndPinFrom: segmentStart to: segmentLimit outPointers: outPointerArray.
"Finally evaporate the container, leaving the newly loaded objects in place."
(self hasOverflowHeader: segmentWordArray)
+ ifTrue: [self setOverflowNumSlotsOf: segmentWordArray to: self allocationUnit / self bytesPerSlot]
+ ifFalse: [self setRawNumSlotsOf: segmentWordArray to: self allocationUnit / self bytesPerSlot].
- ifTrue: [self setOverflowNumSlotsOf: segmentWordArray to: 0]
- ifFalse: [self setRawNumSlotsOf: segmentWordArray to: 0].
self leakCheckImageSegments ifTrue:
[self runLeakCheckerForFullGC: true].
^self objectStartingAt: segmentStart!
Item was changed:
----- Method: SpurMemoryManager>>objectAfter: (in category 'object enumeration') -----
objectAfter: objOop
<api>
"Object parsing.
1. all objects have at least a word following the header, for a forwarding pointer.
2. objects with an overflow size have a preceeing word with a saturated slotSize. If the word following
an object doesn't have a saturated size field it must be a single-header object. If the word following
does have a saturated slotSize it must be the overflow size word."
<inline: false>
(self oop: objOop isLessThan: newSpaceLimit) ifTrue:
[(self isInEden: objOop) ifTrue:
[^self objectAfter: objOop limit: freeStart].
+ (self isInPastSpace: objOop) ifTrue:
- (self isInSurvivorSpace: objOop) ifTrue:
[^self objectAfter: objOop limit: pastSpaceStart].
^self objectAfter: objOop limit: scavenger futureSurvivorStart].
^self objectAfter: objOop limit: endOfMemory!
Item was changed:
----- Method: SpurMemoryManager>>objectsReachableFromRoots: (in category 'image segment in/out') -----
objectsReachableFromRoots: arrayOfRoots
"Answer an Array of all the objects only reachable from the argument, an Array of root objects,
starting with arrayOfRoots. If there is no space, answer a SmallInteger whose value is the
number of slots required. This is used to collect the objects to include in an image segment
on Spur, separate from creating the segment, hence simplifying the implementation.
Thanks to Igor Stasenko for this idea."
| freeChunk ptr start limit count oop objOop |
self assert: (self isArray: arrayOfRoots).
"Mark all objects except those only reachable from the arrayOfRoots by marking
each object in arrayOfRoots and then marking all reachable objects (from the
system roots). This leaves unmarked only objects reachable from the arrayOfRoots.
N.B. A side-effect of the marking is that all forwarders in arrayOfRoots will be followed."
self assert: self allObjectsUnmarked.
self markObjectsIn: arrayOfRoots.
self markObjects: false.
"After the mark phase all unreachable weak slots will have been nilled
and all active ephemerons fired."
self assert: (self isEmptyObjStack: markStack).
self assert: (self isEmptyObjStack: weaklingStack).
self assert: self noUnscannedEphemerons.
"Use the largest free chunk to answer the result."
freeChunk := self allocateLargestFreeChunk.
ptr := start := freeChunk + self baseHeaderSize.
limit := self addressAfter: freeChunk.
count := 0.
"First put the arrayOfRoots; order is important."
count := count + 1.
ptr < limit ifTrue:
[self longAt: ptr put: arrayOfRoots.
ptr := ptr + self bytesPerSlot].
0 to: (self numSlotsOf: arrayOfRoots) - 1 do:
[:i|
oop := self fetchPointer: i ofObject: arrayOfRoots.
(self isNonImmediate: oop) ifTrue:
[self push: oop onObjStack: markStack]].
"Now collect the unmarked objects reachable from the roots."
[self isEmptyObjStack: markStack] whileFalse:
[objOop := self popObjStack: markStack.
count := count + 1.
ptr < limit ifTrue:
[self longAt: ptr put: objOop.
ptr := ptr + self bytesPerSlot].
oop := self fetchClassOfNonImm: objOop.
(self isMarked: oop) ifFalse:
[self setIsMarkedOf: objOop to: true.
self push: oop onObjStack: markStack].
+ ((self isContextNonImm: objOop)
+ and: [coInterpreter isStillMarriedContext: objOop]) "widow now, before the loop"
+ ifTrue:
+ [0 to: (coInterpreter numSlotsOfMarriedContext: objOop) - 1 do:
+ [:i|
+ oop := coInterpreter fetchPointer: i ofMarriedContext: objOop.
+ ((self isImmediate: oop)
+ or: [self isMarked: oop]) ifFalse:
+ [self setIsMarkedOf: objOop to: true.
+ self push: oop onObjStack: markStack]]]
+ ifFalse:
+ [0 to: (self numPointerSlotsOf: objOop) - 1 do:
+ [:i|
+ oop := self fetchPointer: i ofObject: objOop.
+ ((self isImmediate: oop)
+ or: [self isMarked: oop]) ifFalse:
+ [self setIsMarkedOf: objOop to: true.
+ self push: oop onObjStack: markStack]]]].
- 0 to: (self numPointerSlotsOf: objOop) - 1 do:
- [:i|
- oop := self fetchPointer: i ofObject: objOop.
- ((self isImmediate: oop)
- or: [self isMarked: oop]) ifFalse:
- [self setIsMarkedOf: objOop to: true.
- self push: oop onObjStack: markStack]]].
self unmarkAllObjects.
totalFreeOldSpace := totalFreeOldSpace - (self bytesInObject: freeChunk).
"Now try and allocate the result"
(count > (ptr - start / self bytesPerSlot) "not enough room"
or: [limit ~= ptr and: [limit - ptr <= self allocationUnit]]) ifTrue: "can't split a single word"
[self freeChunkWithBytes: (self bytesInObject: freeChunk) at: (self startOfObject: freeChunk).
self checkFreeSpace.
^self integerObjectOf: count].
"There's room; set the format, & classIndex and shorten."
self setFormatOf: freeChunk to: self arrayFormat.
self setClassIndexOf: freeChunk to: ClassArrayCompactIndex.
self shorten: freeChunk toIndexableSize: count.
self possibleRootStoreInto: freeChunk.
self checkFreeSpace.
self runLeakCheckerForFullGC: false.
^freeChunk!
Item was changed:
----- Method: SpurMemoryManager>>storeShort16:ofObject:withValue: (in category 'object access') -----
storeShort16: shortIndex ofObject: objOop withValue: value
+ ^self
+ shortAt: objOop + self baseHeaderSize + (shortIndex << 1)
+ put: (self cCode: [value] inSmalltalk: [value bitAnd: 16rFFFF])!
- ^self shortAt: objOop + self baseHeaderSize + (shortIndex << 1) put: value!
Item was changed:
----- Method: StackInterpreter>>externalInstVar:ofContext: (in category 'frame access') -----
externalInstVar: offset ofContext: aContext
"Fetch an instance variable from a maybe married context.
If the context is still married compute the value of the
relevant inst var from the spouse frame's state."
- | spouseFP |
- <var: #spouseFP type: #'char *'>
- <var: #thePage type: #'StackPage *'>
- <var: #theFPAbove type: #'char *'>
-
self assert: (objectMemory isContext: aContext).
"method, closureOrNil & receiver need no special handling; only
sender, pc & stackp have to be computed for married contexts."
+ ((self isReadMediatedContextInstVarIndex: offset)
- (offset < MethodIndex
and: [self isMarriedOrWidowedContext: aContext]) ifFalse:
[^objectMemory fetchPointer: offset ofObject: aContext].
self externalWriteBackHeadFramePointers.
+ ^(self isStillMarriedContext: aContext)
+ ifTrue: [self fetchPointer: offset ofMarriedContext: aContext]
+ ifFalse: [objectMemory fetchPointer: offset ofObject: aContext]!
- (self isWidowedContext: aContext) ifTrue:
- [^objectMemory fetchPointer: offset ofObject: aContext].
-
- spouseFP := self frameOfMarriedContext: aContext.
- offset = SenderIndex ifTrue:
- [^self ensureCallerContext: spouseFP].
- offset = StackPointerIndex ifTrue:
- [self assert: ReceiverIndex + (self stackPointerIndexForFrame: spouseFP) < (objectMemory lengthOf: aContext).
- ^objectMemory integerObjectOf: (self stackPointerIndexForFrame: spouseFP)].
- offset = InstructionPointerIndex ifTrue:
- [| theIP thePage theFPAbove |
- spouseFP = framePointer
- ifTrue: [theIP := self oopForPointer: instructionPointer]
- ifFalse:
- [thePage := stackPages stackPageFor: spouseFP.
- theFPAbove := self findFrameAbove: spouseFP inPage: thePage.
- theIP := theFPAbove == 0
- ifTrue: [stackPages longAt: thePage headSP]
- ifFalse:[self oopForPointer: (self frameCallerSavedIP: theFPAbove)]].
- ^self contextInstructionPointer: theIP frame: spouseFP].
- self error: 'bad index'.
- ^0!
Item was added:
+ ----- Method: StackInterpreter>>fetchPointer:ofMarriedContext: (in category 'frame access') -----
+ fetchPointer: offset ofMarriedContext: aContext
+ "Fetch a slot from a married context. Compute the value
+ of the relevant inst var from the spouse frame's state.
+
+ This method assumes frame pointers have been written back."
+ | spouseFP |
+ <inline: false>
+ <var: #spouseFP type: #'char *'>
+
+ self assert: (objectMemory isContext: aContext).
+ self assert: (stackPage headFP = framePointer and: [stackPage headSP = stackPointer]).
+ self assert: (self checkIsStillMarriedContext: aContext currentFP: framePointer).
+
+ "method, closureOrNil & receiver need no special handling; only
+ sender, pc & stackp have to be computed for married contexts."
+ offset <= ReceiverIndex ifTrue:
+ [(self isReadMediatedContextInstVarIndex: offset) ifFalse:
+ [^objectMemory fetchPointer: offset ofObject: aContext].
+
+ spouseFP := self frameOfMarriedContext: aContext.
+ offset = SenderIndex ifTrue:
+ [^self ensureCallerContext: spouseFP].
+ offset = StackPointerIndex ifTrue:
+ [^objectMemory integerObjectOf: (self stackPointerIndexForFrame: spouseFP)].
+ offset = InstructionPointerIndex ifTrue:
+ [^self instructionPointerForFrame: spouseFP currentFP: framePointer currentIP: instructionPointer]].
+
+ spouseFP := self frameOfMarriedContext: aContext.
+ ^(offset - ReceiverIndex between: 1 and: (self stackPointerIndexForFrame: spouseFP))
+ ifTrue: [self temporary: offset - (ReceiverIndex + 1) in: spouseFP]
+ ifFalse: [objectMemory nilObject]!
Item was changed:
----- Method: StackInterpreter>>instVar:ofContext: (in category 'frame access') -----
instVar: offset ofContext: aContext
"Fetch an instance variable from a maybe married context.
If the context is still married compute the value of the
relevant inst var from the spouse frame's state."
| spouseFP |
<var: #spouseFP type: #'char *'>
- <var: #thePage type: #'StackPage *'>
- <var: #theFPAbove type: #'char *'>
<inline: true>
self assert: offset < MethodIndex.
self assert: (objectMemory isContext: aContext).
(self isMarriedOrWidowedContext: aContext) ifFalse:
[^objectMemory fetchPointer: offset ofObject: aContext].
self writeBackHeadFramePointers.
(self isWidowedContext: aContext) ifTrue:
[^objectMemory fetchPointer: offset ofObject: aContext].
spouseFP := self frameOfMarriedContext: aContext.
offset = SenderIndex ifTrue:
[^self ensureCallerContext: spouseFP].
offset = StackPointerIndex ifTrue:
[self assert: ReceiverIndex + (self stackPointerIndexForFrame: spouseFP) < (objectMemory lengthOf: aContext).
^objectMemory integerObjectOf: (self stackPointerIndexForFrame: spouseFP)].
offset = InstructionPointerIndex ifTrue:
+ [^self instructionPointerForFrame: spouseFP currentFP: localFP currentIP: localIP].
- [| theIP thePage theFPAbove |
- spouseFP = localFP
- ifTrue: [theIP := self oopForPointer: localIP]
- ifFalse:
- [thePage := stackPages stackPageFor: spouseFP.
- theFPAbove := self findFrameAbove: spouseFP inPage: thePage.
- theIP := theFPAbove == 0
- ifTrue: [stackPages longAt: thePage headSP]
- ifFalse:[self oopForPointer: (self frameCallerSavedIP: theFPAbove)]].
- ^self contextInstructionPointer: theIP frame: spouseFP].
self error: 'bad index'.
^0!
Item was changed:
----- Method: StackInterpreter>>instVar:ofContext:put: (in category 'frame access') -----
instVar: index ofContext: aMarriedContext put: anOop
| theFP |
"Assign the field of a married context. The important case to optimize is
+ assigning the sender. We could also consider optimizing assigning the IP but
- assigning the sender. We could also consider optimizing assiging the IP but
typically that is followed by an assignment to the stack pointer and we can't
efficiently assign the stack pointer because it involves moving frames around."
<inline: true>
self assert: (self isMarriedOrWidowedContext: aMarriedContext).
self writeBackHeadFramePointers.
(self isStillMarriedContext: aMarriedContext) ifFalse:
[objectMemory storePointer: index ofObject: aMarriedContext withValue: anOop.
index = StackPointerIndex ifTrue:
[self ensureContextIsExecutionSafeAfterAssignToStackPointer: aMarriedContext].
^nil].
theFP := self frameOfMarriedContext: aMarriedContext.
index == SenderIndex ifTrue:
[| thePage onCurrentPage |
thePage := stackPages stackPageFor: theFP.
self assert: stackPage = stackPages mostRecentlyUsedPage.
onCurrentPage := thePage = stackPage.
self storeSenderOfFrame: theFP withValue: anOop.
onCurrentPage
ifTrue:
[localFP := stackPage headFP.
localSP := stackPage headSP]
ifFalse:
[stackPages markStackPageMostRecentlyUsed: stackPage].
^nil].
self externalizeIPandSP.
self externalDivorceFrame: theFP andContext: aMarriedContext.
objectMemory storePointer: index ofObject: aMarriedContext withValue: anOop.
index = StackPointerIndex ifTrue:
[self ensureContextIsExecutionSafeAfterAssignToStackPointer: aMarriedContext].
self internalizeIPandSP.
"Assigning various fields can force a divorce which can change the stackPage."
stackPages markStackPageMostRecentlyUsed: stackPage.
self assertValidExecutionPointe: localIP asUnsignedInteger r: localFP s: localSP imbar: true line: #'__LINE__'!
Item was added:
+ ----- Method: StackInterpreter>>instructionPointerForFrame:currentFP:currentIP: (in category 'frame access') -----
+ instructionPointerForFrame: spouseFP currentFP: currentFP currentIP: instrPtr
+ "Answer the bytecode pc object (i.e. SmallInteger) for an active frame. The bytecode
+ pc is derived from the frame's pc. If the frame is the top frame on the current stack
+ the frame pc is whatever the current instruction pointer is. If the frame is the top
+ frame on some other stack the frame pc is the value on top of stack. Otherwise the
+ frame pc is the saved pc of the frame above. Once the frame pc is found it must be
+ mapped to a bytecode pc."
+ | theIP thePage theFPAbove |
+ spouseFP = currentFP
+ ifTrue: [theIP := self oopForPointer: instrPtr]
+ ifFalse:
+ [thePage := stackPages stackPageFor: spouseFP.
+ theFPAbove := self findFrameAbove: spouseFP inPage: thePage.
+ theIP := theFPAbove == 0
+ ifTrue: [stackPages longAt: thePage headSP]
+ ifFalse:[self oopForPointer: (self frameCallerSavedIP: theFPAbove)]].
+ ^self contextInstructionPointer: theIP frame: spouseFP!
Item was changed:
----- Method: StackInterpreter>>longPrintOop: (in category 'debug printing') -----
longPrintOop: oop
<api>
| fmt lastIndex startIP bytecodesPerLine column |
((objectMemory isImmediate: oop)
or: [(objectMemory addressCouldBeObj: oop) not
or: [(oop bitAnd: objectMemory allocationUnit - 1) ~= 0
or: [(objectMemory isFreeObject: oop)
or: [objectMemory isForwarded: oop]]]]) ifTrue:
[self printOop: oop.
^self].
self printHex: oop.
(objectMemory fetchClassOfNonImm: oop)
ifNil: [self print: ' has a nil class!!!!']
ifNotNil: [:class|
self print: ': a(n) '; printNameOfClass: class count: 5;
print: ' ('.
objectMemory hasSpurMemoryManagerAPI ifTrue:
[self printHexnp: (objectMemory compactClassIndexOf: oop); print: '=>'].
self printHexnp: class; print: ')'].
fmt := objectMemory formatOf: oop.
self print: ' format '; printHexnp: fmt.
fmt > objectMemory lastPointerFormat
ifTrue: [self print: ' nbytes '; printNum: (objectMemory numBytesOf: oop)]
ifFalse: [(objectMemory isIndexableFormat: fmt) ifTrue:
[| len |
len := objectMemory lengthOf: oop.
self print: ' size '; printNum: len - (objectMemory fixedFieldsOf: oop format: fmt length: len)]].
objectMemory printHeaderTypeOf: oop.
self print: ' hash '; printHexnp: (objectMemory rawHashBitsOf: oop).
self cr.
(fmt between: objectMemory firstByteFormat and: objectMemory firstCompiledMethodFormat - 1) ifTrue:
[^self printStringOf: oop; cr].
(fmt between: objectMemory firstLongFormat and: objectMemory firstByteFormat - 1) ifTrue:
[0 to: ((objectMemory num32BitUnitsOf: oop) min: 256) - 1 do:
[:i| | fieldOop |
fieldOop := objectMemory fetchLong32: i ofObject: oop.
+ self space; printNum: i; space; printHex: fieldOop; space; cr].
- self space; printNum: i - 1; space; printHex: fieldOop; space; cr].
^self].
"this is nonsense. apologies."
startIP := (objectMemory lastPointerOf: oop) + BytesPerOop - objectMemory baseHeaderSize / BytesPerOop.
lastIndex := 256 min: startIP.
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 cCode: [self printOopShort: fieldOop]
inSmalltalk: [self print: (self shortPrint: 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 added:
+ ----- Method: StackInterpreter>>numSlotsOfMarriedContext: (in category 'internal interpreter access') -----
+ numSlotsOfMarriedContext: aContext
+ "Answer the number of effective pointer fields in the given context."
+ <inline: true>
+ | contextSize |
+ contextSize := self stackPointerIndexForFrame: (self frameOfMarriedContext: aContext).
+ ^CtxtTempFrameStart + contextSize!
Item was changed:
----- Method: StackInterpreterSimulator>>utilitiesMenu: (in category 'UI') -----
utilitiesMenu: aMenuMorph
aMenuMorph
add: 'toggle transcript' action: #toggleTranscript;
add: 'clone VM' action: #cloneSimulationWindow;
addLine;
add: 'print ext head frame' action: #printExternalHeadFrame;
add: 'print int head frame' action: #printHeadFrame;
add: 'short print ext frame & callers' action: [self shortPrintFrameAndCallers: framePointer];
add: 'short print int frame & callers' action: [self shortPrintFrameAndCallers: localFP];
add: 'long print ext frame & callers' action: [self printFrameAndCallers: framePointer SP: stackPointer];
add: 'long print int frame & callers' action: [self printFrameAndCallers: localFP SP: localSP];
add: 'print frame...' action: [(self promptHex: 'print frame') ifNotNil: [:fp| self printFrame: fp]];
add: 'print call stack' action: #printCallStack;
add: 'print stack call stack' action: #printStackCallStack;
+ add: 'print stack call stack of...' action: [(self promptHex: 'frame') ifNotNil: [:fp| self printStackCallStackOf: fp]];
add: 'print call stack of...' action: [(self promptHex: 'context or process oop') ifNotNil: [:obj| self printCallStackOf: obj]];
add: 'print call stack of frame...' action: [(self promptHex: 'frame') ifNotNil: [:fp| self printCallStackFP: fp]];
add: 'print all stacks' action: #printAllStacks;
add: 'write back local ptrs' action: [stackPointer := localSP. framePointer := localFP. instructionPointer := localIP.
self writeBackHeadFramePointers];
add: 'print prim trace log' action: #dumpPrimTraceLog;
addLine;
add: 'print oop...' action: [(self promptHex: 'print oop') ifNotNil: [:oop| self printOop: oop]];
add: 'long print oop...' action: [(self promptHex: 'print oop') ifNotNil: [:oop| self longPrintOop: oop]];
addLine;
add: 'inspect object memory' target: objectMemory action: #inspect;
add: 'inspect interpreter' action: #inspect;
addLine;
add: 'set break count...' action: [|s| s := UIManager default request: 'break count (dec)'.
s notEmpty ifTrue: [breakCount := Integer readFrom: s readStream]];
add: 'set break selector...' action: [|s| s := UIManager default request: 'break selector'.
s notEmpty ifTrue: [self setBreakSelector: s]];
add: 'turn valid exec ptrs assert o', (assertVEPAES ifTrue: ['ff'] ifFalse: ['n']) action: [assertVEPAES := assertVEPAES not];
add: (printSends
ifTrue: ['no print sends']
ifFalse: ['print sends'])
action: [self ensureDebugAtEachStepBlock.
printSends := printSends not];
"currently printReturns does nothing"
"add: (printReturns
ifTrue: ['no print returns']
ifFalse: ['print returns'])
action: [self ensureDebugAtEachStepBlock.
printReturns := printReturns not];"
add: (printBytecodeAtEachStep
ifTrue: ['no print bytecode each bytecode']
ifFalse: ['print bytecode each bytecode'])
action: [self ensureDebugAtEachStepBlock.
printBytecodeAtEachStep := printBytecodeAtEachStep not];
add: (printFrameAtEachStep
ifTrue: ['no print frame each bytecode']
ifFalse: ['print frame each bytecode'])
action: [self ensureDebugAtEachStepBlock.
printFrameAtEachStep := printFrameAtEachStep not].
^aMenuMorph!
More information about the Vm-dev
mailing list