Squeak-dev June 2021

squeak-dev@lists.squeakfoundation.org

25 participants
145 discussions

The Trunk: Monticello-ct.750.mcz
by commits＠source.squeak.org 11 Jun '21

11 Jun '21

Marcel Taeumel uploaded a new version of Monticello to project The Trunk: http://source.squeak.org/trunk/Monticello-ct.750.mcz ==================== Summary ==================== Name: Monticello-ct.750 Author: ct Time: 10 June 2021, 7:24:46.348229 pm UUID: ca48d945-43a8-e74c-bb9a-49ae3d71d644 Ancestors: Monticello-eem.749 Implements remaining abstract members on MCDictionaryRepository. =============== Diff against Monticello-eem.749 =============== Item was added: + ----- Method: MCDictionaryRepository>>allPackageNames (in category 'packages') ----- + allPackageNames + + ^ self allVersionNames collect: [:versionName | versionName packageName] as: Set! Item was added: + ----- Method: MCDictionaryRepository>>versionNamed: (in category 'versions') ----- + versionNamed: aMCVersionName + + ^ self versionWithInfo: (dict keys detect: [:info | info name = aMCVersionName] ifNone: [^ nil])! Item was added: + ----- Method: MCDictionaryRepository>>versionNamesForPackageNamed: (in category 'versions') ----- + versionNamesForPackageNamed: aString + + ^ self allVersionNames select: [:versionName | versionName packageName = aString]!

1 0

The Trunk: Morphic-mt.1771.mcz
by commits＠source.squeak.org 11 Jun '21

11 Jun '21

Marcel Taeumel uploaded a new version of Morphic to project The Trunk: http://source.squeak.org/trunk/Morphic-mt.1771.mcz ==================== Summary ==================== Name: Morphic-mt.1771 Author: mt Time: 11 June 2021, 8:56:28.364233 am UUID: 0708f93f-e82a-5c4a-bf37-3a0ef7a58587 Ancestors: Morphic-mt.1770 When accessing a text selection, avoid extra check for removal of oblivious text attributes to make those usable outside the context of #interactivePrintIt. Approximate slow-down is still about 2 orders of magnitude away from being noticed during user interactions (e.g. cut, copy). So, we are fine here. Empty selections (i.e. the normal blinking text cursor) are still very fast. =============== Diff against Morphic-mt.1770 =============== Item was changed: ----- Method: TextEditor>>selection (in category 'accessing-selection') ----- selection "Answer the text in the paragraph that is currently selected." | result | result := paragraph text copyFrom: self startIndex to: self stopIndex - 1. + result ifNotEmpty: [ - self class interactivePrintIt ifTrue: [ result removeAttributesThat: [:attr | attr isOblivious]]. ^ result!

1 0

The Inbox: CollectionsTests-ct.359.mcz
by commits＠source.squeak.org 10 Jun '21

10 Jun '21

A new version of CollectionsTests was added to project The Inbox: http://source.squeak.org/inbox/CollectionsTests-ct.359.mcz ==================== Summary ==================== Name: CollectionsTests-ct.359 Author: ct Time: 10 June 2021, 8:49:09.245588 pm UUID: b6b2dadc-31a0-ef45-b41c-861e1fbad6c3 Ancestors: CollectionsTests-nice.354 Complements Collections-ct.948. =============== Diff against CollectionsTests-nice.354 =============== Item was changed: ----- Method: SortFunctionTest>>testAsSortFunction (in category 'tests') ----- testAsSortFunction | function | function := #name ascending. self assert: function equals: function asSortFunction. function := #name asSortFunction. self assert: function equals: function asSortFunction. + function := #<=> asSortFunction. + self assert: function equals: function asSortFunction. function := [ :each | each name ] ascending. self assert: function equals: function asSortFunction. function := [ :x :y | x <=> y ] asSortFunction. self assert: function equals: function asSortFunction.!

1 0

The Inbox: Collections-ct.948.mcz
by commits＠source.squeak.org 10 Jun '21

10 Jun '21

A new version of Collections was added to project The Inbox: http://source.squeak.org/inbox/Collections-ct.948.mcz ==================== Summary ==================== Name: Collections-ct.948 Author: ct Time: 10 June 2021, 8:48:33.981588 pm UUID: 551e6fa7-8f93-ab48-8ab6-17fc5191f48c Ancestors: Collections-eem.944 Handle binary selectors in Symbol >> #asSortFunction. As long as we do not officially deprecate Symbol >> #value:value:, the current state is a bit disappointing. Usage: 'hello' sorted: #<=> asSortFunction. "...in the past, we needed to write all this prose instead:" 'hello' sorted: [:someCharacter :someOtherCharacter | someCharacter <=> someOtherCharacter] asSortFunction. =============== Diff against Collections-eem.944 =============== Item was changed: ----- Method: Symbol>>asSortFunction (in category '*Collections-SortFunctions-converting') ----- asSortFunction + "Return a SortFunction around the receiver. If the receiver is a 2-arg symbol, it is assumed it will do the collation directly itself, returning -1, 0, or 1. If the receiver is a one-arg symbol, it will be evaluated for each a and b and of the sort input, and the result of sending <=> to those will be used." + + self numArgs = 0 ifTrue: [^PropertySortFunction property: self]. + self numArgs = 1 ifTrue: [^CollatorBlockFunction usingBlock: self]. - "Return a SortFunction around the receiver, where the receiver will be used as a unary message to send to both a and b during sorting, and then the result of said send will be collated in ascending order using the <=> method." - "#('abc' 'de' 'fghi') sorted: #size ascending >>> #('de' 'abc' 'fghi')" + self error: 'Cant be converted to sort function. It should has one or two args'.! - ^PropertySortFunction property: self!

1 0

The Inbox: CollectionsTests-ct.358.mcz
by commits＠source.squeak.org 10 Jun '21

10 Jun '21

A new version of CollectionsTests was added to project The Inbox: http://source.squeak.org/inbox/CollectionsTests-ct.358.mcz ==================== Summary ==================== Name: CollectionsTests-ct.358 Author: ct Time: 10 June 2021, 8:46:05.348588 pm UUID: 38a6fe79-5645-2b44-bc79-952cd4cac3e3 Ancestors: CollectionsTests-nice.354 Tests Collections-ct.947. =============== Diff against CollectionsTests-nice.354 =============== Item was added: + ----- Method: SortFunctionTest>>testCompareSortBlock (in category 'tests') ----- + testCompareSortBlock + + | function block | + block := [:a :b | a x <= b x and: [a y >= b y]]. + function := block asCompareSortFunction. + + self assert: (function value: 1 @ 1 value: 1 @ 1). + self assert: (function value: 0 @ 1 value: 1 @ 1). + self assert: (function value: 1 @ 2 value: 1 @ 1). + self deny: (function value: 2 @ 1 value: 1 @ 1). + self deny: (function value: 1 @ 2 value: 0 @ 1).! Item was added: + ----- Method: SortFunctionTest>>testCompareSortSymbol (in category 'tests') ----- + testCompareSortSymbol + + | function symbol | + symbol := #compareSafely:. + function := symbol asCompareSortFunction. + + self assert: (function value: true value: nil). + self deny: (function value: nil value: true). + self assert: (function value: Object new value: true). + self deny: (function value: true value: Object new). + self assert: (function value: Object new value: nil). + self deny: (function value: nil value: Object new).!

1 0

The Inbox: Monticello-ct.750.mcz
by commits＠source.squeak.org 10 Jun '21

10 Jun '21

A new version of Monticello was added to project The Inbox: http://source.squeak.org/inbox/Monticello-ct.750.mcz ==================== Summary ==================== Name: Monticello-ct.750 Author: ct Time: 10 June 2021, 7:24:46.348229 pm UUID: ca48d945-43a8-e74c-bb9a-49ae3d71d644 Ancestors: Monticello-eem.749 Implements remaining abstract members on MCDictionaryRepository. =============== Diff against Monticello-eem.749 =============== Item was added: + ----- Method: MCDictionaryRepository>>allPackageNames (in category 'packages') ----- + allPackageNames + + ^ self allVersionNames collect: [:versionName | versionName packageName] as: Set! Item was added: + ----- Method: MCDictionaryRepository>>versionNamed: (in category 'versions') ----- + versionNamed: aMCVersionName + + ^ self versionWithInfo: (dict keys detect: [:info | info name = aMCVersionName] ifNone: [^ nil])! Item was added: + ----- Method: MCDictionaryRepository>>versionNamesForPackageNamed: (in category 'versions') ----- + versionNamesForPackageNamed: aString + + ^ self allVersionNames select: [:versionName | versionName packageName = aString]!

1 0

The Trunk: Monticello-eem.749.mcz
by commits＠source.squeak.org 08 Jun '21

08 Jun '21

Eliot Miranda uploaded a new version of Monticello to project The Trunk: http://source.squeak.org/trunk/Monticello-eem.749.mcz ==================== Summary ==================== Name: Monticello-eem.749 Author: eem Time: 8 June 2021, 1:16:00.179893 pm UUID: 03263724-e499-4eb9-888f-01683d304f18 Ancestors: Monticello-mt.748 Load time robustness when proceeding through syntax errors (which result in nil methods in MethodAddition). =============== Diff against Monticello-mt.748 =============== Item was changed: ----- Method: MethodAddition>>installMethod (in category 'compiling') ----- installMethod + compiledMethod + ifNil: [Transcript cr; show: 'failed to install ', myClass name, '>>', selector] + ifNotNil: [myClass addSelectorSilently: selector withMethod: compiledMethod]! - myClass addSelectorSilently: selector withMethod: compiledMethod. - ! Item was changed: ----- Method: MethodAddition>>notifyObservers (in category 'compiling') ----- notifyObservers + compiledMethod ifNil: [^self]. "this can occur if syntax errors on package load are proceeded through" SystemChangeNotifier uniqueInstance doSilently: [myClass organization classify: selector under: category suppressIfDefault: false]. priorMethodOrNil isNil ifTrue: [SystemChangeNotifier uniqueInstance methodAdded: compiledMethod selector: selector inProtocol: category class: myClass requestor: requestor] ifFalse: [SystemChangeNotifier uniqueInstance methodChangedFrom: priorMethodOrNil to: compiledMethod selector: selector inClass: myClass requestor: requestor]. "The following code doesn't seem to do anything." myClass instanceSide noteCompilationOf: selector meta: myClass isClassSide. !

1 0

FFI: FFI-Tests-mt.52.mcz
by commits＠source.squeak.org 08 Jun '21

08 Jun '21

Marcel Taeumel uploaded a new version of FFI-Tests to project FFI: http://source.squeak.org/FFI/FFI-Tests-mt.52.mcz ==================== Summary ==================== Name: FFI-Tests-mt.52 Author: mt Time: 8 June 2021, 11:54:40.903752 am UUID: a366270d-4f7e-d447-913e-2c38fd1f2c47 Ancestors: FFI-Tests-mt.51 Complements FFI-Kernel-mt.181 =============== Diff against FFI-Tests-mt.51 =============== Item was changed: ----- Method: ExternalTypeTests>>testArrayOfAliases (in category 'tests - array types') ----- testArrayOfAliases self classesForTypeAliases do: [:aliasClass | | contentType arrayType | contentType := aliasClass externalType. arrayType := contentType asArrayType: 5. self assert: arrayType isArrayType. self assert: contentType identical: arrayType contentType. self assert: 5 equals: arrayType size. self assert: 5 * contentType byteSize equals: arrayType byteSize. self assert: contentType identical: arrayType contentType; assert: contentType byteAlignment equals: arrayType byteAlignment. self assert: contentType isTypeAlias; assert: (contentType isAtomic or: [contentType isStructureType]); deny: contentType isPointerType; deny: contentType isArrayType. self deny: arrayType isAtomic; deny: arrayType isStructureType; deny: arrayType isPointerType; deny: arrayType isTypeAlias. self + deny: contentType referentClass isNil; + assert: arrayType referentClass isNil].! - "referentClass shared" - assert: contentType referentClass - identical: arrayType referentClass].! Item was changed: ----- Method: ExternalTypeTests>>testArrayOfAliasesForArrays (in category 'tests - array types') ----- testArrayOfAliasesForArrays "This is the only way to construct n-dimensional arrays for now." | contentType arrayType | contentType := FFITestAliasForInt32Array externalType. arrayType := contentType asArrayType: 5. self assert: arrayType isArrayType. self assert: contentType identical: arrayType contentType. self assert: 5 equals: arrayType size. self assert: 5 * contentType byteSize equals: arrayType byteSize. self assert: contentType identical: arrayType contentType; assert: contentType byteAlignment equals: arrayType byteAlignment. self assert: contentType isTypeAlias; assert: contentType isArrayType; deny: contentType isAtomic; deny: contentType isStructureType; deny: contentType isPointerType. self deny: arrayType isAtomic; deny: arrayType isStructureType; deny: arrayType isPointerType; deny: arrayType isTypeAlias. self + deny: contentType referentClass isNil; + assert: arrayType referentClass isNil.! - "referentClass shared" - assert: contentType referentClass - identical: arrayType referentClass.! Item was changed: ----- Method: ExternalTypeTests>>testArrayOfAliasesForPointers (in category 'tests - array types') ----- testArrayOfAliasesForPointers self specsForTypeAliasForPointer groupsDo: [:aliasClass :originalType | | contentType arrayType | contentType := aliasClass externalType. arrayType := contentType asArrayType: 5. self assert: arrayType isArrayType. self assert: contentType identical: arrayType contentType. self assert: 5 equals: arrayType size. self assert: 5 * contentType byteSize equals: arrayType byteSize. self assert: contentType identical: arrayType contentType; assert: contentType byteAlignment equals: arrayType byteAlignment. self assert: contentType isTypeAlias; assert: contentType isPointerType; deny: contentType isAtomic; deny: contentType isStructureType; deny: contentType isArrayType. self deny: arrayType isAtomic; deny: arrayType isStructureType; deny: arrayType isPointerType; deny: arrayType isTypeAlias. self + deny: contentType referentClass isNil; + assert: arrayType referentClass isNil].! - "referentClass shared" - assert: contentType referentClass - identical: arrayType referentClass].! Item was changed: ----- Method: ExternalTypeTests>>testArrayOfAliasesForPointersDereferenced (in category 'tests - array types') ----- testArrayOfAliasesForPointersDereferenced "It should be possible to use the non-pointer type of an alias-to-pointer type as contentType in an array/container." self specsForTypeAliasForPointer groupsDo: [:aliasClass :originalType | | contentType arrayType | contentType := aliasClass externalType asNonPointerType. contentType byteSize = 0 ifTrue: [^ self "Ignore void"]. arrayType := contentType asArrayType: 5. self assert: arrayType isArrayType. self assert: contentType identical: arrayType contentType. self assert: 5 equals: arrayType size. self assert: 5 * contentType byteSize equals: arrayType byteSize. self assert: contentType identical: arrayType contentType; assert: contentType byteAlignment equals: arrayType byteAlignment. self deny: contentType isTypeAlias; deny: contentType isPointerType; assert: [contentType isAtomic or: [contentType isStructureType or: [contentType isArrayType]]]. self deny: arrayType isAtomic; deny: arrayType isStructureType; deny: arrayType isPointerType; deny: arrayType isTypeAlias. self + deny: contentType referentClass isNil; + assert: arrayType referentClass isNil].! - "referentClass shared" - assert: contentType referentClass - identical: arrayType referentClass].! Item was changed: ----- Method: ExternalTypeTests>>testArrayOfPointersToStructs (in category 'tests - array types') ----- testArrayOfPointersToStructs self classesForStructures do: [:structClass | | arrayType contentType | contentType := structClass externalType asPointerType. arrayType := contentType asArrayType: 5. self assert: arrayType isArrayType. self assert: contentType identical: arrayType contentType. self assert: 5 equals: arrayType size. self assert: 5 * contentType byteSize equals: arrayType byteSize. self deny: arrayType isAtomic. self deny: arrayType isStructureType. self deny: arrayType isPointerType. self deny: arrayType isTypeAlias. + self assert: arrayType referentClass isNil].! - self - assert: structClass - identical: arrayType referentClass].! Item was changed: ----- Method: ExternalTypeTests>>testArrayOfStructs (in category 'tests - array types') ----- testArrayOfStructs self classesForStructures do: [:structClass | | arrayType contentType | contentType := structClass externalType. arrayType := structClass externalType asArrayType: 5. self assert: arrayType isArrayType. self assert: contentType identical: arrayType contentType. self assert: 5 equals: arrayType size. self assert: 5 * contentType byteSize equals: arrayType byteSize. self deny: arrayType isAtomic. self deny: arrayType isStructureType. self deny: arrayType isPointerType. self deny: arrayType isTypeAlias. + self assert: arrayType referentClass isNil].! - self - assert: structClass - identical: arrayType referentClass].! Item was changed: ----- Method: ExternalTypeTests>>testArrayOfStructsEmpty (in category 'tests - array types') ----- testArrayOfStructsEmpty | structClass arrayType contentType | structClass := FFITestEmptyStruct. contentType := structClass externalType. arrayType := structClass externalType asArrayType: 5. self assert: contentType isEmpty. self assert: 0 equals: contentType byteSize. self assert: 0 equals: arrayType byteSize. self assert: arrayType isArrayType. self assert: contentType identical: arrayType contentType. self assert: 5 equals: arrayType size. self deny: arrayType isAtomic. self deny: arrayType isStructureType. self deny: arrayType isPointerType. self deny: arrayType isTypeAlias. + self assert: arrayType referentClass isNil.! - self - assert: structClass - identical: arrayType referentClass.! Item was changed: ----- Method: ExternalTypeTests>>testPointerToAliasForArray (in category 'tests - pointer types') ----- testPointerToAliasForArray | type pointerType | type := FFITestAliasForInt32Array externalType. pointerType := type asPointerType. self assert: type isArrayType; assert: type isTypeAlias. self assert: pointerType isPointerType; - assert: pointerType isPointerTypeForArray; deny: pointerType isAtomic; deny: pointerType isStructureType; deny: pointerType isArrayType; deny: pointerType isTypeAlias. + self assert: pointerType referentClass notNil.! - self - "referentClass is nil to ensure ExternalData for return values from FFI calls" - assert: pointerType referentClass isNil.!

1 0

FFI: FFI-Kernel-mt.181.mcz
by commits＠source.squeak.org 08 Jun '21

08 Jun '21

Marcel Taeumel uploaded a new version of FFI-Kernel to project FFI: http://source.squeak.org/FFI/FFI-Kernel-mt.181.mcz ==================== Summary ==================== Name: FFI-Kernel-mt.181 Author: mt Time: 8 June 2021, 11:53:52.533752 am UUID: d7c02d46-f7b6-4d41-a63a-dd327d60367a Ancestors: FFI-Kernel-mt.180 Fixes and clean-up in array types. No need for #isPointerTypeForArray because #referentClass is used only for alias-to-array types as in other types. The #contentType has its own instVar. =============== Diff against FFI-Kernel-mt.180 =============== Item was changed: ----- Method: ExternalArrayType class>>newTypeForContentType:size: (in category 'instance creation') ----- newTypeForContentType: contentType size: numElements "!!!!!! Be aware that only the pointer type can be used in calls. As of SqueakFFIPrims VMMaker.oscog-eem.2950, there is no actual support for array types in the FFI plugin !!!!!!" | type pointerType headerWord byteSize | self flag: #contentVsContainer; assert: [contentType isTypeAlias or: [contentType isArrayType not]] description: 'No support for direct multi-dimensional containers yet. Use type aliases.'. self assert: [contentType isVoid not] description: 'No array types for void type!!'. self assert: [ (ArrayTypes at: contentType typeName ifPresent: [:sizes | sizes at: numElements ifAbsent: [nil]] ifAbsent: [nil] ) isNil] description: 'Array type already exists. Use #typeNamed: to access it.'. type := ExternalArrayType basicNew. pointerType := ExternalPointerType basicNew. "1) Regular type" byteSize := numElements ifNil: [0] ifNotNil: [numElements * contentType byteSize]. headerWord := contentType headerWord. headerWord := headerWord bitClear: FFIStructSizeMask. headerWord := headerWord bitOr: (byteSize min: FFIStructSizeMask). type setReferencedType: pointerType; compiledSpec: (WordArray with: headerWord); byteAlignment: (numElements ifNil: [0] ifNotNil: [contentType byteAlignment]); + setReferentClass: nil; "Like atomics and pointers-to-atomics, no dedicated class exists." - setReferentClass: contentType referentClass; setContentType: contentType; setSize: numElements; setByteSize: byteSize. "2) Pointer type. Reuse the compiledSpec of the content-type's pointer type." pointerType setReferencedType: type; compiledSpec: (WordArray with: (self pointerSpec bitOr: FFIFlagAtomic "HACK!! To deceive the FFI plugin :)")); byteAlignment: self pointerAlignment; setReferentClass: nil. "3) Remember this new array type." (ArrayTypes at: contentType typeName ifAbsentPut: [WeakValueDictionary new]) at: numElements put: type. ^ type! Item was changed: ----- Method: ExternalArrayType>>allocate (in category 'external data') ----- allocate + "Overwritten to allocate specific to contentType and size. Check referentClass to consider #isTypeAlias." + - | data | data := self contentType allocate: self size. + ^ referentClass + ifNil: [data "genuine arrays"] + ifNotNil: [referentClass fromHandle: data getHandle]! - ^ self isTypeAlias - ifTrue: [referentClass fromHandle: data getHandle] - ifFalse: [data]! Item was changed: ----- Method: ExternalArrayType>>allocateExternal (in category 'external data') ----- allocateExternal + "Overwritten to allocate specific to contentType and size. Check referentClass to consider #isTypeAlias." + - | data | data := self contentType allocateExternal: self size. + ^ referentClass + ifNil: [data "genuine arrays"] + ifNotNil: [referentClass fromHandle: data getHandle]! - ^ self isTypeAlias - ifTrue: [referentClass fromHandle: data getHandle] - ifFalse: [data]! Item was changed: ----- Method: ExternalArrayType>>handle:at: (in category 'external data') ----- handle: handle at: byteOffset | resultHandle | resultHandle := handle structAt: byteOffset length: self byteSize. + ^ referentClass + ifNotNil: [referentClass fromHandle: resultHandle] + ifNil: [ExternalData fromHandle: resultHandle type: self]! - ^ self isTypeAlias - ifTrue: [referentClass fromHandle: resultHandle] - ifFalse: [ExternalData fromHandle: resultHandle type: self]! Item was added: + ----- Method: ExternalArrayType>>newContentType: (in category 'private') ----- + newContentType: typeOrNil + "My content type has changed. Update my byteSize." + + | newByteSize newHeaderWord | + (contentType := typeOrNil) + ifNil: [ "my class has been removed - make me empty" + compiledSpec := WordArray with: self class structureSpec. + byteAlignment := 1] + ifNotNil: [ "my class has been changed - update my compiledSpec" + newHeaderWord := contentType headerWord. + newByteSize := size ifNil: [0] ifNotNil: [size * (newHeaderWord bitAnd: FFIStructSizeMask)]. + newHeaderWord := newHeaderWord bitClear: FFIStructSizeMask. + newHeaderWord := newHeaderWord bitOr: (newByteSize min: FFIStructSizeMask). + compiledSpec := WordArray with: newHeaderWord. + byteAlignment := contentType byteAlignment. + byteSize := newByteSize]! Item was changed: ----- Method: ExternalArrayType>>newReferentClass: (in category 'private') ----- newReferentClass: classOrNil "The class I'm referencing has changed, which affects arrays of structs. Update my byteSize." - | newByteSize newHeaderWord | (referentClass := classOrNil) + ifNil: [ "my class has been removed - make me 'struct { void }'" - ifNil: [ "my class has been removed - make me empty" compiledSpec := WordArray with: self class structureSpec. + byteAlignment := 1. + contentType := size := byteSize := nil] + ifNotNil: [ "I am an alias-to-array type. Update my specs." + | originalType | + originalType := referentClass originalType. + self assert: [originalType isArrayType]. + + compiledSpec := originalType compiledSpec. + byteAlignment := originalType byteAlignment. + + contentType := originalType contentType. + size := originalType size. + byteSize := originalType byteSize]! - byteAlignment := 1] - ifNotNil: [ "my class has been changed - update my compiledSpec" - newHeaderWord := referentClass compiledSpec first. - newByteSize := size ifNil: [0] ifNotNil: [size * (newHeaderWord bitAnd: FFIStructSizeMask)]. - newHeaderWord := newHeaderWord bitClear: FFIStructSizeMask. - newHeaderWord := newHeaderWord bitOr: (newByteSize min: FFIStructSizeMask). - compiledSpec := WordArray with: newHeaderWord. - byteAlignment := referentClass byteAlignment. - byteSize := newByteSize]! Item was changed: ----- Method: ExternalArrayType>>readFieldAt: (in category 'external structure') ----- readFieldAt: byteOffset + ^ referentClass + ifNotNil: [ - ^ self isTypeAlias - ifTrue: [ '^ {1} fromHandle: (handle structAt: {1} length: {2})' format: { referentClass name. byteOffset. self byteSize}] + ifNil: [ - ifFalse: [ '^ ExternalData fromHandle: (handle structAt: {1} length: {2}) type: {3}' format: { byteOffset. self byteSize. self storeStringForField}]! Item was changed: ----- Method: ExternalArrayType>>storeOn: (in category 'printing') ----- storeOn: aStream + referentClass ifNotNil: [ - self isTypeAlias ifTrue: [ ^ aStream nextPutAll: referentClass name; nextPutAll: ' externalType']. aStream nextPut: $(. self contentType storeOn: aStream. aStream nextPutAll: ' asArrayType: '. aStream nextPutAll: self size asString. aStream nextPut: $).! Item was changed: ----- Method: ExternalArrayType>>typeName (in category 'accessing') ----- typeName + referentClass + ifNotNil: [^ super typeName]. - self isTypeAlias - ifTrue: [^ super typeName]. ^ String streamContents: [:stream | | inParentheses | (inParentheses := self contentType isPointerType not and: [self contentType asPointerType isTypeAlias]) ifTrue: [stream nextPut: $(. "e.g. (*DoublePtr)[5]"]. stream nextPutAll: self contentType typeName. inParentheses ifTrue: [stream nextPut: $)]. stream nextPut: $[. self size ifNotNil: [stream nextPutAll: self size asString]. stream nextPut: $]. ]! Item was changed: ----- Method: ExternalPointerType>>handle:at: (in category 'external data') ----- handle: handle at: byteOffset + ^ referentClass - | referentClassToUse | - referentClassToUse := self isPointerTypeForArray - ifFalse: [referentClass] - ifTrue: [self asNonPointerType isTypeAlias - ifTrue: [self asNonPointerType referentClass] ifFalse: [nil]]. - ^ referentClassToUse ifNotNil: [ + referentClass fromHandle: (handle pointerAt: byteOffset length: self byteSize)] - referentClassToUse fromHandle: (handle pointerAt: byteOffset length: self byteSize)] ifNil: [ ExternalData fromHandle: (handle pointerAt: byteOffset length: self byteSize) type: self asNonPointerType "content type"]! Item was removed: - ----- Method: ExternalPointerType>>isPointerTypeForArray (in category 'testing') ----- - isPointerTypeForArray - "referentClass is currently nil for pointer-to-array types. All operations on referentClass should check this to then use the referentClass from the non-pointer type. Might be changed once array information are encoded in the headerWord." - - ^ self asNonPointerType isArrayType! Item was removed: - ----- Method: ExternalPointerType>>newReferentClass: (in category 'private') ----- - newReferentClass: classOrNil - "The class I'm referencing has changed. Keep pointer types for array types free of the referentClass so that FFI calls return ExternalData." - - self isPointerTypeForArray - ifTrue: [referentClass := nil] - ifFalse: [referentClass := classOrNil].! Item was changed: ----- Method: ExternalPointerType>>originalType (in category 'accessing - type alias') ----- originalType "Overwritten to look into my referencedType. See #isTypeAliasReferenced." - self isPointerTypeForArray ifTrue: [ - ^ self asNonPointerType originalType asPointerType]. - ^ self "e.g. MyStructPtr" asNonPointerType isTypeAlias "e.g. *MyStructPtr" ifTrue: [super originalType asPointerType "e.g. MyStruct*, not MyStruct"] ifFalse: [super originalType]! Item was changed: ----- Method: ExternalPointerType>>readFieldAt: (in category 'external structure') ----- readFieldAt: byteOffset - | referentClassToUse | - referentClassToUse := self isPointerTypeForArray - ifFalse: [referentClass] - ifTrue: [self asNonPointerType isTypeAlias - ifTrue: [self asNonPointerType referentClass] ifFalse: [nil]]. ^ '^ {1} fromHandle: (handle pointerAt: {2} length: {3}){4}' format: { + (referentClass ifNil: [ExternalData]) name. - (referentClassToUse ifNil: [ExternalData]) name. byteOffset. self byteSize. + referentClass ifNotNil: [''] ifNil: [ - referentClassToUse ifNotNil: [''] ifNil: [ ' type: ', self asNonPointerType "content type" storeStringForField]}! Item was changed: ----- Method: ExternalType class>>noticeModificationOf: (in category 'housekeeping') ----- noticeModificationOf: aClass + "A subclass of ExternalStructure has been redefined." - "A subclass of ExternalStructure has been redefined. - Clean out any obsolete references to its type." aClass withAllSubclassesDo: [:cls | | typeName type | typeName := cls name. - ArrayTypes at: typeName ifPresent: [:sizes | - sizes do: [:arrayType | arrayType ifNotNil: [ - arrayType newReferentClass: cls. - arrayType asPointerType newReferentClass: cls]]]. - (type := StructTypes at: typeName ifAbsent: []) ifNotNil: [ type newReferentClass: cls. type asPointerType newReferentClass: cls. + type newTypeAlias]. + + ArrayTypes at: typeName ifPresent: [:sizes | + sizes do: [:arrayType | arrayType ifNotNil: [ + arrayType newContentType: type]]]. + + "Alias-to-array types, which are stored in StructTypes, will not update via #newContentType:. We scan StructTypes for #isArrayType to find such aliases to then call #newContentType:." + StructTypes do: [:each | + (each notNil and: [each isArrayType and: [each contentType == type]]) + ifTrue: [each newContentType: type]]].! - type newTypeAlias]]! Item was changed: ----- Method: ExternalType class>>noticeRemovalOf: (in category 'housekeeping') ----- noticeRemovalOf: aClass "A subclass of ExternalStructure is being removed. Clean out any obsolete references to its type." + + | typeName type | + typeName := aClass name. + + (type := StructTypes at: typeName ifAbsent: []) + ifNotNil: [ + type newReferentClass: nil. + type asPointerType newReferentClass: nil]. + - | type | - type := StructTypes at: aClass name ifAbsent:[nil]. - type == nil ifFalse:[ - type newReferentClass: nil. - type asPointerType newReferentClass: nil]. ArrayTypes at: aClass name ifPresent: [:sizes | + sizes do: [:arrayType | arrayType ifNotNil: [ + arrayType newContentType: nil]]. + + "Alias-to-array types, which are stored in StructTypes, will not update via #newContentType:. We scan StructTypes for #isArrayType to find such aliases to then call #newContentType:." + StructTypes do: [:each | + (each notNil and: [each isArrayType and: [each contentType == type]]) + ifTrue: [each newContentType: type]]].! - sizes do: [:arrayType | - arrayType newReferentClass: nil. - arrayType asPointerType newReferentClass: nil]].! Item was changed: ----- Method: ExternalUnknownType>>becomeArrayType (in category 'construction') ----- becomeArrayType "I am now positive on #isTypeAliasForArray :-) Make myself an array type. Not that easy because Arraytype as extra instVars #size and #contentType." | newArrayType | newArrayType := ExternalArrayType basicNew compiledSpec: self compiledSpec; byteAlignment: self byteAlignment; setReferentClass: referentClass; setReferencedType: referencedType; setContentType: referentClass originalType contentType; "Hmm..." setSize: referentClass originalType size; "Hmm..." setByteSize: referentClass originalType byteSize; "Hmm..." yourself. - "No referentClass for pointer types of array types." - referencedType setReferentClass: nil. - self becomeForward: newArrayType. ^ newArrayType!

1 0

FFI: FFI-Callbacks-mt.25.mcz
by commits＠source.squeak.org 08 Jun '21

08 Jun '21

Marcel Taeumel uploaded a new version of FFI-Callbacks to project FFI: http://source.squeak.org/FFI/FFI-Callbacks-mt.25.mcz ==================== Summary ==================== Name: FFI-Callbacks-mt.25 Author: mt Time: 8 June 2021, 9:41:01.812752 am UUID: 238cc8cb-19d7-1f49-ad78-b3654c7e9fe4 Ancestors: FFI-Callbacks-mt.24 Makes FFI-Callbacks compatible with Alien (callbacks): - Renames #FFICallbackMemory to #AlienStub - Moves management of executable pages from ExternalAddress and FFICallbackMemory to FFICallback - Marks compatibility methods with flag #alienCompatibility. =============== Diff against FFI-Callbacks-mt.24 =============== Item was added: + ByteArray variableByteSubclass: #AlienStub + instanceVariableNames: '' + classVariableNames: 'LifoCallbackSemaphore' + poolDictionaries: '' + category: 'FFI-Callbacks'! + + !AlienStub commentStamp: 'mt 6/7/2021 11:21' prior: 0! + Interface for memory allocation using the IA32ABI plugin. Also used as a compatibility layer for Alien. + + *** + + An instance of FFICallback is a reference to a machine-code thunk/trampoline that calls-back into the VM. The reference can be passed to C code which can use it as a function pointer through which to call-back into Smalltalk. The machine-code thunk/trampoline is different for each instance, hence its address is a unique key that can be used to assocuate the Smalltalk side of the call-back (e.g. a block) with the thunk. Since thunks must be executable and some OSs may not provide default execute permission on memory returned by malloc we may not be able to use malloc directly. Instead we rely on a primitive to provide memory that is guaranteed to be executable. ExternalAddress class>>allocateExecutablePage answers an instance of ExternalData that references an executable piece of memory that is some (possiby unitary) multiple of the pagesize. Class-side code then parcels out pieces of a page to individual thunks. These pieces are recycled when thunks are reclaimed. Since the first byte of a thunk is non-zero we can use it as a flag indicating if the piece is in use or not. + + FFICallback is also the higher-level construct that represents a Smalltalk block to be run in response to a callback. Callbacks evaluate on instances of FFICallbackContext, which describe the stack layout and register contents for receiving callback arguments. + ! Item was added: + ----- Method: AlienStub class>>ensureInSpecialObjectsArray (in category 'class initialization') ----- + ensureInSpecialObjectsArray + "AlienStub must be in the specialObjectsArray to enable the FFI callback mechanism. Because of + the bootstrap the specialObjectsArray may already have been partially initialized with + the callback selector and to be large enough (as part of loading immutability), but + it will be missing FFICallbackMemory until FFICallbackMemory is loaded. So check if the specialObjectsArray is + of the expected size before recreating and slam FFICallbackMemory in if the specialObjectsArray + is already large enough." + + | index | + self ~~ AlienStub ifTrue: [^self]. + + index := 53. + ((Smalltalk includesKey: #VMObjectIndices) + and: [((Smalltalk at: #VMObjectIndices) classPool at: #ClassAlien ifAbsent: []) ~= (index - 1)]) ifTrue: + [self error: 'index probably wrong']. + + Smalltalk specialObjectsArray size < index ifTrue: + [Smalltalk recreateSpecialObjectsArray]. + + Smalltalk specialObjectsArray size < index ifTrue: + [self error: 'SystemDictionary>>recreateSpecialObjectsArray appears incompatible']. + + (Smalltalk specialObjectsArray at: index) ifNil: + [Smalltalk specialObjectsArray at: index put: self]! Item was added: + ----- Method: AlienStub class>>forOop (in category 'instance creation') ----- + forOop + " DANGEROUS!! Use during callbacks only or oop will be come invalid!! + object := Morph new. + handle := FFICallbackMemory forOop. + handle oopAt: 1 put: object. + handle oopAt: 1. + " + + ^ self new + sizeFieldPut: ExternalAddress wordSize; + yourself ! Item was added: + ----- Method: AlienStub class>>forPointer: (in category 'instance creation') ----- + forPointer: address "<Integer>" "^<Alien>" + + ^ self new + sizeFieldPut: 0; + addressFieldPut: address; + yourself! Item was added: + ----- Method: AlienStub class>>initialize (in category 'class initialization') ----- + initialize + + self ensureInSpecialObjectsArray. + + Smalltalk addToStartUpList: self after: FFIPlatformDescription. + LifoCallbackSemaphore := Semaphore new.! Item was added: + ----- Method: AlienStub class>>invokeCallbackContext: (in category 'callbacks') ----- + invokeCallbackContext: vmCallbackContextAddress "<Integer>" + "The low-level entry-point for callbacks sent from the VM/IA32ABI plugin. + Evaluate the callback corresponding to the thunk referenced by vmCallbackContextAddress, + a pointer to a VMCallbackContext32 or VMCallbackContext64, set up by the VM's thunkEntry + routine. Return from the Callback via primSignal:andReturnAs:fromContext:. thisContext's + sender is typically an FFI call-out context and is restored as the Process's top context on return. + Therefore callbacks run on the process that did the call-out in which the callback occurred." + + | callbackContext typeCode helper | + callbackContext := FFICallbackContext fromHandle: vmCallbackContextAddress. + helper := self forPointer: vmCallbackContextAddress. + + [typeCode := callbackContext callback evaluateInContext: callbackContext] + ifCurtailed: [self error: 'attempt to non-local return across a callback']. + typeCode ifNil: + [typeCode := callbackContext errorResult]. + + "Now attempt to return from a Callback. This must be done in LIFO order. The IA32ABI + plugin maintains a linked list of vmCallbackContextAddresses to record this order. If + vmCallbackContextAddress *is* that of the most recent Callback then the return will + occur and the primitive will not return here. If vmCallbackContextAddress *is not* that + of the most recent Callback the primitive will answer false, in which case this process + waits on the lifoCallbackSemaphore which will be signalled by some other attempted + Callback return. In any case (successful return from callback or answering false here), + the primtive signals the first process waiting on the semaphore (which is after this one + if this one was waiting), allowing the next process to attempt to return, and so on. + Hence all nested callbacks should eventually return, and in the right order." + [helper primSignal: LifoCallbackSemaphore andReturnAs: typeCode fromContext: thisContext] + whileFalse: + [LifoCallbackSemaphore wait]! Item was added: + ----- Method: AlienStub class>>isAlienLoaded (in category 'class initialization') ----- + isAlienLoaded + + self flag: #alienCompatibility. + ^ (Smalltalk specialObjectsArray at: 53) ~~ self! Item was added: + ----- Method: AlienStub class>>new (in category 'instance creation') ----- + new + "Only used for holding (alien) pointers." + + ^ super new: ExternalAddress wordSize * 2! Item was added: + ----- Method: AlienStub class>>new: (in category 'instance creation') ----- + new: n + + self shouldNotImplement.! Item was added: + ----- Method: AlienStub class>>startUp: (in category 'system startup') ----- + startUp: resuming + + resuming ifTrue: [ + LifoCallbackSemaphore := Semaphore new].! Item was added: + ----- Method: AlienStub class>>unload (in category 'class initialization') ----- + unload + + Smalltalk removeFromStartUpList: self. + + (Smalltalk specialObjectsArray at: 53) == self ifTrue: [ + Smalltalk specialObjectsArray at: 53 put: nil].! Item was added: + ----- Method: AlienStub>>addressField (in category 'primitives-accessing') ----- + addressField "^<Integer>" + <primitive: 'primAddressField' module: 'IA32ABI' error: errorCode> + + ^ (ExternalData fromHandle: self type: ExternalType uintptr_t) + at: ExternalData wordSize + 1! Item was added: + ----- Method: AlienStub>>addressFieldPut: (in category 'primitives-accessing') ----- + addressFieldPut: value "<Integer> ^<Integer>" + <primitive: 'primAddressFieldPut' module: 'IA32ABI' error: errorCode> + + self notify: 'Primitive failed. Proceed to use fallback code.'. + ^ (ExternalData fromHandle: self type: ExternalType uintptr_t) + at: ExternalAddress wordSize "Alien size prefix bytes" + 1 "Start of pointer address" + put: value! Item was added: + ----- Method: AlienStub>>oopAt: (in category 'primitives-accessing') ----- + oopAt: byteOffset + "Access for callbacks that want to exchange Smalltalk objects." + <primitive: 'primOopAt' module: 'IA32ABI' error: errorCode> + ^self primitiveFailed! Item was added: + ----- Method: AlienStub>>oopAt:put: (in category 'primitives-accessing') ----- + oopAt: byteOffset put: value + "Access for callbacks that want to exchange Smalltalk objects." + <primitive: 'primOopAtPut' module: 'IA32ABI' error: errorCode> + ^self primitiveFailed! Item was added: + ----- Method: AlienStub>>primSignal:andReturnAs:fromContext: (in category 'primitives-context') ----- + primSignal: aSemaphore andReturnAs: typeCode fromContext: context + "Attempt to return from a callback. This must be done in LIFO order. The IA32ABI + plugin maintains a linked list of vmCallbackContextAddresses to record this order. + If vmCallbackContextAddress *is* that of the most recent Callback then return from + the callback and do not return here. If vmCallbackContextAddress *is not* that of + the most recent Callback then succeed but answer false. In either case, signal the + first process waiting on aSemaphore. See Alien class>> invokeCallbackContext: + for a full explanation. Fail if the arguments are not of the expected type." + <primitive: 'primReturnAsFromContextThrough' module: 'IA32ABI' error: ec> + ^ self primitiveFailed! Item was added: + ----- Method: AlienStub>>sizeField (in category 'primitives-accessing') ----- + sizeField "^<Integer>" + <primitive: 'primSizeField' module: 'IA32ABI' error: errorCode> + + "For some reason, the size is stored as intptr_t, not uintpr_t." + ^ (ExternalData fromHandle: self type: ExternalType intptr_t) + at: 1! Item was added: + ----- Method: AlienStub>>sizeFieldPut: (in category 'primitives-accessing') ----- + sizeFieldPut: size "<Integer> ^<Integer>" + <primitive: 'primSizeFieldPut' module: 'IA32ABI' error: errorCode> + + self notify: 'Primitive failed. Proceed to use fallback code.'. + + "For some reason, the size is stored as intptr_t, not uintpr_t." + ^ (ExternalData fromHandle: self type: ExternalType intptr_t) + at: 1 put: size! Item was removed: - ----- Method: ExternalAddress class>>allocateExecutablePage (in category '*FFI-Callbacks') ----- - allocateExecutablePage - "The IA32ABI plugin answers a byte array where the first half encodes the allocated byte size and the second half the external address to that executable memory. Unpack that byte array and return external data we can read and write conveniently." - - | alien | - alien := self primAllocateExecutablePage. - ^ ExternalData - fromHandle: alien externalPointer - byteSize: alien byteSize! Item was removed: - ----- Method: ExternalAddress class>>primAllocateExecutablePage (in category '*FFI-Callbacks') ----- - primAllocateExecutablePage "^<Alien>" - "Answer an Alien around a piece of (probably malloced) memory, of some multiple - of the pagesize, that has execute permissions set. This memory can be parcelled - out to individual FFICallbackThunks to hold their thunk/trampoline machine code." - <primitive: 'primAllocateExecutablePage' module: 'IA32ABI' error: errorCode> - ^self primitiveFailed! Item was removed: - ----- Method: ExternalData class>>fromHandle:byteSize: (in category '*FFI-Callbacks') ----- - fromHandle: aHandle byteSize: numBytes - "Answer an instance that manages a number of unsigned bytes." - - ^ self - fromHandle: aHandle - type: ExternalType unsignedByte "content type" - size: numBytes! Item was changed: ExternalTypeAlias subclass: #FFICallback instanceVariableNames: 'evaluableObject evaluator argumentTypes resultType' + classVariableNames: 'EvaluableToCallbackMap ExecutablePages ExecutablePagesAccessProtect ThunkToCallbackMap' - classVariableNames: 'EvaluableToCallbackMap ThunkToCallbackMap' poolDictionaries: 'FFICallbackConstants' category: 'FFI-Callbacks'! Item was added: + ----- Method: FFICallback class>>allocateExecutableBlock (in category 'executable pages') ----- + allocateExecutableBlock + + | blockSize | + blockSize := MaxThunkSize. + ExecutablePagesAccessProtect critical: + [ExecutablePages do: + [:page | + 1 to: page size - blockSize by: blockSize do: + [:i| + (page at: i) = 0 ifTrue: + [page at: i put: 1. + ^ page from: i to: i + blockSize - 1]]]]. + ExecutablePagesAccessProtect critical: [ + | newPage | + newPage := ExecutablePages add: self allocateExecutablePage. + ^ (newPage from: 1 to: blockSize) + at: 1 put: 1; "Mark as allocated." + yourself]! Item was added: + ----- Method: FFICallback class>>allocateExecutablePage (in category 'executable pages') ----- + allocateExecutablePage + "The IA32ABI plugin answers a byte array where the first half encodes the allocated byte size and the second half the external address to that executable memory. Unpack that byte array and return external data we can read and write conveniently." + + | alien | + alien := self primAllocateExecutablePage. + ^ ExternalData + fromHandle: (ExternalAddress fromInteger: alien addressField) + type: ExternalType unsignedByte + size: alien sizeField abs! Item was added: + ----- Method: FFICallback class>>allocateExternal (in category 'instance creation') ----- + allocateExternal + "Overwritten for custom management of executable pages. Assure compatibility with Alien." + + | instance | + instance := self fromHandle: self allocateExecutableBlock getHandle. + AlienStub isAlienLoaded ifTrue: [instance addToAlienThunkTable]. + ^ instance! Item was added: + ----- Method: FFICallback class>>allocateExternal: (in category 'instance creation') ----- + allocateExternal: n + "Overwritten but stubbed. Please create callbacks one after another and not as array." + + self shouldNotImplement.! Item was added: + ----- Method: FFICallback class>>externalNewGC (in category 'instance creation - managed') ----- + externalNewGC + + ^ self externalNew + beManaged; + yourself! Item was changed: ----- Method: FFICallback class>>fromHandle: (in category 'instance lookup') ----- fromHandle: thunkAddress + "Lookup known instances or create a new one and put it into the lookup table." + - ^ ThunkToCallbackMap at: thunkAddress + ifAbsentPut: [super fromHandle: thunkAddress]! - ifAbsent: [self error: 'could not locate Callback instance corresponding to thunk address'] - ! Item was changed: ----- Method: FFICallback class>>gcMessage: (in category 'instance creation - managed') ----- gcMessage: message "Like #message: but automatically free'd when message gets garbage collected. Thus, the callback holds only weakly to the message and the sender MUST take care of not loosing the reference as long as needed. BEWARE that any external library using a free'd NULL callback will most likely SEGFAULT." + ^ self externalNewGC - ^ self newGC setMessage: message; yourself ! Item was changed: ----- Method: FFICallback class>>gcSignature:block: (in category 'instance creation - managed') ----- gcSignature: signature "<String>" block: aBlock "<BlockClosure> ^<FFICallback>" "Like #signature:block: but automatically free'd when aBlock gets garbage collected. Thus, the callback holds only weakly to aBlock and the sender MUST take care of not loosing the reference as long as needed. BEWARE that any external library using a free'd NULL callback will most likely SEGFAULT." + ^ self externalNewGC - ^ self newGC setBlock: aBlock signature: signature; yourself! Item was changed: ----- Method: FFICallback class>>gcSignature:message: (in category 'instance creation - managed') ----- gcSignature: signature "<String>" message: message "<MessageSend> ^<FFICallback>" "Like #signature:message: but automatically free'd when message gets garbage collected. Thus, the callback holds only weakly to the message and the sender MUST take care of not loosing the reference as long as needed. BEWARE that any external library using a free'd NULL callback will most likely SEGFAULT." + ^ self externalNewGC - ^ self newGC setMessage: message signature: signature; yourself! Item was changed: ----- Method: FFICallback class>>initialize (in category 'class initialization') ----- initialize Smalltalk addToStartUpList: self after: FFIPlatformDescription. + + self initializeExecutablePages. self initializeCallbacks.! Item was added: + ----- Method: FFICallback class>>initializeExecutablePages (in category 'class initialization') ----- + initializeExecutablePages + + ExecutablePages := Set new. + ExecutablePagesAccessProtect := Semaphore forMutualExclusion.! Item was changed: ----- Method: FFICallback class>>message: (in category 'instance creation') ----- message: message "<MessageSend> ^<FFICallback>" "Answers a new FFI callback for the given message (send). The callback signature will be looked up in the actual method's callback pragma." + ^ self externalNew - ^ self new setMessage: message; yourself ! Item was removed: - ----- Method: FFICallback class>>new (in category 'instance creation') ----- - new - - ^ self basicNew! Item was changed: ----- Method: FFICallback class>>newGC (in category 'instance creation - managed') ----- newGC + ^ self new - ^ self basicNew beManaged; yourself! Item was added: + ----- Method: FFICallback class>>primAllocateExecutablePage (in category 'executable pages') ----- + primAllocateExecutablePage "^<Alien>" + "Answer an Alien around a piece of (probably malloced) memory, of some multiple + of the pagesize, that has execute permissions set. This memory can be parcelled + out to individual FFICallbackThunks to hold their thunk/trampoline machine code." + <primitive: 'primAllocateExecutablePage' module: 'IA32ABI' error: errorCode> + ^self primitiveFailed! Item was changed: ----- Method: FFICallback class>>signature:block: (in category 'instance creation') ----- signature: signature "<String | Array>" block: aBlock "<BlockClosure> ^<FFICallback>" "Answers a new FFI callback for the given signature and block. The signature can have the form of a callback pragma, a list of type names, or a list of actual types. The first type is always the return type." + ^ self externalNew - ^ self new setBlock: aBlock signature: signature; yourself! Item was changed: ----- Method: FFICallback class>>signature:message: (in category 'instance creation') ----- signature: signature "<String | Array>" message: message "<MessageSend> ^<FFICallback>" "Answers a new FFI callback for the given signature and message (send). The signature can have the form of a callback pragma, a list of type names, or a list of actual types. The first type is always the return type." + ^ self externalNew - ^ self new setMessage: message signature: signature; yourself! Item was changed: ----- Method: FFICallback class>>startUp: (in category 'system startup') ----- startUp: resuming "Any thunks in the finalization registry at the time the image comes up in a new session MUST NOT be finalized and should immediately be discarded. Their thunk pointers are no longer valid." + resuming ifTrue: [ + self initializeExecutablePages. + self initializeCallbacks].! - resuming ifTrue: [self initializeCallbacks].! Item was added: + ----- Method: FFICallback>>addToAlienThunkTable (in category 'alien compatibility') ----- + addToAlienThunkTable + + | weakValueMap | + self flag: #alienCompatibility. + weakValueMap := (self environment classNamed: #Callback) classPool at: #ThunkToCallbackMap. + weakValueMap at: handle asInteger put: self.! Item was added: + ----- Method: FFICallback>>evaluateInContext: (in category 'evaluating') ----- + evaluateInContext: callbackContext "<FFICallbackContext> ^<Integer>" + + ^ evaluator + ifNil: [self evaluateDynamic: callbackContext] + ifNotNil: [evaluator perform: callbackContext]! Item was changed: ----- Method: FFICallback>>free (in category 'initialize-release') ----- free handle ifNil: [^ self]. ThunkToCallbackMap removeKey: handle. + AlienStub isAlienLoaded ifTrue: [self removeFromAlienThunkTable]. + self zeroMemory. + + self flag: #discuss. "mt: Hold on to NULL pointer if external address?" handle := nil. ! Item was changed: ----- Method: FFICallback>>init__ccall (in category 'private') ----- init__ccall "Initialize the receiver with a __ccall thunk." + ExecutablePagesAccessProtect critical: [ + FFIPlatformDescription current abiSend: #'init_ccall' to: self].! - FFIPlatformDescription current abiSend: #'init_ccall' to: self.! Item was changed: ----- Method: FFICallback>>init__stdcall: (in category 'private') ----- init__stdcall: numBytes "Initialize the receiver with a __stdcall thunk with numBytes argument bytes." + ExecutablePagesAccessProtect critical: [ + FFIPlatformDescription current abiSend: #'init_stdcall' to: self with: numBytes].! - FFIPlatformDescription current abiSend: #'init_stdcall' to: self with: numBytes.! Item was added: + ----- Method: FFICallback>>removeFromAlienThunkTable (in category 'alien compatibility') ----- + removeFromAlienThunkTable + + | weakValueMap | + self flag: #alienCompatibility. + weakValueMap := (self environment classNamed: #Callback) classPool at: #ThunkToCallbackMap. + weakValueMap removeKey: handle asInteger! Item was changed: ----- Method: FFICallback>>setResultType:argumentTypes:evaluableObject: (in category 'private') ----- setResultType: anExternalType argumentTypes: moreExternalTypes evaluableObject: blockOrMessage self evaluableObject: blockOrMessage. argumentTypes := moreExternalTypes. resultType := anExternalType. "Support for callee pop callbacks (Pascal calling convention such as the Win32 stdcall: convention) are supported using the <calleepops: N> pragma which specifies how many bytes to pop. See http://forum.world.st/Pharo-FFI-on-aarch64-arm64-td5096777.html#a5096786." - handle := FFICallbackMemory allocateExecutableBlock getHandle. self init__ccall. "self init__stdcall: 0." "(method pragmaAt: #calleepops:) ifNil: [self init__ccall] ifNotNil: [:pragma | self init__stdcall: (pragma argumentAt: 1)]." + "numEvaluatorArgs := (evaluator := method selector) numArgs."! - "numEvaluatorArgs := (evaluator := method selector) numArgs. - self addToThunkTable" - ThunkToCallbackMap at: handle put: self! Item was changed: + ----- Method: FFICallback>>valueInContext: (in category 'alien compatibility') ----- + valueInContext: alien "<VMCallbackContext> ^<Integer>" + "Re-interpret Alien-specific context as Squeak-FFI-specific context." - ----- Method: FFICallback>>valueInContext: (in category 'evaluating') ----- - valueInContext: callbackContext "<FFICallbackContext> ^<Integer>" + self flag: #alienCompatibility. + ^ self evaluateInContext: (FFICallbackContext fromHandle: alien addressField)! - ^ evaluator - ifNil: [self evaluateDynamic: callbackContext] - ifNotNil: [evaluator perform: callbackContext]! Item was added: + ----- Method: FFICallback>>zeroMemory (in category 'initialize-release') ----- + zeroMemory + + ExecutablePagesAccessProtect critical: [ + super zeroMemory].! Item was changed: ----- Method: FFICallbackContext class>>fromHandle: (in category 'instance creation') ----- fromHandle: aHandleOrInteger + "Overwritten to support address-as-integer, which is the default for primitives in the IA32ABI plugin. See #primMostRecentCallbackContextAddress and #invokeCallbackContext:" + - ^ super fromHandle: (aHandleOrInteger isInteger ifTrue: [ExternalAddress fromInteger: aHandleOrInteger] ifFalse: [aHandleOrInteger])! Item was changed: ----- Method: FFICallbackContext class>>mostRecent (in category 'instance lookup') ----- mostRecent + + ^ self fromHandle: self primMostRecentCallbackContextAddress! - - ^ FFICallbackMemory mostRecentCallbackContext! Item was added: + ----- Method: FFICallbackContext class>>primMostRecentCallbackContextAddress (in category 'primitives') ----- + primMostRecentCallbackContextAddress + "Answer the address of the mostRecentCallbackContext, which will be 0 if no callback is running. + Does not fail (if the plugin is present and implements the primitive)." + <primitive: 'primMostRecentCallbackContext' module: 'IA32ABI' error: ec> + self primitiveFailed.! Item was removed: - ByteArray variableByteSubclass: #FFICallbackMemory - instanceVariableNames: '' - classVariableNames: 'AccessProtect AllocatedThunks ExecutablePages LifoCallbackSemaphore' - poolDictionaries: 'FFICallbackConstants' - category: 'FFI-Callbacks'! - - !FFICallbackMemory commentStamp: 'mt 6/17/2020 12:24' prior: 0! - Interface for memory allocation using the IA32ABI plugin. Also used as a compatibility layer for Alien. - - *** - - An instance of FFICallbackThunk is a reference to a machine-code thunk/trampoline that calls-back into the VM. The reference can be passed to C code which can use it as a function pointer through which to call-back into Smalltalk. The machine-code thunk/trampoline is different for each instance, hence its address is a unique key that can be used to assocuate the Smalltalk side of the call-back (e.g. a block) with the thunk. Since thunks must be executable and some OSs may not provide default execute permission on memory returned by malloc we may not be able to use malloc directly. Instead we rely on a primitive to provide memory that is guaranteed to be executable. ExternalAddress class>>allocateExecutablePage answers an instance of ExternalData that references an executable piece of memory that is some (possiby unitary) multiple of the pagesize. Class-side code then parcels out pieces of a page to individual thunks. These pieces are recycled when thunks are reclaimed. Sinc e the first byte of a thunk is non-zero we can use it as a flag indicating if the piece is in use or not. - - See FFICallback for the higher-level construct that represents a Smalltalk block to be run in response to a callback. Callbacks wrap instances of FFICallbackThunk and FFICallbackContext instances that describe the stack layout and register contents for receiving callback arguments. - - Class Variables - AccessProtect <Semaphore> critical section for ExecutablePages (de)allocation - AllocatedThunks <AlienWeakTable of <FFICallbackThunk -> Integer>> - weak collection of thunks, used to return thunk storage to the executable page pool. - ExecutablePages <Set of: Alien "executable page"> - collection of pages with execute permissions used to provide executable thunks! Item was removed: - ----- Method: FFICallbackMemory class>>allocateExecutableBlock (in category 'executable pages') ----- - allocateExecutableBlock - - | blockSize | - blockSize := MaxThunkSize. - AccessProtect critical: - [ExecutablePages do: - [:page | - 1 to: page size - blockSize by: blockSize do: - [:i| - (page at: i) = 0 ifTrue: - [page at: i put: 1. - ^ page from: i to: i + blockSize - 1]]]]. - AccessProtect critical: [ - | newPage | - newPage := ExecutablePages add: self allocateExecutablePage. - ^ (newPage from: 1 to: blockSize) - at: 1 put: 1; - yourself]! Item was removed: - ----- Method: FFICallbackMemory class>>allocateExecutablePage (in category 'executable pages') ----- - allocateExecutablePage - "Forward allocation to ExternalAddress, which already sends primitives to allocate memory." - - ^ ExternalAddress allocateExecutablePage! Item was removed: - ----- Method: FFICallbackMemory class>>ensureInSpecialObjectsArray (in category 'class initialization') ----- - ensureInSpecialObjectsArray - "FFICallbackMemory must be in the specialObjectsArray to enable the FFI callback mechanism. Because of - the bootstrap the specialObjectsArray may already have been partially initialized with - the callback selector and to be large enough (as part of loading immutability), but - it will be missing FFICallbackMemory until FFICallbackMemory is loaded. So check if the specialObjectsArray is - of the expected size before recreating and slam FFICallbackMemory in if the specialObjectsArray - is already large enough." - - | index | - self ~~ FFICallbackMemory ifTrue: [^self]. - - index := 53. - ((Smalltalk includesKey: #VMObjectIndices) - and: [((Smalltalk at: #VMObjectIndices) classPool at: #ClassAlien ifAbsent: []) ~= (index - 1)]) ifTrue: - [self error: 'index probably wrong']. - - Smalltalk specialObjectsArray size < index ifTrue: - [Smalltalk recreateSpecialObjectsArray]. - - Smalltalk specialObjectsArray size < index ifTrue: - [self error: 'SystemDictionary>>recreateSpecialObjectsArray appears incompatible']. - - ((Smalltalk specialObjectsArray at: index) ~~ nil - and: [(Smalltalk specialObjectsArray at: index) ~~ self]) ifTrue: - [self error: 'Alien is already installed. You should not load FFI-Callbacks, too.']. - - (Smalltalk specialObjectsArray at: index) ifNil: - [Smalltalk specialObjectsArray at: index put: self]! Item was removed: - ----- Method: FFICallbackMemory class>>forOop (in category 'instance creation') ----- - forOop - " DANGEROUS!! Use during callbacks only or oop will be come invalid!! - object := Morph new. - handle := FFICallbackMemory forOop. - handle oopAt: 1 put: object. - handle oopAt: 1. - " - - ^ self new - sizeFieldPut: ExternalAddress wordSize; - yourself ! Item was removed: - ----- Method: FFICallbackMemory class>>fromInteger: (in category 'instance creation') ----- - fromInteger: anInteger - "Like the extension in ExternalAddress, but duplicate byte size to follow the alien format as expected in the IA32ABI plugin." - - ^ self new - addressFieldPut: anInteger; - yourself ! Item was removed: - ----- Method: FFICallbackMemory class>>initialize (in category 'class initialization') ----- - initialize - - self ensureInSpecialObjectsArray. - Smalltalk addToStartUpList: self after: FFIPlatformDescription. - LifoCallbackSemaphore := Semaphore new. - - AccessProtect := Semaphore forMutualExclusion. - "AllocatedThunks := AlienWeakTable newForOwner: self." - ExecutablePages := Set new.! Item was removed: - ----- Method: FFICallbackMemory class>>invokeCallbackContext: (in category 'callbacks') ----- - invokeCallbackContext: vmCallbackContextAddress "<Integer>" - "The low-level entry-point for callbacks sent from the VM/IA32ABI plugin. - Evaluate the callback corresponding to the thunk referenced by vmCallbackContextAddress, - a pointer to a VMCallbackContext32 or VMCallbackContext64, set up by the VM's thunkEntry - routine. Return from the Callback via primSignal:andReturnAs:fromContext:. thisContext's - sender is typically an FFI call-out context and is restored as the Process's top context on return. - Therefore callbacks run on the process that did the call-out in which the callback occurred." - - | callbackContext typeCode helper | - callbackContext := FFICallbackContext fromHandle: vmCallbackContextAddress. - helper := self fromInteger: vmCallbackContextAddress. - - [typeCode := callbackContext callback valueInContext: callbackContext] - ifCurtailed: [self error: 'attempt to non-local return across a callback']. - typeCode ifNil: - [typeCode := callbackContext errorResult]. - - "Now attempt to return from a Callback. This must be done in LIFO order. The IA32ABI - plugin maintains a linked list of vmCallbackContextAddresses to record this order. If - vmCallbackContextAddress *is* that of the most recent Callback then the return will - occur and the primitive will not return here. If vmCallbackContextAddress *is not* that - of the most recent Callback the primitive will answer false, in which case this process - waits on the lifoCallbackSemaphore which will be signalled by some other attempted - Callback return. In any case (successful return from callback or answering false here), - the primtive signals the first process waiting on the semaphore (which is after this one - if this one was waiting), allowing the next process to attempt to return, and so on. - Hence all nested callbacks should eventually return, and in the right order." - [helper primSignal: LifoCallbackSemaphore andReturnAs: typeCode fromContext: thisContext] - whileFalse: - [LifoCallbackSemaphore wait]! Item was removed: - ----- Method: FFICallbackMemory class>>mostRecentCallbackContext (in category 'callbacks') ----- - mostRecentCallbackContext - - ^ FFICallbackContext fromHandle: self primMostRecentCallbackContextAddress! Item was removed: - ----- Method: FFICallbackMemory class>>new (in category 'instance creation') ----- - new - "Only used for holding (alien) pointers." - - ^ super new: ExternalAddress wordSize * 2! Item was removed: - ----- Method: FFICallbackMemory class>>new: (in category 'instance creation') ----- - new: n - - self shouldNotImplement.! Item was removed: - ----- Method: FFICallbackMemory class>>primMostRecentCallbackContextAddress (in category 'callbacks') ----- - primMostRecentCallbackContextAddress - "Answer the address of the mostRecentCallbackContext, which will be 0 if no callback is running. - Does not fail (if the plugin is present and implements the primitive)." - <primitive: 'primMostRecentCallbackContext' module: 'IA32ABI' error: ec> - self primitiveFailed.! Item was removed: - ----- Method: FFICallbackMemory class>>startUp: (in category 'system startup') ----- - startUp: resuming - - resuming ifTrue: - [ ExecutablePages := Set new. - LifoCallbackSemaphore := Semaphore new ]! Item was removed: - ----- Method: FFICallbackMemory class>>unload (in category 'class initialization') ----- - unload - - Smalltalk removeFromStartUpList: self. - Smalltalk specialObjectsArray at: 53 put: nil.! Item was removed: - ----- Method: FFICallbackMemory>>addressField (in category 'alien compatibility') ----- - addressField "^<Integer>" - <primitive: 'primAddressField' module: 'IA32ABI' error: errorCode> - - ^ (ExternalData fromHandle: self type: ExternalType uintptr_t) - at: ExternalData wordSize + 1! Item was removed: - ----- Method: FFICallbackMemory>>addressFieldPut: (in category 'alien compatibility') ----- - addressFieldPut: value "<Integer> ^<Integer>" - <primitive: 'primAddressFieldPut' module: 'IA32ABI' error: errorCode> - - self notify: 'Primitive failed. Proceed to use fallback code.'. - ^ (ExternalData fromHandle: self type: ExternalType uintptr_t) - at: ExternalAddress wordSize "Alien size prefix bytes" + 1 "Start of pointer address" - put: value! Item was removed: - ----- Method: FFICallbackMemory>>byteSize (in category 'accessing') ----- - byteSize - "Answer the number of bytes that are allocated when following the #externalPointer." - ^ self sizeField abs! Item was removed: - ----- Method: FFICallbackMemory>>externalPointer (in category 'accessing') ----- - externalPointer - "Answer the address that points to allocated memory of #byteSize num bytes." - ^ ExternalAddress fromInteger: self addressField! Item was removed: - ----- Method: FFICallbackMemory>>externalPointer: (in category 'accessing') ----- - externalPointer: anExternalAddress - - self addressFieldPut: anExternalAddress asInteger.! Item was removed: - ----- Method: FFICallbackMemory>>oopAt: (in category 'alien compatibility') ----- - oopAt: byteOffset - "Access for callbacks that want to exchange Smalltalk objects." - <primitive: 'primOopAt' module: 'IA32ABI' error: errorCode> - ^self primitiveFailed! Item was removed: - ----- Method: FFICallbackMemory>>oopAt:put: (in category 'alien compatibility') ----- - oopAt: byteOffset put: value - "Access for callbacks that want to exchange Smalltalk objects." - <primitive: 'primOopAtPut' module: 'IA32ABI' error: errorCode> - ^self primitiveFailed! Item was removed: - ----- Method: FFICallbackMemory>>primSignal:andReturnAs:fromContext: (in category 'callbacks') ----- - primSignal: aSemaphore andReturnAs: typeCode fromContext: context - "Attempt to return from a callback. This must be done in LIFO order. The IA32ABI - plugin maintains a linked list of vmCallbackContextAddresses to record this order. - If vmCallbackContextAddress *is* that of the most recent Callback then return from - the callback and do not return here. If vmCallbackContextAddress *is not* that of - the most recent Callback then succeed but answer false. In either case, signal the - first process waiting on aSemaphore. See Alien class>> invokeCallbackContext: - for a full explanation. Fail if the arguments are not of the expected type." - <primitive: 'primReturnAsFromContextThrough' module: 'IA32ABI' error: ec> - ^ self primitiveFailed! Item was removed: - ----- Method: FFICallbackMemory>>sizeField (in category 'alien compatibility') ----- - sizeField "^<Integer>" - <primitive: 'primSizeField' module: 'IA32ABI' error: errorCode> - - "For some reason, the size is stored as intptr_t, not uintpr_t." - ^ (ExternalData fromHandle: self type: ExternalType intptr_t) - at: 1! Item was removed: - ----- Method: FFICallbackMemory>>sizeFieldPut: (in category 'alien compatibility') ----- - sizeFieldPut: size "<Integer> ^<Integer>" - <primitive: 'primSizeFieldPut' module: 'IA32ABI' error: errorCode> - - self notify: 'Primitive failed. Proceed to use fallback code.'. - - "For some reason, the size is stored as intptr_t, not uintpr_t." - ^ (ExternalData fromHandle: self type: ExternalType intptr_t) - at: 1 put: size!

1 0

Jump to page: