[Vm-dev] VM Maker: VMMaker-oscog-EstebanLorenzano.234.mcz
commits at source.squeak.org
commits at source.squeak.org
Wed Mar 6 13:17:22 UTC 2013
Esteban Lorenzano uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker-oscog-EstebanLorenzano.234.mcz
==================== Summary ====================
Name: VMMaker-oscog-EstebanLorenzano.234
Author: EstebanLorenzano
Time: 6 March 2013, 2:13:03.474 pm
UUID: 26b9f698-94a5-45ed-bf30-28f2bf8f3912
Ancestors: VMMaker-oscog-EstebanLorenzano.233, VMMaker.oscog-eem.270
- merged with Eiot's 270, to fix the become problem (looks solved now)
=============== Diff against VMMaker-oscog-EstebanLorenzano.233 ===============
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>>ceCounterTripped: (in category 'cog jit support') -----
ceCounterTripped: condition
<api>
<option: #SistaStackToRegisterMappingCogit>
+ "Send e.g. thisContext conditionalBranchCounterTrippedOn: boolean."
- "Send e.g. thisContext conditionalBranchCounterTrippedAt: bcpc boolean: boolean."
| context counterTrippedSelector |
counterTrippedSelector := objectMemory maybeSplObj: SelectorCounterTripped.
(counterTrippedSelector isNil
or: [counterTrippedSelector = objectMemory nilObject]) ifTrue:
[cogit resetCountersIn: (self mframeHomeMethod: framePointer).
^condition].
lkupClass := self splObj: ClassMethodContext.
(self lookupInMethodCacheSel: counterTrippedSelector class: lkupClass) ifFalse:
[messageSelector := counterTrippedSelector.
(self lookupMethodNoMNUEtcInClass: lkupClass) ~= 0 ifTrue:
[cogit resetCountersIn: (self mframeHomeMethod: framePointer).
^condition]].
(primitiveFunctionPointer ~= 0
or: [(self argumentCountOf: newMethod) ~= 1]) ifTrue:
[cogit resetCountersIn: (self mframeHomeMethod: framePointer).
^condition].
instructionPointer := self popStack.
context := self ensureFrameIsMarried: framePointer SP: stackPointer.
self push: context.
self push: condition.
self ifAppropriateCompileToNativeCode: newMethod selector: messageSelector.
self activateNewMethod.
"not reached"
^true!
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 changed:
VMStructType subclass: #CogBlockMethod
+ instanceVariableNames: 'objectHeader homeOffset startpc padToWord cmNumArgs cmType cmRefersToYoung cpicHasMNUCase cmUsageCount cmUsesPenultimateLit cmUnusedFlags stackCheckOffset'
- instanceVariableNames: 'objectHeader homeOffset startpc padToWord cmNumArgs cmType cmRefersToYoung cpicHasMNUCase cmUsageCount stackCheckOffset'
classVariableNames: ''
poolDictionaries: 'CogMethodConstants VMBasicConstants'
category: 'VMMaker-JIT'!
!CogBlockMethod commentStamp: 'eem 1/9/2011 08:41' prior: 0!
I am the rump method header for a block method embedded in a full CogMethod. I am the superclass of CogMethod, which is a Cog method header proper. Instances of both classes have the same second word. The homeOffset abd startpc fields are overlaid on the objectHeader in a CogMethod. In C I look like
typedef struct {
unsigned short homeOffset;
unsigned short startpc;
unsigned cmNumArgs : 8;
unsigned cmType : 3;
unsigned cmRefersToYoung : 1;
unsigned cmIsUnlinked : 1;
unsigned cmUsageCount : 3;
unsigned stackCheckOffset : 16;
} CogBlockMethod;
My instances are not actually used. The methods exist only as input to Slang. The simulator uses my surrogates (CogBlockMethodSurrogate32 and CogBlockMethodSurrogate64.!
Item was changed:
----- Method: CogBlockMethod class>>initialize (in category 'class initialization') -----
initialize
"CogBlockMethod initialize"
"CogBlockMethod initialize. CogMethod initialize"
(Smalltalk classNamed: #CogBlockMethodSurrogate32) ifNotNil:
[:cbms32|
self checkGenerateSurrogate: cbms32 bytesPerWord: 4].
(Smalltalk classNamed: #CogBlockMethodSurrogate64) ifNotNil:
[:cbms64|
self checkGenerateSurrogate: cbms64 bytesPerWord: 8].
+ "see instVarNamesAndTypesForTranslationDo:"
+ CMMaxUsageCount := (2 raisedTo: 3) - 1.
+ MaxStackCheckOffset := (2 raisedTo: 12) - 1.
+ MaxMethodSize := (2 raisedTo: 16) - 1
- CMMaxUsageCount := 7 "see instVarNamesAndTypesForTranslationDo:"
"{ CogBlockMethodSurrogate32 selectors reject: [:s| CogBlockMethod includesSelector: s].
CogBlockMethodSurrogate64 selectors reject: [:s| CogBlockMethod includesSelector: s].
CogMethodSurrogate32 selectors reject: [:s| CogMethod includesSelector: s].
CogMethodSurrogate64 selectors reject: [:s| CogMethod includesSelector: s]. }"!
Item was changed:
----- Method: CogBlockMethod class>>instVarNamesAndTypesForTranslationDo: (in category 'translation') -----
instVarNamesAndTypesForTranslationDo: aBinaryBlock
"enumerate aBinaryBlock with the names and C type strings for the inst vars to include in a CogMethod or CogBlockMethod struct."
self allInstVarNames do:
[:ivn|
"Notionally objectHeader is in a union with homeOffset and startpc but
we don't have any convenient support for unions. So hack, hack, hack, hack."
((self == CogBlockMethod
ifTrue: [#('objectHeader')]
ifFalse: [#('homeOffset' 'startpc' 'padToWord')]) includes: ivn) ifFalse:
[aBinaryBlock
value: ivn
value: (ivn caseOf: {
+ ['cmNumArgs'] -> [#(unsigned ' : 8')]. "SqueakV3 needs only 5 bits"
+ ['cmType'] -> [#(unsigned ' : 3')].
+ ['cmRefersToYoung'] -> [#(unsigned #Boolean ' : 1')].
+ ['cpicHasMNUCase'] -> [#(unsigned #Boolean ' : 1')].
+ ['cmUsageCount'] -> [#(unsigned ' : 3')]. "see CMMaxUsageCount in initialize"
+ ['cmUsesPenultimateLit'] -> [#(unsigned #Boolean ' : 1')].
+ ['cmUnusedFlags'] -> [#(unsigned ' : 3')].
+ ['stackCheckOffset'] -> [#(unsigned ' : 12')]. "See MaxStackCheckOffset in initialize. a.k.a. cPICNumCases"
+ ['blockSize'] -> [#'unsigned short']. "See MaxMethodSize in initialize"
+ ['blockEntryOffset'] -> [#'unsigned short'].
+ ['homeOffset'] -> [#'unsigned short'].
+ ['startpc'] -> [#'unsigned short'].
+ ['padToWord'] -> [#(#BytesPerWord 8 'unsigned int')]}
- ['cmNumArgs'] -> [#(unsigned ' : 8')]. "SqueakV3 needs only 5 bits"
- ['cmType'] -> [#(unsigned ' : 3')].
- ['cmRefersToYoung'] -> [#(unsigned #Boolean ' : 1')].
- ['cpicHasMNUCase'] -> [#(unsigned #Boolean ' : 1')].
- ['cmUsageCount'] -> [#(unsigned ' : 3')]. "see CMMaxUsageCount in initialize"
- ['stackCheckOffset'] -> [#(unsigned ' : 16')]. "a.k.a. cPICNumCases"
- ['blockSize'] -> [#'unsigned short'].
- ['blockEntryOffset'] -> [#'unsigned short'].
- ['homeOffset'] -> [#'unsigned short'].
- ['startpc'] -> [#'unsigned short'].
- ['padToWord'] -> [#(#BytesPerWord 8 'unsigned int')]}
otherwise:
[#sqInt])]]!
Item was added:
+ ----- Method: CogBlockMethod>>cmUsesPenultimateLit (in category 'accessing') -----
+ cmUsesPenultimateLit
+ "Answer the value of cmUsesPenultimateLit"
+
+ ^cmUsesPenultimateLit!
Item was added:
+ ----- Method: CogBlockMethod>>cmUsesPenultimateLit: (in category 'accessing') -----
+ cmUsesPenultimateLit: anObject
+ "Set the value of cmUsesPenultimateLit"
+
+ ^cmUsesPenultimateLit := anObject!
Item was added:
+ ----- Method: CogBlockMethodSurrogate32>>cmUsesPenultimateLit (in category 'accessing') -----
+ cmUsesPenultimateLit
+ ^((memory unsignedByteAt: address + 7) bitAnd: 16r1) ~= 0!
Item was added:
+ ----- Method: CogBlockMethodSurrogate32>>cmUsesPenultimateLit: (in category 'accessing') -----
+ cmUsesPenultimateLit: aValue
+ memory
+ unsignedByteAt: address + 7
+ put: (((memory unsignedByteAt: address + 7) bitAnd: 16rFE) + (aValue ifTrue: [1] ifFalse: [0])).
+ ^aValue!
Item was changed:
----- Method: CogBlockMethodSurrogate32>>stackCheckOffset (in category 'accessing') -----
stackCheckOffset
+ ^((memory unsignedShortAt: address + 7) bitShift: -4) bitAnd: 16rFFF!
- ^memory unsignedShortAt: address + 7!
Item was changed:
----- Method: CogBlockMethodSurrogate32>>stackCheckOffset: (in category 'accessing') -----
stackCheckOffset: aValue
+ self assert: (aValue between: 0 and: 16rFFF).
+ memory
- ^memory
unsignedShortAt: address + 7
+ put: ((memory unsignedShortAt: address + 7) bitAnd: 16rF) + (aValue bitShift: 4).
+ ^aValue!
- put: aValue!
Item was added:
+ ----- Method: CogBlockMethodSurrogate64>>cmUsesPenultimateLit (in category 'accessing') -----
+ cmUsesPenultimateLit
+ ^((memory unsignedByteAt: address + 11) bitAnd: 16r1) ~= 0!
Item was added:
+ ----- Method: CogBlockMethodSurrogate64>>cmUsesPenultimateLit: (in category 'accessing') -----
+ cmUsesPenultimateLit: aValue
+ memory
+ unsignedByteAt: address + 11
+ put: (((memory unsignedByteAt: address + 11) bitAnd: 16rFE) + (aValue ifTrue: [1] ifFalse: [0])).
+ ^aValue!
Item was changed:
----- Method: CogBlockMethodSurrogate64>>stackCheckOffset (in category 'accessing') -----
stackCheckOffset
+ ^((memory unsignedShortAt: address + 11) bitShift: -4) bitAnd: 16rFFF!
- ^memory unsignedShortAt: address + 11!
Item was changed:
----- Method: CogBlockMethodSurrogate64>>stackCheckOffset: (in category 'accessing') -----
stackCheckOffset: aValue
+ self assert: (aValue between: 0 and: 16rFFF).
+ memory
- ^memory
unsignedShortAt: address + 11
+ put: ((memory unsignedShortAt: address + 11) bitAnd: 16rF) + (aValue bitShift: 4).
+ ^aValue!
- put: aValue!
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:
SharedPool subclass: #CogMethodConstants
instanceVariableNames: ''
+ classVariableNames: 'CMBlock CMClosedPIC CMFree CMMaxUsageCount CMMethod CMOpenPIC MaxLiteralCountForCompile MaxMethodSize MaxNumArgs MaxStackCheckOffset PrimCallCollectsProfileSamples PrimCallMayCallBack PrimCallNeedsNewMethod PrimCallNeedsPrimitiveFunction'
- classVariableNames: 'CMBlock CMClosedPIC CMFree CMMaxUsageCount CMMethod CMOpenPIC MaxLiteralCountForCompile MaxNumArgs PrimCallCollectsProfileSamples PrimCallMayCallBack PrimCallNeedsNewMethod PrimCallNeedsPrimitiveFunction'
poolDictionaries: ''
category: 'VMMaker-JIT'!
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 changed:
CogClass subclass: #Cogit
+ instanceVariableNames: 'coInterpreter objectMemory objectRepresentation processor threadManager methodZone methodZoneBase codeBase minValidCallAddress lastNInstructions simulatedAddresses simulatedTrampolines simulatedVariableGetters simulatedVariableSetters printRegisters printInstructions compilationTrace clickConfirm breakPC breakBlock singleStep guardPageSize traceFlags traceStores breakMethod methodObj initialPC endPC methodOrBlockNumArgs inBlock needsFrame hasYoungReferent primitiveIndex backEnd postCompileHook primInvokeLabel methodLabel stackCheckLabel blockEntryLabel blockEntryNoContextSwitch blockNoContextSwitchOffset stackOverflowCall sendMissCall missOffset entryPointMask checkedEntryAlignment cmEntryOffset entry cmNoCheckEntryOffset noCheckEntry dynSuperEntry dynSuperEntryAlignment cmDynSuperEntryOffset mnuCall interpretCall endCPICCase0 endCPICCase1 numPICCases firstCPICCaseOffset cPICCaseSize cPICEndSize closedPICSize openPICSize fixups abstractOpcodes annotations generatorTable primitiveGeneratorTable byte0 byte1 byte2 byte3 bytecodePC bytecodeSetOffset opcodeIndex numAbstractOpcodes annotationIndex blockStarts blockCount labelCounter cStackAlignment expectedSPAlignment expectedFPAlignment codeModified maxMethodBefore maxLitIndex ceMethodAbortTrampoline cePICAbortTrampoline ceCheckForInterruptTrampoline ceCPICMissTrampoline ceStoreCheckTrampoline ceReturnToInterpreterTrampoline ceBaseFrameReturnTrampoline ceSendMustBeBooleanAddTrueTrampoline ceSendMustBeBooleanAddFalseTrampoline ceCannotResumeTrampoline ceClosureCopyTrampoline ceCreateNewArrayTrampoline ceEnterCogCodePopReceiverReg ceEnterCogCodePopReceiverAndClassRegs cePrimReturnEnterCogCode cePrimReturnEnterCogCodeProfiling ceNonLocalReturnTrampoline ceActiveContextTrampoline ceFetchContextInstVarTrampoline ceStoreContextInstVarTrampoline cePositive32BitIntegerTrampoline ceImplicitReceiverTrampoline ceExplicitReceiverTrampoline ceCaptureCStackPointers ceFlushICache ceCheckFeaturesFunction ceTraceLinkedSendTrampoline ceTraceBlockActivationTrampoline ceTraceStoreTrampoline ceGetSP sendTrampolines superSendTrampolines dynamicSuperSendTrampolines firstSend lastSend realCEEnterCogCodePopReceiverReg realCEEnterCogCodePopReceiverAndClassRegs trampolineTableIndex trampolineAddresses objectReferencesInRuntime runtimeObjectRefIndex cFramePointerInUse debugPrimCallStackOffset ceTryLockVMOwner ceUnlockVMOwner cogMethodSurrogateClass cogBlockMethodSurrogateClass extA extB'
+ classVariableNames: 'AltBlockCreationBytecodeSize AnnotationConstantNames AnnotationShift BlockCreationBytecodeSize Debug DisplacementMask DisplacementX2N EagerInstructionDecoration EncounteredUnknownBytecode FirstAnnotation HasBytecodePC InsufficientCodeSpace IsAbsPCReference IsDisplacement IsDisplacementX2N IsNSSendCall IsObjectReference IsRelativeCall IsSendCall MapEnd MaxCompiledPrimitiveIndex MaxNegativeErrorCode MaxUnitDisplacement MaxUnreportableError MaxX2NDisplacement MethodTooBig NotFullyInitialized NumObjRefsInRuntime NumSendTrampolines NumTrampolines ProcessorClass YoungSelectorInPIC'
- instanceVariableNames: 'coInterpreter objectMemory objectRepresentation processor threadManager methodZone methodZoneBase codeBase minValidCallAddress lastNInstructions simulatedAddresses simulatedTrampolines simulatedVariableGetters simulatedVariableSetters printRegisters printInstructions compilationTrace clickConfirm breakPC breakBlock singleStep guardPageSize traceFlags traceStores breakMethod methodObj initialPC endPC methodOrBlockNumArgs inBlock needsFrame hasYoungReferent primitiveIndex backEnd postCompileHook primInvokeLabel methodLabel stackCheckLabel blockEntryLabel blockEntryNoContextSwitch blockNoContextSwitchOffset stackOverflowCall sendMissCall missOffset entryPointMask checkedEntryAlignment cmEntryOffset entry cmNoCheckEntryOffset noCheckEntry dynSuperEntry dynSuperEntryAlignment cmDynSuperEntryOffset mnuCall interpretCall endCPICCase0 endCPICCase1 numPICCases firstCPICCaseOffset cPICCaseSize cPICEndSize closedPICSize openPICSize fixups abstractOpcodes annotations generatorTable primitiveGeneratorTable byte0 byte1 byte2 byte3 bytecodePC bytecodeSetOffset opcodeIndex numAbstractOpcodes annotationIndex blockStarts blockCount labelCounter cStackAlignment expectedSPAlignment expectedFPAlignment codeModified maxMethodBefore ceMethodAbortTrampoline cePICAbortTrampoline ceCheckForInterruptTrampoline ceCPICMissTrampoline ceStoreCheckTrampoline ceReturnToInterpreterTrampoline ceBaseFrameReturnTrampoline ceSendMustBeBooleanAddTrueTrampoline ceSendMustBeBooleanAddFalseTrampoline ceCannotResumeTrampoline ceClosureCopyTrampoline ceCreateNewArrayTrampoline ceEnterCogCodePopReceiverReg ceEnterCogCodePopReceiverAndClassRegs cePrimReturnEnterCogCode cePrimReturnEnterCogCodeProfiling ceNonLocalReturnTrampoline ceActiveContextTrampoline ceFetchContextInstVarTrampoline ceStoreContextInstVarTrampoline cePositive32BitIntegerTrampoline ceImplicitReceiverTrampoline ceExplicitReceiverTrampoline ceCaptureCStackPointers ceFlushICache ceCheckFeaturesFunction ceTraceLinkedSendTrampoline ceTraceBlockActivationTrampoline ceTraceStoreTrampoline ceGetSP sendTrampolines superSendTrampolines dynamicSuperSendTrampolines firstSend lastSend realCEEnterCogCodePopReceiverReg realCEEnterCogCodePopReceiverAndClassRegs trampolineTableIndex trampolineAddresses objectReferencesInRuntime runtimeObjectRefIndex cFramePointerInUse debugPrimCallStackOffset ceTryLockVMOwner ceUnlockVMOwner cogMethodSurrogateClass cogBlockMethodSurrogateClass extA extB'
- classVariableNames: 'AltBlockCreationBytecodeSize AnnotationConstantNames AnnotationShift BlockCreationBytecodeSize Debug DisplacementMask DisplacementX2N EagerInstructionDecoration EncounteredUnknownBytecode FirstAnnotation HasBytecodePC InsufficientCodeSpace IsAbsPCReference IsDisplacement IsDisplacementX2N IsNSSendCall IsObjectReference IsRelativeCall IsSendCall MapEnd MaxCompiledPrimitiveIndex MaxNegativeErrorCode MaxUnitDisplacement MaxUnreportableError MaxX2NDisplacement NotFullyInitialized NumObjRefsInRuntime NumSendTrampolines NumTrampolines ProcessorClass YoungSelectorInPIC'
poolDictionaries: 'CogMethodConstants CogRTLOpcodes VMBasicConstants VMObjectIndices VMStackFrameOffsets'
category: 'VMMaker-JIT'!
Cogit class
instanceVariableNames: 'generatorTable primitiveTable'!
!Cogit commentStamp: 'eem 2/13/2013 15:37' prior: 0!
I am the code generator for the Cog VM. My job is to produce machine code versions of methods for faster execution and to manage inline caches for faster send performance. I can be tested in the current image using my class-side in-image compilation facilities. e.g. try
StackToRegisterMappingCogit genAndDis: (Integer >> #benchFib)
I have concrete subclasses that implement different levels of optimization:
SimpleStackBasedCogit is the simplest code generator.
StackToRegisterMappingCogit is the current production code generator It defers pushing operands
to the stack until necessary and implements a register-based calling convention for low-arity sends.
StackToRegisterMappingCogit is an experimental code generator with support for counting
conditional branches, intended to support adaptive optimization.
coInterpreter <CoInterpreterSimulator>
the VM's interpreter with which I cooperate
methodZoneManager <CogMethodZoneManager>
the manager of the machine code zone
objectRepresentation <CogObjectRepresentation>
the object used to generate object accesses
processor <BochsIA32Alien|?>
the simulator that executes the IA32/x86 machine code I generate when simulating execution in Smalltalk
simulatedTrampolines <Dictionary of Integer -> MessageSend>
the dictionary mapping trap jump addresses to run-time routines used to warp from simulated machine code in to the Smalltalk run-time.
simulatedVariableGetters <Dictionary of Integer -> MessageSend>
the dictionary mapping trap read addresses to variables in run-time objects used to allow simulated machine code to read variables in the Smalltalk run-time.
simulatedVariableSetters <Dictionary of Integer -> MessageSend>
the dictionary mapping trap write addresses to variables in run-time objects used to allow simulated machine code to write variables in the Smalltalk run-time.
printRegisters printInstructions clickConfirm <Boolean>
flags controlling debug printing and code simulation
breakPC <Integer>
machine code pc breakpoint
cFramePointer cStackPointer <Integer>
the variables representing the C stack & frame pointers, which must change on FFI callback and return
selectorOop <sqInt>
the oop of the methodObj being compiled
methodObj <sqInt>
the bytecode method being compiled
initialPC endPC <Integer>
the start and end pcs of the methodObj being compiled
methodOrBlockNumArgs <Integer>
argument count of current method or block being compiled
needsFrame <Boolean>
whether methodObj or block needs a frame to execute
primitiveIndex <Integer>
primitive index of current method being compiled
methodLabel <CogAbstractOpcode>
label for the method header
blockEntryLabel <CogAbstractOpcode>
label for the start of the block dispatch code
stackOverflowCall <CogAbstractOpcode>
label for the call of ceStackOverflow in the method prolog
sendMissCall <CogAbstractOpcode>
label for the call of ceSICMiss in the method prolog
entryOffset <Integer>
offset of method entry code from start (header) of method
entry <CogAbstractOpcode>
label for the first instruction of the method entry code
noCheckEntryOffset <Integer>
offset of the start of a method proper (after the method entry code) from start (header) of method
noCheckEntry <CogAbstractOpcode>
label for the first instruction of start of a method proper
fixups <Array of <AbstractOpcode Label | nil>>
the labels for forward jumps that will be fixed up when reaching the relevant bytecode. fixup shas one element per byte in methodObj's bytecode
abstractOpcodes <Array of <AbstractOpcode>>
the code generated when compiling methodObj
byte0 byte1 byte2 byte3 <Integer>
individual bytes of current bytecode being compiled in methodObj
bytecodePointer <Integer>
bytecode pc (same as Smalltalk) of the current bytecode being compiled
opcodeIndex <Integer>
the index of the next free entry in abstractOpcodes (this code is translated into C where OrderedCollection et al do not exist)
numAbstractOpcodes <Integer>
the number of elements in abstractOpcocdes
blockStarts <Array of <BlockStart>>
the starts of blocks in the current method
blockCount
the index into blockStarts as they are being noted, and hence eventuakly teh total number of blocks in the current method
labelCounter <Integer>
a nicety for numbering labels not needed in the production system but probably not expensive enough to worry about
ceStackOverflowTrampoline <Integer>
ceSend0ArgsTrampoline <Integer>
ceSend1ArgsTrampoline <Integer>
ceSend2ArgsTrampoline <Integer>
ceSendNArgsTrampoline <Integer>
ceSendSuper0ArgsTrampoline <Integer>
ceSendSuper1ArgsTrampoline <Integer>
ceSendSuper2ArgsTrampoline <Integer>
ceSendSuperNArgsTrampoline <Integer>
ceSICMissTrampoline <Integer>
ceCPICMissTrampoline <Integer>
ceStoreCheckTrampoline <Integer>
ceReturnToInterpreterTrampoline <Integer>
ceBaseFrameReturnTrampoline <Integer>
ceSendMustBeBooleanTrampoline <Integer>
ceClosureCopyTrampoline <Integer>
the various trampolines (system-call-like jumps from machine code to the run-time).
See Cogit>>generateTrampolines for the mapping from trampoline to run-time
routine and then read the run-time routine for a funcitonal description.
ceEnterCogCodePopReceiverReg <Integer>
the enilopmart (jump from run-time to machine-code)
methodZoneBase <Integer>
!
Cogit class
instanceVariableNames: 'generatorTable primitiveTable'!
Item was changed:
----- Method: Cogit class>>initializeErrorCodes (in category 'class initialization') -----
initializeErrorCodes
self flag: 'these should be positive quantities and the check for error code should be a comparison against minCogMethodAddress/methodZoneBase'.
NotFullyInitialized := -1.
InsufficientCodeSpace := -2.
+ MethodTooBig := -4.
+ YoungSelectorInPIC := -5.
- YoungSelectorInPIC := -3.
MaxUnreportableError := YoungSelectorInPIC.
+ EncounteredUnknownBytecode := -6.
- EncounteredUnknownBytecode := -4.
MaxNegativeErrorCode := EncounteredUnknownBytecode!
Item was changed:
----- Method: Cogit>>compileCogMethod: (in category 'compile abstract instructions') -----
compileCogMethod: selector
<returnTypeC: #'CogMethod *'>
| numBytecodes numBlocks result extra |
hasYoungReferent := (objectMemory isYoung: methodObj)
or: [objectMemory isYoung: selector].
methodOrBlockNumArgs := coInterpreter argumentCountOf: methodObj.
inBlock := false.
primInvokeLabel := nil.
postCompileHook := nil.
+ maxLitIndex := -1.
extra := ((primitiveIndex := coInterpreter primitiveIndexOf: methodObj) > 0
and: [(coInterpreter isQuickPrimitiveIndex: primitiveIndex) not])
ifTrue: [30]
ifFalse: [10].
initialPC := coInterpreter startPCOfMethod: methodObj.
"initial estimate. Actual endPC is determined in scanMethod."
endPC := (coInterpreter isQuickPrimitiveIndex: primitiveIndex)
ifTrue: [initialPC - 1]
ifFalse: [objectMemory byteLengthOf: methodObj].
numBytecodes := endPC - initialPC + 1.
self allocateOpcodes: (numBytecodes + extra) * 10 bytecodes: numBytecodes.
(numBlocks := self scanMethod) < 0 ifTrue:
[^coInterpreter cCoerceSimple: numBlocks to: #'CogMethod *'].
self allocateBlockStarts: numBlocks.
blockEntryLabel := nil.
methodLabel dependent: nil.
(result := self compileEntireMethod) < 0 ifTrue:
[^coInterpreter cCoerceSimple: result to: #'CogMethod *'].
^self generateCogMethod: selector!
Item was changed:
----- Method: Cogit>>fillInMethodHeader:size:selector: (in category 'generate machine code') -----
fillInMethodHeader: method size: size selector: selector
<returnTypeC: #'CogMethod *'>
<var: #method type: #'CogMethod *'>
<var: #originalMethod type: #'CogMethod *'>
| methodHeader originalMethod |
method cmType: CMMethod.
method objectHeader: objectMemory nullHeaderForMachineCodeMethod.
method blockSize: size.
method methodObject: methodObj.
methodHeader := coInterpreter rawHeaderOf: methodObj.
"If the method has already been cogged (e.g. Newspeak accessors) then
leave the original method attached to its cog method, but get the right header."
(coInterpreter isCogMethodReference: methodHeader)
ifTrue:
[originalMethod := self cCoerceSimple: methodHeader to: #'CogMethod *'.
self assert: originalMethod blockSize = size.
methodHeader := originalMethod methodHeader]
ifFalse:
[coInterpreter rawHeaderOf: methodObj put: method asInteger].
method methodHeader: methodHeader.
method selector: selector.
method cmNumArgs: (coInterpreter argumentCountOfMethodHeader: methodHeader).
(method cmRefersToYoung: hasYoungReferent) ifTrue:
[methodZone addToYoungReferrers: method].
method cmUsageCount: self initialMethodUsageCount.
method cpicHasMNUCase: false.
+ method cmUsesPenultimateLit: maxLitIndex >= ((coInterpreter literalCountOfHeader: methodHeader) - 2).
method blockEntryOffset: (blockEntryLabel notNil
ifTrue: [blockEntryLabel address - method asInteger]
ifFalse: [0]).
+ "This can be an error check since a large stackCheckOffset is caused by compiling
+ a machine-code primitive, and hence depends on the Cogit, not the input method."
+ needsFrame ifTrue:
+ [stackCheckLabel address - method asInteger <= MaxStackCheckOffset ifFalse:
+ [self error: 'too much code for stack check offset']].
method stackCheckOffset: (needsFrame
ifTrue: [stackCheckLabel address - method asInteger]
ifFalse: [0]).
+ self assert: (backEnd callTargetFromReturnAddress: method asInteger + missOffset)
+ = (self methodAbortTrampolineFor: method cmNumArgs).
- self assert: (backEnd callTargetFromReturnAddress: method asInteger + missOffset) = (self methodAbortTrampolineFor: method cmNumArgs).
self assert: size = (methodZone roundUpLength: size).
^method!
Item was changed:
----- Method: Cogit>>generateCogMethod: (in category 'generate machine code') -----
generateCogMethod: selector
"We handle jump sizing simply. First we make a pass that asks each
instruction to compute its maximum size. Then we make a pass that
sizes jumps based on the maxmimum sizes. Then we make a pass
that fixes up jumps. When fixing up a jump the jump is not allowed to
choose a smaller offset but must stick to the size set in the second pass."
| codeSize headerSize mapSize totalSize startAddress result method |
<var: #method type: #'CogMethod *'>
<var: #blockStart type: #'BlockStart *'>
<var: #headerReference type: #'AbstractInstruction *'>
<returnTypeC: #'CogMethod *'>
headerSize := self sizeof: CogMethod.
methodLabel address: headerSize negated.
self computeMaximumSizes.
methodLabel concretizeAt: methodZone freeStart.
codeSize := self generateInstructionsAt: methodLabel address + headerSize.
mapSize := self generateMapAt: 0 start: methodLabel address + cmNoCheckEntryOffset.
totalSize := methodZone roundUpLength: headerSize + codeSize + mapSize.
+ totalSize > MaxMethodSize ifTrue:
+ [^self cCoerceSimple: MethodTooBig to: #'CogMethod *'].
startAddress := methodZone allocate: totalSize.
startAddress = 0 ifTrue:
[^self cCoerceSimple: InsufficientCodeSpace to: #'CogMethod *'].
self assert: startAddress + cmEntryOffset = entry address.
self assert: startAddress + cmNoCheckEntryOffset = noCheckEntry address.
result := self outputInstructionsAt: startAddress + headerSize.
self assert: startAddress + headerSize + codeSize = result.
backEnd padIfPossibleWithNopsFrom: result to: startAddress + totalSize - mapSize.
self generateMapAt: startAddress + totalSize - 1 start: startAddress + cmNoCheckEntryOffset.
self fillInBlockHeadersAt: startAddress.
method := self fillInMethodHeader: (self cCoerceSimple: startAddress to: #'CogMethod *')
size: totalSize
selector: selector.
postCompileHook notNil ifTrue:
[self perform: postCompileHook with: method with: primInvokeLabel.
postCompileHook := nil].
processor flushICacheFrom: startAddress to: startAddress + headerSize + codeSize.
^method!
Item was added:
+ ----- Method: Cogit>>getLiteral: (in category 'compile abstract instructions') -----
+ getLiteral: litIndex
+ maxLitIndex < litIndex ifTrue:
+ [maxLitIndex := litIndex].
+ ^coInterpreter literal: litIndex ofMethod: methodObj!
Item was changed:
----- Method: Cogit>>mapObjectReferencesInMachineCodeForBecome (in category 'garbage collection') -----
mapObjectReferencesInMachineCodeForBecome
"Update all references to objects in machine code for a become.
Unlike incrementalGC or fullGC a method that does not refer to young may
refer to young as a result of the become operation. Unlike incrementalGC
or fullGC the reference from a Cog method to its methodObject *must not*
change since the two are two halves of the same object."
| cogMethod hasYoungObj hasYoungObjPtr freedPIC |
<var: #cogMethod type: #'CogMethod *'>
hasYoungObj := false.
hasYoungObjPtr := self cCode: [(self addressOf: hasYoungObj) asInteger]
inSmalltalk: [CPluggableAccessor new
setObject: nil;
atBlock: [:obj :idx| hasYoungObj]
atPutBlock: [:obj :idx :val| hasYoungObj := val]].
codeModified := freedPIC := false.
self mapObjectReferencesInGeneratedRuntime.
cogMethod := self cCoerceSimple: methodZoneBase to: #'CogMethod *'.
[cogMethod < methodZone limitZony] whileTrue:
[self assert: hasYoungObj not.
cogMethod cmType ~= CMFree ifTrue:
[self assert: (self cogMethodDoesntLookKosher: cogMethod) = 0.
cogMethod selector: (objectRepresentation remapOop: cogMethod selector)..
cogMethod cmType = CMClosedPIC
ifTrue:
[((objectMemory isYoung: cogMethod selector)
or: [self mapObjectReferencesInClosedPIC: cogMethod]) ifTrue:
[freedPIC := true.
methodZone freeMethod: cogMethod]]
ifFalse:
[(objectMemory isYoung: cogMethod selector) ifTrue:
[hasYoungObj := true].
cogMethod cmType = CMMethod ifTrue:
[| remappedMethod |
self assert: cogMethod objectHeader = objectMemory nullHeaderForMachineCodeMethod.
self assert: ((coInterpreter rawHeaderOf: cogMethod methodObject) = cogMethod asInteger
or: [(self noAssertMethodClassAssociationOf: cogMethod methodObject)
= objectMemory nilObject]).
remappedMethod := objectRepresentation remapOop: cogMethod methodObject.
remappedMethod ~= cogMethod methodObject ifTrue:
[(coInterpreter methodHasCogMethod: remappedMethod) ifTrue:
[self error: 'attempt to become two cogged methods'].
(objectMemory
withoutForwardingOn: cogMethod methodObject
and: remappedMethod
+ with: cogMethod cmUsesPenultimateLit
+ sendToCogit: #method:hasSameCodeAs:checkPenultimate:) ifFalse:
- sendToCogit: #method:hasSameCodeAs:) ifFalse:
[self error: 'attempt to become cogged method into different method'].
coInterpreter
rawHeaderOf: cogMethod methodObject
put: cogMethod methodHeader.
cogMethod
methodHeader: (coInterpreter rawHeaderOf: remappedMethod);
methodObject: remappedMethod.
coInterpreter
rawHeaderOf: remappedMethod
put: cogMethod asInteger].
(objectMemory isYoung: cogMethod methodObject) ifTrue:
[hasYoungObj := true]].
self mapFor: cogMethod
performUntil: (self cppIf: NewspeakVM
ifTrue: [#remapNSIfObjectRef:pc:hasYoung:]
ifFalse: [#remapIfObjectRef:pc:hasYoung:])
arg: hasYoungObjPtr.
hasYoungObj
ifTrue:
[cogMethod cmRefersToYoung ifFalse:
[cogMethod cmRefersToYoung: true.
methodZone addToYoungReferrers: cogMethod].
hasYoungObj := false]
ifFalse: [cogMethod cmRefersToYoung: false]]].
cogMethod := methodZone methodAfter: cogMethod].
methodZone pruneYoungReferrers.
freedPIC ifTrue:
[self unlinkSendsToFree.
codeModified := true].
codeModified ifTrue: "After updating oops in inline caches we need to flush the icache."
[processor flushICacheFrom: codeBase to: methodZone limitZony asInteger]!
Item was added:
+ ----- Method: Cogit>>method:hasSameCodeAs:checkPenultimate: (in category 'garbage collection') -----
+ method: methodA hasSameCodeAs: methodB checkPenultimate: comparePenultimateLiteral
+ "For the purposes of become: see if the two methods are similar, i.e. can be safely becommed.
+ This is pretty strict. All literals and bytecodes must be identical. Only trailer bytes and header
+ flags can differ."
+ <inline: false>
+ | headerA headerB numLitsA endPCA |
+ headerA := coInterpreter headerOf: methodA.
+ headerB := coInterpreter headerOf: methodB.
+ numLitsA := coInterpreter literalCountOfHeader: headerA.
+ endPCA := self endPCOf: methodA.
+ ((coInterpreter argumentCountOfMethodHeader: headerA) ~= (coInterpreter argumentCountOfMethodHeader: headerB)
+ or: [(coInterpreter temporaryCountOfMethodHeader: headerA) ~= (coInterpreter temporaryCountOfMethodHeader: headerB)
+ or: [(coInterpreter primitiveIndexOfMethod: methodA header: headerA) ~= (coInterpreter primitiveIndexOfMethod: methodB header: headerB)
+ or: [numLitsA ~= (coInterpreter literalCountOfHeader: headerB)
+ or: [endPCA > (objectMemory byteLengthOf: methodB)]]]]) ifTrue:
+ [^false].
+ 1 to: numLitsA - 1 do:
+ [:li|
+ (objectMemory fetchPointer: li ofObject: methodA) ~= (objectMemory fetchPointer: li ofObject: methodB) ifTrue:
+ [(li < (numLitsA - 1) "If the method doesn't use the penultimate literal then don't fail the comparison."
+ or: [comparePenultimateLiteral]) ifTrue:
+ [^false]]].
+ (coInterpreter startPCOfMethod: methodA) to: endPCA do:
+ [:bi|
+ (objectMemory fetchByte: bi ofObject: methodA) ~= (objectMemory fetchByte: bi ofObject: methodB) ifTrue:
+ [^false]].
+ ^true!
Item was added:
+ ----- Method: CurrentImageCoInterpreterFacade>>literalCountOfHeader: (in category 'accessing') -----
+ literalCountOfHeader: methodHeader
+ ^(headerToMethodMap at: methodHeader) numLiterals!
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 added:
+ TestCase subclass: #IncludedMethodsTest
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'VMMaker-Tests'!
+
+ !IncludedMethodsTest commentStamp: 'dtl 11/9/2010 21:03' prior: 0!
+ Various classes in the image contain methods that are intended to be translated to C and executed as primitives. IncludedMethodsTest provides tests to validate these methods.
+ !
Item was added:
+ ----- Method: IncludedMethodsTest>>compare:with:collated: (in category 'primitives') -----
+ compare: string1 with: string2 collated: order
+ "Return 1, 2 or 3, if string1 is <, =, or > string2, with the collating order of characters given by the order array."
+
+ <primitive: 'primitiveCompareString' module: 'MiscPrimitivePlugin'>
+ self primitiveFailed
+ !
Item was added:
+ ----- Method: IncludedMethodsTest>>compress:toByteArray: (in category 'primitives') -----
+ compress: bm toByteArray: ba
+
+ <primitive: 'primitiveCompressToByteArray' module: 'MiscPrimitivePlugin'>
+ self primitiveFailed!
Item was added:
+ ----- Method: IncludedMethodsTest>>convert8bitSignedFrom:to16Bit: (in category 'primitives') -----
+ convert8bitSignedFrom: aByteArray to16Bit: aSoundBuffer
+ "Copy the contents of the given array of signed 8-bit samples into the given array of 16-bit signed samples."
+
+ <primitive: 'primitiveConvert8BitSigned' module: 'MiscPrimitivePlugin'>
+ self primitiveFailed
+ !
Item was added:
+ ----- Method: IncludedMethodsTest>>decompress:fromByteArray:at: (in category 'primitives') -----
+ decompress: bm fromByteArray: ba at: index
+
+ <primitive: 'primitiveDecompressFromByteArray' module: 'MiscPrimitivePlugin'>
+ self primitiveFailed
+ !
Item was added:
+ ----- Method: IncludedMethodsTest>>findFirstInString:inSet:startingAt: (in category 'primitives') -----
+ findFirstInString: aString inSet: inclusionMap startingAt: start
+
+ <primitive: 'primitiveFindFirstInString' module: 'MiscPrimitivePlugin'>
+ self primitiveFailed
+ !
Item was added:
+ ----- Method: IncludedMethodsTest>>findSubstring:in:startingAt:matchTable: (in category 'primitives') -----
+ findSubstring: key in: body startingAt: start matchTable: matchTable
+ "Answer the index in the string body at which the substring key first occurs, at or beyond start. The match is determined using matchTable, which can be used to effect, eg, case-insensitive matches. If no match is found, zero will be returned."
+
+ <primitive: 'primitiveFindSubstring' module: 'MiscPrimitivePlugin'>
+ self primitiveFailed
+ !
Item was added:
+ ----- Method: IncludedMethodsTest>>indexOfAscii:inString:startingAt: (in category 'primitives') -----
+ indexOfAscii: anInteger inString: aString startingAt: start
+
+ <primitive: 'primitiveIndexOfAsciiInString' module: 'MiscPrimitivePlugin'>
+ self primitiveFailed
+ !
Item was added:
+ ----- Method: IncludedMethodsTest>>mixSampleCount:into:startingAt:leftVol:rightVol: (in category 'primitives') -----
+ mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol
+ "Play samples from a wave table by stepping a fixed amount through the table on every sample. The table index and increment are scaled to allow fractional increments for greater pitch accuracy."
+ "(FMSound pitch: 440.0 dur: 1.0 loudness: 0.5) play"
+
+ <primitive:'primitiveMixFMSound' module:'SoundGenerationPlugin'>
+ self primitiveFailed
+ !
Item was added:
+ ----- Method: IncludedMethodsTest>>testCompareWithCollated (in category 'testing - MiscPrimitivePlugin') -----
+ testCompareWithCollated
+ "Verify that primitive exists in the VM"
+
+ self assert: 3 = (self compare: 'foo' with: 'bar' collated: ((0 to: 255) as: ByteArray))
+ !
Item was added:
+ ----- Method: IncludedMethodsTest>>testCompressToByteArray (in category 'testing - MiscPrimitivePlugin') -----
+ testCompressToByteArray
+
+ | bitmap byteArray |
+ bitmap := Bitmap with: 16rFFFFFFFF.
+ byteArray := ByteArray new: 4.
+ self compress: bitmap toByteArray: byteArray.
+ self should: byteArray = #[1 5 255 0]!
Item was added:
+ ----- Method: IncludedMethodsTest>>testConvert8bitSignedFromTo16Bit (in category 'testing - MiscPrimitivePlugin') -----
+ testConvert8bitSignedFromTo16Bit
+ "SampledSound class>>convert8bitSignedFrom:to16Bit:"
+
+
+ | aByteArray aSoundBuffer |
+ aByteArray := #[1 2 3 4 5 6 7 8 9].
+ aSoundBuffer := SoundBuffer newMonoSampleCount: aByteArray size.
+ self convert8bitSignedFrom: aByteArray to16Bit: aSoundBuffer.
+ self assert: aSoundBuffer = ((SoundBuffer new: 10) at: 1 put: 256; at: 2 put: 512;
+ at: 3 put: 768; at: 4 put: 1024; at: 5 put: 1280; at: 6 put: 1536; at: 7 put: 1792;
+ at: 8 put: 2048; at: 9 put: 2304; at: 10 put: 0; yourself)!
Item was added:
+ ----- Method: IncludedMethodsTest>>testDecompressFromByteArrayAt (in category 'testing - MiscPrimitivePlugin') -----
+ testDecompressFromByteArrayAt
+
+ | bitmap byteArray s size |
+ byteArray := #(1 5 255 0) asByteArray.
+ s := ReadStream on: byteArray.
+ size := Bitmap decodeIntFrom: s.
+ bitmap := Bitmap new: size.
+ self decompress: bitmap fromByteArray: byteArray at: s position + 1.
+ self should: bitmap = ((Bitmap new: 1) at: 1 put: 4294967295; yourself)!
Item was added:
+ ----- Method: IncludedMethodsTest>>testFindFirstInStringInSetStartingAt (in category 'testing - MiscPrimitivePlugin') -----
+ testFindFirstInStringInSetStartingAt
+
+ | position set |
+ set := ((0 to: 255) collect: [:e | (e \\ 2) + $0 asciiValue]) asByteArray.
+ position := self findFirstInString: 'abcdef' inSet: set startingAt: 1.
+ self assert: position = 1
+ !
Item was added:
+ ----- Method: IncludedMethodsTest>>testFindSubstring (in category 'testing - MiscPrimitivePlugin') -----
+ testFindSubstring
+ "Verify that primitive exists in the VM and that non byte array arguments cause primitive to fail"
+
+ | position |
+ position := IncludedMethodsTest new
+ findSubstring: 'bc'
+ in: 'abcdef'
+ startingAt: 1
+ matchTable: ((0 to: 255)
+ as: ByteArray).
+ self assert: position = 2.
+ self should: [IncludedMethodsTest new
+ findSubstring: 'bc' asWideString
+ in: 'abcdef'
+ startingAt: 1
+ matchTable: ((0 to: 255)
+ as: ByteArray)]
+ raise: Error.
+ self should: [IncludedMethodsTest new
+ findSubstring: 'bc'
+ in: 'abcdef' asWideString
+ startingAt: 1
+ matchTable: ((0 to: 255)
+ as: ByteArray)]
+ raise: Error.
+ self should: [IncludedMethodsTest new
+ findSubstring: 'bc' asWideString
+ in: 'abcdef' asWideString
+ startingAt: 1
+ matchTable: ((0 to: 255)
+ as: ByteArray)]
+ raise: Error
+ !
Item was added:
+ ----- Method: IncludedMethodsTest>>testIindexOfAsciiInStringStartingAt (in category 'testing - MiscPrimitivePlugin') -----
+ testIindexOfAsciiInStringStartingAt
+
+ | position |
+ position := self indexOfAscii: 50 inString: '012345' startingAt: 1.
+ self assert: position = 3!
Item was added:
+ ----- Method: IncludedMethodsTest>>testMixSampleCountIntoStartingAtLeftVolRightVol (in category 'testing - SoundGeneratorPlugin') -----
+ testMixSampleCountIntoStartingAtLeftVolRightVol
+
+ "mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol"!
Item was added:
+ ----- Method: IncludedMethodsTest>>testTranslateFromToTable (in category 'testing - MiscPrimitivePlugin') -----
+ testTranslateFromToTable
+ "Verify that primitive exists in the VM"
+
+ | s t |
+ s := 'foo' copy. "copy so string is instantiated each time"
+ t := ByteArray withAll: ((1 to: 255) as: ByteArray).
+ self translate: s from: 1 to: 3 table: t.
+ self assert: s = 'gpp'
+ !
Item was added:
+ ----- Method: IncludedMethodsTest>>todoForADPCMCodecPlugin (in category 'testing - ADPCMCodecPlugin') -----
+ todoForADPCMCodecPlugin
+ "TODO - write tests for these"
+
+ ^#(
+ (ADPCMCodec privateDecodeMono:)
+ (ADPCMCodec privateDecodeStereo:)
+ (ADPCMCodec privateEncodeMono:)
+ (ADPCMCodec privateEncodeStereo:)
+ (ADPCMCodec indexForDeltaFrom:to:)
+ (ADPCMCodec nextBits:)
+ (ADPCMCodec nextBits:put:)
+ )!
Item was added:
+ ----- Method: IncludedMethodsTest>>todoForSoundGeneratorPlugin (in category 'testing - SoundGeneratorPlugin') -----
+ todoForSoundGeneratorPlugin
+ "TODO - write tests for these"
+
+ ^#(
+ (FMSound mixSampleCount:into:startingAt:leftVol:rightVol:)
+ (PluckedSound mixSampleCount:into:startingAt:leftVol:rightVol:)
+ (LoopedSampledSound mixSampleCount:into:startingAt:leftVol:rightVol:)
+ (SampledSound mixSampleCount:into:startingAt:leftVol:rightVol:)
+ (ReverbSound applyReverbTo:startingAt:count:)
+ )!
Item was added:
+ ----- Method: IncludedMethodsTest>>translate:from:to:table: (in category 'primitives') -----
+ translate: aString from: start to: stop table: table
+ "translate the characters in the string by the given table, in place"
+
+ <primitive: 'primitiveTranslateStringWithTable' module: 'MiscPrimitivePlugin'>
+ self primitiveFailed!
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>>primitiveMillisecondClockMask (in category 'system control primitives') -----
primitiveMillisecondClockMask
"Provide access to the millisecond clock mask to support calculation
of durations based on the millisecond clock value."
<export: true>
+ self pop: 1 thenPush: (objectMemory integerObjectOf: MillisecondClockMask)
- self pop: 1 thenPush: (self integerObjectOf: MillisecondClockMask)
!
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: NewCoObjectMemory>>withoutForwardingOn:and:with:sendToCogit: (in category 'cog jit support') -----
+ withoutForwardingOn: obj1 and: obj2 with: aBool sendToCogit: selector
+ "For the purposes of become: send selector to the cogit with obj1 and obj2 and
+ answer the result. Undo forwarding for the selector, but redo forwarding after since
+ become:'s restoreHeadersAfter*Become* methods expect to be able to restore."
+ <api>
+ <var: #selector declareC: 'sqInt (*selector)(sqInt,sqInt,sqInt)'>
+ | savedHeaderA savedHeaderB result |
+ savedHeaderA := self baseHeader: obj1.
+ self baseHeader: obj1 put: (self headerWhileForwardingOf: obj1).
+ savedHeaderB := self baseHeader: obj2.
+ self baseHeader: obj2 put: (self headerWhileForwardingOf: obj2).
+
+ result := cogit perform: selector with: obj1 with: obj2 with: aBool.
+
+ self baseHeader: obj1 put: savedHeaderA.
+ self baseHeader: obj2 put: savedHeaderB.
+ ^result!
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 ephemeronsQueue'
- instanceVariableNames: 'coInterpreter freeStart reserveStart scavengeThreshold needGCFlag fullGCLock edenBytes checkForLeaks statGCEndUsecs ephemeronsQueue'
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>>initializeSpecialObjectIndices (in category 'initialization') -----
initializeSpecialObjectIndices
"Initialize indices into specialObjects array."
NilObject := 0.
FalseObject := 1.
TrueObject := 2.
SchedulerAssociation := 3.
ClassBitmap := 4.
ClassInteger := 5.
ClassByteString := ClassString := 6. "N.B. Actually class ByteString"
ClassArray := 7.
"SmalltalkDictionary := 8." "Do not delete!!"
ClassFloat := 9.
ClassMethodContext := 10.
ClassBlockContext := 11.
ClassPoint := 12.
ClassLargePositiveInteger := 13.
TheDisplay := 14.
ClassMessage := 15.
ClassCompiledMethod := 16.
TheLowSpaceSemaphore := 17.
ClassSemaphore := 18.
ClassCharacter := 19.
SelectorDoesNotUnderstand := 20.
SelectorCannotReturn := 21.
ProcessSignalingLowSpace := 22. "was TheInputSemaphore"
SpecialSelectors := 23.
CharacterTable := 24.
SelectorMustBeBoolean := 25.
ClassByteArray := 26.
ClassProcess := 27.
CompactClasses := 28.
TheTimerSemaphore := 29.
TheInterruptSemaphore := 30.
SelectorCannotInterpret := 34.
"Was MethodContextProto := 35."
ClassBlockClosure := 36.
"Was BlockContextProto := 37."
ExternalObjectsArray := 38.
ClassMutex := 39.
"Was: ClassTranslatedMethod := 40."
ProcessInExternalCodeTag := 40.
TheFinalizationSemaphore := 41.
ClassLargeNegativeInteger := 42.
ClassExternalAddress := 43.
ClassExternalStructure := 44.
ClassExternalData := 45.
ClassExternalFunction := 46.
ClassExternalLibrary := 47.
SelectorAboutToReturn := 48.
SelectorRunWithIn := 49.
SelectorAttemptToAssign := 50.
"PrimErrTableIndex := 51. in Interpreter class>>initializePrimitiveErrorCodes"
ClassAlien := 52.
SelectorInvokeCallback := 53.
ClassUnsafeAlien := 54.
ClassWeakFinalizer := 55.
ForeignCallbackProcess := 56.
+ SelectorUnknownBytecode := 57.
+ SelectorCounterTripped := 58
+ !
- SelectorCounterTripped := 57!
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>>maybeSplObj: (in category 'interpreter access') -----
maybeSplObj: index
<api>
+ "Answer one of the objects in the SpecialObjectsArray, if in range, otherwise answer nil."
- "Return one of the objects in the SpecialObjectsArray, if in range, otherwise ansser nil"
^index < (self lengthOf: specialObjectsOop) ifTrue:
[self fetchPointer: index ofObject: specialObjectsOop]!
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: SimpleStackBasedCogit>>doubleExtendedDoAnythingBytecode (in category 'bytecode generators') -----
doubleExtendedDoAnythingBytecode
"Replaces the Blue Book double-extended send [132], in which the first byte was wasted on 8 bits of argument count.
Here we use 3 bits for the operation sub-type (opType), and the remaining 5 bits for argument count where needed.
The last byte give access to 256 instVars or literals.
See also secondExtendedSendBytecode"
| opType |
opType := byte1 >> 5.
opType = 0 ifTrue:
+ [^self genSend: (self getLiteral: byte2) numArgs: (byte1 bitAnd: 31)].
- [^self genSend: (coInterpreter literal: byte2 ofMethod: methodObj) numArgs: (byte1 bitAnd: 31)].
opType = 1 ifTrue:
+ [^self genSendSuper: (self getLiteral: byte2) numArgs: (byte1 bitAnd: 31)].
- [^self genSendSuper: (coInterpreter literal: byte2 ofMethod: methodObj) numArgs: (byte1 bitAnd: 31)].
"We need a map entry for this bytecode for correct parsing.
The sends will get an IsSend entry anyway. The other cases need a
fake one. We could of course special case the scanning but that's silly."
opType caseOf: {
[2] -> [byte2 <= StackPointerIndex
ifTrue: [self genPushMaybeContextReceiverVariable: byte2]
ifFalse: [self genPushReceiverVariable: byte2]].
[3] -> [self genPushLiteralIndex: byte2].
[4] -> [self genPushLiteralVariable: byte2].
[7] -> [self genStorePop: false LiteralVariable: byte2] }
otherwise: "5 & 6"
[byte2 <= StackPointerIndex
ifTrue: [self genStorePop: opType = 6 MaybeContextReceiverVariable: byte2]
ifFalse: [self genStorePop: opType = 6 ReceiverVariable: byte2]].
"We need a map entry for this bytecode for correct parsing (if the method builds a frame).
We could of course special case the scanning but that's silly."
needsFrame ifTrue:
[self annotateBytecode: self Label].
^0!
Item was changed:
----- Method: SimpleStackBasedCogit>>genDynamicSuperSendBytecode (in category 'bytecode generators') -----
genDynamicSuperSendBytecode
+ ^self genSendDynamicSuper: (self getLiteral: byte2) numArgs: byte1!
- ^self genSendDynamicSuper: (coInterpreter literal: byte2 ofMethod: methodObj) numArgs: byte1!
Item was changed:
----- Method: SimpleStackBasedCogit>>genExtSendAbsentDynamicSuperBytecode (in category 'bytecode generators') -----
genExtSendAbsentDynamicSuperBytecode
"241 11110001 i i i i i j j j Send To Absent Dynamic Superclass Literal Selector #iiiii (+ Extend A * 32) with jjj (+ Extend B * 8) Arguments"
| litIndex nArgs |
litIndex := (byte1 >> 3) + (extA << 5).
extA := 0.
nArgs := (byte1 bitAnd: 7) + (extB << 3).
extB := 0.
+ ^self genSendAbsentDynamicSuper: (self getLiteral: litIndex) numArgs: nArgs!
- ^self genSendAbsentDynamicSuper: (coInterpreter literal: litIndex ofMethod: methodObj) numArgs: nArgs!
Item was changed:
----- Method: SimpleStackBasedCogit>>genExtSendAbsentImplicitBytecode (in category 'bytecode generators') -----
genExtSendAbsentImplicitBytecode
"240 11110000 i i i i i j j j Send To Absent Implicit Receiver Literal Selector #iiiii (+ Extend A * 32) with jjj (+ Extend B * 8) Arguments"
| litIndex nArgs |
litIndex := (byte1 >> 3) + (extA << 5).
extA := 0.
nArgs := (byte1 bitAnd: 7) + (extB << 3).
extB := 0.
+ ^self genSendAbsentImplicit: (self getLiteral: litIndex) numArgs: nArgs!
- ^self genSendAbsentImplicit: (coInterpreter literal: litIndex ofMethod: methodObj) numArgs: nArgs!
Item was changed:
----- Method: SimpleStackBasedCogit>>genExtSendBytecode (in category 'bytecode generators') -----
genExtSendBytecode
"238 11101110 i i i i i j j j Send Literal Selector #iiiii (+ Extend A * 32) with jjj (+ Extend B * 8) Arguments"
| litIndex nArgs |
litIndex := (byte1 >> 3) + (extA << 5).
extA := 0.
nArgs := (byte1 bitAnd: 7) + (extB << 3).
extB := 0.
+ ^self genSend: (self getLiteral: litIndex) numArgs: nArgs!
- ^self genSend: (coInterpreter literal: litIndex ofMethod: methodObj) numArgs: nArgs!
Item was changed:
----- Method: SimpleStackBasedCogit>>genExtSendSuperBytecode (in category 'bytecode generators') -----
genExtSendSuperBytecode
"239 11101111 i i i i i j j j Send To Superclass Literal Selector #iiiii (+ Extend A * 32) with jjj (+ Extend B * 8) Arguments"
| litIndex nArgs |
litIndex := (byte1 >> 3) + (extA << 5).
extA := 0.
nArgs := (byte1 bitAnd: 7) + (extB << 3).
extB := 0.
+ ^self genSendSuper: (self getLiteral: litIndex) numArgs: nArgs!
- ^self genSendSuper: (coInterpreter literal: litIndex ofMethod: methodObj) numArgs: nArgs!
Item was changed:
----- Method: SimpleStackBasedCogit>>genExtendedSendBytecode (in category 'bytecode generators') -----
genExtendedSendBytecode
"Can use any of the first 32 literals for the selector and pass up to 7 arguments."
+ ^self genSend: (self getLiteral: (byte1 bitAnd: 16r1F)) numArgs: byte1 >> 5!
- ^self genSend: (coInterpreter literal: (byte1 bitAnd: 16r1F) ofMethod: methodObj) numArgs: byte1 >> 5!
Item was changed:
----- Method: SimpleStackBasedCogit>>genExtendedSuperBytecode (in category 'bytecode generators') -----
genExtendedSuperBytecode
+ ^self genSendSuper: (self getLiteral: (byte1 bitAnd: 16r1F)) numArgs: byte1 >> 5!
- ^self genSendSuper: (coInterpreter literal: (byte1 bitAnd: 16r1F) ofMethod: methodObj) numArgs: byte1 >> 5!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPushExplicitOuterSendReceiverBytecode (in category 'bytecode generators') -----
genPushExplicitOuterSendReceiverBytecode
"Uncached push explicit outer send receiver"
| levelOop |
+ levelOop := self getLiteral: byte1.
- levelOop := coInterpreter literal: byte1 ofMethod: methodObj.
self assert: (objectMemory isIntegerObject: levelOop).
^self genPushExplicitOuterSendReceiver: (objectMemory integerValueOf: levelOop)!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPushImplicitReceiverBytecode (in category 'bytecode generators') -----
genPushImplicitReceiverBytecode
| result |
+ result := self genGetImplicitReceiverFor: (self getLiteral: byte1).
- result := self genGetImplicitReceiverFor: (coInterpreter literal: byte1 ofMethod: methodObj).
result ~= 0 ifTrue:
[^result].
self PushR: ReceiverResultReg.
^0!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPushLiteralIndex: (in category 'bytecode generators') -----
genPushLiteralIndex: literalIndex "<SmallInteger>"
<inline: false>
| literal |
+ literal := self getLiteral: literalIndex.
- literal := coInterpreter literal: literalIndex ofMethod: methodObj.
^self genPushLiteral: literal!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPushLiteralVariable: (in category 'bytecode generators') -----
genPushLiteralVariable: literalIndex
<inline: false>
| association |
+ association := self getLiteral: literalIndex.
- association := coInterpreter literal: literalIndex ofMethod: methodObj.
"N.B. Do _not_ use ReceiverResultReg to avoid overwriting receiver in assignment in frameless methods."
self annotate: (self MoveCw: association R: ClassReg) objRef: association.
objectRepresentation
genLoadSlot: ValueIndex
sourceReg: ClassReg
destReg: TempReg.
self PushR: TempReg.
^0!
Item was changed:
----- Method: SimpleStackBasedCogit>>genSecondExtendedSendBytecode (in category 'bytecode generators') -----
genSecondExtendedSendBytecode
"Can use any of the first 64 literals for the selector and pass up to 3 arguments."
+ ^self genSend: (self getLiteral: (byte1 bitAnd: 16r3F)) numArgs: byte1 >> 6!
- ^self genSend: (coInterpreter literal: (byte1 bitAnd: 16r3F) ofMethod: methodObj) numArgs: byte1 >> 6!
Item was changed:
----- Method: SimpleStackBasedCogit>>genSendAbsentImplicit0ArgsBytecode (in category 'bytecode generators') -----
genSendAbsentImplicit0ArgsBytecode
"160-175 1010 i i i i Send To Absent Implicit Receiver Literal Selector #iiii With 0 Arguments."
+ ^self genSendAbsentImplicit: (self getLiteral: (byte0 bitAnd: 15)) numArgs: 0!
- ^self genSendAbsentImplicit: (coInterpreter literal: (byte0 bitAnd: 15) ofMethod: methodObj) numArgs: 0!
Item was changed:
----- Method: SimpleStackBasedCogit>>genSendLiteralSelector0ArgsBytecode (in category 'bytecode generators') -----
genSendLiteralSelector0ArgsBytecode
+ ^self genSend: (self getLiteral: (byte0 bitAnd: 15)) numArgs: 0!
- ^self genSend: (coInterpreter literal: (byte0 bitAnd: 15) ofMethod: methodObj) numArgs: 0!
Item was changed:
----- Method: SimpleStackBasedCogit>>genSendLiteralSelector1ArgBytecode (in category 'bytecode generators') -----
genSendLiteralSelector1ArgBytecode
+ ^self genSend: (self getLiteral: (byte0 bitAnd: 15)) numArgs: 1!
- ^self genSend: (coInterpreter literal: (byte0 bitAnd: 15) ofMethod: methodObj) numArgs: 1!
Item was changed:
----- Method: SimpleStackBasedCogit>>genSendLiteralSelector2ArgsBytecode (in category 'bytecode generators') -----
genSendLiteralSelector2ArgsBytecode
+ ^self genSend: (self getLiteral: (byte0 bitAnd: 15)) numArgs: 2!
- ^self genSend: (coInterpreter literal: (byte0 bitAnd: 15) ofMethod: methodObj) numArgs: 2!
Item was changed:
----- Method: SimpleStackBasedCogit>>genStorePop:LiteralVariable: (in category 'bytecode generators') -----
genStorePop: popBoolean LiteralVariable: litVarIndex
<inline: false>
| association |
self assert: needsFrame.
+ association := self getLiteral: litVarIndex.
- association := coInterpreter literal: litVarIndex ofMethod: methodObj.
self annotate: (self MoveCw: association R: ReceiverResultReg) objRef: association.
popBoolean
ifTrue: [self PopR: ClassReg]
ifFalse: [self MoveMw: 0 r: SPReg R: ClassReg].
traceStores > 0 ifTrue:
[self CallRT: ceTraceStoreTrampoline].
^objectRepresentation
genStoreSourceReg: ClassReg
slotIndex: ValueIndex
destReg: ReceiverResultReg
scratchReg: TempReg!
Item was changed:
----- Method: SistaStackToRegisterMappingCogit>>generateCogMethod: (in category 'generate machine code') -----
generateCogMethod: selector
"We handle jump sizing simply. First we make a pass that asks each
instruction to compute its maximum size. Then we make a pass that
sizes jumps based on the maxmimum sizes. Then we make a pass
that fixes up jumps. When fixing up a jump the jump is not allowed to
choose a smaller offset but must stick to the size set in the second pass.
Override to add counters"
| codeSize headerSize mapSize countersSize totalSize startAddress result method |
<var: #method type: #'CogMethod *'>
<var: #blockStart type: #'BlockStart *'>
<var: #headerReference type: #'AbstractInstruction *'>
<returnTypeC: #'CogMethod *'>
headerSize := self sizeof: CogMethod.
methodLabel address: headerSize negated.
self computeMaximumSizes.
methodLabel concretizeAt: (methodZone allocate: 0).
codeSize := self generateInstructionsAt: methodLabel address + headerSize.
mapSize := self generateMapAt: 0 start: methodLabel address + cmNoCheckEntryOffset.
countersSize := counterIndex * CounterBytes.
totalSize := methodZone roundUpLength: headerSize + codeSize + mapSize + countersSize.
+ totalSize > MaxMethodSize ifTrue:
+ [^self cCoerceSimple: MethodTooBig to: #'CogMethod *'].
startAddress := methodZone allocate: totalSize.
startAddress = 0 ifTrue:
[^self cCoerceSimple: InsufficientCodeSpace to: #'CogMethod *'].
self assert: startAddress + cmEntryOffset = entry address.
self assert: startAddress + cmNoCheckEntryOffset = noCheckEntry address.
self regenerateCounterReferences: startAddress + totalSize.
result := self outputInstructionsAt: startAddress + headerSize.
self assert: startAddress + headerSize + codeSize = result.
backEnd nopsFrom: result to: startAddress + totalSize - mapSize.
self generateMapAt: startAddress + totalSize - countersSize - 1 start: startAddress + cmNoCheckEntryOffset.
self fillInBlockHeadersAt: startAddress.
self fillInCounters: counterIndex atEndAddress: startAddress + totalSize.
method := self fillInMethodHeader: (self cCoerceSimple: startAddress to: #'CogMethod *')
size: totalSize
selector: selector.
postCompileHook notNil ifTrue:
[self perform: postCompileHook with: method with: primInvokeLabel.
postCompileHook := nil].
processor flushICacheFrom: startAddress to: startAddress + headerSize + codeSize.
^method!
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 added:
+ ----- Method: StackInterpreter>>respondToUnknownBytecode (in category 'miscellaneous bytecodes') -----
+ respondToUnknownBytecode
+ "If an error selector is available then send it to the activeContext, otherwise abort."
+ <sharedCodeNamed: #respondToUnknownBytecode inCase: #unknownBytecode>
+ | unknownBytecodeSelector ourContext |
+ unknownBytecodeSelector := objectMemory maybeSplObj: SelectorUnknownBytecode.
+ unknownBytecodeSelector isNil ifTrue:
+ [self error: 'Unknown bytecode'].
+ ourContext := self ensureFrameIsMarried: localFP SP: localSP.
+ "N.B. Do Not:
+ self fetchNextBytecode."
+ self internalPush: ourContext.
+ messageSelector := unknownBytecodeSelector.
+ argumentCount := 0.
+ self commonSend!
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>>unknownBytecode (in category 'miscellaneous bytecodes') -----
- ----- Method: StackInterpreter>>unknownBytecode (in category 'interpreter shell') -----
unknownBytecode
+ "If an error selector is available then send it to the activeContext, otherwise abort."
+ self respondToUnknownBytecode!
- "This should never get called; it means that an unimplemented bytecode appears in a CompiledMethod."
-
- self error: 'Unknown bytecode'.!
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 changed:
----- Method: StackToRegisterMappingCogit>>doubleExtendedDoAnythingBytecode (in category 'bytecode generators') -----
doubleExtendedDoAnythingBytecode
"Replaces the Blue Book double-extended send [132], in which the first byte was wasted on 8 bits of argument count.
Here we use 3 bits for the operation sub-type (opType), and the remaining 5 bits for argument count where needed.
The last byte give access to 256 instVars or literals.
See also secondExtendedSendBytecode"
| opType |
opType := byte1 >> 5.
opType = 0 ifTrue:
+ [^self genSend: (self getLiteral: byte2) numArgs: (byte1 bitAnd: 31)].
- [^self genSend: (coInterpreter literal: byte2 ofMethod: methodObj) numArgs: (byte1 bitAnd: 31)].
opType = 1 ifTrue:
+ [^self genSendSuper: (self getLiteral: byte2) numArgs: (byte1 bitAnd: 31)].
- [^self genSendSuper: (coInterpreter literal: byte2 ofMethod: methodObj) numArgs: (byte1 bitAnd: 31)].
"We need a map entry for this bytecode for correct parsing.
The sends will get an IsSend entry anyway. The other cases need a
fake one. We could of course special case the scanning but that's silly."
opType caseOf: {
[2] -> [byte2 <= StackPointerIndex
ifTrue: [self genPushMaybeContextReceiverVariable: byte2]
ifFalse: [self genPushReceiverVariable: byte2.
self ssTop annotateUse: true.
^0]].
[3] -> [self genPushLiteralIndex: byte2.
self ssTop annotateUse: true.
^0].
[4] -> [self genPushLiteralVariable: byte2.].
[7] -> [self genStorePop: false LiteralVariable: byte2] }
otherwise: "5 & 6"
[byte2 <= StackPointerIndex
ifTrue: [self genStorePop: opType = 6 MaybeContextReceiverVariable: byte2]
ifFalse: [self genStorePop: opType = 6 ReceiverVariable: byte2]].
"We need a map entry for this bytecode for correct parsing (if the method builds a frame).
We could of course special case the scanning but that's silly (or is it?)."
self assert: needsFrame.
"genPushMaybeContextInstVar, pushListVar, store & storePop all generate code"
self assert: self prevInstIsPCAnnotated not.
self annotateBytecode: self Label.
^0!
Item was changed:
----- Method: StackToRegisterMappingCogit>>genPushImplicitReceiverBytecode (in category 'bytecode generators') -----
genPushImplicitReceiverBytecode
| result |
+ result := self genGetImplicitReceiverFor: (self getLiteral: byte1).
- result := self genGetImplicitReceiverFor: (coInterpreter literal: byte1 ofMethod: methodObj).
result ~= 0 ifTrue:
[^result].
^self ssPushRegister: ReceiverResultReg!
Item was changed:
----- Method: StackToRegisterMappingCogit>>genPushLiteralVariable: (in category 'bytecode generators') -----
genPushLiteralVariable: literalIndex
<inline: false>
| association freeReg |
freeReg := self ssAllocatePreferredReg: ClassReg.
+ association := self getLiteral: literalIndex.
- association := coInterpreter literal: literalIndex ofMethod: methodObj.
"N.B. Do _not_ use ReceiverResultReg to avoid overwriting receiver in assignment in frameless methods."
"So far descriptors are not rich enough to describe the entire dereference so generate the register
load but don't push the result. There is an order-or-evaluation issue if we defer the dereference."
self annotate: (self MoveCw: association R: TempReg) objRef: association.
objectRepresentation
genLoadSlot: ValueIndex
sourceReg: TempReg
destReg: freeReg.
self ssPushRegister: freeReg.
^0!
Item was changed:
----- Method: StackToRegisterMappingCogit>>genStorePop:LiteralVariable: (in category 'bytecode generators') -----
genStorePop: popBoolean LiteralVariable: litVarIndex
<inline: false>
| topReg valueReg association constVal |
self flag: 'with better register allocation this wouldn''t need a frame. e.g. use SendNumArgs instead of ReceiverResultReg'.
self assert: needsFrame.
optStatus isReceiverResultRegLive: false.
"N.B. No need to check the stack for references because we generate code for
literal variable loads that stores the result in a register, deferring only the register push."
+ association := self getLiteral: litVarIndex.
- association := coInterpreter literal: litVarIndex ofMethod: methodObj.
constVal := self ssTop maybeConstant.
"Avoid store check for immediate values"
(self ssTop type = SSConstant
and: [(objectRepresentation shouldAnnotateObjectReference: constVal) not]) ifTrue:
[self ssAllocateRequiredReg: ReceiverResultReg.
self annotate: (self MoveCw: association R: ReceiverResultReg) objRef: association.
self ssStorePop: popBoolean toPreferredReg: TempReg.
traceStores > 0 ifTrue:
[self CallRT: ceTraceStoreTrampoline].
^objectRepresentation
genStoreImmediateInSourceReg: TempReg
slotIndex: ValueIndex
destReg: ReceiverResultReg].
((topReg := self ssTop registerOrNil) isNil
or: [topReg = ReceiverResultReg]) ifTrue:
[topReg := ClassReg].
self ssPop: 1.
self ssAllocateCallReg: topReg. "for the ceStoreCheck call in genStoreSourceReg:... below"
self ssPush: 1.
valueReg := self ssStorePop: popBoolean toPreferredReg: topReg.
valueReg = ReceiverResultReg ifTrue:
[self MoveR: valueReg R: topReg].
self ssAllocateCallReg: ReceiverResultReg.
self annotate: (self MoveCw: association R: ReceiverResultReg) objRef: association.
traceStores > 0 ifTrue:
[self MoveR: topReg R: TempReg.
self CallRT: ceTraceStoreTrampoline].
^objectRepresentation
genStoreSourceReg: topReg
slotIndex: ValueIndex
destReg: ReceiverResultReg
scratchReg: TempReg!
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)]]!
Item was changed:
SharedPool subclass: #VMObjectIndices
instanceVariableNames: ''
+ classVariableNames: 'ActiveProcessIndex CharacterTable CharacterValueIndex ClassAlien ClassArray ClassBitmap ClassBlockClosure ClassBlockContext ClassByteArray ClassByteString ClassCharacter ClassCompiledMethod ClassExternalAddress ClassExternalData ClassExternalFunction ClassExternalLibrary ClassExternalStructure ClassFloat ClassInteger ClassLargeNegativeInteger ClassLargePositiveInteger ClassMessage ClassMethodContext ClassMutex ClassPoint ClassProcess ClassSemaphore ClassString ClassUnsafeAlien ClassWeakFinalizer ClosureCopiedValuesIndex ClosureFirstCopiedValueIndex ClosureIndex ClosureNumArgsIndex ClosureOuterContextIndex ClosureStartPCIndex CompactClasses ConstMinusOne ConstOne ConstTwo ConstZero ExcessSignalsIndex ExternalObjectsArray FalseObject FirstLinkIndex ForeignCallbackProcess HeaderIndex InstanceSpecificationIndex InstructionPointerIndex KeyIndex LastLinkIndex LiteralStart MessageArgumentsIndex MessageLookupClassIndex MessageSelectorIndex MethodArrayIndex MethodDictionaryIndex MethodIndex MyListIndex NextLinkIndex NilObject PrimErrTableIndex PriorityIndex ProcessInExternalCodeTag ProcessListsIndex ProcessSignalingLowSpace ReceiverIndex SchedulerAssociation SelectorAboutToReturn SelectorAttemptToAssign SelectorCannotInterpret SelectorCannotReturn SelectorCounterTripped SelectorDoesNotUnderstand SelectorInvokeCallback SelectorMustBeBoolean SelectorRunWithIn SelectorStart SelectorUnknownBytecode SenderIndex SpecialSelectors StackPointerIndex StreamArrayIndex StreamIndexIndex StreamReadLimitIndex StreamWriteLimitIndex SuperclassIndex SuspendedContextIndex TheDisplay TheFinalizationSemaphore TheInputSemaphore TheInterruptSemaphore TheLowSpaceSemaphore TheTimerSemaphore TrueObject ValueIndex XIndex YIndex'
- classVariableNames: 'ActiveProcessIndex CharacterTable CharacterValueIndex ClassAlien ClassArray ClassBitmap ClassBlockClosure ClassBlockContext ClassByteArray ClassByteString ClassCharacter ClassCompiledMethod ClassExternalAddress ClassExternalData ClassExternalFunction ClassExternalLibrary ClassExternalStructure ClassFloat ClassInteger ClassLargeNegativeInteger ClassLargePositiveInteger ClassMessage ClassMethodContext ClassMutex ClassPoint ClassProcess ClassSemaphore ClassString ClassUnsafeAlien ClassWeakFinalizer ClosureCopiedValuesIndex ClosureFirstCopiedValueIndex ClosureIndex ClosureNumArgsIndex ClosureOuterContextIndex ClosureStartPCIndex CompactClasses ConstMinusOne ConstOne ConstTwo ConstZero ExcessSignalsIndex ExternalObjectsArray FalseObject FirstLinkIndex ForeignCallbackProcess HeaderIndex InstanceSpecificationIndex InstructionPointerIndex KeyIndex LastLinkIndex LiteralStart MessageArgumentsIndex MessageLookupClassIndex MessageSelectorIndex MethodArrayIndex MethodDictionaryIndex MethodIndex MyListIndex NextLinkIndex NilObject PrimErrTableIndex PriorityIndex ProcessInExternalCodeTag ProcessListsIndex ProcessSignalingLowSpace ReceiverIndex SchedulerAssociation SelectorAboutToReturn SelectorAttemptToAssign SelectorCannotInterpret SelectorCannotReturn SelectorCounterTripped SelectorDoesNotUnderstand SelectorInvokeCallback SelectorMustBeBoolean SelectorRunWithIn SelectorStart SenderIndex SpecialSelectors StackPointerIndex StreamArrayIndex StreamIndexIndex StreamReadLimitIndex StreamWriteLimitIndex SuperclassIndex SuspendedContextIndex TheDisplay TheFinalizationSemaphore TheInputSemaphore TheInterruptSemaphore TheLowSpaceSemaphore TheTimerSemaphore TrueObject ValueIndex XIndex YIndex'
poolDictionaries: ''
category: 'VMMaker-Interpreter'!
!VMObjectIndices commentStamp: '<historical>' prior: 0!
I am a shared pool for the constants that define object layout and well-known objects shared between the object memories (e.g. ObjectMemory, NewObjectMemory), the interpreters (e.g. StackInterpreter, CoInterpreter) and the object representations (e.g. ObjectRepresentationForSqueakV3).
self classPool declare: #Foo from: StackInterpreter classPool
(ObjectMemory classPool keys select: [:k| (k beginsWith: 'Class') and: [(k endsWith: 'Index') not]]) do:
[:k| self classPool declare: k from: ObjectMemory classPool]!
More information about the Vm-dev
mailing list