50497

17241 ffi-nb is not cleaning compiled methods. then they fail when platform changes
	https://pharo.fogbugz.com/f/cases/17241

http://files.pharo.org/image/50/50497.zip

AST-FFI-Pharo50Compatibility.package/RBFFICallPragma.class/README.md

@@ -0,0 +1 @@
+additionnal smalltalk semantic for FFI calls

AST-FFI-Pharo50Compatibility.package/RBFFICallPragma.class/class/instance creation/externalName_module_callType_returnType_argumentTypes_.st

@@ -0,0 +1,8 @@
+externalName: anExternalName module: aModuleName callType: aCallType returnType: aReturnType argumentTypes: arguments
+
+	^ self new
+		initializeWithExternalName: anExternalName
+		module: aModuleName
+		callType: aCallType 
+		returnType: aReturnType 
+		argumentTypes: arguments

AST-FFI-Pharo50Compatibility.package/RBFFICallPragma.class/definition.st

@@ -0,0 +1,5 @@
+RBPragmaNode subclass: #RBFFICallPragma
+	instanceVariableNames: 'externalName moduleName callType returnType argumentTypes'
+	classVariableNames: ''
+	poolDictionaries: ''
+	category: 'AST-FFI-Pharo50Compatibility'

AST-FFI-Pharo50Compatibility.package/RBFFICallPragma.class/instance/as yet unclassified/asPrimitive.st

@@ -0,0 +1,6 @@
+asPrimitive
+
+	^ IRPrimitive new
+		num: 120;
+		spec: self cFunction;
+		yourself

AST-FFI-Pharo50Compatibility.package/RBFFICallPragma.class/instance/as yet unclassified/cFunction.st

@@ -0,0 +1,8 @@
+cFunction
+
+	^ ExternalLibraryFunction
+				name: externalName
+				module: moduleName
+				callType: callType
+				returnType: returnType
+				argumentTypes: argumentTypes

AST-FFI-Pharo50Compatibility.package/RBFFICallPragma.class/instance/initialization-release/initializeWithExternalName_module_callType_returnType_argumentTypes_.st

@@ -0,0 +1,7 @@
+initializeWithExternalName: anExternalName module: aModuleName callType: aCallType returnType: aReturnType argumentTypes: someArgumentTypes
+
+	externalName := anExternalName.
+	moduleName:= aModuleName.
+	callType := aCallType.
+	returnType := aReturnType.
+	argumentTypes := someArgumentTypes.

AST-FFI-Pharo50Compatibility.package/RBFFICallPragma.class/instance/testing/isCompilerOption.st

@@ -0,0 +1,2 @@
+isCompilerOption
+	^ false

AST-FFI-Pharo50Compatibility.package/RBFFICallPragma.class/instance/testing/isFFICallPragma.st

@@ -0,0 +1,3 @@
+isFFICallPragma
+
+	^ true

AST-FFI-Pharo50Compatibility.package/RBFFICallPragma.class/instance/testing/isPrimitive.st

@@ -0,0 +1,2 @@
+isPrimitive
+	^ true

AST-FFI-Pharo50Compatibility.package/RBFFICallPragma.class/instance/testing/isPrimitiveError.st

@@ -0,0 +1,2 @@
+isPrimitiveError
+	^ false

AST-FFI-Pharo50Compatibility.package/ShortRunArray.class/README.md

@@ -0,0 +1 @@
+I'm a class needed to load FFI and nothing else. FFI declares ExternalObject to be in the startup list after myself. That's why in my initialize class side method I declare myself to be in the startup list.

AST-FFI-Pharo50Compatibility.package/ShortRunArray.class/class/class initialization/initialize.st

@@ -0,0 +1,3 @@
+initialize
+
+	Smalltalk addToStartUpList: self.

AST-FFI-Pharo50Compatibility.package/ShortRunArray.class/definition.st

@@ -0,0 +1,5 @@
+Object subclass: #ShortRunArray
+	instanceVariableNames: 'parent comments properties'
+	classVariableNames: 'FormatterClass'
+	poolDictionaries: ''
+	category: 'AST-FFI-Pharo50Compatibility'

OpalCompiler-Core.package/IRTranslatorV2.class/instance/visiting/visitMethod_.st → AST-FFI-Pharo50Compatibility.package/extension/IRTranslatorV2/instance/visitMethod_.st

@@ -2,6 +2,8 @@ visitMethod: anIr
 	IRFix new visitNode: anIr.
 	self pushScope: anIr.
 	gen irPrimitive: anIr irPrimitive.
+	"Hack for FFI call" 
+	anIr irPrimitive num = 120 ifTrue: [ gen addLiteral: anIr irPrimitive spec ].	
 	gen numArgs: anIr numArgs.
 	gen properties: anIr properties.
 	gen numTemps: (anIr tempMap size).

AST-FFI-Pharo50Compatibility.package/extension/OCASTTranslator/instance/visitPragmaNode_.st

@@ -0,0 +1,5 @@
+visitPragmaNode: aPragmaNode
+	aPragmaNode isFFICallPragma 
+		ifFalse: [ methodBuilder addPragma: aPragmaNode asPragma ].
+	aPragmaNode isPrimitiveError ifTrue: [
+		methodBuilder storeTemp: aPragmaNode arguments last value].

AST-FFI-Pharo50Compatibility.package/extension/RBParser/instance/basicParsePragma.st

@@ -0,0 +1,10 @@
+basicParsePragma
+	^ currentToken isIdentifier
+		ifTrue: [ self parseUnaryPragma ]
+		ifFalse: [
+			currentToken isKeyword
+				ifTrue: [ 	
+					(currentToken value = #apicall: or: [ currentToken value = #cdecl: ])
+						ifTrue: [ ^ self externalFunctionDeclaration ].
+					self parseKeywordPragma ]
+				ifFalse: [ self parseBinaryPragma ] ]

AST-FFI-Pharo50Compatibility.package/extension/RBParser/instance/externalFunctionDeclaration.st

@@ -0,0 +1,47 @@
+externalFunctionDeclaration
+	"Parse the function declaration for a call to an external library."
+
+	| descriptorClass callType retType externalName args argType module |
+	descriptorClass := Smalltalk globals at: #ExternalFunction ifAbsent: [ nil ].
+	descriptorClass == nil 
+		ifTrue: [ ^ false ].
+	callType := descriptorClass callingConventionFor: currentToken value.
+	callType == nil 
+		ifTrue: [ ^ false ].	"Parse return type"
+	self step.
+	retType := self externalType: descriptorClass.
+	retType == nil 
+		ifTrue: [ ^ self parserError: 'lack return type' ].	"Parse function name or index"
+	externalName := currentToken value.
+	(self match: String)
+		ifTrue: [ externalName := externalName asSymbol ]
+		ifFalse: [ (self match: Number)
+			ifFalse: [ self parserError: 'function name or index' ] ].
+	(self matchToken: $()
+		ifFalse: [ ^ self parserError: 'argument list' ].
+	args := Array new writeStream.
+	[ currentToken value == $) ]
+		whileFalse: [ 
+			argType := self externalType: descriptorClass.
+			argType == nil
+				ifTrue: [ ^ self parserError: 'argument' ].
+			argType isVoid & argType isPointerType not
+				ifFalse: [ args nextPut: argType ] ].
+	(args position = currentScope selector numArgs) ifFalse: [
+		^self parserError: 'Matching number of arguments'].
+	(self matchToken: $))
+		ifFalse: [ ^ self parserError: ')' ].
+	(self matchToken: 'module:')
+		ifTrue: [ 
+			module := currentToken value.
+			(self match: String)
+				ifFalse: [ ^ self parserError: 'String' ].
+			module := module asSymbol ].
+
+	^ RBFFICallPragma 
+		externalName: externalName 
+		module: module 
+		callType: callType 
+		returnType: retType 
+		argumentTypes: args contents
+

AST-FFI-Pharo50Compatibility.package/extension/RBParser/instance/externalType_.st

@@ -0,0 +1,13 @@
+externalType: descriptorClass
+	"Parse an return an external type"
+	| xType |
+	xType := descriptorClass atomicTypeNamed: currentToken value.
+	xType == nil ifTrue:["Look up from class scope"
+		Symbol hasInterned: currentToken value ifTrue:[:sym|
+			xType := descriptorClass structTypeNamed: sym]].
+	xType == nil ifTrue:[
+		xType := descriptorClass forceTypeNamed: currentToken value].
+	self step.
+	(self matchToken:#*)
+		ifTrue:[^xType asPointerType]
+		ifFalse:[^xType]

AST-FFI-Pharo50Compatibility.package/extension/RBParser/instance/ffiCallClass.st

@@ -0,0 +1,2 @@
+ffiCallClass
+	^ RBFFICallPragma

AST-FFI-Pharo50Compatibility.package/extension/RBParser/instance/matchToken_.st

@@ -0,0 +1,4 @@
+matchToken: thing 
+	"Matches the token, not its type."
+	currentToken value = thing ifTrue: [self step. ^true].
+	^false

AST-FFI-Pharo50Compatibility.package/extension/RBParser/instance/match_.st

@@ -0,0 +1,8 @@
+match: type 
+	"Answer with true if next tokens type matches."
+
+	(currentToken value isKindOf: type)
+		ifTrue: 
+			[self step.
+			^true].
+	^false

AST-FFI-Pharo50Compatibility.package/extension/RBProgramNode/instance/isFFICallPragma.st

@@ -0,0 +1,3 @@
+isFFICallPragma
+
+	^ false

Alien.package/Alien.class/README.md

@@ -0,0 +1 @@
+Copyright 2008 Cadence Design Systems, Inc.      Licensed under the Apache License, Version 2.0 (the ''License''); you may not use this file except in compliance with the License.  You may obtain a copy of the License at  http://www.apache.org/licenses/LICENSE-2.0Instances of Alien represent actual parameters, return results and function pointers in FFI call-outs and call-backs and provide handles on external data.  See NewsqueakIA32ABIPlugin for the VM code that actually implements call-outs and call-backs.See the class-side examples category for some simple example workspaces.Aliens represent ABI (C language) data.  They can hold data directly in their bytes or indirectly by pointing to data on the C heap.  Alien instances are at least 5 bytes in length. The first 4 bytes of an Alien hold the size, as a signed integer, of the datum the instance is a proxy for.  If the size is positive then the Alien is "direct" and the actual datum resides in the object itself, starting at the 5th byte.  If the size is negative then the proxy is "indirect", is at least 8 bytes in length and the second 4 bytes hold the address of the datum, which is assumed to be on the C heap.  Any attempt to access data beyond the size will fail.  If the size is zero then the Alien is a pointer, the second 4 bytes hold a pointer, as for "indirect" Aliens, and accessing primitives indirect through the pointer to access data, but no bounds checking is performed.When Aliens are used as parameters in FFI calls then all are "passed by value", so that e.g. a 4 byte direct alien will have its 4 bytes of data passed, and a 12-byte indirect alien will have the 12 bytes its address references passed.  Pointer aliens will have their 4 byte pointer passed.  So indirect and pointer aliens are equivalent for accessing data but different when passed as parameters, indirect Aliens passing the data and pointer Aliens passing the pointer.Class Variables:GCMallocedAliens <AlienWeakTable of <Alien -> Integer>> - weak collection of malloced aliens, used to free malloced memory of Aliens allocated with newGC:LoadedLibraries <Dictionary of <String -> Alien>> - library name to library handle map

Alien.package/Alien.class/class/callbacks/invokeCallbackContext_.st

@@ -0,0 +1,14 @@
+invokeCallbackContext: vmCallbackContextAddress "<Integer>" "^<FFICallbackReturnValue>"
+	"The low-level entry-point for callbacks sent from the VM/IA32ABI plugin.
+	 Return via primReturnFromContext:through:.  thisContext's sender is the
+	 call-out context."
+	| callbackAlien type |
+	callbackAlien := (Smalltalk wordSize = 4
+						ifTrue: [VMCallbackContext32]
+						ifFalse: [VMCallbackContext64])
+							atAddress: vmCallbackContextAddress.
+	[type := Callback evaluateCallbackForContext: callbackAlien]
+		ifCurtailed: [self error: 'attempt to non-local return across a callback'].
+	type ifNil:
+		[type := 1. callbackAlien wordResult: -1].
+	callbackAlien primReturnAs: type fromContext: thisContext

Alien.package/Alien.class/class/callbacks/invokeCallback_stack_registers_jmpbuf_.st

@@ -0,0 +1,10 @@
+invokeCallback: thunkPtr "<Integer>" stack: stackPtr "<Integer>" registers: regsPtr "<Integer>" jmpbuf: jmpBufPtr "<Integer>" "^<FFICallbackReturnValue>"
+	"The low-level entry-point for callbacks sent from the VM/IA32ABI plugin.
+	 Return via primReturnFromContext:through:.  thisContext's sender is the
+	 call-out context."
+	| resultProxy |
+	[resultProxy := Callback evaluateCallbackForThunk: thunkPtr stack: stackPtr]
+		ifCurtailed: [self error: 'attempt to non-local return across a callback'].
+	resultProxy ifNil:
+		[(resultProxy := FFICallbackReturnValue new) returnInteger: 0].
+	resultProxy primReturnFromContext: thisContext through: jmpBufPtr

Alien.package/Alien.class/class/class initialization/ensureInSpecialObjectsArray.st

@@ -0,0 +1,26 @@
+ensureInSpecialObjectsArray
+	"Alien must be in the specialObjectsArray to enable the Newsqueak FFI.  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 Alien until Alien is loaded.  So check if the specialObjectsArray is
+	 of the expected size before recreating and slam Alien in if the specialObjectsArray
+	 is already large enough."
+
+	| index |
+	self ~~ Alien ifTrue: [^self].
+
+	index := 53.
+	((Smalltalk includesKey: #ObjectMemory)
+	 and: [((Smalltalk at: #ObjectMemory) classPool at: #ClassAlien ifAbsent: []) ~~ (index - 1)]) ifTrue:
+		[self error: 'index probably wrong'].
+
+	Smalltalk specialObjectsArray size < index ifTrue:
+		[Smalltalk recreateSpecialObjectsArray].
+
+	(Smalltalk specialObjectsArray size < index
+	 or: [(Smalltalk specialObjectsArray at: index) ~~ nil
+		and: [(Smalltalk specialObjectsArray at: index) ~~ self]]) ifTrue:
+		[self error: 'SystemDictionary>>recreateSpecialObjectsArray appears incompatible'].
+
+	(Smalltalk specialObjectsArray at: index) == nil ifTrue:
+		[Smalltalk specialObjectsArray at: index put: self]

Alien.package/Alien.class/class/class initialization/ensureNotifiedAtStartup.st

@@ -0,0 +1,5 @@
+ensureNotifiedAtStartup
+	"Alien needs to be notified at system startup to clear the LoadedLibraries table
+	and otherwise sanitise Aliens with dangling pointers."
+	self ~~ Alien ifTrue: [^self].
+	Smalltalk addToStartUpList: self after: Delay

Alien.package/Alien.class/class/class initialization/ensureNotifiedAtStartupAfter_.st

@@ -0,0 +1,4 @@
+ensureNotifiedAtStartupAfter: anotherClass
+	"Support routine for putting Alien classes in the start-up list."
+	anotherClass ensureNotifiedAtStartup.
+	Smalltalk addToStartUpList: self after: anotherClass

Alien.package/Alien.class/class/class initialization/initialize.st

@@ -0,0 +1,8 @@
+initialize
+	"Alien initialize"
+	LoadedLibraries isNil ifTrue:
+		[LoadedLibraries := Dictionary new].
+	GCMallocedAliens isNil ifTrue:
+		[GCMallocedAliens := AlienWeakTable newForOwner: self].
+	self ensureInSpecialObjectsArray.
+	self ensureNotifiedAtStartup

Alien.package/Alien.class/class/examples/exampleCqsort.st

@@ -0,0 +1,22 @@
+exampleCqsort
+	"Call the libc qsort function (which requires a callback)."
+	"Alien exampleCqsort"
+	"(Time millisecondsToRun: [100 timesRepeat: [Alien exampleCqsort]]) / 100.0"
+	| cb rand nElements sizeofDouble values orig sort |
+	rand := Random new.
+	values := Alien newC: (nElements := 100) * (sizeofDouble := 8).
+	1 to: values dataSize by: sizeofDouble do:
+		[:i| values doubleAt: i put: rand next].
+	orig := (1 to: values dataSize by: sizeofDouble) collect: [:i| values doubleAt: i].
+	cb := Callback
+			signature:  #(int (*)(const void *, const void *))
+			block: [ :arg1 :arg2 | ((arg1 doubleAt: 1) - (arg2 doubleAt: 1)) sign].
+	(Alien lookup: 'qsort' inLibrary: Alien libcName)
+		primFFICallResult: nil
+		with: values pointer
+		with: nElements
+		with: sizeofDouble
+		with: cb thunk.
+	sort := (1 to: values dataSize by: sizeofDouble) collect: [:i| values doubleAt: i].
+	values free.
+	^orig -> sort

Alien.package/Alien.class/class/examples/exampleEnumFontFamiliesEx.st

@@ -0,0 +1,30 @@
+exampleEnumFontFamiliesEx
+	"Call the Win32 EnumFontFamiliesEx function."
+	"Alien exampleEnumFontFamiliesEx"
+	"(Time millisecondsToRun: [1000 timesRepeat: [Alien exampleEnumFontFamiliesEx]]) / 1000.0"
+	| fontNames r gle err hDC cb |
+	fontNames := OrderedCollection new.
+	gle := self lookup: 'GetLastError' inLibrary: 'kernel32.dll'.
+	hDC := (self lookup: 'GetDC' inLibrary: 'user32.dll')
+				primFFICallResult: (Alien new: 4)
+				with: 0. "entire screen"
+	err := Alien new: 4.
+	cb := Callback
+				block: [:args :result|
+						fontNames addLast: args logicalFontData elfFullName.
+						result returnInteger: 1]
+				stdcallArgsClass: EnumFontFamExProc.
+	(self lookup: 'EnumFontFamiliesExA' inLibrary: 'gdi32.dll')
+		primFFICallResult: (r := Alien new: 4)
+		with: hDC
+		with: (LOGFONTA newC lfCharset: LOGFONTA DEFAULTCHARSET; yourself) pointer
+		with: cb thunk
+		with: 0
+		with: 0.
+	(r signedLongAt: 1) ~= 1 ifTrue:
+		[gle primFFICallResult: err].
+	(self lookup: 'ReleaseDC' inLibrary: 'user32.dll')
+		primFFICallResult: (Alien new: 4)
+		with: 0 "entire screen"
+		with: hDC.
+	^(err signedLongAt: 1) -> fontNames -> fontNames size

Alien.package/Alien.class/class/examples/exampleEnumWindows.st

@@ -0,0 +1,17 @@
+exampleEnumWindows
+	"Call the Win32 EnumWindows function, which takes a callback.
+	Count how many windows.  Use an Alien to hold the counter on the C heap.
+	Answer the count of windows (number of callbacks)."
+	"Alien exampleEnumWindows"
+	| counter cb |
+	counter := Alien newC: 4.
+	cb := Callback
+				block: [:args :result| | ptr |
+						ptr := Alien forPointer: args lParam.
+						ptr signedLongAt: 1 put: (ptr signedLongAt: 1) + 1.
+						result returnInteger: (ptr signedLongAt: 1)]
+				stdcallArgsClass: EnumWindowsProc.
+	^((self lookup: 'EnumWindows' inLibrary: 'user32.dll')
+		primFFICallResult: (Alien new: 4)
+		with: cb thunk
+		with: counter pointer) signedLongAt: 1

Alien.package/Alien.class/class/examples/exampleEnumWindowsCallbackPerformance.st

@@ -0,0 +1,20 @@
+exampleEnumWindowsCallbackPerformance
+	"Measure the speed of callbacks using the Win32 EnumWindows function.
+	Count how many windows using a Smalltalk counter.
+	Answer seconds -> callbacks -> microseconds per callback."
+	"Alien exampleEnumWindowsCallbackPerformance"
+	| enumWin count ms cb |
+	Smalltalk garbageCollect.
+	enumWin := self lookup: 'EnumWindows' inLibrary: 'user32.dll'.
+	count := 0.
+	cb := Callback
+			block: [:args :result|
+					result returnInteger: (count := count + 1)]
+			stdcallArgsClass: EnumWindowsProc.
+	ms := Time millisecondsToRun:
+			[1000 timesRepeat:
+				[enumWin
+					primFFICallResult: (Alien new: 4)
+					with: cb thunk
+					with: 0]].
+	^ms / 1000.0 -> count -> (ms * 1000.0 / count)

Alien.package/Alien.class/class/examples/exampleEnumWindowsSimple.st

@@ -0,0 +1,15 @@
+exampleEnumWindowsSimple
+	"Call the Win32 EnumWindows function, which takes a callback.
+	Count how many windows.  Use an Alien to hold the counter on the C heap.
+	Answer the count of windows (number of callbacks)."
+	"Alien exampleEnumWindowsSimple"
+	| count cb |
+	count := 0.
+	cb := Callback
+			block: [:args :result|
+					result returnInteger: (count := count + 1)]
+			stdcallArgsClass: EnumWindowsProc.
+	^((self lookup: 'EnumWindows' inLibrary: 'user32.dll')
+		primFFICallResult: (Alien new: 4)
+		with: cb thunk
+		with: 0) signedLongAt: 1