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

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

Name: VMMaker.oscog-eem.3186
Author: eem
Time: 9 June 2022, 11:13:32.630854 am
UUID: 0d525cc7-e989-4c4b-af03-cb12d271b302
Ancestors: VMMaker.oscog-eem.3184, VMMaker.oscog-dtl.3185

Fix failure of Spur image segment loading due to not having enough memory to allocate the Array of loaded objects result.  This is unlikely, but can happen with large image segments if memory is scarce.  Fix received from Max Leske with thanks.  Improve some comments in the changed methods.

=============== Diff against VMMaker.oscog-dtl.3185 ===============

Item was changed:
  ----- Method: SpurMemoryManager>>loadImageSegmentFrom:outPointers: (in category 'image segment in/out') -----
  loadImageSegmentFrom: segmentWordArray outPointers: outPointerArray
  	"This primitive is called from Smalltalk as...
  		<imageSegment> loadSegmentFrom: aWordArray outPointers: anArray."
  
  	"This primitive will load a binary image segment created by primitiveStoreImageSegment.
  	 It expects the outPointer array to be of the proper size, and the wordArray to be well formed.
  	 It will return as its value the original array of roots, and the segmentWordArray will become an
  	 array of the loaded objects.  If this primitive should fail, the segmentWordArray will, sadly, have
  	 been reduced to an unrecognizable and unusable jumble.  But what more could you have done
  	 with it anyway?
  
  	 The primitive, if it succeeds, also becomes the segmentWordArray into the array of loaded objects.
  	 This allows fixing up of loaded objects directly, without nextObject, which Spur doesn't support."
  
  	<inline: #never>
  	| segmentLimit segmentStart segVersion errorCode numLoadedObjects loadedObjectsArray |
  
  	segmentLimit := self numSlotsOf: segmentWordArray.
  	(self objectBytesForSlots: segmentLimit) < (self allocationUnit "version info" + self baseHeaderSize "one object header") ifTrue:
  		[^PrimErrBadArgument halt].
  
  	"Verify format.  If the format is wrong, word-swap (since ImageSegment data are 32-bit longs).
  	 If it is still wrong, undo the damage and fail."
  	segVersion := self longAt: segmentWordArray + self baseHeaderSize.
  	(coInterpreter readableFormat: (segVersion bitAnd: 16rFFFFFF "low 3 bytes")) ifFalse:
  		[self reverseBytesIn32BitWordsIn: segmentWordArray.
  		 segVersion := self longAt: segmentWordArray + self baseHeaderSize.
  		 (coInterpreter readableFormat: (segVersion bitAnd: 16rFFFFFF "low 3 bytes")) ifFalse:
  			[self reverseBytesIn32BitWordsIn: segmentWordArray.
  			 ^PrimErrBadArgument halt]].
  
  	segmentStart := segmentWordArray + self baseHeaderSize + self allocationUnit.
  	segmentLimit := segmentLimit * self bytesPerOop + segmentWordArray + self baseHeaderSize.
  
  	"Notionally reverse the Byte type objects if the data is from opposite endian machine.
  	 Test top byte.  $d on the Mac or $s on the PC.  Rest of word is equal.  If Spur is ever
  	 ported to big-endian machines then the segment may have to be byte/word swapped,
  	 but so far it only runs on little-endian machines, so for now just fail if endianness is wrong."
  	self flag: #endianness.
  	(segVersion >> 24 bitAnd: 16rFF) ~= (self imageSegmentVersion >> 24 bitAnd: 16rFF) ifTrue:
  		"Reverse the byte-type objects once"
  		[true
  			ifTrue: [^PrimErrBadArgument halt]
  			ifFalse:
  				[self byteSwapByteObjectsFrom: (self objectStartingAt: segmentStart)
  					to: segmentLimit
  					flipFloatsIf: false]].
  
  	"Avoid having to remember by arranging that there are no young outPointers if segment is in old space."
  	(self isOldObject: segmentWordArray) ifTrue:
  		[errorCode := self ensureNoNewObjectsIn: outPointerArray.
  		 errorCode ~= 0 ifTrue:
  			[^errorCode]].
  
  	"scan through mapping oops and validating class references. Defer entering any
  	 class objects into the class table and/or pinning objects until a second pass."
  	errorCode := self mapOopsAndValidateClassRefsFrom: segmentStart to: segmentLimit outPointers: outPointerArray.
  	errorCode > 0 ifTrue:
  		[^errorCode].
  	numLoadedObjects := errorCode negated.
  	loadedObjectsArray := self allocateSlots: numLoadedObjects format: self arrayFormat classIndex: ClassArrayCompactIndex.
  	loadedObjectsArray ifNil:
+ 		[self growOldSpaceByAtLeast: (self largeObjectBytesForSlots: numLoadedObjects).
+ 		 loadedObjectsArray := self allocateSlots: numLoadedObjects format: self arrayFormat classIndex: ClassArrayCompactIndex.
+ 		 loadedObjectsArray ifNil:
+ 			[^PrimErrNoMemory halt]].
- 		[^PrimErrNoMemory halt].
  
  	"Scan for classes contained in the segment, entering them into the class table.
  	 Classes are at the front, after the root array and have the remembered bit set."
  	errorCode := self enterClassesIntoClassTableFrom: segmentStart to: segmentLimit.
  	errorCode ~= 0 ifTrue:
  		[^errorCode].
  
  	"Make a final pass, assigning class indices and/or pinning pinned objects and collecting the loaded objects in loadedObjectsArray"
  	self assignClassIndicesAndPinFrom: segmentStart to: segmentLimit outPointers: outPointerArray filling: loadedObjectsArray.
  
  	"Evaporate the container, leaving the newly loaded objects in place."
  	(self hasOverflowHeader: segmentWordArray)
  		ifTrue: "N.B. setting the overflow slots to 1 creates a slimbridge in eden, so we also need to delete the overflow slot count in the segment itself"
  			[(self oop: segmentWordArray isLessThan: oldSpaceStart)
  				ifTrue:
  					[self rawOverflowSlotsOf: segmentWordArray put: 0.
  					 self rawNumSlotsOf: segmentWordArray put: 0]
  				ifFalse:
  					[self rawOverflowSlotsOf: segmentWordArray put: self allocationUnit / self bytesPerOop]]
  		ifFalse: [self rawNumSlotsOf: segmentWordArray put: self allocationUnit / self bytesPerOop].
  
  	"Finally forward the segmentWordArray to the loadedObjectsArray"
  	self forward: segmentWordArray to: loadedObjectsArray.
  	
  	self runLeakCheckerFor: GCCheckImageSegment.
  
+ 	"Answer the first object in the segment because this is what primitiveLoadImageSegment tests for,
+ 	 even though the real result is the segmentWordArray forwarded to the loadedObjectsArray."
  	^self objectStartingAt: segmentStart!

Item was changed:
  ----- Method: SpurMemoryManager>>mapOopsAndValidateClassRefsFrom:to:outPointers: (in category 'image segment in/out') -----
  mapOopsAndValidateClassRefsFrom: segmentStart to: segmentLimit outPointers: outPointerArray
  	"This is part of loadImageSegmentFrom:outPointers:.
  	 Scan through mapping oops and validating class references.  Defer
  	 entering any class objects into the class table and/or pinning objects
+ 	 until the second pass in assignClassIndicesAndPinFrom:to:outPointers:.
+ 	 If anything is wrong, answer a primitive error code, otherwise answer
+ 	 the number of objects in the segment as a negative value."
- 	 until the second pass in assignClassIndicesAndPinFrom:to:outPointers:."
  	<var: 'segmentLimit' type: #usqInt>
  	| numOutPointers numSegObjs objOop |
  	<var: #oop type: #usqInt>
  	numOutPointers := self numSlotsOf: outPointerArray.
  	numSegObjs := 0.
  	objOop := self objectStartingAt: segmentStart.
  	[self oop: objOop isLessThan: segmentLimit] whileTrue:
  		[| classIndex hash oop mappedOop |
  		 numSegObjs := numSegObjs + 1.
  		 "No object in the segment should be marked.  If is is something is wrong."
  		 (self isMarked: objOop) ifTrue:
  			[^PrimErrInappropriate halt].
  		 classIndex := self classIndexOf: objOop.
  		 "validate the class ref, but don't update it until any internal classes have been added to the class table."
  		 (classIndex anyMask: TopHashBit)
  			ifTrue:
  				[classIndex := classIndex - TopHashBit.
  				 classIndex >= numOutPointers ifTrue:
  					[^PrimErrBadIndex halt].
  				 mappedOop := self fetchPointer: classIndex ofObject: outPointerArray.
  				 hash := self rawHashBitsOf: mappedOop.
  				 (hash = 0 "class has yet to be instantiated"
  				  or: [hash > self lastClassIndexPun and: [(self classOrNilAtIndex: hash) = mappedOop]]) ifFalse:
  					[^PrimErrInappropriate halt]]
  			ifFalse: "The class is contained within the segment."
  				[(oop := classIndex - self firstClassIndexPun * self allocationUnit + segmentStart) >= segmentLimit ifTrue:
  					[^PrimErrBadIndex halt].
  				 (self rawHashBitsOf: oop) ~= 0 ifTrue:
  					[^PrimErrInappropriate halt]].
  		 0 to: (self numPointerSlotsOf: objOop) - 1 do:
  			[:i|
  			 oop := self fetchPointer: i ofObject: objOop.
  			 (self isNonImmediate: oop) ifTrue:
  				[(oop anyMask: TopOopBit)
  					ifTrue:
  						[(oop := oop - TopOopBit / self bytesPerOop) >= numOutPointers ifTrue:
  							[^PrimErrBadIndex halt].
  						 mappedOop := self fetchPointer: oop ofObject: outPointerArray]
  					ifFalse:
  						[(oop bitAnd: self allocationUnit - 1) ~= 0 ifTrue:
  							[^PrimErrInappropriate halt].
  						 (mappedOop := oop + segmentStart) >= segmentLimit ifTrue:
  							[^PrimErrBadIndex halt]].
  				 self storePointerUnchecked: i ofObject: objOop withValue: mappedOop]].
  		 objOop := self objectAfter: objOop limit: segmentLimit].
  	^numSegObjs negated!