[Vm-dev] VM Maker: VMMaker-dtl.330.mcz

commits at source.squeak.org commits at source.squeak.org
Wed Nov 27 02:35:34 UTC 2013 

David T. Lewis uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker-dtl.330.mcz

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

Name: VMMaker-dtl.330
Author: dtl
Time: 26 November 2013, 9:33:55.06 pm
UUID: 4dabd4f4-3bed-4c10-9c4e-4bfa69037719
Ancestors: VMMaker-dtl.329

Fix loading of format 6505 (Cog) images in InterpreterSimulator in float word order fixup. An interpreter must send #lengthOf:baseHeader:format: to its object memory, not to self.

No change to generated code, so versionString is unchanged.

=============== Diff against VMMaker-dtl.329 ===============

Item was changed:
  ----- Method: Interpreter>>install:inAtCache:at:string: (in category 'indexing primitives') -----
  install: rcvr inAtCache: cache at: atIx string: stringy
  	"Install the oop of this object in the given cache (at or atPut), along with
  	its size, format and fixedSize"
  	| hdr fmt totalLength fixedFields |
  	<var: #cache type: 'sqInt *'>
  
  	hdr := objectMemory baseHeader: rcvr.
  	fmt := (hdr >> 8) bitAnd: 16rF.
  	(fmt = 3 and: [self isContextHeader: hdr]) ifTrue:
  		["Contexts must not be put in the atCache, since their size is not constant"
  		^ self primitiveFail].
+ 	totalLength := objectMemory lengthOf: rcvr baseHeader: hdr format: fmt.
- 	totalLength := self lengthOf: rcvr baseHeader: hdr format: fmt.
  	fixedFields := objectMemory fixedFieldsOf: rcvr format: fmt length: totalLength.
  
  	cache at: atIx+AtCacheOop put: rcvr.
  	stringy ifTrue: [cache at: atIx+AtCacheFmt put: fmt + 16]  "special flag for strings"
  			ifFalse: [cache at: atIx+AtCacheFmt put: fmt].
  	cache at: atIx+AtCacheFixedFields put: fixedFields.
  	cache at: atIx+AtCacheSize put: totalLength - fixedFields.
  !

Item was changed:
  ----- Method: Interpreter>>stObject:at: (in category 'array primitive support') -----
  stObject: array at: index
  	"Return what ST would return for <obj> at: index."
  
  	| hdr fmt totalLength fixedFields stSize |
  	<inline: false>
  	hdr := objectMemory baseHeader: array.
  	fmt := (hdr >> 8) bitAnd: 16rF.
+ 	totalLength := objectMemory lengthOf: array baseHeader: hdr format: fmt.
- 	totalLength := self lengthOf: array baseHeader: hdr format: fmt.
  	fixedFields := objectMemory fixedFieldsOf: array format: fmt length: totalLength.
  	(fmt = 3 and: [self isContextHeader: hdr])
  		ifTrue: [stSize := self fetchStackPointerOf: array]
  		ifFalse: [stSize := totalLength - fixedFields].
  	((objectMemory oop: index isGreaterThanOrEqualTo: 1)
  			and: [objectMemory oop: index isLessThanOrEqualTo: stSize])
  		ifTrue: [^ self subscript: array with: (index + fixedFields) format: fmt]
  		ifFalse: [self primitiveFail.  ^ 0].!

Item was changed:
  ----- Method: Interpreter>>stObject:at:put: (in category 'array primitive support') -----
  stObject: array at: index put: value
  	"Do what ST would return for <obj> at: index put: value."
  	| hdr fmt totalLength fixedFields stSize |
  	<inline: false>
  	hdr := objectMemory baseHeader: array.
  	fmt := (hdr >> 8) bitAnd: 16rF.
+ 	totalLength := objectMemory lengthOf: array baseHeader: hdr format: fmt.
- 	totalLength := self lengthOf: array baseHeader: hdr format: fmt.
  	fixedFields := objectMemory fixedFieldsOf: array format: fmt length: totalLength.
  	(fmt = 3 and: [self isContextHeader: hdr])
  		ifTrue: [stSize := self fetchStackPointerOf: array]
  		ifFalse: [stSize := totalLength - fixedFields].
  	((objectMemory oop: index isGreaterThanOrEqualTo: 1)
  			and: [objectMemory oop: index isLessThanOrEqualTo: stSize])
  		ifTrue: [self subscript: array with: (index + fixedFields) storing: value format: fmt]
  		ifFalse: [self primitiveFail]!

Item was changed:
  ----- Method: Interpreter>>stSizeOf: (in category 'array primitive support') -----
  stSizeOf: oop
  	"Return the number of indexable fields in the given object. (i.e., what Smalltalk would return for <obj> size)."
  	"Note: Assume oop is not a SmallInteger!!"
  
  	| hdr fmt totalLength fixedFields |
  	<inline: false>
  	hdr := objectMemory baseHeader: oop.
  	fmt := (hdr >> 8) bitAnd: 16rF.
+ 	totalLength := objectMemory lengthOf: oop baseHeader: hdr format: fmt.
- 	totalLength := self lengthOf: oop baseHeader: hdr format: fmt.
  	fixedFields := objectMemory fixedFieldsOf: oop format: fmt length: totalLength.
  	(fmt = 3 and: [self isContextHeader: hdr])
  		ifTrue: [^ self fetchStackPointerOf: oop]
  		ifFalse: [^ totalLength - fixedFields]!

Item was changed:
  ----- Method: InterpreterPrimitives>>primitiveInstVarAt (in category 'object access primitives') -----
  primitiveInstVarAt
  	| index rcvr hdr fmt totalLength fixedFields value |
  	index := self stackIntegerValue: 0.
  	rcvr := self stackValue: 1.
  	self successful
  		ifTrue: [hdr := objectMemory baseHeader: rcvr.
  			fmt := hdr >> 8 bitAnd: 15.
+ 			totalLength := objectMemory lengthOf: rcvr baseHeader: hdr format: fmt.
- 			totalLength := self lengthOf: rcvr baseHeader: hdr format: fmt.
  			fixedFields := objectMemory fixedFieldsOf: rcvr format: fmt length: totalLength.
  			(index >= 1 and: [index <= fixedFields])
  				ifFalse: [self primitiveFail]].
  	self successful ifTrue: [value := self subscript: rcvr with: index format: fmt].
  	self successful ifTrue: [self pop: argumentCount + 1 thenPush: value]!

Item was changed:
  ----- Method: InterpreterPrimitives>>primitiveInstVarAtPut (in category 'object access primitives') -----
  primitiveInstVarAtPut
  	| newValue index rcvr hdr fmt totalLength fixedFields |
  	newValue := self stackTop.
  	index := self stackIntegerValue: 1.
  	rcvr := self stackValue: 2.
  	self successful
  		ifTrue: [hdr := objectMemory baseHeader: rcvr.
  			fmt := hdr >> 8 bitAnd: 15.
+ 			totalLength := objectMemory lengthOf: rcvr baseHeader: hdr format: fmt.
- 			totalLength := self lengthOf: rcvr baseHeader: hdr format: fmt.
  			fixedFields := objectMemory fixedFieldsOf: rcvr format: fmt length: totalLength.
  			(index >= 1 and: [index <= fixedFields]) ifFalse: [self primitiveFail]].
  	self successful ifTrue: [self subscript: rcvr with: index storing: newValue format: fmt].
  	self successful ifTrue: [self pop: argumentCount + 1 thenPush: newValue]!

Item was changed:
  ----- Method: InterpreterPrimitives>>primitiveStringReplace (in category 'indexing primitives') -----
  primitiveStringReplace
  	" 
  	<array> primReplaceFrom: start to: stop with: replacement 
  	startingAt: repStart  
  	<primitive: 105>
  	"
  	| array start stop repl replStart hdr arrayFmt totalLength arrayInstSize replFmt replInstSize srcIndex |
  	array := self stackValue: 4.
  	start := self stackIntegerValue: 3.
  	stop := self stackIntegerValue: 2.
  	repl := self stackValue: 1.
  	replStart := self stackIntegerValue: 0.
  
  	self successful ifFalse: [^ self primitiveFail].
  	(objectMemory isIntegerObject: repl) ifTrue: ["can happen in LgInt copy"
  			^ self primitiveFail].
  
  	hdr := objectMemory baseHeader: array.
  	arrayFmt := hdr >> 8 bitAnd: 15.
+ 	totalLength := objectMemory lengthOf: array baseHeader: hdr format: arrayFmt.
- 	totalLength := self lengthOf: array baseHeader: hdr format: arrayFmt.
  	arrayInstSize := objectMemory fixedFieldsOf: array format: arrayFmt length: totalLength.
  	(start >= 1 and: [start - 1 <= stop and: [stop + arrayInstSize <= totalLength]])
  		ifFalse: [^ self primitiveFail].
  
  	hdr := objectMemory baseHeader: repl.
  	replFmt := hdr >> 8 bitAnd: 15.
+ 	totalLength := objectMemory lengthOf: repl baseHeader: hdr format: replFmt.
- 	totalLength := self lengthOf: repl baseHeader: hdr format: replFmt.
  	replInstSize := objectMemory fixedFieldsOf: repl format: replFmt length: totalLength.
  	(replStart >= 1 and: [stop - start + replStart + replInstSize <= totalLength])
  		ifFalse: [^ self primitiveFail].
  
  	"Array formats (without byteSize bits, if bytes array) must be same "
  	arrayFmt < 8
  		ifTrue: [arrayFmt = replFmt
  				ifFalse: [^ self primitiveFail]]
  		ifFalse: [(arrayFmt bitAnd: 12) = (replFmt bitAnd: 12)
  				ifFalse: [^ self primitiveFail]].
  
  	srcIndex := replStart + replInstSize - 1.
  	"- 1 for 0-based access"
  
  	arrayFmt <= 4
  		ifTrue: ["pointer type objects"
  			start + arrayInstSize - 1 to: stop + arrayInstSize - 1 do: [:i |
  				objectMemory storePointer: i ofObject: array withValue: (objectMemory fetchPointer: srcIndex ofObject: repl).
  					srcIndex := srcIndex + 1]]
  		ifFalse: [arrayFmt < 8
  				ifTrue: ["32-bit-word type objects"
  					start + arrayInstSize - 1 to: stop + arrayInstSize - 1
  						do: [:i | objectMemory storeLong32: i ofObject: array withValue: (objectMemory fetchLong32: srcIndex ofObject: repl).
  							srcIndex := srcIndex + 1]]
  				ifFalse: ["byte-type objects"
  					start + arrayInstSize - 1 to: stop + arrayInstSize - 1
  						do: [:i |  objectMemory storeByte: i ofObject: array withValue: (objectMemory fetchByte: srcIndex ofObject: repl).
  							srcIndex := srcIndex + 1]]].
  	"We might consider  comparing stop - start to some value here and using forceInterruptCheck"
  
  	self pop: argumentCount "leave rcvr on stack"!

Item was changed:
  ----- Method: ObjectMemorySimulator>>firstIndexableField: (in category 'memory access') -----
  firstIndexableField: oop
  	"NOTE: overridden from Interpreter to add coercion to CArray"
  
  	| hdr fmt totalLength fixedFields |
  	self returnTypeC: 'void *'.
  	hdr := self baseHeader: oop.
  	fmt := (hdr >> 8) bitAnd: 16rF.
+ 	totalLength := self lengthOf: oop baseHeader: hdr format: fmt.
- 	totalLength := interpreter lengthOf: oop baseHeader: hdr format: fmt.
  	fixedFields := self fixedFieldsOf: oop format: fmt length: totalLength.
  	fmt < 8 ifTrue:
  		[fmt = 6 ifTrue:
  			["32 bit field objects"
  			^ self cCoerce: (self pointerForOop: oop + self baseHeaderSize + (fixedFields << 2)) to: 'int *'].
  		"full word objects (pointer or bits)"
  		^ self cCoerce: (self pointerForOop: oop + self baseHeaderSize + (fixedFields << self shiftForWord)) to: 'oop *']
  		ifFalse:
  		["Byte objects"
  		^ self cCoerce: (self pointerForOop: oop + self baseHeaderSize + fixedFields) to: 'char *']!

More information about the Vm-dev mailing list