VM Maker: VMMaker.oscog-eem.2757.mcz

 
Eliot Miranda uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker.oscog-eem.2757.mcz

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

Name: VMMaker.oscog-eem.2757
Author: eem
Time: 31 May 2020, 3:42:59.428516 pm
UUID: c2aedcf5-7fdb-48d6-90c2-15d41942bc06
Ancestors: VMMaker.oscog-ul.2756

Spur:
Make sure prim fail codes in primitiveConstantFillSpur are correct.

ThreadedFFIPlugin:
Add ThreadedFFIPlugin>>primitiveStructureElementAlignment.

Fix some comment typos.

Slang:
Allow a VMStructType to control adding its types to the struct name cache, ehnce allowing AlignmentStruct to encode multiple struct types.

=============== Diff against VMMaker.oscog-ul.2756 ===============

Item was added:
+ VMStructType subclass: #AlignmentStructType
+ instanceVariableNames: 'element'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'VMMaker-Plugins-FFI'!
+
+ !AlignmentStructType commentStamp: 'eem 5/30/2020 18:50' prior: 0!
+ AlignmentStruct is a hack to declare and generate all the structure field alignment types used in ThreadedFFIPlugin>>primitiveStructureElementAlignment.
+
+ Instance Variables
+ element: <char,short,int,long long, etc>
+
+ element
+ - a C type that is defined according to the relevant type name
+ !

Item was added:
+ ----- Method: AlignmentStructType class>>addStructTypeNamesTo: (in category 'code generation') -----
+ addStructTypeNamesTo: aSet
+ aSet addAll: #('structByte' 'structShort' 'structInt' 'structLongLong' 'structFloat' 'structDouble' 'structStruct')!

Item was added:
+ ----- Method: AlignmentStructType class>>printTypedefOn: (in category 'code generation') -----
+ printTypedefOn: aStream
+ | union |
+ union := String streamContents:
+ [:unionStream|
+ #('Byte' 'Short' 'Int' 'LongLong' 'Float' 'Double')
+  with: #(#char #short #int #'long long' #float #double) do:
+ [:structName :type|
+ aStream
+ nextPutAll: 'typedef struct { char pad_to_misalgnment; ';
+ nextPutAll: type;
+ nextPutAll: ' element; } struct';
+ nextPutAll: structName;
+ nextPut: $;; cr; cr.
+ unionStream crtab: 3; nextPutAll: type; space; nextPutAll: structName; nextPut: $;]].
+ aStream
+ nextPutAll: 'typedef struct { char pad_to_misalgnment;';
+ crtab: 2;
+ nextPutAll: 'union {';
+ nextPutAll: union;
+ crtab: 2;
+ nextPutAll: '} element; } structStruct;'!

Item was changed:
  ----- Method: CCodeGenerator>>generateBetweenAnd:on:indent: (in category 'C translation') -----
  generateBetweenAnd: msgNode on: aStream indent: level
  "Generate the C code for the between:and: message onto the given stream."
 
  aStream nextPutAll: '(('.
  self emitCExpression: msgNode receiver on: aStream.
  aStream nextPutAll: ' >= '.
  self emitCExpression: msgNode args first on: aStream.
  aStream nextPutAll: ') && ('.
+ self emitCExpression: (msgNode receiver isAssignment
+ ifTrue: [msgNode receiver variable]
+ ifFalse: [msgNode receiver])
+ on: aStream.
- self emitCExpression: msgNode receiver on: aStream.
  aStream nextPutAll: ' <= '.
  self emitCExpression: msgNode args second on: aStream.
  aStream nextPutAll: '))'!

Item was changed:
  ----- Method: CoInterpreter>>internalExecuteNewMethod (in category 'message sending') -----
  internalExecuteNewMethod
  <inline: true>
  "For interpreter performance and to ease the objectAsMethod implementation eagerly
  evaluate the primitive, i.e. if the method is cogged and has a primitive /do not/ evaluate
  the machine code primitive, just evaluate primitiveFunctionPointer directly."
  | succeeded methodHeader |
  primitiveFunctionPointer ~= 0 ifTrue:
  [self isPrimitiveFunctionPointerAnIndex ifTrue:
  [^self internalQuickPrimitiveResponse].
  "slowPrimitiveResponse may of course context-switch.  If so we must reenter the
   new process appropriately, returning only if we've found an interpreter frame."
  self externalizeIPandSP.
  succeeded := self slowPrimitiveResponse.
  instructionPointer = cogit ceReturnToInterpreterPC ifTrue:
  [instructionPointer := self iframeSavedIP: framePointer].
  self internalizeIPandSP.
  succeeded ifTrue:
  [self return: self popStack toExecutive: true.
  self browserPluginReturnIfNeeded.
  ^nil]].
  methodHeader := self rawHeaderOf: newMethod.
  "if not primitive, or primitive failed, activate the method"
  (self isCogMethodReference: methodHeader) ifFalse:
  [^self internalActivateNewMethod].
  self iframeSavedIP: localFP put: localIP asInteger.
  instructionPointer := cogit ceReturnToInterpreterPC.
  self externalizeFPandSP.
+ "This may context switch and hence return..."
- "THis may cintext switch and hence return..."
  self activateNewCogMethod: (self cCoerceSimple: methodHeader to: #'CogMethod *') inInterpreter: true.
  "Hence this si reachable..."
  self internalizeIPandSP!

Item was added:
+ ----- Method: CogIA32Compiler>>genAlignCStackSavingRegisters:numArgs:wordAlignment: (in category 'abi') -----
+ genAlignCStackSavingRegisters: regMask numArgs: numArgs wordAlignment: alignment
+ <inline: true>
+ | regMaskCopy numRegsPushed wordsPushedModAlignment delta |
+ <var: 'regMaskCopy' type: #usqInt>
+ self shouldBeImplemented.
+ self flag: 'test the assert & debug VMs on Windows and Mac OS (while you still can).  The Windows build produces stack alignment assert fails, probably due to ceInvokeInterpret.  The issue is the alignment calculation may not take into account the return address.'.
+ regMaskCopy := regMask asUnsignedInteger.
+ numRegsPushed := 0.
+ [regMaskCopy ~= 0] whileTrue:
+ [numRegsPushed := numRegsPushed + (regMaskCopy bitAnd: 1).
+ regMaskCopy := regMaskCopy bitShift: -1].
+ (numRegsPushed = 0
+ and: [self numIntRegArgs >= numArgs]) ifTrue:
+ [^0].
+ wordsPushedModAlignment := numRegsPushed + (numArgs - self numIntRegArgs max: 0) \\ alignment.
+ wordsPushedModAlignment ~= 0 ifTrue:
+ [delta := alignment - wordsPushedModAlignment.
+ cogit SubCq: delta * objectMemory wordSize R: SPReg].
+ ^0!

Item was changed:
  ----- Method: Cogit>>genInvokeInterpretTrampoline (in category 'initialization') -----
  genInvokeInterpretTrampoline
  "Switch to the C stack (do *not* save the Smalltalk stack pointers;
  this is the caller's responsibility), and invoke interpret PDQ."
  | startAddress |
  <inline: false>
  startAddress := methodZoneBase.
  self zeroOpcodeIndex.
  backEnd hasVarBaseRegister ifTrue:
  [self MoveCq: self varBaseAddress R: VarBaseReg]. "Must happen first; value may be used in genLoadStackPointers"
  cFramePointerInUse
  ifTrue: [backEnd genLoadCStackPointers]
  ifFalse: [backEnd genLoadCStackPointer].
+ cStackAlignment > objectMemory wordSize ifTrue:
+ [backEnd
+ genAlignCStackSavingRegisters: self emptyRegisterMask
+ numArgs: 0
+ wordAlignment: cStackAlignment / objectMemory wordSize].
  "Sideways call interpret so that the stack looks correct, for exception handling etc"
  backEnd genMarshallNArgs: 0 arg: nil arg: nil arg: nil arg: nil.
  backEnd hasLinkRegister
  ifTrue:
  [self MoveAw: coInterpreter cReturnAddressAddress R: LinkReg]
  ifFalse:
  [self MoveAw: coInterpreter cReturnAddressAddress R: ABIResultReg.
  backEnd genSubstituteReturnAddressR: ABIResultReg].
  self JumpFullRT: (self
  cCode: [#interpret asUnsignedInteger]
  inSmalltalk: [self simulatedTrampolineFor: #interpret]).
  self outputInstructionsForGeneratedRuntimeAt: startAddress.
  self recordGeneratedRunTime: 'ceInvokeInterpret' address: startAddress.
  ^startAddress!

Item was changed:
  ----- Method: InterpreterPrimitives>>primitiveConstantFillSpur (in category 'sound primitives') -----
  primitiveConstantFillSpur
  "Fill the receiver, which must be an indexable non-pointer object, with the given integer value."
  <inline: true>
  | fillValue rcvr format end i oddBytes |
  <var: #fillValue type: #usqLong>
  <var: #end type: #usqInt>
  <var: #i type: #usqInt>
  argumentCount ~= 1 ifTrue:
  [^self primitiveFailFor: PrimErrBadNumArgs].
  rcvr := self stackValue: 1.
  ((objectMemory isNonImmediate: rcvr)
  and: [(format := objectMemory formatOf: rcvr) >= objectMemory sixtyFourBitIndexableFormat]) ifFalse:
+ [^self primitiveFailFor: PrimErrBadReceiver].
- [^self primitiveFailFor: PrimErrBadReceiver].
  (objectMemory isObjImmutable: rcvr) ifTrue:
  [^self primitiveFailFor: PrimErrNoModification].
  fillValue := self positive64BitValueOf: self stackTop.
  self successful ifFalse:
  [^self primitiveFailFor: PrimErrBadArgument].
  format >= objectMemory firstShortFormat
  ifTrue:
  [format >= objectMemory firstByteFormat
  ifTrue:
  [(fillValue > 16rFF or: [format >= objectMemory firstCompiledMethodFormat]) ifTrue:
+ [^self primitiveFailFor: (fillValue > 16rFF ifTrue: [PrimErrBadArgument] ifFalse: [PrimErrBadReceiver])].
- [^self primitiveFail].
  fillValue := fillValue + (fillValue << 8) + (fillValue << 16) + (fillValue << 24).
  oddBytes := format bitAnd: 7]
  ifFalse:
  [fillValue > 16rFFFF ifTrue:
+ [^self primitiveFailFor: PrimErrBadArgument].
- [^self primitiveFail].
  fillValue := fillValue + (fillValue << 16).
  oddBytes := (format bitAnd: 3) << 1].
  fillValue := fillValue + (fillValue << 32)]
  ifFalse:
  [format = objectMemory sixtyFourBitIndexableFormat
  ifTrue:
  [oddBytes := 0]
  ifFalse:
  [fillValue > 16rFFFFFFFF ifTrue:
+ [^self primitiveFailFor: PrimErrBadArgument].
- [^self primitiveFail].
  fillValue := fillValue + (fillValue << 32).
  oddBytes := (format bitAnd: 1) << 2]].
  end := objectMemory addressAfter: rcvr.
  i := rcvr + objectMemory baseHeaderSize.
  [i < end] whileTrue:
  [objectMemory long64At: i put: fillValue.
  i := i + 8].
  "now ensure trailing bytes are zero"
  oddBytes > 0 ifTrue:
  [self flag: #endianness.
  fillValue := fillValue >> (8 * oddBytes).
  objectMemory long64At: i - 8 put: fillValue].
  self pop: 1!

Item was changed:
  ----- Method: ThreadedFFIPlugin class>>ancilliaryClasses (in category 'translation') -----
  ancilliaryClasses
+ ^{ self calloutStateClass. AlignmentStructType }!
- ^{ self calloutStateClass }!

Item was added:
+ ----- Method: ThreadedFFIPlugin class>>primitiveAlignmentOf: (in category 'simulation') -----
+ primitiveAlignmentOf: atomicTypeCode
+ "Answer the platform C compiler's alignment in a structure of an element of the
+ C type corresponding to atomicTypeCode, where atomicTypeCode is in the range
+ FFITypeUnsignedByte (2) to FFITypeDoubleFloat (13), or is FFIFlagStructure (65536)."
+ <primitive: #primitiveStructureElementAlignment module: #SqueakFFIPrims>
+ self primitiveFailed
+
+ "(FFITypeUnsignedByte to: FFITypeDoubleFloat), {FFIFlagStructure} collect: [:n| self primitiveAlignmentOf: n]"!

Item was changed:
  ----- Method: ThreadedFFIPlugin>>checkAlignmentOfStructSpec:OfLength:StartingAt: (in category 'marshalling-struct') -----
  checkAlignmentOfStructSpec: specs OfLength: specSize StartingAt: startIndex
  "Check the alignment of a structure and return true if correctly aligned.
  If computed size = declared size, then the struct is assumed correctly aligned."
  | index spec computedSize fieldAlignment fieldSize declaredSize maxAlignment |
  <var: #specs type: #'unsigned int*'>
- <var: #indexPtr type: #'unsigned int*'>
  <inline: false>
  index := startIndex.
  spec := specs at: index.
  self assert: (spec bitAnd: FFIFlagPointer + FFIFlagAtomic + FFIFlagStructure) = FFIFlagStructure.
  (self isUnionSpec: specs OfLength: specSize StartingAt: index)
  ifTrue:
  [^self checkAlignmentOfUnionSpec: specs OfLength: specSize StartingAt: startIndex].
  declaredSize := spec bitAnd: FFIStructSizeMask.
  computedSize := 0.
  maxAlignment := 1.
  [index := index + 1.
  index < specSize]
  whileTrue:
  [spec := specs at: index.
  spec = FFIFlagStructure
  ifTrue: [^(computedSize - 1 bitOr: maxAlignment - 1) + 1 = declaredSize].
  (spec anyMask: FFIFlagPointer)
  ifTrue:
  [fieldSize := BytesPerWord.
  fieldAlignment := fieldSize]
  ifFalse:
  [fieldSize := spec bitAnd: FFIStructSizeMask.
  (spec anyMask: FFIFlagStructure)
  ifTrue:
  [(self checkAlignmentOfStructSpec: specs OfLength: specSize StartingAt: index)
  ifFalse: [^false].
  fieldAlignment := self alignmentOfStructSpec: specs OfLength: specSize StartingAt: (self addressOf: index)]
  ifFalse: [fieldAlignment := fieldSize]].
  "round to fieldAlignment"
  maxAlignment := maxAlignment max: fieldAlignment.
  computedSize := (computedSize - 1 bitOr: fieldAlignment - 1) + 1.
  computedSize := computedSize + fieldSize].
  ^(computedSize - 1 bitOr: maxAlignment - 1) + 1 = declaredSize!

Item was changed:
  ----- Method: ThreadedFFIPlugin>>checkAlignmentOfUnionSpec:OfLength:StartingAt: (in category 'marshalling-struct') -----
  checkAlignmentOfUnionSpec: specs OfLength: specSize StartingAt: startIndex
  "Check the alignment of a union and return true if correctly aligned.
  Union are correctly aligned, but a sub-structure might not."
  | index spec |
  <var: #specs type: #'unsigned int*'>
- <var: #indexPtr type: #'unsigned int*'>
  <inline: false>
  index := startIndex.
  spec := specs at: index.
  [index := index + 1.
  index < specSize]
  whileTrue:
  [spec := specs at: index.
  spec = FFIFlagStructure
  ifTrue: [^true].
  (spec anyMask: FFIFlagPointer)
  ifFalse:
  [(spec anyMask: FFIFlagStructure)
  ifTrue:
  [(self checkAlignmentOfStructSpec: specs OfLength: specSize StartingAt: index)
  ifFalse: [^false]]]].
  ^true!

Item was added:
+ ----- Method: ThreadedFFIPlugin>>primitiveStructureElementAlignment (in category 'primitives') -----
+ primitiveStructureElementAlignment
+ "Answer the alignment of an element of an atomic type, or a structure, within a structure on the current platform."
+ <export: true>
+ | typeCode alignment |
+ typeCode := interpreterProxy stackValue: 0.
+ ((interpreterProxy isIntegerObject: typeCode)
+ and: [((typeCode := interpreterProxy integerValueOf: typeCode) between: FFITypeUnsignedByte and: FFITypeDoubleFloat)
+ or: [typeCode = FFIFlagStructure]]) ifFalse:
+ [^self primitiveFailFor: PrimErrBadArgument].
+
+ alignment := typeCode
+ caseOf: {
+ [FFITypeUnsignedByte] -> [self structOffsetOf: 'structByte *' atomicTypeCode: FFITypeUnsignedByte].
+ [FFITypeSignedByte] -> [self structOffsetOf: 'structByte *' atomicTypeCode: FFITypeUnsignedByte].
+ [FFITypeUnsignedShort] -> [self structOffsetOf: 'structShort *' atomicTypeCode: FFITypeUnsignedShort].
+ [FFITypeSignedShort] -> [self structOffsetOf: 'structShort *' atomicTypeCode: FFITypeUnsignedShort].
+ [FFITypeUnsignedInt] -> [self structOffsetOf: 'structInt *' atomicTypeCode: FFITypeUnsignedInt].
+ [FFITypeSignedInt] -> [self structOffsetOf: 'structInt *' atomicTypeCode: FFITypeUnsignedInt].
+ [FFITypeUnsignedLongLong] -> [self structOffsetOf: 'structLongLong *' atomicTypeCode: FFITypeUnsignedLongLong].
+ [FFITypeSignedLongLong] -> [self structOffsetOf: 'structLongLong *' atomicTypeCode: FFITypeUnsignedLongLong].
+ [FFITypeSingleFloat] -> [self structOffsetOf: 'structFloat *' atomicTypeCode: FFITypeSingleFloat].
+ [FFITypeDoubleFloat] -> [self structOffsetOf: 'structDouble *' atomicTypeCode: FFITypeDoubleFloat].
+ }
+ otherwise: [self structOffsetOf: 'structStruct *' atomicTypeCode: FFIFlagStructure].
+ ^interpreterProxy methodReturnInteger: alignment!

Item was added:
+ ----- Method: ThreadedFFIPlugin>>structOffsetOf:atomicTypeCode: (in category 'primitive support') -----
+ structOffsetOf: structPointerType atomicTypeCode: atomicTypeCode
+ <inline: #always>
+ ^self cCode: [self addressOf: (self cCoerceSimple: 0 to: structPointerType) element]
+ inSmalltalk: [self class primitiveAlignmentOf: atomicTypeCode]!

Item was changed:
  ----- Method: ThreadedX64SysVFFIPlugin class>>ancilliaryClasses (in category 'translation') -----
  ancilliaryClasses
+ ^super ancilliaryClasses,
+  { ThreadedFFIX64SixteenByteReturnDD.
- ^{ self calloutStateClass.
- ThreadedFFIX64SixteenByteReturnDD.
  ThreadedFFIX64SixteenByteReturnDI.
  ThreadedFFIX64SixteenByteReturnID.
  ThreadedFFIX64SixteenByteReturnII }!

Item was added:
+ ----- Method: VMStructType class>>addStructTypeNamesTo: (in category 'code generation') -----
+ addStructTypeNamesTo: aSet
+ aSet add: self name; add: self structTypeName!

Item was added:
+ ----- Method: VMStructType class>>ensureStructTypeNameCache (in category 'translation') -----
+ ensureStructTypeNameCache
+ ^StructTypeNameCache ifNil:
+ [StructTypeNameCache := Set new.
+ self allSubclassesDo:
+ [:sc| sc addStructTypeNamesTo: StructTypeNameCache].
+ StructTypeNameCache]!

Item was changed:
  ----- Method: VMStructType class>>isTypePointerToStruct: (in category 'translation') -----
  isTypePointerToStruct: type
  | index |
- StructTypeNameCache ifNil:
- [StructTypeNameCache := Set new.
- self allSubclassesDo:
- [:sc| StructTypeNameCache add: sc name; add: sc structTypeName ]].
  ^type notNil
   and: [(index := type indexOf: $*) > 0
+  and: [self ensureStructTypeNameCache anySatisfy:
-  and: [StructTypeNameCache anySatisfy:
  [:structType|
  (type beginsWith: structType)
  and: [index > structType size]]]]!

Item was changed:
  ----- Method: VMStructType class>>structTargetKindForDeclaration: (in category 'translation') -----
  structTargetKindForDeclaration: decl
- StructTypeNameCache ifNil:
- [StructTypeNameCache := Set new.
- self allSubclassesDo:
- [:sc| StructTypeNameCache add: sc name; add: sc structTypeName ]].
  ^(decl notNil
+   and: [(self ensureStructTypeNameCache includes: decl)
-   and: [(StructTypeNameCache includes: decl)
  or: [StructTypeNameCache anySatisfy:
  [:structType|
  (decl beginsWith: structType)
  and: [(decl indexOf: $* ifAbsent: [decl indexOf: Character space]) > structType size]]]]) ifTrue:
  [(decl indexOf: $*) > 0
  ifTrue: [#pointer]
  ifFalse: [#struct]]!