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

commits at source.squeak.org commits at source.squeak.org
Tue Apr 18 18:35:39 UTC 2017 

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

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

Name: VMMaker.oscog-eem.2197
Author: eem
Time: 18 April 2017, 11:34:46.395361 am
UUID: ef120220-dcf2-4825-ad2c-eab126683414
Ancestors: VMMaker.oscog-eem.2196

Modify the hashMultiply primitive implementations to do what's intended.  Make the magic constant and modulo mask global vars shared between the three implementations.

Modify translated primitive parsing to allow int as a valid variable type.

Improve the commentary in MiscPrimitivePlugin class>>translatedPrimitives.

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

Item was changed:
  ----- Method: CoInterpreterPrimitives>>mcprimHashMultiply: (in category 'arithmetic primitives') -----
  mcprimHashMultiply: receiverArg
  	"Machine code primitive for hash multiply. c.f. primitiveHashMultiply.
  	 mcprims consume receiver and arguments as parameters and answer the
  	 result on success, or set the primitive error code and answer 0 on failure."
  	"Implement 28-bit hashMultiply for SmallInteger and LargePositiveInteger receivers."
  	<api>
+ 	| value |
- 	| receiver low |
  	(objectMemory isIntegerObject: receiverArg)
+ 		ifTrue: [value := objectMemory integerValueOf: receiverArg]
- 		ifTrue: [receiver := objectMemory integerValueOf: receiverArg]
  		ifFalse:
  			[| ok |
  			 ok := objectMemory is: receiverArg instanceOf: (objectMemory splObj: ClassLargePositiveInteger) compactClassIndex: ClassLargePositiveIntegerCompactIndex.
  			 ok ifFalse:
  				[self primitiveFailFor: PrimErrBadReceiver.
  				 ^0].
+ 			 value := objectMemory byteSwapped32IfBigEndian: (objectMemory fetchLong32: 0 ofObject: receiverArg)].
+ 	^objectMemory integerObjectOf: (value * HashMultiplyConstant bitAnd: 16rFFFFFFF)!
- 			 receiver := objectMemory byteSwapped32IfBigEndian: (objectMemory fetchLong32: 0 ofObject: receiverArg)].
- 	low := receiver bitAnd: 16383.
- 	"N.B. We use undefined behaviour assuming the compiler will still generate a multiply, rather than simply crap out, so as to save the unnecessary bitAnd: 16383."
- 	^objectMemory integerObjectOf: ((16r260D * low + ((16r260D * (receiver bitShift: -14) + (16r0065 * low) "bitAnd: 16383") * 16384)) bitAnd: 16r0FFFFFFF)!

Item was added:
+ ----- Method: InterpreterPrimitives class>>initializeMiscConstants (in category 'class initialization') -----
+ initializeMiscConstants
+ 	"Initialize the hashMultiply constants."
+ 	super initializeMiscConstants.
+ 	HashMultiplyConstant := 1664525.
+ 	HashMultiplyMask := 16rFFFFFFF "(2 raisedTo: 28) - 1"!

Item was changed:
  ----- Method: InterpreterPrimitives>>primitiveHashMultiply (in category 'arithmetic integer primitives') -----
  primitiveHashMultiply
  	"Implement 28-bit hashMultiply for SmallInteger and LargePositiveInteger receivers."
+ 	| value |
+ 	value := self stackTop.
+ 	(objectMemory isIntegerObject: value)
+ 		ifTrue: [value := objectMemory integerValueOf: value]
- 	| receiver low result |
- 	receiver := self stackTop.
- 	(objectMemory isIntegerObject: receiver)
- 		ifTrue: [receiver := objectMemory integerValueOf: receiver]
  		ifFalse:
  			[| ok |
+ 			 ok := objectMemory is: value instanceOf: (objectMemory splObj: ClassLargePositiveInteger) compactClassIndex: ClassLargePositiveIntegerCompactIndex.
- 			 ok := objectMemory is: receiver instanceOf: (objectMemory splObj: ClassLargePositiveInteger) compactClassIndex: ClassLargePositiveIntegerCompactIndex.
  			 ok ifFalse:
  				[^self primitiveFailFor: PrimErrBadReceiver].
+ 			 value := objectMemory byteSwapped32IfBigEndian: (objectMemory fetchLong32: 0 ofObject: value)].
+ 	self pop: 1
+ 		thenPush: (objectMemory integerObjectOf: (value * HashMultiplyConstant bitAnd: 16rFFFFFFF))!
- 			 receiver := objectMemory byteSwapped32IfBigEndian: (objectMemory fetchLong32: 0 ofObject: receiver)].
- 	low := receiver bitAnd: 16383.
- 	"N.B. We use undefined behaviour assuming the compiler will still generate a multiply, rather than simply crap out, so as to save the unnecessary bitAnd: 16383."
- 	result := (16r260D * low + ((16r260D * (receiver bitShift: -14) + (16r0065 * low) "bitAnd: 16383") * 16384)) bitAnd: 16r0FFFFFFF.
- 	self pop: 1 thenPush: (objectMemory integerObjectOf: result)!

Item was changed:
  ----- Method: MiscPrimitivePlugin class>>translatedPrimitives (in category 'translation') -----
  translatedPrimitives
  	"an assorted list of various primitives"
+ 	"MiscPrimitivePlugin browseTranslatedPrimitives"
  	(ByteString compiledMethodAt: #findSubstringViaPrimitive:in:startingAt:matchTable: ifAbsent: []) ifNotNil:
  		[^#("Pharo uses findSubstringViaPrimitive:in:startingAt:matchTable:"
  			(Bitmap compress:toByteArray:)
  			(Bitmap decompress:fromByteArray:at:)
+ 			(Bitmap encodeBytesOf:in:at:)	"merely a support function"
+ 			(Bitmap encodeInt:in:at:)		"merely a support function"
- 			(Bitmap encodeBytesOf:in:at:)
- 			(Bitmap encodeInt:in:at:)
  			(ByteString compare:with:collated:)
  			(ByteString translate:from:to:table:)	
  			(ByteString findFirstInString:inSet:startingAt:)
  			(ByteString indexOfAscii:inString:startingAt:)
  			(String findSubstringViaPrimitive:in:startingAt:matchTable:)
  			(ByteArray hashBytes:startingWith:)
  			(SampledSound convert8bitSignedFrom:to16Bit:))].
+ 	^#((Bitmap compress:toByteArray:)
- 	^#(
- 		(Bitmap compress:toByteArray:)
  		(Bitmap decompress:fromByteArray:at:)
+ 		(Bitmap encodeBytesOf:in:at:)	"merely a support function"
+ 		(Bitmap encodeInt:in:at:)		"merely a support function"
- 		(Bitmap encodeBytesOf:in:at:)
- 		(Bitmap encodeInt:in:at:)
  		(ByteString compare:with:collated:)
  		(ByteString translate:from:to:table:)	
  		(ByteString findFirstInString:inSet:startingAt:)
  		(ByteString indexOfAscii:inString:startingAt:)
  		(ByteString findSubstring:in:startingAt:matchTable:)
  		(ByteArray hashBytes:startingWith:)
+ 		(SampledSound convert8bitSignedFrom:to16Bit:))!
- 		(SampledSound convert8bitSignedFrom:to16Bit:)
- 	)
- 
- 	"| tps |
- 	'This opens a list browser on all translated primitives in the image'.
- 	 tps := (SystemNavigation default allImplementorsOf: #translatedPrimitives)
- 				inject: Set new
- 				into: [:tp :mr|
- 					tp addAll: (mr actualClass theNonMetaClass translatedPrimitives collect:
- 								[:pair|
- 								MethodReference
- 									class: (((Smalltalk at: pair first) canUnderstand: pair last)
- 												ifTrue: [Smalltalk at: pair first]
- 												ifFalse: [(Smalltalk at: pair first) class])
- 									selector: pair last]);
- 						yourself].
- 	SystemNavigation default browseMessageList: tps asArray sort name: 'Translated Primitives' "!

Item was changed:
  ----- Method: SimpleStackBasedCogit>>genPrimitiveHashMultiply (in category 'primitive generators') -----
  genPrimitiveHashMultiply
+ 	"Implement 28-bit hashMultiply for SmallInteger and LargePositiveInteger receivers."
+ 	| jmpFailImm jmpFailNonImm jmpNotSmallInt reenter |
- 	| highReg jmpFailImm jmpFailNonImm jmpNotSmallInt lowReg reenter |
  	jmpNotSmallInt := objectRepresentation genJumpNotSmallInteger: ReceiverResultReg.
+ 
  	objectRepresentation genConvertSmallIntegerToIntegerInReg: ReceiverResultReg.
+ 	reenter :=
+ 	self MoveCq: HashMultiplyConstant R: TempReg.
+ 	self MulR: TempReg R: ReceiverResultReg.
+ 	self AndCq: HashMultiplyMask R: ReceiverResultReg.
- 	reenter := self MoveR: ReceiverResultReg R: (highReg := Arg1Reg).
- 	self
- 		ArithmeticShiftRightCq: 14 R: highReg;				"highReg := receiver bitShift: -14"
- 		AndCq: 16383 R: ReceiverResultReg;
- 		MoveR: ReceiverResultReg R: (lowReg := Arg0Reg);	"lowReg := receiver bitAnd: 16383"
- 		MoveCq: 16r260D R: TempReg;
- 		MulR: TempReg R: ReceiverResultReg;				"RRR := 16r260D * low"
- 		MulR: TempReg R: highReg;						"highReg := (16r260D * (receiver bitShift: -14))"
- 		MoveCq: 16r0065 R: TempReg;
- 		MulR: TempReg R: lowReg;							"lowReg := 16r0065 * low"
- 		AddR: lowReg R: highReg;							"highReg := (16r260D * (receiver bitShift: -14)) + (16r0065 * low)"
- 		MoveCq: 16384 R: TempReg;
- 		MulR: TempReg R: highReg;						"highReg := (16r260D * (receiver bitShift: -14)) + (16r0065 * low)"
- 		AddR: highReg R: ReceiverResultReg;
- 		AndCq: 16r0FFFFFFF R: ReceiverResultReg.
  	objectRepresentation genConvertIntegerToSmallIntegerInReg: ReceiverResultReg.
  	self RetN: 0.
+ 
  	jmpNotSmallInt jmpTarget: self Label.
  	jmpFailImm := objectRepresentation genJumpImmediate: ReceiverResultReg.
  	objectRepresentation genGetCompactClassIndexNonImmOf: ReceiverResultReg into: ClassReg.
  	self CmpCq: ClassLargePositiveIntegerCompactIndex R: ClassReg.
  	jmpFailNonImm := self JumpNonZero: 0.
  	objectRepresentation genLoadSlot: 0 sourceReg: ReceiverResultReg destReg: ReceiverResultReg.
  	self Jump: reenter.
+ 
  	jmpFailImm jmpTarget: (jmpFailNonImm jmpTarget: self Label).
  	^0!

Item was changed:
  ----- Method: TMethod>>argConversionExprFor:stackIndex: (in category 'primitive compilation') -----
  argConversionExprFor: varName stackIndex: stackIndex 
  	"Return the parse tree for an expression that fetches and converts the 
  	primitive argument at the given stack offset."
+ 	| exprList decl type stmtList |
- 	| exprList decl stmtList |
  	exprList := OrderedCollection new.
+ 	((decl := declarations at: varName ifAbsent: []) notNil
+ 	 and: ['int' ~= (type := (decl copyReplaceAll: varName with: '') withBlanksTrimmed)])
+ 		ifTrue:
+ 			[(decl includes: $*) ifTrue: "array"
+ 				[(decl includesSubString: 'char')
+ 					ifTrue:
+ 						[| expr |
+ 						expr := '(interpreterProxy isBytes: (interpreterProxy stackValue: (stackIndex))) ifFalse: [^interpreterProxy primitiveFail]'.
+ 						expr := expr copyReplaceAll: 'interpreterProxy' with: self vmNameString.
+ 						expr := expr copyReplaceAll: 'stackIndex' with: stackIndex printString.
+ 						exprList addLast: expr].
+ 					exprList addLast: varName , ' := ', self vmNameString, ' arrayValueOf: (', self vmNameString, ' stackValue: (' , stackIndex printString , '))'.
+ 					exprList addLast: varName , ' := ' , varName , ' - 1'] "so that varName[1] is the zero'th element"
+ 				ifFalse: "must be a double"
+ 					[type ~= 'double' ifTrue:
+ 						[self error: 'unsupported type declaration in a translated primitive method'].
+ 					 exprList addLast: varName , ' := ', self vmNameString, ' stackFloatValue: ' , stackIndex printString]]
+ 			ifFalse: "undeclared variables are taken to be integer"
+ 				[exprList addLast: varName , ' := ', self vmNameString, ' stackIntegerValue: ' , stackIndex printString].
- 	(declarations includesKey: varName) ifTrue:[
- 		decl := declarations at: varName.
- 		(decl includes: $*) ifTrue:["array"
- 			(decl includesSubString: 'char') ifTrue:[ | expr |
- 				expr := '(interpreterProxy isBytes: (interpreterProxy stackValue: (stackIndex))) ifFalse:[^interpreterProxy primitiveFail].'.
- 				expr := expr copyReplaceAll: 'interpreterProxy' with: self vmNameString.
- 				expr := expr copyReplaceAll: 'stackIndex' with: stackIndex printString.
- 				exprList add: expr.
- 			].
- 			exprList add: varName , ' := ', self vmNameString, ' arrayValueOf: (', self vmNameString, ' stackValue: (' , stackIndex printString , '))'.
- 			exprList add: varName , ' := ' , varName , ' - 1'.
- 		] ifFalse:["must be a double"
- 			(decl findString: 'double' startingAt: 1) = 0 ifTrue: [
- 				self error: 'unsupported type declaration in a primitive method'
- 			].
- 			exprList add: varName , ' := ', self vmNameString, ' stackFloatValue: ' , stackIndex printString.
- 		]
- 	] ifFalse: ["undeclared variables are taken to be integer"
- 		exprList add: varName , ' := ', self vmNameString, ' stackIntegerValue: ' , stackIndex printString
- 	].
  	stmtList := OrderedCollection new.
  	exprList do: [:e | stmtList addAll: (self statementsFor: e varName: varName)].
  	^ stmtList!

Item was changed:
  SharedPool subclass: #VMBasicConstants
  	instanceVariableNames: ''
+ 	classVariableNames: 'BaseHeaderSize BytecodeSetHasExtensions BytesPerOop BytesPerWord COGMTVM COGVM DisownVMLockOutFullGC DoAssertionChecks DoExpensiveAssertionChecks GCCheckPrimCall GCModeBecome GCModeFreeSpace GCModeFull GCModeImageSegment GCModeIncremental GCModeNewSpace HashMultiplyConstant HashMultiplyMask IMMUTABILITY LowcodeVM MULTIPLEBYTECODESETS NewspeakVM PharoVM PrimErrBadArgument PrimErrBadIndex PrimErrBadMethod PrimErrBadNumArgs PrimErrBadReceiver PrimErrCallbackError PrimErrGenericFailure PrimErrInappropriate PrimErrLimitExceeded PrimErrNamedInternal PrimErrNoCMemory PrimErrNoMemory PrimErrNoModification PrimErrNotFound PrimErrObjectIsPinned PrimErrObjectMayMove PrimErrObjectMoved PrimErrObjectNotPinned PrimErrUnsupported PrimErrWritePastObject PrimNoErr SPURVM STACKVM SistaVM VMBIGENDIAN'
- 	classVariableNames: 'BaseHeaderSize BytecodeSetHasExtensions BytesPerOop BytesPerWord COGMTVM COGVM DisownVMLockOutFullGC DoAssertionChecks DoExpensiveAssertionChecks GCCheckPrimCall GCModeBecome GCModeFreeSpace GCModeFull GCModeImageSegment GCModeIncremental GCModeNewSpace IMMUTABILITY LowcodeVM MULTIPLEBYTECODESETS NewspeakVM PharoVM PrimErrBadArgument PrimErrBadIndex PrimErrBadMethod PrimErrBadNumArgs PrimErrBadReceiver PrimErrCallbackError PrimErrGenericFailure PrimErrInappropriate PrimErrLimitExceeded PrimErrNamedInternal PrimErrNoCMemory PrimErrNoMemory PrimErrNoModification PrimErrNotFound PrimErrObjectIsPinned PrimErrObjectMayMove PrimErrObjectMoved PrimErrObjectNotPinned PrimErrUnsupported PrimErrWritePastObject PrimNoErr SPURVM STACKVM SistaVM VMBIGENDIAN'
  	poolDictionaries: ''
  	category: 'VMMaker-Interpreter'!
  
  !VMBasicConstants commentStamp: '<historical>' prior: 0!
  I am a shared pool for basic constants upon which the VM as a whole depends.
  
  self ensureClassPool.
  self classPool declare: #BytesPerWord from: VMSqueakV3ObjectRepresentationConstants classPool.
  self classPool declare: #BaseHeaderSize from: VMSqueakV3ObjectRepresentationConstants classPool
  (ObjectMemory classPool keys select: [:k| k beginsWith: 'Byte']) do:
  	[:k| self classPool declare: k from: ObjectMemory classPool]!

More information about the Vm-dev mailing list