[Vm-dev] VM Maker: VMMaker.oscog-eem.534.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.534.mcz

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

Name: VMMaker.oscog-eem.534
Author: eem
Time: 5 December 2013, 9:48:34.679 am
UUID: f9804193-9d68-4cac-b3be-178c55da6b52
Ancestors: VMMaker.oscog-eem.533

Fix to: loops with unsigned limits hence if limit is unsigned and zero,
avoiding the overflow resulting from i <= (limit - 1).

Change printAllStacks to enumerate heap for suspended processes
last, and to use class indices on Spur, and to follow potentially
forwarded fields.

Fix assert in segment writing.

Add missing stub for followNonImmediateField:ofObject: in ObjMem.

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

Item was changed:
  ----- Method: CCodeGenerator>>generateToByDo:on:indent: (in category 'C translation') -----
  generateToByDo: msgNode on: aStream indent: level
  	"Generate the C code for this message onto the given stream."
  	"N.B. MessageNode>>asTranslatorNodeIn: adds the limit var as a hidden fourth argument."
  	| blockExpr iterationVar limitExpr mayHaveSideEffects limitVar step negative |
  	blockExpr := msgNode args third.
  	blockExpr args size = 1 ifFalse:
  		[self error: 'wrong number of block arguments'].
  	iterationVar := blockExpr args first.
  	limitExpr := msgNode args first.
  	aStream nextPutAll: 'for (', iterationVar, ' = '.
  	self emitCExpression: msgNode receiver on: aStream.
  	mayHaveSideEffects := msgNode args size = 4. "See TMethod>>prepareMethodIn:"
  	mayHaveSideEffects ifTrue:
  		[limitVar := msgNode args last.
  		 aStream nextPutAll: ', ', limitVar name, ' = '.
  		 self emitCExpression: limitExpr on: aStream.
  		 limitExpr := limitVar].
  	aStream nextPutAll: '; ', iterationVar.
  	negative := ((step := msgNode args at: 2) isConstant and: [step value < 0])
  				or: [step isSend and: [step selector == #negated
  					and: [step receiver isConstant and: [step receiver value >= 0]]]].
+ 	self generateToByDoLimitExpression: limitExpr negative: negative on: aStream.
- 	aStream nextPutAll: (negative ifTrue: [' >= '] ifFalse: [' <= ']).
- 	self emitCExpression: limitExpr on: aStream.
  	aStream nextPutAll: '; ', iterationVar, ' += '.
  	self emitCExpression: step on: aStream.
  	aStream nextPutAll: ') {'; cr.
  	blockExpr emitCCodeOn: aStream level: level + 1 generator: self.
  	aStream tab: level.
  	aStream nextPut: $}!

Item was added:
+ ----- Method: CCodeGenerator>>generateToByDoLimitExpression:negative:on: (in category 'C translation') -----
+ generateToByDoLimitExpression: limitExpr negative: negative on: aStream
+ 	"Generate the limit expression for a to:do: or to:by:do:.
+ 	 If the limitExpr is of the form foo - 1 use < foo or > foo, as appropriate, instead of
+ 	 <= (foo - 1) or >= (foo - 1), so as to avoid underflowing an unsigned value to maxint."
+ 	(limitExpr isSend
+ 	 and: [limitExpr selector = #-
+ 	 and: [limitExpr args first isConstant
+ 	 and: [limitExpr args first value = 1]]])
+ 		ifTrue:
+ 			[aStream nextPutAll: (negative ifTrue: [' > '] ifFalse: [' < ']).
+ 			 self emitCExpression: limitExpr receiver on: aStream]
+ 		ifFalse:
+ 			[aStream nextPutAll: (negative ifTrue: [' >= '] ifFalse: [' <= ']).
+ 			 self emitCExpression: limitExpr on: aStream]!

Item was changed:
  ----- Method: CCodeGenerator>>generateToDo:on:indent: (in category 'C translation') -----
  generateToDo: msgNode on: aStream indent: level
  	"Generate the C code for this message onto the given stream."
  
  	| iterationVar |
  	(msgNode args last args size = 1) ifFalse: [
  		self error: 'wrong number of block arguments'.
  	].
  	iterationVar := msgNode args last args first.
  	aStream nextPutAll: 'for (', iterationVar, ' = '.
  	self emitCExpression: msgNode receiver on: aStream.
+ 	aStream nextPutAll: '; ', iterationVar.
+ 	self generateToByDoLimitExpression: msgNode args first negative: false on: aStream.
- 	aStream nextPutAll: '; ', iterationVar, ' <= '.
- 	self emitCExpression: msgNode args first on: aStream.
  	aStream nextPutAll: '; ', iterationVar, '++) {'; cr.
  	msgNode args last emitCCodeOn: aStream level: level + 1 generator: self.
  	level timesRepeat: [ aStream tab ].
  	aStream nextPutAll: '}'.!

Item was added:
+ ----- Method: ObjectMemory>>followNonImmediateField:ofObject: (in category 'forward compatibility') -----
+ followNonImmediateField: fieldIndex ofObject: anObject
+ 	^self fetchPointer: fieldIndex ofObject: anObject!

Item was changed:
  ----- Method: SpurSegmentManager>>writeSegment:nextSegmentSize:toFile: (in category 'snapshot') -----
  writeSegment: segment nextSegmentSize: nextSegSize toFile: aBinaryStream
  	<var: 'segment' type: #'SpurSegmentInfo *'>
  	<var: 'aBinaryStream' type: #'FILE *'>
  	| lastDoubleWord savedDoubleWord nWritten |
  	<var: 'savedDoubleWord' type: #usqLong>
  	lastDoubleWord := segment segLimit - manager baseHeaderSize.
  	self assert: (self isValidSegmentBridge: (self bridgeFor: segment)).
+ 	self assert: (manager startOfObject: (self bridgeFor: segment)) = (lastDoubleWord - manager baseHeaderSize).
- 	self assert: (self bridgeFor: segment) = (lastDoubleWord - manager baseHeaderSize).
  	savedDoubleWord := manager longLongAt: lastDoubleWord.
  	manager longLongAt: lastDoubleWord put: nextSegSize.
  	nWritten := self cCode:
  						[self
  							sq: segment segStart asVoidPointer
  							Image: 1
  							File: segment segSize
  							Write: aBinaryStream]
  					inSmalltalk:
  						[aBinaryStream
  							next: segment segSize / 4
  							putAll: manager memory
  							startingAt: segment segStart / 4 + 1.
  						 segment segSize].
  	manager longLongAt: lastDoubleWord put: savedDoubleWord.
  	^nWritten!

Item was changed:
  ----- Method: StackInterpreter>>printAllStacks (in category 'debug printing') -----
  printAllStacks
  	"Print all the stacks of all running processes, including those that are currently suspended."
  	<api>
+ 	| proc semaphoreClass mutexClass schedLists p processList |
- 	| classObj proc semaphoreClass mutexClass schedLists p processList |
  	<inline: false>
  	proc := self activeProcess.
  	self printNameOfClass: (objectMemory fetchClassOf: proc) count: 5; space; printHex: proc.
  	self print: ' priority '; printNum: (self quickFetchInteger: PriorityIndex ofObject: proc); cr.
  	self printCallStackFP: framePointer. "first the current activation"
- 	semaphoreClass := objectMemory classSemaphore.
- 	mutexClass := objectMemory classMutex.
- 	objectMemory allObjectsDo:
- 		[:oop|
- 		classObj := objectMemory fetchClassOfNonImm: oop.
- 		 (classObj = semaphoreClass
- 		  or: [classObj = mutexClass]) ifTrue:
- 			[self printProcsOnList: oop]].
  	schedLists := objectMemory fetchPointer: ProcessListsIndex ofObject: self schedulerPointer.
+ 	"then the runnable processes"
  	p := highestRunnableProcessPriority = 0
  			ifTrue: [objectMemory fetchWordLengthOf: schedLists]
  			ifFalse: [highestRunnableProcessPriority].
  	p - 1 to: 0 by: -1 do:
  		[:pri|
  		processList := objectMemory fetchPointer: pri ofObject: schedLists.
  		(self isEmptyList: processList) ifFalse:
  			[self cr; print: 'processes at priority '; printNum: pri + 1.
+ 			 self printProcsOnList: processList]].
+ 	self cr; print: 'suspended processes'.
+ 	semaphoreClass := objectMemory classSemaphore.
+ 	mutexClass := objectMemory classMutex.
+ 	objectMemory hasSpurMemoryManagerAPI
+ 		ifTrue:
+ 			[semaphoreClass := objectMemory compactIndexOfClass: semaphoreClass.
+ 			 mutexClass := objectMemory compactIndexOfClass: mutexClass.
+ 			 objectMemory allHeapEntitiesDo:
+ 				[:obj| | classIdx |
+ 				 classIdx := objectMemory classIndexOf: obj.
+ 				 (classIdx = semaphoreClass
+ 				  or: [classIdx = mutexClass]) ifTrue:
+ 					[self printProcsOnList: obj]]]
+ 		ifFalse:
+ 			[objectMemory allObjectsDo:
+ 				[:obj| | classObj |
+ 				 classObj := objectMemory fetchClassOfNonImm: obj.
+ 				 (classObj = semaphoreClass
+ 				  or: [classObj = mutexClass]) ifTrue:
+ 					[self printProcsOnList: obj]]]!
- 			 self printProcsOnList: processList]]!

Item was changed:
  ----- Method: StackInterpreter>>printProcessStack: (in category 'debug printing') -----
  printProcessStack: aProcess
  	<api>
  	<inline: false>
  	| ctx |
  	self cr; printNameOfClass: (objectMemory fetchClassOf: aProcess) count: 5; space; printHex: aProcess.
  	self print: ' priority '; printNum: (self quickFetchInteger: PriorityIndex ofObject: aProcess); cr.
+ 	ctx := objectMemory followField: SuspendedContextIndex ofObject: aProcess.
- 	ctx := objectMemory fetchPointer: SuspendedContextIndex ofObject: aProcess.
  	ctx = objectMemory nilObject ifFalse:
  		[self printCallStackOf: ctx currentFP: framePointer]!

Item was changed:
  ----- Method: StackInterpreter>>printProcsOnList: (in category 'debug printing') -----
  printProcsOnList: procList
  	<api>
  	<inline: false>
  	| proc firstProc |
+ 	proc := firstProc := objectMemory followField: FirstLinkIndex ofObject: procList.
- 	proc := firstProc := objectMemory fetchPointer: FirstLinkIndex ofObject: procList.
  	[proc = objectMemory nilObject] whileFalse:
  		[self printProcessStack: proc.
+ 		 proc := objectMemory followField: NextLinkIndex ofObject: proc.
- 		 proc := objectMemory fetchPointer: NextLinkIndex ofObject: proc.
  		 proc = firstProc ifTrue:
  			[self warning: 'circular process list!!!!'.
  			 ^nil]]!