Skip to content

Commit fdc898c

Browse files
KevinRansomKevinRansom
authored
Enable pinvoke tests for coreclr (#6617)
* Enable pinvoke tests for coreclr * Update Build.ps1
1 parent 0aacd63 commit fdc898c

File tree

5 files changed

+104
-167
lines changed

5 files changed

+104
-167
lines changed

‎eng/Build.ps1‎

Lines changed: 12 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -46,9 +46,10 @@ param (
4646
[switch]$warnAsError = $true,
4747
[switch][Alias('test')]$testDesktop,
4848
[switch]$testCoreClr,
49-
[switch]$testFSharpCompiler,
50-
[switch]$testFSharpQA,
49+
[switch]$testCambridge,
50+
[switch]$testCompiler,
5151
[switch]$testFSharpCore,
52+
[switch]$testFSharpQA,
5253
[switch]$testVs,
5354
[switch]$testAll,
5455

@@ -76,11 +77,12 @@ function Print-Usage() {
7677
Write-Host ""
7778
Write-Host "Test actions"
7879
Write-Host " -testAll Run all tests"
80+
Write-Host " -testCambridge Run Cambridge tests"
81+
Write-Host " -testCompiler Run FSharpCompiler unit tests"
7982
Write-Host " -testDesktop Run tests against full .NET Framework"
8083
Write-Host " -testCoreClr Run tests against CoreCLR"
81-
Write-Host " -testFSharpCompiler Run F# Compiler unit tests"
82-
Write-Host " -testFSharpQA Run F# Cambridge tests"
8384
Write-Host " -testFSharpCore Run FSharpCore unit tests"
85+
Write-Host " -testFSharpQA Run F# Cambridge tests"
8486
Write-Host " -testVs Run F# editor unit tests"
8587
Write-Host ""
8688
Write-Host "Advanced settings:"
@@ -285,11 +287,16 @@ try {
285287
TestUsingNUnit -testProject "$RepoRoot\tests\FSharp.Core.UnitTests\FSharp.Core.UnitTests.fsproj" -targetFramework $coreclrTargetFramework
286288
}
287289

288-
if ($testFSharpCompiler) {
290+
if ($testCompiler) {
289291
TestUsingNUnit -testProject "$RepoRoot\tests\FSharp.Compiler.UnitTests\FSharp.Compiler.UnitTests.fsproj" -targetFramework $desktopTargetFramework
290292
TestUsingNUnit -testProject "$RepoRoot\tests\FSharp.Compiler.UnitTests\FSharp.Compiler.UnitTests.fsproj" -targetFramework $coreclrTargetFramework
291293
}
292294

295+
if ($testCambridge) {
296+
TestUsingNUnit -testProject "$RepoRoot\tests\fsharp\FSharpSuite.Tests.fsproj" -targetFramework $desktopTargetFramework
297+
TestUsingNUnit -testProject "$RepoRoot\tests\fsharp\FSharpSuite.Tests.fsproj" -targetFramework $coreclrTargetFramework
298+
}
299+
293300
if ($testVs) {
294301
TestUsingNUnit -testProject "$RepoRoot\vsintegration\tests\GetTypesVS.UnitTests\GetTypesVS.UnitTests.fsproj" -targetFramework $desktopTargetFramework
295302
TestUsingNUnit -testProject "$RepoRoot\vsintegration\tests\UnitTests\VisualFSharp.UnitTests.fsproj" -targetFramework $desktopTargetFramework

‎src/absil/ilreflect.fs‎

Lines changed: 12 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -1500,18 +1500,18 @@ let enablePInvoke = true
15001500
// but we can run on Netcoreapp3.0 so ... use reflection to invoke the api, when we are executing on netcoreapp3.0
15011501
let definePInvokeMethod =
15021502
typeof<TypeBuilder>.GetMethod("DefinePInvokeMethod", [|
1503-
typeof<string>;
1504-
typeof<string>;
1505-
typeof<string>;
1506-
typeof<System.Reflection.MethodAttributes>;
1507-
typeof<System.Reflection.CallingConventions>;
1508-
typeof<Type>;
1509-
typeof<Type[]>;
1510-
typeof<Type[]>;
1511-
typeof<Type[]>;
1512-
typeof<Type[][]>;
1513-
typeof<Type[][]>;
1514-
typeof<System.Runtime.InteropServices.CallingConvention>;
1503+
typeof<string>
1504+
typeof<string>
1505+
typeof<string>
1506+
typeof<System.Reflection.MethodAttributes>
1507+
typeof<System.Reflection.CallingConventions>
1508+
typeof<Type>
1509+
typeof<Type[]>
1510+
typeof<Type[]>
1511+
typeof<Type[]>
1512+
typeof<Type[][]>
1513+
typeof<Type[][]>
1514+
typeof<System.Runtime.InteropServices.CallingConvention>
15151515
typeof<System.Runtime.InteropServices.CharSet> |])
15161516

15171517
let enablePInvoke = definePInvokeMethod <> null

‎tests/fsharp/core/pinvoke/test.fsx‎

Lines changed: 27 additions & 126 deletions
Original file line numberDiff line numberDiff line change
@@ -1,138 +1,20 @@
11
// #Conformance #Interop #PInvoke #Structs
22

3+
#if TESTS_AS_APP
4+
module Core_csext
5+
#endif
36

47
#nowarn "9"
58
open System
69
open System.Runtime.InteropServices
7-
open System.Windows.Forms
810
open System.Drawing
911

12+
let failures = ref []
1013

11-
[<DllImport("cards.dll")>]
12-
let cdtInit((width: IntPtr), (height: IntPtr)) : unit = ()
13-
14-
let pinned (obj: obj) f =
15-
let gch = GCHandle.Alloc(obj,GCHandleType.Pinned) in
16-
try f(gch.AddrOfPinnedObject())
17-
finally
18-
gch.Free()
19-
20-
//The following types from the System namespace are blittable types:
21-
//
22-
//System.Byte
23-
//System.SByte
24-
//System.Int16
25-
//System.UInt16
26-
//System.Int32
27-
//System.UInt32
28-
//System.Int64
29-
//System.IntPtr
30-
//System.UIntPtr
31-
//The following complex types are also blittable types:
32-
//One-dimensional arrays of blittable types, such as an array of integers.
33-
//Formatted value types that contain only blittable types (and classes if they are marshaled as formatted types).
34-
35-
//
36-
// assert ((typeof<'a>) == (typeof<int>) or
37-
// (typeof<'a>) == (typeof<int64>) or
38-
// etc.
39-
40-
type PinBox<'a> =
41-
{ v : obj }
42-
static member Create(x) = { v = box(x) }
43-
member x.Value = (unbox x.v : 'a)
44-
member x.Pin(f) = pinned(x.v) f
45-
46-
let card_init () =
47-
let width = PinBox<_>.Create(300) in
48-
let height = PinBox<_>.Create(400) in
49-
width.Pin (fun widthAddress ->
50-
height.Pin (fun heightAddress ->
51-
cdtInit (widthAddress, heightAddress)));
52-
Printf.printf "width = %d\n" width.Value;
53-
Printf.printf "height = %d\n" height.Value;
54-
()
55-
56-
do card_init()
57-
58-
let asciiz (pBytes: nativeptr<sbyte>) = new System.String(pBytes)
59-
60-
#nowarn "0044";;
61-
#nowarn "0051";;
62-
63-
open System
64-
open System.Runtime.InteropServices
65-
open Microsoft.FSharp.NativeInterop
66-
67-
type voidptr = System.IntPtr
68-
69-
//int (*derivs)(double, double [], double [], void *),
70-
type DerivsFunction = delegate of double * double nativeptr * double nativeptr * voidptr -> int
71-
72-
//int (*outputFn)(double, double*, void*) );
73-
type OutputFunction = delegate of double * double nativeptr * voidptr -> int
74-
75-
[<DllImport("PopDyn.dll")>]
76-
// Wrap the C function with the following signature:
77-
//
78-
extern int SolveODE2(double *ystart, int nvar, double x1, double x2, double eps, double h1,
79-
double hmin, double hmax, int *nok, int *nbad, double dx, void *info,
80-
DerivsFunction derivs,
81-
OutputFunction outputFn);
82-
module Array =
83-
let inline pinObjUnscoped (obj: obj) = GCHandle.Alloc(obj,GCHandleType.Pinned)
84-
85-
let inline pinObj (obj: obj) f =
86-
let gch = pinObjUnscoped obj
87-
try f gch
88-
finally
89-
gch.Free()
90-
91-
[<NoDynamicInvocation>]
92-
let inline pin (arr: 'T []) (f : nativeptr<'T> -> 'U) =
93-
pinObj (box arr) (fun _ -> f (&&arr.[0]))
94-
95-
96-
type NativeArray<'T when 'T : unmanaged>(ptr : nativeptr<'T>, len: int) =
97-
member x.Ptr = ptr
98-
[<NoDynamicInvocation>]
99-
member inline x.Item
100-
with get n = NativePtr.get x.Ptr n
101-
and set n v = NativePtr.set x.Ptr n v
102-
member x.Length = len
103-
// Provide a nicer wrapper for use from F# code. This takes an F# array as input,
104-
// and when the callbacks happen wraps up the returned native arrays in the
105-
// F# NativeArray thin wrapper which lets you use nice syntax arr.[n] for getting and
106-
// setting values of these arrays.
107-
let solveODE ystart (x1,x2,eps,h1,hmin,hmax) (nok,nbad) dx derivs outputFn =
108-
Array.pin ystart (fun ystartAddr ->
109-
let nvar = Array.length ystart in
110-
let mutable nok = nok in
111-
let mutable nbad = nbad in
112-
let info = 0n in
113-
let derivsF = new DerivsFunction(fun x arr1 arr2 _ -> derivs x (new NativeArray<_>(arr1,nvar)) (new NativeArray<_>(arr2,nvar))) in
114-
let outputFnF = new OutputFunction(fun x pY _ -> outputFn x) in
115-
SolveODE2(ystartAddr,nvar,x1,x2,eps,h1,hmin,hmax,&&nok,&&nbad,dx,info,derivsF,outputFnF))
116-
117-
let example1() =
118-
solveODE
119-
// initial values
120-
[| 1.0; 2.0 |]
121-
// settings
122-
(1.0,2.0,0.0001,1.0,1.0,1.0)
123-
// nok,nbad
124-
(10,20)
125-
// dx
126-
0.05
127-
// Compute the derivatives. Note outp and inp are both NativeArrays, passed to us from C.
128-
// So there is no bounds checking on these assignments - be careful!
129-
// If it turns out that these arrays are of static known size then we can do better here.
130-
(fun x inp outp ->
131-
outp.[0] <- inp.[0] + 0.05; 1)
132-
// output
133-
(fun v -> printf "v = %G\n" v; 5)
134-
135-
14+
let report_failure (s : string) =
15+
stderr.Write" NO: "
16+
stderr.WriteLine s
17+
failures := !failures @ [s]
13618

13719
module GetSystemTimeTest =
13820
open System
@@ -241,3 +123,22 @@ module MemoryStatusTest2 =
241123

242124
main()
243125

126+
(*--------------------*)
127+
128+
#if TESTS_AS_APP
129+
let RUN() = !failures
130+
#else
131+
let aa =
132+
match !failures with
133+
| [] ->
134+
stdout.WriteLine "Test Passed"
135+
System.IO.File.WriteAllText("test.ok","ok")
136+
exit 0
137+
| messages ->
138+
printfn "%A" messages
139+
stdout.WriteLine "Test Failed"
140+
exit 1
141+
#endif
142+
143+
144+

‎tests/fsharp/single-test.fs‎

Lines changed: 14 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -206,6 +206,7 @@ let generateProjectArtifacts (pc:ProjectConfiguration) outputType (targetFramewo
206206

207207
generateProjBody
208208

209+
let lockObj = obj()
209210
let singleTestBuildAndRunCore cfg copyFiles p =
210211
let sources = []
211212
let loadSources = []
@@ -222,7 +223,19 @@ let singleTestBuildAndRunCore cfg copyFiles p =
222223
// optimize = true or false
223224
let executeSingleTestBuildAndRun outputType compilerType targetFramework optimize =
224225
let mutable result = false
225-
let directory = Path.Combine(Path.GetTempPath(), Path.GetRandomFileName() )
226+
let directory =
227+
let mutable result = ""
228+
lock lockObj <| (fun () ->
229+
let rec loop () =
230+
let dir = Path.Combine(Path.GetTempPath(), Path.GetRandomFileName())
231+
if Directory.Exists(dir) then
232+
loop ()
233+
else
234+
Directory.CreateDirectory(dir) |>ignore
235+
dir
236+
result <- loop())
237+
result
238+
226239
let pc = {
227240
OutputType = outputType
228241
Framework = framework

‎tests/fsharp/tests.fs‎

Lines changed: 39 additions & 23 deletions
Original file line numberDiff line numberDiff line change
@@ -59,18 +59,18 @@ module CoreTests =
5959
[<Test>]
6060
let ``comprehensionshw-FSI_BASIC`` () = singleTestBuildAndRun "core/comprehensions-hw" FSI_BASIC
6161

62-
[<Test>]
63-
let ``genericmeasures-FSI_BASIC`` () = singleTestBuildAndRun "core/genericmeasures" FSI_BASIC
64-
6562
[<Test>]
6663
let ``genericmeasures-FSC_BASIC`` () = singleTestBuildAndRun "core/genericmeasures" FSC_BASIC
6764

6865
[<Test>]
69-
let ``innerpoly-FSI_BASIC`` () = singleTestBuildAndRun "core/innerpoly" FSI_BASIC
66+
let ``genericmeasures-FSI_BASIC`` () = singleTestBuildAndRun "core/genericmeasures" FSI_BASIC
7067

7168
[<Test>]
7269
let ``innerpoly-FSC_BASIC`` () = singleTestBuildAndRun "core/innerpoly" FSC_BASIC
7370

71+
[<Test>]
72+
let ``innerpoly-FSI_BASIC`` () = singleTestBuildAndRun "core/innerpoly" FSI_BASIC
73+
7474
[<Test>]
7575
let ``namespaceAttributes-FSC_BASIC`` () = singleTestBuildAndRun "core/namespaces" FSC_BASIC
7676

@@ -216,7 +216,7 @@ module CoreTests =
216216
let ``test int32-FSI_BASIC`` () = singleTestBuildAndRun "core/int32" FSI_BASIC
217217

218218
[<Test>]
219-
let ``quotes-FSC-BASIC`` () = singleTestBuildAndRun "core/quotes" FSC_BASIC // TODO: fails on coreclr
219+
let ``quotes-FSC-BASIC`` () = singleTestBuildAndRun "core/quotes" FSC_BASIC
220220

221221
[<Test>]
222222
let ``quotes-FSI-BASIC`` () = singleTestBuildAndRun "core/quotes" FSI_BASIC
@@ -1313,6 +1313,40 @@ module CoreTests =
13131313
// [<Test>]
13141314
// let ``patterns-FSI_BASIC`` () = singleTestBuildAndRun "core/patterns" FSI_BASIC
13151315

1316+
[<Test>]
1317+
let ``pinvoke-FSC_BASIC`` () = singleTestBuildAndRun "core/pinvoke" FSC_BASIC
1318+
1319+
[<Test>]
1320+
let ``pinvoke-FSI_BASIC`` () =
1321+
// We currently build targeting netcoreapp2_1, and will continue to do so through this VS cycle
1322+
// but we can run on Netcoreapp3.0 so ... use reflection to invoke the api, when we are executing on netcoreapp3.0
1323+
let definePInvokeMethod =
1324+
typeof<System.Reflection.Emit.TypeBuilder>.GetMethod("DefinePInvokeMethod", [|
1325+
typeof<string>
1326+
typeof<string>
1327+
typeof<string>
1328+
typeof<System.Reflection.MethodAttributes>
1329+
typeof<System.Reflection.CallingConventions>
1330+
typeof<Type>
1331+
typeof<Type[]>
1332+
typeof<Type[]>
1333+
typeof<Type[]>
1334+
typeof<Type[][]>
1335+
typeof<Type[][]>
1336+
typeof<System.Runtime.InteropServices.CallingConvention>
1337+
typeof<System.Runtime.InteropServices.CharSet> |])
1338+
1339+
let enablePInvokeOnCoreClr = definePInvokeMethod <> null
1340+
1341+
if enablePInvokeOnCoreClr then
1342+
singleTestBuildAndRun "core/pinvoke" FSI_BASIC
1343+
1344+
[<Test>]
1345+
let ``fsi_load-FSC_BASIC`` () = singleTestBuildAndRun "core/fsi-load" FSC_BASIC
1346+
1347+
[<Test>]
1348+
let ``fsi_load-FSI_BASIC`` () = singleTestBuildAndRun "core/fsi-load" FSI_BASIC
1349+
13161350
#if !FSHARP_SUITE_DRIVES_CORECLR_TESTS
13171351
[<Test>]
13181352
let ``measures-AS_DLL`` () = singleTestBuildAndRun "core/measures" AS_DLL
@@ -1341,24 +1375,6 @@ module CoreTests =
13411375
[<Test>]
13421376
let ``members-incremental-hw-mutrec-FSC_BASIC`` () = singleTestBuildAndRun "core/members/incremental-hw-mutrec" FSC_BASIC
13431377

1344-
[<Test>]
1345-
let pinvoke () =
1346-
let cfg = testConfig "core/pinvoke"
1347-
1348-
fsc cfg "%s -o:test.exe -g" cfg.fsc_flags ["test.fsx"]
1349-
1350-
peverifyWithArgs cfg "/nologo /MD" "test.exe"
1351-
1352-
[<Test>]
1353-
let fsi_load () =
1354-
let cfg = testConfig "core/fsi-load"
1355-
1356-
use testOkFile = fileguard cfg "test.ok"
1357-
1358-
fsi cfg "%s" cfg.fsi_flags ["test.fsx"]
1359-
1360-
testOkFile.CheckExists()
1361-
13621378
[<Test>]
13631379
let queriesLeafExpressionConvert () =
13641380
let cfg = testConfig "core/queriesLeafExpressionConvert"

0 commit comments

Comments
 (0)