Smalltalk › Squeak › Squeak VM

VM Maker: VMMaker.oscog-eem.2150.mcz

_‹ Previous Topic Next Topic _›

Classic

List

Threaded

1 message

commits-2

VM Maker: VMMaker.oscog-eem.2150.mcz

Eliot Miranda uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker.oscog-eem.2150.mcz

==================== Summary ====================

Name: VMMaker.oscog-eem.2150
Author: eem
Time: 13 March 2017, 5:38:40.739778 pm
UUID: 022f453c-dd21-46ff-877c-e997ce7cdc88
Ancestors: VMMaker.oscog-eem.2149

Stack/CoInterpreter:
Refactor the assignments to the stack pointers from a page's head pointers into setStackPointersFromPage:.

Remove calls to addNewmethodToCache: from clients of lookupOrdinaryNoMNUEtcInClass: which does this anyway.

Cogit:
Use unsigned int as the type of 32-bit instructions (ARM & MIPS). Reduce code on the class side in defining the CogAbstractInstruction typedefs.
Eliminate some "variable name shadows method" warnings.
Document that the limit on the Cogit's alloca more than ensures that the number of abstract instructions and bytecode fixups fits within 16 bits.
Make sure a simulation-only merthod is not generated.
FDix traceMerge: for in-image compilation.

=============== Diff against VMMaker.oscog-eem.2149 ===============

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 - objectMemory wordSize).
self assert: stackPage baseFP + (2 * objectMemory wordSize) < 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 - objectMemory wordSize))
and: [objectMemory isContext: (stackPages longAt: stackPage baseAddress - objectMemory wordSize)]).
contextToReturnTo := stackPages longAt: stackPage baseAddress.
self assert: (objectMemory addressCouldBeObj: contextToReturnTo).

"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
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 := stackPages newStackPage.
self assert: newPage = stackPage.
self moveFramesIn: thePage through: frameAbove toPage: newPage.
stackPages markStackPageMostRecentlyUsed: newPage.
+ self setStackPointersFromPage: thePage]]
- framePointer := thePage headFP.
- stackPointer := thePage headSP]]
ifFalse:
[(isAContext
and: [objectMemory isIntegerObject: (objectMemory fetchPointer: InstructionPointerIndex ofObject: contextToReturnTo)]) ifFalse:
[contextToReturnFrom := stackPages longAt: stackPage baseAddress - objectMemory wordSize.
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.
+ self setStackPointersFromPage: thePage].
- 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
"Two things are going on here. The main one is catching a counter trip and attempting
to send the SelectorCounterTripped selector. In this case we would like to back-up
the pc to the return address of the send that yields the boolean to be tested, so that
after potential optimization, computation proceeds by retrying the jump. But we cannot,
since there may be no send, just a pop (as in and: [] and or: [] chains). In this case we also
want to prevent further callbacks until optimization is complete. So we nil-out the
SelectorCounterTripped entry in the specialSelectorArray.

The minor case is that there is an unlikely possibility that the cointer tripped but condition
is not a boolean, in which case a mustBeBoolean response should occur."
<api>
<option: #SistaCogit>
"Send e.g. thisContext conditionalBranchCounterTrippedOn: boolean."
| context counterTrippedSelector classTag classObj |
(condition = objectMemory falseObject
or: [condition = objectMemory trueObject]) ifFalse:
[^self ceSendMustBeBoolean: condition].

counterTrippedSelector := objectMemory maybeSplObj: SelectorCounterTripped.
(counterTrippedSelector isNil
or: [counterTrippedSelector = objectMemory nilObject]) ifTrue:
[cogit resetCountersIn: (self mframeHomeMethod: framePointer).
^condition].

classTag := objectMemory
classTagForSpecialObjectsIndex: ClassMethodContext
compactClassIndex: ClassMethodContextCompactIndex.
(self lookupInMethodCacheSel: counterTrippedSelector classTag: classTag) ifFalse:
[messageSelector := counterTrippedSelector.
classObj := objectMemory classForClassTag: classTag.
(self lookupOrdinaryNoMNUEtcInClass: classObj) ~= 0 ifTrue:
[cogit resetCountersIn: (self mframeHomeMethod: framePointer).
+ ^condition]].
- ^condition].
- self addNewMethodToCache: classObj].

(primitiveFunctionPointer ~= 0
or: [(self argumentCountOf: newMethod) ~= 1]) ifTrue:
[cogit resetCountersIn: (self mframeHomeMethod: framePointer).
^condition].

objectMemory splObj: SelectorCounterTripped put: objectMemory nilObject.
instructionPointer := self popStack.
context := self ensureFrameIsMarried: framePointer SP: stackPointer.
self push: context.
self push: condition.
self ifAppropriateCompileToNativeCode: newMethod selector: counterTrippedSelector.
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 followField: ClosureOuterContextIndex ofObject: closure.
closure := objectMemory followField: 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)
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).
stackPages freeStackPage: stackPage.
[self assert: (objectMemory 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.
+ self setStackPointersFromPage: 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."
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>>ceSend:above:to:numArgs: (in category 'trampolines') -----
ceSend: selector above: startAssociationArg to: rcvr numArgs: numArgs
"Entry-point for an unlinked directed super send in a CogMethod. Smalltalk stack looks like
receiver
args
head sp -> sender return pc
startAssociation is an association whose value is the class above which to start the lookup.

If an MNU then defer to handleMNUInMachineCodeTo:... which will dispatch the MNU and
may choose to allocate a closed PIC with a fast MNU dispatch for this send. Otherwise
attempt to link the send site as efficiently as possible. All link attempts may fail; e.g.
because we're out of code memory.

Continue execution via either executeMethod or interpretMethodFromMachineCode:
depending on whether the target method is cogged or not."
<api>
<option: #BytecodeSetHasDirectedSuperSend>
| startAssociation classTag classObj errSelIdx cogMethod |
<inline: false>
<var: #cogMethod type: #'CogMethod *'>
<var: #newCogMethod type: #'CogMethod *'>
"self printExternalHeadFrame"
"self printStringOf: selector"
cogit assertCStackWellAligned.
self assert: (objectMemory addressCouldBeOop: rcvr).
self sendBreakpoint: selector receiver: rcvr.
startAssociation := objectMemory followMaybeForwarded: startAssociationArg.
classTag := objectMemory classTagForClass: (self superclassOf: (objectMemory fetchPointer: ValueIndex ofObject: startAssociation)).
argumentCount := numArgs.
(self lookupInMethodCacheSel: selector classTag: classTag)
ifTrue:"check for coggability because method is in the cache"
[self
ifAppropriateCompileToNativeCode: newMethod
selector: selector]
ifFalse:
[self deny: (objectMemory isForwardedClassTag: classTag).
(objectMemory isOopForwarded: selector) ifTrue:
[^self
ceSend: (self handleForwardedSelectorFaultFor: selector)
above: startAssociation
to: rcvr
numArgs: numArgs].
messageSelector := selector.
classObj := objectMemory classForClassTag: classTag.
(errSelIdx := self lookupOrdinaryNoMNUEtcInClass: classObj) ~= 0 ifTrue:
[(errSelIdx = SelectorDoesNotUnderstand
and: [(cogMethod := cogit cogMNUPICSelector: messageSelector
receiver: rcvr
methodOperand: (self mnuMethodOrNilFor: rcvr)
numArgs: argumentCount) asUnsignedInteger
> cogit minCogMethodAddress]) ifTrue:
[cogit
linkSendAt: (stackPages longAt: stackPointer)
in: (self mframeHomeMethod: framePointer)
to: cogMethod
offset: cogit noCheckEntryOffset
receiver: rcvr].
self handleMNU: errSelIdx
InMachineCodeTo: rcvr
classForMessage: classObj.
+ self assert: false "NOTREACHED"]].
- self assert: false "NOTREACHED"].
- self addNewMethodToCache: classObj].
"Method found and has a cog method. Attempt to link to it. The receiver's class may be young.
If the Cogit can't store young classes in inline caches we can link to an open PIC instead."
(self maybeMethodHasCogMethod: newMethod) ifTrue:
[cogMethod := self cogMethodOf: newMethod.
cogMethod selector = objectMemory nilObject
ifTrue: [cogit setSelectorOf: cogMethod to: selector]
ifFalse:
["Deal with anonymous accessors, e.g. in Newspeak. The cogMethod may not have the
correct selector. If not, try and compile a new method with the correct selector."
cogMethod selector ~= selector ifTrue:
[(cogit cog: newMethod selector: selector) ifNotNil:
[:newCogMethod| cogMethod := newCogMethod]]].
cogMethod selector = selector
ifTrue:
[cogit
linkSendAt: (stackPages longAt: stackPointer)
in: (self mframeHomeMethod: framePointer)
to: cogMethod
offset: cogit noCheckEntryOffset
receiver: rcvr]
ifFalse: "If patchToOpenPICFor:.. returns we're out of code memory"
[cogit
patchToOpenPICFor: selector
numArgs: numArgs
receiver: rcvr].
instructionPointer := self popStack.
self executeNewMethod.
self assert: false "NOTREACHED"].
instructionPointer := self popStack.
^self interpretMethodFromMachineCode
"NOTREACHED"!

Item was changed:
----- Method: CoInterpreter>>ceSend:super:to:numArgs: (in category 'trampolines') -----
ceSend: selector super: superNormalBar to: rcvr numArgs: numArgs
"Entry-point for an unlinked send in a CogMethod. Smalltalk stack looks like
receiver
args
head sp -> sender return pc

If an MNU then defer to handleMNUInMachineCodeTo:... which will dispatch the MNU and
may choose to allocate a closed PIC with a fast MNU dispatch for this send. Otherwise
attempt to link the send site as efficiently as possible. All link attempts may fail; e.g.
because we're out of code memory.

Continue execution via either executeMethod or interpretMethodFromMachineCode:
depending on whether the target method is cogged or not."
<api>
| classTag classObj errSelIdx cogMethod |
<inline: false>
<var: #cogMethod type: #'CogMethod *'>
<var: #newCogMethod type: #'CogMethod *'>
"self printExternalHeadFrame"
"self printStringOf: selector"
cogit assertCStackWellAligned.
self assert: (objectMemory addressCouldBeOop: rcvr).
self sendBreakpoint: selector receiver: rcvr.
superNormalBar = 0
ifTrue: [classTag := objectMemory fetchClassTagOf: rcvr]
ifFalse: [classTag := objectMemory classTagForClass: (self superclassOf: (self methodClassOf: (self frameMethodObject: framePointer)))].
argumentCount := numArgs.
(self lookupInMethodCacheSel: selector classTag: classTag)
ifTrue:"check for coggability because method is in the cache"
[self
ifAppropriateCompileToNativeCode: newMethod
selector: selector]
ifFalse:
[(objectMemory isOopForwarded: selector) ifTrue:
[^self
ceSend: (self handleForwardedSelectorFaultFor: selector)
super: superNormalBar
to: rcvr
numArgs: numArgs].
(objectMemory isForwardedClassTag: classTag) ifTrue:
[self assert: superNormalBar = 0.
^self
ceSend: selector
super: superNormalBar
to: (self handleForwardedSendFaultForReceiver: rcvr stackDelta: 1 "skip return pc")
numArgs: numArgs].
messageSelector := selector.
classObj := objectMemory classForClassTag: classTag.
(errSelIdx := self lookupOrdinaryNoMNUEtcInClass: classObj) ~= 0 ifTrue:
[(errSelIdx = SelectorDoesNotUnderstand
and: [(cogMethod := cogit cogMNUPICSelector: messageSelector
receiver: rcvr
methodOperand: (self mnuMethodOrNilFor: rcvr)
numArgs: argumentCount) asUnsignedInteger
> cogit minCogMethodAddress]) ifTrue:
[cogit
linkSendAt: (stackPages longAt: stackPointer)
in: (self mframeHomeMethod: framePointer)
to: cogMethod
offset: (superNormalBar = 0
ifTrue: [cogit entryOffset]
ifFalse: [cogit noCheckEntryOffset])
receiver: rcvr].
self handleMNU: errSelIdx InMachineCodeTo: rcvr classForMessage: classObj.
+ self assert: false "NOTREACHED"]].
- self assert: false "NOTREACHED"].
- self addNewMethodToCache: classObj].
"Method found and has a cog method. Attempt to link to it. The receiver's class may be young.
If the Cogit can't store young classes in inline caches we can link to an open PIC instead."
(self maybeMethodHasCogMethod: newMethod) ifTrue:
[cogMethod := self cogMethodOf: newMethod.
cogMethod selector = objectMemory nilObject
ifTrue: [cogit setSelectorOf: cogMethod to: selector]
ifFalse:
["Deal with anonymous accessors, e.g. in Newspeak. The cogMethod may not have the
correct selector. If not, try and compile a new method with the correct selector."
cogMethod selector ~= selector ifTrue:
[(cogit cog: newMethod selector: selector) ifNotNil:
[:newCogMethod| cogMethod := newCogMethod]]].
cogMethod selector = selector
ifTrue:
[cogit
linkSendAt: (stackPages longAt: stackPointer)
in: (self mframeHomeMethod: framePointer)
to: cogMethod
offset: (superNormalBar = 0
ifTrue: [cogit entryOffset]
ifFalse: [cogit noCheckEntryOffset])
receiver: rcvr]
ifFalse: "If patchToOpenPICFor:.. returns we're out of code memory"
[cogit
patchToOpenPICFor: selector
numArgs: numArgs
receiver: rcvr].
instructionPointer := self popStack.
self executeNewMethod.
self assert: false "NOTREACHED"].
instructionPointer := self popStack.
^self interpretMethodFromMachineCode
"NOTREACHED"!

Item was changed:
----- Method: CoInterpreter>>ceSendAbort:to:numArgs: (in category 'trampolines') -----
ceSendAbort: selector to: rcvr numArgs: numArgs
"Entry-point for an abort send in a CogMethod (aboutToReturn:through:, cannotReturn: et al).
Try and dispatch the send, but the send may turn into an MNU in which case defer to
handleMNUInMachineCodeTo:... which will dispatch the MNU.

Continue execution via either executeMethod or interpretMethodFromMachineCode:
depending on whether the target method is cogged or not."
<api>
| classTag classObj errSelIdx |
<inline: false>
"self printExternalHeadFrame"
"self printStringOf: selector"
cogit assertCStackWellAligned.
self assert: (objectMemory addressCouldBeOop: rcvr).
self sendBreakpoint: selector receiver: rcvr.
argumentCount := numArgs.
classTag := objectMemory fetchClassTagOf: rcvr.
(self lookupInMethodCacheSel: selector classTag: classTag)
ifTrue:"check for coggability because method is in the cache"
[self
ifAppropriateCompileToNativeCode: newMethod
selector: selector]
ifFalse:
[messageSelector := selector.
classObj := objectMemory classForClassTag: classTag.
(errSelIdx := self lookupOrdinaryNoMNUEtcInClass: classObj) ~= 0 ifTrue:
[self handleMNU: errSelIdx InMachineCodeTo: rcvr classForMessage: classObj.
"NOTREACHED"
+ self assert: false]].
- self assert: false].
- self addNewMethodToCache: classObj].
instructionPointer := self popStack.
(self maybeMethodHasCogMethod: newMethod) ifTrue:
[self executeNewMethod.
self assert: false
"NOTREACHED"].
^self interpretMethodFromMachineCode
"NOTREACHED"!

Item was changed:
----- Method: CoInterpreter>>ceSendFromInLineCacheMiss: (in category 'trampolines') -----
ceSendFromInLineCacheMiss: cogMethodOrPIC
"Send from an Open PIC when the first-level method lookup probe has failed,
or to continue when PIC creation has failed (e.g. because we're out of code space),
or when a send has failed due to a forwarded receiver."
<api>
<var: #cogMethodOrPIC type: #'CogMethod *'>
| numArgs rcvr classTag classObj errSelIdx |
"self printFrame: stackPage headFP WithSP: stackPage headSP"
"self printStringOf: selector"
numArgs := cogMethodOrPIC cmNumArgs.
rcvr := self stackValue: numArgs + 1. "skip return pc"
self assert: (objectMemory addressCouldBeOop: rcvr).
classTag := objectMemory fetchClassTagOf: rcvr.
argumentCount := numArgs.
false ifTrue: "would like to assert this but must also allow for an interpretable method in the cache."
[self deny: (cogMethodOrPIC cmType = CMOpenPIC
and: [self newMethodInLookupCacheAt: cogMethodOrPIC selector and: classTag])].
(self lookupInMethodCacheSel: cogMethodOrPIC selector classTag: classTag)
ifTrue:"check for coggability because method is in the cache"
[self
ifAppropriateCompileToNativeCode: newMethod
selector: cogMethodOrPIC selector]
ifFalse:
[(objectMemory isOopForwarded: cogMethodOrPIC selector) ifTrue:
[self handleForwardedSelectorFaultFor: cogMethodOrPIC selector.
^self ceSendFromInLineCacheMiss: cogMethodOrPIC].
(objectMemory isForwardedClassTag: classTag) ifTrue:
[self handleForwardedSendFaultForReceiver: rcvr stackDelta: 1 "skip return pc".
^self ceSendFromInLineCacheMiss: cogMethodOrPIC].
messageSelector := cogMethodOrPIC selector.
classObj := objectMemory classForClassTag: classTag.
(errSelIdx := self lookupOrdinaryNoMNUEtcInClass: classObj) ~= 0 ifTrue:
[self handleMNU: errSelIdx InMachineCodeTo: rcvr classForMessage: classObj.
"NOTREACHED"
+ self assert: false]].
- self assert: false].
- self addNewMethodToCache: classObj].
instructionPointer := self popStack.
(self maybeMethodHasCogMethod: newMethod) ifTrue:
[self executeNewMethod.
self assert: false
"NOTREACHED"].
^self interpretMethodFromMachineCode
"NOTREACHED"!

Item was changed:
----- Method: CoInterpreter>>tearDownAndRebuildFrameForCannotReturnBaseFrameReturnFrom:to:returnValue: (in category 'return bytecodes') -----
tearDownAndRebuildFrameForCannotReturnBaseFrameReturnFrom: contextToReturnFrom to: contextToReturnTo returnValue: returnValue
"Handle the cannot return response for a base frame return to an invalid context.
Build a new base frame for the context in the cannot resume state ready for the
send of cannotReturn:.

Since we have returned from the base frame of the page the context is effectively widowed.
But its sender needs to be contextToReturnTo, and its pc needs to be the HasBeenReturnedFromMCPC
marker. So bereave it (as a side-effect of isWidowedContext:), assign contextToReturnTo to
sender, and rebuild its frame, which will have the ceCannotResumePC as its pc. Finally push
returnValue and set instructionPointer to ceCannotResumePC in preparation for the send."
| newPage |
<inline: false>
<var: #newPage type: #'StackPage *'>
self assert: (stackPage ~= 0 and: [stackPage isFree]).
self isWidowedContext: contextToReturnFrom.
self assert: (self isMarriedOrWidowedContext: contextToReturnFrom) not.
objectMemory
storePointer: SenderIndex ofObject: contextToReturnFrom withValue: contextToReturnTo;
storePointer: InstructionPointerIndex ofObject: contextToReturnFrom withValue: HasBeenReturnedFromMCPCOop.
"void the instructionPointer to stop it being incorrectly updated in a code
compaction in makeBaseFrameFor:."
instructionPointer := 0.
newPage := self makeBaseFrameFor: contextToReturnFrom.
self assert: stackPage = newPage.
self setStackPageAndLimit: newPage.
+ self setStackPointersFromPage: newPage.
- framePointer := stackPage headFP.
- stackPointer := stackPage headSP.
self assert: self stackTop = cogit ceCannotResumePC.
"overwrite the ceSendCannotResumePC on the stack. If ever re-executed
the returnValue will be taken from top-of-stack by ceCannotResume."
self stackTopPut: returnValue.
"Assign it to instructionPointer as externalCannotReturn:from: pushes it."
instructionPointer := cogit ceCannotResumePC!

Item was changed:
----- Method: CoInterpreterPrimitives>>primitiveVoidVMStateForMethod (in category 'system control primitives') -----
primitiveVoidVMStateForMethod
"The receiver is a compiledMethod. Clear all VM state associated with the method,
including any machine code, or machine code pcs in context objects."
| activeContext methodObj hasCogMethod theFrame thePage |
<var: #theFrame type: #'char *'>
<var: #thePage type: #'StackPage *'>
super primitiveFlushCacheByMethod.
"One might think (as this author did) that the heap scan is unnecessary if the method does not
have a cog method. But it could be the case that the code zone has recently been reclaimed
and so not having a cog method is no indication that it didn't have a cog method some time in
the recent past, and that there are indeed still contexts with machine code pcs out there. The
only steps that can be avoided is divorcing frames in the stack zone, and scanning to unlink and
free if there isn't a cog method."
methodObj := self stackTop.
activeContext := self ensureFrameIsMarried: framePointer SP: stackPointer.
self ensurePushedInstructionPointer.
self externalWriteBackHeadFramePointers.
(hasCogMethod := self methodHasCogMethod: methodObj) ifTrue:
[self divorceMachineCodeFramesWithMethod: methodObj].
self ensureAllContextsWithMethodHaveBytecodePCs: methodObj.
hasCogMethod ifTrue:
[cogit unlinkSendsTo: methodObj andFreeIf: true].
(self isStillMarriedContext: activeContext)
ifTrue:
[theFrame := self frameOfMarriedContext: activeContext.
thePage := stackPages stackPageFor: theFrame.
self assert: thePage headFP = theFrame.
self setStackPageAndLimit: thePage.
+ self setStackPointersFromPage: thePage.
- stackPointer := thePage headSP.
- framePointer := thePage headFP.
instructionPointer := self popStack.
self assert: methodObj = self stackTop]
ifFalse:
[self zeroStackPage. "to avoid assert in marryContextInNewStackPageAndInitializeInterpreterRegisters:"
self marryContextInNewStackPageAndInitializeInterpreterRegisters: activeContext.
self popStack. "pop bogus machine-code instructionPointer"
self assert: methodObj = self stackTop.
self siglong: reenterInterpreter jmp: ReturnToInterpreter]!

Item was changed:
----- Method: CogARMCompiler class>>machineCodeDeclaration (in category 'translation') -----
machineCodeDeclaration
+ "Answer the declaration for the machineCode array.
+ ARM instructions are 32-bits in length."
+ ^{#'unsigned int'. '[', self basicNew machineCodeWords printString, ']'}!
- "Answer the declaration for the machineCode array."
- ^{#'usqIntptr_t'. '[', self basicNew machineCodeWords printString, ']'}!

Item was changed:
----- Method: CogARMCompiler>>rewriteCPICJumpAt:target: (in category 'inline cacheing') -----
+ rewriteCPICJumpAt: addressFollowingJump target: jumpTargetAddr
- rewriteCPICJumpAt: addressFollowingJump target: jumpTargetAddress
"Rewrite a jump instruction to call a different target. This variant is used to reset the
jumps in the prototype CPIC to suit each use,.
Answer the extent of the code change which is used to compute the range of the icache to flush."
<var: #addressFollowingJump type: #usqInt>
+ <var: #jumpTargetAddr type: #usqInt>
- <var: #jumpTargetAddress type: #usqInt>
<inline: true>
+ ^self rewriteTransferAt: addressFollowingJump target: jumpTargetAddr!
- ^self rewriteTransferAt: addressFollowingJump target: jumpTargetAddress!

Item was added:
+ ----- Method: CogAbstractInstruction class>>filteredInstVarNames (in category 'translation') -----
+ filteredInstVarNames
+ "Eliminate bcpc, which is development-time only."
+ ^super filteredInstVarNames copyWithout: 'bcpc'!

Item was changed:
----- Method: CogAbstractInstruction class>>instVarNamesAndTypesForTranslationDo: (in category 'translation') -----
instVarNamesAndTypesForTranslationDo: aBinaryBlock
+ "Enumerate aBinaryBlock with the names and C type strings for the inst vars to include in an AbstractInstruction struct."
+ "(CogAbstractInstruction withAllSubclasses reject: [:c| c name includesSubString: 'ForTests']) do:
- "enumerate aBinaryBlock with the names and C type strings for the inst vars to include in an AbstractInstruction struct."
- "{CogAbstractInstruction. CogIA32Compiler. CogARMCompiler} do:
[:c| Transcript print: c; cr. c printTypedefOn: Transcript]"
(self filteredInstVarNames copyWithout: 'machineCode'), #('machineCode') do:
[:ivn|
+ aBinaryBlock
+ value: ivn
+ value: (ivn caseOf: {
+ ['address'] -> [#usqInt]. "usqInt is always large enough to contain a pointer; we do not need to use usqIntptr_t"
+ ['machineCode'] -> [self machineCodeDeclaration].
+ ['operands'] -> [{#usqInt. '[', NumOperands, ']'}].
+ ['dependent'] -> ['struct _AbstractInstruction *']}
+ otherwise:
+ [#'unsigned char'])]!
- ivn ~= 'bcpc' ifTrue:
- [aBinaryBlock
- value: ivn
- value: (ivn caseOf: {
- ['address'] -> [#'usqIntptr_t'].
- ['machineCode'] -> [self machineCodeDeclaration].
- ['operands'] -> [{#'usqIntptr_t'. '[', NumOperands, ']'}].
- ['dependent'] -> ['struct _AbstractInstruction *']}
- otherwise:
- [#'unsigned char'])]]!

Item was changed:
----- Method: CogAbstractInstruction class>>machineCodeDeclaration (in category 'translation') -----
machineCodeDeclaration
+ "Answer a dummy declaration. Subclasses will override to provide the real one."
- "Answer a dummy declaration. Subclasses will override to provgide the real one."
^#(#'unsigned char' '[4]')!

Item was changed:
----- Method: CogBytecodeFixup class>>instVarNamesAndTypesForTranslationDo: (in category 'translation') -----
instVarNamesAndTypesForTranslationDo: aBinaryBlock
+ "Enumerate aBinaryBlock with the names and C type strings for the inst vars to include in a BytecodeFixup struct."
+ "self withAllSubclasses collect: [:ea| ea typedef]"
- "enumerate aBinaryBlock with the names and C type strings for the inst vars to include in a BytecodeFixup struct."

self filteredInstVarNames do:
[:ivn|
aBinaryBlock
value: ivn
+ value: (ivn first ~= $# ifTrue:
+ [ivn caseOf: {
+ ['targetInstruction'] -> [#'AbstractInstruction *'].
+ ['mergeSimStack'] -> [#'SimStackEntry *'].
+ ['instructionIndex'] -> [#'unsigned short'].
+ ['simStackPtr'] -> [#char].
+ ['simNativeStackPtr'] -> [#'unsigned short'].
+ ['simNativeStackSize'] -> [#'unsigned short'].
+ ['isReceiverResultRegSelf'] -> [#char] }])]!
- value: (ivn = 'targetInstruction'
- ifTrue: [#'AbstractInstruction *']
- ifFalse:
- [#sqInt])]!

Item was changed:
----- Method: CogIA32Compiler>>genPushC64: (in category 'abstract instructions') -----
genPushC64: constant64Bits
<inline: true>
<var: #constant64Bits type: #sqLong>
<returnTypeC: #'AbstractInstruction *'>
| inst highPart |
+ self assert: BytesPerWord = 4.
+ highPart := self cCode: '(constant64Bits >> 32LL)' inSmalltalk: [ constant64Bits bitShift: -32 ].
+ inst :=cogit PushCw: highPart.
+ cogit PushCw: (constant64Bits bitAnd: 16rFFFFFFFF).
+ ^inst!
- BytesPerWord == 4 ifTrue: [
- highPart := self cCode: '(constant64Bits >> 32ll)' inSmalltalk: [ constant64Bits bitShift: -32 ].
- inst :=cogit PushCw: highPart.
- cogit PushCw: (constant64Bits bitAnd: 16rFFFFFFFF).
- ^ inst
- ] ifFalse: [
- ^ cogit PushCw: constant64Bits.
- ]!

Item was changed:
----- Method: CogIA32Compiler>>rewriteCPICJumpAt:target: (in category 'inline cacheing') -----
+ rewriteCPICJumpAt: addressFollowingJump target: jumpTargetAddr
- rewriteCPICJumpAt: addressFollowingJump target: jumpTargetAddress
"Rewrite the short jump instruction to jump to a new cpic case target. "
<var: #addressFollowingJump type: #usqInt>
+ <var: #jumpTargetAddr type: #usqInt>
- <var: #jumpTargetAddress type: #usqInt>
<var: #callDistance type: #sqInt> "prevent type inference for avoiding warning on abs"
| callDistance |
+ callDistance := jumpTargetAddr - addressFollowingJump.
- callDistance := jumpTargetAddress - addressFollowingJump.
self assert: callDistance abs < 128.
objectMemory
byteAt: addressFollowingJump - 1
put: (callDistance bitAnd: 16rFF).
"self cCode: ''
+ inSmalltalk: [cogit disassembleFrom: addressFollowingJump - 10 to: addressFollowingJump - 1]."!
- inSmalltalk: [cogit disassembleFrom: addressFollowingJump - 10 to: addressFollowingJump - 1]."
- ^2!

Item was changed:
----- Method: CogMIPSELCompiler class>>machineCodeDeclaration (in category 'translation') -----
machineCodeDeclaration
+ "Answer the declaration for the machineCode array.
+ MPIS instructions are 32-bits in length."
+ ^{#'unsigned int'. '[', self basicNew machineCodeWords printString, ']'}!
- "Answer the declaration for the machineCode array."
- ^{#'usqIntptr_t'. '[', self basicNew machineCodeWords printString, ']'}!

Item was changed:
----- Method: CogMIPSELCompiler>>rewriteCPICJumpAt:target: (in category 'inline cacheing') -----
+ rewriteCPICJumpAt: addressFollowingJump target: jumpTargetAddr
- rewriteCPICJumpAt: addressFollowingJump target: jumpTargetAddress
"Rewrite a jump instruction to call a different target. This variant is used to reset the
jumps in the prototype CPIC to suit each use,.
Answer the extent of the code change which is used to compute the range of the icache to flush."
<var: #addressFollowingJump type: #usqInt>
+ <var: #jumpTargetAddr type: #usqInt>
- <var: #jumpTargetAddress type: #usqInt>

"self CmpR: ClassReg R: TempReg.
^self JumpNonZero: 0"

"bne s5, s3, +156 ; =BE7C
nop (delay slot)
.... <-- addressFollowingJump"

self assert: (self opcodeAtAddress: addressFollowingJump - 8) = BNE.
self assert: (objectMemory longAt: addressFollowingJump - 4) = self nop.
"cogit disassembleFrom: addressFollowingJump - 8 to: addressFollowingJump."

+ self rewriteITypeBranchAtAddress: addressFollowingJump - 8 target: jumpTargetAddr.
- self rewriteITypeBranchAtAddress: addressFollowingJump - 8 target: jumpTargetAddress.

self assert: (self opcodeAtAddress: addressFollowingJump - 8) = BNE.
self assert: (objectMemory longAt: addressFollowingJump - 4) = self nop.
"cogit disassembleFrom: addressFollowingJump - 8 to: addressFollowingJump."!

Item was removed:
- ----- Method: CogMethodZone>>alignment (in category 'accessing') -----
- alignment
- ^8!

Item was added:
+ ----- Method: CogMethodZone>>zoneAlignment (in category 'accessing') -----
+ zoneAlignment
+ ^8!

Item was changed:
----- Method: CogObjectRepresentationFor64BitSpur>>maybeGenerateSelectorIndexDereferenceRoutine (in category 'initialization') -----
maybeGenerateSelectorIndexDereferenceRoutine
"Generate the routine that converts selector indices into selector objects.
It is called from the send trampolines.
If the selector index is negative, convert it into a positive index into the
special selectors array and index that. Otherwise, index the current method.
The routine uses Extra0Reg & Extra1Reg, which are available, since they
are not live at point of send."
| jumpNegative jumpNotBlock jumpFullBlock |
<var: 'jumpNegative' type: #'AbstractInstruction *'>
<var: 'jumpNotBlock' type: #'AbstractInstruction *'>
<var: 'jumpFullBlock' type: #'AbstractInstruction *'>
cogit zeroOpcodeIndex.
cogit CmpCq: 0 R: ClassReg.
jumpNegative := cogit JumpLess: 0.
cogit
MoveMw: FoxMethod r: FPReg R: Extra0Reg;
AddCq: 2 R: ClassReg; "Change selector index to 1-relative, skipping the method header"
TstCq: MFMethodFlagIsBlockFlag R: Extra0Reg.
jumpNotBlock := cogit JumpZero: 0.
"If in a block, need to find the home method... If using full blocks, need to test the cpicHasMNUCaseOrCMIsFullBlock bit"
+ cogit AndCq: methodZone zoneAlignment negated R: Extra0Reg.
- cogit AndCq: methodZone alignment negated R: Extra0Reg.
SistaV1BytecodeSet ifTrue:
[self bitAndByteOffsetOfIsFullBlockBitInto:
[:bitmask :byteOffset|
jumpFullBlock := cogit
MoveMb: byteOffset r: Extra0Reg R: Extra1Reg;
TstCq: bitmask R: Extra1Reg;
JumpNonZero: 0]].
cogit
MoveM16: 0 r: Extra0Reg R: Extra1Reg;
SubR: Extra1Reg R: Extra0Reg.
jumpNotBlock jmpTarget: cogit Label.
SistaV1BytecodeSet ifTrue:
[jumpFullBlock jmpTarget: jumpNotBlock getJmpTarget].
cogit "Now fetch the method object and index with the literal index to retrieve the selector"
+ AndCq: methodZone zoneAlignment negated R: Extra0Reg;
- AndCq: methodZone alignment negated R: Extra0Reg;
MoveMw: (cogit offset: CogMethod of: #methodObject) r: Extra0Reg R: Extra1Reg;
MoveXwr: ClassReg R: Extra1Reg R: ClassReg;
RetN: 0.
jumpNegative jmpTarget: cogit Label.
cogit
NegateR: ClassReg;
LogicalShiftLeftCq: 1 R: ClassReg;
MoveAw: objectMemory specialObjectsArrayAddress R: Extra0Reg;
SubCq: 1 R: ClassReg;
MoveMw: SpecialSelectors + 1 * objectMemory wordSize r: Extra0Reg R: Extra1Reg; "Index, including header size"
MoveXwr: ClassReg R: Extra1Reg R: ClassReg;
RetN: 0.
ceDereferenceSelectorIndex := cogit methodZoneBase.
cogit
outputInstructionsForGeneratedRuntimeAt: ceDereferenceSelectorIndex;
recordGeneratedRunTime: 'ceDereferenceSelectorIndex' address: ceDereferenceSelectorIndex;
recordRunTimeObjectReferences!

Item was added:
+ ----- Method: CogRASSBytecodeFixup class>>filteredInstVarNames (in category 'translation') -----
+ filteredInstVarNames
+ "Override to group char and short vars together for compactness.
+ self typedef"
+ | vars |
+ vars := super filteredInstVarNames asOrderedCollection.
+ vars
+ remove: 'mergeSimStack';
+ add: 'mergeSimStack' afterIndex: (vars indexOf: 'targetInstruction');
+ remove: 'isReceiverResultRegSelf';
+ add: 'isReceiverResultRegSelf' afterIndex: (vars indexOf: 'simStackPtr').
+ ^vars!

Item was removed:
- ----- Method: CogRASSBytecodeFixup class>>instVarNamesAndTypesForTranslationDo: (in category 'translation') -----
- instVarNamesAndTypesForTranslationDo: aBinaryBlock
- "enumerate aBinaryBlock with the names and C type strings for the inst vars to include in a CogRASSBytecodeFixup struct."
-
- (self allInstVarNames copyWithout: 'cogit') do:
- [:ivn|
- aBinaryBlock
- value: ivn
- value: (ivn caseOf: {
- ['targetInstruction'] -> [#'AbstractInstruction *'].
- ['mergeSimStack'] -> [#'CogSimStackEntry *'] }
- otherwise: [#sqInt])]!

Item was changed:
----- Method: CogSSBytecodeFixup class>>filteredInstVarNames (in category 'translation') -----
filteredInstVarNames
+ "Override to add ifdef LowcodeVM around the native stack info, and to put
+ char vars before short vars.
- "Override to add ifdef LowcodeVM around the native stack info.
self typedef"
+ | vars |
+ vars := super filteredInstVarNames asOrderedCollection.
+ vars
+ remove: 'instructionIndex';
+ add: 'instructionIndex' afterIndex: (vars indexOf: 'simStackPtr');
+ add: '#if LowcodeVM' beforeIndex: (vars indexOf: 'simNativeStackPtr');
+ add: '#endif' afterIndex: (vars indexOf: 'simNativeStackSize').
+ ^vars!
- ^super filteredInstVarNames
- copyReplaceAll: #('simNativeStackPtr' 'simNativeStackSize')
- with: #('#if LowcodeVM' 'simNativeStackPtr' 'simNativeStackSize' '#endif')!

Item was added:
+ ----- Method: CogX64Compiler>>genPushC64: (in category 'abstract instructions') -----
+ genPushC64: constant64Bits
+ <inline: true>
+ ^cogit PushCw: constant64Bits!

Item was changed:
----- Method: CogX64Compiler>>rewriteCPICJumpAt:target: (in category 'inline cacheing') -----
+ rewriteCPICJumpAt: addressFollowingJump target: jumpTargetAddr
- rewriteCPICJumpAt: addressFollowingJump target: jumpTargetAddress
"Rewrite the short jump instruction to jump to a new cpic case target. "
<var: #addressFollowingJump type: #usqInt>
+ <var: #jumpTargetAddr type: #usqInt>
- <var: #jumpTargetAddress type: #usqInt>
<var: #callDistance type: #sqInt> "prevent type inference for avoiding warning on abs"
| callDistance |
+ callDistance := jumpTargetAddr - addressFollowingJump.
- callDistance := jumpTargetAddress - addressFollowingJump.
self assert: callDistance abs < 128.
objectMemory
byteAt: addressFollowingJump - 1
put: (callDistance bitAnd: 16rFF).
"self cCode: ''
+ inSmalltalk: [cogit disassembleFrom: addressFollowingJump - 10 to: addressFollowingJump - 1]."!
- inSmalltalk: [cogit disassembleFrom: addressFollowingJump - 10 to: addressFollowingJump - 1]."
- ^2!

Item was changed:
----- Method: CogX64Compiler>>rewriteJumpLongAt:target: (in category 'inline cacheing') -----
+ rewriteJumpLongAt: addressFollowingJump target: jumpTargetAddr
- rewriteJumpLongAt: addressFollowingJump target: jumpTargetAddress
"Rewrite a long jump instruction to jump to a different target. This variant
is used to rewrite cached primitive calls. Answer the extent of the
code change which is used to compute the range of the icache to flush."
<inline: true>
+ ^self rewriteCallAt: addressFollowingJump target: jumpTargetAddr!
- ^self rewriteCallAt: addressFollowingJump target: jumpTargetAddress!

Item was changed:
----- Method: Cogit>>allocateOpcodes:bytecodes:ifFail: (in category 'initialization') -----
allocateOpcodes: numberOfAbstractOpcodes bytecodes: numberOfBytecodes ifFail: failBlock
"Allocate the various arrays needed to compile abstract instructions, failing if the size
needed is considered too high. Notionally we only need as many fixups as there are
bytecodes. But we reuse fixups to record pc-dependent instructions in
generateInstructionsAt: and so need at least as many as there are abstract opcodes.

This *must* be inlined since the arrays are alloca'ed (stack allocated)
so that they are freed when compilation is done.

N.B. We do one single alloca to save embarrassing C optimizers that
generate incorrect code as both gcc and the intel compiler do on x86."
<inline: true>
| opcodeBytes fixupBytes allocBytes |
numAbstractOpcodes := numberOfAbstractOpcodes.
opcodeBytes := (self sizeof: CogAbstractInstruction) * numAbstractOpcodes.
fixupBytes := (self sizeof: CogBytecodeFixup) * numAbstractOpcodes.
allocBytes := opcodeBytes + fixupBytes.
+ "Document the fact that the MaxStackAllocSize ensures that the number of abstract
+ opcodes fits in a 16 bit integer (e.g. CogBytecodeFixup's instructionIndex)."
+ self assert: (self sizeof: CogAbstractInstruction) + (self sizeof: CogBytecodeFixup) * 32768 > MaxStackAllocSize.
+ allocBytes > MaxStackAllocSize ifTrue:
+ [^failBlock value].
- allocBytes > MaxStackAllocSize ifTrue: [^failBlock value].
self
cCode:
[abstractOpcodes := self alloca: allocBytes.
self b: abstractOpcodes zero: allocBytes.
fixups := (abstractOpcodes asUnsignedInteger + opcodeBytes) asVoidPointer]
inSmalltalk:
[abstractOpcodes := CArrayAccessor on:
((1 to: numAbstractOpcodes) collect: [:ign| CogCompilerClass for: self]).
fixups := CArrayAccessor on:
((1 to: numAbstractOpcodes) collect: [:ign| self bytecodeFixupClass for: self])].
self zeroOpcodeIndexForNewOpcodes.
labelCounter := 0!

Item was changed:
----- Method: Cogit>>cPICPrototypeCaseOffset (in category 'in-line cacheing') -----
cPICPrototypeCaseOffset
"Whimsey; we want 16rCA5E10 + cPICPrototypeCaseOffset to be somewhere in the middle of the zone."
+ <inline: true>
+ ^methodZoneBase + methodZone youngReferrers / 2 - 16rCA5E10!
- ^methodZoneBase + methodZone youngReferrers / 2 - 16rCA5E10!

Item was changed:
----- Method: Cogit>>findMapLocationForMcpc:inMethod: (in category 'method map') -----
findMapLocationForMcpc: targetMcpc inMethod: cogMethod
+ <var: #targetMcpc type: #usqInt>
<var: #cogMethod type: #'CogMethod *'>
| mcpc map mapByte annotation |
mcpc := self firstMappedPCFor: cogMethod.
map := self mapStartFor: cogMethod.
mcpc = targetMcpc ifTrue: [^map].
[(mapByte := objectMemory byteAt: map) ~= MapEnd] whileTrue:
[annotation := mapByte >> AnnotationShift.
annotation ~= IsAnnotationExtension ifTrue:
[mcpc := mcpc + (backEnd codeGranularity
* (annotation = IsDisplacementX2N
ifTrue: [mapByte - DisplacementX2N << AnnotationShift]
ifFalse: [mapByte bitAnd: DisplacementMask]))].
mcpc >= targetMcpc ifTrue:
[self assert: mcpc = targetMcpc.
annotation = IsDisplacementX2N ifTrue:
[map := map - 1.
mapByte := objectMemory byteAt: map.
annotation := mapByte >> AnnotationShift.
self assert: annotation > IsAnnotationExtension].
^map].
map := map - 1].
^0!

Item was changed:
----- Method: Cogit>>generateMapAt:start: (in category 'method map') -----
generateMapAt: addressOrNull start: startAddress
"Generate the method map at addressrNull (or compute it if addressOrNull is null).
Answer the length of the map in byes. Each entry in the map is in two parts. In the
least signficant bits are a displacement of how far from the start or previous entry,
unless it is an IsAnnotationExtension byte, in which case those bits are the extension.
In the most signficant bits are the type of annotation at the point reached. A null
byte ends the map."
+ <var: 'addressOrNull' type: #usqInt>
+ <var: 'startAddress' type: #usqInt>
| length location |
<var: #instruction type: #'AbstractInstruction *'>
length := 0.
location := startAddress.
0 to: opcodeIndex - 1 do:
[:i| | instruction mcpc delta maxDelta mapEntry |
instruction := self abstractInstructionAt: i.
instruction annotation ifNotNil:
[:annotation|
literalsManager assertValidAnnotation: annotation for: instruction.
mcpc := instruction mapEntryAddress.
[(delta := mcpc - location / backEnd codeGranularity) > DisplacementMask] whileTrue:
[maxDelta := (delta min: MaxX2NDisplacement) bitClear: DisplacementMask.
self assert: maxDelta >> AnnotationShift <= DisplacementMask.
addressOrNull ifNotNil:
[self addToMap: IsDisplacementX2N
instruction: instruction
byte: maxDelta >> AnnotationShift + DisplacementX2N
at: addressOrNull - length
for: mcpc].
location := location + (maxDelta * backEnd codeGranularity).
length := length + 1].
addressOrNull ifNotNil:
[mapEntry := delta + ((annotation min: IsSendCall) << AnnotationShift).
self addToMap: annotation instruction: instruction byte: mapEntry at: addressOrNull - length for: mcpc].
location := location + (delta * backEnd codeGranularity).
length := length + 1.
annotation > IsSendCall ifTrue: "Add the necessary IsAnnotationExtension"
[addressOrNull ifNotNil:
[mapEntry := IsAnnotationExtension << AnnotationShift + (annotation - IsSendCall).
self addToMap: annotation instruction: instruction byte: mapEntry at: addressOrNull - length for: mcpc].
length := length + 1]]].
addressOrNull ifNotNil:
[self addToMap: MapEnd instruction: nil byte: MapEnd at: addressOrNull - length for: 0].
^length + 1!

Item was changed:
----- Method: Cogit>>lookupFrameOffset: (in category 'disassembly') -----
lookupFrameOffset: anInteger
+ <doNotGenerate>
(self class initializationOptions at: #tempNames ifAbsent: nil) ifNotNil:
[:dict|
(self class initializationOptions at: #startpc ifAbsent: nil) ifNotNil:
[:startpc|
(dict at: startpc + 1 ifAbsent: nil) ifNotNil:
[:tempNames| | numArgs |
anInteger = FoxMFReceiver ifTrue:
[^'self'].
numArgs := self class initializationOptions at: #numArgs.
1 to: tempNames size do:
[:i|
anInteger = (self frameOffsetOfTemporary: i - 1 numArgs: numArgs) ifTrue:
[^tempNames at: i]]]]].
^nil!

Item was changed:
----- Method: StackInterpreter>>externalDivorceFrame:andContext: (in category 'frame access') -----
externalDivorceFrame: theFP andContext: ctxt
"Divorce a single frame and its context. If it is not the top frame of a stack this means splitting its stack."
| thePage onCurrent theSP callerCtx newPage frameAbove callerFP callerSP callerIP theIP |
<inline: false>
<var: #theFP type: #'char *'>
<var: #thePage type: #'StackPage *'>
<var: #theSP type: #'char *'>
<var: #newPage type: #'StackPage *'>
<var: #frameAbove type: #'char *'>
<var: #callerFP type: #'char *'>
<var: #callerSP type: #'char *'>
"stackPage needs to have current head pointers to avoid confusion."
self assert: (stackPage = 0 or: [stackPage = stackPages mostRecentlyUsedPage]).
thePage := stackPages stackPageFor: theFP.
(onCurrent := thePage = stackPage) ifFalse:
[stackPages markStackPageNextMostRecentlyUsed: thePage].
theSP := self findSPOf: theFP on: thePage.
self updateStateOfSpouseContextForFrame: theFP WithSP: theSP.
callerCtx := self ensureCallerContext: theFP.
(frameAbove := self findFrameAbove: theFP inPage: thePage) == 0
ifTrue: "If we're divorcing the top frame we can simply peel it off."
[theIP := stackPages longAt: thePage headSP]
ifFalse: "othewise move all frames above to a new stack and then peel the frame off."
[newPage := stackPages newStackPage.
theIP := self oopForPointer: (self frameCallerSavedIP: frameAbove).
frameAbove := self moveFramesIn: thePage through: frameAbove toPage: newPage.
onCurrent
ifTrue:
[self setStackPageAndLimit: newPage.
+ self setStackPointersFromPage: newPage]
- framePointer := stackPage headFP.
- stackPointer := stackPage headSP]
ifFalse:
[stackPages markStackPageMostRecentlyUsed: newPage].
self assert: (self frameCallerContext: frameAbove) = ctxt].
objectMemory storePointerUnchecked: InstructionPointerIndex
ofObject: ctxt
withValue: (self contextInstructionPointer: theIP frame: theFP).
objectMemory storePointer: SenderIndex
ofObject: ctxt
withValue: callerCtx.
callerFP := self frameCallerFP: theFP.
callerFP == 0 "theFP is a base frame; it is now alone; free the entire page"
ifTrue: [stackPages freeStackPage: thePage]
ifFalse:
[callerIP := self oopForPointer: (self frameCallerSavedIP: theFP).
callerSP := (self frameCallerSP: theFP) - objectMemory wordSize.
stackPages longAt: callerSP put: callerIP.
self setHeadFP: callerFP andSP: callerSP inPage: thePage]
!

Item was changed:
----- Method: StackInterpreter>>externalEnsureIsBaseFrame: (in category 'frame access') -----
externalEnsureIsBaseFrame: aFramePtr
"Ensure aFramePtr is a base frame. Then we can assign its sender.
Answer the possibly moved location of the frame."
| theFP thePage onCurrent |
<var: #aFramePtr type: #'char *'>
<var: #theFP type: #'char *'>
<var: #thePage type: #'StackPage *'>
<returnTypeC: 'char *'>
(self isBaseFrame: aFramePtr) ifTrue:
[^aFramePtr].
theFP := aFramePtr.
thePage := stackPages stackPageFor: theFP.
onCurrent := thePage = stackPage.
"Storing the frame's sender with its caller's context
has the side effect of making theFP a base frame."
theFP := self
storeSenderOfFrame: theFP
withValue: (self ensureCallerContext: theFP).
onCurrent
ifTrue:
[self assert: stackPage ~~ thePage. "stackPage has moved to a new page"
+ self setStackPointersFromPage: stackPage]
- framePointer := stackPage headFP.
- stackPointer := stackPage headSP]
ifFalse:
[stackPages markStackPageMostRecentlyUsed: stackPage].
self assert: stackPages pageListIsWellFormed.
self assert: stackPage = stackPages mostRecentlyUsedPage.
^theFP!

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 externalWriteBackHeadFramePointers.
"Assign the field of a married context."
self deny: (objectMemory isObjImmutable: maybeMarriedContext).
(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:
+ [self setStackPointersFromPage: stackPage]
- [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, instructionPointer, 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 newPage |
<inline: true>
<var: #theFrame type: #'char *'>
<var: #thePage type: #'StackPage *'>
<var: #newPage type: #'StackPage *'>

newContext := objectMemory fetchPointer: SuspendedContextIndex ofObject: aProcess.
self assert: (objectMemory 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.
theFrame ~= thePage headFP ifTrue:
["explicit assignment of suspendedContext can cause switch to interior frame."
newPage := stackPages newStackPage.
self moveFramesIn: thePage
through: (self findFrameAbove: theFrame inPage: thePage)
toPage: newPage.
stackPages markStackPageLeastMostRecentlyUsed: newPage].
self assert: thePage headFP = theFrame]
ifFalse:
[thePage := self makeBaseFrameFor: newContext.
theFrame := thePage baseFP].
self setStackPageAndLimit: thePage.
+ self setStackPointersFromPage: thePage.
- stackPointer := thePage headSP.
- framePointer := thePage headFP.
(self isMachineCodeFrame: framePointer) ifFalse:
[self setMethod: (self iframeMethod: framePointer)].
instructionPointer := self popStack.
self assertValidExecutionPointe: instructionPointer r: framePointer s: stackPointer!

Item was changed:
----- Method: StackInterpreter>>handleStackOverflow (in category 'message sending') -----
handleStackOverflow
"Check for stack overflow, moving frames to another stack if so.
This should *only* be sent from checkForStackOverflow."
<inline: #never>
| newPage theFP callerFP overflowLimitAddress overflowCount |
<var: #newPage type: #'StackPage *'>
<var: #theFP type: #'char *'>
<var: #callerFP type: #'char *'>
<var: #overflowLimitAddress type: #'char *'>

self assert: stackPointer < stackPage realStackLimit.

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 := stackPages newStackPage.
self moveFramesIn: stackPage through: theFP toPage: newPage.
self setStackPageAndLimit: newPage.
+ self setStackPointersFromPage: 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 + 1
inMethod: method
framePointer: framePointer)]
ifTrue:
[self assert: (self validInstructionPointer: instructionPointer + 1
inFrame: framePointer).
self assert: ((self frameHasContext: framePointer) not
or: [objectMemory isContext: (self frameContext: framePointer)])]!

Item was changed:
+ ----- Method: StackInterpreter>>internalPopStackNativeSize: (in category 'internal interpreter access') -----
- ----- Method: StackInterpreter>>internalPopStackNativeSize: (in category 'as yet unclassified') -----
internalPopStackNativeSize: popSize
<option: #LowcodeVM>
"In the StackInterpreter stacks grow down."
nativeSP := self nativeStackPointerIn: localFP.
nativeSP := self nativeStackPointerIn: localFP put: nativeSP + popSize.!

Item was changed:
----- Method: StackInterpreter>>marryContextInNewStackPageAndInitializeInterpreterRegisters: (in category 'frame access') -----
marryContextInNewStackPageAndInitializeInterpreterRegisters: aContext
"Establish aContext at the base of a new stackPage, make the stackPage the
active one and set-up the interreter registers. This is used to boot the system
and bring it back after a snapshot."
<inline: false>
| newPage |
<var: #newPage type: #'StackPage *'>
self assert: stackPage = 0.
newPage := self makeBaseFrameFor: aContext.
self setStackPageAndLimit: newPage.
+ self setStackPointersFromPage: newPage.
- framePointer := stackPage headFP.
- stackPointer := stackPage headSP.
self setMethod: (self iframeMethod: stackPage headFP).
instructionPointer := self popStack!

Item was changed:
----- Method: StackInterpreter>>reestablishContextPriorToCallback: (in category 'callback support') -----
reestablishContextPriorToCallback: callbackContext
"callbackContext is an activation of invokeCallback:[stack:registers:jmpbuf:].
Its sender is the VM's state prior to the callback. Reestablish that state,
and mark calloutContext as dead."
| calloutContext theFP thePage |
<export: true>
<var: #theFP type: #'char *'>
<var: #thePage type: #'StackPage *'>
self flag: #obsolete.
(self isLiveContext: callbackContext) ifFalse:
[^false].
calloutContext := self externalInstVar: SenderIndex ofContext: callbackContext.
(self isLiveContext: calloutContext) ifFalse:
[^false].
"We're about to leave this stack page; must save the current frame's instructionPointer."
self push: instructionPointer.
self externalWriteBackHeadFramePointers.
"Mark callbackContext as dead; the common case is that it is the current frame.
We go the extra mile for the debugger."
(self isSingleContext: callbackContext)
ifTrue: [self markContextAsDead: callbackContext]
ifFalse:
[theFP := self frameOfMarriedContext: callbackContext.
framePointer = theFP "common case"
ifTrue:
[(self isBaseFrame: theFP)
ifTrue: [stackPages freeStackPage: stackPage]
ifFalse: "calloutContext is immediately below on the same page. Make it current."
[instructionPointer := (self frameCallerSavedIP: framePointer) asUnsignedInteger.
stackPointer := framePointer + (self frameStackedReceiverOffset: framePointer) + objectMemory wordSize.
framePointer := self frameCallerFP: framePointer.
^true]]
ifFalse:
[self externalDivorceFrame: theFP andContext: callbackContext.
self markContextAsDead: callbackContext]].
"Make the calloutContext the active frame. The case where calloutContext
is immediately below callbackContext on the same page is handled above."
(self isStillMarriedContext: calloutContext)
ifTrue:
[theFP := self frameOfMarriedContext: calloutContext.
thePage := stackPages stackPageFor: theFP.
"findSPOf:on: points to the word beneath the instructionPointer, but
there is no instructionPointer on the top frame of the current page."
self assert: thePage ~= stackPage.
stackPointer := (self findSPOf: theFP on: thePage) - objectMemory wordSize.
+ framePointer := theFP.
+ self assert: stackPointer < framePointer]
- framePointer := theFP]
ifFalse:
[thePage := self makeBaseFrameFor: calloutContext.
+ self setStackPointersFromPage: thePage].
- framePointer := thePage headFP.
- stackPointer := thePage headSP].
instructionPointer := self popStack.
self setStackPageAndLimit: thePage.
^true!

Item was added:
+ ----- Method: StackInterpreter>>setStackPointersFromPage: (in category 'stack pages') -----
+ setStackPointersFromPage: thePage
+ <var: #thePage type: #'StackPage *'>
+ <inline: true>
+ stackPointer := thePage headSP.
+ framePointer := thePage headFP!

Item was changed:
----- Method: StackInterpreterPrimitives>>primitiveStoreStackp (in category 'object access primitives') -----
primitiveStoreStackp
"Atomic store into context stackPointer.
Also ensures that any newly accessible cells are initialized to nil "
| ctxt newStackp theFP thePage onCurrentPage stackp |
<var: #theFP type: #'char *'>
<var: #thePage type: #'StackPage *'>
ctxt := self stackValue: 1.
newStackp := self stackIntegerValue: 0.
(self successful
and: [newStackp between: 0 and: (objectMemory numSlotsOf: ctxt) - CtxtTempFrameStart]) ifFalse:
[^self primitiveFail].
self externalWriteBackHeadFramePointers.
(self isStillMarriedContext: ctxt) ifTrue:
[theFP := self frameOfMarriedContext: ctxt.
thePage := stackPages stackPageFor: theFP.
((onCurrentPage := thePage = stackPage)
and: [theFP = framePointer]) ifTrue:
[^self primitiveFail]. "Probably easy to do this right here right now (just move stackPointer). But fail for now."
self externalDivorceFrame: theFP andContext: ctxt.
onCurrentPage
ifTrue:
+ [self setStackPointersFromPage: stackPage]
- [framePointer := stackPage headFP.
- stackPointer := stackPage headSP]
ifFalse:
[self assert: stackPage = (stackPages stackPageFor: framePointer).
stackPages markStackPageMostRecentlyUsed: stackPage]].
stackp := self fetchStackPointerOf: ctxt.
"Nil any newly accessible cells"
stackp + 1 to: newStackp do:
[:i | objectMemory storePointerUnchecked: i + CtxtTempFrameStart - 1 ofObject: ctxt withValue: objectMemory nilObject].
self storeStackPointerValue: newStackp inContext: ctxt.
self ensureContextIsExecutionSafeAfterAssignToStackPointer: ctxt.
self pop: 1!

Item was changed:
----- Method: StackToRegisterMappingCogit>>traceMerge: (in category 'simulation only') -----
traceMerge: fixup
<cmacro: '(ign) 0'>
| index original |
(compilationTrace anyMask: 16) ifTrue:
[index := (fixups object identityIndexOf: fixup) - 1.
+ (fixup isBackwardBranchFixup and: [compilationPass notNil and: [compilationPass > 1 and: [(original := fixup simStackPtr) < 0]]]) ifTrue:
- (fixup isBackwardBranchFixup and: [compilationPass > 1 and: [(original := fixup simStackPtr) < 0]]) ifTrue:
[fixup simStackPtr: simStackPtr].

[coInterpreter transcript
ensureCr;
print: index; nextPut: $/; print: index + initialPC;
nextPut: $:; space.
fixup printStateOn: coInterpreter transcript.
coInterpreter transcript cr; flush]
ensure: [original ifNotNil: [fixup simStackPtr: original]]]!