FFI: FFI-Callbacks-mt.5.mcz

Marcel Taeumel uploaded a new version of FFI-Callbacks to project FFI:
http://source.squeak.org/FFI/FFI-Callbacks-mt.5.mcz

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

Name: FFI-Callbacks-mt.5
Author: mt
Time: 30 April 2021, 7:10:05.967986 pm
UUID: 32dde9ab-5acb-384f-bade-83c10c63ecec
Ancestors: FFI-Callbacks-mt.4

Merges 2020/21 updates from VMMaker/Alien plugin:
- #voidResult
- #oopAt:put: (not yet compatible with SqueakFFI)
- #mostRecentCallbackContext + field "outerContext" for debugging
- better comments
- detect new ABI #ARM64

And simplify the existing #evaluateDynamic again. There is still logic missing when to switch between registers.

=============== Diff against FFI-Callbacks-mt.4 ===============

Item was changed:
  ----- Method: FFICallback class>>initialize (in category 'class initialization') -----
  initialize
 
+ Smalltalk addToStartUpList: self after: FFIPlatformDescription.
  ThunkToCallbackMap := WeakValueDictionary new.!

Item was added:
+ ----- 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:
+ [ThunkToCallbackMap := WeakValueDictionary new]!

Item was changed:
  ----- Method: FFICallback>>evaluateDynamic: (in category 'callback - evaluators') -----
  evaluateDynamic: callbackContext
  "Read all arguments and make the call(back). Assume that 'handle' and 'type' are set correctly. Only watch out for the sign. See field definition in FFICallbackContext to explore alternative ways to read the arguments."
 
  | offset args |
  offset := 1.
  args := Array new: argumentTypes size.
 
  1 to: args size do: [:argIndex |
  | argType data |
  argType := argumentTypes at: argIndex.
+ data := argType handle: handle at: offset.
-
- argType isPointerType
- ifTrue: [
- data := (type handle: handle at: offset).
-
- argType referentClass "pointer to atomic"
- ifNil: [data := data asType: argType]
- ifNotNil: [:structClass | "pointer to external structure or union"
- argType isTypeAliasToPointer
- ifTrue: [data := structClass fromHandle: data getHandle asByteArrayPointer]
- ifFalse: [data := structClass fromHandle: data getHandle]] ]
- ifFalse: [ "non-pointer type"
- self flag: #floats. "mt: When should we switch to callbackContext floatRegArgs?"
- data := argType handle: handle at: offset.
-
- argType isAtomic
- ifFalse: ["structure type, most likely type alias to pointer"
- data := argType referentClass
- fromHandle: (ExternalAddress fromInteger: data) asByteArrayPointer]
- ifTrue: [ argType isTypeAlias
- ifTrue: [ "alias to atomic type"
- data := argType referentClass fromHandle: data]
- ifFalse: [ "atomic, non-pointer type"
- data := data ";-)"]] ].
-
  args at: argIndex put: data.
+
+ "Move the offset. Consider the byte-alignment?"
  offset := offset + ((type byteSize max: argType byteSize) roundUpTo: type byteSize)].
 
  ^ self
  setResult: (evaluableObject valueWithArguments: args)
+ inContext: callbackContext!
- inContext: callbackContext.!

Item was changed:
  ----- Method: FFICallback>>evaluateDynamic_ARM32: (in category 'callback - evaluators') -----
  evaluateDynamic_ARM32: callbackContext
  "Set handle to access arguments as most appropriate for the ABI. For ''RISCs'' it is the pointer to the integer register."
  <abi: #ARM32> <evaluator>
 
+ | intRegArgs floatRegArgs stackPtr |
+ intRegArgs := callbackContext intRegArgs.
+ intRegArgs size: 4.
+ floatRegArgs := callbackContext floatRegArgs.
+ floatRegArgs size: 8.
+
+ stackPtr := callbackContext stackPtr.
+
+ self assert: [argumentTypes size <= intRegArgs size].
+
+ self setArgData: intRegArgs.
- self setArgData: callbackContext intRegArgs.
  ^ self evaluateDynamic: callbackContext!

Item was added:
+ ----- Method: FFICallback>>evaluateDynamic_ARM64: (in category 'callback - evaluators') -----
+ evaluateDynamic_ARM64: callbackContext
+ "Set handle to access arguments as most appropriate for the ABI. ARMv8 with AArch64."
+ <abi: #ARM64> <evaluator>
+
+ | intRegArgs floatRegArgs stackPtr |
+ intRegArgs := callbackContext intRegArgs.
+ intRegArgs size: 8.
+ floatRegArgs := callbackContext floatRegArgs.
+ floatRegArgs size: 8.
+
+ stackPtr := callbackContext stackPtr.
+
+ self assert: [argumentTypes size <= intRegArgs size].
+
+ self setArgData: intRegArgs.
+ ^ self evaluateDynamic: callbackContext!

Item was changed:
  ----- Method: FFICallback>>evaluateDynamic_IA32: (in category 'callback - evaluators') -----
  evaluateDynamic_IA32: callbackContext
  "Set handle to access arguments as most appropriate for the ABI. For x86 (i.e. IA32) it is the stack pointer."
+ <abi: 'IA32'> <evaluator>
- <abi: #IA32> <evaluator>
 
+ self setArgData: callbackContext stackPtr.
+ ^ self evaluateDynamic: callbackContext!
- | stackPtr offset args |
- stackPtr := callbackContext stackPtr. "For IA32, all arguments are on the stack."
-
- handle := stackPtr getHandle.
- type := stackPtr contentType. "intptr_t"
-
- offset := 1.
- args := Array new: argumentTypes size.
-
- 1 to: args size do: [:argIndex |
- | argType data |
- argType := argumentTypes at: argIndex.
- data := argType handle: handle at: offset.
- args at: argIndex put: data.
-
- "Move the offset. Consider the byte-alignment?"
- offset := offset + ((type byteSize max: argType byteSize) roundUpTo: type byteSize)].
-
- ^ self
- setResult: (evaluableObject valueWithArguments: args)
- inContext: callbackContext!

Item was changed:
  ----- Method: FFICallback>>evaluateDynamic_X64: (in category 'callback - evaluators') -----
  evaluateDynamic_X64: callbackContext
  "Set handle to access arguments as most appropriate for the ABI. For ''RISCs'' it is the pointer to the integer register."
  <abi: #X64> <evaluator>
 
+ | intRegArgs floatRegArgs stackPtr |
+ intRegArgs := callbackContext intRegArgs.
+ intRegArgs size: 6.
+ floatRegArgs := callbackContext floatRegArgs.
+ floatRegArgs size: 8.
+
+ stackPtr := callbackContext stackPtr.
+
+ self assert: [argumentTypes size <= intRegArgs size].
+
+ self setArgData: intRegArgs.
- self setArgData: callbackContext intRegArgs.
  ^ self evaluateDynamic: callbackContext!

Item was changed:
  ----- Method: FFICallback>>evaluateDynamic_X64Win64: (in category 'callback - evaluators') -----
  evaluateDynamic_X64Win64: callbackContext
  "Set handle to access arguments as most appropriate for the ABI. For ''RISCs'' it is the pointer to the integer register."
  <abi: #X64Win64> <evaluator>
+
+ | intRegArgs floatRegArgs stackPtr |
+ intRegArgs := callbackContext intRegArgs.
+ intRegArgs size: 4.
+ floatRegArgs := callbackContext floatRegArgs.
+ floatRegArgs size: 4.
 
+ stackPtr := callbackContext stackPtr.
+
+ self assert: [argumentTypes size <= intRegArgs size].
+
+ self setArgData: intRegArgs.
- self setArgData: callbackContext intRegArgs.
  ^ self evaluateDynamic: callbackContext!

Item was changed:
  ----- Method: FFICallback>>setArgData: (in category 'callback') -----
  setArgData: externalData
 
  handle := externalData getHandle.
+ type := externalData contentType. !
- type := externalData externalType. !

Item was changed:
  ----- Method: FFICallbackContext class>>fields (in category 'field definition') -----
  fields
  "
  self defineFields.
  "
  ^ #(
  (thunkp 'void*')
  (stackPtr 'intptr_t*') "was: char*"
  (intRegArgs 'intptr_t*') "was: long* or int*"
  (floatRegArgs 'double*')
  (nil 'void*') "was: savedCStackPointer"
  (nil 'void*') "was: savedCFramePointer"
  (rvs 'FFICallbackResult')
+ (nil 'void*') "was: savedPrimFunctionPointer"
+ (outerContext 'FFICallbackContext*') "jmp_buf trampoline --- for debugging only?"
  )
 
  "
  typedef struct {
      void *thunkp;
      char *stackptr;
      long *intRegArgs;
      double *floatRegArgs;
      void *savedCStackPointer;
      void *savedCFramePointer;
      union {
                              intptr_t vallong;
                              struct { int low, high; } valleint64;
                              struct { int high, low; } valbeint64;
                              double valflt64;
                              struct { void *addr; intptr_t size; } valstruct;
                          }   rvs;
  void *savedPrimFunctionPointer;
  jmp_buf trampoline;
  jmp_buf savedReenterInterpreter;
   } VMCallbackContext;
  "!

Item was changed:
+ ----- Method: FFICallbackContext>>voidResult (in category 'callback result') -----
- ----- Method: FFICallbackContext>>voidResult (in category 'callback result - convenience') -----
  voidResult
+ "Actually return garbage."
 
+ ^ ResultTypeWord!
- self flag: #discuss. "mt: Is this the expected answer in the IA32ABI plugin?"
- ^ self wordResult: 0!

Item was added:
+ ----- 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 changed:
  ----- Method: FFICallbackMemory class>>invokeCallbackContext: (in category 'callbacks') -----
+ invokeCallbackContext: vmCallbackContextAddress "<Integer>"
- invokeCallbackContext: vmCallbackContextAddress "<Integer>" "^<FFICallbackReturnValue>"
  "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."
+
- a pointer to a FFICallbackContext, set up by the VM's thunkEntry
- routine.  Return to C via primSignal:andReturnAs:fromContext:.  thisContext's sender is the
- call-out context."
  | callbackContext typeCode helper |
  callbackContext := FFICallbackContext fromHandle: vmCallbackContextAddress.
  helper := self fromInteger: vmCallbackContextAddress.
 
  [typeCode := FFICallback evaluateCallbackForContext: 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]!
- "Now attempt to return to C.  The primitive will answer false if this is not the most recent Callback,
- in which case we should wait on the lifoCallbackSemaphore which will be signalled when the most
- recent callback successfully returns.  If this is the most recent callback the primitive will signal all
- the processes waiting on the lifoCallbackSemaphore, one of which will be the next most recent.
- Hence all nested callbacks will end up returning in the right order."
- [helper primSignal: LifoCallbackSemaphore andReturnAs: typeCode fromContext: thisContext] whileFalse:
- [LifoCallbackSemaphore wait]!

Item was added:
+ ----- Method: FFICallbackMemory class>>mostRecentCallbackContext (in category 'callbacks') -----
+ mostRecentCallbackContext
+
+ ^ FFICallbackContext fromHandle: self primMostRecentCallbackContextAddress!

Item was added:
+ ----- 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 changed:
  ----- Method: FFICallbackMemory 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:
+ [ ExecutablePages := Set new.
+ LifoCallbackSemaphore := Semaphore new ]!
- ["AllocatedThunks removeAll."
- ExecutablePages := Set new]!

Item was added:
+ ----- 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 added:
+ ----- 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 changed:
  ----- 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."
- primSignal: aSemaphore "<Semaphore>" andReturnAs: typeCode "<SmallInteger>" fromContext: context "<MethodContext>"
  <primitive: 'primReturnAsFromContextThrough' module: 'IA32ABI' error: ec>
  ^ self primitiveFailed!

Item was changed:
  ----- Method: FFICallbackResult class>>fields (in category 'field definition') -----
  fields
  "
  self defineFields.
  "
  ^ #(
  (booleanResult 'bool')
  (floatResult 'double')
  (positiveIntegerResult 'uintptr_t')
  (integerResult 'intptr_t')
+ "(oopResult 'oop')" "Not yet working. Needs new atomic oop type to then call #oopAt:put: on ByteArray or ExternalAddress. See AtomicSelectors. Still, the IA32ABI plugin needs the Alien-form of a byte array. See FFICallbackMemory and its #oopAt:(put:) implementation. Maybe in the future Squeak FFI supports this interface on its regular handles, too."
  )!

Item was changed:
  ----- Method: FFIPlatformDescription>>abi (in category '*FFI-Callbacks') -----
  abi
 
  | processor |
  processor := self subtype asLowercase.
 
+ (#('aarch64' 'arm64') includes: processor)
+ ifTrue: [^ #ARM64 "#ARMv8 ???"].
  (processor = 'arm' or: [(processor beginsWith: 'armv') and: [processor fifth <= $7]])
+ ifTrue: [^ #ARM32].
- ifTrue: [^ #'ARM32'].
  (processor first = $i and: [processor = 'intel' or: ['i#86' match: processor]])
+ ifTrue: [^ #IA32].
- ifTrue: [^ #'IA32'].
 
  (processor first = $x and: [processor = 'x64' or: [('x86#64*' match: processor)]])
+ ifTrue: [^ self isWindows ifTrue: [#X64Win64] ifFalse: [#X64]].
- ifTrue: [^ self isWindows ifTrue: [#'X64Win64'] ifFalse: [#'X64']].
 
  ^ #'UNKNOWN_ABI'!