FFI: FFI-Kernel-mt.89.mcz

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

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

Name: FFI-Kernel-mt.89
Author: mt
Time: 4 June 2020, 3:58:25.336669 pm
UUID: 40d6dc34-2829-e141-ac5e-405a9753b67b
Ancestors: FFI-Kernel-mt.88

Serveral fixes concerning the creation for external struct types during field compilation in external structs. It is now possible to have a pointer to the same struct you are currently defining in the very first try.

typedef struct Link {
   struct Link* next;
} Link;

Note that I think there is no need for #initializeStructureTypes anymore. I may drop that in the near future in favor of the #platformChangedFrom:to: mechanism. :-)

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

Item was removed:
- ----- Method: ExternalFunction class>>forceTypeNamed: (in category 'compiler support') -----
- forceTypeNamed: aString
- ^ExternalType forceTypeNamed: aString!

Item was removed:
- ----- Method: ExternalFunction class>>isValidType: (in category 'compiler support') -----
- isValidType: anObject
- ^anObject isBehavior and:[anObject includesBehavior: ExternalStructure]!

Item was added:
+ ----- Method: ExternalFunction class>>newTypeNamed: (in category 'compiler support') -----
+ newTypeNamed: typeName
+ ^ExternalType newTypeNamed: typeName!

Item was added:
+ ----- Method: ExternalFunction class>>typeNamed: (in category 'compiler support') -----
+ typeNamed: aString
+ ^ExternalType typeNamed: aString!

Item was changed:
  ----- Method: ExternalStructure class>>byteAlignment (in category 'field definition') -----
  byteAlignment
- byteAlignment ifNil: [self compileFields].
- self assert: byteAlignment ~~ nil.
  ^ byteAlignment!

Item was changed:
  ----- Method: ExternalStructure class>>compileAlias:withAccessors: (in category 'field definition') -----
  compileAlias: spec withAccessors: aSymbol
  "Define all the fields in the receiver.
  Return the newly compiled spec."
+ | fieldName fieldTypeName isPointerField externalType newCompiledSpec |
- | fieldName fieldType isPointerField externalType newCompiledSpec |
  fieldName := spec first.
+ fieldTypeName := spec second.
+ isPointerField := fieldTypeName last = $*.
+ fieldTypeName := fieldTypeName copyWithout: $*.
+ externalType := (ExternalType typeNamed: fieldTypeName)
+ ifNil: [self errorTypeNotFound: spec second].
- fieldType := spec second.
- isPointerField := fieldType last = $*.
- fieldType := fieldType copyWithout: $*.
- externalType := ExternalType atomicTypeNamed: fieldType.
- externalType == nil ifTrue:["non-atomic"
- Symbol hasInterned: fieldType ifTrue:[:sym|
- externalType := ExternalType structTypeNamed: sym]].
- externalType == nil ifTrue:[
- Transcript show:'(', fieldType,' is void)'.
- externalType := ExternalType void].
  isPointerField ifTrue:[externalType := externalType asPointerType].
  (fieldName notNil and:[self shouldGenerate: fieldName policy: aSymbol]) ifTrue:[
  self defineAliasAccessorsFor: fieldName
  type: externalType].
  newCompiledSpec := isPointerField
  ifTrue:[WordArray with:
  (ExternalType structureSpec bitOr: ExternalType pointerSpec)]
  ifFalse:[externalType compiledSpec].
  byteAlignment := isPointerField
  ifTrue: [ExternalType pointerAlignment]
  ifFalse: [externalType byteAlignment].
  ^newCompiledSpec!

Item was changed:
  ----- Method: ExternalStructure class>>compileFields:withAccessors: (in category 'field definition') -----
  compileFields: specArray withAccessors: aSymbol
  "Compile a type specification for the FFI machinery.
  Return the newly compiled spec.
  Eventually generate the field accessors according to following rules:
  - aSymbol = #always always generate the accessors
  - aSymbol = #never never generate the accessors
  - aSymbol = #generated only generate the auto-generated accessors
  - aSymbol = #absent only generate the absent accessors"
  | newByteAlignment byteOffset typeSpec newCompiledSpec |
  (specArray size > 0 and: [specArray first class ~~ Array]) ifTrue:
  [^ self compileAlias: specArray withAccessors: aSymbol].
  byteOffset := 0.
  newByteAlignment := self minStructureAlignment.
  typeSpec := WriteStream on: (WordArray new: 10).
  typeSpec nextPut: FFIFlagStructure.
+ specArray do: [:spec |
+ | fieldName fieldTypeName isPointerField externalType typeSize fieldAlignment |
- "dummy for size"
- specArray do:
- [:spec | | fieldName fieldType isPointerField externalType typeSize fieldAlignment selfRefering |
  fieldName := spec first.
+ fieldTypeName := spec second.
+ isPointerField := fieldTypeName last = $*.
+ fieldTypeName := (fieldTypeName findTokens: '*') first withBlanksTrimmed.
+ externalType := (ExternalType typeNamed: fieldTypeName)
+ ifNil: [self errorTypeNotFound: spec second].
+ isPointerField ifTrue: [externalType := externalType asPointerType].
+ typeSize := externalType byteSize.
+ fieldAlignment := (externalType byteAlignment
+ max: self minFieldAlignment)
+ min: self maxFieldAlignment.
+ byteOffset := byteOffset alignedTo: fieldAlignment.
+ newByteAlignment := newByteAlignment max: fieldAlignment.
+ spec size > 2 ifTrue: ["extra size"
+ spec third < typeSize
+ ifTrue: [^ self error: 'Explicit type size is less than expected'].
+ typeSize := spec third.
- fieldType := spec second.
- isPointerField := fieldType last = $*.
- fieldType := (fieldType findTokens: '*') first withBlanksTrimmed.
- externalType := ExternalType atomicTypeNamed: fieldType.
- selfRefering := isPointerField and: [externalType isNil and: [fieldType = self asString]].
- selfRefering ifTrue: [
- externalType := ExternalType void asPointerType
- ] ifFalse:[
- externalType ifNil: ["non-atomic"
- (Symbol lookup: fieldType) ifNotNil: [:sym |
- externalType := ExternalType structTypeNamed: sym].
- ].
- externalType ifNil: [
- Transcript show: '(' , fieldType , ' is void)'.
- externalType := ExternalType void.
- ].
- isPointerField ifTrue: [externalType := externalType asPointerType]].
- typeSize := externalType byteSize.
- fieldAlignment := (externalType byteAlignment max: self minFieldAlignment)
- min: self maxFieldAlignment.
- byteOffset := byteOffset alignedTo: fieldAlignment.
- newByteAlignment := newByteAlignment max: fieldAlignment.
- spec size > 2 ifTrue: ["extra size"
- spec third < typeSize
- ifTrue: [^ self error: 'Explicit type size is less than expected'].
- typeSize := spec third.
- ].
- (fieldName notNil and: [self shouldGenerate: fieldName policy: aSymbol]) ifTrue: [
- self defineFieldAccessorsFor: fieldName startingAt: byteOffset + 1 type: externalType.
- ].
- typeSpec nextPutAll: (externalType embeddedSpecWithSize: typeSize).
- byteOffset := byteOffset + typeSize.
  ].
+ (fieldName notNil and: [self shouldGenerate: fieldName policy: aSymbol]) ifTrue: [
+ self defineFieldAccessorsFor: fieldName startingAt: byteOffset + 1 type: externalType.
+ ].
+ typeSpec nextPutAll: (externalType embeddedSpecWithSize: typeSize).
+ byteOffset := byteOffset + typeSize.
+ ].
 
  newByteAlignment := newByteAlignment min: self maxStructureAlignment.
  byteOffset := byteOffset alignedTo: newByteAlignment.
  newCompiledSpec := typeSpec contents.
  newCompiledSpec at: 1 put: (byteOffset bitOr: FFIFlagStructure).
  byteAlignment := newByteAlignment.
  ^ newCompiledSpec!

Item was added:
+ ----- Method: ExternalStructure class>>compileFieldsSilently (in category 'field definition') -----
+ compileFieldsSilently
+
+ compiledSpec := self compileFields: self fields withAccessors: #generated.
+ ^compiledSpec!

Item was changed:
  ----- Method: ExternalStructure class>>compiledSpec (in category 'field definition') -----
  compiledSpec
+ ^compiledSpec!
- "Return the compiled spec of the receiver"
- ^compiledSpec ifNil:[self compileFields].!

Item was added:
+ ----- Method: ExternalStructure class>>errorTypeNotFound: (in category 'field definition') -----
+ errorTypeNotFound: typeName
+
+ self error: ('Unknown external type ''{1}''. If it is a structure type, create a class for that structure first.' format: {typeName}).!

Item was changed:
+ ----- Method: ExternalType class>>atomicTypeNamed: (in category 'instance lookup') -----
- ----- Method: ExternalType class>>atomicTypeNamed: (in category 'private') -----
  atomicTypeNamed: aString
  ^AtomicTypes at: aString ifAbsent:[nil]!

Item was removed:
- ----- Method: ExternalType class>>forceTypeNamed: (in category 'private') -----
- forceTypeNamed: aString
- ^self newTypeNamed: aString force: true!

Item was changed:
  ----- Method: ExternalType class>>initializeStructureTypes (in category 'class initialization') -----
  initializeStructureTypes
  "ExternalType initialize"
+
+ | referentClassOrNil |
- | referentClass pointerType |
  self cleanupUnusedTypes.
+
+ StructTypes keysAndValuesDo:[:referentName :type |
+ referentClassOrNil := (self environment classNamed: referentName)
+ ifNotNil: [:cls | (cls  includesBehavior: ExternalStructure) ifTrue: [cls]].
+
+ self flag: #remove. "mt: Recompilation happens already via ExternalObject."
+ referentClassOrNil ifNotNil: [referentClassOrNil compileFieldsSilently].
+
+ type asNonPointerType
+ newReferentClass: referentClassOrNil.
+ type asPointerType
+ newReferentClass: referentClassOrNil.
+
- StructTypes keysAndValuesDo:[:referentName :type|
- referentClass := (Smalltalk at: referentName ifAbsent:[nil]).
- (referentClass isBehavior and:[
- referentClass includesBehavior: ExternalStructure])
- ifFalse:[referentClass := nil].
- type compiledSpec:
- (WordArray with: self structureSpec).
- type newReferentClass: referentClass.
- pointerType := type asPointerType.
- pointerType compiledSpec:
- (WordArray with: self pointerSpec);
- byteAlignment: self pointerAlignment.
- pointerType newReferentClass: referentClass.
  ].!

Item was added:
+ ----- Method: ExternalType class>>newTypeForStructureClass: (in category 'instance creation') -----
+ newTypeForStructureClass: anExternalStructureClass
+
+ | type referentClass |
+ referentClass := anExternalStructureClass.
+ self assert: [referentClass includesBehavior: ExternalStructure].
+
+ type := self newTypeForUnknownNamed: referentClass name.
+
+ referentClass compiledSpec
+ ifNil: [ "First time. The referent class' fields are probably just compiled for the first time."
+ type asNonPointerType setReferentClass: referentClass.
+ type asPointerType setReferentClass: referentClass]
+ ifNotNil: [
+ type asNonPointerType newReferentClass: referentClass.
+ type asPointerType newReferentClass: referentClass].
+
+ ^ type!

Item was added:
+ ----- Method: ExternalType class>>newTypeForUnknownNamed: (in category 'instance creation') -----
+ newTypeForUnknownNamed: typeName
+
+ | type pointerType |
+ self assert: [(StructTypes includesKey: typeName) not].
+
+ type := self basicNew
+ compiledSpec: (WordArray with: self structureSpec);
+ yourself.
+
+ pointerType := self basicNew
+ compiledSpec: (WordArray with: self pointerSpec);
+ yourself.
+
+ "Connect non-pointer type with pointer type."
+ type setReferencedType: pointerType.
+ pointerType setReferencedType: type.
+
+ "Remember this new struct type."
+ self flag: #discuss. "mt: Field definitions in external structures will usually have strings of the struct type, not symbols. At least, if it is a pointer to that struct type. Maybe we should always use strings instead of symbols?"
+ StructTypes at: typeName asSymbol put: type.
+
+ ^ type!

Item was added:
+ ----- Method: ExternalType class>>newTypeNamed: (in category 'instance creation') -----
+ newTypeNamed: aTypeName
+
+ | structClass |
+ structClass := (self environment classNamed: aTypeName)
+ ifNotNil: [:class | (class includesBehavior: ExternalStructure) ifTrue: [class]].
+
+ ^ structClass
+ ifNil: [self newTypeForUnknownNamed: aTypeName]
+ ifNotNil: [self newTypeForStructureClass: structClass]!

Item was removed:
- ----- Method: ExternalType class>>newTypeNamed:force: (in category 'private') -----
- newTypeNamed: aString force: aBool
- | sym type referentClass pointerType |
- sym := aString asSymbol.
- type := StructTypes at: aString ifAbsent:[nil].
- type == nil ifFalse:[^type].
- referentClass := Smalltalk at: sym ifAbsent:[nil].
- (referentClass isBehavior and:[referentClass includesBehavior: ExternalStructure])
- ifFalse:[referentClass := nil].
- "If we don't have a referent class and are not forced to create a type get out"
- (referentClass == nil and:[aBool not]) ifTrue:[^nil].
- type := self basicNew compiledSpec:
- (WordArray with: self structureSpec).
- pointerType := self basicNew compiledSpec:
- (WordArray with: self pointerSpec).
- type setReferencedType: pointerType.
- pointerType setReferencedType: type.
- type newReferentClass: referentClass.
- pointerType newReferentClass: referentClass.
- pointerType byteAlignment: self pointerAlignment.
- StructTypes at: sym put: type.
- ^type!

Item was changed:
+ ----- Method: ExternalType class>>structTypeNamed: (in category 'instance lookup') -----
+ structTypeNamed: typeName
+ "Answers the external type for the struct named typeName. If there is no type yet, create a new one but only if typeName can be matched to an existing class in the system already. If you still need a type even if there is no such class present, use #newTypeNamed: to create a type with an unknown referent class."
+
+ ^ (StructTypes at: typeName ifAbsent: [nil])
+ ifNil: [
+ (self environment classNamed: typeName)
+ ifNotNil: [:cls | (cls includesBehavior: ExternalStructure) ifTrue: [
+ StructTypes removeKey: typeName ifAbsent: [].
+ self newTypeNamed: typeName]]]
+ !
- ----- Method: ExternalType class>>structTypeNamed: (in category 'private') -----
- structTypeNamed: aSymbol
- aSymbol == nil ifTrue:[^nil].
- ^self newTypeNamed: aSymbol force: false!

Item was added:
+ ----- Method: ExternalType class>>typeNamed: (in category 'instance lookup') -----
+ typeNamed: typeName
+
+ (self atomicTypeNamed: typeName)
+ ifNotNil: [:type | ^ type].
+ (self structTypeNamed: typeName)
+ ifNotNil: [:type | ^ type].
+
+ ^ nil!

Item was changed:
  ----- Method: ExternalType>>newReferentClass: (in category 'private') -----
  newReferentClass: aClass
  "The class I'm referencing has changed. Update my spec."
  referentClass := aClass.
  self isPointerType ifTrue:[^self]. "for pointers only the referentClass changed"
  referentClass == nil ifTrue:[
  "my class has been removed - make me 'struct { void }'"
+ compiledSpec := WordArray with: self class structureSpec.
- compiledSpec := WordArray with: (FFIFlagStructure).
  byteAlignment := 1.
  ] ifFalse:[
  "my class has been changed - update my compiledSpec"
  compiledSpec := referentClass compiledSpec.
  byteAlignment := referentClass byteAlignment.
  ].!

Item was changed:
  ----- Method: ExternalType>>printOn: (in category 'printing') -----
  printOn: aStream
+
+ self isAtomic
+ ifTrue: [aStream nextPutAll: (AtomicTypeNames at: self atomicType)]
+ ifFalse: [
+ referentClass == nil
+ ifTrue:[aStream nextPutAll: '<unknown struct type>']
+ ifFalse:[aStream nextPutAll: referentClass name]].
- referentClass == nil
- ifTrue:[aStream nextPutAll: (AtomicTypeNames at: self atomicType)]
- ifFalse:[aStream nextPutAll: referentClass name].
  self isPointerType ifTrue:[aStream nextPut: $*].!

Item was added:
+ ----- Method: ExternalType>>setReferentClass: (in category 'private') -----
+ setReferentClass: aClass
+ referentClass := aClass.!

Item was changed:
  ----- Method: ExternalType>>storeOn: (in category 'printing') -----
  storeOn: aStream
+
+ self isAtomic
- referentClass == nil
  ifTrue:[aStream nextPutAll: ExternalType name; space; nextPutAll: (AtomicTypeNames at: self atomicType)]
+ ifFalse:[
+ referentClass == nil
+ ifTrue: [aStream nextPutAll: 'nil']
+ ifFalse: [aStream nextPut: $(; nextPutAll: ExternalType name; space; nextPutAll: #structTypeNamed:; space;  store: referentClass name; nextPut: $)]].
- ifFalse:[aStream nextPut: $(; nextPutAll: ExternalType name; space; nextPutAll: #structTypeNamed:; space;  store: referentClass name; nextPut: $)].
  self isPointerType ifTrue: [aStream space; nextPutAll: #asPointerType].!

Item was changed:
  ----- Method: ExternalUnion class>>compileFields:withAccessors: (in category 'field definition') -----
  compileFields: specArray withAccessors: aSymbol
  "Compile a type specification for the FFI machinery.
  Return the newly compiled spec.
  Eventually generate the field accessors according to the policy defined in aSymbol."
  | byteOffset maxByteSize typeSpec newCompiledSpec newByteAlignment |
  (specArray size > 0 and: [specArray first class ~~ Array]) ifTrue:
+ [^ self error: 'Use ExternalStructure to define a type alias, not ExternalUnion'].
- [^ self error: 'unions must have fields defined by sub-Array'].
  byteOffset := 1.
  newByteAlignment := 1.
  maxByteSize := 0.
  typeSpec := WriteStream on: (WordArray new: specArray size + 1).
  typeSpec nextPut: FFIFlagStructure.
+ specArray do: [:spec |
+ | fieldName fieldTypeName isPointerField externalType typeSize typeAlignment |
- "dummy for size"
- specArray do:
- [:spec |
- | fieldName fieldType isPointerField externalType typeSize typeAlignment selfRefering |
  fieldName := spec first.
+ fieldTypeName := spec second.
+ isPointerField := fieldTypeName last = $*.
+ fieldTypeName := (fieldTypeName findTokens: '*') first withBlanksTrimmed.
+ externalType := (ExternalType typeNamed: fieldTypeName)
+ ifNil: [self errorTypeNotFound: spec second].
+ isPointerField ifTrue: [externalType := externalType asPointerType].
+ typeSize := externalType byteSize.
+ typeAlignment := externalType byteAlignment.
+ spec size > 2 ifTrue: ["extra size"
+ spec third < typeSize
+ ifTrue: [^ self error: 'Explicit type size is less than expected'].
+ typeSize := spec third.
- fieldType := spec second.
- isPointerField := fieldType last = $*.
- fieldType := (fieldType findTokens: '*') first withBlanksTrimmed.
- externalType := ExternalType atomicTypeNamed: fieldType.
- selfRefering := isPointerField and: [externalType isNil and: [fieldType = self asString]].
- selfRefering ifTrue: [
- externalType := ExternalType void asPointerType
- ] ifFalse:[
- externalType ifNil: ["non-atomic"
- (Symbol lookup: fieldType) ifNotNil: [:sym |
- externalType := ExternalType structTypeNamed: sym].
- ].
- externalType ifNil: [
- Transcript show: '(' , fieldType , ' is void)'.
- externalType := ExternalType void.
- ].
- isPointerField ifTrue: [externalType := externalType asPointerType]].
- typeSize := externalType byteSize.
- typeAlignment := externalType byteAlignment.
- spec size > 2 ifTrue: ["extra size"
- spec third < typeSize
- ifTrue: [^ self error: 'Explicit type size is less than expected'].
- typeSize := spec third.
- ].
- (fieldName notNil and: [self shouldGenerate: fieldName policy: aSymbol]) ifTrue: [
- self defineFieldAccessorsFor: fieldName startingAt: byteOffset type: externalType.
- ].
- typeSpec nextPutAll: (externalType embeddedSpecWithSize: typeSize).
- maxByteSize := maxByteSize max: typeSize.
- newByteAlignment := newByteAlignment max: typeAlignment
  ].
+ (fieldName notNil and: [self shouldGenerate: fieldName policy: aSymbol]) ifTrue: [
+ self defineFieldAccessorsFor: fieldName startingAt: byteOffset type: externalType.
+ ].
+ typeSpec nextPutAll: (externalType embeddedSpecWithSize: typeSize).
+ maxByteSize := maxByteSize max: typeSize.
+ newByteAlignment := newByteAlignment max: typeAlignment
+ ].
  maxByteSize := maxByteSize alignedTo: newByteAlignment.
  newCompiledSpec := typeSpec contents.
  newCompiledSpec at: 1 put: (maxByteSize bitOr: FFIFlagStructure).
  byteAlignment := newByteAlignment.
  ^ newCompiledSpec!