'From Squeak 1.18 of December 12, 1996 on 17 March 1997 at 9:29:11 pm'! Object subclass: #ObjectMemory instanceVariableNames: 'memory youngStart endOfMemory memoryLimit nilObj falseObj trueObj specialObjectsOop rootTable rootTableCount child field parentField freeBlock lastHash freeLargeContexts freeSmallContexts allocationCount lowSpaceThreshold signalLowSpace compStart compEnd fwdTableNext fwdTableLast remapBuffer remapBufferCount interruptCheckCounter checkAssertions oldImageFormatVersion ' classVariableNames: 'AllocationsBetweenGCs StartObj HeaderTypeFree ConstTwo TheInputSemaphore ClassPoint SmallContextSize ClassCharacter Done Upward FalseObject TypeMask StackStart ClassProcess HashBitsOffset CompactClasses ConstMinusOne ClassArray FreeSizeMask ClassLargePositiveInteger TheTimerSemaphore ClassBlockContext ClassCompiledMethod RootTableSize ConstOne GCTopMarker ClassBitmap CharacterTable ClassFloat SelectorMustBeBoolean ClassInteger ClassSemaphore AllButHashBits HeaderTypeClass NilContext ClassString HashBits NilObject MinimumForwardTableBytes SelectorCannotReturn HeaderTypeGC SelectorDoesNotUnderstand AllButTypeMask MarkBit TheLowSpaceSemaphore SchedulerAssociation RemapBufferSize AllButRootBit LargeContextSize BaseHeaderSize ClassMethodContext RootBit AllButMarkBit AllButMarkBitAndTypeMask HeaderTypeShort TrueObject HeaderTypeSizeAndClass ClassByteArray StartField SpecialSelectors ConstZero TheDisplay TheInterruptSemaphore ClassMessage ' poolDictionaries: '' category: 'Squeak Interpreter'! !CCodeGenerator methodsFor: 'C translation'! generateIntegerObjectOf: msgNode on: aStream indent: level "Generate the C code for this message onto the given stream." aStream nextPutAll: '(('. self emitCExpression: msgNode args first on: aStream. aStream nextPutAll: ' << 2) | 3)'.! generateIntegerValueOf: msgNode on: aStream indent: level "Generate the C code for this message onto the given stream." aStream nextPutAll: '('. self emitCExpression: msgNode args first on: aStream. aStream nextPutAll: ' >> 2)'.! generateIsIntegerObject: msgNode on: aStream indent: level "Generate the C code for this message onto the given stream." aStream nextPutAll: '(('. self emitCExpression: msgNode args first on: aStream. aStream nextPutAll: ' & 2) == 2)'.! ! !Interpreter class methodsFor: 'initialization'! patchInitializePrimitiveTable "Interpreter patchInitializePrimitiveTable" "patch the method initializing the primitive table. Signal an error if the text to replace cannot be found" | tabtab cr oldString newString oldSource newSource | tabtab _ String with: Character tab with: Character tab. cr _ String with: Character cr. oldString _ tabtab, '(126 primitiveFail)', cr, tabtab, '(127 primitiveFail)'. newString _ tabtab, '(126 primitiveImmediateValue) "patched"', cr, tabtab, '(127 primitiveNewImmediateObject) "patched"'. oldSource _ self class sourceCodeAt: #initializePrimitiveTable. newSource _ oldSource copyReplaceAll: oldString with: newString. newSource = oldSource ifTrue: [self error: 'method could not be patched']. self class compile: newSource classified: #initialization. self initializePrimitiveTable! ! !ObjectMemory methodsFor: 'initialization'! adjustAllOopsBy: bytesToShift "Adjust all oop references by the given number of bytes. This is done just after reading in an image when the new base address of the object heap is different from the base address in the image." | oop | (bytesToShift = 0 and: [oldImageFormatVersion = self imageFormatVersion]) ifTrue: [ ^ nil ]. oop _ self firstObject. [oop < endOfMemory] whileTrue: [ (self isFreeObject: oop) ifFalse: [ self adjustFieldsAndClassOf: oop by: bytesToShift. ]. oop _ self objectAfter: oop. ]. ! adjustFieldsAndClassOf: oop by: offsetBytes "Adjust all pointers in this object by the given offset." | fieldAddr fieldOop classHeader newClassOop | oldImageFormatVersion = 6502 ifTrue: [fieldAddr _ oop + (self oldFormatLastPointerOf: oop)] ifFalse: [fieldAddr _ oop + (self lastPointerOf: oop)]. [fieldAddr > oop] whileTrue: [ fieldOop _ self longAt: fieldAddr. (self isImmediateObject: fieldOop) ifTrue: [ oldImageFormatVersion = 6502 ifTrue: [ "convert integers from 1 tag bit to 2 tag bits" self longAt: fieldAddr put: (fieldOop << 1 + 1 bitAnd: 16rFFFFFFFF) ] ] ifFalse: [ self longAt: fieldAddr put: (fieldOop + offsetBytes). ]. fieldAddr _ fieldAddr - 4. ]. (self headerType: oop) ~= HeaderTypeShort ifTrue: [ "adjust class header if not a compact class" classHeader _ self longAt: (oop - 4). newClassOop _ (classHeader bitAnd: AllButTypeMask) + offsetBytes. self longAt: (oop - 4) put: (newClassOop bitOr: (classHeader bitAnd: TypeMask)). ]. ! ! !ObjectMemory methodsFor: 'interpreter access'! fetchClassOf: oop | ccIndex | (self isImmediateObject: oop) ifTrue: [ (self isIntegerObject: oop) ifTrue: [^ self splObj: ClassInteger ] ifFalse: [ ccIndex _ ((oop >> 2) bitAnd: 16rF) + 31. ^ self fetchPointer: ccIndex ofObject: (self fetchPointer: CompactClasses ofObject: specialObjectsOop) ] ]. ccIndex _ (((self baseHeader: oop) >> 12) bitAnd: 16r1F) - 1. ccIndex < 0 ifTrue: [ ^ (self classHeader: oop) bitAnd: AllButTypeMask ] ifFalse: [ "look up compact class" ^ self fetchPointer: ccIndex ofObject: (self fetchPointer: CompactClasses ofObject: specialObjectsOop) ]. ! integerObjectOf: value "adjusted for 2 tag bits" value < 0 ifTrue: [^ ((16r40000000 + value) << 2) + 3] ifFalse: [^ (value << 2) + 3]! integerValueOf: objectPointer "adjusted for 2 tag bits" "Translator produces 'objectPointer >> 2'" ((objectPointer bitAnd: 16r80000000) ~= 0) ifTrue: ["negative" ^ ((objectPointer bitAnd: 16r7FFFFFFF) >> 2) - 16r1FFFFFFF - 1 "Faster than -16r20000000 (a LgInt)"] ifFalse: ["positive" ^ objectPointer >> 2]! isImmediateObject: objectPointer ^(objectPointer bitAnd: 1) ~= 0! isIntegerObject: objectPointer ^(objectPointer bitAnd: 2) ~= 0! isIntegerValue: valueWord "adjusted for 2 tag bits" ^ valueWord >= 16r-20000000 and: [valueWord < 16r20000000]! ! !ObjectMemory methodsFor: 'object enumeration'! lastPointerOf: objectPointer "Return the byte offset of the last pointer field of the given object. Works with CompiledMethods, as well as ordinary objects. Can be used even when the type bits are not correct." | fmt sz methodHeader | fmt _ self formatOf: objectPointer. fmt < 4 ifTrue: [ sz _ self sizeBitsOfSafe: objectPointer. ^ sz - BaseHeaderSize "all pointers" ]. fmt < 12 ifTrue: [ ^0 ]. "no pointers" "CompiledMethod: contains both pointers and bytes:" methodHeader _ self longAt: objectPointer + BaseHeaderSize. ^ ((methodHeader >> 11) bitAnd: 16rFF) * 4 + BaseHeaderSize! oldFormatLastPointerOf: objectPointer "Return the byte offset of the last pointer field of the given object. Works with CompiledMethods, as well as ordinary objects. Can be used even when the type bits are not correct." | fmt sz methodHeader | fmt _ self formatOf: objectPointer. fmt < 4 ifTrue: [ sz _ self sizeBitsOfSafe: objectPointer. ^ sz - BaseHeaderSize "all pointers" ]. fmt < 12 ifTrue: [ ^0 ]. "no pointers" "CompiledMethod: contains both pointers and bytes:" methodHeader _ self longAt: objectPointer + BaseHeaderSize. ^ ((methodHeader >> 10) bitAnd: 16rFF) * 4 + BaseHeaderSize! ! !ObjectMemory methodsFor: 'garbage collection'! beRootIfOld: oop "Record that the given oop in the old object area may point to an object in the young area." | header | ((oop < youngStart) and: [(self isImmediateObject: oop) not]) ifTrue: [ "oop is in the old object area" header _ self longAt: oop. (header bitAnd: RootBit) = 0 ifTrue: [ "record oop as root only if not already recorded" rootTableCount < RootTableSize ifTrue: [ "record root only if there is room in the roots table" rootTableCount _ rootTableCount + 1. rootTable at: rootTableCount put: oop. self longAt: oop put: (header bitOr: RootBit). ]. ]. ].! possibleRootStoreInto: oop value: valueObj "Called when storing the given value object into the given old object. If valueObj is young, record the fact that oldObj is now a root for incremental garbage collection." "Warning: No young objects should be recorded as roots." | header | ((valueObj >= youngStart) and: [(self isImmediateObject: valueObj) not]) ifTrue: [ header _ self longAt: oop. (header bitAnd: RootBit) = 0 ifTrue: [ "record oop as root only if not already recorded" rootTableCount < RootTableSize ifTrue: [ "record root only if there is room in the roots table" rootTableCount _ rootTableCount + 1. rootTable at: rootTableCount put: oop. self longAt: oop put: (header bitOr: RootBit). ]. ]. ].! ! !ObjectMemory methodsFor: 'gc -- mark and sweep'! markPhase "Mark phase of the mark and sweep garbage collector. Set the mark bits of all reachable objects. Free chunks are untouched by this process." "Assume: All non-free objects are initially unmarked. Root objects were unmarked when they were made roots. (Make sure this stays true!!!!)." | oop | "clear the recycled context lists" freeSmallContexts _ NilContext. freeLargeContexts _ NilContext. "trace the interpreter's objects, including the active stack and special objects array" self markAndTraceInterpreterOops. "trace the roots" 1 to: rootTableCount do: [ :i | oop _ rootTable at: i. (self isImmediateObject: oop) ifFalse: [ self markAndTrace: oop ]. ]. ! ! !ObjectMemory methodsFor: 'gc -- compaction'! lastPointerWhileForwarding: oop "The given object may have its header word in a forwarding block. Find the offset of the last pointer in the object in spite of this obstacle." | header fwdBlock fmt size methodHeader | header _ self longAt: oop. (header bitAnd: MarkBit) ~= 0 ifTrue: [ "oop is forwarded; get its real header from its forwarding table entry" fwdBlock _ header bitAnd: AllButMarkBitAndTypeMask. checkAssertions ifTrue: [ self fwdBlockValidate: fwdBlock ]. header _ self longAt: fwdBlock + 4. ]. fmt _ (header >> 8) bitAnd: 16rF. fmt < 4 ifTrue: [ "do sizeBitsOf: using the header we obtained" (header bitAnd: TypeMask) = HeaderTypeSizeAndClass ifTrue: [ size _ (self sizeHeader: oop) bitAnd: 16rFFFFFFC ] ifFalse: [ size _ header bitAnd: 16rFC ]. ^ size - BaseHeaderSize ]. fmt < 12 ifTrue: [ ^ 0 ]. "no pointers" methodHeader _ self longAt: oop + BaseHeaderSize. ^ ((methodHeader >> 11) bitAnd: 16rFF) * 4 + BaseHeaderSize! ! !ObjectMemory methodsFor: 'become'! containOnlyOops: array1 and: array2 "Return true if neither array contains a small integer. You can't become: integers!!" | fieldOffset | fieldOffset _ self lastPointerOf: array1. "same size as array2" [fieldOffset >= BaseHeaderSize] whileTrue: [ (self isImmediateObject: (self longAt: array1 + fieldOffset)) ifTrue: [ ^ false ]. (self isImmediateObject: (self longAt: array2 + fieldOffset)) ifTrue: [ ^ false ]. fieldOffset _ fieldOffset - 4. ]. ^ true! ! !Interpreter methodsFor: '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 | (self isImmediateObject: oop) ifTrue: [ successFlag _ false. ^ nil ]. ccIndex _ ((self baseHeader: oop) >> 12) bitAnd: 16r1F. ccIndex = 0 ifTrue: [ cl _ ((self classHeader: oop) bitAnd: AllButTypeMask) ] ifFalse: [ "look up compact class" cl _ (self fetchPointer: (ccIndex - 1) ofObject: (self fetchPointer: CompactClasses ofObject: specialObjectsOop))]. self success: cl = classOop. ! ! !Interpreter methodsFor: '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 | nilObj _ self remap: nilObj. falseObj _ self remap: falseObj. trueObj _ self remap: trueObj. specialObjectsOop _ self remap: specialObjectsOop. stackPointer _ stackPointer - activeContext. "*rel to active" activeContext _ self remap: activeContext. stackPointer _ stackPointer + activeContext. "*rel to active" theHomeContext _ self remap: theHomeContext. instructionPointer _ instructionPointer - method. "*rel to method" method _ self remap: method. instructionPointer _ instructionPointer + method. "*rel to method" receiver _ self remap: receiver. messageSelector _ self remap: messageSelector. newMethod _ self remap: newMethod. 1 to: remapBufferCount do: [ :i | oop _ remapBuffer at: i. (self isImmediateObject: oop) ifFalse: [ remapBuffer at: i put: (self remap: oop). ]. ]. "The method cache uses oops as hashes -- toss the whole thing." self flushMethodCache.! markAndTraceInterpreterOops "Mark and trace all oops in the interpreter's state." "Assume: All traced variables contain valid oops." | oop | self markAndTrace: specialObjectsOop. "also covers nilObj, trueObj, falseObj, and compact classes" self markAndTrace: activeContext. "traces entire stack" "also covers theHomeContext, receiver, method" self markAndTrace: messageSelector. self markAndTrace: newMethod. 1 to: remapBufferCount do: [ :i | oop _ remapBuffer at: i. (self isImmediateObject: oop) ifFalse: [ self markAndTrace: oop. ]. ].! ! !Interpreter methodsFor: 'compiled methods'! argumentCountOf: methodPointer ^ ((self headerOf: methodPointer) >> 26) bitAnd: 16r1F! headerOf: methodPointer ^self fetchPointer: HeaderIndex ofObject: methodPointer! literalCountOfHeader: headerPointer ^ (headerPointer >> 11) bitAnd: 16rFF! primitiveIndexOf: methodPointer ^ ((self headerOf: methodPointer) >> 2) bitAnd: 16r1FF! ! !Interpreter methodsFor: 'object format'! formatOfClass: classPointer "**should be in-lined**" "Note that, in Smalltalk, the instSpec will be equal to the inst spec part of the base header of an instance (without hdr type) shifted left 1. In this way, apart from the smallInt bit, the bits are just where you want them for the first header word." "Callers expect low 2 bits (header type) to be zero!!" ^ (self fetchPointer: InstanceSpecificationIndex ofObject: classPointer) - 3 >> 1! ! !Interpreter methodsFor: 'message sending'! activateNewMethod | methodHeader smallContext newContext initialIP tempCount i contextEnd nilOop | methodHeader _ self headerOf: newMethod. smallContext _ ((methodHeader >> 19) bitAnd: 1) = 0. newContext _ self allocateOrRecycleContext: smallContext. initialIP _ ((LiteralStart + (self literalCountOfHeader: methodHeader)) * 4) + 1. tempCount _ (methodHeader >> 20) bitAnd: 16r3F. "Assume: newContext will be recorded as a root if necessary by the call to newActiveContext: below, so we can use unchecked stores." self storePointerUnchecked: SenderIndex ofObject: newContext withValue: activeContext. self storeWord: InstructionPointerIndex ofObject: newContext withValue: (self integerObjectOf: initialIP). self storeWord: StackPointerIndex ofObject: newContext withValue: (self integerObjectOf: tempCount). self storePointerUnchecked: MethodIndex ofObject: newContext withValue: newMethod. self transfer: argumentCount + 1 fromIndex: self stackPointerIndex - argumentCount ofObject: activeContext toIndex: ReceiverIndex ofObject: newContext. "clear extra context fields to nil in case it is recycled" nilOop _ nilObj. i _ newContext + ((ReceiverIndex + argumentCount + 1) * 4). smallContext ifTrue: [ contextEnd _ newContext + SmallContextSize - BaseHeaderSize ] ifFalse: [ contextEnd _ newContext + LargeContextSize - BaseHeaderSize ]. [i < contextEnd] whileTrue: [ i _ i + 4. self longAt: i put: nilOop. ]. self pop: argumentCount + 1. reclaimableContextCount _ reclaimableContextCount + 1. self newActiveContext: newContext.! ! !Interpreter methodsFor: 'array and stream primitives'! commonAt: stringy "This version of at: is called from the special byteCode, from primitiveAt, and from primStringAt. The boolean 'stringy' indicates that the result should be converted to a Character." | index array result | index _ self popInteger. array _ self popStack. self success: (self isImmediateObject: array) not. successFlag ifTrue: [ result _ self stObject: array at: index. ]. successFlag ifTrue: [ stringy ifTrue: [ self push: (self characterForAscii: result) ] ifFalse: [ self push: result ]. ] ifFalse: [ self unPop: 2. stringy ifTrue: [ self failSpecialPrim: 63 ] ifFalse: [ self failSpecialPrim: 60 ]. ].! primitiveStringReplace " primReplaceFrom: start to: stop with: replacement startingAt: repStart " | array start stop replacement repStart arrayInstSize repInstSize fmt repi | array _ self stackValue: 4. start _ self stackIntegerValue: 3. stop _ self stackIntegerValue: 2. replacement _ self stackValue: 1. repStart _ self stackIntegerValue: 0. (self isImmediateObject: replacement) "can happen in LgInt copy" ifTrue: [^ self primitiveFail]. arrayInstSize _ self fixedFieldsOf: array. repInstSize _ self fixedFieldsOf: replacement. self success: start >= 1. self success: start <= stop. self success: (stop + arrayInstSize <= (self lengthOf: array)). self success: repStart >= 1. self success: (stop - start + repStart + repInstSize <= (self lengthOf: replacement)). fmt _ self formatOf: array. fmt < 8 "Array formats (without byteSize bits) must be same" ifTrue: [self success: fmt = (self formatOf: replacement)] ifFalse: [self success: (fmt bitAnd: 16rC) = ((self formatOf: replacement) bitAnd: 16rC)]. successFlag ifFalse: [^ self primitiveFail]. repi _ repStart + repInstSize - 1. " - 1 for 0-based access" start + arrayInstSize - 1 to: stop + arrayInstSize - 1 do: [:i | fmt < 4 ifTrue: ["pointer type objects" self storePointer: i ofObject: array withValue: (self fetchPointer: repi ofObject: replacement)] ifFalse: [fmt < 8 ifTrue: ["long-word type objects" self storeWord: i ofObject: array withValue: (self fetchWord: repi ofObject: replacement)] ifFalse: ["byte-type objects" self storeByte: i ofObject: array withValue: (self fetchByte: repi ofObject: replacement)]]. repi _ repi + 1]. self pop: 4.! stSizeOf: oop "Return the number of indexable fields in the given object. (i.e. what ST would return for size)." "Note: oop may be a SmallInteger!!" | totalLength fixedFields | (self isImmediateObject: oop) ifTrue: [ ^ 0 ]. "immediates have no indexable fields" totalLength _ self lengthOf: oop. fixedFields _ self fixedFieldsOf: oop. ^ totalLength - fixedFields! ! !Interpreter methodsFor: 'object access primitives'! checkInstanceVariableBoundsOf: index in: object "NOTE: this should really only work for index <= fixed instSize" self success: (self isImmediateObject: object) not. successFlag ifTrue: [ self success: index >= 1. self success: index <= (self lengthOf: object)]! primitiveImmediateValue "Return the integer value of the given immediate object" | instance | instance _ self popStack. self success: (self isImmediateObject: instance). successFlag ifTrue: [self push: (instance bitOr: 3)] ifFalse: [self unPop: 1]! primitiveNewImmediateObject "Return a new immediate instance of the receiver class, with the value given by the argument. Check that the returend object is indeed an instance of the receiver class." | class value ccIndex immClass | value _ self popStack. self success: (self isIntegerObject: value). class _ self popStack. value _ value bitAnd: 2 bitInvert32. ccIndex _ ((value >> 2) bitAnd: 16rF) + 31. immClass _ (self fetchPointer: ccIndex ofObject: (self fetchPointer: CompactClasses ofObject: specialObjectsOop)). self success: immClass == class. successFlag ifTrue: [ self push: value] ifFalse: [ self unPop: 2 ].! primitiveObjectPointsTo | rcvr thang lastField | thang _ self popStack. rcvr _ self popStack. (self isImmediateObject: rcvr) ifTrue: [^ self pushBool: false]. lastField _ self lastPointerOf: rcvr. BaseHeaderSize to: lastField by: 4 do: [:i | (self longAt: rcvr + i) = thang ifTrue: [^ self pushBool: true]]. self pushBool: false.! ! !Interpreter methodsFor: 'sound primitives'! primitiveShortAt "Treat the receiver, which can be indexible by either bytes or words, as an array of signed 16-bit values. Return the contents of the given index. Note that the index specifies the i-th 16-bit entry, not the i-th byte or word." | index rcvr sz addr value | index _ self stackIntegerValue: 0. rcvr _ self stackValue: 1. self success: ((self isImmediateObject: rcvr) not and: [self isWordsOrBytes: rcvr]). successFlag ifFalse: [ ^ nil ]. sz _ ((self sizeBitsOf: rcvr) - BaseHeaderSize) // 2. "number of 16-bit fields" self success: ((index >= 1) and: [index <= sz]). successFlag ifTrue: [ addr _ rcvr + BaseHeaderSize + (2 * (index - 1)). value _ self cCode: '*((short int *) addr)'. self pop: 2. "pop rcvr, index" self pushInteger: value. "push element value" ].! primitiveShortAtPut "Treat the receiver, which can be indexible by either bytes or words, as an array of signed 16-bit values. Set the contents of the given index to the given value. Note that the index specifies the i-th 16-bit entry, not the i-th byte or word." | index rcvr sz addr value | value _ self stackIntegerValue: 0. index _ self stackIntegerValue: 1. rcvr _ self stackValue: 2. self success: ((self isImmediateObject: rcvr) not and: [self isWordsOrBytes: rcvr]). successFlag ifFalse: [ ^ nil ]. sz _ ((self sizeBitsOf: rcvr) - BaseHeaderSize) // 2. "number of 16-bit fields" self success: ((index >= 1) and: [index <= sz]). self success: ((value >= -32768) and: [value <= 32767]). successFlag ifTrue: [ addr _ rcvr + BaseHeaderSize + (2 * (index - 1)). self cCode: '*((short int *) addr) = value'. self pop: 2. "pop index and value; leave rcvr on stack" ].! ! !Interpreter methodsFor: 'debug support'! okayFields: oop "If this is a pointers object, check that its fields are all okay oops." | i fieldOop | (oop = nil or: [oop = 0]) ifTrue: [ ^true ]. (self isImmediateObject: oop) ifTrue: [ ^true ]. self okayOop: oop. self oopHasOkayClass: oop. (self isPointers: oop) ifFalse: [ ^true ]. i _ (self lengthOf: oop) - 1. [i >= 0] whileTrue: [ fieldOop _ self fetchPointer: i ofObject: oop. (self isImmediateObject: fieldOop) ifFalse: [ self okayOop: fieldOop. self oopHasOkayClass: fieldOop. ]. i _ i - 1. ].! okayInterpreterObjects | oopOrZero oop | self okayFields: nilObj. self okayFields: falseObj. self okayFields: trueObj. self okayFields: specialObjectsOop. self okayFields: activeContext. self okayFields: method. self okayFields: receiver. self okayFields: theHomeContext. self okayFields: messageSelector. self okayFields: newMethod. 1 to: MethodCacheEntries do: [ :i | oopOrZero _ methodCache at: i. oopOrZero = 0 ifFalse: [ self okayFields: (methodCache at: i). "selector" self okayFields: (methodCache at: i + MethodCacheEntries). "class" self okayFields: (methodCache at: i + (2 * MethodCacheEntries)). "method" ]. ]. 1 to: remapBufferCount do: [ :i | oop _ remapBuffer at: i. (self isImmediateObject: oop) ifFalse: [ self okayFields: oop. ]. ]. self okayActiveProcessStack.! okayOop: oop "Verify that the given oop is legitimate. Check address, header, and size but not class." | sz type fmt | "address and size checks" (self isImmediateObject: oop) ifTrue: [ ^true ]. ((0 < oop) & (oop < endOfMemory)) ifFalse: [ self error: 'oop is not a valid address' ]. ((oop \\ 4) = 0) ifFalse: [ self error: 'oop is not a word-aligned address' ]. sz _ self sizeBitsOf: oop. (oop + sz) < endOfMemory ifFalse: [ self error: 'oop size would make it extend beyond the end of memory' ]. "header type checks" type _ self headerType: oop. type = HeaderTypeFree ifTrue: [ self error: 'oop is a free chunk, not an object' ]. type = HeaderTypeShort ifTrue: [ (((self baseHeader: oop) >> 12) bitAnd: 16r1F) = 0 ifTrue: [ self error: 'cannot have zero compact class field in a short header' ]. ]. type = HeaderTypeClass ifTrue: [ ((oop >= 4) and: [(self headerType: oop - 4) = type]) ifFalse: [ self error: 'class header word has wrong type' ]. ]. type = HeaderTypeSizeAndClass ifTrue: [ ((oop >= 8) and: [(self headerType: oop - 8) = type and: [(self headerType: oop - 4) = type]]) ifFalse: [ self error: 'class header word has wrong type' ]. ]. "format check" fmt _ self formatOf: oop. ((fmt = 4) | (fmt = 5) | (fmt = 7)) ifTrue: [ self error: 'oop has an unknown format type' ]. "mark and root bit checks" ((self longAt: oop) bitAnd: 16r20000000) = 0 ifFalse: [ self error: 'unused header bit 30 is set; should be zero' ]. "xxx ((self longAt: oop) bitAnd: MarkBit) = 0 ifFalse: [ self error: 'mark bit should not be set except during GC' ]. xxx" (((self longAt: oop) bitAnd: RootBit) = 1 and: [oop >= youngStart]) ifTrue: [ self error: 'root bit is set in a young object' ]. ^true! oopHasOkayClass: oop "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." | oopClass formatMask behaviorFormatBits oopFormatBits | self okayOop: oop. oopClass _ self fetchClassOf: oop. (self isImmediateObject: oopClass) ifTrue: [ self error: 'an immediate object is not a valid class or behavior' ]. self okayOop: oopClass. ((self isPointers: oopClass) and: [(self lengthOf: oopClass) >= 3]) ifFalse: [ self error: 'a class (behavior) must be a pointers object of size >= 3' ]. (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: [ self error: 'object and its class (behavior) formats differ' ]. ^true! ! !Interpreter methodsFor: 'image save/restore'! checkImageVersionFrom: f "Read and verify the image file version number and return true if the the given image file needs to be byte-swapped. As a side effect, position the file stream just after the version number of the image header. This code prints a warning and does a hard-exit if it cannot find a valid version number." "This code is based on C code by Ian Piumarta." | expectedVersion firstVersion previousVersion | self var: #f declareC: 'FILE *f'. expectedVersion _ self imageFormatVersion. previousVersion _ self previousImageFormatVersion. "check the version number" self fileSeek: f position: 0. oldImageFormatVersion _ firstVersion _ self getLongFromFile: f swap: false. (oldImageFormatVersion = expectedVersion or: [oldImageFormatVersion = previousVersion]) ifTrue: [^ false]. "try with byte reversal" self fileSeek: f position: 0. oldImageFormatVersion _ self getLongFromFile: f swap: true. (oldImageFormatVersion = expectedVersion or: [oldImageFormatVersion = previousVersion]) ifTrue: [^ true]. "try skipping the first 512 bytes (prepended by certain Mac file transfer utilities)" self fileSeek: f position: 512. oldImageFormatVersion _ self getLongFromFile: f swap: false. (oldImageFormatVersion = expectedVersion or: [oldImageFormatVersion = previousVersion]) ifTrue: [^ false]. "try skipping the first 512 bytes with byte reversal" self fileSeek: f position: 512. oldImageFormatVersion _ self getLongFromFile: f swap: true. (oldImageFormatVersion = expectedVersion or: [oldImageFormatVersion = previousVersion]) ifTrue: [^ true]. "hard failure; abort" self print: 'This interpreter (vers. '. self printNum: expectedVersion. self print: ') cannot read image file (vers. '. self printNum: firstVersion; print: ')'. self cr. self exit: -1. ! imageFormatVersion "Return a magic constant that changes when the image format changes. Since the image reading code uses this to detect byte ordering, one must avoid version numbers that are invariant under byte reversal." ^ 6503! previousImageFormatVersion "Return a magic constant that changes when the image format changes. This is the version number for the previous image format, which can still be read and converted." ^ 6502! ! !InterpreterSimulator methodsFor: 'initialization'! openOn: fileName extraMemory: extraBytes "InterpreterSimulator new openOn: 'clone.im' extraMemory: 100000" | f headerSize count oldBaseAddr bytesToShift | "open image file and read the header" f _ FileStream oldFileNamed: fileName. imageName _ f fullName. f binary; readOnly. oldImageFormatVersion _ self nextLongFrom: f. "current version: 6502" headerSize _ self nextLongFrom: f. endOfMemory _ self nextLongFrom: f. "first unused location in heap" oldBaseAddr _ self nextLongFrom: f. "object memory base address of image" specialObjectsOop _ self nextLongFrom: f. lastHash _ 999. "Should be loaded from, and saved to the image header" "allocate interpreter memory" memoryLimit _ endOfMemory + extraBytes. "read in the image" f position: headerSize. memory _ Bitmap new: memoryLimit // 4. count _ f readInto: memory startingAt: 1 count: endOfMemory // 4. count ~= (endOfMemory // 4) ifTrue: [self halt]. f close. self initialize. bytesToShift _ 0 - oldBaseAddr. "adjust pointers for zero base address" endOfMemory _ endOfMemory. self initializeInterpreter: bytesToShift. checkAssertions _ false.! ! !InterpreterSimulator methodsFor: 'debug support'! hexDump: oop | byteSize val | (self isImmediateObject: oop) ifTrue: [^ self shortPrint: oop]. ^ String streamContents: [:strm | byteSize _ 256 min: (self sizeBitsOf: oop)-4. (self headerStart: oop) to: byteSize by: 4 do: [:a | val _ self longAt: oop+a. strm cr; nextPutAll: (a<16 ifTrue: [' ', a hex] ifFalse: [a hex]); space; space; space; nextPutAll: val hex8; space; space. a=0 ifTrue: [strm nextPutAll: (self dumpHeader: val)] ifFalse: [strm nextPutAll: (self charsOfLong: val)]]]! longPrint: oop | lastPtr val lastLong hdrType prevVal | (self isImmediateObject: oop) ifTrue: [^ self shortPrint: oop]. ^ String streamContents: [:strm | lastPtr _ 256 min: (self lastPointerOf: oop). hdrType _ self headerType: oop. hdrType = 2 ifTrue: [lastPtr _ 0]. prevVal _ 0. (self headerStart: oop) to: lastPtr by: 4 do: [:a | val _ self longAt: oop+a. (a > 0 and: [(val = prevVal) & (a ~= lastPtr)]) ifTrue: [prevVal = (self longAt: oop+a-8) ifFalse: [strm cr; nextPutAll: ' ...etc...']] ifFalse: [strm cr; nextPutAll: (a<16 ifTrue: [' ', a hex] ifFalse: [a hex]); space; space; space; nextPutAll: val hex8; space; space. a=-8 ifTrue: [strm nextPutAll: 'size = ' , (val - hdrType) hex]. a=-4 ifTrue: [strm nextPutAll: '<' , (self nameOfClass: (val - hdrType)) , '>']. a=0 ifTrue: [strm cr; tab; nextPutAll: (self dumpHeader: val)]. a>0 ifTrue: [strm nextPutAll: (self shortPrint: val)]. a=4 ifTrue: [(self fetchClassOf: oop) = (self splObj: ClassCompiledMethod) ifTrue: [strm cr; tab; nextPutAll: (self dumpMethodHeader: val)]]]. prevVal _ val]. lastLong _ 256 min: (self sizeBitsOf: oop) - 4. hdrType = 2 ifTrue: ["free" strm cr; nextPutAll: (oop+(self longAt: oop)-2) hex; space; space; nextPutAll: (oop+(self longAt: oop)-2) printString] ifFalse: [lastPtr+4 to: lastLong by: 4 do: [:a | val _ self longAt: oop+a. strm cr; nextPutAll: (a<16 ifTrue: [' ', a hex] ifFalse: [a hex]); space; space; space. strm nextPutAll: val hex8; space; space; nextPutAll: (self charsOfLong: val)]]. ]! !