[Vm-dev] VM Maker: VMMaker-dtl.342.mcz
Eliot Miranda
eliot.miranda at gmail.com
Sun Feb 23 16:48:28 UTC 2014
Hi David, you might want to check the accessors. For example, in the below you added getNilObj but (at least in Cog) there's already nilObject, trueObject et al to access nilObj, trueObj et al.
Eliot (phone)
On Feb 23, 2014, at 8:36 AM, commits at source.squeak.org wrote:
>
> David T. Lewis uploaded a new version of VMMaker to project VM Maker:
> http://source.squeak.org/VMMaker/VMMaker-dtl.342.mcz
>
> ==================== Summary ====================
>
> Name: VMMaker-dtl.342
> Author: dtl
> Time: 23 February 2014, 10:37:08.672 am
> UUID: b96b3f58-94e9-45e0-a1b5-833b62ca2284
> Ancestors: VMMaker-dtl.341
>
> VMMaker 4.13.3
>
> Make it possible to produce a working VM with inlining disabled.
>
> To build a VM without inlining: A VMMaker instance has an #inline variable, set it false to disable inlining. During build, disable the gnufication step.
>
> Changes are:
>
> Fix BalloonEnginePlugin>>stepToNextBezierForward:at: by removing unneeded cCoerce (this was an earlier workaround for a slang generation bug, no longer relevant).
>
> Rename accessors in ObjectMemory and Interpreter to prevent name clashes in generated code. For variable foo the accessors would be getFoo and setFoo. Accessors are required because the object memory and interpreter have been factored into separate hierarchies.
>
> For variables that represent C arrays, provide accessors such as fooAt: and fooAt:put: for array access.
>
> =============== Diff against VMMaker-dtl.341 ===============
>
> Item was changed:
> ----- Method: BalloonEnginePlugin>>stepToNextBezierForward:at: (in category 'beziers-simple') -----
> stepToNextBezierForward: updateData at: yValue
> + "Incrementally step to the next scan line in the given bezier update data."
> - "Incrementally step to the next scan line in the given bezier update data.
> - Note: This method has been written so that inlining works, e.g.,
> - not declaring updateData as 'int*' but casting it on every use."
> | minY lastX lastY fwDx fwDy |
> <inline: true>
> + <var: #updateData type: 'int *'>
> + lastX := updateData at: GBUpdateX.
> + lastY := updateData at: GBUpdateY.
> + fwDx := updateData at: GBUpdateDX.
> + fwDy := updateData at: GBUpdateDY.
> - lastX := (self cCoerce: updateData to: 'int*') at: GBUpdateX.
> - lastY := (self cCoerce: updateData to: 'int*') at: GBUpdateY.
> - fwDx := (self cCoerce: updateData to: 'int*') at: GBUpdateDX.
> - fwDy := (self cCoerce: updateData to: 'int*') at: GBUpdateDY.
> minY := yValue * 256.
> "Step as long as we haven't yet reached minY and also
> as long as fwDy is greater than zero thus stepping down.
> Note: The test for fwDy should not be necessary in theory
> but is a good insurance in practice."
> [minY > lastY and:[fwDy >= 0]] whileTrue:[
> lastX := lastX + ((fwDx + 16r8000) // 16r10000).
> lastY := lastY + ((fwDy + 16r8000) // 16r10000).
> + fwDx := fwDx + (updateData at: GBUpdateDDX).
> + fwDy := fwDy + (updateData at: GBUpdateDDY).
> - fwDx := fwDx + ((self cCoerce: updateData to: 'int*') at: GBUpdateDDX).
> - fwDy := fwDy + ((self cCoerce: updateData to: 'int*') at: GBUpdateDDY).
> ].
> + updateData at: GBUpdateX put: lastX.
> + updateData at: GBUpdateY put: lastY.
> + updateData at: GBUpdateDX put: fwDx.
> + updateData at: GBUpdateDY put: fwDy.
> - (self cCoerce: updateData to: 'int*') at: GBUpdateX put: lastX.
> - (self cCoerce: updateData to: 'int*') at: GBUpdateY put: lastY.
> - (self cCoerce: updateData to: 'int*') at: GBUpdateDX put: fwDx.
> - (self cCoerce: updateData to: 'int*') at: GBUpdateDY put: fwDy.
> ^lastX // 256
> !
>
> Item was added:
> + ----- Method: ClassicObjectMemory>>getYoungStart (in category 'accessing') -----
> + getYoungStart
> + <returnTypeC: #usqInt>
> + ^youngStart!
>
> Item was added:
> + ----- Method: ClassicObjectMemory>>startOfFreeSpace (in category 'accessing') -----
> + startOfFreeSpace
> + <returnTypeC: #usqInt>
> + ^freeBlock!
>
> Item was removed:
> - ----- Method: ClassicObjectMemory>>youngStart (in category 'accessing') -----
> - youngStart
> - ^youngStart!
>
> Item was changed:
> ----- Method: Interpreter>>activateNewMethod (in category 'message sending') -----
> activateNewMethod
> | newContext methodHeader initialIP tempCount nilOop where |
>
> methodHeader := self headerOf: newMethod.
> newContext := objectMemory allocateOrRecycleContext: (methodHeader bitAnd: LargeContextBit).
>
> initialIP := ((LiteralStart + (self literalCountOfHeader: methodHeader)) * objectMemory bytesPerWord) + 1.
> tempCount := (methodHeader >> 19) bitAnd: 16r3F.
>
> "Assume: newContext will be recorded as a root if necessary by the
> call to newActiveContext: below, so we can use unchecked stores."
>
> where := newContext + objectMemory baseHeaderSize.
> objectMemory longAt: where + (SenderIndex << objectMemory shiftForWord) put: activeContext.
> objectMemory longAt: where + (InstructionPointerIndex << objectMemory shiftForWord) put: (objectMemory integerObjectOf: initialIP).
> objectMemory longAt: where + (StackPointerIndex << objectMemory shiftForWord) put: (objectMemory integerObjectOf: tempCount).
> objectMemory longAt: where + (MethodIndex << objectMemory shiftForWord) put: newMethod.
> + objectMemory longAt: where + (ClosureIndex << objectMemory shiftForWord) put: objectMemory getNilObj.
> - objectMemory longAt: where + (ClosureIndex << objectMemory shiftForWord) put: objectMemory nilObj.
>
> "Copy the receiver and arguments..."
> 0 to: argumentCount do:
> [:i | objectMemory longAt: where + ((ReceiverIndex+i) << objectMemory shiftForWord) put: (self stackValue: argumentCount-i)].
>
> "clear remaining temps to nil in case it has been recycled"
> + nilOop := objectMemory getNilObj.
> - nilOop := objectMemory nilObj.
> argumentCount+1+ReceiverIndex to: tempCount+ReceiverIndex do:
> [:i | objectMemory longAt: where + (i << objectMemory shiftForWord) put: nilOop].
>
> self pop: argumentCount + 1.
> reclaimableContextCount := reclaimableContextCount + 1.
> self newActiveContext: newContext.!
>
> Item was changed:
> ----- Method: Interpreter>>assertClassOf:is: (in category 'utilities') -----
> assertClassOf: oop is: classOop
> "Succeed if the given (non-integer) object is an instance of the given class. Fail if the object is an integer."
>
> | ccIndex cl |
> <inline: true>
> (objectMemory isIntegerObject: oop)
> ifTrue: [ self primitiveFail. ^ nil ].
>
> ccIndex := ((objectMemory baseHeader: oop) >> 12) bitAnd: 16r1F.
> ccIndex = 0
> ifTrue: [ cl := ((objectMemory classHeader: oop) bitAnd: objectMemory allButTypeMask) ]
> ifFalse: [
> "look up compact class"
> cl := (objectMemory fetchPointer: (ccIndex - 1)
> + ofObject: (objectMemory fetchPointer: CompactClasses ofObject: objectMemory getSpecialObjectsOop))].
> - ofObject: (objectMemory fetchPointer: CompactClasses ofObject: objectMemory specialObjectsOop))].
>
> self success: cl = classOop.
> !
>
> Item was changed:
> ----- Method: Interpreter>>booleanCheat: (in category 'utilities') -----
> booleanCheat: cond
> "cheat the interpreter out of the pleasure of handling the next bytecode IFF it is a jump-on-boolean. Which it is, often enough when the current bytecode is something like bytecodePrimEqual"
> | bytecode offset |
> <inline: true>
>
> bytecode := self fetchByte. "assume next bytecode is jumpIfFalse (99%)"
> self internalPop: 2.
> (bytecode < 160 and: [bytecode > 151]) ifTrue: [ "short jumpIfFalse"
> cond
> ifTrue: [^ self fetchNextBytecode]
> ifFalse: [^ self jump: bytecode - 151]].
>
> bytecode = 172 ifTrue: [ "long jumpIfFalse"
> offset := self fetchByte.
> cond
> ifTrue: [^ self fetchNextBytecode]
> ifFalse: [^ self jump: offset]].
>
> "not followed by a jumpIfFalse; undo instruction fetch and push boolean result"
> localIP := localIP - 1.
> self fetchNextBytecode.
> cond
> + ifTrue: [self internalPush: objectMemory getTrueObj]
> + ifFalse: [self internalPush: objectMemory getFalseObj].
> - ifTrue: [self internalPush: objectMemory trueObj]
> - ifFalse: [self internalPush: objectMemory falseObj].
> !
>
> Item was changed:
> ----- Method: Interpreter>>booleanValueOf: (in category 'utilities') -----
> booleanValueOf: obj
> "convert true and false (Smalltalk) to true or false(C)"
> + obj = objectMemory getTrueObj ifTrue: [ ^ true ].
> + obj = objectMemory getFalseObj ifTrue: [ ^ false ].
> - obj = objectMemory trueObj ifTrue: [ ^ true ].
> - obj = objectMemory falseObj ifTrue: [ ^ false ].
> self primitiveFail.
> ^ nil!
>
> Item was changed:
> ----- Method: Interpreter>>byteSwapByteObjects (in category 'image save/restore') -----
> byteSwapByteObjects
> "Byte-swap the words of all bytes objects in the image. This returns these objects to their original byte ordering after blindly byte-swapping the entire image."
>
> + self byteSwapByteObjectsFrom: objectMemory firstObject to: objectMemory getEndOfMemory!
> - self byteSwapByteObjectsFrom: objectMemory firstObject to: objectMemory endOfMemory!
>
> Item was changed:
> ----- Method: Interpreter>>capturePendingFinalizationSignals (in category 'debug support') -----
> capturePendingFinalizationSignals
> + objectMemory setStatpendingFinalizationSignals: pendingFinalizationSignals.
> - objectMemory statpendingFinalizationSignals: pendingFinalizationSignals.
> !
>
> Item was changed:
> ----- Method: Interpreter>>changeClassOf:to: (in category 'object access primitives') -----
> changeClassOf: rcvr to: argClass
> "Change the class of the receiver into the class specified by the argument given that the format of the receiver matches the format of the argument. Fail if 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."
> | classHdr sizeHiBits byteSize argFormat rcvrFormat ccIndex |
> "Check what the format of the class says"
> classHdr := objectMemory formatOfClass: argClass. "Low 2 bits are 0"
>
> "Compute the size of instances of the class (used for fixed field classes only)"
> sizeHiBits := (classHdr bitAnd: 16r60000) >> 9.
> classHdr := classHdr bitAnd: 16r1FFFF.
> byteSize := (classHdr bitAnd: objectMemory sizeMask) + sizeHiBits. "size in bytes -- low 2 bits are 0"
>
> "Check the receiver's format against that of the class"
> argFormat := (classHdr >> 8) bitAnd: 16rF.
> rcvrFormat := objectMemory formatOf: rcvr.
> argFormat = rcvrFormat ifFalse:[^self primitiveFail]. "no way"
>
> "For fixed field classes, the sizes must match.
> Note: byteSize-4 because base header is included in class size."
> argFormat < 2 ifTrue:[(byteSize - objectMemory baseHeaderSize) = (objectMemory byteSizeOf: rcvr) ifFalse:[^self primitiveFail]].
>
> (objectMemory headerType: rcvr) = HeaderTypeShort
> ifTrue:[ "Compact classes. Check if the arg's class is compact and exchange ccIndex"
> ccIndex := classHdr bitAnd: CompactClassMask.
> ccIndex = 0 ifTrue:[^self primitiveFail]. "class is not compact"
> objectMemory longAt: rcvr put:
> (((objectMemory longAt: rcvr) bitAnd: CompactClassMask bitInvert32)
> bitOr: ccIndex)]
> ifFalse:["Exchange the class pointer, which could make rcvr a root for argClass"
> objectMemory longAt: rcvr - objectMemory baseHeaderSize put: (argClass bitOr: (objectMemory headerType: rcvr)).
> + (objectMemory oop: rcvr isLessThan: objectMemory getYoungStart)
> - (objectMemory oop: rcvr isLessThan: objectMemory youngStart)
> ifTrue: [objectMemory possibleRootStoreInto: rcvr value: argClass]]!
>
> Item was changed:
> ----- Method: Interpreter>>checkForInterrupts (in category 'process primitive support') -----
> checkForInterrupts
> "Check for possible interrupts and handle one if necessary."
> | sema now |
> <inline: false>
>
> "Mask so same wrapping as primitiveMillisecondClock"
> now := self ioMSecs bitAnd: MillisecondClockMask.
>
> self interruptCheckForced ifFalse: [
> "don't play with the feedback if we forced a check. It only makes life difficult"
> now - lastTick < interruptChecksEveryNms
> ifTrue: ["wrapping is not a concern, it'll get caught quickly
> enough. This clause is trying to keep a reasonable
> guess of how many times per interruptChecksEveryNms we are calling
> quickCheckForInterrupts. Not sure how effective it really is."
> interruptCheckCounterFeedBackReset := interruptCheckCounterFeedBackReset + 10]
> ifFalse: [interruptCheckCounterFeedBackReset <= 1000
> ifTrue: [interruptCheckCounterFeedBackReset := 1000]
> ifFalse: [interruptCheckCounterFeedBackReset := interruptCheckCounterFeedBackReset - 12]]].
>
> "reset the interrupt check counter"
> interruptCheckCounter := interruptCheckCounterFeedBackReset.
>
> + objectMemory getSignalLowSpace
> + ifTrue: [objectMemory setSignalLowSpace: false. "reset flag"
> - objectMemory signalLowSpace
> - ifTrue: [objectMemory signalLowSpace: false. "reset flag"
> sema := objectMemory splObj: TheLowSpaceSemaphore.
> + sema = objectMemory getNilObj ifFalse: [self synchronousSignal: sema]].
> - sema = objectMemory nilObj ifFalse: [self synchronousSignal: sema]].
>
> now < lastTick
> ifTrue: ["millisecond clock wrapped so correct the nextPollTick"
> nextPollTick := nextPollTick - MillisecondClockMask - 1].
> now >= nextPollTick
> ifTrue: [self ioProcessEvents.
> "sets interruptPending if interrupt key pressed"
> nextPollTick := now + 200
> "msecs to wait before next call to ioProcessEvents.
> Note that strictly speaking we might need to update
> 'now' at this point since ioProcessEvents could take a
> very long time on some platforms"].
> interruptPending
> ifTrue: [interruptPending := false.
> "reset interrupt flag"
> sema := objectMemory splObj: TheInterruptSemaphore.
> + sema = objectMemory getNilObj
> - sema = objectMemory nilObj
> ifFalse: [self synchronousSignal: sema]].
>
> nextWakeupTick ~= 0
> ifTrue: [now < lastTick
> ifTrue: ["the clock has wrapped. Subtract the wrap
> interval from nextWakeupTick - this might just
> possibly result in 0. Since this is used as a flag
> value for 'no timer' we do the 0 check above"
> nextWakeupTick := nextWakeupTick - MillisecondClockMask - 1].
> now >= nextWakeupTick
> ifTrue: [nextWakeupTick := 0.
> "set timer interrupt to 0 for 'no timer'"
> sema := objectMemory splObj: TheTimerSemaphore.
> + sema = objectMemory getNilObj ifFalse: [self synchronousSignal: sema]]].
> - sema = objectMemory nilObj ifFalse: [self synchronousSignal: sema]]].
>
> "signal any pending finalizations"
> pendingFinalizationSignals > 0
> ifTrue: [sema := objectMemory splObj: TheFinalizationSemaphore.
> (objectMemory fetchClassOf: sema) = (objectMemory splObj: ClassSemaphore)
> ifTrue: [self synchronousSignal: sema].
> pendingFinalizationSignals := 0].
>
> "signal all semaphores in semaphoresToSignal"
> (semaphoresToSignalCountA > 0 or: [semaphoresToSignalCountB > 0])
> ifTrue: [self signalExternalSemaphores].
>
> "update the tracking value"
> lastTick := now!
>
> Item was changed:
> ----- Method: Interpreter>>commonReturn (in category 'return bytecodes') -----
> commonReturn
> "Note: Assumed to be inlined into the dispatch loop."
>
> | nilOop thisCntx contextOfCaller localCntx localVal unwindMarked |
> <inline: true>
> self sharedCodeNamed: 'commonReturn' inCase: 120.
>
> + nilOop := objectMemory getNilObj. "keep in a register"
> - nilOop := objectMemory nilObj. "keep in a register"
> thisCntx := activeContext.
> localCntx := localReturnContext.
> localVal := localReturnValue.
>
> "make sure we can return to the given context"
> ((localCntx = nilOop) or:
> [(objectMemory fetchPointer: InstructionPointerIndex ofObject: localCntx) = nilOop]) ifTrue: [
> "error: sender's instruction pointer or context is nil; cannot return"
> ^self internalCannotReturn: localVal].
>
> "If this return is not to our immediate predecessor (i.e. from a method to its sender, or from a block to its caller), scan the stack for the first unwind marked context and inform this context and let it deal with it. This provides a chance for ensure unwinding to occur."
> thisCntx := objectMemory fetchPointer: SenderIndex ofObject: activeContext.
>
> "Just possibly a faster test would be to compare the homeContext and activeContext - they are of course different for blocks. Thus we might be able to optimise a touch by having a different returnTo for the blockreteurn (since we know that must return to caller) and then if active ~= home we must be doing a non-local return. I think. Maybe."
> [thisCntx = localCntx] whileFalse: [
> thisCntx = nilOop ifTrue:[
> "error: sender's instruction pointer or context is nil; cannot return"
> ^self internalCannotReturn: localVal].
> "Climb up stack towards localCntx. Break out to a send of #aboutToReturn:through: if an unwind marked context is found"
> unwindMarked := self isUnwindMarked: thisCntx.
> unwindMarked ifTrue:[
> "context is marked; break out"
> ^self internalAboutToReturn: localVal through: thisCntx].
> thisCntx := objectMemory fetchPointer: SenderIndex ofObject: thisCntx.
> ].
>
> "If we get here there is no unwind to worry about. Simply terminate the stack up to the localCntx - often just the sender of the method"
> thisCntx := activeContext.
> [thisCntx = localCntx]
> whileFalse:
> ["climb up stack to localCntx"
> contextOfCaller := objectMemory fetchPointer: SenderIndex ofObject: thisCntx.
>
> "zap exited contexts so any future attempted use will be caught"
> objectMemory storePointerUnchecked: SenderIndex ofObject: thisCntx withValue: nilOop.
> objectMemory storePointerUnchecked: InstructionPointerIndex ofObject: thisCntx withValue: nilOop.
> reclaimableContextCount > 0 ifTrue:
> ["try to recycle this context"
> reclaimableContextCount := reclaimableContextCount - 1.
> objectMemory recycleContextIfPossible: thisCntx].
> thisCntx := contextOfCaller].
>
> activeContext := thisCntx.
> + (objectMemory oop: thisCntx isLessThan: objectMemory getYoungStart) ifTrue: [ objectMemory beRootIfOld: thisCntx ].
> - (objectMemory oop: thisCntx isLessThan: objectMemory youngStart) ifTrue: [ objectMemory beRootIfOld: thisCntx ].
>
> self internalFetchContextRegisters: thisCntx. "updates local IP and SP"
> self fetchNextBytecode.
> self internalPush: localVal.
> !
>
> Item was changed:
> ----- Method: Interpreter>>context:hasSender: (in category 'contexts') -----
> context: thisCntx hasSender: aContext
> "Does thisCntx have aContext in its sender chain?"
> | s nilOop |
> <inline: true>
> thisCntx == aContext ifTrue: [^false].
> + nilOop := objectMemory getNilObj.
> - nilOop := objectMemory nilObj.
> s := objectMemory fetchPointer: SenderIndex ofObject: thisCntx.
> [s == nilOop]
> whileFalse: [s == aContext ifTrue: [^true].
> s := objectMemory fetchPointer: SenderIndex ofObject: s].
> ^false!
>
> Item was changed:
> ----- Method: Interpreter>>dumpImage: (in category 'image save/restore') -----
> dumpImage: fileName
> "Dump the entire image out to the given file. Intended for debugging only."
> | f dataSize result |
> <export: true>
> <var: #fileName type: 'char *'>
> <var: #f type: 'sqImageFile'>
>
> f := self cCode: 'sqImageFileOpen(fileName, "wb")'.
> f = nil ifTrue: [^-1].
> + dataSize := objectMemory getEndOfMemory - objectMemory startOfMemory.
> - dataSize := objectMemory endOfMemory - objectMemory startOfMemory.
> result := self cCode: 'sqImageFileWrite(pointerForOop(memory), sizeof(unsigned char), dataSize, f)'.
> self cCode: 'sqImageFileClose(f)'.
> ^result
> !
>
> Item was changed:
> ----- Method: Interpreter>>fetchContextRegisters: (in category 'contexts') -----
> fetchContextRegisters: activeCntx
> "Note: internalFetchContextRegisters: should track changes to this method."
> | tmp |
> <inline: true>
> tmp := objectMemory fetchPointer: MethodIndex ofObject: activeCntx.
> (objectMemory isIntegerObject: tmp)
> ifTrue: ["if the MethodIndex field is an integer, activeCntx is a block context"
> tmp := objectMemory fetchPointer: HomeIndex ofObject: activeCntx.
> + (objectMemory oop: tmp isLessThan: objectMemory getYoungStart) ifTrue: [objectMemory beRootIfOld: tmp]]
> - (objectMemory oop: tmp isLessThan: objectMemory youngStart) ifTrue: [objectMemory beRootIfOld: tmp]]
> ifFalse: ["otherwise, it is a method context and is its own home context "
> tmp := activeCntx].
> theHomeContext := tmp.
> receiver := objectMemory fetchPointer: ReceiverIndex ofObject: tmp.
> method := objectMemory fetchPointer: MethodIndex ofObject: tmp.
>
> "the instruction pointer is a pointer variable equal to
> method oop + ip + objectMemory baseHeaderSize
> -1 for 0-based addressing of fetchByte
> -1 because it gets incremented BEFORE fetching currentByte "
> tmp := self quickFetchInteger: InstructionPointerIndex ofObject: activeCntx.
> instructionPointer := method + tmp + objectMemory baseHeaderSize - 2.
>
> "the stack pointer is a pointer variable also..."
> tmp := self quickFetchInteger: StackPointerIndex ofObject: activeCntx.
> stackPointer := activeCntx + objectMemory baseHeaderSize + (TempFrameStart + tmp - 1 * objectMemory bytesPerWord)!
>
> Item was changed:
> ----- Method: Interpreter>>findClassOfMethod:forReceiver: (in category 'debug support') -----
> findClassOfMethod: meth forReceiver: rcvr
>
> | currClass classDict classDictSize methodArray i done |
> currClass := objectMemory fetchClassOf: rcvr.
> done := false.
> [done] whileFalse: [
> classDict := objectMemory fetchPointer: MessageDictionaryIndex ofObject: currClass.
> classDictSize := objectMemory fetchWordLengthOf: classDict.
> methodArray := objectMemory fetchPointer: MethodArrayIndex ofObject: classDict.
> i := 0.
> [i < (classDictSize - SelectorStart)] whileTrue: [
> meth = (objectMemory fetchPointer: i ofObject: methodArray) ifTrue: [ ^currClass ].
> i := i + 1.
> ].
> currClass := objectMemory fetchPointer: SuperclassIndex ofObject: currClass.
> + done := currClass = objectMemory getNilObj.
> - done := currClass = objectMemory nilObj.
> ].
> ^objectMemory fetchClassOf: rcvr "method not found in superclass chain"!
>
> Item was changed:
> ----- Method: Interpreter>>findSelectorOfMethod:forReceiver: (in category 'debug support') -----
> findSelectorOfMethod: meth forReceiver: rcvr
>
> | currClass done classDict classDictSize methodArray i |
> currClass := objectMemory fetchClassOf: rcvr.
> done := false.
> [done] whileFalse: [
> classDict := objectMemory fetchPointer: MessageDictionaryIndex ofObject: currClass.
> classDictSize := objectMemory fetchWordLengthOf: classDict.
> methodArray := objectMemory fetchPointer: MethodArrayIndex ofObject: classDict.
> i := 0.
> [i <= (classDictSize - SelectorStart)] whileTrue: [
> meth = (objectMemory fetchPointer: i ofObject: methodArray) ifTrue: [
> ^(objectMemory fetchPointer: i + SelectorStart ofObject: classDict)
> ].
> i := i + 1.
> ].
> currClass := objectMemory fetchPointer: SuperclassIndex ofObject: currClass.
> + done := currClass = objectMemory getNilObj.
> - done := currClass = objectMemory nilObj.
> ].
> + ^ objectMemory getNilObj "method not found in superclass chain"!
> - ^ objectMemory nilObj "method not found in superclass chain"!
>
> Item was changed:
> ----- Method: Interpreter>>flushExternalPrimitives (in category 'plugin primitive support') -----
> flushExternalPrimitives
> "Flush the references to external functions from plugin
> primitives. This will force a reload of those primitives when
> accessed next.
> Note: We must flush the method cache here so that any
> failed primitives are looked up again."
> | oop primIdx |
> oop := objectMemory firstObject.
> + [objectMemory oop: oop isLessThan: objectMemory getEndOfMemory]
> - [objectMemory oop: oop isLessThan: objectMemory endOfMemory]
> whileTrue: [(objectMemory isFreeObject: oop)
> ifFalse: [(objectMemory isCompiledMethod: oop)
> ifTrue: ["This is a compiled method"
> primIdx := self primitiveIndexOf: oop.
> primIdx = PrimitiveExternalCallIndex
> ifTrue: ["It's primitiveExternalCall"
> self flushExternalPrimitiveOf: oop]]].
> oop := objectMemory objectAfter: oop].
> self flushMethodCache.
> self flushExternalPrimitiveTable!
>
> Item was removed:
> - ----- Method: Interpreter>>imageFormatInitialVersion (in category 'image save/restore') -----
> - imageFormatInitialVersion
> - "This is the image format version that was saved to in the previous image snapshot.
> - The interpreter checks this value at image load time to determine if it is able to load
> - and run the image file. When the image is next saved, it will be saved using the current
> - imageFormatVersion, which may be different from imageFormatInitialVersion. "
> - ^imageFormatInitialVersion!
>
> Item was changed:
> ----- Method: Interpreter>>includesBehavior:ThatOf: (in category 'plugin primitive support') -----
> includesBehavior: aClass ThatOf: aSuperclass
> "Return the equivalent of
> aClass includesBehavior: aSuperclass.
> Note: written for efficiency and better inlining (only 1 temp)"
> | theClass |
> <inline: true>
> + aSuperclass = objectMemory getNilObj ifTrue:
> - aSuperclass = objectMemory nilObj ifTrue:
> [^false].
> theClass := aClass.
> [theClass = aSuperclass ifTrue:
> [^true].
> + theClass ~= objectMemory getNilObj] whileTrue:
> - theClass ~= objectMemory nilObj] whileTrue:
> [theClass := self superclassOf: theClass].
> ^false!
>
> Item was added:
> + ----- Method: Interpreter>>initialImageFormatVersion (in category 'image save/restore') -----
> + initialImageFormatVersion
> + "This is the image format version that was saved to in the previous image snapshot.
> + The interpreter checks this value at image load time to determine if it is able to load
> + and run the image file. When the image is next saved, it will be saved using the current
> + imageFormatVersion, which may be different from imageFormatInitialVersion.
> + Selector name chosen to avoid conflict with variable declaration in generated code."
> + ^imageFormatInitialVersion!
>
> 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.
> objectMemory initializeObjectMemory: bytesToShift.
> self initCompilerHooks.
> + activeContext := objectMemory getNilObj.
> + theHomeContext := objectMemory getNilObj.
> + method := objectMemory getNilObj.
> + receiver := objectMemory getNilObj.
> + messageSelector := objectMemory getNilObj.
> + newMethod := objectMemory getNilObj.
> + methodClass := objectMemory getNilObj.
> + lkupClass := objectMemory getNilObj.
> + receiverClass := objectMemory getNilObj.
> + newNativeMethod := objectMemory getNilObj.
> - activeContext := objectMemory nilObj.
> - theHomeContext := objectMemory nilObj.
> - method := objectMemory nilObj.
> - receiver := objectMemory nilObj.
> - messageSelector := objectMemory nilObj.
> - newMethod := objectMemory nilObj.
> - methodClass := objectMemory nilObj.
> - lkupClass := objectMemory nilObj.
> - receiverClass := objectMemory nilObj.
> - newNativeMethod := objectMemory nilObj.
> self flushMethodCache.
> self loadInitialContext.
> self initialCleanup.
> interruptCheckCounter := 0.
> interruptCheckCounterFeedBackReset := 1000.
> interruptChecksEveryNms := 1.
> 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 := 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"
> !
>
> Item was changed:
> ----- Method: Interpreter>>internalActivateNewMethod (in category 'message sending') -----
> internalActivateNewMethod
> | methodHeader newContext tempCount argCount2 needsLarge where |
> <inline: true>
>
> methodHeader := self headerOf: newMethod.
> needsLarge := methodHeader bitAnd: LargeContextBit.
> + (needsLarge = 0 and: [objectMemory getFreeContexts ~= objectMemory nilContext])
> + ifTrue: [newContext := objectMemory getFreeContexts.
> - (needsLarge = 0 and: [objectMemory freeContexts ~= objectMemory nilContext])
> - ifTrue: [newContext := objectMemory freeContexts.
> objectMemory setFreeContextsAfter: newContext]
> ifFalse: ["Slower call for large contexts or empty free list"
> self externalizeIPandSP.
> newContext := objectMemory allocateOrRecycleContext: needsLarge.
> self internalizeIPandSP].
> tempCount := (methodHeader >> 19) bitAnd: 16r3F.
>
> "Assume: newContext will be recorded as a root if necessary by the
> call to newActiveContext: below, so we can use unchecked stores."
> where := newContext + objectMemory baseHeaderSize.
> objectMemory longAt: where + (SenderIndex << objectMemory shiftForWord) put: activeContext.
> objectMemory longAt: where + (InstructionPointerIndex << objectMemory shiftForWord)
> put: (objectMemory integerObjectOf: (((LiteralStart + (self literalCountOfHeader: methodHeader)) * objectMemory bytesPerWord) + 1)).
> objectMemory longAt: where + (StackPointerIndex << objectMemory shiftForWord) put: (objectMemory integerObjectOf: tempCount).
> objectMemory longAt: where + (MethodIndex << objectMemory shiftForWord) put: newMethod.
> + objectMemory longAt: where + (ClosureIndex << objectMemory shiftForWord) put: objectMemory getNilObj.
> - objectMemory longAt: where + (ClosureIndex << objectMemory shiftForWord) put: objectMemory nilObj.
>
> "Copy the receiver and arguments..."
> argCount2 := argumentCount.
> 0 to: argCount2 do:
> [:i | objectMemory longAt: where + ((ReceiverIndex+i) << objectMemory shiftForWord) put: (self internalStackValue: argCount2-i)].
>
> "clear remaining temps to nil in case it has been recycled"
> + methodHeader := objectMemory getNilObj. "methodHeader here used just as faster (register?) temp"
> - methodHeader := objectMemory nilObj. "methodHeader here used just as faster (register?) temp"
> argCount2+1+ReceiverIndex to: tempCount+ReceiverIndex do:
> [:i | objectMemory longAt: where + (i << objectMemory shiftForWord) put: methodHeader].
>
> self internalPop: argCount2 + 1.
> reclaimableContextCount := reclaimableContextCount + 1.
> self internalNewActiveContext: newContext.
> !
>
> Item was changed:
> ----- Method: Interpreter>>internalExecuteNewMethod (in category 'message sending') -----
> internalExecuteNewMethod
> | localPrimIndex delta nArgs |
> <inline: true>
> localPrimIndex := primitiveIndex.
> localPrimIndex > 0
> ifTrue: [(localPrimIndex > 255
> and: [localPrimIndex < 520])
> ifTrue: ["Internal return instvars"
> localPrimIndex >= 264
> ifTrue: [^ self internalPop: 1 thenPush: (objectMemory fetchPointer: localPrimIndex - 264 ofObject: self internalStackTop)]
> ifFalse: ["Internal return constants"
> localPrimIndex = 256 ifTrue: [^ nil].
> + localPrimIndex = 257 ifTrue: [^ self internalPop: 1 thenPush: objectMemory getTrueObj].
> + localPrimIndex = 258 ifTrue: [^ self internalPop: 1 thenPush: objectMemory getFalseObj].
> + localPrimIndex = 259 ifTrue: [^ self internalPop: 1 thenPush: objectMemory getNilObj].
> - localPrimIndex = 257 ifTrue: [^ self internalPop: 1 thenPush: objectMemory trueObj].
> - localPrimIndex = 258 ifTrue: [^ self internalPop: 1 thenPush: objectMemory falseObj].
> - localPrimIndex = 259 ifTrue: [^ self internalPop: 1 thenPush: objectMemory nilObj].
> ^ self internalPop: 1 thenPush: (objectMemory integerObjectOf: localPrimIndex - 261)]]
> ifFalse: [self externalizeIPandSP.
> "self primitiveResponse. <-replaced with manually inlined code"
> DoBalanceChecks
> ifTrue: ["check stack balance"
> nArgs := argumentCount.
> delta := stackPointer - activeContext].
> self initPrimCall.
> self dispatchFunctionPointer: primitiveFunctionPointer. "branch direct to prim function from address stored in mcache"
> DoBalanceChecks
> ifTrue: [(self balancedStack: delta afterPrimitive: localPrimIndex withArgs: nArgs)
> ifFalse: [self printUnbalancedStack: localPrimIndex]].
> self internalizeIPandSP.
> self successful
> ifTrue: [self browserPluginReturnIfNeeded.
> ^ nil]]].
> "if not primitive, or primitive failed, activate the method"
> self internalActivateNewMethod.
> "check for possible interrupts at each real send"
> self internalQuickCheckForInterrupts!
>
> Item was changed:
> ----- Method: Interpreter>>internalFetchContextRegisters: (in category 'contexts') -----
> internalFetchContextRegisters: activeCntx
> "Inlined into return bytecodes. The only difference between this method and fetchContextRegisters: is that this method sets the local IP and SP."
>
> | tmp |
> <inline: true>
> tmp := objectMemory fetchPointer: MethodIndex ofObject: activeCntx.
> (objectMemory isIntegerObject: tmp) ifTrue: [
> "if the MethodIndex field is an integer, activeCntx is a block context"
> tmp := objectMemory fetchPointer: HomeIndex ofObject: activeCntx.
> + (objectMemory oop: tmp isLessThan: objectMemory getYoungStart) ifTrue: [ objectMemory beRootIfOld: tmp ].
> - (objectMemory oop: tmp isLessThan: objectMemory youngStart) ifTrue: [ objectMemory beRootIfOld: tmp ].
> ] ifFalse: [
> "otherwise, it is a method context and is its own home context"
> tmp := activeCntx.
> ].
> localHomeContext := tmp.
> receiver := objectMemory fetchPointer: ReceiverIndex ofObject: tmp.
> method := objectMemory fetchPointer: MethodIndex ofObject: tmp.
>
> "the instruction pointer is a pointer variable equal to
> method oop + ip + objectMemory baseHeaderSize
> -1 for 0-based addressing of fetchByte
> -1 because it gets incremented BEFORE fetching currentByte"
> tmp := self quickFetchInteger: InstructionPointerIndex ofObject: activeCntx.
> localIP := objectMemory pointerForOop: method + tmp + objectMemory baseHeaderSize - 2.
>
> "the stack pointer is a pointer variable also..."
> tmp := self quickFetchInteger: StackPointerIndex ofObject: activeCntx.
> localSP := objectMemory pointerForOop: activeCntx + objectMemory baseHeaderSize + ((TempFrameStart + tmp - 1) * objectMemory bytesPerWord)!
>
> Item was changed:
> ----- Method: Interpreter>>internalJustActivateNewMethod (in category 'message sending') -----
> internalJustActivateNewMethod
> "Activate the new method but *do not* copy receiver or arguments from activeContext."
> | methodHeader initialIP newContext tempCount needsLarge where |
> <inline: true>
>
> methodHeader := self headerOf: newMethod.
> needsLarge := methodHeader bitAnd: LargeContextBit.
> + (needsLarge = 0 and: [objectMemory getFreeContexts ~= objectMemory nilContext])
> + ifTrue: [newContext := objectMemory getFreeContexts.
> - (needsLarge = 0 and: [objectMemory freeContexts ~= objectMemory nilContext])
> - ifTrue: [newContext := objectMemory freeContexts.
> objectMemory setFreeContextsAfter: newContext]
> ifFalse: ["Slower call for large contexts or empty free list"
> newContext := objectMemory allocateOrRecycleContext: needsLarge].
> initialIP := ((LiteralStart + (self literalCountOfHeader: methodHeader)) * objectMemory bytesPerWord) + 1.
> tempCount := (methodHeader >> 19) bitAnd: 16r3F.
>
> "Assume: newContext will be recorded as a root if necessary by the
> call to newActiveContext: below, so we can use unchecked stores."
> where := newContext + objectMemory baseHeaderSize.
> objectMemory longAt: where + (SenderIndex << objectMemory shiftForWord) put: activeContext.
> objectMemory longAt: where + (InstructionPointerIndex << objectMemory shiftForWord) put: (objectMemory integerObjectOf: initialIP).
> objectMemory longAt: where + (StackPointerIndex << objectMemory shiftForWord) put: (objectMemory integerObjectOf: tempCount).
> objectMemory longAt: where + (MethodIndex << objectMemory shiftForWord) put: newMethod.
>
> "Set the receiver..."
> objectMemory longAt: where + (ReceiverIndex << objectMemory shiftForWord) put: receiver.
>
> "clear all args and temps to nil in case it has been recycled"
> + needsLarge := objectMemory getNilObj. "needsLarge here used just as faster (register?) temp"
> - needsLarge := objectMemory nilObj. "needsLarge here used just as faster (register?) temp"
> ReceiverIndex + 1 to: tempCount + ReceiverIndex do:
> [:i | objectMemory longAt: where + (i << objectMemory shiftForWord) put: needsLarge].
> reclaimableContextCount := reclaimableContextCount + 1.
>
> activeContext := newContext.!
>
> Item was changed:
> ----- Method: Interpreter>>internalNewActiveContext: (in category 'contexts') -----
> internalNewActiveContext: aContext
> "The only difference between this method and newActiveContext: is that this method uses internal context registers."
> <inline: true>
>
> self internalStoreContextRegisters: activeContext.
> + (objectMemory oop: aContext isLessThan: objectMemory getYoungStart) ifTrue: [ objectMemory beRootIfOld: aContext ].
> - (objectMemory oop: aContext isLessThan: objectMemory youngStart) ifTrue: [ objectMemory beRootIfOld: aContext ].
> activeContext := aContext.
> self internalFetchContextRegisters: aContext.!
>
> Item was changed:
> ----- Method: Interpreter>>internalPrimitiveValue (in category 'control primitives') -----
> internalPrimitiveValue
> | newContext blockArgumentCount initialIP |
> <inline: true>
> self sharedCodeNamed: 'commonPrimitiveValue' inCase: 201.
> self initPrimCall.
> newContext := self internalStackValue: argumentCount.
> self assertClassOf: newContext is: (objectMemory splObj: ClassBlockContext).
> blockArgumentCount := self argumentCountOfBlock: newContext.
>
> + self success: (argumentCount = blockArgumentCount and: [(objectMemory fetchPointer: CallerIndex ofObject: newContext) = objectMemory getNilObj]).
> - self success: (argumentCount = blockArgumentCount and: [(objectMemory fetchPointer: CallerIndex ofObject: newContext) = objectMemory nilObj]).
>
> self successful
> ifTrue: ["This code assumes argCount can only = 0 or 1"
> argumentCount = 1
> ifTrue: [objectMemory storePointer: TempFrameStart ofObject: newContext withValue: self internalStackTop].
> self internalPop: argumentCount + 1.
> "copy the initialIP value to the ip slot"
> initialIP := objectMemory fetchPointer: InitialIPIndex ofObject: newContext.
> objectMemory storePointerUnchecked: InstructionPointerIndex ofObject: newContext withValue: initialIP.
> self storeStackPointerValue: argumentCount inContext: newContext.
> objectMemory storePointerUnchecked: CallerIndex ofObject: newContext withValue: activeContext.
> self internalNewActiveContext: newContext]
> ifFalse: [messageSelector := self specialSelector: 25 + argumentCount.
> self normalSend]!
>
> Item was changed:
> ----- Method: Interpreter>>is:KindOf: (in category 'plugin primitive support') -----
> is: oop KindOf: className
> "Support for external primitives."
> | oopClass |
> <var: #className type: 'char *'>
> oopClass := objectMemory fetchClassOf: oop.
> + [oopClass == objectMemory getNilObj] whileFalse:[
> - [oopClass == objectMemory nilObj] whileFalse:[
> (self classNameOf: oopClass Is: className) ifTrue:[^true].
> oopClass := self superclassOf: oopClass].
> ^false!
>
> Item was changed:
> ----- Method: Interpreter>>is:KindOfClass: (in category 'plugin primitive support') -----
> is: oop KindOfClass: aClass
> "Support for external primitives."
> <api>
> | oopClass |
> oopClass := self fetchClassOf: oop.
> + [oopClass = objectMemory getNilObj] whileFalse:
> - [oopClass = objectMemory nilObj] whileFalse:
> [oopClass = aClass ifTrue: [^true].
> oopClass := self superclassOf: oopClass].
> ^false!
>
> Item was changed:
> ----- Method: Interpreter>>isEmptyList: (in category 'process primitive support') -----
> isEmptyList: aLinkedList
>
> + ^ (objectMemory fetchPointer: FirstLinkIndex ofObject: aLinkedList) = objectMemory getNilObj!
> - ^ (objectMemory fetchPointer: FirstLinkIndex ofObject: aLinkedList) = objectMemory nilObj!
>
> Item was changed:
> ----- Method: Interpreter>>jumplfFalseBy: (in category 'jump bytecodes') -----
> jumplfFalseBy: offset
> | boolean |
> boolean := self internalStackTop.
> + boolean = objectMemory getFalseObj
> - boolean = objectMemory falseObj
> ifTrue: [self jump: offset]
> + ifFalse: [boolean = objectMemory getTrueObj
> - ifFalse: [boolean = objectMemory trueObj
> ifFalse: [messageSelector := objectMemory splObj: SelectorMustBeBoolean.
> argumentCount := 0.
> ^ self normalSend].
> self fetchNextBytecode].
> self internalPop: 1!
>
> Item was changed:
> ----- Method: Interpreter>>jumplfTrueBy: (in category 'jump bytecodes') -----
> jumplfTrueBy: offset
> | boolean |
> boolean := self internalStackTop.
> + boolean = objectMemory getTrueObj
> - boolean = objectMemory trueObj
> ifTrue: [self jump: offset]
> + ifFalse: [boolean = objectMemory getFalseObj
> - ifFalse: [boolean = objectMemory falseObj
> ifFalse: [messageSelector := objectMemory splObj: SelectorMustBeBoolean.
> argumentCount := 0.
> ^ self normalSend].
> self fetchNextBytecode].
> self internalPop: 1!
>
> Item was changed:
> ----- Method: Interpreter>>loadInitialContext (in category 'initialization') -----
> loadInitialContext
>
> | sched proc |
> sched := objectMemory fetchPointer: ValueIndex ofObject: (objectMemory splObj: SchedulerAssociation).
> proc := objectMemory fetchPointer: ActiveProcessIndex ofObject: sched.
> activeContext := objectMemory fetchPointer: SuspendedContextIndex ofObject: proc.
> + (objectMemory oop: activeContext isLessThan: objectMemory getYoungStart) ifTrue: [ objectMemory beRootIfOld: activeContext ].
> - (objectMemory oop: activeContext isLessThan: objectMemory youngStart) ifTrue: [ objectMemory beRootIfOld: activeContext ].
> self fetchContextRegisters: activeContext.
> reclaimableContextCount := 0.!
>
> Item was changed:
> ----- Method: Interpreter>>lookupMethodInClass: (in category 'message sending') -----
> lookupMethodInClass: class
> | currentClass dictionary found rclass |
> <inline: false>
>
> currentClass := class.
> + [currentClass ~= objectMemory getNilObj]
> - [currentClass ~= objectMemory nilObj]
> whileTrue:
> [dictionary := objectMemory fetchPointer: MessageDictionaryIndex ofObject: currentClass.
> + dictionary = objectMemory getNilObj ifTrue:
> - dictionary = objectMemory nilObj ifTrue:
> ["MethodDict pointer is nil (hopefully due a swapped out stub)
> -- raise exception #cannotInterpret:."
> objectMemory pushRemappableOop: currentClass. "may cause GC!!"
> self createActualMessageTo: class.
> currentClass := objectMemory popRemappableOop.
> messageSelector := objectMemory splObj: SelectorCannotInterpret.
> ^ self lookupMethodInClass: (self superclassOf: currentClass)].
> found := self lookupMethodInDictionary: dictionary.
> found ifTrue: [^ methodClass := currentClass].
> currentClass := self superclassOf: currentClass].
>
> "Could not find #doesNotUnderstand: -- unrecoverable error."
> messageSelector = (objectMemory splObj: SelectorDoesNotUnderstand) ifTrue:
> [self error: 'Recursive not understood error encountered'].
>
> "Cound not find a normal message -- raise exception #doesNotUnderstand:"
> objectMemory pushRemappableOop: class. "may cause GC!!"
> self createActualMessageTo: class.
> rclass := objectMemory popRemappableOop.
> messageSelector := objectMemory splObj: SelectorDoesNotUnderstand.
> ^ self lookupMethodInClass: rclass!
>
> Item was changed:
> ----- Method: Interpreter>>lookupMethodInDictionary: (in category 'message sending') -----
> lookupMethodInDictionary: dictionary
> "This method lookup tolerates integers as Dictionary keys to
> support execution of images in which Symbols have been
> compacted out"
> | length index mask wrapAround nextSelector methodArray |
> <inline: true>
> length := objectMemory fetchWordLengthOf: dictionary.
> mask := length - SelectorStart - 1.
> (objectMemory isIntegerObject: messageSelector)
> ifTrue: [index := (mask bitAnd: (objectMemory integerValueOf: messageSelector)) + SelectorStart]
> ifFalse: [index := (mask bitAnd: (objectMemory hashBitsOf: messageSelector)) + SelectorStart].
>
> "It is assumed that there are some nils in this dictionary, and search will
> stop when one is encountered. However, if there are no nils, then wrapAround
> will be detected the second time the loop gets to the end of the table."
> wrapAround := false.
> [true]
> whileTrue: [nextSelector := objectMemory fetchPointer: index ofObject: dictionary.
> + nextSelector = objectMemory getNilObj ifTrue: [^ false].
> - nextSelector = objectMemory nilObj ifTrue: [^ false].
> nextSelector = messageSelector
> ifTrue: [methodArray := objectMemory fetchPointer: MethodArrayIndex ofObject: dictionary.
> newMethod := objectMemory fetchPointer: index - SelectorStart ofObject: methodArray.
> "Check if newMethod is a CompiledMethod."
> (objectMemory isCompiledMethod: newMethod)
> ifTrue: [primitiveIndex := self primitiveIndexOf: newMethod.
> primitiveIndex > MaxPrimitiveIndex
> ifTrue: ["If primitiveIndex is out of range, set to zero before putting in
> cache. This is equiv to primFail, and avoids the need to check on
> every send."
> primitiveIndex := 0]]
> ifFalse: ["indicate that this is no compiled method - use primitiveInvokeObjectAsMethod"
> primitiveIndex := 248].
> ^ true].
> index := index + 1.
> index = length
> ifTrue: [wrapAround
> ifTrue: [^ false].
> wrapAround := true.
> index := SelectorStart]]!
>
> Item was changed:
> ----- Method: Interpreter>>lookupMethodNoMNUEtcInClass: (in category 'alien support') -----
> lookupMethodNoMNUEtcInClass: class
> "Lookup. Answer false on failure father than performing MNU processing etc."
> | currentClass dictionary |
> <inline: true>
>
> currentClass := class.
> + [currentClass ~= objectMemory getNilObj] whileTrue:
> - [currentClass ~= objectMemory nilObj] whileTrue:
> [dictionary := objectMemory fetchPointer: MessageDictionaryIndex ofObject: currentClass.
> + (dictionary ~= objectMemory getNilObj
> - (dictionary ~= objectMemory nilObj
> and: [self lookupMethodInDictionary: dictionary]) ifTrue:
> [methodClass := currentClass.
> ^true].
> currentClass := self superclassOf: currentClass].
>
> ^false!
>
> Item was changed:
> ----- Method: Interpreter>>mapInterpreterOops (in category 'object memory support') -----
> mapInterpreterOops
> "Map all oops in the interpreter's state to their new values
> during garbage collection or a become: operation."
> "Assume: All traced variables contain valid oops."
> | oop |
> objectMemory mapRootObjects.
> compilerInitialized
> ifFalse: [stackPointer := stackPointer - activeContext. "*rel to active"
> activeContext := objectMemory remap: activeContext.
> stackPointer := stackPointer + activeContext. "*rel to active"
> theHomeContext := objectMemory remap: theHomeContext].
> instructionPointer := instructionPointer - method. "*rel to method"
> method := objectMemory remap: method.
> instructionPointer := instructionPointer + method. "*rel to method"
> receiver := objectMemory remap: receiver.
> messageSelector := objectMemory remap: messageSelector.
> newMethod := objectMemory remap: newMethod.
> methodClass := objectMemory remap: methodClass.
> lkupClass := objectMemory remap: lkupClass.
> receiverClass := objectMemory remap: receiverClass.
> + 1 to: objectMemory getRemapBufferCount do: [:i |
> + oop := objectMemory remapBufferAt: i.
> - 1 to: objectMemory remapBufferCount do: [:i |
> - oop := objectMemory remapBuffer at: i.
> (objectMemory isIntegerObject: oop)
> + ifFalse: [objectMemory remapBufferAt: i put: (objectMemory remap: oop)]].
> - ifFalse: [objectMemory remapBuffer at: i put: (objectMemory remap: oop)]].
>
> "Callback support - trace suspended callback list"
> 1 to: jmpDepth do:[:i|
> oop := suspendedCallbacks at: i.
> (objectMemory isIntegerObject: oop)
> ifFalse:[suspendedCallbacks at: i put: (objectMemory remap: oop)].
> oop := suspendedMethods at: i.
> (objectMemory isIntegerObject: oop)
> ifFalse:[suspendedMethods at: i put: (objectMemory remap: oop)].
> ].
> !
>
> Item was removed:
> - ----- Method: Interpreter>>markAndTraceInterpreterOops (in category 'object memory support') -----
> - markAndTraceInterpreterOops
> - "Mark and trace all oops in the interpreter's state."
> - "Assume: All traced variables contain valid oops."
> - | oop |
> - self compilerMarkHook.
> - objectMemory markAndTrace: objectMemory specialObjectsOop. "also covers nilObj, trueObj, falseObj, and compact classes"
> - compilerInitialized
> - ifTrue: [objectMemory markAndTrace: receiver.
> - objectMemory markAndTrace: method]
> - ifFalse: [objectMemory markAndTrace: activeContext].
> - objectMemory markAndTrace: messageSelector.
> - objectMemory markAndTrace: newMethod.
> - objectMemory markAndTrace: methodClass.
> - objectMemory markAndTrace: lkupClass.
> - objectMemory markAndTrace: receiverClass.
> - 1 to: objectMemory remapBufferCount do: [:i |
> - oop := objectMemory remapBuffer at: i.
> - (objectMemory isIntegerObject: oop) ifFalse: [objectMemory markAndTrace: oop]].
> -
> - "Callback support - trace suspended callback list"
> - 1 to: jmpDepth do:[:i|
> - oop := suspendedCallbacks at: i.
> - (objectMemory isIntegerObject: oop) ifFalse:[objectMemory markAndTrace: oop].
> - oop := suspendedMethods at: i.
> - (objectMemory isIntegerObject: oop) ifFalse:[objectMemory markAndTrace: oop].
> - ].
> - !
>
> Item was changed:
> ----- Method: Interpreter>>markAndTraceInterpreterOops: (in category 'object memory support') -----
> markAndTraceInterpreterOops: fullGCFlag
> + "Mark and trace all oops in the interpreter's state."
> + "Assume: All traced variables contain valid oops."
> + | oop |
> + self compilerMarkHook.
> + objectMemory markAndTrace: objectMemory getSpecialObjectsOop. "also covers nilObj, trueObj, falseObj, and compact classes"
> + compilerInitialized
> + ifTrue: [objectMemory markAndTrace: receiver.
> + objectMemory markAndTrace: method]
> + ifFalse: [objectMemory markAndTrace: activeContext].
> + objectMemory markAndTrace: messageSelector.
> + objectMemory markAndTrace: newMethod.
> + objectMemory markAndTrace: methodClass.
> + objectMemory markAndTrace: lkupClass.
> + objectMemory markAndTrace: receiverClass.
> + 1 to: objectMemory getRemapBufferCount do: [:i |
> + oop := objectMemory remapBufferAt: i.
> + (objectMemory isIntegerObject: oop) ifFalse: [objectMemory markAndTrace: oop]].
> +
> + "Callback support - trace suspended callback list"
> + 1 to: jmpDepth do:[:i|
> + oop := suspendedCallbacks at: i.
> + (objectMemory isIntegerObject: oop) ifFalse:[objectMemory markAndTrace: oop].
> + oop := suspendedMethods at: i.
> + (objectMemory isIntegerObject: oop) ifFalse:[objectMemory markAndTrace: oop].
> + ].
> - "Compatibility with NewObjectMemory"
> - ^self markAndTraceInterpreterOops
> !
>
> Item was changed:
> ----- Method: Interpreter>>newActiveContext: (in category 'contexts') -----
> newActiveContext: aContext
> "Note: internalNewActiveContext: should track changes to this method."
>
> self storeContextRegisters: activeContext.
> + (objectMemory oop: aContext isLessThan: objectMemory getYoungStart) ifTrue: [ objectMemory beRootIfOld: aContext ].
> - (objectMemory oop: aContext isLessThan: objectMemory youngStart) ifTrue: [ objectMemory beRootIfOld: aContext ].
> activeContext := aContext.
> self fetchContextRegisters: aContext.!
>
> Item was changed:
> ----- Method: Interpreter>>okayActiveProcessStack (in category 'debug support') -----
> okayActiveProcessStack
>
> | cntxt |
> cntxt := activeContext.
> + [cntxt = objectMemory getNilObj] whileFalse: [
> - [cntxt = objectMemory nilObj] whileFalse: [
> self okayFields: cntxt.
> cntxt := (objectMemory fetchPointer: SenderIndex ofObject: cntxt).
> ].!
>
> Item was changed:
> ----- Method: Interpreter>>okayInterpreterObjects (in category 'debug support') -----
> okayInterpreterObjects
>
> | oopOrZero oop |
> + self okayFields: objectMemory getNilObj.
> + self okayFields: objectMemory getFalseObj.
> + self okayFields: objectMemory getTrueObj.
> + self okayFields: objectMemory getSpecialObjectsOop.
> - self okayFields: objectMemory nilObj.
> - self okayFields: objectMemory falseObj.
> - self okayFields: objectMemory trueObj.
> - self okayFields: objectMemory specialObjectsOop.
> self okayFields: activeContext.
> self okayFields: method.
> self okayFields: receiver.
> self okayFields: theHomeContext.
> self okayFields: messageSelector.
> self okayFields: newMethod.
> self okayFields: lkupClass.
> 0 to: MethodCacheEntries - 1 by: MethodCacheEntrySize do: [ :i |
> oopOrZero := methodCache at: i + MethodCacheSelector.
> oopOrZero = 0 ifFalse: [
> self okayFields: (methodCache at: i + MethodCacheSelector).
> self okayFields: (methodCache at: i + MethodCacheClass).
> self okayFields: (methodCache at: i + MethodCacheMethod).
> ].
> ].
> + 1 to: objectMemory getRemapBufferCount do: [ :i |
> + oop := objectMemory remapBufferAt: i.
> - 1 to: objectMemory remapBufferCount do: [ :i |
> - oop := objectMemory remapBuffer at: i.
> (objectMemory isIntegerObject: oop) ifFalse: [
> self okayFields: oop.
> ].
> ].
> self okayActiveProcessStack.!
>
> Item was changed:
> ----- Method: Interpreter>>pop:thenPushBool: (in category 'contexts') -----
> pop: nItems thenPushBool: trueOrFalse
> "A few places pop a few items off the stack and then push a boolean. Make it convenient"
> | sp |
> objectMemory longAt: (sp := stackPointer - ((nItems - 1) * objectMemory bytesPerWord))
> + put:(trueOrFalse ifTrue: [objectMemory getTrueObj] ifFalse: [objectMemory getFalseObj]).
> - put:(trueOrFalse ifTrue: [objectMemory trueObj] ifFalse: [objectMemory falseObj]).
> stackPointer := sp!
>
> Item was changed:
> ----- Method: Interpreter>>postGCAction (in category 'object memory support') -----
> postGCAction
> "Mark the active and home contexts as roots if old. This
> allows the interpreter to use storePointerUnchecked to
> store into them."
>
> compilerInitialized
> ifTrue: [self compilerPostGC]
> + ifFalse: [(objectMemory oop: activeContext isLessThan: objectMemory getYoungStart)
> - ifFalse: [(objectMemory oop: activeContext isLessThan: objectMemory youngStart)
> ifTrue: [objectMemory beRootIfOld: activeContext].
> + (objectMemory oop: theHomeContext isLessThan: objectMemory getYoungStart)
> - (objectMemory oop: theHomeContext isLessThan: objectMemory youngStart)
> ifTrue: [objectMemory beRootIfOld: theHomeContext]].
> + (objectMemory oop: (objectMemory sizeOfFree: objectMemory getFreeBlock) isGreaterThan: objectMemory getShrinkThreshold)
> - (objectMemory oop: (objectMemory sizeOfFree: objectMemory freeBlock) isGreaterThan: objectMemory shrinkThreshold)
> ifTrue: ["Attempt to shrink memory after successfully
> reclaiming lots of memory"
> + objectMemory shrinkObjectMemory: (objectMemory sizeOfFree: objectMemory getFreeBlock) - objectMemory getGrowHeadroom].
> - objectMemory shrinkObjectMemory: (objectMemory sizeOfFree: objectMemory freeBlock) - objectMemory growHeadroom].
>
> + self signalSemaphoreWithIndex: objectMemory getGcSemaphoreIndex.
> - self signalSemaphoreWithIndex: objectMemory gcSemaphoreIndex.
> !
>
> Item was changed:
> ----- Method: Interpreter>>primitiveBlockCopy (in category 'control primitives') -----
> primitiveBlockCopy
>
> | context methodContext contextSize newContext initialIP |
> context := self stackValue: 1.
> (objectMemory isIntegerObject: (objectMemory fetchPointer: MethodIndex ofObject: context))
> ifTrue: ["context is a block; get the context of its enclosing method"
> methodContext := objectMemory fetchPointer: HomeIndex ofObject: context]
> ifFalse: [methodContext := context].
> contextSize := objectMemory sizeBitsOf: methodContext. "in bytes, including header"
> context := nil. "context is no longer needed and is not preserved across allocation"
>
> "remap methodContext in case GC happens during allocation"
> objectMemory pushRemappableOop: methodContext.
> newContext := objectMemory instantiateContext: (objectMemory splObj: ClassBlockContext) sizeInBytes: contextSize.
> methodContext := objectMemory popRemappableOop.
>
> initialIP := objectMemory integerObjectOf: (instructionPointer+1+3) - (method + objectMemory baseHeaderSize).
> "Was instructionPointer + 3, but now it's greater by 1 due to preIncrement"
>
> "Assume: have just allocated a new context; it must be young.
> Thus, can use uncheck stores. See the comment in fetchContextRegisters."
>
> objectMemory storePointerUnchecked: InitialIPIndex ofObject: newContext withValue: initialIP.
> objectMemory storePointerUnchecked: InstructionPointerIndex ofObject: newContext withValue: initialIP.
> self storeStackPointerValue: 0 inContext: newContext.
> objectMemory storePointerUnchecked: BlockArgumentCountIndex ofObject: newContext withValue: (self stackValue: 0).
> objectMemory storePointerUnchecked: HomeIndex ofObject: newContext withValue: methodContext.
> + objectMemory storePointerUnchecked: SenderIndex ofObject: newContext withValue: objectMemory getNilObj.
> - objectMemory storePointerUnchecked: SenderIndex ofObject: newContext withValue: objectMemory nilObj.
>
> self pop: 2 thenPush: newContext.!
>
> Item was changed:
> ----- Method: Interpreter>>primitiveDeferDisplayUpdates (in category 'I/O primitives') -----
> primitiveDeferDisplayUpdates
> "Set or clear the flag that controls whether modifications of
> the Display object are propagated to the underlying
> platform's screen."
> | flag |
> flag := self stackTop.
> + flag = objectMemory getTrueObj
> - flag = objectMemory trueObj
> ifTrue: [deferDisplayUpdates := true]
> + ifFalse: [flag = objectMemory getFalseObj
> - ifFalse: [flag = objectMemory falseObj
> ifTrue: [deferDisplayUpdates := false]
> ifFalse: [self primitiveFail]].
> self successful
> ifTrue: [self pop: 1]!
>
> Item was changed:
> ----- Method: Interpreter>>primitiveDoPrimitiveWithArgs (in category 'control primitives') -----
> primitiveDoPrimitiveWithArgs
> | argumentArray arraySize index cntxSize primIdx |
> argumentArray := self stackTop.
> arraySize := objectMemory fetchWordLengthOf: argumentArray.
> cntxSize := objectMemory fetchWordLengthOf: activeContext.
> self success: self stackPointerIndex + arraySize < cntxSize.
> (objectMemory isArray: argumentArray) ifFalse: [^ self primitiveFail].
>
> primIdx := self stackIntegerValue: 1.
> self successful ifFalse: [^ self primitiveFail]. "invalid args"
>
> "Pop primIndex and argArray, then push args in place..."
> self pop: 2.
> primitiveIndex := primIdx.
> argumentCount := arraySize.
> index := 1.
> [index <= argumentCount]
> whileTrue: [self push: (objectMemory fetchPointer: index - 1 ofObject: argumentArray).
> index := index + 1].
>
> "Run the primitive (sets primFailCode)"
> objectMemory pushRemappableOop: argumentArray. "prim might alloc/gc"
> + lkupClass := objectMemory getNilObj.
> - lkupClass := objectMemory nilObj.
> self primitiveResponse.
> argumentArray := objectMemory popRemappableOop.
> self successful
> ifFalse: ["If primitive failed, then restore state for failure code"
> self pop: arraySize.
> self pushInteger: primIdx.
> self push: argumentArray.
> argumentCount := 2]!
>
> Item was changed:
> ----- Method: Interpreter>>primitiveExternalCall (in category 'plugin primitives') -----
> primitiveExternalCall
> "Call an external primitive. The external primitive methods
> contain as first literal an array consisting of:
> * The module name (String | Symbol)
> * The function name (String | Symbol)
> * The session ID (SmallInteger) [OBSOLETE]
> * The function index (Integer) in the externalPrimitiveTable
> For fast failures the primitive index of any method where the
> external prim is not found is rewritten in the method cache
> with zero. This allows for ultra fast responses as long as the
> method stays in the cache.
> The fast failure response relies on lkupClass being properly
> set. This is done in
> #addToMethodCacheSel:class:method:primIndex: to
> compensate for execution of methods that are looked up in a
> superclass (such as in primitivePerformAt).
> With the latest modifications (e.g., actually flushing the
> function addresses from the VM), the session ID is obsolete.
> But for backward compatibility it is still kept around. Also, a
> failed lookup is reported specially. If a method has been
> looked up and not been found, the function address is stored
> as -1 (e.g., the SmallInteger -1 to distinguish from
> 16rFFFFFFFF which may be returned from the lookup).
> It is absolutely okay to remove the rewrite if we run into any
> problems later on. It has an approximate speed difference of
> 30% per failed primitive call which may be noticable but if,
> for any reasons, we run into problems (like with J3) we can
> always remove the rewrite.
> "
> | lit extFnAddr moduleName functionName moduleLength functionLength index |
> <var: #extFnAddr declareC: 'void (*extFnAddr)(void)'>
>
> "Fetch the first literal of the method"
> self success: (self literalCountOf: newMethod) > 0. "@@: Could this be omitted for speed?!!"
> self successful ifFalse: [^ nil].
>
> lit := self literal: 0 ofMethod: newMethod.
> "Check if it's an array of length 4"
> self success: ((objectMemory isArray: lit) and: [(objectMemory lengthOf: lit) = 4]).
> self successful ifFalse: [^ nil].
>
> "Look at the function index in case it has been loaded before"
> index := objectMemory fetchPointer: 3 ofObject: lit.
> index := self checkedIntegerValueOf: index.
> self successful ifFalse: [^ nil].
> "Check if we have already looked up the function and failed."
> index < 0
> ifTrue: ["Function address was not found in this session,
> Rewrite the mcache entry with a zero primitive index."
> self
> rewriteMethodCacheSel: messageSelector
> class: lkupClass
> primIndex: 0.
> ^ self success: false].
>
> "Try to call the function directly"
> (index > 0 and: [index <= MaxExternalPrimitiveTableSize])
> ifTrue: [extFnAddr := externalPrimitiveTable at: index - 1.
> extFnAddr ~= 0
> ifTrue: [self rewriteMethodCacheSel: messageSelector class: lkupClass primIndex: (1000 + index) primFunction: extFnAddr.
> self callExternalPrimitive: extFnAddr.
> ^ nil].
> "if we get here, then an index to the external prim was
> kept on the ST side although the underlying prim
> table was already flushed"
> ^ self primitiveFail].
>
> "Clean up session id and external primitive index"
> objectMemory storePointerUnchecked: 2 ofObject: lit withValue: ConstZero.
> objectMemory storePointerUnchecked: 3 ofObject: lit withValue: ConstZero.
>
> "The function has not been loaded yet. Fetch module and function name."
> moduleName := objectMemory fetchPointer: 0 ofObject: lit.
> + moduleName = objectMemory getNilObj
> - moduleName = objectMemory nilObj
> ifTrue: [moduleLength := 0]
> ifFalse: [self success: (objectMemory isBytes: moduleName).
> moduleLength := objectMemory lengthOf: moduleName.
> self cCode: '' inSmalltalk:
> [ (#('FloatArrayPlugin' 'Matrix2x3Plugin') includes: (self stringOf: moduleName))
> ifTrue: [moduleLength := 0 "Cause all of these to fail"]]].
> functionName := objectMemory fetchPointer: 1 ofObject: lit.
> self success: (objectMemory isBytes: functionName).
> functionLength := objectMemory lengthOf: functionName.
> self successful ifFalse: [^ nil].
>
> extFnAddr := self cCoerce: (self ioLoadExternalFunction: functionName + objectMemory baseHeaderSize
> OfLength: functionLength
> FromModule: moduleName + objectMemory baseHeaderSize
> OfLength: moduleLength) to: 'void (*)(void)'.
> extFnAddr = 0
> ifTrue: [index := -1]
> ifFalse: ["add the function to the external primitive table"
> index := self addToExternalPrimitiveTable: extFnAddr].
> self success: index >= 0.
> "Store the index (or -1 if failure) back in the literal"
> objectMemory storePointerUnchecked: 3 ofObject: lit withValue: (objectMemory integerObjectOf: index).
>
> "If the function has been successfully loaded process it"
> (self successful and: [extFnAddr ~= 0])
> ifTrue: [self rewriteMethodCacheSel: messageSelector class: lkupClass primIndex: (1000 + index) primFunction: extFnAddr.
> self callExternalPrimitive: extFnAddr]
> ifFalse: ["Otherwise rewrite the primitive index"
> self
> rewriteMethodCacheSel: messageSelector
> class: lkupClass
> primIndex: 0]!
>
> Item was changed:
> ----- Method: Interpreter>>primitivePerformInSuperclass (in category 'control primitives') -----
> primitivePerformInSuperclass
> | lookupClass rcvr currentClass |
> lookupClass := self stackTop.
> rcvr := self stackValue: 3.
> currentClass := objectMemory fetchClassOf: rcvr.
> [currentClass ~= lookupClass]
> whileTrue:
> [currentClass := self superclassOf: currentClass.
> + currentClass = objectMemory getNilObj ifTrue: [^self primitiveFailFor: PrimErrBadArgument]].
> - currentClass = objectMemory nilObj ifTrue: [^self primitiveFailFor: PrimErrBadArgument]].
>
> argumentCount = 3
> ifTrue: ["normal primitive call with 3 arguments expected on the stack"
> self popStack.
> self primitivePerformAt: lookupClass.
> self successful ifFalse:
> [self push: lookupClass]]
> ifFalse: [argumentCount = 4
> ifTrue: ["mirror primitive call with extra argument specifying object to serve as receiver"
> | s1 s2 s3 s4 s5 |
> "save stack contents"
> s1 := self popStack. "lookupClass"
> s2 := self popStack. "args"
> s3 := self popStack. "selector"
> s4 := self popStack. "mirror receiver"
> s5 := self popStack. "actual receiver"
> "slide stack up one, omitting the actual receiver parameter"
> self push: s4. "mirror receiver"
> self push: s3. "selector"
> self push: s2. "args"
> "perform as if mirror receiver had been the actual receiver"
> self primitivePerformAt: lookupClass.
> self successful ifFalse:
> ["restore original stack"
> self pop: 3. "args, selector, mirror receiver"
> self push: s5. "actual receiver"
> self push: s4. "mirror receiver"
> self push: s3. "selector"
> self push: s2. "args"
> self push: s1. "lookup class" ]]
> ifFalse: ["wrong number of arguments"
> ^self primitiveFailFor: PrimErrBadNumArgs]]
> !
>
> Item was changed:
> ----- Method: Interpreter>>primitivePushFalse (in category 'quick primitives') -----
> primitivePushFalse
> self popStack.
> + self push: objectMemory getFalseObj!
> - self push: objectMemory falseObj!
>
> Item was changed:
> ----- Method: Interpreter>>primitivePushNil (in category 'quick primitives') -----
> primitivePushNil
> self popStack.
> + self push: objectMemory getNilObj!
> - self push: objectMemory nilObj!
>
> Item was changed:
> ----- Method: Interpreter>>primitivePushTrue (in category 'quick primitives') -----
> primitivePushTrue
> self popStack.
> + self push: objectMemory getTrueObj!
> - self push: objectMemory trueObj!
>
> Item was changed:
> ----- Method: Interpreter>>primitiveSetGCSemaphore (in category 'memory space primitives') -----
> primitiveSetGCSemaphore
> "Primitive. Indicate the semaphore to be signalled for upon garbage collection"
> | index |
> <export: true>
> index := self stackIntegerValue: 0.
> self successful ifTrue:[
> + objectMemory setGcSemaphoreIndex: index.
> - objectMemory gcSemaphoreIndex: index.
> self pop: argumentCount.
> ].!
>
> Item was changed:
> ----- Method: Interpreter>>primitiveSignalAtMilliseconds (in category 'system control primitives') -----
> primitiveSignalAtMilliseconds
> "Cause the time semaphore, if one has been registered, to
> be signalled when the millisecond clock is greater than or
> equal to the given tick value. A tick value of zero turns off
> timer interrupts."
> | tick sema |
> tick := self popInteger.
> sema := self popStack.
> self successful
> ifTrue: [(objectMemory fetchClassOf: sema) = (objectMemory splObj: ClassSemaphore)
> ifTrue: [objectMemory
> storePointer: TheTimerSemaphore
> + ofObject: objectMemory getSpecialObjectsOop
> - ofObject: objectMemory specialObjectsOop
> withValue: sema.
> nextWakeupTick := tick]
> ifFalse: [objectMemory
> storePointer: TheTimerSemaphore
> + ofObject: objectMemory getSpecialObjectsOop
> + withValue: objectMemory getNilObj.
> - ofObject: objectMemory specialObjectsOop
> - withValue: objectMemory nilObj.
> nextWakeupTick := 0]]
> ifFalse: [self unPop: 2]!
>
> Item was changed:
> ----- Method: Interpreter>>primitiveStoreStackp (in category 'object access primitives') -----
> primitiveStoreStackp
> "Atomic store into context stackPointer.
> Also ensures that any newly accessible cells are initialized to nil "
> | ctxt newStackp stackp |
> ctxt := self stackValue: 1.
> newStackp := self stackIntegerValue: 0.
> self success: (objectMemory oop: newStackp isGreaterThanOrEqualTo: 0).
> self success: (objectMemory oop: newStackp isLessThanOrEqualTo: (objectMemory largeContextSize - objectMemory baseHeaderSize // objectMemory bytesPerWord - CtxtTempFrameStart)).
> self successful ifFalse: [^ self primitiveFail].
> stackp := self fetchStackPointerOf: ctxt.
> (objectMemory oop: newStackp isGreaterThan: stackp) ifTrue: ["Nil any newly accessible cells"
> + stackp + 1 to: newStackp do: [:i | objectMemory storePointer: i + CtxtTempFrameStart - 1 ofObject: ctxt withValue: objectMemory getNilObj]].
> - stackp + 1 to: newStackp do: [:i | objectMemory storePointer: i + CtxtTempFrameStart - 1 ofObject: ctxt withValue: objectMemory nilObj]].
> self storeStackPointerValue: newStackp inContext: ctxt.
> self pop: 1!
>
> Item was changed:
> ----- Method: Interpreter>>primitiveTerminateTo (in category 'process primitives') -----
> primitiveTerminateTo
> "Primitive. Terminate up the context stack from the receiver up to but not including the argument, if previousContext is on my Context stack. Make previousContext my sender. This prim has to shadow the code in ContextPart>terminateTo: to be correct"
> | thisCntx currentCntx aContext nextCntx nilOop |
> aContext := self popStack.
> thisCntx := self popStack.
>
> "make sure that aContext is in my chain"
> (self context: thisCntx hasSender: aContext) ifTrue:[
> + nilOop := objectMemory getNilObj.
> - nilOop := objectMemory nilObj.
> currentCntx := objectMemory fetchPointer: SenderIndex ofObject: thisCntx.
> [currentCntx = aContext] whileFalse: [
> nextCntx := objectMemory fetchPointer: SenderIndex ofObject: currentCntx.
> objectMemory storePointer: SenderIndex ofObject: currentCntx withValue: nilOop.
> objectMemory storePointer: InstructionPointerIndex ofObject: currentCntx withValue: nilOop.
> currentCntx := nextCntx]].
>
> objectMemory storePointer: SenderIndex ofObject: thisCntx withValue: aContext.
> ^self push: thisCntx!
>
> Item was changed:
> ----- Method: Interpreter>>primitiveVMParameter (in category 'system control primitives') -----
> (excessive size, no diff calculated)
>
> Item was changed:
> ----- Method: Interpreter>>primitiveValue (in category 'control primitives') -----
> primitiveValue
> | blockContext blockArgumentCount initialIP |
> blockContext := self stackValue: argumentCount.
> blockArgumentCount := self argumentCountOfBlock: blockContext.
> self success: (argumentCount = blockArgumentCount
> + and: [(objectMemory fetchPointer: CallerIndex ofObject: blockContext) = objectMemory getNilObj]).
> - and: [(objectMemory fetchPointer: CallerIndex ofObject: blockContext) = objectMemory nilObj]).
> self successful
> ifTrue: [self transfer: argumentCount
> fromIndex: self stackPointerIndex - argumentCount + 1
> ofObject: activeContext
> toIndex: TempFrameStart
> ofObject: blockContext.
>
> "Assume: The call to transfer:... makes blockContext a root if necessary,
> allowing use to use unchecked stored in the following code."
> self pop: argumentCount + 1.
> initialIP := objectMemory fetchPointer: InitialIPIndex ofObject: blockContext.
> objectMemory storePointerUnchecked: InstructionPointerIndex ofObject: blockContext withValue: initialIP.
> self storeStackPointerValue: argumentCount inContext: blockContext.
> objectMemory storePointerUnchecked: CallerIndex ofObject: blockContext withValue: activeContext.
> self newActiveContext: blockContext]!
>
> Item was changed:
> ----- Method: Interpreter>>primitiveValueWithArgs (in category 'control primitives') -----
> primitiveValueWithArgs
> | argumentArray blockContext blockArgumentCount arrayArgumentCount initialIP |
> argumentArray := self popStack.
> blockContext := self popStack.
> blockArgumentCount := self argumentCountOfBlock: blockContext.
> "If the argArray isnt actually an Array we ahve to unpop the above two"
> (objectMemory isArray: argumentArray) ifFalse: [self unPop:2. ^self primitiveFail].
>
> self successful ifTrue: [arrayArgumentCount := objectMemory fetchWordLengthOf: argumentArray.
> self success: (arrayArgumentCount = blockArgumentCount
> + and: [(objectMemory fetchPointer: CallerIndex ofObject: blockContext) = objectMemory getNilObj])].
> - and: [(objectMemory fetchPointer: CallerIndex ofObject: blockContext) = objectMemory nilObj])].
> self successful
> ifTrue: [self
> transfer: arrayArgumentCount
> fromIndex: 0
> ofObject: argumentArray
> toIndex: TempFrameStart
> ofObject: blockContext.
> "Assume: The call to transfer:... makes blockContext a root if necessary,
> allowing use to use unchecked stored in the following code. "
> initialIP := objectMemory fetchPointer: InitialIPIndex ofObject: blockContext.
> objectMemory
> storePointerUnchecked: InstructionPointerIndex
> ofObject: blockContext
> withValue: initialIP.
> self storeStackPointerValue: arrayArgumentCount inContext: blockContext.
> objectMemory
> storePointerUnchecked: CallerIndex
> ofObject: blockContext
> withValue: activeContext.
> self newActiveContext: blockContext]
> ifFalse: [self unPop: 2]!
>
> Item was changed:
> ----- Method: Interpreter>>printAllStacks (in category 'debug printing') -----
> printAllStacks
> "Print all the stacks of all running processes, including those that are currently suspended."
> | oop proc ctx |
> <export: true> "exported to permit access from plugins"
> proc := objectMemory fetchPointer: ActiveProcessIndex ofObject: self schedulerPointer.
> self printNameOfClass: (objectMemory fetchClassOf: proc) count: 5.
> self cr.
> self printCallStackOf: activeContext. "first the active context"
> oop := objectMemory firstObject.
> + [objectMemory oop: oop isLessThan: objectMemory getEndOfMemory] whileTrue:[
> - [objectMemory oop: oop isLessThan: objectMemory endOfMemory] whileTrue:[
> (objectMemory fetchClassOf: oop) == objectMemory classSemaphore ifTrue:[
> self cr.
> proc := objectMemory fetchPointer: FirstLinkIndex ofObject: oop.
> [proc == objectMemory nilObject] whileFalse:[
> self printNameOfClass: (objectMemory fetchClassOf: proc) count: 5.
> self cr.
> ctx := objectMemory fetchPointer: SuspendedContextIndex ofObject: proc.
> ctx == objectMemory nilObject ifFalse:[self printCallStackOf: ctx].
> proc := objectMemory fetchPointer: NextLinkIndex ofObject: proc].
> ].
> oop := objectMemory objectAfter: oop.
> ].!
>
> Item was changed:
> ----- Method: Interpreter>>printCallStackOf: (in category 'debug printing') -----
> printCallStackOf: aContext
>
> | ctxt home methClass methodSel message |
> <inline: false>
> ctxt := aContext.
> + [ctxt = objectMemory getNilObj] whileFalse: [
> - [ctxt = objectMemory nilObj] whileFalse: [
> (objectMemory fetchClassOf: ctxt) = (objectMemory splObj: ClassBlockContext)
> ifTrue: [ home := objectMemory fetchPointer: HomeIndex ofObject: ctxt ]
> ifFalse: [ home := ctxt ].
> methClass :=
> self findClassOfMethod: (objectMemory fetchPointer: MethodIndex ofObject: home)
> forReceiver: (objectMemory fetchPointer: ReceiverIndex ofObject: home).
> methodSel :=
> self findSelectorOfMethod: (objectMemory fetchPointer: MethodIndex ofObject: home)
> forReceiver: (objectMemory fetchPointer: ReceiverIndex ofObject: home).
> self printNum: ctxt.
> self print: ' '.
> ctxt = home ifFalse: [ self print: '[] in ' ].
> self printNameOfClass: methClass count: 5.
> self print: '>'.
> + methodSel = objectMemory getNilObj
> - methodSel = objectMemory nilObj
> ifTrue: [self print: '?']
> ifFalse: [self printStringOf: methodSel].
> methodSel = (objectMemory splObj: SelectorDoesNotUnderstand) ifTrue: [
> "print arg message selector"
> message := objectMemory fetchPointer: 0 + TempFrameStart ofObject: home.
> methodSel := objectMemory fetchPointer: MessageSelectorIndex ofObject: message.
> self print: ' '.
> self printStringOf: methodSel.
> ].
> self cr.
>
> ctxt := (objectMemory fetchPointer: SenderIndex ofObject: ctxt).
> ].!
>
> Item was changed:
> ----- Method: Interpreter>>pushBool: (in category 'contexts') -----
> pushBool: trueOrFalse
>
> trueOrFalse
> + ifTrue: [ self push: objectMemory getTrueObj ]
> + ifFalse: [ self push: objectMemory getFalseObj ].!
> - ifTrue: [ self push: objectMemory trueObj ]
> - ifFalse: [ self push: objectMemory falseObj ].!
>
> Item was changed:
> ----- Method: Interpreter>>pushConstantFalseBytecode (in category 'stack bytecodes') -----
> pushConstantFalseBytecode
>
> self fetchNextBytecode.
> + self internalPush: objectMemory getFalseObj.
> - self internalPush: objectMemory falseObj.
> !
>
> Item was changed:
> ----- Method: Interpreter>>pushConstantNilBytecode (in category 'stack bytecodes') -----
> pushConstantNilBytecode
>
> self fetchNextBytecode.
> + self internalPush: objectMemory getNilObj.
> - self internalPush: objectMemory nilObj.
> !
>
> Item was changed:
> ----- Method: Interpreter>>pushConstantTrueBytecode (in category 'stack bytecodes') -----
> pushConstantTrueBytecode
>
> self fetchNextBytecode.
> + self internalPush: objectMemory getTrueObj.
> - self internalPush: objectMemory trueObj.
> !
>
> Item was changed:
> ----- Method: Interpreter>>readImageFromFile:HeapSize:StartingAt: (in category 'image save/restore') -----
> readImageFromFile: f HeapSize: desiredHeapSize StartingAt: imageOffset
> "Read an image from the given file stream, allocating the given amount of memory to its object heap. Fail if the image has an unknown format or requires more than the given amount of memory."
> "Details: This method detects when the image was stored on a machine with the opposite byte ordering from this machine and swaps the bytes automatically. Furthermore, it allows the header information to start 512 bytes into the file, since some file transfer programs for the Macintosh apparently prepend a Mac-specific header of this size. Note that this same 512 bytes of prefix area could also be used to store an exec command on Unix systems, allowing one to launch Smalltalk by invoking the image name as a command."
> "This code is based on C code by Ian Piumarta and Smalltalk code by Tim Rowledge. Many thanks to both of you!!!!"
>
> | swapBytes headerStart headerSize dataSize oldBaseAddr minimumMemory memStart bytesRead bytesToShift heapSize |
> <var: #f type: 'sqImageFile '>
> <var: #desiredHeapSize type: 'usqInt'>
> <var: #headerStart type: 'squeakFileOffsetType '>
> <var: #dataSize type: 'size_t '>
> <var: #imageOffset type: 'squeakFileOffsetType '>
>
> swapBytes := self checkImageVersionFrom: f startingAt: imageOffset.
> headerStart := (self sqImageFilePosition: f) - objectMemory bytesPerWord. "record header start position"
>
> headerSize := self getLongFromFile: f swap: swapBytes.
> dataSize := self getLongFromFile: f swap: swapBytes.
> oldBaseAddr := self getLongFromFile: f swap: swapBytes.
> + objectMemory setSpecialObjectsOop: (self getLongFromFile: f swap: swapBytes).
> + objectMemory setLastHash: (self getLongFromFile: f swap: swapBytes).
> - objectMemory specialObjectsOop: (self getLongFromFile: f swap: swapBytes).
> - objectMemory lastHash: (self getLongFromFile: f swap: swapBytes).
> savedWindowSize := self getLongFromFile: f swap: swapBytes.
> fullScreenFlag := self oldFormatFullScreenFlag: (self getLongFromFile: f swap: swapBytes).
> extraVMMemory := self getLongFromFile: f swap: swapBytes.
>
> + objectMemory getLastHash = 0 ifTrue: [
> - objectMemory lastHash = 0 ifTrue: [
> "lastHash wasn't stored (e.g. by the cloner); use 999 as the seed"
> + objectMemory setLastHash: 999].
> - objectMemory lastHash: 999].
>
> "decrease Squeak object heap to leave extra memory for the VM"
> heapSize := self cCode: 'reserveExtraCHeapBytes(desiredHeapSize, extraVMMemory)'.
>
> "compare memory requirements with availability".
> minimumMemory := dataSize + 100000. "need at least 100K of breathing room"
> heapSize < minimumMemory ifTrue: [
> self insufficientMemorySpecifiedError].
>
> "allocate a contiguous block of memory for the Squeak heap"
> (objectMemory allocateMemory: heapSize
> minimum: minimumMemory
> imageFile: f
> headerSize: headerSize) = nil ifTrue: [self insufficientMemoryAvailableError].
>
> memStart := objectMemory startOfMemory.
> + objectMemory setMemoryLimit: (memStart + heapSize) - 24. "decrease memoryLimit a tad for safety"
> + objectMemory setEndOfMemory: memStart + dataSize.
> - objectMemory memoryLimit: (memStart + heapSize) - 24. "decrease memoryLimit a tad for safety"
> - objectMemory endOfMemory: memStart + dataSize.
>
> "position file after the header"
> self sqImageFile: f Seek: headerStart + headerSize.
>
> "read in the image in bulk, then swap the bytes if necessary"
> bytesRead := self
> + sqImage: (objectMemory pointerForOop: objectMemory getMemory)
> - sqImage: (objectMemory pointerForOop: objectMemory memory)
> read: f
> size: (self cCode: 'sizeof(unsigned char)')
> length: dataSize.
> bytesRead ~= dataSize ifTrue: [self unableToReadImageError].
>
> + objectMemory headerTypeBytesAt: 0 put: objectMemory bytesPerWord * 2. "3-word header (type 0)"
> + objectMemory headerTypeBytesAt: 1 put: objectMemory bytesPerWord. "2-word header (type 1)"
> + objectMemory headerTypeBytesAt: 2 put: 0. "free chunk (type 2)"
> + objectMemory headerTypeBytesAt: 3 put: 0. "1-word header (type 3)"
> - objectMemory headerTypeBytes at: 0 put: objectMemory bytesPerWord * 2. "3-word header (type 0)"
> - objectMemory headerTypeBytes at: 1 put: objectMemory bytesPerWord. "2-word header (type 1)"
> - objectMemory headerTypeBytes at: 2 put: 0. "free chunk (type 2)"
> - objectMemory headerTypeBytes at: 3 put: 0. "1-word header (type 3)"
>
> swapBytes ifTrue: [self reverseBytesInImage].
>
> "compute difference between old and new memory base addresses"
> bytesToShift := memStart - oldBaseAddr.
> self initializeInterpreter: bytesToShift. "adjusts all oops to new location"
> self isBigEnder. "work out the machine endianness and cache the answer"
>
> + (self initialImageFormatVersion bitAnd: 1) = 1
> - (self imageFormatInitialVersion bitAnd: 1) = 1
> ifTrue: ["Low order bit set, indicating that the image was saved from
> a StackInterpreter (Cog) VM. Storage of all Float objects must be
> returned to older object memory format."
> self normalizeFloatOrderingInImage].
>
> ^ dataSize
> !
>
> Item was changed:
> ----- Method: Interpreter>>removeFirstLinkOfList: (in category 'process primitive support') -----
> removeFirstLinkOfList: aList
> "Remove the first process from the given linked list."
> | first last next |
> first := objectMemory fetchPointer: FirstLinkIndex ofObject: aList.
> last := objectMemory fetchPointer: LastLinkIndex ofObject: aList.
> first = last
> + ifTrue: [objectMemory storePointer: FirstLinkIndex ofObject: aList withValue: objectMemory getNilObj.
> + objectMemory storePointer: LastLinkIndex ofObject: aList withValue: objectMemory getNilObj]
> - ifTrue: [objectMemory storePointer: FirstLinkIndex ofObject: aList withValue: objectMemory nilObj.
> - objectMemory storePointer: LastLinkIndex ofObject: aList withValue: objectMemory nilObj]
> ifFalse: [next := objectMemory fetchPointer: NextLinkIndex ofObject: first.
> objectMemory storePointer: FirstLinkIndex ofObject: aList withValue: next].
> + objectMemory storePointer: NextLinkIndex ofObject: first withValue: objectMemory getNilObj.
> - objectMemory storePointer: NextLinkIndex ofObject: first withValue: objectMemory nilObj.
> ^ first!
>
> Item was changed:
> ----- Method: Interpreter>>returnFalse (in category 'return bytecodes') -----
> returnFalse
> localReturnContext := self sender.
> + localReturnValue := objectMemory getFalseObj.
> - localReturnValue := objectMemory falseObj.
> self commonReturn.
> !
>
> Item was changed:
> ----- Method: Interpreter>>returnNil (in category 'return bytecodes') -----
> returnNil
> localReturnContext := self sender.
> + localReturnValue := objectMemory getNilObj.
> - localReturnValue := objectMemory nilObj.
> self commonReturn.!
>
> Item was changed:
> ----- Method: Interpreter>>returnTrue (in category 'return bytecodes') -----
> returnTrue
> localReturnContext := self sender.
> + localReturnValue := objectMemory getTrueObj.
> - localReturnValue := objectMemory trueObj.
> self commonReturn.!
>
> Item was changed:
> ----- Method: Interpreter>>reverseBytesInImage (in category 'image save/restore') -----
> reverseBytesInImage
> "Byte-swap all words in memory after reading in the entire image file with bulk read. Contributed by Tim Rowledge."
>
> "First, byte-swap every word in the image. This fixes objects headers."
> + objectMemory reverseBytesFrom: objectMemory startOfMemory to: objectMemory getEndOfMemory.
> - objectMemory reverseBytesFrom: objectMemory startOfMemory to: objectMemory endOfMemory.
>
> "Second, return the bytes of bytes-type objects to their orginal order."
> self byteSwapByteObjects.!
>
> Item was changed:
> ----- Method: Interpreter>>saveProcessSignalingLowSpace (in category 'process primitive support') -----
> saveProcessSignalingLowSpace
> "The low space semaphore is about to be signaled. Save the currently active
> process in the special objects array so that the low space handler will be able
> to determine the process that first triggered a low space condition. The low
> space handler (in the image) is expected to nil out the special objects array
> slot when it handles the low space condition."
>
> | lastSavedProcess sched currentProc |
> lastSavedProcess := objectMemory splObj: ProcessSignalingLowSpace.
> (lastSavedProcess == objectMemory nilObject) ifTrue:
> [sched := self schedulerPointer.
> currentProc := objectMemory fetchPointer: ActiveProcessIndex ofObject: sched.
> + objectMemory storePointer: ProcessSignalingLowSpace ofObject: objectMemory getSpecialObjectsOop withValue: currentProc]!
> - objectMemory storePointer: ProcessSignalingLowSpace ofObject: objectMemory specialObjectsOop withValue: currentProc]!
>
> Item was changed:
> ----- Method: Interpreter>>sender (in category 'contexts') -----
> sender
>
> | context closureOrNil |
> context := localHomeContext.
> + [(closureOrNil := objectMemory fetchPointer: ClosureIndex ofObject: context) ~~ objectMemory getNilObj] whileTrue:
> - [(closureOrNil := objectMemory fetchPointer: ClosureIndex ofObject: context) ~~ objectMemory nilObj] whileTrue:
> [context := objectMemory fetchPointer: ClosureOuterContextIndex ofObject: closureOrNil].
> ^objectMemory fetchPointer: SenderIndex ofObject: context!
>
> Item was changed:
> ----- Method: Interpreter>>snapshot: (in category 'image save/restore') -----
> snapshot: embedded
> "update state of active context"
> | activeProc dataSize rcvr setMacType |
> <var: #setMacType type: 'void *'>
> compilerInitialized
> ifTrue: [self compilerPreSnapshot]
> ifFalse: [self storeContextRegisters: activeContext].
>
> "update state of active process"
> activeProc := objectMemory fetchPointer: ActiveProcessIndex ofObject: self schedulerPointer.
> objectMemory
> storePointer: SuspendedContextIndex
> ofObject: activeProc
> withValue: activeContext.
>
> "compact memory and compute the size of the memory actually in use"
> objectMemory incrementalGC.
>
> "maximimize space for forwarding table"
> objectMemory fullGC.
> self snapshotCleanUp.
>
> + dataSize := objectMemory getFreeBlock - objectMemory startOfMemory. "Assume all objects are below the start of the free block"
> - dataSize := objectMemory freeBlock - objectMemory startOfMemory. "Assume all objects are below the start of the free block"
> self successful
> ifTrue: [rcvr := self popStack.
> "pop rcvr"
> + self push: objectMemory getTrueObj.
> - self push: objectMemory trueObj.
> self writeImageFile: dataSize.
> embedded
> ifFalse: ["set Mac file type and creator; this is a noop on other platforms"
> setMacType := self ioLoadFunction: 'setMacFileTypeAndCreator' From: 'FilePlugin'.
> setMacType = 0
> ifFalse: [self cCode: '((sqInt (*)(char *, char *, char *))setMacType)(imageName, "STim", "FAST")']].
> self pop: 1].
>
> "activeContext was unmarked in #snapshotCleanUp, mark it old "
> objectMemory beRootIfOld: activeContext.
> self successful
> + ifTrue: [self push: objectMemory getFalseObj]
> - ifTrue: [self push: objectMemory falseObj]
> ifFalse: [self push: rcvr].
> compilerInitialized
> ifTrue: [self compilerPostSnapshot]!
>
> Item was changed:
> ----- Method: Interpreter>>snapshotCleanUp (in category 'image save/restore') -----
> snapshotCleanUp
> "Clean up right before saving an image, sweeping memory and:
> * nilling out all fields of contexts above the stack pointer.
> * flushing external primitives
> * clearing the root bit of any object in the root table "
> | oop header fmt sz |
> oop := objectMemory firstObject.
> + [objectMemory oop: oop isLessThan: objectMemory getEndOfMemory]
> - [objectMemory oop: oop isLessThan: objectMemory endOfMemory]
> whileTrue: [(objectMemory isFreeObject: oop)
> ifFalse: [header := objectMemory longAt: oop.
> fmt := header >> 8 bitAnd: 15.
> "Clean out context"
> (fmt = 3 and: [self isContextHeader: header])
> ifTrue: [sz := objectMemory sizeBitsOf: oop.
> (objectMemory lastPointerOf: oop) + objectMemory bytesPerWord
> to: sz - objectMemory baseHeaderSize by: objectMemory bytesPerWord
> + do: [:i | objectMemory longAt: oop + i put: objectMemory getNilObj]].
> - do: [:i | objectMemory longAt: oop + i put: objectMemory nilObj]].
> "Clean out external functions"
> fmt >= 12
> ifTrue: ["This is a compiled method"
> (self primitiveIndexOf: oop) = PrimitiveExternalCallIndex
> ifTrue: ["It's primitiveExternalCall"
> self flushExternalPrimitiveOf: oop]]].
> oop := objectMemory objectAfter: oop].
> objectMemory clearRootsTable!
>
> Item was changed:
> ----- Method: Interpreter>>storeAndPopReceiverVariableBytecode (in category 'stack bytecodes') -----
> storeAndPopReceiverVariableBytecode
> "Note: This code uses
> storePointerUnchecked:ofObject:withValue: and does the
> store check explicitely in order to help the translator
> produce better code."
> | rcvr top |
> self flag: #'requires currentBytecode to be expanded to a constant'.
> self fetchNextBytecode.
> "this bytecode will be expanded so that refs to currentBytecode below will be constant"
> rcvr := receiver.
> top := self internalStackTop.
> + (objectMemory oop: rcvr isLessThan: objectMemory getYoungStart)
> - (objectMemory oop: rcvr isLessThan: objectMemory youngStart)
> ifTrue: [objectMemory possibleRootStoreInto: rcvr value: top].
> objectMemory storePointerUnchecked: (currentBytecode bitAnd: 7) ofObject: rcvr withValue: top.
> self internalPop: 1!
>
> Item was changed:
> ----- Method: Interpreter>>transferTo: (in category 'process primitive support') -----
> transferTo: aProc
> "Record a process to be awoken on the next interpreter cycle.
> ikp 11/24/1999 06:07 -- added hook for external runtime
> compiler "
> | sched oldProc newProc |
> newProc := aProc.
> sched := self schedulerPointer.
> oldProc := objectMemory fetchPointer: ActiveProcessIndex ofObject: sched.
> objectMemory storePointer: ActiveProcessIndex ofObject: sched withValue: newProc.
> compilerInitialized
> ifTrue: [self compilerProcessChange: oldProc to: newProc]
> ifFalse: [objectMemory storePointer: SuspendedContextIndex ofObject: oldProc withValue: activeContext.
> self newActiveContext: (objectMemory fetchPointer: SuspendedContextIndex ofObject: newProc).
> + objectMemory storePointer: SuspendedContextIndex ofObject: newProc withValue: objectMemory getNilObj].
> - objectMemory storePointer: SuspendedContextIndex ofObject: newProc withValue: objectMemory nilObj].
> reclaimableContextCount := 0!
>
> Item was changed:
> ----- Method: Interpreter>>writeImageFileIO: (in category 'image save/restore') -----
> writeImageFileIO: imageBytes
>
> | headerStart headerSize f bytesWritten sCWIfn okToWrite |
> <var: #f type: 'sqImageFile'>
> <var: #headerStart type: 'squeakFileOffsetType '>
> <var: #sCWIfn type: 'void *'>
>
> "If the security plugin can be loaded, use it to check for write permission.
> If not, assume it's ok"
> sCWIfn := self ioLoadFunction: 'secCanWriteImage' From: 'SecurityPlugin'.
> sCWIfn ~= 0 ifTrue:[okToWrite := self cCode: '((sqInt (*)(void))sCWIfn)()'.
> okToWrite ifFalse:[^self primitiveFail]].
>
> "local constants"
> headerStart := 0.
> headerSize := 16 * objectMemory bytesPerWord. "header size in bytes; do not change!!"
>
> f := self cCode: 'sqImageFileOpen(imageName, "wb")'.
> f = nil ifTrue: [
> "could not open the image file for writing"
> self success: false.
> ^ nil].
>
> headerStart := self cCode: 'sqImageFileStartLocation(f,imageName,headerSize+imageBytes)'.
> self cCode: '/* Note: on Unix systems one could put an exec command here, padded to 512 bytes */'.
> "position file to start of header"
> self sqImageFile: f Seek: headerStart.
>
> self putLong: (self imageFormatVersion) toFile: f.
> self putLong: headerSize toFile: f.
> self putLong: imageBytes toFile: f.
> self putLong: (objectMemory startOfMemory) toFile: f.
> + self putLong: objectMemory getSpecialObjectsOop toFile: f.
> + self putLong: objectMemory getLastHash toFile: f.
> - self putLong: objectMemory specialObjectsOop toFile: f.
> - self putLong: objectMemory lastHash toFile: f.
> self putLong: (self ioScreenSize) toFile: f.
> self putLong: fullScreenFlag toFile: f.
> self putLong: extraVMMemory toFile: f.
> 1 to: 7 do: [:i | self putLong: 0 toFile: f]. "fill remaining header words with zeros"
> self successful ifFalse: [
> "file write or seek failure"
> self cCode: 'sqImageFileClose(f)'.
> ^ nil].
>
> "position file after the header"
> self sqImageFile: f Seek: headerStart + headerSize.
>
> "write the image data"
> bytesWritten := self
> + sqImage: (objectMemory pointerForOop: objectMemory getMemory)
> - sqImage: (objectMemory pointerForOop: objectMemory memory)
> write: f
> size: (self cCode: 'sizeof(unsigned char)')
> length: imageBytes.
> self success: bytesWritten = imageBytes.
> self cCode: 'sqImageFileClose(f)'.
>
> !
>
> Item was changed:
> ----- Method: InterpreterPrimitives>>primitiveBeDisplay (in category 'I/O primitives') -----
> primitiveBeDisplay
> "Record the system Display object in the specialObjectsTable."
> | rcvr |
> rcvr := self stackTop.
> self success: ((objectMemory isPointers: rcvr) and: [(objectMemory lengthOf: rcvr) >= 4]).
> + self successful ifTrue: [objectMemory storePointer: TheDisplay ofObject: objectMemory getSpecialObjectsOop withValue: rcvr]!
> - self successful ifTrue: [objectMemory storePointer: TheDisplay ofObject: objectMemory specialObjectsOop withValue: rcvr]!
>
> Item was changed:
> ----- Method: InterpreterPrimitives>>primitiveBytesLeft (in category 'memory space primitives') -----
> primitiveBytesLeft
> "Reports bytes available at this moment. For more meaningful
> results, calls to this primitive should be preceeded by a full
> or incremental garbage collection."
> | aBool |
> self methodArgumentCount = 0
> ifTrue: ["old behavior - just return the size of the free block"
> + ^self pop: 1 thenPush: (self positive64BitIntegerFor: (objectMemory sizeOfFree: objectMemory getFreeBlock))].
> - ^self pop: 1 thenPush: (self positive64BitIntegerFor: (objectMemory sizeOfFree: objectMemory freeBlock))].
> self methodArgumentCount = 1
> ifTrue: ["new behaviour -including or excluding swap space depending on aBool"
> aBool := self booleanValueOf: self stackTop.
> self successful ifFalse: [^ nil].
> ^self pop: 2 thenPush: (self positive64BitIntegerFor: (objectMemory bytesLeft: aBool))].
> ^ self primitiveFail!
>
> Item was changed:
> ----- Method: InterpreterPrimitives>>primitiveFailAfterCleanup: (in category 'image segment in/out') -----
> primitiveFailAfterCleanup: outPointerArray
> "If the storeSegment primitive fails, it must clean up first."
>
> | i lastAddr | "Store nils throughout the outPointer array."
> lastAddr := outPointerArray + (objectMemory lastPointerOf: outPointerArray).
> i := outPointerArray + objectMemory baseHeaderSize.
> [i <= lastAddr] whileTrue:
> + [objectMemory longAt: i put: objectMemory getNilObj.
> - [objectMemory longAt: i put: objectMemory nilObj.
> i := i + objectMemory bytesPerWord].
>
> DoAssertionChecks ifTrue: [objectMemory verifyCleanHeaders].
> self primitiveFail!
>
> Item was changed:
> ----- Method: InterpreterPrimitives>>primitiveFindHandlerContext (in category 'control primitives') -----
> primitiveFindHandlerContext
> "Primitive. Search up the context stack for the next method context marked for exception handling starting at the receiver. Return nil if none found"
> | thisCntx nilOop |
> thisCntx := self popStack.
> + nilOop := objectMemory getNilObj.
> - nilOop := objectMemory nilObj.
>
> [(self isHandlerMarked: thisCntx) ifTrue:[
> self push: thisCntx.
> ^nil].
> thisCntx := objectMemory fetchPointer: SenderIndex ofObject: thisCntx.
> thisCntx = nilOop] whileFalse.
>
> + ^self push: objectMemory getNilObj!
> - ^self push: objectMemory nilObj!
>
> Item was changed:
> ----- Method: InterpreterPrimitives>>primitiveFindNextUnwindContext (in category 'control primitives') -----
> primitiveFindNextUnwindContext
> "Primitive. Search up the context stack for the next method context marked for unwind handling from the receiver up to but not including the argument. Return nil if none found."
> | thisCntx nilOop aContext unwindMarked |
> aContext := self popStack.
> thisCntx := objectMemory fetchPointer: SenderIndex ofObject: self popStack.
> + nilOop := objectMemory getNilObj.
> - nilOop := objectMemory nilObj.
>
> [(thisCntx = aContext) or: [thisCntx = nilOop]] whileFalse: [
> unwindMarked := self isUnwindMarked: thisCntx.
> unwindMarked ifTrue:[
> self push: thisCntx.
> ^nil].
> thisCntx := objectMemory fetchPointer: SenderIndex ofObject: thisCntx].
>
> ^self push: nilOop!
>
> Item was changed:
> ----- Method: InterpreterPrimitives>>primitiveForceTenure (in category 'I/O primitives') -----
> primitiveForceTenure
> "Set force tenure flag to true, this forces a tenure operation on the next incremental GC"
>
> <export: true>
> + objectMemory setForceTenureFlag: 1!
> - objectMemory forceTenureFlag: 1!
>
> Item was changed:
> ----- Method: InterpreterPrimitives>>primitiveInterruptSemaphore (in category 'I/O primitives') -----
> primitiveInterruptSemaphore
> "Register the user interrupt semaphore. If the argument is
> not a Semaphore, unregister the current interrupt
> semaphore. "
> | arg |
> arg := self popStack.
> (objectMemory fetchClassOf: arg) = (objectMemory splObj: ClassSemaphore)
> + ifTrue: [objectMemory storePointer: TheInterruptSemaphore ofObject: objectMemory getSpecialObjectsOop withValue: arg]
> + ifFalse: [objectMemory storePointer: TheInterruptSemaphore ofObject: objectMemory getSpecialObjectsOop withValue: objectMemory getNilObj]!
> - ifTrue: [objectMemory storePointer: TheInterruptSemaphore ofObject: objectMemory specialObjectsOop withValue: arg]
> - ifFalse: [objectMemory storePointer: TheInterruptSemaphore ofObject: objectMemory specialObjectsOop withValue: objectMemory nilObj]!
>
> Item was changed:
> ----- Method: InterpreterPrimitives>>primitiveIsYoung (in category 'memory space primitives') -----
> primitiveIsYoung
> "Primitive. Answer whether the argument to the primitive resides in young space."
> | oop |
> <export: true>
> oop := self stackObjectValue: 0.
> self successful ifTrue:[
> self pop: argumentCount + 1.
> + self pushBool: (objectMemory oop: oop isGreaterThanOrEqualTo: objectMemory getYoungStart).
> - self pushBool: (objectMemory oop: oop isGreaterThanOrEqualTo: objectMemory youngStart).
> ].!
>
> Item was changed:
> ----- Method: InterpreterPrimitives>>primitiveKbdNext (in category 'I/O primitives') -----
> primitiveKbdNext
> "Obsolete on virtually all platforms; old style input polling code.
> Return the next keycode and remove it from the input buffer. The low byte is the 8-bit ISO character. The next four bits are the Smalltalk modifier bits <cmd><option><ctrl><shift>."
>
> | keystrokeWord |
> self pop: 1.
> keystrokeWord := self ioGetKeystroke.
> keystrokeWord >= 0
> ifTrue: [self pushInteger: keystrokeWord]
> + ifFalse: [self push: objectMemory getNilObj].!
> - ifFalse: [self push: objectMemory nilObj].!
>
> Item was changed:
> ----- Method: InterpreterPrimitives>>primitiveKbdPeek (in category 'I/O primitives') -----
> primitiveKbdPeek
> "Obsolete on virtually all platforms; old style input polling code.
> Return the next keycode and without removing it from the input buffer. The low byte is the 8-bit ISO character. The next four bits are the Smalltalk modifier bits <cmd><option><ctrl><shift>."
>
> | keystrokeWord |
> self pop: 1.
> keystrokeWord := self ioPeekKeystroke.
> keystrokeWord >= 0
> ifTrue: [self pushInteger: keystrokeWord]
> + ifFalse: [self push: objectMemory getNilObj].!
> - ifFalse: [self push: objectMemory nilObj].!
>
> Item was changed:
> ----- Method: InterpreterPrimitives>>primitiveLoadImageSegment (in category 'image segment in/out') -----
> primitiveLoadImageSegment
> "This primitive is called from Squeak as...
> <imageSegment> loadSegmentFrom: aWordArray outPointers: anArray."
>
> "This primitive will load a binary image segment created by primitiveStoreImageSegment. It expects the outPointer array to be of the proper size, and the wordArray to be well formed. It will return as its value the original array of roots, and the erstwhile segmentWordArray will have been truncated to a size of zero. If this primitive should fail, the segmentWordArray will, sadly, have been reduced to an unrecognizable and unusable jumble. But what more could you have done with it anyway?"
>
> | outPointerArray segmentWordArray endSeg segOop fieldPtr fieldOop doingClass lastPtr extraSize mapOop lastOut outPtr hdrTypeBits header data |
>
> <var: #endSeg type: 'usqInt'>
> <var: #segOop type: 'usqInt'>
> <var: #fieldPtr type: 'usqInt'>
> <var: #lastOut type: 'usqInt'>
> <var: #outPtr type: 'usqInt'>
> <var: #lastPtr type: 'usqInt'>
>
> DoAssertionChecks ifTrue: [objectMemory verifyCleanHeaders].
> outPointerArray := self stackTop.
> lastOut := outPointerArray + (objectMemory lastPointerOf: outPointerArray).
> segmentWordArray := self stackValue: 1.
> endSeg := segmentWordArray + (objectMemory sizeBitsOf: segmentWordArray) - objectMemory baseHeaderSize.
>
> "Essential type checks"
> ((objectMemory formatOf: outPointerArray) = 2 "Must be indexable pointers"
> and: [(objectMemory formatOf: segmentWordArray) = 6]) "Must be indexable words"
> ifFalse: [^ self primitiveFail].
>
> "Version check. Byte order of the WordArray now"
> data := objectMemory longAt: segmentWordArray + objectMemory baseHeaderSize.
> (self readableFormat: (data bitAnd: 16rFFFF "low 2 bytes")) ifFalse: [
> "Not readable -- try again with reversed bytes..."
> objectMemory reverseBytesFrom: segmentWordArray + objectMemory baseHeaderSize to: endSeg + objectMemory bytesPerWord.
> data := objectMemory longAt: segmentWordArray + objectMemory baseHeaderSize.
> (self readableFormat: (data bitAnd: 16rFFFF "low 2 bytes")) ifFalse: [
> "Still NG -- put things back and fail"
> objectMemory reverseBytesFrom: segmentWordArray + objectMemory baseHeaderSize to: endSeg + objectMemory bytesPerWord.
> DoAssertionChecks ifTrue: [objectMemory verifyCleanHeaders].
> ^ self primitiveFail]].
> "Reverse the Byte type objects if the is data from opposite endian machine."
> "Test top byte. $d on the Mac or $s on the PC. Rest of word is equal."
> (data >> 16) = (objectMemory imageSegmentVersion >> 16) ifFalse: [
> "Reverse the byte-type objects once"
> segOop := objectMemory oopFromChunk: segmentWordArray + objectMemory baseHeaderSize + objectMemory bytesPerWord.
> "Oop of first embedded object"
> self byteSwapByteObjectsFrom: segOop to: endSeg + objectMemory bytesPerWord].
>
> "Proceed through the segment, remapping pointers..."
> segOop := objectMemory oopFromChunk: segmentWordArray + objectMemory baseHeaderSize + objectMemory bytesPerWord.
> [segOop <= endSeg] whileTrue:
> [(objectMemory headerType: segOop) <= 1
> ifTrue: ["This object has a class field (type = 0 or 1) -- start with that."
> fieldPtr := segOop - objectMemory bytesPerWord. doingClass := true]
> ifFalse: ["No class field -- start with first data field"
> fieldPtr := segOop + objectMemory baseHeaderSize. doingClass := false].
> lastPtr := segOop + (objectMemory lastPointerOf: segOop). "last field"
> lastPtr > endSeg ifTrue: [
> DoAssertionChecks ifTrue: [objectMemory verifyCleanHeaders].
> ^ self primitiveFail "out of bounds"].
>
> "Go through all oops, remapping them..."
> [fieldPtr > lastPtr] whileFalse:
> ["Examine each pointer field"
> fieldOop := objectMemory longAt: fieldPtr.
> doingClass ifTrue:
> [hdrTypeBits := objectMemory headerType: fieldPtr.
> fieldOop := fieldOop - hdrTypeBits].
> (objectMemory isIntegerObject: fieldOop)
> ifTrue:
> ["Integer -- nothing to do"
> fieldPtr := fieldPtr + objectMemory bytesPerWord]
> ifFalse:
> [(fieldOop bitAnd: 3) = 0 ifFalse: [^ self primitiveFail "bad oop"].
> (fieldOop bitAnd: 16r80000000) = 0
> ifTrue: ["Internal pointer -- add segment offset"
> mapOop := fieldOop + segmentWordArray]
> ifFalse: ["External pointer -- look it up in outPointers"
> outPtr := outPointerArray + (fieldOop bitAnd: 16r7FFFFFFF).
> outPtr > lastOut ifTrue: [^ self primitiveFail "out of bounds"].
> mapOop := objectMemory longAt: outPtr].
> doingClass
> ifTrue: [objectMemory longAt: fieldPtr put: mapOop + hdrTypeBits.
> fieldPtr := fieldPtr + 8.
> doingClass := false]
> ifFalse: [objectMemory longAt: fieldPtr put: mapOop.
> fieldPtr := fieldPtr + objectMemory bytesPerWord].
> + segOop < objectMemory getYoungStart
> - segOop < objectMemory youngStart
> ifTrue: [objectMemory possibleRootStoreInto: segOop value: mapOop].
> ]].
> segOop := objectMemory objectAfter: segOop].
>
> "Again, proceed through the segment checking consistency..."
> segOop := objectMemory oopFromChunk: segmentWordArray + objectMemory baseHeaderSize + objectMemory bytesPerWord.
> [segOop <= endSeg] whileTrue:
> [(objectMemory oopHasAcceptableClass: segOop) ifFalse: [^ self primitiveFail "inconsistency"].
> fieldPtr := segOop + objectMemory baseHeaderSize. "first field"
> lastPtr := segOop + (objectMemory lastPointerOf: segOop). "last field"
> "Go through all oops, remapping them..."
> [fieldPtr > lastPtr] whileFalse:
> ["Examine each pointer field"
> fieldOop := objectMemory longAt: fieldPtr.
> (objectMemory oopHasAcceptableClass: fieldOop) ifFalse: [^ self primitiveFail "inconsistency"].
> fieldPtr := fieldPtr + objectMemory bytesPerWord].
> segOop := objectMemory objectAfter: segOop].
>
> "Truncate the segment word array to size = objectMemory bytesPerWord (vers stamp only)"
> extraSize := objectMemory extraHeaderBytes: segmentWordArray.
> hdrTypeBits := objectMemory headerType: segmentWordArray.
> extraSize = 8
> ifTrue: [objectMemory longAt: segmentWordArray-extraSize put: objectMemory baseHeaderSize + objectMemory bytesPerWord + hdrTypeBits]
> ifFalse: [header := objectMemory longAt: segmentWordArray.
> objectMemory longAt: segmentWordArray
> put: header - (header bitAnd: objectMemory sizeMask) + objectMemory baseHeaderSize + objectMemory bytesPerWord].
> "and return the roots array which was first in the segment"
> DoAssertionChecks ifTrue: [objectMemory verifyCleanHeaders].
> self pop: 3 thenPush: (objectMemory oopFromChunk: segmentWordArray + objectMemory baseHeaderSize + objectMemory bytesPerWord).
> !
>
> Item was changed:
> ----- Method: InterpreterPrimitives>>primitiveLowSpaceSemaphore (in category 'memory space primitives') -----
> primitiveLowSpaceSemaphore
> "Register the low-space semaphore. If the argument is not a
> Semaphore, unregister the current low-space Semaphore."
> | arg |
> arg := self popStack.
> (objectMemory fetchClassOf: arg) = (objectMemory splObj: ClassSemaphore)
> + ifTrue: [objectMemory storePointer: TheLowSpaceSemaphore ofObject: objectMemory getSpecialObjectsOop withValue: arg]
> + ifFalse: [objectMemory storePointer: TheLowSpaceSemaphore ofObject: objectMemory getSpecialObjectsOop withValue: objectMemory getNilObj]!
> - ifTrue: [objectMemory storePointer: TheLowSpaceSemaphore ofObject: objectMemory specialObjectsOop withValue: arg]
> - ifFalse: [objectMemory storePointer: TheLowSpaceSemaphore ofObject: objectMemory specialObjectsOop withValue: objectMemory nilObj]!
>
> Item was changed:
> ----- Method: InterpreterPrimitives>>primitiveNewMethod (in category 'compiled methods') -----
> primitiveNewMethod
> | header bytecodeCount class size theMethod literalCount |
> header := self popStack.
> bytecodeCount := self popInteger.
> self success: (objectMemory isIntegerObject: header).
> self successful ifFalse:
> [self unPop: 2. ^nil].
> class := self popStack.
> size := (self literalCountOfHeader: header) + 1 * objectMemory bytesPerWord + bytecodeCount.
> theMethod := objectMemory instantiateClass: class indexableSize: size.
> objectMemory storePointerUnchecked: HeaderIndex ofObject: theMethod withValue: header.
> literalCount := self literalCountOfHeader: header.
> 1 to: literalCount do:
> + [:i | objectMemory storePointer: i ofObject: theMethod withValue: objectMemory getNilObj].
> - [:i | objectMemory storePointer: i ofObject: theMethod withValue: objectMemory nilObj].
> self push: theMethod!
>
> Item was changed:
> ----- Method: InterpreterPrimitives>>primitiveNextInstance (in category 'object access primitives') -----
> primitiveNextInstance
> | object instance |
> object := self stackTop.
> instance := objectMemory instanceAfter: object.
> + instance = objectMemory getNilObj
> - instance = objectMemory nilObj
> ifTrue: [self primitiveFail]
> ifFalse: [self pop: argumentCount+1 thenPush: instance]!
>
> Item was changed:
> ----- Method: InterpreterPrimitives>>primitiveRootTable (in category 'memory space primitives') -----
> primitiveRootTable
> "Primitive. Answer a copy (snapshot) element of the root table.
> The primitive can cause GC itself and if so the return value may
> be inaccurate - in this case one should guard the read operation
> by looking at the gc counter statistics."
> | oop sz |
> <export: true>
> + sz := objectMemory getRootTableCount.
> - sz := objectMemory rootTableCount.
> oop := objectMemory instantiateClass: objectMemory classArray indexableSize: sz. "can cause GC"
> + sz > objectMemory getRootTableCount ifTrue:[sz := objectMemory getRootTableCount].
> - sz > objectMemory rootTableCount ifTrue:[sz := objectMemory rootTableCount].
> 1 to: sz do:[:i|
> + objectMemory storePointer: i-1 ofObject: oop withValue: (objectMemory rootTableAt: i).
> - objectMemory storePointer: i-1 ofObject: oop withValue: (objectMemory rootTable at: i).
> ].
> self pop: argumentCount + 1.
> self push: oop.!
>
> Item was changed:
> ----- Method: InterpreterPrimitives>>primitiveRootTableAt (in category 'memory space primitives') -----
> primitiveRootTableAt
> "Primitive. Answer the nth element of the root table.
> This primitive avoids the creation of an extra array;
> it is intended for enumerations of the form:
> index := 1.
> [root := Smalltalk rootTableAt: index.
> root == nil] whileFalse:[index := index + 1].
> "
> | index |
> <export: true>
> index := self stackIntegerValue: 0.
> + self success: (index > 0 and:[index <= objectMemory getRootTableCount]).
> - self success: (index > 0 and:[index <= objectMemory rootTableCount]).
> self successful ifTrue:[
> self pop: argumentCount + 1.
> + self push: (objectMemory rootTableAt: index).
> - self push: (objectMemory rootTable at: index).
> ].!
>
> Item was changed:
> ----- Method: InterpreterPrimitives>>primitiveSetFullScreen (in category 'I/O primitives') -----
> primitiveSetFullScreen
> "On platforms that support it, set full-screen mode to the value of the boolean argument."
>
> | argOop |
> argOop := self stackTop.
> + argOop = objectMemory getTrueObj
> - argOop = objectMemory trueObj
> ifTrue: [self ioSetFullScreen: true]
> + ifFalse: [ argOop = objectMemory getFalseObj
> - ifFalse: [ argOop = objectMemory falseObj
> ifTrue: [self ioSetFullScreen: false]
> ifFalse: [self primitiveFail]].
> self successful ifTrue: [self pop: 1].
> !
>
> Item was changed:
> ----- Method: InterpreterPrimitives>>primitiveSetGCBiasToGrow (in category 'memory space primitives') -----
> primitiveSetGCBiasToGrow
> "Primitive. Indicate if the GC logic should have bias to grow"
> | flag |
> <export: true>
> flag := self stackIntegerValue: 0.
> self successful ifTrue:[
> + objectMemory setGcBiasToGrow: flag.
> - objectMemory gcBiasToGrow: flag.
> self pop: argumentCount.
> ].!
>
> Item was changed:
> ----- Method: InterpreterPrimitives>>primitiveSignalAtBytesLeft (in category 'memory space primitives') -----
> primitiveSignalAtBytesLeft
> "Set the low-water mark for free space. When the free space
> falls below this level, the new and new: primitives fail and
> system attempts to allocate space (e.g., to create a method
> context) cause the low-space semaphore (if one is
> registered) to be signalled."
> | bytes |
> bytes := self popInteger.
> self successful
> + ifTrue: [objectMemory setLowSpaceThreshold: bytes]
> + ifFalse: [objectMemory setLowSpaceThreshold: 0.
> - ifTrue: [objectMemory lowSpaceThreshold: bytes]
> - ifFalse: [objectMemory lowSpaceThreshold: 0.
> self unPop: 1]!
>
> Item was changed:
> ----- Method: InterpreterPrimitives>>primitiveSomeInstance (in category 'object access primitives') -----
> primitiveSomeInstance
> | class instance |
> class := self stackTop.
> instance := objectMemory initialInstanceOf: class.
> + instance = objectMemory getNilObj
> - instance = objectMemory nilObj
> ifTrue: [self primitiveFail]
> ifFalse: [self pop: argumentCount+1 thenPush: instance]!
>
> Item was changed:
> ----- Method: InterpreterPrimitives>>primitiveSpecialObjectsOop (in category 'system control primitives') -----
> primitiveSpecialObjectsOop
> "Return the oop of the SpecialObjectsArray."
>
> + self pop: 1 thenPush: objectMemory getSpecialObjectsOop.!
> - self pop: 1 thenPush: objectMemory specialObjectsOop.!
>
> Item was changed:
> ----- Method: InterpreterPrimitives>>primitiveStoreImageSegment (in category 'image segment in/out') -----
> (excessive size, no diff calculated)
>
> Item was changed:
> ----- Method: InterpreterPrimitives>>primitiveSuspend (in category 'process primitives') -----
> primitiveSuspend
> "Primitive. Suspend the receiver, aProcess such that it can be executed again
> by sending #resume. If the given process is not currently running, take it off
> its corresponding list. The primitive returns the list the receiver was previously on."
>
> | process activeProc myList |
> process := self stackTop.
> activeProc := objectMemory fetchPointer: ActiveProcessIndex
> ofObject: self schedulerPointer.
> process == activeProc ifTrue:[
> self pop: 1.
> + self push: objectMemory getNilObj.
> - self push: objectMemory nilObj.
> self transferTo: self wakeHighestPriority.
> ] ifFalse:[
> myList := objectMemory fetchPointer: MyListIndex ofObject: process.
> "XXXX Fixme. We should really check whether myList is a kind of LinkedList or not
> but we can't easily so just do a quick check for nil which is the most common case."
> + myList == objectMemory getNilObj ifTrue:[^self primitiveFail].
> - myList == objectMemory nilObject ifTrue:[^self primitiveFail].
> self removeProcess: process fromList: myList.
> self successful ifTrue:[
> + objectMemory storePointer: MyListIndex ofObject: process withValue: objectMemory getNilObj.
> - objectMemory storePointer: MyListIndex ofObject: process withValue: objectMemory nilObject.
> self pop: 1.
> self push: myList.
> ].
> ].
> !
>
> Item was changed:
> ----- Method: InterpreterSimulator class>>on: (in category 'instance creation') -----
> on: objectMemory
> | interp |
> interp := self == InterpreterSimulator
> ifTrue: [SmalltalkImage current endianness == #big
> ifTrue: [InterpreterSimulatorMSB basicNew]
> ifFalse: [InterpreterSimulatorLSB basicNew]]
> ifFalse: [super basicNew].
> interp objectMemory: objectMemory.
> + objectMemory setInterpreter: interp.
> - objectMemory interpreter: interp.
> ^ interp initialize
> !
>
> Item was changed:
> ----- Method: InterpreterSimulator>>classAndSelectorOfMethod:forReceiver: (in category 'debug support') -----
> classAndSelectorOfMethod: meth forReceiver: rcvr
> | mClass dict length methodArray |
> mClass := objectMemory fetchClassOf: rcvr.
> [dict := objectMemory fetchPointer: MessageDictionaryIndex ofObject: mClass.
> length := objectMemory fetchWordLengthOf: dict.
> methodArray := objectMemory fetchPointer: MethodArrayIndex ofObject: dict.
> 0 to: length-SelectorStart-1 do:
> [:index |
> meth = (objectMemory fetchPointer: index ofObject: methodArray)
> ifTrue: [^ Array
> with: mClass
> with: (objectMemory fetchPointer: index + SelectorStart ofObject: dict)]].
> mClass := objectMemory fetchPointer: SuperclassIndex ofObject: mClass.
> + mClass = objectMemory getNilObj]
> - mClass = objectMemory nilObj]
> whileFalse: [].
> ^ Array
> with: (objectMemory fetchClassOf: rcvr)
> with: (objectMemory splObj: SelectorDoesNotUnderstand)!
>
> Item was changed:
> ----- Method: InterpreterSimulator>>compactClassAt: (in category 'debug support') -----
> compactClassAt: ccIndex
> "Index must be between 1 and compactClassArray size. (A zero compact class index in the base header indicate that the class is in the class header word.)"
>
> | classArray |
> + classArray := objectMemory fetchPointer: CompactClasses ofObject: objectMemory getSpecialObjectsOop.
> - classArray := objectMemory fetchPointer: CompactClasses ofObject: objectMemory specialObjectsOop.
> ^ objectMemory fetchPointer: (ccIndex - 1) ofObject: classArray!
>
> Item was changed:
> ----- Method: InterpreterSimulator>>convertToArray (in category 'initialization') -----
> convertToArray
> "I dont believe it -- this *just works*"
> "The comment above is from the original method, stamped di 5/8/2004 16:42"
>
> + objectMemory setMemory: (objectMemory getMemory as: Array)!
> - objectMemory memory: (objectMemory memory as: Array)!
>
> Item was changed:
> ----- Method: InterpreterSimulator>>initialize (in category 'initialization') -----
> initialize
>
> "Initialize the InterpreterSimulator when running the interpreter inside
> Smalltalk. The primary responsibility of this method is to allocate
> Smalltalk Arrays for variables that will be declared as statically-allocated
> global arrays in the translated code."
>
> "copy of bytesPerWord to avoid extra indirection that may affect performance"
> bytesPerWord := objectMemory bytesPerWord.
>
> "initialize class variables"
> ObjectMemory initializeConstants.
> Interpreter initialize.
>
> "Note: we must initialize ConstMinusOne differently for simulation,
> due to the fact that the simulator works only with +ve 32-bit values"
> ConstMinusOne := objectMemory integerObjectOf: -1.
>
> methodCache := Array new: MethodCacheSize.
> atCache := Array new: AtCacheTotalSize.
> self flushMethodCache.
> + objectMemory setRootTable: (Array new: ObjectMemory rootTableSize).
> + objectMemory setWeakRoots: (Array new: ObjectMemory rootTableSize + ObjectMemory remapBufferSize + 100).
> + objectMemory setRemapBuffer: (Array new: ObjectMemory remapBufferSize).
> - objectMemory rootTable: (Array new: ObjectMemory rootTableSize).
> - objectMemory weakRoots: (Array new: ObjectMemory rootTableSize + ObjectMemory remapBufferSize + 100).
> - objectMemory remapBuffer: (Array new: ObjectMemory remapBufferSize).
> semaphoresUseBufferA := true.
> semaphoresToSignalA := Array new: SemaphoresToSignalSize.
> semaphoresToSignalB := Array new: SemaphoresToSignalSize.
> externalPrimitiveTable := CArrayAccessor on: (Array new: MaxExternalPrimitiveTableSize).
> primitiveTable := self class primitiveTable.
> pluginList := #().
> mappedPluginEntries := #().
>
> "initialize InterpreterSimulator variables used for debugging"
> byteCount := 0.
> sendCount := 0.
> quitBlock := [^ self].
> traceOn := true.
> myBitBlt := BitBltSimulator new setInterpreter: self.
> filesOpen := OrderedCollection new.
> + objectMemory setHeaderTypeBytes: (CArrayAccessor on: (Array with: bytesPerWord * 2 with: bytesPerWord with: 0 with: 0)).
> - objectMemory headerTypeBytes: (CArrayAccessor on: (Array with: bytesPerWord * 2 with: bytesPerWord with: 0 with: 0)).
> transcript := Transcript.
> objectMemory transcript: Transcript.
> displayForm := 'Display has not yet been installed' asDisplayText form.
> !
>
> Item was changed:
> ----- Method: InterpreterSimulator>>lookupMethodInClass: (in category 'debug support') -----
> lookupMethodInClass: class
> | currentClass dictionary found rclass |
>
> "This method overrides the interp, causing a halt on MNU."
> "true ifTrue: [^ super lookupMethodInClass: class]." "Defeat debug support"
>
> currentClass := class.
> + [currentClass ~= objectMemory getNilObj]
> - [currentClass ~= objectMemory nilObj]
> whileTrue:
> [dictionary := objectMemory fetchPointer: MessageDictionaryIndex ofObject: currentClass.
> + dictionary = objectMemory getNilObj ifTrue:
> - dictionary = objectMemory nilObj ifTrue:
> ["MethodDict pointer is nil (hopefully due a swapped out stub)
> -- raise exception #cannotInterpret:."
> objectMemory pushRemappableOop: currentClass. "may cause GC!!"
> self createActualMessageTo: class.
> currentClass := objectMemory popRemappableOop.
> messageSelector := objectMemory splObj: SelectorCannotInterpret.
> ^ self lookupMethodInClass: (self superclassOf: currentClass)].
>
> found := self lookupMethodInDictionary: dictionary.
> found ifTrue: [^ methodClass := currentClass].
> currentClass := self superclassOf: currentClass].
>
> "Could not find #doesNotUnderstand: -- unrecoverable error."
> messageSelector = (objectMemory splObj: SelectorDoesNotUnderstand) ifTrue:
> [self error: 'Recursive not understood error encountered'].
>
> self halt: (self stringOf: messageSelector).
>
> "Cound not find a normal message -- raise exception #doesNotUnderstand:"
> objectMemory pushRemappableOop: class. "may cause GC!!"
> self createActualMessageTo: class.
> rclass := objectMemory popRemappableOop.
> messageSelector := objectMemory splObj: SelectorDoesNotUnderstand.
> ^ self lookupMethodInClass: rclass!
>
> Item was changed:
> ----- Method: InterpreterSimulator>>makeDirEntryName:size:createDate:modDate:isDir:fileSize: (in category 'file primitives') -----
> makeDirEntryName: entryName size: entryNameSize
> createDate: createDate modDate: modifiedDate
> isDir: dirFlag fileSize: fileSize
>
> | modDateOop createDateOop nameString results |
> self var: 'entryName' type: 'char *'.
>
> "allocate storage for results, remapping newly allocated
> oops in case GC happens during allocation"
> objectMemory pushRemappableOop:
> (objectMemory instantiateClass: (objectMemory splObj: ClassArray) indexableSize: 5).
> objectMemory pushRemappableOop:
> (objectMemory instantiateClass: (objectMemory splObj: ClassString) indexableSize: entryNameSize)..
> objectMemory pushRemappableOop: (self positive32BitIntegerFor: createDate).
> objectMemory pushRemappableOop: (self positive32BitIntegerFor: modifiedDate).
>
> modDateOop := objectMemory popRemappableOop.
> createDateOop := objectMemory popRemappableOop.
> nameString := objectMemory popRemappableOop.
> results := objectMemory popRemappableOop.
>
> 1 to: entryNameSize do: [ :i |
> objectMemory storeByte: i-1 ofObject: nameString withValue: (entryName at: i) asciiValue.
> ].
>
> objectMemory storePointer: 0 ofObject: results withValue: nameString.
> objectMemory storePointer: 1 ofObject: results withValue: createDateOop.
> objectMemory storePointer: 2 ofObject: results withValue: modDateOop.
> dirFlag
> + ifTrue: [ objectMemory storePointer: 3 ofObject: results withValue: objectMemory getTrueObj ]
> + ifFalse: [ objectMemory storePointer: 3 ofObject: results withValue: objectMemory getFalseObj ].
> - ifTrue: [ objectMemory storePointer: 3 ofObject: results withValue: objectMemory trueObj ]
> - ifFalse: [ objectMemory storePointer: 3 ofObject: results withValue: objectMemory falseObj ].
> objectMemory storePointer: 4 ofObject: results
> withValue: (objectMemory integerObjectOf: fileSize).
> ^ results
> !
>
> Item was changed:
> ----- Method: InterpreterSimulator>>objectBefore: (in category 'testing') -----
> objectBefore: addr
> | oop prev |
> oop := objectMemory firstObject.
> + [oop < objectMemory getEndOfMemory] whileTrue: [
> - [oop < objectMemory endOfMemory] whileTrue: [
> prev := oop. "look here if debugging prev obj overlapping this one"
> oop := objectMemory objectAfter: oop.
> oop >= addr ifTrue: [^ prev]
> ]!
>
> Item was changed:
> ----- Method: InterpreterSimulator>>openOn:extraMemory: (in category 'initialization') -----
> openOn: fileName extraMemory: extraBytes
> "InterpreterSimulator new openOn: 'clone.im' extraMemory: 100000"
>
> | f headerSize count oldBaseAddr bytesToShift swapBytes hasPlatformFloatOrdering |
> "open image file and read the header"
>
> ["begin ensure block..."
> f := FileStream readOnlyFileNamed: fileName.
> imageName := f fullName.
> f binary.
>
> swapBytes := self checkImageVersionFrom: f startingAt: 0.
> "This interpreter does not use native float word order. Clear bit 1of format number."
> imageFormatVersionNumber := imageFormatInitialVersion bitAnd: -2.
> "If bit 1 was set set in the image file header, float word order must be normalized."
> hasPlatformFloatOrdering := (imageFormatInitialVersion bitAnd: 1) = 1.
>
> headerSize := self nextLongFrom: f swap: swapBytes.
> + objectMemory setEndOfMemory: (self nextLongFrom: f swap: swapBytes). "first unused location in heap"
> - objectMemory endOfMemory: (self nextLongFrom: f swap: swapBytes). "first unused location in heap"
> oldBaseAddr := self nextLongFrom: f swap: swapBytes. "object memory base address of image"
> + objectMemory setSpecialObjectsOop: (self nextLongFrom: f swap: swapBytes).
> + objectMemory setLastHash: (self nextLongFrom: f swap: swapBytes). "Should be loaded from, and saved to the image header"
> + objectMemory getLastHash = 0 ifTrue: [objectMemory setLastHash: 999].
> - objectMemory specialObjectsOop: (self nextLongFrom: f swap: swapBytes).
> - objectMemory lastHash: (self nextLongFrom: f swap: swapBytes). "Should be loaded from, and saved to the image header"
> - objectMemory lastHash = 0 ifTrue: [objectMemory lastHash: 999].
>
> savedWindowSize := self nextLongFrom: f swap: swapBytes.
> fullScreenFlag := self oldFormatFullScreenFlag: (self nextLongFrom: f swap: swapBytes).
> extraVMMemory := self nextLongFrom: f swap: swapBytes.
>
> "allocate interpreter memory"
> + objectMemory setMemoryLimit: (objectMemory getEndOfMemory + extraBytes).
> - objectMemory memoryLimit: (objectMemory endOfMemory + extraBytes).
>
> "read in the image in bulk, then swap the bytes if necessary"
> f position: headerSize.
> + objectMemory setMemory: (Bitmap new: objectMemory getMemoryLimit // 4).
> + count := f readInto: objectMemory getMemory startingAt: 1 count: objectMemory getEndOfMemory // 4.
> + count ~= (objectMemory getEndOfMemory // 4) ifTrue: [self halt].
> - objectMemory memory: (Bitmap new: objectMemory memoryLimit // 4).
> - count := f readInto: objectMemory memory startingAt: 1 count: objectMemory endOfMemory // 4.
> - count ~= (objectMemory endOfMemory // 4) ifTrue: [self halt].
> ]
> ensure: [f close].
>
> swapBytes ifTrue: [Utilities informUser: 'Swapping bytes of foreign image...'
> during: [self reverseBytesInImage]].
> self initialize.
> bytesToShift := 0 - oldBaseAddr. "adjust pointers for zero base address"
> + objectMemory setEndOfMemory: objectMemory getEndOfMemory.
> - objectMemory endOfMemory: objectMemory endOfMemory.
> Utilities informUser: 'Relocating object pointers...'
> during: [self initializeInterpreter: bytesToShift].
>
> hasPlatformFloatOrdering ifTrue: [
> "Low order bit set, indicating that the image was saved from
> a StackInterpreter (Cog) VM. Storage of all Float objects must be
> returned to older object memory format."
> Utilities informUser: 'Swapping words in float objects...'
> during: [self normalizeFloatOrderingInImage]].
> !
>
> Item was changed:
> ----- Method: InterpreterSimulator>>primitiveDirectoryLookup (in category 'file primitives') -----
> primitiveDirectoryLookup
> | index pathName array result |
> index := self stackIntegerValue: 0.
> pathName := (self stringOf: (self stackValue: 1)).
>
> self successful ifFalse: [
> ^self primitiveFail.
> ].
>
> array := FileDirectory default primLookupEntryIn: pathName index: index.
>
> array == nil ifTrue: [
> self pop: 3.
> + self push: objectMemory getNilObj.
> - self push: objectMemory nilObj.
> ^array.
> ].
> array == #badDirectoryPath ifTrue: [self halt.
> ^self primitiveFail.
> ].
>
> result := self makeDirEntryName: (array at: 1) size: (array at: 1) size
> createDate: (array at: 2) modDate: (array at: 3)
> isDir: (array at: 4) fileSize: (array at: 5).
> self pop: 3.
> self push: result.
> !
>
> Item was changed:
> ----- Method: InterpreterSimulator>>primitiveKbdNext (in category 'I/O primitives') -----
> primitiveKbdNext
>
> self pop: 1.
> Sensor keyboardPressed
> ifTrue: [self pushInteger: Sensor primKbdNext]
> + ifFalse: [self push: objectMemory getNilObj]!
> - ifFalse: [self push: objectMemory nilObj]!
>
> Item was changed:
> ----- Method: InterpreterSimulator>>primitiveKbdPeek (in category 'I/O primitives') -----
> primitiveKbdPeek
>
> self pop: 1.
> Sensor keyboardPressed
> ifTrue: [self pushInteger: Sensor primKbdPeek]
> + ifFalse: [self push: objectMemory getNilObj]!
> - ifFalse: [self push: objectMemory nilObj]!
>
> Item was changed:
> ----- Method: InterpreterSimulator>>printStack: (in category 'debug support') -----
> printStack: includeTemps
> | ctxt |
> ctxt := activeContext.
> ^ String streamContents:
> [:strm |
> [self printStackFrame: ctxt onStream: strm.
> includeTemps ifTrue: [self printStackTemps: ctxt onStream: strm].
> + (ctxt := (objectMemory fetchPointer: SenderIndex ofObject: ctxt)) = objectMemory getNilObj]
> - (ctxt := (objectMemory fetchPointer: SenderIndex ofObject: ctxt)) = objectMemory nilObj]
> whileFalse: [].
> ]!
>
> Item was changed:
> ----- Method: InterpreterSimulator>>printTop: (in category 'debug support') -----
> printTop: n
> "Print important fields of the top n contexts"
> | ctxt classAndSel home top ip sp |
> ctxt := activeContext.
> ^ String streamContents:
> [:strm | 1 to: n do:
> [:i |
> home := (objectMemory fetchClassOf: ctxt) = (objectMemory splObj: ClassBlockContext)
> ifTrue: [objectMemory fetchPointer: HomeIndex ofObject: ctxt]
> ifFalse: [ctxt].
> classAndSel := self
> classAndSelectorOfMethod: (objectMemory fetchPointer: MethodIndex ofObject: home)
> forReceiver: (objectMemory fetchPointer: ReceiverIndex ofObject: home).
> strm cr; nextPutAll: ctxt hex8.
> ctxt = home ifFalse: [strm nextPutAll: ' [] in'].
> strm space; nextPutAll: (self nameOfClass: classAndSel first).
> strm nextPutAll: '>>'; nextPutAll: (self shortPrint: classAndSel last).
> ctxt = activeContext
> ifTrue: [ip := instructionPointer - method - (objectMemory baseHeaderSize - 2).
> sp := self stackPointerIndex - TempFrameStart + 1.
> top := self stackTop]
> ifFalse: [ip := objectMemory integerValueOf:
> (objectMemory fetchPointer: InstructionPointerIndex ofObject: ctxt).
> sp := objectMemory integerValueOf:
> (objectMemory fetchPointer: StackPointerIndex ofObject: ctxt).
> top := objectMemory longAt: ctxt + (objectMemory lastPointerOf: ctxt)].
> strm cr; tab; nextPutAll: 'ip = '; print: ip.
> strm cr; tab; nextPutAll: 'sp = '; print: sp.
> strm cr; tab; nextPutAll: 'top = '; nextPutAll: (self shortPrint: top).
> + (ctxt := (objectMemory fetchPointer: SenderIndex ofObject: ctxt)) = objectMemory getNilObj
> - (ctxt := (objectMemory fetchPointer: SenderIndex ofObject: ctxt)) = objectMemory nilObj
> ifTrue: [^strm contents].
> ].
> ]!
>
> Item was changed:
> ----- Method: InterpreterSimulator>>reverseBytesFrom:to: (in category 'initialization') -----
> reverseBytesFrom: begin to: end
> "Byte-swap the given range of memory (not inclusive!!)."
> | wordAddr |
> wordAddr := begin.
> + objectMemory getMemory swapBytesFrom: wordAddr // 4 + 1 to: end // 4!
> - objectMemory memory swapBytesFrom: wordAddr // 4 + 1 to: end // 4!
>
> Item was changed:
> ----- Method: InterpreterSimulator>>rewriteImageFileNamed: (in category 'image save/restore') -----
> rewriteImageFileNamed: fileName
> "Write an image file on a file named fileName using the window size that
> was provided by the original image file. This is intended for rewriting an
> image file that has been read from a disk file, but that has not yet been
> run in the interpreter. This may be used to load an image file that had been
> saved by another type of interpreter, and resaving it in the format used by
> this interpreter. For example, an image that has been saved as format 6505
> (indicating use of native float word ordering for a Cog VM) may be resaved
> in format 6504."
>
> "(InterpreterSimulator new openOn: Smalltalk imageName) rewriteImageFileNamed: 'newimagefile.image' "
>
> | file numberOfBytesToWrite |
> bytesPerWord = 4 ifFalse: [self error: 'Not rewritten for 64 bits yet'].
> + numberOfBytesToWrite := objectMemory getFreeBlock - objectMemory startOfMemory.
> - numberOfBytesToWrite := objectMemory freeBlock - objectMemory startOfMemory.
>
> [
> file := (FileStream fileNamed: fileName) binary.
> file == nil ifTrue: [^nil].
> Utilities informUser: 'Writing image to ''', fileName, '''...'
> during: [self writeImageFile: file size: numberOfBytesToWrite screenSize: savedWindowSize]
> ]
> ensure: [file close]!
>
> Item was changed:
> ----- Method: InterpreterSimulator>>showDisplayBits:w:h:d:left:right:top:bottom: (in category 'I/O primitives') -----
> showDisplayBits: destBits w: w h: h d: d left: left right: right top: top bottom: bottom
> | raster pixPerWord simDisp realDisp rect |
> pixPerWord := 32 // d.
> raster := displayForm width + (pixPerWord - 1) // pixPerWord.
> + simDisp := Form new hackBits: objectMemory getMemory.
> - simDisp := Form new hackBits: objectMemory memory.
> displayForm unhibernate.
> realDisp := Form new hackBits: displayForm bits.
> realDisp
> copy: (0 @ (top * raster) extent: 4 @ (bottom - top * raster))
> from: 0 @ (destBits // 4 + (top * raster))
> in: simDisp
> rule: Form over.
> displayView ifNotNil: [^ displayView changed].
>
> "If running without a view, just blat the bits onto the screen..."
> rect := 0 @ top corner: displayForm width @ bottom.
> Display
> copy: (rect translateBy: self displayLocation)
> from: rect topLeft
> in: displayForm
> rule: Form over!
>
> Item was changed:
> ----- Method: InterpreterSimulator>>stackDepth (in category 'testing') -----
> stackDepth
> | ctxt n |
> ctxt := activeContext.
> n := 0.
> + [(ctxt := (objectMemory fetchPointer: SenderIndex ofObject: ctxt)) = objectMemory getNilObj]
> - [(ctxt := (objectMemory fetchPointer: SenderIndex ofObject: ctxt)) = objectMemory nilObj]
> whileFalse: [n := n+1].
> ^ n!
>
> Item was changed:
> ----- Method: InterpreterSimulator>>stats (in category 'testing') -----
> stats
> | oop fieldAddr fieldOop last stats v d |
> stats := Bag new.
> oop := objectMemory firstObject.
>
> 'Scanning the image...' displayProgressAt: Sensor cursorPoint
> + from: oop to: objectMemory getEndOfMemory
> - from: oop to: objectMemory endOfMemory
> during: [:bar |
>
> + [oop < objectMemory getEndOfMemory] whileTrue:
> - [oop < objectMemory endOfMemory] whileTrue:
> [(objectMemory isFreeObject: oop) ifFalse:
> [stats add: #objects.
> fieldAddr := oop + (objectMemory lastPointerOf: oop).
> [fieldAddr > oop] whileTrue:
> [fieldOop := objectMemory longAt: fieldAddr.
> (objectMemory isIntegerObject: fieldOop)
> ifTrue: [v := objectMemory integerValueOf: fieldOop.
> (v between: -16000 and: 16000)
> ifTrue: [stats add: #ints32k]
> ifFalse: [stats add: #intsOther]]
> + ifFalse: [fieldOop = objectMemory getNilObj ifTrue: [stats add: #nil]
> - ifFalse: [fieldOop = objectMemory nilObj ifTrue: [stats add: #nil]
> ifFalse:
> [d := fieldOop - oop.
> (d between: -16000 and: 16000)
> ifTrue: [stats add: #oops32k]
> ifFalse: [stats add: #oopsOther]]].
> fieldAddr := fieldAddr - bytesPerWord]].
> bar value: oop.
> last := oop.
> last := last.
> oop := objectMemory objectAfter: oop]].
> ^ stats sortedElements!
>
> Item was changed:
> ----- Method: InterpreterSimulator>>storeAndPopReceiverVariableBytecode (in category 'bytecode routines') -----
> storeAndPopReceiverVariableBytecode
> "Note: This code uses storePointerUnchecked:ofObject:withValue: and does the store check explicitely in order to help the translator produce better code."
>
> "Interpreter version has fetchNextBytecode out of order"
> | rcvr top |
> rcvr := receiver.
> top := self internalStackTop.
> + (rcvr < objectMemory getYoungStart) ifTrue: [
> - (rcvr < objectMemory youngStart) ifTrue: [
> objectMemory possibleRootStoreInto: rcvr value: top.
> ].
> objectMemory storePointerUnchecked: (currentBytecode bitAnd: 7)
> ofObject: rcvr
> withValue: top.
> self internalPop: 1.
> self fetchNextBytecode.
> !
>
> Item was changed:
> ----- Method: InterpreterSimulator>>validOop: (in category 'testing') -----
> validOop: oop
> " Return true if oop appears to be valid "
> (oop bitAnd: 1) = 1 ifTrue: [^ true]. "Integer"
> (oop bitAnd: 3) = 0 ifFalse: [^ false]. "Uneven address"
> + oop >= objectMemory getEndOfMemory ifTrue: [^ false]. "Out of range"
> - oop >= objectMemory endOfMemory ifTrue: [^ false]. "Out of range"
> "could test if within the first large freeblock"
> (objectMemory longAt: oop) = 4 ifTrue: [^ false].
> (objectMemory headerType: oop) = 2 ifTrue: [^ false]. "Free object"
> ^ true!
>
> Item was changed:
> ----- Method: InterpreterSimulator>>validate (in category 'testing') -----
> validate
> | oop prev |
> transcript show: 'Validating...'.
> oop := objectMemory firstObject.
> + [oop < objectMemory getEndOfMemory] whileTrue: [
> - [oop < objectMemory endOfMemory] whileTrue: [
> self validate: oop.
> prev := oop. "look here if debugging prev obj overlapping this one"
> oop := objectMemory objectAfter: oop.
> ].
> prev := prev. "Don't offer to delete this please"
> transcript show: 'done.'; cr!
>
> Item was changed:
> ----- Method: InterpreterSimulator>>validate: (in category 'testing') -----
> validate: oop
> | header type cc sz fmt nextChunk |
> header := objectMemory longAt: oop.
> type := header bitAnd: 3.
> type = 2 ifFalse: [type = (objectMemory rightType: header) ifFalse: [self halt]].
> sz := (header bitAnd: objectMemory sizeMask) >> 2.
> (objectMemory isFreeObject: oop)
> ifTrue: [ nextChunk := oop + (objectMemory sizeOfFree: oop) ]
> ifFalse: [ nextChunk := oop + (objectMemory sizeBitsOf: oop) ].
> + nextChunk > objectMemory getEndOfMemory
> + ifTrue: [oop = objectMemory getEndOfMemory ifFalse: [self halt]].
> - nextChunk > objectMemory endOfMemory
> - ifTrue: [oop = objectMemory endOfMemory ifFalse: [self halt]].
> (objectMemory headerType: nextChunk) = 0 ifTrue: [
> (objectMemory headerType: (nextChunk + (bytesPerWord * 2))) = 0 ifFalse: [self halt]].
> (objectMemory headerType: nextChunk) = 1 ifTrue: [
> (objectMemory headerType: (nextChunk + bytesPerWord)) = 1 ifFalse: [self halt]].
> type = 2 ifTrue:
> ["free block" ^ self].
> fmt := (header >> 8) bitAnd: 16rF.
> cc := (header >> 12) bitAnd: 31.
> cc > 16 ifTrue: [self halt]. "up to 32 are legal, but not used"
> type = 0 ifTrue:
> ["three-word header"
> ((objectMemory longAt: oop - bytesPerWord) bitAnd: 3) = type ifFalse: [self halt].
> ((objectMemory longAt: oop-(bytesPerWord * 2)) bitAnd: 3) = type ifFalse: [self halt].
> ((objectMemory longAt: oop - bytesPerWord) = type) ifTrue: [self halt]. "Class word is 0"
> sz = 0 ifFalse: [self halt]].
> type = 1 ifTrue:
> ["two-word header"
> ((objectMemory longAt: oop - bytesPerWord) bitAnd: 3) = type ifFalse: [self halt].
> cc > 0 ifTrue: [sz = 1 ifFalse: [self halt]].
> sz = 0 ifTrue: [self halt]].
> type = 3 ifTrue:
> ["one-word header"
> cc = 0 ifTrue: [self halt]].
> fmt = 5 ifTrue: [self halt].
> fmt = 7 ifTrue: [self halt].
> fmt >= 12 ifTrue:
> ["CompiledMethod -- check for integer header"
> (objectMemory isIntegerObject: (objectMemory longAt: oop + bytesPerWord)) ifFalse: [self halt]].!
>
> Item was changed:
> ----- Method: InterpreterSimulator>>writeImageFile:size:screenSize: (in category 'image save/restore') -----
> writeImageFile: file size: numberOfBytesToWrite screenSize: screenSize
> "Actually emit the first numberOfBytesToWrite object memory bytes onto the snapshot."
>
> | headerSize |
> objectMemory bytesPerWord = 4 ifFalse: [self error: 'Not rewritten for 64 bits yet'].
> headerSize := 16 * self bytesPerWord.
>
> {
> self imageFormatVersion.
> headerSize.
> numberOfBytesToWrite.
> objectMemory startOfMemory.
> + objectMemory getSpecialObjectsOop.
> + objectMemory getLastHash.
> - objectMemory specialObjectsOop.
> - objectMemory lastHash.
> screenSize.
> fullScreenFlag.
> extraVMMemory
> }
> do: [:long | self putLong: long toFile: file].
>
> "Pad the rest of the header."
> 7 timesRepeat: [self putLong: 0 toFile: file].
>
> "Position the file after the header."
> file position: headerSize.
>
> "Write the object memory."
> 1 to: numberOfBytesToWrite // 4
> do: [:index |
> self
> + putLong: (objectMemory getMemory at: index)
> - putLong: (objectMemory memory at: index)
> toFile: file].
>
> self success: true
> !
>
> Item was changed:
> ----- Method: InterpreterSimulator>>writeImageFileIO: (in category 'image save/restore') -----
> writeImageFileIO: numberOfBytesToWrite
> "Actually emit the first numberOfBytesToWrite object memory bytes onto the snapshot."
>
> | headerSize file |
> bytesPerWord = 4 ifFalse: [self error: 'Not rewritten for 64 bits yet'].
> headerSize := 16 * bytesPerWord.
>
> [
> file := (FileStream fileNamed: imageName) binary.
> file == nil ifTrue: [^nil].
>
> {
> self imageFormatVersion.
> headerSize.
> numberOfBytesToWrite.
> objectMemory startOfMemory.
> + objectMemory getSpecialObjectsOop.
> + objectMemory getLastHash.
> - objectMemory specialObjectsOop.
> - objectMemory lastHash.
> self ioScreenSize.
> fullScreenFlag.
> extraVMMemory
> }
> do: [:long | self putLong: long toFile: file].
>
> "Pad the rest of the header."
> 7 timesRepeat: [self putLong: 0 toFile: file].
>
> "Position the file after the header."
> file position: headerSize.
>
> "Write the object memory."
> 1
> to: numberOfBytesToWrite // 4
> do: [:index |
> self
> + putLong: (objectMemory getMemory at: index)
> - putLong: (objectMemory memory at: index)
> toFile: file].
>
> self success: true
> ]
> ensure: [file close]!
>
> Item was changed:
> ----- Method: InterpreterSimulatorLSB>>displayForm: (in category 'debug support') -----
> displayForm: f
> | width height depth bits realForm simDisp realDisp |
> bits := objectMemory fetchPointer: 0 ofObject: f.
> width := self fetchInteger: 1 ofObject: f.
> height := self fetchInteger: 2 ofObject: f.
> depth := self fetchInteger: 3 ofObject: f.
> realForm := Form extent: width at height depth: depth.
> + simDisp := Form new hackBits: objectMemory getMemory.
> - simDisp := Form new hackBits: objectMemory memory.
> realDisp := Form new hackBits: realForm bits.
> realDisp
> copy: (0 @ 0 extent: 4 @ realForm bits size)
> from: (0 @ (bits + 4 // 4))
> in: simDisp
> rule: Form over.
> realForm displayOn: Display at: 0 at 0.!
>
> Item was removed:
> - ----- Method: NewObjectMemory>>edenBytes: (in category 'accessing') -----
> - edenBytes: aValue
> - ^edenBytes := aValue!
>
> Item was removed:
> - ----- Method: NewObjectMemory>>falseObject: (in category 'accessing') -----
> - falseObject: anOop
> - "For mapInterpreterOops"
> - falseObj := anOop!
>
> Item was removed:
> - ----- Method: NewObjectMemory>>freeStart: (in category 'accessing') -----
> - freeStart: aValue
> - ^freeStart := aValue!
>
> Item was added:
> + ----- Method: NewObjectMemory>>getYoungStart (in category 'cog jit support') -----
> + getYoungStart
> + <cmacro: '() GIV(youngStart)'>
> + <returnTypeC: #usqInt>
> + ^youngStart!
>
> Item was removed:
> - ----- Method: NewObjectMemory>>heapMapAtWord: (in category 'debug printing') -----
> - heapMapAtWord: wordPointer
> - "Implemented in support code for Cog branch in Cross/vm/sqHeapMap.c and
> - stubbed out here for use with trunk platform sources"
> -
> - self flag: #FIXME. "remove this method and add sqHeapMap.c to Cross when 64 bit address space can be supported"
> - ^ 1
> -
> - "
> - /*
> - * Answer non-zero if the heapMap is set at wordPointer, 0 otherwise
> - */
> - int heapMapAtWord(void *wordPointer)
> - { . . . }
> - "!
>
> Item was removed:
> - ----- Method: NewObjectMemory>>needGCFlag: (in category 'accessing') -----
> - needGCFlag: aValue
> - ^needGCFlag := aValue!
>
> Item was changed:
> ----- Method: NewObjectMemory>>postGCAction: (in category 'garbage collection') -----
> postGCAction: fullGCFlag
> "Shrink free memory and signal the gc semaphore."
> | freeSizeNow |
>
> freeSizeNow := self freeSize.
> + (freeSizeNow > self getShrinkThreshold
> + and: [freeSizeNow > self getGrowHeadroom]) ifTrue:
> - (freeSizeNow > self shrinkThreshold
> - and: [freeSizeNow > self growHeadroom]) ifTrue:
> ["Attempt to shrink memory after successfully reclaiming lots of memory"
> + self shrinkObjectMemory: freeSizeNow - self getGrowHeadroom].
> - self shrinkObjectMemory: freeSizeNow - self growHeadroom].
>
> + interpreter signalSemaphoreWithIndex: self getGcSemaphoreIndex!
> - interpreter signalSemaphoreWithIndex: self gcSemaphoreIndex!
>
> Item was added:
> + ----- Method: NewObjectMemory>>setEdenBytes: (in category 'accessing') -----
> + setEdenBytes: aValue
> + ^edenBytes := aValue!
>
> Item was added:
> + ----- Method: NewObjectMemory>>setFalseObject: (in category 'accessing') -----
> + setFalseObject: anOop
> + "For mapInterpreterOops"
> + falseObj := anOop!
>
> Item was added:
> + ----- Method: NewObjectMemory>>setFreeStart: (in category 'accessing') -----
> + setFreeStart: aValue
> + ^freeStart := aValue!
>
> Item was added:
> + ----- Method: NewObjectMemory>>setNeedGCFlag: (in category 'accessing') -----
> + setNeedGCFlag: aValue
> + ^needGCFlag := aValue!
>
> Item was added:
> + ----- Method: NewObjectMemory>>setTrueObject: (in category 'accessing') -----
> + setTrueObject: anOop
> + "For mapInterpreterOops"
> + trueObj := anOop!
>
> Item was changed:
> + ----- Method: NewObjectMemory>>startOfFreeSpace (in category 'accessing') -----
> - ----- Method: NewObjectMemory>>startOfFreeSpace (in category 'memory access') -----
> startOfFreeSpace
> + <returnTypeC: #usqInt>
> - <inline: true>
> ^freeStart!
>
> Item was removed:
> - ----- Method: NewObjectMemory>>trueObject: (in category 'accessing') -----
> - trueObject: anOop
> - "For mapInterpreterOops"
> - trueObj := anOop!
>
> Item was removed:
> - ----- Method: NewObjectMemory>>youngStart (in category 'cog jit support') -----
> - youngStart
> - <cmacro: '() GIV(youngStart)'>
> - ^youngStart!
>
> Item was added:
> + ----- Method: NewObjectMemorySimulator>>setHeaderTypeBytes: (in category 'initialization') -----
> + setHeaderTypeBytes: array
> + headerTypeBytes := array!
>
> Item was added:
> + ----- Method: NewObjectMemorySimulator>>setInterpreter: (in category 'initialization') -----
> + setInterpreter: anInterpreter
> + interpreter := anInterpreter!
>
> Item was added:
> + ----- Method: NewObjectMemorySimulator>>setRemapBuffer: (in category 'initialization') -----
> + setRemapBuffer: table
> + remapBuffer := table!
>
> Item was added:
> + ----- Method: NewObjectMemorySimulator>>setRootTable: (in category 'initialization') -----
> + setRootTable: table
> + rootTable := table!
>
> Item was added:
> + ----- Method: NewObjectMemorySimulator>>setWeakRoots: (in category 'initialization') -----
> + setWeakRoots: table
> + weakRoots := table!
>
> Item was changed:
> ----- Method: NewObjectMemorySimulator>>sqGrowMemory:By: (in category 'memory access') -----
> sqGrowMemory: oldLimit By: delta
> | newMemory |
> coInterpreter transcript show: 'grow memory from ', oldLimit printString, ' by ', delta printString; cr.
> memory size * 4 < (oldLimit + delta) ifTrue:
> [newMemory := (memory class new: oldLimit + delta + 3 // 4).
> newMemory replaceFrom: 1 to: memory size with: memory startingAt: 1.
> + coInterpreter setMemory: (memory := newMemory)].
> - coInterpreter memory: (memory := newMemory)].
> ^memory size * 4!
>
> Item was changed:
> VMClass subclass: #ObjectMemory
> + instanceVariableNames: 'interpreter memory youngStart endOfMemory memoryLimit nilObj falseObj trueObj specialObjectsOop rootTable rootTableCount extraRoots extraRootCount weakRoots weakRootCount child field parentField freeBlock lastHash allocationCount lowSpaceThreshold signalLowSpace compStart compEnd fwdTableNext fwdTableLast remapBuffer remapBufferCount allocationsBetweenGCs tenuringThreshold gcSemaphoreIndex gcBiasToGrow gcBiasToGrowGCLimit gcBiasToGrowThreshold statFullGCs statFullGCMSecs statFullGCUsecs statIncrGCs statIncrGCMSecs statIncrGCUsecs statIGCDeltaUsecs statTenures statRootTableOverflows freeContexts freeLargeContexts totalObjectCount shrinkThreshold growHeadroom headerTypeBytes youngStartLocal statMarkCount statSweepCount statMkFwdCount statCompMoveCount statGrowMemory statShrinkMemory statRootTableCount statAllocationCount statSurvivorCount statGCTime statSpecialMarkCount statIGCDeltaTime statpendingFinalizationSignals forceTenureFlag gcStartUsecs rootTableOverflowed'
> - instanceVariableNames: 'interpreter memory youngStart endOfMemory memoryLimit nilObj falseObj trueObj specialObjectsOop rootTable rootTableCount extraRoots extraRootCount weakRoots weakRootCount child field parentField freeBlock lastHash allocationCount lowSpaceThreshold signalLowSpace compStart compEnd fwdTableNext fwdTableLast remapBuffer remapBufferCount allocationsBetweenGCs tenuringThreshold gcSemaphoreIndex gcBiasToGrow gcBiasToGrowGCLimit gcBiasToGrowThreshold statFullGCs statFullGCMSecs statFullGCUsecs statIncrGCs statIncrGCMSecs statIncrGCUsecs statIGCDeltaUsecs statTenures statRootTableOverflows freeContexts freeLargeContexts totalObjectCount shrinkThreshold growHeadroom headerTypeBytes youngStartLocal statMarkCount statSweepCount statMkFwdCount statCompMoveCount statGrowMemory statShrinkMemory statRootTableCount statAllocationCount statSurvivorCount statGCTime statSpecialMarkCount statIGCDeltaTime statpendingFinalizationSignals forceTenureFlag gcStartUsecs'
> classVariableNames: 'Byte0Mask Byte0Shift Byte1Mask Byte1Shift Byte1ShiftNegated Byte2Mask Byte2Shift Byte3Mask Byte3Shift Byte3ShiftNegated Byte4Mask Byte4Shift Byte4ShiftNegated Byte5Mask Byte5Shift Byte5ShiftNegated Byte6Mask Byte6Shift Byte7Mask Byte7Shift Byte7ShiftNegated Bytes3to0Mask Bytes7to4Mask ClassPseudoContext ClassTranslatedMethod ContextFixedSizePlusHeader Done ExtraRootSize GCTopMarker HashBits HeaderTypeClass HeaderTypeFree HeaderTypeGC InvokeCallbackSelector NilContext RemapBufferSize RootTableRedZone RootTableSize StartField StartObj Upward'
> poolDictionaries: 'VMBasicConstants VMObjectIndices VMSqueakV3BytecodeConstants VMSqueakV3ObjectRepresentationConstants'
> category: 'VMMaker-Interpreter'!
>
> !ObjectMemory commentStamp: '<historical>' prior: 0!
> This class describes a 32-bit direct-pointer object memory for Smalltalk. The model is very simple in principle: a pointer is either a SmallInteger or a 32-bit direct object pointer.
>
> SmallIntegers are tagged with a low-order bit equal to 1, and an immediate 31-bit 2s-complement signed value in the rest of the word.
>
> All object pointers point to a header, which may be followed by a number of data fields. This object memory achieves considerable compactness by using a variable header size (the one complexity of the design). The format of the 0th header word is as follows:
>
> 3 bits reserved for gc (mark, root, unused)
> 12 bits object hash (for HashSets)
> 5 bits compact class index
> 4 bits object format
> 6 bits object size in 32-bit words
> 2 bits header type (0: 3-word, 1: 2-word, 2: forbidden, 3: 1-word)
>
> If a class is in the compact class table, then this is the only header information needed. If it is not, then it will have another header word at offset -4 bytes with its class in the high 30 bits, and the header type repeated in its low 2 bits. It the objects size is greater than 255 bytes, then it will have yet another header word at offset -8 bytes with its full word size in the high 30 bits and its header type repeated in the low two bits.
>
> The object format field provides the remaining information as given in the formatOf: method (including isPointers, isVariable, isBytes, and the low 2 size bits of byte-sized objects).
>
> This implementation includes incremental (2-generation) and full garbage collection, each with compaction and rectification of direct pointers. It also supports a bulk-become (exchange object identity) feature that allows many objects to be becomed at once, as when all instances of a class must be grown or shrunk.
>
> There is now a simple 64-bit version of the object memory. It is the simplest possible change that could work. It merely sign-extends all integer oops, and extends all object headers and oops by adding 32 zeroes in the high bits. The format of the base header word is changed in one minor, not especially elegant, way. Consider the old 32-bit header:
> ggghhhhhhhhhhhhcccccffffsssssstt
> The 64-bit header is almost identical, except that the size field (now being in units of 8 bytes, has a zero in its low-order bit. At the same time, the byte-size residue bits for byte objects, which are in the low order bits of formats 8-11 and 12-15, are now in need of another bit of residue. So, the change is as follows:
> ggghhhhhhhhhhhhcccccffffsssssrtt
> where bit r supplies the 4's bit of the byte size residue for byte objects. Oh, yes, this is also needed now for 'variableWord' objects, since their size in 32-bit words requires a low-order bit.
>
> See the comment in formatOf: for the change allowing for 64-bit wide bitmaps, now dubbed 'variableLong'.!
>
> Item was removed:
> - ----- Method: ObjectMemory>>allocationsBetweenGCs (in category 'accessing') -----
> - allocationsBetweenGCs
> - ^allocationsBetweenGCs!
>
> Item was removed:
> - ----- Method: ObjectMemory>>allocationsBetweenGCs: (in category 'accessing') -----
> - allocationsBetweenGCs: count
> - allocationsBetweenGCs := count!
>
> Item was changed:
> ----- Method: ObjectMemory>>checkHeapIntegrity (in category 'memory access') -----
> checkHeapIntegrity
> "Perform an integrity/leak check using the heapMap. Assume
> clearLeakMapAndMapAccessibleObjects has set a bit at each
> object's header. Scan all objects in the heap checking that every
> pointer points to a header. Scan the rootTable, remapBuffer and
> extraRootTable checking that every entry is a pointer to a header.
> Check that the number of roots is correct and that all rootTable
> entries have their rootBit set. Answer if all checks pass."
> | ok obj sz hdr fmt fi fieldOop numRootsInHeap |
> <inline: false>
> ok := true.
> numRootsInHeap := 0.
> obj := self firstObject.
> [self oop: obj isLessThan: self startOfFreeSpace] whileTrue:
> [(self isFreeObject: obj)
> ifTrue:
> [sz := self sizeOfFree: obj]
> ifFalse:
> [hdr := self baseHeader: obj.
> + (self isYoungRootHeader: hdr) ifTrue:
> - (hdr bitAnd: self rootBit) ~= 0 ifTrue:
> [numRootsInHeap := numRootsInHeap + 1].
> (self compactClassIndexOfHeader: hdr) = 0 ifTrue:
> [fieldOop := (self classHeader: obj) bitAnd: self allButTypeMask.
> ((self isIntegerObject: fieldOop)
> or: [(self heapMapAtWord: (self pointerForOop: fieldOop)) = 0]) ifTrue:
> [self print: 'object leak in '; printHex: obj; print: ' class = '; printHex: fieldOop; cr.
> ok := false]].
> fmt := self formatOfHeader: hdr.
> + (fmt <= self lastPointerFormat or: [fmt >= self firstCompiledMethodFormat]) ifTrue:
> + [fmt >= self firstCompiledMethodFormat
> + ifTrue: [fi := (self literalCountOf: obj) + LiteralStart]
> + ifFalse: [(fmt = self indexablePointersFormat and: [self isContextHeader: hdr])
> - (fmt <= 4 "pointers" or: [fmt >= 12 "compiled method"]) ifTrue:
> - [fmt >= 12
> - ifTrue: [fi := (self literalCountOf: obj) + 1 "+ 1 = methodHeader slot"]
> - ifFalse: [(fmt = 3 and: [self isContextHeader: hdr])
> ifTrue: [fi := CtxtTempFrameStart + (self fetchStackPointerOf: obj)]
> ifFalse: [fi := self lengthOf: obj]].
> [(fi := fi - 1) >= 0] whileTrue:
> [fieldOop := self fetchPointer: fi ofObject: obj.
> (self isNonIntegerObject: fieldOop) ifTrue:
> [(fieldOop bitAnd: self bytesPerWord - 1) ~= 0
> ifTrue:
> [self print: 'misaligned oop in '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; cr.
> ok := false]
> ifFalse:
> [(self heapMapAtWord: (self pointerForOop: fieldOop)) = 0 ifTrue:
> [self print: 'object leak in '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; cr.
> ok := false]]]]].
> sz := self sizeBitsOf: obj].
> obj := self oopFromChunk: obj + sz].
> numRootsInHeap ~= rootTableCount ifTrue:
> [self print: 'root count mismatch. #heap roots '; printNum: numRootsInHeap; print: '; #roots '; printNum: rootTableCount; cr.
> + "But the system copes with overflow..."
> + ok := rootTableOverflowed and: [allocationCount > allocationsBetweenGCs]].
> - ok := false].
> 1 to: rootTableCount do:
> [:ri|
> obj := rootTable at: ri.
> (obj bitAnd: self bytesPerWord - 1) ~= 0
> ifTrue:
> [self print: 'misaligned oop in rootTable @ '; printNum: ri; print: ' = '; printHex: obj; cr.
> ok := false]
> ifFalse:
> [(self heapMapAtWord: (self pointerForOop: obj)) = 0
> ifTrue:
> [self print: 'object leak in rootTable @ '; printNum: ri; print: ' = '; printHex: obj; cr.
> ok := false]
> ifFalse:
> [hdr := self baseHeader: obj.
> + (self isYoungRootHeader: hdr) ifFalse:
> - (hdr bitAnd: self rootBit) = 0 ifTrue:
> [self print: 'non-root in rootTable @ '; printNum: ri; print: ' = '; printHex: obj; cr.
> ok := false]]]].
> 1 to: remapBufferCount do:
> [:ri|
> obj := remapBuffer at: ri.
> (obj bitAnd: self bytesPerWord - 1) ~= 0
> ifTrue:
> [self print: 'misaligned remapRoot @ '; printNum: ri; print: ' = '; printHex: obj; cr.
> ok := false]
> ifFalse:
> [(self heapMapAtWord: (self pointerForOop: obj)) = 0
> ifTrue:
> [self print: 'object leak in remapRoots @ '; printNum: ri; print: ' = '; printHex: obj; cr.
> ok := false]]].
> 1 to: extraRootCount do:
> [:ri|
> obj := (extraRoots at: ri) at: 0.
> (obj bitAnd: self bytesPerWord - 1) ~= 0
> ifTrue:
> [self print: 'misaligned extraRoot @ '; printNum: ri; print: ' => '; printHex: obj; cr.
> ok := false]
> ifFalse:
> [(self heapMapAtWord: (self pointerForOop: obj)) = 0
> ifTrue:
> [self print: 'object leak in extraRoots @ '; printNum: ri; print: ' => '; printHex: obj; cr.
> ok := false]]].
> ^ok!
>
> Item was removed:
> - ----- Method: ObjectMemory>>endOfMemory (in category 'accessing') -----
> - endOfMemory
> - "Simulation support"
> - ^endOfMemory!
>
> Item was removed:
> - ----- Method: ObjectMemory>>endOfMemory: (in category 'accessing') -----
> - endOfMemory: position
> - "Simulation support"
> - endOfMemory := position!
>
> Item was removed:
> - ----- Method: ObjectMemory>>falseObj (in category 'accessing') -----
> - falseObj
> - ^falseObj!
>
> Item was removed:
> - ----- Method: ObjectMemory>>falseObj: (in category 'accessing') -----
> - falseObj: oop
> - falseObj := oop!
>
> Item was added:
> + ----- Method: ObjectMemory>>firstCompiledMethodFormat (in category 'header formats') -----
> + firstCompiledMethodFormat
> + <api>
> + ^12!
>
> Item was removed:
> - ----- Method: ObjectMemory>>forceTenureFlag: (in category 'accessing') -----
> - forceTenureFlag: arg
> - forceTenureFlag := arg!
>
> Item was removed:
> - ----- Method: ObjectMemory>>freeBlock (in category 'accessing') -----
> - freeBlock
> - ^freeBlock!
>
> Item was removed:
> - ----- Method: ObjectMemory>>freeContexts (in category 'accessing') -----
> - freeContexts
> - ^freeContexts!
>
> Item was removed:
> - ----- Method: ObjectMemory>>freeContexts: (in category 'accessing') -----
> - freeContexts: arg
> - freeContexts := arg!
>
> Item was removed:
> - ----- Method: ObjectMemory>>freeLargeContexts: (in category 'accessing') -----
> - freeLargeContexts: arg
> - freeLargeContexts := arg!
>
> Item was removed:
> - ----- Method: ObjectMemory>>gcBiasToGrow: (in category 'accessing') -----
> - gcBiasToGrow: arg
> - gcBiasToGrow := arg!
>
> Item was removed:
> - ----- Method: ObjectMemory>>gcSemaphoreIndex (in category 'accessing') -----
> - gcSemaphoreIndex
> - ^gcSemaphoreIndex!
>
> Item was removed:
> - ----- Method: ObjectMemory>>gcSemaphoreIndex: (in category 'accessing') -----
> - gcSemaphoreIndex: index
> - gcSemaphoreIndex := index!
>
> Item was added:
> + ----- Method: ObjectMemory>>getAllocationsBetweenGCs (in category 'accessing') -----
> + getAllocationsBetweenGCs
> + ^allocationsBetweenGCs!
>
> Item was added:
> + ----- Method: ObjectMemory>>getEndOfMemory (in category 'accessing') -----
> + getEndOfMemory
> + <returnTypeC: #usqInt>
> + ^endOfMemory!
>
> Item was added:
> + ----- Method: ObjectMemory>>getFalseObj (in category 'accessing') -----
> + getFalseObj
> + ^falseObj!
>
> Item was added:
> + ----- Method: ObjectMemory>>getFreeBlock (in category 'accessing') -----
> + getFreeBlock
> + <returnTypeC: #usqInt>
> + ^freeBlock!
>
> Item was added:
> + ----- Method: ObjectMemory>>getFreeContexts (in category 'accessing') -----
> + getFreeContexts
> + ^freeContexts!
>
> Item was added:
> + ----- Method: ObjectMemory>>getGcSemaphoreIndex (in category 'accessing') -----
> + getGcSemaphoreIndex
> + ^gcSemaphoreIndex!
>
> Item was added:
> + ----- Method: ObjectMemory>>getGrowHeadroom (in category 'accessing') -----
> + getGrowHeadroom
> + ^growHeadroom!
>
> Item was added:
> + ----- Method: ObjectMemory>>getLastHash (in category 'accessing') -----
> + getLastHash
> + "Simulation support"
> + ^lastHash!
>
> Item was added:
> + ----- Method: ObjectMemory>>getMemory (in category 'accessing') -----
> + getMemory
> + <returnTypeC: #usqInt>
> + ^memory!
>
> Item was added:
> + ----- Method: ObjectMemory>>getMemoryLimit (in category 'accessing') -----
> + getMemoryLimit
> + "Simulation support"
> + <returnTypeC: #usqInt>
> + ^memoryLimit!
>
> Item was added:
> + ----- Method: ObjectMemory>>getNilObj (in category 'accessing') -----
> + getNilObj
> + ^nilObj!
>
> Item was added:
> + ----- Method: ObjectMemory>>getRemapBufferCount (in category 'accessing') -----
> + getRemapBufferCount
> + ^remapBufferCount!
>
> Item was added:
> + ----- Method: ObjectMemory>>getRootTableCount (in category 'accessing') -----
> + getRootTableCount
> + ^rootTableCount!
>
> Item was added:
> + ----- Method: ObjectMemory>>getShrinkThreshold (in category 'accessing') -----
> + getShrinkThreshold
> + <returnTypeC: #usqInt>
> + ^shrinkThreshold!
>
> Item was added:
> + ----- Method: ObjectMemory>>getSignalLowSpace (in category 'accessing') -----
> + getSignalLowSpace
> + ^signalLowSpace!
>
> Item was added:
> + ----- Method: ObjectMemory>>getSpecialObjectsOop (in category 'accessing') -----
> + getSpecialObjectsOop
> + "Simulation support"
> + ^specialObjectsOop!
>
> Item was added:
> + ----- Method: ObjectMemory>>getStatAllocationCount (in category 'accessing') -----
> + getStatAllocationCount
> + ^statAllocationCount!
>
> Item was added:
> + ----- Method: ObjectMemory>>getStatCompMoveCount (in category 'accessing') -----
> + getStatCompMoveCount
> + ^statCompMoveCount!
>
> Item was added:
> + ----- Method: ObjectMemory>>getStatFullGCMSecs (in category 'accessing') -----
> + getStatFullGCMSecs
> + ^statFullGCMSecs!
>
> Item was added:
> + ----- Method: ObjectMemory>>getStatFullGCs (in category 'accessing') -----
> + getStatFullGCs
> + ^statFullGCs!
>
> Item was added:
> + ----- Method: ObjectMemory>>getStatGCTime (in category 'accessing') -----
> + getStatGCTime
> + ^statGCTime!
>
> Item was added:
> + ----- Method: ObjectMemory>>getStatGrowMemory (in category 'accessing') -----
> + getStatGrowMemory
> + ^statGrowMemory!
>
> Item was added:
> + ----- Method: ObjectMemory>>getStatIGCDeltaTime (in category 'accessing') -----
> + getStatIGCDeltaTime
> + ^statIGCDeltaTime!
>
> Item was added:
> + ----- Method: ObjectMemory>>getStatIncrGCMSecs (in category 'accessing') -----
> + getStatIncrGCMSecs
> + ^statIncrGCMSecs!
>
> Item was added:
> + ----- Method: ObjectMemory>>getStatIncrGCs (in category 'accessing') -----
> + getStatIncrGCs
> + ^statIncrGCs!
>
> Item was added:
> + ----- Method: ObjectMemory>>getStatMarkCount (in category 'accessing') -----
> + getStatMarkCount
> + ^statMarkCount!
>
> Item was added:
> + ----- Method: ObjectMemory>>getStatMkFwdCount (in category 'accessing') -----
> + getStatMkFwdCount
> + ^statMkFwdCount!
>
> Item was added:
> + ----- Method: ObjectMemory>>getStatRootTableCount (in category 'accessing') -----
> + getStatRootTableCount
> + ^statRootTableCount!
>
> Item was added:
> + ----- Method: ObjectMemory>>getStatRootTableOverflows (in category 'accessing') -----
> + getStatRootTableOverflows
> + ^statRootTableOverflows!
>
> Item was added:
> + ----- Method: ObjectMemory>>getStatShrinkMemory (in category 'accessing') -----
> + getStatShrinkMemory
> + ^statShrinkMemory!
>
> Item was added:
> + ----- Method: ObjectMemory>>getStatSpecialMarkCount (in category 'accessing') -----
> + getStatSpecialMarkCount
> + ^statSpecialMarkCount!
>
> Item was added:
> + ----- Method: ObjectMemory>>getStatSurvivorCount (in category 'accessing') -----
> + getStatSurvivorCount
> + ^statSurvivorCount!
>
> Item was added:
> + ----- Method: ObjectMemory>>getStatSweepCount (in category 'accessing') -----
> + getStatSweepCount
> + ^statSweepCount!
>
> Item was added:
> + ----- Method: ObjectMemory>>getStatTenures (in category 'accessing') -----
> + getStatTenures
> + ^statTenures!
>
> Item was added:
> + ----- Method: ObjectMemory>>getStatpendingFinalizationSignals (in category 'accessing') -----
> + getStatpendingFinalizationSignals
> + ^statpendingFinalizationSignals!
>
> Item was added:
> + ----- Method: ObjectMemory>>getTenuringThreshold (in category 'accessing') -----
> + getTenuringThreshold
> + ^tenuringThreshold!
>
> Item was added:
> + ----- Method: ObjectMemory>>getTrueObj (in category 'accessing') -----
> + getTrueObj
> + ^trueObj!
>
> Item was added:
> + ----- Method: ObjectMemory>>getYoungStart (in category 'accessing') -----
> + getYoungStart
> + <returnTypeC: #usqInt>
> + self subclassResponsibility!
>
> Item was removed:
> - ----- Method: ObjectMemory>>growHeadroom (in category 'accessing') -----
> - growHeadroom
> - ^growHeadroom!
>
> Item was removed:
> - ----- Method: ObjectMemory>>growHeadroom: (in category 'accessing') -----
> - growHeadroom: arg
> - growHeadroom := arg!
>
> Item was removed:
> - ----- Method: ObjectMemory>>headerTypeBytes (in category 'accessing') -----
> - headerTypeBytes
> - ^headerTypeBytes!
>
> Item was removed:
> - ----- Method: ObjectMemory>>headerTypeBytes: (in category 'accessing') -----
> - headerTypeBytes: array
> - "Simulation support"
> - headerTypeBytes := array!
>
> Item was added:
> + ----- Method: ObjectMemory>>headerTypeBytesAt:put: (in category 'accessing') -----
> + headerTypeBytesAt: index put: value
> + headerTypeBytes at: index put: value!
>
> Item was removed:
> - ----- Method: ObjectMemory>>headerTypeClass (in category 'accessing') -----
> - headerTypeClass
> - ^HeaderTypeClass!
>
> Item was added:
> + ----- Method: ObjectMemory>>heapMapAtWord: (in category 'debug printing') -----
> + heapMapAtWord: wordPointer
> + "Implemented in support code for Cog branch in Cross/vm/sqHeapMap.c and
> + stubbed out here for use with trunk platform sources"
> +
> + self flag: #FIXME. "remove this method and add sqHeapMap.c to Cross when 64 bit address space can be supported"
> + ^ 1
> +
> + "
> + /*
> + * Answer non-zero if the heapMap is set at wordPointer, 0 otherwise
> + */
> + int heapMapAtWord(void *wordPointer)
> + { . . . }
> + "!
>
> Item was added:
> + ----- Method: ObjectMemory>>indexablePointersFormat (in category 'header formats') -----
> + indexablePointersFormat
> + <api>
> + ^3!
>
> Item was removed:
> - ----- Method: ObjectMemory>>interpreter: (in category 'accessing') -----
> - interpreter: anInterpreter
> - interpreter := anInterpreter!
>
> Item was added:
> + ----- Method: ObjectMemory>>isYoungRootHeader: (in category 'garbage collection') -----
> + isYoungRootHeader: header
> + "Answer if oop is a root for objects in youngSpace"
> + ^(header bitAnd: self rootBit) ~= 0!
>
> Item was removed:
> - ----- Method: ObjectMemory>>lastHash (in category 'accessing') -----
> - lastHash
> - "Simulation support"
> - ^lastHash!
>
> Item was removed:
> - ----- Method: ObjectMemory>>lastHash: (in category 'accessing') -----
> - lastHash: hash
> - "Simulation support"
> - lastHash := hash!
>
> Item was added:
> + ----- Method: ObjectMemory>>lastPointerFormat (in category 'header access') -----
> + lastPointerFormat
> + "N.B. 5 is unused and could be used for ephemerons.
> + 7 is unused and could be used for 64-bit indexable."
> + ^4!
>
> Item was removed:
> - ----- Method: ObjectMemory>>lowSpaceThreshold: (in category 'accessing') -----
> - lowSpaceThreshold: arg
> - lowSpaceThreshold := arg!
>
> Item was removed:
> - ----- Method: ObjectMemory>>memory (in category 'accessing') -----
> - memory
> - ^memory!
>
> Item was removed:
> - ----- Method: ObjectMemory>>memory: (in category 'accessing') -----
> - memory: loc
> - memory := loc!
>
> Item was removed:
> - ----- Method: ObjectMemory>>memoryLimit (in category 'accessing') -----
> - memoryLimit
> - "Simulation support"
> - ^memoryLimit!
>
> Item was removed:
> - ----- Method: ObjectMemory>>memoryLimit: (in category 'accessing') -----
> - memoryLimit: limit
> - "Simulation support"
> - memoryLimit := limit!
>
> Item was removed:
> - ----- Method: ObjectMemory>>nilObj (in category 'accessing') -----
> - nilObj
> - ^nilObj!
>
> Item was removed:
> - ----- Method: ObjectMemory>>nilObj: (in category 'accessing') -----
> - nilObj: oop
> - nilObj := oop!
>
> Item was removed:
> - ----- Method: ObjectMemory>>remapBuffer (in category 'accessing') -----
> - remapBuffer
> - ^remapBuffer!
>
> Item was removed:
> - ----- Method: ObjectMemory>>remapBuffer: (in category 'accessing') -----
> - remapBuffer: table
> - "Simulation support"
> - remapBuffer := table!
>
> Item was added:
> + ----- Method: ObjectMemory>>remapBufferAt: (in category 'accessing') -----
> + remapBufferAt: index
> + ^remapBuffer at: index!
>
> Item was added:
> + ----- Method: ObjectMemory>>remapBufferAt:put: (in category 'accessing') -----
> + remapBufferAt: index put: value
> + remapBuffer at: index put: value!
>
> Item was removed:
> - ----- Method: ObjectMemory>>remapBufferCount (in category 'accessing') -----
> - remapBufferCount
> - ^remapBufferCount!
>
> Item was removed:
> - ----- Method: ObjectMemory>>rootTable (in category 'accessing') -----
> - rootTable
> - ^rootTable!
>
> Item was removed:
> - ----- Method: ObjectMemory>>rootTable: (in category 'accessing') -----
> - rootTable: table
> - "Simulation support"
> - rootTable := table!
>
> Item was added:
> + ----- Method: ObjectMemory>>rootTableAt: (in category 'accessing') -----
> + rootTableAt: index
> + ^rootTable at: index!
>
> Item was removed:
> - ----- Method: ObjectMemory>>rootTableCount (in category 'accessing') -----
> - rootTableCount
> - ^rootTableCount!
>
> Item was added:
> + ----- Method: ObjectMemory>>setAllocationsBetweenGCs: (in category 'accessing') -----
> + setAllocationsBetweenGCs: count
> + allocationsBetweenGCs := count!
>
> Item was changed:
> + ----- Method: ObjectMemory>>setEndOfMemory: (in category 'accessing') -----
> + setEndOfMemory: position
> + "Simulation support"
> + endOfMemory := position!
> - ----- Method: ObjectMemory>>setEndOfMemory: (in category 'initialization') -----
> - setEndOfMemory: newEndOfMemory
> - self assert: (newEndOfMemory bitAnd: self bytesPerWord - 1) = 0.
> - endOfMemory := newEndOfMemory!
>
> Item was added:
> + ----- Method: ObjectMemory>>setForceTenureFlag: (in category 'accessing') -----
> + setForceTenureFlag: arg
> + forceTenureFlag := arg!
>
> Item was added:
> + ----- Method: ObjectMemory>>setFreeContexts: (in category 'accessing') -----
> + setFreeContexts: arg
> + freeContexts := arg!
>
> Item was added:
> + ----- Method: ObjectMemory>>setFreeLargeContexts: (in category 'accessing') -----
> + setFreeLargeContexts: arg
> + freeLargeContexts := arg!
>
> Item was added:
> + ----- Method: ObjectMemory>>setGcBiasToGrow: (in category 'accessing') -----
> + setGcBiasToGrow: arg
> + gcBiasToGrow := arg!
>
> Item was added:
> + ----- Method: ObjectMemory>>setGcSemaphoreIndex: (in category 'accessing') -----
> + setGcSemaphoreIndex: index
> + gcSemaphoreIndex := index!
>
> Item was added:
> + ----- Method: ObjectMemory>>setGrowHeadroom: (in category 'accessing') -----
> + setGrowHeadroom: arg
> + growHeadroom := arg!
>
> Item was added:
> + ----- Method: ObjectMemory>>setLastHash: (in category 'accessing') -----
> + setLastHash: hash
> + "Simulation support"
> + lastHash := hash!
>
> Item was added:
> + ----- Method: ObjectMemory>>setLowSpaceThreshold: (in category 'accessing') -----
> + setLowSpaceThreshold: arg
> + lowSpaceThreshold := arg!
>
> Item was added:
> + ----- Method: ObjectMemory>>setMemory: (in category 'accessing') -----
> + setMemory: loc
> + memory := loc!
>
> Item was changed:
> + ----- Method: ObjectMemory>>setMemoryLimit: (in category 'accessing') -----
> + setMemoryLimit: limit
> + "Simulation support"
> + memoryLimit := limit!
> - ----- Method: ObjectMemory>>setMemoryLimit: (in category 'initialization') -----
> - setMemoryLimit: newMemoryLimit
> - self assert: (newMemoryLimit bitAnd: self bytesPerWord - 1) = 0.
> - memoryLimit := newMemoryLimit!
>
> Item was added:
> + ----- Method: ObjectMemory>>setShrinkThreshold: (in category 'accessing') -----
> + setShrinkThreshold: arg
> + shrinkThreshold := arg!
>
> Item was added:
> + ----- Method: ObjectMemory>>setSignalLowSpace: (in category 'accessing') -----
> + setSignalLowSpace: boolean
> + signalLowSpace := boolean!
>
> Item was added:
> + ----- Method: ObjectMemory>>setSpecialObjectsOop: (in category 'accessing') -----
> + setSpecialObjectsOop: oop
> + "Simulation support"
> + specialObjectsOop := oop!
>
> Item was added:
> + ----- Method: ObjectMemory>>setStatpendingFinalizationSignals: (in category 'accessing') -----
> + setStatpendingFinalizationSignals: arg
> + statpendingFinalizationSignals := arg!
>
> Item was added:
> + ----- Method: ObjectMemory>>setTenuringThreshold: (in category 'accessing') -----
> + setTenuringThreshold: arg
> + tenuringThreshold := arg!
>
> Item was added:
> + ----- Method: ObjectMemory>>setYoungStart: (in category 'accessing') -----
> + setYoungStart: arg
> + youngStart := arg!
>
> Item was removed:
> - ----- Method: ObjectMemory>>shrinkThreshold (in category 'accessing') -----
> - shrinkThreshold
> - ^shrinkThreshold!
>
> Item was removed:
> - ----- Method: ObjectMemory>>shrinkThreshold: (in category 'accessing') -----
> - shrinkThreshold: arg
> - shrinkThreshold := arg!
>
> Item was removed:
> - ----- Method: ObjectMemory>>signalLowSpace (in category 'accessing') -----
> - signalLowSpace
> - ^signalLowSpace!
>
> Item was removed:
> - ----- Method: ObjectMemory>>signalLowSpace: (in category 'accessing') -----
> - signalLowSpace: boolean
> - signalLowSpace := boolean!
>
> Item was removed:
> - ----- Method: ObjectMemory>>specialObjectsOop (in category 'accessing') -----
> - specialObjectsOop
> - "Simulation support"
> - ^specialObjectsOop!
>
> Item was removed:
> - ----- Method: ObjectMemory>>specialObjectsOop: (in category 'accessing') -----
> - specialObjectsOop: oop
> - "Simulation support"
> - specialObjectsOop := oop!
>
> Item was added:
> + ----- Method: ObjectMemory>>startOfFreeSpace (in category 'accessing') -----
> + startOfFreeSpace
> + <returnTypeC: #usqInt>
> + self subclassResponsibility!
>
> Item was removed:
> - ----- Method: ObjectMemory>>statAllocationCount (in category 'accessing') -----
> - statAllocationCount
> - ^statAllocationCount!
>
> Item was removed:
> - ----- Method: ObjectMemory>>statCompMoveCount (in category 'accessing') -----
> - statCompMoveCount
> - ^statCompMoveCount!
>
> Item was removed:
> - ----- Method: ObjectMemory>>statFullGCMSecs (in category 'accessing') -----
> - statFullGCMSecs
> - ^statFullGCMSecs!
>
> Item was removed:
> - ----- Method: ObjectMemory>>statFullGCs (in category 'accessing') -----
> - statFullGCs
> - ^statFullGCs!
>
> Item was removed:
> - ----- Method: ObjectMemory>>statGCTime (in category 'accessing') -----
> - statGCTime
> - ^statGCTime!
>
> Item was removed:
> - ----- Method: ObjectMemory>>statGrowMemory (in category 'accessing') -----
> - statGrowMemory
> - ^statGrowMemory!
>
> Item was removed:
> - ----- Method: ObjectMemory>>statIGCDeltaTime (in category 'accessing') -----
> - statIGCDeltaTime
> - ^statIGCDeltaTime!
>
> Item was removed:
> - ----- Method: ObjectMemory>>statIncrGCMSecs (in category 'accessing') -----
> - statIncrGCMSecs
> - ^statIncrGCMSecs!
>
> Item was removed:
> - ----- Method: ObjectMemory>>statIncrGCs (in category 'accessing') -----
> - statIncrGCs
> - ^statIncrGCs!
>
> Item was removed:
> - ----- Method: ObjectMemory>>statMarkCount (in category 'accessing') -----
> - statMarkCount
> - ^statMarkCount!
>
> Item was removed:
> - ----- Method: ObjectMemory>>statMkFwdCount (in category 'accessing') -----
> - statMkFwdCount
> - ^statMkFwdCount!
>
> Item was removed:
> - ----- Method: ObjectMemory>>statRootTableCount (in category 'accessing') -----
> - statRootTableCount
> - ^statRootTableCount!
>
> Item was removed:
> - ----- Method: ObjectMemory>>statRootTableOverflows (in category 'accessing') -----
> - statRootTableOverflows
> - ^statRootTableOverflows!
>
> Item was removed:
> - ----- Method: ObjectMemory>>statShrinkMemory (in category 'accessing') -----
> - statShrinkMemory
> - ^statShrinkMemory!
>
> Item was removed:
> - ----- Method: ObjectMemory>>statSpecialMarkCount (in category 'accessing') -----
> - statSpecialMarkCount
> - ^statSpecialMarkCount!
>
> Item was removed:
> - ----- Method: ObjectMemory>>statSurvivorCount (in category 'accessing') -----
> - statSurvivorCount
> - ^statSurvivorCount!
>
> Item was removed:
> - ----- Method: ObjectMemory>>statSweepCount (in category 'accessing') -----
> - statSweepCount
> - ^statSweepCount!
>
> Item was removed:
> - ----- Method: ObjectMemory>>statTenures (in category 'accessing') -----
> - statTenures
> - ^statTenures!
>
> Item was removed:
> - ----- Method: ObjectMemory>>statpendingFinalizationSignals (in category 'accessing') -----
> - statpendingFinalizationSignals
> - ^statpendingFinalizationSignals!
>
> Item was removed:
> - ----- Method: ObjectMemory>>statpendingFinalizationSignals: (in category 'accessing') -----
> - statpendingFinalizationSignals: arg
> - statpendingFinalizationSignals := arg!
>
> Item was removed:
> - ----- Method: ObjectMemory>>tenuringThreshold (in category 'accessing') -----
> - tenuringThreshold
> - ^tenuringThreshold!
>
> Item was removed:
> - ----- Method: ObjectMemory>>tenuringThreshold: (in category 'accessing') -----
> - tenuringThreshold: arg
> - tenuringThreshold := arg!
>
> Item was removed:
> - ----- Method: ObjectMemory>>trueObj (in category 'accessing') -----
> - trueObj
> - ^trueObj!
>
> Item was removed:
> - ----- Method: ObjectMemory>>trueObj: (in category 'accessing') -----
> - trueObj: oop
> - trueObj := oop!
>
> Item was removed:
> - ----- Method: ObjectMemory>>weakRoots: (in category 'accessing') -----
> - weakRoots: table
> - "Simulation support"
> - weakRoots := table!
>
> Item was removed:
> - ----- Method: ObjectMemory>>youngStart (in category 'accessing') -----
> - youngStart
> - self subclassResponsibility!
>
> Item was removed:
> - ----- Method: ObjectMemory>>youngStart: (in category 'accessing') -----
> - youngStart: arg
> - youngStart := arg!
>
> Item was changed:
> ----- Method: ObjectMemorySimulator>>allObjectsDo: (in category 'debug support') -----
> allObjectsDo: objBlock
>
> | oop |
> oop := self firstObject.
> + [oop < self getEndOfMemory] whileTrue:
> - [oop < self endOfMemory] whileTrue:
> [(self isFreeObject: oop)
> ifFalse: [objBlock value: oop].
> oop := self objectAfter: oop].
> !
>
> Item was changed:
> ----- Method: ObjectMemorySimulator>>allObjectsSelect: (in category 'debug support') -----
> allObjectsSelect: objBlock
> "self allObjectsSelect: [:oop | (self baseHeader: oop) = 1234]"
>
> | oop selected |
> oop := self firstObject.
> selected := OrderedCollection new.
> + [oop < self getEndOfMemory] whileTrue:
> - [oop < self endOfMemory] whileTrue:
> [(self isFreeObject: oop)
> ifFalse: [(objBlock value: oop) ifTrue: [selected addLast: oop]].
> oop := self objectAfter: oop].
> ^ selected!
>
> Item was changed:
> ----- Method: ObjectMemorySimulator>>numObjects (in category 'debug support') -----
> numObjects
>
> | count oop |
> count := 0.
> oop := self firstObject.
> + [oop < self getEndOfMemory] whileTrue:
> - [oop < self endOfMemory] whileTrue:
> [(self isFreeObject: oop)
> ifFalse: [count := count + 1].
> oop := self objectAfter: oop].
> ^count
> !
>
> Item was added:
> + ----- Method: ObjectMemorySimulator>>setHeaderTypeBytes: (in category 'initialization') -----
> + setHeaderTypeBytes: array
> + headerTypeBytes := array!
>
> Item was added:
> + ----- Method: ObjectMemorySimulator>>setInterpreter: (in category 'initialization') -----
> + setInterpreter: anInterpreter
> + interpreter := anInterpreter!
>
> Item was added:
> + ----- Method: ObjectMemorySimulator>>setRemapBuffer: (in category 'initialization') -----
> + setRemapBuffer: table
> + remapBuffer := table!
>
> Item was added:
> + ----- Method: ObjectMemorySimulator>>setRootTable: (in category 'initialization') -----
> + setRootTable: table
> + rootTable := table!
>
> Item was added:
> + ----- Method: ObjectMemorySimulator>>setWeakRoots: (in category 'initialization') -----
> + setWeakRoots: table
> + weakRoots := table!
>
> Item was changed:
> ----- Method: SlangTestSupportInterpreter>>setInstanceVariableWithAnAccessorMethod (in category 'local and instance vars') -----
> setInstanceVariableWithAnAccessorMethod
> + objectMemory setAVariable: (objectMemory remap: objectMemory getNilObj).
> - objectMemory setAVariable: (objectMemory remap: objectMemory nilObj).
> !
>
> Item was changed:
> ----- Method: SlangTestSupportPlugin>>methodWithLoopLimitThatIsNotModified: (in category 'loop limits') -----
> methodWithLoopLimitThatIsNotModified: arrayObj
>
> + 0 to: 10 do: [:i | self storePointerUnchecked: i ofObject: arrayObj withValue: 0]
> - 0 to: 10 do: [:i | self storePointerUnchecked: i ofObject: arrayObj withValue: nilObj]
> !
>
> Item was changed:
> ----- Method: SlangTestSupportSSIP>>methodWithLoopLimitThatIsNotModified: (in category 'loop limits') -----
> methodWithLoopLimitThatIsNotModified: arrayObj
>
> + 0 to: 10 do: [:i | self storePointerUnchecked: i ofObject: arrayObj withValue: 0]
> - 0 to: 10 do: [:i | self storePointerUnchecked: i ofObject: arrayObj withValue: nilObj]
> !
>
> Item was changed:
> ----- Method: StackInterpreter>>checkForEventsMayContextSwitch: (in category 'process primitive support') -----
> checkForEventsMayContextSwitch: mayContextSwitch
> "Check for possible interrupts and handle one if necessary.
> Answer if a context switch has occurred."
> | switched sema now |
> <inline: false>
> <var: #now type: #usqLong>
> statCheckForEvents := statCheckForEvents + 1.
>
> "restore the stackLimit if it has been smashed."
> self restoreStackLimit.
> self externalWriteBackHeadFramePointers.
> self assert: stackPage = stackPages mostRecentlyUsedPage.
>
> "Allow the platform to do anything it needs to do synchronously."
> self ioSynchronousCheckForEvents.
>
> self checkCogCompiledCodeCompactionCalledFor.
>
> objectMemory needGCFlag ifTrue:
> + [objectMemory setNeedGCFlag: false.
> - [objectMemory needGCFlag: false.
> "sufficientSpaceAfterGC: runs the incremental GC and
> then, if not enough space is available, the fullGC."
> (objectMemory sufficientSpaceAfterGC: 0) ifFalse:
> [self setSignalLowSpaceFlagAndSaveProcess]].
>
> mayContextSwitch ifFalse: [^false].
>
> switched := false.
>
> (profileProcess ~= objectMemory nilObject
> or: [nextProfileTick > 0 and:[self ioHighResClock >= nextProfileTick]]) ifTrue:
> ["Take a sample (if not already done so) for the profiler if it is active. This
> must be done before any of the synchronousSignals below or else we will
> attribute a pause in ioRelinquishProcessor to the newly activated process."
> profileProcess = objectMemory nilObject ifTrue:
> [profileProcess := self activeProcess.
> profileMethod := objectMemory nilObject].
> "and signal the profiler semaphore if it is present"
> (profileSemaphore ~= objectMemory nilObject
> and: [self synchronousSignal: profileSemaphore]) ifTrue:
> [switched := true].
> nextProfileTick := 0].
>
> self checkDeliveryOfLongRunningPrimitiveSignal ifTrue:
> [switched := true].
>
> + objectMemory getSignalLowSpace ifTrue:
> + [objectMemory setSignalLowSpace: false. "reset flag"
> - objectMemory signalLowSpace ifTrue:
> - [objectMemory signalLowSpace: false. "reset flag"
> sema := objectMemory splObj: TheLowSpaceSemaphore.
> (sema ~= objectMemory nilObject
> and: [self synchronousSignal: sema]) ifTrue:
> [switched := true]].
>
> "inIOProcessEvents prevents reentrancy into ioProcessEvents and allows disabling
> ioProcessEvents e.g. for native GUIs. We would like to manage that here but can't
> since the platform code may choose to call ioProcessEvents itself in various places."
> false
> ifTrue:
> [((now := self ioUTCMicroseconds) >= nextPollUsecs
> and: [inIOProcessEvents = 0]) ifTrue:
> [statIOProcessEvents := statIOProcessEvents + 1.
> inIOProcessEvents := inIOProcessEvents + 1.
> self ioProcessEvents. "sets interruptPending if interrupt key pressed; may callback"
> inIOProcessEvents > 0 ifTrue:
> [inIOProcessEvents := inIOProcessEvents - 1].
> nextPollUsecs := now + 20000
> "msecs to wait before next call to ioProcessEvents. Note that strictly
> speaking we might need to update 'now' at this point since
> ioProcessEvents could take a very long time on some platforms"]]
> ifFalse:
> [(now := self ioUTCMicroseconds) >= nextPollUsecs ifTrue:
> [statIOProcessEvents := statIOProcessEvents + 1.
> self ioProcessEvents. "sets interruptPending if interrupt key pressed; may callback"
> nextPollUsecs := now + 20000
> "msecs to wait before next call to ioProcessEvents. Note that strictly
> speaking we might need to update 'now' at this point since
> ioProcessEvents could take a very long time on some platforms"]].
>
> interruptPending ifTrue:
> [interruptPending := false.
> "reset interrupt flag"
> sema := objectMemory splObj: TheInterruptSemaphore.
> (sema ~= objectMemory nilObject
> and: [self synchronousSignal: sema]) ifTrue:
> [switched := true]].
>
> nextWakeupUsecs ~= 0 ifTrue:
> [now >= nextWakeupUsecs ifTrue:
> [nextWakeupUsecs := 0.
> "set timer interrupt to 0 for 'no timer'"
> sema := objectMemory splObj: TheTimerSemaphore.
> (sema ~= objectMemory nilObject
> and: [self synchronousSignal: sema]) ifTrue:
> [switched := true]]].
>
> "signal any pending finalizations"
> pendingFinalizationSignals > 0 ifTrue:
> [sema := objectMemory splObj: TheFinalizationSemaphore.
> ((objectMemory isClassOfNonImm: sema equalTo: (objectMemory splObj: ClassSemaphore))
> and: [self synchronousSignal: sema]) ifTrue:
> [switched := true].
> pendingFinalizationSignals := 0].
>
> "signal all semaphores in semaphoresToSignal"
> self signalExternalSemaphores ifTrue:
> [switched := true].
>
> ^switched!
>
> Item was changed:
> ----- Method: StackInterpreter>>checkInterpreterIntegrity (in category 'object memory support') -----
> checkInterpreterIntegrity
> "Perform an integrity/leak check using the heapMap. Assume
> clearLeakMapAndMapAccessibleObjects has set a bit at each
> object's header. Check that all oops in the interpreter's state
> points to a header. Answer if all checks pass."
> | ok |
> ok := true.
> + (objectMemory checkOopIntegrity: objectMemory getSpecialObjectsOop named: 'specialObjectsOop')ifFalse:
> - (objectMemory checkOopIntegrity: objectMemory specialObjectsOop named: 'specialObjectsOop')ifFalse:
> [ok := false].
> (objectMemory isIntegerObject: messageSelector) ifFalse:
> [(objectMemory checkOopIntegrity: messageSelector named: 'messageSelector')ifFalse:
> [ok := false]].
> (objectMemory checkOopIntegrity: newMethod named: 'newMethod')ifFalse:
> [ok := false].
> (objectMemory checkOopIntegrity: lkupClass named: 'lkupClass')ifFalse:
> [ok := false].
> (objectMemory checkOopIntegrity: profileProcess named: 'profileProcess')ifFalse:
> [ok := false].
> (objectMemory checkOopIntegrity: profileMethod named: 'profileMethod')ifFalse:
> [ok := false].
> (objectMemory checkOopIntegrity: profileSemaphore named: 'profileSemaphore')ifFalse:
> [ok := false].
> tempOop = 0 ifFalse:
> [(objectMemory checkOopIntegrity: tempOop named: 'tempOop')ifFalse:
> [ok := false]].
>
> "Callback support - check suspended callback list"
> 1 to: jmpDepth do:
> [:i|
> (objectMemory checkOopIntegrity: (suspendedCallbacks at: i) named: 'suspendedCallbacks' index: i) ifFalse:
> [ok := false].
> (objectMemory checkOopIntegrity: (suspendedMethods at: i) named: 'suspendedMethods' index: i) ifFalse:
> [ok := false]].
>
> self checkLogIntegrity ifFalse:
> [ok := false].
>
> ^ok!
>
> Item was changed:
> ----- Method: StackInterpreter>>dumpImage: (in category 'image save/restore') -----
> dumpImage: fileName
> "Dump the entire image out to the given file. Intended for debugging only."
> | f dataSize result |
> <export: true>
> <var: #f type: 'sqImageFile'>
>
> f := self cCode: 'sqImageFileOpen(pointerForOop(fileName), "wb")'.
> f = nil ifTrue: [^-1].
> + dataSize := objectMemory getEndOfMemory - objectMemory startOfMemory.
> - dataSize := objectMemory endOfMemory - objectMemory startOfMemory.
> result := self cCode: 'sqImageFileWrite(pointerForOop(memory), sizeof(unsigned char), dataSize, f)'.
> self cCode: 'sqImageFileClose(f)'.
> ^result
> !
>
> Item was changed:
> ----- Method: StackInterpreter>>ensureImageFormatIsUpToDate: (in category 'image save/restore') -----
> ensureImageFormatIsUpToDate: swapBytes
> "Ensure the image data has been updayed to suit the current VM."
> <inline: false>
> swapBytes
> ifTrue: [self reverseBytesInImage]
> + ifFalse: [self convertFloatsToPlatformOrderFrom: objectMemory firstObject to: objectMemory getEndOfMemory]!
> - ifFalse: [self convertFloatsToPlatformOrderFrom: objectMemory firstObject to: objectMemory endOfMemory]!
>
> Item was changed:
> ----- Method: StackInterpreter>>mapInterpreterOops (in category 'object memory support') -----
> mapInterpreterOops
> "Map all oops in the interpreter's state to their new values
> during garbage collection or a become: operation."
> "Assume: All traced variables contain valid oops."
> | oop |
> objectMemory nilObject: (objectMemory remap: objectMemory nilObject).
> + objectMemory setFalseObject: (objectMemory remap: objectMemory falseObject).
> + objectMemory setTrueObject: (objectMemory remap: objectMemory trueObject).
> + objectMemory setSpecialObjectsOop: (objectMemory remap: objectMemory getSpecialObjectsOop).
> - objectMemory falseObject: (objectMemory remap: objectMemory falseObject).
> - objectMemory trueObject: (objectMemory remap: objectMemory trueObject).
> - objectMemory specialObjectsOop: (objectMemory remap: objectMemory specialObjectsOop).
> self mapStackPages.
> self mapMachineCode.
> self mapTraceLogs.
> self mapVMRegisters.
> self mapProfileState.
> tempOop = 0 ifFalse: [tempOop := self remap: tempOop].
> + 1 to: objectMemory getRemapBufferCount do: [:i |
> + oop := objectMemory remapBufferAt: i.
> - 1 to: objectMemory remapBufferCount do: [:i |
> - oop := objectMemory remapBuffer at: i.
> (objectMemory isIntegerObject: oop)
> + ifFalse: [objectMemory remapBufferAt: i put: (objectMemory remap: oop)]].
> - ifFalse: [objectMemory remapBuffer at: i put: (objectMemory remap: oop)]].
>
> "Callback support - trace suspended callback list"
> 1 to: jmpDepth do:[:i|
> oop := suspendedCallbacks at: i.
> (objectMemory isIntegerObject: oop)
> ifFalse:[suspendedCallbacks at: i put: (objectMemory remap: oop)].
> oop := suspendedMethods at: i.
> (objectMemory isIntegerObject: oop)
> ifFalse:[suspendedMethods at: i put: (objectMemory remap: oop)].
> ].
> !
>
> Item was changed:
> ----- Method: StackInterpreter>>markAndTraceInterpreterOops: (in category 'object memory support') -----
> markAndTraceInterpreterOops: fullGCFlag
> "Mark and trace all oops in the interpreter's state."
> "Assume: All traced variables contain valid oops."
> | oop |
> "Must mark stack pages first to initialize the per-page trace
> flags for full garbage collect before any subsequent tracing."
> self markAndTraceStackPages: fullGCFlag.
> self markAndTraceTraceLog.
> self markAndTracePrimTraceLog.
> + objectMemory markAndTrace: objectMemory getSpecialObjectsOop. "also covers nilObj, trueObj, falseObj, and compact classes"
> - objectMemory markAndTrace: objectMemory specialObjectsOop. "also covers nilObj, trueObj, falseObj, and compact classes"
> (objectMemory isIntegerObject: messageSelector) ifFalse:
> [objectMemory markAndTrace: messageSelector].
> (objectMemory isIntegerObject: newMethod) ifFalse:
> [objectMemory markAndTrace: newMethod.
> objectMemory markAndTrace: lkupClass].
> self traceProfileState.
> tempOop = 0 ifFalse: [self markAndTrace: tempOop].
>
> + 1 to: objectMemory getRemapBufferCount do: [:i |
> + oop := objectMemory remapBufferAt: i.
> - 1 to: objectMemory remapBufferCount do: [:i |
> - oop := objectMemory remapBuffer at: i.
> (objectMemory isIntegerObject: oop) ifFalse: [objectMemory markAndTrace: oop]].
>
> "Callback support - trace suspended callback list"
> 1 to: jmpDepth do:[:i|
> oop := suspendedCallbacks at: i.
> (objectMemory isIntegerObject: oop) ifFalse:[objectMemory markAndTrace: oop].
> oop := suspendedMethods at: i.
> (objectMemory isIntegerObject: oop) ifFalse:[objectMemory markAndTrace: oop].
> ]!
>
> Item was changed:
> ----- Method: StackInterpreter>>okayInterpreterObjects (in category 'debug support') -----
> okayInterpreterObjects
>
> | oopOrZero oop |
> self okayFields: objectMemory nilObject.
> self okayFields: objectMemory falseObject.
> self okayFields: objectMemory trueObject.
> + self okayFields: objectMemory getSpecialObjectsOop.
> - self okayFields: objectMemory specialObjectsOop.
> self okayFields: messageSelector.
> self okayFields: newMethod.
> self okayFields: lkupClass.
> 0 to: MethodCacheEntries - 1 by: MethodCacheEntrySize do: [ :i |
> oopOrZero := methodCache at: i + MethodCacheSelector.
> oopOrZero = 0 ifFalse: [
> self okayFields: (methodCache at: i + MethodCacheSelector).
> self okayFields: (methodCache at: i + MethodCacheClass).
> self okayFields: (methodCache at: i + MethodCacheMethod).
> ].
> ].
> + 1 to: objectMemory getRemapBufferCount do: [ :i |
> + oop := objectMemory remapBufferAt: i.
> - 1 to: objectMemory remapBufferCount do: [ :i |
> - oop := objectMemory remapBuffer at: i.
> (objectMemory isIntegerObject: oop) ifFalse: [
> self okayFields: oop.
> ].
> ].
> self okayStackZone.!
>
> Item was changed:
> ----- Method: StackInterpreter>>readImageFromFile:HeapSize:StartingAt: (in category 'image save/restore') -----
> readImageFromFile: f HeapSize: desiredHeapSize StartingAt: imageOffset
> "Read an image from the given file stream, allocating the given amount of memory to its object heap. Fail if the image has an unknown format or requires more than the given amount of memory."
> "Details: This method detects when the image was stored on a machine with the opposite byte ordering from this machine and swaps the bytes automatically. Furthermore, it allows the header information to start 512 bytes into the file, since some file transfer programs for the Macintosh apparently prepend a Mac-specific header of this size. Note that this same 512 bytes of prefix area could also be used to store an exec command on Unix systems, allowing one to launch Smalltalk by invoking the image name as a command."
> "This code is based on C code by Ian Piumarta and Smalltalk code by Tim Rowledge. Many thanks to both of you!!!!"
>
> | swapBytes headerStart headerSize dataSize oldBaseAddr hdrNumStackPages
> minimumMemory memStart bytesRead bytesToShift heapSize hdrEdenBytes
> headerFlags hdrMaxExtSemTabSize |
> <var: #f type: 'sqImageFile '>
> <var: #memStart type: 'usqInt'>
> <var: #desiredHeapSize type: 'usqInt'>
> <var: #headerStart type: 'squeakFileOffsetType '>
> <var: #dataSize type: 'size_t '>
> <var: #imageOffset type: 'squeakFileOffsetType '>
>
> metaclassSizeBytes := 6 * self bytesPerWord. "guess (Metaclass instSize * BPW)"
> swapBytes := self checkImageVersionFrom: f startingAt: imageOffset.
> headerStart := (self sqImageFilePosition: f) - self bytesPerWord. "record header start position"
>
> headerSize := self getLongFromFile: f swap: swapBytes.
> dataSize := self getLongFromFile: f swap: swapBytes.
> oldBaseAddr := self getLongFromFile: f swap: swapBytes.
> + objectMemory setSpecialObjectsOop: (self getLongFromFile: f swap: swapBytes).
> + objectMemory setLastHash: (self getLongFromFile: f swap: swapBytes). "N.B. not used."
> - objectMemory specialObjectsOop: (self getLongFromFile: f swap: swapBytes).
> - objectMemory lastHash: (self getLongFromFile: f swap: swapBytes). "N.B. not used."
> savedWindowSize := self getLongFromFile: f swap: swapBytes.
> headerFlags := self getLongFromFile: f swap: swapBytes.
> self setImageHeaderFlagsFrom: headerFlags.
> extraVMMemory := self getLongFromFile: f swap: swapBytes.
> hdrNumStackPages := self getShortFromFile: f swap: swapBytes.
> "4 stack pages is small. Should be able to run with as few as
> three. 4 should be comfortable but slow. 8 is a reasonable
> default. Can be changed via vmParameterAt: 43 put: n.
> Can be set as a preference (Info.plist, VM.ini, command line etc).
> If desiredNumStackPages is already non-zero then it has been
> set as a preference. Ignore (but preserve) the header's default."
> numStackPages := desiredNumStackPages ~= 0
> ifTrue: [desiredNumStackPages]
> ifFalse: [hdrNumStackPages = 0
> ifTrue: [self defaultNumStackPages]
> ifFalse: [hdrNumStackPages]].
> desiredNumStackPages := hdrNumStackPages.
> "pad to word boundary. This slot can be used for anything else that will fit in 16 bits.
> Preserve it to be polite to images run on Cog."
> theUnknownShort := self getShortFromFile: f swap: swapBytes.
> hdrEdenBytes := self getLongFromFile: f swap: swapBytes.
> + objectMemory setEdenBytes: (desiredEdenBytes ~= 0
> - objectMemory edenBytes: (desiredEdenBytes ~= 0
> ifTrue: [desiredEdenBytes]
> ifFalse:
> [hdrEdenBytes = 0
> ifTrue: [objectMemory defaultEdenBytes]
> ifFalse: [hdrEdenBytes]]).
> desiredEdenBytes := hdrEdenBytes.
> hdrMaxExtSemTabSize := self getShortFromFile: f swap: swapBytes.
> hdrMaxExtSemTabSize ~= 0 ifTrue:
> [self setMaxExtSemSizeTo: hdrMaxExtSemTabSize].
> "decrease Squeak object heap to leave extra memory for the VM"
> heapSize := self cCode: 'reserveExtraCHeapBytes(desiredHeapSize, extraVMMemory)'.
>
> "compare memory requirements with availability".
> minimumMemory := dataSize + objectMemory edenBytes + self interpreterAllocationReserveBytes.
> heapSize < minimumMemory ifTrue:
> [self insufficientMemorySpecifiedError].
>
> "allocate a contiguous block of memory for the Squeak heap"
> + objectMemory setMemory: (self cCode: 'sqAllocateMemory(minimumMemory, heapSize)').
> + objectMemory getMemory = nil ifTrue: [self insufficientMemoryAvailableError].
> - objectMemory memory: (self cCode: 'sqAllocateMemory(minimumMemory, heapSize)').
> - objectMemory memory = nil ifTrue: [self insufficientMemoryAvailableError].
>
> memStart := objectMemory startOfMemory.
> objectMemory setMemoryLimit: (memStart + heapSize) - 24. "decrease memoryLimit a tad for safety"
> objectMemory setEndOfMemory: memStart + dataSize.
>
> "position file after the header"
> self sqImageFile: f Seek: headerStart + headerSize.
>
> "read in the image in bulk, then swap the bytes if necessary"
> bytesRead := self cCode: 'sqImageFileRead(pointerForOop(memory), sizeof(unsigned char), dataSize, f)'.
> bytesRead ~= dataSize ifTrue: [self unableToReadImageError].
>
> self ensureImageFormatIsUpToDate: swapBytes.
>
> "compute difference between old and new memory base addresses"
> bytesToShift := memStart - oldBaseAddr.
> self initializeInterpreter: bytesToShift. "adjusts all oops to new location"
> ^dataSize
> !
>
> Item was changed:
> ----- Method: StackInterpreter>>reverseBytesInImage (in category 'image save/restore') -----
> reverseBytesInImage
> "Byte-swap all words in memory after reading in the entire image file with bulk read. Contributed by Tim Rowledge."
>
> "First, byte-swap every word in the image. This fixes objects headers."
> + objectMemory reverseBytesFrom: objectMemory startOfMemory to: objectMemory getEndOfMemory.
> - objectMemory reverseBytesFrom: objectMemory startOfMemory to: objectMemory endOfMemory.
>
> "Second, return the bytes of bytes-type objects to their orginal order, and perform any
> other format conversions."
> + self updateObjectsPostByteSwapFrom: objectMemory firstObject to: objectMemory getEndOfMemory!
> - self updateObjectsPostByteSwapFrom: objectMemory firstObject to: objectMemory endOfMemory!
>
> Item was changed:
> ----- Method: StackInterpreter>>setSignalLowSpaceFlagAndSaveProcess (in category 'process primitive support') -----
> setSignalLowSpaceFlagAndSaveProcess
> "The low space semaphore is about to be signaled. Set the signalLowSpace flag,
> and force an interrupt check. Save the currently active process in the special
> objects array so that the low space handler will be able to determine the process
> that first triggered a low space condition. The image's low space handler is expected
> to nil out the special objects array slot when it handles the low space condition."
>
> | lastSavedProcess activeProc |
> <inline: false>
> DumpStackOnLowSpace ~= 0 ifTrue:
> [self printCallStack.
> self printAllStacks].
> + objectMemory setSignalLowSpace: true.
> + objectMemory setLowSpaceThreshold: 0. "disable additional interrupts until lowSpaceThreshold is reset by image"
> - objectMemory signalLowSpace: true.
> - objectMemory lowSpaceThreshold: 0. "disable additional interrupts until lowSpaceThreshold is reset by image"
> lastSavedProcess := objectMemory splObj: ProcessSignalingLowSpace.
> lastSavedProcess = objectMemory nilObject ifTrue:
> [activeProc := self activeProcess.
> objectMemory splObj: ProcessSignalingLowSpace put: activeProc].
> self forceInterruptCheck!
>
> Item was changed:
> ----- Method: StackInterpreter>>storeAndPopReceiverVariableBytecode (in category 'stack bytecodes') -----
> storeAndPopReceiverVariableBytecode
> "Note: This code uses
> storePointerUnchecked:ofObject:withValue: and does the
> store check explicitely in order to help the translator
> produce better code."
> | rcvr top |
> rcvr := self receiver.
> top := self internalStackTop.
> + (self oop: rcvr isLessThan: objectMemory getYoungStart) ifTrue:
> - (self oop: rcvr isLessThan: objectMemory youngStart) ifTrue:
> [objectMemory possibleRootStoreInto: rcvr value: top].
> objectMemory storePointerUnchecked: (currentBytecode bitAnd: 7) ofObject: rcvr withValue: top.
> self fetchNextBytecode.
> self internalPop: 1!
>
> Item was changed:
> ----- Method: StackInterpreter>>writeImageFileIO: (in category 'image save/restore') -----
> writeImageFileIO: imageBytes
>
> | headerStart headerSize f bytesWritten sCWIfn okToWrite memStart |
> <var: #f type: 'sqImageFile'>
> <var: #headerStart type: 'squeakFileOffsetType '>
> <var: #sCWIfn type: 'void *'>
>
> "If the security plugin can be loaded, use it to check for write permission.
> If not, assume it's ok"
> sCWIfn := self ioLoadFunction: 'secCanWriteImage' From: 'SecurityPlugin'.
> sCWIfn ~= 0 ifTrue:
> [okToWrite := self cCode: '((sqInt (*)(void))sCWIfn)()'.
> okToWrite ifFalse:[^self primitiveFail]].
>
> "local constants"
> headerStart := 0.
> headerSize := 64. "header size in bytes; do not change!!"
>
> f := self cCode: 'sqImageFileOpen(imageName, "wb")'.
> f = nil ifTrue: "could not open the image file for writing"
> [^self primitiveFail].
>
> headerStart := self cCode: 'sqImageFileStartLocation(f,imageName,headerSize+imageBytes)'.
> self cCode: '/* Note: on Unix systems one could put an exec command here, padded to 512 bytes */'.
> "position file to start of header"
> self sqImageFile: f Seek: headerStart.
>
> self putLong: self imageFormatVersion toFile: f.
> self putLong: headerSize toFile: f.
> self putLong: imageBytes toFile: f.
> self putLong: objectMemory startOfMemory toFile: f.
> + self putLong: objectMemory getSpecialObjectsOop toFile: f.
> - self putLong: objectMemory specialObjectsOop toFile: f.
> self putLong: objectMemory newObjectHash toFile: f.
> self putLong: self ioScreenSize toFile: f.
> self putLong: self getImageHeaderFlags toFile: f.
> self putLong: extraVMMemory toFile: f.
> self putShort: desiredNumStackPages toFile: f.
> self putShort: self unknownShortOrCodeSizeInKs toFile: f.
> self putLong: desiredEdenBytes toFile: f.
> self putShort: (maxExtSemTabSizeSet ifTrue: [self ioGetMaxExtSemTableSize] ifFalse: [0]) toFile: f.
> self putShort: 0 toFile: f.
> 1 to: 4 do: [:i | self putLong: 0 toFile: f]. "fill remaining header words with zeros"
> self successful ifFalse: [
> "file write or seek failure"
> self cCode: 'sqImageFileClose(f)'.
> ^ nil].
>
> "position file after the header"
> self sqImageFile: f Seek: headerStart + headerSize.
>
> "write the image data"
> memStart := objectMemory startOfMemory.
> bytesWritten := self cCode: 'sqImageFileWrite(pointerForOop(memStart), sizeof(unsigned char), imageBytes, f)'.
> self success: bytesWritten = imageBytes.
> self touch: memStart.
> self cCode: 'sqImageFileClose(f)'
> !
>
> Item was changed:
> ----- Method: StackInterpreterPrimitives>>primitiveSetGCSemaphore (in category 'memory space primitives') -----
> primitiveSetGCSemaphore
> "Primitive. Indicate the semaphore to be signalled for upon garbage collection"
> | index |
> <export: true>
> index := self stackIntegerValue: 0.
> self successful ifTrue:[
> + objectMemory setGcSemaphoreIndex: index.
> - gcSemaphoreIndex := index.
> self pop: argumentCount.
> ]!
>
> 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 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 getSpecialObjectsOop
> - 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 fetchClassOfNonInt: sema) = (objectMemory splObj: ClassSemaphore)
> ifTrue:
> [objectMemory splObj: TheTimerSemaphore put: sema.
> nextWakeupUsecs := usecs]
> ifFalse:
> [objectMemory
> storePointer: TheTimerSemaphore
> + ofObject: objectMemory getSpecialObjectsOop
> - ofObject: objectMemory specialObjectsOop
> withValue: objectMemory nilObject.
> nextWakeupUsecs := 0].
> self pop: 2!
>
> Item was changed:
> ----- Method: StackInterpreterPrimitives>>primitiveVMParameter (in category 'system control primitives') -----
> (excessive size, no diff calculated)
>
> Item was changed:
> ----- Method: StackInterpreterSimulator>>allObjectsDo: (in category 'debug support') -----
> allObjectsDo: objBlock
>
> | oop |
> oop := objectMemory firstObject.
> + [oop < objectMemory getEndOfMemory] whileTrue:
> - [oop < objectMemory endOfMemory] whileTrue:
> [(objectMemory isFreeObject: oop)
> ifFalse: [objBlock value: oop].
> oop := objectMemory objectAfter: oop].
> !
>
> Item was changed:
> ----- Method: StackInterpreterSimulator>>allObjectsSelect: (in category 'debug support') -----
> allObjectsSelect: objBlock
> "self allObjectsSelect: [:oop | (self baseHeader: oop) = 1234]"
>
> | oop selected |
> oop := objectMemory firstObject.
> selected := OrderedCollection new.
> + [oop < objectMemory getEndOfMemory] whileTrue:
> - [oop < objectMemory endOfMemory] whileTrue:
> [(objectMemory isFreeObject: oop)
> ifFalse: [(objBlock value: oop) ifTrue: [selected addLast: oop]].
> oop := objectMemory objectAfter: oop].
> ^ selected!
>
> Item was changed:
> ----- Method: StackInterpreterSimulator>>convertToArray (in category 'initialization') -----
> convertToArray
> "I dont believe it -- this *just works*"
>
> + objectMemory setMemory: (objectMemory getMemory as: Array)!
> - objectMemory memory: (objectMemory memory as: Array)!
>
> Item was changed:
> ----- Method: StackInterpreterSimulator>>initialize (in category 'initialization') -----
> initialize
> "Initialize the StackInterpreterSimulator when running the interpreter
> inside Smalltalk. The primary responsibility of this method is to allocate
> Smalltalk Arrays for variables that will be declared as statically-allocated
> global arrays in the translated code."
>
> | objectMemoryClass |
>
> "initialize class variables"
> objectMemory ifNotNil:
> [^self halt].
>
> objectMemoryClass := self class objectMemoryClass.
>
> objectMemoryClass initBytesPerWord: objectMemoryClass bytesPerWord.
> objectMemoryClass initialize.
> StackInterpreter initialize.
>
> super initialize.
> objectMemory := objectMemoryClass simulatorClass new.
> objectMemory coInterpreter: self.
>
> "Note: we must initialize ConstMinusOne differently for simulation,
> due to the fact that the simulator works only with +ve 32-bit values"
> ConstMinusOne := objectMemory integerObjectOf: -1.
>
> methodCache := Array new: MethodCacheSize.
> atCache := Array new: AtCacheTotalSize.
> self flushMethodCache.
> self flushAtCache.
> + objectMemory setGcSemaphoreIndex: 0.
> - gcSemaphoreIndex := 0.
> externalSemaphoreSignalRequests := externalSemaphoreSignalResponses := #().
> externalPrimitiveTable := CArrayAccessor on: (Array new: MaxExternalPrimitiveTableSize).
> externalPrimitiveTableFirstFreeIndex := 0.
> primitiveTable := self class primitiveTable copy.
> pluginList := #().
> mappedPluginEntries := #().
> desiredNumStackPages := desiredEdenBytes := 0.
> startMicroseconds := Time totalSeconds * 1000000.
>
> "initialize InterpreterSimulator variables used for debugging"
> byteCount := 0.
> sendCount := 0.
> quitBlock := [^ self].
> traceOn := true.
> printSends := printReturns := printFrameAtEachStep := printBytecodeAtEachStep := false.
> myBitBlt := BitBltSimulator new setInterpreter: self.
> transcript := Transcript.
> displayForm := 'Display has not yet been installed' asDisplayText form.
> suppressHeartbeatFlag := false.
> extSemTabSize := 256.
> disableBooleanCheat := false!
>
> Item was changed:
> ----- Method: StackInterpreterSimulator>>integerAt: (in category 'memory access') -----
> integerAt: byteAddress
> "Note: Adjusted for Smalltalk's 1-based array indexing."
>
> + ^objectMemory getMemory integerAt: (byteAddress // 4) + 1!
> - ^objectMemory memory integerAt: (byteAddress // 4) + 1!
>
> Item was changed:
> ----- Method: StackInterpreterSimulator>>integerAt:put: (in category 'memory access') -----
> integerAt: byteAddress put: a32BitValue
> "Note: Adjusted for Smalltalk's 1-based array indexing."
>
> + ^objectMemory getMemory integerAt: (byteAddress // 4) + 1 put: a32BitValue!
> - ^objectMemory memory integerAt: (byteAddress // 4) + 1 put: a32BitValue!
>
> Item was changed:
> ----- Method: StackInterpreterSimulator>>objectBefore: (in category 'testing') -----
> objectBefore: addr
> | oop prev |
> oop := objectMemory firstObject.
> + [oop < objectMemory getEndOfMemory] whileTrue:
> - [oop < objectMemory endOfMemory] whileTrue:
> [prev := oop. "look here if debugging prev obj overlapping this one"
> oop := objectMemory objectAfter: oop.
> oop >= addr ifTrue: [^ prev]].
> ^0!
>
> Item was changed:
> ----- Method: StackInterpreterSimulator>>openOn:extraMemory: (in category 'initialization') -----
> openOn: fileName extraMemory: extraBytes
> "InterpreterSimulator new openOn: 'clone.im' extraMemory: 100000"
>
> | f version headerSize count oldBaseAddr bytesToShift swapBytes
> hdrNumStackPages hdrEdenBytes headerFlags |
> "open image file and read the header"
>
> ["begin ensure block..."
> f := FileStream readOnlyFileNamed: fileName.
> imageName := f fullName.
> f binary.
> version := self nextLongFrom: f. "current version: 16r1968 (=6504) vive la revolucion!!"
> (self readableFormat: version)
> ifTrue: [swapBytes := false]
> ifFalse: [(version := objectMemory byteSwapped: version) = self imageFormatVersion
> ifTrue: [swapBytes := true]
> ifFalse: [self error: 'incomaptible image format']].
> headerSize := self nextLongFrom: f swap: swapBytes.
> objectMemory setEndOfMemory: (self nextLongFrom: f swap: swapBytes). "first unused location in heap"
> oldBaseAddr := self nextLongFrom: f swap: swapBytes. "object memory base address of image"
> + objectMemory setSpecialObjectsOop: (self nextLongFrom: f swap: swapBytes).
> + objectMemory setLastHash: (self nextLongFrom: f swap: swapBytes). "Should be loaded from, and saved to the image header"
> - objectMemory specialObjectsOop: (self nextLongFrom: f swap: swapBytes).
> - objectMemory lastHash: (self nextLongFrom: f swap: swapBytes). "Should be loaded from, and saved to the image header"
>
> savedWindowSize := self nextLongFrom: f swap: swapBytes.
> headerFlags := self nextLongFrom: f swap: swapBytes.
> self setImageHeaderFlagsFrom: headerFlags.
> extraVMMemory := self nextLongFrom: f swap: swapBytes.
> hdrNumStackPages := self nextShortFrom: f swap: swapBytes.
> "4 stack pages is small. Should be able to run with as few as
> three. 4 should be comfortable but slow. 8 is a reasonable
> default. Can be changed via vmParameterAt: 43 put: n"
> numStackPages := desiredNumStackPages ~= 0
> ifTrue: [desiredNumStackPages]
> ifFalse: [hdrNumStackPages = 0
> ifTrue: [self defaultNumStackPages]
> ifFalse: [hdrNumStackPages]].
> desiredNumStackPages := hdrNumStackPages.
> stackPages := self stackPagesClass new. "Temporary for computeStackZoneSize"
> "pad to word boundary. This slot can be used for anything else that will fit in 16 bits.
> Preserve it to be polite to images run on Cog."
> theUnknownShort := self getShortFromFile: f swap: swapBytes.
> hdrEdenBytes := self nextLongFrom: f swap: swapBytes.
> + objectMemory setEdenBytes: (hdrEdenBytes = 0
> - objectMemory edenBytes: (hdrEdenBytes = 0
> ifTrue: [objectMemory defaultEdenBytes]
> ifFalse: [hdrEdenBytes]).
> desiredEdenBytes := hdrEdenBytes.
> "allocate interpreter memory"
> + objectMemory setMemoryLimit: objectMemory getEndOfMemory + extraBytes + objectMemory edenBytes + self interpreterAllocationReserveBytes.
> - objectMemory setMemoryLimit: objectMemory endOfMemory + extraBytes + objectMemory edenBytes + self interpreterAllocationReserveBytes.
>
> "read in the image in bulk, then swap the bytes if necessary"
> f position: headerSize.
> + objectMemory setMemory: (Bitmap new: objectMemory getMemoryLimit // 4).
> + count := f readInto: objectMemory getMemory startingAt: 1 count: objectMemory getEndOfMemory // 4.
> + count ~= (objectMemory getEndOfMemory // 4) ifTrue: [self halt].
> - objectMemory memory: (Bitmap new: objectMemory memoryLimit // 4).
> - count := f readInto: objectMemory memory startingAt: 1 count: objectMemory endOfMemory // 4.
> - count ~= (objectMemory endOfMemory // 4) ifTrue: [self halt].
> ]
> ensure: [f close].
>
> self ensureImageFormatIsUpToDate: swapBytes.
>
> objectMemory initialize.
> bytesToShift := objectMemory startOfMemory - oldBaseAddr. "adjust pointers for zero base address"
> Utilities informUser: 'Relocating object pointers...'
> during: [self initializeInterpreter: bytesToShift].
> !
>
> Item was changed:
> ----- Method: StackInterpreterSimulator>>reverseBytesFrom:to: (in category 'initialization') -----
> reverseBytesFrom: begin to: end
> "Byte-swap the given range of memory (not inclusive!!)."
> | wordAddr |
> wordAddr := begin.
> + objectMemory getMemory swapBytesFrom: wordAddr // 4 + 1 to: end // 4!
> - objectMemory memory swapBytesFrom: wordAddr // 4 + 1 to: end // 4!
>
> Item was changed:
> ----- Method: StackInterpreterSimulator>>showDisplayBits:w:h:d:left:right:top:bottom: (in category 'I/O primitives') -----
> showDisplayBits: destBits w: w h: h d: d left: left right: right top: top bottom: bottom
> | raster pixPerWord simDisp realDisp rect |
> pixPerWord := 32 // d.
> raster := displayForm width + (pixPerWord - 1) // pixPerWord.
> + simDisp := Form new hackBits: objectMemory getMemory.
> - simDisp := Form new hackBits: objectMemory memory.
> displayForm unhibernate.
> realDisp := Form new hackBits: displayForm bits.
> realDisp
> copy: (0 @ (top * raster) extent: 4 @ (bottom - top * raster))
> from: 0 @ (destBits // 4 + (top * raster))
> in: simDisp
> rule: Form over.
> displayView ifNotNil: [^ displayView changed].
>
> "If running without a view, just blat the bits onto the screen..."
> rect := 0 @ top corner: displayForm width @ bottom.
> Display
> copy: (rect translateBy: self displayLocation)
> from: rect topLeft
> in: displayForm
> rule: Form over!
>
> Item was changed:
> ----- Method: StackInterpreterSimulator>>sqGrowMemory:By: (in category 'memory access') -----
> sqGrowMemory: oldLimit By: delta
>
> transcript show: 'grow memory from ', oldLimit printString, ' by ', delta printString; cr.
> + objectMemory setMemory: objectMemory getMemory , (objectMemory getMemory class new: delta // 4).
> + ^ objectMemory getMemory size * 4!
> - objectMemory memory: objectMemory memory , (objectMemory memory class new: delta // 4).
> - ^ objectMemory memory size * 4!
>
> Item was changed:
> ----- Method: StackInterpreterSimulator>>validOop: (in category 'testing') -----
> validOop: oop
> " Return true if oop appears to be valid "
> (oop bitAnd: 1) = 1 ifTrue: [^ true]. "Integer"
> (oop bitAnd: 3) = 0 ifFalse: [^ false]. "Uneven address"
> + oop >= objectMemory getEndOfMemory ifTrue: [^ false]. "Out of range"
> - oop >= objectMemory endOfMemory ifTrue: [^ false]. "Out of range"
> "could test if within the first large freeblock"
> (self longAt: oop) = 4 ifTrue: [^ false].
> (objectMemory headerType: oop) = 2 ifTrue: [^ false]. "Free object"
> ^ true!
>
> Item was changed:
> ----- Method: StackInterpreterSimulator>>writeEnableMemory (in category 'debug printing') -----
> writeEnableMemory
> + objectMemory setMemory: objectMemory getMemory array!
> - objectMemory memory: objectMemory memory array!
>
> Item was changed:
> ----- Method: StackInterpreterSimulator>>writeImageFileIO: (in category 'image save/restore') -----
> writeImageFileIO: numberOfBytesToWrite
> "Actually emit the first numberOfBytesToWrite object memory bytes onto the snapshot."
>
> | headerSize file |
> BytesPerWord = 4 ifFalse: [self error: 'Not rewritten for 64 bits yet'].
> headerSize := 64.
>
> [
> file := (FileStream fileNamed: imageName) binary.
> file == nil ifTrue: [^nil].
>
> {
> self imageFormatVersion.
> headerSize.
> numberOfBytesToWrite.
> objectMemory startOfMemory.
> + (objectMemory getSpecialObjectsOop).
> + (objectMemory getLastHash).
> - (objectMemory specialObjectsOop).
> - (objectMemory lastHash).
> self ioScreenSize.
> fullScreenFlag.
> extraVMMemory
> }
> do: [:long | self putLong: long toFile: file].
>
> { desiredNumStackPages. self unknownShortOrCodeSizeInKs } do:
> [:short| self putShort: short toFile: file].
>
> self putLong: desiredEdenBytes toFile: file.
>
> { maxExtSemTabSizeSet ifTrue: [self ioGetMaxExtSemTableSize] ifFalse: [0]. 0 } do:
> [:short| self putShort: short toFile: file].
>
> "Pad the rest of the header."
> 4 timesRepeat: [self putLong: 0 toFile: file].
>
> "Position the file after the header."
> file position: headerSize.
>
> "Write the object memory."
> objectMemory startOfMemory // 4 + 1
> to: numberOfBytesToWrite // 4
> do: [:index |
> self
> + putLong: (objectMemory getMemory at: index)
> - putLong: (objectMemory memory at: index)
> toFile: file].
>
> self success: true
> ]
> ensure: [file close]!
>
> Item was changed:
> ----- Method: StackInterpreterSimulator>>writeProtectMemory (in category 'debug printing') -----
> writeProtectMemory
> + objectMemory setMemory: (ReadOnlyArrayWrapper around: objectMemory getMemory)!
> - objectMemory memory: (ReadOnlyArrayWrapper around: objectMemory memory)!
>
> Item was changed:
> ----- Method: VMMaker class>>versionString (in category 'version testing') -----
> versionString
>
> "VMMaker versionString"
>
> + ^'4.13.3'!
> - ^'4.13.2'!
>
More information about the Vm-dev
mailing list