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

commits at source.squeak.org commits at source.squeak.org
Fri Jun 30 21:08:00 UTC 2017


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

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

Name: VMMaker.oscog-eem.2250
Author: eem
Time: 30 June 2017, 2:07:03.058813 pm
UUID: 0726505e-161b-4a23-843e-c5222917ff5e
Ancestors: VMMaker.oscog-eem.2249

Spur Image Segments:
Fix the mapping mistakes on the store side.  N.B.  The code needs rewriting to abstract mapping operarions and to use more descriptive variable names (inSegOop in stead of objOop etc).

Add a big test and rename the small test.

Get WordArrays to print in hex in the inspector.

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

Item was added:
+ ----- Method: SpurImageSegmentTests>>testSaveHashedCollectionAndAllSubclasses (in category 'tests') -----
+ testSaveHashedCollectionAndAllSubclasses
+ 	SimulatorHarnessForTests new
+ 		withExecutableInterpreter: self initializedVM
+ 		do: [:vm :harness| | error objects |
+ 			CheckForLeaks == true ifTrue: "CheckForLeaks := self confirm: 'Check for leaks?'"
+ 				[vm objectMemory setCheckForLeaks: (vm objectMemory class bindingOf: #GCModeImageSegment) value].
+ 			error := harness findSymbol: #error.
+ 			self deny: error isNil.
+ 			objects := harness
+ 				interpreter: vm
+ 				object: (harness findClassNamed: 'Compiler')
+ 				perform: (harness findSymbol: #evaluate:)
+ 				withArguments: {vm objectMemory stringForCString:
+ 					'[| seg out result |
+ 					 seg := WordArray new: 1024 * 1024.
+ 					 out := Array new: 512.
+ 					 roots := HashedCollection withAllSubclasses asArray.
+ 					 roots := roots, (roots collect: [:ea| ea class]).
+ 					 (thisContext isPrimFailToken: (nil tryPrimitive: 98 withArgs: { roots. seg. out })) ifTrue:
+ 						[^#error].
+ 					 result := { seg. out }.
+ 					 (thisContext isPrimFailToken: (nil tryPrimitive: 99 withArgs: result)) ifTrue:
+ 						[^#error].
+ 					 result]
+ 						on: Error
+ 						do: [:ex| ^#error]'}.
+ 			self deny: objects = error]!

Item was removed:
- ----- Method: SpurImageSegmentTests>>testSaveHashedCollectionAndSubclasses (in category 'tests') -----
- testSaveHashedCollectionAndSubclasses
- 	SimulatorHarnessForTests new
- 		withExecutableInterpreter: self initializedVM
- 		do: [:vm :harness| | objects |
- 			CheckForLeaks == true ifTrue: "CheckForLeaks := self confirm: 'Check for leaks?'"
- 				[vm objectMemory setCheckForLeaks: (vm objectMemory class bindingOf: #GCModeImageSegment) value].
- 			objects := harness
- 				interpreter: vm
- 				object: (harness findClassNamed: 'Compiler')
- 				perform: (harness findSymbol: #evaluate:)
- 				withArguments: {vm objectMemory stringForCString:
- 					'| seg out result |
- 					 seg := WordArray new: 1024 * 1024.
- 					 out := Array new: 256.
- 					 nil tryPrimitive: 98 withArgs: {	HashedCollection subclasses,
- 													(HashedCollection subclasses collect: [:ea| ea class]).
- 													seg. out }.
- 					 result := { seg. out }.
- 					 nil tryPrimitive: 99 withArgs: result.
- 					 result'}]!

Item was added:
+ ----- Method: SpurImageSegmentTests>>testSaveHashedCollectionSubclasses (in category 'tests') -----
+ testSaveHashedCollectionSubclasses
+ 	SimulatorHarnessForTests new
+ 		withExecutableInterpreter: self initializedVM
+ 		do: [:vm :harness| | error objects |
+ 			CheckForLeaks == true ifTrue: "CheckForLeaks := self confirm: 'Check for leaks?'"
+ 				[vm objectMemory setCheckForLeaks: (vm objectMemory class bindingOf: #GCModeImageSegment) value].
+ 			error := harness findSymbol: #error.
+ 			self deny: error isNil.
+ 			objects := harness
+ 				interpreter: vm
+ 				object: (harness findClassNamed: 'Compiler')
+ 				perform: (harness findSymbol: #evaluate:)
+ 				withArguments: {vm objectMemory stringForCString:
+ 					'[| seg out result |
+ 					 seg := WordArray new: 1024 * 1024.
+ 					 out := Array new: 256.
+ 					 roots := HashedCollection subclasses asArray.
+ 					 roots := roots, (roots collect: [:ea| ea class]).
+ 					 (thisContext isPrimFailToken: (nil tryPrimitive: 98 withArgs: { roots. seg. out })) ifTrue:
+ 						[^#error].
+ 					 result := { seg. out }.
+ 					 (thisContext isPrimFailToken: (nil tryPrimitive: 99 withArgs: result)) ifTrue:
+ 						[^#error].
+ 					 result]
+ 						on: Error
+ 						do: [:ex| ^#error]'}.
+ 			self deny: objects = error]!

Item was changed:
  ----- Method: SpurMemoryManager>>mapOopsFrom:to:outPointers:outHashes: (in category 'image segment in/out') -----
  mapOopsFrom: segStart to: segAddr outPointers: outPointerArray outHashes: savedOutHashes
  	"This is part of storeImageSegmentInto:outPointers:roots:.
  	 Now scan, adding out pointers to the outPointersArray; all objects in arrayOfObjects
  	 have had their first fields set to point to their copies in segmentWordArray.  Answer
  	 the outIndex if the scan succeded.  Fail if outPointers is too small and answer -1.
  
  	 As established by copyObj:toAddr:startAt:stopAt:savedFirstFields:index:,
  	 the marked bit is set for all objects in the segment
  	 the remembered bit is set for all classes in the segment.
  
  	 Class indices should be set as follows (see assignClassIndicesAndPinFrom:to:outPointers:filling:)
  	 - class indices for classes in the segment "
  	| objOop outIndex |
  	outIndex := 0.
  	self fillObj: outPointerArray numSlots: (self numSlotsOf: outPointerArray) with: nilObj.
  	objOop := self objectStartingAt: segStart.
  	[objOop < segAddr] whileTrue:
  		[| oop hash segIndex |
  		 oop := self fetchClassOfNonImm: objOop.
  		 "Set the classIndex of the instance.  This is a segment offset (segAddr - segStart / allocatiopnUnit) for instances of
  		  classes within the segment, and an outPointer index (index in outPointers + TopHashBit) for classes outside the segment."
  		 (self isMarked: oop)
  			ifTrue: "oop is a class in the segment; storeImageSegmentInto:outPointers:roots: established offset is within range."
  				[oop := self fetchPointer: 0 ofObject: oop.
  				 self assert: (self oop: oop isGreaterThanOrEqualTo: segStart andLessThan: segAddr).
  				 segIndex := oop - segStart / self allocationUnit + self firstClassIndexPun.
  				 (segIndex anyMask: TopHashBit) ifTrue: "Too many classes in the segment"
  					[^-1 halt]]
  			ifFalse: "oop is an outPointer; locate or allocate its oop"
  				[hash := self rawHashBitsOf: oop.
  				 (self is: hash outPointerClassHashFor: oop in: outPointerArray limit: outIndex)
  					ifTrue: [segIndex := hash]
  					ifFalse: "oop is a new outPointer; allocate its oop"
  						[outIndex := self newOutPointer: oop at: outIndex in: outPointerArray hashes: savedOutHashes.
  						 outIndex = 0 ifTrue: "no room in outPointers; fail"
  							[^-1 halt].
  						 segIndex := self rawHashBitsOf: oop].
  				 self assert: (segIndex anyMask: TopHashBit)].
  		 self setClassIndexOf: objOop to: segIndex.
  		 0 to: (self numPointerSlotsOf: objOop) - 1 do:
  			[:i|
  			 oop := self fetchPointer: i ofObject: objOop.
  			 (self isNonImmediate: oop) ifTrue:
  				[(self isMarked: oop)
  					ifTrue: "oop is an object in the segment."
  						[oop := self fetchPointer: 0 ofObject: oop.
  						 self assert: (self oop: oop isGreaterThanOrEqualTo: segStart andLessThan: segAddr).
  						 oop := oop - segStart]
  					ifFalse: "oop is an outPointer; locate or allocate its oop"
  						[hash := self rawHashBitsOf: oop.
  						(self is: hash outPointerClassHashFor: oop in: outPointerArray limit: outIndex)
+ 							ifTrue: [oop := hash - TopHashBit * self bytesPerOop + TopOopBit]
- 							ifTrue: [oop := hash * self bytesPerOop + TopOopBit]
  							ifFalse: "oop is a new outPointer; allocate its oop"
  								[outIndex := self newOutPointer: oop at: outIndex in: outPointerArray hashes: savedOutHashes.
  								 outIndex = 0 ifTrue: "no room in outPointers; fail"
  									[^-1 halt].
  								 self assert: ((self rawHashBitsOf: oop) anyMask: TopHashBit).
+ 								 oop := (self rawHashBitsOf: oop) - TopHashBit * self bytesPerOop + TopOopBit]].
- 								 oop := (self rawHashBitsOf: objOop) - TopHashBit * self bytesPerOop + TopOopBit]].
  				 self storePointerUnchecked: i ofObject: objOop withValue: oop]].
  		 objOop := self objectAfter: objOop limit: segAddr].
  	^outIndex!

Item was changed:
  ----- Method: SpurMemoryManager>>storeImageSegmentInto:outPointers:roots: (in category 'image segment in/out') -----
  storeImageSegmentInto: segmentWordArrayArg outPointers: outPointerArrayArg roots: arrayOfRootsArg
  	"This primitive is called from Squeak as...
  		<imageSegment> storeSegmentFor: arrayOfRoots into: aWordArray outPointers: anArray.
  
  	 This primitive will store a binary image segment (in the same format as objects in the heap) of the
  	 set of objects in arrayOfObjects.  All pointers from within the set to objects outside the set will be
  	 copied into the array of outPointers.  In their place in the image segment will be an oop equal to the
  	 offset in the outPointer array (the first would be 8), but with the high bit set.
  
  	 Since Spur has a class table the load primitive must insert classes that have instances into the
  	 class table.  This primitive marks such classes using the isRemembered bit, which isn't meaningful
  	 as a remembered bit in the segment.
  
  	 The primitive expects the segmentWordArray and outPointerArray to be more than adequately long.
  	 In this case it returns normally, and truncates the two arrays to exactly the right size.
  
  	 The primitive can fail for the following reasons with the specified failure codes:
  		PrimErrGenericError:		the segmentWordArray is too small for the version stamp
  		PrimErrWritePastObject:	the segmentWordArray is too small to contain the reachable objects
  		PrimErrBadIndex:			the outPointerArray is too small
  		PrimErrNoMemory:			additional allocations failed
  		PrimErrLimitExceeded:		there is no room in the hash field to store out pointer indices or class references."
  	<inline: false>
  	| segmentWordArray outPointerArray arrayOfRoots
  	  arrayOfObjects savedFirstFields savedOutHashes segStart segAddr endSeg outIndex numClassesInSegment |
  	((self isObjImmutable: segmentWordArrayArg)
  	 or: [self isObjImmutable: outPointerArrayArg]) ifTrue:
  		[^PrimErrNoModification].
  	"Since segmentWordArrayArg & outPointerArrayArg may get shortened, they can't be pinned."
  	((self isPinned: segmentWordArrayArg)
  	 or: [self isPinned: outPointerArrayArg]) ifTrue:
  		[^PrimErrObjectIsPinned].
  	(self numSlotsOf: outPointerArrayArg) > self maxIdentityHash ifTrue:
  		[^PrimErrLimitExceeded].
  
  	self runLeakCheckerFor: GCModeImageSegment.
  
  	"First scavenge to collect any new space garbage that refers to the graph."
  	self scavengingGC.
  	segmentWordArray := self updatePostScavenge: segmentWordArrayArg.
  	outPointerArray := self updatePostScavenge: outPointerArrayArg.
  	arrayOfRoots := self updatePostScavenge: arrayOfRootsArg.
  	
  	"Now compute the transitive closure, collecting the sequence of objects to be stored in the arrayOfObjects array.
  	 Included in arrayOfObjects are the arrayOfRoots and all its contents.  All objects have been unmarked."
  	arrayOfObjects := self objectsReachableFromRoots: arrayOfRoots.
  	arrayOfObjects ifNil:
  		[^PrimErrNoMemory].
  
  	self assert: self allObjectsUnmarked. "work to be done when the incremental GC is written"
  
  	"Both to expand the max size of segment and to reduce the length of the
  	 load-time pass that adds classes to the class table, move classes to the
  	 front of arrayOfObjects, leaving the root array as the first element."
  	numClassesInSegment := self moveClassesForwardsIn: arrayOfObjects.
  
  	"The scheme is to copy the objects into segmentWordArray, and then map the oops in segmentWordArray.
  	 Therefore the primitive needs to both map efficiently originals to copies in segmentWordArray and
  	 be able to undo any side-effects if the primitive fails because either segmentWordArray or outPointerArray
  	 is too small.  The mapping is done by having the objects to be stored in arrayOfObjects refer to their mapped
  	 locations through their first field, just like a forwarding pointer, but without becoming a forwarder, saving their
+ 	 first field in savedFirstFields, and the objects in outPointerArray pointing to their locations in the outPointerArray
- 	 first field in savedFirstFields, and the objects in outPointerArray pointing to tehir locations in the outPointerArray
  	 through their identityHashes, saved in savedOutHashes.
  	 Since arrayOfObjects and its savedFirstFields, and outPointerArray and its saved hashes, can be enumerated
+ 	 side-by-side, the hashes can be restored to the originals.  So the first field of the heap object corresponding to
+ 	 an object in arrayOfObjects is set to its location in segmentWordArray, and the hash of an object in outPointerArray
+ 	 is set to its index in outPointerArray plus the top hash bit.  Classes in arrayOfObjects have their marked bit set.
+ 	 Oops in objects in segmentWordArray are therefore mapped by accessing the original oop, and following its first
+ 	 field. Class indices in segmentWordArray are mapped by fetching the original class, and testing its marked bit.
+ 	 If marked, the first field is followed to access the class copy in the segment.  Out pointers (objects and classes,
+ 	 which are unmarked), the object's identityHash is set (eek!!!!) to its index in the outPointerArray. So savedOutHashes
+ 	 parallels the outPointerArray. The saved hash array is initialized with an out-of-range hash value so that the first
- 	 side-by-side, the hashes can be restored to the originals.  So the hash of an object in arrayOfObjects
- 	 is set to its offset in segmentWordArray / self allocationUnit, and the hash of an object in outPointerArray
- 	 is set to its index in outPointerArray plus the top hash bit.  Oops in segmentWordArray are therefore
- 	 mapped by accessing the original oop's identityHash, testing the bottom bit to distinguish between internal
- 	 and external oops.  The saved hash arrays are initialized with an out-of-range hash value so that the first
  	 unused entry can be identified."
  
  	savedFirstFields := self allocateSlots: (self numSlotsOf: arrayOfObjects)
  							format: self wordIndexableFormat
  							classIndex: self wordSizeClassIndexPun.
  	savedOutHashes := self allocateSlots: (self numSlotsForBytes: (self numSlotsOf: outPointerArray) * 4)
  							format: self firstLongFormat
  							classIndex: self thirtyTwoBitLongsClassIndexPun.
  	(savedFirstFields isNil or: [savedOutHashes isNil]) ifTrue:
  		[self freeObject: arrayOfObjects.
  		 ^PrimErrNoMemory].
  
  	self fillObj: savedFirstFields numSlots: (self numSlotsOf: savedFirstFields) with: 0.
  	self fillObj: savedOutHashes numSlots: (self numSlotsOf: savedOutHashes) with: self savedOutHashFillValue.
  
  	segAddr := segmentWordArray + self baseHeaderSize.
  	endSeg := self addressAfter: segmentWordArray.
  
  	"Write a version number for byte order and version check."
  	segAddr >= endSeg ifTrue: [^PrimErrGenericFailure].
  	self long32At: segAddr put: self imageSegmentVersion.
  	self long32At: segAddr + 4 put: self imageSegmentVersion.
  	segStart := segAddr := segAddr + self allocationUnit.
  
  	"Copy all reachable objects to the segment, setting the marked bit for all objects (clones) in the segment,
  	 and the remembered bit for all classes (clones) in the segment."
  	0 to: (self numSlotsOf: arrayOfObjects) - 1 do:
  		[:i| | newSegAddrOrError objOop |
  		"Check that classes in the segment are addressible.  Since the top bit of the hash field is used to tag
  		 classes external to the segment, the segment offset must not inadvertently set this bit.  This limit still
  		 allows for a million or more classes."
  		(i = numClassesInSegment
  		 and: [segAddr - segStart / self allocationUnit + self lastClassIndexPun >= TopHashBit]) ifTrue:
  			[^self return: PrimErrLimitExceeded
  					restoringObjectsIn: arrayOfObjects upTo: i savedFirstFields: savedFirstFields].
  		objOop := self fetchPointer: i ofObject: arrayOfObjects.
  		self deny: ((self isImmediate: objOop) or: [self isForwarded: objOop]).
  		newSegAddrOrError := self copyObj: objOop
  									toAddr: segAddr
  									startAt: segStart 
  									stopAt: endSeg
  									savedFirstFields: savedFirstFields
  									index: i.
  		newSegAddrOrError < segStart ifTrue:
  			[^self return: newSegAddrOrError
  					restoringObjectsIn: arrayOfObjects upTo: i savedFirstFields: savedFirstFields].
  		 segAddr := newSegAddrOrError].
  
  	"Check that it can be safely shortened."
  	(endSeg ~= segAddr
  	 and: [endSeg - segAddr < (self baseHeaderSize + self bytesPerOop)]) ifTrue:
  		[^self return: PrimErrWritePastObject
  				restoringObjectsIn: arrayOfObjects upTo: -1 savedFirstFields: savedFirstFields].
  
  	"Now scan, adding out pointers to the outPointersArray; all objects in arrayOfObjects
  	 have their first field pointing to the corresponding copy in segmentWordArray."
  	(outIndex := self mapOopsFrom: segStart
  					to: segAddr
  					outPointers: outPointerArray
  					outHashes: savedOutHashes) < 0 ifTrue: "no room in outPointers; fail"
  		[^self return: PrimErrBadIndex
  				restoringObjectsIn: arrayOfObjects savedFirstFields: savedFirstFields
  				and: outPointerArray savedHashes: savedOutHashes].
  
  	"We're done.  Shorten the results, restore hashes and return."
  	self shorten: segmentWordArray toIndexableSize: segAddr - (segmentWordArray + self baseHeaderSize) / 4.
  	self shorten: outPointerArray toIndexableSize: outIndex.
  	^self return: PrimNoErr
  		restoringObjectsIn: arrayOfObjects savedFirstFields: savedFirstFields
  		and: outPointerArray savedHashes: savedOutHashes!

Item was added:
+ ----- Method: WordArray class>>defaultIntegerBaseInDebugger (in category '*VMMaker-inspecting') -----
+ defaultIntegerBaseInDebugger
+ 	^16!



More information about the Vm-dev mailing list