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

[commits at source.squeak.org]

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

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

Name: VMMaker.oscog-eem.477
Author: eem
Time: 25 October 2013, 12:57:49.906 pm
UUID: b29f70be-1ead-4893-8f3c-f39b3d189a87
Ancestors: VMMaker.oscog-eem.476

Fix shift in headerForSlots:format:classIndex:; needs to be long long.
Make a few vitals inlined.
Fix off-by-one in printOopShortInner:.
Relax restriction in isFunctional of return type being sqInt to
being any of sqInt, usqInt, sqLong or usqLong.

C Spur VM runs up to the end of the first scavenge, when it tries
to shrink memory.

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

Item was changed:
  ----- Method: CogClass>>cCoerceSimple:to: (in category 'translation support') -----
  cCoerceSimple: value to: cTypeString
  	"Type coercion for translation and simulation.
  	 For simulation answer a suitable surrogate for the struct types"
  	^cTypeString caseOf:
  	   {	[#'unsigned long']							->	[value].
  		[#sqInt]										->	[value].
  		[#usqInt]									->	[value].
+ 		[#sqLong]									->	[value].
+ 		[#usqLong]									->	[value].
  		[#'AbstractInstruction *']					->	[value].
  		[#'BytecodeFixup *']						->	[value].
  		[#'CogMethod *']							->	[value].
  		[#'char *']									->	[value].
  		[#'sqInt *']									->	[value].
  		[#'void *']									->	[value].
  		[#void]										->	[value].
  		[#'void (*)()']								->	[value].
  		[#'void (*)(void)']							->	[value].
  		[#'unsigned long (*)(void)']					->	[value].
  		[#'void (*)(unsigned long,unsigned long)']	->	[value] }!

Item was changed:
  ----- Method: Spur32BitMemoryManager>>fillObj:numSlots:with: (in category 'instantiation') -----
  fillObj: objOop numSlots: numSlots with: fillValue
+ 	<inline: true>
  	self assert: (objOop + self baseHeaderSize + (numSlots * self bytesPerOop) - 1)
  				< (self addressAfter: objOop).
  	objOop + self baseHeaderSize
  		to: objOop + self baseHeaderSize + (numSlots * self wordSize) - 1
  		by: self allocationUnit
  		do: [:p|
  			self longAt: p put: fillValue;
  				longAt: p + 4 put: fillValue]!

Item was changed:
  ----- Method: Spur64BitMemoryManager>>fillObj:numSlots:with: (in category 'instantiation') -----
  fillObj: objOop numSlots: numSlots with: fillValue
+ 	<inline: true>
  	self assert: (objOop + self baseHeaderSize + (numSlots * self bytesPerOop) - 1)
  				< (self addressAfter: objOop).
  	objOop + self baseHeaderSize
  		to: objOop + self baseHeaderSize + (numSlots * self bytesPerOop) - 1
  		by: self allocationUnit
  		do: [:p| self longAt: p put: fillValue]!

Item was changed:
  ----- Method: SpurMemoryManager>>checkedLongAt: (in category 'memory access') -----
  checkedLongAt: byteAddress
  	"Assumes zero-based array indexing."
  	<api>
+ 	(byteAddress asUnsignedInteger < self startOfMemory
+ 	 or: [byteAddress asUnsignedInteger > endOfMemory
+ 	 or: [byteAddress asUnsignedInteger > newSpaceLimit
+ 		and: [(segmentManager isInSegments: byteAddress asUnsignedInteger) not]]]) ifTrue:
- 	(self addressCouldBeObj: byteAddress) ifFalse:
  		[self warning: 'checkedLongAt bad address'.
  		 coInterpreter primitiveFail].
  	^self longAt: byteAddress!

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)
  			| 2 bits				|	(msb,lsb = {isMarked,?})
  			| 22: identityHash	| (on a word boundary)
  			| 3 bits				|	(msb <-> lsb = {isGrey,isPinned,isRemembered}
  			| 5: format			| (on a byte boundary)
  			| 2 bits				|	(msb,lsb = {isImmutable,?})
  			| 22: classIndex		| (on a word boundary) : LSB
  	 The remaining bits (7) are used for
  		isImmutable	(bit 23)
  		isRemembered	(bit 29)
  		isPinned		(bit 30)
  		isGrey			(bit 31)
  		isMarked		(bit 55)
  	 leaving 2 unused bits, each next to a 22-bit field, allowing those fields to be
  	 expanded to 23 bits..  The three bit field { isGrey, isPinned, isRemembered }
  	 is for bits that are never set in young objects.  This allows the remembered
  	 table to be pruned when full by using these bits as a reference count of
  	 newSpace objects from the remembered table. Objects with a high count
  	 should be tenured to prune the remembered table."
  	<returnTypeC: #usqLong>
+ 	<inline: true>
+ 	^ ((self cCoerceSimple: numSlots to: #usqLong) << self numSlotsFullShift)
- 	^ (numSlots << self numSlotsFullShift)
  	+ (formatField << self formatShift)
  	+ classIndex!

Item was changed:
  ----- Method: SpurMemoryManager>>unlinkSolitaryFreeTreeNode: (in category 'free space') -----
  unlinkSolitaryFreeTreeNode: freeTreeNode
  	"Unlink a freeTreeNode.  Assumes the node has no list (null next link)."
  	| parent smaller larger |
  	self assert: (self fetchPointer: self freeChunkNextIndex ofObject: freeTreeNode) = 0.
  
  	"case 1. interior node has one child, P = parent, N = node, S = subtree (mirrored for large vs small)
  			___				  ___
  			| P |				  | P |
  		    _/_				_/_
  		    | N |		=>		| S |
  		 _/_
  		 | S |
  
  	 case 2: interior node has two children, , P = parent, N = node, L = smaller, left subtree, R = larger, right subtree.
  	 add the left subtree to the bottom left of the right subtree (mirrored for large vs small) 
  			___				  ___
  			| P |				  | P |
  		    _/_				_/_
  		    | N |		=>		| R |
  		 _/_  _\_		    _/_
  		 | L | | R |		    | L |"
  
  	smaller := self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: freeTreeNode.
  	larger := self fetchPointer: self freeChunkLargerIndex ofFreeChunk: freeTreeNode.
  	parent := self fetchPointer: self freeChunkParentIndex ofFreeChunk: freeTreeNode.
  	parent = 0
  		ifTrue: "no parent; stitch the subnodes back into the root"
  			[smaller = 0
  				ifTrue:
  					[self storePointer: self freeChunkParentIndex ofFreeChunk: larger withValue: 0.
  					 freeLists at: 0 put: larger]
  				ifFalse:
  					[self storePointer: self freeChunkParentIndex ofFreeChunk: smaller withValue: 0.
  					 freeLists at: 0 put: smaller.
  					 larger ~= 0 ifTrue:
  						[self addFreeSubTree: larger]]]
  		ifFalse: "parent; stitch back into appropriate side of parent."
  			[smaller = 0
  				ifTrue: [self storePointer: (freeTreeNode = (self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: parent)
  											ifTrue: [self freeChunkSmallerIndex]
  											ifFalse: [self freeChunkLargerIndex])
  							ofFreeChunk: parent
  							withValue: larger.
+ 						larger ~= 0 ifTrue:
+ 							[self storePointer: self freeChunkParentIndex
+ 								ofObject: larger
+ 								withValue: parent]]
- 						self storePointer: self freeChunkParentIndex
- 							ofObject: larger
- 							withValue: parent]
  				ifFalse:
  					[self storePointer: (freeTreeNode = (self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: parent)
  											ifTrue: [self freeChunkSmallerIndex]
  											ifFalse: [self freeChunkLargerIndex])
  						ofFreeChunk: parent
  						withValue: smaller.
  					 self storePointer: self freeChunkParentIndex
  						ofObject: smaller
  						withValue: parent.
  					 larger ~= 0 ifTrue:
  						[self addFreeSubTree: larger]]]!

Item was changed:
  ----- Method: SpurSegmentManager>>isInSegments: (in category 'testing') -----
  isInSegments: address
+ 	<var: #address type: #usqInt>
  	0 to: numSegments - 1 do:
  		[:i|
  		address < (segments at: i) segStart ifTrue:
  			[^false].
  		address < ((segments at: i) segStart + (segments at: i) segSize) ifTrue:
  			[^true]].
  	^false!

Item was changed:
  ----- Method: StackInterpreter>>nameOfClass: (in category 'debug printing') -----
  nameOfClass: classOop
  	"Brain-damaged nameOfClass: for C VM.  Does *not* answer Foo class for metaclasses.
  	 Use e.g. classIsMeta: to avoid being fooled."
  	<inline: false>
  	<returnTypeC: 'char *'>
  	| numSlots |
  	numSlots := objectMemory numSlotsOf: classOop.
  	numSlots = metaclassNumSlots ifTrue:
  		[^self nameOfClass: (objectMemory fetchPointer: thisClassIndex ofObject: classOop)].
  	numSlots <= classNameIndex ifTrue:
  		[^'bad class'].
+ 	^objectMemory firstIndexableField: (objectMemory fetchPointer: classNameIndex ofObject: classOop)!
- 	^objectMemory firstFixedField: (objectMemory fetchPointer: classNameIndex ofObject: classOop)!

Item was changed:
  ----- Method: StackInterpreter>>printOopShortInner: (in category 'debug printing') -----
  printOopShortInner: oop
  	| classOop name nameLen |
  	<var: #name type: #'char *'>
  	<inline: true>
  	(objectMemory isImmediate: oop) ifTrue:
  		[(objectMemory isImmediateCharacter: oop) ifTrue:
  			[self printChar: $$;
  				printChar: (objectMemory characterValueOf: oop);
  				printChar: $(;
  				printHex: (objectMemory integerValueOf: oop);
  				printChar: $).
  			 ^nil].
  		self printNum: (objectMemory integerValueOf: oop);
  			printChar: $(;
  			printHex: (objectMemory integerValueOf: oop);
  			printChar: $).
  		 ^nil].
  	(objectMemory addressCouldBeObj: oop) ifFalse:
  		[self print: ((oop bitAnd: objectMemory allocationUnit - 1) ~= 0
  						ifTrue: [' is misaligned']
  						ifFalse: [' is not on the heap']); cr.
  		 ^nil].
  	(self isFloatObject: oop) ifTrue:
  		[self printFloat: (self dbgFloatValueOf: oop).
  		 ^nil].
  	classOop := objectMemory fetchClassOfNonImm: oop.
  	(objectMemory addressCouldBeObj: classOop) ifFalse:
  		[self print: 'a ??'. ^nil].
  	(objectMemory numSlotsOf: classOop) = metaclassNumSlots ifTrue:
  		[self printNameOfClass: oop count: 5.
  		 ^nil].
  	oop = objectMemory nilObject ifTrue: [self print: 'nil'. ^nil].
  	oop = objectMemory trueObject ifTrue: [self print: 'true'. ^nil].
  	oop = objectMemory falseObject ifTrue: [self print: 'false'. ^nil].
  	nameLen := self lengthOfNameOfClass: classOop.
  	nameLen = 0 ifTrue: [self print: 'a ??'. ^nil].
  	name := self nameOfClass: classOop.
  	nameLen = 10 ifTrue:
  		[(self str: name n: 'ByteString' cmp: 10) not "strncmp is weird" ifTrue:
  			[self printChar: $'; printStringOf: oop; printChar: $'.
  			 ^nil].
  		 (self str: name n: 'ByteSymbol' cmp: 10) not "strncmp is weird" ifTrue:
  			[self printChar: $#; printStringOf: oop.
  			 ^nil]].
  	(nameLen = 9 and: [(self str: name n: 'Character' cmp: 9) not]) ifTrue:
  		[self printChar: $$; printChar: (objectMemory integerValueOf: (objectMemory fetchPointer: 0 ofObject: oop)).
  		 ^nil].
  	self print: 'a(n) '.
+ 	0 to: nameLen - 1 do: [:i| self printChar: (name at: i)].
- 	1 to: nameLen do: [:i| self printChar: (name at: i)].
  	"Try to spot association-like things; they're all subclasses of LookupKey"
  	((objectMemory instanceSizeOf: classOop) = (ValueIndex + 1)
  	 and: [(self superclassOf: classOop) = (self superclassOf: (objectMemory fetchClassOfNonImm: (objectMemory splObj: SchedulerAssociation)))
  	 and: [objectMemory isBytes: (objectMemory fetchPointer: KeyIndex ofObject: oop)]]) ifTrue:
  		[self space;
  			printOopShort: (objectMemory fetchPointer: KeyIndex ofObject: oop);
  			print: ' -> ';
  			printHex: (objectMemory fetchPointer: ValueIndex ofObject: oop)]!

Item was changed:
  ----- Method: TMethod>>isFunctional (in category 'inlining') -----
  isFunctional
  	"Answer true if the receiver is a functional method. That is, if it
  	 consists of a single return statement of an expression that contains
  	 no other returns.
  
+ 	 Answer false for methods with return types other than the simple
+ 	 integer types to work around bugs in the inliner."
- 	 Answer false for methods with return types other than #sqInt to work
- 	 around bugs in the inliner."
  
  	(parseTree statements size = 1 and:
  	 [parseTree statements last isReturn]) ifFalse: [ ^false ].
  	parseTree statements last expression nodesDo: [ :n | n isReturn ifTrue: [ ^false ]].
+ 	^#(sqInt usqInt sqLong usqLong) includes: returnType!
- 	returnType = #sqInt ifFalse:[^false].
- 	^true!

Item was changed:
  ----- Method: TMethod>>maybeBreakFor:in: (in category 'inlining') -----
  maybeBreakFor: aNode in: aCodeGen
  	"convenient for debugging..."
  	(aNode isSend
  	and: [(aCodeGen breakSrcInlineSelector notNil or: [aCodeGen breakDestInlineSelector notNil])
  	and: [(aCodeGen breakSrcInlineSelector ifNil: [true] ifNotNil: [:srcSel| srcSel = aNode selector])
  	and: [aCodeGen breakDestInlineSelector ifNil: [true] ifNotNil: [:dstSel| dstSel = selector]]]]) ifTrue:
+ 		[self halt: selector]!
- 		[self halt]!