FFI: FFI-Callbacks-mt.13.mcz

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

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

Name: FFI-Callbacks-mt.13
Author: mt
Time: 14 May 2021, 4:19:38.426022 pm
UUID: b29d5eae-e802-c644-9431-430613ced096
Ancestors: FFI-Callbacks-mt.12

Fixes callbacks for 64-bit. Clean up some code in the qsort examples.

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

Item was changed:
  ----- Method: ExternalType class>>lookupTypes: (in category '*FFI-Callbacks') -----
  lookupTypes: signature
  "
  Supported arguments:
  '<callback: int (*) (double* double*)>' ... pragma as string
  #(int 'double*' 'double*') ... array with type names
  { ExternalType int. ExternalType double asPointerType. ExternalType double asPointerType } ... array with external types
  "
 
  (signature isString and: [signature first == $<]) ifTrue: [
  ^ (Parser new parse: 'foo', String cr, signature class: Object)
  properties pragmas first argumentAt: 1].
 
  signature first isString ifTrue: [
  ^ signature collect: [:typeName | self typeNamed: typeName]].
 
+ (signature first isKindOf: ExternalType) ifTrue: [
- signature first class == ExternalType ifTrue: [
  ^ signature].
 
  self error: 'Could not lookup external types from signature'.!

Item was changed:
  ----- Method: FFICallback class>>exampleCqsort01 (in category 'examples') -----
  exampleCqsort01
  "Call the libc qsort function (which requires a callback)."
  "FFICallback exampleCqsort01"
  "(Time millisecondsToRun: [100 timesRepeat: [FFICallback exampleCqsort]]) / 100.0"
 
+ | type cb rand nElements values orig sort libcName knownLibcNames fn |
- | type cb rand nElements sizeofDouble values orig sort libcName knownLibcNames fn |
 
  knownLibcNames := #('libobjc.dylib' 'libgcc_s.1.dylib' 'libc.dylib' 'libc.so.6' 'libc.so' 'msvcrt.dll').
  libcName := Project uiManager chooseFrom: knownLibcNames title: 'Choose your libc'.
  libcName = 0 ifTrue: [^ self].
  libcName := knownLibcNames at: libcName.
 
  rand := Random new.
  type := ExternalType double.
- sizeofDouble := type byteSize.
  nElements := 10.
+ values := type allocateExternal: nElements.
- values := ExternalData
- fromHandle: (ExternalAddress allocate: nElements * sizeofDouble)
- type: type asPointerType.
  "Initialize external data and set size for enumeration."
  1 to: nElements do: [:i| values at: i put: rand next].
- values size: nElements.
  "Fetch a local copy of the external data."
+ orig := values copy.
- orig := values collect: [:each | each].
 
  "Construct the callback structure."
  cb := FFICallback
  signature: '<callback: int (*)(double* double*)>'
  "signature: #(int 'double*' 'double*')"
  block: [ :arg1 :arg2 |
  | a  b |
+ a := arg1.
+ b := arg2.
- a := arg1 doubleAt: 1.
- b := arg2 doubleAt: 1.
- Transcript showln: ('Comparing {1} and {2}' format: {a. b}).
- self halt.
  (a - b) sign].
 
  "void qsort( void *base, size_t number, size_t width, int (__cdecl *compare )(const void *, const void *) );"
  fn := ExternalLibraryFunction
  name: 'qsort' module: libcName
  callType: ExternalLibraryFunction callTypeCDecl
  returnType: ExternalType void
  argumentTypes: (ExternalType lookupTypes: #('void*' size_t size_t 'void*')).
 
  "Invoke!!"
+ fn
+ invokeWith: values "getHandle"
+ with: nElements
+ with: type byteSize
+ with: cb thunk "getHandle".
- fn invokeWith: values "getHandle" with: nElements with: sizeofDouble with: cb thunk "getHandle".
 
  sort := values collect: [:each | each].
+ values free.
- values getHandle free.
  ^orig -> sort!

Item was changed:
  ----- Method: FFICallback class>>exampleCqsort02 (in category 'examples') -----
  exampleCqsort02
  "Call the libc qsort function (which requires a callback)."
  "
  FFICallback exampleCqsort02
  "
  "(Time millisecondsToRun: [100 timesRepeat: [FFICallback exampleCqsort]]) / 100.0"
 
  | type rand nElements sizeofDouble values orig sort |
 
  rand := Random new.
  type := ExternalType double.
  sizeofDouble := type byteSize.
  nElements := 10.
+ values := type allocateExternal: nElements.
- values := ExternalData
- fromHandle: (ExternalAddress allocate: nElements * sizeofDouble)
- type: type asPointerType.
  "Initialize external data and set size for enumeration."
  1 to: nElements do: [:i| values at: i put: rand next].
+
- values size: nElements.
  "Fetch a local copy of the external data."
+ orig := values copy.
+
- orig := values collect: [:each | each].
-
  "Invoke!!"
  self
+ qsort: values  with: values size with: values contentType byteSize
- qsort: values  with: nElements with: sizeofDouble
  with:  [ :arg1 :arg2 |
  | a  b |
+ a := arg1.
+ b := arg2.
- a := arg1 doubleAt: 1.
- b := arg2 doubleAt: 1.
- Transcript showln: ('Comparing {1} and {2}' format: {a. b}).
- self halt.
  (a - b) sign].
 
+ sort := values copy.
+ values free.
- sort := values collect: [:each | each].
- values getHandle free.
  ^orig -> sort!

Item was changed:
  ----- Method: FFICallback class>>exampleCqsort03 (in category 'examples') -----
  exampleCqsort03
  "Call the libc qsort function (which requires a callback)."
  "
  FFICallback exampleCqsort03
  "
  "(Time millisecondsToRun: [100 timesRepeat: [FFICallback exampleCqsort]]) / 100.0"
 
+ | type rand nElements values orig sort cb |
- | type rand nElements sizeofDouble values orig sort cb |
 
  rand := Random new.
  type := ExternalType double.
- sizeofDouble := type byteSize.
  nElements := 10.
+ values := type allocateExternal: nElements.
- values := ExternalData
- fromHandle: (ExternalAddress allocate: nElements * sizeofDouble)
- type: type asPointerType.
  "Initialize external data and set size for enumeration."
  1 to: nElements do: [:i| values at: i put: rand next].
+
- values size: nElements.
  "Fetch a local copy of the external data."
+ orig := values copy.
- orig := values collect: [:each | each].
 
  "Construct the callback structure."
  cb := FFICallback
  signature: '<callback: int (*)(double* double*)>'
  "signature: #(int 'double*' 'double*')"
  block: [ :arg1 :arg2 |
  | a  b |
+ a := arg1.
+ b := arg2.
- a := arg1 doubleAt: 1.
- b := arg2 doubleAt: 1.
- Transcript showln: ('Comparing {1} and {2}' format: {a. b}).
- self halt.
  (a - b) sign].
 
 
  "Invoke!!"
  self
+ cdeclQsort: values  with: values size with: values contentType byteSize
- cdeclQsort: values  with: nElements with: sizeofDouble
  with: cb thunk.
 
  sort := values collect: [:each | each].
+ values free.
- values getHandle free.
  ^orig -> sort!

Item was changed:
  ----- Method: FFICallback class>>exampleCqsort04 (in category 'examples') -----
  exampleCqsort04
  "
  FFICallback exampleCqsort04
  "
 
  | type in out fn cb |
  type := ExternalType int32_t.
  in := type allocateExternal: 10.
  1 to: in size do: [:each |
  in at: each put: 100 atRandom].
 
  cb := FFICallback
  signature: '<callback: int (*)(int32_t* int32_t*)>'
  "signature: #(int 'double*' 'double*')"
  block: [ :arg1 :arg2 |
  | a  b |
+ a := arg1.
+ b := arg2.
- a := arg1 signedLongAt: 1.
- b := arg2 signedLongAt: 1.
- Transcript showln: ('Comparing {1} and {2}' format: {a. b}).
-
  (a - b) sign].
 
  fn := ExternalLibraryFunction
  name: 'qsort' module: 'msvcrt.dll'
  callType: ExternalLibraryFunction callTypeCDecl
  returnType: ExternalType void
  argumentTypes: (ExternalType lookupTypes: #('void*' size_t size_t 'void*')).
 
  "Invoke!!"
  [fn
  invokeWith: in "getHandle"
  with: in size
  with: in contentType byteSize
  with: cb thunk "getHandle"]
  ifCurtailed: [in free].
 
+ out := in copy.
- out := in collect: [:each | each].
  in free.
  ^ out!

Item was changed:
  ----- Method: FFICallback class>>qsort:with:with:with: (in category 'examples') -----
  qsort: values with: number with: width with: block
  "Indirection to define the signature for the provided block."
  <callback: int (*)(double* double*)>
 
  | callback |
  callback := FFICallback
  signature: ((thisContext method pragmaAt: #callback:) argumentAt: 1)
  block: block.
+
-
  ^ self cdeclQsort: values with: number with: width with: callback thunk!

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."
 
  | byteOffset args intArgs intPos floatArgs floatPos |
 
  handle := callbackContext stackPtr getHandle.
  type := callbackContext stackPtr contentType.
  byteOffset := 1.
 
  intArgs := callbackContext integerArguments.
  intPos := 0.
  floatArgs := callbackContext floatArguments.
  floatPos := 0.
 
  args := Array new: argumentTypes size.
  1 to: args size do: [:argIndex |
  | argType data isPointer |
  argType := argumentTypes at: argIndex.
 
  "1) Try to read arguments from registers."
  data := (intPos < intArgs size and: [(isPointer := argType isPointerType) or: [argType isIntegerType]])
+ ifTrue: [intPos := intPos + 1. intArgs setContentType: argType. (intArgs at: intPos) value]
- ifTrue: [intPos := intPos + 1. intArgs at: intPos]
  ifFalse: [(floatPos < floatArgs size and: [argType isFloatType])
  ifTrue: [floatPos := floatPos + 1. floatArgs at: floatPos]].
 
  data
- ifNotNil: [ "1b) Materialize pointers from integers."
- isPointer ifTrue: [
- self flag: #designSmell. "mt: If we had a way to set, for example, double** as container type and double* as content type for intArgs, we would not have to construct the correct external object here but already had it."
- self flag: #discuss. "mt: Should we resolve atomic types? That is, double* to an actual float object etc? Well, for pointers to external structures (unions, ...) it would make sense to provide an actual instance of that structure to the callback... If so, we just need to send #value below."
- data := (ExternalData
- fromHandle: (ExternalAddress fromInteger: data)
- type: argType size: 1) "value"]]
  ifNil: [ "2) If nothing was read, read the argument from the stack."
  data := argType handle: handle at: byteOffset.
  byteOffset := byteOffset
  + ((type byteSize max: argType byteSize) roundUpTo: type byteAlignment)].
 
  args at: argIndex put: data].
 
  ^ self
  setResult: (evaluableObject valueWithArguments: args)
  inContext: callbackContext!