[Vm-dev] VM Maker: VMMaker.oscog-eem.837.mcz
commits at source.squeak.org
commits at source.squeak.org
Tue Jul 29 05:28:48 UTC 2014
Eliot Miranda uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker.oscog-eem.837.mcz
==================== Summary ====================
Name: VMMaker.oscog-eem.837
Author: eem
Time: 28 July 2014, 7:24:22.923 pm
UUID: e32a7e76-4a4d-48ae-adf6-28d22f64b157
Ancestors: VMMaker.oscog-eem.836
Sista:
Provide a SistaVM flag for <option: SistaVM> pragmas.
Implement the inlined ops in callPrimitiveMethod for the
current Sista spec in StackInterpreter.
Implement the SistaV1 bytecode table for
StackToRegisterMappingCogit
All:
Rationalize the length functions, deleting byteLengthOf:,
fetchLong32LengthOf: & fetchWordLengthOf: and providing
numBytesOf:, num16BitUnitsOf:, num32BitUnitsOf:,
num64BitUnitsOf: and numBytesOf:.
Provide fetch/storeShort16:ofObject:[withValue:] and
fetch/storeLong64:ofObject:[withValue:].
Recategorize ObjectMemory methods categorized as
object access in SpurMemoryManager as object access.
Spur: provide unpinObject: for InterpreterProxy.
=============== Diff against VMMaker.oscog-eem.836 ===============
Item was changed:
----- Method: CoInterpreter>>assertValidExecutionPointe:r:s:imbar:line: (in category 'debug support') -----
assertValidExecutionPointe: lip r: lifp s: lisp imbar: inInterpreter line: ln
<var: #lip type: #usqInt>
<var: #lifp type: #'char *'>
<var: #lisp type: #'char *'>
| methodField cogMethod theIP |
<var: #cogMethod type: #'CogMethod *'>
self assert: stackPage = (stackPages stackPageFor: lifp) l: ln.
self assert: stackPage = stackPages mostRecentlyUsedPage l: ln.
self assert: (self deferStackLimitSmashAround: #assertValidStackLimits: asSymbol with: ln).
self assert: lifp < stackPage baseAddress l: ln.
self assert: lisp < lifp l: ln.
self assert: lifp > lisp l: ln.
self assert: lisp >= (stackPage realStackLimit - self stackLimitOffset) l: ln.
self assert: (lifp - lisp) < LargeContextSize l: ln.
methodField := self frameMethodField: lifp.
inInterpreter
ifTrue:
[self assert: (self isMachineCodeFrame: lifp) not l: ln.
self assert: method = methodField l: ln.
self cppIf: MULTIPLEBYTECODESETS
ifTrue: [self assert: (self methodUsesAlternateBytecodeSet: method) = (bytecodeSetSelector = 256) l: ln].
(self asserta: (objectMemory cheapAddressCouldBeInHeap: methodField) l: ln) ifTrue:
[theIP := lip = cogit ceReturnToInterpreterPC
ifTrue: [self iframeSavedIP: lifp]
ifFalse: [lip].
self assert: (theIP >= (methodField + (objectMemory lastPointerOf: methodField))
+ and: [theIP < (methodField + (objectMemory numBytesOf: methodField) + objectMemory baseHeaderSize - 1)])
- and: [theIP < (methodField + (objectMemory byteLengthOf: methodField) + objectMemory baseHeaderSize - 1)])
l: ln].
self assert: ((self iframeIsBlockActivation: lifp)
or: [(self pushedReceiverOrClosureOfFrame: lifp) = (self iframeReceiver: lifp)])
l: ln]
ifFalse:
[self assert: (self isMachineCodeFrame: lifp) l: ln.
((self asserta: methodField asUnsignedInteger >= cogit minCogMethodAddress l: ln)
and: [self asserta: methodField asUnsignedInteger < cogit maxCogMethodAddress l: ln]) ifTrue:
[cogMethod := self mframeHomeMethod: lifp.
self assert: (lip > (methodField + ((self mframeIsBlockActivation: lifp)
ifTrue: [self sizeof: CogBlockMethod]
ifFalse: [self sizeof: CogMethod]))
and: [lip < (methodField + cogMethod blockSize)])
l: ln].
self assert: ((self mframeIsBlockActivation: lifp)
or: [(self pushedReceiverOrClosureOfFrame: lifp) = (self mframeReceiver: lifp)])
l: ln].
(self isBaseFrame: lifp) ifTrue:
[self assert: (self frameHasContext: lifp) l: ln.
self assert: (self frameContext: lifp) = (stackPages longAt: stackPage baseAddress - BytesPerWord) l: ln]!
Item was changed:
----- Method: CoInterpreter>>assertValidStackedInstructionPointersIn:line: (in category 'debug support') -----
assertValidStackedInstructionPointersIn: aStackPage line: ln
"Check that the stacked instruction pointers in the given page are correct.
Checks the interpreter sender/machine code callee contract."
<var: #aStackPage type: #'StackPage *'>
<var: #theFP type: #'char *'>
<var: #callerFP type: #'char *'>
<var: #theIP type: #usqInt>
<var: #theMethod type: #'CogMethod *'>
<inline: false>
| prevFrameWasCogged theFP callerFP theMethod theIP methodObj |
(self asserta: (stackPages isFree: aStackPage) not l: ln) ifFalse:
[^false].
prevFrameWasCogged := false.
"The top of stack of an inactive page is always the instructionPointer.
The top of stack of the active page may be the instructionPointer if it has been pushed,
which is indicated by a 0 instructionPointer."
(stackPage = aStackPage and: [instructionPointer ~= 0])
ifTrue:
[theIP := instructionPointer.
theFP := framePointer]
ifFalse:
[theIP := (stackPages longAt: aStackPage headSP) asUnsignedInteger.
theFP := aStackPage headFP.
stackPage = aStackPage ifTrue:
[self assert: framePointer = theFP l: ln]].
[(self isMachineCodeFrame: theFP)
ifTrue:
[theMethod := self mframeHomeMethod: theFP.
self assert: (theIP = cogit ceCannotResumePC
or: [theIP >= theMethod asUnsignedInteger
and: [theIP < (theMethod asUnsignedInteger + theMethod blockSize)]])
l: ln.
prevFrameWasCogged := true]
ifFalse: "assert-check the interpreter frame."
[methodObj := self iframeMethod: theFP.
prevFrameWasCogged ifTrue:
[self assert: theIP = cogit ceReturnToInterpreterPC l: ln].
theIP = cogit ceReturnToInterpreterPC ifTrue:
[theIP := self iframeSavedIP: theFP].
self assert: (theIP >= (methodObj + (objectMemory lastPointerOf: methodObj))
+ and: [theIP < (methodObj + (objectMemory numBytesOf: methodObj) + objectMemory baseHeaderSize - 1)])
- and: [theIP < (methodObj + (objectMemory byteLengthOf: methodObj) + objectMemory baseHeaderSize - 1)])
l: ln.
prevFrameWasCogged := false].
theIP := (stackPages longAt: theFP + FoxCallerSavedIP) asUnsignedInteger.
(callerFP := self frameCallerFP: theFP) ~= 0] whileTrue:
[theFP := callerFP].
self assert: theIP = cogit ceBaseFrameReturnPC l: ln.
^true!
Item was changed:
----- Method: CoInterpreter>>printMethodCacheFor: (in category 'debug printing') -----
printMethodCacheFor: thing
<api>
0 to: MethodCacheSize - 1 by: MethodCacheEntrySize do:
[:i | | s c m p |
s := methodCache at: i + MethodCacheSelector.
c := methodCache at: i + MethodCacheClass.
m := methodCache at: i + MethodCacheMethod.
p := methodCache at: i + MethodCachePrimFunction.
((thing = -1 or: [s = thing or: [c = thing or: [p = thing or: [m = thing
or: [(objectMemory addressCouldBeObj: m)
and: [(self maybeMethodHasCogMethod: m)
and: [(self cogMethodOf: m) asInteger = thing]]]]]]])
and: [(objectMemory addressCouldBeOop: s)
and: [c ~= 0
and: [(self addressCouldBeClassObj: c)
or: [self addressCouldBeClassObj: (objectMemory classForClassTag: c)]]]]) ifTrue:
[self cCode: [] inSmalltalk: [self transcript ensureCr].
self printNum: i; cr; tab.
(objectMemory isBytesNonImm: s)
+ ifTrue: [self cCode: 'printf("%x %.*s\n", s, numBytesOf(s), (char *)firstIndexableField(s))'
- ifTrue: [self cCode: 'printf("%x %.*s\n", s, byteLengthOf(s), (char *)firstIndexableField(s))'
inSmalltalk: [self printHex: s; space; print: (self stringOf: s); cr]]
ifFalse: [self shortPrintOop: s].
self tab.
(self addressCouldBeClassObj: c)
ifTrue: [self shortPrintOop: c]
ifFalse: [self printNum: c; space; shortPrintOop: (objectMemory classForClassTag: c)].
self tab; shortPrintOop: m; tab.
self cCode:
[p > 1024
ifTrue: [self printHexnp: p]
ifFalse: [self printNum: p]]
inSmalltalk:
[p isSymbol ifTrue: [self print: p] ifFalse: [self printNum: p]].
self cr]]!
Item was changed:
----- Method: CoInterpreterMT>>wakeHighestPriority (in category 'process primitive support') -----
wakeHighestPriority
"Return the highest priority process that is ready to run.
To save time looking at many empty lists before finding a
runnable process the VM maintains a variable holding the
highest priority runnable process. If this variable is 0 then the
VM does not know the highest priority and must search all lists.
Override to answer nil when there is no runnable process instead of
aborting. In the threaded VM the abort test is done in transferTo:from:
becaue there may be some thread waiting to own the VM. The transfer
to the thread shouldn't be done here because not all clients call this in
the right context (allowing a longjmp back to the threadSchedulingLoop)."
| schedLists p processList proc ctxt |
schedLists := objectMemory fetchPointer: ProcessListsIndex ofObject: self schedulerPointer.
p := highestRunnableProcessPriority = 0
+ ifTrue: [objectMemory numSlotsOf: schedLists]
- ifTrue: [objectMemory fetchWordLengthOf: schedLists]
ifFalse: [highestRunnableProcessPriority].
[(p := p - 1) >= 0] whileTrue:
[processList := objectMemory fetchPointer: p ofObject: schedLists.
[self isEmptyList: processList] whileFalse:
["Only answer processes with a runnable suspendedContext.
Discard those that aren't; the VM would crash otherwise."
proc := self removeFirstLinkOfList: processList.
ctxt := objectMemory fetchPointer: SuspendedContextIndex ofObject: proc.
(self isLiveContext: ctxt) ifTrue:
[highestRunnableProcessPriority := p + 1.
^proc].
self warning: 'evicted zombie process from run queue']].
^nil!
Item was changed:
----- Method: CogVMSimulator>>classAndSelectorOfMethod:forReceiver: (in category 'debug support') -----
classAndSelectorOfMethod: meth forReceiver: rcvr
| mClass dict length methodArray |
mClass := objectMemory fetchClassOf: rcvr.
[dict := objectMemory fetchPointer: MethodDictionaryIndex ofObject: mClass.
+ length := objectMemory numSlotsOf: dict.
- length := objectMemory fetchWordLengthOf: dict.
methodArray := objectMemory fetchPointer: MethodArrayIndex ofObject: dict.
0 to: length-SelectorStart-1 do:
[:index |
meth = (objectMemory fetchPointer: index ofObject: methodArray)
ifTrue: [^ Array
with: mClass
with: (objectMemory fetchPointer: index + SelectorStart ofObject: dict)]].
mClass := objectMemory fetchPointer: SuperclassIndex ofObject: mClass.
mClass = objectMemory nilObject]
whileFalse: [].
^ Array
with: (objectMemory fetchClassOf: rcvr)
with: (objectMemory splObj: SelectorDoesNotUnderstand)!
Item was changed:
----- Method: Cogit>>bcpcsAndDescriptorsFor:do: (in category 'tests-method map') -----
bcpcsAndDescriptorsFor: aMethod do: trinaryBlock
<doNotGenerate>
| bsOffset nExts byte descriptor endpc latestContinuation pc primIdx |
((primIdx := coInterpreter primitiveIndexOf: aMethod) > 0
and: [coInterpreter isQuickPrimitiveIndex: primIdx]) ifTrue:
[^self].
latestContinuation := pc := coInterpreter startPCOfMethod: aMethod.
trinaryBlock value: pc value: nil value: nil. "stackCheck/entry pc"
bsOffset := self bytecodeSetOffsetFor: aMethod.
nExts := 0.
+ endpc := objectMemory numBytesOf: aMethod.
- endpc := objectMemory byteLengthOf: aMethod.
[pc <= endpc] whileTrue:
[byte := objectMemory fetchByte: pc ofObject: aMethod.
descriptor := self generatorAt: byte + bsOffset.
trinaryBlock value: pc value: byte value: descriptor.
(descriptor isReturn
and: [pc >= latestContinuation]) ifTrue:
[endpc := pc].
(descriptor isBranch
or: [descriptor isBlockCreation]) ifTrue:
[| targetPC |
descriptor isBlockCreation ifTrue:
[trinaryBlock value: pc + descriptor numBytes value: nil value: nil]. "stackCheck/entry pc"
targetPC := self latestContinuationPCFor: descriptor at: pc exts: nExts in: aMethod.
self assert: targetPC < endpc.
latestContinuation := latestContinuation max: targetPC].
pc := pc + descriptor numBytes.
nExts := descriptor isExtension ifTrue: [nExts + 1] ifFalse: [0]]!
Item was changed:
----- Method: Cogit>>blockStartPcsIn: (in category 'disassembly') -----
blockStartPcsIn: aMethod
"Answer the start bytecopde pcs in a method in compilation order, i.e. depth-first.
Blocks must occur in pc/depth-first order for binary tree block dispatch to work."
| startpcs pc latestContinuation end descriptor byte bsOffset nExts |
<doNotGenerate>
startpcs := OrderedCollection new.
startpcs add: (pc := latestContinuation := coInterpreter startPCOfMethod: aMethod).
+ end := objectMemory numBytesOf: aMethod.
- end := objectMemory byteLengthOf: aMethod.
bsOffset := self bytecodeSetOffsetFor: aMethod.
nExts := 0.
[pc <= end] whileTrue:
[byte := objectMemory fetchByte: pc ofObject: aMethod.
descriptor := self generatorAt: byte + bsOffset.
(descriptor isReturn
and: [pc >= latestContinuation]) ifTrue:
[end := pc].
(descriptor isBranch
or: [descriptor isBlockCreation]) ifTrue:
[| targetPC |
targetPC := self latestContinuationPCFor: descriptor at: pc exts: nExts in: aMethod.
latestContinuation := latestContinuation max: targetPC].
pc := pc + descriptor numBytes.
descriptor isBlockCreation ifTrue:
[startpcs add: pc].
nExts := descriptor isExtension ifTrue: [nExts + 1] ifFalse: [0]].
^startpcs!
Item was changed:
----- Method: Cogit>>compileCogMethod: (in category 'compile abstract instructions') -----
compileCogMethod: selector
<returnTypeC: #'CogMethod *'>
| numBytecodes numBlocks numCleanBlocks result extra |
hasYoungReferent := (objectMemory isYoungObject: 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 numBytesOf: methodObj].
- ifFalse: [objectMemory byteLengthOf: methodObj].
numBytecodes := endPC - initialPC + 1.
self allocateOpcodes: (numBytecodes + extra) * 10
bytecodes: numBytecodes
ifFail: [^coInterpreter cCoerceSimple: MethodTooBig to: #'CogMethod *'].
(numBlocks := self scanMethod) < 0 ifTrue:
[^coInterpreter cCoerceSimple: numBlocks to: #'CogMethod *'].
numCleanBlocks := self scanForCleanBlocks.
self allocateBlockStarts: numBlocks + numCleanBlocks.
blockCount := 0.
numCleanBlocks > 0 ifTrue:
[self addCleanBlockStarts].
(self maybeAllocAndInitCounters
and: [self maybeAllocAndInitIRCs]) ifFalse: "Inaccurate error code, but it'll do. This will likely never fail."
[^coInterpreter cCoerceSimple: InsufficientCodeSpace to: #'CogMethod *'].
blockEntryLabel := nil.
methodLabel dependent: nil.
(result := self compileEntireMethod) < 0 ifTrue:
[^coInterpreter cCoerceSimple: result to: #'CogMethod *'].
^self generateCogMethod: selector!
Item was changed:
----- Method: Cogit>>endPCOf: (in category 'compiled methods') -----
endPCOf: aMethod
<var: #descriptor type: #'BytecodeDescriptor *'>
| pc end latestContinuation descriptor prim distance targetPC byte bsOffset nExts |
pc := latestContinuation := coInterpreter startPCOfMethod: aMethod.
(prim := coInterpreter primitiveIndexOf: aMethod) > 0 ifTrue:
[(coInterpreter isQuickPrimitiveIndex: prim) ifTrue:
[^pc - 1]].
bsOffset := self bytecodeSetOffsetFor: aMethod.
nExts := 0.
+ end := objectMemory numBytesOf: aMethod.
- end := objectMemory byteLengthOf: aMethod.
[pc <= end] whileTrue:
[byte := objectMemory fetchByte: pc ofObject: aMethod.
descriptor := self generatorAt: byte + bsOffset.
(descriptor isReturn
and: [pc >= latestContinuation]) ifTrue:
[end := pc].
(descriptor isBranch or: [descriptor isBlockCreation]) ifTrue:
[distance := self spanFor: descriptor at: pc exts: nExts in: aMethod.
targetPC := pc + descriptor numBytes + distance.
latestContinuation := latestContinuation max: targetPC.
descriptor isBlockCreation ifTrue:
[pc := pc + distance]].
nExts := descriptor isExtension ifTrue: [nExts + 1] ifFalse: [0].
pc := pc + descriptor numBytes].
^end!
Item was changed:
----- Method: Cogit>>mapFor:bcpc:performUntil:arg: (in category 'method map') -----
mapFor: cogMethod bcpc: startbcpc performUntil: functionSymbol arg: arg
"Machine-code <-> bytecode pc mapping support. Evaluate functionSymbol
for each mcpc, bcpc pair in the map until the function returns non-zero,
answering that result, or 0 if it fails to. This works only for frameful methods."
<var: #cogMethod type: #'CogBlockMethod *'>
<var: #functionSymbol declareC: 'sqInt (*functionSymbol)(BytecodeDescriptor *desc, sqInt isBackwardBranch, char *mcpc, sqInt bcpc, void *arg)'>
<var: #arg type: #'void *'>
<inline: true>
| isInBlock mcpc bcpc endbcpc map mapByte homeMethod aMethodObj result
latestContinuation byte descriptor bsOffset nExts |
<var: #descriptor type: #'BytecodeDescriptor *'>
<var: #homeMethod type: #'CogMethod *'>
self assert: cogMethod stackCheckOffset > 0.
"In both CMMethod and CMBlock cases find the start of the map and
skip forward to the bytecode pc map entry for the stack check."
cogMethod cmType = CMMethod
ifTrue:
[isInBlock := false.
homeMethod := self cCoerceSimple: cogMethod to: #'CogMethod *'.
self assert: startbcpc = (coInterpreter startPCOfMethodHeader: homeMethod methodHeader).
map := self mapStartFor: homeMethod.
self assert: ((objectMemory byteAt: map) >> AnnotationShift = IsAbsPCReference
or: [(objectMemory byteAt: map) >> AnnotationShift = IsObjectReference
or: [(objectMemory byteAt: map) >> AnnotationShift = IsRelativeCall
or: [(objectMemory byteAt: map) >> AnnotationShift = IsDisplacementX2N]]]).
latestContinuation := startbcpc.
aMethodObj := homeMethod methodObject.
+ endbcpc := (objectMemory numBytesOf: aMethodObj) - 1.
- endbcpc := (objectMemory byteLengthOf: aMethodObj) - 1.
bsOffset := self bytecodeSetOffsetForHeader: homeMethod methodHeader]
ifFalse:
[isInBlock := true.
homeMethod := cogMethod cmHomeMethod.
map := self findMapLocationForMcpc: cogMethod asUnsignedInteger + (self sizeof: CogBlockMethod)
inMethod: homeMethod.
self assert: map ~= 0.
self assert: ((objectMemory byteAt: map) >> AnnotationShift = HasBytecodePC "fiducial"
or: [(objectMemory byteAt: map) >> AnnotationShift = IsDisplacementX2N]).
[(objectMemory byteAt: map) >> AnnotationShift ~= HasBytecodePC] whileTrue:
[map := map - 1].
map := map - 1. "skip fiducial; i.e. the map entry for the pc immediately following the method header."
aMethodObj := homeMethod methodObject.
bcpc := startbcpc - (self blockCreationBytecodeSizeForHeader: homeMethod methodHeader).
bsOffset := self bytecodeSetOffsetForHeader: homeMethod methodHeader.
byte := (objectMemory fetchByte: bcpc ofObject: aMethodObj) + bsOffset.
descriptor := self generatorAt: byte.
endbcpc := self nextBytecodePCFor: descriptor at: bcpc exts: -1 in: aMethodObj].
bcpc := startbcpc.
mcpc := cogMethod asUnsignedInteger + cogMethod stackCheckOffset.
nExts := 0.
"The stack check maps to the start of the first bytecode,
the first bytecode being effectively after frame build."
result := self perform: functionSymbol
with: nil
with: false
with: (self cCoerceSimple: mcpc to: #'char *')
with: startbcpc
with: arg.
result ~= 0 ifTrue:
[^result].
"Now skip up through the bytecode pc map entry for the stack check."
[(objectMemory byteAt: map) >> AnnotationShift ~= HasBytecodePC] whileTrue:
[map := map - 1].
map := map - 1.
[(mapByte := objectMemory byteAt: map) ~= MapEnd] whileTrue: "defensive; we exit on bcpc"
[mapByte >= FirstAnnotation
ifTrue:
[| annotation nextBcpc isBackwardBranch |
annotation := mapByte >> AnnotationShift.
mcpc := mcpc + (mapByte bitAnd: DisplacementMask).
(self isPCMappedAnnotation: annotation alternateInstructionSet: bsOffset > 0) ifTrue:
[[byte := (objectMemory fetchByte: bcpc ofObject: aMethodObj) + bsOffset.
descriptor := self generatorAt: byte.
isInBlock
ifTrue: [bcpc >= endbcpc ifTrue: [^0]]
ifFalse:
[(descriptor isReturn and: [bcpc >= latestContinuation]) ifTrue: [^0].
(descriptor isBranch or: [descriptor isBlockCreation]) ifTrue:
[| targetPC |
targetPC := self latestContinuationPCFor: descriptor at: bcpc exts: nExts in: aMethodObj.
latestContinuation := latestContinuation max: targetPC]].
nextBcpc := self nextBytecodePCFor: descriptor at: bcpc exts: nExts in: aMethodObj.
descriptor isMapped
or: [isInBlock and: [descriptor isMappedInBlock]]] whileFalse:
[bcpc := nextBcpc.
nExts := descriptor isExtension ifTrue: [nExts + 1] ifFalse: [0]].
isBackwardBranch := descriptor isBranch
and: [self isBackwardBranch: descriptor at: bcpc exts: nExts in: aMethodObj].
result := self perform: functionSymbol
with: descriptor
with: isBackwardBranch
with: (self cCoerceSimple: mcpc to: #'char *')
with: bcpc
with: arg.
result ~= 0 ifTrue:
[^result].
bcpc := nextBcpc.
nExts := descriptor isExtension ifTrue: [nExts + 1] ifFalse: [0]].
self maybeRememberPrevMap: annotation absPCMcpc: mcpc]
ifFalse:
[mcpc := mcpc + (mapByte >= DisplacementX2N
ifTrue: [mapByte - DisplacementX2N << AnnotationShift]
ifFalse: [mapByte])].
map := map - 1].
^0!
Item was changed:
----- Method: Cogit>>method:hasSameCodeAs: (in category 'garbage collection') -----
method: methodA hasSameCodeAs: methodB
"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 numBytesOf: methodB)]]]]) ifTrue:
- or: [endPCA > (objectMemory byteLengthOf: methodB)]]]]) ifTrue:
[^false].
1 to: numLitsA - 1 do:
[:li|
(objectMemory fetchPointer: li ofObject: methodA) ~= (objectMemory fetchPointer: li ofObject: methodB) ifTrue:
[^false]].
(coInterpreter startPCOfMethod: methodA) to: endPCA do:
[:bi|
(objectMemory fetchByte: bi ofObject: methodA) ~= (objectMemory fetchByte: bi ofObject: methodB) ifTrue:
[^false]].
^true!
Item was changed:
----- 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 numBytesOf: methodB)]]]]) ifTrue:
- 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 changed:
----- Method: Cogit>>spanForCleanBlockStartingAt: (in category 'compile abstract instructions') -----
spanForCleanBlockStartingAt: startPC
<var: #descriptor type: #'BytecodeDescriptor *'>
| pc end descriptor |
pc := startPC.
+ end := objectMemory numBytesOf: methodObj.
- end := objectMemory byteLengthOf: methodObj.
[pc <= end] whileTrue:
[descriptor := self generatorAt: (objectMemory fetchByte: pc ofObject: methodObj) + bytecodeSetOffset.
pc := pc + descriptor numBytes.
descriptor isReturn ifTrue:
[^pc - startPC]].
self error: 'couldn''t locate end of clean block'.
^0!
Item was removed:
- ----- Method: CurrentImageCoInterpreterFacade>>byteLengthOf: (in category 'accessing') -----
- byteLengthOf: anOop
- | obj |
- obj := self objectForOop: anOop.
- obj class isBytes ifTrue:
- [^obj basicSize].
- self error: 'cannot determine byte size of argument'!
Item was changed:
----- Method: CurrentImageCoInterpreterFacade>>byteSizeOf: (in category 'accessing') -----
byteSizeOf: anOop
+ | obj elementSize |
+ obj := self objectForOop: anOop.
+ ([obj class isImmediateClass]
+ on: MessageNotUnderstood
+ do: [:ex| obj class == SmallInteger]) ifTrue:
+ [^0].
+ elementSize :=
+ [obj class elementSize]
+ on: MessageNotUnderstood
+ do: [:ex| obj class isBytes ifTrue: [1] ifFalse: [Smalltalk wordSize]].
+ ^obj basicSize * elementSize!
- ^(self objectForOop: anOop) basicSize!
Item was added:
+ ----- Method: CurrentImageCoInterpreterFacade>>numBytesOf: (in category 'accessing') -----
+ numBytesOf: objOop
+ "Answer the number of indexable bytes in the given non-immediate object.
+ Does not adjust the size of contexts by stackPointer."
+ | obj elementSize |
+ obj := self objectForOop: objOop.
+ self deny: ([obj class isImmediateClass]
+ on: MessageNotUnderstood
+ do: [:ex| obj class == SmallInteger]).
+ elementSize :=
+ [obj class elementSize]
+ on: MessageNotUnderstood
+ do: [:ex| obj class isBytes ifTrue: [1] ifFalse: [Smalltalk wordSize]].
+ ^obj basicSize * elementSize!
Item was changed:
----- Method: Interpreter>>activateNewClosureMethod: (in category 'control primitives') -----
activateNewClosureMethod: blockClosure
"Similar to activateNewMethod but for Closure and newMethod."
| theBlockClosure closureMethod newContext methodHeader numCopied where outerContext |
DoAssertionChecks ifTrue:
[self okayOop: blockClosure].
outerContext := self fetchPointer: ClosureOuterContextIndex ofObject: blockClosure.
DoAssertionChecks ifTrue:
[self okayOop: outerContext].
closureMethod := self fetchPointer: MethodIndex ofObject: outerContext.
methodHeader := self headerOf: closureMethod.
self pushRemappableOop: blockClosure.
newContext := self allocateOrRecycleContext: (methodHeader bitAnd: LargeContextBit). "All for one, and one for all!!"
"allocateOrRecycleContext: may cause a GC; restore blockClosure and refetch outerContext et al"
theBlockClosure := self popRemappableOop.
outerContext := self fetchPointer: ClosureOuterContextIndex ofObject: theBlockClosure.
+ numCopied := (self numSlotsOf: theBlockClosure) - ClosureFirstCopiedValueIndex.
- numCopied := (self fetchWordLengthOf: theBlockClosure) - ClosureFirstCopiedValueIndex.
"Assume: newContext will be recorded as a root if necessary by the
call to newActiveContext: below, so we can use unchecked stores."
where := newContext + BaseHeaderSize.
self longAt: where + (SenderIndex << ShiftForWord)
put: activeContext.
self longAt: where + (InstructionPointerIndex << ShiftForWord)
put: (self fetchPointer: ClosureStartPCIndex ofObject: theBlockClosure).
self longAt: where + (StackPointerIndex << ShiftForWord)
put: (self integerObjectOf: argumentCount + numCopied).
self longAt: where + (MethodIndex << ShiftForWord)
put: (self fetchPointer: MethodIndex ofObject: outerContext).
self longAt: where + (ClosureIndex << ShiftForWord)
put: theBlockClosure.
self longAt: where + (ReceiverIndex << ShiftForWord)
put: (self fetchPointer: ReceiverIndex ofObject: outerContext).
"Copy the arguments..."
1 to: argumentCount do:
[:i | self longAt: where + ((ReceiverIndex+i) << ShiftForWord)
put: (self stackValue: argumentCount-i)].
"Copy the copied values..."
where := newContext + BaseHeaderSize + ((ReceiverIndex + 1 + argumentCount) << ShiftForWord).
0 to: numCopied - 1 do:
[:i| self longAt: where + (i << ShiftForWord)
put: (self fetchPointer: i + ClosureFirstCopiedValueIndex
ofObject: theBlockClosure)].
"The initial instructions in the block nil-out remaining temps."
self pop: argumentCount + 1.
self newActiveContext: newContext!
Item was changed:
----- Method: Interpreter>>findClassOfMethod:forReceiver: (in category 'debug support') -----
findClassOfMethod: meth forReceiver: rcvr
| currClass classDict classDictSize methodArray i done |
currClass := self fetchClassOf: rcvr.
done := false.
[done] whileFalse: [
classDict := self fetchPointer: MethodDictionaryIndex ofObject: currClass.
+ classDictSize := self numSlotsOf: classDict.
- classDictSize := self fetchWordLengthOf: classDict.
methodArray := self fetchPointer: MethodArrayIndex ofObject: classDict.
i := 0.
[i < (classDictSize - SelectorStart)] whileTrue: [
meth = (self fetchPointer: i ofObject: methodArray) ifTrue: [ ^currClass ].
i := i + 1.
].
currClass := self fetchPointer: SuperclassIndex ofObject: currClass.
done := currClass = nilObj.
].
^self fetchClassOf: rcvr "method not found in superclass chain"!
Item was changed:
----- Method: Interpreter>>findSelectorOfMethod:forReceiver: (in category 'debug support') -----
findSelectorOfMethod: meth forReceiver: rcvr
| currClass done classDict classDictSize methodArray i |
currClass := self fetchClassOf: rcvr.
done := false.
[done] whileFalse: [
classDict := self fetchPointer: MethodDictionaryIndex ofObject: currClass.
+ classDictSize := self numSlotsOf: classDict.
- classDictSize := self fetchWordLengthOf: classDict.
methodArray := self fetchPointer: MethodArrayIndex ofObject: classDict.
i := 0.
[i <= (classDictSize - SelectorStart)] whileTrue: [
meth = (self fetchPointer: i ofObject: methodArray) ifTrue: [
^(self fetchPointer: i + SelectorStart ofObject: classDict)
].
i := i + 1.
].
currClass := self fetchPointer: SuperclassIndex ofObject: currClass.
done := currClass = nilObj.
].
^ nilObj "method not found in superclass chain"!
Item was changed:
----- Method: Interpreter>>lookupMethodInDictionary: (in category 'message sending') -----
lookupMethodInDictionary: dictionary
"This method lookup tolerates integers as Dictionary keys to
support execution of images in which Symbols have been
compacted out"
| length index mask wrapAround nextSelector methodArray |
<inline: true>
+ length := self numSlotsOf: dictionary.
- length := self fetchWordLengthOf: dictionary.
mask := length - SelectorStart - 1.
(self isIntegerObject: messageSelector)
ifTrue: [index := (mask bitAnd: (self integerValueOf: messageSelector)) + SelectorStart]
ifFalse: [index := (mask bitAnd: (self hashBitsOf: messageSelector)) + SelectorStart].
"It is assumed that there are some nils in this dictionary, and search will
stop when one is encountered. However, if there are no nils, then wrapAround
will be detected the second time the loop gets to the end of the table."
wrapAround := false.
[true]
whileTrue: [nextSelector := self fetchPointer: index ofObject: dictionary.
nextSelector = nilObj ifTrue: [^ false].
nextSelector = messageSelector
ifTrue: [methodArray := self fetchPointer: MethodArrayIndex ofObject: dictionary.
newMethod := self fetchPointer: index - SelectorStart ofObject: methodArray.
"Check if newMethod is a CompiledMethod."
(self isCompiledMethod: newMethod)
ifTrue: [primitiveIndex := self primitiveIndexOf: newMethod.
primitiveIndex > MaxPrimitiveIndex
ifTrue: ["If primitiveIndex is out of range, set to zero before putting in
cache. This is equiv to primFail, and avoids the need to check on
every send."
primitiveIndex := 0]]
ifFalse: ["indicate that this is no compiled method - use primitiveInvokeObjectAsMethod"
primitiveIndex := 248].
^ true].
index := index + 1.
index = length
ifTrue: [wrapAround
ifTrue: [^ false].
wrapAround := true.
index := SelectorStart]]!
Item was changed:
----- Method: Interpreter>>primitiveClosureCopyWithCopiedValues (in category 'control primitives') -----
primitiveClosureCopyWithCopiedValues
| newClosure copiedValues numCopiedValues numArgs |
numArgs := self stackIntegerValue: 1.
copiedValues := self stackTop.
self success: (self fetchClassOf: copiedValues) = (self splObj: ClassArray).
successFlag ifFalse:
[^self primitiveFail].
+ numCopiedValues := self numSlotsOf: copiedValues.
- numCopiedValues := self fetchWordLengthOf: copiedValues.
newClosure := self
closureNumArgs: numArgs
"greater by 1 due to preIncrement of localIP"
instructionPointer: instructionPointer + 2 - (method+BaseHeaderSize)
numCopiedValues: numCopiedValues.
"Assume: have just allocated a new closure; it must be young. Thus, can use unchecked stores."
self storePointerUnchecked: ClosureOuterContextIndex ofObject: newClosure withValue: (self stackValue: 2).
numCopiedValues > 0 ifTrue:
["Allocation may have done a GC and copiedValues may have moved."
copiedValues := self stackTop.
0 to: numCopiedValues - 1 do:
[:i|
"Assume: have just allocated a new BlockClosure; it must be young.
Thus, can use unchecked stores."
self storePointerUnchecked: i + ClosureFirstCopiedValueIndex
ofObject: newClosure
withValue: (self fetchPointer: i ofObject: copiedValues)]].
self pop: 3 thenPush: newClosure!
Item was changed:
----- Method: Interpreter>>primitiveClosureValueWithArgs (in category 'control primitives') -----
primitiveClosureValueWithArgs
| argumentArray arraySize cntxSize blockClosure blockArgumentCount closureMethod index outerContext |
argumentArray := self stackTop.
(self isArray: argumentArray) ifFalse:
[^self primitiveFail].
"Check for enough space in thisContext to push all args"
+ arraySize := self numSlotsOf: argumentArray.
+ cntxSize := self numSlotsOf: activeContext.
- arraySize := self fetchWordLengthOf: argumentArray.
- cntxSize := self fetchWordLengthOf: activeContext.
(self stackPointerIndex + arraySize) < cntxSize ifFalse:
[^self primitiveFail].
blockClosure := self stackValue: argumentCount.
blockArgumentCount := self argumentCountOfClosure: blockClosure.
arraySize = blockArgumentCount ifFalse:
[^self primitiveFail].
"Somewhat paranoiac checks we need while debugging that we may be able to discard
in a robust system."
outerContext := self fetchPointer: ClosureOuterContextIndex ofObject: blockClosure.
(self isContext: outerContext) ifFalse:
[^self primitiveFail].
closureMethod := self fetchPointer: MethodIndex ofObject: outerContext.
"Check if the closure's method is actually a CompiledMethod."
(self isOopCompiledMethod: closureMethod) ifFalse:
[^self primitiveFail].
self popStack.
"Copy the arguments to the stack, and activate"
index := 1.
[index <= arraySize]
whileTrue:
[self push: (self fetchPointer: index - 1 ofObject: argumentArray).
index := index + 1].
argumentCount := arraySize.
self activateNewClosureMethod: blockClosure.
self quickCheckForInterrupts!
Item was changed:
----- Method: Interpreter>>primitiveDoPrimitiveWithArgs (in category 'control primitives') -----
primitiveDoPrimitiveWithArgs
| argumentArray arraySize index cntxSize primIdx |
argumentArray := self stackTop.
+ arraySize := self numSlotsOf: argumentArray.
+ cntxSize := self numSlotsOf: activeContext.
- arraySize := self fetchWordLengthOf: argumentArray.
- cntxSize := self fetchWordLengthOf: activeContext.
self success: self stackPointerIndex + arraySize < cntxSize.
(self isArray: argumentArray) ifFalse: [^ self primitiveFail].
primIdx := self stackIntegerValue: 1.
successFlag ifFalse: [^ self primitiveFail]. "invalid args"
"Pop primIndex and argArray, then push args in place..."
self pop: 2.
primitiveIndex := primIdx.
argumentCount := arraySize.
index := 1.
[index <= argumentCount]
whileTrue: [self push: (self fetchPointer: index - 1 ofObject: argumentArray).
index := index + 1].
"Run the primitive (sets successFlag)"
self pushRemappableOop: argumentArray. "prim might alloc/gc"
lkupClass := nilObj.
self primitiveResponse.
argumentArray := self popRemappableOop.
successFlag
ifFalse: ["If primitive failed, then restore state for failure code"
self pop: arraySize.
self pushInteger: primIdx.
self push: argumentArray.
argumentCount := 2]!
Item was changed:
----- Method: Interpreter>>primitiveExecuteMethodArgsArray (in category 'control primitives') -----
primitiveExecuteMethodArgsArray
"receiver, argsArray, then method are on top of stack. Execute method against
receiver and args. Allow for up to two extra arguments (e.g. for mirror primitives).
Set primitiveFunctionPointer because no cache lookup has been done for the
method, and hence primitiveFunctionPointer is stale."
| methodArgument argCnt argumentArray |
methodArgument := self stackTop.
argumentArray := self stackValue: 1.
((self isOopCompiledMethod: methodArgument)
and: [self isArray: argumentArray]) ifFalse:
[^self primitiveFail].
argCnt := self argumentCountOf: methodArgument.
+ argCnt = (self numSlotsOf: argumentArray) ifFalse:
- argCnt = (self fetchWordLengthOf: argumentArray) ifFalse:
[^self primitiveFail].
argumentCount > 2 ifTrue: "CompiledMethod class>>receiver:withArguments:executeMethod:
SqueakObjectPrimitives class >> receiver:withArguments:apply:
VMMirror>>ifFail:object:with:executeMethod: et al"
[argumentCount > 4 ifTrue:
[^self primitiveFail].
self stackValue: argumentCount put: (self stackValue: 2)]. "replace actual receiver with desired receiver"
"and push the actual arguments"
self pop: argumentCount.
0 to: argCnt - 1 do:
[:i|
self push: (self fetchPointer: i ofObject: argumentArray)].
newMethod := methodArgument.
primitiveIndex := self primitiveIndexOf: newMethod.
primitiveFunctionPointer := self functionPointerFor: primitiveIndex inClass: nil.
argumentCount := argCnt.
"We set the messageSelector for executeMethod below since things
like the at cache read messageSelector and so it cannot be left stale."
messageSelector := self nilObject.
self executeNewMethod.
"Recursive xeq affects successFlag"
successFlag := true!
Item was changed:
----- Method: Interpreter>>primitiveFormPrint (in category 'I/O primitives') -----
primitiveFormPrint
"On platforms that support it, this primitive prints the receiver, assumed to be a Form, to the default printer."
| landscapeFlag vScale hScale rcvr bitsArray w h
depth pixelsPerWord wordsPerLine bitsArraySize ok |
<var: #vScale type: 'double '>
<var: #hScale type: 'double '>
landscapeFlag := self booleanValueOf: self stackTop.
vScale := self floatValueOf: (self stackValue: 1).
hScale := self floatValueOf: (self stackValue: 2).
rcvr := self stackValue: 3.
(rcvr isIntegerObject: rcvr) ifTrue: [self success: false].
successFlag ifTrue: [
((self isPointers: rcvr) and: [(self lengthOf: rcvr) >= 4])
ifFalse: [self success: false]].
successFlag ifTrue: [
bitsArray := self fetchPointer: 0 ofObject: rcvr.
w := self fetchInteger: 1 ofObject: rcvr.
h := self fetchInteger: 2 ofObject: rcvr.
depth := self fetchInteger: 3 ofObject: rcvr.
(w > 0 and: [h > 0]) ifFalse: [self success: false].
pixelsPerWord := 32 // depth.
wordsPerLine := (w + (pixelsPerWord - 1)) // pixelsPerWord.
((rcvr isIntegerObject: rcvr) not and: [self isWordsOrBytes: bitsArray])
ifTrue: [
+ bitsArraySize := self numBytesOf: bitsArray.
- bitsArraySize := self byteLengthOf: bitsArray.
self success: (bitsArraySize = (wordsPerLine * h * 4))]
ifFalse: [self success: false]].
successFlag ifTrue: [
ok := self cCode: 'ioFormPrint(bitsArray + BaseHeaderSize, w, h, depth, hScale, vScale, landscapeFlag)'.
self success: ok].
successFlag ifTrue: [
self pop: 3]. "pop hScale, vScale, and landscapeFlag; leave rcvr on stack"
!
Item was changed:
----- Method: Interpreter>>primitivePerformAt: (in category 'control primitives') -----
primitivePerformAt: lookupClass
"Common routine used by perform:withArgs: and perform:withArgs:inSuperclass:"
"NOTE: The case of doesNotUnderstand: is not a failure to perform.
The only failures are arg types and consistency of argumentCount."
| performSelector argumentArray arraySize index cntxSize performMethod performArgCount |
argumentArray := self stackTop.
(self isArray: argumentArray) ifFalse:[^self primitiveFail].
successFlag ifTrue:
["Check for enough space in thisContext to push all args"
+ arraySize := self numSlotsOf: argumentArray.
+ cntxSize := self numSlotsOf: activeContext.
- arraySize := self fetchWordLengthOf: argumentArray.
- cntxSize := self fetchWordLengthOf: activeContext.
self success: (self stackPointerIndex + arraySize) < cntxSize].
successFlag ifFalse: [^nil].
performSelector := messageSelector.
performMethod := newMethod.
performArgCount := argumentCount.
"pop the arg array and the selector, then push the args out of the array, as if they were on the stack"
self popStack.
messageSelector := self popStack.
"Copy the arguments to the stack, and execute"
index := 1.
[index <= arraySize]
whileTrue:
[self push: (self fetchPointer: index - 1 ofObject: argumentArray).
index := index + 1].
argumentCount := arraySize.
self findNewMethodInClass: lookupClass.
"Only test CompiledMethods for argument count - any other objects playacting as CMs will have to take their chances"
(self isOopCompiledMethod: newMethod)
ifTrue: [self success: (self argumentCountOf: newMethod) = argumentCount].
successFlag
ifTrue: [self executeNewMethod. "Recursive xeq affects successFlag"
successFlag := true]
ifFalse: ["Restore the state by popping all those array entries and pushing back the selector and array, and fail"
self pop: argumentCount.
self push: messageSelector.
self push: argumentArray.
messageSelector := performSelector.
newMethod := performMethod.
argumentCount := performArgCount]
!
Item was changed:
----- Method: Interpreter>>primitiveStopVMProfiling (in category 'process primitives') -----
primitiveStopVMProfiling
"Primitive. Stop the VM profiler and either copy the histogram data into the
supplied arguments, if they're non-nil. Fail if the arguments are not of the right type or size."
| vmHistArrayOrNil vmHist vmBins easHistArrayOrNil easHist easBins |
<var: #vmHist type: #'long *'>
<var: #vmBins type: #long>
<var: #easHist type: #'long *'>
<var: #easBins type: #long>
self success: argumentCount = 2.
vmHistArrayOrNil := self stackObjectValue: 1.
easHistArrayOrNil := self stackObjectValue: 0.
successFlag ifFalse:
[^nil].
"Both args must be either nil or arrays. If they're arrays and the wrong size we incorrectly stop profiling."
((vmHistArrayOrNil = nilObj or: [(self fetchClassOfNonImm: vmHistArrayOrNil) = (self splObj: ClassArray)])
and: [(self fetchClassOfNonImm: vmHistArrayOrNil) = (self fetchClassOfNonImm: easHistArrayOrNil)]) ifFalse:
[^self primitiveFail].
self cCode: 'ioControlProfile(0,&vmHist,&vmBins,&easHist,&easBins)'
inSmalltalk: [vmHist := vmBins := easHist := easBins := 0].
vmHistArrayOrNil ~= nilObj ifTrue:
+ [((self numSlotsOf: vmHistArrayOrNil) = vmBins
+ and: [(self numSlotsOf: easHistArrayOrNil) = easBins]) ifFalse:
- [((self fetchWordLengthOf: vmHistArrayOrNil) = vmBins
- and: [(self fetchWordLengthOf: easHistArrayOrNil) = easBins]) ifFalse:
[^self primitiveFail].
0 to: vmBins - 1 do:
[:i|
self storePointerUnchecked: i
ofObject: vmHistArrayOrNil
withValue: (self integerObjectOf: (vmHist at: i))].
0 to: easBins - 1 do:
[:i|
self storePointerUnchecked: i
ofObject: easHistArrayOrNil
withValue: (self integerObjectOf: (easHist at: i))]].
self pop: argumentCount!
Item was changed:
----- Method: Interpreter>>primitiveVMProfileInfoInto (in category 'process primitives') -----
primitiveVMProfileInfoInto
"Primitive. Answer whether the profiler is running or not.
If the argument is an Array of suitable size fill it with the following information:
1. the addresses of the first element of the VM histogram (the first address in the executable)
2. the address following the last element (the last address in the executable, excluding dynamically linked libraries)
3. the size of the VM histogram in bins (each bin is a 4 byte unsigned long)
4. the size of the VM histogram in bins (each bin is a 4 byte unsigned long)"
| info running exeStart exeLimit vmBins easBins |
<var: #exeStart type: #'char *'>
<var: #exeLimit type: #'char *'>
<var: #vmBins type: #long>
<var: #easBins type: #long>
self success: argumentCount = 1.
successFlag ifTrue:
[info := self stackObjectValue: 0.
info ~= nilObj ifTrue:
[self assertClassOf: info is: (self splObj: ClassArray).
+ self success: (self numSlotsOf: info) >= 4]].
- self success: (self fetchWordLengthOf: info) >= 4]].
successFlag ifFalse:
[^nil].
self cCode: 'ioProfileStatus(&running,&exeStart,&exeLimit,0,&vmBins,0,&easBins)'
inSmalltalk: [running := exeStart := exeLimit := vmBins := easBins := 0].
info ~= nilObj ifTrue:
[self storePointerUnchecked: 0
ofObject: info
withValue: (self integerObjectOf: (self oopForPointer: exeStart)).
self storePointerUnchecked: 1
ofObject: info
withValue: (self integerObjectOf: (self oopForPointer: exeLimit)).
self storePointerUnchecked: 2
ofObject: info
withValue: (self integerObjectOf: vmBins).
self storePointerUnchecked: 3
ofObject: info
withValue: (self integerObjectOf: easBins)].
self pop: 2 thenPushBool: running!
Item was changed:
----- Method: Interpreter>>primitiveVMProfileSamplesInto (in category 'process primitives') -----
primitiveVMProfileSamplesInto
"Primitive.
0 args: Answer whether the VM Profiler is running or not.
1 arg: Copy the sample data into the supplied argument, which must be a Bitmap
of suitable size. Answer the number of samples copied into the buffer."
| sampleBuffer sampleBufferAddress running bufferSize numSamples |
<var: #bufferSize type: #long>
<var: #sampleBufferAddress type: #'unsigned long *'>
self cCode: 'ioNewProfileStatus(&running,&bufferSize)'
inSmalltalk: [running := false. bufferSize := 0].
argumentCount = 0 ifTrue:
[^self pop: 1 thenPushBool: running].
self success: argumentCount = 1.
successFlag ifTrue:
[sampleBuffer := self stackObjectValue: 0.
self assertClassOf: sampleBuffer is: (self splObj: ClassBitmap).
+ self success: (self numSlotsOf: sampleBuffer) >= bufferSize].
- self success: (self fetchWordLengthOf: sampleBuffer) >= bufferSize].
successFlag ifFalse:
[^nil].
sampleBufferAddress := self firstFixedField: sampleBuffer.
numSamples := self cCode: 'ioNewProfileSamplesInto(sampleBufferAddress)'
inSmalltalk: [sampleBufferAddress := sampleBufferAddress].
self pop: argumentCount + 1 thenPushInteger: numSamples!
Item was changed:
----- Method: Interpreter>>primitiveValueWithArgs (in category 'control primitives') -----
primitiveValueWithArgs
| argumentArray blockContext blockArgumentCount arrayArgumentCount initialIP |
argumentArray := self popStack.
blockContext := self popStack.
blockArgumentCount := self argumentCountOfBlock: blockContext.
"If the argArray isnt actually an Array we ahve to unpop the above two"
(self isArray: argumentArray) ifFalse: [self unPop:2. ^self primitiveFail].
+ successFlag ifTrue: [arrayArgumentCount := self numSlotsOf: argumentArray.
- successFlag ifTrue: [arrayArgumentCount := self fetchWordLengthOf: argumentArray.
self success: (arrayArgumentCount = blockArgumentCount
and: [(self fetchPointer: CallerIndex ofObject: blockContext) = nilObj])].
successFlag
ifTrue: [self
transfer: arrayArgumentCount
fromIndex: 0
ofObject: argumentArray
toIndex: TempFrameStart
ofObject: blockContext.
"Assume: The call to transfer:... makes blockContext a root if necessary,
allowing use to use unchecked stored in the following code. "
initialIP := self fetchPointer: InitialIPIndex ofObject: blockContext.
self
storePointerUnchecked: InstructionPointerIndex
ofObject: blockContext
withValue: initialIP.
self storeStackPointerValue: arrayArgumentCount inContext: blockContext.
self
storePointerUnchecked: CallerIndex
ofObject: blockContext
withValue: activeContext.
self newActiveContext: blockContext]
ifFalse: [self unPop: 2]!
Item was changed:
----- Method: Interpreter>>wakeHighestPriority (in category 'process primitive support') -----
wakeHighestPriority
"Return the highest priority process that is ready to run."
"Note: It is a fatal VM error if there is no runnable process."
| schedLists p processList |
schedLists := self fetchPointer: ProcessListsIndex ofObject: self schedulerPointer.
+ p := self numSlotsOf: schedLists.
- p := self fetchWordLengthOf: schedLists.
p := p - 1.
"index of last indexable field"
processList := self fetchPointer: p ofObject: schedLists.
[self isEmptyList: processList]
whileTrue: [p := p - 1.
p < 0 ifTrue: [self error: 'scheduler could not find a runnable process'].
processList := self fetchPointer: p ofObject: schedLists].
^ self removeFirstLinkOfList: processList!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveClipboardText (in category 'I/O primitives') -----
primitiveClipboardText
"When called with a single string argument, post the string to
the clipboard. When called with zero arguments, return a
string containing the current clipboard contents."
| s sz |
argumentCount = 1
ifTrue:
[s := self stackTop.
(objectMemory isBytes: s) ifFalse: [^ self primitiveFail].
self successful ifTrue:
+ [sz := objectMemory numBytesOf: s.
- [sz := objectMemory byteLengthOf: s.
self clipboardWrite: sz From: s + objectMemory baseHeaderSize At: 0.
self pop: 1]]
ifFalse:
[sz := self clipboardSize.
objectMemory hasSpurMemoryManagerAPI
ifTrue:
[s := objectMemory allocateBytes: sz classIndex: ClassByteStringCompactIndex.
s ifNil: [^self primitiveFail]]
ifFalse:
[(objectMemory sufficientSpaceToAllocate: sz) ifFalse: [^self primitiveFail].
s := objectMemory instantiateClass: (objectMemory splObj: ClassByteString) indexableSize: sz].
self clipboardRead: sz Into: s + objectMemory baseHeaderSize At: 0.
self pop: 1 thenPush: s]!
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 numSlotsOf: argumentArray.
- 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 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>>primitiveFormPrint (in category 'I/O primitives') -----
primitiveFormPrint
"On platforms that support it, this primitive prints the receiver, assumed to be a Form, to the default printer."
| landscapeFlag vScale hScale rcvr bitsArray w h
depth pixelsPerWord wordsPerLine bitsArraySize ok |
<var: #vScale type: 'double '>
<var: #hScale type: 'double '>
landscapeFlag := self booleanValueOf: self stackTop.
vScale := self floatValueOf: (self stackValue: 1).
hScale := self floatValueOf: (self stackValue: 2).
rcvr := self stackValue: 3.
((objectMemory isPointers: rcvr)
and: [(objectMemory lengthOf: rcvr) >= 4]) ifFalse:
[self success: false].
self successful ifTrue:
[bitsArray := objectMemory fetchPointer: 0 ofObject: rcvr.
w := self fetchInteger: 1 ofObject: rcvr.
h := self fetchInteger: 2 ofObject: rcvr.
depth := self fetchInteger: 3 ofObject: rcvr.
(w > 0 and: [h > 0]) ifFalse: [self success: false].
pixelsPerWord := 32 // depth.
wordsPerLine := (w + (pixelsPerWord - 1)) // pixelsPerWord.
(objectMemory isWordsOrBytes: bitsArray)
ifTrue:
+ [bitsArraySize := objectMemory numBytesOf: bitsArray.
- [bitsArraySize := objectMemory byteLengthOf: bitsArray.
self success: (bitsArraySize = (wordsPerLine * h * 4))]
ifFalse: [self success: false]].
self successful ifTrue:
[ok := self cCode: 'ioFormPrint(bitsArray + BaseHeaderSize, w, h, depth, hScale, vScale, landscapeFlag)'.
self success: ok].
self successful ifTrue:
[self pop: 3] "pop hScale, vScale, and landscapeFlag; leave rcvr on stack"!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveShortAt (in category 'sound primitives') -----
primitiveShortAt
"Treat the receiver, which can be indexible by either bytes or words, as an array of signed 16-bit values. Return the contents of the given index. Note that the index specifies the i-th 16-bit entry, not the i-th byte or word."
+ | index rcvr value |
+ index := self stackTop..
+ (objectMemory isIntegerObject: index) ifFalse:
- | index rcvr sz addr value |
- index := self stackIntegerValue: 0.
- self successful ifFalse:
[^self primitiveFailFor: PrimErrBadArgument].
rcvr := self stackValue: 1.
(objectMemory isWordsOrBytes: rcvr) ifFalse:
[^self primitiveFailFor: PrimErrInappropriate].
+ ((index >= 1) and: [index <= (objectMemory num16BitUnitsOf: rcvr)]) ifFalse:
- sz := (objectMemory numSlotsOf: rcvr) * objectMemory bytesPerOop // 2. "number of 16-bit fields"
- ((index >= 1) and: [index <= sz]) ifFalse:
[^self primitiveFailFor: PrimErrBadIndex].
+ value := objectMemory fetchShort16: index - 1 ofObject: rcvr.
- addr := rcvr + objectMemory baseHeaderSize + (2 * (index - 1)).
- value := objectMemory shortAt: addr.
self pop: 2 thenPushInteger: value!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveShortAtPut (in category 'sound primitives') -----
primitiveShortAtPut
+ "Treat the receiver, which can be indexible by either bytes or words, as an array
+ of signed 16-bit values. Set the contents of the given index to the given value.
+ Note that the index specifies the i-th 16-bit entry, not the i-th byte or word."
- "Treat the receiver, which can be indexible by either bytes or words, as an array of signed 16-bit values. Set the contents of the given index to the given value. Note that the index specifies the i-th 16-bit entry, not the i-th byte or word."
+ | index rcvr value |
+ value := self stackTop.
+ index := self stackValue: 1.
+ ((objectMemory isIntegerObject: value)
+ and: [(objectMemory isIntegerObject: index)
+ and: [value := objectMemory integerValueOf: value.
+ (value >= -32768) and: [value <= 32767]]]) ifFalse:
- | index rcvr sz addr value |
- value := self stackIntegerValue: 0.
- index := self stackIntegerValue: 1.
- (self successful and: [(value >= -32768) and: [value <= 32767]]) ifFalse:
[^self primitiveFailFor: PrimErrBadArgument].
rcvr := self stackValue: 2.
(objectMemory isWordsOrBytes: rcvr) ifFalse:
[^self primitiveFailFor: PrimErrInappropriate].
+ (index >= 1 and: [index <= (objectMemory num16BitUnitsOf: rcvr)]) ifFalse:
- sz := ((objectMemory sizeBitsOf: rcvr) - BaseHeaderSize) // 2. "number of 16-bit fields"
- (index >= 1 and: [index <= sz]) ifFalse:
[^self primitiveFailFor: PrimErrBadIndex].
+ objectMemory storeShort16: index - 1 ofObject: rcvr withValue: value.
+ self pop: 3 thenPush: (objectMemory integerObjectOf: value)!
- addr := rcvr + BaseHeaderSize + (2 * (index - 1)).
- objectMemory shortAt: addr put: value.
- self pop: 3 thenPush: (objectMemory integerObjectOf: value) "pop all; return value"!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveStopVMProfiling (in category 'process primitives') -----
primitiveStopVMProfiling
"Primitive. Stop the VM profiler and either copy the histogram data into the
supplied arguments, if they're non-nil. Fail if the arguments are not of the right type or size."
| vmHistArrayOrNil vmHist vmBins easHistArrayOrNil easHist easBins |
<var: #vmHist type: #'long *'>
<var: #vmBins type: #long>
<var: #easHist type: #'long *'>
<var: #easBins type: #long>
self success: argumentCount = 2.
vmHistArrayOrNil := self stackObjectValue: 1.
easHistArrayOrNil := self stackObjectValue: 0.
self successful ifFalse:
[^nil].
"Both args must be either nil or arrays. If they're arrays and the wrong size we incorrectly stop profiling."
((vmHistArrayOrNil = objectMemory nilObject or: [(objectMemory fetchClassOfNonImm: vmHistArrayOrNil) = (objectMemory splObj: ClassArray)])
and: [(objectMemory fetchClassOfNonImm: vmHistArrayOrNil) = (objectMemory fetchClassOfNonImm: easHistArrayOrNil)]) ifFalse:
[^self primitiveFail].
self cCode: 'ioControlProfile(0,&vmHist,&vmBins,&easHist,&easBins)'
inSmalltalk: [vmHist := vmBins := easHist := easBins := 0].
vmHistArrayOrNil ~= objectMemory nilObject ifTrue:
+ [((objectMemory numSlotsOf: vmHistArrayOrNil) = vmBins
+ and: [(objectMemory numSlotsOf: easHistArrayOrNil) = easBins]) ifFalse:
- [((objectMemory fetchWordLengthOf: vmHistArrayOrNil) = vmBins
- and: [(objectMemory fetchWordLengthOf: easHistArrayOrNil) = easBins]) ifFalse:
[^self primitiveFail].
0 to: vmBins - 1 do:
[:i|
objectMemory storePointerUnchecked: i
ofObject: vmHistArrayOrNil
withValue: (objectMemory integerObjectOf: (vmHist at: i))].
0 to: easBins - 1 do:
[:i|
objectMemory storePointerUnchecked: i
ofObject: easHistArrayOrNil
withValue: (objectMemory integerObjectOf: (easHist at: i))]].
self pop: argumentCount!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveVMProfileInfoInto (in category 'process primitives') -----
primitiveVMProfileInfoInto
"Primitive. Answer whether the profiler is running or not.
If the argument is an Array of suitable size fill it with the following information:
1. the addresses of the first element of the VM histogram (the first address in the executable)
2. the address following the last element (the last address in the executable, excluding dynamically linked libraries)
3. the size of the VM histogram in bins (each bin is a 4 byte unsigned long)
4. the size of the VM histogram in bins (each bin is a 4 byte unsigned long)"
| info running exeStart exeLimit vmBins easBins |
<var: #exeStart type: #'char *'>
<var: #exeLimit type: #'char *'>
<var: #vmBins type: #long>
<var: #easBins type: #long>
self success: argumentCount = 1.
self successful ifTrue:
[info := self stackObjectValue: 0.
info ~= objectMemory nilObject ifTrue:
[self assertClassOf: info is: (objectMemory splObj: ClassArray).
+ self success: (objectMemory numSlotsOf: info) >= 4]].
- self success: (objectMemory fetchWordLengthOf: info) >= 4]].
self successful ifFalse:
[^nil].
self cCode: 'ioProfileStatus(&running,&exeStart,&exeLimit,0,&vmBins,0,&easBins)'
inSmalltalk: [running := exeStart := exeLimit := vmBins := easBins := 0].
info ~= objectMemory nilObject ifTrue:
[objectMemory storePointerUnchecked: 0
ofObject: info
withValue: (objectMemory integerObjectOf: (self oopForPointer: exeStart)).
objectMemory storePointerUnchecked: 1
ofObject: info
withValue: (objectMemory integerObjectOf: (self oopForPointer: exeLimit)).
objectMemory storePointerUnchecked: 2
ofObject: info
withValue: (objectMemory integerObjectOf: vmBins).
objectMemory storePointerUnchecked: 3
ofObject: info
withValue: (objectMemory integerObjectOf: easBins)].
self pop: 2 thenPushBool: running!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveVMProfileSamplesInto (in category 'process primitives') -----
primitiveVMProfileSamplesInto
"Primitive.
0 args: Answer whether the VM Profiler is running or not.
1 arg: Copy the sample data into the supplied argument, which must be a Bitmap
of suitable size. Answer the number of samples copied into the buffer."
| sampleBuffer sampleBufferAddress running bufferSize numSamples |
<var: #bufferSize type: #long>
<var: #sampleBufferAddress type: #'unsigned long *'>
self cCode: 'ioNewProfileStatus(&running,&bufferSize)'
inSmalltalk: [running := false. bufferSize := 0].
argumentCount = 0 ifTrue:
[^self pop: 1 thenPushBool: running].
self success: argumentCount = 1.
self successful ifTrue:
[sampleBuffer := self stackObjectValue: 0.
self assertClassOf: sampleBuffer is: (objectMemory splObj: ClassBitmap).
+ self success: (objectMemory numSlotsOf: sampleBuffer) >= bufferSize].
- self success: (objectMemory fetchWordLengthOf: sampleBuffer) >= bufferSize].
self successful ifFalse:
[^nil].
sampleBufferAddress := objectMemory firstFixedField: sampleBuffer.
numSamples := self cCode: 'ioNewProfileSamplesInto(sampleBufferAddress)'
inSmalltalk: [sampleBufferAddress := sampleBufferAddress].
self pop: argumentCount + 1 thenPushInteger: numSamples!
Item was added:
+ ----- Method: InterpreterProxy>>unpinObject: (in category 'object access') -----
+ unpinObject: anObject
+ <option: #(atLeastVMProxyMajor:minor: 1 13)>
+ ^self shouldBeImplemented!
Item was changed:
----- Method: InterpreterSimulator>>classAndSelectorOfMethod:forReceiver: (in category 'debug support') -----
classAndSelectorOfMethod: meth forReceiver: rcvr
| mClass dict length methodArray |
mClass := self fetchClassOf: rcvr.
[dict := self fetchPointer: MethodDictionaryIndex ofObject: mClass.
+ length := self numSlotsOf: dict.
- length := self fetchWordLengthOf: dict.
methodArray := self fetchPointer: MethodArrayIndex ofObject: dict.
0 to: length-SelectorStart-1 do:
[:index |
meth = (self fetchPointer: index ofObject: methodArray)
ifTrue: [^ Array
with: mClass
with: (self fetchPointer: index + SelectorStart ofObject: dict)]].
mClass := self fetchPointer: SuperclassIndex ofObject: mClass.
mClass = nilObj]
whileFalse: [].
^ Array
with: (self fetchClassOf: rcvr)
with: (self splObj: SelectorDoesNotUnderstand)!
Item was removed:
- ----- Method: NewObjectMemory>>goodContextSize: (in category 'contexts') -----
- goodContextSize: oop
- | numSlots |
- numSlots := self numSlotsOf: oop.
- ^numSlots = SmallContextSlots or: [numSlots = LargeContextSlots]!
Item was removed:
- ----- Method: NewObjectMemory>>numSlotsOf: (in category 'interpreter access') -----
- numSlotsOf: obj
- "Answer the number of oop-sized elements in the given object.
- Unlike lengthOf: this does not adjust the length of a context
- by the stackPointer and so can be used e.g. by cloneContext:"
- <api>
- | header sz |
- header := self baseHeader: obj.
- sz := (header bitAnd: TypeMask) = HeaderTypeSizeAndClass
- ifTrue: [(self sizeHeader: obj) bitAnd: AllButTypeMask]
- ifFalse: [header bitAnd: SizeMask].
- ^sz - BaseHeaderSize >> ShiftForWord!
Item was changed:
----- 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 isContextNonImm: oop)
and: [self badContextSize: oop]) ifTrue:
+ [self printHex: oop; space; printNum: (self numBytesOf: oop); cr.
- [self printHex: oop; space; printNum: (self byteLengthOf: oop); cr.
printContexts ifTrue:
[coInterpreter printContext: oop]].
oop := self accessibleObjectAfter: oop]!
Item was changed:
+ ----- Method: NewObjectMemory>>sizeBitsOf: (in category 'object access') -----
- ----- Method: NewObjectMemory>>sizeBitsOf: (in category 'header access') -----
sizeBitsOf: oop
"Answer the number of bytes in the given object, including its base header, rounded up to an integral number of words."
"Note: byte indexable objects need to have low bits subtracted from this size."
<inline: true>
| header |
header := self baseHeader: oop.
^(header bitAnd: TypeMask) = HeaderTypeSizeAndClass
ifTrue: [(self sizeHeader: oop) bitAnd: LongSizeMask]
ifFalse: [header bitAnd: SizeMask]!
Item was changed:
+ ----- Method: NewObjectMemory>>sizeBitsOfSafe: (in category 'object access') -----
- ----- Method: NewObjectMemory>>sizeBitsOfSafe: (in category 'header access') -----
sizeBitsOfSafe: oop
"Compute the size of the given object from the cc and size fields in its header.
This works even if its type bits are not correct."
| header type |
header := self baseHeader: oop.
type := self rightType: header.
^type = HeaderTypeSizeAndClass
ifTrue: [(self sizeHeader: oop) bitAnd: AllButTypeMask]
ifFalse: [header bitAnd: SizeMask]!
Item was added:
+ ----- Method: NewObjectMemory>>unpinObject: (in category 'primitive support') -----
+ unpinObject: objOop
+ "For forward-compatibility with Spur. Fail; ObjectMemory does not support pinning."
+ <api>
+ coInterpreter primitiveFailFor: PrimErrUnsupported!
Item was changed:
----- Method: NewspeakInterpreter>>activateNewClosureMethod: (in category 'control primitives') -----
activateNewClosureMethod: blockClosure
"Similar to activateNewMethod but for Closure and newMethod."
| theBlockClosure closureMethod newContext methodHeader numCopied where outerContext |
DoAssertionChecks ifTrue:
[self okayOop: blockClosure].
outerContext := self fetchPointer: ClosureOuterContextIndex ofObject: blockClosure.
DoAssertionChecks ifTrue:
[self okayOop: outerContext].
closureMethod := self fetchPointer: MethodIndex ofObject: outerContext.
methodHeader := self headerOf: closureMethod.
self pushRemappableOop: blockClosure.
newContext := self allocateOrRecycleContext: (methodHeader bitAnd: LargeContextBit). "All for one, and one for all!!"
"allocateOrRecycleContext: may cause a GC; restore blockClosure and refetch outerContext et al"
theBlockClosure := self popRemappableOop.
outerContext := self fetchPointer: ClosureOuterContextIndex ofObject: theBlockClosure.
+ numCopied := (self numSlotsOf: theBlockClosure) - ClosureFirstCopiedValueIndex.
- numCopied := (self fetchWordLengthOf: theBlockClosure) - ClosureFirstCopiedValueIndex.
"Assume: newContext will be recorded as a root if necessary by the
call to newActiveContext: below, so we can use unchecked stores."
where := newContext + BaseHeaderSize.
self longAt: where + (SenderIndex << ShiftForWord)
put: activeContext.
self longAt: where + (InstructionPointerIndex << ShiftForWord)
put: (self fetchPointer: ClosureStartPCIndex ofObject: theBlockClosure).
self longAt: where + (StackPointerIndex << ShiftForWord)
put: (self integerObjectOf: argumentCount + numCopied).
self longAt: where + (MethodIndex << ShiftForWord)
put: (self fetchPointer: MethodIndex ofObject: outerContext).
self longAt: where + (ClosureIndex << ShiftForWord)
put: theBlockClosure.
self longAt: where + (ReceiverIndex << ShiftForWord)
put: (self fetchPointer: ReceiverIndex ofObject: outerContext).
"Copy the arguments..."
1 to: argumentCount do:
[:i | self longAt: where + ((ReceiverIndex+i) << ShiftForWord)
put: (self stackValue: argumentCount-i)].
"Copy the copied values..."
where := newContext + BaseHeaderSize + ((ReceiverIndex + 1 + argumentCount) << ShiftForWord).
0 to: numCopied - 1 do:
[:i| self longAt: where + (i << ShiftForWord)
put: (self fetchPointer: i + ClosureFirstCopiedValueIndex
ofObject: theBlockClosure)].
"The initial instructions in the block nil-out remaining temps."
self pop: argumentCount + 1.
self newActiveContext: newContext!
Item was changed:
----- Method: NewspeakInterpreter>>findClassOfMethod:forReceiver: (in category 'debug support') -----
findClassOfMethod: meth forReceiver: rcvr
| currClass classDict classDictSize methodArray i done |
currClass := self fetchClassOf: rcvr.
done := false.
[done] whileFalse: [
classDict := self fetchPointer: MessageDictionaryIndex ofObject: currClass.
+ classDictSize := self numSlotsOf: classDict.
- classDictSize := self fetchWordLengthOf: classDict.
methodArray := self fetchPointer: MethodArrayIndex ofObject: classDict.
i := 0.
[i < (classDictSize - SelectorStart)] whileTrue: [
meth = (self fetchPointer: i ofObject: methodArray) ifTrue: [ ^currClass ].
i := i + 1.
].
currClass := self fetchPointer: SuperclassIndex ofObject: currClass.
done := currClass = nilObj.
].
^self fetchClassOf: rcvr "method not found in superclass chain"!
Item was changed:
----- Method: NewspeakInterpreter>>findSelectorOfMethod:forReceiver: (in category 'debug support') -----
findSelectorOfMethod: meth forReceiver: rcvr
| currClass done classDict classDictSize methodArray i |
currClass := self fetchClassOf: rcvr.
done := false.
[done] whileFalse: [
classDict := self fetchPointer: MessageDictionaryIndex ofObject: currClass.
+ classDictSize := self numSlotsOf: classDict.
- classDictSize := self fetchWordLengthOf: classDict.
methodArray := self fetchPointer: MethodArrayIndex ofObject: classDict.
i := 0.
[i <= (classDictSize - SelectorStart)] whileTrue: [
meth = (self fetchPointer: i ofObject: methodArray) ifTrue: [
^(self fetchPointer: i + SelectorStart ofObject: classDict)
].
i := i + 1.
].
currClass := self fetchPointer: SuperclassIndex ofObject: currClass.
done := currClass = nilObj.
].
^ nilObj "method not found in superclass chain"!
Item was changed:
----- Method: NewspeakInterpreter>>lookupMethodInDictionary: (in category 'message sending') -----
lookupMethodInDictionary: dictionary
"This method lookup tolerates integers as Dictionary keys to
support execution of images in which Symbols have been
compacted out"
| length index mask wrapAround nextSelector methodArray |
<inline: true>
+ length := self numSlotsOf: dictionary.
- length := self fetchWordLengthOf: dictionary.
mask := length - SelectorStart - 1.
(self isIntegerObject: messageSelector)
ifTrue: [index := (mask bitAnd: (self integerValueOf: messageSelector)) + SelectorStart]
ifFalse: [index := (mask bitAnd: (self hashBitsOf: messageSelector)) + SelectorStart].
"It is assumed that there are some nils in this dictionary, and search will
stop when one is encountered. However, if there are no nils, then wrapAround
will be detected the second time the loop gets to the end of the table."
wrapAround := false.
[true] whileTrue:
[nextSelector := self fetchPointer: index ofObject: dictionary.
nextSelector = nilObj ifTrue: [^ false].
nextSelector = messageSelector ifTrue:
[methodArray := self fetchPointer: MethodArrayIndex ofObject: dictionary.
newMethod := self fetchPointer: index - SelectorStart ofObject: methodArray.
^true].
index := index + 1.
index = length ifTrue:
[wrapAround ifTrue: [^false].
wrapAround := true.
index := SelectorStart]]!
Item was changed:
----- Method: NewspeakInterpreter>>primitiveClosureCopyWithCopiedValues (in category 'control primitives') -----
primitiveClosureCopyWithCopiedValues
| newClosure copiedValues numCopiedValues numArgs |
numArgs := self stackIntegerValue: 1.
copiedValues := self stackTop.
(self fetchClassOf: copiedValues) = (self splObj: ClassArray) ifFalse:
[^self primitiveFail].
+ numCopiedValues := self numSlotsOf: copiedValues.
- numCopiedValues := self fetchWordLengthOf: copiedValues.
newClosure := self
closureNumArgs: numArgs
"greater by 1 due to preIncrement of localIP"
instructionPointer: instructionPointer + 2 - (method+BaseHeaderSize)
numCopiedValues: numCopiedValues.
"Assume: have just allocated a new closure; it must be young. Thus, can use unchecked stores."
self storePointerUnchecked: ClosureOuterContextIndex ofObject: newClosure withValue: (self stackValue: 2).
numCopiedValues > 0 ifTrue:
["Allocation may have done a GC and copiedValues may have moved."
copiedValues := self stackTop.
0 to: numCopiedValues - 1 do:
[:i|
"Assume: have just allocated a new BlockClosure; it must be young.
Thus, can use unchecked stores."
self storePointerUnchecked: i + ClosureFirstCopiedValueIndex
ofObject: newClosure
withValue: (self fetchPointer: i ofObject: copiedValues)]].
self pop: 3 thenPush: newClosure!
Item was changed:
----- Method: NewspeakInterpreter>>primitiveClosureValueWithArgs (in category 'control primitives') -----
primitiveClosureValueWithArgs
| argumentArray arraySize cntxSize blockClosure blockArgumentCount closureMethod index outerContext |
argumentArray := self stackTop.
(self isArray: argumentArray) ifFalse:
[^self primitiveFail].
"Check for enough space in thisContext to push all args"
+ arraySize := self numSlotsOf: argumentArray.
+ cntxSize := self numSlotsOf: activeContext.
- arraySize := self fetchWordLengthOf: argumentArray.
- cntxSize := self fetchWordLengthOf: activeContext.
(self stackPointerIndex + arraySize) < cntxSize ifFalse:
[^self primitiveFail].
blockClosure := self stackValue: argumentCount.
blockArgumentCount := self argumentCountOfClosure: blockClosure.
arraySize = blockArgumentCount ifFalse:
[^self primitiveFail].
"Somewhat paranoiac checks we need while debugging that we may be able to discard
in a robust system."
outerContext := self fetchPointer: ClosureOuterContextIndex ofObject: blockClosure.
(self isContext: outerContext) ifFalse:
[^self primitiveFail].
closureMethod := self fetchPointer: MethodIndex ofObject: outerContext.
"Check if the closure's method is actually a CompiledMethod."
((self isNonIntegerObject: closureMethod) and: [self isCompiledMethod: closureMethod]) ifFalse:
[^self primitiveFail].
self popStack.
"Copy the arguments to the stack, and activate"
index := 1.
[index <= arraySize]
whileTrue:
[self push: (self fetchPointer: index - 1 ofObject: argumentArray).
index := index + 1].
argumentCount := arraySize.
self activateNewClosureMethod: blockClosure.
self quickCheckForInterrupts!
Item was changed:
----- Method: NewspeakInterpreter>>primitiveDoNamedPrimitiveWithArgs (in category 'plugin primitives') -----
primitiveDoNamedPrimitiveWithArgs
"Simulate an primitiveExternalCall invocation (e.g. for the Debugger). Do not cache anything.
e.g. ContextPart>>tryNamedPrimitiveIn: aCompiledMethod for: aReceiver withArgs: arguments"
| argumentArray arraySize index methodArg methodHeader spec
moduleName functionName moduleLength functionLength addr |
<var: #addr declareC: 'void (*addr)()'>
argumentArray := self stackTop.
(self isArray: argumentArray) ifFalse:
[^self primitiveFail]. "invalid args"
+ arraySize := self numSlotsOf: argumentArray.
- arraySize := self fetchWordLengthOf: argumentArray.
self success: (self roomToPushNArgs: arraySize).
methodArg := self stackObjectValue: 2.
self successful ifFalse:
[^self primitiveFail]. "invalid args"
(self isCompiledMethod: methodArg) ifFalse:
[^self primitiveFail]. "invalid args"
methodHeader := self headerOf: methodArg.
(self literalCountOfHeader: methodHeader) > 2 ifFalse:
[^self primitiveFail]. "invalid methodArg state"
self assertClassOf: (spec := self fetchPointer: 1 "first literal" ofObject: methodArg)
is: (self splObj: ClassArray).
(self successful
and: [(self lengthOf: spec) = 4
and: [(self primitiveIndexOfMethodHeader: methodHeader) = 117]]) ifFalse:
[^self primitiveFail]. "invalid methodArg state"
(self argumentCountOfMethodHeader: methodHeader) = arraySize ifFalse:
[^self primitiveFail]. "invalid args (Array args wrong size)"
"The function has not been loaded yet. Fetch module and function name."
moduleName := self fetchPointer: 0 ofObject: spec.
moduleName = nilObj
ifTrue: [moduleLength := 0]
ifFalse: [self success: (self isBytes: moduleName).
moduleLength := self lengthOf: moduleName.
self cCode: '' inSmalltalk:
[ (#('FloatArrayPlugin' 'Matrix2x3Plugin') includes: (self stringOf: moduleName)) "??"
ifTrue: [moduleLength := 0 "Cause all of these to fail"]]].
functionName := self fetchPointer: 1 ofObject: spec.
self success: (self isBytes: functionName).
functionLength := self lengthOf: functionName.
self successful ifFalse: [^self primitiveFail]. "invalid methodArg state"
addr := self ioLoadExternalFunction: functionName + BaseHeaderSize
OfLength: functionLength
FromModule: moduleName + BaseHeaderSize
OfLength: moduleLength.
addr = 0 ifTrue:
[^self primitiveFail]. "could not find function"
"Cannot fail this primitive from now on. Can only fail the external primitive."
self pop: 1.
argumentCount := arraySize.
index := 1.
[index <= arraySize] whileTrue:
[self push: (self fetchPointer: index - 1 ofObject: argumentArray).
index := index + 1].
"Run the primitive (sets primFailCode)"
self pushRemappableOop: argumentArray. "prim might alloc/gc in callback"
lkupClass := nilObj.
self callExternalPrimitive: addr.
argumentArray := self popRemappableOop.
self successful ifFalse: "If primitive failed, then restore state for failure code"
[self pop: arraySize thenPush: argumentArray.
argumentCount := 3]!
Item was changed:
----- Method: NewspeakInterpreter>>primitiveDoPrimitiveWithArgs (in category 'control primitives') -----
primitiveDoPrimitiveWithArgs
| argumentArray arraySize index cntxSize primIdx |
argumentArray := self stackTop.
+ arraySize := self numSlotsOf: argumentArray.
+ cntxSize := self numSlotsOf: activeContext.
- arraySize := self fetchWordLengthOf: argumentArray.
- cntxSize := self fetchWordLengthOf: activeContext.
self success: self stackPointerIndex + arraySize < cntxSize.
(self isArray: argumentArray) ifFalse: [^ self primitiveFail].
primIdx := self stackIntegerValue: 1.
self successful ifFalse: [^ self primitiveFail]. "invalid args"
primitiveFunctionPointer := self functionPointerFor: primIdx inClass: nil.
primitiveFunctionPointer = 0 ifTrue:
[^self primitiveFail].
"Pop primIndex and argArray, then push args in place..."
self pop: 2.
argumentCount := arraySize.
index := 1.
[index <= argumentCount] whileTrue:
[self push: (self fetchPointer: index - 1 ofObject: argumentArray).
index := index + 1].
self isPrimitiveFunctionPointerAnIndex ifTrue:
[self externalQuickPrimitiveResponse.
^nil].
"Run the primitive (sets successFlag)"
self pushRemappableOop: argumentArray. "prim might alloc/gc"
lkupClass := nilObj.
"Run the primitive (sets primFailCode)"
self slowPrimitiveResponse.
argumentArray := self popRemappableOop.
self successful ifFalse:
["If primitive failed, then restore state for failure code"
self pop: arraySize.
self pushInteger: primIdx.
self push: argumentArray.
argumentCount := 2]!
Item was changed:
----- Method: NewspeakInterpreter>>primitiveExecuteMethodArgsArray (in category 'control primitives') -----
primitiveExecuteMethodArgsArray
"receiver, argsArray, then method are on top of stack. Execute method against
receiver and args. Allow for up to two extra arguments (e.g. for mirror primitives).
Set primitiveFunctionPointer because no cache lookup has been done for the
method, and hence primitiveFunctionPointer is stale."
| methodArgument argCnt argumentArray primitiveIndex |
methodArgument := self stackTop.
argumentArray := self stackValue: 1.
((self isOopCompiledMethod: methodArgument)
and: [self isArray: argumentArray]) ifFalse:
[^self primitiveFailFor: PrimErrBadArgument].
argCnt := self argumentCountOf: methodArgument.
+ argCnt = (self numSlotsOf: argumentArray) ifFalse:
- argCnt = (self fetchWordLengthOf: argumentArray) ifFalse:
[^self primitiveFailFor: PrimErrBadNumArgs].
argumentCount > 2 ifTrue: "CompiledMethod class>>receiver:withArguments:executeMethod:
SqueakObjectPrimitives class >> receiver:withArguments:apply:
VMMirror>>ifFail:object:with:executeMethod: et al"
[argumentCount > 4 ifTrue:
[^self primitiveFailFor: PrimErrUnsupported].
self stackValue: argumentCount put: (self stackValue: 2)]. "replace actual receiver with desired receiver"
"and push the actual arguments"
self pop: argumentCount.
0 to: argCnt - 1 do:
[:i|
self push: (self fetchPointer: i ofObject: argumentArray)].
newMethod := methodArgument.
primitiveIndex := self primitiveIndexOf: newMethod.
primitiveFunctionPointer := self functionPointerFor: primitiveIndex inClass: nil.
argumentCount := argCnt.
"We set the messageSelector for executeMethod below since things
like the at cache read messageSelector and so it cannot be left stale."
messageSelector := self nilObject.
self executeNewMethod.
"Recursive xeq affects primErrorCode"
self initPrimCall!
Item was changed:
----- Method: NewspeakInterpreter>>primitiveFormPrint (in category 'I/O primitives') -----
primitiveFormPrint
"On platforms that support it, this primitive prints the receiver, assumed to be a Form, to the default printer."
| landscapeFlag vScale hScale rcvr bitsArray w h
depth pixelsPerWord wordsPerLine bitsArraySize ok |
<var: #vScale type: 'double '>
<var: #hScale type: 'double '>
landscapeFlag := self booleanValueOf: self stackTop.
vScale := self floatValueOf: (self stackValue: 1).
hScale := self floatValueOf: (self stackValue: 2).
rcvr := self stackValue: 3.
(rcvr isIntegerObject: rcvr) ifTrue: [self success: false].
self successful ifTrue: [
((self isPointers: rcvr) and: [(self lengthOf: rcvr) >= 4])
ifFalse: [self success: false]].
self successful ifTrue: [
bitsArray := self fetchPointer: 0 ofObject: rcvr.
w := self fetchInteger: 1 ofObject: rcvr.
h := self fetchInteger: 2 ofObject: rcvr.
depth := self fetchInteger: 3 ofObject: rcvr.
(w > 0 and: [h > 0]) ifFalse: [self success: false].
pixelsPerWord := 32 // depth.
wordsPerLine := (w + (pixelsPerWord - 1)) // pixelsPerWord.
((rcvr isIntegerObject: rcvr) not and: [self isWordsOrBytes: bitsArray])
ifTrue: [
+ bitsArraySize := self numBytesOf: bitsArray.
- bitsArraySize := self byteLengthOf: bitsArray.
self success: (bitsArraySize = (wordsPerLine * h * 4))]
ifFalse: [self success: false]].
self successful ifTrue: [
ok := self cCode: 'ioFormPrint(bitsArray + BaseHeaderSize, w, h, depth, hScale, vScale, landscapeFlag)'.
self success: ok].
self successful ifTrue: [
self pop: 3]. "pop hScale, vScale, and landscapeFlag; leave rcvr on stack"
!
Item was changed:
----- Method: NewspeakInterpreter>>primitivePerformAt: (in category 'control primitives') -----
primitivePerformAt: lookupClass
"Common routine used by perform:withArgs: and perform:withArgs:inSuperclass:"
"NOTE: The case of doesNotUnderstand: is not a failure to perform.
The only failures are arg types and consistency of argumentCount."
| performSelector argumentArray arraySize index cntxSize performMethod performArgCount |
argumentArray := self stackTop.
(self isArray: argumentArray) ifFalse:[^self primitiveFail].
self successful ifTrue:
["Check for enough space in thisContext to push all args"
+ arraySize := self numSlotsOf: argumentArray.
+ cntxSize := self numSlotsOf: activeContext.
- arraySize := self fetchWordLengthOf: argumentArray.
- cntxSize := self fetchWordLengthOf: activeContext.
self success: (self stackPointerIndex + arraySize) < cntxSize].
self successful ifFalse: [^nil].
performSelector := messageSelector.
performMethod := newMethod.
performArgCount := argumentCount.
"pop the arg array and the selector, then push the args out of the array, as if they were on the stack"
self popStack.
messageSelector := self popStack.
"Copy the arguments to the stack, and execute"
index := 1.
[index <= arraySize] whileTrue:
[self push: (self fetchPointer: index - 1 ofObject: argumentArray).
index := index + 1].
argumentCount := arraySize.
self fastLogSend: messageSelector.
self sendBreakpoint: messageSelector receiver: receiver.
self findNewMethodInClass: lookupClass.
"Only test CompiledMethods for argument count - any other objects playacting as CMs will have to take their chances"
(self isCompiledMethod: newMethod)
ifTrue: [self success: (self argumentCountOf: newMethod) = argumentCount].
self successful
ifTrue: [self executeNewMethod. "Recursive xeq affects successFlag"
self initPrimCall]
ifFalse: ["Restore the state by popping all those array entries and pushing back the selector and array, and fail"
self pop: argumentCount.
self push: messageSelector.
self push: argumentArray.
messageSelector := performSelector.
newMethod := performMethod.
argumentCount := performArgCount]
!
Item was changed:
----- Method: NewspeakInterpreter>>primitiveVMProfileSamplesInto (in category 'process primitives') -----
primitiveVMProfileSamplesInto
"Primitive.
0 args: Answer whether the VM Profiler is running or not.
1 arg: Copy the sample data into the supplied argument, which must be a Bitmap
of suitable size. Answer the number of samples copied into the buffer."
| sampleBuffer sampleBufferAddress running bufferSize numSamples |
<var: #bufferSize type: #long>
<var: #sampleBufferAddress type: #'unsigned long *'>
self cCode: 'ioNewProfileStatus(&running,&bufferSize)'
inSmalltalk: [running := false. bufferSize := 0].
argumentCount = 0 ifTrue:
[^self pop: 1 thenPushBool: running].
self success: argumentCount = 1.
self successful ifTrue:
[sampleBuffer := self stackObjectValue: 0.
self assertClassOf: sampleBuffer is: (self splObj: ClassBitmap).
+ self success: (self numSlotsOf: sampleBuffer) >= bufferSize].
- self success: (self fetchWordLengthOf: sampleBuffer) >= bufferSize].
self successful ifFalse:
[^nil].
sampleBufferAddress := self firstFixedField: sampleBuffer.
numSamples := self cCode: 'ioNewProfileSamplesInto(sampleBufferAddress)'
inSmalltalk: [sampleBufferAddress := sampleBufferAddress].
self pop: argumentCount + 1 thenPushInteger: numSamples!
Item was changed:
----- Method: NewspeakInterpreter>>primitiveValueWithArgs (in category 'control primitives') -----
primitiveValueWithArgs
| argumentArray blockContext blockArgumentCount arrayArgumentCount initialIP |
argumentArray := self popStack.
blockContext := self popStack.
blockArgumentCount := self argumentCountOfBlock: blockContext.
"If the argArray isnt actually an Array we ahve to unpop the above two"
(self isArray: argumentArray) ifFalse: [self unPop:2. ^self primitiveFail].
+ self successful ifTrue: [arrayArgumentCount := self numSlotsOf: argumentArray.
- self successful ifTrue: [arrayArgumentCount := self fetchWordLengthOf: argumentArray.
self success: (arrayArgumentCount = blockArgumentCount
and: [(self fetchPointer: CallerIndex ofObject: blockContext) = nilObj])].
self successful
ifTrue: [self
transfer: arrayArgumentCount
fromIndex: 0
ofObject: argumentArray
toIndex: TempFrameStart
ofObject: blockContext.
"Assume: The call to transfer:... makes blockContext a root if necessary,
allowing use to use unchecked stored in the following code. "
initialIP := self fetchPointer: InitialIPIndex ofObject: blockContext.
self
storePointerUnchecked: InstructionPointerIndex
ofObject: blockContext
withValue: initialIP.
self storeStackPointerValue: arrayArgumentCount inContext: blockContext.
self
storePointerUnchecked: CallerIndex
ofObject: blockContext
withValue: activeContext.
self newActiveContext: blockContext]
ifFalse: [self unPop: 2]!
Item was changed:
----- Method: NewspeakInterpreter>>printAllStacks (in category 'debug printing') -----
printAllStacks
"Print all the stacks of all running processes, including those that are currently suspended."
<api>
| oop classObj proc semaphoreClass schedLists processList |
<inline: false>
proc := self activeProcess.
self printNameOfClass: (self fetchClassOf: proc) count: 5; space; printHex: proc.
self print: ' priority '; printNum: (self quickFetchInteger: PriorityIndex ofObject: proc); cr.
self printContextCallStackOf: activeContext.
semaphoreClass := self classSemaphore.
oop := self firstObject.
[self oop: oop isLessThan: freeBlock] whileTrue:
[classObj := self fetchClassOfNonImm: oop.
(classObj = semaphoreClass) ifTrue:
[self printProcsOnList: oop].
oop := self objectAfter: oop].
schedLists := self fetchPointer: ProcessListsIndex ofObject: self schedulerPointer.
+ (self numSlotsOf: schedLists) - 1 to: 0 by: -1 do:
- (self fetchWordLengthOf: schedLists) - 1 to: 0 by: -1 do:
[:pri|
processList := self fetchPointer: pri ofObject: schedLists.
(self isEmptyList: processList) ifFalse:
[self cr; print: 'processes at priority '; printNum: pri + 1.
self printProcsOnList: processList]]!
Item was changed:
----- Method: NewspeakInterpreter>>validInstructionPointer:inMethod: (in category 'debug support') -----
validInstructionPointer: anInstrPointer inMethod: aMethod
^anInstrPointer >= (aMethod + (self lastPointerOf: aMethod) + 1)
+ and: [anInstrPointer < (aMethod + (self numBytesOf: aMethod))]!
- and: [anInstrPointer < (aMethod + (self byteLengthOf: aMethod))]!
Item was changed:
----- Method: NewspeakInterpreter>>wakeHighestPriority (in category 'process primitive support') -----
wakeHighestPriority
"Return the highest priority process that is ready to run."
"Note: It is a fatal VM error if there is no runnable process."
| schedLists p processList |
schedLists := self fetchPointer: ProcessListsIndex ofObject: self schedulerPointer.
+ p := self numSlotsOf: schedLists.
- p := self fetchWordLengthOf: schedLists.
p := p - 1.
"index of last indexable field"
processList := self fetchPointer: p ofObject: schedLists.
[self isEmptyList: processList]
whileTrue: [p := p - 1.
p < 0 ifTrue: [self error: 'scheduler could not find a runnable process'].
processList := self fetchPointer: p ofObject: schedLists].
^ self removeFirstLinkOfList: processList!
Item was changed:
----- Method: NewspeakInterpreterSimulator>>classAndSelectorOfMethod:forReceiver: (in category 'debug support') -----
classAndSelectorOfMethod: meth forReceiver: rcvr
| mClass dict length methodArray |
mClass := self fetchClassOf: rcvr.
[dict := self fetchPointer: MethodDictionaryIndex ofObject: mClass.
+ length := self numSlotsOf: dict.
- length := self fetchWordLengthOf: dict.
methodArray := self fetchPointer: MethodArrayIndex ofObject: dict.
0 to: length-SelectorStart-1 do:
[:index |
meth = (self fetchPointer: index ofObject: methodArray)
ifTrue: [^ Array
with: mClass
with: (self fetchPointer: index + SelectorStart ofObject: dict)]].
mClass := self fetchPointer: SuperclassIndex ofObject: mClass.
mClass = nilObj]
whileFalse: [].
^ Array
with: (self fetchClassOf: rcvr)
with: (self splObj: SelectorDoesNotUnderstand)!
Item was changed:
----- Method: ObjectMemory>>badContextSize: (in category 'contexts') -----
badContextSize: oop
+ ^(self numBytesOf: oop) ~= (SmallContextSize-BaseHeaderSize)
+ and: [(self numBytesOf: oop) ~= (LargeContextSize-BaseHeaderSize)]!
- ^(self byteLengthOf: oop) ~= (SmallContextSize-BaseHeaderSize)
- and: [(self byteLengthOf: oop) ~= (LargeContextSize-BaseHeaderSize)]!
Item was removed:
- ----- Method: ObjectMemory>>byteLengthOf: (in category 'indexing primitive support') -----
- byteLengthOf: obj
- "Return the number of indexable bytes in the given object.
- This is basically a special copy of lengthOf: for BitBlt. But it is also
- whoorishly used for the Cogit."
- <api>
- | header sz fmt |
- header := self baseHeader: obj.
- sz := (header bitAnd: TypeMask) = HeaderTypeSizeAndClass
- ifTrue: [(self sizeHeader: obj) bitAnd: AllButTypeMask]
- ifFalse: [header bitAnd: SizeMask].
- fmt := self formatOfHeader: header.
- ^fmt < self firstByteFormat
- ifTrue: [(sz - BaseHeaderSize)] "words"
- ifFalse: [(sz - BaseHeaderSize) - (fmt bitAnd: 3)] "bytes"!
Item was changed:
+ ----- Method: ObjectMemory>>byteSizeOf: (in category 'object access') -----
- ----- Method: ObjectMemory>>byteSizeOf: (in category 'object format') -----
byteSizeOf: oop
<api>
- | header format size |
(self isIntegerObject: oop) ifTrue:[^0].
+ ^self numBytesOf: oop!
- header := self baseHeader: oop.
- format := self formatOfHeader: header.
- size := (header bitAnd: TypeMask) = HeaderTypeSizeAndClass
- ifTrue: [(self sizeHeader: oop) bitAnd: LongSizeMask]
- ifFalse: [header bitAnd: SizeMask].
- size := size - (header bitAnd: Size4Bit).
- ^format < self firstByteFormat
- ifTrue: [ size - BaseHeaderSize "32-bit longs"]
- ifFalse: [ (size - BaseHeaderSize) - (format bitAnd: 3) "bytes"]!
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 > self firstByteFormat 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 < self arrayFormat
ifTrue:
+ [(argClassInstByteSize - BaseHeaderSize) ~= (self numBytesOf: rcvr) ifTrue:
- [(argClassInstByteSize - BaseHeaderSize) ~= (self byteLengthOf: rcvr) ifTrue:
[^PrimErrBadReceiver]]
ifFalse:
[argFormat = self indexablePointersFormat ifTrue: "For indexable plus fixed fields the receiver must be at least big enough."
+ [(argClassInstByteSize - BaseHeaderSize) > (self numBytesOf: rcvr) ifTrue:
- [(argClassInstByteSize - BaseHeaderSize) > (self byteLengthOf: 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 changed:
+ ----- Method: ObjectMemory>>characterObjectOf: (in category 'object access') -----
- ----- Method: ObjectMemory>>characterObjectOf: (in category 'primitive support') -----
characterObjectOf: characterCode
<api>
^(characterCode between: 0 and: 255)
ifTrue: [self fetchPointer: characterCode ofObject: self characterTable]
ifFalse: [nilObj]!
Item was changed:
+ ----- Method: ObjectMemory>>compactClassIndexOf: (in category 'object access') -----
- ----- Method: ObjectMemory>>compactClassIndexOf: (in category 'header access') -----
compactClassIndexOf: oop
<api>
<inline: true>
^((self baseHeader: oop) >> self compactClassFieldLSB) bitAnd: 16r1F!
Item was changed:
+ ----- Method: ObjectMemory>>fetchByte:ofObject: (in category 'object access') -----
- ----- Method: ObjectMemory>>fetchByte:ofObject: (in category 'interpreter access') -----
fetchByte: byteIndex ofObject: oop
<api>
^self byteAt: oop + BaseHeaderSize + byteIndex!
Item was changed:
+ ----- Method: ObjectMemory>>fetchClassOf: (in category 'object access') -----
- ----- Method: ObjectMemory>>fetchClassOf: (in category 'interpreter access') -----
fetchClassOf: oop
| ccIndex |
<inline: true>
<asmLabel: false>
^(self isIntegerObject: oop)
ifTrue: [self splObj: ClassSmallInteger]
ifFalse:
[(ccIndex := (self compactClassIndexOf: oop)) = 0
ifTrue: [(self classHeader: oop) bitAnd: AllButTypeMask]
ifFalse: [self compactClassAt: ccIndex]]!
Item was changed:
+ ----- Method: ObjectMemory>>fetchClassOfNonImm: (in category 'object access') -----
- ----- Method: ObjectMemory>>fetchClassOfNonImm: (in category 'interpreter access') -----
fetchClassOfNonImm: oop
| ccIndex |
<inline: true>
<asmLabel: false>
^(ccIndex := (self compactClassIndexOf: oop)) = 0
ifTrue: [(self classHeader: oop) bitAnd: AllButTypeMask]
ifFalse: [self compactClassAt: ccIndex]!
Item was changed:
+ ----- Method: ObjectMemory>>fetchLong32:ofObject: (in category 'object access') -----
- ----- Method: ObjectMemory>>fetchLong32:ofObject: (in category 'interpreter access') -----
fetchLong32: fieldIndex ofObject: oop
" index by 32-bit units, and return a 32-bit value. Intended to replace fetchWord:ofObject:"
^ self long32At: oop + BaseHeaderSize + (fieldIndex << 2)!
Item was removed:
- ----- Method: ObjectMemory>>fetchLong32LengthOf: (in category 'interpreter access') -----
- fetchLong32LengthOf: objectPointer
- "Gives size appropriate for, eg, fetchLong32"
-
- | sz |
- sz := self sizeBitsOf: objectPointer.
- ^ (sz - BaseHeaderSize) >> 2!
Item was added:
+ ----- Method: ObjectMemory>>fetchLong64:ofObject: (in category 'object access') -----
+ fetchLong64: longIndex ofObject: oop
+ <returnTypeC: #sqLong>
+ ^self long64At: oop + BaseHeaderSize + (8 * (longIndex - 1))!
Item was changed:
+ ----- Method: ObjectMemory>>fetchPointer:ofObject: (in category 'object access') -----
- ----- Method: ObjectMemory>>fetchPointer:ofObject: (in category 'interpreter access') -----
fetchPointer: fieldIndex ofObject: oop
"index by word size, and return a pointer as long as the word size"
<api>
^self longAt: oop + BaseHeaderSize + (fieldIndex << ShiftForWord)!
Item was added:
+ ----- Method: ObjectMemory>>fetchShort16:ofObject: (in category 'object access') -----
+ fetchShort16: shortIndex ofObject: oop
+ ^self shortAt: oop + BaseHeaderSize + (2 * (shortIndex - 1))!
Item was removed:
- ----- Method: ObjectMemory>>fetchWordLengthOf: (in category 'interpreter access') -----
- fetchWordLengthOf: objectPointer
- "NOTE: this gives size appropriate for fetchPointer: n, but not in general for, eg, fetchLong32, etc."
-
- | sz |
- sz := self sizeBitsOf: objectPointer.
- ^ (sz - BaseHeaderSize) >> ShiftForWord!
Item was changed:
+ ----- Method: ObjectMemory>>firstFixedField: (in category 'object access') -----
- ----- Method: ObjectMemory>>firstFixedField: (in category 'object format') -----
firstFixedField: oop
<returnTypeC: #'void *'>
^ self pointerForOop: oop + BaseHeaderSize!
Item was changed:
+ ----- Method: ObjectMemory>>formatOf: (in category 'object access') -----
- ----- Method: ObjectMemory>>formatOf: (in category 'header access') -----
formatOf: oop
" 0 no fields
1 fixed fields only (all containing pointers)
2 indexable fields only (all containing pointers)
3 both fixed and indexable fields (all containing pointers)
4 both fixed and indexable weak fields (all containing pointers).
5 unused (reserved for ephemerons?)
6 indexable word fields only (no pointers)
7 indexable long (64-bit) fields (only in 64-bit images)
8-11 indexable byte fields only (no pointers) (low 2 bits are low 2 bits of size)
12-15 compiled methods:
# of literal oops specified in method header,
followed by indexable bytes (same interpretation of low 2 bits as above)
"
<inline: true>
^((self baseHeader: oop) >> self instFormatFieldLSB) bitAnd: 16rF!
Item was changed:
+ ----- Method: ObjectMemory>>formatOfHeader: (in category 'object access') -----
- ----- Method: ObjectMemory>>formatOfHeader: (in category 'header access') -----
formatOfHeader: header
" 0 no fields
1 fixed fields only (all containing pointers)
2 indexable fields only (all containing pointers)
3 both fixed and indexable fields (all containing pointers)
4 both fixed and indexable weak fields (all containing pointers).
5 unused
6 indexable word fields only (no pointers)
7 indexable long (64-bit) fields (only in 64-bit images)
8-11 indexable byte fields only (no pointers) (low 2 bits are low 2 bits of size)
12-15 compiled methods:
# of literal oops specified in method header,
followed by indexable bytes (same interpretation of low 2 bits as above)
"
<inline: true>
^header >> self instFormatFieldLSB bitAnd: 16rF!
Item was changed:
----- Method: ObjectMemory>>goodContextSize: (in category 'contexts') -----
goodContextSize: oop
+ | numSlots |
+ numSlots := self numSlotsOf: oop.
+ ^numSlots = SmallContextSlots or: [numSlots = LargeContextSlots]!
- ^(self byteLengthOf: oop) = (SmallContextSize-BaseHeaderSize)
- or: [(self byteLengthOf: oop) = (LargeContextSize-BaseHeaderSize)]!
Item was changed:
+ ----- Method: ObjectMemory>>is:instanceOf: (in category 'object access') -----
- ----- Method: ObjectMemory>>is:instanceOf: (in category 'header access') -----
is: oop instanceOf: classOop
"Answer if oop is an instance of the given class. If the class has a (non-zero)
compactClassIndex use that to speed up the check."
<inline: true>
(self isIntegerObject: oop) ifTrue:
[^classOop = (self splObj: ClassSmallInteger)].
^self isClassOfNonImm: oop equalTo: classOop!
Item was changed:
+ ----- Method: ObjectMemory>>is:instanceOf:compactClassIndex: (in category 'object access') -----
- ----- Method: ObjectMemory>>is:instanceOf:compactClassIndex: (in category 'header access') -----
is: oop instanceOf: classOop compactClassIndex: compactClassIndex
"Answer if oop is an instance of the given class. If the class has a (non-zero)
compactClassIndex use that to speed up the check. N.B. Inlining should
result in classOop not being accessed if oop's compact class index and
compactClassIndex are non-zero."
<inline: true>
(self isIntegerObject: oop) ifTrue:
[^false].
^self isClassOfNonImm: oop equalTo: classOop compactClassIndex: compactClassIndex!
Item was changed:
+ ----- Method: ObjectMemory>>isClassOfNonImm:equalTo:compactClassIndex: (in category 'object access') -----
- ----- Method: ObjectMemory>>isClassOfNonImm:equalTo:compactClassIndex: (in category 'header access') -----
isClassOfNonImm: oop equalTo: classOop compactClassIndex: compactClassIndex
"Answer if the given (non-immediate) object is an instance of the given class
that may have a compactClassIndex (if compactClassIndex is non-zero).
N.B. Inlining and/or compiler optimization should result in classOop not being
accessed if oop's compact class index and compactClassIndex are non-zero.
N.B. Generally one cannot assume that if compactClassIndex is non-zero the
instances of the corresponding class always have the compactClassIndex
because the compact class index is only non-zero in short header instances."
| ccIndex |
<inline: true>
<asmLabel: false>
self assert: (self isIntegerObject: oop) not.
ccIndex := self compactClassIndexOf: oop.
ccIndex = 0 ifTrue:
[^((self classHeader: oop) bitAnd: AllButTypeMask) = classOop].
compactClassIndex ~= 0 ifTrue:
[^compactClassIndex = ccIndex].
^classOop = (self compactClassAt: ccIndex)!
Item was changed:
+ ----- Method: ObjectMemory>>lengthOf: (in category 'object access') -----
- ----- Method: ObjectMemory>>lengthOf: (in category 'indexing primitive support') -----
lengthOf: oop
"Return the number of indexable bytes or words in the given object. Assume the argument is not an integer. For a CompiledMethod, the size of the method header (in bytes) should be subtracted from the result."
<api>
| header |
<inline: true>
<asmLabel: false>
header := self baseHeader: oop.
^self lengthOf: oop baseHeader: header format: (self formatOfHeader: header)!
Item was changed:
+ ----- Method: ObjectMemory>>lengthOf:baseHeader:format: (in category 'object access') -----
- ----- Method: ObjectMemory>>lengthOf:baseHeader:format: (in category 'indexing primitive support') -----
lengthOf: oop baseHeader: hdr format: fmt
"Return the number of fixed and indexable bytes, words, or object pointers in the
given object. Assume the given oop is not an integer. For a CompiledMethod, the size
of the method header (in bytes) should be subtracted from the result of this method."
| sz |
<inline: true>
<asmLabel: false>
(hdr bitAnd: TypeMask) = HeaderTypeSizeAndClass
ifTrue: [ sz := (self sizeHeader: oop) bitAnd: LongSizeMask ]
ifFalse: [ sz := (hdr bitAnd: SizeMask)].
sz := sz - (hdr bitAnd: Size4Bit).
fmt <= self lastPointerFormat
ifTrue: [ ^ (sz - BaseHeaderSize) >> ShiftForWord "words"].
^fmt < self firstByteFormat
ifTrue: [(sz - BaseHeaderSize) >> 2 "32-bit longs"]
ifFalse: [(sz - BaseHeaderSize) - (fmt bitAnd: 3) "bytes"]!
Item was added:
+ ----- Method: ObjectMemory>>num16BitUnitsOf: (in category 'object access') -----
+ num16BitUnitsOf: objOop
+ "Answer the number of 16-bit units in the given non-immediate object.
+ N..B. Rounds down 8-bit units, so a 5 byte object has 2 16-bit units.
+ Does not adjust the size of contexts by stackPointer."
+ ^(self numBytesOf: objOop) >> 1!
Item was added:
+ ----- Method: ObjectMemory>>num32BitUnitsOf: (in category 'object access') -----
+ num32BitUnitsOf: objOop
+ "Answer the number of 16-bit units in the given non-immediate object.
+ N..B. Rounds down 8-bit units, so a 7 byte object has 1 32-bit unit.
+ Does not adjust the size of contexts by stackPointer."
+ ^(self numBytesOf: objOop) >> 2!
Item was added:
+ ----- Method: ObjectMemory>>num64BitUnitsOf: (in category 'object access') -----
+ num64BitUnitsOf: objOop
+ "Answer the number of 16-bit units in the given non-immediate object.
+ N..B. Rounds down 8-bit units, so a 15 byte object has 1 64-bit unit.
+ Does not adjust the size of contexts by stackPointer."
+ ^(self numBytesOf: objOop) >> 3!
Item was added:
+ ----- Method: ObjectMemory>>numBytesOf: (in category 'object access') -----
+ numBytesOf: objOop
+ "Answer the number of indexable bytes in the given non-immediate object.
+ Does not adjust the size of contexts by stackPointer."
+ <api>
+ | header sz fmt |
+ header := self baseHeader: objOop.
+ sz := (header bitAnd: TypeMask) = HeaderTypeSizeAndClass
+ ifTrue: [(self sizeHeader: objOop) bitAnd: AllButTypeMask]
+ ifFalse: [header bitAnd: SizeMask].
+ fmt := self formatOfHeader: header.
+ ^fmt < self firstByteFormat
+ ifTrue: [(sz - BaseHeaderSize)] "words"
+ ifFalse: [(sz - BaseHeaderSize) - (fmt bitAnd: 3)] "bytes"!
Item was added:
+ ----- Method: ObjectMemory>>numSlotsOf: (in category 'object access') -----
+ numSlotsOf: obj
+ "Answer the number of oop-sized elements in the given object.
+ Unlike lengthOf: this does not adjust the length of a context
+ by the stackPointer and so can be used e.g. by cloneContext:"
+ <api>
+ | header sz |
+ header := self baseHeader: obj.
+ sz := (header bitAnd: TypeMask) = HeaderTypeSizeAndClass
+ ifTrue: [(self sizeHeader: obj) bitAnd: AllButTypeMask]
+ ifFalse: [header bitAnd: SizeMask].
+ ^sz - BaseHeaderSize >> ShiftForWord!
Item was changed:
----- 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 isContextNonImm: oop)
and: [self badContextSize: oop]) ifTrue:
+ [self printHex: oop; space; printNum: (self numBytesOf: oop); cr].
- [self printHex: oop; space; printNum: (self byteLengthOf: oop); cr].
oop := self accessibleObjectAfter: oop]!
Item was changed:
+ ----- Method: ObjectMemory>>sizeBitsOf: (in category 'object access') -----
- ----- Method: ObjectMemory>>sizeBitsOf: (in category 'header access') -----
sizeBitsOf: oop
"Answer the number of bytes in the given object, including its base header, rounded up to an integral number of words."
"Note: byte indexable objects need to have low bits subtracted from this size."
| header |
header := self baseHeader: oop.
(header bitAnd: TypeMask) = HeaderTypeSizeAndClass
ifTrue: [ ^ (self sizeHeader: oop) bitAnd: LongSizeMask ]
ifFalse: [ ^ header bitAnd: SizeMask ].!
Item was changed:
+ ----- Method: ObjectMemory>>sizeBitsOfSafe: (in category 'object access') -----
- ----- Method: ObjectMemory>>sizeBitsOfSafe: (in category 'header access') -----
sizeBitsOfSafe: oop
"Compute the size of the given object from the cc and size fields in its header. This works even if its type bits are not correct."
| header type |
header := self baseHeader: oop.
type := self rightType: header.
type = HeaderTypeSizeAndClass
ifTrue: [ ^ (self sizeHeader: oop) bitAnd: AllButTypeMask ]
ifFalse: [ ^ header bitAnd: SizeMask ].!
Item was changed:
+ ----- Method: ObjectMemory>>slotSizeOf: (in category 'object access') -----
- ----- Method: ObjectMemory>>slotSizeOf: (in category 'object format') -----
slotSizeOf: oop
"Returns the number of slots in the receiver.
If the receiver is a byte object, return the number of bytes.
Otherwise return the number of words."
(self isIntegerObject: oop) ifTrue:[^0].
^self lengthOf: oop!
Item was changed:
+ ----- Method: ObjectMemory>>storeByte:ofObject:withValue: (in category 'object access') -----
- ----- Method: ObjectMemory>>storeByte:ofObject:withValue: (in category 'interpreter access') -----
storeByte: byteIndex ofObject: oop withValue: valueByte
^ self byteAt: oop + BaseHeaderSize + byteIndex
put: valueByte!
Item was changed:
+ ----- Method: ObjectMemory>>storeLong32:ofObject:withValue: (in category 'object access') -----
- ----- Method: ObjectMemory>>storeLong32:ofObject:withValue: (in category 'interpreter access') -----
storeLong32: fieldIndex ofObject: oop withValue: valueWord
^ self long32At: oop + BaseHeaderSize + (fieldIndex << 2)
put: valueWord!
Item was added:
+ ----- Method: ObjectMemory>>storeLong64:ofObject:withValue: (in category 'object access') -----
+ storeLong64: longIndex ofObject: oop withValue: value
+ <var: #value type: #sqLong>
+ ^self long64At: oop + BaseHeaderSize + (8 * (longIndex - 1)) put: value!
Item was changed:
+ ----- Method: ObjectMemory>>storePointer:ofObject:withValue: (in category 'object access') -----
- ----- Method: ObjectMemory>>storePointer:ofObject:withValue: (in category 'interpreter access') -----
storePointer: fieldIndex ofObject: oop withValue: valuePointer
"Note must check here for stores of young objects into old ones."
(self oop: oop isLessThan: youngStart) ifTrue: [
self possibleRootStoreInto: oop value: valuePointer.
].
^ self longAt: oop + BaseHeaderSize + (fieldIndex << ShiftForWord)
put: valuePointer!
Item was changed:
+ ----- Method: ObjectMemory>>storePointerUnchecked:ofObject:withValue: (in category 'object access') -----
- ----- Method: ObjectMemory>>storePointerUnchecked:ofObject:withValue: (in category 'interpreter access') -----
storePointerUnchecked: fieldIndex ofObject: oop withValue: valuePointer
"Like storePointer:ofObject:withValue:, but the caller guarantees that the
object being stored into is a young object or is already marked as a root."
<api>
<inline: true>
^self
longAt: oop + BaseHeaderSize + (fieldIndex << ShiftForWord)
put: valuePointer!
Item was added:
+ ----- Method: ObjectMemory>>storeShort16:ofObject:withValue: (in category 'object access') -----
+ storeShort16: shortIndex ofObject: oop withValue: value
+ ^self shortAt: oop + BaseHeaderSize + (2 * (shortIndex - 1)) put: value!
Item was changed:
----- Method: Spur32BitMemoryManager>>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 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."
<inline: false>
| classFormat fixedFields instFormat normalizedInstFormat newFormat classIndex |
classFormat := self formatOfClass: argClass.
fixedFields := self fixedFieldsOfClassFormat: classFormat.
classFormat := self instSpecOfClassFormat: classFormat.
instFormat := self formatOf: rcvr.
normalizedInstFormat := self classFormatForInstanceFormat: instFormat.
(normalizedInstFormat > self lastPointerFormat
and: [normalizedInstFormat = classFormat])
ifTrue: [newFormat := instFormat]
ifFalse:
[normalizedInstFormat <= self lastPointerFormat
ifTrue:
[classFormat > self lastPointerFormat ifTrue:
[^PrimErrInappropriate].
(self numSlotsOf: rcvr) < fixedFields ifTrue:
[^PrimErrBadReceiver].
newFormat := classFormat]
ifFalse:
[| instBytes |
+ instBytes := self numBytesOf: rcvr.
- instBytes := self byteLengthOf: rcvr.
normalizedInstFormat caseOf: {
[self sixtyFourBitIndexableFormat] ->
[(classFormat < self sixtyFourBitIndexableFormat
or: [classFormat >= self firstCompiledMethodFormat]) ifTrue:
[^PrimErrInappropriate].
newFormat := classFormat].
[self firstLongFormat] ->
[(classFormat < self sixtyFourBitIndexableFormat
or: [classFormat >= self firstCompiledMethodFormat]) ifTrue:
[^PrimErrInappropriate].
(classFormat = self sixtyFourBitIndexableFormat and: [instBytes anyMask: 1]) ifTrue:
[^PrimErrBadReceiver].
newFormat := classFormat].
[self firstShortFormat] ->
[(classFormat < self sixtyFourBitIndexableFormat
or: [classFormat >= self firstCompiledMethodFormat]) ifTrue:
[^PrimErrInappropriate].
classFormat caseOf: {
[self sixtyFourBitIndexableFormat]
-> [(instBytes anyMask: 3) ifTrue: [^PrimErrBadReceiver].
newFormat := classFormat].
[self firstLongFormat]
-> [(instBytes anyMask: 1) ifTrue: [^PrimErrBadReceiver].
newFormat := classFormat].
[self firstByteFormat]
-> [newFormat := classFormat + (4 - instBytes bitAnd: 3)] }].
[self firstByteFormat] ->
[(classFormat < self sixtyFourBitIndexableFormat
or: [classFormat >= self firstCompiledMethodFormat]) ifTrue:
[^PrimErrInappropriate].
classFormat caseOf: {
[self sixtyFourBitIndexableFormat]
-> [(instBytes anyMask: 7) ifTrue: [^PrimErrBadReceiver]].
[self firstLongFormat]
-> [(instBytes anyMask: 3) ifTrue: [^PrimErrBadReceiver]].
[self firstShortFormat]
-> [(instBytes anyMask: 1) ifTrue: [^PrimErrBadReceiver]] }.
newFormat := classFormat].
[self firstCompiledMethodFormat] ->
[classFormat ~= self firstCompiledMethodFormat ifTrue:
[^PrimErrInappropriate].
newFormat := instFormat] }]].
(classIndex := self ensureBehaviorHash: argClass) < 0 ifTrue:
[^classIndex negated].
self set: rcvr classIndexTo: classIndex formatTo: newFormat.
"ok"
^0!
Item was changed:
----- Method: Spur64BitMemoryManager>>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 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."
<inline: false>
| classFormat fixedFields instFormat normalizedInstFormat newFormat classIndex |
classFormat := self formatOfClass: argClass.
fixedFields := self fixedFieldsOfClassFormat: classFormat.
classFormat := self instSpecOfClassFormat: classFormat.
instFormat := self formatOf: rcvr.
normalizedInstFormat := self classFormatForInstanceFormat: instFormat.
(normalizedInstFormat > self lastPointerFormat
and: [normalizedInstFormat = classFormat])
ifTrue: [newFormat := instFormat]
ifFalse:
[normalizedInstFormat <= self lastPointerFormat
ifTrue:
[classFormat > self lastPointerFormat ifTrue:
[^PrimErrInappropriate].
(self numSlotsOf: rcvr) < fixedFields ifTrue:
[^PrimErrBadReceiver].
newFormat := classFormat]
ifFalse:
[| instBytes |
+ instBytes := self numBytesOf: rcvr.
- instBytes := self byteLengthOf: rcvr.
normalizedInstFormat caseOf: {
[self sixtyFourBitIndexableFormat] ->
[(classFormat < self sixtyFourBitIndexableFormat
or: [classFormat >= self firstCompiledMethodFormat]) ifTrue:
[^PrimErrInappropriate].
newFormat := classFormat].
[self firstLongFormat] ->
[(classFormat < self sixtyFourBitIndexableFormat
or: [classFormat >= self firstCompiledMethodFormat]) ifTrue:
[^PrimErrInappropriate].
(classFormat = self sixtyFourBitIndexableFormat and: [instBytes anyMask: 1]) ifTrue:
[^PrimErrBadReceiver].
newFormat := classFormat].
[self firstShortFormat] ->
[(classFormat < self sixtyFourBitIndexableFormat
or: [classFormat >= self firstCompiledMethodFormat]) ifTrue:
[^PrimErrInappropriate].
classFormat caseOf: {
[self sixtyFourBitIndexableFormat]
-> [(instBytes anyMask: 7) ifTrue: [^PrimErrBadReceiver].
newFormat := classFormat].
[self firstLongFormat]
-> [(instBytes anyMask: 3) ifTrue: [^PrimErrBadReceiver].
newFormat := classFormat + (2 - instBytes bitAnd: 1)].
[self firstByteFormat]
-> [newFormat := classFormat + (8 - instBytes bitAnd: 7)] }].
[self firstByteFormat] ->
[(classFormat < self sixtyFourBitIndexableFormat
or: [classFormat >= self firstCompiledMethodFormat]) ifTrue:
[^PrimErrInappropriate].
classFormat caseOf: {
[self sixtyFourBitIndexableFormat]
-> [(instBytes anyMask: 7) ifTrue: [^PrimErrBadReceiver].
newFormat := classFormat].
[self firstLongFormat]
-> [(instBytes anyMask: 3) ifTrue: [^PrimErrBadReceiver].
newFormat := classFormat + (2 - instBytes bitAnd: 1)].
[self firstShortFormat]
-> [(instBytes anyMask: 1) ifTrue: [^PrimErrBadReceiver].
newFormat := classFormat + (4 - instBytes bitAnd: 3)] }.
newFormat := classFormat].
[self firstCompiledMethodFormat] ->
[classFormat ~= self firstCompiledMethodFormat ifTrue:
[^PrimErrInappropriate].
newFormat := instFormat] }]].
(classIndex := self ensureBehaviorHash: argClass) < 0 ifTrue:
[^classIndex negated].
self set: rcvr classIndexTo: classIndex formatTo: newFormat.
"ok"
^0!
Item was removed:
- ----- Method: SpurMemoryManager>>byteLengthOf: (in category 'object access') -----
- byteLengthOf: objOop
- "Answer the number of indexable bytes in the given object.
- Does not adjust contexts by stackPointer.
- This is basically a special copy of lengthOf: for BitBlt. But it is also
- whoorishly used for the Cogit."
- <api>
- | fmt numBytes |
- <inline: true>
- <asmLabel: false>
- fmt := self formatOf: objOop.
- numBytes := (self numSlotsOf: objOop) << self shiftForWord.
- fmt <= self sixtyFourBitIndexableFormat ifTrue:
- [^numBytes].
- fmt >= self firstByteFormat ifTrue: "bytes, including CompiledMethod"
- [^numBytes - (fmt bitAnd: 7)].
- fmt >= self firstShortFormat ifTrue:
- [^numBytes - ((fmt bitAnd: 3) << 1)].
- "fmt >= self firstLongFormat"
- ^numBytes - ((fmt bitAnd: 1) << 2)!
Item was changed:
----- Method: SpurMemoryManager>>byteSizeOf: (in category 'object access') -----
byteSizeOf: oop
<api>
- | format |
(self isImmediate: oop) ifTrue: [^0].
+ ^self numBytesOf: oop!
- format := self formatOf: oop.
- format < self sixtyFourBitIndexableFormat ifTrue:
- [^(self numSlotsOf: oop) << self shiftForWord].
- format >= self firstByteFormat ifTrue:
- [^(self numSlotsOf: oop) << self shiftForWord - (format bitAnd: 7)].
- format >= self firstShortFormat ifTrue:
- [^(self numSlotsOf: oop) << self shiftForWord - ((format bitAnd: 3) << 1)].
- format >= self firstLongFormat ifTrue:
- [^(self numSlotsOf: oop) << self shiftForWord - ((format bitAnd: 1) << 2)].
- ^(self numSlotsOf: oop) << self shiftForWord!
Item was added:
+ ----- Method: SpurMemoryManager>>fetchLong64:ofObject: (in category 'object access') -----
+ fetchLong64: longIndex ofObject: objOop
+ <returnTypeC: #sqLong>
+ ^self long64At: objOop + self baseHeaderSize + (8 * (longIndex - 1))!
Item was added:
+ ----- Method: SpurMemoryManager>>fetchShort16:ofObject: (in category 'object access') -----
+ fetchShort16: shortIndex ofObject: objOop
+ ^self shortAt: objOop + self baseHeaderSize + (2 * (shortIndex - 1))!
Item was removed:
- ----- Method: SpurMemoryManager>>fetchWordLengthOf: (in category 'object access') -----
- fetchWordLengthOf: objOop
- "NOTE: this gives size appropriate for fetchPointer: n, but not in general for, eg, fetchLong32, etc.
- Unlike lengthOf: this does not adjust the length of a context
- by the stackPointer and so can be used e.g. by cloneContext:"
- ^self numSlotsOf: objOop!
Item was added:
+ ----- Method: SpurMemoryManager>>num16BitUnitsOf: (in category 'object access') -----
+ num16BitUnitsOf: objOop
+ "Answer the number of 16-bit units in the given non-immediate object.
+ N..B. Rounds down 8-bit units, so a 5 byte object has 2 16-bit units.
+ Does not adjust the size of contexts by stackPointer."
+ ^(self numBytesOf: objOop) >> 1!
Item was added:
+ ----- Method: SpurMemoryManager>>num32BitUnitsOf: (in category 'object access') -----
+ num32BitUnitsOf: objOop
+ "Answer the number of 16-bit units in the given non-immediate object.
+ N..B. Rounds down 8-bit units, so a 7 byte object has 1 32-bit unit.
+ Does not adjust the size of contexts by stackPointer."
+ ^(self numBytesOf: objOop) >> 2!
Item was added:
+ ----- Method: SpurMemoryManager>>num64BitUnitsOf: (in category 'object access') -----
+ num64BitUnitsOf: objOop
+ "Answer the number of 16-bit units in the given non-immediate object.
+ N..B. Rounds down 8-bit units, so a 15 byte object has 1 64-bit unit.
+ Does not adjust the size of contexts by stackPointer."
+ ^(self numBytesOf: objOop) >> 3!
Item was added:
+ ----- Method: SpurMemoryManager>>numBytesOf: (in category 'object access') -----
+ numBytesOf: objOop
+ "Answer the number of indexable bytes in the given non-immediate object.
+ Does not adjust the size of contexts by stackPointer."
+ <api>
+ | fmt numBytes |
+ <inline: true>
+ <asmLabel: false>
+ fmt := self formatOf: objOop.
+ numBytes := self numSlotsOf: objOop.
+ numBytes := numBytes << self shiftForWord.
+ fmt <= self sixtyFourBitIndexableFormat ifTrue:
+ [^numBytes].
+ fmt >= self firstByteFormat ifTrue: "bytes, including CompiledMethod"
+ [^numBytes - (fmt bitAnd: 7)].
+ fmt >= self firstShortFormat ifTrue:
+ [^numBytes - ((fmt bitAnd: 3) << 1)].
+ "fmt >= self firstLongFormat"
+ ^numBytes - ((fmt bitAnd: 1) << 2)!
Item was added:
+ ----- Method: SpurMemoryManager>>storeLong64:ofObject:withValue: (in category 'object access') -----
+ storeLong64: longIndex ofObject: objOop withValue: value
+ <var: #value type: #sqLong>
+ ^self long64At: objOop + self baseHeaderSize + (8 * (longIndex - 1)) put: value!
Item was added:
+ ----- Method: SpurMemoryManager>>storeShort16:ofObject:withValue: (in category 'object access') -----
+ storeShort16: shortIndex ofObject: objOop withValue: value
+ ^self shortAt: objOop + self baseHeaderSize + (2 * (shortIndex - 1)) put: value!
Item was added:
+ ----- Method: SpurMemoryManager>>unpinObject: (in category 'primitive support') -----
+ unpinObject: objOop
+ self assert: (self isNonImmediate: objOop).
+ self setIsPinnedOf: objOop to: false.
+ ^0!
Item was changed:
----- Method: StackInterpreter>>callPrimitiveBytecode (in category 'miscellaneous bytecodes') -----
callPrimitiveBytecode
+ "V4: 249 11111001 i i i i i i i i jjjjjjjj Call Primitive #iiiiiiii + (jjjjjjjj * 256)
+ SistaV1: 248 11111000 iiiiiiii mjjjjjjj Call Primitive #iiiiiiii + (jjjjjjj * 256) m=1 means inlined primitive, no hard return after execution."
+ self cppIf: SistaVM
+ ifTrue:
+ [| byte1 byte2 |
+ byte1 := self fetchByte.
+ byte2 := self fetchByte.
+ self fetchNextBytecode.
+ byte2 > 127
+ ifTrue:
+ [self inlinePrimitiveBytecode: (byte2 bitAnd: 16r7F) << 8 + byte1]
+ ifFalse:
+ [self error: 'non-inlined callPrimitiveBytecode should not be evaluated. method activation should step beyond this bytecode.']]
+ ifFalse:
+ [self error: 'callPrimitiveBytecode should not be evaluated. method activation should step beyond this bytecode.']
+
- "249 11111001 i i i i i i i i jjjjjjjj Call Primitive #iiiiiiii + (jjjjjjjj * 256)"
- self error: 'should not be evaluated. method activation should step beyond this bytecode.'
"We could make it a noop and not skip it in {foo}ActivateMethod, as in:
localIP := localIP + 3.
self fetchNextBytecode
But for now, having {foo}ActivateMethod skip it makes it available for invoking embedded primitives."!
Item was changed:
----- Method: StackInterpreter>>closureIn:numArgs:instructionPointer:copiedValues: (in category 'control primitives') -----
closureIn: context numArgs: numArgs instructionPointer: initialIP copiedValues: copiedValues
| newClosure numCopied |
<inline: true>
"numCopied should be zero for nil"
+ numCopied := objectMemory numSlotsOf: copiedValues.
- numCopied := objectMemory fetchWordLengthOf: copiedValues.
ClassBlockClosureCompactIndex ~= 0
ifTrue:
[newClosure := objectMemory
eeInstantiateSmallClassIndex: ClassBlockClosureCompactIndex
format: objectMemory indexablePointersFormat
numSlots: ClosureFirstCopiedValueIndex + numCopied]
ifFalse:
[newClosure := objectMemory
eeInstantiateSmallClass: (objectMemory splObj: ClassBlockClosure)
numSlots: ClosureFirstCopiedValueIndex + numCopied].
"Assume: have just allocated a new closure; it must be young. Thus, can use unchecked stores."
objectMemory
storePointerUnchecked: ClosureOuterContextIndex ofObject: newClosure withValue: context;
storePointerUnchecked: ClosureStartPCIndex ofObject: newClosure withValue: (objectMemory integerObjectOf: initialIP);
storePointerUnchecked: ClosureNumArgsIndex ofObject: newClosure withValue: (objectMemory integerObjectOf: numArgs).
0 to: numCopied - 1 do:
[:i|
objectMemory storePointerUnchecked: i + ClosureFirstCopiedValueIndex
ofObject: newClosure
withValue: (objectMemory fetchPointer: i ofObject: copiedValues)].
^newClosure!
Item was changed:
----- Method: StackInterpreter>>copiedValueCountOfClosure: (in category 'internal interpreter access') -----
copiedValueCountOfClosure: closurePointer
<api> "for Cogit"
+ ^(objectMemory numSlotsOf: closurePointer) - ClosureFirstCopiedValueIndex!
- ^(objectMemory fetchWordLengthOf: closurePointer) - ClosureFirstCopiedValueIndex!
Item was changed:
----- Method: StackInterpreter>>findClassContainingMethod:startingAt: (in category 'debug support') -----
findClassContainingMethod: meth startingAt: classObj
| currClass classDict classDictSize methodArray i |
currClass := classObj.
[self assert: (objectMemory isForwarded: currClass) not.
classDict := objectMemory fetchPointer: MethodDictionaryIndex ofObject: currClass.
self assert: (objectMemory isForwarded: classDict) not.
+ classDictSize := objectMemory numSlotsOf: classDict.
- classDictSize := objectMemory fetchWordLengthOf: classDict.
methodArray := objectMemory fetchPointer: MethodArrayIndex ofObject: classDict.
self assert: (objectMemory isForwarded: methodArray) not.
i := 0.
[i < (classDictSize - SelectorStart)] whileTrue:
[meth = (objectMemory fetchPointer: i ofObject: methodArray) ifTrue:
[^currClass].
i := i + 1].
currClass := self superclassOf: currClass.
currClass = objectMemory nilObject] whileFalse.
^currClass "method not found in superclass chain"!
Item was changed:
----- Method: StackInterpreter>>findClassForSelector:lookupClass:do: (in category 'debug support') -----
findClassForSelector: aSelector lookupClass: startClass do: unaryBlock
"Search startClass' class hierarchy looking for aSelector and if found, evaluate unaryBlock
with the class where the selector is found. Otherwise evaluate unaryBlock with nil."
| currClass classDict classDictSize i |
currClass := startClass.
[classDict := objectMemory fetchPointer: MethodDictionaryIndex ofObject: currClass.
+ classDictSize := objectMemory numSlotsOf: classDict.
- classDictSize := objectMemory fetchWordLengthOf: classDict.
i := SelectorStart.
[i < classDictSize] whileTrue:
[aSelector = (objectMemory fetchPointer: i ofObject: classDict) ifTrue:
[^unaryBlock value: currClass].
i := i + 1].
currClass := self superclassOf: currClass.
currClass = objectMemory nilObject] whileFalse.
^unaryBlock value: nil "selector not found in superclass chain"
!
Item was changed:
----- Method: StackInterpreter>>findSelectorAndClassForMethod:lookupClass:do: (in category 'debug support') -----
findSelectorAndClassForMethod: meth lookupClass: startClass do: binaryBlock
"Search startClass' class hierarchy searching for method and if found, evaluate aBinaryBlock
with the selector and class where the method is found. Otherwise evaluate aBinaryBlock
with doesNotUnderstand: and nil."
| currClass classDict classDictSize methodArray i |
currClass := startClass.
[classDict := objectMemory fetchPointer: MethodDictionaryIndex ofObject: currClass.
+ classDictSize := objectMemory numSlotsOf: classDict.
- classDictSize := objectMemory fetchWordLengthOf: classDict.
methodArray := objectMemory fetchPointer: MethodArrayIndex ofObject: classDict.
i := 0.
[i <= (classDictSize - SelectorStart)] whileTrue:
[meth = (objectMemory fetchPointer: i ofObject: methodArray) ifTrue:
[^binaryBlock
value: (objectMemory fetchPointer: i + SelectorStart ofObject: classDict)
value: currClass].
i := i + 1].
currClass := self superclassOf: currClass.
currClass = objectMemory nilObject] whileFalse.
^binaryBlock "method not found in superclass chain"
value: (objectMemory splObj: SelectorDoesNotUnderstand)
value: nil!
Item was changed:
----- Method: StackInterpreter>>findSelectorOfMethod: (in category 'debug support') -----
findSelectorOfMethod: methArg
| meth classObj classDict classDictSize methodArray i |
(objectMemory addressCouldBeObj: methArg) ifFalse:
[^objectMemory nilObject].
(objectMemory isForwarded: methArg)
ifTrue: [meth := objectMemory followForwarded: methArg]
ifFalse: [meth := methArg].
(objectMemory isOopCompiledMethod: meth) ifFalse:
[^objectMemory nilObject].
classObj := self methodClassOf: meth.
(self addressCouldBeClassObj: classObj) ifTrue:
[classDict := objectMemory fetchPointer: MethodDictionaryIndex ofObject: classObj.
+ classDictSize := objectMemory numSlotsOf: classDict.
- classDictSize := objectMemory fetchWordLengthOf: classDict.
methodArray := objectMemory fetchPointer: MethodArrayIndex ofObject: classDict.
i := 0.
[i < (classDictSize - SelectorStart)] whileTrue:
[meth = (objectMemory fetchPointer: i ofObject: methodArray) ifTrue:
[^(objectMemory fetchPointer: i + SelectorStart ofObject: classDict)].
i := i + 1]].
^objectMemory nilObject!
Item was changed:
----- Method: StackInterpreter>>highestPriorityProcess (in category 'process primitive support') -----
highestPriorityProcess
"Answer the highest priority process that is ready to run, but
unlike wakeHighestPriority do not remove it from the list.
To save time looking at many empty lists before finding a
runnable process the VM maintains a variable holding the
highest priority runnable process. If this variable is 0 then the
VM does not know the highest priority and must search all lists.
Note: It is a fatal VM error if there is no runnable process."
| schedLists p processList processOrNil |
<inline: false>
schedLists := objectMemory fetchPointer: ProcessListsIndex ofObject: self schedulerPointer.
p := highestRunnableProcessPriority = 0
+ ifTrue: [objectMemory numSlotsOf: schedLists]
- ifTrue: [objectMemory fetchWordLengthOf: schedLists]
ifFalse: [highestRunnableProcessPriority].
p := p - 1.
"index of last indexable field"
[processList := objectMemory fetchPointer: p ofObject: schedLists.
processOrNil := objectMemory fetchPointer: FirstLinkIndex ofObject: processList.
processOrNil = objectMemory nilObject] whileTrue:
[(p := p - 1) < 0 ifTrue:
[^nil]].
highestRunnableProcessPriority := p + 1.
^processOrNil!
Item was added:
+ ----- Method: StackInterpreter>>inlinePrimitiveBytecode: (in category 'miscellaneous bytecodes') -----
+ inlinePrimitiveBytecode: primIndex
+ "SistaV1: 248 11111000 iiiiiiii mjjjjjjj Call Primitive #iiiiiiii + (jjjjjjj * 256) m=1 means inlined primitive, no hard return after execution."
+ <option: #SistaVM>
+ | result result64 |
+ primIndex caseOf: {
+ "0 unchecked SmallInteger #+. Both arguments are SmallIntegers and the result fits in a SmallInteger (* depends on word size)"
+ [0] -> [result := objectMemory integerObjectOf: ((objectMemory integerValueOf: self internalStackTop)
+ + (objectMemory integerValueOf: (self internalStackValue: 1))).
+ self internalPop: 1; internalStackTopPut: result].
+ "1 unchecked SmallInteger #-. Both arguments are SmallIntegers and the result fits in a SmallInteger (* depends on word size)"
+ [1] -> [result := objectMemory integerObjectOf: ((objectMemory integerValueOf: self internalStackTop)
+ - (objectMemory integerValueOf: (self internalStackValue: 1))).
+ self internalPop: 1; internalStackTopPut: result].
+ "2 unchecked SmallInteger #*. Both arguments are SmallIntegers and the result fits in a SmallInteger (* depends on word size)"
+ [2] -> [result := objectMemory integerObjectOf: ((objectMemory integerValueOf: self internalStackTop)
+ * (objectMemory integerValueOf: (self internalStackValue: 1))).
+ self internalPop: 1; internalStackTopPut: result].
+ "3 unchecked SmallInteger #/. Both arguments are SmallIntegers and the result fits in a SmallInteger (* depends on word size)"
+ [3] -> [result := objectMemory integerObjectOf: ((objectMemory integerValueOf: self internalStackTop)
+ / (objectMemory integerValueOf: (self internalStackValue: 1))).
+ self internalPop: 1; internalStackTopPut: result].
+ "4 unchecked SmallInteger #//. Both arguments are SmallIntegers and the result fits in a SmallInteger (* depends on word size)"
+ [4] -> [result := objectMemory integerObjectOf: ((objectMemory integerValueOf: self internalStackTop)
+ // (objectMemory integerValueOf: (self internalStackValue: 1))).
+ self internalPop: 1; internalStackTopPut: result].
+ "5 unchecked SmallInteger #\\. Both arguments are SmallIntegers and the result fits in a SmallInteger (* depends on word size)"
+ [5] -> [result := objectMemory integerObjectOf: ((objectMemory integerValueOf: self internalStackTop)
+ \\ (objectMemory integerValueOf: (self internalStackValue: 1))).
+ self internalPop: 1; internalStackTopPut: result].
+ "6 unchecked SmallInteger #quo:. Both arguments are SmallIntegers and the result fits in a SmallInteger (* depends on word size)"
+ [6] -> [result := objectMemory integerObjectOf: ((objectMemory integerValueOf: self internalStackTop)
+ quo: (objectMemory integerValueOf: (self internalStackValue: 1))).
+ self internalPop: 1; internalStackTopPut: result].
+
+ "16 unchecked SmallInteger #bitAnd:. Both arguments are SmallIntegers and the result fits in a SmallInteger (* depends on word size)"
+ [16] -> [result := objectMemory integerObjectOf: ((objectMemory integerValueOf: self internalStackTop)
+ bitAnd: (objectMemory integerValueOf: (self internalStackValue: 1))).
+ self internalPop: 1; internalStackTopPut: result].
+ "17 unchecked SmallInteger #bitOr:. Both arguments are SmallIntegers and the result fits in a SmallInteger (* depends on word size)"
+ [17] -> [result := objectMemory integerObjectOf: ((objectMemory integerValueOf: self internalStackTop)
+ bitOr: (objectMemory integerValueOf: (self internalStackValue: 1))).
+ self internalPop: 1; internalStackTopPut: result].
+ "18 unchecked SmallInteger #bitXor:. Both arguments are SmallIntegers and the result fits in a SmallInteger (* depends on word size)"
+ [18] -> [result := objectMemory integerObjectOf: ((objectMemory integerValueOf: self internalStackTop)
+ bitXor: (objectMemory integerValueOf: (self internalStackValue: 1))).
+ self internalPop: 1; internalStackTopPut: result].
+ "19 unchecked SmallInteger #bitShift:. Both arguments are SmallIntegers and the result fits in a SmallInteger (* depends on word size)"
+ [19] -> [result := objectMemory integerObjectOf: ((objectMemory integerValueOf: self internalStackTop)
+ bitShift: (objectMemory integerValueOf: (self internalStackValue: 1))).
+ self internalPop: 1; internalStackTopPut: result].
+
+ "32 unchecked SmallInteger #>. Both arguments are SmallIntegers"
+ [32] -> [result := objectMemory booleanObjectOf: (self internalStackTop > (self internalStackValue: 1)).
+ self internalPop: 1; internalStackTopPut: result].
+ "33 unchecked SmallInteger #<. Both arguments are SmallIntegers"
+ [33] -> [result := objectMemory booleanObjectOf: (self internalStackTop < (self internalStackValue: 1)).
+ self internalPop: 1; internalStackTopPut: result].
+ "34 unchecked SmallInteger #>=. Both arguments are SmallIntegers"
+ [34] -> [result := objectMemory booleanObjectOf: (self internalStackTop >= (self internalStackValue: 1)).
+ self internalPop: 1; internalStackTopPut: result].
+ "35 unchecked SmallInteger #<=. Both arguments are SmallIntegers"
+ [35] -> [result := objectMemory booleanObjectOf: (self internalStackTop <= (self internalStackValue: 1)).
+ self internalPop: 1; internalStackTopPut: result].
+ "36 unchecked SmallInteger #=. Both arguments are SmallIntegers"
+ [36] -> [result := objectMemory booleanObjectOf: (self internalStackTop = (self internalStackValue: 1)).
+ self internalPop: 1; internalStackTopPut: result].
+ "37 unchecked SmallInteger #~=. Both arguments are SmallIntegers"
+ [37] -> [result := objectMemory booleanObjectOf: (self internalStackTop ~= (self internalStackValue: 1)).
+ self internalPop: 1; internalStackTopPut: result].
+
+ "64 unchecked Pointer Object>>at:. The receiver is guaranteed to be a pointer object. The 0-relative (1-relative?) index is an in-range SmallInteger"
+ [64] -> [result := objectMemory
+ fetchPointer: (objectMemory integerValueOf: self internalStackTop)
+ ofObject: (self internalStackValue: 1).
+ self internalPop: 1; internalStackTopPut: result].
+ "65 unchecked Byte Object>>at:. The receiver is guaranteed to be a non-pointer object. The 0-relative (1-relative?) index is an in-range SmallInteger. The result is a SmallInteger."
+ [65] -> [result := objectMemory
+ fetchByte: (objectMemory integerValueOf: self internalStackTop)
+ ofObject: (self internalStackValue: 1).
+ self internalPop: 1; internalStackTopPut: (objectMemory integerObjectOf: result)].
+ "66 unchecked Word Object>>at:. The receiver is guaranteed to be a non-pointer object. The 0-relative (1-relative?) index is an in-range SmallInteger. The result is a SmallInteger."
+ [66] -> [result := objectMemory
+ fetchShort: (objectMemory integerValueOf: self internalStackTop)
+ ofObject: (self internalStackValue: 1).
+ self internalPop: 1; internalStackTopPut: (objectMemory integerObjectOf: result)].
+ "67 unchecked DoubleWord Object>>at:. The receiver is guaranteed to be a non-pointer object. The 0-relative (1-relative?) index is an in-range SmallInteger. The result is a SmallInteger or a LargePositiveInteger."
+ [67] -> [result := objectMemory
+ fetchLong32: (objectMemory integerValueOf: self internalStackTop)
+ ofObject: (self internalStackValue: 1).
+ self internalPop: 1; internalStackTopPut: (self signed64BitValueOf: result)].
+ "68 unchecked QuadWord Object>>at:. The receiver is guaranteed to be a non-pointer object. The 0-relative (1-relative?) index is an in-range SmallInteger. The result is a SmallInteger or a LargePositiveInteger."
+ [68] -> [result64 := objectMemory
+ fetchLong64: (objectMemory integerValueOf: self internalStackTop)
+ ofObject: (self internalStackValue: 1).
+ self internalPop: 1; internalStackTopPut: (self signed64BitValueOf: result)].
+
+ "80 unchecked Pointer Object>>at:put:. The receiver is guaranteed to be a pointer object. The 0-relative (1-relative?) index is an in-range SmallInteger"
+ [80] -> [result := self internalStackTop.
+ objectMemory
+ storePointer: (objectMemory integerValueOf: (self internalStackValue: 1))
+ ofObject: (self internalStackValue: 1)
+ withValue: result.
+ self internalPop: 2; internalStackTopPut: result].
+ "81 unchecked Byte Object>>at:put:. The receiver is guaranteed to be a non-pointer object. The 0-relative (1-relative?) index is an in-range SmallInteger. The argument is a SmallInteger. The primitive stores the least significant 8 bits."
+ [81] -> [result := self internalStackTop.
+ objectMemory
+ storeByte: (objectMemory integerValueOf: (self internalStackValue: 1))
+ ofObject: (self internalStackValue: 1)
+ withValue: (objectMemory integerValueOf: result).
+ self internalPop: 2; internalStackTopPut: result].
+ "82 unchecked Word Object>>at:put:. The receiver is guaranteed to be a non-pointer object. The 0-relative (1-relative?) index is an in-range SmallInteger. The argument is a SmallInteger. The primitive stores the least significant 16 bits."
+ [82] -> [result := self internalStackTop.
+ objectMemory
+ storeShort: (objectMemory integerValueOf: (self internalStackValue: 1))
+ ofObject: (self internalStackValue: 1)
+ withValue: (objectMemory integerValueOf: result).
+ self internalPop: 2; internalStackTopPut: result].
+ "83 unchecked DoubleWord Object>>at:put:. The receiver is guaranteed to be a non-pointer object. The 0-relative (1-relative?) index is an in-range SmallInteger. The argument is a SmallInteger. The primitive stores the least significant 32 bits."
+ [83] -> [result := self internalStackTop.
+ objectMemory
+ storeLong32: (objectMemory integerValueOf: (self internalStackValue: 1))
+ ofObject: (self internalStackValue: 1)
+ withValue: (objectMemory integerValueOf: result).
+ self internalPop: 2; internalStackTopPut: result].
+ "84 unchecked QuadWord Object>>at:put:. The receiver is guaranteed to be a non-pointer object. The 0-relative (1-relative?) index is an in-range SmallInteger. The argument is a SmallInteger. The primitive stores the least significant 64 bits."
+ [84] -> [result := self internalStackTop.
+ objectMemory
+ storeLong64: (objectMemory integerValueOf: (self internalStackValue: 1))
+ ofObject: (self internalStackValue: 1)
+ withValue: (objectMemory integerValueOf: result).
+ self internalPop: 2; internalStackTopPut: result] }
+ otherwise:
+ [localIP := localIP - 3.
+ self respondToUnknownBytecode]!
Item was changed:
----- Method: StackInterpreter>>longPrintOop: (in category 'debug printing') -----
longPrintOop: oop
<api>
| fmt lastIndex startIP bytecodesPerLine column |
((objectMemory isImmediate: oop)
or: [(objectMemory addressCouldBeObj: oop) not
or: [(oop bitAnd: objectMemory allocationUnit - 1) ~= 0
or: [(objectMemory isFreeObject: oop)
or: [objectMemory isForwarded: oop]]]]) ifTrue:
[self printOop: oop.
^self].
self printHex: oop.
(objectMemory fetchClassOfNonImm: oop)
ifNil: [self print: ' has a nil class!!!!']
ifNotNil: [:class|
self print: ': a(n) '; printNameOfClass: class count: 5;
print: ' ('.
objectMemory hasSpurMemoryManagerAPI ifTrue:
[self printHexnp: (objectMemory compactClassIndexOf: oop); print: '=>'].
self printHexnp: class; print: ')'].
fmt := objectMemory formatOf: oop.
self print: ' format '; printHexnp: fmt.
fmt > objectMemory lastPointerFormat
+ ifTrue: [self print: ' nbytes '; printNum: (objectMemory numBytesOf: oop)]
- ifTrue: [self print: ' nbytes '; printNum: (objectMemory byteLengthOf: oop)]
ifFalse: [(objectMemory isIndexableFormat: fmt) ifTrue:
[| len |
len := objectMemory lengthOf: oop.
self print: ' size '; printNum: len - (objectMemory fixedFieldsOf: oop format: fmt length: len)]].
objectMemory printHeaderTypeOf: oop.
self print: ' hash '; printHexnp: (objectMemory rawHashBitsOf: oop).
self cr.
(fmt between: objectMemory firstByteFormat and: objectMemory firstCompiledMethodFormat - 1) ifTrue:
[^self printStringOf: oop; cr].
(fmt between: objectMemory firstLongFormat and: objectMemory firstByteFormat - 1) ifTrue:
[^self].
"this is nonsense. apologies."
startIP := (objectMemory lastPointerOf: oop) + BytesPerOop - objectMemory baseHeaderSize / BytesPerOop.
lastIndex := 256 min: startIP.
lastIndex > 0 ifTrue:
[1 to: lastIndex do:
[:i| | fieldOop |
fieldOop := objectMemory fetchPointer: i - 1 ofObject: oop.
self space; printNum: i - 1; space; printHex: fieldOop; space.
(i = 1 and: [objectMemory isCompiledMethod: oop])
ifTrue: [self printMethodHeaderOop: fieldOop]
ifFalse: [self cCode: [self printOopShort: fieldOop]
inSmalltalk: [self print: (self shortPrint: fieldOop)]].
self cr]].
(objectMemory isCompiledMethod: oop)
ifFalse:
[startIP > 64 ifTrue: [self print: '...'; cr]]
ifTrue:
[startIP := startIP * BytesPerWord + 1.
lastIndex := objectMemory lengthOf: oop.
lastIndex - startIP > 100 ifTrue:
[lastIndex := startIP + 100].
bytecodesPerLine := 8.
column := 1.
startIP to: lastIndex do:
[:index| | byte |
column = 1 ifTrue:
[self cCode: 'printf("0x%08x: ", oop+BaseHeaderSize+index-1)'
inSmalltalk: [self print: (oop+BaseHeaderSize+index-1) hex; print: ': ']].
byte := objectMemory fetchByte: index - 1 ofObject: oop.
self cCode: 'printf(" %02x/%-3d", byte,byte)'
inSmalltalk: [self space; print: (byte radix: 16); printChar: $/; printNum: byte].
column := column + 1.
column > bytecodesPerLine ifTrue:
[column := 1. self cr]].
column = 1 ifFalse:
[self cr]]!
Item was changed:
----- Method: StackInterpreter>>lookupMethodFor:InDictionary: (in category 'message sending') -----
lookupMethodFor: selector InDictionary: dictionary
"Lookup the argument selector in aDictionary and answer either the
method or nil, if not found.
This method lookup tolerates integers as Dictionary keys to support
execution of images in which Symbols have been compacted out."
| length index mask wrapAround nextSelector methodArray |
<inline: true>
<asmLabel: false>
+ length := objectMemory numSlotsOf: dictionary.
- length := objectMemory fetchWordLengthOf: dictionary.
mask := length - SelectorStart - 1.
index := SelectorStart + (objectMemory methodDictionaryHash: selector mask: mask).
"It is assumed that there are some nils in this dictionary, and search will
stop when one is encountered. However, if there are no nils, then wrapAround
will be detected the second time the loop gets to the end of the table."
wrapAround := false.
[true] whileTrue:
[nextSelector := objectMemory fetchPointer: index ofObject: dictionary.
nextSelector = objectMemory nilObject ifTrue:
[^nil].
(objectMemory isOopForwarded: nextSelector) ifTrue:
[nextSelector := objectMemory
fixFollowedField: index + SelectorStart
ofObject: dictionary
withInitialValue: nextSelector].
nextSelector = selector ifTrue:
[methodArray := objectMemory followObjField: MethodArrayIndex ofObject: dictionary.
^objectMemory followField: index - SelectorStart ofObject: methodArray].
index := index + 1.
index = length ifTrue:
[wrapAround ifTrue: [^nil].
wrapAround := true.
index := SelectorStart]].
^nil "for Slang"!
Item was changed:
----- Method: StackInterpreter>>lookupMethodInDictionary: (in category 'message sending') -----
lookupMethodInDictionary: dictionary
"This method lookup tolerates integers as Dictionary keys to support
execution of images in which Symbols have been compacted out."
| length index mask wrapAround nextSelector methodArray |
<inline: true>
<asmLabel: false>
+ length := objectMemory numSlotsOf: dictionary.
- length := objectMemory fetchWordLengthOf: dictionary.
mask := length - SelectorStart - 1.
"Use linear search on small dictionaries; its cheaper.
Also the limit can be set to force linear search of all dictionaries, which supports the
booting of images that need rehashing (e.g. because a tracer has generated an image
with different hashes but hasn't rehashed it yet.)"
mask <= methodDictLinearSearchLimit ifTrue:
[index := 0.
[index <= mask] whileTrue:
[nextSelector := objectMemory fetchPointer: index + SelectorStart ofObject: dictionary.
(objectMemory isOopForwarded: nextSelector) ifTrue:
[nextSelector := objectMemory
fixFollowedField: index + SelectorStart
ofObject: dictionary
withInitialValue: nextSelector].
nextSelector = messageSelector ifTrue:
[methodArray := objectMemory followObjField: MethodArrayIndex ofObject: dictionary.
newMethod := objectMemory followField: index ofObject: methodArray.
^true].
index := index + 1].
^false].
index := SelectorStart + (objectMemory methodDictionaryHash: messageSelector mask: mask).
"It is assumed that there are some nils in this dictionary, and search will
stop when one is encountered. However, if there are no nils, then wrapAround
will be detected the second time the loop gets to the end of the table."
wrapAround := false.
[true] whileTrue:
[nextSelector := objectMemory fetchPointer: index ofObject: dictionary.
nextSelector = objectMemory nilObject ifTrue: [^false].
(objectMemory isOopForwarded: nextSelector) ifTrue:
[nextSelector := objectMemory
fixFollowedField: index + SelectorStart
ofObject: dictionary
withInitialValue: nextSelector].
nextSelector = messageSelector ifTrue:
[methodArray := objectMemory followObjField: MethodArrayIndex ofObject: dictionary.
newMethod := objectMemory followField: index - SelectorStart ofObject: methodArray.
^true].
index := index + 1.
index = length ifTrue:
[wrapAround ifTrue: [^false].
wrapAround := true.
index := SelectorStart]].
^false "for Slang"!
Item was changed:
----- Method: StackInterpreter>>primitiveObject:perform:withArguments:lookedUpIn: (in category 'control primitives') -----
primitiveObject: actualReceiver perform: selector withArguments: argumentArray lookedUpIn: lookupClass
"Common routine used by perform:withArgs:, perform:withArgs:inSuperclass:,
object:perform:withArgs:inClass: et al. Answer nil on success.
NOTE: The case of doesNotUnderstand: is not a failure to perform.
The only failures are arg types and consistency of argumentCount.
Since we're in the stack VM we can assume there is space to push the arguments
provided they are within limits (max argument count is 15). We can therefore deal
with the arbitrary amount of state to remove from the stack (lookup class, selector,
mirror receiver) and arbitrary argument orders by deferring popping anything until
we know whether the send has succeeded. So on failure we merely have to remove
the actual receiver and arguments pushed, and on success we have to slide the actual
receiver and arguments down to replace the original ones."
| arraySize performArgCount delta |
(objectMemory isArray: argumentArray) ifFalse:
[^self primitiveFailFor: PrimErrBadArgument].
"Check if number of arguments is reasonable; MaxNumArgs isn't available
so just use LargeContextSize"
+ arraySize := objectMemory numSlotsOf: argumentArray.
- arraySize := objectMemory fetchWordLengthOf: argumentArray.
arraySize > LargeContextSlots ifTrue:
[^self primitiveFailFor: PrimErrBadNumArgs].
performArgCount := argumentCount.
"Push newMethod to save it in case of failure,
then push the actual receiver and args out of the array."
self push: newMethod.
self push: actualReceiver.
"Copy the arguments to the stack, and execute"
1 to: arraySize do:
[:index| self push: (objectMemory fetchPointer: index - 1 ofObject: argumentArray)].
argumentCount := arraySize.
messageSelector := selector.
self sendBreakpoint: messageSelector receiver: actualReceiver.
self printSends ifTrue:
[self printActivationNameForSelector: messageSelector startClass: lookupClass; cr].
self findNewMethodInClassTag: (objectMemory classTagForClass: lookupClass).
"Only test CompiledMethods for argument count - any other objects playacting as CMs will have to take their chances"
((objectMemory isOopCompiledMethod: newMethod)
and: [(self argumentCountOf: newMethod) ~= argumentCount]) ifTrue:
["Restore the state by popping all those array entries and pushing back the selector and array, and fail"
self pop: arraySize + 1.
newMethod := self popStack.
^self primitiveFailFor: PrimErrBadNumArgs].
"Cannot fail this primitive from here-on. Slide the actual receiver and arguments down
to replace the perform arguments and saved newMethod and then execute the new
method. Use argumentCount not arraySize because an MNU may have changed it."
delta := BytesPerWord * (performArgCount + 2). "+2 = receiver + saved newMethod"
argumentCount * BytesPerWord to: 0 by: BytesPerWord negated do:
[:offset|
stackPages
longAt: stackPointer + offset + delta
put: (stackPages longAt: stackPointer + offset)].
self pop: performArgCount + 2.
self executeNewMethod.
self initPrimCall. "Recursive xeq affects primErrorCode"
^nil!
Item was changed:
----- Method: StackInterpreter>>printAllStacks (in category 'debug printing') -----
printAllStacks
"Print all the stacks of all running processes, including those that are currently suspended."
<api>
| proc semaphoreClass mutexClass schedLists p processList |
<inline: false>
proc := self activeProcess.
self printNameOfClass: (objectMemory fetchClassOf: proc) count: 5; space; printHex: proc.
self print: ' priority '; printNum: (self quickFetchInteger: PriorityIndex ofObject: proc); cr.
self printCallStackFP: framePointer. "first the current activation"
schedLists := objectMemory fetchPointer: ProcessListsIndex ofObject: self schedulerPointer.
"then the runnable processes"
p := highestRunnableProcessPriority = 0
+ ifTrue: [objectMemory numSlotsOf: schedLists]
- ifTrue: [objectMemory fetchWordLengthOf: schedLists]
ifFalse: [highestRunnableProcessPriority].
p - 1 to: 0 by: -1 do:
[:pri|
processList := objectMemory fetchPointer: pri ofObject: schedLists.
(self isEmptyList: processList) ifFalse:
[self cr; print: 'processes at priority '; printNum: pri + 1.
self printProcsOnList: processList]].
self cr; print: 'suspended processes'.
semaphoreClass := objectMemory classSemaphore.
mutexClass := objectMemory classMutex.
objectMemory hasSpurMemoryManagerAPI
ifTrue:
[semaphoreClass := objectMemory compactIndexOfClass: semaphoreClass.
mutexClass := objectMemory compactIndexOfClass: mutexClass.
objectMemory allHeapEntitiesDo:
[:obj| | classIdx |
classIdx := objectMemory classIndexOf: obj.
(classIdx = semaphoreClass
or: [classIdx = mutexClass]) ifTrue:
[self printProcsOnList: obj]]]
ifFalse:
[objectMemory allObjectsDoSafely:
[:obj| | classObj |
classObj := objectMemory fetchClassOfNonImm: obj.
(classObj = semaphoreClass
or: [classObj = mutexClass]) ifTrue:
[self printProcsOnList: obj]]]!
Item was changed:
----- Method: StackInterpreter>>printMethodCacheFor: (in category 'debug printing') -----
printMethodCacheFor: thing
<api>
0 to: MethodCacheSize - 1 by: MethodCacheEntrySize do:
[:i | | s c m p |
s := methodCache at: i + MethodCacheSelector.
c := methodCache at: i + MethodCacheClass.
m := methodCache at: i + MethodCacheMethod.
p := methodCache at: i + MethodCachePrimFunction.
((thing = -1 or: [s = thing or: [c = thing or: [p = thing or: [m = thing]]]])
and: [(objectMemory addressCouldBeOop: s)
and: [c ~= 0
and: [(self addressCouldBeClassObj: c)
or: [self addressCouldBeClassObj: (objectMemory classForClassTag: c)]]]]) ifTrue:
[self cCode: [] inSmalltalk: [self transcript ensureCr].
self printNum: i; cr; tab.
(objectMemory isBytesNonImm: s)
+ ifTrue: [self cCode: 'printf("%x %.*s\n", s, numBytesOf(s), (char *)firstIndexableField(s))'
- ifTrue: [self cCode: 'printf("%x %.*s\n", s, byteLengthOf(s), (char *)firstIndexableField(s))'
inSmalltalk: [self printHex: s; space; print: (self stringOf: s); cr]]
ifFalse: [self shortPrintOop: s].
self tab.
(self addressCouldBeClassObj: c)
ifTrue: [self shortPrintOop: c]
ifFalse: [self printNum: c; space; shortPrintOop: (objectMemory classForClassTag: c)].
self tab; shortPrintOop: m; tab.
self cCode:
[p > 1024
ifTrue: [self printHexnp: p]
ifFalse: [self printNum: p]]
inSmalltalk:
[p isSymbol ifTrue: [self print: p] ifFalse: [self printNum: p]].
self cr]]!
Item was changed:
----- Method: StackInterpreter>>printMethodDictionary: (in category 'debug printing') -----
printMethodDictionary: dictionary
<api>
| methodArray |
methodArray := objectMemory fetchPointer: MethodArrayIndex ofObject: dictionary.
+ SelectorStart to: (objectMemory numSlotsOf: dictionary) - 1 do:
- SelectorStart to: (objectMemory fetchWordLengthOf: dictionary) - 1 do:
[:index | | selector meth |
selector := objectMemory fetchPointer: index ofObject: dictionary.
selector ~= objectMemory nilObject ifTrue:
[meth := objectMemory fetchPointer: index - SelectorStart ofObject: methodArray.
self
printOopShort: selector;
print: ' => ';
printOopShort: meth;
print: ' (';
printHex: selector;
print: ' => ';
printHex: meth;
putchar: $);
cr]]!
Item was changed:
----- Method: StackInterpreter>>printOop: (in category 'debug printing') -----
printOop: oop
| cls fmt lastIndex startIP bytecodesPerLine column |
<inline: false>
(objectMemory isImmediate: oop) ifTrue:
[^self shortPrintOop: oop].
self printHex: oop.
(objectMemory addressCouldBeObj: oop) ifFalse:
[^self print: ((oop bitAnd: objectMemory allocationUnit - 1) ~= 0
ifTrue: [' is misaligned']
ifFalse: [self whereIs: oop]); cr].
(objectMemory isFreeObject: oop) ifTrue:
[^self print: ' is a free chunk of size '; printNum: (objectMemory sizeOfFree: oop); cr].
(objectMemory isForwarded: oop) ifTrue:
[^self
print: ' is a forwarded object to '; printHex: (objectMemory followForwarded: oop);
print: ' of slot size '; printNum: (objectMemory numSlotsOfAny: oop); cr].
self print: ': a(n) '.
self printNameOfClass: (cls := objectMemory fetchClassOfNonImm: oop) count: 5.
cls = (objectMemory splObj: ClassFloat) ifTrue:
[^self cr; printFloat: (self dbgFloatValueOf: oop); cr].
fmt := objectMemory formatOf: oop.
fmt > objectMemory lastPointerFormat ifTrue:
+ [self print: ' nbytes '; printNum: (objectMemory numBytesOf: oop)].
- [self print: ' nbytes '; printNum: (objectMemory byteLengthOf: oop)].
self cr.
(fmt between: objectMemory firstLongFormat and: objectMemory firstCompiledMethodFormat - 1) ifTrue:
["This will answer false if splObj: ClassAlien is nilObject"
(self is: oop KindOfClass: (objectMemory splObj: ClassAlien)) ifTrue:
[self print: ' datasize '; printNum: (self sizeOfAlienData: oop).
self print: ((self isIndirectAlien: oop)
ifTrue: [' indirect @ ']
ifFalse:
[(self isPointerAlien: oop)
ifTrue: [' pointer @ ']
ifFalse: [' direct @ ']]).
^self printHex: (self startOfAlienData: oop) asUnsignedInteger; cr].
(objectMemory isWords: oop) ifTrue:
+ [lastIndex := 64 min: ((objectMemory numBytesOf: oop) / BytesPerWord).
- [lastIndex := 64 min: ((objectMemory byteLengthOf: oop) / BytesPerWord).
lastIndex > 0 ifTrue:
[1 to: lastIndex do:
[:index|
self space; printHex: (objectMemory fetchLong32: index - 1 ofObject: oop).
(index \\ self elementsPerPrintOopLine) = 0 ifTrue:
[self cr]].
(lastIndex \\ self elementsPerPrintOopLine) = 0 ifFalse:
[self cr]].
^self].
^self printStringOf: oop; cr].
"this is nonsense. apologies."
startIP := (objectMemory lastPointerOf: oop) + BytesPerOop - objectMemory baseHeaderSize / BytesPerOop.
lastIndex := 256 min: startIP.
lastIndex > 0 ifTrue:
[1 to: lastIndex do:
[:index|
self cCode: [self printHex: (objectMemory fetchPointer: index - 1 ofObject: oop); space]
inSmalltalk: [self space; printHex: (objectMemory fetchPointer: index - 1 ofObject: oop); space.
self print: (self shortPrint: (objectMemory fetchPointer: index - 1 ofObject: oop))].
(index \\ self elementsPerPrintOopLine) = 0 ifTrue:
[self cr]].
(lastIndex \\ self elementsPerPrintOopLine) = 0 ifFalse:
[self cr]].
(objectMemory isCompiledMethod: oop)
ifFalse:
[startIP > 64 ifTrue: [self print: '...'; cr]]
ifTrue:
[startIP := startIP * BytesPerWord + 1.
lastIndex := objectMemory lengthOf: oop.
lastIndex - startIP > 100 ifTrue:
[lastIndex := startIP + 100].
bytecodesPerLine := 8.
column := 1.
startIP to: lastIndex do:
[:index| | byte |
column = 1 ifTrue:
[self cCode: 'printf("0x%08x: ", oop+BaseHeaderSize+index-1)'
inSmalltalk: [self print: (oop+BaseHeaderSize+index-1) hex; print: ': ']].
byte := objectMemory fetchByte: index - 1 ofObject: oop.
self cCode: 'printf(" %02x/%-3d", byte,byte)'
inSmalltalk: [self space; print: (byte radix: 16); printChar: $/; printNum: byte].
column := column + 1.
column > bytecodesPerLine ifTrue:
[column := 1. self cr]].
column = 1 ifFalse:
[self cr]]!
Item was changed:
----- Method: StackInterpreter>>validInstructionPointer:inMethod:framePointer: (in category 'debug support') -----
validInstructionPointer: theInstrPointer inMethod: aMethod framePointer: fp
<var: #theInstrPointer type: #usqInt>
<var: #aMethod type: #usqInt>
<var: #fp type: #'char *'>
^self
cppIf: MULTIPLEBYTECODESETS
ifTrue:
[| methodHeader |
methodHeader := self noAssertHeaderOf: aMethod. "-1 for pre-increment in fetchNextBytecode"
theInstrPointer >= (aMethod + (objectMemory lastPointerOf: aMethod) + BytesPerOop - 1)
+ and: [theInstrPointer < (aMethod + (objectMemory numBytesOf: aMethod) + BaseHeaderSize - 1)
- and: [theInstrPointer < (aMethod + (objectMemory byteLengthOf: aMethod) + BaseHeaderSize - 1)
and: ["If the method starts with a CallPrimitive opcode the instruction pointer should be past it."
((self headerIndicatesAlternateBytecodeSet: methodHeader)
and: [(self alternateHeaderHasPrimitiveFlag: methodHeader)
and: [theInstrPointer < (aMethod
+ BytesPerOop - 1
+ (objectMemory lastPointerOf: aMethod)
+ (self sizeOfCallPrimitiveBytecode: methodHeader))]])
not]]]
ifFalse: "-1 for pre-increment in fetchNextBytecode"
[theInstrPointer >= (aMethod + (objectMemory lastPointerOf: aMethod) + BytesPerOop - 1)
+ and: [theInstrPointer < (aMethod + (objectMemory numBytesOf: aMethod) + objectMemory baseHeaderSize - 1)]]!
- and: [theInstrPointer < (aMethod + (objectMemory byteLengthOf: aMethod) + objectMemory baseHeaderSize - 1)]]!
Item was changed:
----- Method: StackInterpreter>>wakeHighestPriority (in category 'process primitive support') -----
wakeHighestPriority
"Return the highest priority process that is ready to run.
To save time looking at many empty lists before finding a
runnable process the VM maintains a variable holding the
highest priority runnable process. If this variable is 0 then the
VM does not know the highest priority and must search all lists.
Note: It is a fatal VM error if there is no runnable process."
| schedLists p processList proc ctxt |
self externalWriteBackHeadFramePointers.
schedLists := objectMemory fetchPointer: ProcessListsIndex ofObject: self schedulerPointer.
p := highestRunnableProcessPriority = 0
+ ifTrue: [objectMemory numSlotsOf: schedLists]
- ifTrue: [objectMemory fetchWordLengthOf: schedLists]
ifFalse: [highestRunnableProcessPriority].
[(p := p - 1) >= 0] whileTrue:
[processList := objectMemory fetchPointer: p ofObject: schedLists.
[self isEmptyList: processList] whileFalse:
["Only answer processes with a runnable suspendedContext.
Discard those that aren't; the VM would crash otherwise."
proc := self removeFirstLinkOfList: processList.
ctxt := objectMemory fetchPointer: SuspendedContextIndex ofObject: proc.
(self isLiveContext: ctxt) ifTrue:
[highestRunnableProcessPriority := p + 1.
^proc].
self warning: 'evicted zombie process from run queue']].
self error: 'scheduler could not find a runnable process'.
^nil!
Item was changed:
----- Method: StackInterpreterPrimitives>>primitiveDoNamedPrimitiveWithArgs (in category 'plugin primitives') -----
primitiveDoNamedPrimitiveWithArgs
"Simulate an primitiveExternalCall invocation (e.g. for the Debugger). Do not cache anything.
e.g. ContextPart>>tryNamedPrimitiveIn: aCompiledMethod for: aReceiver withArgs: arguments"
| argumentArray arraySize methodArg methodHeader
moduleName functionName moduleLength functionLength
spec addr primRcvr ctxtRcvr isArray |
<var: #addr declareC: 'void (*addr)()'>
argumentArray := self stackTop.
methodArg := self stackValue: 2.
((objectMemory isArray: argumentArray)
and: [objectMemory isOopCompiledMethod: methodArg]) ifFalse:
[^self primitiveFailFor: -2]. "invalid args"
+ arraySize := objectMemory numSlotsOf: argumentArray.
- arraySize := objectMemory fetchWordLengthOf: argumentArray.
(self roomToPushNArgs: arraySize) ifFalse:
[^self primitiveFailFor: -2]. "invalid args"
methodHeader := self headerOf: methodArg.
(self literalCountOfHeader: methodHeader) > 2 ifFalse:
[^self primitiveFailFor: -3]. "invalid methodArg state"
spec := objectMemory fetchPointer: 1 "first literal" ofObject: methodArg.
isArray := self isInstanceOfClassArray: spec.
(isArray
and: [(objectMemory lengthOf: spec) = 4
and: [(self primitiveIndexOfMethod: methodArg header: methodHeader) = 117]]) ifFalse:
[^self primitiveFailFor: -3]. "invalid methodArg state"
(self argumentCountOfMethodHeader: methodHeader) = arraySize ifFalse:
[^self primitiveFailFor: -2]. "invalid args (Array args wrong size)"
"The function has not been loaded yet. Fetch module and function name."
moduleName := objectMemory fetchPointer: 0 ofObject: spec.
moduleName = objectMemory nilObject
ifTrue: [moduleLength := 0]
ifFalse: [self success: (objectMemory isBytes: moduleName).
moduleLength := objectMemory lengthOf: moduleName.
self cCode: '' inSmalltalk:
[ (#('FloatArrayPlugin' 'Matrix2x3Plugin') includes: (self stringOf: moduleName)) "??"
ifTrue: [moduleLength := 0 "Cause all of these to fail"]]].
functionName := objectMemory fetchPointer: 1 ofObject: spec.
self success: (objectMemory isBytes: functionName).
functionLength := objectMemory lengthOf: functionName.
self successful ifFalse: [^self primitiveFailFor: -3]. "invalid methodArg state"
addr := self ioLoadExternalFunction: functionName + BaseHeaderSize
OfLength: functionLength
FromModule: moduleName + BaseHeaderSize
OfLength: moduleLength.
addr = 0 ifTrue:
[^self primitiveFailFor: -1]. "could not find function; answer generic failure (see below)"
"Cannot fail this primitive from now on. Can only fail the external primitive."
objectMemory pushRemappableOop: (argumentArray := self popStack).
objectMemory pushRemappableOop: (primRcvr := self popStack).
objectMemory pushRemappableOop: self popStack. "the method"
objectMemory pushRemappableOop: self popStack. "the context receiver"
self push: primRcvr. "replace context receiver with actual receiver"
argumentCount := arraySize.
1 to: arraySize do:
[:index| self push: (objectMemory fetchPointer: index - 1 ofObject: argumentArray)].
self callExternalPrimitive: addr.
ctxtRcvr := objectMemory popRemappableOop.
methodArg := objectMemory popRemappableOop.
primRcvr := objectMemory popRemappableOop.
argumentArray := objectMemory popRemappableOop.
self successful ifFalse: "If primitive failed, then restore state for failure code"
[self pop: arraySize + 1.
self push: ctxtRcvr.
self push: methodArg.
self push: primRcvr.
self push: argumentArray.
argumentCount := 3.
"Hack. A nil prim error code (primErrorCode = 1) is interpreted by the image
as meaning this primitive is not implemented. So to pass back nil as an error
code we use -1 to indicate generic failure."
primFailCode = 1 ifTrue:
[primFailCode := -1]]!
Item was changed:
----- Method: StackInterpreterPrimitives>>primitiveDoPrimitiveWithArgs (in category 'control primitives') -----
primitiveDoPrimitiveWithArgs
| argumentArray arraySize index primIdx |
argumentArray := self stackTop.
(objectMemory isArray: argumentArray) ifFalse: [^self primitiveFail].
+ arraySize := objectMemory numSlotsOf: argumentArray.
- arraySize := objectMemory fetchWordLengthOf: argumentArray.
self success: (self roomToPushNArgs: arraySize).
primIdx := self stackIntegerValue: 1.
self successful ifFalse: [^self primitiveFail]. "invalid args"
primitiveFunctionPointer := self functionPointerFor: primIdx inClass: nil.
primitiveFunctionPointer = 0 ifTrue:
[^self primitiveFail].
"Pop primIndex and argArray, then push args in place..."
self pop: 2.
argumentCount := arraySize.
index := 1.
[index <= argumentCount] whileTrue:
[self push: (objectMemory fetchPointer: index - 1 ofObject: argumentArray).
index := index + 1].
self isPrimitiveFunctionPointerAnIndex ifTrue:
[self externalQuickPrimitiveResponse.
^nil].
"We use tempOop instead of pushRemappableOop:/popRemappableOop here because in
the Cogit primitiveEnterCriticalSection, primitiveSignal, primitiveResume et al longjmp back
to either the interpreter or machine code, depending on the process activated. So if we're
executing one of these primitives control won't actually return here and the matching
popRemappableOop: wouldn't occur, potentially overflowing the remap buffer. While recursion
could occur (nil tryPrimitive: 118 withArgs: #(111 #())) it counts as shooting oneself in the foot."
tempOop := argumentArray. "prim might alloc/gc"
"Run the primitive (sets primFailCode)"
self slowPrimitiveResponse.
self successful ifFalse: "If primitive failed, then restore state for failure code"
[self pop: arraySize.
self pushInteger: primIdx.
self push: tempOop.
argumentCount := 2].
tempOop := 0!
Item was changed:
----- Method: StackInterpreterPrimitives>>primitiveExecuteMethodArgsArray (in category 'control primitives') -----
primitiveExecuteMethodArgsArray
"receiver, argsArray, then method are on top of stack. Execute method against
receiver and args. Allow for up to two extra arguments (e.g. for mirror primitives).
Set primitiveFunctionPointer because no cache lookup has been done for the
method, and hence primitiveFunctionPointer is stale."
| methodArgument argCnt argumentArray primitiveIndex |
methodArgument := self stackTop.
argumentArray := self stackValue: 1.
((objectMemory isOopCompiledMethod: methodArgument)
and: [objectMemory isArray: argumentArray]) ifFalse:
[^self primitiveFailFor: PrimErrBadArgument].
argCnt := self argumentCountOf: methodArgument.
+ argCnt = (objectMemory numSlotsOf: argumentArray) ifFalse:
- argCnt = (objectMemory fetchWordLengthOf: argumentArray) ifFalse:
[^self primitiveFailFor: PrimErrBadNumArgs].
argumentCount > 2 ifTrue: "CompiledMethod class>>receiver:withArguments:executeMethod:
SqueakObjectPrimitives class >> receiver:withArguments:apply:
VMMirror>>ifFail:object:with:executeMethod: et al"
[argumentCount > 4 ifTrue:
[^self primitiveFailFor: PrimErrUnsupported].
self stackValue: argumentCount put: (self stackValue: 2)]. "replace actual receiver with desired receiver"
"and push the actual arguments"
self pop: argumentCount.
0 to: argCnt - 1 do:
[:i|
self push: (objectMemory fetchPointer: i ofObject: argumentArray)].
newMethod := methodArgument.
primitiveIndex := self primitiveIndexOf: newMethod.
primitiveFunctionPointer := self functionPointerFor: primitiveIndex inClass: nil.
argumentCount := argCnt.
self executeNewMethod.
"Recursive xeq affects primErrorCode"
self initPrimCall!
Item was changed:
----- Method: StackInterpreterSimulator>>classAndSelectorOfMethod:forReceiver: (in category 'debug support') -----
classAndSelectorOfMethod: meth forReceiver: rcvr
| mClass dict length methodArray |
mClass := objectMemory fetchClassOf: rcvr.
[dict := objectMemory fetchPointer: MethodDictionaryIndex ofObject: mClass.
+ length := objectMemory numSlotsOf: dict.
- length := objectMemory fetchWordLengthOf: dict.
methodArray := objectMemory fetchPointer: MethodArrayIndex ofObject: dict.
0 to: length-SelectorStart-1 do:
[:index |
meth = (objectMemory fetchPointer: index ofObject: methodArray)
ifTrue: [^ Array
with: mClass
with: (objectMemory fetchPointer: index + SelectorStart ofObject: dict)]].
mClass := self superclassOf: mClass.
mClass = objectMemory nilObject]
whileFalse.
^ Array
with: (objectMemory fetchClassOf: rcvr)
with: (objectMemory splObj: SelectorDoesNotUnderstand)!
Item was added:
+ ----- Method: StackToRegisterMappingCogit class>>initializeBytecodeTableForSistaV1 (in category 'class initialization') -----
+ initializeBytecodeTableForSistaV1
+ "StackToRegisterMappingCogit initializeBytecodeTableForSistaV1"
+
+ isPushNilFunction := #sistaV1:Is:Push:Nil:.
+ pushNilSizeFunction := #sistaV1PushNilSize:.
+ self flag:
+ 'Special selector send class must be inlined to agree with the interpreter, which
+ inlines class. If class is sent to e.g. a general instance of ProtoObject then unless
+ class is inlined there will be an MNU. It must be that the Cointerpreter and Cogit
+ have identical semantics. We get away with not hardwiring the other special
+ selectors either because in the Cointerpreter they are not inlined or because they
+ are inlined only to instances of classes for which there will always be a method.'.
+ self generatorTableFrom: #(
+ "1 byte bytecodes"
+ "pushes"
+ (1 0 15 genPushReceiverVariableBytecode needsFrameNever: 1)
+ (1 16 31 genPushLiteralVariable16CasesBytecode needsFrameNever: 1)
+ (1 32 63 genPushLiteralConstantBytecode needsFrameNever: 1)
+ (1 64 75 genPushTemporaryVariableBytecode needsFrameIfMod16GENumArgs: 1)
+ (1 76 76 genPushReceiverBytecode needsFrameNever: 1)
+ (1 77 77 pushConstantTrueBytecode needsFrameNever: 1)
+ (1 78 78 pushConstantFalseBytecode needsFrameNever: 1)
+ (1 79 79 pushConstantNilBytecode needsFrameNever: 1)
+ (1 80 80 genPushConstantZeroBytecode needsFrameNever: 1)
+ (1 81 81 genPushConstantOneBytecode needsFrameNever: 1)
+ (1 82 82 genExtPushPseudoVariable)
+ (1 83 83 duplicateTopBytecode needsFrameNever: 1)
+
+ (1 84 87 unknownBytecode)
+
+ "returns"
+ (1 88 88 genReturnReceiver return needsFrameIfInBlock: isMappedInBlock 0)
+ (1 89 89 genReturnTrue return needsFrameIfInBlock: isMappedInBlock 0)
+ (1 90 90 genReturnFalse return needsFrameIfInBlock: isMappedInBlock 0)
+ (1 91 91 genReturnNil return needsFrameIfInBlock: isMappedInBlock 0)
+ (1 92 92 genReturnTopFromMethod return needsFrameIfInBlock: isMappedInBlock -1)
+ (1 93 93 genReturnNilFromBlock return needsFrameNever: -1)
+ (1 94 94 genReturnTopFromBlock return needsFrameNever: -1)
+ (1 95 95 genExtNop needsFrameNever: 0)
+
+ "sends"
+ (1 96 96 genSpecialSelectorArithmetic isMapped AddRR)
+ (1 97 97 genSpecialSelectorArithmetic isMapped SubRR)
+ (1 98 98 genSpecialSelectorComparison isMapped JumpLess)
+ (1 99 99 genSpecialSelectorComparison isMapped JumpGreater)
+ (1 100 100 genSpecialSelectorComparison isMapped JumpLessOrEqual)
+ (1 101 101 genSpecialSelectorComparison isMapped JumpGreaterOrEqual)
+ (1 102 102 genSpecialSelectorComparison isMapped JumpZero)
+ (1 103 103 genSpecialSelectorComparison isMapped JumpNonZero)
+ (1 104 109 genSpecialSelectorSend isMapped) " #* #/ #\\ #@ #bitShift: //"
+ (1 110 110 genSpecialSelectorArithmetic isMapped AndRR)
+ (1 111 111 genSpecialSelectorArithmetic isMapped OrRR)
+ (1 112 117 genSpecialSelectorSend isMapped) "#at: #at:put: #size #next #nextPut: #atEnd"
+ (1 118 118 genSpecialSelectorEqualsEquals needsFrameNever: notMapped -1) "not mapped because it is directly inlined (for now)"
+ (1 119 119 genSpecialSelectorClass needsFrameIfStackGreaterThanOne: notMapped 0) "not mapped because it is directly inlined (for now)"
+ (1 120 127 genSpecialSelectorSend isMapped) "#blockCopy: #value #value: #do: #new #new: #x #y"
+
+ (1 128 143 genSendLiteralSelector0ArgsBytecode isMapped)
+ (1 144 159 genSendLiteralSelector1ArgBytecode isMapped)
+ (1 160 175 genSendLiteralSelector2ArgsBytecode isMapped)
+
+ "jumps"
+ (1 176 183 genShortUnconditionalJump branch v3:ShortForward:Branch:Distance:)
+ (1 184 191 genShortJumpIfTrue branch isBranchTrue isMapped "because of mustBeBoolean"
+ v3:ShortForward:Branch:Distance:)
+ (1 192 199 genShortJumpIfFalse branch isBranchFalse isMapped "because of mustBeBoolean"
+ v3:ShortForward:Branch:Distance:)
+
+ "stores"
+ (1 200 207 genStoreAndPopReceiverVariableBytecode needsFrameNever: -1) "N.B. not frameless if immutability"
+ (1 208 215 genStoreAndPopTemporaryVariableBytecode)
+
+ (1 216 216 genPopStackBytecode needsFrameNever: -1)
+
+ (1 217 223 unknownBytecode)
+
+ "2 byte bytecodes"
+ (2 224 224 extABytecode extension)
+ (2 225 225 extBBytecode extension)
+
+ "pushes"
+ (2 226 226 genExtPushReceiverVariableBytecode needsFrameNever: 1)
+ (2 227 227 genExtPushLiteralVariableBytecode needsFrameNever: 1)
+ (2 228 228 genExtPushLiteralBytecode needsFrameNever: 1)
+ (2 229 229 genLongPushTemporaryVariableBytecode)
+ (2 230 230 genPushClosureTempsBytecode)
+ (2 231 231 genPushNewArrayBytecode)
+ (2 232 232 genExtPushIntegerBytecode needsFrameNever: 1)
+ (2 233 233 genExtPushCharacterBytecode needsFrameNever: 1)
+
+ "returns"
+ "sends"
+ (2 234 234 genExtSendBytecode isMapped)
+ (2 235 235 genExtSendSuperBytecode isMapped)
+
+ "sista bytecodes"
+ (2 236 236 genExtTrapIfNotInstanceOfBehaviorsBytecode isMapped)
+
+ "jumps"
+ (2 237 237 genExtUnconditionalJump branch isMapped "because of interrupt check" v4:Long:Branch:Distance:)
+ (2 238 238 genExtJumpIfTrue branch isBranchTrue isMapped "because of mustBeBoolean" v4:Long:Branch:Distance:)
+ (2 239 239 genExtJumpIfFalse branch isBranchFalse isMapped "because of mustBeBoolean" v4:Long:Branch:Distance:)
+
+ "stores"
+ (2 240 240 genExtStoreAndPopReceiverVariableBytecode)
+ (2 241 241 genExtStoreAndPopLiteralVariableBytecode)
+ (2 242 242 genLongStoreAndPopTemporaryVariableBytecode)
+ (2 243 243 genExtStoreReceiverVariableBytecode)
+ (2 244 244 genExtStoreLiteralVariableBytecode)
+ (2 245 245 genLongStoreTemporaryVariableBytecode)
+
+ (2 246 247 unknownBytecode)
+
+ "3 byte bytecodes"
+ (3 248 248 callPrimitiveBytecode)
+ (3 249 249 unknownBytecode) "reserved for Push Float"
+ (3 250 250 genExtPushClosureBytecode block sistaV1:Block:Code:Size:)
+ (3 251 251 genPushRemoteTempLongBytecode)
+ (3 252 252 genStoreRemoteTempLongBytecode)
+ (3 253 253 genStoreAndPopRemoteTempLongBytecode)
+
+ (3 254 255 unknownBytecode))!
Item was changed:
SharedPool subclass: #VMBasicConstants
instanceVariableNames: ''
+ classVariableNames: 'BaseHeaderSize Byte0Mask Byte0Shift Byte1Mask Byte1Shift Byte1ShiftNegated Byte2Mask Byte2Shift Byte3Mask Byte3Shift Byte3ShiftNegated Byte4Mask Byte4Shift Byte4ShiftNegated Byte5Mask Byte5Shift Byte5ShiftNegated Byte6Mask Byte6Shift Byte7Mask Byte7Shift Byte7ShiftNegated Bytes3to0Mask Bytes7to4Mask BytesPerOop BytesPerWord COGMTVM COGVM DisownVMLockOutFullGC DoAssertionChecks DoExpensiveAssertionChecks GCModeBecome GCModeFull GCModeIncr GCModeScavenge IMMUTABILITY MULTIPLEBYTECODESETS NewspeakVM PrimErrBadArgument PrimErrBadIndex PrimErrBadMethod PrimErrBadNumArgs PrimErrBadReceiver PrimErrGenericFailure PrimErrInappropriate PrimErrLimitExceeded PrimErrNamedInternal PrimErrNoCMemory PrimErrNoMemory PrimErrNoModification PrimErrNotFound PrimErrObjectIsPinned PrimErrObjectMayMove PrimErrUnsupported PrimErrWritePastObject PrimNoErr STACKVM ShiftForWord SistaVM VMBIGENDIAN'
- classVariableNames: 'BaseHeaderSize Byte0Mask Byte0Shift Byte1Mask Byte1Shift Byte1ShiftNegated Byte2Mask Byte2Shift Byte3Mask Byte3Shift Byte3ShiftNegated Byte4Mask Byte4Shift Byte4ShiftNegated Byte5Mask Byte5Shift Byte5ShiftNegated Byte6Mask Byte6Shift Byte7Mask Byte7Shift Byte7ShiftNegated Bytes3to0Mask Bytes7to4Mask BytesPerOop BytesPerWord COGMTVM COGVM DisownVMLockOutFullGC DoAssertionChecks DoExpensiveAssertionChecks GCModeBecome GCModeFull GCModeIncr GCModeScavenge IMMUTABILITY MULTIPLEBYTECODESETS NewspeakVM PrimErrBadArgument PrimErrBadIndex PrimErrBadMethod PrimErrBadNumArgs PrimErrBadReceiver PrimErrGenericFailure PrimErrInappropriate PrimErrLimitExceeded PrimErrNamedInternal PrimErrNoCMemory PrimErrNoMemory PrimErrNoModification PrimErrNotFound PrimErrObjectIsPinned PrimErrObjectMayMove PrimErrUnsupported PrimErrWritePastObject PrimNoErr STACKVM ShiftForWord VMBIGENDIAN'
poolDictionaries: ''
category: 'VMMaker-Interpreter'!
!VMBasicConstants commentStamp: '<historical>' prior: 0!
I am a shared pool for basic constants upon which the VM as a whole depends.
self ensureClassPool.
self classPool declare: #BytesPerWord from: VMSqueakV3ObjectRepresentationConstants classPool.
self classPool declare: #BaseHeaderSize from: VMSqueakV3ObjectRepresentationConstants classPool
(ObjectMemory classPool keys select: [:k| k beginsWith: 'Byte']) do:
[:k| self classPool declare: k from: ObjectMemory classPool]!
Item was changed:
----- Method: VMClass class>>initializeMiscConstants (in category 'initialization') -----
initializeMiscConstants
"Falsify the `what type of VM is this?' flags that are defined in the various interp.h files,
or in the case of VMBIGENDIAN the various sqConfig.h files.
Subclass implementations need to include a super initializeMiscConstants"
| omc |
VMBIGENDIAN class. "Mention this for the benefit of CCodeGenerator>>emitCConstantsOn:"
self isInterpreterClass ifTrue:
[STACKVM := COGVM := COGMTVM := false].
initializationOptions ifNil: [self initializationOptions: Dictionary new].
omc := initializationOptions at: #ObjectMemory ifAbsent: nil.
initializationOptions
at: #SqueakV3ObjectMemory "the good ole default"
put: (omc
ifNil: [true]
ifNotNil: [(Smalltalk at: omc) inheritsFrom: ObjectMemory]);
at: #SpurObjectMemory "the new condender"
put: (omc
ifNil: [false]
ifNotNil: [(Smalltalk at: omc) inheritsFrom: SpurMemoryManager]).
"Use ifAbsentPut: so that they will get copied back to the
VMMaker's options and dead code will likely be eliminated."
NewspeakVM := initializationOptions at: #NewspeakVM ifAbsentPut: [false].
+ SistaVM := initializationOptions at: #SistaVM ifAbsentPut: [false].
MULTIPLEBYTECODESETS := initializationOptions at: #MULTIPLEBYTECODESETS ifAbsentPut: [false].
"N.B. Not yet implemented."
IMMUTABILITY := initializationOptions at: #IMMUTABILITY ifAbsentPut: [false].
"These for scripts etc... Usually they should get set by an Interpreter class's initializeMiscConstantsWith:"
(initializationOptions includesKey: #STACKVM) ifTrue:
[STACKVM := initializationOptions at: #STACKVM].
(initializationOptions includesKey: #COGVM) ifTrue:
[COGVM := initializationOptions at: #COGVM].
(initializationOptions includesKey: #COGMTVM) ifTrue:
[COGMTVM := initializationOptions at: #COGMTVM]!
Item was changed:
----- Method: VMCompiledMethodProxy>>at: (in category 'accessing') -----
at: index
+ ^(index between: 1 and: (objectMemory numBytesOf: oop))
- ^(index between: 1 and: (objectMemory byteLengthOf: oop))
ifTrue: [objectMemory fetchByte: index - 1 ofObject: oop]
ifFalse: [self errorSubscriptBounds: index]!
Item was changed:
----- Method: VMCompiledMethodProxy>>size (in category 'accessing') -----
size
+ ^objectMemory numBytesOf: oop!
- ^objectMemory byteLengthOf: oop!
Item was changed:
----- Method: VMMaker class>>generateSqueakCogSistaVM (in category 'configurations') -----
generateSqueakCogSistaVM
"No primitives since we can use those for the Cog VM"
^VMMaker
generate: CoInterpreter
and: SistaStackToRegisterMappingCogit
+ with: #( SistaVM true
+ MULTIPLEBYTECODESETS true
- with: #( MULTIPLEBYTECODESETS true
bytecodeTableInitializer initializeBytecodeTableForSqueakV3PlusClosuresSistaV1Hybrid)
to: (FileDirectory default pathFromURI: self sourceTree, '/sistasrc')
platformDir: (FileDirectory default pathFromURI: self sourceTree, '/platforms')
including: #()!
Item was changed:
----- Method: VMMaker class>>generateSqueakSpurCogSistaVM (in category 'configurations') -----
generateSqueakSpurCogSistaVM
"No primitives since we can use those for the Cog VM"
^VMMaker
generate: CoInterpreter
and: SistaStackToRegisterMappingCogit
+ with: #( SistaVM true
+ ObjectMemory Spur32BitCoMemoryManager
- with: #( ObjectMemory Spur32BitCoMemoryManager
MULTIPLEBYTECODESETS true
bytecodeTableInitializer initializeBytecodeTableForSqueakV3PlusClosuresSistaV1Hybrid)
to: (FileDirectory default pathFromURI: self sourceTree, '/spursistasrc')
platformDir: (FileDirectory default pathFromURI: self sourceTree, '/platforms')
including:#()!
More information about the Vm-dev
mailing list