[Vm-dev] VM Maker: VMMaker.oscog-nice.1904.mcz

commits at source.squeak.org commits at source.squeak.org
Tue Jul 19 22:03:15 UTC 2016


Nicolas Cellier uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker.oscog-nice.1904.mcz

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

Name: VMMaker.oscog-nice.1904
Author: nice
Time: 19 July 2016, 11:57:01.639243 pm
UUID: ac13f54a-6f44-4700-8e32-6615076821b8
Ancestors: VMMaker.oscog-lpc.1903

Remove Undefined Behavior that prevents correct SmallFloat handling

The following symptoms were experienced with Squeak stack spur 64 bits VM and gcc 4.9.2 with -O2 optimization (mvm -f).

2.0 = 3.0 -> true.
2.0 * 3.0 -> 4.0.

For solving that it's necessary to remove undefined behavior related to left shifting a signed integer.

Instead of generating something like:
    ((sqLong) rcvr) << arg
It's better to generate it like this:
    (sqLong)(((usqLong) rcvr) ) << arg)

This way we preserve signedness and Behavior is well defined.
Since the formulation is rather heavy, I've also added tricks to avoid some casts if variable is long enough and unsigned already. If we later switch longAt and some others as unsigned as already dicussed here, the generated C might almost be readable.

I've also replaced pointer aliasing used to get/set SmallFloat value, like:
    doubleResult = (double *)( & rawBitsInteger )[0];
by memcpy:
    memcpy( &doubleResult  , &rawBitsInteger , sizeof(doubleResult) );

Why is memcpy less evil than pointer aliasing?
With pointer aliasing any other write into a long integer could modify doubleResult.
This completely defeat optimization - the holy grail of C people, they can't bother that FORTRAN compilers are faster than theirs ;).
With this greatly biased wisdom, they declared this construct as undefined behavior, giving priority to optimization rather than backward compatibility or programmers' intentions...
memcpy is less evil because it's localized (one shot).
memcpy is heavily optimized (no function call generated, just about the same instructions as pointer aliasing), so there's no reason to not abide the standard.

=============== Diff against VMMaker.oscog-lpc.1903 ===============

Item was added:
+ ----- Method: CCodeGenerator>>cLiteralForUnsignedInteger:hex:longlong: (in category 'C code generator') -----
+ cLiteralForUnsignedInteger: anInteger hex: aBoolean longlong: llBoolean
+ 	"Answer the string for generating an unsigned literal integer.
+ 	Use hexadecimal notation as prescribed by aBoolean.
+ 	Force long long suffix (LL) if the integer does not fit on 32 bits, or if llBoolean is true."
+ 	
+ 	| printString |
+ 	printString := aBoolean
+ 		ifTrue: [anInteger positive
+ 			ifTrue: ['0x' , (anInteger printStringBase: 16)]
+ 			ifFalse: ['-0x' , (anInteger negated printStringBase: 16)]]
+ 		ifFalse: [anInteger printString].
+ 	^anInteger positive
+ 		ifTrue: [(llBoolean or: [anInteger > 16rFFFFFFFF "UINT_MAX"])
+ 			ifTrue: [printString , 'ULL']
+ 			ifFalse: [printString , 'U']]
+ 		ifFalse: [self error: 'please provide positive integer']!

Item was added:
+ ----- Method: CCodeGenerator>>cLiteralForUnsignedInteger:longlong: (in category 'C code generator') -----
+ cLiteralForUnsignedInteger: anInteger longlong: llBoolean
+ 	"Answer the string for generating an unsigned literal integer.
+ 	Eventually use hexadecimal.
+ 	Force long long suffix (LL) if the integer does not fit on 32 bits, or if llBoolean is true."
+ 	
+ 	| hex |
+ 	hex := (anInteger > 0
+ 				and: [(anInteger >> anInteger lowBit + 1) isPowerOfTwo
+ 				and: [(anInteger highBit = anInteger lowBit and: [anInteger > 65536])
+ 					  or: [anInteger highBit - anInteger lowBit >= 4]]]).
+ 	^self cLiteralForUnsignedInteger: anInteger hex: hex longlong: llBoolean!

Item was changed:
  ----- Method: CCodeGenerator>>generateShiftLeft:on:indent: (in category 'C translation') -----
  generateShiftLeft: msgNode on: aStream indent: level
+ 	"Generate a C bitShift.  If we can determine the result
+ 	 would overflow the word size, cast to a long integer."
+ 	| rcvr arg castToLong type mustCastBackToSign mustCastToUnsigned canSuffixTheConstant typeIsUnsigned |
- 	"Generate a C bitShift.  If we can determine the result would overflow the word size,
- 	 cast to a long long integer. If the receiver is an integer constant make sure its type
- 	 is long, since the default type of numeric constants is int, which plays havoc in 64-bits."
- 	| rcvr arg valueBeyondInt castToLong |
  	rcvr := msgNode receiver.
  	arg := msgNode args first.
+ 	castToLong := false.
+ 	rcvr constantNumbericValueOrNil ifNotNil:
+ 		[:rcvrVal |
+ 		 arg constantNumbericValueOrNil
+ 			ifNil: [castToLong := vmClass notNil and: [vmClass objectMemoryClass wordSize = 8]]
+ 			ifNotNil:
+ 				[:argVal |
+ 				| valueBeyondInt |
+ 				valueBeyondInt := 1 bitShift: 32. "The default type of const << N is int."
+ 				castToLong := rcvrVal < valueBeyondInt
+ 								  and: [(rcvrVal bitShift: argVal) >= valueBeyondInt]]].
+ 	canSuffixTheConstant := rcvr isConstant and: [rcvr name isEmpty and: [rcvr value >= 0]].
+ 	canSuffixTheConstant
- 	valueBeyondInt := 1 bitShift: 32. "The default type of const << N is int."
- 	castToLong := vmClass notNil and: [vmClass objectMemoryClass wordSize = 8].
- 	castToLong ifFalse:
- 		[rcvr constantNumbericValueOrNil ifNotNil:
- 			[:rcvrVal|
- 			 arg constantNumbericValueOrNil ifNotNil:
- 				[:argVal|
- 				 castToLong := rcvrVal < valueBeyondInt
- 								  and: [(rcvrVal bitShift: argVal) >= valueBeyondInt]]]].
- 	castToLong
  		ifTrue:
+ 			[aStream nextPutAll: (self cLiteralForUnsignedInteger: rcvr value longlong: castToLong).
+ 			aStream nextPutAll: ' << '.
+ 			self emitCExpression: arg on: aStream indent: level.
+ 			^self].
+ 	type := self typeFor: rcvr in: currentMethod.
+ 	castToLong := castToLong and: [(self sizeOfIntegralCType: type) < (self sizeOfIntegralCType: #usqLong)].
+ 	typeIsUnsigned := type first = $u.
+ 	mustCastToUnsigned := typeIsUnsigned not
+ 		or: [castToLong
+ 		or: [(self sizeOfIntegralCType: type) < (self sizeOfIntegralCType: #usqInt)]].
+ 	mustCastBackToSign := typeIsUnsigned not.
+ 	mustCastBackToSign
+ 		ifTrue:
+ 			[| promotedType |
+ 			promotedType := castToLong
+ 				ifTrue: [#sqLong]
+ 				ifFalse: [(self sizeOfIntegralCType: type) < (self sizeOfIntegralCType: #sqInt)
+ 					ifTrue: [#sqInt]
+ 					ifFalse: [type]].
+ 			aStream nextPutAll: '(('; nextPutAll: promotedType; nextPut: $)].
+ 	mustCastToUnsigned
+ 		ifTrue:
+ 			[| unsigned |
+ 			unsigned := castToLong
+ 				ifTrue: [#usqLong]
+ 				ifFalse: [(self sizeOfIntegralCType: type) < (self sizeOfIntegralCType: #usqLong)
+ 					ifTrue: [#usqInt]
+ 					ifFalse: [self unsignedTypeForIntegralType: type]].
+ 			aStream nextPutAll: '(('; nextPutAll: unsigned; nextPutAll: ')('].
+ 	self emitCExpression: rcvr on: aStream indent: level.
+ 	mustCastToUnsigned ifTrue: [aStream nextPut: $)].
+ 		aStream nextPutAll: ' << '.
+ 		self emitCExpression: arg on: aStream indent: level.
+ 	mustCastToUnsigned ifTrue: [aStream nextPut: $)].
+ 	mustCastBackToSign ifTrue: [aStream nextPut: $)].!
- 			[(rcvr isConstant and: [rcvr name isEmpty])
- 				ifTrue:
- 					[self emitCExpression: rcvr on: aStream.
- 					 aStream nextPutAll: 'LL']
- 				ifFalse:
- 					[aStream nextPutAll: '((long)'.
- 					 self emitCExpression: rcvr on: aStream.
- 					 aStream nextPut: $)]]
- 		ifFalse:
- 			[self emitCExpression: rcvr on: aStream.
- 			 (rcvr isConstant and: [rcvr name isEmpty]) ifTrue:
- 				[aStream nextPut: $L]].
- 	aStream nextPutAll: ' << '.
- 	self emitCExpression: arg on: aStream!

Item was changed:
  ----- Method: Spur64BitMemoryManager>>isSmallFloatValue: (in category 'interpreter access') -----
  isSmallFloatValue: aFloat
  	<inline: true>
+ 	<var: #rawFloat type: #usqLong>
  	<var: #aFloat type: #double>
  	| exponent rawFloat |
+ 	self
+ 		cCode: [self mem: (self addressOf: rawFloat) cp: (self addressOf: aFloat) y: (self sizeof: rawFloat)]
+ 		inSmalltalk: [rawFloat := (aFloat at: 1) << 32 + (aFloat at: 2)].
- 	rawFloat := self
- 					cCode: [(self cCoerce: (self addressOf: aFloat) to: 'sqLong *') at: 0]
- 					inSmalltalk: [(aFloat at: 1) << 32 + (aFloat at: 2)].
  	exponent := rawFloat >> self smallFloatMantissaBits bitAnd: 16r7FF.
  	^exponent > self smallFloatExponentOffset
  	 	ifTrue: [exponent <= (255 + self smallFloatExponentOffset)]
  		ifFalse:
  			[(rawFloat bitAnd: (1 << self smallFloatMantissaBits - 1)) = 0
  				ifTrue: [exponent = 0]
  				ifFalse: [exponent = self smallFloatExponentOffset]]!

Item was changed:
  ----- Method: Spur64BitMemoryManager>>smallFloatBitsOf: (in category 'interpreter access') -----
  smallFloatBitsOf: oop
  	"Answer the ieee 754 double precision floating point bits of the argument, a SmallFloat.
  	 See section 61-bit Immediate Floats in the SpurMemoryManager class comment.
  							msb                                              lsb 
  	 Decode:				[8expsubset][52mantissa][1s][3tags] 
  	 shift away tags:		[ 000 ][8expsubset][52mantissa][1s] 
  	 add exponent offset:	[     11 exponent     ][52mantissa][1s] 
  	 rot sign:				[1s][     11 exponent     ][52mantissa]"
  	| rot |
+ 	<returnTypeC: #usqLong>
+ 	<var: #rot type: #usqLong>
  	self assert: (self isImmediateFloat: oop).
  	rot := oop asUnsignedInteger >> self numTagBits.
  	rot > 1 ifTrue: "a.k.a. ~= +/-0.0"
  		[rot := rot + (self smallFloatExponentOffset << (self smallFloatMantissaBits + 1))].
  	rot := self rotateRight: rot.
  	^rot!

Item was changed:
  ----- Method: Spur64BitMemoryManager>>smallFloatObjectOf: (in category 'interpreter access') -----
  smallFloatObjectOf: aFloat
  	"Encode the argument, aFloat in the SmallFloat range, as a tagged small float.
  	 See section 61-bit Immediate Floats in the SpurMemoryManager class comment.
  
  	 Encode:				[1s][     11 exponent     ][52mantissa] 
  	 rot sign:				[     11 exponent     ][52mantissa][1s] 
  	 sub exponent offset:	[ 000 ][8expsubset][52 mantissa][1s] 
  	 shift:					[8expsubset][52 mantissa][1s][ 000 ] 
  	 or/add tags:			[8expsubset][52mantissa][1s][3tags]"
  	<inline: true>
  	<var: #aFloat type: #double>
  	| rawFloat rot |
+ 	<var: #rawFloat type: #usqLong>
+ 	<var: #rot type: #usqLong>
- 	<var: #rot type: #'unsigned long'>
  	self assert: (self isSmallFloatValue: aFloat).
+ 	self
+ 		cCode: [self mem: (self addressOf: rawFloat) cp: (self addressOf: aFloat) y: (self sizeof: rawFloat)]
+ 		inSmalltalk: [rawFloat := (aFloat at: 1) << 32 + (aFloat at: 2)].
- 	rawFloat := self cCode: [(self cCoerce: (self addressOf: aFloat) to: 'sqLong *') at: 0]
- 					inSmalltalk: [(aFloat at: 1) << 32 + (aFloat at: 2)].
  	rot := self rotateLeft: rawFloat.
  	rot > 1 ifTrue: "a.k.a. ~= +/-0.0"
  		[rot := rot - (self smallFloatExponentOffset << (self smallFloatMantissaBits + 1)).
  		 self assert: rot > 0].
  	^self cCode: [rot << self numTagBits + self smallFloatTag]
  		inSmalltalk: [((rot << self numTagBits) bitAnd: 16rFFFFFFFFFFFFFFFF) + self smallFloatTag]!

Item was changed:
  ----- Method: Spur64BitMemoryManager>>smallFloatValueOf: (in category 'interpreter access') -----
  smallFloatValueOf: oop
  	"Answer the C double precision floating point value of the argument, a SmallFloat.
  	 See section 61-bit Immediate Floats in the SpurMemoryManager class comment.
  							msb                                              lsb 
  	 Decode:				[8expsubset][52mantissa][1s][3tags] 
  	 shift away tags:		[ 000 ][8expsubset][52mantissa][1s] 
  	 add exponent offset:	[     11 exponent     ][52mantissa][1s] 
  	 rot sign:				[1s][     11 exponent     ][52mantissa]"
+ 	| bits value |
- 	| bits |
  	<returnTypeC: #double>
+ 	<var: #value type: #double>
+ 	<var: #bits type: #usqLong>
  	bits := self smallFloatBitsOf: oop.
+ 	self cCode:
+ 			[self mem: (self addressOf: value) cp: (self addressOf: bits) y: (self sizeof: value).
+ 			^value]
- 	^self cCode: [(self cCoerce: (self addressOf: bits) to: #'double *') at: 0]
  		inSmalltalk:
+ 			[^(Float new: 2)
- 			[(Float new: 2)
  				at: 1 put: bits >> 32;
  				at: 2 put: (bits bitAnd: 16rFFFFFFFF);
  				* 1.0 "reduce to SmallFloat64 if possible"]!



More information about the Vm-dev mailing list