FFI: FFI-Kernel-mt.127.mcz

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

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

Name: FFI-Kernel-mt.127
Author: mt
Time: 4 May 2021, 9:54:26.141881 am
UUID: 143e5c5b-ccff-9143-823d-4d6657005d2c
Ancestors: FFI-Kernel-mt.126

Makes extra type checks optional, disabled by default. (This feature more care because some checks are wrong. Thanks to Ron for reporting this!)

(Also fixes Character zero, which should actually be the NUL character.)

=============== Diff against FFI-Kernel-mt.126 ===============

Item was changed:
  ----- Method: Character class>>zero (in category '*FFI-Kernel') -----
  zero
  "See ExternalStructure >> #zeroMemory."
 
+ ^ Character value: 0!
- ^ $0!

Item was changed:
  ----- Method: ExternalStructureType>>checkType (in category 'external structure') -----
  checkType
 
+ self class extraTypeChecks ifFalse: [^ self].
+
  self
  assert: [self isPointerType not]
  description: 'Convert to ExternalType to use this feature'.
 
  referentClass ifNil: [self error: 'Unknown structure type'].
  self isEmpty ifTrue: [self error: 'Empty structure'].
  !

Item was changed:
  ----- Method: ExternalStructureType>>handle:at: (in category 'external data') -----
  handle: handle at: byteOffset
  "Read the receiver's external type using the given handle and the byteOffset. This is the dynamic version of #readFieldAt:."
 
  | result |
+ self checkType.
- self
- assert: [self isPointerType not]
- description: 'Use ExternalStructure to use this feature.'.
 
- referentClass ifNil: [self error: 'Unknown structure type'].
- self isEmpty ifTrue: [self error: 'Empty structure'].
-
  result := self isAtomic
  ifTrue: [
  handle "alias to atomic"
  perform: (AtomicSelectors at: self atomicType)
  with: byteOffset]
  ifFalse: [
  handle "regular struct or alias to struct or alias to pointer"
  structAt: byteOffset length: self byteSize].
 
  ^ referentClass fromHandle: result!

Item was changed:
  ----- Method: ExternalStructureType>>handle:at:put: (in category 'external data') -----
  handle: handle at: byteOffset put: value
  "Write a value using the receiver's external type at the given handle and byteOffset. This is the dynamic version of #writeFieldAt:with:."
 
+ self checkType.
- self
- assert: [self isPointerType not]
- description: 'Use ExternalType to use this feature.'.
-
- referentClass ifNil: [self error: 'Unknown structure type'].
- self isEmpty ifTrue: [self error: 'Empty structure'].
 
  self isAtomic
  ifTrue: [ "alias to atomic"
  self flag: #addTypeCheck. "mt: Note that there is currently no mapping from objects that represent valid atomics to atomic types."
  ^ handle
  perform: ((AtomicSelectors at: self atomicType), 'put:') asSymbol
  with: byteOffset
  with: value getHandle]
  ifFalse: [ "regular struct or alias to struct or alias to pointer"
  self assert: [value externalType == self].
  ^ handle
  structAt: byteOffset
  put: value getHandle
  length: self byteSize].!

Item was changed:
  ----- Method: ExternalStructureType>>writeAliasWith: (in category 'external structure') -----
  writeAliasWith: valueName
  "this is an aliased structure type"
  "expect the value have that structure type with either byte array or external address as handle"
 
  self checkType.
 
  ^ String streamContents: [:s |
+ self class extraTypeChecks ifTrue: [
+ s nextPutAll: ('self assert: [{1} class externalType == {2}].' format: {valueName. self storeString}); crtab].
- s nextPutAll: ('self assert: [{1} class externalType == {2}].' format: {valueName. self storeString}); crtab.
  s nextPutAll:'handle := ', valueName,' getHandle']!

Item was changed:
  ----- Method: ExternalStructureType>>writeFieldAt:with: (in category 'external structure') -----
  writeFieldAt: byteOffset with: valueName
  "Answer a string defining the accessor to an entity of the receiver type starting at the given byte offset.
  Private. Used for field definition only."
 
  self checkType.
 
  ^String streamContents:[:s|
  self isAtomic
  ifTrue: [ "alias to atomic"
+ self class extraTypeChecks ifTrue: [
+ self flag: #addTypeCheck. "mt: Note that there is currently no mapping from objects that represent valid atomics to atomic types."].
- self flag: #addTypeCheck. "mt: Note that there is currently no mapping from objects that represent valid atomics to atomic types."
  s nextPutAll:'handle ';
  nextPutAll: (AtomicSelectors at: self atomicType);
  space; print: byteOffset;
  nextPutAll:' put: ';
  nextPutAll: valueName;
  nextPutAll: ' getHandle']
  ifFalse: [ "regular struct or alias to struct or alias to pointer"
+ self class extraTypeChecks ifTrue: ["expect either byte array or external address as handle"
+ s nextPutAll: ('self assert: [{1} class externalType == {2}].' format: {valueName. self storeString}); crtab].
- "expect either byte array or external address as handle"
- s nextPutAll: ('self assert: [{1} class externalType == {2}].' format: {valueName. self storeString}); crtab.
 
  self isTypeAliasForPointer
  ifFalse: [
  s nextPutAll:'handle structAt: ';
  print: byteOffset;
  nextPutAll:' put: ';
  nextPutAll: valueName;
  nextPutAll:' getHandle';
  nextPutAll:' length: ';
  print: self byteSize;
  nextPutAll:'.']
  ifTrue: [
  s nextPutAll:'handle pointerAt: ';
  print: byteOffset;
  nextPutAll:' put: ';
  nextPutAll: valueName;
  nextPutAll:' getHandle asExternalPointer';
  nextPutAll:' length: ';
  print: self byteSize;
  nextPutAll:'.']]].!

Item was changed:
  Object subclass: #ExternalType
  instanceVariableNames: 'compiledSpec referentClass referencedType byteAlignment'
+ classVariableNames: 'AtomicSelectors AtomicTypeNames AtomicTypes ExtraTypeChecks StructTypes'
- classVariableNames: 'AtomicSelectors AtomicTypeNames AtomicTypes StructTypes'
  poolDictionaries: 'FFIConstants'
  category: 'FFI-Kernel'!
 
  !ExternalType commentStamp: 'mt 6/5/2020 18:25' prior: 0!
  An external type represents the type of external objects.
 
  Instance variables:
  compiledSpec <WordArray> Compiled specification of the external type
  referentClass <Behavior | nil> Class type of argument required
  referencedType <ExternalType> Associated (non)pointer type with the receiver
  byteAlignment <Integer | nil> The desired alignment for a field of the external type within a structure.  If nil it has yet to be computed.
 
  Compiled Spec:
  The compiled spec defines the type in terms which are understood by the VM. Each word is defined as:
  bits 0...15 - byte size of the entity
  bit 16 - structure flag (FFIFlagStructure)
   This flag is set if the following words define a structure
  bit 17 - pointer flag (FFIFlagPointer)
   This flag is set if the entity represents a pointer to another object
  bit 18 - atomic flag (FFIFlagAtomic)
   This flag is set if the entity represents an atomic type.
   If the flag is set the atomic type bits are valid.
  bits 19...23 - unused
  bits 24...27 - atomic type (FFITypeVoid ... FFITypeDoubleFloat)
  bits 28...31 - unused
 
  Note that all combinations of the flags FFIFlagPointer, FFIFlagAtomic, and FFIFlagStructure are invalid, EXCEPT from the following:
 
  FFIFlagPointer + FFIFlagAtomic:
  This defines a pointer to an atomic type (e.g., 'char*', 'int*').
  The actual atomic type is represented in the atomic type bits.
 
  FFIFlagPointer + FFIFlagStructure:
  This defines a structure which is a typedef of a pointer type as in
  typedef void* VoidPointer;
  typedef Pixmap* PixmapPtr;
  It requires a byte size of four or eight (e.g. a 32-bit or 64-bit pointer) to work correctly.
 
  [Note: Other combinations may be allowed in the future]
  !

Item was added:
+ ----- Method: ExternalType class>>extraTypeChecks (in category 'preferences') -----
+ extraTypeChecks
+ <preference: 'Extra type checks'
+ categoryList: #('FFI Kernel')
+ description: 'When true, there will be extra type checks during dynamic or compiled access to external objects (e.g. structures, unions).'
+ type: #Boolean>
+ ^ExtraTypeChecks ifNil:[false]!

Item was added:
+ ----- Method: ExternalType class>>extraTypeChecks: (in category 'preferences') -----
+ extraTypeChecks: aBoolean
+
+ ExtraTypeChecks = aBoolean ifTrue: [^ self].
+
+ ExtraTypeChecks := aBoolean.
+
+ Cursor wait showWhile: [
+ "Recompile all compiled artifacts."
+ ExternalStructure defineAllFields].!

Item was changed:
  ----- Method: ExternalType>>checkType (in category 'external structure') -----
  checkType
 
+ self class extraTypeChecks ifFalse: [^ self].
+
  (self isPointerType not and: [referentClass notNil])
  ifTrue: [self error: 'Must convert to ExternalStructureType before use'].
 
  self
  assert: [self isStructureType not]
  description: 'Convert to ExternalStructureType to use this feature'.!

Item was changed:
  ----- Method: ExternalType>>writeAliasWith: (in category 'external structure') -----
  writeAliasWith: valueName
 
  self checkType.
 
  ^ String streamContents: [:s |
  self isPointerType
  ifFalse: [
  "this is an aliased atomic non-pointer type"
+ self class extraTypeChecks ifTrue: [
+ self flag: #addTypeCheck. "mt: Note that there is currently no mapping from objects that represent valid atomics to atomic types."].
- self flag: #addTypeCheck. "mt: Note that there is currently no mapping from objects that represent valid atomics to atomic types."
  s nextPutAll:'handle := ', valueName, '.']
  ifTrue: [
  "this is an aliased pointer type"
+ self class extraTypeChecks ifTrue: ["expect the value to be a structure/union/alias/data with an external address as handle"
+ s nextPutAll: ('self assert: [{1} externalType == {2}].' format: {valueName. self storeString}); crtab].
- "expect the value to be a structure/union/alias/data with an external address as handle"
- s nextPutAll: ('self assert: [{1} externalType == {2}].' format: {valueName. self storeString}); crtab.
  s nextPutAll:'handle := ', valueName,' getHandle asByteArrayPointer']]!

Item was changed:
  ----- Method: ExternalType>>writeFieldAt:with: (in category 'external structure') -----
  writeFieldAt: byteOffset with: valueName
  "Answer a string defining the accessor to an entity of the receiver type starting at the given byte offset.
  Private. Used for field definition only."
 
  self checkType.
 
  ^ String streamContents: [:s |
  self isPointerType
  ifFalse: [
  "Atomic value"
+ self class extraTypeChecks ifTrue: [
+ self flag: #addTypeCheck. "mt: Note that there is currently no mapping from objects that represent valid atomics to atomic types."].
- self flag: #addTypeCheck. "mt: Note that there is currently no mapping from objects that represent valid atomics to atomic types."
  s nextPutAll:'handle ';
  nextPutAll: (AtomicSelectors at: self atomicType);
  space; print: byteOffset;
  nextPutAll:' put: ';
  nextPutAll: valueName]
  ifTrue: [
  "Pointer to structure, union, type alias, or external data."
+ self class extraTypeChecks ifTrue: [
+ s nextPutAll: ('self assert: [{1} externalType == {2}].' format: {valueName. self storeString}); crtab].
- s nextPutAll: ('self assert: [{1} externalType == {2}].' format: {valueName. self storeString}); crtab.
  s nextPutAll:'handle pointerAt: ';
  print: byteOffset;
  nextPutAll:' put: ';
  nextPutAll: valueName;
  nextPutAll:' getHandle';
  nextPutAll: ' length: ';
  print: self byteSize;
  nextPutAll: '.']]!

Item was changed:
  (PackageInfo named: 'FFI-Kernel') postscript: 'Smalltalk removeFromStartUpList: ExternalAddress.
  Smalltalk removeFromStartUpList: ExternalObject.
 
  "Split up types for external structures from atomic types."
  ExternalType resetAllStructureTypes.
 
+ "Re-generate all field accessors because type checks are now controlled by a new preference."
- "Re-generate all field accessors because there are now type checks, too."
  ExternalStructure defineAllFields.
  '!