[Vm-dev] VM Maker: VMMaker.oscog-eem.269.mcz
commits at source.squeak.org
commits at source.squeak.org
Thu Feb 28 21:22:11 UTC 2013
Eliot Miranda uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker.oscog-eem.269.mcz
==================== Summary ====================
Name: VMMaker.oscog-eem.269
Author: eem
Time: 28 February 2013, 1:19:23.804 pm
UUID: 49173296-5145-4de1-a2d9-defc8579acc6
Ancestors: VMMaker.oscog-eem.268
Fix bug in primitiveClone/cloneContext: that causes the copy to be a
word short.
Move isContext: to ObjectMemory where it belongs.
Implement the heap map check for simulation, plus a test class.
Implement mem:mo:ve: for simulation.
Use isPointerNonInt: and isContextNonInt: in a few places.
=============== Diff against VMMaker.oscog-eem.268 ===============
Item was changed:
----- Method: CoInterpreter class>>isNonArgumentImplicitReceiverVariableName: (in category 'translation') -----
isNonArgumentImplicitReceiverVariableName: aString
+ ^#('self' 'stackPages' 'cogit' 'coInterpreter' 'cogMethodZone' 'objectMemory' 'interpreter' 'heapMap') includes: aString!
- ^#('self' 'stackPages' 'cogit' 'coInterpreter' 'cogMethodZone' 'objectMemory' 'interpreter') includes: aString!
Item was changed:
----- Method: CoInterpreter>>baseFrameReturn (in category 'return bytecodes') -----
baseFrameReturn
"Return from a baseFrame (the bottom frame in a stackPage). The context to
return to (which may be married) is stored in the first word of the stack."
<inline: true>
| contextToReturnTo retToContext theFP theSP thePage newPage frameAbove |
<var: #theFP type: #'char *'>
<var: #theSP type: #'char *'>
<var: #thePage type: #'StackPage *'>
<var: #newPage type: #'StackPage *'>
<var: #frameAbove type: #'char *'>
contextToReturnTo := self frameCallerContext: localFP.
"The stack page is effectively free now, so free it. We must free it to be
correct in determining if contextToReturnTo is still married, and in case
makeBaseFrameFor: cogs a method, which may cause a code compaction,
in which case the frame must be free to avoid the relocation machinery
tracing the dead frame. Since freeing now temporarily violates the page-list
ordering invariant, use the assert-free version."
stackPages freeStackPageNoAssert: stackPage.
+ retToContext := objectMemory isContext: contextToReturnTo.
- retToContext := self isContext: contextToReturnTo.
(retToContext
and: [self isStillMarriedContext: contextToReturnTo])
ifTrue:
[theFP := self frameOfMarriedContext: contextToReturnTo.
thePage := stackPages stackPageFor: theFP.
theFP = thePage headFP
ifTrue:
[theSP := thePage headSP]
ifFalse:
["Returning to some interior frame, presumably because of a sender assignment.
Move the frames above to another page (they may be in use, e.g. via coroutining).
Make the interior frame the top frame."
frameAbove := self findFrameAbove: theFP inPage: thePage.
"Since we've just deallocated a page we know that newStackPage won't deallocate an existing one."
newPage := self newStackPage.
self assert: newPage = stackPage.
self moveFramesIn: thePage through: frameAbove toPage: newPage.
stackPages markStackPageMostRecentlyUsed: newPage.
theFP := thePage headFP.
theSP := thePage headSP]]
ifFalse:
[(retToContext
and: [objectMemory isIntegerObject: (objectMemory fetchPointer: InstructionPointerIndex ofObject: contextToReturnTo)]) ifFalse:
[| contextToReturnFrom |
contextToReturnFrom := stackPages longAt: stackPage baseAddress - BytesPerWord.
self tearDownAndRebuildFrameForCannotReturnBaseFrameReturnFrom: contextToReturnFrom
to: contextToReturnTo
returnValue: localReturnValue.
^self externalCannotReturn: localReturnValue from: contextToReturnFrom].
"We must void the instructionPointer to stop it being updated if makeBaseFrameFor:
cogs a method, which may cause a code compaction."
instructionPointer := 0.
thePage := self makeBaseFrameFor: contextToReturnTo.
theFP := thePage headFP.
theSP := thePage headSP].
self setStackPageAndLimit: thePage.
self assert: (stackPages stackPageFor: theFP) = stackPage.
localSP := theSP.
localFP := theFP.
localIP := self pointerForOop: self internalStackTop.
localIP asUnsignedInteger < objectMemory startOfMemory ifTrue:
[localIP asUnsignedInteger ~= cogit ceReturnToInterpreterPC ifTrue:
["localIP in the cog method zone indicates a return to machine code."
^self returnToMachineCodeFrame].
localIP := self pointerForOop: (self iframeSavedIP: localFP)].
self assert: (self checkIsStillMarriedContext: contextToReturnTo currentFP: localFP).
self setMethod: (self iframeMethod: localFP).
self internalStackTopPut: localReturnValue.
^self fetchNextBytecode!
Item was changed:
----- Method: CoInterpreter>>ceBaseFrameReturn: (in category 'trampolines') -----
ceBaseFrameReturn: returnValue
"Return across a page boundary. The context to return to (which may be married)
is stored in the first word of the stack. We get here when a return instruction jumps
to the ceBaseFrameReturn: address that is the return pc for base frames. A consequence
of this is that the current frame is no longer valid since an interrupt may have overwritten
its state as soon as the stack pointer has been cut-back beyond the return pc. So to have
a context to send the cannotReturn: message to we also store the base frame's context
in the second word of the stack page."
<api>
| contextToReturnTo contextToReturnFrom isAContext thePage newPage frameAbove |
<var: #thePage type: #'StackPage *'>
<var: #newPage type: #'StackPage *'>
<var: #frameAbove type: #'char *'>
self assert: (stackPages stackPageFor: stackPointer) = stackPage.
self assert: stackPages mostRecentlyUsedPage = stackPage.
cogit assertCStackWellAligned.
self assert: framePointer = 0.
self assert: stackPointer <= (stackPage baseAddress - BytesPerWord).
self assert: stackPage baseFP + (2 * BytesPerWord) < stackPage baseAddress.
"We would like to use the following assert but we can't since the stack pointer will be above the
base frame pointer in the base frame return and hence the 0 a base frame pointer points at could
be overwritten which will cause the isBaseFrame assert in frameCallerContext: to fail."
"self assert: (self frameCallerContext: stackPage baseFP) = (stackPages longAt: stackPage baseAddress)."
self assert: ((objectMemory addressCouldBeObj: (stackPages longAt: stackPage baseAddress - BytesPerWord))
+ and: [objectMemory isContext: (stackPages longAt: stackPage baseAddress - BytesPerWord)]).
- and: [self isContext: (stackPages longAt: stackPage baseAddress - BytesPerWord)]).
self assert: ((objectMemory addressCouldBeObj: (stackPages longAt: stackPage baseAddress))
+ and: [objectMemory isContext: (stackPages longAt: stackPage baseAddress)]).
- and: [self isContext: (stackPages longAt: stackPage baseAddress)]).
contextToReturnTo := stackPages longAt: stackPage baseAddress.
"The stack page is effectively free now, so free it. We must free it to be
correct in determining if contextToReturnTo is still married, and in case
makeBaseFrameFor: cogs a method, which may cause a code compaction,
in which case the frame must be free to avoid the relocation machinery
tracing the dead frame. Since freeing now temporarily violates the page-list
ordering invariant, use the assert-free version."
stackPages freeStackPageNoAssert: stackPage.
+ isAContext := objectMemory isContext: contextToReturnTo.
- isAContext := self isContext: contextToReturnTo.
(isAContext
and: [self isStillMarriedContext: contextToReturnTo])
ifTrue:
[framePointer := self frameOfMarriedContext: contextToReturnTo.
thePage := stackPages stackPageFor: framePointer.
framePointer = thePage headFP
ifTrue:
[stackPointer := thePage headSP]
ifFalse:
["Returning to some interior frame, presumably because of a sender assignment.
Move the frames above to another page (they may be in use, e.g. via coroutining).
Make the interior frame the top frame."
frameAbove := self findFrameAbove: framePointer inPage: thePage.
"Since we've just deallocated a page we know that newStackPage won't deallocate an existing one."
newPage := self newStackPage.
self assert: newPage = stackPage.
self moveFramesIn: thePage through: frameAbove toPage: newPage.
stackPages markStackPageMostRecentlyUsed: newPage.
framePointer := thePage headFP.
stackPointer := thePage headSP]]
ifFalse:
[(isAContext
and: [objectMemory isIntegerObject: (objectMemory fetchPointer: InstructionPointerIndex ofObject: contextToReturnTo)]) ifFalse:
[contextToReturnFrom := stackPages longAt: stackPage baseAddress - BytesPerWord.
self tearDownAndRebuildFrameForCannotReturnBaseFrameReturnFrom: contextToReturnFrom
to: contextToReturnTo
returnValue: returnValue.
^self externalCannotReturn: returnValue from: contextToReturnFrom].
"void the instructionPointer to stop it being incorrectly updated in a code
compaction in makeBaseFrameFor:."
instructionPointer := 0.
thePage := self makeBaseFrameFor: contextToReturnTo.
framePointer := thePage headFP.
stackPointer := thePage headSP].
self setStackPageAndLimit: thePage.
self assert: (stackPages stackPageFor: framePointer) = stackPage.
(self isMachineCodeFrame: framePointer) ifTrue:
[self push: returnValue.
cogit ceEnterCogCodePopReceiverReg.
"NOTREACHED"].
instructionPointer := self stackTop.
instructionPointer = cogit ceReturnToInterpreterPC ifTrue:
[instructionPointer := self iframeSavedIP: framePointer].
self setMethod: (self iframeMethod: framePointer).
self stackTopPut: returnValue. "a.k.a. pop saved ip then push result"
self assert: (self checkIsStillMarriedContext: contextToReturnTo currentFP: framePointer).
self siglong: reenterInterpreter jmp: ReturnToInterpreter.
"NOTREACHED"
^nil!
Item was changed:
----- Method: CoInterpreter>>ceNonLocalReturn: (in category 'trampolines') -----
ceNonLocalReturn: returnValue
<api>
| closure home unwindContextOrNilOrZero ourContext frameToReturnTo contextToReturnTo theFP callerFP newPage |
<var: #frameToReturnTo type: #'char *'>
<var: #theFP type: #'char *'>
<var: #callerFP type: #'char *'>
<var: #newPage type: #'StackPage *'>
<var: #thePage type: #'StackPage *'>
"self shortPrintFrameAndCallers: framePointer.
self printOop: returnValue.
self halt."
self assert: (self isMachineCodeFrame: framePointer).
self assert: (self frameIsBlockActivation: framePointer).
"Since this is a block activation the closure is on the stack above any args and the frame."
closure := self pushedReceiverOrClosureOfFrame: framePointer.
home := nil.
"Walk the closure's lexical chain to find the context or frame to return from (home)."
[closure ~= objectMemory nilObject] whileTrue:
[home := objectMemory fetchPointer: ClosureOuterContextIndex ofObject: closure.
closure := objectMemory fetchPointer: ClosureIndex ofObject: home].
"home is to be returned from provided there is no unwind-protect activation between
this frame and home's sender. Search for an unwind. findUnwindThroughContext:
will answer either the context for an unwind-protect activation or nilObj if the sender
cannot be found or 0 if no unwind is found but the sender is. We must update the
current page's headFrame pointers to enable the search to identify widowed contexts
correctly."
self externalWriteBackHeadFramePointers.
unwindContextOrNilOrZero := self findUnwindThroughContext: home.
unwindContextOrNilOrZero = objectMemory nilObject ifTrue:
["error: can't find home on chain; cannot return"
ourContext := self ensureFrameIsMarried: framePointer SP: stackPointer.
^self externalCannotReturn: returnValue from: ourContext].
unwindContextOrNilOrZero ~= 0 ifTrue:
[^self externalAboutToReturn: returnValue through: unwindContextOrNilOrZero].
"Now we know home is on the sender chain.
We could be returning to either a context or a frame. Find out which."
contextToReturnTo := nil.
(self isMarriedOrWidowedContext: home)
ifTrue:
[self assert: (self checkIsStillMarriedContext: home currentFP: framePointer).
theFP := self frameOfMarriedContext: home.
(self isBaseFrame: theFP)
ifTrue:
[contextToReturnTo := self frameCallerContext: theFP]
ifFalse:
[frameToReturnTo := self frameCallerFP: theFP]]
ifFalse:
[contextToReturnTo := objectMemory fetchPointer: SenderIndex ofObject: home.
+ ((objectMemory isContext: contextToReturnTo)
- ((self isContext: contextToReturnTo)
and: [self isMarriedOrWidowedContext: contextToReturnTo]) ifTrue:
[self assert: (self checkIsStillMarriedContext: contextToReturnTo currentFP: framePointer).
frameToReturnTo := self frameOfMarriedContext: contextToReturnTo.
contextToReturnTo := nil]].
"If returning to a context we must make a frame for it unless it is dead."
contextToReturnTo ~= nil ifTrue:
[frameToReturnTo := self establishFrameForContextToReturnTo: contextToReturnTo.
frameToReturnTo == 0 ifTrue:
["error: home's sender is dead; cannot return"
ourContext := self ensureFrameIsMarried: framePointer SP: stackPointer.
^self externalCannotReturn: returnValue from: ourContext]].
"Now we have a frame to return to. If it is on a different page we must
free intervening pages and nil out intervening contexts. We must free
intervening stack pages because if we leave the pages to be divorced
then their contexts will be divorced with intact senders and instruction
pointers. This code is similar to primitiveTerminateTo."
self assert: stackPages pageListIsWellFormed.
newPage := stackPages stackPageFor: frameToReturnTo.
newPage ~~ stackPage ifTrue:
[| currentCtx thePage nextCntx |
currentCtx := self frameCallerContext: stackPage baseFP.
+ self assert: (objectMemory isContext: currentCtx).
- self assert: (self isContext: currentCtx).
stackPages freeStackPage: stackPage.
+ [self assert: (objectMemory isContext: currentCtx).
- [self assert: (self isContext: currentCtx).
(self isMarriedOrWidowedContext: currentCtx)
and: [(stackPages stackPageFor: (theFP := self frameOfMarriedContext: currentCtx)) = newPage]] whileFalse:
[(self isMarriedOrWidowedContext: currentCtx)
ifTrue:
[thePage := stackPages stackPageFor: theFP.
currentCtx := self frameCallerContext: thePage baseFP.
stackPages freeStackPage: thePage]
ifFalse:
[nextCntx := objectMemory fetchPointer: SenderIndex ofObject: currentCtx.
self markContextAsDead: currentCtx.
currentCtx := nextCntx]].
self setStackPageAndLimit: newPage.
stackPointer := stackPage headSP.
framePointer := stackPage headFP].
"Two cases. Returning to the top frame or an interior frame. The
top frame has its instruction pointer on top of stack. An interior
frame has its instruction pointer in the caller frame. We need to
peel back any frames on the page until we get to the correct frame."
self flag: 'currently caller pushes result'. "(in machine code)"
framePointer = frameToReturnTo
ifTrue:
[instructionPointer := self popStack]
ifFalse:
[[callerFP := framePointer.
framePointer := self frameCallerFP: framePointer.
framePointer ~~ frameToReturnTo] whileTrue.
instructionPointer := (self frameCallerSavedIP: callerFP) asUnsignedInteger.
stackPointer := (self frameCallerSP: callerFP)].
^self return: returnValue toExecutive: false!
Item was changed:
----- Method: CoInterpreter>>checkOkayFields: (in category 'debug support') -----
checkOkayFields: oop
"Check if the argument is an ok object.
If this is a pointers object, check that its fields are all okay oops."
| hasYoung i fieldOop |
(oop = nil or: [oop = 0]) ifTrue: [ ^true ]. "?? eem 1/16/2013"
(objectMemory isIntegerObject: oop) ifTrue: [ ^true ].
(objectMemory checkOkayOop: oop) ifFalse: [ ^false ].
(self checkOopHasOkayClass: oop) ifFalse: [ ^false ].
hasYoung := objectMemory isYoung: (objectMemory fetchClassOfNonInt: oop).
+ ((objectMemory isPointersNonInt: oop) or: [objectMemory isCompiledMethod: oop]) ifFalse: [ ^true ].
- ((objectMemory isPointers: oop) or: [objectMemory isCompiledMethod: oop]) ifFalse: [ ^true ].
(objectMemory isCompiledMethod: oop)
ifTrue:
[i := (self literalCountOf: oop) - 1]
ifFalse:
+ [(objectMemory isContext: oop)
- [(self isContext: oop)
ifTrue: [i := CtxtTempFrameStart + (self fetchStackPointerOf: oop) - 1]
ifFalse: [i := (objectMemory lengthOf: oop) - 1]].
[i >= 0] whileTrue:
[fieldOop := objectMemory fetchPointer: i ofObject: oop.
(objectMemory isNonIntegerObject: fieldOop) ifTrue:
[(i = 0 and: [objectMemory isCompiledMethod: oop])
ifTrue:
[(cogMethodZone methodFor: (self pointerForOop: fieldOop)) = 0 ifTrue:
[self print: 'method '; printHex: oop; print: ' has an invalid cog method reference'.
^false]]
ifFalse:
[hasYoung := hasYoung or: [objectMemory isYoung: fieldOop].
(objectMemory checkOkayOop: fieldOop) ifFalse: [ ^false ].
(self checkOopHasOkayClass: fieldOop) ifFalse: [ ^false ]]].
i := i - 1].
hasYoung ifTrue:
[^objectMemory checkOkayYoungReferrer: oop].
^true!
Item was changed:
----- Method: CoInterpreter>>checkStackIntegrity (in category 'object memory support') -----
checkStackIntegrity
"Perform an integrity/leak check using the heapMap. Assume
clearLeakMapAndMapAccesibleObjects has set a bit at each
object's header. Scan all objects accessible from the stack
checking that every pointer points to a header. Answer if no
dangling pointers were detected."
| ok |
<inline: false>
<var: #thePage type: #'StackPage *'>
<var: #theSP type: #'char *'>
<var: #theFP type: #'char *'>
<var: #callerFP type: #'char *'>
<var: #frameRcvrOffset type: #'char *'>
<var: #cogMethod type: #'CogMethod *'>
ok := true.
0 to: numStackPages - 1 do:
[:i| | thePage theSP theFP frameRcvrOffset callerFP oop |
thePage := stackPages stackPageAt: i.
(stackPages isFree: thePage) ifFalse:
[thePage = stackPage
ifTrue:
[theSP := stackPointer.
theFP := framePointer]
ifFalse:
[theSP := thePage headSP.
theFP := thePage headFP].
"Skip the instruction pointer on top of stack of inactive pages."
thePage = stackPage ifFalse:
[theSP := theSP + BytesPerWord].
[frameRcvrOffset := self frameReceiverOffset: theFP.
[theSP <= frameRcvrOffset] whileTrue:
[oop := stackPages longAt: theSP.
((objectMemory isNonIntegerObject: oop)
and: [(self heapMapAtWord: (self pointerForOop: oop)) = 0]) ifTrue:
[self printFrameThing: 'object leak in frame temp' at: theSP; cr.
ok := false].
theSP := theSP + BytesPerWord].
(self frameHasContext: theFP) ifTrue:
[oop := self frameContext: theFP.
((objectMemory isIntegerObject: oop)
or: [(self heapMapAtWord: (self pointerForOop: oop)) = 0]) ifTrue:
[self printFrameThing: 'object leak in frame ctxt' at: theFP + FoxThisContext; cr.
ok := false].
+ (oop = objectMemory nilObject or: [objectMemory isContext: oop]) ifFalse:
- (oop = objectMemory nilObject or: [self isContext: oop]) ifFalse:
[self printFrameThing: 'frame ctxt should be context' at: theFP + FoxThisContext; cr.
ok := false]].
(self isMachineCodeFrame: theFP)
ifTrue:
[| cogMethod |
cogMethod := self mframeHomeMethod: theFP.
(self heapMapAtWord: (self pointerForOop: cogMethod)) = 0 ifTrue:
[self printFrameThing: 'object leak in mframe mthd' at: theFP + FoxMethod; cr.
ok := false]]
ifFalse:
[oop := self iframeMethod: theFP.
((objectMemory isIntegerObject: oop)
or: [(self heapMapAtWord: (self pointerForOop: oop)) = 0]) ifTrue:
[self printFrameThing: 'object leak in iframe mthd' at: theFP + FoxMethod; cr.
ok := false]].
(callerFP := self frameCallerFP: theFP) ~= 0] whileTrue:
[theSP := theFP + FoxCallerSavedIP + BytesPerWord.
theFP := callerFP].
theSP := theFP + FoxCallerSavedIP + BytesPerWord.
[theSP <= thePage baseAddress] whileTrue:
[oop := stackPages longAt: theSP.
((objectMemory isNonIntegerObject: oop)
and: [(self heapMapAtWord: (self pointerForOop: oop)) = 0]) ifTrue:
[self printFrameThing: 'object leak in frame arg' at: theSP; cr.
ok := false].
theSP := theSP + BytesPerWord]]].
^ok!
Item was changed:
----- Method: CoInterpreter>>commonReturn (in category 'return bytecodes') -----
commonReturn
"Do an ^-return (return form method), perhaps checking for unwinds if this is a block activation.
Note: Assumed to be inlined into the dispatch loop."
<sharedCodeNamed: 'commonReturn' inCase: #returnReceiver>
| closure home unwindContextOrNilOrZero frameToReturnTo contextToReturnTo theFP callerFP newPage |
<var: #frameToReturnTo type: #'char *'>
<var: #theFP type: #'char *'>
<var: #callerFP type: #'char *'>
<var: #newPage type: #'StackPage *'>
<var: #thePage type: #'StackPage *'>
"If this is a method simply return to the sender/caller."
(self frameIsBlockActivation: localFP) ifFalse:
[^self commonCallerReturn].
"Since this is a block activation the closure is on the stack above any args and the frame."
closure := self pushedReceiverOrClosureOfFrame: localFP.
home := nil.
"Walk the closure's lexical chain to find the context or frame to return from (home)."
[closure ~= objectMemory nilObject] whileTrue:
[home := objectMemory fetchPointer: ClosureOuterContextIndex ofObject: closure.
closure := objectMemory fetchPointer: ClosureIndex ofObject: home].
"home is to be returned from provided there is no unwind-protect activation between
this frame and home's sender. Search for an unwind. findUnwindThroughContext:
will answer either the context for an unwind-protect activation or nilObj if the sender
cannot be found or 0 if no unwind is found but the sender is. We must update the
current page's headFrame pointers to enable the search to identify widowed contexts
correctly."
self writeBackHeadFramePointers.
unwindContextOrNilOrZero := self internalFindUnwindThroughContext: home.
unwindContextOrNilOrZero = objectMemory nilObject ifTrue:
["error: can't find home on chain; cannot return"
^self internalCannotReturn: localReturnValue].
unwindContextOrNilOrZero ~= 0 ifTrue:
[^self internalAboutToReturn: localReturnValue through: unwindContextOrNilOrZero].
"Now we know home is on the sender chain.
We could be returning to either a context or a frame. Find out which."
contextToReturnTo := nil.
(self isMarriedOrWidowedContext: home)
ifTrue:
[self assert: (self checkIsStillMarriedContext: home currentFP: localFP).
theFP := self frameOfMarriedContext: home.
(self isBaseFrame: theFP)
ifTrue:
[contextToReturnTo := self frameCallerContext: theFP]
ifFalse:
[frameToReturnTo := self frameCallerFP: theFP]]
ifFalse:
[contextToReturnTo := objectMemory fetchPointer: SenderIndex ofObject: home.
+ ((objectMemory isContext: contextToReturnTo)
- ((self isContext: contextToReturnTo)
and: [self isMarriedOrWidowedContext: contextToReturnTo]) ifTrue:
[self assert: (self checkIsStillMarriedContext: contextToReturnTo currentFP: localFP).
frameToReturnTo := self frameOfMarriedContext: contextToReturnTo.
contextToReturnTo := nil]].
"If returning to a context we must make a frame for it unless it is dead."
contextToReturnTo ~= nil ifTrue:
[frameToReturnTo := self establishFrameForContextToReturnTo: contextToReturnTo.
frameToReturnTo == 0 ifTrue:
["error: home's sender is dead; cannot return"
^self internalCannotReturn: localReturnValue]].
"Now we have a frame to return to. If it is on a different page we must free intervening pages and
nil out intervening contexts. We must free intervening stack pages because if we leave the pages
to be divorced then their contexts will be divorced with intact senders and instruction pointers. This
code is similar to primitiveTerminateTo. We must move any frames on itervening pages above the
frame linked to because these may be in use, e.g. via co-routining (see baseFrameReturn)."
self assert: stackPages pageListIsWellFormed.
newPage := stackPages stackPageFor: frameToReturnTo.
newPage ~~ stackPage ifTrue:
[| currentCtx thePage nextCntx |
currentCtx := self frameCallerContext: stackPage baseFP.
+ self assert: (objectMemory isContext: currentCtx).
- self assert: (self isContext: currentCtx).
stackPages freeStackPage: stackPage.
[(self isMarriedOrWidowedContext: currentCtx)
and: [(stackPages stackPageFor: (theFP := self frameOfMarriedContext: currentCtx)) = newPage]] whileFalse:
[(self isMarriedOrWidowedContext: currentCtx)
ifTrue:
[thePage := stackPages stackPageFor: theFP.
theFP ~= thePage headFP ifTrue:
["Since we've just deallocated a page we know that newStackPage won't deallocate an existing one."
self moveFramesIn: thePage through: (self findFrameAbove: theFP inPage: thePage) toPage: self newStackPage].
currentCtx := self frameCallerContext: thePage baseFP.
stackPages freeStackPage: thePage]
ifFalse:
[nextCntx := objectMemory fetchPointer: SenderIndex ofObject: currentCtx.
self markContextAsDead: currentCtx.
currentCtx := nextCntx]].
self setStackPageAndLimit: newPage.
localSP := stackPage headSP.
localFP := stackPage headFP].
"Two cases. Returning to the top frame on a new page or an interior frame on the current page.
The top frame has its instruction pointer on top of stack. An interior frame has its instruction pointer
in the caller frame. We need to peel back any frames on the page until we get to the correct frame."
localFP = frameToReturnTo
ifTrue:
[localIP := self pointerForOop: self internalStackTop]
ifFalse:
[[callerFP := localFP.
localFP := self frameCallerFP: localFP.
localFP ~~ frameToReturnTo] whileTrue.
localIP := self frameCallerSavedIP: callerFP.
localSP := (self frameCallerSP: callerFP) - BytesPerWord].
localIP asUnsignedInteger < objectMemory startOfMemory ifTrue:
[localIP asUnsignedInteger ~= cogit ceReturnToInterpreterPC ifTrue:
["localIP in the cog method zone indicates a return to machine code."
^self returnToMachineCodeFrame].
localIP := self pointerForOop: (self iframeSavedIP: localFP)].
"pop the saved IP, push the return value and continue."
self internalStackTopPut: localReturnValue.
self setMethod: (self iframeMethod: localFP).
^self fetchNextBytecode!
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 spouseFP |
<var: #spouseFP type: #'char *'>
<var: #thePage type: #'StackPage *'>
<var: #theFPAbove type: #'char *'>
+ self assert: (objectMemory isContext: aContext).
- self assert: (self isContext: aContext).
self externalWriteBackHeadFramePointers.
"method, closureOrNil & receiver need no special handling; only
sender, pc & stackp have to be computed for married contexts."
(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 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>>frameCallerContext: (in category 'frame access') -----
frameCallerContext: theFP
"In the StackInterpreter the saved ip field of a base frame holds the
base frame's caller context. But in the Cog VM the first word on the
stack holds the base frame's caller context, which is immediately
above the stacked receiver."
<var: #theFP type: #'char *'>
| thePage callerContextOrNil |
<var: #thePage type: #'StackPage *'>
self assert: (self isBaseFrame: theFP).
thePage := stackPages stackPageFor: theFP.
callerContextOrNil := stackPages longAt: thePage baseAddress.
self assert: (objectMemory addressCouldBeObj: callerContextOrNil).
+ self assert: (callerContextOrNil = objectMemory nilObject or: [objectMemory isContext: callerContextOrNil]).
- self assert: (callerContextOrNil = objectMemory nilObject or: [self isContext: callerContextOrNil]).
^callerContextOrNil!
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 assert: (self isContext: aContext).
self writeBackHeadFramePointers.
(self isMarriedOrWidowedContext: aContext) ifFalse:
[value := objectMemory fetchPointer: offset ofObject: aContext.
(offset = InstructionPointerIndex
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:
[| 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 changed:
----- Method: CoInterpreter>>makeBaseFrameFor: (in category 'frame access') -----
makeBaseFrameFor: aContext "<Integer>"
"Marry aContext with the base frame of a new stack page. Build the base
frame to reflect the context's state. Answer the new page. Override to
hold the caller context in a different place, In the StackInterpreter we use
the caller saved ip, but in the Cog VM caller saved ip is the ceBaseReturn:
trampoline. Simply hold the caller context in the first word of the stack."
<returnTypeC: #'StackPage *'>
| page pointer theMethod theIP numArgs stackPtrIndex maybeClosure |
<inline: false>
<var: #page type: #'StackPage *'>
<var: #pointer type: #'char *'>
<var: #cogMethod type: #'CogMethod *'>
self assert: (self isSingleContext: aContext).
+ self assert: (objectMemory goodContextSize: aContext).
theIP := objectMemory fetchPointer: InstructionPointerIndex ofObject: aContext.
self assert: HasBeenReturnedFromMCPC signedIntFromLong < 0.
theIP := (objectMemory isIntegerObject: theIP)
ifTrue: [objectMemory integerValueOf: theIP]
ifFalse: [HasBeenReturnedFromMCPC].
theMethod := objectMemory fetchPointer: MethodIndex ofObject: aContext.
page := self newStackPage.
"first word on stack is caller context of base frame"
stackPages
longAt: (pointer := page baseAddress)
put: (objectMemory fetchPointer: SenderIndex ofObject: aContext).
"second word is the context itself; needed for cannotReturn processing; see ceBaseReturn:."
stackPages
longAt: (pointer := pointer - BytesPerWord)
put: aContext.
"If the frame is a closure activation then the closure should be on the stack in
the pushed receiver position (closures receiver the value[:value:] messages).
Otherwise it should be the receiver proper."
maybeClosure := objectMemory fetchPointer: ClosureIndex ofObject: aContext.
maybeClosure ~= objectMemory nilObject
ifTrue:
[numArgs := self argumentCountOfClosure: maybeClosure.
stackPages
longAt: (pointer := pointer - BytesPerWord)
put: maybeClosure]
ifFalse:
[| header |
header := self headerOf: theMethod.
numArgs := self argumentCountOfMethodHeader: header.
self cppIf: MULTIPLEBYTECODESETS
ifTrue: "If this is a synthetic context its IP could be pointing at the CallPrimitive opcode. If so, skip it."
[(theIP signedIntFromLong > 0
and: [(self methodHeaderHasPrimitive: header)
and: [theIP = (1 + (objectMemory lastPointerOf: theMethod))]]) ifTrue:
[theIP := theIP + (self sizeOfCallPrimitiveBytecode: header)]].
stackPages
longAt: (pointer := pointer - BytesPerWord)
put: (objectMemory fetchPointer: ReceiverIndex ofObject: aContext)].
"Put the arguments on the stack"
1 to: numArgs do:
[:i|
stackPages
longAt: (pointer := pointer - BytesPerWord)
put: (objectMemory fetchPointer: ReceiverIndex + i ofObject: aContext)].
"saved caller ip is base return trampoline"
stackPages
longAt: (pointer := pointer - BytesPerWord)
put: cogit ceBaseFrameReturnPC.
"base frame's saved fp is null"
stackPages
longAt: (pointer := pointer - BytesPerWord)
put: 0.
"N.B. Don't set the baseFP, which marks the page as in use, until after
ensureMethodIsCogged: and/or instructionPointer:forContext:frame:. These
can cause a compiled code compaction which, if marked as in use, will
examine this partially initialized page and crash."
page headFP: pointer.
"Create either a machine code frame or an interpreter frame based on the pc. If the pc is -ve
it is a machine code pc and so we produce a machine code frame. If +ve an interpreter frame.
N.B. Do *not* change this to try and map from a bytecode pc to a machine code frame under
any circumstances. See ensureContextIsExecutionSafeAfterAssignToStackPointer:"
theIP signedIntFromLong < 0
ifTrue:
[| cogMethod |
"Since we would have to generate a machine-code method to be able to map
the native pc anyway we should create a native method and native frame."
cogMethod := self ensureMethodIsCogged: theMethod.
theMethod := cogMethod asInteger.
maybeClosure ~= objectMemory nilObject
ifTrue:
["If the pc is the special HasBeenReturnedFromMCPC pc set the pc
appropriately so that the frame stays in the cannotReturn: state."
theIP = HasBeenReturnedFromMCPC signedIntFromLong
ifTrue:
[theMethod := (cogit findMethodForStartBcpc: (self startPCOfClosure: maybeClosure)
inHomeMethod: (self cCoerceSimple: theMethod
to: #'CogMethod *')) asInteger.
theMethod = 0 ifTrue:
[self error: 'cannot find machine code block matching closure''s startpc'].
theIP := cogit ceCannotResumePC]
ifFalse:
[self assert: (theIP signedBitShift: -16) < -1. "See contextInstructionPointer:frame:"
theMethod := theMethod - ((theIP signedBitShift: -16) * (cogit sizeof: CogBlockMethod)).
theIP := theMethod - theIP signedIntFromShort].
stackPages
longAt: (pointer := pointer - BytesPerWord)
put: theMethod + MFMethodFlagHasContextFlag + MFMethodFlagIsBlockFlag]
ifFalse:
[self assert: (theIP signedBitShift: -16) >= -1.
"If the pc is the special HasBeenReturnedFromMCPC pc set the pc
appropriately so that the frame stays in the cannotReturn: state."
theIP := theIP = HasBeenReturnedFromMCPC signedIntFromLong
ifTrue: [cogit ceCannotResumePC]
ifFalse: [theMethod asInteger - theIP].
stackPages
longAt: (pointer := pointer - BytesPerWord)
put: theMethod + MFMethodFlagHasContextFlag].
stackPages
longAt: (pointer := pointer - BytesPerWord)
put: aContext]
ifFalse:
[stackPages
longAt: (pointer := pointer - BytesPerWord)
put: theMethod.
stackPages
longAt: (pointer := pointer - BytesPerWord)
put: aContext.
stackPages
longAt: (pointer := pointer - BytesPerWord)
put: (self encodeFrameFieldHasContext: true isBlock: maybeClosure ~= objectMemory nilObject numArgs: numArgs).
stackPages
longAt: (pointer := pointer - BytesPerWord)
put: 0. "FoxIFSavedIP"
theIP := self iframeInstructionPointerForIndex: theIP method: theMethod].
page baseFP: page headFP.
self assert: (self frameHasContext: page baseFP).
self assert: (self frameNumArgs: page baseFP) == numArgs.
stackPages
longAt: (pointer := pointer - BytesPerWord)
put: (objectMemory fetchPointer: ReceiverIndex ofObject: aContext).
stackPtrIndex := self quickFetchInteger: StackPointerIndex ofObject: aContext.
self assert: ReceiverIndex + stackPtrIndex < (objectMemory lengthOf: aContext).
numArgs + 1 to: stackPtrIndex do:
[:i|
stackPages
longAt: (pointer := pointer - BytesPerWord)
put: (objectMemory fetchPointer: ReceiverIndex + i ofObject: aContext)].
"top of stack is the instruction pointer"
stackPages longAt: (pointer := pointer - BytesPerWord) put: theIP.
page headSP: pointer.
self assert: (self context: aContext hasValidInversePCMappingOf: theIP in: page baseFP).
"Mark context as married by setting its sender to the frame pointer plus SmallInteger
tags and the InstructionPointer to the saved fp (which ensures correct alignment
w.r.t. the frame when we check for validity) plus SmallInteger tags."
objectMemory storePointerUnchecked: SenderIndex
ofObject: aContext
withValue: (self withSmallIntegerTags: page baseFP).
objectMemory storePointerUnchecked: InstructionPointerIndex
ofObject: aContext
withValue: (self withSmallIntegerTags: 0).
self assert: (objectMemory isIntegerObject: (objectMemory fetchPointer: SenderIndex ofObject: aContext)).
self assert: (self frameOfMarriedContext: aContext) = page baseFP.
self assert: self validStackPageBaseFrames.
^page!
Item was changed:
----- Method: CoInterpreter>>markAndTraceStackPage: (in category 'object memory support') -----
markAndTraceStackPage: thePage
| theSP theFP frameRcvrOffset callerFP oop |
<var: #thePage type: #'StackPage *'>
<var: #theSP type: #'char *'>
<var: #theFP type: #'char *'>
<var: #frameRcvrOffset type: #'char *'>
<var: #callerFP type: #'char *'>
<inline: false>
self assert: (stackPages isFree: thePage) not.
theSP := thePage headSP.
theFP := thePage headFP.
"Skip the instruction pointer on top of stack of inactive pages."
thePage = stackPage ifFalse:
[theSP := theSP + BytesPerWord].
[frameRcvrOffset := self frameReceiverOffset: theFP.
[theSP <= frameRcvrOffset] whileTrue:
[oop := stackPages longAt: theSP.
(objectMemory isIntegerObject: oop) ifFalse:
[objectMemory markAndTrace: oop].
theSP := theSP + BytesPerWord].
(self frameHasContext: theFP) ifTrue:
+ [self assert: (objectMemory isContext: (self frameContext: theFP)).
- [self assert: (self isContext: (self frameContext: theFP)).
objectMemory markAndTrace: (self frameContext: theFP)].
(self isMachineCodeFrame: theFP)
ifTrue: [self markAndTraceMachineCodeMethod: (self mframeCogMethod: theFP)]
ifFalse: [objectMemory markAndTrace: (self iframeMethod: theFP)].
(callerFP := self frameCallerFP: theFP) ~= 0] whileTrue:
[theSP := theFP + FoxCallerSavedIP + BytesPerWord.
theFP := callerFP].
theSP := theFP + FoxCallerSavedIP + BytesPerWord. "caller ip is ceBaseReturnPC"
[theSP <= thePage baseAddress] whileTrue:
[oop := stackPages longAt: theSP.
(objectMemory isIntegerObject: oop) ifFalse:
[objectMemory markAndTrace: oop].
theSP := theSP + BytesPerWord]!
Item was changed:
----- Method: CoInterpreter>>moveFramesIn:through:toPage: (in category 'frame access') -----
moveFramesIn: oldPage through: theFP toPage: newPage
"Move frames from the hot end of oldPage through to theFP to newPage.
This has the effect of making theFP a base frame which can be stored into.
Answer theFP's new location."
| newSP newFP stackedReceiverOffset delta callerFP callerIP fpInNewPage offsetCallerFP theContext |
<inline: false>
<var: #oldPage type: #'StackPage *'>
<var: #theFP type: #'char *'>
<var: #newPage type: #'StackPage *'>
<var: #newSP type: #'char *'>
<var: #newFP type: #'char *'>
<var: #callerFP type: #'char *'>
<var: #fpInNewPage type: #'char *'>
<var: #offsetCallerFP type: #'char *'>
<var: #source type: #'char *'>
<returnTypeC: #'char *'>
"A base frame must have a context for cannotReturn: processing."
self assert: (self isBaseFrame: theFP) not.
self assert: self validStackPageBaseFrames.
callerFP := self frameCallerFP: theFP.
self assert: (self frameHasContext: callerFP).
+ self assert: (objectMemory isContext: (self frameContext: callerFP)).
- self assert: (self isContext: (self frameContext: callerFP)).
theContext := self ensureFrameIsMarried: theFP
SP: theFP + ((self isMachineCodeFrame: theFP) ifTrue: [FoxMFReceiver] ifFalse: [FoxIFReceiver]).
stackPages
longAt: (newSP := newPage baseAddress) put: (self frameContext: callerFP);
longAt: (newSP := newSP - BytesPerWord) put: theContext.
stackedReceiverOffset := self frameStackedReceiverOffset: theFP.
"First move the data, leaving room for the caller and base frame contexts. We will fix up frame pointers later."
theFP + stackedReceiverOffset
to: oldPage headSP
by: BytesPerWord negated
do: [:source|
newSP := newSP - BytesPerWord.
stackPages longAt: newSP put: (stackPages longAt: source)].
"newSP = oldSP + delta => delta = newSP - oldSP"
delta := newSP - oldPage headSP.
newFP := newPage baseAddress - stackedReceiverOffset - (2 * BytesPerWord).
self setHeadFP: oldPage headFP + delta andSP: newSP inPage: newPage.
newPage baseFP: newFP.
callerIP := self oopForPointer: (self frameCallerSavedIP: theFP).
callerIP asUnsignedInteger >= objectMemory startOfMemory ifTrue:
[self iframeSavedIP: callerFP put: callerIP.
callerIP := cogit ceReturnToInterpreterPC].
stackPages longAt: theFP + stackedReceiverOffset put: callerIP.
self assert: (callerFP < oldPage baseAddress
and: [callerFP > (oldPage realStackLimit - (LargeContextSize / 2))]).
oldPage
headFP: callerFP;
headSP: theFP + stackedReceiverOffset.
"Mark the new base frame in the new page"
stackPages
longAt: newFP + FoxCallerSavedIP put: cogit ceBaseFrameReturnPC;
longAt: newFP + FoxSavedFP put: 0.
"Now relocate frame pointers, updating married contexts to refer to their moved spouse frames."
fpInNewPage := newPage headFP.
[offsetCallerFP := self frameCallerFP: fpInNewPage.
offsetCallerFP ~= 0 ifTrue:
[offsetCallerFP := offsetCallerFP + delta].
stackPages longAt: fpInNewPage + FoxSavedFP put: (self oopForPointer: offsetCallerFP).
(self frameHasContext: fpInNewPage) ifTrue:
[theContext := self frameContext: fpInNewPage.
objectMemory storePointerUnchecked: SenderIndex
ofObject: theContext
withValue: (self withSmallIntegerTags: fpInNewPage).
objectMemory storePointerUnchecked: InstructionPointerIndex
ofObject: theContext
withValue: (self withSmallIntegerTags: offsetCallerFP)].
fpInNewPage := offsetCallerFP.
fpInNewPage ~= 0] whileTrue.
self assert: self validStackPageBaseFrames.
^newFP!
Item was changed:
----- Method: CoInterpreter>>updateStateOfSpouseContextForFrame:WithSP: (in category 'frame access') -----
updateStateOfSpouseContextForFrame: theFP WithSP: theSP
"Update the frame's spouse context with the frame's current state except for the
sender and instruction pointer, which are used to mark the context as married."
| theContext tempIndex pointer argsPointer |
<inline: false>
<var: #theFP type: #'char *'>
<var: #theSP type: #'char *'>
<var: #pointer type: #'char *'>
<var: #argsPointer type: #'char *'>
self assert: (self frameHasContext: theFP).
theContext := self frameContext: theFP.
+ self assert: (objectMemory isContext: theContext).
- self assert: (self isContext: theContext).
self assert: (self frameReceiver: theFP)
= (objectMemory fetchPointer: ReceiverIndex ofObject: theContext).
(self isMachineCodeFrame: theFP)
ifTrue:
[tempIndex := self mframeNumArgs: theFP.
pointer := theFP + FoxMFReceiver - BytesPerWord]
ifFalse:
[tempIndex := self iframeNumArgs: theFP.
pointer := theFP + FoxIFReceiver - BytesPerWord].
"update the arguments. this would appear not to be strictly necessary, but is for two reasons.
First, the fact that arguments are read-only is only as convention in the Smalltalk compiler;
other languages may choose to modify arguments.
Second, the Squeak runUntilErrorOrReturnFrom: nightmare pops the stack top, which may, in
certain circumstances, be the last argument, and hence the last argument may not have been
stored into the context."
argsPointer := theFP + (self frameStackedReceiverOffsetNumArgs: tempIndex).
1 to: tempIndex do:
[:i|
argsPointer := argsPointer - BytesPerWord.
self assert: (objectMemory addressCouldBeOop: (stackPages longAt: argsPointer)).
objectMemory storePointer: ReceiverIndex + i
ofObject: theContext
withValue: (stackPages longAt: argsPointer)].
"now update the non-argument stack contents."
[pointer >= theSP] whileTrue:
[self assert: (objectMemory addressCouldBeOop: (stackPages longAt: pointer)).
tempIndex := tempIndex + 1.
objectMemory storePointer: ReceiverIndex + tempIndex
ofObject: theContext
withValue: (stackPages longAt: pointer).
pointer := pointer - BytesPerWord].
self assert: ReceiverIndex + tempIndex < (objectMemory lengthOf: theContext).
objectMemory storePointerUnchecked: StackPointerIndex
ofObject: theContext
withValue: (objectMemory integerObjectOf: tempIndex)!
Item was changed:
----- Method: CoInterpreter>>validStackPageBaseFrames (in category 'stack pages') -----
validStackPageBaseFrames
"Check that the base frames in all in-use stack pages have a sender and a saved context."
<var: #aPage type: #'StackPage *'>
0 to: numStackPages - 1 do:
[:i| | aPage senderContextOrNil savedThisContext |
aPage := stackPages stackPageAt: i.
(stackPages isFree: aPage) ifFalse:
[senderContextOrNil := stackPages longAt: aPage baseAddress.
savedThisContext := stackPages longAt: aPage baseAddress - BytesPerWord.
(self asserta: aPage baseFP + (self frameStackedReceiverOffset: aPage baseFP) + (2 * BytesPerWord) = aPage baseAddress) ifFalse:
[^false].
(self asserta: (objectMemory addressCouldBeObj: senderContextOrNil)) ifFalse:
[^false].
(self asserta: (objectMemory addressCouldBeObj: savedThisContext)) ifFalse:
[^false].
+ (self asserta: (senderContextOrNil = objectMemory nilObject or: [objectMemory isContext: senderContextOrNil])) ifFalse:
- (self asserta: (senderContextOrNil = objectMemory nilObject or: [self isContext: senderContextOrNil])) ifFalse:
[^false].
+ (self asserta: (objectMemory isContext: savedThisContext)) ifFalse:
- (self asserta: (self isContext: savedThisContext)) ifFalse:
[^false].
(self asserta: (self frameCallerContext: aPage baseFP) = senderContextOrNil) ifFalse:
[^false].
(self asserta: (self frameContext: aPage baseFP) = savedThisContext) ifFalse:
[^false]]].
^true!
Item was changed:
----- Method: CoInterpreterPrimitives>>primitiveResume (in category 'process primitives') -----
primitiveResume
"Put this process on the scheduler's lists thus allowing it to proceed next time there is
a chance for processes of it's priority level. It must go to the back of its run queue so
as not to preempt any already running processes at this level. If the process's priority
is higher than the current process, preempt the current process."
| proc inInterpreter |
proc := self stackTop. "rcvr"
+ (objectMemory isContext: (objectMemory fetchPointer: SuspendedContextIndex ofObject: proc)) ifFalse:
- (self isContext: (objectMemory fetchPointer: SuspendedContextIndex ofObject: proc)) ifFalse:
[^self primitiveFail].
"We're about to switch process, either to an interpreted frame or a
machine code frame. To know whether to return or enter machine code
we have to know from whence we came. We could have come from the
interpreter, either directly or via a machine code primitive. We could have
come from machine code. The instructionPointer tells us where from:"
inInterpreter := instructionPointer >= objectMemory startOfMemory.
(self resume: proc preemptedYieldingIf: preemptionYields from: CSResume) ifTrue:
[self forProcessPrimitiveReturnToExecutivePostContextSwitch: inInterpreter]
"Personally I would like to check MyList, which should not be one of the elements of the scheduler lists.
But there are awful race conditions in things like should:notTakeMoreThan: that mean we can't.
eem 9/27/2010 23:08. e.g.
| proc myList classLinkedList |
proc := self stackTop.
myList := objectMemory fetchPointer: MyListIndex ofObject: proc.
classLinkedList := self superclassOf: (objectMemory splObj: ClassSemaphore).
((self fetchClassOfNonInt: myList) ~= classLinkedList
+ and: [objectMemory isContext: (objectMemory fetchPointer: SuspendedContextIndex ofObject: proc)]) ifFalse:
- and: [self isContext: (objectMemory fetchPointer: SuspendedContextIndex ofObject: proc)]) ifFalse:
[^self primitiveFail].
''We're about to switch process, either to an interpreted frame or a
machine code frame. To know whether to return or enter machine code
we have to know from whence we came. We could have come from the
interpreter, either directly or via a machine code primitive. We could have
come from machine code. The instructionPointer tells us where from:''
inInterpreter := instructionPointer >= objectMemory startOfMemory.
(self resume: proc preemptedYieldingIf: preemptionYields from: CSResume) ifTrue:
[self forProcessPrimitiveReturnToExecutivePostContextSwitch: inInterpreter]"!
Item was changed:
----- Method: CoInterpreterPrimitives>>primitiveTerminateTo (in category 'control primitives') -----
primitiveTerminateTo
"Primitive. Terminate up the context stack from the receiver up to but not including
the argument, if previousContext is on my Context stack. Make previousContext my
sender. This prim has to shadow the code in ContextPart>terminateTo: to be correct.
Override to ensure the caller's saved ip is correct, i.e. if an interpreter frame it may
have to move to iframeSavedIP."
| thisCtx currentCtx aContextOrNil contextsFP contextsSP contextsIP nextCntx stackedReceiverOffset
theFP newFP newSP pageToStopOn thePage frameAbove |
<var: #contextsFP type: #'char *'>
<var: #theFP type: #'char *'>
<var: #newFP type: #'char *'>
<var: #newSP type: #'char *'>
<var: #contextsIP type: #usqInt>
<var: #frameAbove type: #'char *'>
<var: #contextsSP type: #'char *'>
<var: #source type: #'char *'>
<var: #pageToStopOn type: #'StackPage *'>
<var: #thePage type: #'StackPage *'>
aContextOrNil := self stackTop.
+ (aContextOrNil = objectMemory nilObject or: [objectMemory isContext: aContextOrNil]) ifFalse:
- (aContextOrNil = objectMemory nilObject or: [self isContext: aContextOrNil]) ifFalse:
[^self primitiveFail].
thisCtx := self stackValue: 1.
thisCtx = aContextOrNil ifTrue:
[^self primitiveFail].
"All stackPages need to have current head pointers to avoid confusion."
self externalWriteBackHeadFramePointers.
"If we're searching for aContextOrNil it might be on a stack page. Helps to know
if we can free a whole page or not, or if we can short-cut the termination."
(aContextOrNil ~= objectMemory nilObject and: [self isStillMarriedContext: aContextOrNil])
ifTrue: [contextsFP := self frameOfMarriedContext: aContextOrNil.
pageToStopOn := stackPages stackPageFor: contextsFP]
ifFalse: [pageToStopOn := 0].
"if thisCtx is married ensure it is a base frame. Then we can assign its sender."
(self isStillMarriedContext: thisCtx)
ifTrue:
[theFP := self frameOfMarriedContext: thisCtx.
"Optimize terminating thisContext. Move its frame down to be next to
aContextOrNil's frame. Common in the exception system and so helps to be fast."
(theFP = framePointer
and: [pageToStopOn = stackPage]) ifTrue:
[(self frameCallerFP: theFP) ~= contextsFP ifTrue:
[stackedReceiverOffset := self frameStackedReceiverOffset: theFP.
frameAbove := self findFrameAbove: contextsFP inPage: pageToStopOn.
contextsIP := (self frameCallerSavedIP: frameAbove) asUnsignedInteger.
self assert: ((contextsIP asUnsignedInteger >= objectMemory startOfMemory)
or: [contextsIP = cogit ceReturnToInterpreterPC]) == (self isMachineCodeFrame: contextsFP) not.
newSP := self frameCallerSP: frameAbove.
newFP := newSP - stackedReceiverOffset - BytesPerWord.
theFP + stackedReceiverOffset
to: stackPointer
by: BytesPerWord negated
do: [:source|
newSP := newSP - BytesPerWord.
stackPages longAt: newSP put: (stackPages longAt: source)].
stackPages longAt: newFP + FoxSavedFP put: contextsFP.
"Ensure contract between machine-code callee and interpreter caller frames is preserved.
Return pc needs to be ceReturnToInterpreterPC."
((self isMachineCodeFrame: newFP)
and: [contextsIP >= objectMemory startOfMemory]) ifTrue:
[self iframeSavedIP: contextsFP put: contextsIP.
contextsIP := cogit ceReturnToInterpreterPC].
stackPages longAt: newFP + FoxCallerSavedIP put: contextsIP.
+ self assert: (objectMemory isContext: thisCtx).
- self assert: (self isContext: thisCtx).
objectMemory storePointerUnchecked: SenderIndex
ofObject: thisCtx
withValue: (self withSmallIntegerTags: newFP).
objectMemory storePointerUnchecked: InstructionPointerIndex
ofObject: thisCtx
withValue: (self withSmallIntegerTags: contextsFP).
framePointer := newFP.
stackPointer := newSP].
self pop: 1.
self assert: stackPage = stackPages mostRecentlyUsedPage.
^nil].
theFP := self externalEnsureIsBaseFrame: theFP. "May cause a GC!!!!"
currentCtx := self frameCallerContext: theFP.
"May also reclaim aContextOrNil's page, hence..."
(aContextOrNil ~= objectMemory nilObject and: [self isStillMarriedContext: aContextOrNil])
ifTrue: [contextsFP := self frameOfMarriedContext: aContextOrNil.
pageToStopOn := stackPages stackPageFor: contextsFP]
ifFalse: [pageToStopOn := 0]]
ifFalse:
[currentCtx := objectMemory fetchPointer: SenderIndex ofObject: thisCtx].
(self context: thisCtx hasSender: aContextOrNil) ifTrue:
["Need to walk the stack freeing stack pages and nilling contexts."
[currentCtx = aContextOrNil
or: [currentCtx = objectMemory nilObject]] whileFalse:
+ [self assert: (objectMemory isContext: currentCtx).
- [self assert: (self isContext: currentCtx).
(self isMarriedOrWidowedContext: currentCtx)
ifTrue:
[theFP := self frameOfMarriedContext: currentCtx.
thePage := stackPages stackPageFor: theFP.
"If externalEnsureIsBaseFrame: above has moved thisContext to its own stack
then we will always terminate to a frame on a different page. But if we are
terminating some other context to a context somewhere on the current page
we must save the active frames above that context. Things will look e.g. like this:
thisCtx 499383332 s MethodContext(ContextPart)>resume:
499380484 s BlockClosure>ensure:
499377320 s MethodContext(ContextPart)>handleSignal:
499373760 s MethodContext(ContextPart)>handleSignal:
499372772 s MessageNotUnderstood(Exception)>signal
499369068 s CodeSimulationTests(Object)>doesNotUnderstand: absentMethod
499368708 s [] in CodeSimulationTests>testDNU
(sender is 0xbffc2480 I CodeSimulationTests>runSimulated:)
------------
framePointer 0xbffc234c M MethodContext(ContextPart)>doPrimitive:method:receiver:args:
0xbffc2378 M MethodContext(ContextPart)>tryPrimitiveFor:receiver:args:
0xbffc23ac M MethodContext(ContextPart)>send:to:with:super:
0xbffc23e4 M MethodContext(ContextPart)>send:super:numArgs:
0xbffc2418 M MethodContext(InstructionStream)>interpretNextInstructionFor:
0xbffc2434 M MethodContext(ContextPart)>step
0xbffc2458 I MethodContext(ContextPart)>runSimulated:contextAtEachStep:
------------
(499368708's sender) 0xbffc2480 I CodeSimulationTests>runSimulated:
0xbffc249c M CodeSimulationTests>testDNU
0xbffc24bc I CodeSimulationTests(TestCase)>performTest
0xbffc24dc I [] in CodeSimulationTests(TestCase)>runCase
aContextOrNil 0xbffc24fc M BlockClosure>ensure:
0xbffc2520 I CodeSimulationTests(TestCase)>runCase
0xbffc253c M [] in TestResult>runCase:
When we find this case we move the frames above to a new page by making the
frame above currentCtx a base frame, i.e. making 0xbffc2458 in the above example
a base frame. But in this iteration of the loop we don't move down a frame i.e. currentCtx
doesn't change on this iteration."
thePage = stackPage
ifTrue:
[frameAbove := self findFrameAbove: theFP inPage: thePage.
self assert: frameAbove ~= 0.
frameAbove := self externalEnsureIsBaseFrame: frameAbove. "May cause a GC!!!! May also reclaim aContextOrNil's page, hence..."
(aContextOrNil ~= objectMemory nilObject and: [self isStillMarriedContext: aContextOrNil])
ifTrue: [contextsFP := self frameOfMarriedContext: aContextOrNil.
pageToStopOn := stackPages stackPageFor: contextsFP]
ifFalse: [pageToStopOn := 0]]
ifFalse:
[thePage = pageToStopOn
ifTrue:
["We're here. Cut back the stack to aContextOrNil's frame,
push its instructionPointer if it's not already a head frame,
and we're done."
frameAbove := self findFrameAbove: contextsFP inPage: thePage.
frameAbove ~= 0 ifTrue:
[contextsSP := (self frameCallerSP: frameAbove) - BytesPerWord.
stackPages longAt: contextsSP put: (self frameCallerSavedIP: frameAbove).
self setHeadFP: contextsFP andSP: contextsSP inPage: thePage].
currentCtx := aContextOrNil]
ifFalse:
["We can free the entire page without further ado."
currentCtx := self frameCallerContext: thePage baseFP.
"for a short time invariant is violated; assert follows"
stackPages freeStackPageNoAssert: thePage]]]
ifFalse:
[nextCntx := objectMemory fetchPointer: SenderIndex ofObject: currentCtx.
self markContextAsDead: currentCtx.
currentCtx := nextCntx]]].
self assert: stackPages pageListIsWellFormed.
(self isMarriedOrWidowedContext: thisCtx)
ifTrue:
[self assert: (self checkIsStillMarriedContext: thisCtx currentFP: framePointer).
self assert: (self isBaseFrame: (self frameOfMarriedContext: thisCtx)).
theFP := self frameOfMarriedContext: thisCtx.
self frameCallerContext: theFP put: aContextOrNil]
ifFalse: [objectMemory storePointer: SenderIndex ofObject: thisCtx withValue: aContextOrNil].
self pop: 1.
self assert: stackPage = stackPages mostRecentlyUsedPage!
Item was added:
+ Object subclass: #CogCheck32BitHeapMap
+ instanceVariableNames: 'pages'
+ classVariableNames: 'NumPages PageMask PageShift PageSize'
+ poolDictionaries: ''
+ category: 'VMMaker-InterpreterSimulation'!
+
+ !CogCheck32BitHeapMap commentStamp: 'eem 2/27/2013 16:26' prior: 0!
+ A CogCheckHeapMap is a simulation of the code in platforms/Cross/vm/sqHeapMap.c. This is a map for leak checking that allocates 1 bit for every 4 bytes of address space. It uses an array of pages to keep space overhead low, only allocating a page if that portion of the address space is used. So the maximum overhead is address space size / (word size * bits per byte), or (2 raisedTo: 32) / (4 * 8) or 134,217,728 bytes.
+
+ Instance Variables
+ pages: <Array of: ByteArray>
+
+ pages
+ - array of pages of bits, 1 bit per word of address space
+ !
Item was added:
+ ----- Method: CogCheck32BitHeapMap class>>initialize (in category 'class initialization') -----
+ initialize
+ "self initialize"
+ | wordSize bitsPerByte |
+ wordSize := 4. "4 bytes per bit in the map"
+ bitsPerByte := 8.
+ NumPages := 256.
+ PageShift := -24. "32 - (NumPages log: 2)"
+ PageSize := 2 << 32 / wordSize / NumPages / bitsPerByte.
+ PageMask := PageSize - 1!
Item was added:
+ ----- Method: CogCheck32BitHeapMap>>bitIndex: (in category 'accessing') -----
+ bitIndex: address
+ ^(address bitShift: -2) bitAnd: 7!
Item was added:
+ ----- Method: CogCheck32BitHeapMap>>byteIndex: (in category 'accessing') -----
+ byteIndex: address
+ ^((address bitShift: -2) bitAnd: PageMask) + 1!
Item was added:
+ ----- Method: CogCheck32BitHeapMap>>clearHeapMap (in category 'accessing') -----
+ clearHeapMap
+ pages do:
+ [:p| p ifNotNil: [p atAllPut: 0]]!
Item was added:
+ ----- Method: CogCheck32BitHeapMap>>heapMapAtWord: (in category 'accessing') -----
+ heapMapAtWord: address
+ "answer the bit corresponding to address aBit in the map"
+ ^(pages at: (self pageIndex: address))
+ ifNil: [0]
+ ifNotNil:
+ [:page|
+ ((page at: (self byteIndex: address))
+ bitShift: 0 - (self bitIndex: address))
+ bitAnd: 1]!
Item was added:
+ ----- Method: CogCheck32BitHeapMap>>heapMapAtWord:Put: (in category 'accessing') -----
+ heapMapAtWord: address Put: aBit
+ "set the bit corresponding to address in the map to aBit"
+ | pageIndex page bitIndex byte byteIndex |
+ pageIndex := self pageIndex: address.
+ page := pages at: pageIndex.
+ page ifNil:
+ [page := pages at: pageIndex put: (ByteArray new: PageSize)].
+ byteIndex := self byteIndex: address.
+ bitIndex := self bitIndex: address.
+ byte := page at: byteIndex.
+ byte := aBit = 0
+ ifTrue: [byte - (byte bitAnd: 1 << bitIndex)]
+ ifFalse: [byte bitOr: 1 << bitIndex].
+ page at: byteIndex put: byte!
Item was added:
+ ----- Method: CogCheck32BitHeapMap>>initialize (in category 'instance initialization') -----
+ initialize
+ pages := Array new: 256!
Item was added:
+ ----- Method: CogCheck32BitHeapMap>>pageIndex: (in category 'accessing') -----
+ pageIndex: address
+ ^(address bitShift: PageShift) + 1 "32 - (pageSize log: 2)"!
Item was added:
+ ----- Method: CogCheck32BitHeapMap>>pageSize (in category 'accessing') -----
+ pageSize
+ self shouldBeImplemented!
Item was changed:
----- Method: CogVMSimulator>>methodForContext: (in category 'simulation only') -----
methodForContext: aContextOop
+ self assert: (objectMemory isContext: aContextOop).
- self assert: (self isContext: aContextOop).
^objectMemory fetchPointer: MethodIndex ofObject: aContextOop!
Item was added:
+ TestCase subclass: #HeapMapTest
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'VMMaker-Tests'!
Item was added:
+ ----- Method: HeapMapTest>>test32BitHeapMap (in category 'tests') -----
+ test32BitHeapMap
+ | heapMap |
+ heapMap := CogCheck32BitHeapMap new.
+
+ "all bits shoud be clear in a new map"
+ 0 to: 1024 * 1024 - 4 by: 4 do:
+ [:addr| self assert: (heapMap heapMapAtWord: addr) = 0].
+ (2 raisedTo: 30) to: 1024 * 1024 - 4 + (2 raisedTo: 30) by: 4 do:
+ [:addr| self assert: (heapMap heapMapAtWord: addr) = 0].
+
+ "set every 9th bit to 1"
+ 0 to: 1024 * 1024 - 4 by: 36 do:
+ [:addr| heapMap heapMapAtWord: addr Put: 1].
+ (2 raisedTo: 30) to: 1024 * 1024 - 4 + (2 raisedTo: 30) by:36 do:
+ [:addr| heapMap heapMapAtWord: addr Put: 1].
+
+ "check every 9th bit is set and all intervening bits are zero"
+ 0 to: 1024 * 1024 - 4 by: 36 do:
+ [:addr|
+ addr - 32 > 0 ifTrue:
+ [addr - 32 to: addr - 4 by: 4 do:
+ [:zeroAddr| self assert: (heapMap heapMapAtWord: zeroAddr) = 0]].
+ self assert: (heapMap heapMapAtWord: addr) = 1].
+
+ (2 raisedTo: 30) to: 1024 * 1024 - 4 + (2 raisedTo: 30) by:36 do:
+ [:addr|
+ addr - 32 > 0 ifTrue:
+ [addr - 32 to: addr - 4 by: 4 do:
+ [:zeroAddr| self assert: (heapMap heapMapAtWord: zeroAddr) = 0]].
+ self assert: (heapMap heapMapAtWord: addr) = 1].
+
+ "clear the bits"
+ 0 to: 1024 * 1024 - 4 by: 36 do:
+ [:addr| heapMap heapMapAtWord: addr Put: 0].
+ (2 raisedTo: 30) to: 1024 * 1024 - 4 + (2 raisedTo: 30) by:36 do:
+ [:addr| heapMap heapMapAtWord: addr Put: 0].
+
+ "check everything is zero again"
+ 0 to: 1024 * 1024 - 4 by: 4 do:
+ [:addr| self assert: (heapMap heapMapAtWord: addr) = 0].
+ (2 raisedTo: 30) to: 1024 * 1024 - 4 + (2 raisedTo: 30) by: 4 do:
+ [:addr| self assert: (heapMap heapMapAtWord: addr) = 0]!
Item was removed:
- ----- Method: Interpreter>>isContext: (in category 'contexts') -----
- isContext: oop
- <inline: true>
- ^(self isNonIntegerObject: oop) and: [self isContextHeader: (self baseHeader: oop)]!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveClosureValue (in category 'control primitives') -----
primitiveClosureValue
| blockClosure numArgs closureMethod outerContext |
blockClosure := self stackValue: argumentCount.
numArgs := self argumentCountOfClosure: blockClosure.
argumentCount = numArgs ifFalse:
[^self primitiveFail].
"Somewhat paranoiac checks we need while debugging that we may be able to discard
in a robust system."
outerContext := objectMemory fetchPointer: ClosureOuterContextIndex ofObject: blockClosure.
+ (objectMemory isContext: outerContext) ifFalse:
- (self isContext: outerContext) ifFalse:
[^self primitiveFail].
closureMethod := objectMemory fetchPointer: MethodIndex ofObject: outerContext.
"Check if the closure's method is actually a CompiledMethod."
(objectMemory isOopCompiledMethod: closureMethod) ifFalse:
[^self primitiveFail].
"Note we use activateNewMethod, not executeNewMethod, to avoid
quickCheckForInterrupts. Don't check until we have a full activation."
self activateNewClosureMethod: blockClosure numArgs: numArgs mayContextSwitch: true!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveClosureValueNoContextSwitch (in category 'control primitives') -----
primitiveClosureValueNoContextSwitch
"An exact clone of primitiveClosureValue except that this version will not
check for interrupts on stack overflow. It may invoke the garbage collector
but will not switch processes. See checkForInterruptsMayContextSwitch:"
| blockClosure numArgs closureMethod outerContext |
blockClosure := self stackValue: argumentCount.
numArgs := self argumentCountOfClosure: blockClosure.
argumentCount = numArgs ifFalse:
[^self primitiveFail].
"Somewhat paranoiac checks we need while debugging that we may be able to discard
in a robust system."
outerContext := objectMemory fetchPointer: ClosureOuterContextIndex ofObject: blockClosure.
+ (objectMemory isContext: outerContext) ifFalse:
- (self isContext: outerContext) ifFalse:
[^self primitiveFail].
closureMethod := objectMemory fetchPointer: MethodIndex ofObject: outerContext.
"Check if the closure's method is actually a CompiledMethod."
(objectMemory isOopCompiledMethod: closureMethod) ifFalse:
[^self primitiveFail].
"Note we use activateNewMethod, not executeNewMethod, to avoid
quickCheckForInterrupts. Don't check until we have a full activation."
self activateNewClosureMethod: blockClosure numArgs: numArgs mayContextSwitch: false!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveClosureValueWithArgs (in category 'control primitives') -----
primitiveClosureValueWithArgs
| argumentArray arraySize blockClosure numArgs closureMethod index outerContext |
argumentArray := self stackTop.
(objectMemory isArray: argumentArray) ifFalse:
[^self primitiveFail].
"Check for enough space in thisContext to push all args"
arraySize := objectMemory fetchWordLengthOf: argumentArray.
(self roomToPushNArgs: arraySize) ifFalse:
[^self primitiveFail].
blockClosure := self stackValue: argumentCount.
numArgs := self argumentCountOfClosure: blockClosure.
arraySize = numArgs ifFalse:
[^self primitiveFail].
"Somewhat paranoiac checks we need while debugging that we may be able to discard
in a robust system."
outerContext := objectMemory fetchPointer: ClosureOuterContextIndex ofObject: blockClosure.
+ (objectMemory isContext: outerContext) ifFalse:
- (self isContext: outerContext) ifFalse:
[^self primitiveFail].
closureMethod := objectMemory fetchPointer: MethodIndex ofObject: outerContext.
"Check if the closure's method is actually a CompiledMethod."
(objectMemory isOopCompiledMethod: closureMethod) ifFalse:
[^self primitiveFail].
self popStack.
"Copy the arguments to the stack, and activate"
index := 1.
[index <= numArgs]
whileTrue:
[self push: (objectMemory fetchPointer: index - 1 ofObject: argumentArray).
index := index + 1].
"Note we use activateNewMethod, not executeNewMethod, to avoid
quickCheckForInterrupts. Don't check until we have a full activation."
self activateNewClosureMethod: blockClosure numArgs: numArgs mayContextSwitch: true!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveResume (in category 'process primitives') -----
primitiveResume
"Put this process on the scheduler's lists thus allowing it to proceed next time there is
a chance for processes of it's priority level. It must go to the back of its run queue so
as not to preempt any already running processes at this level. If the process's priority
is higher than the current process, preempt the current process."
| proc |
proc := self stackTop. "rcvr"
+ (objectMemory isContext: (objectMemory fetchPointer: SuspendedContextIndex ofObject: proc)) ifFalse:
- (self isContext: (objectMemory fetchPointer: SuspendedContextIndex ofObject: proc)) ifFalse:
[^self primitiveFail].
self resume: proc preemptedYieldingIf: preemptionYields
"Personally I would like to check MyList, which should not be one of the elements of the scheduler lists.
But there are awful race conditions in things like should:notTakeMoreThan: that mean we can't.
eem 9/27/2010 23:08. e.g.
| proc myList classLinkedList |
proc := self stackTop.
myList := objectMemory fetchPointer: MyListIndex ofObject: proc.
classLinkedList := self superclassOf: (objectMemory splObj: ClassSemaphore).
((self fetchClassOfNonInt: myList) ~= classLinkedList
+ and: [objectMemory isContext: (objectMemory fetchPointer: SuspendedContextIndex ofObject: proc)]) ifFalse:
- and: [self isContext: (objectMemory fetchPointer: SuspendedContextIndex ofObject: proc)]) ifFalse:
[^self primitiveFail].
self resume: proc preemptedYieldingIf: preemptionYields"!
Item was changed:
----- Method: NewCoObjectMemory>>clearLeakMapAndMapAccessibleObjects (in category 'object enumeration') -----
clearLeakMapAndMapAccessibleObjects
"Perform an integrity/leak check using the heapMap. Set a bit at each object's header.
Override to set a bit at each Cog method"
+ super clearLeakMapAndMapAccessibleObjects.
- | obj sz nextHeader |
- <inline: false>
- <var: #obj type: #usqInt>
- <var: #sz type: #usqInt>
- <var: #nextHeader type: #usqInt>
- self clearHeapMap.
- obj := self firstObject.
- [obj < freeStart] whileTrue:
- [(self isFreeObject: obj)
- ifTrue:
- [sz := self sizeOfFree: obj]
- ifFalse:
- [self heapMapAtWord: (self pointerForOop: obj) Put: 1.
- sz := self sizeBitsOf: obj].
- nextHeader := obj + sz.
- obj := self oopFromChunk: nextHeader].
cogit addCogMethodsToHeapMap!
Item was added:
+ ----- Method: NewCoObjectMemorySimulator>>eek (in category 'memory access') -----
+ eek
+ self halt!
Item was changed:
ObjectMemory subclass: #NewObjectMemory
+ instanceVariableNames: 'coInterpreter freeStart reserveStart scavengeThreshold needGCFlag fullGCLock edenBytes checkForLeaks statGCEndUsecs heapMap'
- instanceVariableNames: 'coInterpreter freeStart reserveStart scavengeThreshold needGCFlag fullGCLock edenBytes checkForLeaks statGCEndUsecs'
classVariableNames: 'AllocationCheckFiller'
poolDictionaries: ''
category: 'VMMaker-Interpreter'!
!NewObjectMemory commentStamp: '<historical>' prior: 0!
I am a refinement of ObjectMemory that eliminates the need for pushRemappableOop:/popRemappableOop in the interpreter proper. Certain primitives that do major allocation may still want to provoke a garbage collection and hence may still need to remap private pointers. But the interpreter subclass of this class does not have to provided it reserves sufficient space for it to make progress to the next scavenge point (send or backward branch).!
Item was changed:
----- Method: NewObjectMemory>>checkHeapIntegrity (in category 'memory access') -----
checkHeapIntegrity
"Perform an integrity/leak check using the heapMap. Assume
clearLeakMapAndMapAccessibleObjects has set a bit at each
object's header. Scan all objects in the heap checking that every
pointer points to a header. Scan the rootTable, remapBuffer and
extraRootTable checking that every entry is a pointer to a header.
Check that the number of roots is correct and that all rootTable
entries have their rootBit set. Answer if all checks pass."
| ok obj sz hdr fmt fi fieldOop numRootsInHeap |
<inline: false>
ok := true.
numRootsInHeap := 0.
obj := self firstObject.
[self oop: obj isLessThan: self startOfFreeSpace] whileTrue:
[(self isFreeObject: obj)
ifTrue:
[sz := self sizeOfFree: obj]
ifFalse:
[hdr := self baseHeader: obj.
(self isYoungRootHeader: hdr) ifTrue:
[numRootsInHeap := numRootsInHeap + 1].
(self compactClassIndexOfHeader: hdr) = 0 ifTrue:
[fieldOop := (self classHeader: obj) bitAnd: AllButTypeMask.
((self isIntegerObject: fieldOop)
+ or: [(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) = 0]) ifTrue:
- or: [(self heapMapAtWord: (self pointerForOop: fieldOop)) = 0]) ifTrue:
[self print: 'object leak in '; printHex: obj; print: ' class = '; printHex: fieldOop; cr.
+ self eek.
ok := false]].
fmt := self formatOfHeader: hdr.
(fmt <= 4 "pointers" or: [fmt >= 12 "compiled method"]) ifTrue:
[fmt >= 12
ifTrue: [fi := (self literalCountOf: obj) + 1 "+ 1 = methodHeader slot"]
ifFalse: [(fmt = 3 and: [self isContextHeader: hdr])
+ ifTrue: [fi := CtxtTempFrameStart + (coInterpreter fetchStackPointerOf: obj)]
- ifTrue: [fi := CtxtTempFrameStart + (self fetchStackPointerOf: obj)]
ifFalse: [fi := self lengthOf: obj]].
[(fi := fi - 1) >= 0] whileTrue:
[fieldOop := self fetchPointer: fi ofObject: obj.
(self isNonIntegerObject: fieldOop) ifTrue:
[(fieldOop bitAnd: BytesPerWord - 1) ~= 0
ifTrue:
[self print: 'misaligned oop in '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; cr.
+ self eek.
ok := false]
ifFalse:
+ [(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) = 0 ifTrue:
- [(self heapMapAtWord: (self pointerForOop: fieldOop)) = 0 ifTrue:
[self print: 'object leak in '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; cr.
+ self eek.
ok := false]]]]].
sz := self sizeBitsOf: obj].
obj := self oopFromChunk: obj + sz].
numRootsInHeap ~= rootTableCount ifTrue:
[self print: 'root count mismatch. #heap roots '; printNum: numRootsInHeap; print: '; #roots '; printNum: rootTableCount; cr.
"But the system copes with overflow..."
ok := rootTableOverflowed and: [needGCFlag]].
1 to: rootTableCount do:
[:ri|
obj := rootTable at: ri.
(obj bitAnd: BytesPerWord - 1) ~= 0
ifTrue:
[self print: 'misaligned oop in rootTable @ '; printNum: ri; print: ' = '; printHex: obj; cr.
+ self eek.
ok := false]
ifFalse:
+ [(heapMap heapMapAtWord: (self pointerForOop: obj)) = 0
- [(self heapMapAtWord: (self pointerForOop: obj)) = 0
ifTrue:
[self print: 'object leak in rootTable @ '; printNum: ri; print: ' = '; printHex: obj; cr.
+ self eek.
ok := false]
ifFalse:
[hdr := self baseHeader: obj.
(self isYoungRootHeader: hdr) ifFalse:
[self print: 'non-root in rootTable @ '; printNum: ri; print: ' = '; printHex: obj; cr.
+ self eek.
ok := false]]]].
1 to: remapBufferCount do:
[:ri|
obj := remapBuffer at: ri.
(obj bitAnd: BytesPerWord - 1) ~= 0
ifTrue:
[self print: 'misaligned remapRoot @ '; printNum: ri; print: ' = '; printHex: obj; cr.
+ self eek.
ok := false]
ifFalse:
+ [(heapMap heapMapAtWord: (self pointerForOop: obj)) = 0
- [(self heapMapAtWord: (self pointerForOop: obj)) = 0
ifTrue:
[self print: 'object leak in remapRoots @ '; printNum: ri; print: ' = '; printHex: obj; cr.
+ self eek.
ok := false]]].
1 to: extraRootCount do:
[:ri|
obj := (extraRoots at: ri) at: 0.
(obj bitAnd: BytesPerWord - 1) ~= 0
ifTrue:
[self print: 'misaligned extraRoot @ '; printNum: ri; print: ' => '; printHex: obj; cr.
+ self eek.
ok := false]
ifFalse:
+ [(heapMap heapMapAtWord: (self pointerForOop: obj)) = 0
- [(self heapMapAtWord: (self pointerForOop: obj)) = 0
ifTrue:
[self print: 'object leak in extraRoots @ '; printNum: ri; print: ' => '; printHex: obj; cr.
+ self eek.
ok := false]]].
^ok!
Item was changed:
----- Method: NewObjectMemory>>clearLeakMapAndMapAccessibleObjects (in category 'object enumeration') -----
clearLeakMapAndMapAccessibleObjects
"Perform an integrity/leak check using the heapMap. Set a bit at each object's header."
+ | obj sz nextHeader |
- | obj sz |
<inline: false>
+ <var: #obj type: #usqInt>
+ <var: #sz type: #usqInt>
+ <var: #nextHeader type: #usqInt>
+ heapMap clearHeapMap.
- self clearHeapMap.
obj := self firstObject.
[self oop: obj isLessThan: freeStart] whileTrue:
[(self isFreeObject: obj)
ifTrue:
[sz := self sizeOfFree: obj]
ifFalse:
+ [heapMap heapMapAtWord: (self pointerForOop: obj) Put: 1.
- [self heapMapAtWord: (self pointerForOop: obj) Put: 1.
sz := self sizeBitsOf: obj].
+ nextHeader := obj + sz.
+ obj := self oopFromChunk: nextHeader].!
- obj := self oopFromChunk: obj + sz]!
Item was changed:
----- Method: NewObjectMemory>>clone: (in category 'allocation') -----
clone: obj
"Return a shallow copy of the given object. May cause GC"
"Assume: Oop is a real object, not a small integer.
Override to assert it's not a married context"
+ self assert: ((self isContext: obj) not
- self assert: ((coInterpreter isContext: obj) not
or: [(coInterpreter isMarriedOrWidowedContext: obj) not]).
^super clone: obj!
Item was changed:
----- Method: NewObjectMemory>>eeInstantiateMethodContextByteSize: (in category 'interpreter access') -----
eeInstantiateMethodContextByteSize: sizeInBytes
"This version of instantiateClass assumes that the total object
size is under 256 bytes, the limit for objects with only one or
two header words. Note that the size is specified in bytes
and should include four bytes for the base header word.
Will *not* cause a GC."
| hash header1 |
+ self assert: (sizeInBytes == SmallContextSize or: [sizeInBytes == LargeContextSize]).
- hash := self newObjectHash.
- header1 := (hash bitAnd: HashMaskUnshifted) << HashBitsOffset bitOr: self formatOfMethodContext.
self assert: sizeInBytes <= SizeMask.
+ hash := self newObjectHash.
+ header1 := (hash bitAnd: HashMaskUnshifted) << HashBitsOffset bitOr: self formatOfMethodContextMinusSize.
self assert: (header1 bitAnd: CompactClassMask) > 0. "contexts must be compact"
+ self assert: (header1 bitAnd: SizeMask) = 0.
"OR size into header1. Must not do this if size > SizeMask"
+ header1 := header1 + sizeInBytes.
- header1 := header1 + (sizeInBytes - (header1 bitAnd: SizeMask)).
- self flag: #Dan. "Check details of context sizes"
^self eeAllocate: sizeInBytes headerSize: 1 h1: header1 h2: nil h3: nil!
Item was added:
+ ----- Method: NewObjectMemory>>eek (in category 'memory access') -----
+ eek
+ <inline: true>!
Item was added:
+ ----- Method: NewObjectMemory>>fixContextSizes (in category 'initialization') -----
+ fixContextSizes
+ "Correct context sizes at start-up."
+ | numBadContexts obj oop map delta hdr len i methodContextProtoIndex methodContextProto |
+ <var: #map type: #'sqInt *'>
+ methodContextProto := self splObj: (methodContextProtoIndex := 35).
+ ((self isContext: methodContextProto)
+ and: [self badContextSize: methodContextProto]) ifTrue:
+ [self splObj: methodContextProtoIndex put: nilObj.
+ "If it is unreferenced except here; nuke it, otherwise resize it"
+ (self numReferencesTo: methodContextProto) = 0 ifTrue:
+ [self freeObject: methodContextProto]].
+ "Count the number of bad contexts"
+ numBadContexts := 0.
+ obj := self firstObject.
+ [obj < freeStart] whileTrue:
+ [((self isFreeObject: obj) not
+ and: [(self isContextNonInt: obj)
+ and: [self badContextSize: obj]]) ifTrue:
+ [numBadContexts := numBadContexts + 1].
+ obj := self objectAfter: obj].
+ numBadContexts = 0 ifTrue:
+ [^self].
+ "Allocate a map of pairs of context obj and how much it has to move."
+ map := self cCode: [self malloc: numBadContexts + 1 * 2 * BytesPerOop]
+ inSmalltalk: [CArrayAccessor on: (Array new: numBadContexts + 1 * 2)].
+ "compute the map"
+ numBadContexts := 0.
+ delta := 0.
+ obj := self firstObject.
+ [obj < freeStart] whileTrue:
+ [((self isFreeObject: obj) not
+ and: [(self isContextNonInt: obj)
+ and: [self badContextSize: obj]]) ifTrue:
+ [delta := ((self byteLengthOf: obj) > SmallContextSize
+ ifTrue: [LargeContextSize]
+ ifFalse: [SmallContextSize]) - (self byteLengthOf: obj).
+ map at: numBadContexts put: (self objectAfter: obj).
+ numBadContexts = 0
+ ifTrue: [map at: numBadContexts + 1 put: delta]
+ ifFalse: [map at: numBadContexts + 1 put: delta + (map at: numBadContexts - 1)].
+ numBadContexts := numBadContexts + 2].
+ obj := self objectAfter: obj].
+ "block-move the segments to make room for the resized contexts"
+ map at: numBadContexts put: freeStart.
+ self assert: freeStart = youngStart. "designed to be run at startup"
+ freeStart := freeStart + (map at: numBadContexts - 1).
+ youngStart := freeStart.
+ [(numBadContexts := numBadContexts - 2) >= 0] whileTrue:
+ [obj := map at: numBadContexts.
+ oop := map at: numBadContexts + 2.
+ self mem: "dest" obj + (map at: numBadContexts + 1)
+ mo: "src" obj
+ ve: "len" oop - obj].
+ "now fix-up objs, resizing wrongly-sized contexts along the way."
+ obj := self firstObject.
+ [obj < freeStart] whileTrue:
+ [(self isFreeObject: obj) not ifTrue:
+ [((self isContextNonInt: obj)
+ and: [self badContextSize: obj]) ifTrue:
+ [hdr := self baseHeader: obj.
+ len := (hdr bitAnd: SizeMask) > SmallContextSize ifTrue: [LargeContextSize] ifFalse: [SmallContextSize].
+ self baseHeader: obj put: ((hdr bitClear: SizeMask) bitOr: len).
+ "now check the enumeration"
+ oop := self objectAfter: obj.
+ self assert: oop <= freeStart.
+ numBadContexts := 0.
+ [oop > (map at: numBadContexts)] whileTrue:
+ [numBadContexts := numBadContexts + 2].
+ self assert: oop = ((map at: numBadContexts) + (map at: numBadContexts + 1))].
+ (self headerType: obj) ~= HeaderTypeShort ifTrue: "see remapClassOf:"
+ [oop := (hdr := self longAt: obj - BytesPerWord) bitAnd: AllButTypeMask.
+ oop >= (map at: 0) ifTrue:
+ [numBadContexts := 2.
+ [oop >= (map at: numBadContexts)] whileTrue:
+ [numBadContexts := numBadContexts + 2].
+ hdr := oop + (map at: numBadContexts - 1) + (hdr bitAnd: TypeMask).
+ self longAt: obj - BytesPerWord put: hdr]].
+ ((self isPointersNonInt: obj) or: [self isCompiledMethod: obj]) ifTrue:
+ [(self isCompiledMethod: obj)
+ ifTrue:
+ [i := self literalCountOf: obj]
+ ifFalse:
+ [(self isContextNonInt: obj)
+ ifTrue: [i := CtxtTempFrameStart + (coInterpreter fetchStackPointerOf: obj)]
+ ifFalse: [i := self lengthOf: obj]].
+ [(i := i - 1) >= 0] whileTrue:
+ [oop := self fetchPointer: i ofObject: obj.
+ ((self isNonIntegerObject: oop)
+ and: [oop >= (map at: 0)]) ifTrue:
+ [numBadContexts := 2.
+ [oop >= (map at: numBadContexts)] whileTrue:
+ [numBadContexts := numBadContexts + 2].
+ self storePointerUnchecked: i ofObject: obj withValue: oop + (map at: numBadContexts - 1)]]]].
+ obj := self objectAfter: obj].
+ self clearLeakMapAndMapAccessibleObjects.
+ (self asserta: self checkHeapIntegrity) ifFalse:
+ [self error: 'failed to resize contexts correctly']!
Item was added:
+ ----- Method: NewObjectMemory>>formatOfMethodContextMinusSize (in category 'frame access') -----
+ formatOfMethodContextMinusSize
+ "Answer the class format word for MethodContext which is used to instantiate
+ contexts without needing to fetch it from the class MethodContext itself."
+ ^(ClassMethodContextCompactIndex << 12)
+ + (3 << 8) "Pointers+Variable"!
Item was changed:
----- Method: NewObjectMemory>>initialize (in category 'initialization') -----
initialize
<doNotGenerate>
"Initialize NewObjectMemory when simulating the VM inside Smalltalk."
super initialize.
checkForLeaks := fullGCLock := 0.
+ needGCFlag := false.
+ heapMap := CogCheck32BitHeapMap new!
- needGCFlag := false!
Item was changed:
----- Method: NewObjectMemory>>longPrintReferencesTo: (in category 'debug printing') -----
longPrintReferencesTo: anOop
"Scan the heap long printing the oops of any and all objects that refer to anOop"
| oop i prntObj |
<api>
prntObj := false.
oop := self firstAccessibleObject.
[oop = nil] whileFalse:
+ [((self isPointersNonInt: oop) or: [self isCompiledMethod: oop]) ifTrue:
- [((self isPointers: oop) or: [self isCompiledMethod: oop]) ifTrue:
[(self isCompiledMethod: oop)
ifTrue:
[i := self literalCountOf: oop]
ifFalse:
+ [(self isContextNonInt: oop)
- [(coInterpreter isContext: oop)
ifTrue: [i := CtxtTempFrameStart + (coInterpreter fetchStackPointerOf: oop)]
ifFalse: [i := self lengthOf: oop]].
[(i := i - 1) >= 0] whileTrue:
[anOop = (self fetchPointer: i ofObject: oop) ifTrue:
[self printHex: oop; print: ' @ '; printNum: i; cr.
prntObj := true.
i := 0]].
prntObj ifTrue:
[prntObj := false.
coInterpreter longPrintOop: oop]].
oop := self accessibleObjectAfter: oop]!
Item was added:
+ ----- Method: NewObjectMemory>>numReferencesTo: (in category 'debug printing') -----
+ numReferencesTo: anOop
+ "Answer the number of objects that refer to anOop, other than anOop."
+ | oop i n |
+ oop := self firstAccessibleObject.
+ n := 0.
+ [oop = nil] whileFalse:
+ [((self isPointersNonInt: oop) or: [self isCompiledMethod: oop]) ifTrue:
+ [(self isCompiledMethod: oop)
+ ifTrue:
+ [i := self literalCountOf: oop]
+ ifFalse:
+ [(self isContextNonInt: oop)
+ ifTrue: [i := CtxtTempFrameStart + (coInterpreter fetchStackPointerOf: oop)]
+ ifFalse: [i := self lengthOf: oop]].
+ [(i := i - 1) >= 0] whileTrue:
+ [anOop = (self fetchPointer: i ofObject: oop) ifTrue:
+ [anOop ~= oop ifTrue:
+ [n := n + 1].
+ i := 0]]].
+ oop := self accessibleObjectAfter: oop].
+ ^n!
Item was changed:
----- Method: NewObjectMemory>>printReferencesTo: (in category 'debug printing') -----
printReferencesTo: anOop
"Scan the heap printing the oops of any and all objects that refer to anOop"
| oop i |
<api>
oop := self firstAccessibleObject.
[oop = nil] whileFalse:
+ [((self isPointersNonInt: oop) or: [self isCompiledMethod: oop]) ifTrue:
- [((self isPointers: oop) or: [self isCompiledMethod: oop]) ifTrue:
[(self isCompiledMethod: oop)
ifTrue:
[i := self literalCountOf: oop]
ifFalse:
+ [(self isContextNonInt: oop)
- [(coInterpreter isContext: oop)
ifTrue: [i := CtxtTempFrameStart + (coInterpreter fetchStackPointerOf: oop)]
ifFalse: [i := self lengthOf: oop]].
[(i := i - 1) >= 0] whileTrue:
[anOop = (self fetchPointer: i ofObject: oop) ifTrue:
[self interpreter printHex: oop; print: ' @ '; printNum: i; space; printOopShort: oop; cr.
i := 0]]].
oop := self accessibleObjectAfter: oop]!
Item was added:
+ ----- Method: NewObjectMemory>>printWronglySizedContexts (in category 'debug printing') -----
+ printWronglySizedContexts
+ "Override. We implement printWronglySizedContexts:"
+ <doNotGenerate>
+ super printWronglySizedContexts!
Item was added:
+ ----- Method: NewObjectMemory>>printWronglySizedContexts: (in category 'debug printing') -----
+ printWronglySizedContexts: printContexts
+ "Scan the heap printing the oops of any and all contexts whose size is not either SmallContextSize or LargeContextSize"
+ | oop |
+ <api>
+ oop := self firstAccessibleObject.
+ [oop = nil] whileFalse:
+ [((self isContextNonInt: oop)
+ and: [self badContextSize: oop]) ifTrue:
+ [self printHex: oop; space; printNum: (self byteLengthOf: oop); cr.
+ printContexts ifTrue:
+ [coInterpreter printContext: oop]].
+ oop := self accessibleObjectAfter: oop]!
Item was changed:
----- Method: NewObjectMemory>>shorten:toIndexableSize: (in category 'allocation') -----
shorten: obj toIndexableSize: nSlots
"Currently this works for pointer objects only, and is almost certainly wrong for 64 bits."
| deltaBytes desiredLength fixedFields fmt hdr totalLength |
+ (self isPointersNonInt: obj) ifFalse:
- (self isPointers: obj) ifFalse:
[^obj].
hdr := self baseHeader: obj.
fmt := self formatOfHeader: hdr.
totalLength := self lengthOf: obj baseHeader: hdr format: fmt.
fixedFields := self fixedFieldsOf: obj format: fmt length: totalLength.
desiredLength := fixedFields + nSlots.
deltaBytes := (totalLength - desiredLength) * BytesPerWord.
obj + BaseHeaderSize + (totalLength * BytesPerWord) = freeStart
ifTrue: "Shortening the last object. Need to reduce freeStart."
[self maybeFillWithAllocationCheckFillerFrom: obj + BaseHeaderSize + (desiredLength * BytesPerWord) to: freeStart.
freeStart := obj + BaseHeaderSize + (desiredLength * BytesPerWord)]
ifFalse: "Shortening some interior object. Need to create a free block."
[self setSizeOfFree: obj + BaseHeaderSize + (desiredLength * BytesPerWord)
to: deltaBytes].
(self headerType: obj) caseOf: {
[HeaderTypeSizeAndClass] ->
[self longAt: obj put: hdr - deltaBytes].
[HeaderTypeClass] ->
[self longAt: obj put: ((hdr bitClear: SizeMask) bitOr: (hdr bitAnd: SizeMask) - deltaBytes)].
[HeaderTypeShort] ->
[self longAt: obj put: ((hdr bitClear: SizeMask) bitOr: (hdr bitAnd: SizeMask) - deltaBytes)] }.
^obj!
Item was added:
+ ----- Method: NewObjectMemorySimulator>>eek (in category 'memory access') -----
+ eek
+ self halt!
Item was removed:
- ----- Method: NewspeakInterpreter>>isContext: (in category 'internal interpreter access') -----
- isContext: oop
- <inline: true>
- ^(self isNonIntegerObject: oop) and: [self isContextHeader: (self baseHeader: oop)]!
Item was changed:
----- Method: ObjectMemory class>>isNonArgumentImplicitReceiverVariableName: (in category 'translation') -----
isNonArgumentImplicitReceiverVariableName: aString
+ ^#('self' 'interpreter' 'coInterpreter' 'heapMap') includes: aString!
- ^#('self' 'interpreter' 'coInterpreter') includes: aString!
Item was added:
+ ----- Method: ObjectMemory>>badContextSize: (in category 'contexts') -----
+ badContextSize: oop
+ ^(self byteLengthOf: oop) ~= (SmallContextSize-BaseHeaderSize)
+ and: [(self byteLengthOf: oop) ~= (LargeContextSize-BaseHeaderSize)]!
Item was changed:
----- Method: ObjectMemory>>changeClassOf:to: (in category 'interpreter access') -----
changeClassOf: rcvr to: argClass
"Attempt to change the class of the receiver to the argument given that the
format of the receiver matches the format of the argument. If successful,
answer 0, otherwise answer an error code indicating the reason for failure.
Fail if the receiver is an instance of a compact class and the argument isn't,
or if the format of the receiver is incompatible with the format of the argument,
or if the argument is a fixed class and the receiver's size differs from the size
that an instance of the argument should have."
| classHdr sizeHiBits argClassInstByteSize argFormat rcvrFormat rcvrHdr ccIndex |
"Check what the format of the class says"
classHdr := self formatOfClass: argClass. "Low 2 bits are 0"
"Compute the size of instances of the class (used for fixed field classes only)"
sizeHiBits := (classHdr bitAnd: 16r60000) >> 9.
classHdr := classHdr bitAnd: 16r1FFFF.
argClassInstByteSize := (classHdr bitAnd: SizeMask) + sizeHiBits. "size in bytes -- low 2 bits are 0"
"Check the receiver's format against that of the class"
argFormat := self formatOfHeader: classHdr.
rcvrHdr := self baseHeader: rcvr.
rcvrFormat := self formatOfHeader: rcvrHdr.
"If the receiver is a byte object we need to clear the number of odd bytes from the format."
rcvrFormat > 8 ifTrue:
[rcvrFormat := rcvrFormat bitAnd: 16rC].
argFormat = rcvrFormat ifFalse:
[^PrimErrInappropriate]. "no way"
"For fixed field classes, the sizes must match.
Note: argClassInstByteSize-4 because base header is included in class size."
argFormat < 2
ifTrue:
+ [(argClassInstByteSize - BaseHeaderSize) ~= (self byteLengthOf: rcvr) ifTrue:
- [(argClassInstByteSize - BaseHeaderSize) ~= (self byteSizeOf: rcvr) ifTrue:
[^PrimErrBadReceiver]]
ifFalse:
[argFormat = 3 ifTrue: "For indexable plus fixed fields the receiver must be at least big enough."
+ [(argClassInstByteSize - BaseHeaderSize) > (self byteLengthOf: rcvr) ifTrue:
- [(argClassInstByteSize - BaseHeaderSize) > (self byteSizeOf: rcvr) ifTrue:
[^PrimErrBadReceiver]]].
(self headerTypeOfHeader: rcvrHdr) = HeaderTypeShort
ifTrue: "Compact classes. Check if the arg's class is compact and exchange ccIndex"
[ccIndex := classHdr bitAnd: CompactClassMask.
ccIndex = 0 ifTrue:
[^PrimErrInappropriate]. "class is not compact"
self cppIf: IMMUTABILITY
ifTrue: [(rcvrHdr bitAnd: ImmutabilityBit) ~= 0 ifTrue:
[^PrimErrNoModification]].
self baseHeader: rcvr put: ((rcvrHdr bitClear: CompactClassMask) bitOr: ccIndex)]
ifFalse: "Exchange the class pointer, which could make rcvr a root for argClass"
[self cppIf: IMMUTABILITY
ifTrue: [(rcvrHdr bitAnd: ImmutabilityBit) ~= 0 ifTrue:
[^PrimErrNoModification]].
"N.B. the recursive scan-mark algorithm uses the header word's size and compact class
fields to determine the header type when it reuses the header type bits for the mark
state. So it is alas an invariant that non-compact headers have a 0 compact class field."
(self compactClassIndexOfHeader: rcvrHdr) ~= 0 ifTrue:
[self baseHeader: rcvr put: (rcvrHdr bitClear: CompactClassMask)].
self longAt: rcvr - BaseHeaderSize put: (argClass bitOr: (self headerTypeOfHeader: rcvrHdr)).
(self oop: rcvr isLessThan: youngStart) ifTrue:
[self possibleRootStoreInto: rcvr value: argClass]].
"ok"
^0!
Item was added:
+ ----- Method: ObjectMemory>>goodContextSize: (in category 'contexts') -----
+ goodContextSize: oop
+ ^(self byteLengthOf: oop) = (SmallContextSize-BaseHeaderSize)
+ or: [(self byteLengthOf: oop) = (LargeContextSize-BaseHeaderSize)]!
Item was added:
+ ----- Method: ObjectMemory>>isContext: (in category 'contexts') -----
+ isContext: oop
+ <inline: true>
+ ^(self isNonIntegerObject: oop) and: [self isContextHeader: (self baseHeader: oop)]!
Item was changed:
----- Method: ObjectMemory>>printReferencesTo: (in category 'debug printing') -----
printReferencesTo: anOop
"Scan the heap printing the oops of any and all objects that refer to anOop"
| oop i |
<api>
oop := self firstAccessibleObject.
[oop = nil] whileFalse:
+ [((self isPointersNonInt: oop) or: [self isCompiledMethod: oop]) ifTrue:
- [((self isPointers: oop) or: [self isCompiledMethod: oop]) ifTrue:
[(self isCompiledMethod: oop)
ifTrue:
[i := self literalCountOf: oop]
ifFalse:
+ [(self isContextNonInt: oop)
- [(self isContext: oop)
ifTrue: [i := CtxtTempFrameStart + (self fetchStackPointerOf: oop)]
ifFalse: [i := self lengthOf: oop]].
[(i := i - 1) >= 0] whileTrue:
[anOop = (self fetchPointer: i ofObject: oop) ifTrue:
[self interpreter printHex: oop; print: ' @ '; printNum: i; space; printOopShort: oop; cr.
i := 0]]].
oop := self accessibleObjectAfter: oop]!
Item was added:
+ ----- Method: ObjectMemory>>printWronglySizedContexts (in category 'debug printing') -----
+ printWronglySizedContexts
+ "Scan the heap printing the oops of any and all contexts whose size is not either SmallContextSize or LargeContextSize"
+ | oop |
+ <api>
+ oop := self firstAccessibleObject.
+ [oop = nil] whileFalse:
+ [((self isContextNonInt: oop)
+ and: [self badContextSize: oop]) ifTrue:
+ [self printHex: oop; space; printNum: (self byteLengthOf: oop); cr].
+ oop := self accessibleObjectAfter: oop]!
Item was changed:
----- Method: ObjectMemory>>shorten:toIndexableSize: (in category 'allocation') -----
shorten: obj toIndexableSize: nSlots
"Currently this works for pointer objects only, and is almost certainly wrong for 64 bits."
| deltaBytes desiredLength fixedFields fmt hdr totalLength |
+ (self isPointersNonInt: obj) ifFalse:
- (self isPointers: obj) ifFalse:
[^obj].
hdr := self baseHeader: obj.
fmt := self formatOfHeader: hdr.
totalLength := self lengthOf: obj baseHeader: hdr format: fmt.
fixedFields := self fixedFieldsOf: obj format: fmt length: totalLength.
desiredLength := fixedFields + nSlots.
deltaBytes := (totalLength - desiredLength) * BytesPerWord.
self setSizeOfFree: obj + BaseHeaderSize + (desiredLength * BytesPerWord)
to: deltaBytes.
(self headerType: obj) caseOf: {
[HeaderTypeSizeAndClass] ->
[self longAt: obj put: hdr - deltaBytes].
[HeaderTypeClass] ->
[self longAt: obj put: ((hdr bitClear: SizeMask) bitOr: (hdr bitAnd: SizeMask) - deltaBytes)].
[HeaderTypeShort] ->
[self longAt: obj put: ((hdr bitClear: SizeMask) bitOr: (hdr bitAnd: SizeMask) - deltaBytes)] }.
^obj!
Item was changed:
----- Method: StackInterpreter>>baseFrameReturn (in category 'return bytecodes') -----
baseFrameReturn
"Return from a baseFrame (the bottom frame in a stackPage). The context to
return to (which may be married) is stored in the saved instruction pointer slot."
<inline: true>
| contextToReturnTo isAContext theFP theSP thePage frameAbove |
<var: #theFP type: #'char *'>
<var: #theSP type: #'char *'>
<var: #thePage type: #'StackPage *'>
<var: #frameAbove type: #'char *'>
contextToReturnTo := self frameCallerContext: localFP.
+ isAContext := objectMemory isContext: contextToReturnTo.
- isAContext := self isContext: contextToReturnTo.
(isAContext
and: [self isStillMarriedContext: contextToReturnTo])
ifTrue:
[theFP := self frameOfMarriedContext: contextToReturnTo.
thePage := stackPages stackPageFor: theFP.
theFP = thePage headFP
ifTrue:
[theSP := thePage headSP.
stackPages freeStackPageNoAssert: stackPage "for a short time invariant is violated; assert follows"]
ifFalse:
["Returning to some interior frame, presumably because of a sender assignment.
Move the frames above to another page (they may be in use, e.g. via coroutining).
Make the interior frame the top frame."
frameAbove := self findFrameAbove: theFP inPage: thePage.
"Reuse the page we're exiting, which avoids allocating a new page and
manipulating the page list to mark the page we're entering as least recently
used (to avoid it being deallocated when allocating a new page)."
self moveFramesIn: thePage through: frameAbove toPage: stackPage.
theFP := thePage headFP.
theSP := thePage headSP]]
ifFalse:
[(isAContext
and: [objectMemory isIntegerObject: (objectMemory fetchPointer: InstructionPointerIndex ofObject: contextToReturnTo)]) ifFalse:
[^self internalCannotReturn: localReturnValue].
thePage := self makeBaseFrameFor: contextToReturnTo.
theFP := thePage headFP.
theSP := thePage headSP.
stackPages freeStackPageNoAssert: stackPage "for a short time invariant is violated; assert follows"].
self setStackPageAndLimit: thePage.
self assert: (stackPages stackPageFor: theFP) = stackPage.
localSP := theSP.
localFP := theFP.
self setMethod: (self frameMethod: localFP).
localIP := self pointerForOop: self internalStackTop.
self internalStackTopPut: localReturnValue.
self assert: (self checkIsStillMarriedContext: contextToReturnTo currentFP: localFP).
^self fetchNextBytecode!
Item was changed:
----- Method: StackInterpreter>>checkIsStillMarriedContext:currentFP: (in category 'frame access') -----
checkIsStillMarriedContext: aContext currentFP: currentFP
"Another version of isWidowedContext:currentFP: for debugging.
This will not bereave a widowed context."
| thePage theFP limitFP |
<inline: false>
<var: #currentFP type: #'char *'>
<var: #thePage type: #'StackPage *'>
<var: #theFP type: #'char *'>
<var: #limitFP type: #'char *'>
(objectMemory isIntegerObject: (objectMemory fetchPointer: SenderIndex ofObject: aContext)) ifFalse:
[^false].
theFP := self frameOfMarriedContext: aContext.
thePage := stackPages stackPageFor: theFP.
limitFP := (thePage = stackPage and: [currentFP notNil])
ifTrue: [currentFP]
ifFalse: [thePage headFP].
^theFP >= limitFP
and: [(objectMemory isNonIntegerObject: (self frameCallerFP: theFP) asInteger)
and: [(self withSmallIntegerTags: (self frameCallerFP: theFP))
= (objectMemory fetchPointer: InstructionPointerIndex ofObject: aContext)
and: [(self frameMethodObject: theFP)
= (objectMemory fetchPointer: MethodIndex ofObject: aContext)
and: [(self frameHasContext: theFP)
and: [(self frameContext: theFP) = aContext
+ and: [objectMemory isContext: aContext]]]]]]!
- and: [self isContext: aContext]]]]]]!
Item was changed:
----- Method: StackInterpreter>>checkOkayFields: (in category 'debug support') -----
checkOkayFields: oop
"Check if the argument is an ok object.
If this is a pointers object, check that its fields are all okay oops."
| hasYoung i fieldOop |
(oop = nil or: [oop = 0]) ifTrue: [ ^true ]. "?? eem 1/16/2013"
(objectMemory isIntegerObject: oop) ifTrue: [ ^true ].
(objectMemory checkOkayOop: oop) ifFalse: [ ^false ].
(self checkOopHasOkayClass: oop) ifFalse: [ ^false ].
hasYoung := objectMemory isYoung: (objectMemory fetchClassOfNonInt: oop).
+ ((objectMemory isPointersNonInt: oop) or: [objectMemory isCompiledMethod: oop]) ifTrue:
- ((objectMemory isPointers: oop) or: [objectMemory isCompiledMethod: oop]) ifTrue:
[(objectMemory isCompiledMethod: oop)
ifTrue:
[i := (self literalCountOf: oop) - 1]
ifFalse:
+ [(objectMemory isContext: oop)
- [(self isContext: oop)
ifTrue: [i := CtxtTempFrameStart + (self fetchStackPointerOf: oop) - 1]
ifFalse: [i := (objectMemory lengthOf: oop) - 1]].
[i >= 0] whileTrue:
[fieldOop := objectMemory fetchPointer: i ofObject: oop.
(objectMemory isIntegerObject: fieldOop) ifFalse:
[hasYoung := hasYoung or: [objectMemory isYoung: fieldOop].
(objectMemory checkOkayOop: fieldOop) ifFalse: [ ^false ].
(self checkOopHasOkayClass: fieldOop) ifFalse: [ ^false ]].
i := i - 1]].
hasYoung ifTrue:
[^objectMemory checkOkayYoungReferrer: oop].
^true!
Item was changed:
----- Method: StackInterpreter>>checkOkayStackPage: (in category 'debug support') -----
checkOkayStackPage: thePage
| theSP theFP ok frameRcvrOffset callerFP oop |
<var: #thePage type: #'StackPage *'>
<var: #theSP type: #'char *'>
<var: #theFP type: #'char *'>
<var: #frameRcvrOffset type: #'char *'>
<var: #callerFP type: #'char *'>
<inline: false>
theSP := thePage headSP.
theFP := thePage headFP.
ok := true.
"Skip the instruction pointer on top of stack of inactive pages."
thePage = stackPage ifFalse:
[theSP := theSP + BytesPerWord].
[frameRcvrOffset := self frameReceiverOffset: theFP.
[theSP <= frameRcvrOffset] whileTrue:
[oop := stackPages longAt: theSP.
(objectMemory isIntegerObject: oop) ifFalse:
[ok := ok & (self checkOkayFields: oop)].
theSP := theSP + BytesPerWord].
(self frameHasContext: theFP) ifTrue:
+ [self assert: (objectMemory isContext: (self frameContext: theFP)).
- [self assert: (self isContext: (self frameContext: theFP)).
ok := ok & (self checkOkayFields: (self frameContext: theFP))].
ok := ok & (self checkOkayFields: (self frameMethodObject: theFP)).
(callerFP := self frameCallerFP: theFP) ~= 0] whileTrue:
[theSP := theFP + FoxCallerSavedIP + BytesPerWord.
theFP := callerFP].
theSP := self isCog
ifTrue: [theFP + FoxCallerSavedIP + BytesPerWord] "caller ip is ceBaseReturnPC"
ifFalse: [theFP + FoxCallerSavedIP]. "caller ip is frameCallerContext in a base frame"
[theSP <= thePage baseAddress] whileTrue:
[oop := stackPages longAt: theSP.
(objectMemory isIntegerObject: oop) ifFalse:
[ok := ok & (self checkOkayFields: oop)].
theSP := theSP + BytesPerWord].
^ok!
Item was changed:
----- Method: StackInterpreter>>checkOopHasOkayClass: (in category 'debug support') -----
checkOopHasOkayClass: obj
"Attempt to verify that the given obj has a reasonable behavior. The class must be a
valid, non-integer oop and must not be nilObj. It must be a pointers object with three
or more fields. Finally, the instance specification field of the behavior must match that
of the instance. If OK answer true. If not, print reason and answer false."
<api>
<var: #oop type: #usqInt>
| objClass formatMask behaviorFormatBits objFormatBits |
<var: #oopClass type: #usqInt>
(objectMemory checkOkayOop: obj) ifFalse:
[^false].
objClass := self cCoerce: (objectMemory fetchClassOfNonInt: obj) to: #usqInt.
(objectMemory isIntegerObject: objClass) ifTrue:
[self print: 'obj '; printHex: obj; print: ' a SmallInteger is not a valid class or behavior'; cr. ^false].
(objectMemory okayOop: objClass) ifFalse:
[self print: 'obj '; printHex: obj; print: ' class obj is not ok'; cr. ^false].
+ ((objectMemory isPointersNonInt: objClass) and: [(objectMemory lengthOf: objClass) >= 3]) ifFalse:
- ((objectMemory isPointers: objClass) and: [(objectMemory lengthOf: objClass) >= 3]) ifFalse:
[self print: 'obj '; printHex: obj; print: ' a class (behavior) must be a pointers object of size >= 3'; cr. ^false].
formatMask := (objectMemory isBytes: obj)
ifTrue: [16rC00] "ignore extra bytes size bits"
ifFalse: [16rF00].
behaviorFormatBits := (objectMemory formatOfClass: objClass) bitAnd: formatMask.
objFormatBits := (objectMemory baseHeader: obj) bitAnd: formatMask.
behaviorFormatBits = objFormatBits ifFalse:
[self print: 'obj '; printHex: obj; print: ' and its class (behavior) formats differ'; cr. ^false].
^true!
Item was changed:
----- Method: StackInterpreter>>checkStackIntegrity (in category 'object memory support') -----
checkStackIntegrity
"Perform an integrity/leak check using the heapMap. Assume
clearLeakMapAndMapAccesibleObjects has set a bit at each
object's header. Scan all objects accessible from the stack
checking that every pointer points to a header. Answer if no
dangling pointers were detected."
| ok |
<inline: false>
<var: #thePage type: #'StackPage *'>
<var: #theSP type: #'char *'>
<var: #theFP type: #'char *'>
<var: #callerFP type: #'char *'>
ok := true.
0 to: numStackPages - 1 do:
[:i| | thePage theSP theFP callerFP oop |
thePage := stackPages stackPageAt: i.
(stackPages isFree: thePage) ifFalse:
[thePage = stackPage
ifTrue:
[theSP := stackPointer.
theFP := framePointer]
ifFalse:
[theSP := thePage headSP.
theFP := thePage headFP].
"Skip the instruction pointer on top of stack of inactive pages."
thePage = stackPage ifFalse:
[theSP := theSP + BytesPerWord].
[[theSP <= (theFP + FoxReceiver)] whileTrue:
[oop := stackPages longAt: theSP.
((objectMemory isNonIntegerObject: oop)
and: [(self heapMapAtWord: (self pointerForOop: oop)) = 0]) ifTrue:
[self printFrameThing: 'object leak in frame temp' at: theSP; cr.
ok := false].
theSP := theSP + BytesPerWord].
(self frameHasContext: theFP) ifTrue:
[oop := self frameContext: theFP.
((objectMemory isIntegerObject: oop)
or: [(self heapMapAtWord: (self pointerForOop: oop)) = 0]) ifTrue:
[self printFrameThing: 'object leak in frame ctxt' at: theFP + FoxThisContext; cr.
ok := false].
+ (objectMemory isContext: oop) ifFalse:
- (self isContext: oop) ifFalse:
[self printFrameThing: 'frame ctxt should be context' at: theFP + FoxThisContext; cr.
ok := false]].
oop := self frameMethod: theFP.
((objectMemory isIntegerObject: oop)
or: [(self heapMapAtWord: (self pointerForOop: oop)) = 0]) ifTrue:
[self printFrameThing: 'object leak in frame mthd' at: theFP + FoxMethod; cr.
ok := false].
(callerFP := self frameCallerFP: theFP) ~= 0] whileTrue:
[theSP := theFP + FoxCallerSavedIP + BytesPerWord.
theFP := callerFP].
theSP := theFP + FoxCallerContext "a.k.a. FoxCallerSavedIP".
[theSP <= thePage baseAddress] whileTrue:
[oop := stackPages longAt: theSP.
((objectMemory isNonIntegerObject: oop)
and: [(self heapMapAtWord: (self pointerForOop: oop)) = 0]) ifTrue:
[self printFrameThing: 'object leak in frame arg' at: theSP; cr.
ok := false].
theSP := theSP + BytesPerWord]]].
^ok!
Item was changed:
----- Method: StackInterpreter>>commonReturn (in category 'return bytecodes') -----
commonReturn
"Do an ^-return (return form method), perhaps checking for unwinds if this is a block activation.
Note: Assumed to be inlined into the dispatch loop."
<sharedCodeNamed: 'commonReturn' inCase: #returnReceiver>
| closure home unwindContextOrNilOrZero frameToReturnTo contextToReturnTo theFP callerFP newPage |
<var: #frameToReturnTo type: #'char *'>
<var: #theFP type: #'char *'>
<var: #callerFP type: #'char *'>
<var: #newPage type: #'StackPage *'>
<var: #thePage type: #'StackPage *'>
"If this is a method simply return to the sender/caller."
(self frameIsBlockActivation: localFP) ifFalse:
[^self commonCallerReturn].
"Since this is a block activation the closure is on the stack above any args and the frame."
closure := self pushedReceiverOrClosureOfFrame: localFP.
home := nil.
"Walk the closure's lexical chain to find the context or frame to return from (home)."
[closure ~= objectMemory nilObject] whileTrue:
[home := objectMemory fetchPointer: ClosureOuterContextIndex ofObject: closure.
closure := objectMemory fetchPointer: ClosureIndex ofObject: home].
"home is to be returned from provided there is no unwind-protect activation between
this frame and home's sender. Search for an unwind. findUnwindThroughContext:
will answer either the context for an unwind-protect activation or nilObj if the sender
cannot be found or 0 if no unwind is found but the sender is. We must update the
current page's headFrame pointers to enable the search to identify widowed contexts
correctly."
self writeBackHeadFramePointers.
unwindContextOrNilOrZero := self internalFindUnwindThroughContext: home.
unwindContextOrNilOrZero = objectMemory nilObject ifTrue:
["error: can't find home on chain; cannot return"
^self internalCannotReturn: localReturnValue].
unwindContextOrNilOrZero ~= 0 ifTrue:
[^self internalAboutToReturn: localReturnValue through: unwindContextOrNilOrZero].
"Now we know home is on the sender chain.
We could be returning to either a context or a frame. Find out which."
contextToReturnTo := nil.
(self isMarriedOrWidowedContext: home)
ifTrue:
[self assert: (self checkIsStillMarriedContext: home currentFP: localFP).
theFP := self frameOfMarriedContext: home.
(self isBaseFrame: theFP)
ifTrue:
[contextToReturnTo := self frameCallerContext: theFP]
ifFalse:
[frameToReturnTo := self frameCallerFP: theFP]]
ifFalse:
[contextToReturnTo := objectMemory fetchPointer: SenderIndex ofObject: home.
+ ((objectMemory isContext: contextToReturnTo)
- ((self isContext: contextToReturnTo)
and: [self isMarriedOrWidowedContext: contextToReturnTo]) ifTrue:
[self assert: (self checkIsStillMarriedContext: contextToReturnTo currentFP: localFP).
frameToReturnTo := self frameOfMarriedContext: contextToReturnTo.
contextToReturnTo := nil]].
"If returning to a context we must make a frame for it unless it is dead."
contextToReturnTo ~= nil ifTrue:
[frameToReturnTo := self establishFrameForContextToReturnTo: contextToReturnTo.
frameToReturnTo == 0 ifTrue:
["error: home's sender is dead; cannot return"
^self internalCannotReturn: localReturnValue]].
"Now we have a frame to return to. If it is on a different page we must free intervening pages and
nil out intervening contexts. We must free intervening stack pages because if we leave the pages
to be divorced then their contexts will be divorced with intact senders and instruction pointers. This
code is similar to primitiveTerminateTo. We must move any frames on itervening pages above the
frame linked to because these may be in use, e.g. via co-routining (see baseFrameReturn)."
self assert: stackPages pageListIsWellFormed.
newPage := stackPages stackPageFor: frameToReturnTo.
newPage ~~ stackPage ifTrue:
[| currentCtx thePage nextCntx |
currentCtx := self frameCallerContext: stackPage baseFP.
+ self assert: (objectMemory isContext: currentCtx).
- self assert: (self isContext: currentCtx).
stackPages freeStackPage: stackPage.
+ [self assert: (objectMemory isContext: currentCtx).
- [self assert: (self isContext: currentCtx).
(self isMarriedOrWidowedContext: currentCtx)
and: [(stackPages stackPageFor: (theFP := self frameOfMarriedContext: currentCtx)) = newPage]] whileFalse:
[(self isMarriedOrWidowedContext: currentCtx)
ifTrue:
[thePage := stackPages stackPageFor: theFP.
theFP ~= thePage headFP ifTrue:
["Since we've just deallocated a page we know that newStackPage won't deallocate an existing one."
self moveFramesIn: thePage through: (self findFrameAbove: theFP inPage: thePage) toPage: self newStackPage].
currentCtx := self frameCallerContext: thePage baseFP.
stackPages freeStackPage: thePage]
ifFalse:
[nextCntx := objectMemory fetchPointer: SenderIndex ofObject: currentCtx.
self markContextAsDead: currentCtx.
currentCtx := nextCntx]].
self setStackPageAndLimit: newPage.
localSP := stackPage headSP.
localFP := stackPage headFP].
"Two cases. Returning to the top frame on a new page or an interior frame on the current page.
The top frame has its instruction pointer on top of stack. An interior frame has its instruction pointer
in the caller frame. We need to peel back any frames on the page until we get to the correct frame."
localFP = frameToReturnTo
ifTrue: "pop the saved IP, push the return value and continue."
[localIP := self pointerForOop: self internalStackTop]
ifFalse:
[[callerFP := localFP.
localFP := self frameCallerFP: localFP.
localFP ~~ frameToReturnTo] whileTrue.
localIP := self frameCallerSavedIP: callerFP.
localSP := (self frameCallerSP: callerFP) - BytesPerWord].
self setMethod: (self frameMethod: localFP).
self fetchNextBytecode.
^self internalStackTopPut: localReturnValue!
Item was changed:
----- Method: StackInterpreter>>ensureFrameIsMarried:SP: (in category 'frame access') -----
ensureFrameIsMarried: theFP SP: theSP
<inline: true>
<var: #theFP type: #'char *'>
<var: #theSP type: #'char *'>
(self frameHasContext: theFP) ifTrue:
+ [self assert: (objectMemory isContext: (self frameContext: theFP)).
- [self assert: (self isContext: (self frameContext: theFP)).
^self frameContext: theFP].
^self marryFrame: theFP SP: theSP!
Item was changed:
----- Method: StackInterpreter>>establishFrameForContextToReturnTo: (in category 'frame access') -----
establishFrameForContextToReturnTo: contextToReturnTo
| thePage |
<var: #thePage type: #'StackPage *'>
<returnTypeC: 'char *'>
+ (objectMemory isContext: contextToReturnTo) ifFalse:
- (self isContext: contextToReturnTo) ifFalse:
[^0].
(self isMarriedOrWidowedContext: contextToReturnTo) ifTrue:
[(self isWidowedContext: contextToReturnTo) ifTrue:
["error: home's sender is dead; cannot return"
^0].
^self frameOfMarriedContext: contextToReturnTo].
(objectMemory isIntegerObject: (objectMemory fetchPointer: InstructionPointerIndex ofObject: contextToReturnTo)) ifFalse:
[^0].
thePage := self makeBaseFrameFor: contextToReturnTo.
stackPages markStackPageMostRecentlyUsed: thePage.
^thePage baseFP!
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).
- self assert: (self isContext: aContext).
"method, closureOrNil & receiver need no special handling; only
sender, pc & stackp have to be computed for married contexts."
(offset < MethodIndex
and: [self isMarriedOrWidowedContext: aContext]) ifFalse:
[^objectMemory fetchPointer: offset ofObject: aContext].
self externalWriteBackHeadFramePointers.
(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 changed:
----- Method: StackInterpreter>>externalInstVar:ofContext:put: (in category 'frame access') -----
externalInstVar: index ofContext: maybeMarriedContext put: anOop
| theFP thePage onCurrentPage |
<var: #theFP type: #'char *'>
<var: #thePage type: #'StackPage *'>
+ self assert: (objectMemory isContext: maybeMarriedContext).
- self assert: (self isContext: maybeMarriedContext).
self externalWriteBackHeadFramePointers.
"Assign the field of a married context."
(self isStillMarriedContext: maybeMarriedContext) ifFalse:
[objectMemory storePointer: index ofObject: maybeMarriedContext withValue: anOop.
index = StackPointerIndex ifTrue:
[self ensureContextIsExecutionSafeAfterAssignToStackPointer: maybeMarriedContext].
^nil].
theFP := self frameOfMarriedContext: maybeMarriedContext.
thePage := stackPages stackPageFor: theFP.
self assert: stackPage = stackPages mostRecentlyUsedPage.
onCurrentPage := thePage = stackPage.
index == SenderIndex
ifTrue:
[self storeSenderOfFrame: theFP withValue: anOop]
ifFalse:
[self externalDivorceFrame: theFP andContext: maybeMarriedContext.
objectMemory storePointer: index ofObject: maybeMarriedContext withValue: anOop.
index = StackPointerIndex ifTrue:
[self ensureContextIsExecutionSafeAfterAssignToStackPointer: maybeMarriedContext]].
onCurrentPage
ifTrue:
[framePointer := stackPage headFP.
stackPointer := stackPage headSP]
ifFalse:
[stackPages markStackPageMostRecentlyUsed: stackPage].
stackPages assert: stackPage = stackPages mostRecentlyUsedPage.
stackPages assert: stackPages pageListIsWellFormed.
stackPages assert: self validStackPageBaseFrames!
Item was changed:
----- Method: StackInterpreter>>externalSetStackPageAndPointersForSuspendedContextOfProcess: (in category 'frame access') -----
externalSetStackPageAndPointersForSuspendedContextOfProcess: aProcess
"Set stackPage, framePointer and stackPointer for the suspendedContext of aProcess,
marrying the context if necessary, and niling the suspendedContext slot. This is used
on process switch to ensure a context has a stack frame and so can continue execution."
| newContext theFrame thePage |
<var: #theFrame type: #'char *'>
<var: #thePage type: #'StackPage *'>
newContext := objectMemory fetchPointer: SuspendedContextIndex ofObject: aProcess.
+ self assert: (objectMemory isContext: newContext).
- self assert: (self isContext: newContext).
(self isMarriedOrWidowedContext: newContext) ifTrue:
[self assert: (self checkIsStillMarriedContext: newContext currentFP: framePointer)].
objectMemory storePointerUnchecked: SuspendedContextIndex ofObject: aProcess withValue: objectMemory nilObject.
(self isStillMarriedContext: newContext)
ifTrue:
[theFrame := self frameOfMarriedContext: newContext.
thePage := stackPages stackPageFor: theFrame]
ifFalse:
[thePage := self makeBaseFrameFor: newContext.
theFrame := thePage baseFP].
self assert: thePage headFP = theFrame.
self setStackPageAndLimit: thePage.
stackPointer := thePage headSP.
framePointer := thePage headFP.
(self isMachineCodeFrame: framePointer) ifFalse:
[self setMethod: (self iframeMethod: framePointer)].
self assertValidExecutionPointe: self stackTop asUnsignedInteger r: framePointer s: stackPointer!
Item was changed:
----- Method: StackInterpreter>>findHomeForContext: (in category 'debug printing') -----
findHomeForContext: aContext
| closureOrNil |
<inline: false>
+ (objectMemory isContext: aContext) ifFalse:
- (self isContext: aContext) ifFalse:
[^nil].
closureOrNil := objectMemory fetchPointer: ClosureIndex ofObject: aContext.
closureOrNil = objectMemory nilObject ifTrue:
[^aContext].
(objectMemory fetchClassOf: closureOrNil) ~= (objectMemory splObj: ClassBlockClosure) ifTrue:
[^nil].
^self findHomeForContext: (objectMemory fetchPointer: ClosureOuterContextIndex ofObject: closureOrNil)!
Item was changed:
----- Method: StackInterpreter>>findMethodWithPrimitive:FromContext:UpToContext: (in category 'handler search') -----
findMethodWithPrimitive: primitive FromContext: senderContext UpToContext: homeContext
"See findUnwindThroughContext:. Alas this is mutually recursive with
findMethodWithPrimitive:FromFP:SP:ThroughContext: instead of iterative.
We're doing the simplest thing that could possibly work. Niceties can wait."
| theContext theMethod |
+ self assert: (senderContext = objectMemory nilObject or: [objectMemory isContext: senderContext]).
+ self assert: (homeContext = objectMemory nilObject or: [objectMemory isContext: homeContext]).
- self assert: (senderContext = objectMemory nilObject or: [self isContext: senderContext]).
- self assert: (homeContext = objectMemory nilObject or: [self isContext: homeContext]).
theContext := senderContext.
[theContext = objectMemory nilObject ifTrue:
[^theContext].
self isMarriedOrWidowedContext: theContext] whileFalse:
[theContext = homeContext ifTrue: [^0].
(objectMemory fetchPointer: ClosureIndex ofObject: theContext) = objectMemory nilObject ifTrue:
[theMethod := objectMemory fetchPointer: MethodIndex ofObject: theContext.
(self primitiveIndexOf: theMethod) == primitive ifTrue:
[^theContext]].
theContext := objectMemory fetchPointer: SenderIndex ofObject: theContext].
(self isWidowedContext: theContext) ifTrue:
[^objectMemory nilObject].
^self
findMethodWithPrimitive: primitive
FromFP: (self frameOfMarriedContext: theContext)
UpToContext: homeContext!
Item was changed:
----- Method: StackInterpreter>>findMethodWithPrimitive:FromFP:UpToContext: (in category 'handler search') -----
findMethodWithPrimitive: primitive FromFP: startFP UpToContext: homeContext
"See findUnwindThroughContext:. Alas this is mutually recursive with
findMethodWithPrimitive:FromContext:ThroughContext: instead of iterative.
We're doing the simplest thing that could possibly work. Niceties can wait."
| theFP theFPAbove theSP theMethod senderContext |
<var: #startFP type: #'char *'>
<var: #theFP type: #'char *'>
<var: #theFPAbove type: #'char *'>
<var: #theSP type: #'char *'>
theFP := startFP.
theFPAbove := startFP.
[((self frameHasContext: theFP)
and: [homeContext = (self frameContext: theFP)]) ifTrue:
[^0].
(self frameIsBlockActivation: theFP) ifFalse:
[theMethod := self frameMethodObject: theFP.
(self primitiveIndexOf: theMethod) == primitive ifTrue:
[theFP = theFPAbove
ifTrue: [theSP := self findSPOf: theFP on: (stackPages stackPageFor: theFP)]
ifFalse: [theSP := self frameCallerStackPointer: theFPAbove].
^self ensureFrameIsMarried: theFP SP: theSP]].
theFPAbove := theFP.
theFP := self frameCallerFP: theFP.
theFP ~= 0] whileTrue.
senderContext := self frameCallerContext: theFPAbove.
+ (objectMemory isContext: senderContext) ifFalse:
- (self isContext: senderContext) ifFalse:
[^objectMemory nilObject].
^self
findMethodWithPrimitive: primitive
FromContext: senderContext
UpToContext: homeContext!
Item was changed:
----- Method: StackInterpreter>>handleStackOverflow (in category 'message sending') -----
handleStackOverflow
"Check for stack overflow, moving frames to another stack if so."
| newPage theFP callerFP overflowLimitAddress overflowCount |
<var: #newPage type: #'StackPage *'>
<var: #theFP type: #'char *'>
<var: #callerFP type: #'char *'>
<var: #overflowLimitAddress type: #'char *'>
"After checkForInterrupts another event check may have been forced, setting both
stackLimit and stackPage stackLimit to all ones. So here we must check against
the real stackLimit, not the effective stackLimit."
stackPointer < stackPage realStackLimit ifFalse:
[^self].
self maybeTraceStackOverflow.
statStackOverflow := statStackOverflow + 1.
"The stack has overflowed this page. If the system is executing some recursive algorithm,
e.g. fibonacci, then the system could thrash overflowing the stack if the call soon returns
back to the current page. To avoid thrashing, since overflow is quite slow, we can move
more than one frame. The idea is to record which page has overflowed, and the first
time it overflows move one frame, the second time two frames, and so on. We move no
more frames than would leave the page half occupied."
theFP := framePointer.
stackPage = overflowedPage
ifTrue:
[overflowLimitAddress := stackPage baseAddress - stackPages overflowLimit.
overflowCount := extraFramesToMoveOnOverflow := extraFramesToMoveOnOverflow + 1.
[(overflowCount := overflowCount - 1) >= 0
and: [(callerFP := self frameCallerFP: theFP) < overflowLimitAddress
and: [(self isBaseFrame: callerFP) not]]] whileTrue:
[theFP := callerFP]]
ifFalse:
[overflowedPage := stackPage.
extraFramesToMoveOnOverflow := 0].
self ensureCallerContext: theFP.
newPage := self newStackPage.
self moveFramesIn: stackPage through: theFP toPage: newPage.
self setStackPageAndLimit: newPage.
framePointer := stackPage headFP.
stackPointer := stackPage headSP.
self isCog
ifFalse: "To overflow the stack this must be a new frame, but in Cog base frames are married."
[self assert: (self frameHasContext: framePointer) not.
self assert: (self validInstructionPointer: instructionPointer
inMethod: method
framePointer: framePointer)]
ifTrue:
[self assert: (self validInstructionPointer: instructionPointer
inFrame: framePointer).
self assert: ((self frameHasContext: framePointer) not
+ or: [objectMemory isContext: (self frameContext: framePointer)])]!
- or: [self isContext: (self frameContext: framePointer)])]!
Item was changed:
----- Method: StackInterpreter>>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."
| 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 assert: (self 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:
[| 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 removed:
- ----- Method: StackInterpreter>>isContext: (in category 'internal interpreter access') -----
- isContext: oop
- <inline: true>
- ^(objectMemory isNonIntegerObject: oop) and: [objectMemory isContextHeader: (objectMemory baseHeader: oop)]!
Item was changed:
----- Method: StackInterpreter>>isLiveContext: (in category 'frame access') -----
isLiveContext: oop
"Answer if the argument, which can be any object, is a live context."
+ (objectMemory isContext: oop) ifFalse:
- (self isContext: oop) ifFalse:
[^false].
(self isSingleContext: oop) ifTrue:
[^objectMemory isIntegerObject: (objectMemory fetchPointer: InstructionPointerIndex ofObject: oop)].
^(self isWidowedContext: oop) not!
Item was changed:
----- Method: StackInterpreter>>isWidowedContext: (in category 'frame access') -----
isWidowedContext: aOnceMarriedContext
"See if the argument is connected with a live frame or not.
If it is not, turn it into a bereaved single context."
| theFrame thePage shouldBeFrameCallerField |
<var: #theFrame type: #'char *'>
<var: #thePage type: #'StackPage *'>
<var: #shouldBeFrameCallerField type: #'char *'>
+ self assert: ((objectMemory isContext: aOnceMarriedContext)
- self assert: ((self isContext: aOnceMarriedContext)
and: [self isMarriedOrWidowedContext: aOnceMarriedContext]).
theFrame := self frameOfMarriedContext: aOnceMarriedContext.
thePage := stackPages stackPageFor: theFrame.
((stackPages isFree: thePage)
or: [theFrame < thePage headFP]) ifFalse:
["The frame pointer is within the bounds of a live page.
Now check if it matches a frame."
shouldBeFrameCallerField := self withoutSmallIntegerTags:
(objectMemory fetchPointer: InstructionPointerIndex
ofObject: aOnceMarriedContext).
((self frameCallerFP: theFrame) = shouldBeFrameCallerField
and: [(self frameMethodObject: theFrame) = (objectMemory fetchPointer: MethodIndex
ofObject: aOnceMarriedContext)
and: [(self frameHasContext: theFrame)
and: [(self frameContext: theFrame) = aOnceMarriedContext]]]) ifTrue:
["It is still married!!"
^false]].
"It is out of range or doesn't match the frame's context.
It is widowed. Time to wear black."
self markContextAsDead: aOnceMarriedContext.
^true!
Item was changed:
----- Method: StackInterpreter>>longPrintOop: (in category 'debug printing') -----
longPrintOop: oop
<api>
| class fmt lastIndex startIP bytecodesPerLine column |
((objectMemory isIntegerObject: oop)
or: [(oop between: objectMemory startOfMemory and: objectMemory freeStart) not
or: [(oop bitAnd: (BytesPerWord - 1)) ~= 0
or: [(objectMemory isFreeObject: oop)]]]) ifTrue:
[^self printOop: oop].
class := objectMemory fetchClassOfNonInt: oop.
self printHex: oop;
print: ': a(n) '; printNameOfClass: class count: 5;
print: ' ('; printHex: class; print: ')'.
fmt := objectMemory formatOf: oop.
fmt > 4 ifTrue:
+ [self print: ' nbytes '; printNum: (objectMemory byteLengthOf: oop)].
- [self print: ' nbytes '; printNum: (objectMemory byteSizeOf: oop)].
objectMemory printHeaderTypeOf: oop.
self cr.
(fmt between: 5 and: 11) ifTrue:
[^self].
lastIndex := 256 min: (startIP := (objectMemory lastPointerOf: oop) / BytesPerWord).
lastIndex > 0 ifTrue:
[1 to: lastIndex do:
[:i| | fieldOop |
fieldOop := objectMemory fetchPointer: i - 1 ofObject: oop.
self space; printNum: i - 1; space; printHex: fieldOop; space.
(i = 1 and: [objectMemory isCompiledMethod: oop])
ifTrue: [self printMethodHeaderOop: fieldOop]
ifFalse: [self printOopShort: fieldOop].
self cr]].
(objectMemory isCompiledMethod: oop)
ifFalse:
[startIP > 64 ifTrue: [self print: '...'; cr]]
ifTrue:
[startIP := startIP * BytesPerWord + 1.
lastIndex := objectMemory lengthOf: oop.
lastIndex - startIP > 100 ifTrue:
[lastIndex := startIP + 100].
bytecodesPerLine := 8.
column := 1.
startIP to: lastIndex do:
[:index| | byte |
column = 1 ifTrue:
[self cCode: 'printf("0x%08x: ", oop+BaseHeaderSize+index-1)'
inSmalltalk: [self print: (oop+BaseHeaderSize+index-1) hex; print: ': ']].
byte := objectMemory fetchByte: index - 1 ofObject: oop.
self cCode: 'printf(" %02x/%-3d", byte,byte)'
inSmalltalk: [self space; print: (byte radix: 16); printChar: $/; printNum: byte].
column := column + 1.
column > bytecodesPerLine ifTrue:
[column := 1. self cr]].
column = 1 ifFalse:
[self cr]]!
Item was changed:
----- Method: StackInterpreter>>makeBaseFrameFor: (in category 'frame access') -----
makeBaseFrameFor: aContext "<Integer>"
"Marry aContext with the base frame of a new stack page. Build the base
frame to reflect the context's state. Answer the new page."
<returnTypeC: #'StackPage *'>
| page pointer theMethod theIP numArgs stackPtrIndex maybeClosure |
<inline: false>
<var: #page type: #'StackPage *'>
<var: #pointer type: #'char *'>
self assert: (self isSingleContext: aContext).
+ self assert: (objectMemory goodContextSize: aContext).
page := self newStackPage.
pointer := page baseAddress.
theIP := objectMemory fetchPointer: InstructionPointerIndex ofObject: aContext.
theMethod := objectMemory fetchPointer: MethodIndex ofObject: aContext.
(objectMemory isIntegerObject: theIP) ifFalse:
[self error: 'context is not resumable'].
theIP := objectMemory integerValueOf: theIP.
"If the frame is a closure activation then the closure should be on the stack in
the pushed receiver position (closures receiver the value[:value:] messages).
Otherwise it should be the receiver proper."
maybeClosure := objectMemory fetchPointer: ClosureIndex ofObject: aContext.
maybeClosure ~= objectMemory nilObject
ifTrue:
[numArgs := self argumentCountOfClosure: maybeClosure.
stackPages longAt: pointer put: maybeClosure]
ifFalse:
[| header |
header := self headerOf: theMethod.
numArgs := self argumentCountOfMethodHeader: header.
self cppIf: MULTIPLEBYTECODESETS
ifTrue: "If this is a synthetic context its IP could be pointing at the CallPrimitive opcode. If so, skip it."
[(theIP signedIntFromLong > 0
and: [(self methodHeaderHasPrimitive: header)
and: [theIP = (1 + (objectMemory lastPointerOf: theMethod))]]) ifTrue:
[theIP := theIP + (self sizeOfCallPrimitiveBytecode: header)]].
stackPages longAt: pointer put: (objectMemory fetchPointer: ReceiverIndex ofObject: aContext)].
"Put the arguments on the stack"
1 to: numArgs do:
[:i|
stackPages
longAt: (pointer := pointer - BytesPerWord)
put: (objectMemory fetchPointer: ReceiverIndex + i ofObject: aContext)].
"saved caller ip is sender context in base frame"
stackPages
longAt: (pointer := pointer - BytesPerWord)
put: (objectMemory fetchPointer: SenderIndex ofObject: aContext).
"base frame's saved fp is null"
stackPages
longAt: (pointer := pointer - BytesPerWord)
put: 0.
page baseFP: pointer; headFP: pointer.
stackPages
longAt: (pointer := pointer - BytesPerWord)
put: theMethod.
stackPages
longAt: (pointer := pointer - BytesPerWord)
put: (self encodeFrameFieldHasContext: true isBlock: maybeClosure ~= objectMemory nilObject numArgs: numArgs).
self assert: (self frameHasContext: page baseFP).
self assert: (self frameNumArgs: page baseFP) == numArgs.
stackPages
longAt: (pointer := pointer - BytesPerWord)
put: aContext.
stackPages
longAt: (pointer := pointer - BytesPerWord)
put: (objectMemory fetchPointer: ReceiverIndex ofObject: aContext).
stackPtrIndex := self quickFetchInteger: StackPointerIndex ofObject: aContext.
self assert: ReceiverIndex + stackPtrIndex < (objectMemory lengthOf: aContext).
numArgs + 1 to: stackPtrIndex do:
[:i|
stackPages
longAt: (pointer := pointer - BytesPerWord)
put: (objectMemory fetchPointer: ReceiverIndex + i ofObject: aContext)].
"top of stack is the instruction pointer"
theIP := self iframeInstructionPointerForIndex: theIP method: theMethod.
stackPages longAt: (pointer := pointer - BytesPerWord) put: theIP.
page headSP: pointer.
self assert: (self context: aContext hasValidInversePCMappingOf: theIP in: page baseFP).
"Mark context as married by setting its sender to the frame pointer plus SmallInteger
tags and the InstructionPointer to the saved fp (which ensures correct alignment
w.r.t. the frame when we check for validity) plus SmallInteger tags."
objectMemory storePointerUnchecked: SenderIndex
ofObject: aContext
withValue: (self withSmallIntegerTags: page baseFP).
objectMemory storePointerUnchecked: InstructionPointerIndex
ofObject: aContext
withValue: (self withSmallIntegerTags: 0).
self assert: (objectMemory isIntegerObject: (objectMemory fetchPointer: SenderIndex ofObject: aContext)).
self assert: (self frameOfMarriedContext: aContext) = page baseFP.
self assert: self validStackPageBaseFrames.
^page!
Item was changed:
----- Method: StackInterpreter>>markAndTraceStackPage: (in category 'object memory support') -----
markAndTraceStackPage: thePage
| theSP theFP frameRcvrOffset callerFP oop |
<var: #thePage type: #'StackPage *'>
<var: #theSP type: #'char *'>
<var: #theFP type: #'char *'>
<var: #frameRcvrOffset type: #'char *'>
<var: #callerFP type: #'char *'>
<inline: false>
self assert: (stackPages isFree: thePage) not.
theSP := thePage headSP.
theFP := thePage headFP.
"Skip the instruction pointer on top of stack of inactive pages."
thePage = stackPage ifFalse:
[theSP := theSP + BytesPerWord].
[frameRcvrOffset := self frameReceiverOffset: theFP.
[theSP <= frameRcvrOffset] whileTrue:
[oop := stackPages longAt: theSP.
(objectMemory isIntegerObject: oop) ifFalse:
[objectMemory markAndTrace: oop].
theSP := theSP + BytesPerWord].
(self frameHasContext: theFP) ifTrue:
+ [self assert: (objectMemory isContext: (self frameContext: theFP)).
- [self assert: (self isContext: (self frameContext: theFP)).
objectMemory markAndTrace: (self frameContext: theFP)].
objectMemory markAndTrace: (self iframeMethod: theFP).
(callerFP := self frameCallerFP: theFP) ~= 0] whileTrue:
[theSP := theFP + FoxCallerSavedIP + BytesPerWord.
theFP := callerFP].
theSP := theFP + FoxCallerSavedIP. "caller ip is frameCallerContext in a base frame"
[theSP <= thePage baseAddress] whileTrue:
[oop := stackPages longAt: theSP.
(objectMemory isIntegerObject: oop) ifFalse:
[objectMemory markAndTrace: oop].
theSP := theSP + BytesPerWord]!
Item was changed:
----- Method: StackInterpreter>>markAndTraceStackPages: (in category 'object memory support') -----
markAndTraceStackPages: fullGCFlag
"GC of pages. Throwing away all stack pages on full GC is simple but dangerous
because it causes us to allocate lots of contexts immediately before a GC.
Reclaiming pages whose top context is not referenced is poor because it would
take N incrementalGCs to reclaim N unused pages. Only the page whose top
context is not referred to by the bottom context of any other page would be
reclaimed. Not until the next GC would the page whose top contect is the
previously reclaimed page's base frame's bottom context be reclaimed.
Better is to not mark stack pages until their contexts are encountered. We can
eagerly trace the active page and the page reachable from its bottom context
if any, and so on. Other pages can be marked when we encounter a married
context."
| thePage context |
<var: #thePage type: #'StackPage *'>
<inline: false>
"Need to write back the frame pointers unless all pages are free (as in snapshot)"
stackPage ~= 0 ifTrue:
[self externalWriteBackHeadFramePointers].
0 to: numStackPages - 1 do:
[:i|
thePage := stackPages stackPageAt: i.
thePage trace: 0].
"On an incremental GC simply consider all non-free stack pages to be roots."
fullGCFlag ifFalse:
[0 to: numStackPages - 1 do:
[:i|
thePage := stackPages stackPageAt: i.
(stackPages isFree: thePage) ifFalse:
[thePage trace: 2.
self markAndTraceStackPage: thePage]].
^nil].
"On a full GC only eagerly trace pages referenced from the active page."
stackPage = 0 ifTrue: [^nil].
thePage := stackPage.
[thePage trace: 2.
self markAndTraceStackPage: thePage.
context := self frameCallerContext: thePage baseFP.
+ ((objectMemory isContext: context)
- ((self isContext: context)
and: [(self isMarriedOrWidowedContext: context)
and: [self isStillMarriedContext: context]]) ifTrue:
[thePage := stackPages stackPageFor: (self frameOfMarriedContext: context).
self assert: (stackPages isFree: thePage) not].
thePage trace = 0] whileTrue!
Item was changed:
----- Method: StackInterpreter>>markContextAsDead: (in category 'frame access') -----
markContextAsDead: oop
"Mark the argument, which must be a context, married, widowed or single, as dead.
For married or widowed contexts this breaks any link to the spouse and makes the context single.
For all contexts, marks the context as inactive/having been returned from."
<inline: true>
+ self assert: (objectMemory isContext: oop).
- self assert: (self isContext: oop).
objectMemory
storePointerUnchecked: SenderIndex ofObject: oop withValue: objectMemory nilObject;
storePointerUnchecked: InstructionPointerIndex ofObject: oop withValue: objectMemory nilObject!
Item was changed:
----- Method: StackInterpreter>>noMarkedContextsOnPage: (in category 'object memory support') -----
noMarkedContextsOnPage: thePage
"Answer true if there are no marked contexts on thePage."
| theFP |
<var: #thePage type: #'StackPage *'>
<var: #theFP type: #'char *'>
<inline: false>
self assert: (stackPages isFree: thePage) not.
theFP := thePage headFP.
[(self frameHasContext: theFP) ifTrue:
+ [self assert: (objectMemory isContext: (self frameContext: theFP)).
- [self assert: (self isContext: (self frameContext: theFP)).
(objectMemory isMarked: (self frameContext: theFP)) ifTrue:
[^false]].
(theFP := self frameCallerFP: theFP) ~= 0] whileTrue.
^true!
Item was changed:
----- Method: StackInterpreter>>okayFields: (in category 'debug support') -----
okayFields: oop
"Check if the argument is an ok object.
If this is a pointers object, check that its fields are all okay oops."
| i fieldOop |
(oop = nil or: [oop = 0]) ifTrue: [ ^true ].
(objectMemory isIntegerObject: oop) ifTrue: [ ^true ].
(objectMemory okayOop: oop) ifFalse: [ ^false ].
(self oopHasOkayClass: oop) ifFalse: [ ^false ].
+ ((objectMemory isPointersNonInt: oop) or: [objectMemory isCompiledMethod: oop]) ifFalse: [ ^true ].
- ((objectMemory isPointers: oop) or: [objectMemory isCompiledMethod: oop]) ifFalse: [ ^true ].
(objectMemory isCompiledMethod: oop)
ifTrue:
[i := (self literalCountOf: oop) - 1]
ifFalse:
+ [(objectMemory isContext: oop)
- [(self isContext: oop)
ifTrue: [i := CtxtTempFrameStart + (self fetchStackPointerOf: oop) - 1]
ifFalse: [i := (objectMemory lengthOf: oop) - 1]].
[i >= 0] whileTrue: [
fieldOop := objectMemory fetchPointer: i ofObject: oop.
(objectMemory isIntegerObject: fieldOop) ifFalse: [
(objectMemory okayOop: fieldOop) ifFalse: [ ^false ].
(self oopHasOkayClass: fieldOop) ifFalse: [ ^false ].
].
i := i - 1.
].
^true!
Item was changed:
----- Method: StackInterpreter>>oopHasOkayClass: (in category 'debug support') -----
oopHasOkayClass: signedOop
"Attempt to verify that the given oop has a reasonable behavior. The class must be a valid, non-integer oop and must not be nilObj. It must be a pointers object with three or more fields. Finally, the instance specification field of the behavior must match that of the instance."
| oop oopClass formatMask behaviorFormatBits oopFormatBits |
<var: #oop type: #usqInt>
<var: #oopClass type: #usqInt>
oop := self cCoerce: signedOop to: #usqInt.
objectMemory okayOop: oop.
oopClass := self cCoerce: (objectMemory fetchClassOf: oop) to: #usqInt.
(objectMemory isIntegerObject: oopClass)
ifTrue: [ self error: 'a SmallInteger is not a valid class or behavior'. ^false ].
(objectMemory okayOop: oopClass)
ifFalse: [ self error: 'class oop is not ok'. ^false ].
+ ((objectMemory isPointersNonInt: oopClass) and: [(objectMemory lengthOf: oopClass) >= 3])
- ((objectMemory isPointers: oopClass) and: [(objectMemory lengthOf: oopClass) >= 3])
ifFalse: [ self error: 'a class (behavior) must be a pointers object of size >= 3'. ^false ].
(objectMemory isBytes: oop)
ifTrue: [ formatMask := 16rC00 ] "ignore extra bytes size bits"
ifFalse: [ formatMask := 16rF00 ].
behaviorFormatBits := (objectMemory formatOfClass: oopClass) bitAnd: formatMask.
oopFormatBits := (objectMemory baseHeader: oop) bitAnd: formatMask.
behaviorFormatBits = oopFormatBits
ifFalse: [ self error: 'object and its class (behavior) formats differ'. ^false ].
^true!
Item was changed:
----- Method: StackInterpreter>>printCallStackOf: (in category 'debug printing') -----
printCallStackOf: aContextOrProcess
<api>
| context |
<inline: false>
<var: #theFP type: #'char *'>
+ ((objectMemory isContext: aContextOrProcess) not
- ((self isContext: aContextOrProcess) not
and: [(objectMemory lengthOf: aContextOrProcess) > MyListIndex
+ and: [objectMemory isContext: (objectMemory
- and: [self isContext: (objectMemory
fetchPointer: SuspendedContextIndex
ofObject: aContextOrProcess)]]) ifTrue:
[^self printCallStackOf: (objectMemory
fetchPointer: SuspendedContextIndex
ofObject: aContextOrProcess)].
context := aContextOrProcess.
[context = objectMemory nilObject] whileFalse:
[(self isMarriedOrWidowedContext: context)
ifTrue:
[(self checkIsStillMarriedContext: context currentFP: framePointer) ifFalse:
[self shortPrintContext: context.
^nil].
context := self shortReversePrintFrameAndCallers: (self frameOfMarriedContext: context)]
ifFalse:
[context := self printContextCallStackOf: context]]!
Item was changed:
----- Method: StackInterpreter>>printOop: (in category 'debug printing') -----
printOop: oop
| cls fmt lastIndex startIP bytecodesPerLine column |
<inline: false>
self printHex: oop.
(objectMemory isIntegerObject: oop) ifTrue:
[^self
cCode: 'printf("=%ld\n", (long)integerValueOf(oop))'
inSmalltalk: [self print: (self shortPrint: oop); cr]].
(oop between: objectMemory startOfMemory and: objectMemory freeStart) ifFalse:
[self print: ' is not on the heap'; cr.
^nil].
(oop bitAnd: (BytesPerWord - 1)) ~= 0 ifTrue:
[self print: ' is misaligned'; cr.
^nil].
(objectMemory isFreeObject: oop) ifTrue:
[self print: ' is a free chunk of size '; printNum: (objectMemory sizeOfFree: oop); cr.
^nil].
self print: ': a(n) '.
self printNameOfClass: (cls := objectMemory fetchClassOfNonInt: oop) count: 5.
cls = (objectMemory splObj: ClassFloat) ifTrue:
[self cr; printFloat: (self dbgFloatValueOf: oop); cr.
^nil].
fmt := objectMemory formatOf: oop.
fmt > 4 ifTrue:
+ [self print: ' nbytes '; printNum: (objectMemory byteLengthOf: oop)].
- [self print: ' nbytes '; printNum: (objectMemory byteSizeOf: oop)].
self cr.
(fmt > 4 and: [fmt < 12]) ifTrue:
["This will answer false if splObj: ClassAlien is nilObject"
(self is: oop KindOfClass: (objectMemory splObj: ClassAlien)) ifTrue:
[self print: ' datasize '; printNum: (self sizeOfAlienData: oop).
self print: ((self isIndirectAlien: oop)
ifTrue: [' indirect @ ']
ifFalse:
[(self isPointerAlien: oop)
ifTrue: [' pointer @ ']
ifFalse: [' direct @ ']]).
self printHex: (self startOfAlienData: oop) asUnsignedInteger; cr.
^nil].
(objectMemory isWords: oop) ifTrue:
+ [lastIndex := 64 min: ((objectMemory byteLengthOf: oop) / BytesPerWord).
- [lastIndex := 64 min: ((objectMemory byteSizeOf: oop) / BytesPerWord).
lastIndex > 0 ifTrue:
[1 to: lastIndex do:
[:index|
self space; printHex: (objectMemory fetchLong32: index - 1 ofObject: oop).
(index \\ self elementsPerPrintOopLine) = 0 ifTrue:
[self cr]].
(lastIndex \\ self elementsPerPrintOopLine) = 0 ifFalse:
[self cr]].
^nil].
^self printStringOf: oop; cr].
lastIndex := 64 min: (startIP := (objectMemory lastPointerOf: oop) / BytesPerWord).
lastIndex > 0 ifTrue:
[1 to: lastIndex do:
[:index|
self cCode: [self printHex: (objectMemory fetchPointer: index - 1 ofObject: oop); space]
inSmalltalk: [self space; printHex: (objectMemory fetchPointer: index - 1 ofObject: oop); space.
self print: (self shortPrint: (objectMemory fetchPointer: index - 1 ofObject: oop))].
(index \\ self elementsPerPrintOopLine) = 0 ifTrue:
[self cr]].
(lastIndex \\ self elementsPerPrintOopLine) = 0 ifFalse:
[self cr]].
(objectMemory isCompiledMethod: oop)
ifFalse:
[startIP > 64 ifTrue: [self print: '...'; cr]]
ifTrue:
[startIP := startIP * BytesPerWord + 1.
lastIndex := objectMemory lengthOf: oop.
lastIndex - startIP > 100 ifTrue:
[lastIndex := startIP + 100].
bytecodesPerLine := 8.
column := 1.
startIP to: lastIndex do:
[:index| | byte |
column = 1 ifTrue:
[self cCode: 'printf("0x%08x: ", oop+BaseHeaderSize+index-1)'
inSmalltalk: [self print: (oop+BaseHeaderSize+index-1) hex; print: ': ']].
byte := objectMemory fetchByte: index - 1 ofObject: oop.
self cCode: 'printf(" %02x/%-3d", byte,byte)'
inSmalltalk: [self space; print: (byte radix: 16); printChar: $/; printNum: byte].
column := column + 1.
column > bytecodesPerLine ifTrue:
[column := 1. self cr]].
column = 1 ifFalse:
[self cr]]!
Item was changed:
----- Method: StackInterpreter>>selectorOfContext: (in category 'debug printing') -----
selectorOfContext: aContext
+ (objectMemory isContext: aContext) ifFalse:
- (self isContext: aContext) ifFalse:
[^nil].
^self
findSelectorOfMethod: (objectMemory fetchPointer: MethodIndex ofObject: aContext)
forReceiver: (objectMemory fetchPointer: ReceiverIndex ofObject: aContext)!
Item was changed:
----- Method: StackInterpreter>>shortPrintContext: (in category 'debug printing') -----
shortPrintContext: aContext
| theFP |
<inline: false>
<var: #theFP type: #'char *'>
+ (objectMemory isContext: aContext) ifFalse:
- (self isContext: aContext) ifFalse:
[self printHex: aContext; print: ' is not a context'; cr.
^nil].
self printHex: aContext.
(self isMarriedOrWidowedContext: aContext)
ifTrue: [(self checkIsStillMarriedContext: aContext currentFP: framePointer)
ifTrue:
[(self isMachineCodeFrame: (theFP := self frameOfMarriedContext: aContext))
ifTrue: [self print: ' M (']
ifFalse: [self print: ' I ('].
self printHex: theFP asUnsignedInteger; print: ') ']
ifFalse:
[self print: ' w ']]
ifFalse: [self print: ' s '].
(self findHomeForContext: aContext)
ifNil: [self print: ' BOGUS CONTEXT (can''t determine home)']
ifNotNil:
[:home|
self printActivationNameFor: (objectMemory fetchPointer: MethodIndex ofObject: aContext)
receiver: (home isNil
ifTrue: [objectMemory nilObject]
ifFalse: [objectMemory fetchPointer: ReceiverIndex ofObject: home])
isBlock: home ~= aContext
firstTemporary: (objectMemory fetchPointer: 0 + CtxtTempFrameStart ofObject: home)].
self cr!
Item was changed:
----- Method: StackInterpreter>>validStackPageBaseFrames (in category 'stack pages') -----
validStackPageBaseFrames
"Check that the base frames in all in-use stack pages have a valid sender context."
<var: #aPage type: #'StackPage *'>
0 to: numStackPages - 1 do:
[:i| | aPage senderContextOrNil |
aPage := stackPages stackPageAt: i.
(stackPages isFree: aPage) ifFalse:
[(self asserta: (self isBaseFrame: aPage baseFP)) ifFalse:
[^false].
senderContextOrNil := self frameCallerContext: aPage baseFP.
(self asserta: (objectMemory addressCouldBeObj: senderContextOrNil)) ifFalse:
[^false].
+ (self asserta: (senderContextOrNil = objectMemory nilObject or: [objectMemory isContext: senderContextOrNil])) ifFalse:
- (self asserta: (senderContextOrNil = objectMemory nilObject or: [self isContext: senderContextOrNil])) ifFalse:
[^false]]].
^true!
Item was changed:
----- Method: StackInterpreterPrimitives>>cloneContext: (in category 'primitive support') -----
cloneContext: aContext
+ | sz cloned spouseFP sp |
- | cloned spouseFP sp |
<var: #spouseFP type: #'char *'>
+ sz := (objectMemory byteLengthOf: aContext) + BaseHeaderSize.
+ cloned := objectMemory eeInstantiateMethodContextByteSize: sz.
- cloned := objectMemory eeInstantiateMethodContextByteSize: (objectMemory byteSizeOf: aContext).
cloned ~= 0 ifTrue:
[0 to: StackPointerIndex do:
[:i|
objectMemory
storePointerUnchecked: i
ofObject: cloned
withValue: (self externalInstVar: i ofContext: aContext)].
MethodIndex to: ReceiverIndex do:
[:i|
objectMemory
storePointerUnchecked: i
ofObject: cloned
withValue: (self fetchPointer: i ofObject: aContext)].
(self isStillMarriedContext: aContext)
ifTrue:
[spouseFP := self frameOfMarriedContext: aContext.
sp := (self stackPointerIndexForFrame: spouseFP) - 1.
0 to: sp do:
[:i|
objectMemory
storePointerUnchecked: i + CtxtTempFrameStart
ofObject: cloned
withValue: (self temporary: i in: spouseFP)]]
ifFalse:
[sp := (self fetchStackPointerOf: aContext) - 1.
0 to: sp do:
[:i|
objectMemory
storePointerUnchecked: i + CtxtTempFrameStart
ofObject: cloned
withValue: (self fetchPointer: i + CtxtTempFrameStart ofObject: aContext)]]].
^cloned!
Item was changed:
----- Method: StackInterpreterPrimitives>>primitiveFindNextUnwindContext (in category 'control primitives') -----
primitiveFindNextUnwindContext
"Primitive. Search up the context stack for the next method context marked for unwind
handling from the receiver up to but not including the argument. Return nil if none found."
| stopContext calleeContext handlerOrNilOrZero |
<var: #theFP type: #'char *'>
stopContext := self stackTop.
calleeContext := self stackValue: 1.
+ (stopContext = objectMemory nilObject or: [objectMemory isContext: stopContext]) ifFalse:
- (stopContext = objectMemory nilObject or: [self isContext: stopContext]) ifFalse:
[^self primitiveFail].
self externalWriteBackHeadFramePointers.
(self isStillMarriedContext: calleeContext)
ifTrue:
[| theFP |
theFP := self frameOfMarriedContext: calleeContext.
(self isBaseFrame: theFP)
ifTrue:
[handlerOrNilOrZero := self findMethodWithPrimitive: 198
FromContext: (self frameCallerContext: theFP)
UpToContext: stopContext]
ifFalse:
[handlerOrNilOrZero := self findMethodWithPrimitive: 198
FromFP: (self frameCallerFP: theFP)
UpToContext: stopContext]]
ifFalse:
[| startContext |
startContext := objectMemory fetchPointer: SenderIndex ofObject: calleeContext.
+ (objectMemory isContext: startContext)
- (self isContext: startContext)
ifTrue:
[handlerOrNilOrZero := self findMethodWithPrimitive: 198
FromContext: startContext
UpToContext: stopContext]
ifFalse:
[handlerOrNilOrZero := 0]].
handlerOrNilOrZero = 0 ifTrue:
[handlerOrNilOrZero := objectMemory nilObject].
self pop: 2 thenPush: handlerOrNilOrZero!
Item was changed:
----- Method: StackInterpreterPrimitives>>primitiveTerminateTo (in category 'control primitives') -----
primitiveTerminateTo
"Primitive. Terminate up the context stack from the receiver up to but not including
the argument, if previousContext is on my Context stack. Make previousContext my
sender. This prim has to shadow the code in ContextPart>terminateTo: to be correct."
| thisCtx currentCtx aContextOrNil contextsFP contextsSP contextsIP nextCntx stackedReceiverOffset
theFP newFP newSP pageToStopOn thePage frameAbove |
<var: #contextsFP type: #'char *'>
<var: #theFP type: #'char *'>
<var: #newFP type: #'char *'>
<var: #newSP type: #'char *'>
<var: #contextsIP type: #usqInt>
<var: #frameAbove type: #'char *'>
<var: #contextsSP type: #'char *'>
<var: #source type: #'char *'>
<var: #pageToStopOn type: #'StackPage *'>
<var: #thePage type: #'StackPage *'>
aContextOrNil := self stackTop.
+ (aContextOrNil = objectMemory nilObject or: [objectMemory isContext: aContextOrNil]) ifFalse:
- (aContextOrNil = objectMemory nilObject or: [self isContext: aContextOrNil]) ifFalse:
[^self primitiveFail].
thisCtx := self stackValue: 1.
thisCtx = aContextOrNil ifTrue:
[^self primitiveFail].
"All stackPages need to have current head pointers to avoid confusion."
self externalWriteBackHeadFramePointers.
"If we're searching for aContextOrNil it might be on a stack page. Helps to know
if we can free a whole page or not, or if we can short-cut the termination."
(aContextOrNil ~= objectMemory nilObject and: [self isStillMarriedContext: aContextOrNil])
ifTrue: [contextsFP := self frameOfMarriedContext: aContextOrNil.
pageToStopOn := stackPages stackPageFor: contextsFP]
ifFalse: [pageToStopOn := 0].
"if thisCtx is married ensure it is a base frame. Then we can assign its sender."
(self isStillMarriedContext: thisCtx)
ifTrue:
[theFP := self frameOfMarriedContext: thisCtx.
"Optimize terminating thisContext. Move its frame down to be next to
aContextOrNil's frame. Common in the exception system and so helps to be fast."
(theFP = framePointer
and: [pageToStopOn = stackPage]) ifTrue:
[(self frameCallerFP: theFP) ~= contextsFP ifTrue:
[stackedReceiverOffset := self frameStackedReceiverOffset: theFP.
frameAbove := self findFrameAbove: contextsFP inPage: pageToStopOn.
contextsIP := (self frameCallerSavedIP: frameAbove) asUnsignedInteger.
newSP := self frameCallerSP: frameAbove.
newFP := newSP - stackedReceiverOffset - BytesPerWord.
theFP + stackedReceiverOffset
to: stackPointer
by: BytesPerWord negated
do: [:source|
newSP := newSP - BytesPerWord.
stackPages longAt: newSP put: (stackPages longAt: source)].
stackPages longAt: newFP + FoxSavedFP put: contextsFP.
stackPages longAt: newFP + FoxCallerSavedIP put: contextsIP.
+ self assert: (objectMemory isContext: thisCtx).
- self assert: (self isContext: thisCtx).
objectMemory storePointerUnchecked: SenderIndex
ofObject: thisCtx
withValue: (self withSmallIntegerTags: newFP).
objectMemory storePointerUnchecked: InstructionPointerIndex
ofObject: thisCtx
withValue: (self withSmallIntegerTags: contextsFP).
framePointer := newFP.
stackPointer := newSP].
self pop: 1.
self assert: stackPage = stackPages mostRecentlyUsedPage.
^nil].
theFP := self externalEnsureIsBaseFrame: theFP. "May cause a GC!!!!"
currentCtx := self frameCallerContext: theFP.
"May also reclaim aContextOrNil's page, hence..."
(aContextOrNil ~= objectMemory nilObject and: [self isStillMarriedContext: aContextOrNil])
ifTrue: [contextsFP := self frameOfMarriedContext: aContextOrNil.
pageToStopOn := stackPages stackPageFor: contextsFP]
ifFalse: [pageToStopOn := 0]]
ifFalse:
[currentCtx := objectMemory fetchPointer: SenderIndex ofObject: thisCtx].
(self context: thisCtx hasSender: aContextOrNil) ifTrue:
["Need to walk the stack freeing stack pages and nilling contexts."
[currentCtx = aContextOrNil
or: [currentCtx = objectMemory nilObject]] whileFalse:
+ [self assert: (objectMemory isContext: currentCtx).
- [self assert: (self isContext: currentCtx).
(self isMarriedOrWidowedContext: currentCtx)
ifTrue:
[theFP := self frameOfMarriedContext: currentCtx.
thePage := stackPages stackPageFor: theFP.
"If externalEnsureIsBaseFrame: above has moved thisContext to its own stack
then we will always terminate to a frame on a different page. But if we are
terminating some other context to a context somewhere on the current page
we must save the active frames above that context. Things will look e.g. like this:
thisCtx 499383332 s MethodContext(ContextPart)>resume:
499380484 s BlockClosure>ensure:
499377320 s MethodContext(ContextPart)>handleSignal:
499373760 s MethodContext(ContextPart)>handleSignal:
499372772 s MessageNotUnderstood(Exception)>signal
499369068 s CodeSimulationTests(Object)>doesNotUnderstand: absentMethod
499368708 s [] in CodeSimulationTests>testDNU
(sender is 0xbffc2480 I CodeSimulationTests>runSimulated:)
------------
framePointer 0xbffc234c M MethodContext(ContextPart)>doPrimitive:method:receiver:args:
0xbffc2378 M MethodContext(ContextPart)>tryPrimitiveFor:receiver:args:
0xbffc23ac M MethodContext(ContextPart)>send:to:with:super:
0xbffc23e4 M MethodContext(ContextPart)>send:super:numArgs:
0xbffc2418 M MethodContext(InstructionStream)>interpretNextInstructionFor:
0xbffc2434 M MethodContext(ContextPart)>step
0xbffc2458 I MethodContext(ContextPart)>runSimulated:contextAtEachStep:
------------
(499368708's sender) 0xbffc2480 I CodeSimulationTests>runSimulated:
0xbffc249c M CodeSimulationTests>testDNU
0xbffc24bc I CodeSimulationTests(TestCase)>performTest
0xbffc24dc I [] in CodeSimulationTests(TestCase)>runCase
aContextOrNil 0xbffc24fc M BlockClosure>ensure:
0xbffc2520 I CodeSimulationTests(TestCase)>runCase
0xbffc253c M [] in TestResult>runCase:
When we find this case we move the frames above to a new page by making the
frame above currentCtx a base frame, i.e. making 0xbffc2458 in the above example
a base frame. But in this iteration of the loop we don't move down a frame i.e. currentCtx
doesn't change on this iteration."
thePage = stackPage
ifTrue:
[frameAbove := self findFrameAbove: theFP inPage: thePage.
self assert: frameAbove ~= 0.
frameAbove := self externalEnsureIsBaseFrame: frameAbove. "May cause a GC!!!! May also reclaim aContextOrNil's page, hence..."
(aContextOrNil ~= objectMemory nilObject and: [self isStillMarriedContext: aContextOrNil])
ifTrue: [contextsFP := self frameOfMarriedContext: aContextOrNil.
pageToStopOn := stackPages stackPageFor: contextsFP]
ifFalse: [pageToStopOn := 0]]
ifFalse:
[thePage = pageToStopOn
ifTrue:
["We're here. Cut back the stack to aContextOrNil's frame,
push its instructionPointer if it's not already a head frame,
and we're done."
frameAbove := self findFrameAbove: contextsFP inPage: thePage.
frameAbove ~= 0 ifTrue:
[contextsSP := (self frameCallerSP: frameAbove) - BytesPerWord.
stackPages longAt: contextsSP put: (self frameCallerSavedIP: frameAbove).
self setHeadFP: contextsFP andSP: contextsSP inPage: thePage].
currentCtx := aContextOrNil]
ifFalse:
["We can free the entire page without further ado."
currentCtx := self frameCallerContext: thePage baseFP.
"for a short time invariant is violated; assert follows"
stackPages freeStackPageNoAssert: thePage]]]
ifFalse:
[nextCntx := objectMemory fetchPointer: SenderIndex ofObject: currentCtx.
self markContextAsDead: currentCtx.
currentCtx := nextCntx]]].
self assert: stackPages pageListIsWellFormed.
(self isMarriedOrWidowedContext: thisCtx)
ifTrue:
[self assert: (self checkIsStillMarriedContext: thisCtx currentFP: framePointer).
self assert: (self isBaseFrame: (self frameOfMarriedContext: thisCtx)).
theFP := self frameOfMarriedContext: thisCtx.
self frameCallerContext: theFP put: aContextOrNil]
ifFalse: [objectMemory storePointer: SenderIndex ofObject: thisCtx withValue: aContextOrNil].
self pop: 1.
self assert: stackPage = stackPages mostRecentlyUsedPage!
Item was changed:
----- Method: StackInterpreterSimulator>>baseFrameReturn (in category 'return bytecodes') -----
baseFrameReturn
| contextToReturnTo |
contextToReturnTo := self frameCallerContext: localFP.
+ ((objectMemory isContext: contextToReturnTo)
- ((self isContext: contextToReturnTo)
and: [self isMarriedOrWidowedContext: contextToReturnTo]) ifTrue:
[(self checkIsStillMarriedContext: contextToReturnTo currentFP: nil) ifFalse:
[self halt]].
^super baseFrameReturn!
Item was changed:
----- Method: StackInterpreterSimulator>>externalInstVar:ofContext:put: (in category 'frame access') -----
externalInstVar: index ofContext: aMarriedContext put: anOop
| imMarried shesMarried result |
index == SenderIndex ifTrue:
[imMarried := self checkIsStillMarriedContext: aMarriedContext currentFP: localFP.
+ (objectMemory isContext: anOop) ifTrue:
- (self isContext: anOop) ifTrue:
[shesMarried := self checkIsStillMarriedContext: anOop currentFP: localFP.
"self shortPrintContext: aMarriedContext.
self shortPrintContext: anOop"]].
result := super externalInstVar: index ofContext: aMarriedContext put: anOop.
imMarried ifNotNil:
[self assert: imMarried == (self checkIsStillMarriedContext: aMarriedContext currentFP: nil).
shesMarried ifNotNil:
[self assert: shesMarried == (self checkIsStillMarriedContext: anOop currentFP: nil)]].
^result!
Item was changed:
----- Method: StackInterpreterSimulator>>instVar:ofContext:put: (in category 'frame access') -----
instVar: index ofContext: aMarriedContext put: anOop
| imMarried shesMarried result |
index == SenderIndex ifTrue:
[imMarried := self checkIsStillMarriedContext: aMarriedContext currentFP: localFP.
+ (objectMemory isContext: anOop) ifTrue:
- (self isContext: anOop) ifTrue:
[shesMarried := self checkIsStillMarriedContext: anOop currentFP: localFP.
"self cr.
self shortPrintContext: aMarriedContext.
self shortPrintContext: anOop.
(#('yield:' 'nextPut:') includesAnyOf: {self stringOf: (self selectorOfContext: aMarriedContext). self stringOf: (self selectorOfContext: anOop)}) ifTrue:
[self halt]"]].
result := super instVar: index ofContext: aMarriedContext put: anOop.
imMarried ifNotNil:
[self assert: imMarried == (self checkIsStillMarriedContext: aMarriedContext currentFP: nil).
shesMarried ifNotNil:
[self assert: shesMarried == (self checkIsStillMarriedContext: anOop currentFP: nil)]].
^result!
Item was changed:
----- Method: StackInterpreterSimulator>>methodForContext: (in category 'simulation only') -----
methodForContext: aContextOop
+ self assert: (objectMemory isContext: aContextOop).
- self assert: (self isContext: aContextOop).
^objectMemory fetchPointer: MethodIndex ofObject: aContextOop!
Item was added:
+ ----- Method: VMClass>>mem:mo:ve: (in category 'C library simulation') -----
+ mem: destAddress mo: sourceAddress ve: bytes
+ <doNotGenerate>
+ | dst src |
+ dst := destAddress asInteger.
+ src := sourceAddress asInteger.
+ "Emulate the c library memmove function"
+ self assert: bytes \\ 4 = 0.
+ destAddress > sourceAddress
+ ifTrue:
+ [bytes - 4 to: 0 by: -4 do:
+ [:i| self longAt: dst + i put: (self longAt: src + i)]]
+ ifFalse:
+ [0 to: bytes - 4 by: 4 do:
+ [:i| self longAt: dst + i put: (self longAt: src + i)]]!
More information about the Vm-dev
mailing list