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

commits at source.squeak.org commits at source.squeak.org
Fri Feb 13 19:23:15 UTC 2015


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

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

Name: VMMaker.oscog-eem.1061
Author: eem
Time: 13 February 2015, 11:21:50.348 am
UUID: bbb9d477-8fc5-4f93-a996-48a20fafeeff
Ancestors: VMMaker.oscog-eem.1060

Refactor positive32BitIntegerFor: and signed32BitIntegerFor:
in the realization that these reduce to essentially
integerObjectOf: in64-bit Spur.  The idea is to inline if in
64-bit Spur but not if in the 32-bit VMs.  Add notOption:
processing to allow excluding noInlineSigned32BitIntegerFor:
et al.  Add hasSixtyFourBitImmediates to no longer assume
that wordSize = 8 implies 64-bit immediates.

Use positiveMachineIntegerFor: in place of
positive32BitIntegerFor: in some plgins.

Simplify two B3DAcceleratorPlugin prims given
topRemappableOop and isArray:

Fix a simulation bug in shortAt:put:.

With these changes 64-bit Spur Stack Linux manages
3548 run, 3495 passes, 0 expected failures, 47 failures, 6 errors, 0 unexpected passes

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

Item was changed:
  ----- Method: B3DAcceleratorPlugin>>primitiveGetRendererColorMasks (in category 'primitives-renderer') -----
  primitiveGetRendererColorMasks
+ 	| handle masks array |
- 	| handle result masks array arrayOop |
  	<export: true>
+ 	<var: #masks declareC:'unsigned int masks[4]'>
- 	<var: #masks declareC:'int masks[4]'>
  	interpreterProxy methodArgumentCount = 2
  		ifFalse:[^interpreterProxy primitiveFail].
  	array := interpreterProxy stackObjectValue: 0.
  	handle := interpreterProxy stackIntegerValue: 1.
  	interpreterProxy failed ifTrue:[^nil].
+ 	((interpreterProxy isArray: array)
+ 	and: [(interpreterProxy slotSizeOf: array) = 4
+ 	and: [self cCode:'b3dxGetRendererColorMasks(handle, masks)' inSmalltalk:[false]]])
- 	(interpreterProxy fetchClassOf: array) = interpreterProxy classArray
  		ifFalse:[^interpreterProxy primitiveFail].
+ 	interpreterProxy pushRemappableOop: array.
+ 	0 to: 3 do: [:i|
+ 		interpreterProxy
+ 			storePointer: i
+ 			ofObject: interpreterProxy topRemappableOop
+ 			withValue: (interpreterProxy positive32BitIntegerFor: (masks at: i))].
+ 	interpreterProxy popRemappableOop.
+ 	^interpreterProxy pop: 2 "pop args return receiver"!
- 	(interpreterProxy slotSizeOf: array) = 4
- 		ifFalse:[^interpreterProxy primitiveFail].
- 	result := self cCode:'b3dxGetRendererColorMasks(handle, masks)' inSmalltalk:[false].
- 	result ifFalse:[^interpreterProxy primitiveFail].
- 	arrayOop := array.
- 	0 to: 3 do:[:i|
- 		interpreterProxy pushRemappableOop: arrayOop.
- 		result := interpreterProxy positive32BitIntegerFor: (masks at: i).
- 		arrayOop := interpreterProxy popRemappableOop.
- 		interpreterProxy storePointer: i ofObject: arrayOop withValue: result].
- 	^interpreterProxy pop: 2. "pop args return receiver"!

Item was changed:
  ----- Method: B3DAcceleratorPlugin>>primitiveTextureGetColorMasks (in category 'primitives-textures') -----
  primitiveTextureGetColorMasks
+ 	| handle masks array renderer |
- 	| handle result masks array renderer arrayOop |
  	<export: true>
+ 	<var: #masks declareC:'unsigned int masks[4]'>
- 	<var: #masks declareC:'int masks[4]'>
  	interpreterProxy methodArgumentCount = 3
  		ifFalse:[^interpreterProxy primitiveFail].
  	array := interpreterProxy stackObjectValue: 0.
  	handle := interpreterProxy stackIntegerValue: 1.
  	renderer := interpreterProxy stackIntegerValue: 2.
  	interpreterProxy failed ifTrue:[^nil].
+ 	((interpreterProxy isArray: array)
+ 	 and: [(interpreterProxy slotSizeOf: array) = 4
+ 	 and: [self cCode:'b3dxTextureColorMasks(renderer, handle, masks)' inSmalltalk:[false]]])
- 	(interpreterProxy fetchClassOf: array) = interpreterProxy classArray
  		ifFalse:[^interpreterProxy primitiveFail].
+ 	interpreterProxy pushRemappableOop: array.
+ 	0 to: 3 do: [:i|
+ 		interpreterProxy
+ 			storePointer: i
+ 			ofObject: interpreterProxy topRemappableOop
+ 			withValue: (interpreterProxy positive32BitIntegerFor: (masks at: i))].
+ 	interpreterProxy popRemappableOop.
+ 	^interpreterProxy pop: 3 "pop args return receiver"!
- 	(interpreterProxy slotSizeOf: array) = 4
- 		ifFalse:[^interpreterProxy primitiveFail].
- 	result := self cCode:'b3dxTextureColorMasks(renderer, handle, masks)' inSmalltalk:[false].
- 	result ifFalse:[^interpreterProxy primitiveFail].
- 	arrayOop := array.
- 	0 to: 3 do:[:i|
- 		interpreterProxy pushRemappableOop: arrayOop.
- 		result := interpreterProxy positive32BitIntegerFor: (masks at: i).
- 		arrayOop := interpreterProxy popRemappableOop.
- 		interpreterProxy storePointer: i ofObject: arrayOop withValue: result].
- 	^interpreterProxy pop: 3. "pop args return receiver"!

Item was added:
+ ----- Method: CCodeGenerator>>optionIsTrue:in: (in category 'utilities') -----
+ optionIsTrue: pragma in: aClass
+ 	"Answer whether an option: or notOption: pragma is true in the context of aClass.
+ 	 The argument to the option: pragma is interpreted as either a Cogit class name
+ 	 or a class variable name or a variable name in VMBasicConstants."
+ 	| key |
+ 	key := pragma argumentAt: 1.
+ 	"If the option is the name of a subclass of Cogit, include it if it inherits from the Cogit class."
+ 	(Smalltalk classNamed: key) ifNotNil:
+ 		[:optionClass|
+ 		 aClass cogitClass ifNotNil:
+ 			[:cogitClass|
+ 			 (optionClass includesBehavior: Cogit) ifTrue:
+ 				[^cogitClass includesBehavior: optionClass]].
+ 		 aClass objectMemoryClass ifNotNil:
+ 			[:objectMemoryClass|
+ 			 ((optionClass includesBehavior: ObjectMemory)
+ 			   or: [optionClass includesBehavior: SpurMemoryManager]) ifTrue:
+ 				[^objectMemoryClass includesBehavior: optionClass]]].
+ 	"Lookup options in options, class variables of the defining class, VMBasicConstants, the interpreterClass and the objectMemoryClass"
+ 	{aClass initializationOptions.
+ 	  aClass.
+ 	  VMBasicConstants.
+ 	  aClass interpreterClass.
+ 	  aClass objectMemoryClass} do:
+ 		[:scopeOrNil|
+ 		 scopeOrNil ifNotNil:
+ 			[:scope|
+ 			 (scope bindingOf: key) ifNotNil:
+ 				[:binding|
+ 				binding value ~~ false ifTrue: [^true]]]].
+ 	^false!

Item was changed:
  ----- Method: CCodeGenerator>>shouldIncludeMethodFor:selector: (in category 'utilities') -----
  shouldIncludeMethodFor: aClass selector: selector
  	"Answer whether a method shoud be translated.  Process optional methods by
  	 interpreting the argument to the option: pragma as either a Cogit class name
  	 or a class variable name or a variable name in VMBasicConstants.  Exclude
  	 methods with the doNotGenerate pragma."
+ 	| optionPragmas notOptionPragmas |
+ 	(aClass >> selector pragmaAt: #doNotGenerate) ifNotNil:
+ 		[^false].
+ 
- 	| pragmas |
  	"where is pragmasAt: ??"
+ 	optionPragmas := (aClass >> selector) pragmas select: [:p| p keyword == #option:].
+ 	notOptionPragmas := (aClass >> selector) pragmas select: [:p| p keyword == #notOption:].
+ 	(optionPragmas notEmpty or: [notOptionPragmas notEmpty]) ifTrue:
+ 		[^(optionPragmas allSatisfy: [:pragma| self optionIsTrue: pragma in: aClass])
+ 		   and: [notOptionPragmas noneSatisfy: [:pragma| self optionIsTrue: pragma in: aClass]]].
+ 
+ 	^true!
- 	(pragmas := (aClass >> selector) pragmas select: [:p| p keyword == #option:]) notEmpty ifTrue:
- 		[pragmas do:
- 			[:pragma| | key |
- 			 key := pragma argumentAt: 1.
- 			 "If the option is the name of a subclass of Cogit, include it if it inherits from the Cogit class."
- 			 (Smalltalk classNamed: key) ifNotNil:
- 				[:optionClass|
- 				 aClass cogitClass ifNotNil:
- 					[:cogitClass|
- 					 (optionClass includesBehavior: Cogit) ifTrue:
- 						[^cogitClass includesBehavior: optionClass]].
- 				 aClass objectMemoryClass ifNotNil:
- 					[:objectMemoryClass|
- 					 ((optionClass includesBehavior: ObjectMemory)
- 					   or: [optionClass includesBehavior: SpurMemoryManager]) ifTrue:
- 						[^objectMemoryClass includesBehavior: optionClass]]].
- 			 "Lookup options in options, class variables of the defining class, VMBasicConstants, the interpreterClass and the objectMemoryClass"
- 			 {aClass initializationOptions.
- 			   aClass.
- 			   VMBasicConstants.
- 			   aClass interpreterClass.
- 			   aClass objectMemoryClass} do:
- 				[:scopeOrNil|
- 				 scopeOrNil ifNotNil:
- 					[:scope|
- 					 (scope bindingOf: key) ifNotNil:
- 						[:binding|
- 						binding value ~~ false ifTrue: [^true]]]]].
- 		^false].
- 	^(aClass >> selector pragmaAt: #doNotGenerate) isNil!

Item was changed:
  ----- Method: InterpreterPrimitives>>primitiveSmallFloatDivide (in category 'arithmetic float primitives') -----
  primitiveSmallFloatDivide
  	<option: #Spur64BitMemoryManager>
  	| rcvr arg |
  	<var: #rcvr type: #double>
  	<var: #arg type: #double>
  
  	rcvr := objectMemory smallFloatValueOf: (self stackValue: 1).
  	arg := objectMemory loadFloatOrIntFrom: self stackTop.
+ 	arg = 0.0 ifTrue:
+ 		[self primitiveFail].
  	self successful ifTrue:
  		[self pop: 2 thenPushFloat: rcvr / arg]!

Item was changed:
  ----- Method: InterpreterPrimitives>>primitiveTimesTwoPower (in category 'arithmetic float primitives') -----
  primitiveTimesTwoPower
  	"Multiply the receiver by the power of the argument."
- 	<option: #Spur64BitMemoryManager>
  	| rcvr result arg |
  	<var: #rcvr type: #double>
  	<var: #result type: #double>
  	arg := self stackTop.
  	(objectMemory isIntegerObject: arg) ifFalse:
  		[^self primitiveFailFor: PrimErrBadArgument].
  	arg := objectMemory integerValueOf: arg.
  	objectMemory bytesPerOop > 4 ifTrue:
  		[| twiceMaxExponent | "clip arg to at most int range; ldexp's last arg is of type int"
  		 twiceMaxExponent := 2 * (1 << self floatExponentBits).
  	 	 arg < twiceMaxExponent negated
  			ifTrue: [arg := twiceMaxExponent negated]
  			ifFalse: [arg > twiceMaxExponent ifTrue:
  						[arg := twiceMaxExponent]]].
  	rcvr := objectMemory floatValueOf: (self stackValue: 1).
  	result := self cCode: [self ld: rcvr exp: (self cCoerceSimple: arg to: #int)]
  					inSmalltalk: [rcvr timesTwoPower: arg].
  	self pop: 2 thenPushFloat: result!

Item was added:
+ ----- Method: ObjectMemory>>hasSixtyFourBitImmediates (in category 'object format') -----
+ hasSixtyFourBitImmediates
+ 	"The V3 64-bit memory manager has 64-bit oops, but its SmallIntegers only have
+ 	 31 bits of precision.  The Spur 64-bit memory manager has 61-bit immediates."
+ 	^false!

Item was added:
+ ----- Method: Spur32BitMemoryManager>>hasSixtyFourBitImmediates (in category 'interpreter access') -----
+ hasSixtyFourBitImmediates
+ 	"The V3 64-bit memory manager has 64-bit oops, but its SmallIntegers only have
+ 	 31 bits of precision.  The Spur 64-bit memory manager has 61-bit immediates."
+ 	^false!

Item was changed:
  ----- Method: Spur64BitMMLESimulator>>shortAt:put: (in category 'memory access') -----
  shortAt: byteAddress put: a16BitValue
      "Return the half-word at byteAddress which must be even."
  	| lowBits long longAddress |
  	lowBits := byteAddress bitAnd: 2.
  	lowBits = 0
  		ifTrue: "storing into LS word"
  			[long := self long32At: byteAddress.
+ 			 self long32At: byteAddress
- 			 self longAt: byteAddress
  				put: ((long bitAnd: 16rFFFF0000) bitOr: a16BitValue)]
  		ifFalse: "storing into MS word"
  			[longAddress := byteAddress - 2.
  			long := self long32At: longAddress.
  			self long32At: longAddress
  				put: ((long bitAnd: 16rFFFF) bitOr: (a16BitValue bitShift: 16))].
  	^a16BitValue!

Item was added:
+ ----- Method: Spur64BitMemoryManager>>hasSixtyFourBitImmediates (in category 'interpreter access') -----
+ hasSixtyFourBitImmediates
+ 	"The V3 64-bit memory manager has 64-bit oops, but its SmallIntegers only have
+ 	 31 bits of precision.  The Spur 64-bit memory manager has 61-bit immediates."
+ 	^true!

Item was added:
+ ----- Method: SpurMemoryManager>>hasSixtyFourBitImmediates (in category 'interpreter access') -----
+ hasSixtyFourBitImmediates
+ 	"The V3 64-bit memory manager has 64-bit oops, but its SmallIntegers only have
+ 	 31 bits of precision.  The Spur 64-bit memory manager has 61-bit immediates."
+ 	^self subclassResponsibility!

Item was added:
+ ----- Method: StackInterpreter>>maybeInlinePositive32BitIntegerFor: (in category 'primitive support') -----
+ maybeInlinePositive32BitIntegerFor: integerValue
+ 	"N.B. will *not* cause a GC.
+ 	 integerValue is interpreted as POSITIVE, e.g. as the result of Bitmap>at:."
+ 	<notOption: #Spur64BitMemoryManager>
+ 	| newLargeInteger |
+ 	self deny: objectMemory hasSixtyFourBitImmediates.
+ 	(integerValue >= 0
+ 	 and: [objectMemory isIntegerValue: integerValue]) ifTrue:
+ 		[^objectMemory integerObjectOf: integerValue].
+ 	newLargeInteger := objectMemory
+ 							eeInstantiateSmallClassIndex: ClassLargePositiveIntegerCompactIndex
+ 							format: (objectMemory byteFormatForNumBytes: 4)
+ 							numSlots: 1.
+ 	objectMemory
+ 		storeByte: 3 ofObject: newLargeInteger withValue: (integerValue >> 24 bitAnd: 16rFF);
+ 		storeByte: 2 ofObject: newLargeInteger withValue: (integerValue >> 16 bitAnd: 16rFF);
+ 		storeByte: 1 ofObject: newLargeInteger withValue: (integerValue >>   8 bitAnd: 16rFF);
+ 		storeByte: 0 ofObject: newLargeInteger withValue: (integerValue ">> 0" bitAnd: 16rFF).
+ 	^newLargeInteger!

Item was added:
+ ----- Method: StackInterpreter>>noInlineSigned32BitIntegerFor: (in category 'primitive support') -----
+ noInlineSigned32BitIntegerFor: integerValue
+ 	"Answer a full 32 bit integer object for the given integer value."
+ 	<notOption: #Spur64BitMemoryManager>
+ 	| newLargeInteger value largeClass |
+ 	<inline: false>
+ 	(objectMemory isIntegerValue: integerValue) ifTrue:
+ 		[^objectMemory integerObjectOf: integerValue].
+ 	self deny: objectMemory hasSixtyFourBitImmediates.
+ 	 integerValue < 0
+ 		ifTrue: [largeClass := ClassLargeNegativeIntegerCompactIndex.
+ 				value := 0 - integerValue]
+ 		ifFalse: [largeClass := ClassLargePositiveIntegerCompactIndex.
+ 				value := integerValue].
+ 	newLargeInteger := objectMemory
+ 							eeInstantiateSmallClassIndex: largeClass
+ 							format: (objectMemory byteFormatForNumBytes: 4)
+ 							numSlots: 1.
+ 	objectMemory storeByte: 3 ofObject: newLargeInteger withValue: ((value >> 24) bitAnd: 16rFF).
+ 	objectMemory storeByte: 2 ofObject: newLargeInteger withValue: ((value >> 16) bitAnd: 16rFF).
+ 	objectMemory storeByte: 1 ofObject: newLargeInteger withValue: ((value >> 8) bitAnd: 16rFF).
+ 	objectMemory storeByte: 0 ofObject: newLargeInteger withValue: (value bitAnd: 16rFF).
+ 	^newLargeInteger!

Item was changed:
  ----- Method: StackInterpreter>>positive32BitIntegerFor: (in category 'primitive support') -----
  positive32BitIntegerFor: integerValue
+ 	"integerValue is interpreted as POSITIVE, e.g. as the result of Bitmap>at:.
+ 	 N.B.  Returning in each arm separately enables Slang inlining.
+ 	 /Don't/ return the ifTrue:ifFalse: unless Slang inlining of conditionals is fixed."
+ 	<inline: true>
+ 	objectMemory hasSixtyFourBitImmediates
+ 		ifTrue:
+ 			[^objectMemory integerObjectOf: (integerValue bitAnd: 16rFFFFFFFF)]
+ 		ifFalse:
+ 			[^self maybeInlinePositive32BitIntegerFor: integerValue]!
- 	| newLargeInteger |
- 	"N.B. will *not* cause a GC.
- 		integerValue is interpreted as POSITIVE, e.g. as the result of Bitmap>at:."
- 	(integerValue >= 0
- 	 and: [objectMemory isIntegerValue: integerValue]) ifTrue:
- 		[^objectMemory integerObjectOf: integerValue].
- 
- 	newLargeInteger := objectMemory
- 							eeInstantiateSmallClassIndex: ClassLargePositiveIntegerCompactIndex
- 							format: (objectMemory byteFormatForNumBytes: 4)
- 							numSlots: 1.
- 	objectMemory
- 		storeByte: 3 ofObject: newLargeInteger withValue: (integerValue >> 24 bitAnd: 16rFF);
- 		storeByte: 2 ofObject: newLargeInteger withValue: (integerValue >> 16 bitAnd: 16rFF);
- 		storeByte: 1 ofObject: newLargeInteger withValue: (integerValue >>   8 bitAnd: 16rFF);
- 		storeByte: 0 ofObject: newLargeInteger withValue: (integerValue ">> 0" bitAnd: 16rFF).
- 	^newLargeInteger!

Item was changed:
  ----- Method: StackInterpreter>>positive64BitIntegerFor: (in category 'primitive support') -----
  positive64BitIntegerFor: integerValue
  	<var: 'integerValue' type: #sqLong>
  	"Answer a Large Positive Integer object for the given integer value.  N.B. will *not* cause a GC."
  	| newLargeInteger highWord sz |
+ 	objectMemory hasSixtyFourBitImmediates
- 	objectMemory wordSize = 8
  		ifTrue:
  			[(integerValue >= 0 and: [objectMemory isIntegerValue: integerValue]) ifTrue:
  				[^objectMemory integerObjectOf: integerValue].
  			 sz := 8]
  		ifFalse:
  			[(highWord := integerValue >>> 32) = 0 ifTrue:
  				[^self positive32BitIntegerFor: integerValue].
  			 sz := 5.
  			 (highWord := highWord >> 8) = 0 ifFalse:
  				[sz := sz + 1.
  				 (highWord := highWord >> 8) = 0 ifFalse:
  					[sz := sz + 1.
  					 (highWord := highWord >> 8) = 0 ifFalse:[sz := sz + 1]]]].
  	newLargeInteger := objectMemory
  							eeInstantiateSmallClassIndex: ClassLargePositiveIntegerCompactIndex
  							format: (objectMemory byteFormatForNumBytes: sz)
  							numSlots: 8 / objectMemory bytesPerOop.
  	objectMemory
  		storeByte: 7 ofObject: newLargeInteger withValue: (integerValue >> 56 bitAnd: 16rFF);
  		storeByte: 6 ofObject: newLargeInteger withValue: (integerValue >> 48 bitAnd: 16rFF);
  		storeByte: 5 ofObject: newLargeInteger withValue: (integerValue >> 40 bitAnd: 16rFF);
  		storeByte: 4 ofObject: newLargeInteger withValue: (integerValue >> 32 bitAnd: 16rFF);
  		storeByte: 3 ofObject: newLargeInteger withValue: (integerValue >> 24 bitAnd: 16rFF);
  		storeByte: 2 ofObject: newLargeInteger withValue: (integerValue >> 16 bitAnd: 16rFF);
  		storeByte: 1 ofObject: newLargeInteger withValue: (integerValue >>   8 bitAnd: 16rFF);
  		storeByte: 0 ofObject: newLargeInteger withValue: (integerValue ">> 0" bitAnd: 16rFF).
  	^newLargeInteger
  !

Item was added:
+ ----- Method: StackInterpreter>>positiveMachineIntegerFor: (in category 'callback support') -----
+ positiveMachineIntegerFor: value
+ 	<var: #value type: #'unsigned long'>
+ 	<inline: true>
+ 	^objectMemory wordSize = 8
+ 		ifTrue: [self positive64BitIntegerFor: value]
+ 		ifFalse: [self positive32BitIntegerFor: value]!

Item was changed:
  ----- Method: StackInterpreter>>sendInvokeCallback:Stack:Registers:Jmpbuf: (in category 'callback support') -----
  sendInvokeCallback: thunkPtr Stack: stackPtr Registers: regsPtr Jmpbuf: jmpBufPtr
  	"Send the 4 argument callback message invokeCallback:stack:registers:jmpbuf:
  	 to Alien class with the supplied args.  The arguments are raw C addresses
  	 and are converted to integer objects on the way."
  	<export: true>
  	| classTag |
  	classTag := self fetchClassTagOfNonImm: (self splObj: ClassAlien).
  	messageSelector := self splObj: SelectorInvokeCallback.
  	argumentCount := 4.
  	(self lookupInMethodCacheSel: messageSelector classTag: classTag) ifFalse:
  	 	[(self lookupMethodNoMNUEtcInClass: (objectMemory classForClassTag: classTag)) ~= 0 ifTrue:
  			[^false]].
  	((self argumentCountOf: newMethod) = 4
  	and: [primitiveFunctionPointer = 0]) ifFalse:
  		[^false].
  	self push: (self splObj: ClassAlien). "receiver"
+ 	self push: (self positiveMachineIntegerFor: thunkPtr).
+ 	self push: (self positiveMachineIntegerFor: stackPtr).
+ 	self push: (self positiveMachineIntegerFor: regsPtr).
+ 	self push: (self positiveMachineIntegerFor: jmpBufPtr).
- 	self push: (self positive32BitIntegerFor: thunkPtr).
- 	self push: (self positive32BitIntegerFor: stackPtr).
- 	self push: (self positive32BitIntegerFor: regsPtr).
- 	self push: (self positive32BitIntegerFor: jmpBufPtr).
  	self ifAppropriateCompileToNativeCode: newMethod selector: messageSelector.
  	self justActivateNewMethod.
  	(self isMachineCodeFrame: framePointer) ifFalse:
  		[self maybeFlagMethodAsInterpreted: newMethod].
  	self externalWriteBackHeadFramePointers.
  	self handleStackOverflow.
  	self enterSmalltalkExecutiveFromCallback.
  	"not reached"
  	^true!

Item was changed:
  ----- Method: StackInterpreter>>sendInvokeCallbackContext: (in category 'callback support') -----
  sendInvokeCallbackContext: vmCallbackContext
  	"Send the calllback message to Alien class with the supplied arg(s).  Use either the
  	 1 arg invokeCallbackContext: or the 4 arg invokeCallback:stack:registers:jmpbuf:
  	 message, depending on what selector is installed in the specialObjectsArray.
  	 Note that if invoking the legacy invokeCallback:stack:registers:jmpbuf: we pass the
  	 vmCallbackContext as the jmpbuf argument (see reestablishContextPriorToCallback:).
  	 The arguments are raw C addresses and are converted to integer objects on the way."
  	<export: true>
  	<var: #vmCallbackContext type: #'VMCallbackContext *'>
  	| classTag |
  	classTag := self fetchClassTagOfNonImm: (self splObj: ClassAlien).
  	messageSelector := self splObj: SelectorInvokeCallback.
  	(self lookupInMethodCacheSel: messageSelector classTag: classTag) ifFalse:
  	 	[(self lookupMethodNoMNUEtcInClass: (objectMemory classForClassTag: classTag)) ~= 0 ifTrue:
  			[^false]].
  	primitiveFunctionPointer ~= 0 ifTrue:
  		[^false].
  	self saveCStackStateForCallbackContext: vmCallbackContext.
  	self push: (self splObj: ClassAlien). "receiver"
+ 	(self argumentCountOf: newMethod) = 4 ifTrue:
+ 		[self push: (self positiveMachineIntegerFor: vmCallbackContext thunkp asUnsignedInteger).
+ 		 self push: (self positiveMachineIntegerFor: vmCallbackContext stackp asUnsignedInteger).
+ 		 self push: (self positiveMachineIntegerFor: vmCallbackContext intregargsp asUnsignedInteger)].
+ 	self push: (self positiveMachineIntegerFor: vmCallbackContext asUnsignedInteger).
- 	self cppIf: objectMemory wordSize = 8
- 		ifTrue:
- 			[(self argumentCountOf: newMethod) = 4 ifTrue:
- 				[self push: (self positive64BitIntegerFor: vmCallbackContext thunkp asUnsignedInteger).
- 				 self push: (self positive64BitIntegerFor: vmCallbackContext stackp asUnsignedInteger).
- 				 self push: (self positive64BitIntegerFor: vmCallbackContext intregargsp asUnsignedInteger)].
- 			 self push: (self positive64BitIntegerFor: vmCallbackContext asUnsignedInteger)]
- 		ifFalse:
- 			[(self argumentCountOf: newMethod) = 4 ifTrue:
- 				[self push: (self positive32BitIntegerFor: vmCallbackContext thunkp asUnsignedInteger).
- 				 self push: (self positive32BitIntegerFor: vmCallbackContext stackp asUnsignedInteger).
- 				 self push: (self positive32BitIntegerFor: vmCallbackContext intregargsp asUnsignedInteger)].
- 			 self push: (self positive32BitIntegerFor: vmCallbackContext asUnsignedInteger)].
  	self ifAppropriateCompileToNativeCode: newMethod selector: messageSelector.
  	self justActivateNewMethod.
  	(self isMachineCodeFrame: framePointer) ifFalse:
  		[self maybeFlagMethodAsInterpreted: newMethod].
  	self externalWriteBackHeadFramePointers.
  	self handleStackOverflow.
  	self enterSmalltalkExecutiveFromCallback.
  	"not reached"
  	^true!

Item was changed:
  ----- Method: StackInterpreter>>signed32BitIntegerFor: (in category 'primitive support') -----
  signed32BitIntegerFor: integerValue
+ 	"Answer a full 32 bit integer object for the given integer value.
+ 	 N.B.  Returning in each arm separately enables Slang inlining.
+ 	 /Don't/ return the ifTrue:ifFalse: unless Slang inlining of conditionals is fixed."
+ 	<inline: true>
+ 	objectMemory hasSixtyFourBitImmediates
+ 		ifTrue:
+ 			[^objectMemory integerObjectOf: 
+ 				(self cCode: [self cCoerceSimple: integerValue to: #int]
+ 					inSmalltalk: [(integerValue bitAnd: 16r7FFFFFFF)
+ 								- ((integerValue >> 31 anyMask: 1)
+ 									ifTrue: [-16r100000000]
+ 									ifFalse: [0])])]
+ 		ifFalse:
+ 			[^self noInlineSigned32BitIntegerFor: integerValue]!
- 	"Answer a full 32 bit integer object for the given integer value."
- 	| newLargeInteger value largeClass |
- 	<inline: false>
- 	(objectMemory isIntegerValue: integerValue) ifTrue:
- 		[^objectMemory integerObjectOf: integerValue].
- 	 integerValue < 0
- 		ifTrue: [largeClass := ClassLargeNegativeIntegerCompactIndex.
- 				value := 0 - integerValue]
- 		ifFalse: [largeClass := ClassLargePositiveIntegerCompactIndex.
- 				value := integerValue].
- 	newLargeInteger := objectMemory
- 							eeInstantiateSmallClassIndex: largeClass
- 							format: (objectMemory byteFormatForNumBytes: 4)
- 							numSlots: 1.
- 	objectMemory storeByte: 3 ofObject: newLargeInteger withValue: ((value >> 24) bitAnd: 16rFF).
- 	objectMemory storeByte: 2 ofObject: newLargeInteger withValue: ((value >> 16) bitAnd: 16rFF).
- 	objectMemory storeByte: 1 ofObject: newLargeInteger withValue: ((value >> 8) bitAnd: 16rFF).
- 	objectMemory storeByte: 0 ofObject: newLargeInteger withValue: (value bitAnd: 16rFF).
- 	^newLargeInteger!

Item was changed:
  ----- Method: StackInterpreterPrimitives>>primitiveSlotAt (in category 'object access primitives') -----
  primitiveSlotAt
  	"Answer a slot in an object.  This numbers all slots from 1, ignoring the distinction between
  	 named and indexed inst vars.  In objects with both named and indexed inst vars, the named
  	 inst vars preceed the indexed ones.  In non-object indexed objects (objects that contain
  	 bits, not object references) this primitive answers the raw integral value at each slot. 
  	 e.g. for Strings it answers the character code, not the Character object at each slot."
  	| index rcvr fmt numSlots |
  	index := self stackTop.
  	rcvr := self stackValue: 1.
  	(objectMemory isIntegerObject: index) ifFalse:
  		[^self primitiveFailFor: PrimErrBadArgument].
  	(objectMemory isImmediate: rcvr) ifTrue:
  		[^self primitiveFailFor: PrimErrBadReceiver].
  	fmt := objectMemory formatOf: rcvr.
  	index := (objectMemory integerValueOf: index) - 1.
  
  	fmt <= objectMemory lastPointerFormat ifTrue:
  		[numSlots := objectMemory numSlotsOf: rcvr.
  		 (self asUnsigned: index) < numSlots ifTrue:
  			[| value numLiveSlots |
  			 (objectMemory isContextNonImm: rcvr)
  				ifTrue:
  					[self externalWriteBackHeadFramePointers.
  					 numLiveSlots := (self stackPointerForMaybeMarriedContext: rcvr) + CtxtTempFrameStart.
  					 value := (self asUnsigned: index) < numLiveSlots
  								ifTrue: [self externalInstVar: index ofContext: rcvr]
  								ifFalse: [objectMemory nilObject]]
  				ifFalse:
  					[value := objectMemory fetchPointer: index ofObject: rcvr].
  			 self pop: argumentCount + 1 thenPush: value.
  			 ^0].
  		 ^self primitiveFailFor: PrimErrBadIndex].
  
  	fmt >= objectMemory firstByteFormat ifTrue:
  		[fmt >= objectMemory firstCompiledMethodFormat ifTrue:
  			[^self primitiveFailFor: PrimErrUnsupported].
  		 numSlots := objectMemory numBytesOf: rcvr.
  		 (self asUnsigned: index) < numSlots ifTrue:
  			[self pop: argumentCount + 1 thenPushInteger: (objectMemory fetchByte: index ofObject: rcvr).
  			 ^0].
  		 ^self primitiveFailFor: PrimErrBadIndex].
  
  	(objectMemory hasSpurMemoryManagerAPI
  	 and: [fmt >= objectMemory firstShortFormat]) ifTrue:
  		[numSlots := objectMemory num16BitUnitsOf: rcvr.
  		 (self asUnsigned: index) < numSlots ifTrue:
  			[self pop: argumentCount + 1 thenPushInteger: (objectMemory fetchShort16: index ofObject: rcvr).
  			 ^0].
  		 ^self primitiveFailFor: PrimErrBadIndex].
  
  	fmt = objectMemory sixtyFourBitIndexableFormat ifTrue:
  		[numSlots := objectMemory num64BitUnitsOf: rcvr.
  		 (self asUnsigned: index) < numSlots ifTrue:
  			[self pop: argumentCount + 1
  				thenPush: (self positive64BitIntegerFor: (objectMemory fetchLong64: index ofObject: rcvr)).
  			 ^0].
  		 ^self primitiveFailFor: PrimErrBadIndex].
  
  	fmt >= objectMemory firstLongFormat ifTrue:
  		[numSlots := objectMemory num32BitUnitsOf: rcvr.
  		 (self asUnsigned: index) < numSlots ifTrue:
  			[self pop: argumentCount + 1
+ 				thenPush: (self positive32BitIntegerFor: (objectMemory fetchLong32: index ofObject: rcvr)).
- 				thenPush: (objectMemory bytesPerOop = 8
- 							ifTrue: [objectMemory integerObjectOf: (objectMemory fetchLong32: index ofObject: rcvr)]
- 							ifFalse: [self positive32BitIntegerFor: (objectMemory fetchLong32: index ofObject: rcvr)]).
  			 ^0].
  		 ^self primitiveFailFor: PrimErrBadIndex].
  
  	^self primitiveFailFor: PrimErrBadReceiver!

Item was changed:
  ----- Method: VMProfileLinuxSupportPlugin>>primitiveDLSymInLibrary (in category 'primitives') -----
  primitiveDLSymInLibrary
  	"Answer the address of the symbol whose name is the first argument
  	 in the library whose name is the second argument, or nil if none."
  	| nameObj symName libName lib sz addr ok |
  	<export: true>
  	<var: #symName type: #'char *'>
  	<var: #libName type: #'char *'>
  	<var: #lib type: #'void *'>
  	<var: #addr type: #'void *'>
  	nameObj := interpreterProxy stackValue: 0.
  	(interpreterProxy isBytes: nameObj) ifFalse:
  		[^interpreterProxy primitiveFailFor: PrimErrBadArgument].
  	sz := interpreterProxy byteSizeOf: nameObj.
  	libName := self malloc: sz+1.
  	self st: libName rn: (interpreterProxy firstIndexableField: nameObj) cpy: sz.
  	libName at: sz put: 0.
  	nameObj := interpreterProxy stackValue: 1.
  	(interpreterProxy isBytes: nameObj) ifFalse:
  		[self free: libName.
  		 ^interpreterProxy primitiveFailFor: PrimErrBadArgument].
  	sz := interpreterProxy byteSizeOf: nameObj.
  	symName := self malloc: sz+1.
  	self st: symName rn: (interpreterProxy firstIndexableField: nameObj) cpy: sz.
  	symName at: sz put: 0.
  	lib := self dl: libName open: (#'RTLD_LAZY' bitOr: #'RTLD_NODELETE').
  	lib ifNil:
  		[self free: libName; free: symName.
  		 ^interpreterProxy primitiveFailFor: PrimErrInappropriate].
  	self dlerror. "clear dlerror"
  	addr := self dl: lib sym: symName.
  	ok := self dlerror isNil.
  	self free: symName.
  	self free: libName.
  	self dlclose: lib.
  	ok ifFalse:
  		[^interpreterProxy primitiveFailFor: PrimErrNotFound].
+ 	^interpreterProxy methodReturnValue: (interpreterProxy positiveMachineIntegerFor: addr asUnsignedLong)!
- 	^interpreterProxy methodReturnValue: (interpreterProxy positive32BitIntegerFor: addr asUnsignedLong)!

Item was changed:
  ----- Method: VMProfileLinuxSupportPlugin>>primitiveInterpretAddress (in category 'primitives') -----
  primitiveInterpretAddress
  	"Answer the address of the interpret routine."
  	<export: true>
  	| interpret |
  	<var: #interpret declareC: 'extern void interpret()'>
+ 	^interpreterProxy methodReturnValue: (interpreterProxy positiveMachineIntegerFor: interpret asUnsignedLong)!
- 	self touch: interpret.
- 	^interpreterProxy methodReturnValue: (interpreterProxy positive32BitIntegerFor: interpret asUnsignedLong)!

Item was changed:
  ----- Method: VMProfileMacSupportPlugin>>primitiveDLSym (in category 'primitives') -----
  primitiveDLSym
  	"Answer the address of the argument in the current process or nil if none."
  	| nameObj name namePtr sz addr |
  	<export: true>
  	<var: #name type: #'char *'>
  	<var: #namePtr type: #'char *'>
  	<var: #addr type: #'void *'>
  	nameObj := interpreterProxy stackValue: 0.
  	(interpreterProxy isBytes: nameObj) ifFalse:
  		[^interpreterProxy primitiveFailFor: PrimErrBadArgument].
  	sz := interpreterProxy byteSizeOf: nameObj.
  	name := self malloc: sz+1.
  	namePtr := interpreterProxy firstIndexableField: nameObj.
  	0 to: sz-1 do:[:i| name at: i put: (namePtr at: i)].
  	name at: sz put: 0.
  	addr := self cCode: 'dlsym(RTLD_SELF,name)' inSmalltalk: [0].
  	self free: name.
  	^interpreterProxy methodReturnValue: (addr = 0
  												ifTrue: [interpreterProxy nilObject]
+ 												ifFalse: [interpreterProxy positiveMachineIntegerFor: addr asUnsignedLong])!
- 												ifFalse: [interpreterProxy positive32BitIntegerFor: addr asUnsignedLong])!

Item was changed:
  ----- Method: VMProfileMacSupportPlugin>>primitiveExecutableModulesAndOffsets (in category 'primitives') -----
  primitiveExecutableModulesAndOffsets
  	"Answer an Array of quads for executable modules (the VM executable
  	 and loaded libraries).  Each quad is the module's name, its vm address
  	 relocation in memory, the (unrelocated) start address, and the size."
  	| present nimages resultObj name valueObj nameObjData slide start size h s |
  	<export: true>
  	<var: #name type: 'const char *'>
  	<var: #nameObjData type: #'char *'>
  	<var: #h type: 'const struct mach_header *'>
  	<var: #s type: 'const struct section *'>
  	<var: #start type: 'unsigned long'>
  	<var: #size type: 'unsigned long'>
  	present := self cCode: '_dyld_present()' inSmalltalk: [false].
  	present ifFalse:
  		[^interpreterProxy primitiveFail].
  	nimages := self cCode: '_dyld_image_count()' inSmalltalk: [0].
  	resultObj := interpreterProxy instantiateClass: interpreterProxy classArray indexableSize: nimages * 4.
  	resultObj = 0 ifTrue:
  		[^interpreterProxy primitiveFail].
  
  	interpreterProxy pushRemappableOop: resultObj.
  	0 to: nimages - 1 do:
  		[:i|
  		start := size := -1. "impossible start & size"
  		name := self cCode: '_dyld_get_image_name(i)' inSmalltalk: [0].
  		slide   := self cCode: '_dyld_get_image_vmaddr_slide(i)' inSmalltalk: [0].
  		h        := self cCode: '_dyld_get_image_header(i)' inSmalltalk: [0].
  		h ~= nil ifTrue:
  			[s := self cCode: 'getsectbynamefromheader(h,SEG_TEXT,SECT_TEXT)' inSmalltalk: [0].
  			 s ~= nil ifTrue:
  				[start := self cCode: 's->addr' inSmalltalk: [0].
  				 size := self cCode: 's->size' inSmalltalk: [0]]].
  
  		valueObj := interpreterProxy
  						instantiateClass: interpreterProxy classString
  						indexableSize: (self strlen: name).
  		interpreterProxy failed ifTrue:
  			[interpreterProxy popRemappableOop.
  			 ^interpreterProxy primitiveFail].
  		interpreterProxy storePointer: i * 4 ofObject: interpreterProxy topRemappableOop withValue: valueObj.
  		nameObjData := interpreterProxy arrayValueOf: valueObj.
  		self mem: nameObjData cp: name y: (self strlen: name).
  
  		valueObj := interpreterProxy signed32BitIntegerFor: slide.
  		interpreterProxy failed ifTrue:
  			[interpreterProxy popRemappableOop.
  			 ^interpreterProxy primitiveFail].
  		interpreterProxy storePointer: i * 4 + 1 ofObject: interpreterProxy topRemappableOop withValue: valueObj.
  
+ 		valueObj := interpreterProxy positiveMachineIntegerFor: start.
- 		valueObj := interpreterProxy positive32BitIntegerFor: start.
  		interpreterProxy failed ifTrue:
  			[interpreterProxy popRemappableOop.
  			 ^interpreterProxy primitiveFail].
  		interpreterProxy storePointer: i * 4 + 2 ofObject: interpreterProxy topRemappableOop withValue: valueObj.
  
+ 		valueObj := interpreterProxy positiveMachineIntegerFor: size.
- 		valueObj := interpreterProxy positive32BitIntegerFor: size.
  		interpreterProxy failed ifTrue:
  			[interpreterProxy popRemappableOop.
  			 ^interpreterProxy primitiveFail].
  		interpreterProxy storePointer: i * 4 + 3 ofObject: interpreterProxy topRemappableOop withValue: valueObj].
  
  	resultObj := interpreterProxy popRemappableOop.
  	^interpreterProxy pop: 1 thenPush: resultObj!



More information about the Vm-dev mailing list