[Vm-dev] VM Maker: VMMaker-dtl.320.mcz
commits at source.squeak.org
commits at source.squeak.org
Wed May 8 12:27:14 UTC 2013
David T. Lewis uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker-dtl.320.mcz
==================== Summary ====================
Name: VMMaker-dtl.320
Author: dtl
Time: 8 May 2013, 8:25:32.706 am
UUID: 22da50b8-8c42-4462-9635-e2f251916442
Ancestors: VMMaker-dtl.319
VMMaker 4.12.4
Move lengthOf: from interpreter to object memory, and update senders.
Move numObjects, allObjectsDo: and allObjectsSelect: to object memory.
Add InterpreterSimulator>>objectMemory to facilitate tracing.
Update InterpreterStackPages from oscog, changing BytesPerWord references to self bytesPerWord.
Update InterpreterPrimitives class comment from oscog.
Remove obsolete comments in InterpreterPrimitives>>failed and InterpreterPrimivies>>successful.
In primitiveUtcWithOffset, allow caller to provide a pre-allocated result array to eliminate possible GC in the time primitive.
=============== Diff against VMMaker-dtl.319 ===============
Item was changed:
----- Method: ClassicObjectMemory>>oopHasAcceptableClass: (in category 'image segment in/out') -----
oopHasAcceptableClass: signedOop
"Similar to oopHasOkayClass:, except that it only returns true or false."
| oopClass formatMask behaviorFormatBits oopFormatBits oop |
<var: #oop type: 'usqInt'>
<var: #oopClass type: 'usqInt'>
(self isIntegerObject: signedOop) ifTrue: [^ true].
oop := self cCoerce: signedOop to: 'usqInt'.
oop < endOfMemory ifFalse: [^ false].
((oop \\ self bytesPerWord) = 0) ifFalse: [^ false].
(oop + (self sizeBitsOf: oop)) < endOfMemory ifFalse: [^ false].
oopClass := self cCoerce: (self fetchClassOf: oop) to: 'usqInt'.
(self isIntegerObject: oopClass) ifTrue: [^ false].
(oopClass < endOfMemory) ifFalse: [^ false].
((oopClass \\ self bytesPerWord) = 0) ifFalse: [^ false].
(oopClass + (self sizeBitsOf: oopClass)) < endOfMemory ifFalse: [^ false].
+ ((self isPointers: oopClass) and: [(self lengthOf: oopClass) >= 3]) ifFalse: [^ false].
- ((self isPointers: oopClass) and: [(interpreter lengthOf: oopClass) >= 3]) ifFalse: [^ false].
(self isBytes: oop)
ifTrue: [ formatMask := 16rC00 ] "ignore extra bytes size bits"
ifFalse: [ formatMask := 16rF00 ].
behaviorFormatBits := (self formatOfClass: oopClass) bitAnd: formatMask.
oopFormatBits := (self baseHeader: oop) bitAnd: formatMask.
behaviorFormatBits = oopFormatBits ifFalse: [^ false].
^ true!
Item was changed:
----- Method: FilePluginSimulator>>fileValueOf: (in category 'simulation') -----
fileValueOf: objectPointer
| index |
index := (interpreterProxy isIntegerObject: objectPointer)
ifTrue: [interpreterProxy integerValueOf: objectPointer]
ifFalse:
[((interpreterProxy isBytes: objectPointer)
+ and: [(interpreterProxy byteSizeOf: objectPointer) = self bytesPerWord]) ifFalse:
- and: [(interpreterProxy byteSizeOf: objectPointer) = BytesPerWord]) ifFalse:
[interpreterProxy primitiveFail.
^nil].
+ interpreterProxy longAt: objectPointer + self baseHeaderSize].
- interpreterProxy longAt: objectPointer + BaseHeaderSize].
^openFiles at: index!
Item was changed:
----- Method: Interpreter>>classNameOf:Is: (in category 'plugin primitive support') -----
classNameOf: aClass Is: className
"Check if aClass's name is className"
| srcName name length |
<var: #className type: 'char *'>
<var: #srcName type: 'char *'>
+ (objectMemory lengthOf: aClass) <= 6 ifTrue: [^ false].
- (self lengthOf: aClass) <= 6 ifTrue: [^ false].
"Not a class but might be behavior"
name := objectMemory fetchPointer: 6 ofObject: aClass.
(objectMemory isBytes: name) ifFalse: [^ false].
length := self stSizeOf: name.
srcName := self cCoerce: (self arrayValueOf: name) to: 'char *'.
0 to: length - 1 do: [:i | (srcName at: i) = (className at: i) ifFalse: [^ false]].
"Check if className really ends at this point"
^ (className at: length) = 0!
Item was changed:
----- Method: Interpreter>>displayBitsOf:Left:Top:Right:Bottom: (in category 'I/O primitives') -----
displayBitsOf: aForm Left: l Top: t Right: r Bottom: b
"Repaint the portion of the Smalltalk screen bounded by the affected rectangle. Used to synchronize the screen after a Bitblt to the Smalltalk Display object."
| displayObj dispBits w h dispBitsIndex d left right top bottom surfaceHandle |
displayObj := objectMemory splObj: TheDisplay.
aForm = displayObj ifFalse: [^ nil].
+ self success: ((objectMemory isPointers: displayObj) and: [(objectMemory lengthOf: displayObj) >= 4]).
- self success: ((objectMemory isPointers: displayObj) and: [(self lengthOf: displayObj) >= 4]).
self successful ifTrue: [
dispBits := objectMemory fetchPointer: 0 ofObject: displayObj.
w := self fetchInteger: 1 ofObject: displayObj.
h := self fetchInteger: 2 ofObject: displayObj.
d := self fetchInteger: 3 ofObject: displayObj.
].
l < 0 ifTrue:[left := 0] ifFalse: [left := l].
r > w ifTrue: [right := w] ifFalse: [right := r].
t < 0 ifTrue: [top := 0] ifFalse: [top := t].
b > h ifTrue: [bottom := h] ifFalse: [bottom := b].
((left <= right) and: [top <= bottom]) ifFalse: [^nil].
self successful ifTrue: [
(objectMemory isIntegerObject: dispBits) ifTrue: [
surfaceHandle := objectMemory integerValueOf: dispBits.
showSurfaceFn = 0 ifTrue: [
showSurfaceFn := self ioLoadFunction: 'ioShowSurface' From: 'SurfacePlugin'.
showSurfaceFn = 0 ifTrue: [^self success: false]].
self cCode:'((sqInt (*)(sqInt, sqInt, sqInt, sqInt, sqInt))showSurfaceFn)(surfaceHandle, left, top, right-left, bottom-top)'.
] ifFalse: [
dispBitsIndex := dispBits + objectMemory baseHeaderSize. "index in memory byte array"
self cCode: 'ioShowDisplay(dispBitsIndex, w, h, d, left, right, top, bottom)'
inSmalltalk: [self showDisplayBits: dispBitsIndex
w: w h: h d: d
left: left right: right top: top bottom: bottom]
].
].!
Item was changed:
----- Method: Interpreter>>flushExternalPrimitiveOf: (in category 'plugin primitive support') -----
flushExternalPrimitiveOf: methodPtr
"methodPtr is a CompiledMethod containing an external primitive. Flush the function address and session ID of the CM"
| lit |
(self literalCountOf: methodPtr) > 0 ifFalse:[^nil]. "Something's broken"
lit := self literal: 0 ofMethod: methodPtr.
+ ((objectMemory isArray: lit) and:[(objectMemory lengthOf: lit) = 4])
- ((objectMemory isArray: lit) and:[(self lengthOf: lit) = 4])
ifFalse:[^nil]. "Something's broken"
"ConstZero is a known SmallInt so no root check needed"
objectMemory storePointerUnchecked: 2 ofObject: lit withValue: ConstZero.
objectMemory storePointerUnchecked: 3 ofObject: lit withValue: ConstZero.
!
Item was changed:
----- Method: Interpreter>>fullDisplayUpdate (in category 'I/O primitive support') -----
fullDisplayUpdate
"Repaint the entire smalltalk screen, ignoring the affected rectangle. Used in some platform's code when the Smalltalk window is brought to the front or uncovered."
| displayObj w h |
displayObj := objectMemory splObj: TheDisplay.
+ ((objectMemory isPointers: displayObj) and: [(objectMemory lengthOf: displayObj) >= 4]) ifTrue: [
- ((objectMemory isPointers: displayObj) and: [(self lengthOf: displayObj) >= 4]) ifTrue: [
w := self fetchInteger: 1 ofObject: displayObj.
h := self fetchInteger: 2 ofObject: displayObj.
self displayBitsOf: displayObj Left: 0 Top: 0 Right: w Bottom: h.
self ioForceDisplayUpdate].
!
Item was removed:
- ----- Method: Interpreter>>lengthOf: (in category 'array primitive support') -----
- lengthOf: oop
- "Return the number of indexable bytes or words in the given object. Assume the argument is not an integer. For a CompiledMethod, the size of the method header (in bytes) should be subtracted from the result."
-
- | header |
- <inline: true>
- header := objectMemory baseHeader: oop.
- ^ self lengthOf: oop baseHeader: header format: ((header >> 8) bitAnd: 16rF)!
Item was removed:
- ----- Method: Interpreter>>lengthOf:baseHeader:format: (in category 'array primitive support') -----
- lengthOf: oop baseHeader: hdr format: fmt
- "Return the number of indexable bytes or words in the given object. Assume the given oop is not an integer. For a CompiledMethod, the size of the method header (in bytes) should be subtracted from the result of this method."
-
- | sz |
- <inline: true>
- (hdr bitAnd: TypeMask) = HeaderTypeSizeAndClass
- ifTrue: [ sz := (objectMemory sizeHeader: oop) bitAnd: objectMemory longSizeMask ]
- ifFalse: [ sz := (hdr bitAnd: objectMemory sizeMask)].
- sz := sz - (hdr bitAnd: objectMemory size4Bit).
- fmt <= 4
- ifTrue: [ ^ (sz - objectMemory baseHeaderSize) >> objectMemory shiftForWord "words"].
- fmt < 8
- ifTrue: [ ^ (sz - objectMemory baseHeaderSize) >> 2 "32-bit longs"]
- ifFalse: [ ^ (sz - objectMemory baseHeaderSize) - (fmt bitAnd: 3) "bytes"]!
Item was changed:
----- Method: Interpreter>>okayFields: (in category 'debug support') -----
okayFields: oop
"If this is a pointers object, check that its fields are all okay oops."
| i fieldOop c |
(oop = nil or: [oop = 0]) ifTrue: [ ^true ].
(objectMemory isIntegerObject: oop) ifTrue: [ ^true ].
objectMemory okayOop: oop.
self oopHasOkayClass: oop.
(objectMemory isPointers: oop) ifFalse: [ ^true ].
c := objectMemory fetchClassOf: oop.
(c = (objectMemory splObj: ClassMethodContext)
or: [c = (objectMemory splObj: ClassBlockContext)])
ifTrue: [i := CtxtTempFrameStart + (self fetchStackPointerOf: oop) - 1]
+ ifFalse: [i := (objectMemory lengthOf: oop) - 1].
- ifFalse: [i := (self lengthOf: oop) - 1].
[i >= 0] whileTrue: [
fieldOop := objectMemory fetchPointer: i ofObject: oop.
(objectMemory isIntegerObject: fieldOop) ifFalse: [
objectMemory okayOop: fieldOop.
self oopHasOkayClass: fieldOop.
].
i := i - 1.
].!
Item was changed:
----- Method: Interpreter>>oopHasOkayClass: (in category 'debug support') -----
oopHasOkayClass: signedOop
"Attempt to verify that the given oop has a reasonable behavior. The class must be a valid, non-integer oop and must not be nilObj. It must be a pointers object with three or more fields. Finally, the instance specification field of the behavior must match that of the instance."
| oop oopClass formatMask behaviorFormatBits oopFormatBits |
<var: #oop type: 'usqInt'>
<var: #oopClass type: 'usqInt'>
oop := self cCoerce: signedOop to: 'usqInt'.
objectMemory okayOop: oop.
oopClass := self cCoerce: (objectMemory fetchClassOf: oop) to: 'usqInt'.
(objectMemory isIntegerObject: oopClass)
ifTrue: [ self error: 'a SmallInteger is not a valid class or behavior' ].
objectMemory okayOop: oopClass.
+ ((objectMemory isPointers: oopClass) and: [(objectMemory lengthOf: oopClass) >= 3])
- ((objectMemory isPointers: oopClass) and: [(self lengthOf: oopClass) >= 3])
ifFalse: [ self error: 'a class (behavior) must be a pointers object of size >= 3' ].
(objectMemory isBytes: oop)
ifTrue: [ formatMask := 16rC00 ] "ignore extra bytes size bits"
ifFalse: [ formatMask := 16rF00 ].
behaviorFormatBits := (objectMemory formatOfClass: oopClass) bitAnd: formatMask.
oopFormatBits := (objectMemory baseHeader: oop) bitAnd: formatMask.
behaviorFormatBits = oopFormatBits
ifFalse: [ self error: 'object and its class (behavior) formats differ' ].
^true!
Item was changed:
----- Method: Interpreter>>primitiveAtEnd (in category 'deprecated - array and stream primitives') -----
primitiveAtEnd
"nb: This primitive was previously installed as primitive 67, but is no
longer in use."
| stream index limit |
stream := self popStack.
((objectMemory isPointers: stream)
+ and: [(objectMemory lengthOf: stream) >= (StreamReadLimitIndex+1)])
- and: [(self lengthOf: stream) >= (StreamReadLimitIndex+1)])
ifTrue: [index := self fetchInteger: StreamIndexIndex ofObject: stream.
limit := self fetchInteger: StreamReadLimitIndex ofObject: stream]
ifFalse: [self primitiveFail].
self successful
ifTrue: [self pushBool: (index >= limit)]
ifFalse: [self unPop: 1].!
Item was changed:
----- Method: Interpreter>>primitiveCopyObject (in category 'object access primitives') -----
primitiveCopyObject
"Primitive. Copy the state of the receiver from the argument.
Fail if receiver and argument are of a different class.
Fail if the receiver or argument are non-pointer objects.
Fail if receiver and argument have different lengths (for indexable objects).
"
| rcvr arg length |
self methodArgumentCount = 1 ifFalse:[^self primitiveFail].
arg := self stackObjectValue: 0.
rcvr := self stackObjectValue: 1.
self failed ifTrue:[^nil].
(objectMemory isPointers: rcvr) ifFalse:[^self primitiveFail].
(objectMemory fetchClassOf: rcvr) = (objectMemory fetchClassOf: arg) ifFalse:[^self primitiveFail].
+ length := objectMemory lengthOf: rcvr.
+ length = (objectMemory lengthOf: arg) ifFalse:[^self primitiveFail].
- length := self lengthOf: rcvr.
- length = (self lengthOf: arg) ifFalse:[^self primitiveFail].
"Now copy the elements"
0 to: length-1 do:[:i|
objectMemory storePointer: i ofObject: rcvr withValue: (objectMemory fetchPointer: i ofObject: arg)].
"Note: The above could be faster for young receivers but I don't think it'll matter"
self pop: 1. "pop arg; answer receiver"
!
Item was changed:
----- Method: 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 success: ((objectMemory isArray: lit) and: [(self 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 nilObj
ifTrue: [moduleLength := 0]
ifFalse: [self success: (objectMemory isBytes: moduleName).
+ moduleLength := objectMemory lengthOf: moduleName.
- moduleLength := self 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.
- functionLength := self 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>>primitiveNext (in category 'deprecated - array and stream primitives') -----
primitiveNext
"PrimitiveNext will succeed only if the stream's array is in the atCache.
Otherwise failure will lead to proper message lookup of at: and
subsequent installation in the cache if appropriate.
nb: This primitive was previously installed as primitive 65, but is no
longer in use."
| stream array index limit result atIx |
stream := self stackTop.
((objectMemory isPointers: stream)
+ and: [(objectMemory lengthOf: stream) >= (StreamReadLimitIndex + 1)])
- and: [(self lengthOf: stream) >= (StreamReadLimitIndex + 1)])
ifFalse: [^ self primitiveFail].
array := objectMemory fetchPointer: StreamArrayIndex ofObject: stream.
index := self fetchInteger: StreamIndexIndex ofObject: stream.
limit := self fetchInteger: StreamReadLimitIndex ofObject: stream.
atIx := array bitAnd: AtCacheMask.
(index < limit and: [(atCache at: atIx+AtCacheOop) = array])
ifFalse: [^ self primitiveFail].
"OK -- its not at end, and the array is in the cache"
index := index + 1.
result := self commonVariable: array at: index cacheIndex: atIx.
"Above may cause GC, so can't use stream, array etc. below it"
self successful ifTrue:
[stream := self stackTop.
self storeInteger: StreamIndexIndex ofObject: stream withValue: index.
^ self pop: 1 thenPush: result].
!
Item was changed:
----- Method: Interpreter>>primitiveNextPut (in category 'deprecated - array and stream primitives') -----
primitiveNextPut
"PrimitiveNextPut will succeed only if the stream's array is in the atPutCache.
Otherwise failure will lead to proper message lookup of at:put: and
subsequent installation in the cache if appropriate.
nb: This primitive was previously installed as primitive 66, but is no
longer in use."
| value stream index limit array atIx |
value := self stackTop.
stream := self stackValue: 1.
((objectMemory isPointers: stream)
+ and: [(objectMemory lengthOf: stream) >= (StreamReadLimitIndex + 1)])
- and: [(self lengthOf: stream) >= (StreamReadLimitIndex + 1)])
ifFalse: [^ self primitiveFail].
array := objectMemory fetchPointer: StreamArrayIndex ofObject: stream.
index := self fetchInteger: StreamIndexIndex ofObject: stream.
limit := self fetchInteger: StreamWriteLimitIndex ofObject: stream.
atIx := (array bitAnd: AtCacheMask) + AtPutBase.
(index < limit and: [(atCache at: atIx+AtCacheOop) = array])
ifFalse: [^ self primitiveFail].
"OK -- its not at end, and the array is in the cache"
index := index + 1.
self commonVariable: array at: index put: value cacheIndex: atIx.
self successful ifTrue:
[self storeInteger: StreamIndexIndex ofObject: stream withValue: index.
^ self pop: 2 thenPush: value].
!
Item was changed:
----- Method: Interpreter>>printStringOf: (in category 'debug printing') -----
printStringOf: oop
| fmt cnt i |
(objectMemory isIntegerObject: oop) ifTrue:[^nil].
fmt := objectMemory formatOf: oop.
fmt < 8 ifTrue: [ ^nil ].
+ cnt := 100 min: (objectMemory lengthOf: oop).
- cnt := 100 min: (self lengthOf: oop).
i := 0.
[i < cnt] whileTrue: [
self printChar: (objectMemory fetchByte: i ofObject: oop).
i := i + 1.
].!
Item was changed:
----- Method: Interpreter>>reverseDisplayFrom:to: (in category 'I/O primitive support') -----
reverseDisplayFrom: startIndex to: endIndex
"Reverse the given range of Display words (at different bit
depths, this will reverse different numbers of pixels). Used to
give feedback during VM activities such as garbage
collection when debugging. It is assumed that the given
word range falls entirely within the first line of the Display."
| displayObj dispBitsPtr w reversed |
displayObj := objectMemory splObj: TheDisplay.
+ ((objectMemory isPointers: displayObj) and: [(objectMemory lengthOf: displayObj) >= 4]) ifFalse: [^ nil].
- ((objectMemory isPointers: displayObj) and: [(self lengthOf: displayObj) >= 4]) ifFalse: [^ nil].
w := self fetchInteger: 1 ofObject: displayObj.
dispBitsPtr := objectMemory fetchPointer: 0 ofObject: displayObj.
(objectMemory isIntegerObject: dispBitsPtr) ifTrue: [^ nil].
dispBitsPtr := dispBitsPtr + objectMemory baseHeaderSize.
dispBitsPtr + (startIndex * 4) to: dispBitsPtr + (endIndex * 4) by: 4
do: [:ptr |
reversed := (objectMemory long32At: ptr) bitXor: 4294967295.
objectMemory longAt: ptr put: reversed].
self initPrimCall.
self displayBitsOf: displayObj Left: 0 Top: 0 Right: w Bottom: 1.
self ioForceDisplayUpdate!
Item was changed:
----- Method: Interpreter>>sizeOfSTArrayFromCPrimitive: (in category 'utilities') -----
sizeOfSTArrayFromCPrimitive: cPtr
"Return the number of indexable fields of the given object. This method is to be called from an automatically generated C primitive. The argument is assumed to be a pointer to the first indexable field of a words or bytes object; the object header starts 4 bytes before that."
"Note: Only called by translated primitive code."
| oop |
<var: #cPtr type: 'void *'>
oop := (objectMemory oopForPointer: (self cCoerce: cPtr to: 'char *')) - objectMemory baseHeaderSize.
(objectMemory isWordsOrBytes: oop) ifFalse: [
self primitiveFail.
^0].
+ ^objectMemory lengthOf: oop
- ^self lengthOf: oop
!
Item was changed:
VMClass subclass: #InterpreterPrimitives
instanceVariableNames: 'objectMemory primFailCode argumentCount interruptKeycode newMethod'
classVariableNames: 'CrossedX EndOfRun InterpreterSourceVersion MillisecondClockMask'
poolDictionaries: 'VMObjectIndices VMSqueakV3ObjectRepresentationConstants'
category: 'VMMaker-Interpreter'!
+ !InterpreterPrimitives commentStamp: 'dtl 4/14/2013 23:16' prior: 0!
+ InterpreterPrimitives implements most of the VM's core primitives. It is the root of the interpreter hierarchy so as to share the core primitives amongst the various interpreters.
+
+ Instance Variables
+ argumentCount: <Integer>
+ messageSelector: <Integer>
+ newMethod: <Integer>
+ nextProfileTick: <Integer>
+ objectMemory: <ObjectMemory> (simulation only)
+ preemptionYields: <Boolean>
+ primFailCode: <Integer>
+ profileMethod: <Integer>
+ profileProcess: <Integer>
+ profileSemaphore: <Integer>
+
+ argumentCount
+ - the number of arguments of the current message
+
+ messageSelector
+ - the oop of the selector of the current message
+
+ newMethod
+ - the oop of the result of looking up the current message
+
+ nextProfileTick
+ - the millisecond clock value of the next profile tick (if profiling is in effect)
+
+ objectMemory
+ - the memory manager and garbage collector that manages the heap
+
+ preemptionYields
+ - a boolean controlling the process primitives. If true (old, incorrect, blue-book semantics) a preempted process is sent to the back of its run-queue. If false, a process preempted by a higher-priority process is put back at the head of its run queue, hence preserving cooperative scheduling within priorities.
+
+ primFailCode
+ - primtiive success/failure flag, 0 for success, otherwise the reason code for failure
+
+ profileMethod
+ - the oop of the method at the time nextProfileTick was reached
+
+ profileProcess
+ - the oop of the activeProcess at the time nextProfileTick was reached
+
+ profileSemaphore
+ - the oop of the semaphore to signal when nextProfileTick is reached
+ !
- !InterpreterPrimitives commentStamp: 'dtl 5/17/2011 07:49' prior: 0!
- InterpreterPrimitives implements most of the VM's core primitives. It is the root of the interpreter hierarchy so as to share the core primitives amongst the various interpreters.!
Item was changed:
----- Method: InterpreterPrimitives>>failed (in category 'primitive support') -----
failed
- "Answer true if primFailCode is not zero. This implementation is only for
- translation to C, and should not be modified without testing performance.
- Simulator subclasses must override this method as primFailCode ~= 0.
- Do not use #cCode:inSmalltalk: as this requires knowledge of the interpreter
- global structure."
<api>
+ "In C, non-zero is true, so avoid computation by simply answering primFailCode in the C version."
+ ^self cCode: [primFailCode] inSmalltalk: [primFailCode ~= 0]!
- ^primFailCode "override in simulator as primFailCode ~= 0"!
Item was changed:
----- Method: InterpreterPrimitives>>positive32BitValueOf: (in category 'primitive support') -----
positive32BitValueOf: oop
"Convert the given object into an integer value.
The object may be either a positive ST integer or a four-byte LargePositiveInteger."
| sz value |
(objectMemory isIntegerObject: oop) ifTrue: [
value := objectMemory integerValueOf: oop.
value < 0 ifTrue: [^ self primitiveFail].
^ value].
self assertClassOf: oop is: (objectMemory splObj: ClassLargePositiveInteger).
self successful ifTrue: [
+ sz := objectMemory lengthOf: oop.
- sz := self lengthOf: oop.
sz = 4 ifFalse: [^ self primitiveFail]].
self successful ifTrue: [
^ (objectMemory fetchByte: 0 ofObject: oop) +
((objectMemory fetchByte: 1 ofObject: oop) << 8) +
((objectMemory fetchByte: 2 ofObject: oop) << 16) +
((objectMemory fetchByte: 3 ofObject: oop) << 24) ].!
Item was changed:
----- Method: InterpreterPrimitives>>positive64BitValueOf: (in category 'primitive support') -----
positive64BitValueOf: oop
"Convert the given object into an integer value.
The object may be either a positive ST integer or a eight-byte LargePositiveInteger."
| sz szsqLong value |
<returnTypeC: 'sqLong'>
<var: 'value' type: 'sqLong'>
(objectMemory isIntegerObject: oop) ifTrue: [
value := objectMemory integerValueOf: oop.
value < 0 ifTrue: [^ self primitiveFail].
^ value].
self assertClassOf: oop is: (objectMemory splObj: ClassLargePositiveInteger).
self successful ifFalse: [^ self primitiveFail].
szsqLong := self cCode: 'sizeof(sqLong)'.
+ sz := objectMemory lengthOf: oop.
- sz := self lengthOf: oop.
sz > szsqLong
ifTrue: [^ self primitiveFail].
value := 0.
0 to: sz - 1 do: [:i |
value := value + ((self cCoerce: (objectMemory fetchByte: i ofObject: oop) to: 'sqLong') << (i*8))].
^value.!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveBeCursor (in category 'I/O primitives') -----
primitiveBeCursor
"Set the cursor to the given shape. The Mac only supports 16x16 pixel cursors. Cursor offsets are handled by Smalltalk."
| cursorObj maskBitsIndex maskObj bitsObj extentX extentY depth offsetObj offsetX offsetY cursorBitsIndex ourCursor |
argumentCount = 0 ifTrue: [
cursorObj := self stackTop.
maskBitsIndex := nil].
argumentCount = 1 ifTrue: [
cursorObj := self stackValue: 1.
maskObj := self stackTop].
self success: (argumentCount < 2).
+ self success: ((objectMemory isPointers: cursorObj) and: [(objectMemory lengthOf: cursorObj) >= 5]).
- self success: ((objectMemory isPointers: cursorObj) and: [(self lengthOf: cursorObj) >= 5]).
self successful ifTrue: [
bitsObj := objectMemory fetchPointer: 0 ofObject: cursorObj.
extentX := self fetchInteger: 1 ofObject: cursorObj.
extentY := self fetchInteger: 2 ofObject: cursorObj.
depth := self fetchInteger: 3 ofObject: cursorObj.
offsetObj := objectMemory fetchPointer: 4 ofObject: cursorObj].
+ self success: ((objectMemory isPointers: offsetObj) and: [(objectMemory lengthOf: offsetObj) >= 2]).
- self success: ((objectMemory isPointers: offsetObj) and: [(self lengthOf: offsetObj) >= 2]).
self successful ifTrue: [
offsetX := self fetchInteger: 0 ofObject: offsetObj.
offsetY := self fetchInteger: 1 ofObject: offsetObj.
(argumentCount = 0 and: [depth = 32])
ifTrue: [
"Support arbitrary-sized 32 bit ARGB forms --bf 3/1/2007 23:51"
self success: ((extentX > 0) and: [extentY > 0]).
self success: ((offsetX >= (extentX * -1)) and: [offsetX <= 0]).
self success: ((offsetY >= (extentY * -1)) and: [offsetY <= 0]).
cursorBitsIndex := bitsObj + objectMemory baseHeaderSize.
+ self success: ((objectMemory isWords: bitsObj) and: [(objectMemory lengthOf: bitsObj) = (extentX * extentY)]).
- self success: ((objectMemory isWords: bitsObj) and: [(self lengthOf: bitsObj) = (extentX * extentY)]).
self cCode: '' inSmalltalk:
[ourCursor := Cursor
extent: extentX @ extentY
depth: 32
fromArray: ((1 to: extentX * extentY) collect: [:i |
objectMemory fetchLong32: i-1 ofObject: bitsObj])
offset: offsetX @ offsetY]]
ifFalse: [
self success: ((extentX = 16) and: [extentY = 16 and: [depth = 1]]).
self success: ((offsetX >= -16) and: [offsetX <= 0]).
self success: ((offsetY >= -16) and: [offsetY <= 0]).
+ self success: ((objectMemory isWords: bitsObj) and: [(objectMemory lengthOf: bitsObj) = 16]).
- self success: ((objectMemory isWords: bitsObj) and: [(self lengthOf: bitsObj) = 16]).
cursorBitsIndex := bitsObj + objectMemory baseHeaderSize.
self cCode: '' inSmalltalk:
[ourCursor := Cursor
extent: extentX @ extentY
fromArray: ((1 to: 16) collect: [:i |
((objectMemory fetchLong32: i-1 ofObject: bitsObj) >> 16) bitAnd: 16rFFFF])
offset: offsetX @ offsetY]]].
argumentCount = 1 ifTrue: [
+ self success: ((objectMemory isPointers: maskObj) and: [(objectMemory lengthOf: maskObj) >= 5]).
- self success: ((objectMemory isPointers: maskObj) and: [(self lengthOf: maskObj) >= 5]).
self successful ifTrue: [
bitsObj := objectMemory fetchPointer: 0 ofObject: maskObj.
extentX := self fetchInteger: 1 ofObject: maskObj.
extentY := self fetchInteger: 2 ofObject: maskObj.
depth := self fetchInteger: 3 ofObject: maskObj].
self successful ifTrue: [
self success: ((extentX = 16) and: [extentY = 16 and: [depth = 1]]).
+ self success: ((objectMemory isWords: bitsObj) and: [(objectMemory lengthOf: bitsObj) = 16]).
- self success: ((objectMemory isWords: bitsObj) and: [(self lengthOf: bitsObj) = 16]).
maskBitsIndex := bitsObj + objectMemory baseHeaderSize]].
self successful ifTrue: [
argumentCount = 0
ifTrue: [
depth = 32
ifTrue: [(self cCode: 'ioSetCursorARGB(cursorBitsIndex, extentX, extentY, offsetX, offsetY)'
inSmalltalk: [ourCursor show. Cursor currentCursor == ourCursor])
ifFalse: [^self success: false]]
ifFalse: [self cCode: 'ioSetCursor(cursorBitsIndex, offsetX, offsetY)'
inSmalltalk: [ourCursor show]]]
ifFalse: [self cCode: 'ioSetCursorWithMask(cursorBitsIndex, maskBitsIndex, offsetX, offsetY)'
inSmalltalk: [cursorBitsIndex == maskBitsIndex. "placate compiler"
ourCursor show]].
self pop: argumentCount]!
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 success: ((objectMemory isPointers: rcvr) and: [(self lengthOf: rcvr) >= 4]).
self successful ifTrue: [objectMemory storePointer: TheDisplay ofObject: objectMemory specialObjectsOop withValue: rcvr]!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveFormPrint (in category 'I/O primitives') -----
primitiveFormPrint
"On platforms that support it, this primitive prints the receiver, assumed to be a Form, to the default printer."
| landscapeFlag vScale hScale rcvr bitsArray w h
depth pixelsPerWord wordsPerLine bitsArraySize ok |
<var: #vScale type: 'double '>
<var: #hScale type: 'double '>
landscapeFlag := self booleanValueOf: self stackTop.
vScale := self floatValueOf: (self stackValue: 1).
hScale := self floatValueOf: (self stackValue: 2).
rcvr := self stackValue: 3.
(rcvr isIntegerObject: rcvr) ifTrue: [self success: false].
self successful ifTrue: [
+ ((objectMemory isPointers: rcvr) and: [(objectMemory lengthOf: rcvr) >= 4])
- ((objectMemory isPointers: rcvr) and: [(self lengthOf: rcvr) >= 4])
ifFalse: [self success: false]].
self successful ifTrue: [
bitsArray := objectMemory fetchPointer: 0 ofObject: rcvr.
w := self fetchInteger: 1 ofObject: rcvr.
h := self fetchInteger: 2 ofObject: rcvr.
depth := self fetchInteger: 3 ofObject: rcvr.
(w > 0 and: [h > 0]) ifFalse: [self success: false].
pixelsPerWord := 32 // depth.
wordsPerLine := (w + (pixelsPerWord - 1)) // pixelsPerWord.
((rcvr isIntegerObject: rcvr) not and: [objectMemory isWordsOrBytes: bitsArray])
ifTrue: [
bitsArraySize := self byteLengthOf: bitsArray.
self success: (bitsArraySize = (wordsPerLine * h * 4))]
ifFalse: [self success: false]].
self successful ifTrue: [
objectMemory bytesPerWord = 8
ifTrue: [ok := self cCode: 'ioFormPrint(bitsArray + 8, w, h, depth, hScale, vScale, landscapeFlag)']
ifFalse: [ok := self cCode: 'ioFormPrint(bitsArray + 4, w, h, depth, hScale, vScale, landscapeFlag)'].
self success: ok].
self successful ifTrue: [
self pop: 3]. "pop hScale, vScale, and landscapeFlag; leave rcvr on stack"
!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveIntegerAt (in category 'indexing primitives') -----
primitiveIntegerAt
"Return the 32bit signed integer contents of a words receiver"
| index rcvr sz addr value intValue |
<var: #intValue type: 'int'>
index := self stackIntegerValue: 0.
rcvr := self stackValue: 1.
(objectMemory isIntegerObject: rcvr) ifTrue: [^self success: false].
(objectMemory isWords: rcvr) ifFalse: [^self success: false].
+ sz := objectMemory lengthOf: rcvr. "number of fields"
- sz := self lengthOf: rcvr. "number of fields"
self success: ((index >= 1) and: [index <= sz]).
self successful ifTrue: [
addr := rcvr + objectMemory baseHeaderSize - 4 "for zero indexing" + (index * 4).
value := objectMemory intAt: addr.
self pop: 2. "pop rcvr, index"
"push element value"
(objectMemory isIntegerValue: value)
ifTrue: [self pushInteger: value]
ifFalse: [
intValue := value. "32 bit int may have been stored in 32 or 64 bit sqInt"
self push: (self signed32BitIntegerFor: intValue)]. "intValue may be sign extended to 64 bit sqInt"
].!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveIntegerAtPut (in category 'indexing primitives') -----
primitiveIntegerAtPut
"Return the 32bit signed integer contents of a words receiver"
| index rcvr sz addr value valueOop |
valueOop := self stackValue: 0.
index := self stackIntegerValue: 1.
rcvr := self stackValue: 2.
(objectMemory isIntegerObject: rcvr) ifTrue:[^self success: false].
(objectMemory isWords: rcvr) ifFalse:[^self success: false].
+ sz := objectMemory lengthOf: rcvr. "number of fields"
- sz := self lengthOf: rcvr. "number of fields"
((index >= 1) and: [index <= sz]) ifFalse:[^self success: false].
(objectMemory isIntegerObject: valueOop)
ifTrue:[value := objectMemory integerValueOf: valueOop]
ifFalse:[value := objectMemory signed32BitValueOf: valueOop].
self successful ifTrue:[
addr := rcvr + objectMemory baseHeaderSize - 4 "for zero indexing" + (index * 4).
value := objectMemory intAt: addr put: value.
self pop: 3 thenPush: valueOop. "pop all; return value"
].
!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveUtcWithOffset (in category 'system control primitives') -----
primitiveUtcWithOffset
"Answer an array with UTC microseconds since the Posix epoch and
+ the current seconds offset from GMT in the local time zone. An empty
+ two element array may be supplied as a parameter.
- the current seconds offset from GMT in the local time zone.
This is a named (not numbered) primitive in the null module (ie the VM)"
| clock offset resultArray |
<export: true>
<var: #clock type: 'sqLong'>
<var: #offset type: 'int'>
+ argumentCount > 1 ifTrue: [^self primitiveFailFor: PrimErrBadNumArgs].
(self cCode: 'ioUtcWithOffset(&clock, &offset)' inSmalltalk: [-1]) = -1
ifTrue: [^ self primitiveFail].
objectMemory pushRemappableOop: (self positive64BitIntegerFor: clock).
+ argumentCount > 0
+ ifTrue: [resultArray := self popStack.
+ ((objectMemory isPointers: resultArray)
+ and: [(objectMemory lengthOf: resultArray) = 2])
+ ifFalse: [^self primitiveFailFor: PrimErrBadArgument]]
+ ifFalse: [resultArray := objectMemory instantiateClass: objectMemory classArray indexableSize: 2].
- resultArray := objectMemory instantiateClass: objectMemory classArray indexableSize: 2.
self stObject: resultArray at: 1 put: objectMemory popRemappableOop.
self stObject: resultArray at: 2 put: (objectMemory integerObjectOf: offset).
self pop: 1 thenPush: resultArray
!
Item was changed:
----- Method: InterpreterPrimitives>>signed32BitValueOf: (in category 'primitive support') -----
signed32BitValueOf: oop
"Convert the given object into an integer value.
The object may be either a positive ST integer or a four-byte LargeInteger."
| value largeClass negative |
<inline: false>
<returnTypeC: 'int'>
<var: 'value' type: 'int'>
(objectMemory isIntegerObject: oop) ifTrue: [^objectMemory integerValueOf: oop].
+ (objectMemory lengthOf: oop) > 4 ifTrue: [^ self primitiveFail].
- (self lengthOf: oop) > 4 ifTrue: [^ self primitiveFail].
largeClass := objectMemory fetchClassOf: oop.
largeClass = objectMemory classLargePositiveInteger
ifTrue:[negative := false]
ifFalse:[largeClass = objectMemory classLargeNegativeInteger
ifTrue:[negative := true]
ifFalse:[^self primitiveFail]].
+ (objectMemory lengthOf: oop) ~= 4 ifTrue: [^ self primitiveFail].
- (self lengthOf: oop) ~= 4 ifTrue: [^ self primitiveFail].
value := (objectMemory fetchByte: 0 ofObject: oop) +
((objectMemory fetchByte: 1 ofObject: oop) << 8) +
((objectMemory fetchByte: 2 ofObject: oop) << 16) +
((objectMemory fetchByte: 3 ofObject: oop) << 24).
"Fail if value exceeds range of a 32-bit twos-complement signed integer."
negative
ifTrue:["perform subtraction using unsigned int to prevent undefined result
for optimizing C compilers in the case of value = 16r80000000"
value := 0 - (self cCoerce: value to: 'unsigned int').
value >= 0 ifTrue: [^ self primitiveFail]]
ifFalse:[value < 0 ifTrue:[^ self primitiveFail]].
^ value!
Item was changed:
----- Method: InterpreterPrimitives>>signed64BitValueOf: (in category 'primitive support') -----
signed64BitValueOf: oop
"Convert the given object into an integer value.
The object may be either a positive ST integer or a eight-byte LargeInteger."
| sz value largeClass negative szsqLong |
<inline: false>
<returnTypeC: 'sqLong'>
<var: 'value' type: 'sqLong'>
(objectMemory isIntegerObject: oop) ifTrue: [^self cCoerce: (objectMemory integerValueOf: oop) to: 'sqLong'].
+ sz := objectMemory lengthOf: oop.
- sz := self lengthOf: oop.
sz > 8 ifTrue: [^ self primitiveFail].
largeClass := objectMemory fetchClassOf: oop.
largeClass = objectMemory classLargePositiveInteger
ifTrue:[negative := false]
ifFalse:[largeClass = objectMemory classLargeNegativeInteger
ifTrue:[negative := true]
ifFalse:[^self primitiveFail]].
szsqLong := self
cCode: 'sizeof(sqLong)'
inSmalltalk: [8].
sz > szsqLong
ifTrue: [^ self primitiveFail].
value := 0.
0 to: sz - 1 do: [:i |
value := value + ((self cCoerce: (objectMemory fetchByte: i ofObject: oop) to: 'sqLong') << (i*8))].
"Fail if value exceeds range of a 64-bit twos-complement signed integer."
negative
ifTrue:["perform subtraction using unsigned usqLong to prevent undefined result
for optimizing C compilers in the case of value = 16r8000000000000000"
value := 0 - (self cCoerce: value to: 'usqLong').
value >= 0 ifTrue: [^ self primitiveFail]]
ifFalse:[value < 0 ifTrue:[^ self primitiveFail]].
^ value!
Item was changed:
----- Method: InterpreterPrimitives>>successful (in category 'primitive support') -----
successful
"Answer the state of the primitive failure code/success flag. If
primFailCode is non-zero a primitive has failed. If primFailCode
+ is greater than one then its value indicates the reason for failure."
- is greater than one then its value indicates the reason for failure.
- This implementation is only for translation to C, and should not be
- modified without testing performance. Simulator subclasses must
- override this method as primFailCode == 0. Do not use #cCode:inSmalltalk:
- as this requires knowledge of the interpreter global structure."
<inline: true>
+
+ "In C, non-zero is true, so avoid computation by using not the C version."
+ ^self cCode: [primFailCode not] inSmalltalk: [primFailCode = 0]!
- ^primFailCode not "override this in simulator as primFailCode == 0"!
Item was changed:
----- Method: InterpreterSimulator>>allObjectsDo: (in category 'debug support') -----
allObjectsDo: objBlock
+ objectMemory allObjectsDo: objBlock
- | oop |
- oop := objectMemory firstObject.
- [oop < objectMemory endOfMemory] whileTrue:
- [(objectMemory isFreeObject: oop)
- ifFalse: [objBlock value: oop].
- oop := objectMemory objectAfter: oop].
!
Item was changed:
----- Method: InterpreterSimulator>>allObjectsSelect: (in category 'debug support') -----
allObjectsSelect: objBlock
"self allObjectsSelect: [:oop | (self baseHeader: oop) = 1234]"
+ ^objectMemory allObjectsSelect: objBlock
+ !
- | oop selected |
- oop := objectMemory firstObject.
- selected := OrderedCollection new.
- [oop < objectMemory endOfMemory] whileTrue:
- [(objectMemory isFreeObject: oop)
- ifFalse: [(objBlock value: oop) ifTrue: [selected addLast: oop]].
- oop := objectMemory objectAfter: oop].
- ^ selected!
Item was changed:
----- Method: InterpreterSimulator>>classNameOf:Is: (in category 'plugin support') -----
classNameOf: aClass Is: className
"Check if aClass' name is className"
| name |
+ (objectMemory lengthOf: aClass) <= 6 ifTrue:[^false]. "Not a class but maybe behavior"
- (self lengthOf: aClass) <= 6 ifTrue:[^false]. "Not a class but maybe behavior"
name := objectMemory fetchPointer: 6 ofObject: aClass.
(objectMemory isBytes: name) ifFalse:[^false].
^ className = (self stringOf: name).
!
Item was changed:
----- Method: InterpreterSimulator>>logOfBytesVerify:fromFileNamed:fromStart: (in category 'testing') -----
logOfBytesVerify: nBytes fromFileNamed: fileName fromStart: loggingStart
"Verify a questionable interpreter against a successful run"
"self logOfBytesVerify: 10000 fromFileNamed: 'clone32Bytecodes.log' "
| logFile rightByte prevCtxt |
logFile := (FileStream readOnlyFileNamed: fileName) binary.
logging := loggingStart.
transcript clear.
byteCount := 0.
quitBlock := [^ self].
self internalizeIPandSP.
self fetchNextBytecode.
prevCtxt := 0. prevCtxt := prevCtxt.
[byteCount < nBytes] whileTrue:
[
"
byteCount > 14560 ifTrue:
[self externalizeIPandSP.
prevCtxt = activeContext ifFalse:
[prevCtxt := activeContext.
transcript cr; nextPutAll: (self printTop: 2); endEntry].
transcript cr; print: byteCount; nextPutAll: ': ' , (activeContext hex); space;
+ print: (instructionPointer - method - (objectMemory baseHeaderSize - 2));
- print: (instructionPointer - method - (BaseHeaderSize - 2));
nextPutAll: ': <' , (objectMemory byteAt: localIP) hex , '>'; space;
nextPutAll: (self symbolic: currentBytecode at: localIP inMethod: method); space;
print: (self stackPointerIndex - TempFrameStart + 1); endEntry.
byteCount = 14590 ifTrue: [self halt]].
"
logging ifTrue: [rightByte := logFile next.
currentBytecode = rightByte ifFalse: [self halt]].
self dispatchOn: currentBytecode in: BytecodeTable.
byteCount := byteCount + 1.
byteCount \\ 10000 = 0 ifTrue: [self fullDisplayUpdate]].
self externalizeIPandSP.
logFile close.
self inform: nBytes printString , ' bytecodes verfied.'!
Item was changed:
----- Method: InterpreterSimulator>>logOfSendsVerify:fromFileNamed:fromStart: (in category 'testing') -----
logOfSendsVerify: nSends fromFileNamed: fileName fromStart: loggingStart
"Write a log file for testing a flaky interpreter on the same image"
"self logOfSendsWrite: 10000 toFileNamed: 'clone32Messages.log' "
| logFile priorContext rightSelector prevCtxt |
logFile := FileStream readOnlyFileNamed: fileName.
logging := loggingStart.
transcript clear.
byteCount := 0.
sendCount := 0.
priorContext := activeContext.
quitBlock := [^ self].
self internalizeIPandSP.
self fetchNextBytecode.
prevCtxt := 0. prevCtxt := prevCtxt.
[sendCount < nSends] whileTrue:
[
"
byteCount>500 ifTrue:
[byteCount>550 ifTrue: [self halt].
self externalizeIPandSP.
prevCtxt = activeContext ifFalse:
[prevCtxt := activeContext.
transcript cr; nextPutAll: (self printTop: 2); endEntry].
transcript cr; print: byteCount; nextPutAll: ': ' , (activeContext hex); space;
+ print: (instructionPointer - method - (objectMemory baseHeaderSize - 2));
- print: (instructionPointer - method - (BaseHeaderSize - 2));
nextPutAll: ': <' , (objectMemory byteAt: localIP) hex , '>'; space;
nextPutAll: (self symbolic: currentBytecode at: localIP inMethod: method); space;
print: (self stackPointerIndex - TempFrameStart + 1); endEntry.
].
"
self dispatchOn: currentBytecode in: BytecodeTable.
activeContext == priorContext ifFalse:
[sendCount := sendCount + 1.
logging ifTrue: [rightSelector := logFile nextLine.
(self stringOf: messageSelector) = rightSelector ifFalse: [self halt]].
priorContext := activeContext].
byteCount := byteCount + 1.
byteCount \\ 10000 = 0 ifTrue: [self fullDisplayUpdate]].
self externalizeIPandSP.
logFile close.
self inform: nSends printString , ' sends verfied.'!
Item was added:
+ ----- Method: InterpreterSimulator>>objectMemory (in category 'accessing') -----
+ objectMemory
+ ^objectMemory!
Item was changed:
----- Method: InterpreterSimulator>>primitiveBeDisplay (in category 'I/O primitives') -----
primitiveBeDisplay
"Extended to create a scratch Form for use by showDisplayBits."
| rcvr destWidth destHeight destDepth |
rcvr := self stackTop.
+ self success: ((objectMemory isPointers: rcvr) and: [(objectMemory lengthOf: rcvr) >= 4]).
- self success: ((objectMemory isPointers: rcvr) and: [(self lengthOf: rcvr) >= 4]).
self successful ifTrue: [
destWidth := self fetchInteger: 1 ofObject: rcvr.
destHeight := self fetchInteger: 2 ofObject: rcvr.
destDepth := self fetchInteger: 3 ofObject: rcvr.
].
self successful ifTrue: [
"create a scratch form the same size as Smalltalk displayObj"
displayForm := Form extent: destWidth @ destHeight
depth: destDepth.
displayView ifNotNil: [displayView image: displayForm].
].
super primitiveBeDisplay.!
Item was changed:
----- Method: InterpreterStackPages>>couldBeFramePointer: (in category 'assertions') -----
couldBeFramePointer: pointer
"Answer if the argument is a properly aligned pointer into the stack zone."
<var: #pointer type: #'void *'>
+ ^self
+ cCode:
+ [(pointer asUnsignedInteger bitAnd: self bytesPerWord - 1) = 0
+ and: [pointer asUnsignedInteger
+ between: stackMemory asUnsignedInteger
+ and: pages asUnsignedInteger]]
+ inSmalltalk:
+ [(pointer bitAnd: self bytesPerWord - 1) = 0
+ and: [(self memIndexFor: pointer)
+ between: 1 and: stackMemory size]]!
- ^(pointer asUnsignedInteger bitAnd: self bytesPerWord - 1) = 0
- and: [pointer asUnsignedInteger
- between: stackMemory asUnsignedInteger
- and: (self cCode: [pages asUnsignedInteger]
- inSmalltalk: [(self stackPageAt: 0) asUnsignedInteger])]!
Item was added:
+ ----- Method: InterpreterStackPages>>initializeStack:numSlots:pageSize: (in category 'initialization') -----
+ initializeStack: theStackPages numSlots: stackSlots pageSize: slotsPerPage
+ "Initialize the stack pages. For testing I want stack addresses to be disjoint from
+ normal memory addresses so stack addresses are negative. The first address is
+ -pageSize bytes. So for example if there are 1024 bytes per page and 3 pages
+ then the pages are organized as
+
+ byte address: -1024 <-> -2047 | -2048 <-> -3071 | -3072 <-> -4096 |
+ page 3 page 2 page 1
+ mem index: 769 <-> 513 | 512 <-> 257 | 256 <-> 1 |
+
+ The byte address is the external address corresponding to a real address in the VM.
+ mem index is the index in the memory Array holding the stack, an index internal to
+ the stack pages. The first stack page allocated will be the last page in the array of pages
+ at the highest effective address. Its base address be -1024 and grow down towards -2047."
+
+ "The lFoo's are to get around the foo->variable scheme in the C call to allocStackPages below."
+ <var: #theStackPages type: #'char *'>
+ | page structStackPageSize pageStructBase count |
+ <var: #page type: #'StackPage *'>
+ <var: #pageStructBase type: #'char *'>
+ self cCode: ''
+ inSmalltalk:
+ [self assert: stackMemory size = stackSlots.
+ self assert: stackMemory size - self extraStackBytes \\ slotsPerPage = 0.
+ self assert: stackMemory == theStackPages].
+ stackMemory := theStackPages. "For initialization in the C code."
+ self cCode: '' inSmalltalk: [pageSizeInSlots := slotsPerPage].
+ structStackPageSize := interpreter sizeof: InterpreterStackPage.
+ bytesPerPage := slotsPerPage * self bytesPerWord.
+ numPages := stackSlots // (slotsPerPage + (structStackPageSize / self bytesPerWord)).
+
+ "Because stack pages grow down baseAddress is at the top of a stack page and so to avoid
+ subtracting bytesPerWord from baseAddress and lastAddress in the init loop below we simply
+ push the stackPage array up one word to avoid the overlap. This word is extraStackBytes."
+ pageStructBase := theStackPages + (numPages * bytesPerPage) + self bytesPerWord.
+ pages := self cCode: '(StackPage *)pageStructBase'
+ inSmalltalk:
+ [pageStructBase class.
+ (1 to: numPages) collect: [:i| InterpreterStackPage new]].
+
+ "Simulation only. Since addresses are negative the offset is positive. To make all
+ stack addresses negative we make the offset a page more than it needs to be so the
+ address of the last slot in memory (the highest address in the stack, or its start) is
+ - pageByteSize
+ and the address of the first slot (the lowest address, or its end) is
+ - pageByteSize * (numPages + 1)"
+ self cCode: '' inSmalltalk: [indexOffset := (numPages + 1) * slotsPerPage].
+ "make sure there's enough headroom"
+ self assert: interpreter stackPageByteSize - interpreter stackLimitBytes - interpreter stackLimitOffset
+ >= interpreter stackPageHeadroom.
+ 0 to: numPages - 1 do:
+ [:index|
+ page := self stackPageAt: index.
+ page
+ lastAddress: (self cCode: '(char *)theStackPages + (index * GIV(bytesPerPage))'
+ inSmalltalk: [(index * slotsPerPage - indexOffset) * self bytesPerWord]);
+ baseAddress: (page lastAddress + bytesPerPage);
+ stackLimit: page baseAddress - interpreter stackLimitBytes;
+ realStackLimit: page stackLimit;
+ baseFP: 0;
+ nextPage: (self stackPageAt: (index = (numPages - 1) ifTrue: [0] ifFalse: [index + 1]));
+ prevPage: (self stackPageAt: (index = 0 ifTrue: [numPages - 1] ifFalse: [index - 1]))].
+ self cCode: ''
+ inSmalltalk:
+ [| lowestAddress highestAddress |
+ lowestAddress := (pages at: 1) lastAddress + self bytesPerWord.
+ highestAddress := (pages at: numPages) baseAddress.
+ "see InterpreterStackPages>>longAt:"
+ self assert: lowestAddress // self bytesPerWord + indexOffset = 1.
+ self assert: highestAddress // self bytesPerWord + indexOffset = (numPages * slotsPerPage)].
+
+ "The overflow limit is the amount of stack to retain when moving frames from an overflowing
+ stack to reduce thrashing. See stackOverflowOrEvent:mayContextSwitch:"
+ page := self stackPageAt: 0.
+ overflowLimit := page baseAddress - page realStackLimit * 3 // 5.
+
+ 0 to: numPages - 1 do:
+ [:index|
+ page := self stackPageAt: index.
+ self assert: (self pageIndexFor: page baseAddress) == index.
+ self assert: (self pageIndexFor: page baseAddress - (slotsPerPage - 1 * self bytesPerWord)) == index.
+ self assert: (self stackPageFor: page baseAddress) == page.
+ self assert: (self stackPageFor: page stackLimit) == page.
+ self cCode: ''
+ inSmalltalk:
+ [| memIndex |
+ memIndex := index * slotsPerPage + 1. "this is memIndex in the block above"
+ self assert: (self memIndexFor: (self oopForPointer: page baseAddress))
+ == (memIndex + slotsPerPage - 1).
+ index < (numPages - 1) ifTrue:
+ [self assert: (self stackPageFor: page baseAddress + self bytesPerWord) == (self stackPageAt: index + 1)]].
+ self assert: (page trace: -1) ~= 0 "for assert checking of the page tracing flags. -1 == invalid state"].
+
+ mostRecentlyUsedPage := self stackPageAt: 0.
+ page := mostRecentlyUsedPage.
+ count := 0.
+ [| theIndex |
+ count := count + 1.
+ theIndex := self pageIndexFor: page baseAddress.
+ self assert: (self stackPageAt: theIndex) == page.
+ self assert: (self pageIndexFor: page baseAddress) == theIndex.
+ self assert: (self pageIndexFor: page stackLimit) == theIndex.
+ self assert: (self pageIndexFor: page lastAddress + self bytesPerWord) == theIndex.
+ (page := page nextPage) ~= mostRecentlyUsedPage] whileTrue.
+ self assert: count == numPages.
+ self assert: self pageListIsWellFormed!
Item was removed:
- ----- Method: InterpreterStackPages>>initializeStack:numSlots:pageSize:stackLimitOffset:stackPageHeadroom: (in category 'initialization') -----
- initializeStack: theStackPages numSlots: stackSlots pageSize: slotsPerPage stackLimitOffset: stackLimitOffsetBytes stackPageHeadroom: stackPageHeadroomBytes
- "Initialize the stack pages. For testing I want stack addresses to be disjoint from
- normal memory addresses so stack addresses are negative. The first address is
- -pageSize bytes. So for example if there are 1024 bytes per page and 3 pages
- then the pages are organized as
-
- byte address: -1024 <-> -2047 | -2048 <-> -3071 | -3072 <-> -4096 |
- page 3 page 2 page 1
- mem index: 769 <-> 513 | 512 <-> 257 | 256 <-> 1 |
-
- The byte address is the external address corresponding to a real address in the VM.
- mem index is the index in the memory Array holding the stack, an index internal to
- the stack pages. The first stack page allocated will be the last page in the array of pages
- at the highest effective address. Its base address be -1024 and grow down towards -2047."
-
- "The lFoo's are to get around the foo->variable scheme in the C call to allocStackPages below."
- <var: #theStackPages type: #'char *'>
- | page structStackPageSize pageStructBase count |
- <var: #page type: #'StackPage *'>
- <var: #pageStructBase type: #'char *'>
- self cCode: ''
- inSmalltalk:
- [self assert: stackMemory size = stackSlots.
- self assert: stackMemory size - self extraStackBytes \\ slotsPerPage = 0.
- self assert: stackMemory == theStackPages].
- stackMemory := theStackPages. "For initialization in the C code."
- self cCode: '' inSmalltalk: [pageSizeInSlots := slotsPerPage].
- structStackPageSize := interpreter sizeof: InterpreterStackPage.
- bytesPerPage := slotsPerPage * BytesPerWord.
- numPages := stackSlots // (slotsPerPage + (structStackPageSize / BytesPerWord)).
-
- "Because stack pages grow down baseAddress is at the top of a stack page and so to avoid
- subtracting BytesPerWord from baseAddress and lastAddress in the init loop below we simply
- push the stackPage array up one word to avoid the overlap. This word is extraStackBytes."
- pageStructBase := theStackPages + (numPages * bytesPerPage) + BytesPerWord.
- pages := self cCode: '(StackPage *)pageStructBase'
- inSmalltalk:
- [pageStructBase class.
- (1 to: numPages) collect: [:i| InterpreterStackPage new]].
-
- "Simulation only. Since addresses are negative the offset is positive. To make all
- stack addresses negative we make the offset a page more than it needs to be so the
- address of the last slot in memory (the highest address in the stack, or its start) is
- - pageByteSize
- and the address of the first slot (the lowest address, or its end) is
- - pageByteSize * (numPages + 1)"
- self cCode: '' inSmalltalk: [indexOffset := (numPages + 1) * slotsPerPage].
-
- 0 to: numPages - 1 do:
- [:index|
- page := self stackPageAt: index.
- page
- lastAddress: (self cCode: '(char *)theStackPages + (index * GIV(bytesPerPage))'
- inSmalltalk: [(index * slotsPerPage - indexOffset) * BytesPerWord]);
- baseAddress: (page lastAddress + bytesPerPage);
- stackLimit: page lastAddress
- + stackLimitOffsetBytes
- + stackPageHeadroomBytes;
- realStackLimit: page stackLimit;
- baseFP: 0;
- nextPage: (self stackPageAt: (index = (numPages - 1) ifTrue: [0] ifFalse: [index + 1]));
- prevPage: (self stackPageAt: (index = 0 ifTrue: [numPages - 1] ifFalse: [index - 1]))].
- self cCode: ''
- inSmalltalk:
- [| lowestAddress highestAddress |
- lowestAddress := (pages at: 1) lastAddress + BytesPerWord.
- highestAddress := (pages at: numPages) baseAddress.
- "see InterpreterStackPages>>longAt:"
- self assert: lowestAddress // BytesPerWord + indexOffset = 1.
- self assert: highestAddress // BytesPerWord + indexOffset = (numPages * slotsPerPage)].
-
- "The overflow limit is the amount of stack to retain when moving frames from an overflowing
- stack to reduce thrashing. See stackOverflowOrEvent:mayContextSwitch:"
- page := self stackPageAt: 0.
- overflowLimit := page baseAddress - page realStackLimit * 3 // 5.
-
- 0 to: numPages - 1 do:
- [:index|
- page := self stackPageAt: index.
- self assert: (self pageIndexFor: page baseAddress) == index.
- self assert: (self pageIndexFor: page baseAddress - (slotsPerPage - 1 * BytesPerWord)) == index.
- self assert: (self stackPageFor: page baseAddress) == page.
- self assert: (self stackPageFor: page stackLimit) == page.
- self cCode: ''
- inSmalltalk:
- [| memIndex |
- memIndex := index * slotsPerPage + 1. "this is memIndex in the block above"
- self assert: (self memIndexFor: (self oopForPointer: page baseAddress))
- == (memIndex + slotsPerPage - 1).
- index < (numPages - 1) ifTrue:
- [self assert: (self stackPageFor: page baseAddress + BytesPerWord) == (self stackPageAt: index + 1)]].
- self assert: (page trace: -1) ~= 0 "for assert checking of the page tracing flags. -1 == invalid state"].
-
- mostRecentlyUsedPage := self stackPageAt: 0.
- page := mostRecentlyUsedPage.
- count := 0.
- [| theIndex |
- count := count + 1.
- theIndex := self pageIndexFor: page baseAddress.
- self assert: (self stackPageAt: theIndex) == page.
- self assert: (self pageIndexFor: page baseAddress) == theIndex.
- self assert: (self pageIndexFor: page stackLimit) == theIndex.
- self assert: (self pageIndexFor: page lastAddress + BytesPerWord) == theIndex.
- (page := page nextPage) ~= mostRecentlyUsedPage] whileTrue.
- self assert: count == numPages.
- self assert: self pageListIsWellFormed!
Item was changed:
----- Method: InterpreterStackPages>>isFree: (in category 'page access') -----
isFree: thePage
+ "This is an anachronism. Previously Slang couldn't generate the method correctly
+ from e.g. InterpreterStackPage>>isFree since Slang didn't do substitution on self.
+ Now it does, but there are still callers of isFree: so we keep this for simulation."
+ <doNotGenerate>
+ ^thePage baseFP = 0!
- "This is a sad workaround. Ideally this is an accessor on InterpreterStackPages.
- But it isn't easy to extend Slang to deal with this. There's no easy place to put
- the type information and Slang doesn't ever do substitution on self. It merely
- elides self."
- <inline: true>
- <var: #thePage type: 'StackPage *'>
- ^thePage baseFP = 0
- !
Item was added:
+ ----- Method: InterpreterStackPages>>markStackPageLeastMostRecentlyUsed: (in category 'page access') -----
+ markStackPageLeastMostRecentlyUsed: page "<InterpreterStackPage>"
+ "This method is used to move a page to the end of the used pages.
+ This is to keep asserts checking pageListIsWellFormed happy."
+
+ "MRUP-->used page<->used page<->used page<->used page<--LRUP
+ ^ <-next-prev-> ^
+ | |
+ v <-prev-next-> v
+ free page<->free page<->free page<->free page"
+
+ <var: #page type: #'StackPage *'>
+ <returnTypeC: #void>
+ | lastUsedPage |
+ <var: #lastUsedPage type: #'StackPage *'>
+ self assert: page = mostRecentlyUsedPage nextPage.
+ lastUsedPage := page nextPage.
+ [lastUsedPage isFree] whileTrue:
+ [lastUsedPage := lastUsedPage nextPage].
+ lastUsedPage nextPage = page ifTrue:
+ [^nil].
+ page prevPage nextPage: page nextPage.
+ page nextPage prevPage: page prevPage.
+ lastUsedPage prevPage nextPage: page.
+ page prevPage: lastUsedPage prevPage.
+ page nextPage: lastUsedPage.
+ lastUsedPage prevPage: page.
+ self assert: self pageListIsWellFormed!
Item was changed:
----- Method: InterpreterStackPages>>markStackPageMostRecentlyUsed: (in category 'page access') -----
markStackPageMostRecentlyUsed: page "<InterpreterStackPage>"
"MRUP-->used page<->used page<->used page<->used page<--LRUP
^ <-next-prev-> ^
| |
v <-prev-next-> v
free page<->free page<->free page<->free page"
+ <var: #page type: #'StackPage *'>
- <var: #page type: 'StackPage *'>
<asmLabel: false>
page == mostRecentlyUsedPage ifTrue:
[^nil].
"Common case; making new page most recently used."
page prevPage == mostRecentlyUsedPage ifTrue:
[mostRecentlyUsedPage := page.
self assert: self pageListIsWellFormed.
^nil].
page prevPage nextPage: page nextPage.
page nextPage prevPage: page prevPage.
mostRecentlyUsedPage nextPage prevPage: page.
page prevPage: mostRecentlyUsedPage.
page nextPage: mostRecentlyUsedPage nextPage.
mostRecentlyUsedPage nextPage: page.
mostRecentlyUsedPage := page.
self assert: self pageListIsWellFormed!
Item was changed:
----- Method: InterpreterStackPages>>markStackPageNextMostRecentlyUsed: (in category 'page access') -----
markStackPageNextMostRecentlyUsed: page "<InterpreterStackPage>"
"This method is used to move a page to a position in the list such that it cannot
be deallocated when a new page is allocated, without changing the most recently
used page. There must be at least 3 pages in the system. So making the page
the MRU's prevPage is sufficient to ensure it won't be deallocated."
"MRUP-->used page<->used page<->used page<->used page<--LRUP
^ <-next-prev-> ^
| |
v <-prev-next-> v
free page<->free page<->free page<->free page"
+ <var: #page type: #'StackPage *'>
- <var: #page type: 'StackPage *'>
self assert: page ~~ mostRecentlyUsedPage.
page nextPage == mostRecentlyUsedPage ifTrue:
[^nil].
page prevPage nextPage: page nextPage.
page nextPage prevPage: page prevPage.
mostRecentlyUsedPage prevPage nextPage: page.
page prevPage: mostRecentlyUsedPage prevPage.
page nextPage: mostRecentlyUsedPage.
mostRecentlyUsedPage prevPage: page.
self assert: self pageListIsWellFormed!
Item was changed:
----- Method: InterpreterStackPages>>pageIndexFor: (in category 'page access') -----
pageIndexFor: pointer "<Integer>"
"Answer the page index for a pointer into stack memory, i.e. the index
for the page the address is in. N.B. This is a zero-relative index."
+ <var: #pointer type: #'void *'>
- <var: #pointer type: 'void *'>
^self pageIndexFor: pointer stackMemory: stackMemory bytesPerPage: bytesPerPage!
Item was changed:
----- Method: InterpreterStackPages>>pageListIsWellFormed (in category 'assertions') -----
pageListIsWellFormed
"Answer if the stack page list is well-formed.
MRUP-->used page<->used page<->used page<->used page<--LRUP
^ <-next-prev-> ^
| |
v <-prev-next-> v
free page<->free page<->free page<->free page"
| ok page count limit |
<inline: false>
+ <var: #page type: #'StackPage *'>
- <var: #page type: 'StackPage *'>
ok := true.
page := mostRecentlyUsedPage nextPage.
count := 1.
limit := numPages * 2.
[page isFree
and: [page ~= mostRecentlyUsedPage
and: [count <= limit]]] whileTrue:
[(self asserta: page nextPage prevPage == page) ifFalse:
[ok := false].
page := page nextPage.
count := count + 1].
[page ~= mostRecentlyUsedPage
and: [count <= limit]] whileTrue:
[(self asserta: page nextPage prevPage == page) ifFalse:
[ok := false].
(self asserta: page isFree not)
ifTrue:
[(self asserta: (self stackPageFor: page baseFP) == page) ifFalse:
[ok := false].
(self asserta: (self stackPageFor: page headSP) == page) ifFalse:
[ok := false]]
ifFalse:
[ok := false].
page := page nextPage.
count := count + 1].
(self asserta: count = numPages) ifFalse:
[ok := false].
^ok!
Item was changed:
----- Method: InterpreterStackPages>>stackPageAt: (in category 'page access') -----
stackPageAt: index
"Answer the page for a page index.
N.B. This is a zero-relative index."
+ <returnTypeC: #'StackPage *'>
- <returnTypeC: 'StackPage *'>
^self stackPageAt: index pages: pages!
Item was added:
+ ----- Method: ObjectMemory>>lengthOf: (in category 'indexing primitive support') -----
+ lengthOf: oop
+ "Return the number of indexable bytes or words in the given object. Assume the argument is not an integer. For a CompiledMethod, the size of the method header (in bytes) should be subtracted from the result."
+
+ <api>
+ | header |
+ <inline: true>
+ <asmLabel: false>
+ header := self baseHeader: oop.
+ ^self lengthOf: oop baseHeader: header format: (self formatOfHeader: header)!
Item was added:
+ ----- Method: ObjectMemory>>lengthOf:baseHeader:format: (in category 'indexing primitive support') -----
+ lengthOf: oop baseHeader: hdr format: fmt
+ "Return the number of indexable bytes or words in the given object. Assume the given oop is not an integer. For a CompiledMethod, the size of the method header (in bytes) should be subtracted from the result of this method."
+
+ | sz |
+ <inline: true>
+ <asmLabel: false>
+ (hdr bitAnd: TypeMask) = HeaderTypeSizeAndClass
+ ifTrue: [ sz := (self sizeHeader: oop) bitAnd: self longSizeMask ]
+ ifFalse: [ sz := (hdr bitAnd: self sizeMask)].
+ sz := sz - (hdr bitAnd: self size4Bit).
+ fmt <= 4
+ ifTrue: [ ^ (sz - self baseHeaderSize) >> self shiftForWord "words"].
+ fmt < 8
+ ifTrue: [ ^ (sz - self baseHeaderSize) >> 2 "32-bit longs"]
+ ifFalse: [ ^ (sz - self baseHeaderSize) - (fmt bitAnd: 3) "bytes"]!
Item was changed:
----- Method: ObjectMemory>>slotSizeOf: (in category 'object format') -----
slotSizeOf: oop
"Returns the number of slots in the receiver.
If the receiver is a byte object, return the number of bytes.
Otherwise return the number of words."
(self isIntegerObject: oop) ifTrue:[^0].
+ ^self lengthOf: oop!
- ^interpreter lengthOf: oop!
Item was added:
+ ----- Method: ObjectMemorySimulator>>allObjectsDo: (in category 'debug support') -----
+ allObjectsDo: objBlock
+
+ | oop |
+ oop := self firstObject.
+ [oop < self endOfMemory] whileTrue:
+ [(self isFreeObject: oop)
+ ifFalse: [objBlock value: oop].
+ oop := self objectAfter: oop].
+ !
Item was added:
+ ----- 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 endOfMemory] whileTrue:
+ [(self isFreeObject: oop)
+ ifFalse: [(objBlock value: oop) ifTrue: [selected addLast: oop]].
+ oop := self objectAfter: oop].
+ ^ selected!
Item was added:
+ ----- Method: ObjectMemorySimulator>>numObjects (in category 'debug support') -----
+ numObjects
+
+ | count oop |
+ count := 0.
+ oop := self firstObject.
+ [oop < self endOfMemory] whileTrue:
+ [(self isFreeObject: oop)
+ ifFalse: [count := count + 1].
+ oop := self objectAfter: oop].
+ ^count
+ !
Item was changed:
----- Method: SlangTestSupportInterpreter>>methodWithLoopLimitThatMightBeModified: (in category 'loop limits') -----
methodWithLoopLimitThatMightBeModified: arrayObj
+ 0 to: (objectMemory lengthOf: arrayObj) do:
- 0 to: (self lengthOf: arrayObj) do:
[:i | self storePointerUnchecked: i ofObject: arrayObj withValue: nilObj]
!
Item was changed:
----- Method: VMMaker class>>versionString (in category 'version testing') -----
versionString
"VMMaker versionString"
+ ^'4.12.4'!
- ^'4.12.3'!
More information about the Vm-dev
mailing list