[Vm-dev] VM Maker: VMMaker.oscog-eem.348.mcz
commits at source.squeak.org
commits at source.squeak.org
Thu Sep 5 00:30:03 UTC 2013
Eliot Miranda uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker.oscog-eem.348.mcz
==================== Summary ====================
Name: VMMaker.oscog-eem.348
Author: eem
Time: 4 September 2013, 5:27:05.1 pm
UUID: 8ba1e038-9d98-46af-b40a-1c663bad8df1
Ancestors: VMMaker.oscog-eem.347
Rename fetchClassOfNonInt: to fetchClassOfNonImm:.
Recast SpurMemMgr's isImmediate: et al in terms of self tagMask.
Fix various printOop:'s in StackInterpreter to use
addressCouldBeObj: to test for correct alignment and avoid
assumption that objects are between startOfMemory and freeStart.
=============== Diff against VMMaker.oscog-eem.347 ===============
Item was changed:
----- Method: CoInterpreter>>bytecodePrimAt (in category 'common selector sends') -----
bytecodePrimAt
"BytecodePrimAt will only succeed if the receiver is in the atCache.
Otherwise it will fail so that the more general primitiveAt will put it in the
cache after validating that message lookup results in a primitive response.
Override to insert in the at: cache here. This is necessary since once there
is a compiled at: primitive method (which doesn't use the at: cache) the only
way something can get installed in the atCache is here."
| index rcvr result atIx |
index := self internalStackTop.
rcvr := self internalStackValue: 1.
((objectMemory isIntegerObject: rcvr) not
and: [objectMemory isIntegerObject: index]) ifTrue:
[atIx := rcvr bitAnd: AtCacheMask. "Index into atCache = 4N, for N = 0 ... 7"
(atCache at: atIx+AtCacheOop) ~= rcvr ifTrue:
+ [lkupClass := objectMemory fetchClassOfNonImm: rcvr.
- [lkupClass := objectMemory fetchClassOfNonInt: rcvr.
messageSelector := self specialSelector: 16.
(self lookupInMethodCacheSel: messageSelector class: lkupClass) ifFalse:
[argumentCount := 1.
^self commonSend].
primitiveFunctionPointer == #primitiveAt
ifTrue: [self install: rcvr inAtCache: atCache at: atIx string: false]
ifFalse:
[primitiveFunctionPointer == #primitiveStringAt
ifTrue: [self install: rcvr inAtCache: atCache at: atIx string: true]
ifFalse:
[argumentCount := 1.
^self commonSend]]].
self successful ifTrue:
[result := self commonVariable: rcvr at: (objectMemory integerValueOf: index) cacheIndex: atIx].
self successful ifTrue:
[self fetchNextBytecode.
^self internalPop: 2 thenPush: result].
self initPrimCall].
messageSelector := self specialSelector: 16.
argumentCount := 1.
self normalSend!
Item was changed:
----- Method: CoInterpreter>>bytecodePrimAtPut (in category 'common selector sends') -----
bytecodePrimAtPut
"BytecodePrimAtPut will only succeed if the receiver is in the atCache.
Otherwise it will fail so that the more general primitiveAtPut will put it in the
cache after validating that message lookup results in a primitive response.
Override to insert in the atCache here. This is necessary since once there
is a compiled at:[put:] primitive method (which doesn't use the at: cache) the
only way something can get installed in the atCache is here."
| index rcvr atIx value |
value := self internalStackTop.
index := self internalStackValue: 1.
rcvr := self internalStackValue: 2.
((objectMemory isIntegerObject: rcvr) not
and: [objectMemory isIntegerObject: index]) ifTrue:
[atIx := (rcvr bitAnd: AtCacheMask) + AtPutBase. "Index into atPutCache"
(atCache at: atIx+AtCacheOop) ~= rcvr ifTrue:
+ [lkupClass := objectMemory fetchClassOfNonImm: rcvr.
- [lkupClass := objectMemory fetchClassOfNonInt: rcvr.
messageSelector := self specialSelector: 17.
(self lookupInMethodCacheSel: messageSelector class: lkupClass) ifFalse:
[argumentCount := 2.
^self commonSend].
primitiveFunctionPointer == #primitiveAtPut
ifTrue: [self install: rcvr inAtCache: atCache at: atIx string: false]
ifFalse:
[primitiveFunctionPointer == #primitiveStringAtPut
ifTrue: [self install: rcvr inAtCache: atCache at: atIx string: true]
ifFalse:
[argumentCount := 2.
^self commonSend]]].
self successful ifTrue:
[self commonVariable: rcvr at: (objectMemory integerValueOf: index) put: value cacheIndex: atIx].
self successful ifTrue:
[self fetchNextBytecode.
^self internalPop: 3 thenPush: value].
self initPrimCall].
messageSelector := self specialSelector: 17.
argumentCount := 2.
self normalSend!
Item was changed:
----- Method: CoInterpreter>>checkOkayFields: (in category 'debug support') -----
checkOkayFields: oop
"Check if the argument is an ok object.
If this is a pointers object, check that its fields are all okay oops."
| hasYoung i fieldOop |
(oop = nil or: [oop = 0]) ifTrue: [ ^true ]. "?? eem 1/16/2013"
(objectMemory isIntegerObject: oop) ifTrue: [ ^true ].
(objectMemory checkOkayOop: oop) ifFalse: [ ^false ].
(self checkOopHasOkayClass: oop) ifFalse: [ ^false ].
((objectMemory isPointersNonInt: oop) or: [objectMemory isCompiledMethod: oop]) ifFalse: [ ^true ].
+ hasYoung := objectMemory isYoung: (objectMemory fetchClassOfNonImm: oop).
- hasYoung := objectMemory isYoung: (objectMemory fetchClassOfNonInt: oop).
(objectMemory isCompiledMethod: oop)
ifTrue:
[i := (self literalCountOf: oop) + LiteralStart - 1]
ifFalse:
[(objectMemory isContext: oop)
ifTrue: [i := CtxtTempFrameStart + (self fetchStackPointerOf: oop) - 1]
ifFalse: [i := (objectMemory lengthOf: oop) - 1]].
[i >= 0] whileTrue:
[fieldOop := objectMemory fetchPointer: i ofObject: oop.
(objectMemory isNonIntegerObject: fieldOop) ifTrue:
[(i = 0 and: [objectMemory isCompiledMethod: oop])
ifTrue:
[(cogMethodZone methodFor: (self pointerForOop: fieldOop)) = 0 ifTrue:
[self print: 'method '; printHex: oop; print: ' has an invalid cog method reference'.
^false]]
ifFalse:
[hasYoung := hasYoung or: [objectMemory isYoung: fieldOop].
(objectMemory checkOkayOop: fieldOop) ifFalse: [ ^false ].
(self checkOopHasOkayClass: fieldOop) ifFalse: [ ^false ]]].
i := i - 1].
hasYoung ifTrue:
[^objectMemory checkOkayYoungReferrer: oop].
^true!
Item was changed:
----- Method: CoInterpreter>>printFrame:WithSP: (in category 'debug printing') -----
printFrame: theFP WithSP: theSP
<api>
| theMethod theMethodEnd numArgs numTemps rcvrAddress topThing |
<inline: false>
<var: #theFP type: #'char *'>
<var: #theSP type: #'char *'>
<var: #addr type: #'char *'>
<var: #rcvrAddress type: #'char *'>
<var: #cogMethod type: #'CogBlockMethod *'>
<var: #homeMethod type: #'CogMethod *'>
self cCode: '' inSmalltalk: [self transcript ensureCr].
(self isMachineCodeFrame: theFP)
ifTrue:
[| cogMethod homeMethod |
cogMethod := self mframeCogMethod: theFP.
homeMethod := self mframeHomeMethod: theFP.
theMethod := homeMethod asInteger.
theMethodEnd := homeMethod asInteger + homeMethod blockSize.
numArgs := cogMethod cmNumArgs.
numTemps := self temporaryCountOfMethodHeader: homeMethod methodHeader]
ifFalse:
[theMethod := self frameMethodObject: theFP.
theMethodEnd := theMethod + (objectMemory sizeBitsOfSafe: theMethod).
numArgs := self iframeNumArgs: theFP.
numTemps := self tempCountOf: theMethod].
(self frameIsBlockActivation: theFP) ifTrue:
[| rcvrOrClosure |
rcvrOrClosure := self pushedReceiverOrClosureOfFrame: theFP.
((objectMemory isNonIntegerObject: rcvrOrClosure)
and: [(objectMemory addressCouldBeObj: rcvrOrClosure)
+ and: [(objectMemory fetchClassOfNonImm: rcvrOrClosure) = (objectMemory splObj: ClassBlockClosure)]])
- and: [(objectMemory fetchClassOfNonInt: rcvrOrClosure) = (objectMemory splObj: ClassBlockClosure)]])
ifTrue: [numTemps := numArgs + (self stSizeOf: rcvrOrClosure)]
ifFalse: [numTemps := 0]].
self shortPrintFrame: theFP.
(self isBaseFrame: theFP) ifTrue:
[self printFrameOop: '(caller ctxt'
at: theFP + (self frameStackedReceiverOffset: theFP) + (2 * BytesPerWord).
self printFrameOop: '(saved ctxt'
at: theFP + (self frameStackedReceiverOffset: theFP) + (1 * BytesPerWord)].
self printFrameOop: 'rcvr/clsr'
at: theFP + FoxCallerSavedIP + ((numArgs + 1) * BytesPerWord).
numArgs to: 1 by: -1 do:
[:i|
self printFrameOop: 'arg' index: numArgs - i at: theFP + FoxCallerSavedIP + (i * BytesPerWord)].
self printFrameThing: 'caller ip' at: theFP + FoxCallerSavedIP.
self printFrameThing: 'saved fp' at: theFP + FoxSavedFP.
self printFrameMethodFor: theFP.
(self isMachineCodeFrame: theFP) ifFalse:
[self printFrameFlagsForFP: theFP].
self printFrameOop: 'context' at: theFP + FoxThisContext.
(self isMachineCodeFrame: theFP) ifTrue:
[self printFrameFlagsForFP: theFP].
(self isMachineCodeFrame: theFP)
ifTrue: [rcvrAddress := theFP + FoxMFReceiver]
ifFalse:
[self printFrameThing: 'saved ip'
at: theFP + FoxIFSavedIP
extra: ((self iframeSavedIP: theFP) = 0
ifTrue: [0]
ifFalse: [(self iframeSavedIP: theFP) - theMethod + 2 - BaseHeaderSize]).
rcvrAddress := theFP + FoxIFReceiver].
self printFrameOop: 'receiver' at: rcvrAddress.
topThing := stackPages longAt: theSP.
(topThing between: theMethod and: theMethodEnd)
ifTrue:
[rcvrAddress - BytesPerWord to: theSP + BytesPerWord by: BytesPerWord negated do:
[:addr| | index |
index := rcvrAddress - addr / BytesPerWord + numArgs.
index <= numTemps
ifTrue: [self printFrameOop: 'temp' index: index - 1 at: addr]
ifFalse: [self printFrameOop: 'stck' at: addr]].
self printFrameThing: 'frame ip'
at: theSP
extra: ((self isMachineCodeFrame: theFP)
ifTrue: [topThing - theMethod]
ifFalse: [topThing - theMethod + 2 - BaseHeaderSize])]
ifFalse:
[rcvrAddress - BytesPerWord to: theSP by: BytesPerWord negated do:
[:addr| | index |
index := rcvrAddress - addr / BytesPerWord + numArgs.
index <= numTemps
ifTrue: [self printFrameOop: 'temp' index: index - 1 at: addr]
ifFalse: [self printFrameOop: 'stck' at: addr]]]!
Item was changed:
----- Method: CoInterpreterPrimitives>>pathTo:using:followWeak: (in category 'object access primitives') -----
pathTo: goal using: stack followWeak: followWeak
"Trace objects and frames from the root, marking visited objects, pushing the current path on stack, until goal is found.
If found, unmark, leaving path in stack, and answer 0. Otherwise answer an error:
PrimErrBadArgument if stack is not an Array
PrimErrBadIndex if search overflows stack
PrimErrNotFound if goal cannot be found"
| current hdr index next stackSize stackp freeStartAtStart |
(objectMemory isArray: stack) ifFalse:
[^PrimErrBadArgument].
freeStartAtStart := objectMemory freeStart. "check no allocations during search"
objectMemory beRootIfOld: stack. "so no store checks are necessary on stack"
stackSize := objectMemory lengthOf: stack.
objectMemory mark: stack.
"no need. the current context is not reachable from the active process (suspendedContext is nil)"
"objectMemory mark: self activeProcess."
current := objectMemory specialObjectsOop.
objectMemory mark: current.
index := objectMemory lengthOf: current.
stackp := 0.
[[(index := index - 1) >= -1] whileTrue:
[next := (stackPages couldBeFramePointer: current)
ifTrue:
[index >= 0
ifTrue: [self field: index ofFrame: (self cCoerceSimple: current to: #'char *')]
ifFalse: [objectMemory nilObject]]
ifFalse:
[index >= 0
ifTrue:
[hdr := objectMemory baseHeader: current.
(objectMemory isContextHeader: hdr)
ifTrue: [self fieldOrSenderFP: index ofContext: current]
ifFalse: [objectMemory fetchPointer: index ofObject: current]]
ifFalse:
+ [objectMemory fetchClassOfNonImm: current]].
- [objectMemory fetchClassOfNonInt: current]].
(stackPages couldBeFramePointer: next)
ifTrue: [self assert: (self isFrame: (self cCoerceSimple: next to: #'char *')
onPage: (stackPages stackPageFor: (self cCoerceSimple: next to: #'char *')))]
ifFalse:
[next >= heapBase ifTrue:
[self assert: (self checkOkayOop: next)]].
next = goal ifTrue:
[self assert: freeStartAtStart = objectMemory freeStart.
self unmarkAfterPathTo.
objectMemory storePointer: stackp ofObject: stack withValue: current.
self pruneStack: stack stackp: stackp.
^0].
((objectMemory isNonIntegerObject: next)
and: [(stackPages couldBeFramePointer: next)
ifTrue: [(self frameIsMarked: next) not]
ifFalse:
[next >= heapBase "exclude Cog methods"
and: [(objectMemory isMarked: next) not
and: [((objectMemory isPointers: next) or: [objectMemory isCompiledMethod: next])
and: [followWeak or: [(objectMemory isWeakNonInt: next) not]]]]]])
ifTrue:
[stackp + 2 > stackSize ifTrue:
[self assert: freeStartAtStart = objectMemory freeStart.
self unmarkAfterPathTo.
objectMemory nilFieldsOf: stack.
^PrimErrBadIndex]. "PrimErrNoMemory ?"
objectMemory
storePointerUnchecked: stackp ofObject: stack withValue: current;
storePointerUnchecked: stackp + 1 ofObject: stack withValue: (objectMemory integerObjectOf: index).
stackp := stackp + 2.
(stackPages couldBeFramePointer: (self cCoerceSimple: next to: #'char *'))
ifTrue:
[self markFrame: next.
index := self fieldsInFrame: (self cCoerceSimple: next to: #'char *')]
ifFalse:
[hdr := objectMemory baseHeader: next.
objectMemory baseHeader: next put: (hdr bitOr: MarkBit).
(objectMemory isCompiledMethodHeader: hdr)
ifTrue: [index := (self literalCountOf: next) + LiteralStart]
ifFalse: [index := objectMemory lengthOf: next]].
current := next]].
current = objectMemory specialObjectsOop ifTrue:
[self assert: freeStartAtStart = objectMemory freeStart.
self unmarkAfterPathTo.
objectMemory nilFieldsOf: stack.
^PrimErrNotFound].
index := objectMemory integerValueOf: (objectMemory fetchPointer: stackp - 1 ofObject: stack).
current := objectMemory fetchPointer: stackp - 2 ofObject: stack.
stackp := stackp - 2] repeat!
Item was changed:
----- Method: CoInterpreterPrimitives>>primitiveLongRunningPrimitiveSemaphore (in category 'process primitives') -----
primitiveLongRunningPrimitiveSemaphore
"Primitive. Install the semaphore to be used for collecting long-running primitives,
or nil if no semaphore should be used."
| sema flushState activeContext |
<export: true>
sema := self stackValue: 0.
((objectMemory isIntegerObject: sema)
or: [self methodArgumentCount ~= 1]) ifTrue:
[^self primitiveFail].
sema = objectMemory nilObject
ifTrue:
[flushState := longRunningPrimitiveCheckSemaphore notNil.
longRunningPrimitiveCheckSemaphore := nil]
ifFalse:
[flushState := longRunningPrimitiveCheckSemaphore isNil.
+ (objectMemory fetchClassOfNonImm: sema) = (objectMemory splObj: ClassSemaphore) ifFalse:
- (objectMemory fetchClassOfNonInt: sema) = (objectMemory splObj: ClassSemaphore) ifFalse:
[^self primitiveFail].
longRunningPrimitiveCheckSemaphore := sema].
"If we've switched checking on or off we must void machine code
(and machine code pcs in contexts) since we will start or stop setting
newMethod in machine code primitive invocations, and so generate
slightly different code from here on in."
flushState ifTrue:
[self push: instructionPointer.
activeContext := self voidVMStateForSnapshot.
self marryContextInNewStackPageAndInitializeInterpreterRegisters: activeContext.
self assert: (((self stackValue: 0) = objectMemory nilObject and: [longRunningPrimitiveCheckSemaphore isNil])
or: [(self stackValue: 0) = longRunningPrimitiveCheckSemaphore
+ and: [(objectMemory fetchClassOfNonImm: sema) = (objectMemory splObj: ClassSemaphore)]])].
- and: [(objectMemory fetchClassOfNonInt: sema) = (objectMemory splObj: ClassSemaphore)]])].
self voidLongRunningPrimitive: 'install'.
self pop: 1.
flushState ifTrue:
[self siglong: reenterInterpreter jmp: ReturnToInterpreter]!
Item was changed:
----- Method: CoInterpreterPrimitives>>primitiveProfileSemaphore (in category 'process primitives') -----
primitiveProfileSemaphore
"Primitive. Install the semaphore to be used for profiling,
or nil if no semaphore should be used.
See also primitiveProfileStart."
| sema flushState activeContext |
<export: true>
sema := self stackValue: 0.
((objectMemory isIntegerObject: sema)
or: [self methodArgumentCount ~= 1]) ifTrue:
[^self primitiveFail].
sema = objectMemory nilObject
ifTrue:
[flushState := profileSemaphore ~= objectMemory nilObject]
ifFalse:
[flushState := profileSemaphore = objectMemory nilObject.
+ (objectMemory fetchClassOfNonImm: sema) = (objectMemory splObj: ClassSemaphore) ifFalse:
- (objectMemory fetchClassOfNonInt: sema) = (objectMemory splObj: ClassSemaphore) ifFalse:
[^self primitiveFail]].
profileSemaphore := sema.
"If we've switched profiling on or off we must void machine code
(and machine code pcs in contexts) since we will start or stop
testing the profile clock in machine code primitive invocations,
and so generate slightly different code from here on in."
flushState ifTrue:
[self push: instructionPointer.
activeContext := self voidVMStateForSnapshot.
self marryContextInNewStackPageAndInitializeInterpreterRegisters: activeContext.
self assert: (((self stackValue: 0) = objectMemory nilObject and: [profileSemaphore = objectMemory nilObject])
or: [(self stackValue: 0) = profileSemaphore
+ and: [(objectMemory fetchClassOfNonImm: sema) = (objectMemory splObj: ClassSemaphore)]])].
- and: [(objectMemory fetchClassOfNonInt: sema) = (objectMemory splObj: ClassSemaphore)]])].
profileProcess := profileMethod := objectMemory nilObject.
self pop: 1.
flushState ifTrue:
[self siglong: reenterInterpreter jmp: ReturnToInterpreter]!
Item was changed:
----- Method: Interpreter>>bytecodePrimValue (in category 'common selector sends') -----
bytecodePrimValue
"In-line value for BlockClosure and BlockContext"
| maybeBlock rcvrClass |
maybeBlock := self internalStackTop.
argumentCount := 0.
successFlag := true.
(self isNonIntegerObject: maybeBlock) ifTrue:
+ [rcvrClass := self fetchClassOfNonImm: maybeBlock.
- [rcvrClass := self fetchClassOfNonInt: maybeBlock.
rcvrClass = (self splObj: ClassBlockClosure)
ifTrue:
[self externalizeIPandSP.
self primitiveClosureValue.
self internalizeIPandSP]
ifFalse:
[rcvrClass = (self splObj: ClassBlockContext)
ifTrue:
[self externalizeIPandSP.
self primitiveValue.
self internalizeIPandSP]
ifFalse:
[successFlag := false]]].
successFlag ifFalse:
[messageSelector := self specialSelector: 25.
^self normalSend].
self fetchNextBytecode!
Item was changed:
----- Method: Interpreter>>bytecodePrimValueWithArg (in category 'common selector sends') -----
bytecodePrimValueWithArg
"In-line value: for BlockClosure and BlockContext"
| maybeBlock rcvrClass |
maybeBlock := self internalStackValue: 1.
argumentCount := 1.
successFlag := true.
(self isNonIntegerObject: maybeBlock) ifTrue:
+ [rcvrClass := self fetchClassOfNonImm: maybeBlock.
- [rcvrClass := self fetchClassOfNonInt: maybeBlock.
rcvrClass = (self splObj: ClassBlockClosure)
ifTrue:
[self externalizeIPandSP.
self primitiveClosureValue.
self internalizeIPandSP]
ifFalse:
[rcvrClass = (self splObj: ClassBlockContext)
ifTrue:
[self externalizeIPandSP.
self primitiveValue.
self internalizeIPandSP]
ifFalse:
[successFlag := false]]].
successFlag ifFalse:
[messageSelector := self specialSelector: 26.
^self normalSend].
self fetchNextBytecode!
Item was changed:
----- Method: Interpreter>>commonAt: (in category 'array primitive support') -----
commonAt: stringy
"This code is called if the receiver responds primitively to at:.
If this is so, it will be installed in the atCache so that subsequent calls of at:
or next may be handled immediately in bytecode primitive routines."
| index rcvr atIx result |
index := self positive32BitValueOf: (self stackTop). "Sets successFlag"
rcvr := self stackValue: 1.
successFlag & (self isIntegerObject: rcvr) not
ifFalse: [^ self primitiveFail].
"NOTE: The at-cache, since it is specific to the non-super response to #at:.
Therefore we must determine that the message is #at: (not, eg, #basicAt:),
and that the send is not a super-send, before using the at-cache."
(messageSelector = (self specialSelector: 16)
+ and: [lkupClass = (self fetchClassOfNonImm: rcvr)])
- and: [lkupClass = (self fetchClassOfNonInt: rcvr)])
ifTrue:
["OK -- look in the at-cache"
atIx := rcvr bitAnd: AtCacheMask. "Index into atCache = 4N, for N = 0 ... 7"
(atCache at: atIx+AtCacheOop) = rcvr ifFalse:
["Rcvr not in cache. Install it..."
self install: rcvr inAtCache: atCache at: atIx string: stringy].
successFlag ifTrue:
[result := self commonVariable: rcvr at: index cacheIndex: atIx].
successFlag ifTrue:
[^ self pop: argumentCount+1 thenPush: result]].
"The slow but sure way..."
successFlag := true.
result := self stObject: rcvr at: index.
successFlag ifTrue:
[stringy ifTrue: [result := self characterForAscii: (self integerValueOf: result)].
^ self pop: argumentCount+1 thenPush: result]!
Item was changed:
----- Method: Interpreter>>commonAtPut: (in category 'array primitive support') -----
commonAtPut: stringy
"This code is called if the receiver responds primitively to at:Put:.
If this is so, it will be installed in the atPutCache so that subsequent calls of at:
or next may be handled immediately in bytecode primitive routines."
| value index rcvr atIx |
value := self stackTop.
index := self positive32BitValueOf: (self stackValue: 1). "Sets successFlag"
rcvr := self stackValue: 2.
successFlag & (self isIntegerObject: rcvr) not
ifFalse: [^ self primitiveFail].
"NOTE: The atPut-cache, since it is specific to the non-super response to #at:Put:.
Therefore we must determine that the message is #at:Put: (not, eg, #basicAt:Put:),
and that the send is not a super-send, before using the at-cache."
(messageSelector = (self specialSelector: 17)
+ and: [lkupClass = (self fetchClassOfNonImm: rcvr)])
- and: [lkupClass = (self fetchClassOfNonInt: rcvr)])
ifTrue:
["OK -- look in the at-cache"
atIx := (rcvr bitAnd: AtCacheMask) + AtPutBase. "Index into atPutCache"
(atCache at: atIx+AtCacheOop) = rcvr ifFalse:
["Rcvr not in cache. Install it..."
self install: rcvr inAtCache: atCache at: atIx string: stringy].
successFlag ifTrue:
[self commonVariable: rcvr at: index put: value cacheIndex: atIx].
successFlag ifTrue:
[^ self pop: argumentCount+1 thenPush: value]].
"The slow but sure way..."
successFlag := true.
stringy ifTrue: [self stObject: rcvr at: index put: (self asciiOfCharacter: value)]
ifFalse: [self stObject: rcvr at: index put: value].
successFlag ifTrue: [^ self pop: argumentCount+1 thenPush: value].
!
Item was changed:
----- Method: Interpreter>>initializeInterpreter: (in category 'initialization') -----
initializeInterpreter: bytesToShift
"Initialize Interpreter state before starting execution of a new image."
interpreterProxy := self sqGetInterpreterProxy.
self dummyReferToProxy.
self initializeObjectMemory: bytesToShift.
self initCompilerHooks.
self checkAssumedCompactClasses.
+ metaclassSizeBits := self sizeBitsOf: (self fetchClassOfNonImm: (self splObj: ClassArray)). "determine actual (Metaclass instSize * 4)"
- metaclassSizeBits := self sizeBitsOf: (self fetchClassOfNonInt: (self splObj: ClassArray)). "determine actual (Metaclass instSize * 4)"
activeContext := nilObj.
theHomeContext := nilObj.
method := nilObj.
receiver := nilObj.
messageSelector := nilObj.
newMethod := nilObj.
lkupClass := nilObj.
receiverClass := nilObj.
self flushMethodCache.
self loadInitialContext.
self initialCleanup.
interruptCheckCounter := 0.
interruptCheckCounterFeedBackReset := 1000.
interruptChecksEveryNms := 1.
nextProfileTick := 0.
profileSemaphore := nilObj.
profileProcess := nilObj.
profileMethod := nilObj.
nextPollTick := 0.
nextWakeupTick := 0.
lastTick := 0.
interruptKeycode := 2094. "cmd-. as used for Mac but no other OS"
interruptPending := false.
semaphoresUseBufferA := true.
semaphoresToSignalCountA := 0.
semaphoresToSignalCountB := 0.
deferDisplayUpdates := false.
pendingFinalizationSignals := statPendingFinalizationSignals := 0.
globalSessionID := 0.
[globalSessionID = 0]
whileTrue: [globalSessionID := self
cCode: 'time(NULL) + ioMSecs()'
inSmalltalk: [(Random new next * SmallInteger maxVal) asInteger]].
jmpDepth := 0.
jmpMax := MaxJumpBuf. "xxxx: Must match the definition of jmpBuf and suspendedCallbacks"
statQuickCheckForEvents := 0.
statCheckForEvents := 0.
statProcessSwitch := 0.
statIOProcessEvents := 0
!
Item was changed:
----- Method: Interpreter>>isFloatObject: (in category 'plugin primitive support') -----
isFloatObject: oop
^(self isNonIntegerObject: oop)
+ and: [(self fetchClassOfNonImm: oop) = self classFloat]!
- and: [(self fetchClassOfNonInt: oop) = self classFloat]!
Item was changed:
----- Method: Interpreter>>primitiveChangeClass (in category 'object access primitives') -----
primitiveChangeClass
"Primitive. Change the class of the receiver into the class of the argument given that
the format of the receiver matches the format of the argument's class. Fail if the
receiver or argument are SmallIntegers, or the receiver is an instance of a compact
class and the argument isn't, or when the argument's class is compact and the receiver
isn't, or when the format of the receiver is different from the format of the argument's
class, or when the arguments class is fixed and the receiver's size differs from the size
that an instance of the argument's class should have."
| arg rcvr argClass err |
arg := self stackObjectValue: 0.
rcvr := self stackObjectValue: 1.
self successful ifFalse:[^nil].
+ argClass := self fetchClassOfNonImm: arg.
- argClass := self fetchClassOfNonInt: arg.
err := self changeClassOf: rcvr to: argClass.
err = 0
ifTrue: ["Flush at cache because rcvr's class has changed."
self flushAtCache.
self pop: self methodArgumentCount]
ifFalse: [self primitiveFail].
^nil!
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:
- ((vmHistArrayOrNil = nilObj or: [(self fetchClassOfNonInt: vmHistArrayOrNil) = (self splObj: ClassArray)])
- and: [(self fetchClassOfNonInt: vmHistArrayOrNil) = (self fetchClassOfNonInt: easHistArrayOrNil)]) ifFalse:
[^self primitiveFail].
self cCode: 'ioControlProfile(0,&vmHist,&vmBins,&easHist,&easBins)'
inSmalltalk: [vmHist := vmBins := easHist := easBins := 0].
vmHistArrayOrNil ~= nilObj ifTrue:
[((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>>sendInvokeCallback:Stack:Registers:Jmpbuf: (in category 'callback support') -----
sendInvokeCallback: thunkPtr Stack: stackPtr Registers: regsPtr Jmpbuf: jmpBufPtr
"Send the 4 argument callback message invokeCallback:stack:registers:jmpbuf:
to Alien class with the supplied args. The arguments are raw C addresses
and are converted to integer objects on the way."
| where |
<export: true>
self pushRemappableOop: (self positive32BitIntegerFor: jmpBufPtr).
self pushRemappableOop: (self positive32BitIntegerFor: regsPtr).
self pushRemappableOop: (self positive32BitIntegerFor: stackPtr).
self pushRemappableOop: (self positive32BitIntegerFor: thunkPtr).
receiver := self splObj: ClassAlien.
+ lkupClass := self fetchClassOfNonImm: receiver.
- lkupClass := self fetchClassOfNonInt: receiver.
messageSelector := self splObj: SelectorInvokeCallback.
(self lookupInMethodCacheSel: messageSelector class: lkupClass) ifFalse:
[(self lookupMethodNoMNUEtcInClass: lkupClass) ifFalse:
[^false]].
primitiveIndex ~= 0 ifTrue:
[^false].
self storeContextRegisters: activeContext.
self justActivateNewMethod.
where := activeContext + BaseHeaderSize + (ReceiverIndex << ShiftForWord).
self longAt: where + (1 << ShiftForWord) put: self popRemappableOop.
self longAt: where + (2 << ShiftForWord) put: self popRemappableOop.
self longAt: where + (3 << ShiftForWord) put: self popRemappableOop.
self longAt: where + (4 << ShiftForWord) put: self popRemappableOop.
self interpret.
"not reached"
^true!
Item was changed:
----- Method: Interpreter>>signed64BitValueOf: (in category 'primitive support') -----
signed64BitValueOf: oop
"Convert the given object into an integer value.
The object may be either a positive ST integer or a eight-byte LargeInteger."
| sz value largeClass negative szsqLong |
<inline: false>
<returnTypeC: #sqLong>
<var: #value type: #sqLong>
(self isIntegerObject: oop) ifTrue: [^self cCoerce: (self integerValueOf: oop) to: #sqLong].
+ largeClass := self fetchClassOfNonImm: oop.
- largeClass := self fetchClassOfNonInt: oop.
largeClass = self classLargePositiveInteger
ifTrue:[negative := false]
ifFalse:[largeClass = self classLargeNegativeInteger
ifTrue:[negative := true]
ifFalse:[^self primitiveFail]].
szsqLong := self sizeof: #sqLong.
sz := self lengthOf: oop.
sz > szsqLong
ifTrue: [^ self primitiveFail].
value := 0.
0 to: sz - 1 do: [:i |
value := value + ((self cCoerce: (self fetchByte: i ofObject: oop) to: #sqLong) << (i*8))].
"Filter out values out of range for the signed interpretation such as
16rFFFFFFFF... (positive w/ bit 64 set) and -16rFFFFFFFF... (negative w/ bit
64 set). Since the sign is implicit in the class we require that the high bit of
the magnitude is not set which is a simple test here. Note that we have to
handle the most negative 64-bit value -9223372036854775808 specially."
self cCode: []
inSmalltalk:
[(value anyMask: 16r8000000000000000) ifTrue:
[value := value - 16r10000000000000000]].
value < 0 ifTrue:
[self cCode:
[self assert: (self sizeof: value) == 8.
self assert: (self sizeof: value << 1) == 8].
"Don't fail for -9223372036854775808/-16r8000000000000000.
Alas the simple (negative and: [value - 1 > 0]) isn't adequate since in C the result of signed integer
overflow is undefined and hence under optimization this may fail. The shift, however, is well-defined."
(negative and: [0 = (self cCode: [value << 1]
inSmalltalk: [value << 1 bitAnd: (1 << 64) - 1])]) ifTrue:
[^value].
^self primitiveFail].
^negative
ifTrue:[0 - value]
ifFalse:[value]!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveChangeClass (in category 'object access primitives') -----
primitiveChangeClass
"Primitive. Change the class of the receiver into the class of the argument given that
the format of the receiver matches the format of the argument's class. Fail if the
receiver or argument are SmallIntegers, or the receiver is an instance of a compact
class and the argument isn't, or when the argument's class is compact and the receiver
isn't, or when the format of the receiver is different from the format of the argument's
class, or when the arguments class is fixed and the receiver's size differs from the size
that an instance of the argument's class should have."
| arg rcvr argClass err |
arg := self stackObjectValue: 0.
rcvr := self stackObjectValue: 1.
self successful ifFalse:[^nil].
+ argClass := objectMemory fetchClassOfNonImm: arg.
- argClass := objectMemory fetchClassOfNonInt: arg.
err := objectMemory changeClassOf: rcvr to: argClass.
err = 0
ifTrue: ["Flush at cache because rcvr's class has changed."
self flushAtCache.
self pop: self methodArgumentCount]
ifFalse: [self primitiveFailFor: err].
^nil!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveCopyObject (in category 'object access primitives') -----
primitiveCopyObject
"Primitive. Copy the state of the receiver from the argument.
Fail if receiver and argument are of a different class.
Fail if the receiver or argument are non-pointer objects.
Fail if receiver and argument have different lengths (for indexable objects).
"
| rcvr arg length |
self methodArgumentCount = 1 ifFalse:
[^self primitiveFail].
arg := self stackObjectValue: 0.
rcvr := self stackObjectValue: 1.
self failed ifTrue:[^nil].
(objectMemory isPointers: rcvr) ifFalse:
[^self primitiveFail].
+ (objectMemory fetchClassOfNonImm: rcvr) = (objectMemory fetchClassOfNonImm: arg) ifFalse:
- (objectMemory fetchClassOfNonInt: rcvr) = (objectMemory fetchClassOfNonInt: arg) ifFalse:
[^self primitiveFail].
length := objectMemory lengthOf: rcvr.
length = (objectMemory lengthOf: arg) ifFalse:
[^self primitiveFail].
"Now copy the elements"
0 to: length-1 do:[:i|
objectMemory storePointer: i ofObject: rcvr withValue: (objectMemory fetchPointer: i ofObject: arg)].
"Note: The above could be faster for young receivers but I don't think it'll matter"
self pop: 1. "pop arg; answer receiver"
!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveNextInstance (in category 'object access primitives') -----
primitiveNextInstance
+ | object subsequentObject |
- | object classPointer subsequentObject |
object := self stackTop.
+ (objectMemory isImmediate: object) ifFalse:
+ [subsequentObject := objectMemory instanceAfter: object.
+ subsequentObject ifNotNil:
+ [^self pop: argumentCount+1 thenPush: subsequentObject]].
- (objectMemory isIntegerObject: object) ifFalse:
- [classPointer := objectMemory fetchClassOfNonInt: object.
- subsequentObject := objectMemory objectAfter: object.
- [self oop: subsequentObject isLessThan: objectMemory freeStart] whileTrue:
- [((objectMemory isFreeObject: subsequentObject) not
- and: [(objectMemory fetchClassOfNonInt: subsequentObject) = classPointer]) ifTrue:
- [^self pop: argumentCount+1 thenPush: subsequentObject].
- subsequentObject := objectMemory objectAfter: subsequentObject]].
self primitiveFail!
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:
- ((vmHistArrayOrNil = objectMemory nilObject or: [(objectMemory fetchClassOfNonInt: vmHistArrayOrNil) = (objectMemory splObj: ClassArray)])
- and: [(objectMemory fetchClassOfNonInt: vmHistArrayOrNil) = (objectMemory fetchClassOfNonInt: easHistArrayOrNil)]) ifFalse:
[^self primitiveFail].
self cCode: 'ioControlProfile(0,&vmHist,&vmBins,&easHist,&easBins)'
inSmalltalk: [vmHist := vmBins := easHist := easBins := 0].
vmHistArrayOrNil ~= objectMemory nilObject ifTrue:
[((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: NewObjectMemory>>lookupAddress: (in category 'simulation') -----
lookupAddress: address
"If address appears to be that of a Symbol or a few well-known objects (such as classes) answer it, otherwise answer nil.
For code disassembly"
<doNotGenerate>
| fmt size string class classSize maybeThisClass classNameIndex thisClassIndex |
(self addressCouldBeObj: address) ifFalse:
[^nil].
fmt := self formatOf: address.
size := self lengthOf: address baseHeader: (self baseHeader: address) format: fmt.
size = 0 ifTrue:
[^address caseOf: { [nilObj] -> ['nil']. [trueObj] -> ['true']. [falseObj] -> ['false'] } otherwise: []].
((fmt between: 8 and: 11) "indexable byte fields"
and: [(size between: 1 and: 64)
and: [Scanner isLiteralSymbol: (string := (0 to: size - 1) collect: [:i| Character value: (self fetchByte: i ofObject: address)])]]) ifTrue:
[^'#', (ByteString withAll: string)].
+ class := self fetchClassOfNonImm: address.
- class := self fetchClassOfNonInt: address.
((self addressCouldBeObj: class)
and: [(self headerType: class) ~= HeaderTypeShort]) ifFalse:
[^nil].
"address is either a class or a metaclass, or an instance of a class or invalid. determine which."
classNameIndex := coInterpreter classNameIndex.
thisClassIndex := coInterpreter thisClassIndex.
((classSize := self lengthOf: class baseHeader: (self baseHeader: address) format: fmt) <= (classNameIndex max: thisClassIndex)
or: [classSize > 255]) ifTrue:
[^nil].
"Address could be a class or a metaclass"
(fmt = 1 and: [size >= classNameIndex]) ifTrue:
["Is address a class? If so class's thisClass is address."
(self lookupAddress: (self fetchPointer: classNameIndex ofObject: address)) ifNotNil:
[:maybeClassName|
(self fetchPointer: thisClassIndex ofObject: class) = address ifTrue:
[^maybeClassName allButFirst]].
"Is address a Metaclass? If so class's name is Metaclass and address's thisClass holds the class name"
((self isBytes: (self fetchPointer: classNameIndex ofObject: class))
and: [(self lookupAddress: (self fetchPointer: classNameIndex ofObject: class)) = '#Metaclass'
and: [size >= thisClassIndex]]) ifTrue:
[maybeThisClass := self fetchPointer: thisClassIndex ofObject: address.
(self lookupAddress: (self fetchPointer: classNameIndex ofObject: maybeThisClass)) ifNotNil:
[:maybeThisClassName| ^maybeThisClassName allButFirst, ' class']]].
^(self lookupAddress: (self fetchPointer: classNameIndex ofObject: class)) ifNotNil:
[:maybeClassName| 'a(n) ', maybeClassName allButFirst]!
Item was changed:
----- Method: NewObjectMemory>>oopHasAcceptableClass: (in category 'image segment in/out') -----
oopHasAcceptableClass: signedOop
"Similar to oopHasOkayClass:, except that it only returns true or false."
| oopClass formatMask behaviorFormatBits oopFormatBits oop |
<var: #oop type: #usqInt>
<var: #oopClass type: #usqInt>
(self isIntegerObject: signedOop) ifTrue: [^ true].
oop := self cCoerce: signedOop to: #usqInt.
(self addressCouldBeObj: oop) ifFalse: [^ false].
+ oopClass := self cCoerce: (self fetchClassOfNonImm: oop) to: #usqInt.
- oopClass := self cCoerce: (self fetchClassOfNonInt: oop) to: #usqInt.
(self addressCouldBeObj: oopClass) ifFalse: [^ false].
(oopClass + (self sizeBitsOf: oopClass)) <= freeStart ifFalse: [^ false].
((self isPointersNonInt: oopClass) and: [(self lengthOf: oopClass) >= 3]) ifFalse: [^ false].
formatMask := (self isBytesNonInt: oop)
ifTrue: [16rC00] "ignore extra bytes size bits"
ifFalse: [16rF00].
behaviorFormatBits := (self formatOfClass: oopClass) bitAnd: formatMask.
oopFormatBits := (self baseHeader: oop) bitAnd: formatMask.
behaviorFormatBits = oopFormatBits ifFalse: [^ false].
^ true!
Item was changed:
----- Method: NewspeakInterpreter>>bytecodePrimValue (in category 'common selector sends') -----
bytecodePrimValue
"In-line value for BlockClosure and BlockContext"
| maybeBlock rcvrClass |
maybeBlock := self internalStackTop.
self initPrimCall.
argumentCount := 0.
(self isNonIntegerObject: maybeBlock) ifTrue:
+ [rcvrClass := self fetchClassOfNonImm: maybeBlock.
- [rcvrClass := self fetchClassOfNonInt: maybeBlock.
rcvrClass = (self splObj: ClassBlockClosure)
ifTrue:
[self externalizeIPandSP.
self primitiveClosureValue.
self internalizeIPandSP]
ifFalse:
[rcvrClass = (self splObj: ClassBlockContext)
ifTrue:
[self externalizeIPandSP.
self primitiveValue.
self internalizeIPandSP]
ifFalse:
[self primitiveFail]]].
self successful ifFalse:
[messageSelector := self specialSelector: 25.
^self normalSend].
self fetchNextBytecode!
Item was changed:
----- Method: NewspeakInterpreter>>bytecodePrimValueWithArg (in category 'common selector sends') -----
bytecodePrimValueWithArg
"In-line value: for BlockClosure and BlockContext"
| maybeBlock rcvrClass |
maybeBlock := self internalStackValue: 1.
self initPrimCall.
argumentCount := 1.
(self isNonIntegerObject: maybeBlock) ifTrue:
+ [rcvrClass := self fetchClassOfNonImm: maybeBlock.
- [rcvrClass := self fetchClassOfNonInt: maybeBlock.
rcvrClass = (self splObj: ClassBlockClosure)
ifTrue:
[self externalizeIPandSP.
self primitiveClosureValue.
self internalizeIPandSP]
ifFalse:
[rcvrClass = (self splObj: ClassBlockContext)
ifTrue:
[self externalizeIPandSP.
self primitiveValue.
self internalizeIPandSP]
ifFalse:
[self primitiveFail]]].
self successful ifFalse:
[messageSelector := self specialSelector: 26.
^self normalSend].
self fetchNextBytecode!
Item was changed:
----- Method: NewspeakInterpreter>>commonAt: (in category 'indexing primitive support') -----
commonAt: stringy
"This code is called if the receiver responds primitively to at:.
If this is so, it will be installed in the atCache so that subsequent calls of at:
or next may be handled immediately in bytecode primitive routines."
| index rcvr atIx result |
self initPrimCall.
rcvr := self stackObjectValue: 1.
self successful ifFalse:
[^self primitiveFailFor: PrimErrInappropriate].
index := self positive32BitValueOf: self stackTop.
self successful ifFalse:
[^self primitiveFailFor: PrimErrBadArgument].
"NOTE: The at-cache, since it is specific to the non-super response to #at:.
Therefore we must determine that the message is #at: (not, eg, #basicAt:),
and that the send is not a super-send, before using the at-cache."
(messageSelector = (self specialSelector: 16)
+ and: [lkupClass = (self fetchClassOfNonImm: rcvr)])
- and: [lkupClass = (self fetchClassOfNonInt: rcvr)])
ifTrue:
["OK -- look in the at-cache"
atIx := rcvr bitAnd: AtCacheMask. "Index into atCache = 4N, for N = 0 ... 7"
(atCache at: atIx+AtCacheOop) = rcvr ifFalse:
["Rcvr not in cache. Install it..."
self install: rcvr inAtCache: atCache at: atIx string: stringy].
self successful ifTrue:
[result := self commonVariable: rcvr at: index cacheIndex: atIx].
self successful ifTrue:
[^ self pop: argumentCount+1 thenPush: result]].
"The slow but sure way..."
self initPrimCall.
result := self stObject: rcvr at: index.
self successful ifTrue:
[stringy ifTrue: [result := self characterForAscii: (self integerValueOf: result)].
^ self pop: argumentCount+1 thenPush: result]!
Item was changed:
----- Method: NewspeakInterpreter>>commonAtPut: (in category 'indexing primitive support') -----
commonAtPut: stringy
"This code is called if the receiver responds primitively to at:Put:.
If this is so, it will be installed in the atPutCache so that subsequent calls of at:
or next may be handled immediately in bytecode primitive routines."
| value index rcvr atIx |
self initPrimCall.
rcvr := self stackObjectValue: 2.
self successful ifFalse:
[^self primitiveFailFor: PrimErrInappropriate].
index := self positive32BitValueOf: (self stackValue: 1).
self successful ifFalse:
[^self primitiveFailFor: PrimErrBadArgument].
(self isOopImmutable: rcvr) ifTrue:
[^self primitiveFailFor: PrimErrNoModification].
value := self stackTop.
"NOTE: The atPut-cache, since it is specific to the non-super response to #at:Put:.
Therefore we must determine that the message is #at:Put: (not, eg, #basicAt:Put:),
and that the send is not a super-send, before using the at-cache."
(messageSelector = (self specialSelector: 17)
+ and: [lkupClass = (self fetchClassOfNonImm: rcvr)])
- and: [lkupClass = (self fetchClassOfNonInt: rcvr)])
ifTrue:
["OK -- look in the at-cache"
atIx := (rcvr bitAnd: AtCacheMask) + AtPutBase. "Index into atPutCache"
(atCache at: atIx+AtCacheOop) = rcvr ifFalse:
["Rcvr not in cache. Install it..."
self install: rcvr inAtCache: atCache at: atIx string: stringy].
self successful ifTrue:
[self commonVariable: rcvr at: index put: value cacheIndex: atIx].
self successful ifTrue:
[^ self pop: argumentCount+1 thenPush: value]].
"The slow but sure way..."
self initPrimCall.
stringy ifTrue: [self stObject: rcvr at: index put: (self asciiOfCharacter: value)]
ifFalse: [self stObject: rcvr at: index put: value].
self successful ifTrue: [^ self pop: argumentCount+1 thenPush: value].
!
Item was changed:
----- Method: NewspeakInterpreter>>dbgFloatValueOf: (in category 'utilities') -----
dbgFloatValueOf: oop
"This version answers the value of a float or nil if not a flat *WITHOUT* setting successFlag or any other such nonsense. It is hence safe for use in debug printing. Sheesh."
| result |
<returnTypeC: #double>
<var: #result type: #double>
self flag: #Dan. "None of the float stuff has been converted for 64 bits"
((self isNonIntegerObject: oop)
+ and: [(self fetchClassOfNonImm: oop) = (self splObj: ClassFloat)]) ifTrue:
- and: [(self fetchClassOfNonInt: oop) = (self splObj: ClassFloat)]) ifTrue:
[self cCode: '' inSmalltalk: [result := Float new: 2].
self fetchFloatAt: oop + BaseHeaderSize into: result.
^result].
^nil!
Item was changed:
----- Method: NewspeakInterpreter>>doSignalSemaphoreWithIndex: (in category 'process primitive support') -----
doSignalSemaphoreWithIndex: index
"Signal the external semaphore with the given index. Answer if a context switch
occurs as a result. Do not bounds check. This has been done in the caller."
<api>
| xArray semaphoreClass sema |
xArray := self splObj: ExternalObjectsArray.
semaphoreClass := self splObj: ClassSemaphore.
sema := self fetchPointer: index - 1 ofObject: xArray. "Note: semaphore indices are 1-based"
^(self isNonIntegerObject: sema)
+ and: [(self fetchClassOfNonImm: sema) = semaphoreClass
- and: [(self fetchClassOfNonInt: sema) = semaphoreClass
and: [self synchronousSignal: sema]]!
Item was changed:
----- Method: NewspeakInterpreter>>initializeExtraClassInstVarIndices (in category 'initialization') -----
initializeExtraClassInstVarIndices
"Initialize metaclassSizeBits and thisClassIndex which are used in debug printing, and
classNameIndex which is used not only for debug printing but for is:KindOf: & is:MemberOf:
via classNameOf:is: (evil but a reality we have to accept)."
| classArrayObj classArrayClass |
classNameIndex := 6. "default"
thisClassIndex := 5. "default"
classArrayObj := self splObj: ClassArray.
+ classArrayClass := self fetchClassOfNonImm: classArrayObj.
- classArrayClass := self fetchClassOfNonInt: classArrayObj.
metaclassSizeBits := self sizeBitsOf: classArrayClass. "determine actual (Metaclass instSize * 4)"
InstanceSpecificationIndex + 1 to: (self lengthOf: classArrayClass) do:
[:i|
(self fetchPointer: i ofObject: classArrayClass) = classArrayObj ifTrue:
[thisClassIndex := i]].
InstanceSpecificationIndex + 1 to: (self lengthOf: classArrayObj) do:
[:i| | oop |
oop := self fetchPointer: i ofObject: classArrayObj.
((self isBytes: oop)
and: [(self lengthOf: oop) = 5
and: [(self str: 'Array' n: (self firstFixedField: oop) cmp: 5) = 0]]) ifTrue:
[classNameIndex := i]]!
Item was changed:
----- Method: NewspeakInterpreter>>isFloatObject: (in category 'internal interpreter access') -----
isFloatObject: oop
^(self isNonIntegerObject: oop)
+ and: [(self fetchClassOfNonImm: oop) = self classFloat]!
- and: [(self fetchClassOfNonInt: oop) = self classFloat]!
Item was changed:
----- Method: NewspeakInterpreter>>primitiveChangeClass (in category 'object access primitives') -----
primitiveChangeClass
"Primitive. Change the class of the receiver into the class of the argument given that
the format of the receiver matches the format of the argument's class. Fail if the
receiver or argument are SmallIntegers, or the receiver is an instance of a compact
class and the argument isn't, or when the argument's class is compact and the receiver
isn't, or when the format of the receiver is different from the format of the argument's
class, or when the arguments class is fixed and the receiver's size differs from the size
that an instance of the argument's class should have."
| arg rcvr argClass err |
arg := self stackObjectValue: 0.
rcvr := self stackObjectValue: 1.
self successful ifFalse:[^nil].
+ argClass := self fetchClassOfNonImm: arg.
- argClass := self fetchClassOfNonInt: arg.
err := self changeClassOf: rcvr to: argClass.
err = 0
ifTrue: ["Flush at cache because rcvr's class has changed."
self flushAtCache.
self pop: self methodArgumentCount]
ifFalse: [self primitiveFailFor: err].
^nil!
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 := self fetchClassOfNonInt: oop.
(classObj = semaphoreClass) ifTrue:
[self printProcsOnList: oop].
oop := self objectAfter: oop].
schedLists := self fetchPointer: ProcessListsIndex ofObject: self schedulerPointer.
(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>>printOop: (in category 'debug printing') -----
printOop: oop
| cls fmt lastIndex startIP bytecodesPerLine |
<inline: false>
self printHex: oop.
(self isIntegerObject: oop) ifTrue:
[^self
cCode: 'printf("=%ld\n", (long)integerValueOf(oop))'
inSmalltalk: [self print: (self shortPrint: oop); cr]].
(oop between: self startOfMemory and: freeBlock) ifFalse:
[self printHex: oop; print: ' is not on the heap'; cr.
^nil].
(oop bitAnd: (BytesPerWord - 1)) ~= 0 ifTrue:
[self printHex: oop; print: ' is misaligned'; cr.
^nil].
(self isFreeObject: oop) ifTrue:
[self print: ' free chunk of size '; printNum: (self sizeOfFree: oop); cr.
^nil].
self print: ': a(n) '.
+ self printNameOfClass: (cls := self fetchClassOfNonImm: oop) count: 5.
- self printNameOfClass: (cls := self fetchClassOfNonInt: oop) count: 5.
cls = (self splObj: ClassFloat) ifTrue:
[self cr; printFloat: (self dbgFloatValueOf: oop); cr.
^nil].
fmt := self formatOf: oop.
fmt > 4 ifTrue:
[self print: ' nbytes '; printNum: (self byteSizeOf: oop)].
self cr.
(fmt > 4 and: [fmt < 12]) ifTrue:
[(self isWords: oop) ifTrue:
[lastIndex := 64 min: ((self byteSizeOf: oop) / BytesPerWord).
lastIndex > 0 ifTrue:
[1 to: lastIndex do:
[:index|
self space; printHex: (self fetchLong32: index - 1 ofObject: oop).
(index \\ self elementsPerPrintOopLine) = 0 ifTrue:
[self cr]].
(lastIndex \\ self elementsPerPrintOopLine) = 0 ifFalse:
[self cr]].
^nil].
^self printStringOf: oop; cr].
lastIndex := 64 min: (startIP := (self lastPointerOf: oop) / BytesPerWord).
lastIndex > 0 ifTrue:
[1 to: lastIndex do:
[:index|
self cCode: 'printHex(fetchPointerofObject(index - 1, oop)); putchar('' '')'
inSmalltalk: [self space; printHex: (self fetchPointer: index - 1 ofObject: oop); space.
self print: (self shortPrint: (self fetchPointer: index - 1 ofObject: oop))].
(index \\ self elementsPerPrintOopLine) = 0 ifTrue:
[self cr]].
(lastIndex \\ self elementsPerPrintOopLine) = 0 ifFalse:
[self cr]].
(self isCompiledMethod: oop)
ifFalse:
[startIP > 64 ifTrue: [self print: '...'; cr]]
ifTrue:
[startIP := startIP * BytesPerWord + 1.
lastIndex := self lengthOf: oop.
lastIndex - startIP > 100 ifTrue:
[lastIndex := startIP + 100].
bytecodesPerLine := 10.
startIP to: lastIndex do:
[:index| | byte |
byte := self fetchByte: index - 1 ofObject: oop.
self cCode: 'printf(" %02x/%-3d", byte,byte)'
inSmalltalk: [self space; print: (byte radix: 16); printChar: $/; printNum: byte].
((index - startIP + 1) \\ bytecodesPerLine) = 0 ifTrue:
[self cr]].
((lastIndex - startIP + 1) \\ bytecodesPerLine) = 0 ifFalse:
[self cr]]!
Item was changed:
----- Method: NewspeakInterpreter>>sendInvokeCallback:Stack:Registers:Jmpbuf: (in category 'callback support') -----
sendInvokeCallback: thunkPtr Stack: stackPtr Registers: regsPtr Jmpbuf: jmpBufPtr
"Send the 4 argument callback message invokeCallback:stack:registers:jmpbuf:
to Alien class with the supplied args. The arguments are raw C addresses
and are converted to integer objects on the way."
| where |
<export: true>
self pushRemappableOop: (self positive32BitIntegerFor: jmpBufPtr).
self pushRemappableOop: (self positive32BitIntegerFor: regsPtr).
self pushRemappableOop: (self positive32BitIntegerFor: stackPtr).
self pushRemappableOop: (self positive32BitIntegerFor: thunkPtr).
receiver := self splObj: ClassAlien.
+ lkupClass := self fetchClassOfNonImm: receiver.
- lkupClass := self fetchClassOfNonInt: receiver.
messageSelector := self splObj: SelectorInvokeCallback.
(self lookupInMethodCacheSel: messageSelector class: lkupClass) ifFalse:
[(self lookupMethodNoMNUEtcInClass: lkupClass) ifFalse:
[^false]].
((self argumentCountOf: newMethod) = 4
and: [primitiveFunctionPointer = 0]) ifFalse:
[^false].
self storeContextRegisters: activeContext.
self justActivateNewMethod.
where := activeContext + BaseHeaderSize + (ReceiverIndex << ShiftForWord).
self longAt: where + (1 << ShiftForWord) put: self popRemappableOop.
self longAt: where + (2 << ShiftForWord) put: self popRemappableOop.
self longAt: where + (3 << ShiftForWord) put: self popRemappableOop.
self longAt: where + (4 << ShiftForWord) put: self popRemappableOop.
self interpret.
"not reached"
^true!
Item was changed:
----- Method: NewspeakInterpreter>>sendInvokeCallbackContext: (in category 'callback support') -----
sendInvokeCallbackContext: vmCallbackContext
"Send the calllback message to Alien class with the supplied arg(s). Use either the
1 arg invokeCallbackContext: or the 4 arg invokeCallback:stack:registers:jmpbuf:
message, depending on what selector is installed in the specialObjectsArray.
Note that if invoking the legacy invokeCallback:stack:registers:jmpbuf: we pass the
vmCallbackContext as the jmpbuf argument (see reestablishContextPriorToCallback:).
The arguments are raw C addresses and are converted to integer objects on the way."
<export: true>
<var: #vmCallbackContext type: #'VMCallbackContext *'>
| relativeSP |
receiver := self splObj: ClassAlien.
+ lkupClass := self fetchClassOfNonImm: receiver.
- lkupClass := self fetchClassOfNonInt: receiver.
messageSelector := self splObj: SelectorInvokeCallback.
(self lookupInMethodCacheSel: messageSelector class: lkupClass) ifFalse:
[(self lookupMethodNoMNUEtcInClass: lkupClass) ~= 0 ifTrue:
[^false]].
primitiveFunctionPointer ~= 0 ifTrue:
[^false].
self storeContextRegisters: activeContext.
self justActivateNewMethod.
relativeSP := stackPointer - activeContext.
stackPointer := activeContext + BaseHeaderSize + (ReceiverIndex * BytesPerWord).
self cppIf: BytesPerWord = 8
ifTrue:
[(self argumentCountOf: newMethod) = 4 ifTrue:
[self push: (self positive64BitIntegerFor: vmCallbackContext thunkp asUnsignedInteger).
self push: (self positive64BitIntegerFor: vmCallbackContext stackp asUnsignedInteger).
self push: (self positive64BitIntegerFor: vmCallbackContext intregargsp asUnsignedInteger)].
self push: (self positive64BitIntegerFor: vmCallbackContext asUnsignedInteger)]
ifFalse:
[(self argumentCountOf: newMethod) = 4 ifTrue:
[self push: (self positive32BitIntegerFor: vmCallbackContext thunkp asUnsignedInteger).
self push: (self positive32BitIntegerFor: vmCallbackContext stackp asUnsignedInteger).
self push: (self positive32BitIntegerFor: vmCallbackContext intregargsp asUnsignedInteger)].
self push: (self positive32BitIntegerFor: vmCallbackContext asUnsignedInteger)].
stackPointer := activeContext + relativeSP.
self assert: (self validInstructionPointer: instructionPointer inMethod: method).
self interpret.
"not reached"
^true!
Item was added:
+ ----- Method: ObjectMemory>>allocationUnit (in category 'allocation') -----
+ allocationUnit
+ ^BytesPerWord!
Item was added:
+ ----- 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 removed:
- ----- Method: ObjectMemory>>fetchClassOfNonInt: (in category 'interpreter access') -----
- fetchClassOfNonInt: oop
- | ccIndex |
- <inline: true>
- <asmLabel: false>
- ^(ccIndex := (self compactClassIndexOf: oop)) = 0
- ifTrue: [(self classHeader: oop) bitAnd: AllButTypeMask]
- ifFalse: [self compactClassAt: ccIndex]!
Item was added:
+ ----- Method: ObjectMemory>>firstByteFormat (in category 'header access') -----
+ firstByteFormat
+ ^8!
Item was changed:
----- Method: ObjectMemory>>fixedFieldsOf:format:length: (in category 'object format') -----
fixedFieldsOf: oop format: fmt length: wordLength
"
NOTE: This code supports the backward-compatible extension to 8 bits of instSize.
When we revise the image format, it should become...
^ (classFormat >> 2 bitAnd: 16rFF) - 1
"
| class classFormat |
<inline: true>
<asmLabel: false>
((fmt > 4) or: [fmt = 2]) ifTrue: [^0]. "indexable fields only"
fmt < 2 ifTrue: [^wordLength]. "fixed fields only (zero or more)"
"fmt = 3 or 4: mixture of fixed and indexable fields, so must look at class format word"
+ class := self fetchClassOfNonImm: oop.
- class := self fetchClassOfNonInt: oop.
classFormat := self formatOfClass: class.
^(classFormat >> 11 bitAnd: 16rC0) + (classFormat >> 2 bitAnd: 16r3F) - 1!
Item was changed:
+ ----- Method: ObjectMemory>>instanceAfter: (in category 'primitive support') -----
+ instanceAfter: objOop
+ "Answer the next instance of objOop's class in the canonical enumeration order,
+ if it exists, otherwise answer nil."
+ | classPointer subsequentObject |
+ classPointer := self fetchClassOfNonImm: objOop.
+ subsequentObject := self objectAfter: objOop.
+ [self oop: subsequentObject isLessThan: self freeStart] whileTrue:
+ [((self isFreeObject: subsequentObject) not
+ and: [(self fetchClassOfNonImm: subsequentObject) = classPointer]) ifTrue:
+ [^subsequentObject].
+ subsequentObject := self objectAfter: subsequentObject].
+ ^nil!
- ----- Method: ObjectMemory>>instanceAfter: (in category 'object enumeration') -----
- instanceAfter: objectPointer
- "Support for instance enumeration. Return the next instance
- of the class of the given object, or nilObj if the enumeration
- is complete."
- | classPointer thisObj thisClass |
- classPointer := self fetchClassOfNonInt: objectPointer.
- thisObj := self accessibleObjectAfter: objectPointer.
- [thisObj = nil] whileFalse:
- [thisClass := self fetchClassOfNonInt: thisObj.
- thisClass = classPointer ifTrue: [^ thisObj].
- thisObj := self accessibleObjectAfter: thisObj].
- ^ nilObj!
Item was added:
+ ----- Method: ObjectMemory>>isPointersNonImm: (in category 'header access') -----
+ isPointersNonImm: objOop
+ "Answer if the argument has only fields that can hold oops. See comment in formatOf:"
+
+ ^(self formatOf: objOop) <= 4!
Item was changed:
----- Method: ObjectMemory>>nonWeakFieldsOf: (in category 'object format') -----
nonWeakFieldsOf: oop
"Return the number of non-weak fields in oop (i.e. the number of fixed fields).
Note: The following is copied from fixedFieldsOf:format:length: since we do know
the format of the oop (e.g. format = 4) and thus don't need the length."
| class classFormat |
self assert: (self isWeakNonInt: oop).
"fmt = 3 or 4: mixture of fixed and indexable fields, so must look at class format word"
+ class := self fetchClassOfNonImm: oop.
- class := self fetchClassOfNonInt: oop.
classFormat := self formatOfClass: class.
^(classFormat >> 11 bitAnd: 16rC0) + (classFormat >> 2 bitAnd: 16r3F) - 1!
Item was changed:
----- Method: ObjectMemory>>oopHasAcceptableClass: (in category 'image segment in/out') -----
oopHasAcceptableClass: signedOop
"Similar to oopHasOkayClass:, except that it only returns true or false."
| oopClass formatMask behaviorFormatBits oopFormatBits oop |
<var: #oop type: #usqInt>
<var: #oopClass type: #usqInt>
(self isIntegerObject: signedOop) ifTrue: [^ true].
oop := self cCoerce: signedOop to: #usqInt.
(self addressCouldBeObj: oop) ifFalse: [^ false].
+ oopClass := self cCoerce: (self fetchClassOfNonImm: oop) to: #usqInt.
- oopClass := self cCoerce: (self fetchClassOfNonInt: oop) to: #usqInt.
(self addressCouldBeObj: oopClass) ifFalse: [^ false].
(oopClass + (self sizeBitsOf: oopClass)) < freeBlock ifFalse: [^ false].
((self isPointersNonInt: oopClass) and: [(self lengthOf: oopClass) >= 3]) ifFalse: [^ false].
formatMask := (self isBytesNonInt: oop)
ifTrue: [16rC00] "ignore extra bytes size bits"
ifFalse: [16rF00].
behaviorFormatBits := (self formatOfClass: oopClass) bitAnd: formatMask.
oopFormatBits := (self baseHeader: oop) bitAnd: formatMask.
behaviorFormatBits = oopFormatBits ifFalse: [^ false].
^ true!
Item was changed:
----- Method: ObjectMemory>>printInstancesOf: (in category 'debug printing') -----
printInstancesOf: aClassOop
"Scan the heap printing the oops of any and all objects that are instances of aClassOop"
| oop |
<api>
oop := self firstAccessibleObject.
[oop = nil] whileFalse:
+ [(self fetchClassOfNonImm: oop) = aClassOop ifTrue:
- [(self fetchClassOfNonInt: oop) = aClassOop ifTrue:
[self printHex: oop; cr].
oop := self accessibleObjectAfter: oop]!
Item was added:
+ ----- Method: Spur32BitMMLESimulator>>byteAtPointer: (in category 'memory access') -----
+ byteAtPointer: pointer
+ "This gets implemented by Macros in C, where its types will also be checked.
+ pointer is a raw address."
+
+ ^self byteAt: pointer!
Item was removed:
- ----- Method: Spur32BitMemoryManager>>isImmediate: (in category 'object testing') -----
- isImmediate: oop
- ^(oop bitAnd: 3) ~= 0!
Item was removed:
- ----- Method: Spur32BitMemoryManager>>isNonImmediate: (in category 'object testing') -----
- isNonImmediate: oop
- ^(oop bitAnd: 3) = 0!
Item was added:
+ ----- Method: Spur32BitMemoryManager>>tagMask (in category 'word size') -----
+ tagMask
+ ^3!
Item was removed:
- ----- Method: Spur64BitMemoryManager>>isImmediate: (in category 'object testing') -----
- isImmediate: oop
- ^(oop bitAnd: 7) ~= 0!
Item was removed:
- ----- Method: Spur64BitMemoryManager>>isNonImmediate: (in category 'object testing') -----
- isNonImmediate: oop
- ^(oop bitAnd: 7) = 0!
Item was added:
+ ----- Method: Spur64BitMemoryManager>>tagMask (in category 'word size') -----
+ tagMask
+ ^7!
Item was changed:
----- Method: SpurGenerationScavenger>>scavengeReferentsOf: (in category 'scavenger') -----
scavengeReferentsOf: referrer
"scavengeReferentsOf: referrer inspects all the pointers in referrer.
If any are new objects, it has them moved to FutureSurvivorSpace,
and returns truth. If there are no new referents, it returns falsity."
- <var: #referrer type: #'object *'>
| foundNewReferent |
+ "manager isPointersNonImm: referrer) ifFalse:
- "referrer isPointers ifFalse:
[^false]."
foundNewReferent := false.
0 to: (manager numPointerSlotsOf: referrer) do:
[:i| | referent |
referent := manager fetchPointer: i ofObject: referrer.
((manager isNonImmediate: referent)
and: [manager isYoung: referent]) ifTrue:
[foundNewReferent := true.
(manager isForwarded: referent) ifFalse:
[self copyAndForward: referent].
manager
storePointerUnchecked: i
ofObject: referrer
withValue: (manager forwardingPointerOf: referent)]].
^foundNewReferent!
Item was changed:
----- Method: SpurGenerationScavenger>>scavengeRememberedSetStartingAt: (in category 'scavenger') -----
scavengeRememberedSetStartingAt: n
"scavengeRememberedSetStartingAt: n traverses objects in the remembered
set starting at the nth one. If the object does not refer to any new objects, it
is removed from the set. Otherwise, its new referents are scavenged."
| destIndex sourceIndex |
sourceIndex := destIndex := n.
[sourceIndex < rememberedSetSize] whileTrue:
[| referree |
referree := rememberedSet at: sourceIndex.
(self scavengeReferentsOf: referree)
ifTrue:
[rememberedSet at: destIndex put: referree.
destIndex := destIndex + 1]
ifFalse:
+ [manager setIsRememberedOf: referree to: false].
- [referree isRemembered: false].
sourceIndex := sourceIndex + 1].
rememberedSetSize := destIndex!
Item was added:
+ ----- Method: SpurMemoryManager>>addressCouldBeOop: (in category 'object testing') -----
+ addressCouldBeOop: address
+ ^(self isImmediate: address)
+ or: [self addressCouldBeObj: address]!
Item was added:
+ ----- Method: SpurMemoryManager>>fetchClassOf: (in category 'object access') -----
+ fetchClassOf: oop
+ | tagBits |
+ (tagBits := oop bitAnd: self tagMask) = 0 ifTrue:
+ [^self fetchPointer: tagBits ofObject: classTableFirstPage].
+ ^self classAtIndex: (self classIndexOf: oop)!
Item was added:
+ ----- Method: SpurMemoryManager>>fetchClassOfNonImm: (in category 'object access') -----
+ fetchClassOfNonImm: objOop
+ | classIndex |
+ classIndex := self classIndexOf: objOop.
+ ^self classAtIndex: classIndex!
Item was removed:
- ----- Method: SpurMemoryManager>>fetchClassOfNonInt: (in category 'object access') -----
- fetchClassOfNonInt: objOop
- | classIndex |
- classIndex := self classIndexOf: objOop.
- ^self classAtIndex: classIndex!
Item was added:
+ ----- 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 changed:
----- Method: SpurMemoryManager>>isImmediate: (in category 'object testing') -----
isImmediate: oop
+ ^(oop bitAnd: self tagMask) ~= 0!
- ^self subclassResponsibility!
Item was added:
+ ----- Method: SpurMemoryManager>>isInOldSpace: (in category 'object testing') -----
+ isInOldSpace: address
+ ^address between: newSpaceLimit and: freeOldSpaceStart!
Item was changed:
----- Method: SpurMemoryManager>>isIntegerObject: (in category 'object testing') -----
isIntegerObject: oop
(#( makeBaseFrameFor:
quickFetchInteger:ofObject:
+ frameOfMarriedContext:
+ addressCouldBeClassObj:
+ isMarriedOrWidowedContext:) includes: thisContext sender method selector) ifFalse:
- frameOfMarriedContext:) includes: thisContext sender method selector) ifFalse:
[self halt].
^(oop bitAnd: 1) ~= 0!
Item was changed:
----- Method: SpurMemoryManager>>isNonImmediate: (in category 'object testing') -----
isNonImmediate: oop
+ ^(oop bitAnd: self tagMask) = 0!
- ^self subclassResponsibility!
Item was added:
+ ----- Method: SpurMemoryManager>>isOopCompiledMethod: (in category 'object testing') -----
+ isOopCompiledMethod: oop
+ "Answer whether the oop is an object of compiled method format"
+ <api>
+ ^(self isNonImmediate: oop)
+ and: [(self formatOf: oop) >= self firstCompiledMethodFormat]!
Item was changed:
----- Method: SpurMemoryManager>>isPointersNonImm: (in category 'object testing') -----
+ isPointersNonImm: objOop
+ "Answer if the argument has only fields that can hold oops. See comment in formatOf:"
- isPointersNonImm: objOop
^(self formatOf: objOop) <= 5!
Item was changed:
----- Method: SpurMemoryManager>>startOfMemory (in category 'accessing') -----
startOfMemory
"Return the start of object memory. This is immediately after the native code zone.
N.B. the stack zone is alloca'ed. Use a macro so as not to punish the debug VM."
+ <cmacro: '() heapBase'> "This is for CoInterpreter, not StackInterpreter"
- <cmacro: '() heapBase'>
<returnTypeC: #usqInt>
+ self flag: #fixme.
+ ^startOfMemory!
- ^coInterpreter ifNil: [startOfMemory] ifNotNil: [coInterpreter heapBase]!
Item was changed:
----- Method: StackInterpreter>>addressCouldBeClassObj: (in category 'debug support') -----
addressCouldBeClassObj: maybeClassObj
"Answer if maybeClassObj looks like a class object"
<inline: false>
^(objectMemory addressCouldBeObj: maybeClassObj)
+ and: [((objectMemory isPointersNonImm: maybeClassObj) and: [(objectMemory lengthOf: maybeClassObj) >= (InstanceSpecificationIndex+1)])
+ and: [(objectMemory isPointersNonImm: (objectMemory fetchPointer: SuperclassIndex ofObject: maybeClassObj))
+ and: [(objectMemory isPointersNonImm: (objectMemory fetchPointer: MethodDictionaryIndex ofObject: maybeClassObj))
- and: [((objectMemory isPointersNonInt: maybeClassObj) and: [(objectMemory lengthOf: maybeClassObj) >= 3])
- and: [(objectMemory isPointersNonInt: (objectMemory fetchPointer: SuperclassIndex ofObject: maybeClassObj))
- and: [(objectMemory isPointersNonInt: (objectMemory fetchPointer: MethodDictionaryIndex ofObject: maybeClassObj))
and: [(objectMemory isIntegerObject: (objectMemory fetchPointer: InstanceSpecificationIndex ofObject: maybeClassObj))]]]]!
Item was changed:
----- Method: StackInterpreter>>checkOkayFields: (in category 'debug support') -----
checkOkayFields: oop
"Check if the argument is an ok object.
If this is a pointers object, check that its fields are all okay oops."
| hasYoung i fieldOop |
(oop = nil or: [oop = 0]) ifTrue: [ ^true ]. "?? eem 1/16/2013"
(objectMemory isIntegerObject: oop) ifTrue: [ ^true ].
(objectMemory checkOkayOop: oop) ifFalse: [ ^false ].
(self checkOopHasOkayClass: oop) ifFalse: [ ^false ].
((objectMemory isPointersNonInt: oop) or: [objectMemory isCompiledMethod: oop]) ifFalse: [ ^true ].
+ hasYoung := objectMemory isYoung: (objectMemory fetchClassOfNonImm: oop).
- hasYoung := objectMemory isYoung: (objectMemory fetchClassOfNonInt: oop).
(objectMemory isCompiledMethod: oop)
ifTrue:
[i := (self literalCountOf: oop) + LiteralStart - 1]
ifFalse:
[(objectMemory isContext: oop)
ifTrue: [i := CtxtTempFrameStart + (self fetchStackPointerOf: oop) - 1]
ifFalse: [i := (objectMemory lengthOf: oop) - 1]].
[i >= 0] whileTrue:
[fieldOop := objectMemory fetchPointer: i ofObject: oop.
(objectMemory isIntegerObject: fieldOop) ifFalse:
[hasYoung := hasYoung or: [objectMemory isYoung: fieldOop].
(objectMemory checkOkayOop: fieldOop) ifFalse: [ ^false ].
(self checkOopHasOkayClass: fieldOop) ifFalse: [ ^false ]].
i := i - 1].
hasYoung ifTrue:
[^objectMemory checkOkayYoungReferrer: oop].
^true!
Item was changed:
----- Method: StackInterpreter>>checkOopHasOkayClass: (in category 'debug support') -----
checkOopHasOkayClass: obj
"Attempt to verify that the given obj has a reasonable behavior. The class must be a
valid, non-integer oop and must not be nilObj. It must be a pointers object with three
or more fields. Finally, the instance specification field of the behavior must match that
of the instance. If OK answer true. If not, print reason and answer false."
<api>
<var: #oop type: #usqInt>
| objClass formatMask behaviorFormatBits objFormatBits |
<var: #oopClass type: #usqInt>
(objectMemory checkOkayOop: obj) ifFalse:
[^false].
+ objClass := self cCoerce: (objectMemory fetchClassOfNonImm: obj) to: #usqInt.
- objClass := self cCoerce: (objectMemory fetchClassOfNonInt: obj) to: #usqInt.
(objectMemory isIntegerObject: objClass) ifTrue:
[self print: 'obj '; printHex: obj; print: ' a SmallInteger is not a valid class or behavior'; cr. ^false].
(objectMemory okayOop: objClass) ifFalse:
[self print: 'obj '; printHex: obj; print: ' class obj is not ok'; cr. ^false].
((objectMemory isPointersNonInt: objClass) and: [(objectMemory lengthOf: objClass) >= 3]) ifFalse:
[self print: 'obj '; printHex: obj; print: ' a class (behavior) must be a pointers object of size >= 3'; cr. ^false].
formatMask := (objectMemory isBytes: obj)
ifTrue: [16rC00] "ignore extra bytes size bits"
ifFalse: [16rF00].
behaviorFormatBits := (objectMemory formatOfClass: objClass) bitAnd: formatMask.
objFormatBits := (objectMemory baseHeader: obj) bitAnd: formatMask.
behaviorFormatBits = objFormatBits ifFalse:
[self print: 'obj '; printHex: obj; print: ' and its class (behavior) formats differ'; cr. ^false].
^true!
Item was changed:
----- Method: StackInterpreter>>commonAt: (in category 'indexing primitive support') -----
commonAt: stringy
"This code is called if the receiver responds primitively to at:.
If this is so, it will be installed in the atCache so that subsequent calls of at:
or next may be handled immediately in bytecode primitive routines."
| index rcvr atIx result |
self initPrimCall.
rcvr := self stackValue: 1.
(objectMemory isNonIntegerObject: rcvr) ifFalse:
[^self primitiveFailFor: PrimErrInappropriate].
index := self stackTop.
"No need to test for large positive integers here. No object has 1g elements"
(objectMemory isIntegerObject: index) ifFalse:
[^self primitiveFailFor: PrimErrBadArgument].
index := objectMemory integerValueOf: index.
"NOTE: The at-cache, since it is specific to the non-super response to #at:.
Therefore we must determine that the message is #at: (not, eg, #basicAt:),
and that the send is not a super-send, before using the at-cache."
(messageSelector = (self specialSelector: 16)
+ and: [lkupClass = (objectMemory fetchClassOfNonImm: rcvr)])
- and: [lkupClass = (objectMemory fetchClassOfNonInt: rcvr)])
ifTrue:
["OK -- look in the at-cache"
atIx := rcvr bitAnd: AtCacheMask. "Index into atCache = 4N, for N = 0 ... 7"
(atCache at: atIx+AtCacheOop) = rcvr ifFalse:
["Rcvr not in cache. Attempt to install it..."
(self install: rcvr inAtCache: atCache at: atIx string: stringy) ifFalse:
[self assert: (objectMemory isContextNonInt: rcvr).
self initPrimCall.
^self primitiveContextAt]].
self successful ifTrue:
[result := self commonVariable: rcvr at: index cacheIndex: atIx].
self successful ifTrue:
[^ self pop: argumentCount+1 thenPush: result]].
"The slow but sure way..."
self initPrimCall.
result := self stObject: rcvr at: index.
self successful ifTrue:
[stringy ifTrue: [result := self characterForAscii: (objectMemory integerValueOf: result)].
^ self pop: argumentCount+1 thenPush: result]!
Item was changed:
----- Method: StackInterpreter>>commonAtPut: (in category 'indexing primitive support') -----
commonAtPut: stringy
"This code is called if the receiver responds primitively to at:Put:.
If this is so, it will be installed in the atPutCache so that subsequent calls of at:
or next may be handled immediately in bytecode primitive routines."
| value index rcvr atIx |
value := self stackTop.
self initPrimCall.
rcvr := self stackValue: 2.
(objectMemory isNonIntegerObject: rcvr) ifFalse:
[^self primitiveFailFor: PrimErrInappropriate].
index := self stackValue: 1.
"No need to test for large positive integers here. No object has 1g elements"
(objectMemory isIntegerObject: index) ifFalse:
[^self primitiveFailFor: PrimErrBadArgument].
index := objectMemory integerValueOf: index.
"NOTE: The atPut-cache, since it is specific to the non-super response to #at:Put:.
Therefore we must determine that the message is #at:Put: (not, eg, #basicAt:Put:),
and that the send is not a super-send, before using the at-cache."
(messageSelector = (self specialSelector: 17)
+ and: [lkupClass = (objectMemory fetchClassOfNonImm: rcvr)])
- and: [lkupClass = (objectMemory fetchClassOfNonInt: rcvr)])
ifTrue:
["OK -- look in the at-cache"
atIx := (rcvr bitAnd: AtCacheMask) + AtPutBase. "Index into atPutCache"
(atCache at: atIx+AtCacheOop) = rcvr ifFalse:
["Rcvr not in cache. Attempt to install it..."
(self install: rcvr inAtCache: atCache at: atIx string: stringy) ifFalse:
[self assert: (objectMemory isContextNonInt: rcvr).
self initPrimCall.
^self primitiveContextAtPut]].
self successful ifTrue:
[self commonVariable: rcvr at: index put: value cacheIndex: atIx].
self successful ifTrue:
[^ self pop: argumentCount+1 thenPush: value]].
"The slow but sure way..."
self initPrimCall.
stringy
ifTrue: [self stObject: rcvr at: index put: (self asciiOfCharacter: value)]
ifFalse: [self stObject: rcvr at: index put: value].
self successful ifTrue:
[^ self pop: argumentCount+1 thenPush: value]!
Item was changed:
----- Method: StackInterpreter>>dbgFloatValueOf: (in category 'utilities') -----
dbgFloatValueOf: oop
"This version answers the value of a float or nil if not a flat *WITHOUT* setting successFlag or any other such nonsense. It is hence safe for use in debug printing. Sheesh."
| result |
<returnTypeC: #double>
<var: #result type: #double>
self flag: #Dan. "None of the float stuff has been converted for 64 bits"
((objectMemory isNonIntegerObject: oop)
+ and: [(objectMemory fetchClassOfNonImm: oop) = (objectMemory splObj: ClassFloat)]) ifTrue:
- and: [(objectMemory fetchClassOfNonInt: oop) = (objectMemory splObj: ClassFloat)]) ifTrue:
[self cCode: '' inSmalltalk: [result := Float new: 2].
objectMemory fetchFloatAt: oop + BaseHeaderSize into: result.
^result].
^nil!
Item was changed:
----- Method: StackInterpreter>>doSignalSemaphoreWithIndex: (in category 'process primitive support') -----
doSignalSemaphoreWithIndex: index
"Signal the external semaphore with the given index. Answer if a context switch
occurs as a result. Do not bounds check. This has been done in the caller."
<api>
| xArray semaphoreClass sema |
xArray := objectMemory splObj: ExternalObjectsArray.
semaphoreClass := objectMemory splObj: ClassSemaphore.
sema := objectMemory fetchPointer: index - 1 ofObject: xArray. "Note: semaphore indices are 1-based"
^(objectMemory isNonIntegerObject: sema)
+ and: [(objectMemory fetchClassOfNonImm: sema) = semaphoreClass
- and: [(objectMemory fetchClassOfNonInt: sema) = semaphoreClass
and: [self synchronousSignal: sema]]!
Item was changed:
----- Method: StackInterpreter>>findApplicationOfTargetMixin:startingAtBehavior: (in category 'newspeak bytecode support') -----
findApplicationOfTargetMixin: targetMixin startingAtBehavior: aBehavior
"This is used to implement the innards of the pushImplicitReceiverBytecode,
used for outer sends in NS2/NS3. Find the MixinApplcation of which aBehavior
is a subclass that is an application of targetMixin. This is an implementation derived from
<ContextPart> findApplicationOfTargetMixin: targetMixin startingAtBehavior: aBehavior
"
| mixinOrMixinApplication mixin |
mixinOrMixinApplication := aBehavior.
[mixinOrMixinApplication = objectMemory nilObject
or: [mixinOrMixinApplication = targetMixin
or: [(mixin := objectMemory fetchPointer: MixinIndex ofObject: mixinOrMixinApplication) = targetMixin
+ or: [(objectMemory fetchClassOfNonImm: mixin) = targetMixin]]]] whileFalse:
- or: [(objectMemory fetchClassOfNonInt: mixin) = targetMixin]]]] whileFalse:
[mixinOrMixinApplication := objectMemory fetchPointer: SuperclassIndex ofObject: mixinOrMixinApplication].
^mixinOrMixinApplication!
Item was changed:
----- Method: StackInterpreter>>findClassOfMethod:forReceiver: (in category 'debug support') -----
findClassOfMethod: meth forReceiver: rcvr
| rclass |
(objectMemory addressCouldBeOop: rcvr) ifTrue:
[rclass := objectMemory fetchClassOf: rcvr.
(self addressCouldBeClassObj: rclass) ifTrue:
[rclass := self findClassContainingMethod: meth startingAt: rclass.
rclass ~= objectMemory nilObject ifTrue:
[^rclass]]].
((objectMemory addressCouldBeObj: meth)
+ and: [objectMemory isCompiledMethod: meth]) ifFalse:
- and: [self isCompiledMethod: meth]) ifFalse:
[^objectMemory nilObject].
^self findClassContainingMethod: meth startingAt: (self methodClassOf: meth)!
Item was changed:
----- Method: StackInterpreter>>initializeExtraClassInstVarIndices (in category 'initialization') -----
initializeExtraClassInstVarIndices
"Initialize metaclassSizeBits and thisClassIndex which are used in debug printing, and
classNameIndex which is used not only for debug printing but for is:KindOf: & is:MemberOf:
via classNameOf:is: (evil but a reality we have to accept)."
| classArrayObj classArrayClass |
classArrayObj := objectMemory splObj: ClassArray.
+ classArrayClass := objectMemory fetchClassOfNonImm: classArrayObj.
- classArrayClass := objectMemory fetchClassOfNonInt: classArrayObj.
metaclassSizeBits := objectMemory sizeBitsOf: classArrayClass. "determine actual (Metaclass instSize * 4)"
thisClassIndex := 5. "default"
InstanceSpecificationIndex + 1 to: (objectMemory lengthOf: classArrayClass) do:
[:i|
(objectMemory fetchPointer: i - 1 ofObject: classArrayClass) = classArrayObj ifTrue:
[thisClassIndex := i - 1]].
classNameIndex := 6. "default"
InstanceSpecificationIndex + 1 to: (objectMemory lengthOf: classArrayObj) do:
[:i| | oop |
oop := objectMemory fetchPointer: i - 1 ofObject: classArrayObj.
((objectMemory isBytes: oop)
and: [(objectMemory lengthOf: oop) = 5
and: [(self str: 'Array' n: (objectMemory firstFixedField: oop) cmp: 5) = 0]]) ifTrue:
[classNameIndex := i - 1]]!
Item was changed:
----- Method: StackInterpreter>>isFloatObject: (in category 'internal interpreter access') -----
isFloatObject: oop
^(objectMemory isNonIntegerObject: oop)
and: [ClassFloatCompactIndex ~= 0
ifTrue: [(objectMemory compactClassIndexOf: oop) = ClassFloatCompactIndex]
+ ifFalse: [(objectMemory fetchClassOfNonImm: oop) = objectMemory classFloat]]!
- ifFalse: [(objectMemory fetchClassOfNonInt: oop) = objectMemory classFloat]]!
Item was changed:
----- Method: StackInterpreter>>longPrintOop: (in category 'debug printing') -----
longPrintOop: oop
<api>
| class fmt lastIndex startIP bytecodesPerLine column |
+ ((objectMemory isImmediate: oop)
+ or: [(objectMemory addressCouldBeObj: oop) not
+ or: [(oop bitAnd: objectMemory allocationUnit - 1) ~= 0
- ((objectMemory isIntegerObject: oop)
- or: [(oop between: objectMemory startOfMemory and: objectMemory freeStart) not
- or: [(oop bitAnd: (BytesPerWord - 1)) ~= 0
or: [(objectMemory isFreeObject: oop)]]]) ifTrue:
[^self printOop: oop].
+ class := objectMemory fetchClassOfNonImm: oop.
- class := objectMemory fetchClassOfNonInt: oop.
self printHex: oop;
print: ': a(n) '; printNameOfClass: class count: 5;
print: ' ('; printHex: class; print: ')'.
fmt := objectMemory formatOf: oop.
fmt > 4 ifTrue:
[self print: ' nbytes '; printNum: (objectMemory byteLengthOf: oop)].
objectMemory printHeaderTypeOf: oop.
self cr.
(fmt between: 5 and: 11) ifTrue:
[^self].
lastIndex := 256 min: (startIP := (objectMemory lastPointerOf: oop) / BytesPerWord).
lastIndex > 0 ifTrue:
[1 to: lastIndex do:
[:i| | fieldOop |
fieldOop := objectMemory fetchPointer: i - 1 ofObject: oop.
self space; printNum: i - 1; space; printHex: fieldOop; space.
(i = 1 and: [objectMemory isCompiledMethod: oop])
ifTrue: [self printMethodHeaderOop: fieldOop]
ifFalse: [self printOopShort: fieldOop].
self cr]].
(objectMemory isCompiledMethod: oop)
ifFalse:
[startIP > 64 ifTrue: [self print: '...'; cr]]
ifTrue:
[startIP := startIP * BytesPerWord + 1.
lastIndex := objectMemory lengthOf: oop.
lastIndex - startIP > 100 ifTrue:
[lastIndex := startIP + 100].
bytecodesPerLine := 8.
column := 1.
startIP to: lastIndex do:
[:index| | byte |
column = 1 ifTrue:
[self cCode: 'printf("0x%08x: ", oop+BaseHeaderSize+index-1)'
inSmalltalk: [self print: (oop+BaseHeaderSize+index-1) hex; print: ': ']].
byte := objectMemory fetchByte: index - 1 ofObject: oop.
self cCode: 'printf(" %02x/%-3d", byte,byte)'
inSmalltalk: [self space; print: (byte radix: 16); printChar: $/; printNum: byte].
column := column + 1.
column > bytecodesPerLine ifTrue:
[column := 1. self cr]].
column = 1 ifFalse:
[self cr]]!
Item was changed:
----- Method: StackInterpreter>>printActivationNameForMethod:startClass:isBlock:firstTemporary: (in category 'debug printing') -----
printActivationNameForMethod: aMethod startClass: startClass isBlock: isBlock firstTemporary: maybeMessage
| methClass methodSel |
<inline: false>
isBlock ifTrue:
[self print: '[] in '].
self findSelectorAndClassForMethod: aMethod
lookupClass: startClass
do: [:sel :class|
methodSel := sel.
methClass := class].
((self addressCouldBeOop: startClass) and: [methClass notNil])
ifTrue:
[startClass = methClass
ifTrue: [self printNameOfClass: methClass count: 5]
ifFalse:
[self printNameOfClass: startClass count: 5.
self printChar: $(.
self printNameOfClass: methClass count: 5.
self printChar: $)]]
ifFalse: [self print: 'INVALID CLASS'].
self printChar: $>.
(objectMemory addressCouldBeOop: methodSel)
ifTrue:
[(objectMemory isBytes: methodSel)
ifTrue: [self printStringOf: methodSel]
ifFalse: [self printOopShort: methodSel]]
ifFalse: [self print: 'INVALID SELECTOR'].
(methodSel = (objectMemory splObj: SelectorDoesNotUnderstand)
and: [(objectMemory addressCouldBeObj: maybeMessage)
+ and: [(objectMemory fetchClassOfNonImm: maybeMessage) = (objectMemory splObj: ClassMessage)]]) ifTrue:
- and: [(objectMemory fetchClassOfNonInt: maybeMessage) = (objectMemory splObj: ClassMessage)]]) ifTrue:
["print arg message selector"
methodSel := objectMemory fetchPointer: MessageSelectorIndex ofObject: maybeMessage.
self print: ' '.
self printStringOf: methodSel]!
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>
| oop classObj 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"
semaphoreClass := objectMemory classSemaphore.
mutexClass := objectMemory classMutex.
oop := objectMemory firstObject.
[self oop: oop isLessThan: objectMemory freeStart] whileTrue:
+ [classObj := objectMemory fetchClassOfNonImm: oop.
- [classObj := objectMemory fetchClassOfNonInt: oop.
(classObj = semaphoreClass
or: [classObj = mutexClass]) ifTrue:
[self printProcsOnList: oop].
oop := objectMemory objectAfter: oop].
schedLists := objectMemory fetchPointer: ProcessListsIndex ofObject: self schedulerPointer.
p := highestRunnableProcessPriority = 0
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]]!
Item was changed:
----- Method: StackInterpreter>>printOop: (in category 'debug printing') -----
printOop: oop
| cls fmt lastIndex startIP bytecodesPerLine column |
<inline: false>
- self printHex: oop.
(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: [' is not on the heap']); cr.
- [(objectMemory isImmediateCharacter: oop) ifTrue:
- [^self
- cCode: 'printf("=$%ld ($%c)\n", (long)characterValueOf(oop), (long)characterValueOf(oop))'
- inSmalltalk: [self print: (self shortPrint: oop); cr]].
- ^self
- cCode: 'printf("=%ld\n", (long)integerValueOf(oop))'
- inSmalltalk: [self print: (self shortPrint: oop); cr]].
- (oop between: objectMemory startOfMemory and: objectMemory freeStart) ifFalse:
- [self print: ' is not on the heap'; cr.
^nil].
- (oop bitAnd: (BytesPerWord - 1)) ~= 0 ifTrue:
- [self print: ' is misaligned'; cr.
- ^nil].
(objectMemory isFreeObject: oop) ifTrue:
[self print: ' is a free chunk of size '; printNum: (objectMemory sizeOfFree: oop); cr.
^nil].
self print: ': a(n) '.
+ self printNameOfClass: (cls := objectMemory fetchClassOfNonImm: oop) count: 5.
- self printNameOfClass: (cls := objectMemory fetchClassOfNonInt: oop) count: 5.
cls = (objectMemory splObj: ClassFloat) ifTrue:
[self cr; printFloat: (self dbgFloatValueOf: oop); cr.
^nil].
fmt := objectMemory formatOf: oop.
fmt > 4 ifTrue:
[self print: ' nbytes '; printNum: (objectMemory byteLengthOf: oop)].
self cr.
(fmt > 4 and: [fmt < 12]) ifTrue:
["This will answer false if splObj: ClassAlien is nilObject"
(self is: oop KindOfClass: (objectMemory splObj: ClassAlien)) ifTrue:
[self print: ' datasize '; printNum: (self sizeOfAlienData: oop).
self print: ((self isIndirectAlien: oop)
ifTrue: [' indirect @ ']
ifFalse:
[(self isPointerAlien: oop)
ifTrue: [' pointer @ ']
ifFalse: [' direct @ ']]).
self printHex: (self startOfAlienData: oop) asUnsignedInteger; cr.
^nil].
(objectMemory isWords: oop) ifTrue:
[lastIndex := 64 min: ((objectMemory byteLengthOf: oop) / BytesPerWord).
lastIndex > 0 ifTrue:
[1 to: lastIndex do:
[:index|
self space; printHex: (objectMemory fetchLong32: index - 1 ofObject: oop).
(index \\ self elementsPerPrintOopLine) = 0 ifTrue:
[self cr]].
(lastIndex \\ self elementsPerPrintOopLine) = 0 ifFalse:
[self cr]].
^nil].
^self printStringOf: oop; cr].
lastIndex := 64 min: (startIP := (objectMemory lastPointerOf: oop) / BytesPerWord).
lastIndex > 0 ifTrue:
[1 to: lastIndex do:
[:index|
self cCode: [self printHex: (objectMemory fetchPointer: index - 1 ofObject: oop); space]
inSmalltalk: [self space; printHex: (objectMemory fetchPointer: index - 1 ofObject: oop); space.
self print: (self shortPrint: (objectMemory fetchPointer: index - 1 ofObject: oop))].
(index \\ self elementsPerPrintOopLine) = 0 ifTrue:
[self cr]].
(lastIndex \\ self elementsPerPrintOopLine) = 0 ifFalse:
[self cr]].
(objectMemory isCompiledMethod: oop)
ifFalse:
[startIP > 64 ifTrue: [self print: '...'; cr]]
ifTrue:
[startIP := startIP * BytesPerWord + 1.
lastIndex := objectMemory lengthOf: oop.
lastIndex - startIP > 100 ifTrue:
[lastIndex := startIP + 100].
bytecodesPerLine := 8.
column := 1.
startIP to: lastIndex do:
[:index| | byte |
column = 1 ifTrue:
[self cCode: 'printf("0x%08x: ", oop+BaseHeaderSize+index-1)'
inSmalltalk: [self print: (oop+BaseHeaderSize+index-1) hex; print: ': ']].
byte := objectMemory fetchByte: index - 1 ofObject: oop.
self cCode: 'printf(" %02x/%-3d", byte,byte)'
inSmalltalk: [self space; print: (byte radix: 16); printChar: $/; printNum: byte].
column := column + 1.
column > bytecodesPerLine ifTrue:
[column := 1. self cr]].
column = 1 ifFalse:
[self cr]]!
Item was changed:
----- Method: StackInterpreter>>printOopShortInner: (in category 'debug printing') -----
printOopShortInner: oop
| classOop name nameLen |
<var: #name type: #'char *'>
<inline: true>
+ (objectMemory isImmediate: oop) ifTrue:
+ [(objectMemory isImmediateCharacter: oop) ifTrue:
+ [self
+ cCode: 'printf("$%c(%ld)", (long)characterValueOf(oop), (long)characterValueOf(oop))'
+ inSmalltalk:
+ [self printChar: $$;
+ printChar: (objectMemory characterValueOf: oop);
+ printChar: $(;
+ printHex: (objectMemory integerValueOf: oop);
+ printChar: $)].
+ ^nil].
+ self printNum: (objectMemory integerValueOf: oop);
- (objectMemory isIntegerObject: oop) ifTrue:
- [self printNum: (objectMemory integerValueOf: oop);
printChar: $(;
printHex: (objectMemory integerValueOf: oop);
printChar: $).
^nil].
+ (objectMemory addressCouldBeObj: oop) ifFalse:
+ [self print: ((oop bitAnd: objectMemory allocationUnit - 1) ~= 0
+ ifTrue: [' is misaligned']
+ ifFalse: [' is not on the heap']); cr.
- (oop between: objectMemory startOfMemory and: objectMemory freeStart) ifFalse:
- [self printHex: oop; print: ' is not on the heap'.
^nil].
- (oop bitAnd: (BytesPerWord - 1)) ~= 0 ifTrue:
- [self printHex: oop; print: ' is misaligned'.
- ^nil].
(self isFloatObject: oop) ifTrue:
[self printFloat: (self dbgFloatValueOf: oop).
^nil].
+ classOop := objectMemory fetchClassOfNonImm: oop.
- classOop := objectMemory fetchClassOfNonInt: oop.
(objectMemory addressCouldBeObj: classOop) ifFalse:
[self print: 'a ??'. ^nil].
(objectMemory sizeBitsOf: classOop) = metaclassSizeBits ifTrue:
[self printNameOfClass: oop count: 5.
^nil].
oop = objectMemory nilObject ifTrue: [self print: 'nil'. ^nil].
oop = objectMemory trueObject ifTrue: [self print: 'true'. ^nil].
oop = objectMemory falseObject ifTrue: [self print: 'false'. ^nil].
nameLen := self lengthOfNameOfClass: classOop.
nameLen = 0 ifTrue: [self print: 'a ??'. ^nil].
name := self nameOfClass: classOop.
nameLen = 10 ifTrue:
[(self str: name n: 'ByteString' cmp: 10) not "strncmp is weird" ifTrue:
[self printChar: $'; printStringOf: oop; printChar: $'.
^nil].
(self str: name n: 'ByteSymbol' cmp: 10) not "strncmp is weird" ifTrue:
[self printChar: $#; printStringOf: oop.
^nil]].
(nameLen = 9 and: [(self str: name n: 'Character' cmp: 9) not]) ifTrue:
[self printChar: $$; printChar: (objectMemory integerValueOf: (objectMemory fetchPointer: 0 ofObject: oop)).
^nil].
self cCode: [self prin: 'a(n) %.*s' t: nameLen f: name]
inSmalltalk: [self print: 'a(n) '; print: name].
"Try to spot association-like things; they're all subclasses of LookupKey"
((objectMemory instanceSizeOf: classOop) = (ValueIndex + 1)
+ and: [(self superclassOf: classOop) = (self superclassOf: (objectMemory fetchClassOfNonImm: (objectMemory splObj: SchedulerAssociation)))
- and: [(self superclassOf: classOop) = (self superclassOf: (objectMemory fetchClassOfNonInt: (objectMemory splObj: SchedulerAssociation)))
and: [objectMemory isBytes: (objectMemory fetchPointer: KeyIndex ofObject: oop)]]) ifTrue:
[self space;
printOopShort: (objectMemory fetchPointer: KeyIndex ofObject: oop);
print: ' -> ';
printHex: (objectMemory fetchPointer: ValueIndex ofObject: oop)]!
Item was changed:
----- Method: StackInterpreter>>printStringOf: (in category 'debug printing') -----
printStringOf: oop
| fmt len cnt max i |
<inline: false>
+ (objectMemory isImmediate: oop) ifTrue:
- (objectMemory isIntegerObject: oop) ifTrue:
[^nil].
(oop between: objectMemory startOfMemory and: objectMemory freeStart) ifFalse:
[^nil].
(oop bitAnd: (BytesPerOop - 1)) ~= 0 ifTrue:
[^nil].
fmt := objectMemory formatOf: oop.
+ fmt < objectMemory firstByteFormat ifTrue: [^nil].
- fmt < 8 ifTrue: [^nil].
cnt := (max := 128) min: (len := objectMemory lengthOf: oop).
i := 0.
((objectMemory is: oop
instanceOf: (objectMemory splObj: ClassByteArray)
compactClassIndex: classByteArrayCompactIndex)
or: [(self isInstanceOfClassLargePositiveInteger: oop)
or: [(self isInstanceOfClassLargeNegativeInteger: oop)]])
ifTrue:
[[i < cnt] whileTrue:
[self printHex: (objectMemory fetchByte: i ofObject: oop).
i := i + 1]]
ifFalse:
[[i < cnt] whileTrue:
[self printChar: (objectMemory fetchByte: i ofObject: oop).
i := i + 1]].
len > max ifTrue:
[self print: '...'].
self flush!
Item was changed:
----- Method: StackInterpreter>>sendInvokeCallback:Stack:Registers:Jmpbuf: (in category 'callback support') -----
sendInvokeCallback: thunkPtr Stack: stackPtr Registers: regsPtr Jmpbuf: jmpBufPtr
"Send the 4 argument callback message invokeCallback:stack:registers:jmpbuf:
to Alien class with the supplied args. The arguments are raw C addresses
and are converted to integer objects on the way."
<export: true>
self flag: #obsolete.
+ lkupClass := self fetchClassOfNonImm: (self splObj: ClassAlien).
- lkupClass := self fetchClassOfNonInt: (self splObj: ClassAlien).
messageSelector := self splObj: SelectorInvokeCallback.
argumentCount := 4.
(self lookupInMethodCacheSel: messageSelector class: lkupClass) ifFalse:
[(self lookupMethodNoMNUEtcInClass: lkupClass) ~= 0 ifTrue:
[^false]].
((self argumentCountOf: newMethod) = 4
and: [primitiveFunctionPointer = 0]) ifFalse:
[^false].
self push: (self splObj: ClassAlien). "receiver"
self push: (self positive32BitIntegerFor: thunkPtr).
self push: (self positive32BitIntegerFor: stackPtr).
self push: (self positive32BitIntegerFor: regsPtr).
self push: (self positive32BitIntegerFor: jmpBufPtr).
self ifAppropriateCompileToNativeCode: newMethod selector: messageSelector.
self justActivateNewMethod.
(self isMachineCodeFrame: framePointer) ifFalse:
[self maybeFlagMethodAsInterpreted: newMethod].
self externalWriteBackHeadFramePointers.
self handleStackOverflow.
self enterSmalltalkExecutiveFromCallback.
"not reached"
^true!
Item was changed:
----- Method: StackInterpreter>>sendInvokeCallbackContext: (in category 'callback support') -----
sendInvokeCallbackContext: vmCallbackContext
"Send the calllback message to Alien class with the supplied arg(s). Use either the
1 arg invokeCallbackContext: or the 4 arg invokeCallback:stack:registers:jmpbuf:
message, depending on what selector is installed in the specialObjectsArray.
Note that if invoking the legacy invokeCallback:stack:registers:jmpbuf: we pass the
vmCallbackContext as the jmpbuf argument (see reestablishContextPriorToCallback:).
The arguments are raw C addresses and are converted to integer objects on the way."
<export: true>
<var: #vmCallbackContext type: #'VMCallbackContext *'>
+ lkupClass := self fetchClassOfNonImm: (self splObj: ClassAlien).
- lkupClass := self fetchClassOfNonInt: (self splObj: ClassAlien).
messageSelector := self splObj: SelectorInvokeCallback.
(self lookupInMethodCacheSel: messageSelector class: lkupClass) ifFalse:
[(self lookupMethodNoMNUEtcInClass: lkupClass) ~= 0 ifTrue:
[^false]].
primitiveFunctionPointer ~= 0 ifTrue:
[^false].
self saveCStackStateForCallbackContext: vmCallbackContext.
self push: (self splObj: ClassAlien). "receiver"
self cppIf: BytesPerWord = 8
ifTrue:
[(self argumentCountOf: newMethod) = 4 ifTrue:
[self push: (self positive64BitIntegerFor: vmCallbackContext thunkp asUnsignedInteger).
self push: (self positive64BitIntegerFor: vmCallbackContext stackp asUnsignedInteger).
self push: (self positive64BitIntegerFor: vmCallbackContext intregargsp asUnsignedInteger)].
self push: (self positive64BitIntegerFor: vmCallbackContext asUnsignedInteger)]
ifFalse:
[(self argumentCountOf: newMethod) = 4 ifTrue:
[self push: (self positive32BitIntegerFor: vmCallbackContext thunkp asUnsignedInteger).
self push: (self positive32BitIntegerFor: vmCallbackContext stackp asUnsignedInteger).
self push: (self positive32BitIntegerFor: vmCallbackContext intregargsp asUnsignedInteger)].
self push: (self positive32BitIntegerFor: vmCallbackContext asUnsignedInteger)].
self ifAppropriateCompileToNativeCode: newMethod selector: messageSelector.
self justActivateNewMethod.
(self isMachineCodeFrame: framePointer) ifFalse:
[self maybeFlagMethodAsInterpreted: newMethod].
self externalWriteBackHeadFramePointers.
self handleStackOverflow.
self enterSmalltalkExecutiveFromCallback.
"not reached"
^true!
Item was changed:
----- Method: StackInterpreter>>shortPrintOop: (in category 'debug printing') -----
shortPrintOop: oop
<inline: false>
self printHex: oop.
+ (objectMemory isImmediate: oop) ifTrue:
+ [(objectMemory isImmediateCharacter: oop) ifTrue:
+ [^self
+ cCode: 'printf("=$%ld ($%c)\n", (long)characterValueOf(oop), (long)characterValueOf(oop))'
+ inSmalltalk: [self print: (self shortPrint: oop); cr]].
+ ^self
+ cCode: 'printf("=%ld\n", (long)integerValueOf(oop))'
+ inSmalltalk: [self print: (self shortPrint: oop); cr]].
- (objectMemory isIntegerObject: oop) ifTrue:
- [^self cCode: 'printf("=%ld\n", (long)integerValueOf(oop))' inSmalltalk: [self print: (self shortPrint: oop); cr]].
(oop between: objectMemory startOfMemory and: objectMemory freeStart) ifFalse:
[self printHex: oop; print: ' is not on the heap'; cr.
^nil].
(oop bitAnd: (BytesPerWord - 1)) ~= 0 ifTrue:
[self printHex: oop; print: ' is misaligned'; cr.
^nil].
self print: ': a(n) '.
self printNameOfClass: (objectMemory fetchClassOf: oop) count: 5.
self cr!
Item was changed:
----- Method: StackInterpreterPrimitives>>pathTo:using:followWeak: (in category 'object access primitives') -----
pathTo: goal using: stack followWeak: followWeak
"Trace objects and frames from the root, marking visited objects, pushing the current path on stack, until goal is found.
If found, unmark, leaving path in stack, and answer 0. Otherwise answer an error:
PrimErrBadArgument if stack is not an Array
PrimErrBadIndex if search overflows stack
PrimErrNotFound if goal cannot be found"
| current hdr index next stackSize stackp freeStartAtStart |
(objectMemory isArray: stack) ifFalse:
[^PrimErrBadArgument].
freeStartAtStart := objectMemory freeStart. "check no allocations during search"
objectMemory beRootIfOld: stack. "so no store checks are necessary on stack"
stackSize := objectMemory lengthOf: stack.
objectMemory mark: stack.
"no need. the current context is not reachable from the active process (suspendedContext is nil)"
"objectMemory mark: self activeProcess."
current := objectMemory specialObjectsOop.
objectMemory mark: current.
index := objectMemory lengthOf: current.
stackp := 0.
[[(index := index - 1) >= -1] whileTrue:
[next := (stackPages couldBeFramePointer: current)
ifTrue:
[index >= 0
ifTrue: [self field: index ofFrame: current]
ifFalse: [objectMemory nilObject]]
ifFalse:
[index >= 0
ifTrue:
[hdr := objectMemory baseHeader: current.
(objectMemory isContextHeader: hdr)
ifTrue: [self fieldOrSenderFP: index ofContext: current]
ifFalse: [objectMemory fetchPointer: index ofObject: current]]
ifFalse:
+ [objectMemory fetchClassOfNonImm: current]].
- [objectMemory fetchClassOfNonInt: current]].
(stackPages couldBeFramePointer: next)
ifTrue: [self assert: (self isFrame: next onPage: (stackPages stackPageFor: next))]
ifFalse: [self assert: (self checkOkayOop: next)].
next = goal ifTrue:
[self assert: freeStartAtStart = objectMemory freeStart.
self unmarkAfterPathTo.
objectMemory storePointer: stackp ofObject: stack withValue: current.
self pruneStack: stack stackp: stackp.
^0].
((objectMemory isNonIntegerObject: next)
and: [(stackPages couldBeFramePointer: next)
ifTrue: [(self frameIsMarked: next) not]
ifFalse:
[(objectMemory isMarked: next) not
and: [((objectMemory isPointers: next) or: [objectMemory isCompiledMethod: next])
and: [followWeak or: [(objectMemory isWeakNonInt: next) not]]]]])
ifTrue:
[stackp + 2 > stackSize ifTrue:
[self assert: freeStartAtStart = objectMemory freeStart.
self unmarkAfterPathTo.
objectMemory nilFieldsOf: stack.
^PrimErrBadIndex]. "PrimErrNoMemory ?"
objectMemory
storePointerUnchecked: stackp ofObject: stack withValue: current;
storePointerUnchecked: stackp + 1 ofObject: stack withValue: (objectMemory integerObjectOf: index).
stackp := stackp + 2.
(stackPages couldBeFramePointer: (self cCoerceSimple: next to: #'char *'))
ifTrue:
[self markFrame: next.
index := self fieldsInFrame: (self cCoerceSimple: next to: #'char *')]
ifFalse:
[hdr := objectMemory baseHeader: next.
objectMemory baseHeader: next put: (hdr bitOr: MarkBit).
(objectMemory isCompiledMethodHeader: hdr)
ifTrue: [index := (self literalCountOf: next) + LiteralStart]
ifFalse: [index := objectMemory lengthOf: next]].
current := next]].
current = objectMemory specialObjectsOop ifTrue:
[self assert: freeStartAtStart = objectMemory freeStart.
self unmarkAfterPathTo.
objectMemory nilFieldsOf: stack.
^PrimErrNotFound].
index := objectMemory integerValueOf: (objectMemory fetchPointer: stackp - 1 ofObject: stack).
current := objectMemory fetchPointer: stackp - 2 ofObject: stack.
stackp := stackp - 2] repeat!
Item was changed:
----- Method: StackInterpreterPrimitives>>primitiveCopyObject (in category 'object access primitives') -----
primitiveCopyObject
"Primitive. Copy the state of the receiver from the argument.
Fail if receiver and argument are of a different class.
Fail if the receiver or argument are non-pointer objects.
Fail if the receiver or argument are contexts (because of context-to-stack mapping).
Fail if receiver and argument have different lengths (for indexable objects).
"
| rcvr arg length |
self methodArgumentCount = 1 ifFalse:
[^self primitiveFail].
arg := self stackObjectValue: 0.
rcvr := self stackObjectValue: 1.
self failed ifTrue:[^nil].
(objectMemory isPointers: rcvr) ifFalse:
[^self primitiveFail].
((objectMemory isContextNonInt: rcvr)
or: [objectMemory isContextNonInt: arg]) ifTrue:
[^self primitiveFail].
+ (objectMemory fetchClassOfNonImm: rcvr) = (objectMemory fetchClassOfNonImm: arg) ifFalse:
- (objectMemory fetchClassOfNonInt: rcvr) = (objectMemory fetchClassOfNonInt: arg) ifFalse:
[^self primitiveFail].
length := objectMemory lengthOf: rcvr.
length = (objectMemory lengthOf: arg) ifFalse:
[^self primitiveFail].
"Now copy the elements"
0 to: length-1 do:
[:i|
objectMemory storePointer: i ofObject: rcvr withValue: (objectMemory fetchPointer: i ofObject: arg)].
"Note: The above could be faster for young receivers but I don't think it'll matter"
self pop: 1 "pop arg; answer receiver"
!
Item was changed:
----- Method: StackInterpreterPrimitives>>primitiveLongRunningPrimitiveSemaphore (in category 'process primitives') -----
primitiveLongRunningPrimitiveSemaphore
"Primitive. Install the semaphore to be used for collecting long-running primitives,
or nil if no semaphore should be used."
| sema |
<export: true>
sema := self stackValue: 0.
((objectMemory isIntegerObject: sema)
or: [self methodArgumentCount ~= 1]) ifTrue:
[^self primitiveFail].
sema = objectMemory nilObject
ifTrue:
[longRunningPrimitiveCheckSemaphore := nil]
ifFalse:
+ [(objectMemory fetchClassOfNonImm: sema) = (objectMemory splObj: ClassSemaphore) ifFalse:
- [(objectMemory fetchClassOfNonInt: sema) = (objectMemory splObj: ClassSemaphore) ifFalse:
[^self primitiveFail].
longRunningPrimitiveCheckSemaphore := sema].
self voidLongRunningPrimitive: 'install'.
self pop: 1!
Item was changed:
----- Method: StackInterpreterPrimitives>>primitiveSignalAtMilliseconds (in category 'system control primitives') -----
primitiveSignalAtMilliseconds
"Cause the time semaphore, if one has been registered, to be
signalled when the microsecond clock is greater than or equal to
the given tick value. A tick value of zero turns off timer interrupts."
| msecsObj msecs deltaMsecs sema |
<var: #msecs type: #usqInt>
msecsObj := self stackTop.
sema := self stackValue: 1.
msecs := self positive32BitValueOf: msecsObj.
(self failed
or: [objectMemory isIntegerObject: sema]) ifTrue:
[self primitiveFail.
^nil].
+ (objectMemory fetchClassOfNonImm: sema) = (objectMemory splObj: ClassSemaphore)
- (objectMemory fetchClassOfNonInt: sema) = (objectMemory splObj: ClassSemaphore)
ifTrue:
[objectMemory splObj: TheTimerSemaphore put: sema.
deltaMsecs := msecs - (self ioMSecs bitAnd: MillisecondClockMask).
deltaMsecs < 0 ifTrue:
[deltaMsecs := deltaMsecs + MillisecondClockMask + 1].
nextWakeupUsecs := self ioUTCMicroseconds + (deltaMsecs * 1000)]
ifFalse:
[objectMemory
storePointer: TheTimerSemaphore
ofObject: objectMemory specialObjectsOop
withValue: objectMemory nilObject.
nextWakeupUsecs := 0].
self pop: 2!
Item was changed:
----- Method: StackInterpreterPrimitives>>primitiveSignalAtUTCMicroseconds (in category 'system control primitives') -----
primitiveSignalAtUTCMicroseconds
"Cause the time semaphore, if one has been registered, to be
signalled when the microsecond clock is greater than or equal to
the given tick value. A tick value of zero turns off timer interrupts."
| usecsObj sema usecs |
<var: #usecs type: #usqLong>
usecsObj := self stackTop.
sema := self stackValue: 1.
usecs := self positive64BitValueOf: usecsObj.
(self failed
or: [objectMemory isIntegerObject: sema]) ifTrue:
[self primitiveFail.
^nil].
+ (objectMemory fetchClassOfNonImm: sema) = (objectMemory splObj: ClassSemaphore)
- (objectMemory fetchClassOfNonInt: sema) = (objectMemory splObj: ClassSemaphore)
ifTrue:
[objectMemory splObj: TheTimerSemaphore put: sema.
nextWakeupUsecs := usecs]
ifFalse:
[objectMemory
storePointer: TheTimerSemaphore
ofObject: objectMemory specialObjectsOop
withValue: objectMemory nilObject.
nextWakeupUsecs := 0].
self pop: 2!
More information about the Vm-dev
mailing list