Packages July 2020

packages@lists.squeakfoundation.org

1 participants
39 discussions

FFI: FFI-Callbacks-mt.3.mcz
by commits＠source.squeak.org 28 Jul '20

28 Jul '20

Marcel Taeumel uploaded a new version of FFI-Callbacks to project FFI: http://source.squeak.org/FFI/FFI-Callbacks-mt.3.mcz ==================== Summary ==================== Name: FFI-Callbacks-mt.3 Author: mt Time: 28 July 2020, 1:37:14.847011 pm UUID: 9d6c3731-a9c3-2742-a9bb-d47d40a156d2 Ancestors: FFI-Callbacks-mt.2 Updates for FFI-Kernel-mt.119. You may need to re-generate the fields in FFICallbackContext and FFICallbackResult. =============== Diff against FFI-Callbacks-mt.2 =============== Item was changed: ----- Method: ExternalAddress class>>fromInteger: (in category '*FFI-Callbacks') ----- fromInteger: anInteger "Read the given interger as an address pointing to an external memory area." | buffer type | + self flag: #refactor. "Maybe: ExternalAddress new fromInteger: anInteger --- and maybe move to FFI-Kernel" type := ExternalType uintptr_t. buffer := ByteArray new: type byteSize. type handle: buffer at: 1 put: anInteger. ^ buffer asExternalPointer! Item was removed: - ----- Method: FFICallbackContext>>floatRegArgs (in category 'accessing') ----- - floatRegArgs - "This method was automatically generated. See FFICallbackContext class>>fields." - <generated> - ^ExternalData fromHandle: (handle shortPointerAt: 13) type: ExternalType double asPointerType! Item was removed: - ----- Method: FFICallbackContext>>floatRegArgs: (in category 'accessing') ----- - floatRegArgs: someExternalData - "This method was automatically generated. See FFICallbackContext class>>fields." - <generated> - handle shortPointerAt: 13 put: someExternalData getHandle.! Item was removed: - ----- Method: FFICallbackContext>>intRegArgs (in category 'accessing') ----- - intRegArgs - "This method was automatically generated. See FFICallbackContext class>>fields." - <generated> - ^ExternalData fromHandle: (handle shortPointerAt: 9) type: ExternalType long asPointerType! Item was removed: - ----- Method: FFICallbackContext>>intRegArgs: (in category 'accessing') ----- - intRegArgs: someExternalData - "This method was automatically generated. See FFICallbackContext class>>fields." - <generated> - handle shortPointerAt: 9 put: someExternalData getHandle.! Item was removed: - ----- Method: FFICallbackContext>>rvs (in category 'accessing') ----- - rvs - "This method was automatically generated. See FFICallbackContext class>>fields." - <generated> - ^FFICallbackResult fromHandle: (handle structAt: 25 length: 8)! Item was removed: - ----- Method: FFICallbackContext>>rvs: (in category 'accessing') ----- - rvs: aFFICallbackResult - "This method was automatically generated. See FFICallbackContext class>>fields." - <generated> - handle structAt: 25 put: aFFICallbackResult getHandle length: 8.! Item was removed: - ----- Method: FFICallbackContext>>stackPtr (in category 'accessing') ----- - stackPtr - "This method was automatically generated. See FFICallbackContext class>>fields." - <generated> - ^ExternalData fromHandle: (handle shortPointerAt: 5) type: ExternalType long asPointerType! Item was removed: - ----- Method: FFICallbackContext>>stackPtr: (in category 'accessing') ----- - stackPtr: someExternalData - "This method was automatically generated. See FFICallbackContext class>>fields." - <generated> - handle shortPointerAt: 5 put: someExternalData getHandle.! Item was removed: - ----- Method: FFICallbackContext>>thunkp (in category 'accessing') ----- - thunkp - "This method was automatically generated. See FFICallbackContext class>>fields." - <generated> - ^ExternalData fromHandle: (handle shortPointerAt: 1) type: ExternalType void asPointerType! Item was removed: - ----- Method: FFICallbackContext>>thunkp: (in category 'accessing') ----- - thunkp: someExternalData - "This method was automatically generated. See FFICallbackContext class>>fields." - <generated> - handle shortPointerAt: 1 put: someExternalData getHandle.! Item was changed: ----- Method: FFICallbackMemory class>>unload (in category 'class initialization') ----- unload + Smalltalk removeFromStartUpList: self. + Smalltalk specialObjectsArray at: 53 put: nil.! - Smalltalk removeFromStartUpList: self.! Item was changed: ----- Method: FFICallbackMemory>>externalPointer: (in category 'accessing') ----- externalPointer: anExternalAddress + self addressFieldPut: anExternalAddress asInteger.! - | type integer | - self flag: #debugging. - type := ExternalType uintptr_t. - integer := type - handle: anExternalAddress asByteArrayPointer - at: 1. - - self addressFieldPut: integer.! Item was removed: - ----- Method: FFICallbackResult>>booleanResult (in category 'accessing') ----- - booleanResult - "This method was automatically generated. See FFICallbackResult class>>fields." - <generated> - ^handle booleanAt: 1! Item was removed: - ----- Method: FFICallbackResult>>booleanResult: (in category 'accessing') ----- - booleanResult: aBoolean - "This method was automatically generated. See FFICallbackResult class>>fields." - <generated> - handle booleanAt: 1 put: aBoolean! Item was removed: - ----- Method: FFICallbackResult>>floatResult (in category 'accessing') ----- - floatResult - "This method was automatically generated. See FFICallbackResult class>>fields." - <generated> - ^handle doubleAt: 1! Item was removed: - ----- Method: FFICallbackResult>>floatResult: (in category 'accessing') ----- - floatResult: aFloat - "This method was automatically generated. See FFICallbackResult class>>fields." - <generated> - handle doubleAt: 1 put: aFloat! Item was removed: - ----- Method: FFICallbackResult>>integerResult (in category 'accessing') ----- - integerResult - "This method was automatically generated. See FFICallbackResult class>>fields." - <generated> - ^handle signedLongAt: 1! Item was removed: - ----- Method: FFICallbackResult>>integerResult: (in category 'accessing') ----- - integerResult: anInteger - "This method was automatically generated. See FFICallbackResult class>>fields." - <generated> - handle signedLongAt: 1 put: anInteger! Item was removed: - ----- Method: FFICallbackResult>>positiveIntegerResult (in category 'accessing') ----- - positiveIntegerResult - "This method was automatically generated. See FFICallbackResult class>>fields." - <generated> - ^handle unsignedLongAt: 1! Item was removed: - ----- Method: FFICallbackResult>>positiveIntegerResult: (in category 'accessing') ----- - positiveIntegerResult: anInteger - "This method was automatically generated. See FFICallbackResult class>>fields." - <generated> - handle unsignedLongAt: 1 put: anInteger! Item was removed: - ----- Method: Parser>>callback (in category '*FFI-Callbacks') ----- - callback - <pragmaParser> - - | descriptorClass retType externalName args argType | - descriptorClass := ExternalFunction. - "Parse return type" - self advance. - here = 'const' ifTrue: [self advance]. - retType := self externalType: descriptorClass. - retType == nil ifTrue:[^self expected:'return type']. - "Parse function name or index" - externalName := here. - - (self match: #leftParenthesis) ifFalse:[^self expected:'function pointer (*)']. - (self matchToken: #*) ifFalse:[^self expected:'function pointer (*)']. - (self match: #rightParenthesis) ifFalse:[^self expected:'function pointer (*)']. - - (self match: #leftParenthesis) ifFalse:[^self expected:'argument list']. - args := WriteStream on: Array new. - [self match: #rightParenthesis] whileFalse:[ - here = 'const' ifTrue: [self advance]. - here = ',' ifTrue: [self advance]. - argType := self externalType: descriptorClass. - argType == nil ifTrue:[^self expected:'argument']. - argType isVoid & argType isPointerType not ifFalse:[args nextPut: argType]]. - - self addPragma: (Pragma keyword: #callback: arguments: {{retType}, args contents}). - ^true! Item was removed: - ----- Method: SHParserST80>>callback (in category '*FFI-Callbacks') ----- - callback - <pragmaParser> - - self scanPast: #externalFunctionCallingConvention. - - self scanPast: #externalCallType. - currentToken = '*' - ifTrue: [self scanPast: #externalCallTypePointerIndicator]. - - currentTokenFirst == $( ifFalse: [^ self fail]. self scanNext. - currentTokenFirst == $* ifFalse: [^ self fail]. self scanNext. - currentTokenFirst == $) ifFalse: [^ self fail]. self scanNext. - - self failUnless: currentTokenFirst == $(. - self scanPast: #leftParenthesis. - [currentTokenFirst ~= $)] - whileTrue: [ - self failUnless: currentToken notNil. - self scanPast: #externalCallType. - currentToken = '*' - ifTrue: [self scanPast: #externalCallTypePointerIndicator]]. - self scanPast: #rightParenthesis. - currentToken = 'module:' - ifTrue: [ - self scanPast: #module. - self parseStringOrSymbol ]. - currentToken = 'error:' ifTrue: [ - self scanPast: #primitive. "there's no rangeType for error" - self currentTokenType == #name - ifTrue: [ self parseTemporary: #patternTempVar ] - ifFalse: [ self parseStringOrSymbol ] ]. - self failUnless: currentToken = '>'. - self scanPast: #primitiveOrExternalCallEnd!

1 0

FFI: FFI-Callbacks-mt.2.mcz
by commits＠source.squeak.org 28 Jul '20

28 Jul '20

Marcel Taeumel uploaded a new version of FFI-Callbacks to project FFI: http://source.squeak.org/FFI/FFI-Callbacks-mt.2.mcz ==================== Summary ==================== Name: FFI-Callbacks-mt.2 Author: mt Time: 18 June 2020, 1:26:27.021543 pm UUID: 4baf5374-6606-fb49-876a-f097fdf20b57 Ancestors: FFI-Callbacks-mt.1 Improves basic logic of #evaluateDynamic:. Still needs either some ABI-specific rules to dynamically dispatch, e.g., floats into floatRegArgs or support for calling other evaluator methods if present to manually read the arguments. Also fixes initial package loading by adding the missing #lookupTypes: and comment-out the example signatures for now. =============== Diff against FFI-Callbacks-mt.1 =============== Item was added: + ----- 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 class == ExternalType ifTrue: [ + ^ signature]. + + self error: 'Could not lookup external types from signature'.! Item was changed: ----- Method: FFICallback class>>getIntWithData:withData: (in category 'examples - signatures') ----- getIntWithData: anExternalData1 withData: anExternalData2 " (FFICallback class >> #getIntWithData:withData:) pragmaAt: #callback: " + "<callback: int (*)(void* void*)>" - <callback: int (*)(void* void*)> self shouldNotImplement.! Item was changed: ----- Method: FFICallback class>>getIntWithData:withData:withInt:withInt: (in category 'examples - signatures') ----- getIntWithData: anExternalData1 withData: anExternalData2 withInt: anInteger1 withInt: anInteger2 " (FFICallback class >> #getIntWithData:withData:withInt:withInt:) pragmaAt: #callback: " + "<callback: int (*)(void* void* uint32_t intptr_t)>" - <callback: int (*)(void* void* uint32_t intptr_t)> self shouldNotImplement. self flag: #todo: "Ignore macros, const, and '*,' comma" "<signature: #(int CALLBACK (*)(const LOGFONT *, const TEXTMETRIC *, DWORD, LPARAM))>" ! Item was changed: ----- Method: FFICallback class>>getIntWithInt:withString: (in category 'examples - signatures') ----- getIntWithInt: anInteger withString: aString " (FFICallback class >> #getIntWithInt:withString:) pragmaAt: #callback: " + "<callback: int (*)(int char *)>" - <callback: int (*)(int char *)> self shouldNotImplement.! Item was changed: ----- Method: FFICallback class>>getVoidWithData:withDouble:withDouble: (in category 'examples - signatures') ----- getVoidWithData: anExternalData withDouble: aFloat withDouble: anotherFloat " (FFICallback class >> #getVoidWithData:withDouble:withDouble:) pragmaAt: #callback: " + "<callback: void (*)(void* double double)>" - <callback: void (*)(void* double double)> self shouldNotImplement.! 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: argTypes size - 1. "Skip return type" 1 to: args size do: [:argIndex | + | argType data | - | argType unsigned data | argType := argTypes at: argIndex + 1. "Skip return type" 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. - self flag: #todo. "mt: How to make boolean out of integer here? Would it work with floats, too?" - unsigned := argType isIntegerType ==> [argType isUnsigned]. - data := unsigned - ifTrue: [type asUnsigned handle: handle at: offset] - ifFalse: [type asSigned 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. + offset := offset + ((type byteSize max: argType byteSize) roundUpTo: type byteSize)]. - offset := offset + type byteSize]. ^ self setResult: (evaluableObject valueWithArguments: args) inContext: callbackContext.! Item was changed: ----- Method: FFICallback>>setArgTypes:evaluableObject: (in category 'initialization') ----- setArgTypes: externalTypes evaluableObject: blockOrMessage abi := FFIPlatformDescription current abi. handle := nil. type := nil. evaluableObject := blockOrMessage. argTypes := externalTypes. "Support for callee pop callbacks (Pascal calling convention such as the Win32 stdcall: convention) are supported using the <calleepops: N> pragma which specifies how many bytes to pop. See http://forum.world.st/Pharo-FFI-on-aarch64-arm64-td5096777.html#a5096786." thunk := FFICallbackMemory allocateExecutableBlock. self init__ccall. + "self init__stdcall: 0." "(method pragmaAt: #calleepops:) ifNil: [self init__ccall] ifNotNil: [:pragma | self init__stdcall: (pragma argumentAt: 1)]." "numEvaluatorArgs := (evaluator := method selector) numArgs. self addToThunkTable" ThunkToCallbackMap at: thunk getHandle put: self!

1 0

FFI: FFI-Callbacks-mt.1.mcz
by commits＠source.squeak.org 28 Jul '20

28 Jul '20

Marcel Taeumel uploaded a new version of FFI-Callbacks to project FFI: http://source.squeak.org/FFI/FFI-Callbacks-mt.1.mcz ==================== Summary ==================== Name: FFI-Callbacks-mt.1 Author: mt Time: 18 June 2020, 7:36:50.422967 am UUID: b0e1b5a9-9625-4e41-b36f-a39f271aec00 Ancestors: First version of callback support for Squeak FFI. This is basically a port of the callback support in Alien-Core.tbn.103. WARNING: You cannot load this package if you already have Alien-Core loaded because this package needs to install a different class into the special-objects array at the same index. Next steps: - add GC support for executable pages/blocks when managing thunks and instances of FFICallback - fix the VM crash that occured on IA32 when return from a callback back to the VM -- iff it turns out to not be an issue in the IA32ABI plugin - add support for ABI-specific argument marshalling on the callback; maybe include some code generation to get started --- this version just does a #evaluateDynamic:, which assumes a lot of things that might not be true for your ABI - see if #exampleCqsort finally works then :-) ==================== Snapshot ==================== SystemOrganization addCategory: #'FFI-Callbacks'! ByteArray variableByteSubclass: #FFICallbackMemory instanceVariableNames: '' classVariableNames: 'AccessProtect AllocatedThunks ExecutablePages LifoCallbackSemaphore' poolDictionaries: '' category: 'FFI-Callbacks'! !FFICallbackMemory commentStamp: 'mt 6/17/2020 12:24' prior: 0! Interface for memory allocation using the IA32ABI plugin. Also used as a compatibility layer for Alien. *** An instance of FFICallbackThunk is a reference to a machine-code thunk/trampoline that calls-back into the VM. The reference can be passed to C code which can use it as a function pointer through which to call-back into Smalltalk. The machine-code thunk/trampoline is different for each instance, hence its address is a unique key that can be used to assocuate the Smalltalk side of the call-back (e.g. a block) with the thunk. Since thunks must be executable and some OSs may not provide default execute permission on memory returned by malloc we may not be able to use malloc directly. Instead we rely on a primitive to provide memory that is guaranteed to be executable. ExternalAddress class>>allocateExecutablePage answers an instance of ExternalData that references an executable piece of memory that is some (possiby unitary) multiple of the pagesize. Class-side code then parcels out pieces of a page to individual thunks. These pieces are recycled when thunks are reclaimed. Since the first byte of a thunk is non-zero we can use it as a flag indicating if the piece is in use or not. See FFICallback for the higher-level construct that represents a Smalltalk block to be run in response to a callback. Callbacks wrap instances of FFICallbackThunk and FFICallbackContext instances that describe the stack layout and register contents for receiving callback arguments. Class Variables AccessProtect <Semaphore> critical section for ExecutablePages (de)allocation AllocatedThunks <AlienWeakTable of <FFICallbackThunk -> Integer>> - weak collection of thunks, used to return thunk storage to the executable page pool. ExecutablePages <Set of: Alien "executable page"> - collection of pages with execute permissions used to provide executable thunks! ----- Method: FFICallbackMemory class>>allocateExecutableBlock (in category 'executable pages') ----- allocateExecutableBlock | blockSize | blockSize := FFICallback maxThunkSize. AccessProtect critical: [ExecutablePages do: [:page | 1 to: page size - blockSize by: blockSize do: [:i| (page at: i) = 0 ifTrue: [page at: i put: 1. ^ page blockAt: i byteSize: blockSize]]]]. AccessProtect critical: [ | newPage | newPage := ExecutablePages add: self allocateExecutablePage. ^ (newPage blockAt: 1 byteSize: blockSize) at: 1 put: 1; yourself]! ----- Method: FFICallbackMemory class>>allocateExecutablePage (in category 'executable pages') ----- allocateExecutablePage "Forward allocation to ExternalAddress, which already sends primitives to allocate memory." ^ ExternalAddress allocateExecutablePage! ----- Method: FFICallbackMemory class>>ensureInSpecialObjectsArray (in category 'class initialization') ----- ensureInSpecialObjectsArray "FFICallbackMemory must be in the specialObjectsArray to enable the FFI callback mechanism. Because of the bootstrap the specialObjectsArray may already have been partially initialized with the callback selector and to be large enough (as part of loading immutability), but it will be missing FFICallbackMemory until FFICallbackMemory is loaded. So check if the specialObjectsArray is of the expected size before recreating and slam FFICallbackMemory in if the specialObjectsArray is already large enough." | index | self ~~ FFICallbackMemory ifTrue: [^self]. index := 53. ((Smalltalk includesKey: #VMObjectIndices) and: [((Smalltalk at: #VMObjectIndices) classPool at: #ClassAlien ifAbsent: []) ~= (index - 1)]) ifTrue: [self error: 'index probably wrong']. Smalltalk specialObjectsArray size < index ifTrue: [Smalltalk recreateSpecialObjectsArray]. Smalltalk specialObjectsArray size < index ifTrue: [self error: 'SystemDictionary>>recreateSpecialObjectsArray appears incompatible']. ((Smalltalk specialObjectsArray at: index) ~~ nil and: [(Smalltalk specialObjectsArray at: index) ~~ self]) ifTrue: [self error: 'Alien is already installed. You should not load FFI-Callbacks, too.']. (Smalltalk specialObjectsArray at: index) ifNil: [Smalltalk specialObjectsArray at: index put: self]! ----- Method: FFICallbackMemory class>>fromInteger: (in category 'instance creation') ----- fromInteger: anInteger "Like the extension in ExternalAddress, but duplicate byte size to follow the alien format as expected in the IA32ABI plugin." ^ self new addressFieldPut: anInteger; yourself ! ----- Method: FFICallbackMemory class>>initialize (in category 'class initialization') ----- initialize self ensureInSpecialObjectsArray. Smalltalk addToStartUpList: self after: FFIPlatformDescription. LifoCallbackSemaphore := Semaphore new. AccessProtect := Semaphore forMutualExclusion. "AllocatedThunks := AlienWeakTable newForOwner: self." ExecutablePages := Set new.! ----- Method: FFICallbackMemory class>>invokeCallbackContext: (in category 'callbacks') ----- 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 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 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]! ----- Method: FFICallbackMemory class>>new (in category 'instance creation') ----- new "Only used for holding (alien) pointers." ^ super new: ExternalAddress wordSize * 2! ----- Method: FFICallbackMemory class>>new: (in category 'instance creation') ----- new: n self shouldNotImplement.! ----- 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: ["AllocatedThunks removeAll." ExecutablePages := Set new]! ----- Method: FFICallbackMemory class>>unload (in category 'class initialization') ----- unload Smalltalk removeFromStartUpList: self.! ----- Method: FFICallbackMemory>>addressField (in category 'alien compatibility') ----- addressField "^<Integer>" <primitive: 'primAddressField' module: 'IA32ABI' error: errorCode> ^ (ExternalData fromHandle: self type: ExternalType uintptr_t) at: ExternalData wordSize + 1! ----- Method: FFICallbackMemory>>addressFieldPut: (in category 'alien compatibility') ----- addressFieldPut: value "<Integer> ^<Integer>" <primitive: 'primAddressFieldPut' module: 'IA32ABI' error: errorCode> self notify: 'Primitive failed. Proceed to use fallback code.'. ^ (ExternalData fromHandle: self type: ExternalType uintptr_t) at: ExternalData wordSize + 1 put: value! ----- Method: FFICallbackMemory>>byteSize (in category 'accessing') ----- byteSize "Answer the number of bytes that are allocated when following the #externalPointer." ^ self sizeField abs! ----- Method: FFICallbackMemory>>externalPointer (in category 'accessing') ----- externalPointer "Answer the address that points to allocated memory of #byteSize num bytes." ^ ExternalAddress fromInteger: self addressField! ----- Method: FFICallbackMemory>>externalPointer: (in category 'accessing') ----- externalPointer: anExternalAddress | type integer | self flag: #debugging. type := ExternalType uintptr_t. integer := type handle: anExternalAddress asByteArrayPointer at: 1. self addressFieldPut: integer.! ----- Method: FFICallbackMemory>>primSignal:andReturnAs:fromContext: (in category 'callbacks') ----- primSignal: aSemaphore "<Semaphore>" andReturnAs: typeCode "<SmallInteger>" fromContext: context "<MethodContext>" <primitive: 'primReturnAsFromContextThrough' module: 'IA32ABI' error: ec> ^ self primitiveFailed! ----- Method: FFICallbackMemory>>sizeField (in category 'alien compatibility') ----- sizeField "^<Integer>" <primitive: 'primSizeField' module: 'IA32ABI' error: errorCode> "For some reason, the size is stored as intptr_t, not uintpr_t." ^ (ExternalData fromHandle: self type: ExternalType intptr_t) at: 1! ----- Method: FFICallbackMemory>>sizeFieldPut: (in category 'alien compatibility') ----- sizeFieldPut: size "<Integer> ^<Integer>" <primitive: 'primSizeFieldPut' module: 'IA32ABI' error: errorCode> self notify: 'Primitive failed. Proceed to use fallback code.'. "For some reason, the size is stored as intptr_t, not uintpr_t." ^ (ExternalData fromHandle: self type: ExternalType intptr_t) at: 1 put: size! ----- Method: ExternalData class>>fromHandle:byteSize: (in category '*FFI-Callbacks') ----- fromHandle: aHandle byteSize: byteSize ^ (self fromHandle: aHandle type: ExternalType unsignedByte asPointerType) size: byteSize; yourself! ----- Method: ExternalData>>blockAt:byteSize: (in category '*FFI-Callbacks') ----- blockAt: byteIndex byteSize: numBytes "Given that the receiver manages a page of memory, answer a block of that memory to use." ^ ExternalData fromHandle: handle + (byteIndex - 1) byteSize: numBytes! ExternalStructure subclass: #FFICallbackContext instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FFI-Callbacks'! ----- 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') ) " 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; "! ----- Method: FFICallbackContext class>>fromHandle: (in category 'instance creation') ----- fromHandle: aHandleOrInteger ^ super fromHandle: (aHandleOrInteger isInteger ifTrue: [ExternalAddress fromInteger: aHandleOrInteger] ifFalse: [aHandleOrInteger])! ----- Method: FFICallbackContext>>errorResult (in category 'callback result') ----- errorResult ^ self wordResult: -1! ----- Method: FFICallbackContext>>externalObjectResult: (in category 'callback result') ----- externalObjectResult: anExternalObject "ExternalStructure, ExternalUnion, ExternalData ... handle MUST BE an ExternalAddress" ^ self pointerResult: anExternalObject getHandle! ----- Method: FFICallbackContext>>floatRegArgs (in category 'accessing') ----- floatRegArgs "This method was automatically generated. See FFICallbackContext class>>fields." <generated> ^ExternalData fromHandle: (handle shortPointerAt: 13) type: ExternalType double asPointerType! ----- Method: FFICallbackContext>>floatRegArgs: (in category 'accessing') ----- floatRegArgs: someExternalData "This method was automatically generated. See FFICallbackContext class>>fields." <generated> handle shortPointerAt: 13 put: someExternalData getHandle.! ----- Method: FFICallbackContext>>floatResult: (in category 'callback result') ----- floatResult: aFloat self rvs floatResult: aFloat. ^ 3! ----- Method: FFICallbackContext>>intRegArgs (in category 'accessing') ----- intRegArgs "This method was automatically generated. See FFICallbackContext class>>fields." <generated> ^ExternalData fromHandle: (handle shortPointerAt: 9) type: ExternalType long asPointerType! ----- Method: FFICallbackContext>>intRegArgs: (in category 'accessing') ----- intRegArgs: someExternalData "This method was automatically generated. See FFICallbackContext class>>fields." <generated> handle shortPointerAt: 9 put: someExternalData getHandle.! ----- Method: FFICallbackContext>>pointerResult: (in category 'callback result') ----- pointerResult: anExternalAddress ^ self wordResult: anExternalAddress asInteger! ----- Method: FFICallbackContext>>rvs (in category 'accessing') ----- rvs "This method was automatically generated. See FFICallbackContext class>>fields." <generated> ^FFICallbackResult fromHandle: (handle structAt: 25 length: 8)! ----- Method: FFICallbackContext>>rvs: (in category 'accessing') ----- rvs: aFFICallbackResult "This method was automatically generated. See FFICallbackContext class>>fields." <generated> handle structAt: 25 put: aFFICallbackResult getHandle length: 8.! ----- Method: FFICallbackContext>>stackPtr (in category 'accessing') ----- stackPtr "This method was automatically generated. See FFICallbackContext class>>fields." <generated> ^ExternalData fromHandle: (handle shortPointerAt: 5) type: ExternalType long asPointerType! ----- Method: FFICallbackContext>>stackPtr: (in category 'accessing') ----- stackPtr: someExternalData "This method was automatically generated. See FFICallbackContext class>>fields." <generated> handle shortPointerAt: 5 put: someExternalData getHandle.! ----- Method: FFICallbackContext>>thunkp (in category 'accessing') ----- thunkp "This method was automatically generated. See FFICallbackContext class>>fields." <generated> ^ExternalData fromHandle: (handle shortPointerAt: 1) type: ExternalType void asPointerType! ----- Method: FFICallbackContext>>thunkp: (in category 'accessing') ----- thunkp: someExternalData "This method was automatically generated. See FFICallbackContext class>>fields." <generated> handle shortPointerAt: 1 put: someExternalData getHandle.! ----- Method: FFICallbackContext>>voidResult (in category 'callback result') ----- voidResult self flag: #discuss. "mt: Is this the expected answer in the IA32ABI plugin?" ^ self wordResult: 0! ----- Method: FFICallbackContext>>wordResult: (in category 'callback result') ----- wordResult: aValue "Accept any value in the -2^31 to 2^32-1 range or booleans." aValue isBoolean ifTrue: [self rvs booleanResult: aValue]. aValue isInteger ifTrue: [aValue >= 0 ifTrue: [self rvs positiveIntegerResult: aValue] ifFalse: [self rvs integerResult: aValue]]. ^1! ----- Method: Parser>>callback (in category '*FFI-Callbacks') ----- callback <pragmaParser> | descriptorClass retType externalName args argType | descriptorClass := ExternalFunction. "Parse return type" self advance. here = 'const' ifTrue: [self advance]. retType := self externalType: descriptorClass. retType == nil ifTrue:[^self expected:'return type']. "Parse function name or index" externalName := here. (self match: #leftParenthesis) ifFalse:[^self expected:'function pointer (*)']. (self matchToken: #*) ifFalse:[^self expected:'function pointer (*)']. (self match: #rightParenthesis) ifFalse:[^self expected:'function pointer (*)']. (self match: #leftParenthesis) ifFalse:[^self expected:'argument list']. args := WriteStream on: Array new. [self match: #rightParenthesis] whileFalse:[ here = 'const' ifTrue: [self advance]. here = ',' ifTrue: [self advance]. argType := self externalType: descriptorClass. argType == nil ifTrue:[^self expected:'argument']. argType isVoid & argType isPointerType not ifFalse:[args nextPut: argType]]. self addPragma: (Pragma keyword: #callback: arguments: {{retType}, args contents}). ^true! ----- Method: SHParserST80>>callback (in category '*FFI-Callbacks') ----- callback <pragmaParser> self scanPast: #externalFunctionCallingConvention. self scanPast: #externalCallType. currentToken = '*' ifTrue: [self scanPast: #externalCallTypePointerIndicator]. currentTokenFirst == $( ifFalse: [^ self fail]. self scanNext. currentTokenFirst == $* ifFalse: [^ self fail]. self scanNext. currentTokenFirst == $) ifFalse: [^ self fail]. self scanNext. self failUnless: currentTokenFirst == $(. self scanPast: #leftParenthesis. [currentTokenFirst ~= $)] whileTrue: [ self failUnless: currentToken notNil. self scanPast: #externalCallType. currentToken = '*' ifTrue: [self scanPast: #externalCallTypePointerIndicator]]. self scanPast: #rightParenthesis. currentToken = 'module:' ifTrue: [ self scanPast: #module. self parseStringOrSymbol ]. currentToken = 'error:' ifTrue: [ self scanPast: #primitive. "there's no rangeType for error" self currentTokenType == #name ifTrue: [ self parseTemporary: #patternTempVar ] ifFalse: [ self parseStringOrSymbol ] ]. self failUnless: currentToken = '>'. self scanPast: #primitiveOrExternalCallEnd! ----- Method: ExternalAddress class>>allocateExecutablePage (in category '*FFI-Callbacks') ----- allocateExecutablePage "The IA32ABI plugin answers a byte array where the first half encodes the allocated byte size and the second half the external address to that executable memory. Unpack that byte array and return external data we can read and write conveniently." | alien | alien := self primAllocateExecutablePage. ^ ExternalData fromHandle: alien externalPointer byteSize: alien byteSize! ----- Method: ExternalAddress class>>fromInteger: (in category '*FFI-Callbacks') ----- fromInteger: anInteger "Read the given interger as an address pointing to an external memory area." | buffer type | type := ExternalType uintptr_t. buffer := ByteArray new: type byteSize. type handle: buffer at: 1 put: anInteger. ^ buffer asExternalPointer! ----- Method: ExternalAddress class>>primAllocateExecutablePage (in category '*FFI-Callbacks') ----- primAllocateExecutablePage "^<Alien>" "Answer an Alien around a piece of (probably malloced) memory, of some multiple of the pagesize, that has execute permissions set. This memory can be parcelled out to individual FFICallbackThunks to hold their thunk/trampoline machine code." <primitive: 'primAllocateExecutablePage' module: 'IA32ABI' error: errorCode> ^self primitiveFailed! ----- Method: FFIPlatformDescription>>abi (in category '*FFI-Callbacks') ----- abi | processor | processor := self subtype asLowercase. (processor = 'arm' or: [(processor beginsWith: 'armv') and: [processor fifth <= $7]]) ifTrue: [^ 'ARM32']. (processor first = $i and: [processor = 'intel' or: ['i#86' match: processor]]) ifTrue: [^ 'IA32']. (processor first = $x and: [processor = 'x64' or: [('x86#64*' match: processor)]]) ifTrue: [^ self isWindows ifTrue: ['X64Win64'] ifFalse: ['X64']]. ^ 'UNKNOWN'! ExternalObject subclass: #FFICallback instanceVariableNames: 'abi type evaluableObject thunk argTypes' classVariableNames: 'ThunkToCallbackMap' poolDictionaries: '' category: 'FFI-Callbacks'! ----- Method: FFICallback class>>cdeclQsort:with:with:with: (in category 'examples') ----- cdeclQsort: values with: number with: width with: callback <cdecl: void 'qsort' (void* size_t size_t void*) module: 'msvcrt.dll'> ^ self externalCallFailed! ----- Method: FFICallback class>>evaluateCallbackForContext: (in category 'instance lookup') ----- evaluateCallbackForContext: callbackContext "<FFIallbackContext> ^<Integer> typeCode" (ThunkToCallbackMap at: callbackContext thunkp getHandle ifAbsent: [^self error: 'could not locate Callback instance corresponding to thunk address']) ifNil: [self error: 'Callback instance for this thunk address has been garbage collected'] ifNotNil: [:callback| ^callback valueInContext: callbackContext]! ----- Method: FFICallback class>>exampleCqsort (in category 'examples') ----- exampleCqsort "Call the libc qsort function (which requires a callback)." "FFICallback exampleCqsort" "(Time millisecondsToRun: [100 timesRepeat: [FFICallback exampleCqsort]]) / 100.0" | 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 := 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 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 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: sizeofDouble with: cb thunk "getHandle". sort := values collect: [:each | each]. values getHandle free. ^orig -> sort! ----- Method: FFICallback class>>exampleCqsortThree (in category 'examples') ----- exampleCqsortThree "Call the libc qsort function (which requires a callback)." " FFICallback exampleCqsortThree " "(Time millisecondsToRun: [100 timesRepeat: [FFICallback exampleCqsort]]) / 100.0" | type rand nElements sizeofDouble values orig sort cb | rand := Random new. type := ExternalType double. sizeofDouble := type byteSize. nElements := 10. 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 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 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: nElements with: sizeofDouble with: cb thunk. sort := values collect: [:each | each]. values getHandle free. ^orig -> sort! ----- Method: FFICallback class>>exampleCqsortTwo (in category 'examples') ----- exampleCqsortTwo "Call the libc qsort function (which requires a callback)." " FFICallback exampleCqsortTwo " "(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 := 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 collect: [:each | each]. "Invoke!!" self qsort: values with: nElements with: sizeofDouble with: [ :arg1 :arg2 | | a b | a := arg1 doubleAt: 1. b := arg2 doubleAt: 1. Transcript showln: ('Comparing {1} and {2}' format: {a. b}). self halt. (a - b) sign]. sort := values collect: [:each | each]. values getHandle free. ^orig -> sort! ----- Method: FFICallback class>>getIntWithData:withData: (in category 'examples - signatures') ----- getIntWithData: anExternalData1 withData: anExternalData2 " (FFICallback class >> #getIntWithData:withData:) pragmaAt: #callback: " <callback: int (*)(void* void*)> self shouldNotImplement.! ----- Method: FFICallback class>>getIntWithData:withData:withInt:withInt: (in category 'examples - signatures') ----- getIntWithData: anExternalData1 withData: anExternalData2 withInt: anInteger1 withInt: anInteger2 " (FFICallback class >> #getIntWithData:withData:withInt:withInt:) pragmaAt: #callback: " <callback: int (*)(void* void* uint32_t intptr_t)> self shouldNotImplement. self flag: #todo: "Ignore macros, const, and '*,' comma" "<signature: #(int CALLBACK (*)(const LOGFONT *, const TEXTMETRIC *, DWORD, LPARAM))>" ! ----- Method: FFICallback class>>getIntWithInt:withString: (in category 'examples - signatures') ----- getIntWithInt: anInteger withString: aString " (FFICallback class >> #getIntWithInt:withString:) pragmaAt: #callback: " <callback: int (*)(int char *)> self shouldNotImplement.! ----- Method: FFICallback class>>getVoidWithData:withDouble:withDouble: (in category 'examples - signatures') ----- getVoidWithData: anExternalData withDouble: aFloat withDouble: anotherFloat " (FFICallback class >> #getVoidWithData:withDouble:withDouble:) pragmaAt: #callback: " <callback: void (*)(void* double double)> self shouldNotImplement.! ----- Method: FFICallback class>>initialize (in category 'class initialization') ----- initialize ThunkToCallbackMap := WeakValueDictionary new.! ----- Method: FFICallback class>>maxThunkSize (in category 'constants') ----- maxThunkSize "see FFICallbackThunk initialize & initializeStdcall:; must be big enough for the largest thunk created" ^ 40! ----- Method: FFICallback class>>message: (in category 'instance creation') ----- message: message "<MessageSend> ^<FFICallback>" ^ self new setMessage: message ! ----- 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! ----- Method: FFICallback class>>signature:block: (in category 'instance creation') ----- signature: signature "<String>" block: aBlock "<BlockClosure> ^<FFICallback>" ^ self new setBlock: aBlock signature: signature! ----- Method: FFICallback class>>signature:message: (in category 'instance creation') ----- signature: signature "<String>" message: message "<MessageSend> ^<FFICallback>" ^ self new setMessage: message signature: signature! ----- 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: argTypes size - 1. "Skip return type" 1 to: args size do: [:argIndex | | argType unsigned data | argType := argTypes at: argIndex + 1. "Skip return type" 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?" self flag: #todo. "mt: How to make boolean out of integer here? Would it work with floats, too?" unsigned := argType isIntegerType ==> [argType isUnsigned]. data := unsigned ifTrue: [type asUnsigned handle: handle at: offset] ifFalse: [type asSigned 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. offset := offset + type byteSize]. ^ self setResult: (evaluableObject valueWithArguments: args) inContext: callbackContext.! ----- 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> self setArgData: callbackContext intRegArgs. ^ self evaluateDynamic: callbackContext! ----- 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> self setArgData: callbackContext stackPtr. ^ self evaluateDynamic: callbackContext! ----- 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> self setArgData: callbackContext intRegArgs. ^ self evaluateDynamic: callbackContext! ----- 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> self setArgData: callbackContext intRegArgs. ^ self evaluateDynamic: callbackContext! ----- Method: FFICallback>>init__ccall (in category 'initialization - thunk prepare') ----- init__ccall "Initialize the receiver with a __ccall thunk." FFICallback methodsDo: [:method | (method selector beginsWith: 'init__ccall') ifTrue: [ (method hasPragma: #init) ifTrue: [ (method pragmaAt: #abi:) ifNotNil: [:pragma | (pragma argumentAt: 1) = abi ifTrue: [^ self executeMethod: method]]]]]. self error: 'Could not initialize thunk for current ABI: ', abi.! ----- Method: FFICallback>>init__ccall_ARM32 (in category 'initialization - thunk prepare') ----- init__ccall_ARM32 <abi: 'ARM32'> <init> "Initialize the receiver with a __ccall thunk. The thunk calls thunkEntry in the IA32ABI plugin, whose source is in platforms/Cross/plugins/IA32ABI/arm32abicc.c. thunkEntry is the entry point for Callbacks. The objective of the thunk is to call thunkEntry with all arguments to the call of the thunk (registers and stack) as well as a pointer to the thunk itself. thunkEntry is as follows: long long thunkEntry(long r0, long r1, long r2, long r3, double d0, double d1, double d2, double d3, double d4, double d5, double d6, double d7, void *thunkpPlus16, sqIntptr_t *stackp) thunkEntry then collects the various arguments (thunk, integer register arguments, floating-point register arguments, stack pointer) in a VMCallbackContext and invokes the callback via invokeCallbackContext:." "0x0 <thunk+0>: mov r12, sp ; 0xe1a0c00d 0x4 <thunk+4>: sub sp, sp, #16 ; 0xe24dd010 0x8 <thunk+8>: str pc, [sp, #0] ; 0xe58df000 N.B. passes thunk+16; thunkEntry compensates 0xc <thunk+12>: str r12, [sp,#4] ; 0xe58dc004 0x10 <thunk+16>: str lr, [sp, #12] ; 0xe58de00c 0x14 <thunk+20>: ldr r12, [pc, #8] ; 0xe59fc008 0x18 <thunk+24>: blx r12 ; 0xe12fff3c 0x1c <thunk+28>: add sp, sp, #12 ; 0xe28dd00c 0x20 <thunk+32>: ldr pc, [sp], #4!! ; 0xe49df004 ; pop {pc} 0x24 <thunk+36>: .word thunkEntry" self flag: #hidden. "mt: How is the thunk's handle stored to lookup this instance upon callback later?" thunk getHandle unsignedLongAt: 1 put: 16re1a0c00d; unsignedLongAt: 5 put: 16re24dd010; unsignedLongAt: 9 put: 16re58df000; unsignedLongAt: 13 put: 16re58dc004; unsignedLongAt: 17 put: 16re58de00c; unsignedLongAt: 21 put: 16re59fc008; unsignedLongAt: 25 put: 16re12fff3c; unsignedLongAt: 29 put: 16re28dd00c; unsignedLongAt: 33 put: 16re49df004; shortPointerAt: 37 put: self thunkEntryAddress.! ----- Method: FFICallback>>init__ccall_IA32 (in category 'initialization - thunk prepare') ----- init__ccall_IA32 <abi: 'IA32'> <init> "Initialize the receiver with a __ccall thunk. The thunk calls thunkEntry in the IA32ABI plugin, whose source is in platforms/Cross/plugins/IA32ABI/x64win64abicc.c. thunkEntry is the entry point for Callbacks. The objective of the thunk is to call thunkEntry with all arguments to the call of the thunk (registers and stack) as well as a pointer to the thunk itself. thunkEntry is as follows: long thunkEntry(void *thunkp, sqIntptr_t *stackp) thunkEntry then collects the various arguments (thunk, stack pointer) in a VMCallbackContext and invokes the callback via invokeCallbackContext:." "thunk: push %esp 0x54 0xa1905454 thunk+01: push %esp 0x54 thunk+02: nop 0x90 thunk+03: mov $thunkEntry,%eax 0xb8 0x00 0x00 0x00 0x00 0x00000000 - entry thunk+08: nop 0x90 0x68909090 thunk+09: nop 0x90 thunk+10: nop 0x90 thunk+11: push $thunk 0x68 0x00 0x00 0x00 0x00 0x00000000 - thunk thunk+16: call *%eax 0xff 0xd0 0xc483d0ff thunk+18: add $0xC,%esp 0x83 0xc4 0x0C 0x9090c30C thunk+21: ret 0xc3 thunk+22: nop 0x90 thunk+23: nop 0x90" thunk getHandle unsignedLongAt: 1 put: 16rB8905454; shortPointerAt: 5 put: self thunkEntryAddress; unsignedLongAt: 9 put: 16r68909090; shortPointerAt: 13 put: thunk getHandle; unsignedLongAt: 17 put: 16rC483D0FF; unsignedLongAt: 21 put: 16r9090C30C! ----- Method: FFICallback>>init__ccall_X64 (in category 'initialization - thunk prepare') ----- init__ccall_X64 <abi: 'X64'> <init> "Initialize the receiver with a __ccall thunk. The thunk calls thunkEntry in the IA32ABI plugin, whose source is in platforms/Cross/plugins/IA32ABI/x64sysvabicc.c. thunkEntry is the entry point for Callbacks. The objective of the thunk is to call thunkEntry with all arguments to the call of the thunk (registers and stack) as well as a pointer to the thunk itself. thunkEntry is as follows: long thunkEntry(long a0, long a1, long a2, long a3, long a4, long a5, double d0, double d1, double d2, double d3, double d4, double d5, double d6, double d7, void *thunkp, sqIntptr_t *stackp) thunkEntry then collects the various arguments (thunk, integer register arguments, floating-point register arguments, stack pointer) in a VMCallbackContext and invokes the callback via invokeCallbackContext:." "thunk+0x0: pushq %rsp 54 thunk+0x1: pushq %rsp 54 thunk+0x4: movabsq $thunk, %rax 48 b8 b0..b7 eight bytes of thunk address a.k.a. handle thunk+0xc: pushq %rax 50 thunk+0xd: movabsq $thunkEntry, %rax 48 b8 b0..b7 eight bytes of the thunkEntry address thunk+0x17: callq *%rax ff d0 thunk+0x19: addq $0x18, %rsp 48 83 c4 18 thunk+0x1d: retq c3 thunk+0x1e: nop 90 thunk+0x1f: nop 90" thunk getHandle unsignedLongAt: 1 put: 16rb8485454; longPointerAt: 5 put: thunk getHandle; unsignedLongAt: 13 put: 16r00b84850; "00 is the first byte of the 64-bit constant the movabsq/0x48 opcode moves" longPointerAt: 16 put: self thunkEntryAddress; unsignedByteAt: 24 put: 16rff; unsignedLongAt: 25 put: 16rc48348d0; unsignedLongAt: 29 put: 16r9090c318.! ----- Method: FFICallback>>init__ccall_X64Win64 (in category 'initialization - thunk prepare') ----- init__ccall_X64Win64 <abi: 'X64Win64'> <init> "Initialize the receiver with a __ccall thunk. The thunk calls thunkEntry in the IA32ABI plugin, whose source is in platforms/Cross/plugins/IA32ABI/x64win64abicc.c. thunkEntry is the entry point for Callbacks. The objective of the thunk is to call thunkEntry with all arguments to the call of the thunk (registers and stack) as well as a pointer to the thunk itself. thunkEntry is as follows: long long thunkEntry(long long rcx, long long rdx, long long r8, long long r9, void *thunkp, sqIntptr_t *stackp) thunkEntry then collects the various arguments (thunk, integer register arguments, stack pointer) in a VMCallbackContext and invokes the callback via invokeCallbackContext:." "thunk+0x0: pushq %rsp 54 thunk+0x1: pushq %rsp 54 thunk+0x4: movabsq $thunk, %rax 48 b8 b0..b7 eight bytes of thunk address a.k.a. addressField thunk+0xc: pushq %rax 50 thunk+0xd: subq $0x20, %rsp 48 83 c4 e0 (this is addq -20 since the immediate is signed extended) thunk+0x11: movabsq $thunkEntry, %rax 48 b8 b0..b7 eight bytes of the thunkEntry address thunk+0x1b: callq *%rax ff d0 thunk+0x1d: addq $0x38, %rsp 48 83 c4 38 thunk+0x21: retq c3 thunk+0x22: nop 90 thunk+0x23: nop 90" thunk getHandle unsignedLongAt: 1 put: 16rb8485454; longPointerAt: 5 put: thunk getHandle; unsignedLongAt: 13 put: 16rc4834850; unsignedLongAt: 17 put: 16r00b848e0; "00 is the first byte of the 64-bit constant the movabsq/0x48 opcode moves" longPointerAt: 20 put: self thunkEntryAddress; unsignedByteAt: 28 put: 16rff; unsignedLongAt: 29 put: 16rc48348d0; unsignedLongAt: 33 put: 16r9090c338.! ----- Method: FFICallback>>init__stdcall: (in category 'initialization - thunk prepare') ----- init__stdcall: numBytes "Initialize the receiver with a __stdcall thunk with numBytes argument bytes." FFICallback methodsDo: [:method | (method selector beginsWith: 'init__stdcall') ifTrue: [ (method hasPragma: #init) ifTrue: [ (method pragmaAt: #abi:) ifNotNil: [:pragma | (pragma argumentAt: 1) = abi ifTrue: [^ self with: numBytes executeMethod: method]]]]]. self error: 'Could not initialize thunk for current ABI: ', abi.! ----- Method: FFICallback>>init__stdcall_IA32: (in category 'initialization - thunk prepare') ----- init__stdcall_IA32: numBytes <abi: 'IA32'> <init> "Initialize the receiver with a __stdcall thunk with numBytes argument bytes. (See #init__ccall_IA32 for more info)" "thunk: push %esp 0x54 0xa1905454 thunk+01: push %esp 0x54 thunk+02: nop 0x90 thunk+03: mov $thunkEntry,%eax 0xb8 0x00 0x00 0x00 0x00 0x00000000 - entry thunk+08: nop 0x90 0x68909090 thunk+09: nop 0x90 thunk+10: nop 0x90 thunk+11: push $thunk 0x68 0x00 0x00 0x00 0x00 0x00000000 - thunk thunk+16: call *%eax 0xff 0xd0 0xc483d0ff thunk+18: add $0xC,%esp 0x83 0xc4 0x0C 0xBYTSc20C thunk+21: ret $bytes 0xc2 0xBY 0xTS" thunk getHandle unsignedLongAt: 1 put: 16rB8905454; shortPointerAt: 5 put: self thunkEntryAddress; unsignedLongAt: 9 put: 16r68909090; shortPointerAt: 13 put: thunk getHandle; unsignedLongAt: 17 put: 16rC483D0FF; unsignedShortAt: 21 put: 16rC20C; unsignedShortAt: 23 put: numBytes.! ----- Method: FFICallback>>primThunkEntryAddress (in category 'initialization - thunk prepare') ----- primThunkEntryAddress "^<Integer>" "Answer the address of the entry-point for thunk callbacks: x86: long thunkEntry(void *thunkp, long *stackp); x64: long thunkEntry(long a, long b, long c, long d, long, e, long f, double d0, double d1, double d2, double d3, double d4, double d5, double d6, double d7, void *thunkp, long *stackp); ARM: long thunkEntry(long a, long b, long c, long d, double d0, double d1, double d2, double d3, double d4, double d5, double d6, double d7, void *thunkp, long *stackp); etc. This is the function a callback thunk/trampoline should call to initiate a callback." <primitive: 'primThunkEntryAddress' module: 'IA32ABI' error: errorCode> ^self primitiveFailed! ----- Method: FFICallback>>setArgData: (in category 'callback') ----- setArgData: externalData handle := externalData getHandle. type := externalData externalType. ! ----- Method: FFICallback>>setArgTypes:evaluableObject: (in category 'initialization') ----- setArgTypes: externalTypes evaluableObject: blockOrMessage abi := FFIPlatformDescription current abi. handle := nil. type := nil. evaluableObject := blockOrMessage. argTypes := externalTypes. "Support for callee pop callbacks (Pascal calling convention such as the Win32 stdcall: convention) are supported using the <calleepops: N> pragma which specifies how many bytes to pop. See http://forum.world.st/Pharo-FFI-on-aarch64-arm64-td5096777.html#a5096786." thunk := FFICallbackMemory allocateExecutableBlock. self init__ccall. "(method pragmaAt: #calleepops:) ifNil: [self init__ccall] ifNotNil: [:pragma | self init__stdcall: (pragma argumentAt: 1)]." "numEvaluatorArgs := (evaluator := method selector) numArgs. self addToThunkTable" ThunkToCallbackMap at: thunk getHandle put: self! ----- Method: FFICallback>>setBlock: (in category 'initialization') ----- setBlock: aBlock "We cannot know the signature for an arbitrary block." self shouldNotImplement.! ----- Method: FFICallback>>setBlock:signature: (in category 'initialization') ----- setBlock: aBlock "<BlockClosure>" signature: signature "<String>" self setArgTypes: (ExternalType lookupTypes: signature) evaluableObject: aBlock.! ----- Method: FFICallback>>setMessage: (in category 'initialization') ----- setMessage: aMessageSend "Fetch the argTypes from <callback: ...> pragma in method." | method | self assert: [aMessageSend receiver notNil]. method := aMessageSend receiver class lookupSelector: aMessageSend selector. self setArgTypes: ((method pragmaAt: #callback:) argumentAt: 1) evaluableObject: aMessageSend.! ----- Method: FFICallback>>setMessage:signature: (in category 'initialization') ----- setMessage: aMessageSend signature: signature "Override the argTypes from <callback: ...> pragma in method." self assert: [aMessageSend receiver notNil]. self setArgTypes: (ExternalType lookupTypes: signature) evaluableObject: aMessageSend.! ----- Method: FFICallback>>setResult:inContext: (in category 'callback') ----- setResult: anObject inContext: aCallbackContext "Set the result in the callback context. Add some fast checks to detect errors." argTypes first atomicType = 0 "void" ifTrue: [ "Quick exit for void return type." ^ aCallbackContext voidResult]. anObject isInteger ifTrue: [ self assert: [argTypes first isIntegerType]. ^ aCallbackContext wordResult: anObject]. anObject isBoolean ifTrue: [ self assert: [argTypes first atomicType = 1 "bool"]. ^ aCallbackContext wordResult: anObject]. anObject isFloat ifTrue: [ self assert: [argTypes first atomicType >= 12 "float/double"]. ^ aCallbackContext floatResult: anObject]. "Try to push pointer for external object." ^ aCallbackContext externalObjectResult: anObject! ----- Method: FFICallback>>thunk (in category 'accessing') ----- thunk " self flag: #debugging. ^ FFICallbackMemory new externalPointer: thunk getHandle; yourself" ^ thunk! ----- Method: FFICallback>>thunkEntryAddress (in category 'initialization - thunk prepare') ----- thunkEntryAddress ^ ExternalAddress fromInteger: self primThunkEntryAddress! ----- Method: FFICallback>>valueInContext: (in category 'callback') ----- valueInContext: callbackContext "<FFICallbackContext> ^<Integer>" FFICallback methodsDo: [:method | (method hasPragma: #evaluator) ifTrue: [ (method pragmaAt: #abi:) ifNotNil: [:pragma | (pragma argumentAt: 1) = abi ifTrue: [^ self with: callbackContext executeMethod: method]]]]. self error: 'Could find evaluator for current ABI: ', abi.! ExternalUnion subclass: #FFICallbackResult instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FFI-Callbacks'! ----- Method: FFICallbackResult class>>fields (in category 'field definition') ----- fields " self defineFields. " ^ #( (booleanResult 'bool') (floatResult 'double') (positiveIntegerResult 'uintptr_t') (integerResult 'intptr_t') )! ----- Method: FFICallbackResult>>booleanResult (in category 'accessing') ----- booleanResult "This method was automatically generated. See FFICallbackResult class>>fields." <generated> ^handle booleanAt: 1! ----- Method: FFICallbackResult>>booleanResult: (in category 'accessing') ----- booleanResult: aBoolean "This method was automatically generated. See FFICallbackResult class>>fields." <generated> handle booleanAt: 1 put: aBoolean! ----- Method: FFICallbackResult>>floatResult (in category 'accessing') ----- floatResult "This method was automatically generated. See FFICallbackResult class>>fields." <generated> ^handle doubleAt: 1! ----- Method: FFICallbackResult>>floatResult: (in category 'accessing') ----- floatResult: aFloat "This method was automatically generated. See FFICallbackResult class>>fields." <generated> handle doubleAt: 1 put: aFloat! ----- Method: FFICallbackResult>>integerResult (in category 'accessing') ----- integerResult "This method was automatically generated. See FFICallbackResult class>>fields." <generated> ^handle signedLongAt: 1! ----- Method: FFICallbackResult>>integerResult: (in category 'accessing') ----- integerResult: anInteger "This method was automatically generated. See FFICallbackResult class>>fields." <generated> handle signedLongAt: 1 put: anInteger! ----- Method: FFICallbackResult>>positiveIntegerResult (in category 'accessing') ----- positiveIntegerResult "This method was automatically generated. See FFICallbackResult class>>fields." <generated> ^handle unsignedLongAt: 1! ----- Method: FFICallbackResult>>positiveIntegerResult: (in category 'accessing') ----- positiveIntegerResult: anInteger "This method was automatically generated. See FFICallbackResult class>>fields." <generated> handle unsignedLongAt: 1 put: anInteger!

1 0

FFI: FFI-Tools-mt.20.mcz
by commits＠source.squeak.org 28 Jul '20

28 Jul '20

Marcel Taeumel uploaded a new version of FFI-Tools to project FFI: http://source.squeak.org/FFI/FFI-Tools-mt.20.mcz ==================== Summary ==================== Name: FFI-Tools-mt.20 Author: mt Time: 28 July 2020, 1:34:28.035011 pm UUID: f78c718c-8d1c-e141-a601-7e9bcf6d3978 Ancestors: FFI-Tools-mt.19 Adds parser hook for callback pragmas. Simplifies loading of FFI-Callback. =============== Diff against FFI-Tools-mt.19 =============== Item was added: + ----- Method: SHParserST80>>callback (in category '*FFI-Tools') ----- + callback + <pragmaParser> + + self scanPast: #externalFunctionCallingConvention. + + self scanPast: #externalCallType. + currentToken = '*' + ifTrue: [self scanPast: #externalCallTypePointerIndicator]. + + currentTokenFirst == $( ifFalse: [^ self fail]. self scanNext. + currentTokenFirst == $* ifFalse: [^ self fail]. self scanNext. + currentTokenFirst == $) ifFalse: [^ self fail]. self scanNext. + + self failUnless: currentTokenFirst == $(. + self scanPast: #leftParenthesis. + [currentTokenFirst ~= $)] + whileTrue: [ + self failUnless: currentToken notNil. + self scanPast: #externalCallType. + currentToken = '*' + ifTrue: [self scanPast: #externalCallTypePointerIndicator]]. + self scanPast: #rightParenthesis. + currentToken = 'module:' + ifTrue: [ + self scanPast: #module. + self parseStringOrSymbol ]. + currentToken = 'error:' ifTrue: [ + self scanPast: #primitive. "there's no rangeType for error" + self currentTokenType == #name + ifTrue: [ self parseTemporary: #patternTempVar ] + ifFalse: [ self parseStringOrSymbol ] ]. + self failUnless: currentToken = '>'. + self scanPast: #primitiveOrExternalCallEnd!

1 0

FFI: FFI-Kernel-mt.119.mcz
by commits＠source.squeak.org 28 Jul '20

28 Jul '20

Marcel Taeumel uploaded a new version of FFI-Kernel to project FFI: http://source.squeak.org/FFI/FFI-Kernel-mt.119.mcz ==================== Summary ==================== Name: FFI-Kernel-mt.119 Author: mt Time: 28 July 2020, 1:34:03.494011 pm UUID: ad1bfdeb-3a7f-bb49-a61d-199918835891 Ancestors: FFI-Kernel-nice.118 Adds parser hook for callback pragmas. Simplifies loading of FFI-Callback. =============== Diff against FFI-Kernel-nice.118 =============== Item was added: + ----- Method: Parser>>callback (in category '*FFI-Kernel') ----- + callback + <pragmaParser> + + | descriptorClass retType externalName args argType | + descriptorClass := ExternalFunction. + "Parse return type" + self advance. + here = 'const' ifTrue: [self advance]. + retType := self externalType: descriptorClass. + retType == nil ifTrue:[^self expected:'return type']. + "Parse function name or index" + externalName := here. + + (self match: #leftParenthesis) ifFalse:[^self expected:'function pointer (*)']. + (self matchToken: #*) ifFalse:[^self expected:'function pointer (*)']. + (self match: #rightParenthesis) ifFalse:[^self expected:'function pointer (*)']. + + (self match: #leftParenthesis) ifFalse:[^self expected:'argument list']. + args := WriteStream on: Array new. + [self match: #rightParenthesis] whileFalse:[ + here = 'const' ifTrue: [self advance]. + here = ',' ifTrue: [self advance]. + argType := self externalType: descriptorClass. + argType == nil ifTrue:[^self expected:'argument']. + argType isVoid & argType isPointerType not ifFalse:[args nextPut: argType]]. + + self addPragma: (Pragma keyword: #callback: arguments: {{retType}, args contents}). + ^true!

1 0

The Trunk: ToolBuilder-Morphic-mt.263.mcz
by commits＠source.squeak.org 28 Jul '20

28 Jul '20

Marcel Taeumel uploaded a new version of ToolBuilder-Morphic to project The Trunk: http://source.squeak.org/trunk/ToolBuilder-Morphic-mt.263.mcz ==================== Summary ==================== Name: ToolBuilder-Morphic-mt.263 Author: mt Time: 28 July 2020, 10:00:57.682779 am UUID: fecabf05-7969-5f4f-8a7a-c0a2fbf874b8 Ancestors: ToolBuilder-Morphic-pre.262 In tree widgets, fixes refresh for nodes w/o parents (aka. top nodes or roots). See ObjectExplorerWrapper for a similar strategy. =============== Diff against ToolBuilder-Morphic-pre.262 =============== Item was changed: ----- Method: PluggableTreeItemNode>>refresh (in category 'as yet unclassified') ----- refresh + self parent ifNil: [^ self]. self setItem: (self parent contents at: self index ifAbsent: [self error: 'No support for changed child count yet!!']) item.!

1 0

The Trunk: SystemReporter-eem.43.mcz
by commits＠source.squeak.org 27 Jul '20

27 Jul '20

Eliot Miranda uploaded a new version of SystemReporter to project The Trunk: http://source.squeak.org/trunk/SystemReporter-eem.43.mcz ==================== Summary ==================== Name: SystemReporter-eem.43 Author: eem Time: 27 July 2020, 12:28:19.766033 pm UUID: 07d625b9-43e4-47c4-9bd2-afc14f912602 Ancestors: SystemReporter-mt.42 Make accurate the label for desired code code size. =============== Diff against SystemReporter-mt.42 =============== Item was changed: ----- Method: SystemReporter>>reportVMParameters: (in category 'reporting') ----- reportVMParameters: aStream | vmParameters isStack isCog isSpur | self header: 'Virtual Machine Parameters' on: aStream. vmParameters := Smalltalk vm getVMParameters. isStack := (vmParameters at: 42 ifAbsent: [0]) ~= 0. "42 = number of stack pages available" isCog := isStack and: [(vmParameters at: 46) ~= 0]. "46 is machine code zone size" isSpur := isStack and: [(vmParameters at: 41) anyMask: 2r10000]. "41 is imageFormatVersion for the VM; bit 16 is the Spur bit" (isSpur ifFalse: [#( 1 'size of old space' 2 'size of young+old space' 3 'size of memory' 4 'allocationCount' 5 'allocations between GCs' 6 'survivor count tenuring threshold')] ifTrue: [#( 1 'size of old space' 2 'used bytes in new space (used eden + used past space)' 3 'size of heap')]), #( 7 'full GCs since startup' 8 'total milliseconds in full GCs since startup'), (isSpur ifFalse: [#( 9 'incremental GCs since startup' 10 'total milliseconds in incremental GCs since startup' 11 'tenures of surving objects since startup'), {12 to: 19. 'specific to the translating VM'}] ifTrue: [#( 9 'scavenging GCs since startup' 10 'total milliseconds in scavenging GCs since startup' 11 'tenures of surving objects since startup'), {12 to: 15. 'reserved for future use'}, #( 16 'total microseconds in idle since startup' 17 'proportion of code zone available for use (Sista VMs only; read-write)' 18 'total milliseconds in full GC compaction since startup (a portion of parameter 8)' 19 'scavenge threshold; the effective size of eden')]), #( 20 'utc microseconds at startup (if non-zero)' 21 'root/remembered table size (occupancy)' 22 'root/remembered table overflows since startup' 23 'bytes of extra memory to reserve for VM buffers, plugins, etc.' 24 'free memory threshold above which object memory will be shrunk' 25 'memory headroom when growing object memory'), (isStack ifFalse: [#( 26 'interruptChecksEveryNms - force an ioProcessEvents every N milliseconds, in case the image is not calling getNextEvent often')] ifTrue: [#( 26 'heartbeat period (ms; see #58)')]), (isSpur ifFalse: [#( 27 'number of times mark loop iterated for current IGC/FGC includes ALL marking' 28 'number of times sweep loop iterated for current IGC/FGC' 29 'number of times make forward loop iterated for current IGC/FGC' 30 'number of times compact move loop iterated for current IGC/FGC')] ifTrue: [#()]), #( 31 'number of grow memory requests' 32 'number of shrink memory requests'), (isSpur ifFalse: [#( 33 'number of root table entries used for current IGC/FGC' 34 'number of allocations done before current IGC/FGC' 35 'number of survivor objects after current IGC/FGC' 36 'millisecond clock when current IGC/FGC completed' 37 'number of marked objects for Roots of the world, not including Root Table entries for current IGC/FGC' 38 'milliseconds taken by current IGC' 39 'Number of finalization signals for Weak Objects pending when current IGC/FGC completed')] ifTrue: [#( 33 'number of root table entries at last scavenge' 35 'number of survivor objects at last scavenge (if non-zero)' 36 'millisecond clock when current scavenge completed' 38 'milliseconds taken by current scavenge' 39 'Number of finalization signals for Weak Objects pending when current SGC/FGC completed')]), #( 40 'VM word size - 4 or 8'), (isStack ifTrue: [#( 41 'imageFormatVersion for the VM' 42 'number of stack pages available' 43 'desired number of stack pages (stored in image file header, max 65535)' 44 'size of eden, in bytes' 45 'desired size of eden, in bytes (stored in image file header)' 46 'machine code zone size, in bytes (0 in Stack VM)' + 47 'desired machine code zone size (0 => default 1Mb to 2Mb depending on processor)' - 47 'desired machine code zone size (0 => default 1Mb)' 48 'various persistent image header flags. See getCogVMFlags in the VM source.' 49 'max size the image promises to grow the external semaphore table to'), (isSpur ifFalse: [{ 50 to: 51. 'reserved for VM parameters that persist in the image (such as size of eden above)'. 52 to: 56. 'specific to Spur' }] ifTrue: [{ 50 to: 51. 'reserved for VM parameters that persist in the image (such as size of eden above)' }, #( 52 'root/remembered table capacity' 53 'number of old space segments' 54 'total free old space' 55 'ratio of growth and image size at or above which a GC will be performed post scavenge')]), #( 56 'number of process switches since startup' 57 'number of ioProcessEvents calls since startup' 58 'number of forceInterruptCheck calls since startup' 59 'number of check event calls since startup' 60 'number of stack page overflows since startup' 61 'number of stack page divorces since startup' 62 'compiled code compactions since startup'), (isCog ifFalse: [#()] ifTrue: [#( 63 'total milliseconds in compiled code compactions since startup' 64 'the number of methods that currently have jitted machine-code')]), { 65. 'Cog feature flags\ bit 0: set if the VM supports MULTIPLE_BYTECODE_SETS.\ bit 1: set if the VM supports read-only objects.\ bit 2: set if the VM has an ITIMER_HEARTBEAT' withCRs. 66. 'the byte size of a stack page'.}, (isSpur ifFalse: [{ 67 to: 69. 'reserved for more Cog-related info' }] ifTrue: [#( 67 'the maximum allowed size of old space (if zero there is no limit)' 68 'the average number of live stack pages when scanned by scavenge/gc/become' 69 'the maximum number of live stack pages when scanned by scavenge/gc/become')]), #( 70 'the vmProxyMajorVersion (the interpreterProxy VM_MAJOR_VERSION)' 71 'the vmProxyMinorVersion (the interpreterProxy VM_MINOR_VERSION)')] ifFalse: [#()]) pairsDo: [:idx :desc | | value values | aStream nextPut: $#. idx isInteger ifTrue: [value := vmParameters at: idx. aStream print: idx; tab: (idx < 10 ifTrue: [2] ifFalse: [1]); nextPutAll: ((value isInteger and: [idx ~= 41]) ifTrue: [value asStringWithCommas] ifFalse: [value printString])] ifFalse: [value := vmParameters at: idx first. aStream print: idx first; next: 2 put: $.; print: idx last; tab. values := idx collect: [:i| vmParameters at: i]. values asSet size = 1 ifTrue: [aStream print: value] ifFalse: [values do: [:v| aStream print: v] separatedBy: [aStream nextPutAll: ', ']]]. aStream tab; nextPutAll: desc; cr]!

1 0

The Trunk: CollectionsTests-ul.341.mcz
by commits＠source.squeak.org 26 Jul '20

26 Jul '20

Eliot Miranda uploaded a new version of CollectionsTests to project The Trunk: http://source.squeak.org/trunk/CollectionsTests-ul.341.mcz ==================== Summary ==================== Name: CollectionsTests-ul.341 Author: eem Time: 25 July 2020, 8:44:46.338509 pm UUID: 1b22fd11-c092-46ba-bd26-526080294ab8 Ancestors: CollectionsTests-ul.340 Fix an old spelling error. Using Levente's initials for the package version and the change stamp because this is his code. I only noticed and fixed the speeling error. No other changes. eem 7/25/2020. I beg forgiveness if this is in any way offensive. =============== Diff against CollectionsTests-ul.340 =============== Item was added: + ----- Method: ByteArrayTest>>testPlatformIndependentIntegerAccessorsAtBitBorders (in category 'tests - platform independent access') ----- + testPlatformIndependentIntegerAccessorsAtBitBorders + + #( + shortAt:put:bigEndian: shortAt:bigEndian: false 16 + longAt:put:bigEndian: longAt:bigEndian: false 32 + long64At:put:bigEndian: long64At:bigEndian: false 64 + unsignedShortAt:put:bigEndian: unsignedShortAt:bigEndian: true 16 + unsignedLongAt:put:bigEndian: unsignedLongAt:bigEndian: true 32 + unsignedLong64At:put:bigEndian: unsignedLong64At:bigEndian: true 64 + ) groupsDo: [ :setter :getter :unsigned :storageBits | + self + verifyPlatformIndependentIntegerAccessorsAtBitBordersSetter: setter + getter: getter + unsigned: unsigned + storageBits: storageBits ]! Item was added: + ----- Method: ByteArrayTest>>testPlatformIndependentIntegerAccessorsWithRandomValues (in category 'tests - platform independent access') ----- + testPlatformIndependentIntegerAccessorsWithRandomValues + + | random | + random := Random seed: 36rSqueak. + #( + shortAt:put:bigEndian: shortAt:bigEndian: false 16 + longAt:put:bigEndian: longAt:bigEndian: false 32 + long64At:put:bigEndian: long64At:bigEndian: false 64 + unsignedShortAt:put:bigEndian: unsignedShortAt:bigEndian: true 16 + unsignedLongAt:put:bigEndian: unsignedLongAt:bigEndian: true 32 + unsignedLong64At:put:bigEndian: unsignedLong64At:bigEndian: true 64 + ) groupsDo: [ :setter :getter :unsigned :storageBits | + self + verifyPlatformIndependentIntegerAccessorsWithRandomValuesSetter: setter + getter: getter + unsigned: unsigned + storageBits: storageBits + random: random ]! Item was removed: - ----- Method: ByteArrayTest>>testPlatformIndepentendIntegerAccessorsAtBitBorders (in category 'tests - platform independent access') ----- - testPlatformIndepentendIntegerAccessorsAtBitBorders - - #( - shortAt:put:bigEndian: shortAt:bigEndian: false 16 - longAt:put:bigEndian: longAt:bigEndian: false 32 - long64At:put:bigEndian: long64At:bigEndian: false 64 - unsignedShortAt:put:bigEndian: unsignedShortAt:bigEndian: true 16 - unsignedLongAt:put:bigEndian: unsignedLongAt:bigEndian: true 32 - unsignedLong64At:put:bigEndian: unsignedLong64At:bigEndian: true 64 - ) groupsDo: [ :setter :getter :unsigned :storageBits | - self - verifyPlatformIndepentendIntegerAccessorsAtBitBordersSetter: setter - getter: getter - unsigned: unsigned - storageBits: storageBits ]! Item was removed: - ----- Method: ByteArrayTest>>testPlatformIndepentendIntegerAccessorsWithRandomValues (in category 'tests - platform independent access') ----- - testPlatformIndepentendIntegerAccessorsWithRandomValues - - | random | - random := Random seed: 36rSqueak. - #( - shortAt:put:bigEndian: shortAt:bigEndian: false 16 - longAt:put:bigEndian: longAt:bigEndian: false 32 - long64At:put:bigEndian: long64At:bigEndian: false 64 - unsignedShortAt:put:bigEndian: unsignedShortAt:bigEndian: true 16 - unsignedLongAt:put:bigEndian: unsignedLongAt:bigEndian: true 32 - unsignedLong64At:put:bigEndian: unsignedLong64At:bigEndian: true 64 - ) groupsDo: [ :setter :getter :unsigned :storageBits | - self - verifyPlatformIndepentendIntegerAccessorsWithRandomValuesSetter: setter - getter: getter - unsigned: unsigned - storageBits: storageBits - random: random ]! Item was added: + ----- Method: ByteArrayTest>>verifyPlatformIndependentIntegerAccessorsAtBitBordersSetter:getter:unsigned:storageBits: (in category 'tests - platform independent access') ----- + verifyPlatformIndependentIntegerAccessorsAtBitBordersSetter: setter getter: getter unsigned: unsigned storageBits: storageBits + + | byteArray minValue maxValue baseValues | + byteArray := ByteArray new: storageBits // 8 * 2. + unsigned + ifTrue: [ + minValue := 0. + maxValue := 1 << storageBits - 1. + baseValues := #(0 1) ] + ifFalse: [ + minValue := -1 << (storageBits - 1). + maxValue := 1 << (storageBits - 1) - 1. + baseValues := #(-1 0 1) ]. + #(true false) do: [ :bigEndian | + 0 to: storageBits - 1 do: [ :bits | + baseValues do: [ :baseValue | + | centerValue | + centerValue := baseValue << bits. + centerValue - 1 to: centerValue + 1 do: [ :value | + (value between: minValue and: maxValue) ifTrue: [ + self + verifyPlatformIndependentIntegerAccessorsMatch: byteArray + for: value + setter: setter + getter: getter + storageBits: storageBits + bigEndian: bigEndian ] ] ] ] ] + ! Item was added: + ----- Method: ByteArrayTest>>verifyPlatformIndependentIntegerAccessorsMatch:for:setter:getter:storageBits:bigEndian: (in category 'tests - platform independent access') ----- + verifyPlatformIndependentIntegerAccessorsMatch: byteArray for: value setter: setter getter: getter storageBits: storageBits bigEndian: bigEndian + + | expectedSetterResult getterResult bytes | + expectedSetterResult := self byteArrayFor: value bits: storageBits bigEndian: bigEndian. + bytes := storageBits // 8. + 1 to: byteArray size - bytes + 1 do: [ :index | + byteArray + perform: setter + with: index + with: value + with: bigEndian. + 1 to: bytes do: [ :byteIndex | + self + assert: (expectedSetterResult at: byteIndex) + equals: (byteArray at: index + byteIndex - 1) ]. + getterResult := byteArray + perform: getter + with: index + with: bigEndian. + self assert: value equals: getterResult ]! Item was added: + ----- Method: ByteArrayTest>>verifyPlatformIndependentIntegerAccessorsWithRandomValuesSetter:getter:unsigned:storageBits:random: (in category 'tests - platform independent access') ----- + verifyPlatformIndependentIntegerAccessorsWithRandomValuesSetter: setter getter: getter unsigned: unsigned storageBits: storageBits random: random + + | byteArray randomMax randomOffset | + byteArray := ByteArray new: storageBits // 8 * 2. + randomMax := 1 << storageBits. + randomOffset := unsigned + ifTrue: [ -1 ] + ifFalse: [ -1 << (storageBits - 1) - 1 ]. + 10000 timesRepeat: [ + | value | + value := (random nextInt: randomMax) + randomOffset. + #(true false) do: [ :bigEndian | + self + verifyPlatformIndependentIntegerAccessorsMatch: byteArray + for: value + setter: setter + getter: getter + storageBits: storageBits + bigEndian: bigEndian ] ]! Item was removed: - ----- Method: ByteArrayTest>>verifyPlatformIndepentendIntegerAccessorsAtBitBordersSetter:getter:unsigned:storageBits: (in category 'tests - platform independent access') ----- - verifyPlatformIndepentendIntegerAccessorsAtBitBordersSetter: setter getter: getter unsigned: unsigned storageBits: storageBits - - | byteArray minValue maxValue baseValues | - byteArray := ByteArray new: storageBits // 8 * 2. - unsigned - ifTrue: [ - minValue := 0. - maxValue := 1 << storageBits - 1. - baseValues := #(0 1) ] - ifFalse: [ - minValue := -1 << (storageBits - 1). - maxValue := 1 << (storageBits - 1) - 1. - baseValues := #(-1 0 1) ]. - #(true false) do: [ :bigEndian | - 0 to: storageBits - 1 do: [ :bits | - baseValues do: [ :baseValue | - | centerValue | - centerValue := baseValue << bits. - centerValue - 1 to: centerValue + 1 do: [ :value | - (value between: minValue and: maxValue) ifTrue: [ - self - verifyPlatformIndepentendIntegerAccessorsMatch: byteArray - for: value - setter: setter - getter: getter - storageBits: storageBits - bigEndian: bigEndian ] ] ] ] ] - ! Item was removed: - ----- Method: ByteArrayTest>>verifyPlatformIndepentendIntegerAccessorsMatch:for:setter:getter:storageBits:bigEndian: (in category 'tests - platform independent access') ----- - verifyPlatformIndepentendIntegerAccessorsMatch: byteArray for: value setter: setter getter: getter storageBits: storageBits bigEndian: bigEndian - - | expectedSetterResult getterResult bytes | - expectedSetterResult := self byteArrayFor: value bits: storageBits bigEndian: bigEndian. - bytes := storageBits // 8. - 1 to: byteArray size - bytes + 1 do: [ :index | - byteArray - perform: setter - with: index - with: value - with: bigEndian. - 1 to: bytes do: [ :byteIndex | - self - assert: (expectedSetterResult at: byteIndex) - equals: (byteArray at: index + byteIndex - 1) ]. - getterResult := byteArray - perform: getter - with: index - with: bigEndian. - self assert: value equals: getterResult ]! Item was removed: - ----- Method: ByteArrayTest>>verifyPlatformIndepentendIntegerAccessorsWithRandomValuesSetter:getter:unsigned:storageBits:random: (in category 'tests - platform independent access') ----- - verifyPlatformIndepentendIntegerAccessorsWithRandomValuesSetter: setter getter: getter unsigned: unsigned storageBits: storageBits random: random - - | byteArray randomMax randomOffset | - byteArray := ByteArray new: storageBits // 8 * 2. - randomMax := 1 << storageBits. - randomOffset := unsigned - ifTrue: [ -1 ] - ifFalse: [ -1 << (storageBits - 1) - 1 ]. - 10000 timesRepeat: [ - | value | - value := (random nextInt: randomMax) + randomOffset. - #(true false) do: [ :bigEndian | - self - verifyPlatformIndepentendIntegerAccessorsMatch: byteArray - for: value - setter: setter - getter: getter - storageBits: storageBits - bigEndian: bigEndian ] ]!

1 0

The Trunk: EToys-eem.400.mcz
by commits＠source.squeak.org 23 Jul '20

23 Jul '20

Eliot Miranda uploaded a new version of EToys to project The Trunk: http://source.squeak.org/trunk/EToys-eem.400.mcz ==================== Summary ==================== Name: EToys-eem.400 Author: eem Time: 23 July 2020, 4:06:39.960265 pm UUID: cd372e46-6184-4c26-9528-da5309945631 Ancestors: EToys-eem.399 Allow the webcam resolution to be set before opening a WebCamMorph. =============== Diff against EToys-eem.399 =============== Item was changed: ----- Method: WebCamMorph>>setWebCamResolution: (in category 'e-toy - settings') ----- setWebCamResolution: aSymbol | wasOn | + "Failing silently here is awful; but that's what the code did :-(" + (WebCamResolution resolutions includes: aSymbol) ifFalse: [^ self]. - - ((WebCamResolution resolutions) includes: aSymbol) ifFalse: [^ self]. resolution := aSymbol. (wasOn := camIsOn) ifTrue: [self off]. frameExtent := self class resolutionFor: aSymbol. + displayForm ifNotNil: + [displayForm := displayForm scaledToSize: frameExtent]. - displayForm := displayForm scaledToSize: frameExtent. self updateDisplay. + wasOn ifTrue: [self on] - wasOn ifTrue: [self on]. - - !

1 0

The Trunk: Collections-eem.904.mcz
by commits＠source.squeak.org 21 Jul '20

21 Jul '20

Eliot Miranda uploaded a new version of Collections to project The Trunk: http://source.squeak.org/trunk/Collections-eem.904.mcz ==================== Summary ==================== Name: Collections-eem.904 Author: eem Time: 21 July 2020, 12:48:47.966166 pm UUID: 5aa53764-ee46-4fee-b681-0bc142550102 Ancestors: Collections-ul.903 Supercede the slow Float[64]ArrayPlugin>>at:[put:] primitives with much faster ones in the Spur VM. =============== Diff against Collections-ul.903 =============== Item was changed: + (PackageInfo named: 'Collections') preamble: '"Use of the Spur FloatArray>>at:[put:] prims requires at least VMMaker.oscog.2778" - (PackageInfo named: 'Collections') preamble: '"FloatArray is going to become the abstract class above Float32Array and Float64Array. - In order to avoid spurious instance migration or recompilation errors, this preamble is required." + Smalltalk vmVMMakerVersion < 2778 ifTrue: + [Warning signal: ''This virtual machine is too old to support correct versions of the FloatArray>>at:[put:] primitives 238 and 239. FloatArray subclasses will not behave correctly and FloatArray[64]Test tests will fail. Please upgrade your VM. You may continue and upgrade later or abort and upgrade now.'']'! - FloatArray rename: #Float32Array.'! Item was removed: - ----- Method: Float32Array>>at: (in category 'accessing') ----- - at: index - <primitive: 'primitiveAt' module: 'FloatArrayPlugin'> - ^Float fromIEEE32Bit: (self basicAt: index)! Item was removed: - ----- Method: Float32Array>>at:put: (in category 'accessing') ----- - at: index put: value - <primitive: 'primitiveAtPut' module: 'FloatArrayPlugin'> - value isFloat - ifTrue:[self basicAt: index put: value asIEEE32BitWord] - ifFalse:[self at: index put: value asFloat]. - ^value! Item was removed: - ----- Method: Float32Array>>defaultElement (in category 'accessing') ----- - defaultElement - "Return the default element of the receiver" - ^0.0! Item was removed: - ----- Method: Float64Array>>at: (in category 'accessing') ----- - at: index - <primitive: 'primitiveAt' module: 'Float64ArrayPlugin'> - | f64 u64 | - u64 := self basicAt: index. - (f64 := Float basicNew) - basicAt: 1 put: (u64 >> 32); - basicAt: 2 put: (u64 bitAnd: 16rFFFFFFFF). - ^f64 * 1.0! Item was removed: - ----- Method: Float64Array>>at:put: (in category 'accessing') ----- - at: index put: value - <primitive: 'primitiveAtPut' module: 'Float64ArrayPlugin'> - value isFloat - ifTrue:[self basicAt: index put: (value basicAt: 1) << 32 + (value basicAt: 2)] - ifFalse:[self at: index put: value asFloat]. - ^value! Item was added: + ----- Method: FloatArray>>at: (in category 'accessing') ----- + at: index + "Answer the Float at index in the receiver. This method converts from either a 32-bit IEEE representation, + or a 64-bit IEEE representation to a Squeak Float object. Primitive. Optional." + <primitive: 238 error: ec> + ^self bytesPerElement = 4 + ifTrue: [Float fromIEEE32Bit: (self basicAt: index)] + ifFalse: [Float fromIEEE64Bit: (self basicAt: index)]! Item was added: + ----- Method: FloatArray>>at:put: (in category 'accessing') ----- + at: index put: value + "Store the Float value at index in the receiver. This method converts from a Squeak Float object, + or an Integer, into either a 32-bit IEEE representation, or a 64-bit IEEE representation. Primitive. Optional." + <primitive: 239 error: ec> + value isFloat + ifTrue:[self basicAt: index put: (self bytesPerElement = 4 + ifTrue: [value asIEEE32BitWord] + ifFalse: [value asIEEE64BitWord])] + ifFalse: [self at: index put: value asFloat]. + ^value!

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

Packages July 2020