FFI: FFI-Callbacks-mt.25.mcz

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!