[Vm-dev] VM Maker: VMMaker.oscog-eem.349.mcz

commits at source.squeak.org commits at source.squeak.org
Thu Sep 5 21:24:45 UTC 2013 

Eliot Miranda uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker.oscog-eem.349.mcz

==================== Summary ====================

Name: VMMaker.oscog-eem.349
Author: eem
Time: 5 September 2013, 2:21:47.363 pm
UUID: bdefa809-bedc-4e5d-ae05-854c29e3dfde
Ancestors: VMMaker.oscog-eem.348

Fix a bad bug with Spur's identityHash (was assigning the classIndex!!).

Add more protocol (e.g. is:instanceOf:compactClassIndex:).

Fix more printing code in the interpreter to use
addressCouldBeObj: et al, instead of explicit between: startOfMemory and: freeStart.

Add StackInterpreter inst var methodDictionaryLinearSearchLimit to
allow an un-rehashed image to run.

=============== Diff against VMMaker.oscog-eem.348 ===============

Item was changed:
  CogClass subclass: #SpurMemoryManager
(excessive size, no diff calculated)

Item was added:
+ ----- Method: SpurMemoryManager class>>initializeObjectHeaderConstants (in category 'class initialization') -----
+ initializeObjectHeaderConstants
+ 
+ 	BytesPerWord ifNil: [BytesPerWord := 4].  "May get called on fileIn, so supply default"
+ 	BaseHeaderSize := 8 "Alas so much of the VM uses BaseheaderSize explicitly we don't (yet) make it a message."!

Item was changed:
  ----- Method: SpurMemoryManager class>>initializeWithOptions: (in category 'class initialization') -----
  initializeWithOptions: optionsDictionary
  	"SpurMemoryManager initializeWithOptions: Dictionary new"
  
  	self initBytesPerWord: (self == SpurMemoryManager
  								ifTrue: [optionsDictionary at: #BytesPerWord ifAbsent: [4]]
  								ifFalse: [self bytesPerWord]).
  	BytesPerOop := optionsDictionary at: #BytesPerOop ifAbsent: [BytesPerWord].
  
  	self initializeSpecialObjectIndices.
  	self initializeCompactClassIndices.
+ 	self initializePrimitiveErrorCodes.
+ 	self initializeObjectHeaderConstants!
- 	self initializePrimitiveErrorCodes.!

Item was added:
+ ----- Method: SpurMemoryManager>>fetchByte:ofObject: (in category 'object access') -----
+ fetchByte: byteIndex ofObject: objOop
+ 	<api>
+ 	^self byteAt: objOop + self baseHeaderSize + byteIndex!

Item was changed:
  ----- Method: SpurMemoryManager>>fetchClassOf: (in category 'object access') -----
  fetchClassOf: oop 
  	| tagBits |
+ 	(tagBits := oop bitAnd: self tagMask) ~= 0 ifTrue:
- 	(tagBits := oop bitAnd: self tagMask) = 0 ifTrue:
  		[^self fetchPointer: tagBits ofObject: classTableFirstPage].
  	^self classAtIndex: (self classIndexOf: oop)!

Item was added:
+ ----- Method: SpurMemoryManager>>fixedFieldsOf:format:length: (in category 'object format') -----
+ fixedFieldsOf: objOop format: fmt length: wordLength
+ "
+ 	NOTE: This code supports the backward-compatible extension to 8 bits of instSize.
+ 	When we revise the image format, it should become...
+ 	^ (classFormat >> 2 bitAnd: 16rFF) - 1
+ "
+ 	| class classFormat |
+ 	<inline: true>
+ 	<asmLabel: false>
+ 	((fmt > 4) or: [fmt = 2]) ifTrue: [^0].  "indexable fields only"
+ 	fmt < 2 ifTrue: [^wordLength].  "fixed fields only (zero or more)"
+ 	self flag: #fixme. "Must munge class formats now..."
+ 	"fmt = 3 or 4: mixture of fixed and indexable fields, so must look at class format word"
+ 	class := self fetchClassOfNonImm: objOop.
+ 	classFormat := self formatOfClass: class.
+ 	^(classFormat >> 11 bitAnd: 16rC0) + (classFormat >> 2 bitAnd: 16r3F) - 1!

Item was changed:
  ----- Method: SpurMemoryManager>>hashBitsOf: (in category 'header access') -----
  hashBitsOf: objOop
  	self flag: #endianness.
+ 	^(self longAt: objOop + 4) bitAnd: self identityHashHalfWordMask!
- 	^(self longAt: objOop) bitAnd: self identityHashHalfWordMask!

Item was changed:
  ----- Method: SpurMemoryManager>>headerForSlots:format:classIndex: (in category 'header format') -----
  headerForSlots: numSlots format: formatField classIndex: classIndex 
  	"The header format in LSB is
+ 	 MSB:	| 8: numSlots		| (on a byte boundary)
- 	 MSB:	| 8: slotSize			| (on a byte boundary)
  			| 2 bits				|
  			| 22: identityHash	| (on a word boundary)
  			| 3 bits				|
  			| 5: format			| (on a byte boundary)
  			| 2 bits				|
  			| 22: classIndex		| (on a word boundary) : LSB
  	 The remaining bits (7) need to be used for
  		isGrey
  		isMarked
  		isRemembered
  		isPinned
  		isImmutable
  	 leaving 2 unused bits."
+ 	<returnTypeC: #usqLong>
  	^ (numSlots << self numSlotsFullShift)
  	+ (formatField << self formatShift)
  	+ classIndex!

Item was added:
+ ----- Method: SpurMemoryManager>>is:instanceOf:compactClassIndex: (in category 'object access') -----
+ is: oop instanceOf: classOop compactClassIndex: compactClassIndex
+ 	"Answer if oop is an instance of the given class. If the class has a (non-zero)
+ 	 compactClassIndex use that to speed up the check.  N.B. Inlining should
+ 	 result in classOop not being accessed if oop's compact class index and
+ 	 compactClassIndex are non-zero."
+ 
+ 	<inline: true>
+ 	(self isImmediate: oop) ifTrue:
+ 		[^false].
+ 
+ 	^self isClassOfNonImm: oop equalTo: classOop compactClassIndex: compactClassIndex!

Item was added:
+ ----- Method: SpurMemoryManager>>isClassOfNonImm:equalTo:compactClassIndex: (in category 'object access') -----
+ isClassOfNonImm: oop equalTo: classOop compactClassIndex: knownClassIndex
+ 	"Answer if the given (non-immediate) object is an instance of the given class
+ 	 that may have a knownClassIndex (if knownClassIndex is non-zero).  This method
+ 	 is misnamed given SPur's architecture (where all objects have ``compact'' class indices)
+ 	 but is so-named for compatibility with ObjectMemory.
+ 	 N.B. Inlining and/or compiler optimization should result in classOop not being
+ 	 accessed if knownClassIndex is non-zero."
+ 
+ 	| ccIndex |
+ 	<inline: true>
+ 	<asmLabel: false>
+ 	self assert: (self isImmediate: oop) not.
+ 
+ 	ccIndex := self classIndexOf: oop.
+ 	knownClassIndex ~= 0 ifTrue:
+ 		[^knownClassIndex = ccIndex].
+ 	^classOop = (self classAtIndex: ccIndex)!

Item was added:
+ ----- Method: SpurMemoryManager>>isImmediateCharacter: (in category 'object testing') -----
+ isImmediateCharacter: oop
+ 	^(oop bitAnd: self tagMask) = 2!

Item was changed:
  ----- Method: SpurMemoryManager>>isIntegerObject: (in category 'object testing') -----
  isIntegerObject: oop
  	(#(	makeBaseFrameFor:
  		quickFetchInteger:ofObject:
  		frameOfMarriedContext:
  		addressCouldBeClassObj:
+ 		isMarriedOrWidowedContext:
+ 		shortPrint:) includes: thisContext sender method selector) ifFalse:
- 		isMarriedOrWidowedContext:) includes: thisContext sender method selector) ifFalse:
  		[self halt].
  	^(oop bitAnd: 1) ~= 0!

Item was changed:
  ----- Method: SpurMemoryManager>>setHashBitsOf:to: (in category 'header access') -----
  setHashBitsOf: objOop to: hash
+ 	self flag: #endianness.
  	self assert: (hash between: 0 and: self identityHashHalfWordMask).
+ 	self longAt: objOop + 4
+ 		put: ((self longAt: objOop + 4) bitClear: self identityHashHalfWordMask) + hash!
- 	self longAt: objOop
- 		put: ((self longAt: objOop) bitClear: self identityHashHalfWordMask) + hash!

Item was changed:
  InterpreterPrimitives subclass: #StackInterpreter
+ 	instanceVariableNames: 'currentBytecode bytecodeSetSelector localFP localIP localSP stackLimit stackPage stackPages method instructionPointer stackPointer framePointer localReturnValue extA extB primitiveFunctionPointer methodCache atCache lkupClass methodDictLinearSearchLimit highestRunnableProcessPriority nextWakeupUsecs nextPollUsecs inIOProcessEvents interruptKeycode interruptPending savedWindowSize imageHeaderFlags fullScreenFlag deferDisplayUpdates pendingFinalizationSignals extraVMMemory interpreterProxy showSurfaceFn primitiveTable externalPrimitiveTable externalPrimitiveTableFirstFreeIndex overflowedPage extraFramesToMoveOnOverflow globalSessionID jmpBuf jmpDepth suspendedCallbacks suspendedMethods numStackPages desiredNumStackPages desiredEdenBytes classNameIndex thisClassIndex metaclassSizeBits interruptCheckChain suppressHeartbeatFlag breakSelector breakSelectorLength longRunningPrimitiveCheckMethod longRunningPrimitiveCheckSemaphore longRunningPrimitiveStartUsecs longRunningPrimitiveStopUsecs longRunningPrimitiveGCUsecs longRunningPrimitiveCheckSequenceNumber longRunningPrimitiveSignalUndelivered tempOop statForceInterruptCheck statStackOverflow statStackPageDivorce statCheckForEvents statProcessSwitch statIOProcessEvents theUnknownShort imageFloatsBigEndian maxExtSemTabSizeSet lastMethodCacheProbeWrite statPendingFinalizationSignals gcSemaphoreIndex classByteArrayCompactIndex'
- 	instanceVariableNames: 'currentBytecode bytecodeSetSelector localFP localIP localSP stackLimit stackPage stackPages method instructionPointer stackPointer framePointer localReturnValue extA extB primitiveFunctionPointer methodCache atCache lkupClass highestRunnableProcessPriority nextWakeupUsecs nextPollUsecs inIOProcessEvents interruptKeycode interruptPending savedWindowSize imageHeaderFlags fullScreenFlag deferDisplayUpdates pendingFinalizationSignals extraVMMemory interpreterProxy showSurfaceFn primitiveTable externalPrimitiveTable externalPrimitiveTableFirstFreeIndex overflowedPage extraFramesToMoveOnOverflow globalSessionID jmpBuf jmpDepth suspendedCallbacks suspendedMethods numStackPages desiredNumStackPages desiredEdenBytes classNameIndex thisClassIndex metaclassSizeBits interruptCheckChain suppressHeartbeatFlag breakSelector breakSelectorLength longRunningPrimitiveCheckMethod longRunningPrimitiveCheckSemaphore longRunningPrimitiveStartUsecs longRunningPrimitiveStopUsecs longRunningPrimitiveGCUsecs longRunningPrimitiveCheckSequenceNumber longRunningPrimitiveSignalUndelivered tempOop statForceInterruptCheck statStackOverflow statStackPageDivorce statCheckForEvents statProcessSwitch statIOProcessEvents theUnknownShort imageFloatsBigEndian maxExtSemTabSizeSet lastMethodCacheProbeWrite statPendingFinalizationSignals gcSemaphoreIndex classByteArrayCompactIndex'
  	classVariableNames: 'AtCacheEntries AtCacheFixedFields AtCacheFmt AtCacheMask AtCacheOop AtCacheSize AtCacheTotalSize AtPutBase BytecodeTable CacheProbeMax DirBadPath DirEntryFound DirNoMoreEntries DumpStackOnLowSpace EnclosingMixinIndex EnclosingObjectIndex FailImbalancedPrimitives HeaderFlagBitPosition MaxExternalPrimitiveTableSize MaxJumpBuf MaxPrimitiveIndex MaxQuickPrimitiveIndex MixinIndex PrimitiveExternalCallIndex PrimitiveTable'
  	poolDictionaries: 'VMBasicConstants VMMethodCacheConstants VMObjectIndices VMSqueakClassIndices VMSqueakV3BytecodeConstants VMSqueakV3ObjectRepresentationConstants VMStackFrameOffsets'
  	category: 'VMMaker-Interpreter'!
  
  !StackInterpreter commentStamp: '<historical>' prior: 0!
  This class is a complete implementation of the Smalltalk-80 virtual machine, derived originally from the Blue Book specification but quite different in some areas.  This VM supports Closures but *not* old-style BlockContexts.
  
  It has been modernized with 32-bit pointers, better management of Contexts (see next item), and attention to variable use that allows the CCodeGenerator (qv) to keep, eg, the instruction pointer and stack pointer in registers as well as keeping most simple variables in a global array that seems to improve performance for most platforms.
  
  The VM does not use Contexts directly.  Instead Contexts serve as proxies for a more conventional stack format that is invisible to the image.  There is considerable explanation at http://www.mirandabanda.org/cogblog/2009/01/14/under-cover-contexts-and-the-big-frame-up.  The VM maintains a fixed-size stack zone divided into pages, each page being capable of holding several method/block activations.  A send establishes a new frame in the current stack page, a return returns to the previous frame.  This eliminates allocation/deallocation of contexts and the moving of receiver and arguments from caller to callee on each send/return.  Contexts are created lazily when an activation needs a context (creating a block, explicit use of thisContext, access to sender when sender is a frame, or linking of stack pages together).  Contexts are either conventional and heap-resident ("single") or "married" and serve as proxies for their corresponding frame or "widowed", meaning that their spouse frame has been returned from (died).  A married context is specially marked (more details in the code) and refers to its frame.  Likewise a married frame is specially marked and refers to its context.
  
  In addition to SmallInteger arithmetic and Floats, the VM supports logic on 32-bit PositiveLargeIntegers, thus allowing it to simulate itself much more effectively than would otherwise be the case.
  
  NOTE:  Here follows a list of things to be borne in mind when working on this code, or when making changes for the future.
  
  1.  There are a number of things that should be done the next time we plan to release a completely incompatible image format.  These include unifying the instanceSize field of the class format word -- see instantiateClass:indexableSize:, and unifying the bits of the method primitive index (if we decide we need more than 512, after all) -- see primitiveIndexOf:.  Also, contexts should be given a special format code (see next item).
  
  2.  There are several fast checks for contexts (see isContextHeader: and isMethodContextHeader:) which will fail if the compact class indices of BlockContext or MethodContext change.  This is necessary because the oops may change during a compaction when the oops are being adjusted.  It's important to be aware of this when writing a new image using the SystemTracer.  A better solution would be to reserve one of the format codes for Contexts only.
  
  3.  We have made normal files tolerant to size and positions up to 32 bits.  This has not been done for async files, since they are still experimental.  The code in size, at: and at:put: should work with sizes and indices up to 31 bits, although I have not tested it (di 12/98); it might or might not work with 32-bit sizes.
  
  4.  Note that 0 is used in a couple of places as an impossible oop.  This should be changed to a constant that really is impossible (or perhaps there is code somewhere that guarantees it --if so it should be put in this comment).  The places include the method cache and the at cache.
  
  5. Moving to a 2 bit immediate tag and having immediate Characters is a good choice for Unicode and the JIT
  
  6.  If Eliot Miranda's 2 word header scheme is acceptable in terms of footprint (we estimate about a 10% increase in image size with about 35 reclaimed by better representation of CompiledMethod - loss of MethodProperties) then the in-line cache for the JIT is simplified, class access is faster and header access is the same in 32-bit and full 64-bit images.!

Item was changed:
  ----- Method: StackInterpreter>>initializeInterpreter: (in category 'initialization') -----
  initializeInterpreter: bytesToShift 
  	"Initialize Interpreter state before starting execution of a new image."
  	interpreterProxy := self sqGetInterpreterProxy.
  	self dummyReferToProxy.
  	objectMemory initializeObjectMemory: bytesToShift.
  	self checkAssumedCompactClasses.
  	primFailCode := 0.
  	self initializeExtraClassInstVarIndices.
  	stackLimit := 0. "This is also the initialization flag for the stack system."
  	stackPage := overflowedPage := 0.
  	extraFramesToMoveOnOverflow := 0.
  	method := objectMemory nilObject.
  	self cCode: [self cppIf: MULTIPLEBYTECODESETS ifTrue: [bytecodeSetSelector := 0]]
  		inSmalltalk: [bytecodeSetSelector := 0].
  	messageSelector := objectMemory nilObject.
  	newMethod := objectMemory nilObject.
  	lkupClass := objectMemory nilObject.
+ 	methodDictLinearSearchLimit := 8.
  	self flushMethodCache.
  	self flushAtCache.
  	self initialCleanup.
  	highestRunnableProcessPriority := 0.
  	nextProfileTick := 0.
  	profileSemaphore := objectMemory nilObject.
  	profileProcess := objectMemory nilObject.
  	profileMethod := objectMemory nilObject.
  	nextPollUsecs := 0.
  	nextWakeupUsecs := 0.
  	tempOop := 0.
  	interruptKeycode := 2094. "cmd-. as used for Mac but no other OS"
  	interruptPending := false.
  	inIOProcessEvents := 0.
  	deferDisplayUpdates := false.
  	pendingFinalizationSignals := statPendingFinalizationSignals := 0.
  	globalSessionID := 0.
  	[globalSessionID = 0]
  		whileTrue: [globalSessionID := self
  						cCode: 'time(NULL) + ioMSecs()'
  						inSmalltalk: [(Random new next * SmallInteger maxVal) asInteger]].
  	jmpDepth := 0.
  	longRunningPrimitiveStartUsecs :=
  	longRunningPrimitiveStopUsecs := 0.
  	maxExtSemTabSizeSet := false.
  	statForceInterruptCheck := 0.
  	statStackOverflow := 0.
  	statCheckForEvents := 0.
  	statProcessSwitch := 0.
  	statIOProcessEvents := 0.
  	statStackPageDivorce := 0!

Item was changed:
  ----- Method: StackInterpreter>>lookupMethodInDictionary: (in category 'message sending') -----
  lookupMethodInDictionary: dictionary 
+ 	"This method lookup tolerates integers as Dictionary keys to support
- 	"This method lookup tolerates integers as Dictionary keys to suoport
  	 execution of images in which Symbols have been compacted out."
  	| length index mask wrapAround nextSelector methodArray |
  	<inline: true>
  	<asmLabel: false>
  	length := objectMemory fetchWordLengthOf: dictionary.
  	mask := length - SelectorStart - 1.
+ 	"Use linear search on small dictionaries; its cheaper.
+ 	 Also the limit can be set to force linear search of all dictionaries, which supports the
+ 	 booting of images that need rehashing (e.g. because a tracer has generated an image
+ 	 with different hashes but hasn't rehashed it yet.)"
+ 	mask <= methodDictLinearSearchLimit ifTrue:
+ 		[index := 0.
+ 		 [index <= mask] whileTrue:
+ 			[nextSelector := objectMemory fetchPointer: index ofObject: dictionary.
+ 			 nextSelector = messageSelector ifTrue:
+ 				[methodArray := objectMemory fetchPointer: MethodArrayIndex ofObject: dictionary.
+ 				 newMethod := objectMemory fetchPointer: index - SelectorStart ofObject: methodArray.
+ 				^true].
+ 		 index := index + 1].
+ 		 ^false].
+ 	index := SelectorStart + (mask bitAnd: ((objectMemory isImmediate: messageSelector)
- 	index := SelectorStart + (mask bitAnd: ((objectMemory isIntegerObject: messageSelector)
  												ifTrue: [objectMemory integerValueOf: messageSelector]
  												ifFalse: [objectMemory hashBitsOf: messageSelector])).
  
  	"It is assumed that there are some nils in this dictionary, and search will 
  	 stop when one is encountered. However, if there are no nils, then wrapAround 
  	 will be detected the second time the loop gets to the end of the table."
  	wrapAround := false.
  	[true] whileTrue:
  		[nextSelector := objectMemory fetchPointer: index ofObject: dictionary.
  		 nextSelector = objectMemory nilObject ifTrue: [^ false].
  		 nextSelector = messageSelector ifTrue:
  			[methodArray := objectMemory fetchPointer: MethodArrayIndex ofObject: dictionary.
  			 newMethod := objectMemory fetchPointer: index - SelectorStart ofObject: methodArray.
  			^true].
  		 index := index + 1.
  		 index = length ifTrue:
  			[wrapAround ifTrue: [^false].
  			 wrapAround := true.
  			 index := SelectorStart]].
+ 	
  	^false "for Slang"!

Item was changed:
  ----- Method: StackInterpreter>>printNameOfClass:count: (in category 'debug printing') -----
  printNameOfClass: classOop count: cnt
  	"Details: The count argument is used to avoid a possible infinite recursion if classOop is a corrupted object."
  	<inline: false>
  	(classOop = 0 or: [cnt <= 0]) ifTrue: [^self print: 'bad class'].
  	((objectMemory sizeBitsOf: classOop) = metaclassSizeBits
+ 	  and: [metaclassSizeBits > (thisClassIndex * BytesPerOop)])	"(Metaclass instSize * 4)"
- 	  and: [metaclassSizeBits > (thisClassIndex * BytesPerWord)])	"(Metaclass instSize * 4)"
  		ifTrue: [self printNameOfClass: (objectMemory fetchPointer: thisClassIndex ofObject: classOop) count: cnt - 1.
  				self print: ' class']
  		ifFalse: [self printStringOf: (objectMemory fetchPointer: classNameIndex ofObject: classOop)]!

Item was changed:
  ----- Method: StackInterpreter>>printStringOf: (in category 'debug printing') -----
  printStringOf: oop
  	| fmt len cnt max i |
  	<inline: false>
  	(objectMemory isImmediate: oop) ifTrue:
  		[^nil].
+ 	(objectMemory addressCouldBeObj: oop) ifFalse:
- 	(oop between: objectMemory startOfMemory and: objectMemory freeStart) ifFalse:
  		[^nil].
- 	(oop bitAnd: (BytesPerOop - 1)) ~= 0 ifTrue:
- 		[^nil].
  	fmt := objectMemory formatOf: oop.
  	fmt < objectMemory firstByteFormat ifTrue: [^nil].
  
  	cnt := (max := 128) min: (len := objectMemory lengthOf: oop).
  	i := 0.
  
  	((objectMemory is: oop
  		  instanceOf: (objectMemory splObj: ClassByteArray)
  		  compactClassIndex: classByteArrayCompactIndex)
  	or: [(self isInstanceOfClassLargePositiveInteger: oop)
  	or: [(self isInstanceOfClassLargeNegativeInteger: oop)]])
  		ifTrue:
  			[[i < cnt] whileTrue:
  				[self printHex: (objectMemory fetchByte: i ofObject: oop).
  				 i := i + 1]]
  		ifFalse:
  			[[i < cnt] whileTrue:
  				[self printChar: (objectMemory fetchByte: i ofObject: oop).
  				 i := i + 1]].
  	len > max ifTrue:
  		[self print: '...'].
  	self flush!

Item was changed:
  ----- Method: StackInterpreter>>shortPrintOop: (in category 'debug printing') -----
  shortPrintOop: oop
  	<inline: false>
  	self printHex: oop.
  	(objectMemory isImmediate: oop) ifTrue:
  		[(objectMemory isImmediateCharacter: oop) ifTrue:
  			[^self
  				cCode: 'printf("=$%ld ($%c)\n", (long)characterValueOf(oop), (long)characterValueOf(oop))'
  				inSmalltalk: [self print: (self shortPrint: oop); cr]].
  		 ^self
  			cCode: 'printf("=%ld\n", (long)integerValueOf(oop))'
  			inSmalltalk: [self print: (self shortPrint: oop); cr]].
+ 	(objectMemory addressCouldBeObj: oop) ifFalse:
+ 		[self print: ((oop bitAnd: objectMemory allocationUnit - 1) ~= 0
+ 						ifTrue: [' is misaligned']
+ 						ifFalse: [' is not on the heap']); cr.
- 	(oop between: objectMemory startOfMemory and: objectMemory freeStart) ifFalse:
- 		[self printHex: oop; print: ' is not on the heap'; cr.
  		 ^nil].
- 	(oop bitAnd: (BytesPerWord - 1)) ~= 0 ifTrue:
- 		[self printHex: oop; print: ' is misaligned'; cr.
- 		 ^nil].
  	self print: ': a(n) '.
  	self printNameOfClass: (objectMemory fetchClassOf: oop) count: 5.
  	self cr!

Item was changed:
  ----- Method: StackInterpreterSimulator>>shortPrint: (in category 'debug support') -----
  shortPrint: oop
  	| name classOop |
  	(objectMemory isImmediate: oop) ifTrue:
  		[(objectMemory isImmediateCharacter: oop) ifTrue: [^ '=$' , (objectMemory integerValueOf: oop) printString , 
  			' (' , (String with: (Character value: (objectMemory integerValueOf: oop))) , ')'].
  		(objectMemory isIntegerObject: oop) ifTrue: [^ '=' , (objectMemory integerValueOf: oop) printString , 
  			' (' , (objectMemory integerValueOf: oop) hex , ')'].
  		^'= UNKNOWN IMMEDIATE', ' (' , (objectMemory integerValueOf: oop) hex , ')'].
+ 	(objectMemory addressCouldBeObj: oop) ifFalse:
+ 		[^(oop bitAnd: objectMemory allocationUnit - 1) ~= 0
+ 			ifTrue: [' is misaligned']
+ 			ifFalse: [' is not on the heap']].
+ 	classOop := objectMemory fetchClassOfNonImm: oop.
+ 	(objectMemory sizeBitsOf: classOop) = metaclassSizeBits ifTrue:
+ 		[^'class ' , (self nameOfClass: oop)].
- 	(oop between: objectMemory startOfMemory and: objectMemory freeStart) ifFalse:
- 		[^' is not on the heap'].
- 	(oop bitAnd: (BytesPerWord - 1)) ~= 0 ifTrue:
- 		[^' is misaligned'].
- 	classOop := objectMemory fetchClassOf: oop.
- 	(objectMemory sizeBitsOf: classOop) = metaclassSizeBits ifTrue: [
- 		^ 'class ' , (self nameOfClass: oop)].
  	name := self nameOfClass: classOop.
  	name size = 0 ifTrue: [name := '??'].
  	name = 'String' ifTrue: [^ (self stringOf: oop) printString].
  	name = 'ByteString' ifTrue: [^ (self stringOf: oop) printString].
  	name = 'Symbol' ifTrue: [^ '#' , (self stringOf: oop)].
  	name = 'ByteSymbol' ifTrue: [^ '#' , (self stringOf: oop)].
+ 	name = 'Character' ifTrue: "SpurMemoryManager has immediate Characters; ObjectMemory does not"
+ 		[^ '=' , (Character value: (objectMemory integerValueOf: 
- 	name = 'Character' ifTrue: [^ '=' , (Character value: (objectMemory integerValueOf: 
  				(objectMemory fetchPointer: 0 ofObject: oop))) printString].
  	name = 'UndefinedObject' ifTrue: [^ 'nil'].
  	name = 'False' ifTrue: [^ 'false'].
  	name = 'True' ifTrue: [^ 'true'].
  	name = 'Float' ifTrue: [^ '=' , (self dbgFloatValueOf: oop) printString].
  	name = 'Association' ifTrue: [^ '(' ,
  				(self shortPrint: (self longAt: oop + BaseHeaderSize)) ,
  				' -> ' ,
  				(self longAt: oop + BaseHeaderSize + BytesPerWord) hex8 , ')'].
  	('AEIOU' includes: name first)
  		ifTrue: [^ 'an ' , name]
  		ifFalse: [^ 'a ' , name]!

More information about the Vm-dev mailing list