[Vm-dev] VM Maker: VMMaker.oscogLLP64-nice.1932.mcz
commits at source.squeak.org
commits at source.squeak.org
Tue Aug 23 16:35:54 UTC 2016
Nicolas Cellier uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker.oscogLLP64-nice.1932.mcz
==================== Summary ====================
Name: VMMaker.oscogLLP64-nice.1932
Author: nice
Time: 18 August 2016, 10:53:27.516376 pm
UUID: 642ecc37-5300-3643-8d95-5acb4704c924
Ancestors: VMMaker.oscogLLP64-nice.1931
Fix generation of signed32BitIntegerFor: for 64 bits VM.
Not only constants must be extended to usqInt, but any expression whose type is shorter.
Also, use unsigned usqInt, rather than signed sqInt, because it's well defined behavior.
=============== Diff against VMMaker.oscog-cb.1919 ===============
Item was changed:
----- Method: BitBltSimulation>>rgbComponentAlpha32 (in category 'combination rules') -----
rgbComponentAlpha32
"This version assumes
combinationRule = 41
sourcePixSize = destPixSize = 32
sourceForm ~= destForm.
Note: The inner loop has been optimized for dealing
with the special case of aR = aG = aB = 0
"
| srcIndex dstIndex sourceWord srcAlpha destWord deltaX deltaY srcY dstY |
<inline: false> "This particular method should be optimized in itself"
"Give the compile a couple of hints"
+ <var: #deltaX type: 'register sqInt'>
- <var: #deltaX type: 'register long'>
<var: #sourceWord type: #'unsigned int'>
<var: #destWord type: #'unsigned int'>
"The following should be declared as pointers so the compiler will
notice that they're used for accessing memory locations
(good to know on an Intel architecture) but then the increments
would be different between ST code and C code so must hope the
compiler notices what happens (MS Visual C does)"
+ <var: #srcIndex type: 'register sqIntptr_t'>
+ <var: #dstIndex type: 'register sqIntptr_t'>
- <var: #srcIndex type: 'register long'>
- <var: #dstIndex type: 'register long'>
deltaY := bbH + 1. "So we can pre-decrement"
srcY := sy.
dstY := dy.
"This is the outer loop"
[(deltaY := deltaY - 1) ~= 0] whileTrue:[
srcIndex := sourceBits + (srcY * sourcePitch) + (sx * 4).
dstIndex := destBits + (dstY * destPitch) + (dx * 4).
deltaX := bbW + 1. "So we can pre-decrement"
"This is the inner loop"
[(deltaX := deltaX - 1) ~= 0] whileTrue:[
sourceWord := self srcLongAt: srcIndex.
srcAlpha := sourceWord bitAnd:16rFFFFFF.
srcAlpha = 0 ifTrue:[
srcIndex := srcIndex + 4.
dstIndex := dstIndex + 4.
"Now skip as many words as possible,"
[(deltaX := deltaX - 1) ~= 0 and:[
((sourceWord := self srcLongAt: srcIndex) bitAnd:16rFFFFFF) = 0]]
whileTrue:[
srcIndex := srcIndex + 4.
dstIndex := dstIndex + 4.
].
"Adjust deltaX"
deltaX := deltaX + 1.
] ifFalse:[ "0 < srcAlpha"
"If we have to mix colors then just copy a single word"
destWord := self dstLongAt: dstIndex.
destWord := self rgbComponentAlpha32: sourceWord with: destWord.
self dstLongAt: dstIndex put: destWord.
srcIndex := srcIndex + 4.
dstIndex := dstIndex + 4.
].
].
srcY := srcY + 1.
dstY := dstY + 1.
].!
Item was added:
+ ----- Method: CCodeGenerator>>generateAsIntegerPtr:on:indent: (in category 'C translation') -----
+ generateAsIntegerPtr: msgNode on: aStream indent: level
+ "Generate the C code for this message onto the given stream."
+
+ aStream nextPutAll:'((sqIntptr_t)'.
+ self emitCExpression: msgNode receiver on: aStream.
+ aStream nextPut: $)!
Item was added:
+ ----- Method: CCodeGenerator>>generateAsUnsignedIntegerPtr:on:indent: (in category 'C translation') -----
+ generateAsUnsignedIntegerPtr: msgNode on: aStream indent: level
+ "Generate the C code for this message onto the given stream."
+
+ aStream nextPutAll:'((usqIntptr_t)'.
+ self emitCExpression: msgNode receiver on: aStream.
+ aStream nextPut: $)!
Item was changed:
----- Method: CCodeGenerator>>generateIntegerObjectOf:on:indent: (in category 'C translation') -----
generateIntegerObjectOf: msgNode on: aStream indent: level
"Generate the C code for this message onto the given stream."
+ | expr mustCastToUnsigned type typeIsUnsigned |
- | expr castToSqint |
expr := msgNode args first.
aStream nextPutAll: '(('.
"Note that the default type of an integer constant in C is int. Hence we /must/
+ cast expression to long if in the 64-bit world, since e.g. in 64-bits
- cast constants to long if in the 64-bit world, since e.g. in 64-bits
(int)(16r1FFFFF << 3) = (int)16rFFFFFFF8 = -8
whereas
(long)(16r1FFFFF << 3) = (long) 16rFFFFFFF8 = 4294967288."
+ type := self typeFor: expr in: currentMethod.
+ typeIsUnsigned := type first = $u.
+ mustCastToUnsigned := typeIsUnsigned not
+ or: [(self sizeOfIntegralCType: type) < (self sizeOfIntegralCType: #usqInt)].
+ mustCastToUnsigned ifTrue:
+ [aStream nextPutAll: '(usqInt)'].
- castToSqint := expr isConstant and: [vmClass isNil or: [vmClass objectMemoryClass wordSize = 8]].
- castToSqint ifTrue:
- [aStream nextPutAll: '(sqInt)'].
self emitCExpression: expr on: aStream.
aStream
nextPutAll: ' << ';
print: vmClass objectMemoryClass numSmallIntegerTagBits;
nextPutAll: ') | 1)'!
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 |
rcvr := msgNode receiver.
arg := msgNode args first.
castToLong := false.
rcvr constantNumbericValueOrNil ifNotNil:
[:rcvrVal |
arg constantNumbericValueOrNil
+ ifNil: [castToLong := self isForBoth32Or64Bits or: [vmClass notNil and: [vmClass objectMemoryClass wordSize = 8]]]
- 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
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: $)].!
Item was changed:
----- Method: CCodeGenerator>>generateShiftRight:on:indent: (in category 'C translation') -----
generateShiftRight: msgNode on: aStream indent: level
"Generate the C code for this message onto the given stream."
+ | type isUnsigned mustCastBackToSigned mustCastToUnsigned |
- | type |
"If the variable is a 64-bit type then don't cast it to usqInt (typically a 32-bit type)"
+ type := self typeFor: msgNode receiver in: currentMethod.
+ isUnsigned := type first = $u.
+ mustCastToUnsigned := isUnsigned not.
+ mustCastBackToSigned := false "isUnsigned not". "FOR COMPATIBILITY WITH OLDER BEHAVIOUR, THIS MUST BE SO..."
+
+ "If not unsigned, cast it to unsigned, and eventually cast the result back to original type."
+ mustCastBackToSigned ifTrue:
+ [aStream nextPut: $(; nextPut: $(; nextPutAll: type; nextPut: $)].
+ mustCastToUnsigned ifTrue:
+ [aStream nextPut: $(; nextPut: $(; nextPutAll: (self unsignedTypeForIntegralType: type); nextPut: $)].
+ self emitCExpression: msgNode receiver on: aStream indent: level.
+ mustCastToUnsigned ifTrue:
+ [aStream nextPut: $)].
- (self is64BitIntegralVariable: msgNode receiver typeInto: [:t| type := t])
- ifTrue:
- ["If not unsigned cast it to unsigned."
- type first ~= $u ifTrue:
- [aStream nextPutAll: '((unsigned '; nextPutAll: type; nextPut: $)].
- self emitCExpression: msgNode receiver on: aStream indent: level.
- type first ~= $u ifTrue:
- [aStream nextPut: $)]]
- ifFalse:
- [aStream nextPutAll: '((usqInt) '.
- self emitCExpression: msgNode receiver on: aStream indent: level.
- aStream nextPut: $)].
aStream nextPutAll: ' >> '.
+ self emitCExpression: msgNode args first on: aStream indent: level.
+ mustCastBackToSigned ifTrue:
+ [aStream nextPut: $)]!
- self emitCExpression: msgNode args first on: aStream indent: level!
Item was changed:
----- Method: CCodeGenerator>>initializeCTranslationDictionary (in category 'C translation support') -----
initializeCTranslationDictionary
"Initialize the dictionary mapping message names to actions for C code generation."
| pairs |
translationDict := Dictionary new: 200.
pairs := #(
#& #generateAnd:on:indent:
#| #generateOr:on:indent:
#abs #generateAbs:on:indent:
#and: #generateSequentialAnd:on:indent:
#or: #generateSequentialOr:on:indent:
#not #generateNot:on:indent:
#+ #generatePlus:on:indent:
#- #generateMinus:on:indent:
#negated #generateNegated:on:indent:
#* #generateTimes:on:indent:
#/ #generateDivide:on:indent:
#// #generateDivide:on:indent:
#\\ #generateModulo:on:indent:
#<< #generateShiftLeft:on:indent:
#>> #generateShiftRight:on:indent:
#>>> #generateSignedShiftRight:on:indent:
#min: #generateMin:on:indent:
#max: #generateMax:on:indent:
#between:and: #generateBetweenAnd:on:indent:
#bitAnd: #generateBitAnd:on:indent:
#bitOr: #generateBitOr:on:indent:
#bitXor: #generateBitXor:on:indent:
#bitShift: #generateBitShift:on:indent:
#signedBitShift: #generateSignedBitShift:on:indent:
#bitInvert32 #generateBitInvert:on:indent:
#bitInvert64 #generateBitInvert:on:indent:
#bitClear: #generateBitClear:on:indent:
#truncateTo: #generateTruncateTo:on:indent:
#rounded #generateRounded:on:indent:
#byteSwap32 #generateByteSwap32:on:indent:
#byteSwap64 #generateByteSwap64:on:indent:
#byteSwapped32IfBigEndian: generateByteSwap32IfBigEndian:on:indent:
#byteSwapped64IfBigEndian: generateByteSwap64IfBigEndian:on:indent:
#< #generateLessThan:on:indent:
#<= #generateLessThanOrEqual:on:indent:
#= #generateEqual:on:indent:
#> #generateGreaterThan:on:indent:
#>= #generateGreaterThanOrEqual:on:indent:
#~= #generateNotEqual:on:indent:
#== #generateEqual:on:indent:
#~~ #generateNotEqual:on:indent:
#isNil #generateIsNil:on:indent:
#notNil #generateNotNil:on:indent:
#whileTrue: #generateWhileTrue:on:indent:
#whileFalse: #generateWhileFalse:on:indent:
#whileTrue #generateDoWhileTrue:on:indent:
#whileFalse #generateDoWhileFalse:on:indent:
#to:do: #generateToDo:on:indent:
#to:by:do: #generateToByDo:on:indent:
#repeat #generateRepeat:on:indent:
#timesRepeat: #generateTimesRepeat:on:indent:
#ifTrue: #generateIfTrue:on:indent:
#ifFalse: #generateIfFalse:on:indent:
#ifTrue:ifFalse: #generateIfTrueIfFalse:on:indent:
#ifFalse:ifTrue: #generateIfFalseIfTrue:on:indent:
#ifNotNil: #generateIfNotNil:on:indent:
#ifNil: #generateIfNil:on:indent:
#ifNotNil:ifNil: #generateIfNotNilIfNil:on:indent:
#ifNil:ifNotNil: #generateIfNilIfNotNil:on:indent:
#at: #generateAt:on:indent:
#at:put: #generateAtPut:on:indent:
#basicAt: #generateAt:on:indent:
#basicAt:put: #generateAtPut:on:indent:
#integerValueOf: #generateIntegerValueOf:on:indent:
#integerObjectOf: #generateIntegerObjectOf:on:indent:
#isIntegerObject: #generateIsIntegerObject:on:indent:
#cCode: #generateInlineCCode:on:indent:
#cCode:inSmalltalk: #generateInlineCCode:on:indent:
#cPreprocessorDirective: #generateInlineCPreprocessorDirective:on:indent:
#cppIf:ifTrue:ifFalse: #generateInlineCppIfElse:on:indent:
#cppIf:ifTrue: #generateInlineCppIfElse:on:indent:
#cCoerce:to: #generateCCoercion:on:indent:
#cCoerceSimple:to: #generateCCoercion:on:indent:
#addressOf: #generateAddressOf:on:indent:
#addressOf:put: #generateAddressOf:on:indent:
#asAddress:put: #generateAsAddress:on:indent:
#signedIntFromLong64 #generateSignedIntFromLong64:on:indent:
#signedIntFromLong #generateSignedIntFromLong:on:indent:
#signedIntFromShort #generateSignedIntFromShort:on:indent:
#signedIntToLong64 #generateSignedIntToLong64:on:indent:
#signedIntToLong #generateSignedIntToLong:on:indent:
#signedIntToShort #generateSignedIntToShort:on:indent:
#preIncrement #generatePreIncrement:on:indent:
#preDecrement #generatePreDecrement:on:indent:
#inline: #generateInlineDirective:on:indent:
#asFloat #generateAsFloat:on:indent:
#asInteger #generateAsInteger:on:indent:
+ #asIntegerPtr #generateAsIntegerPtr:on:indent:
#asUnsignedInteger #generateAsUnsignedInteger:on:indent:
+ #asUnsignedIntegerPtr #generateAsUnsignedIntegerPtr:on:indent:
#asLong #generateAsLong:on:indent:
#asUnsignedLong #generateAsUnsignedLong:on:indent:
#asUnsignedLongLong #generateAsUnsignedLongLong:on:indent:
#asVoidPointer #generateAsVoidPointer:on:indent:
#asSymbol #generateAsSymbol:on:indent:
#flag: #generateFlag:on:indent:
#anyMask: #generateBitAnd:on:indent:
#allMask: #generateAllMask:on:indent:
#noMask: #generateNoMask:on:indent:
#raisedTo: #generateRaisedTo:on:indent:
#touch: #generateTouch:on:indent:
#bytesPerOop #generateBytesPerOop:on:indent:
#bytesPerWord #generateBytesPerWord:on:indent:
#wordSize #generateBytesPerWord:on:indent:
#baseHeaderSize #generateBaseHeaderSize:on:indent:
#minSmallInteger #generateSmallIntegerConstant:on:indent:
#maxSmallInteger #generateSmallIntegerConstant:on:indent:
#sharedCodeNamed:inCase: #generateSharedCodeDirective:on:indent:
#perform: #generatePerform:on:indent:
#perform:with: #generatePerform:on:indent:
#perform:with:with: #generatePerform:on:indent:
#perform:with:with:with: #generatePerform:on:indent:
#perform:with:with:with:with: #generatePerform:on:indent:
#perform:with:with:with:with:with: #generatePerform:on:indent:
#value #generateValue:on:indent:
#value: #generateValue:on:indent:
#value:value: #generateValue:on:indent:
#value:value:value: #generateValue:on:indent:
#value:value:value:value: #generateValue:on:indent:
#deny: #generateDeny:on:indent:
#shouldNotImplement #generateSmalltalkMetaError:on:indent:
#shouldBeImplemented #generateSmalltalkMetaError:on:indent:
#subclassResponsibility #generateSmalltalkMetaError:on:indent:
).
1 to: pairs size by: 2 do: [:i |
translationDict at: (pairs at: i) put: (pairs at: i + 1)].
pairs := #(
#ifTrue: #generateIfTrueAsArgument:on:indent:
#ifFalse: #generateIfFalseAsArgument:on:indent:
#ifTrue:ifFalse: #generateIfTrueIfFalseAsArgument:on:indent:
#ifFalse:ifTrue: #generateIfFalseIfTrueAsArgument:on:indent:
#ifNotNil: #generateIfNotNilAsArgument:on:indent:
#ifNil: #generateIfNilAsArgument:on:indent:
#ifNotNil:ifNil: #generateIfNotNilIfNilAsArgument:on:indent:
#ifNil:ifNotNil: #generateIfNilIfNotNilAsArgument:on:indent:
#cCode: #generateInlineCCodeAsArgument:on:indent:
#cCode:inSmalltalk: #generateInlineCCodeAsArgument:on:indent:
#cppIf:ifTrue:ifFalse: #generateInlineCppIfElseAsArgument:on:indent:
#cppIf:ifTrue: #generateInlineCppIfElseAsArgument:on:indent:
#value #generateValueAsArgument:on:indent:
#value: #generateValueAsArgument:on:indent:
#value:value: #generateValueAsArgument:on:indent:
).
asArgumentTranslationDict := Dictionary new: 8.
1 to: pairs size by: 2 do: [:i |
asArgumentTranslationDict at: (pairs at: i) put: (pairs at: i + 1)].
!
Item was changed:
+ ----- Method: CCodeGenerator>>isBuiltinSelector: (in category 'testing') -----
- ----- Method: CCodeGenerator>>isBuiltinSelector: (in category 'utilities') -----
isBuiltinSelector: sel
"Answer true if the given selector is one of the builtin selectors."
^(self isKernelSelector: sel) or: [translationDict includesKey: sel]!
Item was changed:
+ ----- Method: CCodeGenerator>>isConstantNode:valueInto: (in category 'testing') -----
- ----- Method: CCodeGenerator>>isConstantNode:valueInto: (in category 'utilities') -----
isConstantNode: aNode valueInto: aBlock
"Answer if aNode evaluates to a constant, and if so, evaluate aBlock with the value of that constant."
aNode isConstant ifTrue:
[(aNode isDefine
and: [(vmClass ifNil: [VMBasicConstants]) defineAtCompileTime: aNode name]) ifTrue:
[^false].
aBlock value: aNode value.
^true].
(aNode isVariable
and: [aNode name = #nil]) ifTrue:
[aBlock value: nil.
^true].
aNode isSend ifFalse:
[^false].
(self anyMethodNamed: aNode selector)
ifNil:
[(VMBasicConstants valueOfBasicSelector: aNode selector) ifNotNil:
[:value|
aBlock value: value.
^true]]
ifNotNil:
[:m|
(m statements size = 1
and: [m statements last isReturn]) ifTrue:
[^self isConstantNode: m statements last expression valueInto: aBlock]].
^false!
Item was added:
+ ----- Method: CCodeGenerator>>isForBoth32Or64Bits (in category 'testing') -----
+ isForBoth32Or64Bits
+ "Answer true if the code is generated for both 32 and 64 bits.
+ Answer false otherwise.
+ Currently, VM source is generated for specific WordSize.
+ But plugins source are generated in common directory for both."
+
+ ^self isGeneratingPluginCode!
Item was changed:
+ ----- Method: CCodeGenerator>>isGeneratingPluginCode (in category 'testing') -----
- ----- Method: CCodeGenerator>>isGeneratingPluginCode (in category 'utilities') -----
isGeneratingPluginCode
^false!
Item was changed:
----- Method: CCodeGenerator>>isIntegralCType: (in category 'inlining') -----
isIntegralCType: aCType "<String>"
+ ^(#('sqLong' 'usqLong' 'sqInt' 'usqInt' 'sqIntptr_t' 'usqIntptr_t'
- ^(#('sqLong' 'usqLong' 'sqInt' 'usqInt'
'long' 'int' 'short' 'char' 'signed char'
'size_t' 'pid_t') includes: aCType asString)
or: [(aCType beginsWith: 'unsigned') "Accept e.g. 'unsigned long' and also 'unsigned : 8'"
and: [(aCType includesAnyOf: '[*]') not]]!
Item was changed:
+ ----- Method: CCodeGenerator>>isKernelSelector: (in category 'testing') -----
- ----- Method: CCodeGenerator>>isKernelSelector: (in category 'utilities') -----
isKernelSelector: sel
"Answer true if the given selector is one of the kernel selectors that are implemented as macros."
^(#(error:
oopAt: oopAt:put: oopAtPointer: oopAtPointer:put:
byteAt: byteAt:put: byteAtPointer: byteAtPointer:put:
shortAt: shortAt:put: shortAtPointer: shortAtPointer:put:
intAt: intAt:put: intAtPointer: intAtPointer:put:
longAt: longAt:put: longAtPointer: longAtPointer:put:
long32At: long32At:put: long64At: long64At:put:
fetchFloatAt:into: storeFloatAt:from: fetchFloatAtPointer:into: storeFloatAtPointer:from:
fetchSingleFloatAt:into: storeSingleFloatAt:from: fetchSingleFloatAtPointer:into: storeSingleFloatAtPointer:from:
pointerForOop: oopForPointer:
cCoerce:to: cCoerceSimple:to:)
includes: sel)!
Item was changed:
+ ----- Method: CCodeGenerator>>isNilConstantReceiverOf: (in category 'testing') -----
- ----- Method: CCodeGenerator>>isNilConstantReceiverOf: (in category 'utilities') -----
isNilConstantReceiverOf: sendNode
"Answer true if the receiver of the given message send is the constant nil. Used to suppress conditional code when the condition is a translation-time constant."
| val |
generateDeadCode ifTrue: [^false].
^(self isConstantNode: sendNode receiver valueInto: [:v| val := v])
and: [val isNil]!
Item was changed:
----- Method: CCodeGenerator>>returnTypeForSend:in:ifNil: (in category 'type inference') -----
returnTypeForSend: sendNode in: aTMethod ifNil: typeIfNil
"Answer the return type for a send. Unbound sends default to typeIfNil.
Methods with types as yet unknown have a type determined either by the
kernelReturnTypes or the table below, or, if they are in neither set, then nil.
The inferred type should match as closely as possible the C type of
generated expessions so that inlining would not change the expression.
If there is a method for sel but its return type is as yet unknown it mustn't
be defaulted, since on a subsequent pass its type may be computable."
| sel methodOrNil |
methodOrNil := self anyMethodNamed: (sel := sendNode selector).
(methodOrNil notNil and: [methodOrNil returnType notNil]) ifTrue:
[^self baseTypeForType: methodOrNil returnType].
^kernelReturnTypes
at: sel
ifAbsent:
[sel
caseOf: {
[#integerValueOf:] -> [#sqInt].
[#isIntegerObject:] -> [#int].
[#negated] -> [self promoteArithmeticTypes: (self typeFor: sendNode receiver in: aTMethod) and: #int].
[#+] -> [self typeForArithmetic: sendNode in: aTMethod].
[#-] -> [self typeForArithmetic: sendNode in: aTMethod].
[#*] -> [self typeForArithmetic: sendNode in: aTMethod].
[#/] -> [self typeForArithmetic: sendNode in: aTMethod].
[#//] -> [self typeForArithmetic: sendNode in: aTMethod].
[#\\] -> [self typeForArithmetic: sendNode in: aTMethod].
[#rem:] -> [self typeForArithmetic: sendNode in: aTMethod].
[#quo:] -> [self typeForArithmetic: sendNode in: aTMethod].
"C99 Sec Bitwise shift operators ... 3 Sematics ...
The integer promotions are performed on each of the operands. The type of the result is that of the promoted left operand..."
[#>>] -> [self typeFor: sendNode receiver in: aTMethod].
[#<<] -> [self typeFor: sendNode receiver in: aTMethod].
[#addressOf:] -> [(self typeFor: sendNode receiver in: aTMethod)
ifNil: [#sqInt]
ifNotNil: [:type| type, (type last isLetter ifTrue: [' *'] ifFalse: ['*'])]].
[#at:] -> [self typeForDereference: sendNode in: aTMethod].
[#bitAnd:] -> [self typeForArithmetic: sendNode in: aTMethod].
[#bitOr:] -> [self typeForArithmetic: sendNode in: aTMethod].
[#bitXor:] -> [self typeForArithmetic: sendNode in: aTMethod].
[#bitClear:] -> [self typeForArithmetic: sendNode in: aTMethod].
[#bitInvert32] -> [#'unsigned int'].
[#bitInvert64] -> [self promoteArithmeticTypes: (self typeFor: sendNode receiver in: aTMethod) and: #int].
[#byteSwap32] -> [#'unsigned int'].
[#byteSwap64] -> [#'unsigned long long'].
[#byteSwapped32IfBigEndian:] -> [#'unsigned int'].
[#byteSwapped64IfBigEndian:] -> [#'unsigned long long'].
[#=] -> [#int].
[#~=] -> [#int].
[#==] -> [#int].
[#~~] -> [#int].
[#<] -> [#int].
[#<=] -> [#int].
[#>] -> [#int].
[#>=] -> [#int].
[#between:and:] -> [#int].
[#anyMask:] -> [#int].
[#allMask:] -> [#int].
[#noMask:] -> [#int].
[#isNil] -> [#int].
[#notNil] -> [#int].
[#&] -> [#int].
[#|] -> [#int].
[#not] -> [#int].
[#asFloat] -> [#double].
[#atan] -> [#double].
[#exp] -> [#double].
[#log] -> [#double].
[#sin] -> [#double].
[#sqrt] -> [#double].
[#asLong] -> [#long].
[#asInteger] -> [#sqInt].
+ [#asIntegerPtr] -> [#'sqIntptr_t'].
[#asUnsignedInteger] -> [#usqInt].
+ [#asUnsignedIntegerPtr]-> [#'usqIntptr_t'].
[#asUnsignedLong] -> [#'unsigned long'].
[#asVoidPointer] -> [#'void *'].
[#signedIntToLong] -> [#usqInt]. "c.f. generateSignedIntToLong:on:indent:"
[#signedIntToShort] -> [#usqInt]. "c.f. generateSignedIntToShort:on:indent:"
[#cCoerce:to:] -> [sendNode args last value].
[#cCoerceSimple:to:] -> [sendNode args last value].
+ [#sizeof:] -> [#'usqIntptr_t']. "Technically it's a size_t but it matches on target architectures so far..."
- [#sizeof:] -> [#'unsigned long']. "Technically it's a size_t but it matches unsigned long on target architectures so far..."
[#ifTrue:ifFalse:] -> [self typeForConditional: sendNode in: aTMethod].
[#ifFalse:ifTrue:] -> [self typeForConditional: sendNode in: aTMethod].
[#ifTrue:] -> [self typeForConditional: sendNode in: aTMethod].
[#ifFalse:] -> [self typeForConditional: sendNode in: aTMethod].
[#and:] -> [#sqInt].
[#or:] -> [#sqInt] }
otherwise: "If there /is/ a method for sel but its return type is as yet unknown it /mustn't/ be defaulted,
since on a subsequent pass its type may be computable. Only default unbound selectors."
[methodOrNil ifNotNil: [nil] ifNil: [typeIfNil]]]!
Item was changed:
----- Method: CCodeGenerator>>signedTypeForIntegralType: (in category 'type inference') -----
signedTypeForIntegralType: aCTypeString
(aCTypeString beginsWith: 'unsigned ') ifTrue:
[^aCTypeString allButFirst: 8].
(aCTypeString beginsWith: 'usq') ifTrue:
[^aCTypeString allButFirst].
+ aCTypeString = 'size_t' ifTrue: [^#usqIntptr_t].
+
self error: 'unknown type'.
^#long!
Item was changed:
----- Method: CCodeGenerator>>sizeOfIntegralCType: (in category 'inlining') -----
sizeOfIntegralCType: anIntegralCType "<String>"
"N.B. Only works for values for which isIntegralCType: answers true."
| prunedCType index |
(anIntegralCType beginsWith: 'register ') ifTrue:
[^self sizeOfIntegralCType: (anIntegralCType allButFirst: 9)].
prunedCType := (anIntegralCType beginsWith: 'unsigned ')
ifTrue: [(anIntegralCType allButFirst: 9) withBlanksTrimmed]
ifFalse: [(anIntegralCType beginsWith: 'signed ')
ifTrue: [(anIntegralCType allButFirst: 7) withBlanksTrimmed]
ifFalse: [anIntegralCType]].
+
^prunedCType asString caseOf: {
['sqLong'] -> [8].
['usqLong'] -> [8].
['long long'] -> [8].
+ ['sqInt'] -> [BytesPerOop].
+ ['usqInt'] -> [BytesPerOop].
+ ['sqIntptr_t'] -> [BytesPerWord].
+ ['usqIntptr_t'] -> [BytesPerWord].
- ['sqInt'] -> [BytesPerWord].
- ['usqInt'] -> [BytesPerWord].
['int'] -> [4].
['short'] -> [2].
['short int'] -> [2].
['char'] -> [1].
+ ['size_t'] -> [BytesPerWord].
- ['long'] -> [BytesPerWord].
- ['size_t'] -> [BytesPerWord].
['pid_t'] -> [BytesPerWord].
}
otherwise:
+ [prunedCType = #long ifTrue: [self error: 'long is ambiguous on 64bits architecture, don''t use it'. ^BytesPerWord].
+ ((anIntegralCType beginsWith: 'unsigned') "e.g. 'unsigned : 8'"
- [((anIntegralCType beginsWith: 'unsigned') "e.g. 'unsigned : 8'"
and: [(anIntegralCType includesAnyOf: '[*]') not
and: [(index := anIntegralCType indexOf: $:) > 0]])
ifTrue: [(Integer readFrom: (anIntegralCType copyFrom: index + 1 to: anIntegralCType size) withBlanksTrimmed readStream) + 7 // 8]
ifFalse: [self error: 'unrecognized integral type']]!
Item was changed:
----- Method: ClipboardExtendedPlugin>>ioAddClipboardData:data:dataFormat: (in category 'io') -----
ioAddClipboardData: clipboard data: data dataFormat: aFormat
| clipboardAddress formatLength dataLength |
+ <var: #clipboardAddress type: #'usqIntptr_t'>
- <var: #clipboardAddress type: #'unsigned long'>
self primitive: 'ioAddClipboardData' parameters: #(Oop ByteArray String).
clipboardAddress := interpreterProxy positiveMachineIntegerValueOf: clipboard.
dataLength := interpreterProxy slotSizeOf: data cPtrAsOop.
formatLength := interpreterProxy slotSizeOf: aFormat cPtrAsOop.
self sqPasteboardPutItemFlavor: clipboardAddress data: data length: dataLength formatType: aFormat formatLength: formatLength.
!
Item was changed:
----- Method: ClipboardExtendedPlugin>>ioClearClipboard: (in category 'io') -----
ioClearClipboard: clipboard
| clipboardAddress |
+ <var: #clipboardAddress type: #'usqIntptr_t'>
- <var: #clipboardAddress type: #'unsigned long'>
self primitive: 'ioClearClipboard' parameters: #(Oop).
clipboardAddress := interpreterProxy positiveMachineIntegerValueOf: clipboard.
self sqPasteboardClear: clipboardAddress.!
Item was changed:
----- Method: ClipboardExtendedPlugin>>ioGetClipboardFormat:formatNumber: (in category 'io') -----
ioGetClipboardFormat: clipboard formatNumber: formatNumber
| clipboardAddress itemCount |
+ <var: #clipboardAddress type: #'usqIntptr_t'>
- <var: #clipboardAddress type: #'unsigned long'>
self primitive: 'ioGetClipboardFormat' parameters: #(#Oop #SmallInteger ).
clipboardAddress := interpreterProxy positiveMachineIntegerValueOf: clipboard.
itemCount := self sqPasteboardGetItemCount: clipboardAddress.
itemCount > 0
ifTrue: [^ self sqPasteboardCopyItemFlavors: clipboardAddress itemNumber: formatNumber].
^ interpreterProxy nilObject!
Item was changed:
----- Method: ClipboardExtendedPlugin>>ioReadClipboardData:format: (in category 'io') -----
ioReadClipboardData: clipboard format: format
| clipboardAddress formatLength |
+ <var: #clipboardAddress type: #'usqIntptr_t'>
- <var: #clipboardAddress type: #'unsigned long'>
self primitive: 'ioReadClipboardData' parameters: #(Oop String).
clipboardAddress := interpreterProxy positiveMachineIntegerValueOf: clipboard.
formatLength := interpreterProxy slotSizeOf: format cPtrAsOop.
^ self sqPasteboardCopyItemFlavorData: clipboardAddress format: format formatLength: formatLength.
!
Item was changed:
----- Method: CoInterpreter>>printMethodCacheFor: (in category 'debug printing') -----
printMethodCacheFor: thing
<api>
| n |
n := 0.
0 to: MethodCacheSize - 1 by: MethodCacheEntrySize do:
[:i | | s c m p |
s := methodCache at: i + MethodCacheSelector.
c := methodCache at: i + MethodCacheClass.
m := methodCache at: i + MethodCacheMethod.
p := methodCache at: i + MethodCachePrimFunction.
((thing = -1 or: [s = thing or: [c = thing or: [p = thing or: [m = thing
or: [(objectMemory addressCouldBeObj: m)
and: [(self maybeMethodHasCogMethod: m)
and: [(self cogMethodOf: m) asInteger = thing]]]]]]])
and: [(objectMemory addressCouldBeOop: s)
and: [c ~= 0
and: [(self addressCouldBeClassObj: c)
or: [self addressCouldBeClassObj: (objectMemory classForClassTag: c)]]]]) ifTrue:
[n := n + 1.
self cCode: [] inSmalltalk: [self transcript ensureCr].
self printNum: i; space; printHexnp: i; cr; tab.
(objectMemory isBytesNonImm: s)
+ ifTrue: [self cCode: 'printf("%" PRIxSQPTR " %.*s\n", s, (int)(numBytesOf(s)), (char *)firstIndexableField(s))'
- ifTrue: [self cCode: 'printf("%lx %.*s\n", s, (int)(numBytesOf(s)), (char *)firstIndexableField(s))'
inSmalltalk: [self printHex: s; space; print: (self stringOf: s); cr]]
ifFalse: [self shortPrintOop: s].
self tab.
(self addressCouldBeClassObj: c)
ifTrue: [self shortPrintOop: c]
ifFalse: [self printNum: c; space; printHexnp: c; space; shortPrintOop: (objectMemory classForClassTag: c)].
self tab; shortPrintOop: m; tab.
self cCode:
[p > 1024
ifTrue: [self printHexnp: p]
ifFalse: [self printNum: p]]
inSmalltalk:
[p isSymbol ifTrue: [self print: p] ifFalse: [self printNum: p]].
self cr]].
n > 1 ifTrue:
[self printNum: n; cr]!
Item was changed:
----- Method: CoInterpreter>>reportMinimumUnusedHeadroom (in category 'debug support') -----
reportMinimumUnusedHeadroom
"Report the stack page size and minimum unused headroom to stdout."
<api>
self cCode:
[self pri: 'stack page bytes %ld available headroom %ld minimum unused headroom %ld\n'
+ n: self stackPageByteSize asIntegerPtr
+ t: (self stackPageByteSize - self stackLimitBytes - self stackLimitOffset) asIntegerPtr
+ f: self minimumUnusedHeadroom asIntegerPtr]
- n: self stackPageByteSize asLong
- t: (self stackPageByteSize - self stackLimitBytes - self stackLimitOffset) asLong
- f: self minimumUnusedHeadroom asLong]
inSmalltalk:
["CogVMSimulator new initStackPagesForTests reportMinimumUnusedHeadroom"
self print: 'stack page bytes '; printNum: self stackPageByteSize;
print: ' available headroom '; printNum: self stackPageByteSize - self stackLimitBytes - self stackLimitOffset;
print: ' minimum unused headroom '; printNum: self minimumUnusedHeadroom;
cr]!
Item was changed:
----- Method: CoInterpreter>>rewriteMethodCacheEntryForExternalPrimitiveToFunction: (in category 'method lookup cache') -----
rewriteMethodCacheEntryForExternalPrimitiveToFunction: localPrimAddress
"Rewrite an existing entry in the method cache with a new primitive function address.
Used by primitiveExternalCall to make direct calls to found external prims, or quickly
fail not found external prims.
Override to do the same to the machine code call. If methodObj has a cogged dual
rewrite the primitive call in it to call localPrimAddress. Used to update calls through
primitiveExternalCall to directly call the target function or to revert to calling
primitiveExternalCall after a flush."
<var: #localPrimAddress declareC: 'void (*localPrimAddress)(void)'>
<inline: false>
(self methodHasCogMethod: newMethod) ifTrue:
[cogit
rewritePrimInvocationIn: (self cogMethodOf: newMethod)
to: (localPrimAddress = 0
ifTrue: [self cCoerceSimple: #primitiveFail to: #'void (*)(void)']
ifFalse: [localPrimAddress])].
(methodCache at: lastMethodCacheProbeWrite + MethodCacheMethod) = newMethod ifTrue:
[methodCache
at: lastMethodCacheProbeWrite + MethodCachePrimFunction
+ put: (self cCoerce: localPrimAddress to: #sqInt)]!
- put: (self cCoerce: localPrimAddress to: #long)]!
Item was changed:
----- Method: CogARMCompiler class>>machineCodeDeclaration (in category 'translation') -----
machineCodeDeclaration
"Answer the declaration for the machineCode array."
+ ^{#'usqIntptr_t'. '[', self basicNew machineCodeWords printString, ']'}!
- ^{#'unsigned long'. '[', self basicNew machineCodeWords printString, ']'}!
Item was changed:
----- Method: CogARMCompiler>>isInImmediateJumpRange: (in category 'testing') -----
isInImmediateJumpRange: operand
"ARM calls and jumps span +/- 32 mb, more than enough for intra-zone calls and jumps."
+ <var: #operand type: #'usqIntptr_t'>
- <var: #operand type: #'unsigned long'>
^operand signedIntFromLong between: -16r2000000 and: 16r1FFFFFC!
Item was changed:
----- Method: CogAbstractInstruction class>>instVarNamesAndTypesForTranslationDo: (in category 'translation') -----
instVarNamesAndTypesForTranslationDo: aBinaryBlock
"enumerate aBinaryBlock with the names and C type strings for the inst vars to include in an AbstractInstruction struct."
"{CogAbstractInstruction. CogIA32Compiler. CogARMCompiler} do:
[:c| Transcript print: c; cr. c printTypedefOn: Transcript]"
(self filteredInstVarNames copyWithout: 'machineCode'), #('machineCode') do:
[:ivn|
ivn ~= 'bcpc' ifTrue:
[aBinaryBlock
value: ivn
value: (ivn caseOf: {
+ ['address'] -> [#'usqIntptr_t'].
- ['address'] -> [#'unsigned long'].
['machineCode'] -> [self machineCodeDeclaration].
+ ['operands'] -> [{#'usqIntptr_t'. '[', NumOperands, ']'}].
- ['operands'] -> [{#'unsigned long'. '[', NumOperands, ']'}].
['dependent'] -> ['struct _AbstractInstruction *']}
otherwise:
[#'unsigned char'])]]!
Item was added:
+ ----- Method: CogAbstractInstruction>>asIntegerPtr (in category 'coercion') -----
+ asIntegerPtr
+ <doNotGenerate>
+ ^self!
Item was added:
+ ----- Method: CogAbstractInstruction>>asUnsignedIntegerPtr (in category 'coercion') -----
+ asUnsignedIntegerPtr
+ <doNotGenerate>
+ ^self!
Item was changed:
----- Method: CogClass>>cCoerceSimple:to: (in category 'translation support') -----
cCoerceSimple: value to: cTypeString
<doNotGenerate>
"Type coercion for translation and simulation.
For simulation answer a suitable surrogate for the struct types"
^cTypeString caseOf:
{ [#'unsigned long'] -> [value].
[#'unsigned int'] -> [value].
[#sqInt] -> [value].
+ [#'sqIntptr_t'] -> [value].
+ [#'usqIntptr_t'] -> [value].
[#usqInt] -> [value].
[#sqLong] -> [value].
[#usqLong] -> [value].
[#'AbstractInstruction *'] -> [value].
[#'BytecodeFixup *'] -> [value].
[#'CogMethod *'] -> [value].
[#'char *'] -> [value].
[#'sqInt *'] -> [value].
[#'void *'] -> [value].
[#void] -> [value].
[#'void (*)()'] -> [value].
[#'void (*)(void)'] -> [value].
[#'unsigned long (*)(void)'] -> [value].
[#'void (*)(unsigned long,unsigned long)'] -> [value] }!
Item was changed:
----- Method: CogIA32Compiler>>concretizeFill32 (in category 'generate machine code') -----
concretizeFill32
<inline: true>
| word |
+ <var: #word type: #'unsigned int'>
- <var: #word type: #'unsigned long'>
word := operands at: 0.
machineCode at: 0 put: (word bitAnd: 16rFF).
machineCode at: 1 put: (word >> 8 bitAnd: 16rFF).
machineCode at: 2 put: (word >> 16 bitAnd: 16rFF).
machineCode at: 3 put: (word >> 24 bitAnd: 16rFF).
^machineCodeSize := 4!
Item was changed:
----- Method: CogIA32Compiler>>flushICacheFrom:to: (in category 'inline cacheing') -----
flushICacheFrom: startAddress "<Integer>" to: endAddress "<Integer>"
<cmacro: '(me,startAddress,endAddress) 0'>
"On Intel processors where code and data have the same linear address, no
+ special action is required to flush the instruction cache. One only needs to
- special action is required to flush the instruciton cache. One only needs to
execute a serializing instruction (e.g. CPUID) if code and data are at different
virtual addresses (e.g. a debugger using memory-mapping to access a debugee).
Using the macro avoids an unnecessary call."
self halt: #ceFlushICache!
Item was changed:
----- Method: CogIA32Compiler>>isQuick: (in category 'testing') -----
isQuick: operand
+ <var: #operand type: #'usqInt'>
- <var: #operand type: #'unsigned long'>
^operand signedIntFromLong between: -128 and: 127!
Item was changed:
----- Method: CogIA32Compiler>>rewriteCPICJumpAt:target: (in category 'inline cacheing') -----
rewriteCPICJumpAt: addressFollowingJump target: jumpTargetAddress
"Rewrite the short jump instruction to jump to a new cpic case target. "
<var: #addressFollowingJump type: #usqInt>
<var: #jumpTargetAddress type: #usqInt>
+ <var: #callDistance type: #sqInt> "prevent type inference for avoiding warning on abs"
| callDistance |
callDistance := jumpTargetAddress - addressFollowingJump.
self assert: callDistance abs < 128.
objectMemory
byteAt: addressFollowingJump - 1
put: (callDistance bitAnd: 16rFF).
"self cCode: ''
inSmalltalk: [cogit disassembleFrom: addressFollowingJump - 10 to: addressFollowingJump - 1]."
^2!
Item was changed:
----- Method: CogMIPSELCompiler class>>machineCodeDeclaration (in category 'translation') -----
machineCodeDeclaration
"Answer the declaration for the machineCode array."
+ ^{#'usqIntptr_t'. '[', self basicNew machineCodeWords printString, ']'}!
- ^{#'unsigned long'. '[', self basicNew machineCodeWords printString, ']'}!
Item was added:
+ ----- Method: CogMethodSurrogate>>asIntegerPtr (in category 'accessing') -----
+ asIntegerPtr
+ "Answer the surrogate's adress. This is equivalent to a C cast to usqIntptr_t,
+ which is precisely what Slang generates for asUnsignedInteger"
+ ^address!
Item was added:
+ ----- Method: CogMethodSurrogate>>asUnsignedIntegerPtr (in category 'accessing') -----
+ asUnsignedIntegerPtr
+ "Answer the surrogate's adress. This is equivalent to a C cast to usqIntptr_t,
+ which is precisely what Slang generates for asUnsignedInteger"
+ ^address!
Item was changed:
----- Method: CogMethodZone>>roundUpAddress: (in category 'accessing') -----
roundUpAddress: address
<returnTypeC: #'void *'>
<var: #address type: #'void *'>
+ ^self cCoerce: ((self cCoerce: address to: #'usqIntptr_t') + 7 bitAnd: -8) to: #'void *'!
- ^self cCoerce: ((self cCoerce: address to: 'unsigned long') + 7 bitAnd: -8) to: #'void *'!
Item was added:
+ ----- Method: CogSSBytecodeFixup>>asIntegerPtr (in category 'simulation support') -----
+ asIntegerPtr
+ <doNotGenerate>
+ ^self!
Item was added:
+ ----- Method: CogSSBytecodeFixup>>asUnsignedIntegerPtr (in category 'simulation support') -----
+ asUnsignedIntegerPtr
+ <doNotGenerate>
+ ^self!
Item was added:
+ ----- Method: CogStackPageSurrogate>>asIntegerPtr (in category 'accessing') -----
+ asIntegerPtr
+ ^address!
Item was added:
+ ----- Method: CogStackPageSurrogate>>asUnsignedIntegerPtr (in category 'accessing') -----
+ asUnsignedIntegerPtr
+ ^address!
Item was changed:
----- Method: CogVMSimulator>>rewriteMethodCacheEntryForExternalPrimitiveToFunction: (in category 'method lookup cache') -----
rewriteMethodCacheEntryForExternalPrimitiveToFunction: localPrimAddress
super rewriteMethodCacheEntryForExternalPrimitiveToFunction:
(self mapFunctionToAddress: (localPrimAddress = 0
ifTrue: [#primitiveFail]
ifFalse: [localPrimAddress])).
"Hack; the super call will rewrite the entry to the address of the function.
So (when simulating) undo the damage and put back the functionPointer"
(methodCache at: lastMethodCacheProbeWrite + MethodCacheMethod) = newMethod ifTrue:
[methodCache
at: lastMethodCacheProbeWrite + MethodCachePrimFunction
+ put: (self cCoerce: localPrimAddress to: #sqInt)]!
- put: (self cCoerce: localPrimAddress to: #long)]!
Item was changed:
----- Method: CogX64Compiler>>concretizeFill32 (in category 'generate machine code') -----
concretizeFill32
<inline: true>
| word |
+ <var: #word type: #'usqIntptr_t'>
- <var: #word type: #'unsigned long'>
word := operands at: 0.
machineCode at: 0 put: (word bitAnd: 16rFF).
machineCode at: 1 put: (word >> 8 bitAnd: 16rFF).
machineCode at: 2 put: (word >> 16 bitAnd: 16rFF).
machineCode at: 3 put: (word >> 24 bitAnd: 16rFF).
^machineCodeSize := 4!
Item was changed:
----- Method: CogX64Compiler>>is32BitSignedImmediate: (in category 'testing') -----
is32BitSignedImmediate: a64BitUnsignedOperand
"Top 32 bits all the same as the bottom 32 bits' sign bit implies we can use a sign-extended 4 byte offset."
+ ^self cCode: [(self cCoerceSimple: a64BitUnsignedOperand to: #int) = (self cCoerceSimple: a64BitUnsignedOperand to: #sqLong)]
- ^self cCode: [(self cCoerceSimple: a64BitUnsignedOperand to: #int) = (self cCoerceSimple: a64BitUnsignedOperand to: #long)]
inSmalltalk: [((a64BitUnsignedOperand >> 32) signedIntFromLong + 1 bitXor: 1) = (a64BitUnsignedOperand >> 31 bitAnd: 1)]!
Item was changed:
----- Method: CogX64Compiler>>isQuick: (in category 'testing') -----
isQuick: operand
+ <var: #operand type: #'usqIntptr_t'>
- <var: #operand type: #'unsigned long'>
^operand signedIntFromLong64 between: -128 and: 127!
Item was changed:
----- Method: Cogit class>>declareCVarsIn: (in category 'translation') -----
declareCVarsIn: aCCodeGenerator
#( 'coInterpreter' 'objectMemory' 'methodZone' 'objectRepresentation'
'cogBlockMethodSurrogateClass' 'cogMethodSurrogateClass' 'nsSendCacheSurrogateClass'
'threadManager' 'processor' 'lastNInstructions' 'simulatedAddresses'
'simulatedTrampolines' 'simulatedVariableGetters' 'simulatedVariableSetters'
'printRegisters' 'printInstructions' 'clickConfirm' 'singleStep') do:
[:simulationVariableNotNeededForRealVM|
aCCodeGenerator removeVariable: simulationVariableNotNeededForRealVM].
NewspeakVM ifFalse:
[#( 'selfSendTrampolines' 'dynamicSuperSendTrampolines'
'implicitReceiverSendTrampolines' 'outerSendTrampolines'
'ceEnclosingObjectTrampoline' 'numIRCs' 'indexOfIRC' 'theIRCs') do:
[:variableNotNeededInNormalVM|
aCCodeGenerator removeVariable: variableNotNeededInNormalVM]].
aCCodeGenerator removeConstant: #COGMTVM. "this should be defined at compile time"
aCCodeGenerator
addHeaderFile:'<stddef.h>'; "for e.g. offsetof"
addHeaderFile:'"sqCogStackAlignment.h"';
addHeaderFile:'"dispdbg.h"'; "must precede cointerp.h & cogit.h otherwise NoDbgRegParms gets screwed up"
addHeaderFile:'"cogmethod.h"'.
NewspeakVM ifTrue:
[aCCodeGenerator addHeaderFile:'"nssendcache.h"'].
aCCodeGenerator
addHeaderFile:'#if COGMTVM';
addHeaderFile:'"cointerpmt.h"';
addHeaderFile:'#else';
addHeaderFile:'"cointerp.h"';
addHeaderFile:'#endif';
addHeaderFile:'"cogit.h"'.
aCCodeGenerator
var: #ceGetFP
+ declareC: 'usqIntptr_t (*ceGetFP)(void)';
- declareC: 'unsigned long (*ceGetFP)(void)';
var: #ceGetSP
+ declareC: 'usqIntptr_t (*ceGetSP)(void)';
- declareC: 'unsigned long (*ceGetSP)(void)';
var: #ceCaptureCStackPointers
declareC: 'void (*ceCaptureCStackPointers)(void)';
var: #ceEnterCogCodePopReceiverReg
declareC: 'void (*ceEnterCogCodePopReceiverReg)(void)';
var: #realCEEnterCogCodePopReceiverReg
declareC: 'void (*realCEEnterCogCodePopReceiverReg)(void)';
var: #ceCallCogCodePopReceiverReg
declareC: 'void (*ceCallCogCodePopReceiverReg)(void)';
var: #realCECallCogCodePopReceiverReg
declareC: 'void (*realCECallCogCodePopReceiverReg)(void)';
var: #ceCallCogCodePopReceiverAndClassRegs
declareC: 'void (*ceCallCogCodePopReceiverAndClassRegs)(void)';
var: #realCECallCogCodePopReceiverAndClassRegs
declareC: 'void (*realCECallCogCodePopReceiverAndClassRegs)(void)';
var: #ceFlushICache
+ declareC: 'static void (*ceFlushICache)(usqIntptr_t from, usqIntptr_t to)';
- declareC: 'static void (*ceFlushICache)(unsigned long from, unsigned long to)';
var: #ceCheckFeaturesFunction
+ declareC: 'static usqIntptr_t (*ceCheckFeaturesFunction)(void)';
- declareC: 'static unsigned long (*ceCheckFeaturesFunction)(void)';
var: #ceTryLockVMOwner
+ declareC: 'usqIntptr_t (*ceTryLockVMOwner)(void)';
- declareC: 'unsigned long (*ceTryLockVMOwner)(void)';
var: #ceUnlockVMOwner
declareC: 'void (*ceUnlockVMOwner)(void)';
var: #postCompileHook
declareC: 'void (*postCompileHook)(CogMethod *)';
var: #openPICList declareC: 'CogMethod *openPICList = 0';
var: #maxMethodBefore type: #'CogBlockMethod *'.
self objectMemoryClass wordSize = 8 ifTrue:
[aCCodeGenerator var: 'enumeratingCogMethod' type: #'CogMethod *'].
aCCodeGenerator
declareVar: 'aMethodLabel' type: #'AbstractInstruction'; "Has to come lexicographically before backEnd & methodLabel"
var: #backEnd declareC: 'AbstractInstruction * const backEnd = &aMethodLabel';
var: #methodLabel declareC: 'AbstractInstruction * const methodLabel = &aMethodLabel'.
self declareC: #(abstractOpcodes stackCheckLabel
blockEntryLabel blockEntryNoContextSwitch
stackOverflowCall sendMiss
entry noCheckEntry selfSendEntry dynSuperEntry
fullBlockNoContextSwitchEntry fullBlockEntry
picMNUAbort picInterpretAbort endCPICCase0 endCPICCase1 cPICEndOfCodeLabel)
as: #'AbstractInstruction *'
in: aCCodeGenerator.
aCCodeGenerator
declareVar: #blockStarts type: #'BlockStart *';
declareVar: #fixups type: #'BytecodeFixup *'.
aCCodeGenerator
var: #ordinarySendTrampolines
declareC: 'sqInt ordinarySendTrampolines[NumSendTrampolines]';
var: #superSendTrampolines
declareC: 'sqInt superSendTrampolines[NumSendTrampolines]';
var: #directedSuperSendTrampolines
declareC: 'sqInt directedSuperSendTrampolines[NumSendTrampolines]';
var: #selfSendTrampolines
declareC: 'sqInt selfSendTrampolines[NumSendTrampolines]';
var: #dynamicSuperSendTrampolines
declareC: 'sqInt dynamicSuperSendTrampolines[NumSendTrampolines]';
var: #implicitReceiverSendTrampolines
declareC: 'sqInt implicitReceiverSendTrampolines[NumSendTrampolines]';
var: #outerSendTrampolines
declareC: 'sqInt outerSendTrampolines[NumSendTrampolines]';
var: #trampolineAddresses
declareC: 'static char *trampolineAddresses[NumTrampolines*2]';
var: #objectReferencesInRuntime
declareC: 'static usqInt objectReferencesInRuntime[NumObjRefsInRuntime]';
var: #labelCounter
type: #int;
var: #traceFlags
declareC: 'int traceFlags = 8 /* prim trace log on by default */';
var: #cStackAlignment
declareC: 'const int cStackAlignment = STACK_ALIGN_BYTES'.
aCCodeGenerator
declareVar: #CFramePointer type: #'void *';
declareVar: #CStackPointer type: #'void *';
+ declareVar: #minValidCallAddress type: #'usqIntptr_t';
+ declareVar: #debugPrimCallStackOffset type: #'usqIntptr_t'.
- declareVar: #minValidCallAddress type: #'unsigned long';
- declareVar: #debugPrimCallStackOffset type: #'unsigned long'.
aCCodeGenerator vmClass generatorTable ifNotNil:
[:bytecodeGenTable|
aCCodeGenerator
var: #generatorTable
declareC: 'static BytecodeDescriptor generatorTable[', bytecodeGenTable size, ']',
(self tableInitializerFor: bytecodeGenTable
in: aCCodeGenerator)].
"In C the abstract opcode names clash with the Smalltak generator syntactic sugar.
Most of the syntactic sugar is inlined, but alas some remains. Rename the syntactic
sugar to avoid the clash."
(self organization listAtCategoryNamed: #'abstract instructions') do:
[:s|
aCCodeGenerator addSelectorTranslation: s to: 'g', (aCCodeGenerator cFunctionNameFor: s)].
aCCodeGenerator addSelectorTranslation: #halt: to: 'haltmsg'!
Item was changed:
----- Method: Cogit>>cFramePointerAddress (in category 'trampoline support') -----
cFramePointerAddress
+ <cmacro: '() ((usqIntptr_t)&CFramePointer)'>
- <cmacro: '() ((unsigned long)&CFramePointer)'>
^(backEnd wantsNearAddressFor: #CFramePointer)
ifTrue: [self simulatedReadWriteVariableAddress: #getCFramePointer in: self]
ifFalse: [coInterpreter inMemoryCFramePointerAddress]!
Item was changed:
----- Method: Cogit>>cStackPointerAddress (in category 'trampoline support') -----
cStackPointerAddress
+ <cmacro: '() ((usqIntptr_t)&CStackPointer)'>
- <cmacro: '() ((unsigned long)&CStackPointer)'>
^(backEnd wantsNearAddressFor: #CStackPointer)
ifTrue: [self simulatedReadWriteVariableAddress: #getCStackPointer in: self]
ifFalse: [coInterpreter inMemoryCStackPointerAddress]!
Item was changed:
----- Method: Cogit>>genGetLeafCallStackPointer (in category 'initialization') -----
genGetLeafCallStackPointer
"Generate a routine that answers the stack pointer immedately
after a leaf call, used for checking stack pointer alignment."
| startAddress |
<inline: false>
self allocateOpcodes: 4 bytecodes: 0.
startAddress := methodZoneBase.
self
MoveR: FPReg R: backEnd cResultRegister;
RetN: 0.
self outputInstructionsForGeneratedRuntimeAt: startAddress.
self recordGeneratedRunTime: 'ceGetFP' address: startAddress.
+ ceGetFP := self cCoerceSimple: startAddress to: #'usqIntptr_t (*)(void)'.
- ceGetFP := self cCoerceSimple: startAddress to: #'unsigned long (*)(void)'.
startAddress := methodZoneBase.
self zeroOpcodeIndex.
self MoveR: SPReg R: backEnd cResultRegister.
backEnd leafCallStackPointerDelta ~= 0 ifTrue:
[self AddCq: backEnd leafCallStackPointerDelta R: backEnd cResultRegister].
self RetN: 0.
self outputInstructionsForGeneratedRuntimeAt: startAddress.
self recordGeneratedRunTime: 'ceGetSP' address: startAddress.
+ ceGetSP := self cCoerceSimple: startAddress to: #'usqIntptr_t (*)(void)'!
- ceGetSP := self cCoerceSimple: startAddress to: #'unsigned long (*)(void)'!
Item was changed:
----- Method: Cogit>>generateVMOwnerLockFunctions (in category 'initialization') -----
generateVMOwnerLockFunctions
| startAddress |
<inline: true>
self cppIf: COGMTVM
ifTrue:
[self allocateOpcodes: backEnd numLowLevelLockOpcodes bytecodes: 0.
self zeroOpcodeIndex.
startAddress := methodZoneBase.
backEnd generateLowLevelTryLock: coInterpreter vmOwnerLockAddress.
self outputInstructionsForGeneratedRuntimeAt: startAddress.
self recordGeneratedRunTime: 'ceTryLockVMOwner' address: startAddress.
+ ceTryLockVMOwner := self cCoerceSimple: startAddress to: #'usqIntptr_t (*)(void)'.
- ceTryLockVMOwner := self cCoerceSimple: startAddress to: #'unsigned long (*)(void)'.
self zeroOpcodeIndex.
initialPC := 0.
endPC := numAbstractOpcodes - 1.
startAddress := methodZoneBase.
backEnd generateLowLevelUnlock: coInterpreter vmOwnerLockAddress.
self outputInstructionsForGeneratedRuntimeAt: startAddress.
self recordGeneratedRunTime: 'ceUnlockVMOwner' address: startAddress.
ceUnlockVMOwner := self cCoerceSimple: startAddress to: #'void (*)(void)']!
Item was changed:
----- Method: Cogit>>maybeGenerateCheckFeatures (in category 'initialization') -----
maybeGenerateCheckFeatures
| startAddress |
<inline: true>
backEnd numCheckFeaturesOpcodes > 0 ifTrue:
[self allocateOpcodes: backEnd numCheckFeaturesOpcodes bytecodes: 0.
startAddress := methodZoneBase.
backEnd generateCheckFeatures.
self outputInstructionsForGeneratedRuntimeAt: startAddress.
self recordGeneratedRunTime: 'ceCheckFeaturesFunction' address: startAddress.
+ ceCheckFeaturesFunction := self cCoerceSimple: startAddress to: #'usqIntptr_t (*)(void)']!
- ceCheckFeaturesFunction := self cCoerceSimple: startAddress to: #'unsigned long (*)(void)']!
Item was changed:
----- Method: Cogit>>maybeGenerateICacheFlush (in category 'initialization') -----
maybeGenerateICacheFlush
| startAddress |
<inline: true>
backEnd numICacheFlushOpcodes > 0 ifTrue:
[self allocateOpcodes: backEnd numICacheFlushOpcodes bytecodes: 0.
startAddress := methodZoneBase.
backEnd generateICacheFlush.
self outputInstructionsForGeneratedRuntimeAt: startAddress.
self recordGeneratedRunTime: 'ceFlushICache' address: startAddress.
+ ceFlushICache := self cCoerceSimple: startAddress to: #'void (*)(usqIntptr_t,usqIntptr_t)']!
- ceFlushICache := self cCoerceSimple: startAddress to: #'void (*)(unsigned long,unsigned long)']!
Item was changed:
----- Method: Cogit>>positiveMachineIntegerFor: (in category 'profiling primitives') -----
positiveMachineIntegerFor: value
+ <var: #value type: #'usqIntptr_t'>
- <var: #value type: #'unsigned long'>
<inline: true>
^objectMemory wordSize = 8
ifTrue: [coInterpreter positive64BitIntegerFor: value]
ifFalse: [coInterpreter positive32BitIntegerFor: value]!
Item was changed:
----- Method: IA32ABIPlugin>>primAllocateExecutablePage (in category 'primitives-memory management') -----
primAllocateExecutablePage
"Answer an Alien for an executable page; for thunks"
"primAllocateExecutablePage ^<Alien>
<primitive: 'primAllocateExecutablePage' error: errorCode module: 'IA32ABI'>"
| byteSize ptr mem alien |
<export: true>
+ <var: #byteSize type: #'sqIntptr_t'>
+ <var: #ptr type: #'sqIntptr_t *'>
+ <var: #mem type: #'void *'>
- <var: #byteSize type: 'long'>
- <var: #ptr type: 'long *'>
- <var: #mem type: 'void *'>
self cCode: 'mem = allocateExecutablePage(&byteSize)'
inSmalltalk: [self error: 'not yet implemented'. mem := 0. byteSize := 0].
mem = 0 ifTrue:
[^interpreterProxy primitiveFailFor: PrimErrNoCMemory].
alien := interpreterProxy
instantiateClass: interpreterProxy classAlien
indexableSize: 2 * interpreterProxy bytesPerOop.
interpreterProxy failed ifTrue:
[^interpreterProxy primitiveFailFor: PrimErrNoMemory].
ptr := interpreterProxy firstIndexableField: alien.
ptr at: 0 put: 0 - byteSize. "indirect mem indicated by negative size. Slang doesn't grok negated"
+ ptr at: 1 put: (self cCoerce: mem to: #'sqIntptr_t').
- ptr at: 1 put: (self cCoerce: mem to: 'long').
interpreterProxy methodReturnValue: alien!
Item was changed:
----- Method: IA32ABIPlugin>>primBoxedFree (in category 'primitives-memory management') -----
primBoxedFree
"Free the memory referenced by the receiver, an Alien."
"proxy <Alien> primFree ^<Alien>
<primitive: 'primBoxedFree' error: errorCode module: 'IA32ABI'>"
| addr rcvr ptr sizeField |
<export: true>
+ <var: #ptr type: #'sqIntptr_t *'>
+ <var: #addr type: #'sqIntptr_t'>
+ <var: #sizeField type: #'sqIntptr_t'>
- <var: #ptr type: 'sqInt *'>
- <var: #sizeField type: 'long'>
rcvr := interpreterProxy stackValue: 0.
(interpreterProxy byteSizeOf: rcvr) >= (2 * interpreterProxy bytesPerOop) ifFalse:
[^interpreterProxy primitiveFailFor: PrimErrBadReceiver].
ptr := interpreterProxy firstIndexableField: rcvr.
sizeField := ptr at: 0.
addr := ptr at: 1.
"Don't you dare to free Squeak's memory!!"
(sizeField >= 0 or: [addr = 0 or: [interpreterProxy isInMemory: addr]]) ifTrue:
[^interpreterProxy primitiveFailFor: PrimErrInappropriate].
self cCode: 'free((void *)addr)'
inSmalltalk: [self Cfree: addr].
ptr
at: 0 put: 0;
at: 1 put: 0 "cleanup"!
Item was changed:
----- Method: IA32ABIPlugin>>primThunkEntryAddress (in category 'primitives-callbacks') -----
primThunkEntryAddress
"Answer the address of the entry-point for thunk callbacks:
long thunkEntry(void *thunkp, long *stackp);
This could be derived via loadModule: findSymbol: etc but that would
preclude making the plugin internal."
| address |
<export: true>
+ address := self cCode: [#thunkEntry asIntegerPtr] inSmalltalk: [0].
- address := self cCode: [#thunkEntry asInteger] inSmalltalk: [0].
interpreterProxy methodReturnValue: (self positiveMachineIntegerFor: address)!
Item was added:
+ ----- Method: Integer>>asIntegerPtr (in category '*VMMaker-interpreter simulator') -----
+ asIntegerPtr
+ ^self!
Item was added:
+ ----- Method: Integer>>asUnsignedIntegerPtr (in category '*VMMaker-interpreter simulator') -----
+ asUnsignedIntegerPtr
+ "Since the simulator deals with positive integers most of the time we assert that the receiver is greater than zero.
+ But one major exception is stack pointers in the StackInterpreterSimulator, which are negative. So don't fail
+ if the sender is a StackInterpreter and the receiver could be a stack pointer."
+ self >= 0 ifFalse:
+ [self assert: ((thisContext sender methodClass includesBehavior: StackInterpreter)
+ and: [thisContext sender receiver stackPages couldBeFramePointer: self])].
+ ^self!
Item was changed:
----- Method: Interpreter class>>declareCVarsIn: (in category 'translation') -----
declareCVarsIn: aCCodeGenerator
aCCodeGenerator addHeaderFile:'<setjmp.h>'.
self declareInterpreterVersionIn: aCCodeGenerator
defaultName: 'Context'.
aCCodeGenerator
var: #interpreterProxy
type: #'struct VirtualMachine*'.
aCCodeGenerator
var: #primitiveTable
declareC: 'void *primitiveTable[MaxPrimitiveIndex + 2 /* ', (MaxPrimitiveIndex +2) printString, ' */] = ', self primitiveTableString.
aCCodeGenerator
var: #primitiveFunctionPointer
declareC: 'void *primitiveFunctionPointer'. "xxxx FIX THIS STUPIDITY xxxx - ikp. What he means is use a better type than void *, apparently - tpr"
aCCodeGenerator
var: #methodCache
+ declareC: 'sqIntptr_t methodCache[MethodCacheSize + 1 /* ', (MethodCacheSize + 1) printString, ' */]'.
- declareC: 'long methodCache[MethodCacheSize + 1 /* ', (MethodCacheSize + 1) printString, ' */]'.
aCCodeGenerator
var: #atCache
declareC: 'sqInt atCache[AtCacheTotalSize + 1 /* ', (AtCacheTotalSize + 1) printString, ' */]'.
aCCodeGenerator var: #localIP type: #'char*'.
aCCodeGenerator var: #localSP type: #'char*'.
aCCodeGenerator var: #showSurfaceFn type: #'void*'.
aCCodeGenerator var: 'semaphoresToSignalA'
declareC: 'sqInt semaphoresToSignalA[SemaphoresToSignalSize + 1 /* ', (SemaphoresToSignalSize + 1) printString, ' */]'.
aCCodeGenerator var: 'semaphoresToSignalB'
declareC: 'sqInt semaphoresToSignalB[SemaphoresToSignalSize + 1 /* ', (SemaphoresToSignalSize + 1) printString, ' */]'.
aCCodeGenerator
var: #compilerHooks
declareC: 'sqInt (*compilerHooks[CompilerHooksSize + 1 /* ', (CompilerHooksSize + 1) printString, ' */])()'.
aCCodeGenerator
var: #externalPrimitiveTable
declareC: 'void *externalPrimitiveTable[MaxExternalPrimitiveTableSize + 1 /* ', (MaxExternalPrimitiveTableSize + 1) printString, ' */]'.
aCCodeGenerator
var: #jmpBuf
declareC: 'jmp_buf jmpBuf[MaxJumpBuf + 1 /* ', (MaxJumpBuf + 1) printString, ' */]'.
aCCodeGenerator
var: #suspendedCallbacks
declareC: 'usqInt suspendedCallbacks[MaxJumpBuf + 1 /* ', (MaxJumpBuf + 1) printString, ' */]'.
aCCodeGenerator
var: #suspendedMethods
declareC: 'usqInt suspendedMethods[MaxJumpBuf + 1 /* ', (MaxJumpBuf + 1) printString, ' */]'.
self declareCAsOop: {
#instructionPointer.
#method.
#newMethod.
#activeContext.
#theHomeContext.
#stackPointer
} in: aCCodeGenerator.
aCCodeGenerator var: #nextProfileTick type: #sqLong.
!
Item was changed:
----- Method: Interpreter>>addNewMethodToCache (in category 'method lookup cache') -----
addNewMethodToCache
"Add the given entry to the method cache.
The policy is as follows:
Look for an empty entry anywhere in the reprobe chain.
If found, install the new entry there.
If not found, then install the new entry at the first probe position
and delete the entries in the rest of the reprobe chain.
This has two useful purposes:
If there is active contention over the first slot, the second
or third will likely be free for reentry after ejection.
Also, flushing is good when reprobe chains are getting full."
| probe hash |
<inline: false>
hash := messageSelector bitXor: lkupClass. "drop low-order zeros from addresses"
(self isOopCompiledMethod: newMethod)
ifTrue:
[primitiveIndex := self primitiveIndexOf: newMethod.
primitiveFunctionPointer := self functionPointerFor: primitiveIndex inClass: lkupClass]
ifFalse:
[primitiveFunctionPointer := #primitiveInvokeObjectAsMethod].
primitiveFunctionPointer := self functionPointerFor: primitiveIndex inClass: lkupClass.
0 to: CacheProbeMax-1 do:
[:p | probe := (hash >> p) bitAnd: MethodCacheMask.
(methodCache at: probe + MethodCacheSelector) = 0 ifTrue:
["Found an empty entry -- use it"
methodCache at: probe + MethodCacheSelector put: messageSelector.
methodCache at: probe + MethodCacheClass put: lkupClass.
methodCache at: probe + MethodCacheMethod put: newMethod.
methodCache at: probe + MethodCachePrim put: primitiveIndex.
+ methodCache at: probe + MethodCachePrimFunction put: (self cCoerce: primitiveFunctionPointer to: #'sqIntptr_t').
- methodCache at: probe + MethodCachePrimFunction put: (self cCoerce: primitiveFunctionPointer to: 'long').
^ nil]].
"OK, we failed to find an entry -- install at the first slot..."
probe := hash bitAnd: MethodCacheMask. "first probe"
methodCache at: probe + MethodCacheSelector put: messageSelector.
methodCache at: probe + MethodCacheClass put: lkupClass.
methodCache at: probe + MethodCacheMethod put: newMethod.
methodCache at: probe + MethodCachePrim put: primitiveIndex.
+ methodCache at: probe + MethodCachePrimFunction put: (self cCoerce: primitiveFunctionPointer to: #'sqIntptr_t').
- methodCache at: probe + MethodCachePrimFunction put: (self cCoerce: primitiveFunctionPointer to: 'long').
"...and zap the following entries"
1 to: CacheProbeMax-1 do:
[:p | probe := (hash >> p) bitAnd: MethodCacheMask.
methodCache at: probe + MethodCacheSelector put: 0].
!
Item was changed:
----- Method: Interpreter>>rewriteMethodCacheSel:class:primIndex:primFunction: (in category 'method lookup cache') -----
rewriteMethodCacheSel: selector class: class primIndex: localPrimIndex primFunction: localPrimAddress
"Rewrite an existing entry in the method cache with a new primitive
index & function address. Used by primExternalCall to make direct jumps to found external prims"
| probe hash |
<inline: false>
<var: #localPrimAddress type: 'void *'>
hash := selector bitXor: class.
0 to: CacheProbeMax - 1 do: [:p |
probe := hash >> p bitAnd: MethodCacheMask.
((methodCache at: probe + MethodCacheSelector) = selector
and: [(methodCache at: probe + MethodCacheClass) = class])
ifTrue: [methodCache at: probe + MethodCachePrim put: localPrimIndex.
+ methodCache at: probe + MethodCachePrimFunction put: (self cCoerce: localPrimAddress to: #'sqIntptr_t').
- methodCache at: probe + MethodCachePrimFunction put: (self cCoerce: localPrimAddress to: 'long').
^ nil]]!
Item was changed:
----- Method: InterpreterPlugin>>positiveMachineIntegerFor: (in category 'API access') -----
positiveMachineIntegerFor: value
+ <var: #value type: #'usqIntptr_t'>
- <var: #value type: #'unsigned long'>
<inline: true>
^interpreterProxy wordSize = 8
ifTrue: [interpreterProxy positive64BitIntegerFor: value]
ifFalse: [interpreterProxy positive32BitIntegerFor: value]!
Item was changed:
----- Method: InterpreterPlugin>>signedMachineIntegerFor: (in category 'API access') -----
signedMachineIntegerFor: value
+ <var: #value type: #'sqIntptr_t'>
- <var: #value type: #'unsigned long'>
<inline: true>
^interpreterProxy wordSize = 8
ifTrue: [interpreterProxy signed64BitIntegerFor: value]
ifFalse: [interpreterProxy signed32BitIntegerFor: value]!
Item was changed:
----- Method: InterpreterPlugin>>sizeof: (in category 'simulation support') -----
sizeof: objectSymbolOrClass
<doNotGenerate>
- objectSymbolOrClass isInteger ifTrue:
- [^interpreterProxy wordSize].
objectSymbolOrClass isSymbol ifTrue:
["In the simulator file handles are just integer indices into openFiles and so need
only be BytesPerWord big. But in the actual VM they are at least 5 words long."
objectSymbolOrClass == #SQFile ifTrue:
[^interpreterProxy wordSize * 5].
"SQSocket is typedef struct { int sessionID; int socketType; void *privateSocketPtr; } SQSocket"
objectSymbolOrClass == #SQSocket ifTrue:
[^8 + interpreterProxy wordSize].
"We assume the file offset type is always 64-bits."
objectSymbolOrClass == #squeakFileOffsetType ifTrue:
[^8].
(objectSymbolOrClass last == $*
+ or: [#'sqIntptr_t' == objectSymbolOrClass
+ or: [#'usqIntptr_t' == objectSymbolOrClass
+ or: [#'size_t' == objectSymbolOrClass]]]) ifTrue:
- or: [#long == objectSymbolOrClass
- or: [#'unsigned long' == objectSymbolOrClass]]) ifTrue:
[^interpreterProxy wordSize].
(#(usqInt sqInt) includes: objectSymbolOrClass) ifTrue:
[^interpreterProxy bytesPerOop]].
^super sizeof: objectSymbolOrClass!
Item was changed:
----- Method: InterpreterPrimitives>>asUnsigned: (in category 'primitive support') -----
asUnsigned: anInteger
<inline: true>
+ ^self cCode: [anInteger asUnsignedIntegerPtr] inSmalltalk: [anInteger bitAnd: objectMemory maxCInteger]!
- ^self cCode: [anInteger asUnsignedLong] inSmalltalk: [anInteger bitAnd: objectMemory maxCInteger]!
Item was added:
+ ----- Method: InterpreterPrimitives>>maybeInlinePositive32BitValueOf: (in category 'primitive support') -----
+ maybeInlinePositive32BitValueOf: oop
+ "Convert the given object into an integer value.
+ The object may be either a positive SmallInteger or a four-byte LargePositiveInteger."
+ <notOption: #Spur64BitMemoryManager>
+ <returnTypeC: #'unsigned int'>
+ | value ok sz |
+ (objectMemory isIntegerObject: oop) ifTrue:
+ [value := objectMemory integerValueOf: oop.
+ (value < 0) ifTrue:
+ [self primitiveFail. value := 0].
+ ^value].
+
+ (objectMemory isNonIntegerImmediate: oop)
+ ifTrue:
+ [self primitiveFail.
+ ^0]
+ ifFalse:
+ [ok := objectMemory
+ isClassOfNonImm: oop
+ equalTo: (objectMemory splObj: ClassLargePositiveInteger)
+ compactClassIndex: ClassLargePositiveIntegerCompactIndex.
+ ok ifFalse:
+ [self primitiveFail.
+ ^0].
+ sz := objectMemory numBytesOfBytes: oop.
+ sz > 4 ifTrue:
+ [self primitiveFail.
+ ^0].
+ ^self cCoerceSimple: (objectMemory byteSwapped32IfBigEndian: (objectMemory fetchLong32: 0 ofObject: oop)) to: #'unsigned int']!
Item was added:
+ ----- Method: InterpreterPrimitives>>noInlineSigned32BitValueOf: (in category 'primitive support') -----
+ noInlineSigned32BitValueOf: oop
+ "Convert the given object into an integer value.
+ The object may be either a SmallInteger or a four-byte LargeInteger."
+ | value negative ok magnitude |
+ <notOption: #Spur64BitMemoryManager>
+ <inline: false>
+ <returnTypeC: #int>
+ <var: #value type: #int>
+ <var: #magnitude type: #'unsigned int'>
+ self deny: objectMemory hasSixtyFourBitImmediates.
+ (objectMemory isIntegerObject: oop) ifTrue:
+ [^objectMemory integerValueOf: oop].
+
+ (objectMemory isNonIntegerImmediate: oop) ifTrue:
+ [self primitiveFail.
+ ^0].
+
+ ok := objectMemory
+ isClassOfNonImm: oop
+ equalTo: (objectMemory splObj: ClassLargePositiveInteger)
+ compactClassIndex: ClassLargePositiveIntegerCompactIndex.
+ ok
+ ifTrue: [negative := false]
+ ifFalse:
+ [negative := true.
+ ok := objectMemory isClassOfNonImm: oop
+ equalTo: (objectMemory splObj: ClassLargeNegativeInteger)
+ compactClassIndex: ClassLargeNegativeIntegerCompactIndex.
+ ok ifFalse:
+ [self primitiveFail.
+ ^0]].
+ (objectMemory numBytesOfBytes: oop) > 4 ifTrue:
+ [^self primitiveFail].
+
+ magnitude := self cCoerceSimple: (objectMemory byteSwapped32IfBigEndian: (objectMemory fetchLong32: 0 ofObject: oop)) to: #'unsigned int'.
+
+ (negative
+ ifTrue: [magnitude > 16r80000000]
+ ifFalse: [magnitude >= 16r80000000])
+ ifTrue:
+ [self primitiveFail.
+ ^0].
+ negative
+ ifTrue: [value := 0 - magnitude]
+ ifFalse: [value := magnitude].
+ ^value!
Item was changed:
----- Method: InterpreterPrimitives>>positive32BitValueOf: (in category 'primitive support') -----
positive32BitValueOf: oop
"Convert the given object into an integer value.
The object may be either a positive SmallInteger or a four-byte LargePositiveInteger."
+ <returnTypeC: #'unsigned int'>
+ objectMemory hasSixtyFourBitImmediates
- <returnTypeC: #usqInt>
- | value ok sz |
- (objectMemory isIntegerObject: oop) ifTrue:
- [value := objectMemory integerValueOf: oop.
- (value < 0
- or: [objectMemory wordSize > 4
- and: [self cCode: [(self cCoerceSimple: value to: #'unsigned int') ~= value]
- inSmalltalk: [value >> 32 ~= 0]]]) ifTrue:
- [self primitiveFail. value := 0].
- ^value].
-
- (objectMemory hasSixtyFourBitImmediates
- or: [objectMemory isNonIntegerImmediate: oop])
ifTrue:
+ [(objectMemory isIntegerObject: oop) ifTrue:
+ [| value64 |
+ value64 := objectMemory integerValueOf: oop.
+ (value64 < 0
+ or: [self cCode: [(self cCoerceSimple: value64 to: #'unsigned int') ~= value64]
+ inSmalltalk: [value64 >> 32 ~= 0]]) ifTrue:
+ [self primitiveFail. value64 := 0].
+ ^value64].
+ self primitiveFail.
+ ^0]
- [self primitiveFail.
- ^0]
ifFalse:
+ [^self maybeInlinePositive32BitValueOf: oop]!
- [ok := objectMemory
- isClassOfNonImm: oop
- equalTo: (objectMemory splObj: ClassLargePositiveInteger)
- compactClassIndex: ClassLargePositiveIntegerCompactIndex.
- ok ifFalse:
- [self primitiveFail.
- ^0].
- sz := objectMemory numBytesOfBytes: oop.
- sz > 4 ifTrue:
- [self primitiveFail.
- ^0].
- ^self cCoerceSimple: (objectMemory byteSwapped32IfBigEndian: (objectMemory fetchLong32: 0 ofObject: oop)) to: #'unsigned int']!
Item was changed:
----- Method: InterpreterPrimitives>>positiveMachineIntegerValueOf: (in category 'primitive support') -----
positiveMachineIntegerValueOf: oop
"Answer a value of an integer in address range, i.e up to the size of a machine word.
The object may be either a positive SmallInteger or a LargePositiveInteger of size <= word size."
+ <returnTypeC: #'usqIntptr_t'>
- <returnTypeC: #'unsigned long'>
<inline: true> "only two callers & one is primitiveNewWithArg"
| value bs ok |
(objectMemory isIntegerObject: oop) ifTrue:
[value := objectMemory integerValueOf: oop.
value < 0 ifTrue: [^self primitiveFail].
^value].
(objectMemory isNonIntegerImmediate: oop) ifTrue:
[self primitiveFail.
^0].
ok := objectMemory
isClassOfNonImm: oop
equalTo: (objectMemory splObj: ClassLargePositiveInteger)
compactClassIndex: ClassLargePositiveIntegerCompactIndex.
ok ifFalse:
[self primitiveFail.
^0].
bs := objectMemory numBytesOfBytes: oop.
+ bs > (self sizeof: #'usqIntptr_t') ifTrue:
- bs > (self sizeof: #'unsigned long') ifTrue:
[self primitiveFail.
^0].
"self cppIf: SPURVM
ifTrue: [""Memory is 8 byte aligned in Spur and oversized bytes are set to zero, so we can safely fetch 8 bytes""
^objectMemory byteSwapped64IfBigEndian: (objectMemory fetchLong64: 0 ofObject: oop)]
+ ifFalse: ["((self sizeof: #'usqIntptr_t') = 8
- ifFalse: ["((self sizeof: #'unsigned long') = 8
and: [bs > 4])
ifTrue:
[^objectMemory byteSwapped64IfBigEndian: (objectMemory fetchLong64: 0 ofObject: oop)]
ifFalse:
[^self cCoerceSimple: (objectMemory byteSwapped32IfBigEndian: (objectMemory fetchLong32: 0 ofObject: oop)) to: #'unsigned int']"]"!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveClockLogAddresses (in category 'system control primitives') -----
primitiveClockLogAddresses
"Take a boolean which if true turns or keeps clock logging on. Answer an array supplying
the size of the clock logs, the address of the usecs log, the index in it, the address of the
msecs log, and the index into it."
<export: true>
| result runInNOut usecs uidx msecs midx v1 v2 |
<var: #usecs type: #'void *'>
<var: #msecs type: #'void *'>
+ <var: #runInNOut type: #sqInt> "bypass type inference which would deduce int"
argumentCount ~= 1 ifTrue:
[^self primitiveFail].
runInNOut := (self stackValue: 0) == objectMemory trueObject.
self ioGetClockLogSize: (self addressOf: runInNOut)
Usecs: (self addressOf: usecs) Idx: (self addressOf: uidx)
Msecs: (self addressOf: msecs) Idx: (self addressOf: midx).
result := objectMemory instantiateClass: (objectMemory splObj: ClassArray) indexableSize: 5.
result = 0 ifTrue:
[^self primitiveFail].
objectMemory pushRemappableOop: result.
objectMemory storePointerUnchecked: 0 ofObject: objectMemory topRemappableOop withValue: (objectMemory integerObjectOf: runInNOut).
v1 := self positive32BitIntegerFor: usecs asUnsignedInteger.
v2 := self positive32BitIntegerFor: msecs asUnsignedInteger.
self successful ifFalse:
[objectMemory popRemappableOop.
^self primitiveFail].
objectMemory storePointer: 1 ofObject: objectMemory topRemappableOop withValue: v1.
objectMemory storePointerUnchecked: 2 ofObject: objectMemory topRemappableOop withValue: (objectMemory integerObjectOf: uidx).
objectMemory storePointer: 3 ofObject: objectMemory topRemappableOop withValue: v2.
objectMemory storePointerUnchecked: 4 ofObject: objectMemory topRemappableOop withValue: (objectMemory integerObjectOf: midx).
self pop: 2 thenPush: objectMemory popRemappableOop
!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveGetNextEvent (in category 'I/O primitives') -----
primitiveGetNextEvent
"Primitive. Return the next input event from the VM event queue."
| evtBuf arg value eventTypeIs |
+ <var: #evtBuf declareC:'sqIntptr_t evtBuf[8] = { 0, 0, 0, 0, 0, 0, 0, 0 }'>
- <var: #evtBuf declareC:'long evtBuf[8] = { 0, 0, 0, 0, 0, 0, 0, 0 }'>
self cCode: [] inSmalltalk: [evtBuf := objectMemory newInputEventAccessorOfSize: 8].
arg := self stackTop.
((objectMemory isArray: arg) and:[(objectMemory slotSizeOf: arg) = 8]) ifFalse:
[^self primitiveFailFor: PrimErrBadArgument].
self ioGetNextEvent: (self cCoerce: evtBuf to: 'sqInputEvent*').
self successful ifFalse:
[^nil].
"Event type"
eventTypeIs := evtBuf at: 0.
self storeInteger: 0 ofObject: arg withValue: (evtBuf at: 0).
self successful ifFalse:
[^nil].
eventTypeIs = 6
ifTrue: "Event is Complex, assume evtBuf is populated correctly and return"
[1 to: 7 do: [:i |
value := evtBuf at: i.
self storePointer: i ofObject: arg withValue: value]]
ifFalse:
["Event time stamp"
self storeInteger: 1 ofObject: arg withValue: ((evtBuf at: 1) bitAnd: MillisecondClockMask).
self successful ifFalse:
[^nil].
"Event arguments"
2 to: 7 do:[:i|
value := evtBuf at: i.
(objectMemory isIntegerValue: value)
ifTrue:[self storeInteger: i ofObject: arg withValue: value]
ifFalse:
[value := self positiveMachineIntegerFor: value.
objectMemory storePointer: i ofObject: arg withValue: value]]].
self successful ifTrue: [self pop: 1]!
Item was changed:
----- Method: InterpreterPrimitives>>signed32BitValueOf: (in category 'primitive support') -----
signed32BitValueOf: oop
"Convert the given object into an integer value.
+ The object may be either a SmallInteger or a four-byte LargeInteger."
- The object may be either a positive SmallInteger or a four-byte LargeInteger."
- | value negative ok magnitude |
- <inline: false>
<returnTypeC: #int>
+
+ objectMemory hasSixtyFourBitImmediates
+ ifTrue:
+ [(objectMemory isIntegerObject: oop) ifTrue:
- <var: #value type: #int>
- <var: #magnitude type: #'unsigned int'>
- <var: #value64 type: #long>
- (objectMemory isIntegerObject: oop) ifTrue:
- [objectMemory wordSize = 4
- ifTrue:
- [^objectMemory integerValueOf: oop]
- ifFalse: "Must fail for SmallIntegers with digitLength > 4"
[| value64 |
value64 := objectMemory integerValueOf: oop.
(self cCode: [(self cCoerceSimple: value64 to: #int) ~= value64]
inSmalltalk: [value64 >> 31 ~= 0 and: [value64 >> 31 ~= -1]]) ifTrue:
[self primitiveFail. value64 := 0].
+ ^value64].
+ self primitiveFail.
+ ^0]
- ^value64]].
-
- (objectMemory isNonIntegerImmediate: oop) ifTrue:
- [self primitiveFail.
- ^0].
-
- ok := objectMemory
- isClassOfNonImm: oop
- equalTo: (objectMemory splObj: ClassLargePositiveInteger)
- compactClassIndex: ClassLargePositiveIntegerCompactIndex.
- ok
- ifTrue: [negative := false]
ifFalse:
+ [^self noInlineSigned32BitValueOf: oop]!
- [negative := true.
- ok := objectMemory isClassOfNonImm: oop
- equalTo: (objectMemory splObj: ClassLargeNegativeInteger)
- compactClassIndex: ClassLargeNegativeIntegerCompactIndex.
- ok ifFalse:
- [self primitiveFail.
- ^0]].
- (objectMemory numBytesOfBytes: oop) > 4 ifTrue:
- [^self primitiveFail].
-
- magnitude := self cCoerceSimple: (objectMemory byteSwapped32IfBigEndian: (objectMemory fetchLong32: 0 ofObject: oop)) to: #'unsigned int'.
-
- (negative
- ifTrue: [magnitude > 16r80000000]
- ifFalse: [magnitude >= 16r80000000])
- ifTrue:
- [self primitiveFail.
- ^0].
- negative
- ifTrue: [value := 0 - magnitude]
- ifFalse: [value := magnitude].
- ^value!
Item was changed:
----- Method: InterpreterPrimitives>>signedMachineIntegerValueOf: (in category 'primitive support') -----
signedMachineIntegerValueOf: oop
"Answer a signed value of an integer up to the size of a machine word.
The object may be either a positive SmallInteger or a LargeInteger of size <= word size."
+ <returnTypeC: #'sqIntptr_t'>
- <returnTypeC: #'long'>
| negative ok bs value limit magnitude |
+ <var: #value type: #sqInt>
+ <var: #magnitude type: #'usqIntptr_t'>
+ <var: #limit type: #'usqIntptr_t'>
- <var: #value type: #long>
- <var: #magnitude type: #usqInt>
- <var: #limit type: #usqInt>
(objectMemory isIntegerObject: oop) ifTrue:
[^objectMemory integerValueOf: oop].
(objectMemory isNonIntegerImmediate: oop) ifTrue:
[^self primitiveFail].
ok := objectMemory isClassOfNonImm: oop
equalTo: (objectMemory splObj: ClassLargePositiveInteger)
compactClassIndex: ClassLargePositiveIntegerCompactIndex.
ok
ifTrue: [negative := false]
ifFalse:
[negative := true.
ok := objectMemory isClassOfNonImm: oop
equalTo: (objectMemory splObj: ClassLargeNegativeInteger)
compactClassIndex: ClassLargeNegativeIntegerCompactIndex.
ok ifFalse: [^self primitiveFail]].
bs := objectMemory numBytesOf: oop.
+ bs > (self sizeof: #'usqIntptr_t') ifTrue:
- bs > (self sizeof: #'unsigned long') ifTrue:
[^self primitiveFail].
"self cppIf: SPURVM
ifTrue:
[""Memory is 8 byte aligned in Spur and oversized bytes are set to zero, so we can safely fetch 8 bytes""
magnitude := objectMemory byteSwapped64IfBigEndian: (objectMemory fetchLong64: 0 ofObject: oop)]
ifFalse:
+ ["((self sizeof: #'sqIntptr_t') = 8
- ["((self sizeof: #'unsigned long') = 8
and: [bs > 4])
ifTrue:
[magnitude := objectMemory byteSwapped64IfBigEndian: (objectMemory fetchLong64: 0 ofObject: oop)]
ifFalse:
[magnitude := self cCoerceSimple: (objectMemory byteSwapped32IfBigEndian: (objectMemory fetchLong32: 0 ofObject: oop)) to: #'unsigned int']"]".
+ limit := 1 asUnsignedIntegerPtr << ((self sizeof: #'sqIntptr_t') * 8 - 1).
- limit := 1 asUnsignedInteger << ((self sizeof: #usqInt) * 8 - 1).
(negative
ifTrue: [magnitude > limit]
ifFalse: [magnitude >= limit])
ifTrue: [self primitiveFail.
^0].
negative
ifTrue: [value := 0 - magnitude]
ifFalse: [value := magnitude].
^value!
Item was changed:
----- Method: InterpreterProxy>>ioLoadSymbol:OfLength:FromModule: (in category 'FFI support') -----
ioLoadSymbol: functionNameIndex OfLength: functionLength FromModule: moduleHandle
<returnTypeC: #'void *'>
+ <var: 'moduleHandle' type: #'void *'>
"Dummy - provided by support code"
^0!
Item was changed:
----- Method: InterpreterProxy>>positiveMachineIntegerValueOf: (in category 'converting') -----
positiveMachineIntegerValueOf: oop
+ <returnTypeC: #'usqIntptr_t'>
- <returnTypeC: #'unsigned long'>
oop isInteger ifFalse:[self error: 'Not an integer object'].
^oop < 0
ifTrue: [self primitiveFail. 0]
ifFalse: [oop]!
Item was changed:
----- Method: InterpreterProxy>>signedMachineIntegerValueOf: (in category 'converting') -----
signedMachineIntegerValueOf: oop
+ <returnTypeC: #'sqIntptr_t'>
- <returnTypeC: #'long'>
oop isInteger ifFalse:[self error:'Not an integer object'].
^oop!
Item was changed:
----- Method: InterpreterProxy>>stackPositiveMachineIntegerValue: (in category 'stack access') -----
stackPositiveMachineIntegerValue: offset
+ <returnTypeC: #'usqIntptr_t'>
^self positiveMachineIntegerValueOf: (self stackValue: offset)!
Item was changed:
----- Method: InterpreterProxy>>stackSignedMachineIntegerValue: (in category 'stack access') -----
stackSignedMachineIntegerValue: offset
+ <returnTypeC: #'sqIntptr_t'>
^self signedMachineIntegerValueOf: (self stackValue: offset)!
Item was changed:
----- Method: LargeIntegersPlugin>>anyBitOfLargeInt:from:to: (in category 'util') -----
anyBitOfLargeInt: anOop from: start to: stopArg
"Argument has to be a Large Integer!!"
"Tests for any magnitude bits in the interval from start to stopArg."
| magnitude stop firstDigitIx lastDigitIx firstMask lastMask |
<var: #digit type: #'unsigned int'>
<var: #firstMask type: #'unsigned int'>
<var: #lastMask type: #'unsigned int'>
<var: #firstDigitIx type: #usqInt>
<var: #lastDigitIx type: #usqInt>
<var: #ix type: #usqInt>
self
debugCode: [self msg: 'anyBitOfLargeInt: anOop from: start to: stopArg'].
start < 1 | (stopArg < 1)
ifTrue: [^ interpreterProxy primitiveFail].
magnitude := anOop.
stop := stopArg min: (self highBitOfLargeInt: magnitude).
start > stop
ifTrue: [^ false].
firstDigitIx := start - 1 // 32 + 1.
lastDigitIx := stop - 1 // 32 + 1.
+ firstMask := 16rFFFFFFFF << (start - 1 bitAnd: 31).
- firstMask := 16rFFFFFFFF asUnsignedLong << (start - 1 bitAnd: 31). "Note asUnsignedLong required to avoid ULLL suffix bug"
lastMask := 16rFFFFFFFF >> (31 - (stop - 1 bitAnd: 31)).
firstDigitIx = lastDigitIx
ifTrue: [| digit |
digit := self unsafeDigitOfLargeInt: magnitude at: firstDigitIx.
^ (digit bitAnd: (firstMask bitAnd: lastMask))
~= 0].
((self unsafeDigitOfLargeInt: magnitude at: firstDigitIx) bitAnd: firstMask)
~= 0
ifTrue: [^ true].
firstDigitIx + 1
to: lastDigitIx - 1
do: [:ix | (self unsafeDigitOfLargeInt: magnitude at: ix)
~= 0
ifTrue: [^ true]].
((self unsafeDigitOfLargeInt: magnitude at: lastDigitIx) bitAnd: lastMask)
~= 0
ifTrue: [^ true].
^ false!
Item was changed:
----- Method: LargeIntegersPlugin>>digitSizeOfCSI: (in category 'util') -----
digitSizeOfCSI: csi
"Answer the number of 32-bits fields of a C-SmallInteger. This value is
the same as the largest legal subscript."
^(interpreterProxy maxSmallInteger <= 16r3FFFFFFF)
ifTrue: [1]
+ ifFalse: [csi > 16rFFFFFFFF asIntegerPtr "conversion is not really needed here, but avoid generating a warning in 32bits, and harmless in 64bits"
- ifFalse: [csi > 16rFFFFFFFF asLong "asLong is not really needed here, but avoid generating a warning in 32bits, and harmless in 64bits"
ifTrue: [2]
ifFalse: [csi < -16rFFFFFFFF
ifTrue: [2]
ifFalse: [1]]]!
Item was changed:
----- Method: LargeIntegersPlugin>>normalizeNegative: (in category 'oop functions') -----
normalizeNegative: aLargeNegativeInteger
"Check for leading zeroes and return shortened copy if so."
"First establish len = significant length."
| val val2 sLen digitLen byteLen oldByteLen minVal |
+ <var: #val type: #usqInt>
+ <var: #val2 type: #usqInt>
+ <var: #minVal type: #usqInt>
- <var: #val type: #'unsigned long'>
- <var: #val2 type: #'unsigned long'>
- <var: #minVal type: #'unsigned long'>
digitLen := self digitSizeOfLargeInt: aLargeNegativeInteger.
[digitLen ~= 0 and: [(self unsafeDigitOfLargeInt: aLargeNegativeInteger at: digitLen) = 0]]
whileTrue: [digitLen := digitLen - 1].
digitLen = 0 ifTrue: [^ 0 asOop: SmallInteger].
"Now check if in SmallInteger range"
val := self unsafeDigitOfLargeInt: aLargeNegativeInteger at: digitLen.
sLen := interpreterProxy minSmallInteger < -16r40000000
ifTrue: [2]
ifFalse: [1]. "SmallInteger minVal digitLength"
digitLen <= sLen
ifTrue:
[minVal := 0 - interpreterProxy minSmallInteger.
val2 := val.
digitLen > 1 ifTrue: [val2 := val2 << 32 + (self unsafeDigitOfLargeInt: aLargeNegativeInteger at: 1)].
val2 <= minVal
ifTrue: [^0 - val2 asOop: SmallInteger]].
"Return self, or a shortened copy"
byteLen := digitLen * 4.
val <= 16rFFFF
ifTrue: [byteLen := byteLen - 2]
ifFalse: [val := val >> 16].
val <= 16rFF
ifTrue: [byteLen := byteLen - 1].
oldByteLen := self byteSizeOfLargeInt: aLargeNegativeInteger.
byteLen < oldByteLen
ifTrue: [^ self largeInt: aLargeNegativeInteger growTo: byteLen]
ifFalse: [^ aLargeNegativeInteger]!
Item was changed:
----- Method: LargeIntegersPlugin>>normalizePositive: (in category 'oop functions') -----
normalizePositive: aLargePositiveInteger
"Check for leading zeroes and return shortened copy if so."
"First establish len = significant length."
| val val2 sLen digitLen byteLen oldByteLen maxVal |
+ <var: #val type: #usqInt>
+ <var: #val2 type: #usqInt>
+ <var: #maxVal type: #usqInt>
- <var: #val type: #'unsigned long'>
- <var: #val2 type: #'unsigned long'>
- <var: #maxVal type: #'unsigned long'>
digitLen := self digitSizeOfLargeInt: aLargePositiveInteger.
[digitLen ~= 0 and: [(self unsafeDigitOfLargeInt: aLargePositiveInteger at: digitLen) = 0]]
whileTrue: [digitLen := digitLen - 1].
digitLen = 0 ifTrue: [^ 0 asOop: SmallInteger].
"Now check if in SmallInteger range"
val := self unsafeDigitOfLargeInt: aLargePositiveInteger at: digitLen.
sLen := interpreterProxy maxSmallInteger > 16r3FFFFFFF
ifTrue: [2]
ifFalse: [1]. "SmallInteger maxVal digitLength"
digitLen <= sLen
ifTrue:
[maxVal := interpreterProxy maxSmallInteger.
val2 := val.
digitLen > 1 ifTrue: [val2 := val2 << 32 + (self unsafeDigitOfLargeInt: aLargePositiveInteger at: 1)].
val2 <= maxVal
ifTrue: [^val2 asOop: SmallInteger]].
"Return self, or a shortened copy"
byteLen := digitLen * 4.
val <= 16rFFFF
ifTrue: [byteLen := byteLen - 2]
ifFalse: [val := val >> 16].
val <= 16rFF
ifTrue: [byteLen := byteLen - 1].
oldByteLen := self byteSizeOfLargeInt: aLargePositiveInteger.
byteLen < oldByteLen
ifTrue: [^ self largeInt: aLargePositiveInteger growTo: byteLen]
ifFalse: [^ aLargePositiveInteger]!
Item was changed:
----- Method: MacMenubarPlugin>>primitiveCreateStandardWindowMenu: (in category 'system primitives') -----
primitiveCreateStandardWindowMenu: inOptions
<var: #menuHandle type: #MenuHandle>
| menuHandle result |
self primitive: 'primitiveCreateStandardWindowMenu'
parameters: #(SmallInteger).
self cppIf: #'TARGET_API_MAC_CARBON'
ifTrue: [result := self cCode: 'CreateStandardWindowMenu(inOptions,&menuHandle);' inSmalltalk:[0]].
+ ^interpreterProxy positiveMachineIntegerFor: (self cCoerce: menuHandle to: #'usqIntptr_t')!
- ^interpreterProxy positiveMachineIntegerFor: (self cCoerce: menuHandle to: 'long')!
Item was changed:
----- Method: MacMenubarPlugin>>primitiveDisposeMenuBar: (in category 'system primitives') -----
primitiveDisposeMenuBar: menuHandleOop
<var: #menuBarHandle type: #Handle>
| menuBarHandle |
self primitive: 'primitiveDisposeMenuBar'
parameters: #(Oop).
+ menuBarHandle := self cCoerce: (interpreterProxy positiveMachineIntegerValueOf: menuHandleOop) to: #Handle.
- menuBarHandle := self cCoerce: (interpreterProxy positive32BitValueOf: menuHandleOop) to: #Handle.
self cppIf: #'TARGET_API_MAC_CARBON'
ifTrue: [self cCode: 'DisposeMenuBar(menuBarHandle);' inSmalltalk: [menuBarHandle]]
ifFalse: [self cCode: 'DisposeHandle(menuBarHandle);' inSmalltalk: [menuBarHandle]].
^nil
!
Item was changed:
----- Method: MacMenubarPlugin>>primitiveGetIndMenuWithCommandID:commandID: (in category 'system primitives') -----
primitiveGetIndMenuWithCommandID: menuHandleOop commandID: aCommandID
<var: #menuHandle type: #MenuHandle>
<var: #commandID type: #MenuCommand>
<var: #applicationMenu type: #MenuHandle>
<var: #outIndex type: #MenuItemIndex>
| menuHandle commandID applicationMenu outIndex |
self primitive: 'primitiveGetIndMenuWithCommandID'
parameters: #(Oop Oop).
menuHandle := self cCoerce: (interpreterProxy positiveMachineIntegerValueOf: menuHandleOop) to: 'MenuHandle'.
commandID := self cCoerce: (interpreterProxy positive32BitValueOf: aCommandID) to: 'MenuCommand'.
(self ioCheckMenuHandle: menuHandle) ifFalse: [^interpreterProxy success: false].
self cppIf: #'TARGET_API_MAC_CARBON'
ifTrue: [self cCode: 'GetIndMenuItemWithCommandID(menuHandle, kHICommandHide, 1,
&applicationMenu, &outIndex);' inSmalltalk: [menuHandle]].
outIndex asSmallIntegerObj. "to avoid elimination of the variable..."
+ ^interpreterProxy positiveMachineIntegerFor: (self cCoerce: applicationMenu to: #'usqIntptr_t')
- ^interpreterProxy positiveMachineIntegerFor: (self cCoerce: applicationMenu to: 'long')
!
Item was changed:
----- Method: MacMenubarPlugin>>primitiveGetMenuBar (in category 'system primitives') -----
primitiveGetMenuBar
<var: #menuHandle type: #Handle>
| menuHandle |
self primitive: 'primitiveGetMenuBar'
parameters: #().
menuHandle := self cCode: 'GetMenuBar()' inSmalltalk:[0].
+ ^interpreterProxy positiveMachineIntegerFor: (self cCoerce: menuHandle to: #'usqIntptr_t')!
- ^interpreterProxy positiveMachineIntegerFor: (self cCoerce: menuHandle to: 'long')!
Item was changed:
----- Method: MacMenubarPlugin>>primitiveGetMenuHandle: (in category 'system primitives') -----
primitiveGetMenuHandle: menuID
<var: #menuHandle type: #MenuHandle>
<var: #menuID type: #MenuID>
| menuHandle |
self primitive: 'primitiveGetMenuHandle'
parameters: #(SmallInteger).
menuHandle := self cCode: 'GetMenuHandle(menuID)' inSmalltalk:[0].
+ ^interpreterProxy positiveMachineIntegerFor: (self cCoerce: menuHandle to: #'usqIntptr_t')!
- ^interpreterProxy positiveMachineIntegerFor: (self cCoerce: menuHandle to: 'long')!
Item was changed:
----- Method: MacMenubarPlugin>>primitiveNewMenu:menuTitle: (in category 'system primitives') -----
primitiveNewMenu: menuID menuTitle: menuTitle
<var: #menuHandle type: #MenuHandle>
<var: #constStr255 type: #ConstStr255Param>
<var: #menuID type: #MenuID>
| menuHandle constStr255 |
self primitive: 'primitiveNewMenu'
parameters: #(SmallInteger ByteArray).
constStr255 := self cCoerce: menuTitle to: #ConstStr255Param.
menuHandle := self cCode: 'NewMenu(menuID,constStr255)' inSmalltalk:[0].
+ ^interpreterProxy positiveMachineIntegerFor: (self cCoerce: menuHandle to: #'usqIntptr_t')!
- ^interpreterProxy positiveMachineIntegerFor: (self cCoerce: menuHandle to: 'long')!
Item was changed:
----- Method: QuicktimePlugin>>primitiveSetGWorldPtrOntoExistingSurface:gWorld:width:height:rowBytes:depth:movie: (in category 'system primitives') -----
primitiveSetGWorldPtrOntoExistingSurface: surfaceID gWorld: bitMapPtr width: width height: height rowBytes: rowBytes depth: depth movie: moviePtr
| buffer movie |
<var: #buffer type: #'char *'>
+ <var: #movie type: #'sqIntptr_t'>
- <var: #movie type: #'long'>
self primitive: 'primitiveSetGWorldPtrOntoExistingSurface' parameters:#(SmallInteger Oop SmallInteger SmallInteger SmallInteger SmallInteger Oop).
buffer := self cCoerce: (interpreterProxy positiveMachineIntegerValueOf: bitMapPtr) to: 'char *'.
+ movie := self cCoerce: (interpreterProxy positiveMachineIntegerValueOf: moviePtr) to: #'sqIntptr_t'.
- movie := self cCoerce: (interpreterProxy positiveMachineIntegerValueOf: moviePtr) to: 'long'.
self stQuicktimeSetToExistingSurface: surfaceID gworld: buffer width: width height: height rowBytes: rowBytes depth: depth movie: movie.
!
Item was changed:
----- Method: QuicktimePlugin>>primitiveSetGWorldPtrOntoSurface:width:height:rowBytes:depth:movie: (in category 'system primitives') -----
primitiveSetGWorldPtrOntoSurface: bitMapPtr width: width height: height rowBytes: rowBytes depth: depth movie: moviePtr
| buffer movie results |
<var: #buffer type: #'char *'>
+ <var: #movie type: #'sqIntptr_t'>
- <var: #movie type: #'long'>
self primitive: 'primitiveSetGWorldPtrOntoSurface' parameters:#(Oop SmallInteger SmallInteger SmallInteger SmallInteger Oop).
buffer := self cCoerce: (interpreterProxy positiveMachineIntegerValueOf: bitMapPtr) to: 'char *'.
+ movie := self cCoerce: (interpreterProxy positiveMachineIntegerValueOf: moviePtr) to: #'sqIntptr_t'.
- movie := self cCoerce: (interpreterProxy positiveMachineIntegerValueOf: moviePtr) to: 'long'.
results := self stQuicktimeSetSurface: buffer width: width height: height rowBytes: rowBytes depth: depth movie: movie.
^results asOop: SmallInteger !
Item was changed:
----- Method: SimpleStackBasedCogit>>compileInterpreterPrimitive: (in category 'primitive generators') -----
compileInterpreterPrimitive: primitiveRoutine
"Compile a call to an interpreter primitive. Call the C routine with the
usual stack-switching dance, test the primFailCode and then either
return on success or continue to the method body."
<var: #primitiveRoutine declareC: 'void (*primitiveRoutine)(void)'>
| flags jmp jmpSamplePrim continuePostSamplePrim jmpSampleNonPrim continuePostSampleNonPrim |
<var: #jmp type: #'AbstractInstruction *'>
<var: #jmpSamplePrim type: #'AbstractInstruction *'>
<var: #jmpSampleNonPrim type: #'AbstractInstruction *'>
<var: #continuePostSamplePrim type: #'AbstractInstruction *'>
<var: #continuePostSampleNonPrim type: #'AbstractInstruction *'>
"Save processor fp, sp and return pc in the interpreter's frame stack and instruction pointers"
self genExternalizePointersForPrimitiveCall.
"Switch to the C stack."
self genLoadCStackPointersForPrimCall.
flags := coInterpreter primitivePropertyFlags: primitiveIndex.
(flags anyMask: PrimCallDoNotJIT) ifTrue:
[^ShouldNotJIT].
(flags anyMask: PrimCallCollectsProfileSamples) ifTrue:
["Test nextProfileTick for being non-zero and call checkProfileTick if so"
objectMemory wordSize = 4
ifTrue:
[self MoveAw: coInterpreter nextProfileTickAddress R: TempReg.
self MoveAw: coInterpreter nextProfileTickAddress + objectMemory wordSize R: ClassReg.
self OrR: TempReg R: ClassReg]
ifFalse:
[self MoveAw: coInterpreter nextProfileTickAddress R: TempReg.
self CmpCq: 0 R: TempReg].
"If set, jump to record sample call."
jmpSampleNonPrim := self JumpNonZero: 0.
continuePostSampleNonPrim := self Label].
"Old full prim trace is in VMMaker-eem.550 and prior"
self recordPrimTrace ifTrue:
[self genFastPrimTraceUsing: ClassReg and: SendNumArgsReg].
"Clear the primFailCode and set argumentCount"
self MoveCq: 0 R: TempReg.
self MoveR: TempReg Aw: coInterpreter primFailCodeAddress.
methodOrBlockNumArgs ~= 0 ifTrue:
[self MoveCq: methodOrBlockNumArgs R: TempReg].
self MoveR: TempReg Aw: coInterpreter argumentCountAddress.
"If required, set primitiveFunctionPointer and newMethod"
(flags anyMask: PrimCallNeedsPrimitiveFunction) ifTrue:
[self MoveCw: primitiveRoutine asInteger R: TempReg.
primSetFunctionLabel :=
self MoveR: TempReg Aw: coInterpreter primitiveFunctionPointerAddress].
(flags anyMask: PrimCallNeedsNewMethod+PrimCallMayCallBack) ifTrue:
["The ceActivateFailingPrimitiveMethod: machinery can't handle framelessness."
(flags anyMask: PrimCallMayCallBack) ifTrue:
[needsFrame := true].
methodLabel addDependent:
(self annotateAbsolutePCRef:
(self MoveCw: methodLabel asInteger R: ClassReg)).
self MoveMw: (self offset: CogMethod of: #methodObject) r: ClassReg R: TempReg.
self MoveR: TempReg Aw: coInterpreter newMethodAddress].
"Invoke the primitive"
self PrefetchAw: coInterpreter primFailCodeAddress.
(flags anyMask: PrimCallMayCallBack)
ifTrue: "Sideways call the C primitive routine so that we return through cePrimReturnEnterCogCode."
["On Spur ceActivateFailingPrimitiveMethod: would like to retry if forwarders
are found. So insist on PrimCallNeedsPrimitiveFunction being set too."
self assert: (flags anyMask: PrimCallNeedsPrimitiveFunction).
backEnd genSubstituteReturnAddress:
((flags anyMask: PrimCallCollectsProfileSamples)
ifTrue: [cePrimReturnEnterCogCodeProfiling]
ifFalse: [cePrimReturnEnterCogCode]).
primInvokeInstruction := self JumpFullRT: primitiveRoutine asInteger.
jmp := jmpSamplePrim := continuePostSamplePrim := nil]
ifFalse:
["Call the C primitive routine."
primInvokeInstruction := self CallFullRT: primitiveRoutine asInteger.
(flags anyMask: PrimCallCollectsProfileSamples) ifTrue:
[self assert: (flags anyMask: PrimCallNeedsNewMethod).
"Test nextProfileTick for being non-zero and call checkProfileTick if so"
objectMemory wordSize = 4
ifTrue:
[self MoveAw: coInterpreter nextProfileTickAddress R: TempReg.
self MoveAw: coInterpreter nextProfileTickAddress + objectMemory wordSize R: ClassReg.
self OrR: TempReg R: ClassReg]
ifFalse:
[self MoveAw: coInterpreter nextProfileTickAddress R: TempReg.
self CmpCq: 0 R: TempReg].
"If set, jump to record sample call."
jmpSamplePrim := self JumpNonZero: 0.
continuePostSamplePrim := self Label].
objectRepresentation maybeCompileRetryOnPrimitiveFail: primitiveIndex.
self maybeCompileAllocFillerCheck.
"Switch back to the Smalltalk stack. Stack better be in either of these two states:
success: stackPointer -> result (was receiver)
arg1
...
argN
return pc
failure: receiver
arg1
...
stackPointer -> argN
return pc
In either case we can push the instructionPointer or load it into the LinkRegister to reestablish the return pc"
self MoveAw: coInterpreter instructionPointerAddress
R: (backEnd hasLinkRegister ifTrue: [LinkReg] ifFalse: [ClassReg]).
backEnd genLoadStackPointers.
"Test primitive failure"
self MoveAw: coInterpreter primFailCodeAddress R: TempReg.
backEnd hasLinkRegister ifFalse: [self PushR: ClassReg]. "Restore return pc on CISCs"
self flag: 'ask concrete code gen if move sets condition codes?'.
self CmpCq: 0 R: TempReg.
jmp := self JumpNonZero: 0.
"Fetch result from stack"
self MoveMw: (backEnd hasLinkRegister ifTrue: [0] ifFalse: [objectMemory wordSize])
r: SPReg
R: ReceiverResultReg.
self RetN: objectMemory wordSize]. "return to caller, popping receiver"
(flags anyMask: PrimCallCollectsProfileSamples) ifTrue:
["The sample is collected by cePrimReturnEnterCogCode for external calls"
jmpSamplePrim ifNotNil:
["Call ceCheckProfileTick: to record sample and then continue."
jmpSamplePrim jmpTarget: self Label.
self assert: (flags anyMask: PrimCallNeedsNewMethod).
+ self CallFullRT: (self cCode: [#ceCheckProfileTick asUnsignedIntegerPtr]
- self CallFullRT: (self cCode: [#ceCheckProfileTick asUnsignedLong]
inSmalltalk: [self simulatedTrampolineFor: #ceCheckProfileTick]).
"reenter the post-primitive call flow"
self Jump: continuePostSamplePrim].
"Null newMethod and call ceCheckProfileTick: to record sample and then continue.
ceCheckProfileTick will map null/0 to coInterpreter nilObject"
jmpSampleNonPrim jmpTarget: self Label.
self MoveCq: 0 R: TempReg.
self MoveR: TempReg Aw: coInterpreter newMethodAddress.
+ self CallFullRT: (self cCode: [#ceCheckProfileTick asUnsignedIntegerPtr]
- self CallFullRT: (self cCode: [#ceCheckProfileTick asUnsignedLong]
inSmalltalk: [self simulatedTrampolineFor: #ceCheckProfileTick]).
"reenter the post-primitive call flow"
self Jump: continuePostSampleNonPrim].
jmp ifNotNil:
["Jump to restore of receiver reg and proceed to frame build for failure."
jmp jmpTarget: self Label.
"Restore receiver reg from stack. If on RISCs ret pc is in LinkReg, if on CISCs ret pc is on stack."
self MoveMw: objectMemory wordSize * (methodOrBlockNumArgs + (backEnd hasLinkRegister ifTrue: [0] ifFalse: [1]))
r: SPReg
R: ReceiverResultReg].
^0!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPrimReturnEnterCogCodeEnilopmart: (in category 'initialization') -----
genPrimReturnEnterCogCodeEnilopmart: profiling
"Generate the substitute return code for an external or FFI primitive call.
On success simply return, extracting numArgs from newMethod.
On primitive failure call ceActivateFailingPrimitiveMethod: newMethod."
| jmpSample continuePostSample jmpFail |
<var: #jmpSample type: #'AbstractInstruction *'>
<var: #continuePostSample type: #'AbstractInstruction *'>
<var: #jmpFail type: #'AbstractInstruction *'>
self zeroOpcodeIndex.
backEnd hasVarBaseRegister ifTrue:
[self MoveCq: self varBaseAddress R: VarBaseReg]. "Must happen sometime"
profiling ifTrue:
["Test nextProfileTick for being non-zero and call checkProfileTick: if so.
N.B. nextProfileTick is 64-bits so 32-bit systems need to test both halves."
objectMemory wordSize = 4
ifTrue:
[self MoveAw: coInterpreter nextProfileTickAddress R: TempReg.
self MoveAw: coInterpreter nextProfileTickAddress + objectMemory wordSize R: ClassReg.
self OrR: TempReg R: ClassReg]
ifFalse:
[self MoveAw: coInterpreter nextProfileTickAddress R: TempReg.
self CmpCq: 0 R: TempReg].
"If set, jump to record sample call."
jmpSample := self JumpNonZero: 0.
continuePostSample := self Label].
self maybeCompileAllocFillerCheck.
"Test primitive failure"
self MoveAw: coInterpreter primFailCodeAddress R: TempReg.
self flag: 'ask concrete code gen if move sets condition codes?'.
self CmpCq: 0 R: TempReg.
jmpFail := self JumpNonZero: 0.
"Switch back to the Smalltalk stack. Stack better be in either of these two states:
success: stackPointer -> result (was receiver)
arg1
...
argN
return pc
failure: receiver
arg1
...
stackPointer -> argN
return pc
We push the instructionPointer to reestablish the return pc in the success case,
but leave it to ceActivateFailingPrimitiveMethod: to do so in the failure case."
backEnd hasLinkRegister
ifTrue:
[backEnd genLoadStackPointers. "Switch back to Smalltalk stack."
backEnd hasPCRegister
ifTrue:
[self PopR: ReceiverResultReg. "Pop result from stack"
self MoveAw: coInterpreter instructionPointerAddress R: PCReg] "Return"
ifFalse:
[self MoveMw: 0 r: SPReg R: ReceiverResultReg. "Fetch result from stack"
self MoveAw: coInterpreter instructionPointerAddress R: LinkReg. "Get ret pc"
self RetN: objectMemory wordSize]] "Return, popping result from stack"
ifFalse:
[self MoveAw: coInterpreter instructionPointerAddress R: ClassReg. "Get return pc"
backEnd genLoadStackPointers. "Switch back to Smalltalk stack."
self MoveMw: 0 r: SPReg R: ReceiverResultReg. "Fetch result from stack"
self MoveR: ClassReg Mw: 0 r: SPReg. "Restore return pc"
self RetN: 0]. "Return, popping result from stack"
"Primitive failed. Invoke C code to build the frame and continue."
jmpFail jmpTarget: (self MoveAw: coInterpreter newMethodAddress R: SendNumArgsReg).
"Reload sp with CStackPointer; easier than popping args of checkProfileTick."
self MoveAw: self cStackPointerAddress R: SPReg.
self
compileCallFor: #ceActivateFailingPrimitiveMethod:
numArgs: 1
arg: SendNumArgsReg
arg: nil
arg: nil
arg: nil
resultReg: NoReg
regsToSave: self emptyRegisterMask.
"On Spur ceActivateFailingPrimitiveMethod: may retry the primitive and return if successful.
So continue by returning to the caller.
Switch back to the Smalltalk stack. Stack should be in this state:
success: stackPointer -> result (was receiver)
arg1
...
argN
return pc
We can push the instructionPointer or load it into the LinkRegister to reestablish the return pc"
self MoveAw: coInterpreter instructionPointerAddress
R: (backEnd hasLinkRegister ifTrue: [LinkReg] ifFalse: [ClassReg]).
backEnd genLoadStackPointers.
backEnd hasLinkRegister
ifTrue:
[self MoveMw: 0 r: SPReg R: ReceiverResultReg] "Fetch result from stack"
ifFalse:
[self MoveMw: objectMemory wordSize r: SPReg R: ReceiverResultReg. "Fetch result from stack"
self PushR: ClassReg]. "Restore return pc on CISCs"
self RetN: objectMemory wordSize. "return to caller, popping receiver"
profiling ifTrue:
["Call ceCheckProfileTick: to record sample and then continue. newMethod
should be up-to-date. Need to save and restore the link reg around this call."
jmpSample jmpTarget: self Label.
backEnd saveAndRestoreLinkRegAround:
+ [self CallFullRT: (self cCode: '(usqIntptr_t)ceCheckProfileTick'
- [self CallFullRT: (self cCode: '(unsigned long)ceCheckProfileTick'
inSmalltalk: [self simulatedTrampolineFor: #ceCheckProfileTick])].
self Jump: continuePostSample]!
Item was changed:
----- Method: SistaCogit>>picDataFor:Annotation:Mcpc:Bcpc:Method: (in category 'method introspection') -----
picDataFor: descriptor Annotation: isBackwardBranchAndAnnotation Mcpc: mcpc Bcpc: bcpc Method: cogMethodArg
<var: #descriptor type: #'BytecodeDescriptor *'>
<var: #mcpc type: #'char *'>
<var: #cogMethodArg type: #'void *'>
| annotation entryPoint tuple counter |
+ <var: #counter type: #usqInt>
- <var: #counter type: #'unsigned long'>
descriptor ifNil:
[^0].
descriptor isBranch ifTrue:
["it's a branch; conditional?"
(descriptor isBranchTrue or: [descriptor isBranchFalse]) ifTrue:
[counter := (self
cCoerce: ((self
cCoerceSimple: cogMethodArg
to: #'CogMethod *') counters)
+ to: #'usqInt *')
- to: #'unsigned long *')
at: counterIndex.
tuple := self picDataForCounter: counter at: bcpc + 1.
tuple = 0 ifTrue: [^PrimErrNoMemory].
objectMemory storePointer: introspectionDataIndex ofObject: introspectionData withValue: tuple.
introspectionDataIndex := introspectionDataIndex + 1.
counterIndex := counterIndex + 1].
^0].
annotation := isBackwardBranchAndAnnotation >> 1.
((self isPureSendAnnotation: annotation)
and: [entryPoint := backEnd callTargetFromReturnAddress: mcpc asUnsignedInteger.
entryPoint > methodZoneBase]) ifFalse: "send is not linked, or is not a send"
[^0].
self targetMethodAndSendTableFor: entryPoint "It's a linked send; find which kind."
annotation: annotation
into: [:targetMethod :sendTable| | methodClassIfSuper association |
methodClassIfSuper := nil.
sendTable = superSendTrampolines ifTrue:
[methodClassIfSuper := coInterpreter methodClassOf: (self cCoerceSimple: cogMethodArg to: #'CogMethod *') methodObject].
sendTable = directedSuperSendTrampolines ifTrue:
[association := backEnd literalBeforeInlineCacheTagAt: mcpc asUnsignedInteger.
methodClassIfSuper := objectRepresentation valueOfAssociation: association].
tuple := self picDataForSendTo: targetMethod
methodClassIfSuper: methodClassIfSuper
at: mcpc
bcpc: bcpc + 1].
tuple = 0 ifTrue: [^PrimErrNoMemory].
objectMemory storePointer: introspectionDataIndex ofObject: introspectionData withValue: tuple.
introspectionDataIndex := introspectionDataIndex + 1.
^0!
Item was changed:
----- Method: SistaCogit>>picDataForCounter:at: (in category 'method introspection') -----
picDataForCounter: counter at: bcpc
| executedCount tuple untakenCount |
+ <var: #counter type: #usqInt>
- <var: #counter type: #'unsigned long'>
tuple := objectMemory
eeInstantiateClassIndex: ClassArrayCompactIndex
format: objectMemory arrayFormat
numSlots: 3.
tuple = 0 ifTrue:
[^0].
self assert: CounterBytes = 4.
executedCount := initialCounterValue - (counter >> 16).
untakenCount := initialCounterValue - (counter bitAnd: 16rFFFF).
objectMemory
storePointerUnchecked: 0 ofObject: tuple withValue: (objectMemory integerObjectOf: bcpc);
storePointerUnchecked: 1 ofObject: tuple withValue: (objectMemory integerObjectOf: executedCount);
storePointerUnchecked: 2 ofObject: tuple withValue: (objectMemory integerObjectOf: untakenCount).
^tuple!
Item was changed:
----- Method: SmartSyntaxPluginCodeGenerator>>generateCPtrAsOop:on:indent: (in category 'translating builtins') -----
generateCPtrAsOop: aNode on: aStream indent: anInteger
+ aStream nextPutAll: '((sqInt)(sqIntptr_t)('.
- aStream nextPutAll: '((sqInt)(long)('.
self emitCExpression: aNode receiver on: aStream.
aStream nextPutAll: ') - BaseHeaderSize)'!
Item was changed:
----- Method: Spur32BitMemoryManager>>integerObjectOfCharacterObject: (in category 'immediates') -----
integerObjectOfCharacterObject: oop
"Immediate characters are unsigned"
+ ^(self cCoerceSimple: oop to: #usqInt) >> 1!
- ^(self cCoerceSimple: oop to: #'unsigned long') >> 1!
Item was changed:
----- Method: Spur64BitMemoryManager>>oldRawNumSlotsOf: (in category 'object access') -----
oldRawNumSlotsOf: objOop
<returnTypeC: #usqInt>
<inline: true>
+ ^(self longAt: objOop) asUnsignedInteger >> self numSlotsFullShift!
- ^(self longAt: objOop) asUnsignedLong >> self numSlotsFullShift!
Item was changed:
----- Method: Spur64BitMemoryManager>>rawOverflowSlotsOf: (in category 'object access') -----
rawOverflowSlotsOf: objOop
<returnTypeC: #usqLong>
<inline: true>
self flag: #endianness.
^self
+ cCode: [((self longAt: objOop - self baseHeaderSize) << 8) asUnsignedInteger >> 8]
- cCode: [((self longAt: objOop - self baseHeaderSize) << 8) asUnsignedLong >> 8]
inSmalltalk: [(self longAt: objOop - self baseHeaderSize) bitAnd: 16rFFFFFFFFFFFFFF]!
Item was changed:
----- Method: Spur64BitMemoryManager>>rotateRight: (in category 'interpreter access') -----
rotateRight: anInteger
+ ^(self cCode: [anInteger] inSmalltalk: [anInteger bitAnd: 1]) << 63 + (anInteger asUnsignedInteger >> 1)!
- ^(self cCode: [anInteger] inSmalltalk: [anInteger bitAnd: 1]) << 63 + (anInteger asUnsignedLong >> 1)!
Item was changed:
----- Method: SpurMemoryManager class>>declareCVarsIn: (in category 'translation') -----
declareCVarsIn: aCCodeGenerator
self declareCAsOop: #( memory freeStart scavengeThreshold newSpaceStart newSpaceLimit pastSpaceStart
lowSpaceThreshold freeOldSpaceStart oldSpaceStart endOfMemory firstFreeChunk lastFreeChunk)
in: aCCodeGenerator.
self declareCAsUSqLong: (self allInstVarNames select: [:ivn| ivn endsWith: 'Usecs'])
in: aCCodeGenerator.
aCCodeGenerator
var: #freeListsMask type: #usqInt;
var: #freeLists type: #'sqInt *';
var: #objStackInvalidBecause type: #'char *';
var: #unscannedEphemerons type: #SpurContiguousObjStack;
var: #heapGrowthToSizeGCRatio type: #float;
var: #heapSizeAtPreviousGC type: #usqInt;
var: #totalFreeOldSpace type: #usqInt;
+ var: #maxOldSpaceSize type: #usqInt.
- var: #maxOldSpaceSize type: #'unsigned long'.
aCCodeGenerator
var: #remapBuffer
declareC: 'sqInt remapBuffer[RemapBufferSize + 1 /* ', (RemapBufferSize + 1) printString, ' */]'.
aCCodeGenerator
var: #extraRoots
declareC: 'sqInt *extraRoots[ExtraRootsSize + 1 /* ', (ExtraRootsSize + 1) printString, ' */]'!
Item was changed:
----- Method: SpurMemoryManager>>byteSizeOfInstanceOf:withIndexableSlots:errInto: (in category 'indexing primitive support') -----
byteSizeOfInstanceOf: classObj withIndexableSlots: nElements errInto: errorBlock
| instSpec classFormat numSlots |
<var: 'numSlots' type: #usqInt>
classFormat := self formatOfClass: classObj.
instSpec := self instSpecOfClassFormat: classFormat.
instSpec caseOf: {
[self arrayFormat] ->
[numSlots := nElements].
[self indexablePointersFormat] ->
[numSlots := (self fixedFieldsOfClassFormat: classFormat) + nElements].
[self weakArrayFormat] ->
[numSlots := (self fixedFieldsOfClassFormat: classFormat) + nElements].
[self sixtyFourBitIndexableFormat] ->
[numSlots := self bytesPerOop = 4 ifTrue: [nElements * 2] ifFalse: [nElements]].
[self firstLongFormat] ->
[numSlots := self bytesPerOop = 4 ifTrue: [nElements] ifFalse: [nElements + 1 // 2]].
[self firstShortFormat] ->
[numSlots := self bytesPerOop = 4 ifTrue: [nElements + 1 // 2] ifFalse: [nElements + 3 // 4]].
[self firstByteFormat] ->
[numSlots := nElements + (self bytesPerOop - 1) // self bytesPerOop].
[self firstCompiledMethodFormat] -> "Assume nElements is derived from CompiledMethod>>basicSize."
[numSlots := nElements + (self bytesPerOop - 1) // self bytesPerOop] }
otherwise: [^errorBlock value: PrimErrBadReceiver negated]. "non-indexable"
+ numSlots >= (1 asIntegerPtr << (self bytesPerOop * 8 - self logBytesPerOop)) ifTrue:
- numSlots >= (1 asLong << (self bytesPerOop * 8 - self logBytesPerOop)) ifTrue:
[^errorBlock value: (nElements < 0 ifTrue: [PrimErrBadArgument] ifFalse: [PrimErrLimitExceeded])].
^self objectBytesForSlots: numSlots!
Item was changed:
----- Method: SpurMemoryManager>>printOopsFrom:to: (in category 'debug printing') -----
printOopsFrom: startAddress to: endAddress
<api>
| oop limit |
oop := self objectBefore: startAddress.
+ limit := endAddress asUnsignedIntegerPtr min: endOfMemory.
- limit := endAddress asUnsignedLong min: endOfMemory.
oop := oop
ifNil: [startAddress]
ifNotNil: [(self objectAfter: oop) = startAddress
ifTrue: [startAddress]
ifFalse: [oop]].
[self oop: oop isLessThan: limit] whileTrue:
[coInterpreter
printHex: oop; print: '/'; printNum: oop; space;
print: ((self isFreeObject: oop) ifTrue: ['free'] ifFalse:
[(self isSegmentBridge: oop) ifTrue: ['bridge'] ifFalse:
[(self isForwarded: oop) ifTrue: ['forwarder'] ifFalse:
['object']]]);
cr.
oop := self objectAfter: oop]!
Item was changed:
----- Method: SpurMemoryManager>>setMaxOldSpaceSize: (in category 'accessing') -----
setMaxOldSpaceSize: limit
+ <var: #limit type: #usqInt>
- <var: #limit type: #'unsigned long'>
maxOldSpaceSize := limit.
^0!
Item was changed:
----- Method: SpurSegmentManager>>addSegmentOfSize: (in category 'growing/shrinking memory') -----
addSegmentOfSize: ammount
<returnTypeC: #'SpurSegmentInfo *'>
<inline: false>
| allocatedSize |
<var: #newSeg type: #'SpurSegmentInfo *'>
<var: #segAddress type: #'void *'>
<var: #allocatedSize type: #'usqInt'>
self cCode: [] inSmalltalk: [segments ifNil: [^nil]]. "bootstrap"
(manager "sent to the manager so that the simulator can increase memory to simulate a new segment"
sqAllocateMemorySegmentOfSize: ammount
Above: (self firstGapOfSizeAtLeast: ammount)
AllocatedSizeInto: (self cCode: [self addressOf: allocatedSize]
inSmalltalk: [[:sz| allocatedSize := sz]])) ifNotNil:
[:segAddress| | newSegIndex newSeg |
+ newSegIndex := self insertSegmentFor: segAddress asUnsignedIntegerPtr.
- newSegIndex := self insertSegmentFor: segAddress asUnsignedLong.
newSeg := self addressOf: (segments at: newSegIndex).
newSeg
+ segStart: segAddress asUnsignedIntegerPtr;
- segStart: segAddress asUnsignedLong;
segSize: allocatedSize.
self bridgeFrom: (self addressOf: (segments at: newSegIndex - 1)) to: newSeg.
self bridgeFrom: newSeg to: (newSegIndex = (numSegments - 1) ifFalse:
[self addressOf: (segments at: newSegIndex + 1)]).
"test isInMemory:"
0 to: numSegments - 1 do:
[:i|
self assert: (self isInSegments: (segments at: i) segStart).
self assert: (self isInSegments: (segments at: i) segLimit - manager wordSize).
self assert: ((self isInSegments: (segments at: i) segLimit) not
or: [i < (numSegments - 1)
and: [(segments at: i) segLimit = (segments at: i + 1) segStart]]).
self assert: ((self isInSegments: (segments at: i) segStart - manager wordSize) not
or: [i > 0
and: [(segments at: i - 1) segLimit = (segments at: i) segStart]])].
^newSeg].
^nil!
Item was changed:
----- Method: SpurSegmentManager>>findEmptySegNearestInSizeTo: (in category 'growing/shrinking memory') -----
findEmptySegNearestInSizeTo: size
| seg best delta |
<var: #seg type: #'SpurSegmentInfo *'>
<var: #best type: #'SpurSegmentInfo *'>
best := nil.
delta := size.
0 to: numSegments - 1 do:
[:i|
seg := self addressOf: (segments at: i).
(self isEmptySegment: seg) ifTrue:
[best
ifNil: [best := seg]
ifNotNil:
[(size >= (seg segSize * 0.75)
+ and: [(self cCoerce: (seg segSize - size) to: #sqInt ) abs < delta]) ifTrue:
- and: [(seg segSize - size) abs < delta]) ifTrue:
[best := seg. delta := (seg segSize - size) abs]]]].
^best!
Item was changed:
----- Method: StackInterpreter class>>declareCVarsIn: (in category 'translation') -----
declareCVarsIn: aCCodeGenerator
| vmClass |
self class == thisContext methodClass ifFalse: [^self]. "Don't duplicate decls in subclasses"
vmClass := aCCodeGenerator vmClass. "Generate primitiveTable etc based on vmClass, not just StackInterpreter"
aCCodeGenerator
addHeaderFile:'<stddef.h> /* for e.g. alloca */';
addHeaderFile:'<setjmp.h>';
addHeaderFile:'<wchar.h> /* for wint_t */';
addHeaderFile:'"vmCallback.h"';
addHeaderFile:'"sqMemoryFence.h"';
addHeaderFile:'"dispdbg.h"'.
vmClass declareInterpreterVersionIn: aCCodeGenerator defaultName: 'Stack'.
aCCodeGenerator
var: #interpreterProxy type: #'struct VirtualMachine*'.
aCCodeGenerator
declareVar: #sendTrace type: 'volatile int';
+ declareVar: #byteCount type: #usqInt.
- declareVar: #byteCount type: 'unsigned long'.
"These need to be pointers or unsigned."
self declareC: #(instructionPointer method newMethod)
as: #usqInt
in: aCCodeGenerator.
"These are all pointers; char * because Slang has no support for C pointer arithmetic."
self declareC: #(localIP localSP localFP stackPointer framePointer stackLimit breakSelector)
as: #'char *'
in: aCCodeGenerator.
aCCodeGenerator
var: #breakSelectorLength
declareC: 'sqInt breakSelectorLength = MinSmallInteger'.
self declareC: #(stackPage overflowedPage)
as: #'StackPage *'
in: aCCodeGenerator.
aCCodeGenerator removeVariable: 'stackPages'. "this is an implicit receiver in the translated code."
NewspeakVM ifFalse:
[aCCodeGenerator
removeVariable: 'localAbsentReceiver';
removeVariable: 'localAbsentReceiverOrZero';
removeVariable: 'nsMethodCache'].
"This defines bytecodeSetSelector as 0 if MULTIPLEBYTECODESETS
is not defined, for the benefit of the interpreter on slow machines."
aCCodeGenerator addConstantForBinding: (self bindingOf: #MULTIPLEBYTECODESETS).
MULTIPLEBYTECODESETS == false ifTrue:
[aCCodeGenerator
removeVariable: 'extA';
removeVariable: 'extB';
removeVariable: 'bytecodeSetSelector'].
aCCodeGenerator
var: #methodCache
+ declareC: 'sqIntptr_t methodCache[MethodCacheSize + 1 /* ', (MethodCacheSize + 1) printString, ' */]'.
- declareC: 'long methodCache[MethodCacheSize + 1 /* ', (MethodCacheSize + 1) printString, ' */]'.
aCCodeGenerator
var: #nsMethodCache
+ declareC: 'sqIntptr_t nsMethodCache[NSMethodCacheSize + 1 /* ', (NSMethodCacheSize + 1) printString, ' */]'.
- declareC: 'long nsMethodCache[NSMethodCacheSize + 1 /* ', (NSMethodCacheSize + 1) printString, ' */]'.
AtCacheTotalSize isInteger ifTrue:
[aCCodeGenerator
var: #atCache
declareC: 'sqInt atCache[AtCacheTotalSize + 1 /* ', (AtCacheTotalSize + 1) printString, ' */]'].
aCCodeGenerator
var: #primitiveTable
declareC: 'void (*primitiveTable[MaxPrimitiveIndex + 2 /* ', (MaxPrimitiveIndex + 2) printString, ' */])(void) = ', vmClass primitiveTableString.
vmClass primitiveTable do:
[:symbolOrNot|
(symbolOrNot isSymbol
and: [symbolOrNot ~~ #primitiveFail]) ifTrue:
[(aCCodeGenerator methodNamed: symbolOrNot) ifNotNil:
[:tMethod| tMethod returnType: #void]]].
vmClass objectMemoryClass hasSpurMemoryManagerAPI
ifTrue:
[aCCodeGenerator
var: #primitiveAccessorDepthTable
type: 'signed char'
sizeString: 'MaxPrimitiveIndex + 2 /* ', (MaxPrimitiveIndex + 2) printString, ' */'
array: vmClass primitiveAccessorDepthTable]
ifFalse:
[aCCodeGenerator removeVariable: #primitiveAccessorDepthTable].
aCCodeGenerator
var: #primitiveFunctionPointer
declareC: 'void (*primitiveFunctionPointer)()'.
aCCodeGenerator
var: #externalPrimitiveTable
declareC: 'void (*externalPrimitiveTable[MaxExternalPrimitiveTableSize + 1 /* ', (MaxExternalPrimitiveTableSize + 1) printString, ' */])(void)'.
aCCodeGenerator var: #showSurfaceFn type: #'void *'.
aCCodeGenerator
var: #jmpBuf
declareC: 'jmp_buf jmpBuf[MaxJumpBuf + 1 /* ', (MaxJumpBuf + 1) printString, ' */]'.
aCCodeGenerator
var: #suspendedCallbacks
declareC: 'usqInt suspendedCallbacks[MaxJumpBuf + 1 /* ', (MaxJumpBuf + 1) printString, ' */]'.
aCCodeGenerator
var: #suspendedMethods
declareC: 'usqInt suspendedMethods[MaxJumpBuf + 1 /* ', (MaxJumpBuf + 1) printString, ' */]'.
aCCodeGenerator
var: #interruptCheckChain
declareC: 'void (*interruptCheckChain)(void) = 0'.
self declareCAsUSqLong: #(nextPollUsecs nextWakeupUsecs longRunningPrimitiveGCUsecs
longRunningPrimitiveStartUsecs longRunningPrimitiveStopUsecs
"these are high-frequency enough that they're overflowing quite quickly on modern hardware"
statProcessSwitch statIOProcessEvents statForceInterruptCheck
statCheckForEvents statStackOverflow statStackPageDivorce)
in: aCCodeGenerator.
aCCodeGenerator var: #nextProfileTick type: #sqLong!
Item was changed:
----- Method: StackInterpreter>>addNewMethodToCache: (in category 'method lookup cache') -----
addNewMethodToCache: classObj
"Add the given entry to the method cache.
The policy is as follows:
Look for an empty entry anywhere in the reprobe chain.
If found, install the new entry there.
If not found, then install the new entry at the first probe position
and delete the entries in the rest of the reprobe chain.
This has two useful purposes:
If there is active contention over the first slot, the second
or third will likely be free for reentry after ejection.
Also, flushing is good when reprobe chains are getting full."
| probe hash primitiveIndex |
<inline: false>
hash := objectMemory methodCacheHashOf: messageSelector with: (objectMemory classTagForClass: classObj). "shift drops low-order zeros from addresses"
(objectMemory isOopCompiledMethod: newMethod)
ifTrue:
[primitiveIndex := self primitiveIndexOf: newMethod.
primitiveFunctionPointer := self functionPointerFor: primitiveIndex inClass: classObj]
ifFalse:
[self assert: ((objectMemory isNonImmediate: newMethod)
and: [objectMemory isForwarded: newMethod]) not.
primitiveFunctionPointer := #primitiveInvokeObjectAsMethod].
0 to: CacheProbeMax-1 do:
[:p | probe := (hash >> p) bitAnd: MethodCacheMask.
(methodCache at: probe + MethodCacheSelector) = 0 ifTrue:
["Found an empty entry -- use it"
methodCache at: probe + MethodCacheSelector put: messageSelector.
methodCache at: probe + MethodCacheClass put: (objectMemory classTagForClass: classObj).
methodCache at: probe + MethodCacheMethod put: newMethod.
+ methodCache at: probe + MethodCachePrimFunction put: (self cCoerce: primitiveFunctionPointer to: #sqInt).
- methodCache at: probe + MethodCachePrimFunction put: (self cCoerce: primitiveFunctionPointer to: #long).
lastMethodCacheProbeWrite := probe. "this for primitiveExternalMethod"
^self]].
"OK, we failed to find an entry -- install at the first slot..."
probe := hash bitAnd: MethodCacheMask. "first probe"
methodCache at: probe + MethodCacheSelector put: messageSelector.
methodCache at: probe + MethodCacheClass put: (objectMemory classTagForClass: classObj).
methodCache at: probe + MethodCacheMethod put: newMethod.
+ methodCache at: probe + MethodCachePrimFunction put: (self cCoerce: primitiveFunctionPointer to: #sqInt).
- methodCache at: probe + MethodCachePrimFunction put: (self cCoerce: primitiveFunctionPointer to: #long).
lastMethodCacheProbeWrite := probe. "this for primitiveExternalMethod"
"...and zap the following entries"
1 to: CacheProbeMax-1 do:
[:p | probe := (hash >> p) bitAnd: MethodCacheMask.
methodCache at: probe + MethodCacheSelector put: 0]!
Item was changed:
----- Method: StackInterpreter>>addNewMethodToNSCache: (in category 'method lookup cache') -----
addNewMethodToNSCache: rule
<option: #NewspeakVM>
<inline: false>
| classObj probe hash primitiveIndex |
classObj := lkupClass.
hash := (objectMemory methodCacheHashOf: messageSelector with: lkupClassTag) bitXor: (method bitXor: rule).
self deny: rule = LookupRuleOrdinary.
(objectMemory isOopCompiledMethod: newMethod)
ifTrue:
[primitiveIndex := self primitiveIndexOf: newMethod.
primitiveFunctionPointer := self functionPointerFor: primitiveIndex inClass: classObj]
ifFalse:
[self assert: ((objectMemory isNonImmediate: newMethod)
and: [objectMemory isForwarded: newMethod]) not.
primitiveFunctionPointer := #primitiveInvokeObjectAsMethod].
0 to: CacheProbeMax-1 do:
[:p | probe := (hash >> p) bitAnd: NSMethodCacheMask.
(nsMethodCache at: probe + NSMethodCacheSelector) = 0 ifTrue:
["Found an empty entry -- use it"
nsMethodCache at: probe + NSMethodCacheSelector put: messageSelector.
nsMethodCache at: probe + NSMethodCacheClassTag put: lkupClassTag. "(objectMemory classTagForClass: classObj)."
nsMethodCache at: probe + NSMethodCacheCallingMethod put: method.
nsMethodCache at: probe + NSMethodCacheDepthOrLookupRule put: rule.
nsMethodCache at: probe + NSMethodCacheTargetMethod put: newMethod.
+ nsMethodCache at: probe + NSMethodCachePrimFunction put: (self cCoerce: primitiveFunctionPointer to: #sqInt).
- nsMethodCache at: probe + NSMethodCachePrimFunction put: (self cCoerce: primitiveFunctionPointer to: #long).
nsMethodCache at: probe + NSMethodCacheActualReceiver put: localAbsentReceiverOrZero.
"lastMethodCacheProbeWrite := probe." "this for primitiveExternalMethod"
^self]].
"OK, we failed to find an entry -- install at the first slot..."
probe := hash bitAnd: NSMethodCacheMask. "first probe"
nsMethodCache at: probe + NSMethodCacheSelector put: messageSelector.
nsMethodCache at: probe + NSMethodCacheClassTag put: lkupClassTag. "(objectMemory classTagForClass: classObj)."
nsMethodCache at: probe + NSMethodCacheCallingMethod put: method.
nsMethodCache at: probe + NSMethodCacheDepthOrLookupRule put: rule.
nsMethodCache at: probe + NSMethodCacheTargetMethod put: newMethod.
+ nsMethodCache at: probe + NSMethodCachePrimFunction put: (self cCoerce: primitiveFunctionPointer to: #sqInt).
- nsMethodCache at: probe + NSMethodCachePrimFunction put: (self cCoerce: primitiveFunctionPointer to: #long).
nsMethodCache at: probe + NSMethodCacheActualReceiver put: localAbsentReceiverOrZero.
"lastMethodCacheProbeWrite := probe. ""this for primitiveExternalMethod"
"...and zap the following entries"
1 to: CacheProbeMax-1 do:
[:p | probe := (hash >> p) bitAnd: NSMethodCacheMask.
nsMethodCache at: probe + NSMethodCacheSelector put: 0]!
Item was changed:
----- Method: StackInterpreter>>isPrimitiveFunctionPointerAnIndex (in category 'primitive support') -----
isPrimitiveFunctionPointerAnIndex
"We save slots in the method cache by using the primitiveFunctionPointer
to hold either a function pointer or the index of a quick primitive. Since
quick primitive indices are small they can't be confused with function
addresses. "
+ ^(self cCoerce: primitiveFunctionPointer to: #'usqIntptr_t') <= MaxQuickPrimitiveIndex!
- ^(self cCoerce: primitiveFunctionPointer to: 'unsigned long') <= MaxQuickPrimitiveIndex!
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>
<var: 'integerValue' type: #'unsigned int'>
objectMemory hasSixtyFourBitImmediates
ifTrue:
+ [^objectMemory integerObjectOf: (integerValue asUnsignedInteger bitAnd: 16rFFFFFFFF)]
- [^objectMemory integerObjectOf: (integerValue asUnsignedLong bitAnd: 16rFFFFFFFF)]
ifFalse:
[^self maybeInlinePositive32BitIntegerFor: integerValue]!
Item was changed:
----- Method: StackInterpreter>>positiveMachineIntegerFor: (in category 'callback support') -----
positiveMachineIntegerFor: value
+ <var: #value type: #'usqIntptr_t'>
- <var: #value type: #'unsigned long'>
<inline: true>
^objectMemory wordSize = 8
ifTrue: [self positive64BitIntegerFor: value]
ifFalse: [self positive32BitIntegerFor: value]!
Item was changed:
----- Method: StackInterpreter>>printMethodCacheFor: (in category 'debug printing') -----
printMethodCacheFor: thing
<api>
| n |
n := 0.
0 to: MethodCacheSize - 1 by: MethodCacheEntrySize do:
[:i | | s c m p |
s := methodCache at: i + MethodCacheSelector.
c := methodCache at: i + MethodCacheClass.
m := methodCache at: i + MethodCacheMethod.
p := methodCache at: i + MethodCachePrimFunction.
((thing = -1 or: [s = thing or: [c = thing or: [p = thing or: [m = thing]]]])
and: [(objectMemory addressCouldBeOop: s)
and: [c ~= 0
and: [(self addressCouldBeClassObj: c)
or: [self addressCouldBeClassObj: (objectMemory classForClassTag: c)]]]]) ifTrue:
[self cCode: [] inSmalltalk: [self transcript ensureCr].
self printNum: i; space; printHexnp: i; cr; tab.
(objectMemory isBytesNonImm: s)
+ ifTrue: [self cCode: 'printf("%" PRIxSQPTR " %.*s\n", s, (int)(numBytesOf(s)), (char *)firstIndexableField(s))'
- ifTrue: [self cCode: 'printf("%lx %.*s\n", s, (int)(numBytesOf(s)), (char *)firstIndexableField(s))'
inSmalltalk: [self printHex: s; space; print: (self stringOf: s); cr]]
ifFalse: [self shortPrintOop: s].
self tab.
(self addressCouldBeClassObj: c)
ifTrue: [self shortPrintOop: c]
ifFalse: [self printNum: c; space; shortPrintOop: (objectMemory classForClassTag: c)].
self tab; shortPrintOop: m; tab.
self cCode:
[p > 1024
ifTrue: [self printHexnp: p]
ifFalse: [self printNum: p]]
inSmalltalk:
[p isSymbol ifTrue: [self print: p] ifFalse: [self printNum: p]].
self cr]].
n > 1 ifTrue:
[self printNum: n; cr]!
Item was changed:
----- Method: StackInterpreter>>putLong:toFile: (in category 'image save/restore') -----
putLong: aLong toFile: aFile
"Append aLong to aFile in this platform's 'natural' byte order. aLong is either 32 or 64 bits,
depending on ObjectMemory. (Bytes will be swapped, if necessary, when the image is read
on a different platform.) Set successFlag to false if the write fails."
+ <var: #aLong type: #sqInt>
- <var: #aLong type: #long>
<var: #aFile type: #sqImageFile>
<inline: false>
| objectsWritten |
objectsWritten := self
+ cCode: [self sq: (self addressOf: aLong) Image: (self sizeof: #sqInt) File: 1 Write: aFile]
- cCode: [self sq: (self addressOf: aLong) Image: (self sizeof: #long) File: 1 Write: aFile]
inSmalltalk:
[| value |
value := aLong.
objectMemory wordSize timesRepeat:
[aFile nextPut: (value bitAnd: 16rFF).
value := value >> 8].
1].
self success: objectsWritten = 1!
Item was changed:
----- Method: StackInterpreter>>rewriteMethodCacheEntryForExternalPrimitiveToFunction: (in category 'method lookup cache') -----
rewriteMethodCacheEntryForExternalPrimitiveToFunction: localPrimAddress
"Rewrite an existing entry in the method cache with a new primitive function address.
Used by primitiveExternalCall to make direct calls to found external prims, or quickly
fail not found external prims."
<inline: false>
<var: #localPrimAddress declareC: 'void (*localPrimAddress)(void)'>
(methodCache at: lastMethodCacheProbeWrite + MethodCacheMethod) = newMethod ifTrue:
[methodCache
at: lastMethodCacheProbeWrite + MethodCachePrimFunction
+ put: (self cCoerce: localPrimAddress to: #sqInt)]!
- put: (self cCoerce: localPrimAddress to: #long)]!
Item was changed:
----- Method: StackInterpreter>>stackPositiveMachineIntegerValue: (in category 'stack access') -----
stackPositiveMachineIntegerValue: offset
<api>
+ <returnTypeC: #'usqIntptr_t'>
"In the StackInterpreter stacks grow down."
| integerPointer |
integerPointer := stackPages longAt: stackPointer + (offset*objectMemory wordSize).
^self positiveMachineIntegerValueOf: integerPointer!
Item was changed:
----- Method: StackInterpreter>>stackSignedMachineIntegerValue: (in category 'stack access') -----
stackSignedMachineIntegerValue: offset
<api>
+ <returnTypeC: #'sqIntptr_t'>
"In the StackInterpreter stacks grow down."
| integerPointer |
integerPointer := stackPages longAt: stackPointer + (offset*objectMemory wordSize).
^self signedMachineIntegerValueOf: integerPointer!
Item was changed:
----- Method: TMethod>>isFunctional (in category 'inlining') -----
isFunctional
"Answer true if the receiver is a functional method. That is, if it
consists of a single return statement of an expression that contains
no other returns.
Answer false for methods with return types other than the simple
integer types to work around bugs in the inliner."
parseTree statements isEmpty ifTrue:
[^false].
parseTree statements last isReturn ifFalse:
[^false].
parseTree statements size = 1 ifFalse:
[(parseTree statements size = 2
and: [parseTree statements first isSend
and: [parseTree statements first selector == #flag:]]) ifFalse:
[^false]].
parseTree statements last expression nodesDo:
[ :n | n isReturn ifTrue: [^false]].
+ ^#(int #'unsigned int' #'long long' #'unsigned long long'
+ sqInt usqInt #'sqIntptr_t' #'usqIntptr_t' sqLong usqLong
- ^#(int #'unsigned int' #long #'unsigned long' #'long long' #'unsigned long long'
- sqInt usqInt sqLong usqLong
#'int *' #'unsigned int *' #'sqInt *' #'usqInt *' #'sqLong *' #'usqLong *' #'CogMethod *' #'char *') includes: returnType!
Item was removed:
- ----- Method: ThreadedFFICalloutStateForX64>>floatRegisterIndex: (in category 'accessing') -----
- floatRegisterIndex: anObject
-
- ^floatRegisterIndex := anObject!
Item was removed:
- ----- Method: ThreadedFFICalloutStateForX64>>floatRegisters: (in category 'accessing') -----
- floatRegisters: anObject
-
- ^floatRegisters := anObject!
Item was added:
+ ----- Method: ThreadedFFICalloutStateForX64>>incrementFloatRegisterIndex (in category 'accessing') -----
+ incrementFloatRegisterIndex
+ ^floatRegisterIndex := floatRegisterIndex + 1!
Item was added:
+ ----- Method: ThreadedFFICalloutStateForX64>>incrementIntegerRegisterIndex (in category 'accessing') -----
+ incrementIntegerRegisterIndex
+ ^integerRegisterIndex := integerRegisterIndex + 1!
Item was removed:
- ----- Method: ThreadedFFICalloutStateForX64>>integerRegisterIndex: (in category 'accessing') -----
- integerRegisterIndex: anObject
-
- ^integerRegisterIndex := anObject!
Item was removed:
- ----- Method: ThreadedFFICalloutStateForX64>>integerRegisters: (in category 'accessing') -----
- integerRegisters: anObject
-
- ^integerRegisters := anObject!
Item was changed:
ThreadedFFICalloutStateForX64 subclass: #ThreadedFFICalloutStateForX64Win64
+ instanceVariableNames: 'floatRegisterSignature'
- instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'VMMaker-Plugins-FFI'!
Item was added:
+ ----- Method: ThreadedFFICalloutStateForX64Win64 class>>instVarNamesAndTypesForTranslationDo: (in category 'translation') -----
+ instVarNamesAndTypesForTranslationDo: aBinaryBlock
+ "enumerate aBinaryBlock with the names and C type strings for the inst vars to include in a ThreadedFFICalloutState struct."
+
+ ThreadedFFICalloutStateForX64 instVarNamesAndTypesForTranslationDo: aBinaryBlock.
+ ThreadedFFICalloutStateForX64Win64 instVarNames do:
+ [:ivn|
+ aBinaryBlock
+ value: ivn
+ value: (ivn caseOf: {
+ ['floatRegisterSignature'] -> [#int] }
+ otherwise:
+ [#sqInt])]!
Item was added:
+ ----- Method: ThreadedFFICalloutStateForX64Win64>>floatRegisterSignature (in category 'accessing') -----
+ floatRegisterSignature
+ ^floatRegisterSignature!
Item was added:
+ ----- Method: ThreadedFFICalloutStateForX64Win64>>incrementFloatRegisterIndex (in category 'accessing') -----
+ incrementFloatRegisterIndex
+ "There are only 4 args passed by register int or float.
+ So we can't distinguish the float index from the integer index.
+ So we have to increment both.
+
+ Consequently, floatRegisterIndex cannot be used anymore to detect presence of float parameter.
+ However, we set a signature bitmap indicating which register position is used to pass a float.
+
+ IMPLEMENTATION NOTES:
+ There are code generator hacks that bypass the accessors.
+ So we cannot just redefine the method floatRegisterIndex as ^integerRegisterIndex.
+ Instead we must maintain the two indices"
+
+ floatRegisterSignature := floatRegisterSignature + (1 << floatRegisterIndex).
+ ^integerRegisterIndex := floatRegisterIndex := floatRegisterIndex + 1!
Item was added:
+ ----- Method: ThreadedFFICalloutStateForX64Win64>>incrementIntegerRegisterIndex (in category 'accessing') -----
+ incrementIntegerRegisterIndex
+ "There are only 4 args passed by register int or float.
+ So we can't distinguish the float index from the integer index.
+ So we have to increment both.
+
+ IMPLEMENTATION NOTES:
+ There are code generator hacks that bypass the accessors.
+ So we cannot just redefine the method floatRegisterIndex as ^integerRegisterIndex.
+ Instead we must maintain the two indices"
+
+ ^floatRegisterIndex := integerRegisterIndex := integerRegisterIndex + 1!
Item was added:
+ ----- Method: ThreadedFFICalloutStateForX64Win64>>initialize (in category 'initialize-release') -----
+ initialize
+ super initialize.
+ floatRegisterSignature := 0.!
Item was changed:
----- Method: ThreadedFFIPlugin class>>preambleCCode (in category 'translation') -----
preambleCCode
"For a source of builtin defines grep for builtin_define in a gcc release config directory."
^'
#include "sqAssert.h" /* for assert */
#define ThreadedFFIPlugin 1 /* to filter-out unwanted declarations from sqFFI.h */
#include "sqFFI.h" /* for logging and surface functions */
#ifdef _MSC_VER
# define alloca _alloca
#endif
#if defined(__GNUC__) && (defined(_X86_) || defined(i386) || defined(__i386) || defined(__i386__))
# define setsp(sp) asm volatile ("movl %0,%%esp" : : "m"(sp))
# define getsp() ({ void *esp; asm volatile ("movl %%esp,%0" : "=r"(esp) : ); esp;})
+ # elif defined(__GNUC__) && (defined(__amd64__) || defined(__x86_64__) || defined(__amd64) || defined(__x86_64))
+ # define setsp(sp) asm volatile ("movq %0,%%rsp" : : "m"(sp))
+ # define getsp() ({ void *rsp; asm volatile ("movq %%rsp,%0" : "=r"(rsp) : ); rsp;})
# elif defined(__GNUC__) && (defined(__arm__))
# define setsp(sp) asm volatile ("ldr %%sp, %0" : : "m"(sp))
# define getsp() ({ void *sp; asm volatile ("mov %0, %%sp" : "=r"(sp) : ); sp;})
#endif
#if !!defined(getsp)
# define getsp() 0
#endif
#if !!defined(setsp)
# define setsp(ignored) 0
#endif
#if !!defined(STACK_ALIGN_BYTES)
# if __APPLE__ && __MACH__ && __i386__
# define STACK_ALIGN_BYTES 16
# elif __linux__ && __i386__
# define STACK_ALIGN_BYTES 16
# elif defined(__amd64__) || defined(__x86_64__) || defined(__amd64) || defined(__x86_64)
# define STACK_ALIGN_BYTES 16
# elif defined(powerpc) || defined(__powerpc__) || defined(_POWER) || defined(__POWERPC__) || defined(__PPC__)
# define STACK_ALIGN_BYTES 16
# elif defined(__sparc64__) || defined(__sparcv9__) || defined(__sparc_v9__) /* must precede 32-bit sparc defs */
# define STACK_ALIGN_BYTES 16
# elif defined(sparc) || defined(__sparc__) || defined(__sparclite__)
# define STACK_ALIGN_BYTES 8
# elif defined(__arm__)
# define STACK_ALIGN_BYTES 8
# else
# define STACK_ALIGN_BYTES 0
# endif
#endif /* !!defined(STACK_ALIGN_BYTES) */
#if !!defined(STACK_OFFSET_BYTES)
# define STACK_OFFSET_BYTES 0
#endif
#if defined(_X86_) || defined(i386) || defined(__i386) || defined(__i386__)
/* Both Mac OS X x86 and Win32 x86 return structs of a power of two in size
* less than or equal to eight bytes in length in registers. Linux never does so.
*/
# if __linux__
# define WIN32_X86_STRUCT_RETURN 0
# else
# define WIN32_X86_STRUCT_RETURN 1
# endif
# if WIN32
# define PLATFORM_API_USES_CALLEE_POPS_CONVENTION 1
# endif
+ # elif defined(__amd64__) || defined(__x86_64__) || defined(__amd64) || defined(__x86_64)
+ # if WIN32 | WIN64
+ # define PLATFORM_API_USES_CALLEE_POPS_CONVENTION 1
+ # endif
#endif /* defined(_X86_) || defined(i386) || defined(__i386) || defined(__i386__) */
#if !!defined(ALLOCA_LIES_SO_USE_GETSP)
+ # if defined(__MINGW32__) && (__GNUC__ >= 3) && (defined(_X86_) || defined(i386) || defined(__i386) || defined(__i386__))
- # if defined(__MINGW32__) && (__GNUC__ >= 3)
/*
* cygwin -mno-cygwin (MinGW) gcc 3.4.x''s alloca is a library routine that answers
* %esp + 4, so the outgoing stack is offset by one word if uncorrected.
* Grab the actual stack pointer to correct.
*/
# define ALLOCA_LIES_SO_USE_GETSP 1
# else
# define ALLOCA_LIES_SO_USE_GETSP 0
# endif
#endif /* !!defined(ALLOCA_LIES_SO_USE_GETSP) */
#if !!defined(PLATFORM_API_USES_CALLEE_POPS_CONVENTION)
# define PLATFORM_API_USES_CALLEE_POPS_CONVENTION 0
#endif
/* The dispatchOn:in:with:with: generates an unwanted call on error. Just squash it. */
#define error(foo) 0
#ifndef SQUEAK_BUILTIN_PLUGIN
/* but print assert failures. */
void
warning(char *s) { /* Print an error message but don''t exit. */
printf("\n%s\n", s);
}
#endif
/* sanitize */
#ifdef SQUEAK_BUILTIN_PLUGIN
# define EXTERN
#else
# define EXTERN extern
#endif
'!
Item was changed:
----- Method: ThreadedFFIPlugin>>ffiAddressOf:startingAt:size: (in category 'primitive support') -----
ffiAddressOf: rcvr startingAt: byteOffset size: byteSize
"Answer a long of the address of the byteSize slot (byte, short, int, whatever) at byteOffset in rcvr.
Nominally intended for use with ExternalAddress objects, this code will work (for obscure historical
reasons) with plain Byte or Word Arrays as well. "
| rcvrClass rcvrSize addr |
(interpreterProxy isBytes: rcvr) ifFalse:[^interpreterProxy primitiveFail].
byteOffset > 0 ifFalse:[^interpreterProxy primitiveFail].
rcvrClass := interpreterProxy fetchClassOf: rcvr.
rcvrSize := interpreterProxy byteSizeOf: rcvr.
rcvrClass = interpreterProxy classExternalAddress
ifTrue:
[rcvrSize = BytesPerWord ifFalse:[^interpreterProxy primitiveFail].
addr := interpreterProxy fetchPointer: 0 ofObject: rcvr. "Hack!!!!"
"don't you dare to read from object memory (unless is pinned)!!"
(addr = 0 "or: [(interpreterProxy isInMemory: addr) or: [(interpreterProxy isPinned: rcvr) not]]") ifTrue:
[^interpreterProxy primitiveFail]]
ifFalse:
[byteOffset+byteSize-1 <= rcvrSize ifFalse:
[^interpreterProxy primitiveFail].
+ addr := self cCoerce: (interpreterProxy firstIndexableField: rcvr) to: #sqInt].
- addr := self cCoerce: (interpreterProxy firstIndexableField: rcvr) to: #long].
addr := addr + byteOffset - 1.
^addr!
Item was changed:
----- Method: ThreadedFFIPlugin>>ffiCreateIntegralResultOop:ofAtomicType:in: (in category 'callout support') -----
ffiCreateIntegralResultOop: retVal ofAtomicType: atomicType in: calloutState
<inline: true>
<var: #calloutState type: #'CalloutState *'>
<var: #retVal type: #usqLong>
"Callout support. Return the appropriate oop for the given atomic type"
| shift value mask byteSize |
<var: 'value' type: #usqLong>
<var: 'mask' type: #usqLong>
self assert: atomicType < FFITypeSingleFloat.
atomicType = FFITypeBool ifTrue:
["Make sure bool honors the byte size requested"
byteSize := calloutState ffiRetHeader bitAnd: FFIStructSizeMask.
value := byteSize = (self sizeof: retVal)
ifTrue:[retVal]
+ ifFalse:[retVal bitAnd: 1 asUnsignedIntegerPtr << (byteSize * 8) - 1].
- ifFalse:[retVal bitAnd: 1 << (byteSize * 8) - 1].
^value = 0
ifTrue:[interpreterProxy falseObject]
ifFalse:[interpreterProxy trueObject]].
atomicType <= FFITypeSignedInt ifTrue:
["these are all generall integer returns"
atomicType <= (BytesPerWord = 8 ifTrue: [FFITypeSignedInt] ifFalse: [FFITypeSignedShort]) ifTrue:
["byte/short. first extract partial word, then sign extend"
shift := (BytesPerWord = 8 and: [atomicType >= FFITypeUnsignedInt])
ifTrue: [32]
ifFalse: [(atomicType >> 1) * 8]. "# of significant bits"
+ value := retVal bitAnd: (1 asUnsignedIntegerPtr << shift - 1).
- value := retVal bitAnd: (1 asUnsignedLong << shift - 1).
(atomicType anyMask: 1) ifTrue:
["make the guy signed"
+ mask := 1 asUnsignedIntegerPtr << (shift-1).
- mask := 1 asUnsignedLong << (shift-1).
value := (value bitAnd: mask-1) - (value bitAnd: mask)].
^interpreterProxy integerObjectOf: value].
"Word sized integer return"
^(atomicType anyMask: 1)
ifTrue:[interpreterProxy signedMachineIntegerFor: retVal] "signed return"
ifFalse:[interpreterProxy positiveMachineIntegerFor: retVal]]. "unsigned return"
"longlong, char"
^(atomicType >> 1) = (FFITypeSignedLongLong >> 1)
ifTrue:
[(atomicType anyMask: 1)
ifTrue:[interpreterProxy signed64BitIntegerFor: retVal] "signed return"
ifFalse:[interpreterProxy positive64BitIntegerFor: retVal]]
ifFalse:
[interpreterProxy characterObjectOf: (retVal bitAnd: 16rFF)]!
Item was changed:
----- Method: ThreadedFFIPlugin>>ffiLoadCalloutAddress: (in category 'symbol loading') -----
ffiLoadCalloutAddress: lit
"Load the address of the foreign function from the given object"
| addressPtr address ptr |
+ <var: #ptr type: #'sqIntptr_t *'>
- <var: #ptr type: #'long *'>
"Lookup the address"
addressPtr := interpreterProxy fetchPointer: 0 ofObject: lit.
"Make sure it's an external handle"
address := self ffiContentsOfHandle: addressPtr errCode: FFIErrorBadAddress.
interpreterProxy failed ifTrue:
[^0].
address = 0 ifTrue:"Go look it up in the module"
[self externalFunctionHasStackSizeSlot ifTrue:
[interpreterProxy
storePointer: ExternalFunctionStackSizeIndex
ofObject: lit
withValue: (interpreterProxy integerObjectOf: -1)].
(interpreterProxy slotSizeOf: lit) < 5 ifTrue:
[^self ffiFail: FFIErrorNoModule].
address := self ffiLoadCalloutAddressFrom: lit.
interpreterProxy failed ifTrue:
[^0].
"Store back the address"
ptr := interpreterProxy firstIndexableField: addressPtr.
ptr at: 0 put: address].
^address!
Item was changed:
----- Method: ThreadedFFIPlugin>>primitiveFFIAllocate (in category 'primitives') -----
primitiveFFIAllocate
"Primitive. Allocate an object on the external heap."
| byteSize addr oop ptr |
<export: true>
<inline: false>
+ <var: #ptr type: #'sqIntptr_t *'>
- <var: #ptr type: #'long *'>
byteSize := interpreterProxy stackIntegerValue: 0.
interpreterProxy failed ifTrue:
[^nil].
addr := self ffiAlloc: byteSize.
addr = 0 ifTrue:
[^interpreterProxy primitiveFail].
oop := interpreterProxy
instantiateClass: interpreterProxy classExternalAddress
+ indexableSize: (self sizeof: #'sqIntptr_t').
- indexableSize: (self sizeof: #long).
ptr := interpreterProxy firstIndexableField: oop.
ptr at: 0 put: addr.
^interpreterProxy pop: 2 thenPush: oop!
Item was changed:
----- Method: ThreadedFFIPlugin>>primitiveFFIFree (in category 'primitives') -----
primitiveFFIFree
"Primitive. Free the object pointed to on the external heap."
| addr oop ptr |
<export: true>
<inline: false>
+ <var: #ptr type: #'sqIntptr_t *'>
- <var: #ptr type: #'long *'>
oop := interpreterProxy stackObjectValue: 0.
((interpreterProxy fetchClassOf: oop) = interpreterProxy classExternalAddress
+ and: [(interpreterProxy byteSizeOf: oop) = (self sizeof: #'sqIntptr_t')]) ifFalse:
- and: [(interpreterProxy byteSizeOf: oop) = (self sizeof: #long)]) ifFalse:
[^interpreterProxy primitiveFail].
ptr := interpreterProxy firstIndexableField: oop.
addr := ptr at: 0.
"Don't you dare to free Squeak's memory!!"
(addr = 0
+ or: [(addr asUnsignedIntegerPtr bitAnd: (self sizeof: #'sqIntptr_t') - 1) ~= 0
- or: [(addr asUnsignedLong bitAnd: (self sizeof: #long) - 1) ~= 0
or: [interpreterProxy isInMemory: addr]]) ifTrue:
[^interpreterProxy primitiveFail].
self ffiFree: addr.
^ptr at: 0 put: 0 "cleanup"!
Item was changed:
----- Method: ThreadedFFIPlugin>>primitiveFFIIntegerAt (in category 'primitives') -----
primitiveFFIIntegerAt
"Answer a (signed or unsigned) n byte integer from the given byte offset
in the receiver, using the platform's endianness."
| isSigned byteSize byteOffset rcvr addr value mask valueOop |
<var: 'value' type: #usqLong>
<var: 'mask' type: #usqLong>
<export: true>
<inline: false>
isSigned := interpreterProxy booleanValueOf: (interpreterProxy stackValue: 0).
byteSize := interpreterProxy stackIntegerValue: 1.
byteOffset := interpreterProxy stackIntegerValue: 2.
rcvr := interpreterProxy stackObjectValue: 3.
interpreterProxy failed ifTrue:[^0].
(byteOffset > 0
and: [(byteSize between: 1 and: 8)
and: [(byteSize bitAnd: byteSize - 1) = 0 "a.k.a. isPowerOfTwo"]]) ifFalse:
[^interpreterProxy primitiveFail].
addr := self ffiAddressOf: rcvr startingAt: byteOffset size: byteSize.
interpreterProxy failed ifTrue:[^0].
byteSize <= 2
ifTrue:
[byteSize = 1
ifTrue: [value := self cCoerceSimple: (interpreterProxy byteAt: addr) to: #'unsigned char']
ifFalse: [value := self cCoerceSimple: (interpreterProxy shortAt: addr) to: #'unsigned short']]
ifFalse:
[byteSize = 4
ifTrue: [value := self cCoerceSimple: (interpreterProxy long32At: addr) to: #'unsigned int']
ifFalse: [value := interpreterProxy long64At: addr]].
byteSize < BytesPerWord
ifTrue:
[isSigned ifTrue: "sign extend value"
+ [mask := 1 asUnsignedIntegerPtr << (byteSize * 8 - 1).
- [mask := 1 << (byteSize * 8 - 1).
value := (value bitAnd: mask-1) - (value bitAnd: mask)].
"note: byte/short (&long if BytesPerWord=8) never exceed SmallInteger range"
valueOop := interpreterProxy integerObjectOf: value]
ifFalse: "general 64 bit integer; note these never fail"
[isSigned
ifTrue:
[byteSize < 8 ifTrue: "sign extend value"
+ [mask := 1 asUnsignedIntegerPtr << (byteSize * 8 - 1).
- [mask := 1 << (byteSize * 8 - 1).
value := (value bitAnd: mask-1) - (value bitAnd: mask)].
valueOop := interpreterProxy signed64BitIntegerFor: value]
ifFalse:[valueOop := interpreterProxy positive64BitIntegerFor: value]].
^interpreterProxy pop: 4 thenPush: valueOop!
Item was changed:
----- Method: ThreadedFFIPlugin>>primitiveFFIIntegerAtPut (in category 'primitives') -----
primitiveFFIIntegerAtPut
"Store a (signed or unsigned) n byte integer at the given byte offset
in the receiver, using the platform's endianness."
| isSigned byteSize byteOffset rcvr addr value max valueOop |
<var: 'value' type: #sqLong>
<var: 'max' type: #sqLong>
<export: true>
<inline: false>
isSigned := interpreterProxy booleanValueOf: (interpreterProxy stackValue: 0).
byteSize := interpreterProxy stackIntegerValue: 1.
valueOop := interpreterProxy stackValue: 2.
byteOffset := interpreterProxy stackIntegerValue: 3.
rcvr := interpreterProxy stackObjectValue: 4.
interpreterProxy failed ifTrue:[^0].
(byteOffset > 0
and: [(byteSize between: 1 and: 8)
and: [(byteSize bitAnd: byteSize - 1) = 0 "a.k.a. isPowerOfTwo"]]) ifFalse:
[^interpreterProxy primitiveFail].
addr := self ffiAddressOf: rcvr startingAt: byteOffset size: byteSize.
interpreterProxy failed ifTrue:[^0].
isSigned
ifTrue:[value := interpreterProxy signedMachineIntegerValueOf: valueOop]
ifFalse:[value := interpreterProxy positiveMachineIntegerValueOf: valueOop].
interpreterProxy failed ifTrue:[^0].
byteSize < BytesPerWord ifTrue:
[isSigned
ifTrue:
+ [max := 1 asUnsignedIntegerPtr << (8 * byteSize - 1).
- [max := 1 << (8 * byteSize - 1).
(value >= (0 - max) and: [value < max]) ifFalse: [^interpreterProxy primitiveFail]]
ifFalse:
+ [value asUnsignedLongLong < (1 asUnsignedIntegerPtr << (8*byteSize)) ifFalse: [^interpreterProxy primitiveFail]]].
- [value asUnsignedLongLong < (1 << (8*byteSize)) ifFalse: [^interpreterProxy primitiveFail]]].
byteSize <= 2
ifTrue:
[byteSize = 1
ifTrue: [interpreterProxy byteAt: addr put: value]
ifFalse: [interpreterProxy shortAt: addr put: value]]
ifFalse:
[byteSize = 4
ifTrue: [interpreterProxy long32At: addr put: value]
ifFalse: [interpreterProxy long64At: addr put: value]].
^interpreterProxy pop: 5 thenPush: valueOop!
Item was changed:
----- Method: ThreadedFFIPlugin>>primitiveSetManualSurfacePointer (in category 'primitives - surfaces') -----
primitiveSetManualSurfacePointer
"Create a 'manual surface' data-structure. See the ExternalForm class in the FFI package for example usage."
"arguments: name(type, stack offset)
surfaceID(Integer, 1)
ptr(uint32/uint64, 0)"
| surfaceID ptr result |
<export: true>
+ <var: #ptr type: #'usqIntptr_t'>
- <var: #ptr type: #'unsigned long'>
interpreterProxy methodArgumentCount = 2 ifFalse: [^interpreterProxy primitiveFail].
surfaceID := interpreterProxy stackIntegerValue: 1.
ptr := interpreterProxy positiveMachineIntegerValueOf: (interpreterProxy stackValue: 0).
interpreterProxy failed ifTrue: [^nil].
self touch: surfaceID; touch: ptr.
result := self setManualSurface: surfaceID Pointer: ptr asVoidPointer.
result = 0 ifTrue: [^interpreterProxy primitiveFail].
^interpreterProxy pop: 2
!
Item was removed:
- ----- Method: ThreadedX64FFIPlugin class>>excludingPredefinedMacros (in category 'translation') -----
- excludingPredefinedMacros
- "Answer the predefined macros that disqualify the platforms a subclass handles, if any.
- This can be used to differentiate e.g. x64 Sys V from x64 Win64."
- ^#('WIN64')!
Item was changed:
----- Method: ThreadedX64FFIPlugin>>ffiPushDoubleFloat:in: (in category 'marshalling') -----
ffiPushDoubleFloat: value in: calloutState
<var: #value type: #double>
<var: #calloutState type: #'CalloutState *'>
<inline: true>
calloutState floatRegisterIndex < NumFloatRegArgs
ifTrue:
[calloutState floatRegisters at: calloutState floatRegisterIndex put: value.
+ calloutState incrementFloatRegisterIndex]
- calloutState floatRegisterIndex: calloutState floatRegisterIndex + 1]
ifFalse:
[calloutState currentArg + WordSize > calloutState limit ifTrue:
[^FFIErrorCallFrameTooBig].
interpreterProxy storeFloatAtPointer: calloutState currentArg from: value.
calloutState currentArg: calloutState currentArg + WordSize].
^0!
Item was changed:
----- Method: ThreadedX64FFIPlugin>>ffiPushPointer:in: (in category 'marshalling') -----
ffiPushPointer: pointer in: calloutState
<var: #pointer type: #'void *'>
<var: #calloutState type: #'CalloutState *'>
<inline: true>
calloutState integerRegisterIndex < NumIntRegArgs
ifTrue:
[calloutState integerRegisters at: calloutState integerRegisterIndex put: pointer asInteger.
+ calloutState incrementIntegerRegisterIndex]
- calloutState integerRegisterIndex: calloutState integerRegisterIndex + 1]
ifFalse:
[calloutState currentArg + WordSize > calloutState limit ifTrue:
[^FFIErrorCallFrameTooBig].
interpreterProxy longAt: calloutState currentArg put: pointer.
calloutState currentArg: calloutState currentArg + WordSize].
^0!
Item was changed:
----- Method: ThreadedX64FFIPlugin>>ffiPushSignedByte:in: (in category 'marshalling') -----
ffiPushSignedByte: value in: calloutState
<var: #calloutState type: #'CalloutState *'>
<inline: true>
calloutState integerRegisterIndex < NumIntRegArgs
ifTrue:
[calloutState integerRegisters at: calloutState integerRegisterIndex put: (self cCoerceSimple: value to: #'signed char').
+ calloutState incrementIntegerRegisterIndex]
- calloutState integerRegisterIndex: calloutState integerRegisterIndex + 1]
ifFalse:
[calloutState currentArg + WordSize > calloutState limit ifTrue:
[^FFIErrorCallFrameTooBig].
interpreterProxy longAt: calloutState currentArg put: (self cCoerceSimple: value to: #'signed char').
calloutState currentArg: calloutState currentArg + WordSize].
^0!
Item was changed:
----- Method: ThreadedX64FFIPlugin>>ffiPushSignedChar:in: (in category 'marshalling') -----
ffiPushSignedChar: value in: calloutState
<var: #calloutState type: #'CalloutState *'>
<inline: true>
calloutState integerRegisterIndex < NumIntRegArgs
ifTrue:
[calloutState integerRegisters at: calloutState integerRegisterIndex put: (self cCoerceSimple: value to: #'signed char').
+ calloutState incrementIntegerRegisterIndex]
- calloutState integerRegisterIndex: calloutState integerRegisterIndex + 1]
ifFalse:
[calloutState currentArg + WordSize > calloutState limit ifTrue:
[^FFIErrorCallFrameTooBig].
interpreterProxy longAt: calloutState currentArg put: (self cCoerceSimple: value to: #'signed char').
calloutState currentArg: calloutState currentArg + WordSize].
^0!
Item was changed:
----- Method: ThreadedX64FFIPlugin>>ffiPushSignedInt:in: (in category 'marshalling') -----
ffiPushSignedInt: value in: calloutState
<var: #calloutState type: #'CalloutState *'>
<inline: true>
calloutState integerRegisterIndex < NumIntRegArgs
ifTrue:
[calloutState integerRegisters at: calloutState integerRegisterIndex put: value.
+ calloutState incrementIntegerRegisterIndex]
- calloutState integerRegisterIndex: calloutState integerRegisterIndex + 1]
ifFalse:
[calloutState currentArg + WordSize > calloutState limit ifTrue:
[^FFIErrorCallFrameTooBig].
interpreterProxy longAt: calloutState currentArg put: value.
calloutState currentArg: calloutState currentArg + WordSize].
^0
!
Item was changed:
----- Method: ThreadedX64FFIPlugin>>ffiPushSignedLongLong:in: (in category 'marshalling') -----
ffiPushSignedLongLong: value in: calloutState
<var: #value type: #sqLong>
<var: #calloutState type: #'CalloutState *'>
<inline: true>
calloutState integerRegisterIndex < NumIntRegArgs
ifTrue:
[calloutState integerRegisters at: calloutState integerRegisterIndex put: (self cCoerceSimple: value to: #usqInt).
+ calloutState incrementIntegerRegisterIndex]
- calloutState integerRegisterIndex: calloutState integerRegisterIndex + 1]
ifFalse:
[calloutState currentArg + WordSize > calloutState limit ifTrue: [^FFIErrorCallFrameTooBig].
interpreterProxy longAt: calloutState currentArg put: value.
calloutState currentArg: calloutState currentArg + WordSize].
^0!
Item was changed:
----- Method: ThreadedX64FFIPlugin>>ffiPushSignedShort:in: (in category 'marshalling') -----
ffiPushSignedShort: value in: calloutState
<var: #calloutState type: #'CalloutState *'>
<inline: true>
calloutState integerRegisterIndex < NumIntRegArgs
ifTrue:
[calloutState integerRegisters at: calloutState integerRegisterIndex put: (self cCoerceSimple: value to: #'signed short').
+ calloutState incrementIntegerRegisterIndex]
- calloutState integerRegisterIndex: calloutState integerRegisterIndex + 1]
ifFalse:
[calloutState currentArg + WordSize > calloutState limit ifTrue:
[^FFIErrorCallFrameTooBig].
interpreterProxy longAt: calloutState currentArg put: (self cCoerceSimple: value to: #'signed short').
calloutState currentArg: calloutState currentArg + WordSize].
^0!
Item was changed:
----- Method: ThreadedX64FFIPlugin>>ffiPushSingleFloat:in: (in category 'marshalling') -----
ffiPushSingleFloat: value in: calloutState
<var: #value type: #float>
<var: #calloutState type: #'CalloutState *'>
<inline: true>
calloutState floatRegisterIndex < NumFloatRegArgs
ifTrue:
[(self cCoerce: calloutState floatRegisters + calloutState floatRegisterIndex to: #'float *') at: 0 put: value.
+ calloutState incrementFloatRegisterIndex]
- calloutState floatRegisterIndex: calloutState floatRegisterIndex + 1]
ifFalse:
[calloutState currentArg + WordSize > calloutState limit ifTrue:
[^FFIErrorCallFrameTooBig].
interpreterProxy storeFloatAtPointer: calloutState currentArg from: value.
calloutState currentArg: calloutState currentArg + WordSize].
^0!
Item was changed:
----- Method: ThreadedX64FFIPlugin>>ffiPushUnsignedByte:in: (in category 'marshalling') -----
ffiPushUnsignedByte: value in: calloutState
<var: #calloutState type: #'CalloutState *'>
<inline: true>
calloutState integerRegisterIndex < NumIntRegArgs
ifTrue:
[calloutState integerRegisters at: calloutState integerRegisterIndex put: (self cCoerceSimple: value to: #'unsigned char').
+ calloutState incrementIntegerRegisterIndex]
- calloutState integerRegisterIndex: calloutState integerRegisterIndex + 1]
ifFalse:
[calloutState currentArg + WordSize > calloutState limit ifTrue:
[^FFIErrorCallFrameTooBig].
interpreterProxy longAt: calloutState currentArg put: (self cCoerceSimple: value to: #'unsigned char').
calloutState currentArg: calloutState currentArg + WordSize].
^0
!
Item was changed:
----- Method: ThreadedX64FFIPlugin>>ffiPushUnsignedChar:in: (in category 'marshalling') -----
ffiPushUnsignedChar: value in: calloutState
<var: #calloutState type: #'CalloutState *'>
<inline: true>
calloutState integerRegisterIndex < NumIntRegArgs
ifTrue:
[calloutState integerRegisters at: calloutState integerRegisterIndex put: (self cCoerceSimple: value to: #'unsigned char').
+ calloutState incrementIntegerRegisterIndex]
- calloutState integerRegisterIndex: calloutState integerRegisterIndex + 1]
ifFalse:
[calloutState currentArg + WordSize > calloutState limit ifTrue:
[^FFIErrorCallFrameTooBig].
interpreterProxy longAt: calloutState currentArg put: (self cCoerceSimple: value to: #'unsigned char').
calloutState currentArg: calloutState currentArg + WordSize].
^0!
Item was changed:
----- Method: ThreadedX64FFIPlugin>>ffiPushUnsignedInt:in: (in category 'marshalling') -----
ffiPushUnsignedInt: value in: calloutState
<var: #calloutState type: #'CalloutState *'>
<inline: true>
calloutState integerRegisterIndex < NumIntRegArgs
ifTrue:
[calloutState integerRegisters at: calloutState integerRegisterIndex put: value.
+ calloutState incrementIntegerRegisterIndex]
- calloutState integerRegisterIndex: calloutState integerRegisterIndex + 1]
ifFalse:
[calloutState currentArg + WordSize > calloutState limit ifTrue:
[^FFIErrorCallFrameTooBig].
interpreterProxy longAt: calloutState currentArg put: value.
calloutState currentArg: calloutState currentArg + WordSize].
^0
!
Item was changed:
----- Method: ThreadedX64FFIPlugin>>ffiPushUnsignedLongLong:in: (in category 'marshalling') -----
ffiPushUnsignedLongLong: value in: calloutState
<var: #value type: #usqLong>
<var: #calloutState type: #'CalloutState *'>
<inline: true>
calloutState integerRegisterIndex < NumIntRegArgs
ifTrue:
[calloutState integerRegisters at: calloutState integerRegisterIndex put: value.
+ calloutState incrementIntegerRegisterIndex]
- calloutState integerRegisterIndex: calloutState integerRegisterIndex + 1]
ifFalse:
[calloutState currentArg + WordSize > calloutState limit ifTrue: [^FFIErrorCallFrameTooBig].
interpreterProxy longAt: calloutState currentArg put: value.
calloutState currentArg: calloutState currentArg + WordSize].
^0!
Item was changed:
----- Method: ThreadedX64FFIPlugin>>ffiPushUnsignedShort:in: (in category 'marshalling') -----
ffiPushUnsignedShort: value in: calloutState
<var: #calloutState type: #'CalloutState *'>
<inline: true>
calloutState integerRegisterIndex < NumIntRegArgs
ifTrue:
[calloutState integerRegisters at: calloutState integerRegisterIndex put: (self cCoerceSimple: value to: #'unsigned short').
+ calloutState incrementIntegerRegisterIndex]
- calloutState integerRegisterIndex: calloutState integerRegisterIndex + 1]
ifFalse:
[calloutState currentArg + WordSize > calloutState limit ifTrue:
[^FFIErrorCallFrameTooBig].
interpreterProxy longAt: calloutState currentArg put: (self cCoerceSimple: value to: #'unsigned short').
calloutState currentArg: calloutState currentArg + WordSize].
^0!
Item was changed:
ThreadedX64FFIPlugin subclass: #ThreadedX64Win64FFIPlugin
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'VMMaker-Plugins-FFI'!
+ !ThreadedX64Win64FFIPlugin commentStamp: 'nice 8/10/2016 19:23' prior: 0!
+ This subclass is for the Win64 x86-64 ABI. The Win64 ABI uses 4 integer registers or 4 double-precision floating-point registers or a mix of the two. See w.g. https://msdn.microsoft.com/en-us/library/ms235286.aspx, or google for "Overview of x64 Calling Conventions - MSDN - Microsoft".
- !ThreadedX64Win64FFIPlugin commentStamp: 'eem 2/16/2016 19:39' prior: 0!
- This subclass is for the Win64 x86-64 ABI. The System V ABI uses 4 integer registers and 4 double-precision floating-point registers. See w.g. https://msdn.microsoft.com/en-us/library/ms235286.aspx, or google for "Overview of x64 Calling Conventions - MSDN - Microsoft".
Note that unlike the System V x86-64 ABI, the Win64 ABI does /not/ decompose structs passed by value across available parameter registers.!
Item was added:
+ ----- Method: ThreadedX64Win64FFIPlugin class>>calloutStateClass (in category 'translation') -----
+ calloutStateClass
+ ^ThreadedFFICalloutStateForX64Win64!
Item was added:
+ ----- Method: ThreadedX64Win64FFIPlugin>>ffiCalloutDoubleRetTo:in: (in category 'callout support') -----
+ ffiCalloutDoubleRetTo: procAddr in: calloutState
+ <var: #procAddr type: #'void *'>
+ <var: #calloutState type: #'CalloutState *'>
+ | floatRet |
+ <var: #floatRet type: #double>
+ <returnTypeC: #double>
+ <inline: true>
+ calloutState floatRegisterSignature caseOf: {
+ [0]-> [floatRet := self
+ dispatchFunctionPointer: (self cCoerceSimple: procAddr to: 'double (*)(sqIntptr_t, sqIntptr_t, sqIntptr_t, sqIntptr_t)')
+ with: (calloutState integerRegisters at: 0)
+ with: (calloutState integerRegisters at: 1)
+ with: (calloutState integerRegisters at: 2)
+ with: (calloutState integerRegisters at: 3)].
+ [1]-> [floatRet := self
+ dispatchFunctionPointer: (self cCoerceSimple: procAddr to: 'double (*)(double, sqIntptr_t, sqIntptr_t, sqIntptr_t)')
+ with: (calloutState floatRegisters at: 0)
+ with: (calloutState integerRegisters at: 1)
+ with: (calloutState integerRegisters at: 2)
+ with: (calloutState integerRegisters at: 3)].
+ [2]-> [floatRet := self
+ dispatchFunctionPointer: (self cCoerceSimple: procAddr to: 'double (*)(sqIntptr_t, double, sqIntptr_t, sqIntptr_t)')
+ with: (calloutState integerRegisters at: 0)
+ with: (calloutState floatRegisters at: 1)
+ with: (calloutState integerRegisters at: 2)
+ with: (calloutState integerRegisters at: 3)].
+ [3]-> [floatRet := self
+ dispatchFunctionPointer: (self cCoerceSimple: procAddr to: 'double (*)(double, double, sqIntptr_t, sqIntptr_t)')
+ with: (calloutState floatRegisters at: 0)
+ with: (calloutState floatRegisters at: 1)
+ with: (calloutState integerRegisters at: 2)
+ with: (calloutState integerRegisters at: 3)].
+ [4]-> [floatRet := self
+ dispatchFunctionPointer: (self cCoerceSimple: procAddr to: 'double (*)(sqIntptr_t, sqIntptr_t, double, sqIntptr_t)')
+ with: (calloutState integerRegisters at: 0)
+ with: (calloutState integerRegisters at: 1)
+ with: (calloutState floatRegisters at: 2)
+ with: (calloutState integerRegisters at: 3)].
+ [5]-> [floatRet := self
+ dispatchFunctionPointer: (self cCoerceSimple: procAddr to: 'double (*)(double, sqIntptr_t, double, sqIntptr_t)')
+ with: (calloutState floatRegisters at: 0)
+ with: (calloutState integerRegisters at: 1)
+ with: (calloutState floatRegisters at: 2)
+ with: (calloutState integerRegisters at: 3)].
+ [6]-> [floatRet := self
+ dispatchFunctionPointer: (self cCoerceSimple: procAddr to: 'double (*)(sqIntptr_t, double, double, sqIntptr_t)')
+ with: (calloutState integerRegisters at: 0)
+ with: (calloutState floatRegisters at: 1)
+ with: (calloutState floatRegisters at: 2)
+ with: (calloutState integerRegisters at: 3)].
+ [7]-> [floatRet := self
+ dispatchFunctionPointer: (self cCoerceSimple: procAddr to: 'double (*)(double, double, double, sqIntptr_t)')
+ with: (calloutState floatRegisters at: 0)
+ with: (calloutState floatRegisters at: 1)
+ with: (calloutState floatRegisters at: 2)
+ with: (calloutState integerRegisters at: 3)].
+
+ [8]-> [floatRet := self
+ dispatchFunctionPointer: (self cCoerceSimple: procAddr to: 'double (*)(sqIntptr_t, sqIntptr_t, sqIntptr_t, double)')
+ with: (calloutState integerRegisters at: 0)
+ with: (calloutState integerRegisters at: 1)
+ with: (calloutState integerRegisters at: 2)
+ with: (calloutState floatRegisters at: 3)].
+ [9]-> [floatRet := self
+ dispatchFunctionPointer: (self cCoerceSimple: procAddr to: 'double (*)(double, sqIntptr_t, sqIntptr_t, double)')
+ with: (calloutState floatRegisters at: 0)
+ with: (calloutState integerRegisters at: 1)
+ with: (calloutState integerRegisters at: 2)
+ with: (calloutState floatRegisters at: 3)].
+ [10]-> [floatRet := self
+ dispatchFunctionPointer: (self cCoerceSimple: procAddr to: 'double (*)(sqIntptr_t, double, sqIntptr_t, double)')
+ with: (calloutState integerRegisters at: 0)
+ with: (calloutState floatRegisters at: 1)
+ with: (calloutState integerRegisters at: 2)
+ with: (calloutState floatRegisters at: 3)].
+ [11]-> [floatRet := self
+ dispatchFunctionPointer: (self cCoerceSimple: procAddr to: 'double (*)(double, double, sqIntptr_t, double)')
+ with: (calloutState floatRegisters at: 0)
+ with: (calloutState floatRegisters at: 1)
+ with: (calloutState integerRegisters at: 2)
+ with: (calloutState floatRegisters at: 3)].
+ [12]-> [floatRet := self
+ dispatchFunctionPointer: (self cCoerceSimple: procAddr to: 'double (*)(sqIntptr_t, sqIntptr_t, double, double)')
+ with: (calloutState integerRegisters at: 0)
+ with: (calloutState integerRegisters at: 1)
+ with: (calloutState floatRegisters at: 2)
+ with: (calloutState floatRegisters at: 3)].
+ [13]-> [floatRet := self
+ dispatchFunctionPointer: (self cCoerceSimple: procAddr to: 'double (*)(double, sqIntptr_t, double, double)')
+ with: (calloutState floatRegisters at: 0)
+ with: (calloutState integerRegisters at: 1)
+ with: (calloutState floatRegisters at: 2)
+ with: (calloutState floatRegisters at: 3)].
+ [14]-> [floatRet := self
+ dispatchFunctionPointer: (self cCoerceSimple: procAddr to: 'double (*)(sqIntptr_t, double, double, double)')
+ with: (calloutState integerRegisters at: 0)
+ with: (calloutState floatRegisters at: 1)
+ with: (calloutState floatRegisters at: 2)
+ with: (calloutState floatRegisters at: 3)].
+ [15]-> [floatRet := self
+ dispatchFunctionPointer: (self cCoerceSimple: procAddr to: 'double (*)(double, double, double, double)')
+ with: (calloutState floatRegisters at: 0)
+ with: (calloutState floatRegisters at: 1)
+ with: (calloutState floatRegisters at: 2)
+ with: (calloutState floatRegisters at: 3)].} otherwise: [floatRet := 0].
+ ^floatRet!
Item was added:
+ ----- Method: ThreadedX64Win64FFIPlugin>>ffiCalloutFloatRetTo:in: (in category 'callout support') -----
+ ffiCalloutFloatRetTo: procAddr in: calloutState
+ <var: #procAddr type: #'void *'>
+ <var: #calloutState type: #'CalloutState *'>
+ | floatRet |
+ <var: #floatRet type: #double> "It's double rather than float because it will be converted to a squeak Float object (a.k.a. double precision)"
+ <returnTypeC: #double>
+ <inline: true>
+ calloutState floatRegisterSignature caseOf: {
+ [0]-> [floatRet := self
+ dispatchFunctionPointer: (self cCoerceSimple: procAddr to: 'float (*)(sqIntptr_t, sqIntptr_t, sqIntptr_t, sqIntptr_t)')
+ with: (calloutState integerRegisters at: 0)
+ with: (calloutState integerRegisters at: 1)
+ with: (calloutState integerRegisters at: 2)
+ with: (calloutState integerRegisters at: 3)].
+ [1]-> [floatRet := self
+ dispatchFunctionPointer: (self cCoerceSimple: procAddr to: 'float (*)(double, sqIntptr_t, sqIntptr_t, sqIntptr_t)')
+ with: (calloutState floatRegisters at: 0)
+ with: (calloutState integerRegisters at: 1)
+ with: (calloutState integerRegisters at: 2)
+ with: (calloutState integerRegisters at: 3)].
+ [2]-> [floatRet := self
+ dispatchFunctionPointer: (self cCoerceSimple: procAddr to: 'float (*)(sqIntptr_t, double, sqIntptr_t, sqIntptr_t)')
+ with: (calloutState integerRegisters at: 0)
+ with: (calloutState floatRegisters at: 1)
+ with: (calloutState integerRegisters at: 2)
+ with: (calloutState integerRegisters at: 3)].
+ [3]-> [floatRet := self
+ dispatchFunctionPointer: (self cCoerceSimple: procAddr to: 'float (*)(double, double, sqIntptr_t, sqIntptr_t)')
+ with: (calloutState floatRegisters at: 0)
+ with: (calloutState floatRegisters at: 1)
+ with: (calloutState integerRegisters at: 2)
+ with: (calloutState integerRegisters at: 3)].
+ [4]-> [floatRet := self
+ dispatchFunctionPointer: (self cCoerceSimple: procAddr to: 'float (*)(sqIntptr_t, sqIntptr_t, double, sqIntptr_t)')
+ with: (calloutState integerRegisters at: 0)
+ with: (calloutState integerRegisters at: 1)
+ with: (calloutState floatRegisters at: 2)
+ with: (calloutState integerRegisters at: 3)].
+ [5]-> [floatRet := self
+ dispatchFunctionPointer: (self cCoerceSimple: procAddr to: 'float (*)(double, sqIntptr_t, double, sqIntptr_t)')
+ with: (calloutState floatRegisters at: 0)
+ with: (calloutState integerRegisters at: 1)
+ with: (calloutState floatRegisters at: 2)
+ with: (calloutState integerRegisters at: 3)].
+ [6]-> [floatRet := self
+ dispatchFunctionPointer: (self cCoerceSimple: procAddr to: 'float (*)(sqIntptr_t, double, double, sqIntptr_t)')
+ with: (calloutState integerRegisters at: 0)
+ with: (calloutState floatRegisters at: 1)
+ with: (calloutState floatRegisters at: 2)
+ with: (calloutState integerRegisters at: 3)].
+ [7]-> [floatRet := self
+ dispatchFunctionPointer: (self cCoerceSimple: procAddr to: 'float (*)(double, double, double, sqIntptr_t)')
+ with: (calloutState floatRegisters at: 0)
+ with: (calloutState floatRegisters at: 1)
+ with: (calloutState floatRegisters at: 2)
+ with: (calloutState integerRegisters at: 3)].
+
+ [8]-> [floatRet := self
+ dispatchFunctionPointer: (self cCoerceSimple: procAddr to: 'float (*)(sqIntptr_t, sqIntptr_t, sqIntptr_t, double)')
+ with: (calloutState integerRegisters at: 0)
+ with: (calloutState integerRegisters at: 1)
+ with: (calloutState integerRegisters at: 2)
+ with: (calloutState floatRegisters at: 3)].
+ [9]-> [floatRet := self
+ dispatchFunctionPointer: (self cCoerceSimple: procAddr to: 'float (*)(double, sqIntptr_t, sqIntptr_t, double)')
+ with: (calloutState floatRegisters at: 0)
+ with: (calloutState integerRegisters at: 1)
+ with: (calloutState integerRegisters at: 2)
+ with: (calloutState floatRegisters at: 3)].
+ [10]-> [floatRet := self
+ dispatchFunctionPointer: (self cCoerceSimple: procAddr to: 'float (*)(sqIntptr_t, double, sqIntptr_t, double)')
+ with: (calloutState integerRegisters at: 0)
+ with: (calloutState floatRegisters at: 1)
+ with: (calloutState integerRegisters at: 2)
+ with: (calloutState floatRegisters at: 3)].
+ [11]-> [floatRet := self
+ dispatchFunctionPointer: (self cCoerceSimple: procAddr to: 'float (*)(double, double, sqIntptr_t, double)')
+ with: (calloutState floatRegisters at: 0)
+ with: (calloutState floatRegisters at: 1)
+ with: (calloutState integerRegisters at: 2)
+ with: (calloutState floatRegisters at: 3)].
+ [12]-> [floatRet := self
+ dispatchFunctionPointer: (self cCoerceSimple: procAddr to: 'float (*)(sqIntptr_t, sqIntptr_t, double, double)')
+ with: (calloutState integerRegisters at: 0)
+ with: (calloutState integerRegisters at: 1)
+ with: (calloutState floatRegisters at: 2)
+ with: (calloutState floatRegisters at: 3)].
+ [13]-> [floatRet := self
+ dispatchFunctionPointer: (self cCoerceSimple: procAddr to: 'float (*)(double, sqIntptr_t, double, double)')
+ with: (calloutState floatRegisters at: 0)
+ with: (calloutState integerRegisters at: 1)
+ with: (calloutState floatRegisters at: 2)
+ with: (calloutState floatRegisters at: 3)].
+ [14]-> [floatRet := self
+ dispatchFunctionPointer: (self cCoerceSimple: procAddr to: 'float (*)(sqIntptr_t, double, double, double)')
+ with: (calloutState integerRegisters at: 0)
+ with: (calloutState floatRegisters at: 1)
+ with: (calloutState floatRegisters at: 2)
+ with: (calloutState floatRegisters at: 3)].
+ [15]-> [floatRet := self
+ dispatchFunctionPointer: (self cCoerceSimple: procAddr to: 'float (*)(double, double, double, double)')
+ with: (calloutState floatRegisters at: 0)
+ with: (calloutState floatRegisters at: 1)
+ with: (calloutState floatRegisters at: 2)
+ with: (calloutState floatRegisters at: 3)].} otherwise: [floatRet := 0].
+ ^floatRet!
Item was added:
+ ----- Method: ThreadedX64Win64FFIPlugin>>ffiCalloutIntRetTo:in: (in category 'callout support') -----
+ ffiCalloutIntRetTo: procAddr in: calloutState
+ <var: #procAddr type: #'void *'>
+ <var: #calloutState type: #'CalloutState *'>
+ | intRet |
+ <var: #intRet type: #usqLong>
+ <returnTypeC: #usqLong>
+ <inline: true>
+ calloutState floatRegisterSignature caseOf: {
+ [0]-> [intRet := self
+ dispatchFunctionPointer: (self cCoerceSimple: procAddr to: 'usqLong (*)(sqIntptr_t, sqIntptr_t, sqIntptr_t, sqIntptr_t)')
+ with: (calloutState integerRegisters at: 0)
+ with: (calloutState integerRegisters at: 1)
+ with: (calloutState integerRegisters at: 2)
+ with: (calloutState integerRegisters at: 3)].
+ [1]-> [intRet := self
+ dispatchFunctionPointer: (self cCoerceSimple: procAddr to: 'usqLong (*)(double, sqIntptr_t, sqIntptr_t, sqIntptr_t)')
+ with: (calloutState floatRegisters at: 0)
+ with: (calloutState integerRegisters at: 1)
+ with: (calloutState integerRegisters at: 2)
+ with: (calloutState integerRegisters at: 3)].
+ [2]-> [intRet := self
+ dispatchFunctionPointer: (self cCoerceSimple: procAddr to: 'usqLong (*)(sqIntptr_t, double, sqIntptr_t, sqIntptr_t)')
+ with: (calloutState integerRegisters at: 0)
+ with: (calloutState floatRegisters at: 1)
+ with: (calloutState integerRegisters at: 2)
+ with: (calloutState integerRegisters at: 3)].
+ [3]-> [intRet := self
+ dispatchFunctionPointer: (self cCoerceSimple: procAddr to: 'usqLong (*)(double, double, sqIntptr_t, sqIntptr_t)')
+ with: (calloutState floatRegisters at: 0)
+ with: (calloutState floatRegisters at: 1)
+ with: (calloutState integerRegisters at: 2)
+ with: (calloutState integerRegisters at: 3)].
+ [4]-> [intRet := self
+ dispatchFunctionPointer: (self cCoerceSimple: procAddr to: 'usqLong (*)(sqIntptr_t, sqIntptr_t, double, sqIntptr_t)')
+ with: (calloutState integerRegisters at: 0)
+ with: (calloutState integerRegisters at: 1)
+ with: (calloutState floatRegisters at: 2)
+ with: (calloutState integerRegisters at: 3)].
+ [5]-> [intRet := self
+ dispatchFunctionPointer: (self cCoerceSimple: procAddr to: 'usqLong (*)(double, sqIntptr_t, double, sqIntptr_t)')
+ with: (calloutState floatRegisters at: 0)
+ with: (calloutState integerRegisters at: 1)
+ with: (calloutState floatRegisters at: 2)
+ with: (calloutState integerRegisters at: 3)].
+ [6]-> [intRet := self
+ dispatchFunctionPointer: (self cCoerceSimple: procAddr to: 'usqLong (*)(sqIntptr_t, double, double, sqIntptr_t)')
+ with: (calloutState integerRegisters at: 0)
+ with: (calloutState floatRegisters at: 1)
+ with: (calloutState floatRegisters at: 2)
+ with: (calloutState integerRegisters at: 3)].
+ [7]-> [intRet := self
+ dispatchFunctionPointer: (self cCoerceSimple: procAddr to: 'usqLong (*)(double, double, double, sqIntptr_t)')
+ with: (calloutState floatRegisters at: 0)
+ with: (calloutState floatRegisters at: 1)
+ with: (calloutState floatRegisters at: 2)
+ with: (calloutState integerRegisters at: 3)].
+
+ [8]-> [intRet := self
+ dispatchFunctionPointer: (self cCoerceSimple: procAddr to: 'usqLong (*)(sqIntptr_t, sqIntptr_t, sqIntptr_t, double)')
+ with: (calloutState integerRegisters at: 0)
+ with: (calloutState integerRegisters at: 1)
+ with: (calloutState integerRegisters at: 2)
+ with: (calloutState floatRegisters at: 3)].
+ [9]-> [intRet := self
+ dispatchFunctionPointer: (self cCoerceSimple: procAddr to: 'usqLong (*)(double, sqIntptr_t, sqIntptr_t, double)')
+ with: (calloutState floatRegisters at: 0)
+ with: (calloutState integerRegisters at: 1)
+ with: (calloutState integerRegisters at: 2)
+ with: (calloutState floatRegisters at: 3)].
+ [10]-> [intRet := self
+ dispatchFunctionPointer: (self cCoerceSimple: procAddr to: 'usqLong (*)(sqIntptr_t, double, sqIntptr_t, double)')
+ with: (calloutState integerRegisters at: 0)
+ with: (calloutState floatRegisters at: 1)
+ with: (calloutState integerRegisters at: 2)
+ with: (calloutState floatRegisters at: 3)].
+ [11]-> [intRet := self
+ dispatchFunctionPointer: (self cCoerceSimple: procAddr to: 'usqLong (*)(double, double, sqIntptr_t, double)')
+ with: (calloutState floatRegisters at: 0)
+ with: (calloutState floatRegisters at: 1)
+ with: (calloutState integerRegisters at: 2)
+ with: (calloutState floatRegisters at: 3)].
+ [12]-> [intRet := self
+ dispatchFunctionPointer: (self cCoerceSimple: procAddr to: 'usqLong (*)(sqIntptr_t, sqIntptr_t, double, double)')
+ with: (calloutState integerRegisters at: 0)
+ with: (calloutState integerRegisters at: 1)
+ with: (calloutState floatRegisters at: 2)
+ with: (calloutState floatRegisters at: 3)].
+ [13]-> [intRet := self
+ dispatchFunctionPointer: (self cCoerceSimple: procAddr to: 'usqLong (*)(double, sqIntptr_t, double, double)')
+ with: (calloutState floatRegisters at: 0)
+ with: (calloutState integerRegisters at: 1)
+ with: (calloutState floatRegisters at: 2)
+ with: (calloutState floatRegisters at: 3)].
+ [14]-> [intRet := self
+ dispatchFunctionPointer: (self cCoerceSimple: procAddr to: 'usqLong (*)(sqIntptr_t, double, double, double)')
+ with: (calloutState integerRegisters at: 0)
+ with: (calloutState floatRegisters at: 1)
+ with: (calloutState floatRegisters at: 2)
+ with: (calloutState floatRegisters at: 3)].
+ [15]-> [intRet := self
+ dispatchFunctionPointer: (self cCoerceSimple: procAddr to: 'usqLong (*)(double, double, double, double)')
+ with: (calloutState floatRegisters at: 0)
+ with: (calloutState floatRegisters at: 1)
+ with: (calloutState floatRegisters at: 2)
+ with: (calloutState floatRegisters at: 3)].} otherwise: [intRet := 0].
+ ^intRet!
Item was changed:
----- Method: ThreadedX64Win64FFIPlugin>>ffiCalloutTo:SpecOnStack:in: (in category 'callout support') -----
ffiCalloutTo: procAddr SpecOnStack: specOnStack in: calloutState
<var: #procAddr type: #'void *'>
<var: #calloutState type: #'CalloutState *'>
- <var: #loadFloatRegs declareC: 'extern void loadFloatRegs(double, double, double, double)'>
"Go out, call this guy and create the return value. This *must* be inlined because of
the alloca of the outgoing stack frame in ffiCall:WithFlags:NumArgs:Args:AndTypes:"
| myThreadIndex atomicType floatRet intRet loadFloatRegs oop |
<var: #floatRet type: #double>
<var: #intRet type: #usqLong>
<inline: true>
self cCode: '' inSmalltalk: [loadFloatRegs := #used. loadFloatRegs class].
self cppIf: COGMTVM ifTrue:
[(calloutState callFlags anyMask: FFICallFlagThreaded) ifTrue:
[myThreadIndex := interpreterProxy disownVM: 0]].
self registerArgsSlop + self cStackAlignment > 0 ifTrue:
[self setsp: calloutState argVector].
- calloutState floatRegisterIndex > 0 ifTrue:
- [self
- load: (calloutState floatRegisters at: 0)
- Flo: (calloutState floatRegisters at: 1)
- at: (calloutState floatRegisters at: 2)
- Re: (calloutState floatRegisters at: 3)
- gs: (calloutState floatRegisters at: 4)].
-
atomicType := self atomicTypeOf: calloutState ffiRetHeader.
(atomicType >> 1) = (FFITypeSingleFloat >> 1)
ifTrue:
[atomicType = FFITypeSingleFloat
ifTrue:
+ [floatRet := self ffiCalloutFloatRetTo: procAddr in: calloutState]
- [floatRet := self
- dispatchFunctionPointer: (self cCoerceSimple: procAddr to: 'float (*)(long, long, long, long)')
- with: (calloutState integerRegisters at: 0)
- with: (calloutState integerRegisters at: 1)
- with: (calloutState integerRegisters at: 2)
- with: (calloutState integerRegisters at: 3)]
ifFalse: "atomicType = FFITypeDoubleFloat"
+ [floatRet := self ffiCalloutDoubleRetTo: procAddr in: calloutState]]
- [floatRet := self
- dispatchFunctionPointer: (self cCoerceSimple: procAddr to: 'double (*)(long, long, long, long)')
- with: (calloutState integerRegisters at: 0)
- with: (calloutState integerRegisters at: 1)
- with: (calloutState integerRegisters at: 2)
- with: (calloutState integerRegisters at: 3)]]
ifFalse:
+ [intRet := self ffiCalloutIntRetTo: procAddr in: calloutState].
- [intRet := self
- dispatchFunctionPointer: (self cCoerceSimple: procAddr to: 'usqLong (*)(long, long, long, long)')
- with: (calloutState integerRegisters at: 0)
- with: (calloutState integerRegisters at: 1)
- with: (calloutState integerRegisters at: 2)
- with: (calloutState integerRegisters at: 3)].
"undo any callee argument pops because it may confuse stack management with the alloca."
(self isCalleePopsConvention: calloutState callFlags) ifTrue:
[self setsp: calloutState argVector].
self cppIf: COGMTVM ifTrue:
[(calloutState callFlags anyMask: FFICallFlagThreaded) ifTrue:
[interpreterProxy ownVM: myThreadIndex]].
(calloutState ffiRetHeader anyMask: FFIFlagPointer+FFIFlagStructure) ifTrue:
["Note: Order is important here since FFIFlagPointer + FFIFlagStructure is used to represent
'typedef void* VoidPointer' and VoidPointer must be returned as pointer *not* as struct."
(calloutState ffiRetHeader anyMask: FFIFlagPointer)
ifTrue:
[oop := self ffiReturnPointer: intRet ofType: (self ffiReturnType: specOnStack) in: calloutState]
ifFalse:
[oop := self ffiReturnStruct: intRet ofType: (self ffiReturnType: specOnStack) in: calloutState].
^oop].
(atomicType >> 1) = (FFITypeSingleFloat >> 1)
ifTrue:
[oop := interpreterProxy floatObjectOf: floatRet]
ifFalse:
[oop := self ffiCreateIntegralResultOop: intRet
ofAtomicType: atomicType
in: calloutState].
^interpreterProxy methodReturnValue: oop!
Item was changed:
----- Method: ThreadedX64Win64FFIPlugin>>ffiPushStructure:ofSize:typeSpec:ofLength:in: (in category 'marshalling') -----
ffiPushStructure: pointer ofSize: structSize typeSpec: argSpec ofLength: argSpecSize in: calloutState
<var: #pointer type: #'void *'>
<var: #argSpec type: #'sqInt *'>
<var: #calloutState type: #'CalloutState *'>
+ <var: #arg type: #usqLong>
<inline: true>
structSize <= 0 ifTrue:
[^FFIErrorStructSize].
+ (structSize <= WordSize
- (structSize <= 16
and: [(structSize bitAnd: structSize - 1) = 0 "a.k.a. structSize isPowerOfTwo"]) ifTrue:
+ [| arg |
+ self mem: (self addressOf: arg) cp: pointer y: structSize.
+ ^self ffiPushUnsignedLongLong: arg in: calloutState].
- [^self ffiPushUnsignedLongLong: (self cCoerceSimple: pointer to: #usqLong) in: calloutState].
"For now just push the pointer; we should copy the struct to the outgoing stack frame!!!!"
self flag: 'quick hack'.
^self ffiPushPointer: pointer in: calloutState!
Item was changed:
----- Method: ThreadedX64Win64FFIPlugin>>returnStructInRegisters: (in category 'marshalling') -----
returnStructInRegisters: returnStructSize
"Answer if a struct result of a given size is returned in memory or not."
+ ^returnStructSize <= WordSize and: ["returnStructSize isPowerOfTwo" (returnStructSize bitAnd: returnStructSize-1) = 0]!
- ^returnStructSize <= WordSize!
Item was added:
+ ----- Method: UndefinedObject>>asIntegerPtr (in category '*VMMaker-interpreter simulator') -----
+ asIntegerPtr
+ ^self!
Item was added:
+ ----- Method: UndefinedObject>>asUnsignedIntegerPtr (in category '*VMMaker-interpreter simulator') -----
+ asUnsignedIntegerPtr
+ ^self!
Item was changed:
----- Method: VMCallbackContext class>>instVarNamesAndTypesForTranslationDo: (in category 'translation') -----
instVarNamesAndTypesForTranslationDo: aBinaryBlock
"Define a CallbackContext, the argument to sendInvokeCallbackContext:
self typedef"
self instVarNames do:
[:ivn|
aBinaryBlock
value: ivn
value: (ivn caseOf: {
['thunkp'] -> [#'void *'].
+ ['stackp'] -> [#'sqIntptr_t *'].
+ ['intregargsp'] -> [#'sqIntptr_t *'].
- ['stackp'] -> [#'long *'].
- ['intregargsp'] -> [#'long *'].
['floatregargsp'] -> [#'double *'].
['rvs'] -> [
'union {
+ sqIntptr_t valword;
- long valword;
struct { int low, high; } valleint64;
struct { int high, low; } valbeint64;
double valflt64;
+ struct { void *addr; sqIntptr_t size; } valstruct;
- struct { void *addr; long size; } valstruct;
}'].
['savedCStackPointer'] -> [#'void *'].
['savedCFramePointer'] -> [#'void *'].
['trampoline'] -> [#'jmp_buf'].
['savedReenterInterpreter'] -> [#'jmp_buf']})]!
Item was changed:
----- Method: VMClass>>sizeof: (in category 'translation support') -----
sizeof: objectSymbolOrClass
<doNotGenerate>
| index |
objectSymbolOrClass isInteger ifTrue:
[^self class objectMemoryClass wordSize].
+ (#(usqInt sqInt) includes: objectSymbolOrClass) ifTrue: [^self class objectMemoryClass bytesPerOop].
objectSymbolOrClass isSymbol ifTrue:
[(objectSymbolOrClass last == $*
+ or: [#(#'sqIntptr_t' #'usqIntptr_t' #'size_t') includes: objectSymbolOrClass]) ifTrue:
- or: [#long == objectSymbolOrClass
- or: [#'unsigned long' == objectSymbolOrClass]]) ifTrue:
[^self class objectMemoryClass wordSize].
index := #( #sqLong #usqLong #double
#int #'unsigned int' #float
#short #'unsigned short'
#char #'unsigned char' #'signed char')
indexOf: objectSymbolOrClass
ifAbsent:
+ [(#(long #'unsigned long') includes: objectSymbolOrClass)
+ ifTrue:
+ [self error: 'long is ambiguous on 64bits architecture, don''t use it'.
+ ^self class objectMemoryClass wordSize].
+ self error: 'unrecognized C type name'].
- [(#(usqInt sqInt) includes: objectSymbolOrClass) ifTrue: [^self class objectMemoryClass bytesPerOop].
- self error: 'unrecognized C type name'].
^#(8 8 8
4 4 4
2 2
1 1 1) at: index].
^(objectSymbolOrClass isBehavior
ifTrue: [objectSymbolOrClass]
ifFalse: [objectSymbolOrClass class])
alignedByteSizeOf: objectSymbolOrClass
forClient: self!
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 asUnsignedIntegerPtr)!
- ^interpreterProxy methodReturnValue: (interpreterProxy positiveMachineIntegerFor: 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 asUnsignedIntegerPtr)!
- ^interpreterProxy methodReturnValue: (interpreterProxy positiveMachineIntegerFor: 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 asUnsignedIntegerPtr])!
- ifFalse: [interpreterProxy positiveMachineIntegerFor: 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: #'usqIntptr_t'>
+ <var: #size type: #'usqIntptr_t'>
- <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.
interpreterProxy failed ifTrue:
[interpreterProxy popRemappableOop.
^interpreterProxy primitiveFail].
interpreterProxy storePointer: i * 4 + 2 ofObject: interpreterProxy topRemappableOop withValue: valueObj.
valueObj := interpreterProxy positiveMachineIntegerFor: 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