From 8ca877853882f8982e7762233d8b5c12b8e47bcb Mon Sep 17 00:00:00 2001 From: IgorErin Date: Fri, 30 Jun 2023 14:43:15 +0300 Subject: [PATCH 01/22] refactor: utils --- .../QuotationTransformers/Utilities/Utils.fs | 31 ++++++++----------- .../Utils/Utils.fs | 7 ++--- 2 files changed, 16 insertions(+), 22 deletions(-) diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Utils.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Utils.fs index 8440808f..8f9e8c9f 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Utils.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Utils.fs @@ -7,7 +7,7 @@ open Brahma.FSharp.OpenCL.Translator module Utils = let rec getFunctionArgTypes (funType: System.Type) = - let (argType, retType) = FSharpType.GetFunctionElements(funType) + let argType, retType = FSharpType.GetFunctionElements(funType) match retType with | _ when FSharpType.IsFunction retType -> argType :: getFunctionArgTypes retType @@ -19,23 +19,20 @@ module Utils = let makeLambdaType types = List.reduceBack (fun domain range -> FSharpType.MakeFunctionType(domain, range)) types - let rec makeLambdaExpr (args: Var list) (body: Expr) = - let mkLambda var expr = Expr.Lambda(var, expr) - List.foldBack mkLambda args body + let makeLambdaExpr (args: Var list) (body: Expr) = + List.foldBack (fun var expr -> Expr.Lambda(var, expr)) args body - let rec makeApplicationExpr (head: Expr) (exprs: Expr list) = - let mkApplication l r = Expr.Application(l, r) - List.fold mkApplication head exprs + let makeApplicationExpr (head: Expr) (expressions: Expr list) = + List.fold (fun l r -> Expr.Application(l, r)) head expressions - let rec extractLambdaArguments (expr: Expr) = - match expr with + // TODO tail recursion + let rec extractLambdaArguments = function | Patterns.Lambda (var, body) -> let vars, body' = extractLambdaArguments body var :: vars, body' - | _ -> [], expr + | expr -> [], expr - let rec collectLambdaArguments (expr: Expr) : List = - match expr with + let rec collectLambdaArguments = function | ExprShape.ShapeLambda (var, body) -> var :: collectLambdaArguments body | _ -> [] @@ -76,13 +73,11 @@ module Utils = | Patterns.Let (variable, DerivedPatterns.SpecificCall <@ local @> (_, _, _), cont) | Patterns.Let (variable, DerivedPatterns.SpecificCall <@ localArray @> (_, _, _), cont) -> variable :: collectLocalVars cont - - | ExprShape.ShapeVar var -> [] - | ExprShape.ShapeLambda (var, lambda) -> + | ExprShape.ShapeVar _ -> [] + | ExprShape.ShapeLambda (_, lambda) -> collectLocalVars lambda - | ExprShape.ShapeCombination (_, exprs) -> - exprs - |> List.collect collectLocalVars + | ExprShape.ShapeCombination (_, expressions) -> + List.collect collectLocalVars expressions let isTypeOf<'tp> (var: Var) = var.Type = typeof<'tp> diff --git a/src/Brahma.FSharp.OpenCL.Translator/Utils/Utils.fs b/src/Brahma.FSharp.OpenCL.Translator/Utils/Utils.fs index 307d2dc1..85274535 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/Utils/Utils.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/Utils/Utils.fs @@ -7,18 +7,17 @@ module Utils = let getMethodInfoOfCall (expr: Expr) = match expr with | Patterns.Call (_, mInfo, _) -> mInfo - | DerivedPatterns.Lambdas (args, Patterns.Call (_, mInfo, _)) -> mInfo + | DerivedPatterns.Lambdas (_, Patterns.Call (_, mInfo, _)) -> mInfo | _ -> failwithf $"Expression is not kind of call, but {expr}" - let makeGenericMethodCall (types: System.Type list) (expr: Expr) = + let makeGenericMethodCall (types: Type list) (expr: Expr) = (getMethodInfoOfCall expr) .GetGenericMethodDefinition() .MakeGenericMethod(Array.ofList types) let hasAttribute<'attr> (tp: Type) = tp.GetCustomAttributes(false) - |> Seq.tryFind (fun attr -> attr.GetType() = typeof<'attr>) - |> Option.isSome + |> Seq.exists (fun attr -> attr.GetType() = typeof<'attr>) let roundUp n x = if x % n <> 0 then From 42e48f0bee04d0ccf61697d95d026e03d06f820a Mon Sep 17 00:00:00 2001 From: IgorErin Date: Wed, 5 Jul 2023 02:09:51 +0300 Subject: [PATCH 02/22] refactor: Translation.Utils.GetFreeVarsWithPredicate with std func --- .../QuotationTransformers/Utilities/Utils.fs | 21 +++---------------- 1 file changed, 3 insertions(+), 18 deletions(-) diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Utils.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Utils.fs index 8f9e8c9f..28f1592f 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Utils.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Utils.fs @@ -40,24 +40,9 @@ module Utils = // Это из замыкания переменные? /// Collect free variables of expression that satisfies predicate. let rec collectFreeVarsWithPredicate (predicate: Var -> bool) (expr: Expr) : Set = - match expr with - | Patterns.Let (var, expr, inExpr) -> - Set.union - <| collectFreeVarsWithPredicate predicate expr - <| Set.remove var (collectFreeVarsWithPredicate predicate inExpr) - - | ExprShape.ShapeVar var -> - if predicate var then Set.singleton var else Set.empty - - | ExprShape.ShapeLambda (var, expr) -> - expr - |> collectFreeVarsWithPredicate predicate - |> Set.remove var - - | ExprShape.ShapeCombination (_, exprs) -> - exprs - |> List.map (collectFreeVarsWithPredicate predicate) - |> Set.unionMany + expr.GetFreeVars() + |> Seq.filter predicate + |> Set.ofSeq let isFunction (var: Var) = FSharpType.IsFunction var.Type From 2cff7252b099b9675b282870460690e90579306f Mon Sep 17 00:00:00 2001 From: IgorErin Date: Wed, 5 Jul 2023 17:23:41 +0300 Subject: [PATCH 03/22] wip: refactor translation tests --- .../Brahma.FSharp.Tests.fsproj | 91 +- tests/Brahma.FSharp.Tests/Common.fs | 2 +- tests/Brahma.FSharp.Tests/TranslationTests.fs | 8 + .../QuotationTransformersTests.fs | 396 ------ .../TranslationTests/TranslationTests.fs | 15 - .../TranslationTests/TranslatorTests.fs | 1070 ----------------- .../Expected/Array.Item.Set.cl | 0 .../Expected/Binary.Operations.Math.cl | 0 .../BinaryOperations}/Expected/Binding.cl | 0 .../BinaryOperations}/Expected/Binop.Plus.cl | 0 .../Expected/MAX.Transformation.cl | 0 .../Translator/BinaryOperations/Tests.fs | 52 + .../Expected/Nested.Function.Carring.cl | 0 .../Expected/Nested.Function.Carring2.cl | 0 .../Translator/Carrying/Tests.fs | 38 + .../Brahma.FSharp.Tests/Translator/Common.fs | 26 + .../Constant array translation. Test 1.cl | 0 .../Constant array translation. Test 2.cl | 0 .../Translator/ConstantArray/Tests.fs | 19 + .../ControlFlow}/Expected/Binding.In.FOR.cl | 0 .../ControlFlow}/Expected/Binding.In.IF.cl | 0 .../ControlFlow}/Expected/Binding.In.WHILE.cl | 0 .../ControlFlow}/Expected/For.Integer.Loop.cl | 0 .../ControlFlow}/Expected/If.Then.Else.cl | 0 .../ControlFlow}/Expected/If.Then.cl | 0 .../Expected/Seq.With.Bindings.cl | 0 .../Expected/Sequential.Bindings.cl | 0 .../ControlFlow}/Expected/Simple.Seq.cl | 0 .../ControlFlow}/Expected/Simple.WHILE.cl | 0 .../Expected/WHILE.with.complex.condition.cl | 0 .../Translator/ControlFlow/Tests.fs | 95 ++ .../Expected/Quotations.Injections.1.cl | 0 .../Expected/Quotations.Injections.2.cl | 0 .../Translator/Injection/Tests.fs | 32 + .../LambdaLifting}/Expected/Let renamed 2.cl | 0 .../LambdaLifting}/Expected/Let renamed.cl | 0 .../Expected/Nested.Function.cl | 0 .../LambdaLifting}/Expected/Renamer Test.cl | 0 .../Expected/Template Test 0.cl | 0 .../Expected/Template Test 1.cl | 0 .../Expected/Template Test 10.cl | 0 .../Expected/Template Test 11.cl | 0 .../Expected/Template Test 12.cl | 0 .../Expected/Template Test 13.cl | 0 .../Expected/Template Test 14.cl | 0 .../Expected/Template Test 15.cl | 0 .../Expected/Template Test 16.cl | 0 .../Expected/Template Test 2.cl | 0 .../Expected/Template Test 3.cl | 0 .../Expected/Template Test 4.cl | 0 .../Expected/Template Test 5.cl | 0 .../Expected/Template Test 6.cl | 0 .../Expected/Template Test 7.cl | 0 .../Expected/Template Test 8.cl | 0 .../Expected/Template Test 9.cl | 0 .../Translator/LambdaLifting/Tests.fs | 298 +++++ .../Translator/LangExtensions/Atomic.fs | 55 + .../Barrier}/Expected/Barrier.Full.cl | 0 .../Barrier}/Expected/Barrier.Global.cl | 0 .../Barrier}/Expected/Barrier.Local.cl | 0 .../LangExtensions/Barrier/Tests.fs | 21 + .../LocalID}/Expected/LocalID1D.cl | 0 .../LocalID}/Expected/LocalID2D.cl | 0 .../LangExtensions/LocalID/Tests.fs | 28 + .../Expected/LocalMemory.float.cl | 0 .../Expected/LocalMemory.int [].cl | 0 .../LocalMemory}/Expected/LocalMemory.int.cl | 0 .../LangExtensions/LocalMemory/Tests.fs | 36 + .../WorkSize}/Expected/WorkSize1D.cl | 0 .../WorkSize}/Expected/WorkSize2D.cl | 0 .../WorkSize}/Expected/WorkSize3D.cl | 0 .../LangExtensions/WorkSize/Tests.fs | 42 + .../Binding.And.FOR.Counter.Conflict.1.cl | 0 .../Binding.And.FOR.Counter.Conflict.2.cl | 0 .../Binding.And.FOR.Counter.Conflict.3.cl | 0 .../Binding.And.FOR.Counter.Conflict.4.cl | 0 .../Expected/Bindings.With.Equal.Names.cl | 0 .../Translator/NamesResolving/Tests.fs | 63 + .../Printf}/Expected/Printf test 1.cl | 0 .../Printf}/Expected/Printf test 2.cl | 0 .../Printf}/Expected/Printf test 3.cl | 0 .../Printf}/Expected/Printf test 4.cl | 0 .../Printf}/Expected/Printf test 5.cl | 0 .../Printf}/Expected/Printf test 6.cl | 0 .../Translator/Printf/Tests.fs | 49 + .../QuatationTransformation/Common.fs | 40 + .../QuatationTransformation/LambdaLifting.fs | 97 ++ .../QuatationTransformation/Transformation.fs | 175 +++ .../VarDefsToLambda.fs | 87 ++ .../Specific}/Expected/MergeKernel.cl | 0 .../Translator/Specific/MergePath.fs | 151 +++ .../Union}/Expected/Translation.Test1.cl | 0 .../Translator/Union/Tests.fs | 69 ++ 93 files changed, 1570 insertions(+), 1485 deletions(-) create mode 100644 tests/Brahma.FSharp.Tests/TranslationTests.fs delete mode 100644 tests/Brahma.FSharp.Tests/TranslationTests/QuotationTransformersTests.fs delete mode 100644 tests/Brahma.FSharp.Tests/TranslationTests/TranslationTests.fs delete mode 100644 tests/Brahma.FSharp.Tests/TranslationTests/TranslatorTests.fs rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/BinaryOperations}/Expected/Array.Item.Set.cl (100%) rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/BinaryOperations}/Expected/Binary.Operations.Math.cl (100%) rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/BinaryOperations}/Expected/Binding.cl (100%) rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/BinaryOperations}/Expected/Binop.Plus.cl (100%) rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/BinaryOperations}/Expected/MAX.Transformation.cl (100%) create mode 100644 tests/Brahma.FSharp.Tests/Translator/BinaryOperations/Tests.fs rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/Carrying}/Expected/Nested.Function.Carring.cl (100%) rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/Carrying}/Expected/Nested.Function.Carring2.cl (100%) create mode 100644 tests/Brahma.FSharp.Tests/Translator/Carrying/Tests.fs create mode 100644 tests/Brahma.FSharp.Tests/Translator/Common.fs rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/ConstantArray}/Expected/Constant array translation. Test 1.cl (100%) rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/ConstantArray}/Expected/Constant array translation. Test 2.cl (100%) create mode 100644 tests/Brahma.FSharp.Tests/Translator/ConstantArray/Tests.fs rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/ControlFlow}/Expected/Binding.In.FOR.cl (100%) rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/ControlFlow}/Expected/Binding.In.IF.cl (100%) rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/ControlFlow}/Expected/Binding.In.WHILE.cl (100%) rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/ControlFlow}/Expected/For.Integer.Loop.cl (100%) rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/ControlFlow}/Expected/If.Then.Else.cl (100%) rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/ControlFlow}/Expected/If.Then.cl (100%) rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/ControlFlow}/Expected/Seq.With.Bindings.cl (100%) rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/ControlFlow}/Expected/Sequential.Bindings.cl (100%) rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/ControlFlow}/Expected/Simple.Seq.cl (100%) rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/ControlFlow}/Expected/Simple.WHILE.cl (100%) rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/ControlFlow}/Expected/WHILE.with.complex.condition.cl (100%) create mode 100644 tests/Brahma.FSharp.Tests/Translator/ControlFlow/Tests.fs rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/Injection}/Expected/Quotations.Injections.1.cl (100%) rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/Injection}/Expected/Quotations.Injections.2.cl (100%) create mode 100644 tests/Brahma.FSharp.Tests/Translator/Injection/Tests.fs rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/LambdaLifting}/Expected/Let renamed 2.cl (100%) rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/LambdaLifting}/Expected/Let renamed.cl (100%) rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/LambdaLifting}/Expected/Nested.Function.cl (100%) rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/LambdaLifting}/Expected/Renamer Test.cl (100%) rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/LambdaLifting}/Expected/Template Test 0.cl (100%) rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/LambdaLifting}/Expected/Template Test 1.cl (100%) rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/LambdaLifting}/Expected/Template Test 10.cl (100%) rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/LambdaLifting}/Expected/Template Test 11.cl (100%) rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/LambdaLifting}/Expected/Template Test 12.cl (100%) rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/LambdaLifting}/Expected/Template Test 13.cl (100%) rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/LambdaLifting}/Expected/Template Test 14.cl (100%) rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/LambdaLifting}/Expected/Template Test 15.cl (100%) rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/LambdaLifting}/Expected/Template Test 16.cl (100%) rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/LambdaLifting}/Expected/Template Test 2.cl (100%) rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/LambdaLifting}/Expected/Template Test 3.cl (100%) rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/LambdaLifting}/Expected/Template Test 4.cl (100%) rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/LambdaLifting}/Expected/Template Test 5.cl (100%) rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/LambdaLifting}/Expected/Template Test 6.cl (100%) rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/LambdaLifting}/Expected/Template Test 7.cl (100%) rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/LambdaLifting}/Expected/Template Test 8.cl (100%) rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/LambdaLifting}/Expected/Template Test 9.cl (100%) create mode 100644 tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Tests.fs create mode 100644 tests/Brahma.FSharp.Tests/Translator/LangExtensions/Atomic.fs rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/LangExtensions/Barrier}/Expected/Barrier.Full.cl (100%) rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/LangExtensions/Barrier}/Expected/Barrier.Global.cl (100%) rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/LangExtensions/Barrier}/Expected/Barrier.Local.cl (100%) create mode 100644 tests/Brahma.FSharp.Tests/Translator/LangExtensions/Barrier/Tests.fs rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/LangExtensions/LocalID}/Expected/LocalID1D.cl (100%) rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/LangExtensions/LocalID}/Expected/LocalID2D.cl (100%) create mode 100644 tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalID/Tests.fs rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/LangExtensions/LocalMemory}/Expected/LocalMemory.float.cl (100%) rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/LangExtensions/LocalMemory}/Expected/LocalMemory.int [].cl (100%) rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/LangExtensions/LocalMemory}/Expected/LocalMemory.int.cl (100%) create mode 100644 tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalMemory/Tests.fs rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/LangExtensions/WorkSize}/Expected/WorkSize1D.cl (100%) rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/LangExtensions/WorkSize}/Expected/WorkSize2D.cl (100%) rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/LangExtensions/WorkSize}/Expected/WorkSize3D.cl (100%) create mode 100644 tests/Brahma.FSharp.Tests/Translator/LangExtensions/WorkSize/Tests.fs rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/NamesResolving}/Expected/Binding.And.FOR.Counter.Conflict.1.cl (100%) rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/NamesResolving}/Expected/Binding.And.FOR.Counter.Conflict.2.cl (100%) rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/NamesResolving}/Expected/Binding.And.FOR.Counter.Conflict.3.cl (100%) rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/NamesResolving}/Expected/Binding.And.FOR.Counter.Conflict.4.cl (100%) rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/NamesResolving}/Expected/Bindings.With.Equal.Names.cl (100%) create mode 100644 tests/Brahma.FSharp.Tests/Translator/NamesResolving/Tests.fs rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/Printf}/Expected/Printf test 1.cl (100%) rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/Printf}/Expected/Printf test 2.cl (100%) rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/Printf}/Expected/Printf test 3.cl (100%) rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/Printf}/Expected/Printf test 4.cl (100%) rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/Printf}/Expected/Printf test 5.cl (100%) rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/Printf}/Expected/Printf test 6.cl (100%) create mode 100644 tests/Brahma.FSharp.Tests/Translator/Printf/Tests.fs create mode 100644 tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Common.fs create mode 100644 tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/LambdaLifting.fs create mode 100644 tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Transformation.fs create mode 100644 tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/VarDefsToLambda.fs rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/Specific}/Expected/MergeKernel.cl (100%) create mode 100644 tests/Brahma.FSharp.Tests/Translator/Specific/MergePath.fs rename tests/Brahma.FSharp.Tests/{TranslationTests => Translator/Union}/Expected/Translation.Test1.cl (100%) create mode 100644 tests/Brahma.FSharp.Tests/Translator/Union/Tests.fs diff --git a/tests/Brahma.FSharp.Tests/Brahma.FSharp.Tests.fsproj b/tests/Brahma.FSharp.Tests/Brahma.FSharp.Tests.fsproj index 56aa57fe..dad2b3eb 100644 --- a/tests/Brahma.FSharp.Tests/Brahma.FSharp.Tests.fsproj +++ b/tests/Brahma.FSharp.Tests/Brahma.FSharp.Tests.fsproj @@ -10,12 +10,97 @@ + Always - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Always diff --git a/tests/Brahma.FSharp.Tests/Common.fs b/tests/Brahma.FSharp.Tests/Common.fs index 3b1611cb..1278efc5 100644 --- a/tests/Brahma.FSharp.Tests/Common.fs +++ b/tests/Brahma.FSharp.Tests/Common.fs @@ -27,4 +27,4 @@ module Utils = .Trim() .Replace("\r\n", "\n") - Expect.equal all1 all2 "Files should be equals as strings" + Expect.sequenceEqual all1 all2 "Files should be equals as strings" diff --git a/tests/Brahma.FSharp.Tests/TranslationTests.fs b/tests/Brahma.FSharp.Tests/TranslationTests.fs new file mode 100644 index 00000000..1396355f --- /dev/null +++ b/tests/Brahma.FSharp.Tests/TranslationTests.fs @@ -0,0 +1,8 @@ +module TranslationTests + +open Brahma.FSharp.OpenCL.Translator +open Expecto + +let translators = [ + FSQuotationToOpenCLTranslator.CreateDefault() +] diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/QuotationTransformersTests.fs b/tests/Brahma.FSharp.Tests/TranslationTests/QuotationTransformersTests.fs deleted file mode 100644 index ec6f9ee1..00000000 --- a/tests/Brahma.FSharp.Tests/TranslationTests/QuotationTransformersTests.fs +++ /dev/null @@ -1,396 +0,0 @@ -module QuotationTransformersTests - -open Expecto -open FSharp.Quotations -open Brahma.FSharp.OpenCL.Translator -open Brahma.FSharp.OpenCL.Translator.QuotationTransformers -open Brahma.FSharp - -[] -module Helpers = - let eqMsg = "Values should be equal" - - let rec renameUnitVar (expr: Expr) = - let replaceUnitVar (var: Var) = - if var.Type = typeof then - Var("unitVar", var.Type, var.IsMutable) - else - var - - match expr with - | ExprShape.ShapeVar var -> Expr.Var(replaceUnitVar var) - | ExprShape.ShapeLambda (var, body) -> Expr.Lambda(replaceUnitVar var, renameUnitVar body) - | ExprShape.ShapeCombination (shapeComboObj, exprList) -> - ExprShape.RebuildShapeCombination(shapeComboObj, List.map renameUnitVar exprList) - - let openclTransformQuotation (translator: FSQuotationToOpenCLTranslator) (expr: Expr) = - translator.TransformQuotation expr - - let assertExprEqual (actual: Expr) (expected: Expr) (msg: string) = - let actual' = renameUnitVar actual - let expected' = renameUnitVar expected - - Expect.equal - <| actual'.ToString() - <| expected'.ToString() - <| msg - - let assertMethodEqual (actual: Var * Expr) (expected: Var * Expr) = - Expect.equal (fst actual).Name (fst expected).Name "Method names should be equal" - - assertExprEqual (snd actual) (snd expected) - <| $"Method bodies of %s{(fst actual).Name} is not equal" -let lambdaLiftingTests = - let genParameterLiftTest testCase name expr expected = - testCase name <| fun _ -> - let actual = LambdaLifting.parameterLiftExpr expr - assertExprEqual actual expected eqMsg - - [ - genParameterLiftTest - testCase - "Test 1" - <@ let x = 1 - let addToX y = x + y - addToX 2 - @> - <@ let x = 1 - let addToX x y = x + y - addToX x 2 - @> - - genParameterLiftTest - testCase - "Test 2" - <@ let x = 1 - let z = x - - let addToX y = // freeVars: [x, z] - x + y + z - - let f z1 = // freeVars: [], addToX freeVars: [x, z] - 2 + addToX z1 - - f 3 - @> - <@ let x = 1 - let z = x - - let addToX x z y = x + y + z - let f x z z1 = 2 + addToX x z z1 - f x z 3 - @> - - genParameterLiftTest - testCase - "Test 3" - <@ let mainX = "global variable" - let mainY = "global variable" - let mainZ = "global variable" - - let foo fooX = - let fooY = "local variable of foo" - let bar barX = mainX + fooY + barX - bar fooX + mainY - - foo mainZ - @> - <@ let mainX = "global variable" - let mainY = "global variable" - let mainZ = "global variable" - - let foo mainX mainY fooX = - let fooY = "local variable of foo" - let bar fooY mainX barX = mainX + fooY + barX - bar fooY mainX fooX + mainY - - foo mainX mainY mainZ - @> - - genParameterLiftTest - testCase - "Test 4" - <@ let x0 = 0 - - let f x1 = - let g x2 = - let h x3 = x3 + x0 - h x2 - - g x1 - - f x0 - @> - <@ let x0 = 0 - - let f x0 x1 = - let g x0 x2 = - let h x0 x3 = x3 + x0 - h x0 x2 - - g x0 x1 - - f x0 x0 - @> - ] - -let varDefsToLambdaTest = - let genVarDefToLambdaTest testCase name expr expected = - testCase name <| fun _ -> - let actual = VarDefsToLambdaTransformer.transformVarDefsToLambda expr - assertExprEqual actual expected eqMsg - - [ - genVarDefToLambdaTest - testCase - "Test 1" - <@ let x = - let mutable y = 0 - - for i in 1 .. 10 do - y <- y + i - - y - - x - @> - <@ let x = - let xUnitFunc () = - let mutable y = 0 - - for i in 1 .. 10 do - y <- y + i - - y - - xUnitFunc () - - x - @> - - genVarDefToLambdaTest - testCase - "Test 2: we need to go deeper" - <@ let x = - let mutable y = - if true then - let z = 10 - z + 1 - else - let z = 20 - z + 2 - - for i in 1 .. 10 do - let z = if false then 10 else 20 - y <- y + i + z - - y - - x - @> - <@ let x = - let xUnitFunc () = - let mutable y = - let yUnitFunc () = - if true then - let z = 10 - z + 1 - else - let z = 20 - z + 2 - - yUnitFunc () - - for i in 1 .. 10 do - let z = - let zUnitFunc () = if false then 10 else 20 - zUnitFunc () - - y <- y + i + z - - y - - xUnitFunc () - - x - @> - ] - -let quotationTransformerTest translator = - let sprintfMethods (methods: seq) = - Seq.map (fun (x: Method) -> $"%A{x.FunVar}\n%A{x.FunExpr}\n") methods - |> String.concat "\n" - - let assertMethodListsEqual (actual: list) (expected: list) = - Expect.equal actual.Length expected.Length "List sizes should be equal" - - List.zip actual expected - |> List.iter (fun (x, y) -> assertMethodEqual x y) - - let makeMethods (expr: Expr) = - let rec go (expr: Expr) = - match expr with - | Patterns.Let (var, body, inExpr) -> - let methods, kernel = go inExpr - (var, body) :: methods, kernel - | _ -> [], expr - - let methods, kernelExpr = go expr - kernelExpr, methods - - let genTest testCase name expr expected = - let expectedKernelExpr, expectedMethods = makeMethods expected - - testCase name <| fun _ -> - let (actualKernelExpr, actualKernelMethods) = expr |> openclTransformQuotation translator - - assertMethodListsEqual actualKernelMethods expectedMethods - assertExprEqual actualKernelExpr expectedKernelExpr "kernels not equals" - - [ - genTest - testCase - "Test 0" - <@ fun (range: Range1D) (buf: array) -> - let mutable x = 1 - let f y = x <- y - f 10 - buf.[0] <- x - @> - <@ - let f xRef (y: int) = xRef := y - - fun (range: Range1D) (buf: array) -> - let mutable x = 1 - let xRef = ref x - - f xRef 10 - buf.[0] <- !xRef - @> - - genTest - testCase - "Test 1" - <@ fun (range: Range1D) (buf: array) -> - let mutable x = 1 - let f y = x <- x + y - f 10 - buf.[0] <- x - @> - <@ - let f xRef (y: int) = xRef := !xRef + y - - fun (range: Range1D) (buf: array) -> - let mutable x = 1 - let xRef = ref x - - f xRef 10 - buf.[0] <- !xRef - @> - - genTest - testCase - "Test 2: simple lambda lifting without capturing variables" - <@ fun (range: Range1D) -> - let f x = - let g y = y + 1 - g x - - f 2 @> - <@ let g y = y + 1 - let f x = g x - fun (range: Range1D) -> f 2 @> - - genTest - testCase - "Test 3: simple lambda lifting with capturing variables" - <@ fun (range: Range1D) -> - let f x = - let g y = y + x - g (x + 1) - - f 2 - @> - <@ let g x y = y + x - let f x = g x (x + 1) - fun (range: Range1D) -> f 2 - @> - - genTest - testCase - "Test 4" - <@ fun (range: Range1D) (arr: array) -> - let x = - let mutable y = 0 - - let addToY x = y <- y + x - - for i in 0 .. 10 do - addToY arr.[i] - - y - - x - @> - <@ let addToY yRef x = yRef := !yRef + x - - let x1UnitFunc (arr: array) = - let y = 0 - let yRef = ref y - - for i in 0 .. 10 do - addToY yRef arr.[i] - - !yRef - - fun (range: Range1D) (arr: array) -> - let x1 = x1UnitFunc arr - x1 - @> - - genTest - testCase - "Test 5" - <@ fun (range: Range1D) (arr: array) -> - let mutable x = if 0 > 1 then 2 else 3 - - let mutable y = - for i in 0 .. 10 do - x <- x + 1 - - x + 1 - - let z = x + y - - let f () = arr.[0] <- x + y + z - f () - @> - <@ let xUnitFunc () = if 0 > 1 then 2 else 3 - - let yUnitFunc xRef = - for i in 0 .. 10 do - xRef := !xRef + 1 - - !xRef + 1 - - let f (arr: array) xRef yRef z = arr.[0] <- !xRef + !yRef + z - - fun (range: Range1D) (arr: array) -> - let mutable x = xUnitFunc () - let xRef = ref x - - let mutable y = yUnitFunc xRef - let yRef = ref y - - let z = !xRef + !yRef - - f arr xRef yRef z - @> - ] - -let tests translator = - [ - testList "Parameter lifting test" lambdaLiftingTests - testList "Var defs to lambda test" varDefsToLambdaTest - testList "Transformer quotation system tests" <| quotationTransformerTest translator - ] diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/TranslationTests.fs b/tests/Brahma.FSharp.Tests/TranslationTests/TranslationTests.fs deleted file mode 100644 index f0fe4a08..00000000 --- a/tests/Brahma.FSharp.Tests/TranslationTests/TranslationTests.fs +++ /dev/null @@ -1,15 +0,0 @@ -module TranslationTests - -open Brahma.FSharp.OpenCL.Translator -open Expecto - -let translators = [ - FSQuotationToOpenCLTranslator.CreateDefault() -] - -let tests = [ - for translator in translators do yield! [ - testList "Tests for translator" <| TranslatorTests.tests translator - testList "Quotation transformer tests" <| QuotationTransformersTests.tests translator - ] -] diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/TranslatorTests.fs b/tests/Brahma.FSharp.Tests/TranslationTests/TranslatorTests.fs deleted file mode 100644 index dda7f7ce..00000000 --- a/tests/Brahma.FSharp.Tests/TranslationTests/TranslatorTests.fs +++ /dev/null @@ -1,1070 +0,0 @@ -module TranslatorTests - -open Expecto -open Brahma.FSharp -open Brahma.FSharp.Tests -open System.IO -open Brahma.FSharp.OpenCL.Printer -open Brahma.FSharp.OpenCL.Translator -open FSharp.Quotations - -[] -module Helpers = - let basePath = "TranslationTests/Expected/" - let generatedPath = "TranslationTests/Generated/" - - do Directory.CreateDirectory(generatedPath) |> ignore - - let openclTranslate (translator: FSQuotationToOpenCLTranslator) (expr: Expr) = - let (ast, _) = translator.Translate expr - AST.print ast - - let checkCode translator command outFile expected = - let code = command |> openclTranslate translator - - let targetPath = Path.Combine(generatedPath, outFile) - let expectedPath = Path.Combine(basePath, expected) - File.WriteAllText(targetPath, code) - - Utils.filesAreEqual targetPath expectedPath - -let basicLocalIdTests translator = [ - let inline checkCode cmd outFile expected = checkCode translator cmd outFile expected - - testCase "LocalID of 1D" <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let id = range.LocalID0 - buf.[id] <- 0 - @> - - checkCode command "LocalID1D.gen" "LocalID1D.cl" - - testCase "LocalID of 2D" <| fun _ -> - let command = - <@ fun (range: Range2D) (buf: int clarray) -> - let v = range.LocalID0 - let id = range.LocalID1 - buf.[id] <- v - @> - - checkCode command "LocalID2D.gen" "LocalID2D.cl" -] - -let basicWorkSizeTests translator = [ - let inline checkCode cmd outFile expected = checkCode translator cmd outFile expected - - testCase "WorkSize of 1D" <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: int clarray) -> - let gSize = range.GlobalWorkSize - let lSize = range.LocalWorkSize - () - @> - - checkCode command "WorkSize1D.gen" "WorkSize1D.cl" - - testCase "WorkSize of 2D" <| fun _ -> - let command = - <@ - fun (range: Range2D) (buf: int clarray) -> - let (gSizeX, gSizeY) = range.GlobalWorkSize - let (lSizeX, lSizeY) = range.LocalWorkSize - () - @> - - checkCode command "WorkSize2D.gen" "WorkSize2D.cl" - - testCase "WorkSize of 3D" <| fun _ -> - let command = - <@ - fun (range: Range3D) (buf: int clarray) -> - let (gSizeX, gSizeY, gSizeZ) = range.GlobalWorkSize - let (lSizeX, lSizeY, lSizeZ) = range.LocalWorkSize - () - @> - - checkCode command "WorkSize3D.gen" "WorkSize3D.cl" -] - -let basicBinOpsTests translator = [ - let inline checkCode cmd outFile expected = checkCode translator cmd outFile expected - - testCase "Array item set" <| fun _ -> - let command = <@ fun (range: Range1D) (buf: int clarray) -> buf.[0] <- 0 @> - - checkCode command "Array.Item.Set.gen" "Array.Item.Set.cl" - - testCase "Binding" <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let x = 1 - buf.[0] <- x - @> - - checkCode command "Binding.gen" "Binding.cl" - - testCase "Binop plus" <| fun _ -> - let command = <@ fun (range: Range1D) (buf: int clarray) -> buf.[0] <- 1 + 2 @> - - checkCode command "Binop.Plus.gen" "Binop.Plus.cl" - - testCase "Binary operations. Math." <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let x = 0 - let y = x + 1 - let z = y * 2 - let a = z - x - let i = a / 2 - buf.[0] <- i - @> - - checkCode command "Binary.Operations.Math.gen" "Binary.Operations.Math.cl" - - testCase "TempVar from MAX transformation should not affect other variables" <| fun () -> - let command = - <@ - fun (range: Range1D) (buf: float clarray) -> - let tempVarY = 1. - buf.[0] <- max buf.[0] tempVarY - buf.[0] <- max buf.[0] tempVarY - @> - - checkCode command "MAX.Transformation.gen" "MAX.Transformation.cl" -] - -let controlFlowTests translator = [ - let inline checkCode cmd outFile expected = checkCode translator cmd outFile expected - - testCase "If Then" <| fun _ -> - let command = <@ fun (range: Range1D) (buf: int clarray) -> if 0 = 2 then buf.[0] <- 1 @> - - checkCode command "If.Then.gen" "If.Then.cl" - - testCase "If Then Else" <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - if 0 = 2 then - buf.[0] <- 1 - else - buf.[0] <- 2 - @> - - checkCode command "If.Then.Else.gen" "If.Then.Else.cl" - - testCase "For Integer Loop" <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - for i in 1 .. 3 do - buf.[0] <- i - @> - - checkCode command "For.Integer.Loop.gen" "For.Integer.Loop.cl" - - testCase "Sequential bindings" <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let x = 1 - let y = x + 1 - buf.[0] <- y - @> - - checkCode command "Sequential.Bindings.gen" "Sequential.Bindings.cl" - - testCase "Binding in IF." <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - if 2 = 0 then - let x = 1 - buf.[0] <- x - else - let i = 2 - buf.[0] <- i - @> - - checkCode command "Binding.In.IF.gen" "Binding.In.IF.cl" - - testCase "Binding in FOR." <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - for i in 0 .. 3 do - let x = i * i - buf.[0] <- x - @> - - checkCode command "Binding.In.FOR.gen" "Binding.In.FOR.cl" - - testCase "Simple WHILE loop." <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - while buf.[0] < 5 do - buf.[0] <- buf.[0] + 1 - @> - - checkCode command "Simple.WHILE.gen" "Simple.WHILE.cl" - - testCase "Binding in WHILE." <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - while buf.[0] < 5 do - let x = buf.[0] + 1 - buf.[0] <- x * x - @> - - checkCode command "Binding.In.WHILE.gen" "Binding.In.WHILE.cl" - - ptestCase - "WHILE with single statement in the body and this stetement is assignment of constant. \ - This test translates to openCL correctly but breaks openCL compiler on ubuntu 18.04" <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - while true do - buf.[0] <- 1 - @> - - checkCode command "WHILE.with.complex.condition.gen" "WHILE.with.complex.condition.cl" - - testCase "WHILE with complex condition" <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - while buf.[0] < 5 && (buf.[1] < 6 || buf.[2] > 2) do - buf.[0] <- 2 + buf.[0] - @> - - checkCode command "WHILE.with.complex.condition.gen" "WHILE.with.complex.condition.cl" - - testCase "Simple seq." <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - buf.[0] <- 2 - buf.[1] <- 3 - @> - - checkCode command "Simple.Seq.gen" "Simple.Seq.cl" - - testCase "Seq with bindings." <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let x = 2 - buf.[0] <- x - let y = 2 - buf.[1] <- y - @> - - checkCode command "Seq.With.Bindings.gen" "Seq.With.Bindings.cl" -] - -let namesResolvingTests translator = [ - let inline checkCode cmd outFile expected = checkCode translator cmd outFile expected - - testCase "Bindings with equal names." <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let x = 2 - buf.[0] <- x - let x = 3 - buf.[1] <- x - @> - - checkCode command "Bindings.With.Equal.Names.gen" "Bindings.With.Equal.Names.cl" - - testCase "Binding and FOR counter conflict 1." <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let i = 2 - - for i in 1 .. 2 do - buf.[1] <- i - @> - - checkCode command "Binding.And.FOR.Counter.Conflict.1.gen" "Binding.And.FOR.Counter.Conflict.1.cl" - - testCase "Binding and FOR counter conflict 2." <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - for i in 1 .. 2 do - let i = 2 - buf.[1] <- i - @> - - checkCode command "Binding.And.FOR.Counter.Conflict.2.gen" "Binding.And.FOR.Counter.Conflict.2.cl" - - testCase "Binding and FOR counter conflict 3." <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - for i in 0 .. 1 do - let i = i + 2 - buf.[i] <- 2 - @> - - checkCode command "Binding.And.FOR.Counter.Conflict.3.gen" "Binding.And.FOR.Counter.Conflict.3.cl" - - testCase "Binding and FOR counter conflict 4." <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let i = 1 - - for i in 0 .. i + 1 do - let i = i + 2 - buf.[i] <- 2 - @> - - checkCode command "Binding.And.FOR.Counter.Conflict.4.gen" "Binding.And.FOR.Counter.Conflict.4.cl" -] - -let quotationsInjectionTests translator = [ - let inline checkCode cmd outFile expected = checkCode translator cmd outFile expected - - testCase "Quotations injections 1" <| fun _ -> - let myF = <@ fun x -> x * x @> - - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - buf.[0] <- (%myF) 2 - buf.[1] <- (%myF) 4 - @> - - checkCode command "Quotations.Injections.1.gen" "Quotations.Injections.1.cl" - - testCase "Quotations injections 2" <| fun _ -> - let myF = <@ fun x y -> x - y @> - - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - buf.[0] <- (%myF) 2 3 - buf.[1] <- (%myF) 4 5 - @> - - checkCode command "Quotations.Injections.2.gen" "Quotations.Injections.2.cl" - -] - -let constantArrayTests translator = [ - let inline checkCode cmd outFile expected = checkCode translator cmd outFile expected - - testCase "Constant array translation. Test 1" <| fun _ -> - let cArray1 = [| 1; 2; 3 |] - let command = <@ fun (range: Range1D) (buf: int clarray) -> buf.[0] <- cArray1.[1] @> - checkCode command "Constant array translation. Test 1.gen" "Constant array translation. Test 1.cl" - - testCase "Constant array translation. Test 2" <| fun _ -> - let cArray1 = [| 1; 2; 3 |] - let command = <@ fun (range: Range1D) (buf: int clarray) -> buf.[0] <- 1 + cArray1.[1] @> - checkCode command "Constant array translation. Test 2.gen" "Constant array translation. Test 2.cl" -] - -let lambdaLiftingTests translator = [ - let inline checkCode cmd outFile expected = checkCode translator cmd outFile expected - - testCase "Template Let Transformation Test 0" <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let f = 3 - buf.[0] <- f - @> - - checkCode command "Template Test 0.gen" "Template Test 0.cl" - - testCase "Template Let Transformation Test 1" <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let f = - let x = 3 - x - - buf.[0] <- f - @> - - checkCode command "Template Test 1.gen" "Template Test 1.cl" - - testCase "Template Let Transformation Test 2" <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let f = - let x = - let y = 3 - y - - x - - buf.[0] <- f - @> - - checkCode command "Template Test 2.gen" "Template Test 2.cl" - - testCase "Template Let Transformation Test 3" <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let f = - let f = 5 - f - - buf.[0] <- f - @> - - checkCode command "Template Test 3.gen" "Template Test 3.cl" - - testCase "Template Let Transformation Test 4" <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let f = - let f = - let f = 5 - f - - f - - buf.[0] <- f - @> - - checkCode command "Template Test 4.gen" "Template Test 4.cl" - - testCase "Template Let Transformation Test 5" <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let f a b = - let x y z = y + z - x a b - - buf.[0] <- f 1 7 - @> - - checkCode command "Template Test 5.gen" "Template Test 5.cl" - - testCase "Template Let Transformation Test 6" <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let f x y = - let x = x - x + y - - buf.[0] <- f 7 8 - @> - - checkCode command "Template Test 6.gen" "Template Test 6.cl" - - testCase "Template Let Transformation Test 7" <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let f y = - let x y = 6 - y - x y - - buf.[0] <- f 7 - @> - - checkCode command "Template Test 7.gen" "Template Test 7.cl" - - testCase "Template Let Transformation Test 8" <| fun _ -> - let command = - <@ fun (range: Range1D) (m: int clarray) -> - let p = m.[0] - - let x n = - let l = m.[9] - let g k = k + m.[0] + m.[1] - - let r = - let y a = - let x = 5 - n + (g 4) - let z t = m.[2] + a - t - z (a + x + l) - - y 6 - - r + m.[3] - - m.[0] <- x 7 - @> - - checkCode command "Template Test 8.gen" "Template Test 8.cl" - - testCase "Template Let Transformation Test 9" <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let x n = - let r = 8 - let h = r + n - h - - buf.[0] <- x 9 - @> - - checkCode command "Template Test 9.gen" "Template Test 9.cl" - - testCase "Template Let Transformation Test 10" <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let p = 9 - - let x n b = - let t = 0 - n + b + t - - buf.[0] <- x 7 9 - @> - - checkCode command "Template Test 10.gen" "Template Test 10.cl" - - testCase "Template Let Transformation Test 11" <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let p = 1 - - let m = - let r l = l + p - r 9 - - let z k = k + 1 - buf.[0] <- m - @> - - checkCode command "Template Test 11.gen" "Template Test 11.cl" - - testCase "Template Let Transformation Test 12" <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let f x y = - let y = y - let y = y - let g x m = m + x - g x y - - buf.[0] <- f 1 7 - @> - - checkCode command "Template Test 12.gen" "Template Test 12.cl" - - testCase "Template Let Transformation Test 13" <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let f y = - let y = y - let y = y - let g m = m + 1 - g y - - buf.[0] <- f 7 - @> - - checkCode command "Template Test 13.gen" "Template Test 13.cl" - - testCase "Template Let Transformation Test 14" <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let f (y: int) = - let y = y - let y = y - - let g (m: int) = - let g r t = r + y - t - let n o = o - (g y 2) - n 5 - - g y - - let z y = y - 2 - buf.[0] <- f (z 7) - @> - - checkCode command "Template Test 14.gen" "Template Test 14.cl" - - testCase "Template Let Transformation Test 15" <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let f y = - let Argi index = if index = 0 then buf.[1] else buf.[2] - Argi y - - buf.[0] <- f 0 - @> - - checkCode command "Template Test 15.gen" "Template Test 15.cl" - - testCase "Template Let Transformation Test 16" <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let f y = - if y = 0 then - let z a = a + 1 - z 9 - else - buf.[2] - - buf.[0] <- f 0 - @> - - checkCode command "Template Test 16.gen" "Template Test 16.cl" - - testCase "Let renamed" <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let f x = - let g = 1 + x - g - - buf.[0] <- f 1 - @> - - checkCode command "Let renamed.gen" "Let renamed.cl" - - testCase "Let renamed 2" <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let f m k = - let g q w = 1 + q + w - let t p = 7 - p - (g 1 2) - m * k / (t 53) - - buf.[0] <- f 1 4 - @> - - checkCode command "Let renamed 2.gen" "Let renamed 2.cl" - - testCase "Renamer Test" <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let f x y = - let y = y - let y = y - let g x m = m + x - g x y - - buf.[0] <- f 1 7 - @> - - checkCode command "Renamer Test.gen" "Renamer Test.cl" - - testCase "Nested functions" <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let f x y = x - y - buf.[0] <- f 2 3 - buf.[1] <- f 4 5 - @> - - checkCode command "Nested.Function.gen" "Nested.Function.cl" -] - -let curryingTests translator = [ - let inline checkCode cmd outFile expected = checkCode translator cmd outFile expected - - testCase "Nested functions.Carring 1." <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let f x y = x - y - let g = f 2 - buf.[0] <- g 3 - buf.[1] <- g 5 - @> - - checkCode command "Nested.Function.Carring.gen" "Nested.Function.Carring.cl" - - testCase "Nested functions.Currying 2." <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let f x y = - let gg = ref 0 - - for i in 1 .. x do - gg := !gg + y - - !gg - - let g x = f 2 x - buf.[0] <- g 2 - buf.[1] <- g 3 - @> - - checkCode command "Nested.Function.Carring2.gen" "Nested.Function.Carring2.cl" -] - -let localMemoryTests translator = [ - let inline checkCode cmd outFile expected = checkCode translator cmd outFile expected - - testCase "Local int" <| fun _ -> - let command = - <@ fun (range: Range1D) -> - let mutable x = local () - x <- 0 - @> - - checkCode command "LocalMemory.int.gen" "LocalMemory.int.cl" - - testCase "Local float" <| fun _ -> - let command = - <@ fun (range: Range1D) -> - let mutable x = local () - x <- 0.0 - @> - - checkCode command "LocalMemory.float.gen" "LocalMemory.float.cl" - - testCase "Local int array" <| fun _ -> - let command = - <@ fun (range: Range1D) -> - let xs = localArray 5 - xs.[range.LocalID0] <- range.LocalID0 - @> - - checkCode command "LocalMemory.int [].gen" "LocalMemory.int [].cl" -] - -let localMemoryAllocationTests translator = [ - let inline checkCode cmd outFile expected = checkCode translator cmd outFile expected - - testCase "Constant array translation. Local copy test 1" <| fun _ -> - let cArray1 = [| 1; 2; 3 |] - - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - //let c = local (Array.zeroCreate 3)//cArray1 - //buf.[0] <- c.[1] - buf.[0] <- 1 - @> - - checkCode - command - "Constant array translation. Local copy test 1.gen" - "Constant array translation. Local copy test 1.cl" -] - -let printfTests translator = [ - let inline checkCode cmd outFile expected = checkCode translator cmd outFile expected - - testCase "Printf test 1" <| fun _ -> - let command = <@ fun (range: Range1D) -> printf "%d %f" 10 15.0 @> - checkCode command "Printf test 1.gen" "Printf test 1.cl" - - testCase "Printf test 2" <| fun _ -> - let command = - <@ fun (range: Range1D) (xs: int clarray) -> - let gid = range.GlobalID0 - let x = 10 - - printf "%d %d" x xs.[gid] - @> - - checkCode command "Printf test 2.gen" "Printf test 2.cl" - - testCase "Printf test 3" <| fun _ -> - let command = - <@ fun (range: Range1D) (xs: int clarray) -> - let mutable i = 0 - - while i < 10 do - xs.[0] <- i * 2 - printf "i = %d, xs.[0]*10 = %d\n" i (xs.[0] + 10) - i <- i + 1 - @> - - checkCode command "Printf test 3.gen" "Printf test 3.cl" - - testCase "Printf test 4: printfn" <| fun _ -> - let command = <@ fun (range: Range1D) -> printfn "%d %f" 10 15.0 @> - checkCode command "Printf test 4.gen" "Printf test 4.cl" - - testCase "Printf test 5: printf without args" <| fun _ -> - let command = <@ fun (range: Range1D) -> printf "I am complied" @> - checkCode command "Printf test 5.gen" "Printf test 5.cl" - - testCase "Printf test 6: printfn without args" <| fun _ -> - let command = <@ fun (range: Range1D) -> printfn "I am complied too" @> - checkCode command "Printf test 6.gen" "Printf test 6.cl" -] - -let barrierTests translator = [ - let inline checkCode cmd outFile expected = checkCode translator cmd outFile expected - - testCase "Local barrier translation tests" <| fun () -> - let command = <@ fun (range: Range1D) -> barrierLocal () @> - checkCode command "Barrier.Local.gen" "Barrier.Local.cl" - - testCase "Global barrier translation tests" <| fun () -> - let command = <@ fun (range: Range1D) -> barrierGlobal () @> - checkCode command "Barrier.Global.gen" "Barrier.Global.cl" - - testCase "Full barrier translation tests" <| fun () -> - let command = <@ fun (range: Range1D) -> barrierFull () @> - checkCode command "Barrier.Full.gen" "Barrier.Full.cl" -] - -type TranslateTest = - | A of int * float - | B of double - | C - -open Brahma.FSharp.OpenCL.AST - -let unionTests (translator: FSQuotationToOpenCLTranslator) = - let testGen testCase name (types: List) outFile expectedFile = - testCase name <| fun () -> - let context = TranslationContext.Create(TranslatorOptions()) - for type' in types do Type.translateUnion type' |> State.run context |> ignore - - let unions = context.CStructDecls.Values |> Seq.map StructDecl |> Seq.toList - - let ast = AST <| List.map (fun du -> du :> ITopDef<_>) unions - let code = AST.print ast - - File.WriteAllText(outFile, code) - - Utils.filesAreEqual outFile - <| Path.Combine(basePath, expectedFile) - - [ - testGen testCase "Test 1" [ typeof ] "Translation.Test1.gen" "Translation.Test1.cl" - ] - -type SimpleUnion = - | SimpleOne - | SimpleTwo of int - -type OuterUnion = - | Outer of int - | Inner of SimpleUnion - -let collectUnionTests (translator: FSQuotationToOpenCLTranslator) = - let testGen testCase name expected command = - testCase name <| fun () -> - let unions = - Body.translate command - |> State.exec (TranslationContext.Create(TranslatorOptions())) - |> fun context -> context.CStructDecls.Keys - - Expect.sequenceEqual unions expected "Should be equal" - - [ - testGen testCase "Simple union" [| typeof |] - <@ let x = SimpleOne - let y = SimpleTwo 2 - () - @> - - testGen testCase "Nested union 1" [| typeof; typeof |] - <@ let x = Outer 5 - () - @> - - testGen testCase "Nested union 2" [| typeof; typeof |] - <@ let x = Inner SimpleOne - () - @> - ] - -let specificTests (translator: FSQuotationToOpenCLTranslator) = [ - let inline checkCode cmd outFile expected = checkCode translator cmd outFile expected - - testCase "Merge kernel" <| fun () -> - let command workGroupSize = - <@ - fun (ndRange: Range1D) - firstSide - secondSide - sumOfSides - (firstRowsBuffer: ClArray) - (firstColumnsBuffer: ClArray) - (firstValuesBuffer: ClArray) - (secondRowsBuffer: ClArray) - (secondColumnsBuffer: ClArray) - (secondValuesBuffer: ClArray) - (allRowsBuffer: ClArray) - (allColumnsBuffer: ClArray) - (allValuesBuffer: ClArray) -> - - let i = ndRange.GlobalID0 - - let mutable beginIdxLocal = local () - let mutable endIdxLocal = local () - let localID = ndRange.LocalID0 - - if localID < 2 then - let mutable x = localID * (workGroupSize - 1) + i - 1 - - if x >= sumOfSides then - x <- sumOfSides - 1 - - let diagonalNumber = x - - let mutable leftEdge = diagonalNumber + 1 - secondSide - if leftEdge < 0 then leftEdge <- 0 - - let mutable rightEdge = firstSide - 1 - - if rightEdge > diagonalNumber then - rightEdge <- diagonalNumber - - while leftEdge <= rightEdge do - let middleIdx = (leftEdge + rightEdge) / 2 - - let firstIndex: uint64 = - ((uint64 firstRowsBuffer.[middleIdx]) <<< 32) - ||| (uint64 firstColumnsBuffer.[middleIdx]) - - let secondIndex: uint64 = - ((uint64 secondRowsBuffer.[diagonalNumber - middleIdx]) - <<< 32) - ||| (uint64 secondColumnsBuffer.[diagonalNumber - middleIdx]) - - if firstIndex < secondIndex then - leftEdge <- middleIdx + 1 - else - rightEdge <- middleIdx - 1 - - // Here localID equals either 0 or 1 - if localID = 0 then - beginIdxLocal <- leftEdge - else - endIdxLocal <- leftEdge - - barrierLocal () - - let beginIdx = beginIdxLocal - let endIdx = endIdxLocal - let firstLocalLength = endIdx - beginIdx - let mutable x = workGroupSize - firstLocalLength - - if endIdx = firstSide then - x <- secondSide - i + localID + beginIdx - - let secondLocalLength = x - - //First indices are from 0 to firstLocalLength - 1 inclusive - //Second indices are from firstLocalLength to firstLocalLength + secondLocalLength - 1 inclusive - let localIndices = localArray workGroupSize - - if localID < firstLocalLength then - localIndices.[localID] <- - ((uint64 firstRowsBuffer.[beginIdx + localID]) - <<< 32) - ||| (uint64 firstColumnsBuffer.[beginIdx + localID]) - - if localID < secondLocalLength then - localIndices.[firstLocalLength + localID] <- - ((uint64 secondRowsBuffer.[i - beginIdx]) <<< 32) - ||| (uint64 secondColumnsBuffer.[i - beginIdx]) - - barrierLocal () - - if i < sumOfSides then - let mutable leftEdge = localID + 1 - secondLocalLength - if leftEdge < 0 then leftEdge <- 0 - - let mutable rightEdge = firstLocalLength - 1 - - if rightEdge > localID then - rightEdge <- localID - - while leftEdge <= rightEdge do - let middleIdx = (leftEdge + rightEdge) / 2 - let firstIndex = localIndices.[middleIdx] - - let secondIndex = - localIndices.[firstLocalLength + localID - middleIdx] - - if firstIndex < secondIndex then - leftEdge <- middleIdx + 1 - else - rightEdge <- middleIdx - 1 - - let boundaryX = rightEdge - let boundaryY = localID - leftEdge - - // boundaryX and boundaryY can't be off the right edge of array (only off the left edge) - let isValidX = boundaryX >= 0 - let isValidY = boundaryY >= 0 - - let mutable fstIdx = 0UL - - if isValidX then - fstIdx <- localIndices.[boundaryX] - - let mutable sndIdx = 0UL - - if isValidY then - sndIdx <- localIndices.[firstLocalLength + boundaryY] - - if not isValidX || isValidY && fstIdx < sndIdx then - allRowsBuffer.[i] <- int (sndIdx >>> 32) - allColumnsBuffer.[i] <- int sndIdx - allValuesBuffer.[i] <- secondValuesBuffer.[i - localID - beginIdx + boundaryY] - else - allRowsBuffer.[i] <- int (fstIdx >>> 32) - allColumnsBuffer.[i] <- int fstIdx - allValuesBuffer.[i] <- firstValuesBuffer.[beginIdx + boundaryX] - @> - - checkCode (command 256) "MergeKernel.gen" "MergeKernel.cl" - - testCase "Multiple local values in atomic operations" <| fun () -> - let kernel = - <@ - fun (ndRange: Range1D) (v: int) -> - let mutable firstMaxIndex = local () - let mutable secondMaxIndex = local () - let mutable value = local () - - if ndRange.LocalID0 = 0 then - firstMaxIndex <- 0 - secondMaxIndex <- 0 - value <- v - - barrierLocal () - - atomic (max) firstMaxIndex value |> ignore - atomic (max) secondMaxIndex value |> ignore - @> - - openclTranslate translator kernel |> ignore -] - -let commonApiTests translator = [ - // TODO is it correct? - ptestCase "Using atomic in lambda should not raise exception if first parameter passed" <| fun () -> - let command = - <@ - fun (range: Range1D) (buffer: int[]) -> - let g = atomic (fun x y -> x + 1) buffer.[0] - g 5 |> ignore - @> - - command |> openclTranslate translator |> ignore - - // TODO is it correct? - ptestCase "Using atomic in lambda should raise exception if first parameter is argument" <| fun () -> - let command = - <@ - fun (range: Range1D) (buffer: int[]) -> - let g x y = atomic (+) x y - g buffer.[0] 6 |> ignore - @> - - Expect.throwsT - <| fun () -> command |> openclTranslate translator |> ignore - <| "Exception should be thrown" -] - -let tests translator = - [ - testList "Basic tests on LocalID translation" << basicLocalIdTests - testList "Basic tests on getting WorkSize translation" << basicWorkSizeTests - testList "Basic operations translation tests" << basicBinOpsTests - testList "Control flow translation tests" << controlFlowTests - testList "Tests on variables renaming." << namesResolvingTests - testList "Quotations injection tests" << quotationsInjectionTests - testList "Constant array translation tests." << constantArrayTests - testList "Let transformation tests" << lambdaLiftingTests - ptestList "Currying translation test" << curryingTests - testList "Test of local memory declaration functions" << localMemoryTests - ptestList "Translation of local memory allocation functions" << localMemoryAllocationTests - testList "Translation of printf" << printfTests - testList "Barrier translation tests" << barrierTests - testList "Translate union" << unionTests - testList "Collect union tests" << collectUnionTests - testList "Test on specific cases" << specificTests - testList "Common Api Tests" << commonApiTests - ] - |> List.map (fun testFixture -> testFixture translator) - diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/Array.Item.Set.cl b/tests/Brahma.FSharp.Tests/Translator/BinaryOperations/Expected/Array.Item.Set.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/Array.Item.Set.cl rename to tests/Brahma.FSharp.Tests/Translator/BinaryOperations/Expected/Array.Item.Set.cl diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/Binary.Operations.Math.cl b/tests/Brahma.FSharp.Tests/Translator/BinaryOperations/Expected/Binary.Operations.Math.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/Binary.Operations.Math.cl rename to tests/Brahma.FSharp.Tests/Translator/BinaryOperations/Expected/Binary.Operations.Math.cl diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/Binding.cl b/tests/Brahma.FSharp.Tests/Translator/BinaryOperations/Expected/Binding.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/Binding.cl rename to tests/Brahma.FSharp.Tests/Translator/BinaryOperations/Expected/Binding.cl diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/Binop.Plus.cl b/tests/Brahma.FSharp.Tests/Translator/BinaryOperations/Expected/Binop.Plus.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/Binop.Plus.cl rename to tests/Brahma.FSharp.Tests/Translator/BinaryOperations/Expected/Binop.Plus.cl diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/MAX.Transformation.cl b/tests/Brahma.FSharp.Tests/Translator/BinaryOperations/Expected/MAX.Transformation.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/MAX.Transformation.cl rename to tests/Brahma.FSharp.Tests/Translator/BinaryOperations/Expected/MAX.Transformation.cl diff --git a/tests/Brahma.FSharp.Tests/Translator/BinaryOperations/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/BinaryOperations/Tests.fs new file mode 100644 index 00000000..75080a9d --- /dev/null +++ b/tests/Brahma.FSharp.Tests/Translator/BinaryOperations/Tests.fs @@ -0,0 +1,52 @@ +module Brahma.FSharp.Tests.Translator.BinaryOperations.Tests + +open Expecto +open Brahma.FSharp +open Brahma.FSharp.Tests.Translator.Common + +let basicBinOpsTests translator = [ + let checkCode command = Helpers.checkCode translator command + + testCase "Array item set" <| fun _ -> + let command = <@ fun (range: Range1D) (buf: int clarray) -> buf.[0] <- 0 @> + + checkCode command "Array.Item.Set.gen" "Array.Item.Set.cl" + + testCase "Binding" <| fun _ -> + let command = + <@ fun (range: Range1D) (buf: int clarray) -> + let x = 1 + buf.[0] <- x + @> + + checkCode command "Binding.gen" "Binding.cl" + + testCase "Binop plus" <| fun _ -> + let command = <@ fun (range: Range1D) (buf: int clarray) -> buf.[0] <- 1 + 2 @> + + checkCode command "Binop.Plus.gen" "Binop.Plus.cl" + + testCase "Binary operations. Math." <| fun _ -> + let command = + <@ fun (range: Range1D) (buf: int clarray) -> + let x = 0 + let y = x + 1 + let z = y * 2 + let a = z - x + let i = a / 2 + buf.[0] <- i + @> + + checkCode command "Binary.Operations.Math.gen" "Binary.Operations.Math.cl" + + testCase "TempVar from MAX transformation should not affect other variables" <| fun () -> + let command = + <@ + fun (range: Range1D) (buf: float clarray) -> + let tempVarY = 1. + buf.[0] <- max buf.[0] tempVarY + buf.[0] <- max buf.[0] tempVarY + @> + + checkCode command "MAX.Transformation.gen" "MAX.Transformation.cl" +] diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/Nested.Function.Carring.cl b/tests/Brahma.FSharp.Tests/Translator/Carrying/Expected/Nested.Function.Carring.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/Nested.Function.Carring.cl rename to tests/Brahma.FSharp.Tests/Translator/Carrying/Expected/Nested.Function.Carring.cl diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/Nested.Function.Carring2.cl b/tests/Brahma.FSharp.Tests/Translator/Carrying/Expected/Nested.Function.Carring2.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/Nested.Function.Carring2.cl rename to tests/Brahma.FSharp.Tests/Translator/Carrying/Expected/Nested.Function.Carring2.cl diff --git a/tests/Brahma.FSharp.Tests/Translator/Carrying/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/Carrying/Tests.fs new file mode 100644 index 00000000..9d4ceaf6 --- /dev/null +++ b/tests/Brahma.FSharp.Tests/Translator/Carrying/Tests.fs @@ -0,0 +1,38 @@ +module Brahma.FSharp.Tests.Translator.Carrying.Tests + +open Brahma.FSharp +open Expecto +open Brahma.FSharp.Tests.Translator.Common + +let curryingTests translator = [ + let inline checkCode cmd outFile expected = checkCode translator cmd outFile expected + + testCase "Nested functions.Carring 1." <| fun _ -> + let command = + <@ fun (range: Range1D) (buf: int clarray) -> + let f x y = x - y + let g = f 2 + buf.[0] <- g 3 + buf.[1] <- g 5 + @> + + checkCode command "Nested.Function.Carring.gen" "Nested.Function.Carring.cl" + + testCase "Nested functions.Currying 2." <| fun _ -> + let command = + <@ fun (range: Range1D) (buf: int clarray) -> + let f x y = + let gg = ref 0 + + for i in 1 .. x do + gg := !gg + y + + !gg + + let g x = f 2 x + buf.[0] <- g 2 + buf.[1] <- g 3 + @> + + checkCode command "Nested.Function.Carring2.gen" "Nested.Function.Carring2.cl" +] diff --git a/tests/Brahma.FSharp.Tests/Translator/Common.fs b/tests/Brahma.FSharp.Tests/Translator/Common.fs new file mode 100644 index 00000000..044fc63c --- /dev/null +++ b/tests/Brahma.FSharp.Tests/Translator/Common.fs @@ -0,0 +1,26 @@ +module Brahma.FSharp.Tests.Translator.Common + +open Expecto +open Brahma.FSharp.Tests +open System.IO +open Brahma.FSharp.OpenCL.Printer +open Brahma.FSharp.OpenCL.Translator +open FSharp.Quotations + +[] +module Helpers = + let basePath = "TranslationTests/Expected/" + + let openclTranslate (translator: FSQuotationToOpenCLTranslator) (expr: Expr) = + translator.Translate expr + |> fst + |> AST.print + + let checkCode translator command outFile expected = + let code = command |> openclTranslate translator + + let expectedPath = Path.Combine(basePath, expected) + // read from file + + Utils.filesAreEqual "targetPath" expectedPath + diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/Constant array translation. Test 1.cl b/tests/Brahma.FSharp.Tests/Translator/ConstantArray/Expected/Constant array translation. Test 1.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/Constant array translation. Test 1.cl rename to tests/Brahma.FSharp.Tests/Translator/ConstantArray/Expected/Constant array translation. Test 1.cl diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/Constant array translation. Test 2.cl b/tests/Brahma.FSharp.Tests/Translator/ConstantArray/Expected/Constant array translation. Test 2.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/Constant array translation. Test 2.cl rename to tests/Brahma.FSharp.Tests/Translator/ConstantArray/Expected/Constant array translation. Test 2.cl diff --git a/tests/Brahma.FSharp.Tests/Translator/ConstantArray/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/ConstantArray/Tests.fs new file mode 100644 index 00000000..ff9259dc --- /dev/null +++ b/tests/Brahma.FSharp.Tests/Translator/ConstantArray/Tests.fs @@ -0,0 +1,19 @@ +module Brahma.FSharp.Tests.Translator.ConstantArray.Tests + +open Expecto +open Brahma.FSharp +open Brahma.FSharp.Tests.Translator.Common + +let constantArrayTests translator = [ + let inline checkCode cmd outFile expected = checkCode translator cmd outFile expected + + testCase "Constant array translation. Test 1" <| fun _ -> + let cArray1 = [| 1; 2; 3 |] + let command = <@ fun (range: Range1D) (buf: int clarray) -> buf.[0] <- cArray1.[1] @> + checkCode command "Constant array translation. Test 1.gen" "Constant array translation. Test 1.cl" + + testCase "Constant array translation. Test 2" <| fun _ -> + let cArray1 = [| 1; 2; 3 |] + let command = <@ fun (range: Range1D) (buf: int clarray) -> buf.[0] <- 1 + cArray1.[1] @> + checkCode command "Constant array translation. Test 2.gen" "Constant array translation. Test 2.cl" +] diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/Binding.In.FOR.cl b/tests/Brahma.FSharp.Tests/Translator/ControlFlow/Expected/Binding.In.FOR.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/Binding.In.FOR.cl rename to tests/Brahma.FSharp.Tests/Translator/ControlFlow/Expected/Binding.In.FOR.cl diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/Binding.In.IF.cl b/tests/Brahma.FSharp.Tests/Translator/ControlFlow/Expected/Binding.In.IF.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/Binding.In.IF.cl rename to tests/Brahma.FSharp.Tests/Translator/ControlFlow/Expected/Binding.In.IF.cl diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/Binding.In.WHILE.cl b/tests/Brahma.FSharp.Tests/Translator/ControlFlow/Expected/Binding.In.WHILE.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/Binding.In.WHILE.cl rename to tests/Brahma.FSharp.Tests/Translator/ControlFlow/Expected/Binding.In.WHILE.cl diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/For.Integer.Loop.cl b/tests/Brahma.FSharp.Tests/Translator/ControlFlow/Expected/For.Integer.Loop.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/For.Integer.Loop.cl rename to tests/Brahma.FSharp.Tests/Translator/ControlFlow/Expected/For.Integer.Loop.cl diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/If.Then.Else.cl b/tests/Brahma.FSharp.Tests/Translator/ControlFlow/Expected/If.Then.Else.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/If.Then.Else.cl rename to tests/Brahma.FSharp.Tests/Translator/ControlFlow/Expected/If.Then.Else.cl diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/If.Then.cl b/tests/Brahma.FSharp.Tests/Translator/ControlFlow/Expected/If.Then.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/If.Then.cl rename to tests/Brahma.FSharp.Tests/Translator/ControlFlow/Expected/If.Then.cl diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/Seq.With.Bindings.cl b/tests/Brahma.FSharp.Tests/Translator/ControlFlow/Expected/Seq.With.Bindings.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/Seq.With.Bindings.cl rename to tests/Brahma.FSharp.Tests/Translator/ControlFlow/Expected/Seq.With.Bindings.cl diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/Sequential.Bindings.cl b/tests/Brahma.FSharp.Tests/Translator/ControlFlow/Expected/Sequential.Bindings.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/Sequential.Bindings.cl rename to tests/Brahma.FSharp.Tests/Translator/ControlFlow/Expected/Sequential.Bindings.cl diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/Simple.Seq.cl b/tests/Brahma.FSharp.Tests/Translator/ControlFlow/Expected/Simple.Seq.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/Simple.Seq.cl rename to tests/Brahma.FSharp.Tests/Translator/ControlFlow/Expected/Simple.Seq.cl diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/Simple.WHILE.cl b/tests/Brahma.FSharp.Tests/Translator/ControlFlow/Expected/Simple.WHILE.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/Simple.WHILE.cl rename to tests/Brahma.FSharp.Tests/Translator/ControlFlow/Expected/Simple.WHILE.cl diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/WHILE.with.complex.condition.cl b/tests/Brahma.FSharp.Tests/Translator/ControlFlow/Expected/WHILE.with.complex.condition.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/WHILE.with.complex.condition.cl rename to tests/Brahma.FSharp.Tests/Translator/ControlFlow/Expected/WHILE.with.complex.condition.cl diff --git a/tests/Brahma.FSharp.Tests/Translator/ControlFlow/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/ControlFlow/Tests.fs new file mode 100644 index 00000000..b24e4add --- /dev/null +++ b/tests/Brahma.FSharp.Tests/Translator/ControlFlow/Tests.fs @@ -0,0 +1,95 @@ +module Brahma.FSharp.Tests.Translator.ControlFlow.Tests + +open Brahma.FSharp +open Expecto +open Brahma.FSharp.Tests.Translator.Common + +let inline createTest translator name fileName quotation = test name { + Helpers.checkCode translator quotation fileName fileName // TODO(remove out file) +} + +let controlFlowTests translator = [ + let inline createTest name = createTest translator name + + <@ fun (range: Range1D) (buf: int clarray) -> if 0 = 2 then buf.[0] <- 1 @> + |> createTest "If Then" "If.Then.cl" + + <@ fun (range: Range1D) (buf: int clarray) -> + if 0 = 2 then + buf.[0] <- 1 + else + buf.[0] <- 2 + @> + |> createTest "If Then Else" "If.Then.Else.cl" + + <@ fun (range: Range1D) (buf: int clarray) -> + for i in 1 .. 3 do + buf.[0] <- i + @> + |> createTest "For Integer Loop" "For.Integer.Loop.cl" + + <@ fun (range: Range1D) (buf: int clarray) -> + let x = 1 + let y = x + 1 + buf.[0] <- y + @> + |> createTest "Sequential bindings" "Sequential.Bindings.cl" + + <@ fun (range: Range1D) (buf: int clarray) -> + if 2 = 0 then + let x = 1 + buf.[0] <- x + else + let i = 2 + buf.[0] <- i + @> + |> createTest "Binding in IF." "Binding.In.IF.cl" + + <@ fun (range: Range1D) (buf: int clarray) -> + for i in 0 .. 3 do + let x = i * i + buf.[0] <- x + @> + |> createTest "Binding in FOR." "Binding.In.FOR.cl" + + <@ fun (range: Range1D) (buf: int clarray) -> + while buf.[0] < 5 do + buf.[0] <- buf.[0] + 1 + @> + |> createTest "Simple WHILE loop." "Simple.WHILE.cl" + + <@ fun (range: Range1D) (buf: int clarray) -> + while buf.[0] < 5 do + let x = buf.[0] + 1 + buf.[0] <- x * x + @> + |> createTest "Binding in WHILE." "Binding.In.WHILE.cl" + + // WHILE with single statement in the body and this stetement is assignment of constant. + // This test translates to openCL correctly but breaks openCL compiler on ubuntu 18.04 + <@ fun (range: Range1D) (buf: int clarray) -> + while true do + buf.[0] <- 1 + @> + |> createTest "WHILE with single statement." "WHILE.with.complex.condition.cl" + + // TODO(paths in test. Race condition?) + <@ fun (range: Range1D) (buf: int clarray) -> + while buf.[0] < 5 && (buf.[1] < 6 || buf.[2] > 2) do + buf.[0] <- 2 + buf.[0] + @> + |> createTest "WHILE with complex condition" "WHILE.with.complex.condition.cl" + + <@ fun (range: Range1D) (buf: int clarray) -> + buf.[0] <- 2 + buf.[1] <- 3 + @> + |> createTest "Simple seq." "Simple.Seq.cl" + + <@ fun (range: Range1D) (buf: int clarray) -> + let x = 2 + buf.[0] <- x + let y = 2 + buf.[1] <- y + @> + |> createTest "Seq with bindings." "Seq.With.Bindings.cl" ] diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/Quotations.Injections.1.cl b/tests/Brahma.FSharp.Tests/Translator/Injection/Expected/Quotations.Injections.1.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/Quotations.Injections.1.cl rename to tests/Brahma.FSharp.Tests/Translator/Injection/Expected/Quotations.Injections.1.cl diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/Quotations.Injections.2.cl b/tests/Brahma.FSharp.Tests/Translator/Injection/Expected/Quotations.Injections.2.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/Quotations.Injections.2.cl rename to tests/Brahma.FSharp.Tests/Translator/Injection/Expected/Quotations.Injections.2.cl diff --git a/tests/Brahma.FSharp.Tests/Translator/Injection/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/Injection/Tests.fs new file mode 100644 index 00000000..144a7180 --- /dev/null +++ b/tests/Brahma.FSharp.Tests/Translator/Injection/Tests.fs @@ -0,0 +1,32 @@ +module Brahma.FSharp.Tests.Translator.Injection.Tests + +open Expecto +open Brahma.FSharp +open Brahma.FSharp.Tests.Translator.Common + +let quotationsInjectionTests translator = [ + let inline checkCode cmd outFile expected = Helpers.checkCode translator cmd outFile expected + + testCase "Quotations injections 1" <| fun _ -> + let myF = <@ fun x -> x * x @> + + let command = + <@ fun (range: Range1D) (buf: int clarray) -> + buf.[0] <- (%myF) 2 + buf.[1] <- (%myF) 4 + @> + + checkCode command "Quotations.Injections.1.gen" "Quotations.Injections.1.cl" + + testCase "Quotations injections 2" <| fun _ -> + let myF = <@ fun x y -> x - y @> + + let command = + <@ fun (range: Range1D) (buf: int clarray) -> + buf.[0] <- (%myF) 2 3 + buf.[1] <- (%myF) 4 5 + @> + + checkCode command "Quotations.Injections.2.gen" "Quotations.Injections.2.cl" + +] diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/Let renamed 2.cl b/tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Expected/Let renamed 2.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/Let renamed 2.cl rename to tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Expected/Let renamed 2.cl diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/Let renamed.cl b/tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Expected/Let renamed.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/Let renamed.cl rename to tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Expected/Let renamed.cl diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/Nested.Function.cl b/tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Expected/Nested.Function.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/Nested.Function.cl rename to tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Expected/Nested.Function.cl diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/Renamer Test.cl b/tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Expected/Renamer Test.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/Renamer Test.cl rename to tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Expected/Renamer Test.cl diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/Template Test 0.cl b/tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Expected/Template Test 0.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/Template Test 0.cl rename to tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Expected/Template Test 0.cl diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/Template Test 1.cl b/tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Expected/Template Test 1.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/Template Test 1.cl rename to tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Expected/Template Test 1.cl diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/Template Test 10.cl b/tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Expected/Template Test 10.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/Template Test 10.cl rename to tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Expected/Template Test 10.cl diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/Template Test 11.cl b/tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Expected/Template Test 11.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/Template Test 11.cl rename to tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Expected/Template Test 11.cl diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/Template Test 12.cl b/tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Expected/Template Test 12.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/Template Test 12.cl rename to tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Expected/Template Test 12.cl diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/Template Test 13.cl b/tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Expected/Template Test 13.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/Template Test 13.cl rename to tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Expected/Template Test 13.cl diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/Template Test 14.cl b/tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Expected/Template Test 14.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/Template Test 14.cl rename to tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Expected/Template Test 14.cl diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/Template Test 15.cl b/tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Expected/Template Test 15.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/Template Test 15.cl rename to tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Expected/Template Test 15.cl diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/Template Test 16.cl b/tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Expected/Template Test 16.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/Template Test 16.cl rename to tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Expected/Template Test 16.cl diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/Template Test 2.cl b/tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Expected/Template Test 2.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/Template Test 2.cl rename to tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Expected/Template Test 2.cl diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/Template Test 3.cl b/tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Expected/Template Test 3.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/Template Test 3.cl rename to tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Expected/Template Test 3.cl diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/Template Test 4.cl b/tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Expected/Template Test 4.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/Template Test 4.cl rename to tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Expected/Template Test 4.cl diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/Template Test 5.cl b/tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Expected/Template Test 5.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/Template Test 5.cl rename to tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Expected/Template Test 5.cl diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/Template Test 6.cl b/tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Expected/Template Test 6.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/Template Test 6.cl rename to tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Expected/Template Test 6.cl diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/Template Test 7.cl b/tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Expected/Template Test 7.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/Template Test 7.cl rename to tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Expected/Template Test 7.cl diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/Template Test 8.cl b/tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Expected/Template Test 8.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/Template Test 8.cl rename to tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Expected/Template Test 8.cl diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/Template Test 9.cl b/tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Expected/Template Test 9.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/Template Test 9.cl rename to tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Expected/Template Test 9.cl diff --git a/tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Tests.fs new file mode 100644 index 00000000..606b1d3b --- /dev/null +++ b/tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Tests.fs @@ -0,0 +1,298 @@ +module Brahma.FSharp.Tests.Translator.LambdaLifting.Tests + +open Expecto +open Brahma.FSharp +open Brahma.FSharp.Tests.Translator.Common + +let lambdaLiftingTests translator = [ + let inline checkCode cmd outFile expected = checkCode translator cmd outFile expected + + testCase "Template Let Transformation Test 0" <| fun _ -> + let command = + <@ fun (range: Range1D) (buf: int clarray) -> + let f = 3 + buf.[0] <- f + @> + + checkCode command "Template Test 0.gen" "Template Test 0.cl" + + testCase "Template Let Transformation Test 1" <| fun _ -> + let command = + <@ fun (range: Range1D) (buf: int clarray) -> + let f = + let x = 3 + x + + buf.[0] <- f + @> + + checkCode command "Template Test 1.gen" "Template Test 1.cl" + + testCase "Template Let Transformation Test 2" <| fun _ -> + let command = + <@ fun (range: Range1D) (buf: int clarray) -> + let f = + let x = + let y = 3 + y + + x + + buf.[0] <- f + @> + + checkCode command "Template Test 2.gen" "Template Test 2.cl" + + testCase "Template Let Transformation Test 3" <| fun _ -> + let command = + <@ fun (range: Range1D) (buf: int clarray) -> + let f = + let f = 5 + f + + buf.[0] <- f + @> + + checkCode command "Template Test 3.gen" "Template Test 3.cl" + + testCase "Template Let Transformation Test 4" <| fun _ -> + let command = + <@ fun (range: Range1D) (buf: int clarray) -> + let f = + let f = + let f = 5 + f + + f + + buf.[0] <- f + @> + + checkCode command "Template Test 4.gen" "Template Test 4.cl" + + testCase "Template Let Transformation Test 5" <| fun _ -> + let command = + <@ fun (range: Range1D) (buf: int clarray) -> + let f a b = + let x y z = y + z + x a b + + buf.[0] <- f 1 7 + @> + + checkCode command "Template Test 5.gen" "Template Test 5.cl" + + testCase "Template Let Transformation Test 6" <| fun _ -> + let command = + <@ fun (range: Range1D) (buf: int clarray) -> + let f x y = + let x = x + x + y + + buf.[0] <- f 7 8 + @> + + checkCode command "Template Test 6.gen" "Template Test 6.cl" + + testCase "Template Let Transformation Test 7" <| fun _ -> + let command = + <@ fun (range: Range1D) (buf: int clarray) -> + let f y = + let x y = 6 - y + x y + + buf.[0] <- f 7 + @> + + checkCode command "Template Test 7.gen" "Template Test 7.cl" + + testCase "Template Let Transformation Test 8" <| fun _ -> + let command = + <@ fun (range: Range1D) (m: int clarray) -> + let p = m.[0] + + let x n = + let l = m.[9] + let g k = k + m.[0] + m.[1] + + let r = + let y a = + let x = 5 - n + (g 4) + let z t = m.[2] + a - t + z (a + x + l) + + y 6 + + r + m.[3] + + m.[0] <- x 7 + @> + + checkCode command "Template Test 8.gen" "Template Test 8.cl" + + testCase "Template Let Transformation Test 9" <| fun _ -> + let command = + <@ fun (range: Range1D) (buf: int clarray) -> + let x n = + let r = 8 + let h = r + n + h + + buf.[0] <- x 9 + @> + + checkCode command "Template Test 9.gen" "Template Test 9.cl" + + testCase "Template Let Transformation Test 10" <| fun _ -> + let command = + <@ fun (range: Range1D) (buf: int clarray) -> + let p = 9 + + let x n b = + let t = 0 + n + b + t + + buf.[0] <- x 7 9 + @> + + checkCode command "Template Test 10.gen" "Template Test 10.cl" + + testCase "Template Let Transformation Test 11" <| fun _ -> + let command = + <@ fun (range: Range1D) (buf: int clarray) -> + let p = 1 + + let m = + let r l = l + p + r 9 + + let z k = k + 1 + buf.[0] <- m + @> + + checkCode command "Template Test 11.gen" "Template Test 11.cl" + + testCase "Template Let Transformation Test 12" <| fun _ -> + let command = + <@ fun (range: Range1D) (buf: int clarray) -> + let f x y = + let y = y + let y = y + let g x m = m + x + g x y + + buf.[0] <- f 1 7 + @> + + checkCode command "Template Test 12.gen" "Template Test 12.cl" + + testCase "Template Let Transformation Test 13" <| fun _ -> + let command = + <@ fun (range: Range1D) (buf: int clarray) -> + let f y = + let y = y + let y = y + let g m = m + 1 + g y + + buf.[0] <- f 7 + @> + + checkCode command "Template Test 13.gen" "Template Test 13.cl" + + testCase "Template Let Transformation Test 14" <| fun _ -> + let command = + <@ fun (range: Range1D) (buf: int clarray) -> + let f (y: int) = + let y = y + let y = y + + let g (m: int) = + let g r t = r + y - t + let n o = o - (g y 2) + n 5 + + g y + + let z y = y - 2 + buf.[0] <- f (z 7) + @> + + checkCode command "Template Test 14.gen" "Template Test 14.cl" + + testCase "Template Let Transformation Test 15" <| fun _ -> + let command = + <@ fun (range: Range1D) (buf: int clarray) -> + let f y = + let Argi index = if index = 0 then buf.[1] else buf.[2] + Argi y + + buf.[0] <- f 0 + @> + + checkCode command "Template Test 15.gen" "Template Test 15.cl" + + testCase "Template Let Transformation Test 16" <| fun _ -> + let command = + <@ fun (range: Range1D) (buf: int clarray) -> + let f y = + if y = 0 then + let z a = a + 1 + z 9 + else + buf.[2] + + buf.[0] <- f 0 + @> + + checkCode command "Template Test 16.gen" "Template Test 16.cl" + + testCase "Let renamed" <| fun _ -> + let command = + <@ fun (range: Range1D) (buf: int clarray) -> + let f x = + let g = 1 + x + g + + buf.[0] <- f 1 + @> + + checkCode command "Let renamed.gen" "Let renamed.cl" + + testCase "Let renamed 2" <| fun _ -> + let command = + <@ fun (range: Range1D) (buf: int clarray) -> + let f m k = + let g q w = 1 + q + w + let t p = 7 - p + (g 1 2) - m * k / (t 53) + + buf.[0] <- f 1 4 + @> + + checkCode command "Let renamed 2.gen" "Let renamed 2.cl" + + testCase "Renamer Test" <| fun _ -> + let command = + <@ fun (range: Range1D) (buf: int clarray) -> + let f x y = + let y = y + let y = y + let g x m = m + x + g x y + + buf.[0] <- f 1 7 + @> + + checkCode command "Renamer Test.gen" "Renamer Test.cl" + + testCase "Nested functions" <| fun _ -> + let command = + <@ fun (range: Range1D) (buf: int clarray) -> + let f x y = x - y + buf.[0] <- f 2 3 + buf.[1] <- f 4 5 + @> + + checkCode command "Nested.Function.gen" "Nested.Function.cl" +] diff --git a/tests/Brahma.FSharp.Tests/Translator/LangExtensions/Atomic.fs b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/Atomic.fs new file mode 100644 index 00000000..2add17ba --- /dev/null +++ b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/Atomic.fs @@ -0,0 +1,55 @@ +module Brahma.FSharp.Tests.Translator.LangExtensions.Atomic + +open Expecto +open Brahma.FSharp +open Brahma.FSharp.Tests.Translator.Common + +let test translator= + + [ testCase "Multiple local values in atomic operations" <| fun () -> + let kernel = + <@ + fun (ndRange: Range1D) (v: int) -> + let mutable firstMaxIndex = local () + let mutable secondMaxIndex = local () + let mutable value = local () + + if ndRange.LocalID0 = 0 then + firstMaxIndex <- 0 + secondMaxIndex <- 0 + value <- v + + barrierLocal () + + atomic (max) firstMaxIndex value |> ignore + atomic (max) secondMaxIndex value |> ignore + @> + + Helpers.openclTranslate translator kernel |> ignore +] + +let commonApiTests translator = [ + // TODO is it correct? + ptestCase "Using atomic in lambda should not raise exception if first parameter passed" <| fun () -> + let command = + <@ + fun (range: Range1D) (buffer: int[]) -> + let g = atomic (fun x y -> x + 1) buffer.[0] + g 5 |> ignore + @> + + command |> Helpers.openclTranslate translator |> ignore + + // TODO is it correct? + ptestCase "Using atomic in lambda should raise exception if first parameter is argument" <| fun () -> + let command = + <@ + fun (range: Range1D) (buffer: int[]) -> + let g x y = atomic (+) x y + g buffer.[0] 6 |> ignore + @> + + Expect.throwsT + <| fun () -> command |> Helpers.openclTranslate translator |> ignore + <| "Exception should be thrown" +] diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/Barrier.Full.cl b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/Barrier/Expected/Barrier.Full.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/Barrier.Full.cl rename to tests/Brahma.FSharp.Tests/Translator/LangExtensions/Barrier/Expected/Barrier.Full.cl diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/Barrier.Global.cl b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/Barrier/Expected/Barrier.Global.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/Barrier.Global.cl rename to tests/Brahma.FSharp.Tests/Translator/LangExtensions/Barrier/Expected/Barrier.Global.cl diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/Barrier.Local.cl b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/Barrier/Expected/Barrier.Local.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/Barrier.Local.cl rename to tests/Brahma.FSharp.Tests/Translator/LangExtensions/Barrier/Expected/Barrier.Local.cl diff --git a/tests/Brahma.FSharp.Tests/Translator/LangExtensions/Barrier/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/Barrier/Tests.fs new file mode 100644 index 00000000..a6f3751f --- /dev/null +++ b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/Barrier/Tests.fs @@ -0,0 +1,21 @@ +module Brahma.FSharp.Tests.Translator.Barrier.Tests + +open Expecto +open Brahma.FSharp +open Brahma.FSharp.Tests.Translator.Common + +let barrierTests translator = [ + let inline checkCode cmd outFile expected = Helpers.checkCode translator cmd outFile expected + + testCase "Local barrier translation tests" <| fun () -> + let command = <@ fun (range: Range1D) -> barrierLocal () @> + checkCode command "Barrier.Local.gen" "Barrier.Local.cl" + + testCase "Global barrier translation tests" <| fun () -> + let command = <@ fun (range: Range1D) -> barrierGlobal () @> + checkCode command "Barrier.Global.gen" "Barrier.Global.cl" + + testCase "Full barrier translation tests" <| fun () -> + let command = <@ fun (range: Range1D) -> barrierFull () @> + checkCode command "Barrier.Full.gen" "Barrier.Full.cl" +] diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/LocalID1D.cl b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalID/Expected/LocalID1D.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/LocalID1D.cl rename to tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalID/Expected/LocalID1D.cl diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/LocalID2D.cl b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalID/Expected/LocalID2D.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/LocalID2D.cl rename to tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalID/Expected/LocalID2D.cl diff --git a/tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalID/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalID/Tests.fs new file mode 100644 index 00000000..ca9e48ae --- /dev/null +++ b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalID/Tests.fs @@ -0,0 +1,28 @@ +module Brahma.FSharp.Tests.Translator.LocalId.Tests + +open Brahma.FSharp +open Expecto +open Brahma.FSharp.Tests.Translator.Common + +let basicLocalIdTests translator = [ + let inline checkCode cmd outFile expected = Helpers.checkCode translator cmd outFile expected + + testCase "LocalID of 1D" <| fun _ -> + let command = + <@ fun (range: Range1D) (buf: int clarray) -> + let id = range.LocalID0 + buf.[id] <- 0 + @> + + checkCode command "LocalID1D.gen" "LocalID1D.cl" + + testCase "LocalID of 2D" <| fun _ -> + let command = + <@ fun (range: Range2D) (buf: int clarray) -> + let v = range.LocalID0 + let id = range.LocalID1 + buf.[id] <- v + @> + + checkCode command "LocalID2D.gen" "LocalID2D.cl" +] diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/LocalMemory.float.cl b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalMemory/Expected/LocalMemory.float.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/LocalMemory.float.cl rename to tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalMemory/Expected/LocalMemory.float.cl diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/LocalMemory.int [].cl b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalMemory/Expected/LocalMemory.int [].cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/LocalMemory.int [].cl rename to tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalMemory/Expected/LocalMemory.int [].cl diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/LocalMemory.int.cl b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalMemory/Expected/LocalMemory.int.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/LocalMemory.int.cl rename to tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalMemory/Expected/LocalMemory.int.cl diff --git a/tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalMemory/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalMemory/Tests.fs new file mode 100644 index 00000000..e1585de7 --- /dev/null +++ b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalMemory/Tests.fs @@ -0,0 +1,36 @@ +module Brahma.FSharp.Tests.Translator.LocalMemory.Tests + +open Expecto +open Brahma.FSharp +open Brahma.FSharp.Tests.Translator.Common + +let localMemoryTests translator = [ + let inline checkCode cmd outFile expected = Helpers.checkCode translator cmd outFile expected + + testCase "Local int" <| fun _ -> + let command = + <@ fun (range: Range1D) -> + let mutable x = local () + x <- 0 + @> + + checkCode command "LocalMemory.int.gen" "LocalMemory.int.cl" + + testCase "Local float" <| fun _ -> + let command = + <@ fun (range: Range1D) -> + let mutable x = local () + x <- 0.0 + @> + + checkCode command "LocalMemory.float.gen" "LocalMemory.float.cl" + + testCase "Local int array" <| fun _ -> + let command = + <@ fun (range: Range1D) -> + let xs = localArray 5 + xs.[range.LocalID0] <- range.LocalID0 + @> + + checkCode command "LocalMemory.int [].gen" "LocalMemory.int [].cl" +] diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/WorkSize1D.cl b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/WorkSize/Expected/WorkSize1D.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/WorkSize1D.cl rename to tests/Brahma.FSharp.Tests/Translator/LangExtensions/WorkSize/Expected/WorkSize1D.cl diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/WorkSize2D.cl b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/WorkSize/Expected/WorkSize2D.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/WorkSize2D.cl rename to tests/Brahma.FSharp.Tests/Translator/LangExtensions/WorkSize/Expected/WorkSize2D.cl diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/WorkSize3D.cl b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/WorkSize/Expected/WorkSize3D.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/WorkSize3D.cl rename to tests/Brahma.FSharp.Tests/Translator/LangExtensions/WorkSize/Expected/WorkSize3D.cl diff --git a/tests/Brahma.FSharp.Tests/Translator/LangExtensions/WorkSize/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/WorkSize/Tests.fs new file mode 100644 index 00000000..1f5c6eb5 --- /dev/null +++ b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/WorkSize/Tests.fs @@ -0,0 +1,42 @@ +module Brahma.FSharp.Tests.Translator.WorkSize.Tests + +open Brahma.FSharp +open Expecto +open Brahma.FSharp.Tests.Translator.Common + +let basicWorkSizeTests translator = [ + let inline checkCode cmd outFile expected = Helpers.checkCode translator cmd outFile expected + + testCase "WorkSize of 1D" <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: int clarray) -> + let gSize = range.GlobalWorkSize + let lSize = range.LocalWorkSize + () + @> + + checkCode command "WorkSize1D.gen" "WorkSize1D.cl" + + testCase "WorkSize of 2D" <| fun _ -> + let command = + <@ + fun (range: Range2D) (buf: int clarray) -> + let (gSizeX, gSizeY) = range.GlobalWorkSize + let (lSizeX, lSizeY) = range.LocalWorkSize + () + @> + + checkCode command "WorkSize2D.gen" "WorkSize2D.cl" + + testCase "WorkSize of 3D" <| fun _ -> + let command = + <@ + fun (range: Range3D) (buf: int clarray) -> + let (gSizeX, gSizeY, gSizeZ) = range.GlobalWorkSize + let (lSizeX, lSizeY, lSizeZ) = range.LocalWorkSize + () + @> + + checkCode command "WorkSize3D.gen" "WorkSize3D.cl" +] diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/Binding.And.FOR.Counter.Conflict.1.cl b/tests/Brahma.FSharp.Tests/Translator/NamesResolving/Expected/Binding.And.FOR.Counter.Conflict.1.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/Binding.And.FOR.Counter.Conflict.1.cl rename to tests/Brahma.FSharp.Tests/Translator/NamesResolving/Expected/Binding.And.FOR.Counter.Conflict.1.cl diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/Binding.And.FOR.Counter.Conflict.2.cl b/tests/Brahma.FSharp.Tests/Translator/NamesResolving/Expected/Binding.And.FOR.Counter.Conflict.2.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/Binding.And.FOR.Counter.Conflict.2.cl rename to tests/Brahma.FSharp.Tests/Translator/NamesResolving/Expected/Binding.And.FOR.Counter.Conflict.2.cl diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/Binding.And.FOR.Counter.Conflict.3.cl b/tests/Brahma.FSharp.Tests/Translator/NamesResolving/Expected/Binding.And.FOR.Counter.Conflict.3.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/Binding.And.FOR.Counter.Conflict.3.cl rename to tests/Brahma.FSharp.Tests/Translator/NamesResolving/Expected/Binding.And.FOR.Counter.Conflict.3.cl diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/Binding.And.FOR.Counter.Conflict.4.cl b/tests/Brahma.FSharp.Tests/Translator/NamesResolving/Expected/Binding.And.FOR.Counter.Conflict.4.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/Binding.And.FOR.Counter.Conflict.4.cl rename to tests/Brahma.FSharp.Tests/Translator/NamesResolving/Expected/Binding.And.FOR.Counter.Conflict.4.cl diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/Bindings.With.Equal.Names.cl b/tests/Brahma.FSharp.Tests/Translator/NamesResolving/Expected/Bindings.With.Equal.Names.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/Bindings.With.Equal.Names.cl rename to tests/Brahma.FSharp.Tests/Translator/NamesResolving/Expected/Bindings.With.Equal.Names.cl diff --git a/tests/Brahma.FSharp.Tests/Translator/NamesResolving/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/NamesResolving/Tests.fs new file mode 100644 index 00000000..5d60112a --- /dev/null +++ b/tests/Brahma.FSharp.Tests/Translator/NamesResolving/Tests.fs @@ -0,0 +1,63 @@ +module Brahma.FSharp.Tests.Translator.NamesResolving.Tests + +open Brahma.FSharp +open Expecto +open Brahma.FSharp.Tests.Translator.Common + +let namesResolvingTests translator = [ + let inline checkCode cmd outFile expected = checkCode translator cmd outFile expected + + testCase "Bindings with equal names." <| fun _ -> + let command = + <@ fun (range: Range1D) (buf: int clarray) -> + let x = 2 + buf.[0] <- x + let x = 3 + buf.[1] <- x + @> + + checkCode command "Bindings.With.Equal.Names.gen" "Bindings.With.Equal.Names.cl" + + testCase "Binding and FOR counter conflict 1." <| fun _ -> + let command = + <@ fun (range: Range1D) (buf: int clarray) -> + let i = 2 + + for i in 1 .. 2 do + buf.[1] <- i + @> + + checkCode command "Binding.And.FOR.Counter.Conflict.1.gen" "Binding.And.FOR.Counter.Conflict.1.cl" + + testCase "Binding and FOR counter conflict 2." <| fun _ -> + let command = + <@ fun (range: Range1D) (buf: int clarray) -> + for i in 1 .. 2 do + let i = 2 + buf.[1] <- i + @> + + checkCode command "Binding.And.FOR.Counter.Conflict.2.gen" "Binding.And.FOR.Counter.Conflict.2.cl" + + testCase "Binding and FOR counter conflict 3." <| fun _ -> + let command = + <@ fun (range: Range1D) (buf: int clarray) -> + for i in 0 .. 1 do + let i = i + 2 + buf.[i] <- 2 + @> + + checkCode command "Binding.And.FOR.Counter.Conflict.3.gen" "Binding.And.FOR.Counter.Conflict.3.cl" + + testCase "Binding and FOR counter conflict 4." <| fun _ -> + let command = + <@ fun (range: Range1D) (buf: int clarray) -> + let i = 1 + + for i in 0 .. i + 1 do + let i = i + 2 + buf.[i] <- 2 + @> + + checkCode command "Binding.And.FOR.Counter.Conflict.4.gen" "Binding.And.FOR.Counter.Conflict.4.cl" +] diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/Printf test 1.cl b/tests/Brahma.FSharp.Tests/Translator/Printf/Expected/Printf test 1.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/Printf test 1.cl rename to tests/Brahma.FSharp.Tests/Translator/Printf/Expected/Printf test 1.cl diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/Printf test 2.cl b/tests/Brahma.FSharp.Tests/Translator/Printf/Expected/Printf test 2.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/Printf test 2.cl rename to tests/Brahma.FSharp.Tests/Translator/Printf/Expected/Printf test 2.cl diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/Printf test 3.cl b/tests/Brahma.FSharp.Tests/Translator/Printf/Expected/Printf test 3.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/Printf test 3.cl rename to tests/Brahma.FSharp.Tests/Translator/Printf/Expected/Printf test 3.cl diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/Printf test 4.cl b/tests/Brahma.FSharp.Tests/Translator/Printf/Expected/Printf test 4.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/Printf test 4.cl rename to tests/Brahma.FSharp.Tests/Translator/Printf/Expected/Printf test 4.cl diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/Printf test 5.cl b/tests/Brahma.FSharp.Tests/Translator/Printf/Expected/Printf test 5.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/Printf test 5.cl rename to tests/Brahma.FSharp.Tests/Translator/Printf/Expected/Printf test 5.cl diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/Printf test 6.cl b/tests/Brahma.FSharp.Tests/Translator/Printf/Expected/Printf test 6.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/Printf test 6.cl rename to tests/Brahma.FSharp.Tests/Translator/Printf/Expected/Printf test 6.cl diff --git a/tests/Brahma.FSharp.Tests/Translator/Printf/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/Printf/Tests.fs new file mode 100644 index 00000000..7c008f45 --- /dev/null +++ b/tests/Brahma.FSharp.Tests/Translator/Printf/Tests.fs @@ -0,0 +1,49 @@ +module Brahma.FSharp.Tests.Translator.Printf.Tests + +open Expecto +open Brahma.FSharp +open Brahma.FSharp.Tests.Translator.Common + +let printfTests translator = [ + let inline checkCode cmd outFile expected = Helpers.checkCode translator cmd outFile expected + + testCase "Printf test 1" <| fun _ -> + let command = <@ fun (range: Range1D) -> printf "%d %f" 10 15.0 @> + checkCode command "Printf test 1.gen" "Printf test 1.cl" + + testCase "Printf test 2" <| fun _ -> + let command = + <@ fun (range: Range1D) (xs: int clarray) -> + let gid = range.GlobalID0 + let x = 10 + + printf "%d %d" x xs.[gid] + @> + + checkCode command "Printf test 2.gen" "Printf test 2.cl" + + testCase "Printf test 3" <| fun _ -> + let command = + <@ fun (range: Range1D) (xs: int clarray) -> + let mutable i = 0 + + while i < 10 do + xs.[0] <- i * 2 + printf "i = %d, xs.[0]*10 = %d\n" i (xs.[0] + 10) + i <- i + 1 + @> + + checkCode command "Printf test 3.gen" "Printf test 3.cl" + + testCase "Printf test 4: printfn" <| fun _ -> + let command = <@ fun (range: Range1D) -> printfn "%d %f" 10 15.0 @> + checkCode command "Printf test 4.gen" "Printf test 4.cl" + + testCase "Printf test 5: printf without args" <| fun _ -> + let command = <@ fun (range: Range1D) -> printf "I am complied" @> + checkCode command "Printf test 5.gen" "Printf test 5.cl" + + testCase "Printf test 6: printfn without args" <| fun _ -> + let command = <@ fun (range: Range1D) -> printfn "I am complied too" @> + checkCode command "Printf test 6.gen" "Printf test 6.cl" +] diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Common.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Common.fs new file mode 100644 index 00000000..53288471 --- /dev/null +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Common.fs @@ -0,0 +1,40 @@ +module Brahma.FSharp.Tests.Translator.QuatationTransformation.Common + +open Expecto +open FSharp.Quotations +open Brahma.FSharp.OpenCL.Translator + +[] +module Helpers = + let equalsMessage = "Values should be the same." + + let rec renameUnitVar (expr: Expr) = + let replaceUnitVar (var: Var) = + if var.Type = typeof then + Var("unitVar", var.Type, var.IsMutable) + else + var + + match expr with + | ExprShape.ShapeVar var -> Expr.Var(replaceUnitVar var) + | ExprShape.ShapeLambda (var, body) -> Expr.Lambda(replaceUnitVar var, renameUnitVar body) + | ExprShape.ShapeCombination (shapeComboObj, exprList) -> + ExprShape.RebuildShapeCombination(shapeComboObj, List.map renameUnitVar exprList) + + let openclTransformQuotation (translator: FSQuotationToOpenCLTranslator) (expr: Expr) = + translator.TransformQuotation expr + + let assertExprEqual (actual: Expr) (expected: Expr) (msg: string) = + let actual' = renameUnitVar actual + let expected' = renameUnitVar expected + + Expect.equal + <| actual'.ToString() + <| expected'.ToString() + <| msg + + let assertMethodEqual (actual: Var * Expr) (expected: Var * Expr) = + Expect.equal (fst actual).Name (fst expected).Name "Method names should be equal" + + assertExprEqual (snd actual) (snd expected) + <| $"Method bodies of %s{(fst actual).Name} is not equal" diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/LambdaLifting.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/LambdaLifting.fs new file mode 100644 index 00000000..879f5499 --- /dev/null +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/LambdaLifting.fs @@ -0,0 +1,97 @@ +module Brahma.FSharp.Tests.Translator.QuatationTransformation.LambdaLifting + +open Expecto +open Brahma.FSharp.OpenCL.Translator.QuotationTransformers +open Common + +let lambdaLiftingTests = + let genParameterLiftTest name expr expected = + test name { + let actual = LambdaLifting.parameterLiftExpr expr + + assertExprEqual actual expected equalsMessage + } + + [ + genParameterLiftTest + "Test 1" + <@ let x = 1 + let addToX y = x + y + addToX 2 + @> + <@ let x = 1 + let addToX x y = x + y + addToX x 2 + @> + + genParameterLiftTest + "Test 2" + <@ let x = 1 + let z = x + + let addToX y = // freeVars: [x, z] + x + y + z + + let f z1 = // freeVars: [], addToX freeVars: [x, z] + 2 + addToX z1 + + f 3 + @> + <@ let x = 1 + let z = x + + let addToX x z y = x + y + z + let f x z z1 = 2 + addToX x z z1 + f x z 3 + @> + + genParameterLiftTest + "Test 3" + <@ let mainX = "global variable" + let mainY = "global variable" + let mainZ = "global variable" + + let foo fooX = + let fooY = "local variable of foo" + let bar barX = mainX + fooY + barX + bar fooX + mainY + + foo mainZ + @> + <@ let mainX = "global variable" + let mainY = "global variable" + let mainZ = "global variable" + + let foo mainX mainY fooX = + let fooY = "local variable of foo" + let bar fooY mainX barX = mainX + fooY + barX + bar fooY mainX fooX + mainY + + foo mainX mainY mainZ + @> + + genParameterLiftTest + "Test 4" + <@ let x0 = 0 + + let f x1 = + let g x2 = + let h x3 = x3 + x0 + h x2 + + g x1 + + f x0 + @> + <@ let x0 = 0 + + let f x0 x1 = + let g x0 x2 = + let h x0 x3 = x3 + x0 + h x0 x2 + + g x0 x1 + + f x0 x0 + @> + ] diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Transformation.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Transformation.fs new file mode 100644 index 00000000..398bb39b --- /dev/null +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Transformation.fs @@ -0,0 +1,175 @@ +module Brahma.FSharp.Tests.Translator.QuatationTransformation.Transformation + +open Expecto +open Brahma.FSharp +open FSharp.Quotations +open Common + +let quotationTransformerTest translator = + let assertMethodListsEqual (actual: list) (expected: list) = + Expect.equal actual.Length expected.Length "List sizes should be equal" + + List.zip actual expected + |> List.iter (fun (x, y) -> assertMethodEqual x y) + + let makeMethods (expr: Expr) = + let rec go (expr: Expr) = + match expr with + | Patterns.Let (var, body, inExpr) -> + let methods, kernel = go inExpr + (var, body) :: methods, kernel + | _ -> [], expr + + let methods, kernelExpr = go expr + kernelExpr, methods + + let genTest testCase name expr expected = + let expectedKernelExpr, expectedMethods = makeMethods expected + + testCase name <| fun _ -> + let (actualKernelExpr, actualKernelMethods) = expr |> openclTransformQuotation translator + + assertMethodListsEqual actualKernelMethods expectedMethods + assertExprEqual actualKernelExpr expectedKernelExpr "kernels not equals" + + [ + genTest + testCase + "Test 0" + <@ fun (range: Range1D) (buf: array) -> + let mutable x = 1 + let f y = x <- y + f 10 + buf.[0] <- x + @> + <@ + let f (xRef: _ ref) (y: int) = xRef.Value <- y + + fun (range: Range1D) (buf: array) -> + let mutable x = 1 + let xRef = ref x + + f xRef 10 + buf.[0] <- xRef.Value + @> + + genTest + testCase + "Test 1" + <@ fun (range: Range1D) (buf: array) -> + let mutable x = 1 + let f y = x <- x + y + f 10 + buf.[0] <- x + @> + <@ + let f (xRef: _ ref) (y: int) = xRef.Value <- xRef.Value + y + + fun (range: Range1D) (buf: array) -> + let mutable x = 1 + let xRef = ref x + + f xRef 10 + buf.[0] <- xRef.Value + @> + + genTest + testCase + "Test 2: simple lambda lifting without capturing variables" + <@ fun (range: Range1D) -> + let f x = + let g y = y + 1 + g x + + f 2 @> + <@ let g y = y + 1 + let f x = g x + fun (range: Range1D) -> f 2 @> + + genTest + testCase + "Test 3: simple lambda lifting with capturing variables" + <@ fun (range: Range1D) -> + let f x = + let g y = y + x + g (x + 1) + + f 2 + @> + <@ let g x y = y + x + let f x = g x (x + 1) + fun (range: Range1D) -> f 2 + @> + + genTest + testCase + "Test 4" + <@ fun (range: Range1D) (arr: array) -> + let x = + let mutable y = 0 + + let addToY x = y <- y + x + + for i in 0 .. 10 do + addToY arr.[i] + + y + + x + @> + <@ let addToY (yRef: _ ref) x = yRef.Value <- yRef.Value + x + + let x1UnitFunc (arr: array) = + let y = 0 + let yRef = ref y + + for i in 0 .. 10 do + addToY yRef arr.[i] + + yRef.Value + + fun (range: Range1D) (arr: array) -> + let x1 = x1UnitFunc arr + x1 + @> + + genTest + testCase + "Test 5" + <@ fun (range: Range1D) (arr: array) -> + let mutable x = if 0 > 1 then 2 else 3 + + let mutable y = + for i in 0 .. 10 do + x <- x + 1 + + x + 1 + + let z = x + y + + let f () = arr.[0] <- x + y + z + f () + @> + <@ let xUnitFunc () = if 0 > 1 then 2 else 3 + + let yUnitFunc (xRef: _ ref) = + for i in 0 .. 10 do + xRef.Value <- xRef.Value + 1 + + xRef.Value + 1 + + let f (arr: array) (xRef: _ ref) (yRef: _ ref) z + = arr.[0] <- xRef.Value + yRef.Value + z + + fun (range: Range1D) (arr: array) -> + let mutable x = xUnitFunc () + let xRef = ref x + + let mutable y = yUnitFunc xRef + let yRef = ref y + + let z = xRef.Value + yRef.Value + + f arr xRef yRef z + @> + ] diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/VarDefsToLambda.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/VarDefsToLambda.fs new file mode 100644 index 00000000..2ee8b078 --- /dev/null +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/VarDefsToLambda.fs @@ -0,0 +1,87 @@ +module Brahma.FSharp.Tests.Translator.QuatationTransformation.VarDefsToLambda + +open Expecto +open Brahma.FSharp.OpenCL.Translator.QuotationTransformers +open Common + +let varDefsToLambdaTest = + let genVarDefToLambdaTest name expr expected = + test name { + let actual = VarDefsToLambdaTransformer.transformVarDefsToLambda expr + + assertExprEqual actual expected equalsMessage + } + + [ + genVarDefToLambdaTest + "Test 1" + <@ let x = + let mutable y = 0 + + for i in 1 .. 10 do + y <- y + i + + y + + x + @> + <@ let x = + let xUnitFunc () = + let mutable y = 0 + + for i in 1 .. 10 do + y <- y + i + + y + + xUnitFunc () + + x + @> + + genVarDefToLambdaTest + "Test 2: we need to go deeper" + <@ let x = + let mutable y = + if true then + let z = 10 + z + 1 + else + let z = 20 + z + 2 + + for i in 1 .. 10 do + let z = if false then 10 else 20 + y <- y + i + z + + y + + x + @> + <@ let x = + let xUnitFunc () = + let mutable y = + let yUnitFunc () = + if true then + let z = 10 + z + 1 + else + let z = 20 + z + 2 + + yUnitFunc () + + for i in 1 .. 10 do + let z = + let zUnitFunc () = if false then 10 else 20 + zUnitFunc () + + y <- y + i + z + + y + + xUnitFunc () + + x + @> + ] diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/MergeKernel.cl b/tests/Brahma.FSharp.Tests/Translator/Specific/Expected/MergeKernel.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/MergeKernel.cl rename to tests/Brahma.FSharp.Tests/Translator/Specific/Expected/MergeKernel.cl diff --git a/tests/Brahma.FSharp.Tests/Translator/Specific/MergePath.fs b/tests/Brahma.FSharp.Tests/Translator/Specific/MergePath.fs new file mode 100644 index 00000000..92e3874e --- /dev/null +++ b/tests/Brahma.FSharp.Tests/Translator/Specific/MergePath.fs @@ -0,0 +1,151 @@ +module Brahma.FSharp.Tests.Translator.Specific.MergePath + +open Brahma.FSharp.Tests.Translator.Common +open Expecto +open Brahma.FSharp +open Brahma.FSharp.OpenCL.Translator + +let specificTests (translator: FSQuotationToOpenCLTranslator) = [ + let inline checkCode cmd outFile expected = Helpers.checkCode translator cmd outFile expected + + testCase "Merge kernel" <| fun () -> + let command workGroupSize = + <@ + fun (ndRange: Range1D) + firstSide + secondSide + sumOfSides + (firstRowsBuffer: ClArray) + (firstColumnsBuffer: ClArray) + (firstValuesBuffer: ClArray) + (secondRowsBuffer: ClArray) + (secondColumnsBuffer: ClArray) + (secondValuesBuffer: ClArray) + (allRowsBuffer: ClArray) + (allColumnsBuffer: ClArray) + (allValuesBuffer: ClArray) -> + + let i = ndRange.GlobalID0 + + let mutable beginIdxLocal = local () + let mutable endIdxLocal = local () + let localID = ndRange.LocalID0 + + if localID < 2 then + let mutable x = localID * (workGroupSize - 1) + i - 1 + + if x >= sumOfSides then + x <- sumOfSides - 1 + + let diagonalNumber = x + + let mutable leftEdge = diagonalNumber + 1 - secondSide + if leftEdge < 0 then leftEdge <- 0 + + let mutable rightEdge = firstSide - 1 + + if rightEdge > diagonalNumber then + rightEdge <- diagonalNumber + + while leftEdge <= rightEdge do + let middleIdx = (leftEdge + rightEdge) / 2 + + let firstIndex: uint64 = + ((uint64 firstRowsBuffer.[middleIdx]) <<< 32) + ||| (uint64 firstColumnsBuffer.[middleIdx]) + + let secondIndex: uint64 = + ((uint64 secondRowsBuffer.[diagonalNumber - middleIdx]) + <<< 32) + ||| (uint64 secondColumnsBuffer.[diagonalNumber - middleIdx]) + + if firstIndex < secondIndex then + leftEdge <- middleIdx + 1 + else + rightEdge <- middleIdx - 1 + + // Here localID equals either 0 or 1 + if localID = 0 then + beginIdxLocal <- leftEdge + else + endIdxLocal <- leftEdge + + barrierLocal () + + let beginIdx = beginIdxLocal + let endIdx = endIdxLocal + let firstLocalLength = endIdx - beginIdx + let mutable x = workGroupSize - firstLocalLength + + if endIdx = firstSide then + x <- secondSide - i + localID + beginIdx + + let secondLocalLength = x + + //First indices are from 0 to firstLocalLength - 1 inclusive + //Second indices are from firstLocalLength to firstLocalLength + secondLocalLength - 1 inclusive + let localIndices = localArray workGroupSize + + if localID < firstLocalLength then + localIndices.[localID] <- + ((uint64 firstRowsBuffer.[beginIdx + localID]) + <<< 32) + ||| (uint64 firstColumnsBuffer.[beginIdx + localID]) + + if localID < secondLocalLength then + localIndices.[firstLocalLength + localID] <- + ((uint64 secondRowsBuffer.[i - beginIdx]) <<< 32) + ||| (uint64 secondColumnsBuffer.[i - beginIdx]) + + barrierLocal () + + if i < sumOfSides then + let mutable leftEdge = localID + 1 - secondLocalLength + if leftEdge < 0 then leftEdge <- 0 + + let mutable rightEdge = firstLocalLength - 1 + + if rightEdge > localID then + rightEdge <- localID + + while leftEdge <= rightEdge do + let middleIdx = (leftEdge + rightEdge) / 2 + let firstIndex = localIndices.[middleIdx] + + let secondIndex = + localIndices.[firstLocalLength + localID - middleIdx] + + if firstIndex < secondIndex then + leftEdge <- middleIdx + 1 + else + rightEdge <- middleIdx - 1 + + let boundaryX = rightEdge + let boundaryY = localID - leftEdge + + // boundaryX and boundaryY can't be off the right edge of array (only off the left edge) + let isValidX = boundaryX >= 0 + let isValidY = boundaryY >= 0 + + let mutable fstIdx = 0UL + + if isValidX then + fstIdx <- localIndices.[boundaryX] + + let mutable sndIdx = 0UL + + if isValidY then + sndIdx <- localIndices.[firstLocalLength + boundaryY] + + if not isValidX || isValidY && fstIdx < sndIdx then + allRowsBuffer.[i] <- int (sndIdx >>> 32) + allColumnsBuffer.[i] <- int sndIdx + allValuesBuffer.[i] <- secondValuesBuffer.[i - localID - beginIdx + boundaryY] + else + allRowsBuffer.[i] <- int (fstIdx >>> 32) + allColumnsBuffer.[i] <- int fstIdx + allValuesBuffer.[i] <- firstValuesBuffer.[beginIdx + boundaryX] + @> + + checkCode (command 256) "MergeKernel.gen" "MergeKernel.cl" + ] diff --git a/tests/Brahma.FSharp.Tests/TranslationTests/Expected/Translation.Test1.cl b/tests/Brahma.FSharp.Tests/Translator/Union/Expected/Translation.Test1.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/TranslationTests/Expected/Translation.Test1.cl rename to tests/Brahma.FSharp.Tests/Translator/Union/Expected/Translation.Test1.cl diff --git a/tests/Brahma.FSharp.Tests/Translator/Union/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/Union/Tests.fs new file mode 100644 index 00000000..36a64b69 --- /dev/null +++ b/tests/Brahma.FSharp.Tests/Translator/Union/Tests.fs @@ -0,0 +1,69 @@ +module Brahma.FSharp.Tests.Translator.Union.Tests + +open Expecto +open Brahma.FSharp.OpenCL.Translator +open Brahma.FSharp.OpenCL.AST +open Brahma.FSharp.OpenCL.Printer +open System.IO +open Brahma.FSharp.Tests.Translator.Common + +type TranslateTest = + | A of int * float + | B of double + | C + +let unionTests (translator: FSQuotationToOpenCLTranslator) = + let testGen testCase name (types: List) outFile expectedFile = + testCase name <| fun () -> + let context = TranslationContext.Create(TranslatorOptions()) + for type' in types do Type.translateUnion type' |> State.run context |> ignore + + let unions = context.CStructDecls.Values |> Seq.map StructDecl |> Seq.toList + + let ast = AST <| List.map (fun du -> du :> ITopDef<_>) unions + let code = AST.print ast + + File.WriteAllText(outFile, code) // TODO() + + Utils.filesAreEqual outFile + <| Path.Combine(basePath, expectedFile) + + [ + testGen testCase "Test 1" [ typeof ] "Translation.Test1.gen" "Translation.Test1.cl" + ] + +type SimpleUnion = + | SimpleOne + | SimpleTwo of int + +type OuterUnion = + | Outer of int + | Inner of SimpleUnion + +let collectUnionTests (translator: FSQuotationToOpenCLTranslator) = + let testGen testCase name expected command = + testCase name <| fun () -> + let unions = + Body.translate command + |> State.exec (TranslationContext.Create(TranslatorOptions())) + |> fun context -> context.CStructDecls.Keys + + Expect.sequenceEqual unions expected "Should be equal" + + [ + testGen testCase "Simple union" [| typeof |] + <@ let x = SimpleOne + let y = SimpleTwo 2 + () + @> + + testGen testCase "Nested union 1" [| typeof; typeof |] + <@ let x = Outer 5 + () + @> + + testGen testCase "Nested union 2" [| typeof; typeof |] + <@ let x = Inner SimpleOne + () + @> + ] From 0b191441a24a83ecc3cfb0eb069e67cf435b1caf Mon Sep 17 00:00:00 2001 From: IgorErin Date: Thu, 6 Jul 2023 18:56:53 +0300 Subject: [PATCH 04/22] wip: translation tests --- .editorconfig | 37 +- src/Brahma.FSharp.OpenCL.AST/Common.fs | 5 +- src/Brahma.FSharp.OpenCL.AST/Expressions.fs | 2 +- src/Brahma.FSharp.OpenCL.AST/FunDecl.fs | 9 +- src/Brahma.FSharp.OpenCL.AST/Types.fs | 38 +- src/Brahma.FSharp.OpenCL.Core/ClBuffer.fs | 62 +- src/Brahma.FSharp.OpenCL.Core/ClContext.fs | 6 +- .../ClContextExtensions.fs | 35 +- src/Brahma.FSharp.OpenCL.Core/ClDevice.fs | 69 +- src/Brahma.FSharp.OpenCL.Core/ClException.fs | 6 +- src/Brahma.FSharp.OpenCL.Core/ClKernel.fs | 14 +- src/Brahma.FSharp.OpenCL.Core/ClProgram.fs | 79 +- src/Brahma.FSharp.OpenCL.Core/ClTask.fs | 62 +- .../CommandQueueProvider.fs | 169 +- .../DataStructures/ClArray.fs | 65 +- .../DataStructures/ClCell.fs | 50 +- src/Brahma.FSharp.OpenCL.Core/IKernel.fs | 4 +- src/Brahma.FSharp.OpenCL.Core/Messages.fs | 40 +- src/Brahma.FSharp.OpenCL.Core/NDRange.fs | 76 +- .../RuntimeContext.fs | 18 +- .../Expressions.fs | 45 +- src/Brahma.FSharp.OpenCL.Printer/FunDecl.fs | 34 +- src/Brahma.FSharp.OpenCL.Printer/Pragmas.fs | 16 +- src/Brahma.FSharp.OpenCL.Printer/Printer.fs | 17 +- .../Statements.fs | 87 +- src/Brahma.FSharp.OpenCL.Printer/TypeDecl.fs | 28 +- src/Brahma.FSharp.OpenCL.Printer/Types.fs | 25 +- src/Brahma.FSharp.OpenCL.Shared/IBuffer.fs | 15 +- src/Brahma.FSharp.OpenCL.Shared/IDevice.fs | 3 +- .../KernelLangExtensions.fs | 18 +- .../Bindings.fs | 22 +- src/Brahma.FSharp.OpenCL.Translator/Body.fs | 1580 ++++---- .../CustomMarshaller.fs | 192 +- .../Exceptions.fs | 6 +- .../Methods.fs | 244 +- .../AtomicTransformer.fs | 774 ++-- .../GettingWorkSizeTransformer.fs | 97 +- .../LambdaLiftingTransformer.fs | 87 +- .../MutableVarsToRefTransformer.fs | 40 +- .../PrintfTransformer.fs | 11 +- .../UniqueVarNamesTransformer.fs | 8 +- .../Utilities/Patterns.fs | 75 +- .../QuotationTransformers/Utilities/Utils.fs | 73 +- .../VarDefsToLambdaTransformer.fs | 19 +- .../TranslationContext.fs | 46 +- .../Translator.fs | 68 +- src/Brahma.FSharp.OpenCL.Translator/Type.fs | 345 +- .../Utils/Extensions.fs | 23 +- .../Utils/StateBuilder.fs | 53 +- .../Utils/Utils.fs | 9 +- .../Brahma.FSharp.Tests.fsproj | 144 +- tests/Brahma.FSharp.Tests/Common.fs | 16 +- .../ExecutionTests/AtomicTests.fs | 438 ++- .../ExecutionTests/CompilationTests.fs | 202 +- .../ExecutionTests/CompositeTypesTests.fs | 661 ++-- .../ExecutionTests/ExecutionTests.fs | 32 +- .../ExecutionTests/RuntimeTests.fs | 3498 ++++++++++------- .../ExecutionTests/WorkflowBuilderTests.fs | 360 +- tests/Brahma.FSharp.Tests/Program.fs | 14 +- tests/Brahma.FSharp.Tests/TranslationTests.fs | 8 - tests/Brahma.FSharp.Tests/Translator/All.fs | 39 + .../Expected/Array.Item.Set.cl | 0 .../Expected/Binary.Operations.Math.cl | 0 .../Expected/Binding.cl | 0 .../Expected/Binop.Plus.cl | 0 .../Expected/MAX.Transformation.cl | 0 .../Translator/BinOp/Tests.fs | 47 + .../Translator/BinaryOperations/Tests.fs | 52 - .../Translator/Carrying/Tests.fs | 57 +- .../Brahma.FSharp.Tests/Translator/Common.fs | 34 +- .../Translator/ConstantArray/Tests.fs | 39 +- .../Translator/ControlFlow/Tests.fs | 195 +- .../Translator/Injection/Tests.fs | 46 +- .../Translator/LambdaLifting/Tests.fs | 553 ++- .../Translator/LangExtensions/Atomic.fs | 100 +- .../LangExtensions/Barrier/Tests.fs | 32 +- .../LangExtensions/LocalID/Tests.fs | 43 +- .../LangExtensions/LocalMemory/Tests.fs | 65 +- .../LangExtensions/WorkSize/Tests.fs | 75 +- .../Translator/NamesResolving/Tests.fs | 115 +- .../Translator/Printf/Tests.fs | 69 +- .../QuatationTransformation/Common.fs | 9 +- .../QuatationTransformation/LambdaLifting.fs | 180 +- .../QuatationTransformation/Transformation.fs | 310 +- .../VarDefsToLambda.fs | 122 +- .../Translator/Specific/MergePath.fs | 221 +- .../Translator/Union/Tests.fs | 93 +- 87 files changed, 6938 insertions(+), 5837 deletions(-) delete mode 100644 tests/Brahma.FSharp.Tests/TranslationTests.fs create mode 100644 tests/Brahma.FSharp.Tests/Translator/All.fs rename tests/Brahma.FSharp.Tests/Translator/{BinaryOperations => BinOp}/Expected/Array.Item.Set.cl (100%) rename tests/Brahma.FSharp.Tests/Translator/{BinaryOperations => BinOp}/Expected/Binary.Operations.Math.cl (100%) rename tests/Brahma.FSharp.Tests/Translator/{BinaryOperations => BinOp}/Expected/Binding.cl (100%) rename tests/Brahma.FSharp.Tests/Translator/{BinaryOperations => BinOp}/Expected/Binop.Plus.cl (100%) rename tests/Brahma.FSharp.Tests/Translator/{BinaryOperations => BinOp}/Expected/MAX.Transformation.cl (100%) create mode 100644 tests/Brahma.FSharp.Tests/Translator/BinOp/Tests.fs delete mode 100644 tests/Brahma.FSharp.Tests/Translator/BinaryOperations/Tests.fs diff --git a/.editorconfig b/.editorconfig index 871c2273..a95a037d 100644 --- a/.editorconfig +++ b/.editorconfig @@ -34,39 +34,4 @@ indent_size = 2 # fantomas conf [*.fs] -fsharp_semicolon_at_end_of_line=false -fsharp_space_before_parameter=true -fsharp_space_before_lowercase_invocation=true -fsharp_space_before_uppercase_invocation=false -fsharp_space_before_class_constructor=false -fsharp_space_before_member=false -fsharp_space_before_colon=false -fsharp_space_after_comma=true -fsharp_space_before_semicolon=false -fsharp_space_after_semicolon=true -fsharp_indent_on_try_with=false -fsharp_space_around_delimiter=true -fsharp_max_if_then_else_short_width=80 -fsharp_max_infix_operator_expression=80 -fsharp_max_record_width=80 -fsharp_max_record_number_of_items=1 -fsharp_record_multiline_formatter=character_width -fsharp_max_array_or_list_width=80 -fsharp_max_array_or_list_number_of_items=1 -fsharp_array_or_list_multiline_formatter=character_width -fsharp_max_value_binding_width=80 -fsharp_max_function_binding_width=80 -fsharp_max_dot_get_expression_width=80 -fsharp_multiline_block_brackets_on_same_column=true -fsharp_newline_between_type_definition_and_members=false -fsharp_keep_if_then_in_same_line=true -fsharp_max_elmish_width=80 -fsharp_single_argument_web_mode=true -fsharp_align_function_signature_to_indentation=false -fsharp_alternative_long_member_definitions=false -fsharp_multi_line_lambda_closing_newline=true -fsharp_disable_elmish_syntax=false -fsharp_keep_indent_in_branch=false -fsharp_blank_lines_around_nested_multiline_expressions=false -fsharp_bar_before_discriminated_union_declaration=false -fsharp_strict_mode=false +fsharp_array_or_list_multiline_formatter=number_of_items diff --git a/src/Brahma.FSharp.OpenCL.AST/Common.fs b/src/Brahma.FSharp.OpenCL.AST/Common.fs index 99fe1baa..bf24f48e 100644 --- a/src/Brahma.FSharp.OpenCL.AST/Common.fs +++ b/src/Brahma.FSharp.OpenCL.AST/Common.fs @@ -17,13 +17,14 @@ namespace Brahma.FSharp.OpenCL.AST [] type Node<'lang>() = - abstract Children : List> + abstract Children: List> [] type Statement<'lang>() = inherit Node<'lang>() type ITopDef<'lang> = - interface end + interface + end type Lang = | OpenCL diff --git a/src/Brahma.FSharp.OpenCL.AST/Expressions.fs b/src/Brahma.FSharp.OpenCL.AST/Expressions.fs index 459c526c..e74a771b 100644 --- a/src/Brahma.FSharp.OpenCL.AST/Expressions.fs +++ b/src/Brahma.FSharp.OpenCL.AST/Expressions.fs @@ -115,7 +115,7 @@ type Ptr<'lang>(expr: Expression<'lang>) = type ArrayInitializer<'lang>() = inherit Expression<'lang>() override this.Children = [] - abstract Length : int + abstract Length: int type ZeroArray<'lang>(length: int) = inherit ArrayInitializer<'lang>() diff --git a/src/Brahma.FSharp.OpenCL.AST/FunDecl.fs b/src/Brahma.FSharp.OpenCL.AST/FunDecl.fs index deb06e7d..376821f6 100644 --- a/src/Brahma.FSharp.OpenCL.AST/FunDecl.fs +++ b/src/Brahma.FSharp.OpenCL.AST/FunDecl.fs @@ -23,9 +23,7 @@ type FunFormalArg<'lang>(declSpecs: DeclSpecifierPack<'lang>, name: string) = member this.Matches(other: obj) = match other with - | :? FunFormalArg<'lang> as o -> - this.DeclSpecs.Matches(o.DeclSpecs) - && this.Name.Equals(o.Name) + | :? FunFormalArg<'lang> as o -> this.DeclSpecs.Matches(o.DeclSpecs) && this.Name.Equals(o.Name) | _ -> false type FunDecl<'lang> @@ -50,10 +48,7 @@ type FunDecl<'lang> let areParamsMatching = (this.Args, o.Args) ||> List.zip - |> List.fold - (fun eq (x, y) -> - eq && x.Matches(y) - ) true + |> List.fold (fun eq (x, y) -> eq && x.Matches(y)) true this.DeclSpecs.Matches(o.DeclSpecs) && this.Name.Equals(o.Name) diff --git a/src/Brahma.FSharp.OpenCL.AST/Types.fs b/src/Brahma.FSharp.OpenCL.AST/Types.fs index df9a5993..596cccdf 100644 --- a/src/Brahma.FSharp.OpenCL.AST/Types.fs +++ b/src/Brahma.FSharp.OpenCL.AST/Types.fs @@ -37,8 +37,8 @@ type Type<'lang>() = inherit Node<'lang>() override this.Children = [] - abstract Size : int - abstract Matches : obj -> bool + abstract Size: int + abstract Matches: obj -> bool type PrimitiveType<'lang>(pType: PTypes<'lang>) = inherit Type<'lang>() @@ -103,10 +103,7 @@ type UnionClInplaceType<'lang>(name: string, fields: List>) = member this.Fields = fields member this.Name = name - override this.Size = - this.Fields - |> List.map (fun f -> f.Type.Size) - |> List.fold max 0 + override this.Size = this.Fields |> List.map (fun f -> f.Type.Size) |> List.fold max 0 override this.Matches _ = failwith "Not implemented" @@ -114,31 +111,32 @@ type StructInplaceType<'lang>(name: string, fields: List>) = inherit StructType<'lang>(name, fields) type DiscriminatedUnionType<'lang>(name: string, fields: List>) = - inherit StructType<'lang>( - name, - [ - { Name = "tag"; Type = PrimitiveType(Int) } - { Name = "data"; Type = UnionClInplaceType(name + "_Data", List.map snd fields) } - ] - ) + inherit + StructType<'lang>( + name, + [ { Name = "tag" + Type = PrimitiveType(Int) } + { Name = "data" + Type = UnionClInplaceType(name + "_Data", List.map snd fields) } ] + ) member this.Tag = this.Fields.[0] member this.Data = this.Fields.[1] member this.GetCaseByTag(tag: int) = - List.tryFind (fun (id, _) -> id = tag) fields - |> Option.map snd + List.tryFind (fun (id, _) -> id = tag) fields |> Option.map snd member this.GetCaseByName(case: string) = - List.tryFind (fun (_, f) -> f.Name = case) fields - |> Option.map snd + List.tryFind (fun (_, f) -> f.Name = case) fields |> Option.map snd type TupleType<'lang>(baseStruct: StructType<'lang>) = inherit Type<'lang>() member this.BaseStruct = baseStruct override this.Size = baseStruct.Size - override this.Matches _ = failwith "Not implemented: matches for tuples" + + override this.Matches _ = + failwith "Not implemented: matches for tuples" type RefType<'lang>(baseType: Type<'lang>, typeQuals: TypeQualifier<'lang> list) = inherit Type<'lang>() @@ -149,9 +147,7 @@ type RefType<'lang>(baseType: Type<'lang>, typeQuals: TypeQualifier<'lang> list) override this.Matches(other) = match other with - | :? RefType<'lang> as o -> - this.BaseType.Matches(o.BaseType) - && this.TypeQuals.Equals(o.TypeQuals) + | :? RefType<'lang> as o -> this.BaseType.Matches(o.BaseType) && this.TypeQuals.Equals(o.TypeQuals) | _ -> false type StructDecl<'lang>(structType: StructType<'lang>) = diff --git a/src/Brahma.FSharp.OpenCL.Core/ClBuffer.fs b/src/Brahma.FSharp.OpenCL.Core/ClBuffer.fs index 00447470..0b0debf4 100644 --- a/src/Brahma.FSharp.OpenCL.Core/ClBuffer.fs +++ b/src/Brahma.FSharp.OpenCL.Core/ClBuffer.fs @@ -32,39 +32,28 @@ type AllocationMode = /// Represents flags to specify allocation and usage information of OpenCL buffer. type ClMemFlags = - { - HostAccessMode: HostAccessMode - DeviceAccessMode: DeviceAccessMode - AllocationMode: AllocationMode - } + { HostAccessMode: HostAccessMode + DeviceAccessMode: DeviceAccessMode + AllocationMode: AllocationMode } /// Represents default flags in case of allocation with copying data. static member DefaultIfData = - { - HostAccessMode = HostAccessMode.ReadWrite - DeviceAccessMode = DeviceAccessMode.ReadWrite - AllocationMode = AllocationMode.AllocAndCopyHostPtr - } + { HostAccessMode = HostAccessMode.ReadWrite + DeviceAccessMode = DeviceAccessMode.ReadWrite + AllocationMode = AllocationMode.AllocAndCopyHostPtr } /// Represents default flags in case of allocation without copying data. static member DefaultIfNoData = - { - HostAccessMode = HostAccessMode.ReadWrite - DeviceAccessMode = DeviceAccessMode.ReadWrite - AllocationMode = AllocationMode.AllocHostPtr - } + { HostAccessMode = HostAccessMode.ReadWrite + DeviceAccessMode = DeviceAccessMode.ReadWrite + AllocationMode = AllocationMode.AllocHostPtr } type BufferInitParam<'a> = | Data of 'a[] | Size of int /// Represents an abstraction over OpenCL memory buffer. -type ClBuffer<'a> - ( - clContext: ClContext, - initParam: BufferInitParam<'a>, - ?memFlags: ClMemFlags - ) = +type ClBuffer<'a>(clContext: ClContext, initParam: BufferInitParam<'a>, ?memFlags: ClMemFlags) = let memFlags = match initParam with @@ -90,17 +79,18 @@ type ClBuffer<'a> | DeviceAccessMode.ReadOnly -> flags <- flags ||| MemFlags.ReadOnly | DeviceAccessMode.WriteOnly -> flags <- flags ||| MemFlags.WriteOnly - let ifDataFlags = [ - AllocationMode.UseHostPtr - AllocationMode.CopyHostPtr - AllocationMode.AllocAndCopyHostPtr - ] + let ifDataFlags = + [ AllocationMode.UseHostPtr + AllocationMode.CopyHostPtr + AllocationMode.AllocAndCopyHostPtr ] match initParam with - | Size _ when ifDataFlags |> List.contains memFlags.AllocationMode -> - raise <| InvalidMemFlagsException $"One of following flags should be setted {ifDataFlags}" + | Size _ when ifDataFlags |> List.contains memFlags.AllocationMode -> + raise + <| InvalidMemFlagsException $"One of following flags should be setted {ifDataFlags}" | Data _ when ifDataFlags |> List.contains memFlags.AllocationMode |> not -> - raise <| InvalidMemFlagsException $"Neither of following flags should be setted {ifDataFlags}" + raise + <| InvalidMemFlagsException $"Neither of following flags should be setted {ifDataFlags}" | _ -> () match memFlags.AllocationMode with @@ -112,13 +102,15 @@ type ClBuffer<'a> flags - let mutable pinnedMemory : GCHandle option = None + let mutable pinnedMemory: GCHandle option = None let buffer = let error = ref Unchecked.defaultof + let buf = if marshaler.IsBlittable typeof<'a> then let elementSize = Marshal.SizeOf Unchecked.defaultof<'a> + let (size, data) = match initParam with | Data array -> @@ -132,7 +124,10 @@ type ClBuffer<'a> match initParam with | Data array -> let (size, data) = marshaler.WriteToUnmanaged(array) - let buffer = Cl.CreateBuffer(clContext.Context, clMemoryFlags, IntPtr size, data, error) + + let buffer = + Cl.CreateBuffer(clContext.Context, clMemoryFlags, IntPtr size, data, error) + Marshal.FreeHGlobal(data) buffer @@ -155,8 +150,7 @@ type ClBuffer<'a> | Data array -> array.Length | Size size -> size - member this.ElementSize = - marshaler.GetTypePacking(typeof<'a>).Size + member this.ElementSize = marshaler.GetTypePacking(typeof<'a>).Size member this.Free() = match pinnedMemory with @@ -166,7 +160,7 @@ type ClBuffer<'a> buffer.Dispose() member this.Item - with get (idx: int) : 'a = FailIfOutsideKernel() + with get (idx: int): 'a = FailIfOutsideKernel() and set (idx: int) (value: 'a) = FailIfOutsideKernel() interface IDisposable with diff --git a/src/Brahma.FSharp.OpenCL.Core/ClContext.fs b/src/Brahma.FSharp.OpenCL.Core/ClContext.fs index a2773c61..e63eb155 100644 --- a/src/Brahma.FSharp.OpenCL.Core/ClContext.fs +++ b/src/Brahma.FSharp.OpenCL.Core/ClContext.fs @@ -9,7 +9,9 @@ type ClContext(clDevice: ClDevice, ?translator, ?compilerOptions: string) = let context = let error = ref Unchecked.defaultof - let ctx = Cl.CreateContext(null, 1u, [| clDevice.Device |], null, System.IntPtr.Zero, error) + + let ctx = + Cl.CreateContext(null, 1u, [| clDevice.Device |], null, System.IntPtr.Zero, error) if error.Value <> ErrorCode.Success then raise <| Cl.Exception error.Value @@ -31,11 +33,13 @@ type ClContext(clDevice: ClDevice, ?translator, ?compilerOptions: string) = let context = this let device = context.ClDevice.Device let deviceName = Cl.GetDeviceInfo(device, DeviceInfo.Name, &e).ToString() + if deviceName.Length < 20 then $"%s{deviceName}" else let platform = Cl.GetDeviceInfo(device, DeviceInfo.Platform, &e).CastTo() let platformName = Cl.GetPlatformInfo(platform, PlatformInfo.Name, &e).ToString() + let deviceType = match Cl.GetDeviceInfo(device, DeviceInfo.Type, &e).CastTo() with | DeviceType.Cpu -> "CPU" diff --git a/src/Brahma.FSharp.OpenCL.Core/ClContextExtensions.fs b/src/Brahma.FSharp.OpenCL.Core/ClContextExtensions.fs index 213e930d..4a8bb3d1 100644 --- a/src/Brahma.FSharp.OpenCL.Core/ClContextExtensions.fs +++ b/src/Brahma.FSharp.OpenCL.Core/ClContextExtensions.fs @@ -5,8 +5,9 @@ open FSharp.Quotations [] module ClContextExtensions = type ClContext with + /// Compiles raw kernel to OpenCL program. - member this.Compile(srcLambda: Expr<'TRange ->'a>) = ClProgram(this, srcLambda) + member this.Compile(srcLambda: Expr<'TRange -> 'a>) = ClProgram(this, srcLambda) /// Creates OpenCL array based on specified data with specified memory flags. member this.CreateClArray @@ -18,11 +19,9 @@ module ClContextExtensions = ) = let flags = - { - HostAccessMode = defaultArg hostAccessMode ClMemFlags.DefaultIfData.HostAccessMode - DeviceAccessMode = defaultArg deviceAccessMode ClMemFlags.DefaultIfData.DeviceAccessMode - AllocationMode = defaultArg allocationMode ClMemFlags.DefaultIfData.AllocationMode - } + { HostAccessMode = defaultArg hostAccessMode ClMemFlags.DefaultIfData.HostAccessMode + DeviceAccessMode = defaultArg deviceAccessMode ClMemFlags.DefaultIfData.DeviceAccessMode + AllocationMode = defaultArg allocationMode ClMemFlags.DefaultIfData.AllocationMode } let buffer = new ClBuffer<'a>(this, Data data, flags) new ClArray<_>(buffer) @@ -37,11 +36,9 @@ module ClContextExtensions = ) = let flags = - { - HostAccessMode = defaultArg hostAccessMode ClMemFlags.DefaultIfNoData.HostAccessMode - DeviceAccessMode = defaultArg deviceAccessMode ClMemFlags.DefaultIfNoData.DeviceAccessMode - AllocationMode = defaultArg allocationMode ClMemFlags.DefaultIfNoData.AllocationMode - } + { HostAccessMode = defaultArg hostAccessMode ClMemFlags.DefaultIfNoData.HostAccessMode + DeviceAccessMode = defaultArg deviceAccessMode ClMemFlags.DefaultIfNoData.DeviceAccessMode + AllocationMode = defaultArg allocationMode ClMemFlags.DefaultIfNoData.AllocationMode } let buffer = new ClBuffer<'a>(this, Size size, flags) new ClArray<_>(buffer) @@ -56,11 +53,9 @@ module ClContextExtensions = ) = let flags = - { - HostAccessMode = defaultArg hostAccessMode ClMemFlags.DefaultIfData.HostAccessMode - DeviceAccessMode = defaultArg deviceAccessMode ClMemFlags.DefaultIfData.DeviceAccessMode - AllocationMode = defaultArg allocationMode ClMemFlags.DefaultIfData.AllocationMode - } + { HostAccessMode = defaultArg hostAccessMode ClMemFlags.DefaultIfData.HostAccessMode + DeviceAccessMode = defaultArg deviceAccessMode ClMemFlags.DefaultIfData.DeviceAccessMode + AllocationMode = defaultArg allocationMode ClMemFlags.DefaultIfData.AllocationMode } let buffer = new ClBuffer<'a>(this, Data [| data |], flags) new ClCell<_>(buffer) @@ -74,11 +69,9 @@ module ClContextExtensions = ) = let flags = - { - HostAccessMode = defaultArg hostAccessMode ClMemFlags.DefaultIfNoData.HostAccessMode - DeviceAccessMode = defaultArg deviceAccessMode ClMemFlags.DefaultIfNoData.DeviceAccessMode - AllocationMode = defaultArg allocationMode ClMemFlags.DefaultIfNoData.AllocationMode - } + { HostAccessMode = defaultArg hostAccessMode ClMemFlags.DefaultIfNoData.HostAccessMode + DeviceAccessMode = defaultArg deviceAccessMode ClMemFlags.DefaultIfNoData.DeviceAccessMode + AllocationMode = defaultArg allocationMode ClMemFlags.DefaultIfNoData.AllocationMode } let buffer = new ClBuffer<'a>(this, Size 1, flags) new ClCell<_>(buffer) diff --git a/src/Brahma.FSharp.OpenCL.Core/ClDevice.fs b/src/Brahma.FSharp.OpenCL.Core/ClDevice.fs index c9319c52..d4e6b140 100644 --- a/src/Brahma.FSharp.OpenCL.Core/ClDevice.fs +++ b/src/Brahma.FSharp.OpenCL.Core/ClDevice.fs @@ -10,13 +10,13 @@ type Cl = OpenCL.Net.Cl exception EmptyDevicesException of string module internal DeviceHelpers = - let convertToDeviceType(deviceType: DeviceType) = + let convertToDeviceType (deviceType: DeviceType) = match deviceType with | DeviceType.CPU -> ClDeviceType.Cpu | DeviceType.GPU -> ClDeviceType.Gpu | DeviceType.Default -> ClDeviceType.Default - let convertToPattern(platform: Platform) = + let convertToPattern (platform: Platform) = match platform with | Platform.Intel -> "Intel*" | Platform.Amd -> "AMD*" @@ -29,6 +29,7 @@ type ClDevice(device: OpenCL.Net.Device) = let throwOnError f = let error = ref Unchecked.defaultof let result = f error + if error.Value <> ClErrorCode.Success then failwithf $"Program creation failed: %A{error}" else @@ -37,14 +38,14 @@ type ClDevice(device: OpenCL.Net.Device) = let defaultOnError onError f = let error = ref Unchecked.defaultof let result = f error + if error.Value <> ClErrorCode.Success then onError else result let (|Contains|_|) (substring: string) (str: string) = - if str.Contains substring then Some Contains - else None + if str.Contains substring then Some Contains else None /// Gets internal representation of device specific to OpenCL.Net. member this.Device = device @@ -72,27 +73,41 @@ type ClDevice(device: OpenCL.Net.Device) = |> defaultOnError DeviceType.Default member val MaxWorkGroupSize = - fun e -> Cl.GetDeviceInfo(device, OpenCL.Net.DeviceInfo.MaxWorkGroupSize, e).CastTo() + fun e -> + Cl + .GetDeviceInfo(device, OpenCL.Net.DeviceInfo.MaxWorkGroupSize, e) + .CastTo() |> throwOnError member val MaxWorkItemDimensions = - fun e -> Cl.GetDeviceInfo(device, OpenCL.Net.DeviceInfo.MaxWorkItemDimensions, e).CastTo() + fun e -> + Cl + .GetDeviceInfo(device, OpenCL.Net.DeviceInfo.MaxWorkItemDimensions, e) + .CastTo() |> throwOnError // TODO change length member val MaxWorkItemSizes = - fun e -> Cl.GetDeviceInfo(device, OpenCL.Net.DeviceInfo.MaxWorkItemSizes, e).CastToArray(3) + fun e -> + Cl + .GetDeviceInfo(device, OpenCL.Net.DeviceInfo.MaxWorkItemSizes, e) + .CastToArray(3) |> throwOnError member val LocalMemSize = - fun e -> Cl.GetDeviceInfo(device, OpenCL.Net.DeviceInfo.LocalMemSize, e).CastTo() * 1 + fun e -> + Cl.GetDeviceInfo(device, OpenCL.Net.DeviceInfo.LocalMemSize, e).CastTo() + * 1 |> throwOnError + member val GlobalMemSize = - fun e -> Cl.GetDeviceInfo(device, OpenCL.Net.DeviceInfo.GlobalMemSize, e).CastTo() * 1L + fun e -> + Cl.GetDeviceInfo(device, OpenCL.Net.DeviceInfo.GlobalMemSize, e).CastTo() + * 1L |> throwOnError member val DeviceExtensions = - let toDeviceExtension (s:string) = + let toDeviceExtension (s: string) = match s.ToLowerInvariant().Trim() with | "cl_intel_accelerator" -> CL_INTEL_ACCELERATOR | "cl_intel_advanced_motion_estimation" -> CL_INTEL_ADVANCED_MOTION_ESTIMATION @@ -157,7 +172,13 @@ type ClDevice(device: OpenCL.Net.Device) = | "cl_nv_pragma_unroll" -> CL_NV_PRAGMA_UNROLL | x -> OTHER x - fun e -> Cl.GetDeviceInfo(device, OpenCL.Net.DeviceInfo.Extensions, e).ToString().Trim().Split ' ' |> Array.map toDeviceExtension + fun e -> + Cl + .GetDeviceInfo(device, OpenCL.Net.DeviceInfo.Extensions, e) + .ToString() + .Trim() + .Split ' ' + |> Array.map toDeviceExtension |> throwOnError /// Device name string. @@ -199,19 +220,21 @@ type ClDevice(device: OpenCL.Net.Device) = let wildcardToRegex (pattern: string) = "^" + Regex.Escape(pattern).Replace("\\*", ".*").Replace("\\?", ".") + "$" - let platformNameRegex = Regex(wildcardToRegex <| DeviceHelpers.convertToPattern platform, RegexOptions.IgnoreCase) + let platformNameRegex = + Regex(wildcardToRegex <| DeviceHelpers.convertToPattern platform, RegexOptions.IgnoreCase) let error = ref Unchecked.defaultof Cl.GetPlatformIDs error - |> Seq.choose - (fun platform -> - let platformName = Cl.GetPlatformInfo(platform, OpenCL.Net.PlatformInfo.Name, error).ToString() - if platformNameRegex.Match(platformName).Success then - Some <| Cl.GetDeviceIDs(platform, DeviceHelpers.convertToDeviceType deviceType, error) - else - None - ) + |> Seq.choose (fun platform -> + let platformName = + Cl.GetPlatformInfo(platform, OpenCL.Net.PlatformInfo.Name, error).ToString() + + if platformNameRegex.Match(platformName).Success then + Some + <| Cl.GetDeviceIDs(platform, DeviceHelpers.convertToDeviceType deviceType, error) + else + None) |> Seq.concat |> Seq.map ClDevice @@ -225,6 +248,6 @@ type ClDevice(device: OpenCL.Net.Device) = try Seq.head <| ClDevice.GetAvailableDevices(platform, deviceType) - with - | :? System.ArgumentException as ex -> - raise <| EmptyDevicesException $"No %A{deviceType} devices on platform %A{platform} were found" + with :? System.ArgumentException as ex -> + raise + <| EmptyDevicesException $"No %A{deviceType} devices on platform %A{platform} were found" diff --git a/src/Brahma.FSharp.OpenCL.Core/ClException.fs b/src/Brahma.FSharp.OpenCL.Core/ClException.fs index 63223207..e148e3e7 100644 --- a/src/Brahma.FSharp.OpenCL.Core/ClException.fs +++ b/src/Brahma.FSharp.OpenCL.Core/ClException.fs @@ -9,8 +9,8 @@ open System.Runtime.Serialization type CLException = inherit Exception - new (error: ErrorCode) = { inherit Exception(error.ToString()) } + new(error: ErrorCode) = { inherit Exception(error.ToString()) } - new (error: ErrorCode, inner: Exception) = { inherit Exception(error.ToString(), inner) } + new(error: ErrorCode, inner: Exception) = { inherit Exception(error.ToString(), inner) } - new (info: SerializationInfo, context: StreamingContext) = { inherit Exception(info, context) } + new(info: SerializationInfo, context: StreamingContext) = { inherit Exception(info, context) } diff --git a/src/Brahma.FSharp.OpenCL.Core/ClKernel.fs b/src/Brahma.FSharp.OpenCL.Core/ClKernel.fs index a5437d75..a234e415 100644 --- a/src/Brahma.FSharp.OpenCL.Core/ClKernel.fs +++ b/src/Brahma.FSharp.OpenCL.Core/ClKernel.fs @@ -8,18 +8,16 @@ open Brahma.FSharp.OpenCL.Shared open Brahma.FSharp.OpenCL.Translator.QuotationTransformers /// Represents an abstraction over OpenCL kernel. -type ClKernel<'TRange, 'a when 'TRange :> INDRange> - ( - program: ClProgram<'TRange, 'a>, - ?kernelName - ) = +type ClKernel<'TRange, 'a when 'TRange :> INDRange>(program: ClProgram<'TRange, 'a>, ?kernelName) = let kernelName = defaultArg kernelName "brahmaKernel" let kernel = let (clKernel, error) = Cl.CreateKernel(program.Program, kernelName) + if error <> ErrorCode.Success then failwithf $"OpenCL kernel creation problem. Error: %A{error}" + clKernel let args = ref [||] @@ -33,8 +31,7 @@ type ClKernel<'TRange, 'a when 'TRange :> INDRange> // TODO maybe return seq of IDisposable? /// Release internal buffers created inside kernel. member this.ReleaseInternalBuffers(queue: MailboxProcessor) = - mutexBuffers - |> Seq.iter (Msg.CreateFreeMsg >> queue.Post) + mutexBuffers |> Seq.iter (Msg.CreateFreeMsg >> queue.Post) mutexBuffers.Clear() @@ -45,5 +42,6 @@ type ClKernel<'TRange, 'a when 'TRange :> INDRange> [] module ClProgramExtensions = type ClProgram<'TRange, 'a when 'TRange :> INDRange> with + /// Returns new kernel instance corresponding to the given OpenCL program. - member this.GetKernel() = ClKernel(this) + member this.GetKernel() = ClKernel(this) diff --git a/src/Brahma.FSharp.OpenCL.Core/ClProgram.fs b/src/Brahma.FSharp.OpenCL.Core/ClProgram.fs index f750ab73..a6c44cf9 100644 --- a/src/Brahma.FSharp.OpenCL.Core/ClProgram.fs +++ b/src/Brahma.FSharp.OpenCL.Core/ClProgram.fs @@ -13,13 +13,10 @@ open System.Runtime.InteropServices open FSharp.Quotations.Evaluator /// Represents an abstraction over OpenCL program. -type ClProgram<'TRange, 'a when 'TRange :> INDRange> - ( - ctx: ClContext, - srcLambda: Expr<'TRange ->'a> - ) = +type ClProgram<'TRange, 'a when 'TRange :> INDRange>(ctx: ClContext, srcLambda: Expr<'TRange -> 'a>) = - let compilerOptions = defaultArg ctx.CompilerOptions " -cl-fast-relaxed-math -cl-mad-enable -cl-unsafe-math-optimizations " + let compilerOptions = + defaultArg ctx.CompilerOptions " -cl-fast-relaxed-math -cl-mad-enable -cl-unsafe-math-optimizations " let (clCode, newLambda) = let (ast, newLambda) = ctx.Translator.Translate(srcLambda) @@ -28,22 +25,26 @@ type ClProgram<'TRange, 'a when 'TRange :> INDRange> let program = let (program, error) = - let sources = [|clCode|] + let sources = [| clCode |] Cl.CreateProgramWithSource(ctx.Context, uint32 sources.Length, sources, null) if error <> ErrorCode.Success then failwithf $"Program creation failed: %A{error}" - let error = Cl.BuildProgram(program, 1u, [| ctx.ClDevice.Device |], compilerOptions, null, IntPtr.Zero) + let error = + Cl.BuildProgram(program, 1u, [| ctx.ClDevice.Device |], compilerOptions, null, IntPtr.Zero) if error <> ErrorCode.Success then let errorCode = ref ErrorCode.Success - let buildInfo = Cl.GetProgramBuildInfo(program, ctx.ClDevice.Device, ProgramBuildInfo.Log, errorCode) + + let buildInfo = + Cl.GetProgramBuildInfo(program, ctx.ClDevice.Device, ProgramBuildInfo.Log, errorCode) + failwithf $"Program compilation failed: %A{error} \n BUILD LOG:\n %A{buildInfo} \n" program - let setupArgument (kernel: Kernel) index (arg: obj) = + let setupArgument (kernel: Kernel) index (arg: obj) = let toIMem arg = match box arg with | :? IClMem as buf -> buf.Size, buf.Data @@ -52,12 +53,13 @@ type ClProgram<'TRange, 'a when 'TRange :> INDRange> let (argSize, argVal) = toIMem arg let error = Cl.SetKernelArg(kernel, uint32 index, argSize, argVal) + if error <> ErrorCode.Success then raise (CLException error) let kernelPrepare = match newLambda with - | DerivedPatterns.Lambdas (lambdaArgs, _) -> + | DerivedPatterns.Lambdas(lambdaArgs, _) -> let flattenArgs = List.collect id lambdaArgs let firstMutexIdx = @@ -69,7 +71,8 @@ type ClProgram<'TRange, 'a when 'TRange :> INDRange> let mutexLengths = let atomicVars = - List.init (flattenArgs.Length - firstMutexIdx) <| fun i -> + List.init (flattenArgs.Length - firstMutexIdx) + <| fun i -> let mutexVar = flattenArgs.[firstMutexIdx + i] argsWithoutMutexes |> List.find (fun v -> mutexVar.Name.Contains v.Name) @@ -88,13 +91,12 @@ type ClProgram<'TRange, 'a when 'TRange :> INDRange> .GetProperty("Length") ) - | var when var.Type.Name.ToLower().StartsWith ClCell_ -> - Expr.Value 1 + | var when var.Type.Name.ToLower().StartsWith ClCell_ -> Expr.Value 1 | _ -> - failwithf $"Something went wrong with type of atomic global var. \ - Expected var of type '%s{ClArray_}' or '%s{ClCell_}', but given %s{var.Type.Name}" - ) + failwithf + $"Something went wrong with type of atomic global var. \ + Expected var of type '%s{ClArray_}' or '%s{ClCell_}', but given %s{var.Type.Name}") ) let regularArgs = @@ -103,9 +105,7 @@ type ClProgram<'TRange, 'a when 'TRange :> INDRange> argsWithoutMutexes |> List.map (fun v -> Expr.Coerce(Expr.Var v, typeof)) ) - let argsList = - argsWithoutMutexes - |> List.map List.singleton + let argsList = argsWithoutMutexes |> List.map List.singleton let kernelVar = Var("kernel", typeof) let rangeVar = Var("range", typeof<'TRange ref>) @@ -114,41 +114,46 @@ type ClProgram<'TRange, 'a when 'TRange :> INDRange> let mutexArgsVar = Var("mutexArgs", typeof) let xVar = Var("x", typeof) + Expr.Lambdas( - [[kernelVar]] @ [[rangeVar]] @ [[argsVar]] @ [[mutexBuffersVar]] @ argsList, + [ [ kernelVar ] ] + @ [ [ rangeVar ] ] @ [ [ argsVar ] ] @ [ [ mutexBuffersVar ] ] @ argsList, Expr.Let( mutexArgsVar, <@@ - (%%mutexLengths : int[]) + (%%mutexLengths: int[]) |> List.ofArray |> List.map (fun n -> let mutexBuffer = new ClBuffer(ctx, Size n) - (%%(Expr.Var mutexBuffersVar) : ResizeArray>).Add mutexBuffer - box mutexBuffer - ) + + (%%(Expr.Var mutexBuffersVar): ResizeArray>).Add mutexBuffer + + box mutexBuffer) @@>, Expr.Let( xVar, <@@ %%regularArgs |> List.ofArray @@>, <@@ - %%Utils.createReferenceSetCall (Expr.Var rangeVar) <@@ unbox<'TRange> (%%Expr.Var xVar : obj list).Head @@> - %%Utils.createReferenceSetCall (Expr.Var argsVar) <@@ (%%Expr.Var xVar : obj list).Tail @ (%%Expr.Var mutexArgsVar : obj list) |> Array.ofList @@> - - %%Utils.createDereferenceCall (Expr.Var argsVar) + %%Utils.createReferenceSetCall + (Expr.Var rangeVar) + <@@ unbox<'TRange> (%%Expr.Var xVar: obj list).Head @@> + + %%Utils.createReferenceSetCall + (Expr.Var argsVar) + <@@ + (%%Expr.Var xVar: obj list).Tail @ (%%Expr.Var mutexArgsVar: obj list) + |> Array.ofList + @@> + + %% Utils.createDereferenceCall(Expr.Var argsVar) |> Array.iteri (setupArgument (%%(Expr.Var kernelVar): IKernel).Kernel) @@> ) ) ) |> fun kernelPrepare -> - <@ - %%kernelPrepare : - IKernel -> - 'TRange ref -> - obj[] ref -> - ResizeArray> -> - 'TRange -> 'a - @>.Compile() + <@ %%kernelPrepare: IKernel -> 'TRange ref -> obj[] ref -> ResizeArray> -> 'TRange -> 'a @> + .Compile() | _ -> failwithf $"Invalid kernel expression. Must be lambda, but given\n{newLambda}" diff --git a/src/Brahma.FSharp.OpenCL.Core/ClTask.fs b/src/Brahma.FSharp.OpenCL.Core/ClTask.fs index 635be59b..cb10c4b1 100644 --- a/src/Brahma.FSharp.OpenCL.Core/ClTask.fs +++ b/src/Brahma.FSharp.OpenCL.Core/ClTask.fs @@ -12,22 +12,18 @@ module internal ClTaskBuilder = /// Represents a computation expression for OpenCL computations. type ClTaskBuilder() = member inline this.Bind(x, f) = - ClTask <| fun env -> + ClTask + <| fun env -> let x' = runComputation x env runComputation (f x') env - member inline this.Return(x) = - ClTask <| fun _ -> - x + member inline this.Return(x) = ClTask <| fun _ -> x - member inline this.ReturnFrom(x) = - x + member inline this.ReturnFrom(x) = x - member inline this.Zero() = - this.Return(()) + member inline this.Zero() = this.Return(()) - member inline this.Combine(m1, m2) = - this.Bind(m1, (fun () -> m2)) + member inline this.Combine(m1, m2) = this.Bind(m1, (fun () -> m2)) member inline this.Delay(rest) = this.Bind(this.Zero(), (fun () -> rest ())) @@ -35,23 +31,25 @@ type ClTaskBuilder() = member inline this.Run(m) = m member this.TryWith(ClTask body, handler) = - ClTask <| fun env -> + ClTask + <| fun env -> try body env - with - | e -> + with e -> let (ClTask handlerBody) = handler e handlerBody env member this.TryFinally(ClTask body, finalizer) = - ClTask <| fun env -> + ClTask + <| fun env -> try body env finally finalizer () member this.Using(disposableRes: #System.IDisposable, f) = - ClTask <| fun env -> + ClTask + <| fun env -> try runComputation (this.Delay(fun () -> f disposableRes)) env finally @@ -82,13 +80,12 @@ module ClTask = let ask = ClTask id /// Returns runtime options. - let runtimeOptions = - ask >>= fun env -> opencl.Return env.RuntimeOptions + let runtimeOptions = ask >>= fun env -> opencl.Return env.RuntimeOptions /// Creates computation with specified options. let withOptions (g: RuntimeOptions -> RuntimeOptions) (ClTask f) = - ask >>= fun env -> - opencl.Return(f <| env.WithRuntimeOptions(g env.RuntimeOptions)) + ask + >>= fun env -> opencl.Return(f <| env.WithRuntimeOptions(g env.RuntimeOptions)) /// Runs computation with specified runtime context. let runSync (context: RuntimeContext) (ClTask f) = @@ -106,29 +103,28 @@ module ClTask = // NOTE maybe switch to manual threads // TODO check if it is really parallel /// Runs computations in parallel. - let inParallel (tasks: seq>) = opencl { - let! ctx = ask + let inParallel (tasks: seq>) = + opencl { + let! ctx = ask - ctx.CommandQueue.PostAndReply <| Msg.MsgNotifyMe + ctx.CommandQueue.PostAndReply <| Msg.MsgNotifyMe - let syncMsgs = Msg.CreateBarrierMessages (Seq.length tasks) - let ctxs = Array.create (Seq.length tasks) (ctx.WithNewCommandQueue()) + let syncMsgs = Msg.CreateBarrierMessages(Seq.length tasks) + let ctxs = Array.create (Seq.length tasks) (ctx.WithNewCommandQueue()) - return - tasks - |> Seq.mapi - (fun i task -> + return + tasks + |> Seq.mapi (fun i task -> opencl { let! ctx = ask let! result = task ctx.CommandQueue.Post <| syncMsgs.[i] return result } - |> fun task -> async { return runComputation task <| ctx.WithNewCommandQueue() } - ) - |> Async.Parallel - |> Async.RunSynchronously - } + |> fun task -> async { return runComputation task <| ctx.WithNewCommandQueue() }) + |> Async.Parallel + |> Async.RunSynchronously + } [] module ClTaskOpened = diff --git a/src/Brahma.FSharp.OpenCL.Core/CommandQueueProvider.fs b/src/Brahma.FSharp.OpenCL.Core/CommandQueueProvider.fs index de197796..1ce4a8e4 100644 --- a/src/Brahma.FSharp.OpenCL.Core/CommandQueueProvider.fs +++ b/src/Brahma.FSharp.OpenCL.Core/CommandQueueProvider.fs @@ -9,13 +9,13 @@ open System.Runtime.InteropServices type CommandQueueProvider private (device, context, translator: FSQuotationToOpenCLTranslator, __: unit) = let finish queue = let error = Cl.Finish(queue) + if error <> ErrorCode.Success then raise <| Cl.Exception error let handleFree (free: IFreeCrate) = { new IFreeCrateEvaluator with - member this.Eval crate = crate.Source.Dispose() - } + member this.Eval crate = crate.Source.Dispose() } |> free.Apply let handleToGPU queue (toGpu: IToGPUCrate) = @@ -25,17 +25,27 @@ type CommandQueueProvider private (device, context, translator: FSQuotationToOpe let mem = crate.Destination.Memory let elementSize = crate.Destination.ElementSize - let error = Cl.EnqueueWriteBuffer(queue, mem, Bool.False, IntPtr(0), - IntPtr(crate.Destination.Length * elementSize), crate.Source, 0u, null, eventID) + + let error = + Cl.EnqueueWriteBuffer( + queue, + mem, + Bool.False, + IntPtr(0), + IntPtr(crate.Destination.Length * elementSize), + crate.Source, + 0u, + null, + eventID + ) if error <> ErrorCode.Success then - raise (Cl.Exception error) - } + raise (Cl.Exception error) } |> toGpu.Apply let handleToHost queue (toHost: IToHostCrate) = { new IToHostCrateEvaluator with - member this.Eval (crate: ToHost<'a>) = + member this.Eval(crate: ToHost<'a>) = let eventID = ref Unchecked.defaultof let clMem = crate.Source.Memory let marshaller = translator.Marshaller @@ -57,7 +67,8 @@ type CommandQueueProvider private (device, context, translator: FSQuotationToOpe 0u, null, eventID - ) |> finishRead + ) + |> finishRead else let size = crate.Destination.Length * marshaller.GetTypePacking(typeof<'a>).Size let hostMem = Marshal.AllocHGlobal size @@ -72,15 +83,15 @@ type CommandQueueProvider private (device, context, translator: FSQuotationToOpe 0u, null, eventID - ) |> finishRead + ) + |> finishRead marshaller.ReadFromUnmanaged(hostMem, crate.Destination) Marshal.FreeHGlobal(hostMem) match crate.ReplyChannel with | Some ch -> ch.Reply crate.Destination - | None -> () - } + | None -> () } |> toHost.Apply let handleRun queue (run: IRunCrate) = @@ -89,12 +100,22 @@ type CommandQueueProvider private (device, context, translator: FSQuotationToOpe let range = crate.Kernel.NDRange let workDim = uint32 range.Dimensions let eventID = ref Unchecked.defaultof - let error = Cl.EnqueueNDRangeKernel(queue, crate.Kernel.Kernel, workDim, null, - range.GlobalWorkSize, range.LocalWorkSize, 0u, null, eventID) + + let error = + Cl.EnqueueNDRangeKernel( + queue, + crate.Kernel.Kernel, + workDim, + null, + range.GlobalWorkSize, + range.LocalWorkSize, + 0u, + null, + eventID + ) if error <> ErrorCode.Success then - raise (Cl.Exception error) - } + raise (Cl.Exception error) } |> run.Apply /// @@ -107,61 +128,69 @@ type CommandQueueProvider private (device, context, translator: FSQuotationToOpe /// Creates new command queue capable of handling messages of type . /// member this.CreateQueue() = - let processor = MailboxProcessor.Start <| fun inbox -> - let commandQueue = - let error = ref Unchecked.defaultof - let props = CommandQueueProperties.None - let queue = Cl.CreateCommandQueue(context, device, props, error) - - if error.Value <> ErrorCode.Success then - raise <| Cl.Exception error.Value - - queue - - let mutable itIsFirstNonqueueMsg = true - - let rec loop i = async { - let! msg = inbox.Receive() - match msg with - | MsgToHost crate -> - itIsFirstNonqueueMsg <- true - handleToHost commandQueue crate - - | MsgToGPU crate -> - itIsFirstNonqueueMsg <- true - handleToGPU commandQueue crate - - | MsgRun crate -> - itIsFirstNonqueueMsg <- true - handleRun commandQueue crate - - | MsgFree crate -> - if itIsFirstNonqueueMsg then - finish commandQueue - itIsFirstNonqueueMsg <- false - handleFree crate - - | MsgSetArguments setterFunc -> - if itIsFirstNonqueueMsg then - finish commandQueue - itIsFirstNonqueueMsg <- false - setterFunc () - - | MsgNotifyMe ch -> - itIsFirstNonqueueMsg <- true - finish commandQueue - ch.Reply () - - | MsgBarrier syncObject -> - itIsFirstNonqueueMsg <- true - finish commandQueue - syncObject.ImReady() - while not <| syncObject.CanContinue() do () - - return! loop 0 - } - - loop 0 + let processor = + MailboxProcessor.Start + <| fun inbox -> + let commandQueue = + let error = ref Unchecked.defaultof + let props = CommandQueueProperties.None + let queue = Cl.CreateCommandQueue(context, device, props, error) + + if error.Value <> ErrorCode.Success then + raise <| Cl.Exception error.Value + + queue + + let mutable itIsFirstNonqueueMsg = true + + let rec loop i = + async { + let! msg = inbox.Receive() + + match msg with + | MsgToHost crate -> + itIsFirstNonqueueMsg <- true + handleToHost commandQueue crate + + | MsgToGPU crate -> + itIsFirstNonqueueMsg <- true + handleToGPU commandQueue crate + + | MsgRun crate -> + itIsFirstNonqueueMsg <- true + handleRun commandQueue crate + + | MsgFree crate -> + if itIsFirstNonqueueMsg then + finish commandQueue + itIsFirstNonqueueMsg <- false + + handleFree crate + + | MsgSetArguments setterFunc -> + if itIsFirstNonqueueMsg then + finish commandQueue + itIsFirstNonqueueMsg <- false + + setterFunc () + + | MsgNotifyMe ch -> + itIsFirstNonqueueMsg <- true + finish commandQueue + ch.Reply() + + | MsgBarrier syncObject -> + itIsFirstNonqueueMsg <- true + finish commandQueue + syncObject.ImReady() + + while not <| syncObject.CanContinue() do + () + + return! loop 0 + } + + loop 0 // TODO rethink error handling? processor.Error.AddHandler(Handler<_>(fun _ -> raise)) diff --git a/src/Brahma.FSharp.OpenCL.Core/DataStructures/ClArray.fs b/src/Brahma.FSharp.OpenCL.Core/DataStructures/ClArray.fs index a8ce2aa4..c20de10e 100644 --- a/src/Brahma.FSharp.OpenCL.Core/DataStructures/ClArray.fs +++ b/src/Brahma.FSharp.OpenCL.Core/DataStructures/ClArray.fs @@ -11,7 +11,7 @@ type ClArray<'a> internal (buffer: ClBuffer<'a>) = member this.Length = buffer.Length member this.Item - with get (idx: int) : 'a = FailIfOutsideKernel() + with get (idx: int): 'a = FailIfOutsideKernel() and set (idx: int) (value: 'a) = FailIfOutsideKernel() interface IDisposable with @@ -28,7 +28,7 @@ type ClArray<'a> internal (buffer: ClBuffer<'a>) = member this.Free() = (buffer :> IBuffer<_>).Free() member this.Item - with get (idx: int) : 'a = FailIfOutsideKernel() + with get (idx: int): 'a = FailIfOutsideKernel() and set (idx: int) (value: 'a) = FailIfOutsideKernel() member this.Dispose() = (this :> IDisposable).Dispose() @@ -41,48 +41,53 @@ type clarray<'a> = ClArray<'a> module ClArray = /// Transfers specified array to device with specified memory flags. - let toDeviceWithFlags (array: 'a[]) (memFlags: ClMemFlags) = opencl { - let! context = ClTask.ask + let toDeviceWithFlags (array: 'a[]) (memFlags: ClMemFlags) = + opencl { + let! context = ClTask.ask - let buffer = new ClBuffer<'a>(context.ClContext, Data array, memFlags) - return new ClArray<'a>(buffer) - } + let buffer = new ClBuffer<'a>(context.ClContext, Data array, memFlags) + return new ClArray<'a>(buffer) + } // or allocate with null ptr and write // TODO if array.Length = 0 ... /// Transfers specified array to device with default memory flags. - let toDevice (array: 'a[]) = toDeviceWithFlags array ClMemFlags.DefaultIfData + let toDevice (array: 'a[]) = + toDeviceWithFlags array ClMemFlags.DefaultIfData /// Allocate empty array on device with specified memory flags. - let allocWithFlags<'a> (size: int) (memFlags: ClMemFlags) = opencl { - let! context = ClTask.ask + let allocWithFlags<'a> (size: int) (memFlags: ClMemFlags) = + opencl { + let! context = ClTask.ask - let buffer = new ClBuffer<'a>(context.ClContext, Size size, memFlags) - return new ClArray<'a>(buffer) - } + let buffer = new ClBuffer<'a>(context.ClContext, Size size, memFlags) + return new ClArray<'a>(buffer) + } /// Allocate empty array on device with default memory flags. - let alloc<'a> (size: int) = allocWithFlags<'a> size ClMemFlags.DefaultIfNoData + let alloc<'a> (size: int) = + allocWithFlags<'a> size ClMemFlags.DefaultIfNoData /// Transfers specified array from device to host. - let toHost (clArray: ClArray<'a>) = opencl { - let! context = ClTask.ask + let toHost (clArray: ClArray<'a>) = + opencl { + let! context = ClTask.ask - let array = Array.zeroCreate<'a> clArray.Length - return context.CommandQueue.PostAndReply(fun ch -> Msg.CreateToHostMsg(clArray.Buffer, array, ch)) - } + let array = Array.zeroCreate<'a> clArray.Length + + return context.CommandQueue.PostAndReply(fun ch -> Msg.CreateToHostMsg(clArray.Buffer, array, ch)) + } // TODO impl it using clEnqueCopy - let copy (clArray: ClArray<'a>) = opencl { - failwith "Not implemented yet" - } + let copy (clArray: ClArray<'a>) = + opencl { failwith "Not implemented yet" } // TODO impl it - let copyTo (destination: ClArray<'a>) (source: ClArray<'a>) = opencl { - failwith "Not implemented yet" - } - - let close (clArray: ClArray<'a>) = opencl { - let! ctx = ClTask.ask - ctx.CommandQueue.Post <| Msg.CreateFreeMsg(clArray) - } + let copyTo (destination: ClArray<'a>) (source: ClArray<'a>) = + opencl { failwith "Not implemented yet" } + + let close (clArray: ClArray<'a>) = + opencl { + let! ctx = ClTask.ask + ctx.CommandQueue.Post <| Msg.CreateFreeMsg(clArray) + } diff --git a/src/Brahma.FSharp.OpenCL.Core/DataStructures/ClCell.fs b/src/Brahma.FSharp.OpenCL.Core/DataStructures/ClCell.fs index 25cd3235..3995f505 100644 --- a/src/Brahma.FSharp.OpenCL.Core/DataStructures/ClCell.fs +++ b/src/Brahma.FSharp.OpenCL.Core/DataStructures/ClCell.fs @@ -9,7 +9,7 @@ type ClCell<'a> internal (buffer: ClBuffer<'a>) = /// Gets internal value. member this.Value - with get () : 'a = FailIfOutsideKernel() + with get (): 'a = FailIfOutsideKernel() and set (value: 'a) = FailIfOutsideKernel() interface IDisposable with @@ -24,8 +24,9 @@ type ClCell<'a> internal (buffer: ClBuffer<'a>) = member this.Length = (buffer :> IBuffer<_>).Length member this.ElementSize = (buffer :> IBuffer<_>).ElementSize member this.Free() = (buffer :> IBuffer<_>).Free() + member this.Item - with get (idx: int) : 'a = FailIfOutsideKernel() + with get (idx: int): 'a = FailIfOutsideKernel() and set (idx: int) (value: 'a) = FailIfOutsideKernel() member this.Dispose() = (this :> IDisposable).Dispose() @@ -35,36 +36,41 @@ type clcell<'a> = ClCell<'a> module ClCell = /// Transfers specified value to device with specified memory flags. - let toDeviceWithFlags (value: 'a) (memFlags: ClMemFlags) = opencl { - let! context = ClTask.ask + let toDeviceWithFlags (value: 'a) (memFlags: ClMemFlags) = + opencl { + let! context = ClTask.ask - let buffer = new ClBuffer<'a>(context.ClContext, Data [| value |], memFlags) - return new ClCell<'a>(buffer) - } + let buffer = new ClBuffer<'a>(context.ClContext, Data [| value |], memFlags) + return new ClCell<'a>(buffer) + } /// Transfers specified value to device with default memory flags. - let toDevice (value: 'a) = toDeviceWithFlags value ClMemFlags.DefaultIfData + let toDevice (value: 'a) = + toDeviceWithFlags value ClMemFlags.DefaultIfData /// Allocate default value on device with specified memory flags. - let allocWithFlags<'a> (memFlags: ClMemFlags) = opencl { - let! context = ClTask.ask + let allocWithFlags<'a> (memFlags: ClMemFlags) = + opencl { + let! context = ClTask.ask - let buffer = new ClBuffer<'a>(context.ClContext, Size 1, memFlags) - return new ClCell<'a>(buffer) - } + let buffer = new ClBuffer<'a>(context.ClContext, Size 1, memFlags) + return new ClCell<'a>(buffer) + } /// Allocate empty array on device with default memory flags. - let alloc<'a> () = allocWithFlags<'a> ClMemFlags.DefaultIfNoData + let alloc<'a> () = + allocWithFlags<'a> ClMemFlags.DefaultIfNoData /// Transfers specified value from device to host. - let toHost (clCell: ClCell<'a>) = opencl { - let! context = ClTask.ask + let toHost (clCell: ClCell<'a>) = + opencl { + let! context = ClTask.ask + + let array = Array.zeroCreate<'a> 1 - let array = Array.zeroCreate<'a> 1 - return context.CommandQueue.PostAndReply(fun ch -> Msg.CreateToHostMsg(clCell.Buffer, array, ch)).[0] - } + return context.CommandQueue.PostAndReply(fun ch -> Msg.CreateToHostMsg(clCell.Buffer, array, ch)).[0] + } // TODO impl it - let copy (clCell: ClCell<'a>) = opencl { - failwith "Not implemented yet" - } + let copy (clCell: ClCell<'a>) = + opencl { failwith "Not implemented yet" } diff --git a/src/Brahma.FSharp.OpenCL.Core/IKernel.fs b/src/Brahma.FSharp.OpenCL.Core/IKernel.fs index 56bd6e32..67e53b80 100644 --- a/src/Brahma.FSharp.OpenCL.Core/IKernel.fs +++ b/src/Brahma.FSharp.OpenCL.Core/IKernel.fs @@ -4,5 +4,5 @@ open OpenCL.Net /// Interface representing an OpenCL kernel. type IKernel = - abstract Kernel : Kernel - abstract NDRange : INDRange + abstract Kernel: Kernel + abstract NDRange: INDRange diff --git a/src/Brahma.FSharp.OpenCL.Core/Messages.fs b/src/Brahma.FSharp.OpenCL.Core/Messages.fs index a3a0c6ae..f9a702c4 100644 --- a/src/Brahma.FSharp.OpenCL.Core/Messages.fs +++ b/src/Brahma.FSharp.OpenCL.Core/Messages.fs @@ -18,24 +18,28 @@ type Run(kernel: IKernel) = member this.Kernel = kernel type IRunCrate = - abstract member Apply : IRunCrateEvaluator -> unit + abstract member Apply: IRunCrateEvaluator -> unit + and IRunCrateEvaluator = - abstract member Eval : Run -> unit + abstract member Eval: Run -> unit type IToHostCrate = - abstract member Apply : IToHostCrateEvaluator -> unit + abstract member Apply: IToHostCrateEvaluator -> unit + and IToHostCrateEvaluator = - abstract member Eval : ToHost<'a> -> unit + abstract member Eval: ToHost<'a> -> unit type IToGPUCrate = - abstract member Apply : IToGPUCrateEvaluator -> unit + abstract member Apply: IToGPUCrateEvaluator -> unit + and IToGPUCrateEvaluator = - abstract member Eval : ToGPU<'a> -> unit + abstract member Eval: ToGPU<'a> -> unit type IFreeCrate = - abstract member Apply : IFreeCrateEvaluator -> unit + abstract member Apply: IFreeCrateEvaluator -> unit + and IFreeCrateEvaluator = - abstract member Eval : Free -> unit + abstract member Eval: Free -> unit type SyncObject(numToWait: int) = let mutable canContinue = false @@ -43,9 +47,12 @@ type SyncObject(numToWait: int) = let mutable counter = 0 member this.ImReady() = - lock this <| fun () -> + lock this + <| fun () -> counter <- counter + 1 - if counter = numToWait then canContinue <- true + + if counter = numToWait then + canContinue <- true member this.CanContinue() = canContinue @@ -61,26 +68,23 @@ type Msg = static member CreateToHostMsg<'a>(src, dst, ?ch) = { new IToHostCrate with - member this.Apply evaluator = evaluator.Eval <| ToHost<'a>(src, dst, ?replyChannel = ch) - } + member this.Apply evaluator = + evaluator.Eval <| ToHost<'a>(src, dst, ?replyChannel = ch) } |> MsgToHost static member CreateToGPUMsg<'a>(src, dst) = { new IToGPUCrate with - member this.Apply evaluator = evaluator.Eval <| ToGPU<'a>(src, dst) - } + member this.Apply evaluator = evaluator.Eval <| ToGPU<'a>(src, dst) } |> MsgToGPU static member CreateFreeMsg<'a>(src) = { new IFreeCrate with - member this.Apply evaluator = evaluator.Eval <| Free(src) - } + member this.Apply evaluator = evaluator.Eval <| Free(src) } |> MsgFree static member CreateRunMsg<'TRange, 'a when 'TRange :> INDRange>(kernel) = { new IRunCrate with - member this.Apply evaluator = evaluator.Eval <| Run(kernel) - } + member this.Apply evaluator = evaluator.Eval <| Run(kernel) } |> MsgRun static member CreateBarrierMessages(numOfQueuesOnBarrier: int) = diff --git a/src/Brahma.FSharp.OpenCL.Core/NDRange.fs b/src/Brahma.FSharp.OpenCL.Core/NDRange.fs index e1c465bf..076ac2d0 100644 --- a/src/Brahma.FSharp.OpenCL.Core/NDRange.fs +++ b/src/Brahma.FSharp.OpenCL.Core/NDRange.fs @@ -4,8 +4,8 @@ open System /// Interface representing n-dimensional index space. type INDRange = - abstract member GlobalWorkSize: IntPtr[] with get - abstract member LocalWorkSize: IntPtr[] with get + abstract member GlobalWorkSize: IntPtr[] + abstract member LocalWorkSize: IntPtr[] abstract member Dimensions: int (* @@ -29,17 +29,17 @@ type Range1D private (globalWorkSize: int, localWorkSize: int, __: unit) = new(globalWorkSize) = Range1D(globalWorkSize, 1) /// Gets the unique global work-item ID. - member this.GlobalID0 : int = FailIfOutsideKernel() + member this.GlobalID0: int = FailIfOutsideKernel() /// Gets the unique local work-item ID. - member this.LocalID0 : int = FailIfOutsideKernel() + member this.LocalID0: int = FailIfOutsideKernel() member this.GlobalWorkSize = globalWorkSize member this.LocalWorkSize = localWorkSize interface INDRange with - member this.GlobalWorkSize with get () = [| IntPtr globalWorkSize |] - member this.LocalWorkSize with get () = [| IntPtr localWorkSize |] + member this.GlobalWorkSize = [| IntPtr globalWorkSize |] + member this.LocalWorkSize = [| IntPtr localWorkSize |] member this.Dimensions = 1 /// @@ -72,27 +72,43 @@ type Range2D private (globalWorkSizeX: int, globalWorkSizeY: int, localWorkSizeX new(globalWorkSizeX, globalWorkSizeY) = Range2D(globalWorkSizeX, globalWorkSizeY, 1, 1) /// Gets the unique global work-item ID for dimension 0. - member this.GlobalID0 : int = FailIfOutsideKernel() + member this.GlobalID0: int = FailIfOutsideKernel() /// Gets the unique global work-item ID for dimension 1. - member this.GlobalID1 : int = FailIfOutsideKernel() + member this.GlobalID1: int = FailIfOutsideKernel() /// Gets the unique local work-item ID for dimension 0. - member this.LocalID0 : int = FailIfOutsideKernel() + member this.LocalID0: int = FailIfOutsideKernel() /// Gets the unique local work-item ID for dimension 1. - member this.LocalID1 : int = FailIfOutsideKernel() + member this.LocalID1: int = FailIfOutsideKernel() member this.GlobalWorkSize = (globalWorkSizeX, globalWorkSizeY) member this.LocalWorkSize = (localWorkSizeX, localWorkSizeY) interface INDRange with - member this.GlobalWorkSize with get () = [| IntPtr globalWorkSizeX; IntPtr globalWorkSizeY |] - member this.LocalWorkSize with get () = [| IntPtr localWorkSizeX; IntPtr localWorkSizeY |] + member this.GlobalWorkSize = + [| IntPtr globalWorkSizeX + IntPtr globalWorkSizeY |] + + member this.LocalWorkSize = + [| IntPtr localWorkSizeX + IntPtr localWorkSizeY |] + member this.Dimensions = 2 /// Represents 3-dimensional index space. -type Range3D private (globalWorkSizeX: int, globalWorkSizeY: int, globalWorkSizeZ: int, localWorkSizeX: int, localWorkSizeY: int, localWorkSizeZ: int, __: unit) = +type Range3D + private + ( + globalWorkSizeX: int, + globalWorkSizeY: int, + globalWorkSizeZ: int, + localWorkSizeX: int, + localWorkSizeY: int, + localWorkSizeZ: int, + __: unit + ) = /// /// Initializes a new instance of the class with specified global and local work size. /// @@ -102,7 +118,12 @@ type Range3D private (globalWorkSizeX: int, globalWorkSizeY: int, globalWorkSize /// Local work size for dimension 0 to use. /// Local work size for dimension 1 to use. /// Local work size for dimension 2 to use. - new(globalWorkSizeX: int, globalWorkSizeY: int, globalWorkSizeZ: int, localWorkSizeX: int, localWorkSizeY: int, localWorkSizeZ: int) = + new(globalWorkSizeX: int, + globalWorkSizeY: int, + globalWorkSizeZ: int, + localWorkSizeX: int, + localWorkSizeY: int, + localWorkSizeZ: int) = Range3D(globalWorkSizeX, globalWorkSizeY, globalWorkSizeZ, localWorkSizeX, localWorkSizeY, localWorkSizeZ) /// @@ -111,30 +132,39 @@ type Range3D private (globalWorkSizeX: int, globalWorkSizeY: int, globalWorkSize /// Global work size for dimension 0 to use. /// Global work size for dimension 1 to use. /// Global work size for dimension 2 to use. - new(globalWorkSizeX, globalWorkSizeY, globalWorkSizeZ) = Range3D(globalWorkSizeX, globalWorkSizeY, globalWorkSizeZ, 1, 1, 1) + new(globalWorkSizeX, globalWorkSizeY, globalWorkSizeZ) = + Range3D(globalWorkSizeX, globalWorkSizeY, globalWorkSizeZ, 1, 1, 1) /// Gets the unique global work-item ID for dimension 0. - member this.GlobalID0 : int = FailIfOutsideKernel() + member this.GlobalID0: int = FailIfOutsideKernel() /// Gets the unique global work-item ID for dimension 1. - member this.GlobalID1 : int = FailIfOutsideKernel() + member this.GlobalID1: int = FailIfOutsideKernel() /// Gets the unique global work-item ID for dimension 2. - member this.GlobalID2 : int = FailIfOutsideKernel() + member this.GlobalID2: int = FailIfOutsideKernel() /// Gets the unique local work-item ID for dimension 0. - member this.LocalID0 : int = FailIfOutsideKernel() + member this.LocalID0: int = FailIfOutsideKernel() /// Gets the unique local work-item ID for dimension 1. - member this.LocalID1 : int = FailIfOutsideKernel() + member this.LocalID1: int = FailIfOutsideKernel() /// Gets the unique local work-item ID for dimension 2. - member this.LocalID2 : int = FailIfOutsideKernel() + member this.LocalID2: int = FailIfOutsideKernel() member this.GlobalWorkSize = (globalWorkSizeX, globalWorkSizeY, globalWorkSizeZ) member this.LocalWorkSize = (localWorkSizeX, localWorkSizeY, localWorkSizeZ) interface INDRange with - member this.GlobalWorkSize with get () = [| IntPtr globalWorkSizeX; IntPtr globalWorkSizeY; IntPtr globalWorkSizeZ |] - member this.LocalWorkSize with get () = [| IntPtr localWorkSizeX; IntPtr localWorkSizeY; IntPtr globalWorkSizeZ |] + member this.GlobalWorkSize = + [| IntPtr globalWorkSizeX + IntPtr globalWorkSizeY + IntPtr globalWorkSizeZ |] + + member this.LocalWorkSize = + [| IntPtr localWorkSizeX + IntPtr localWorkSizeY + IntPtr globalWorkSizeZ |] + member this.Dimensions = 3 diff --git a/src/Brahma.FSharp.OpenCL.Core/RuntimeContext.fs b/src/Brahma.FSharp.OpenCL.Core/RuntimeContext.fs index 15316b63..ab12b1d7 100644 --- a/src/Brahma.FSharp.OpenCL.Core/RuntimeContext.fs +++ b/src/Brahma.FSharp.OpenCL.Core/RuntimeContext.fs @@ -2,14 +2,10 @@ namespace Brahma.FSharp type RuntimeOptions = { - // TODO if 2D or 3D - WorkgroupSize: int - } + // TODO if 2D or 3D + WorkgroupSize: int } - static member Default = - { - WorkgroupSize = 256 - } + static member Default = { WorkgroupSize = 256 } /// Provides a context to run OpenCL computation. type RuntimeContext(clContext: ClContext) = @@ -20,12 +16,12 @@ type RuntimeContext(clContext: ClContext) = new(clDevice: ClDevice) = RuntimeContext(ClContext(clDevice)) member this.RuntimeOptions - with get() = runtimeOptions - and private set(value) = runtimeOptions <- value + with get () = runtimeOptions + and private set (value) = runtimeOptions <- value member this.CommandQueue - with get() = queue - and private set(value) = queue <- value + with get () = queue + and private set (value) = queue <- value member this.ClContext = clContext diff --git a/src/Brahma.FSharp.OpenCL.Printer/Expressions.fs b/src/Brahma.FSharp.OpenCL.Printer/Expressions.fs index 6e4bf674..f79cb77c 100644 --- a/src/Brahma.FSharp.OpenCL.Printer/Expressions.fs +++ b/src/Brahma.FSharp.OpenCL.Printer/Expressions.fs @@ -45,9 +45,11 @@ module Expressions = let private printVar (varible: Variable<'lang>) = wordL varible.Name - let rec private printItem (itm: Item<'lang>) = (print itm.Arr) ++ squareBracketL (print itm.Idx) + let rec private printItem (itm: Item<'lang>) = + (print itm.Arr) ++ squareBracketL (print itm.Idx) - and private printIndirectionOp (deref: IndirectionOp<'lang>) = wordL "*" ++ (print deref.Expr |> bracketL) + and private printIndirectionOp (deref: IndirectionOp<'lang>) = + wordL "*" ++ (print deref.Expr |> bracketL) and private printBop (op: BOp<'lang>) = match op with @@ -76,7 +78,12 @@ module Expressions = let l = print binop.Left let r = print binop.Right let op = printBop binop.Op - [ l; op; r ] |> spaceListL |> bracketL + + [ l + op + r ] + |> spaceListL + |> bracketL and private printProperty (prop: Property<'lang>) = match prop.Property with @@ -136,28 +143,40 @@ module Expressions = and printNewStruct (newStruct: NewStruct<_>) = let args = List.map print newStruct.ConstructorArgs |> commaListL + match newStruct.Struct with - | :? StructInplaceType<_> -> [ wordL "{"; args; wordL "}" ] |> spaceListL + | :? StructInplaceType<_> -> + [ wordL "{" + args + wordL "}" ] + |> spaceListL | _ -> let t = Types.print newStruct.Struct - [ t |> bracketL; wordL "{"; args; wordL "}" ] |> spaceListL + + [ t |> bracketL + wordL "{" + args + wordL "}" ] + |> spaceListL and printNewUnion (newUnion: NewUnion<_>) = let arg = print newUnion.ConstructorArg - [ - wordL "{" - wordL <| "." + newUnion.ConstructorArgName - wordL "=" - arg - wordL "}" - ] + [ wordL "{" + wordL <| "." + newUnion.ConstructorArgName + wordL "=" + arg + wordL "}" ] |> spaceListL and printFfieldGet (fg: FieldGet<_>) = let host = print fg.Host let fld = wordL fg.Field - [ host |> bracketL; wordL "."; fld ] |> spaceListL + + [ host |> bracketL + wordL "." + fld ] + |> spaceListL and print (expr: Expression<'lang>) = match expr with diff --git a/src/Brahma.FSharp.OpenCL.Printer/FunDecl.fs b/src/Brahma.FSharp.OpenCL.Printer/FunDecl.fs index df35935b..95c70a9d 100644 --- a/src/Brahma.FSharp.OpenCL.Printer/FunDecl.fs +++ b/src/Brahma.FSharp.OpenCL.Printer/FunDecl.fs @@ -21,18 +21,16 @@ open Brahma.FSharp.OpenCL.Printer module FunDecl = let private printFunFormalParam (param: FunFormalArg<_>) = - [ - match param.DeclSpecs.AddressSpaceQualifier with - | Global -> yield wordL "__global" - | Local -> yield wordL "__local" - | _ -> yield wordL "private" + [ match param.DeclSpecs.AddressSpaceQualifier with + | Global -> yield wordL "__global" + | Local -> yield wordL "__local" + | _ -> yield wordL "private" - match param.DeclSpecs.Type with - | Some t -> yield Types.print t - | None -> failwith "Could not print a formal arg with undefined type" + match param.DeclSpecs.Type with + | Some t -> yield Types.print t + | None -> failwith "Could not print a formal arg with undefined type" - yield wordL param.Name - ] + yield wordL param.Name ] |> spaceListL let print<'lang> (funDecl: FunDecl<'lang>) = @@ -45,15 +43,13 @@ module FunDecl = | None -> false let header = - [ - match funDecl.DeclSpecs.FunQual with - | Some Kernel -> yield wordL "__kernel" - | None -> () - match funDecl.DeclSpecs.Type with - | Some t -> yield Types.print t - | None -> failwith "Could not print a func declaration with undefined return type" - yield wordL funDecl.Name - ] + [ match funDecl.DeclSpecs.FunQual with + | Some Kernel -> yield wordL "__kernel" + | None -> () + match funDecl.DeclSpecs.Type with + | Some t -> yield Types.print t + | None -> failwith "Could not print a func declaration with undefined return type" + yield wordL funDecl.Name ] |> spaceListL let formalParams = diff --git a/src/Brahma.FSharp.OpenCL.Printer/Pragmas.fs b/src/Brahma.FSharp.OpenCL.Printer/Pragmas.fs index ee998125..64e6390a 100644 --- a/src/Brahma.FSharp.OpenCL.Printer/Pragmas.fs +++ b/src/Brahma.FSharp.OpenCL.Printer/Pragmas.fs @@ -22,19 +22,9 @@ module Pragmas = let print (clp: CLPragma<_>) = match clp.Type with | CLGlobalInt32BaseAtomics -> - [ - "#pragma OPENCL EXTENSION cl_khr_global_int32_base_atomics : enable" - |> wordL - ] + [ "#pragma OPENCL EXTENSION cl_khr_global_int32_base_atomics : enable" |> wordL ] |> aboveListL | CLLocalInt32BaseAtomics -> - [ - "#pragma OPENCL EXTENSION cl_khr_local_int32_base_atomics : enable" - |> wordL - ] - |> aboveListL - | CLFP64 -> - [ - "#pragma OPENCL EXTENSION cl_khr_fp64 : enable" |> wordL - ] + [ "#pragma OPENCL EXTENSION cl_khr_local_int32_base_atomics : enable" |> wordL ] |> aboveListL + | CLFP64 -> [ "#pragma OPENCL EXTENSION cl_khr_fp64 : enable" |> wordL ] |> aboveListL diff --git a/src/Brahma.FSharp.OpenCL.Printer/Printer.fs b/src/Brahma.FSharp.OpenCL.Printer/Printer.fs index af8a0f3d..c7ad8d42 100644 --- a/src/Brahma.FSharp.OpenCL.Printer/Printer.fs +++ b/src/Brahma.FSharp.OpenCL.Printer/Printer.fs @@ -22,17 +22,14 @@ open Brahma.FSharp.OpenCL.Printer module AST = let print (ast: AST<'lang>) = ast.TopDefs - |> List.map - (fun d -> - match d with - | :? FunDecl<'lang> as fd -> FunDecl.print fd - | :? CLPragma<'lang> as clp -> Pragmas.print clp - | :? StructDecl<'lang> as s -> TypeDecl.printStructDeclaration s - | :? VarDecl<'lang> as s -> Statements.print false s - | _ -> failwithf "Printer. Unsupported toplevel declaration: %A" d - ) + |> List.map (fun d -> + match d with + | :? FunDecl<'lang> as fd -> FunDecl.print fd + | :? CLPragma<'lang> as clp -> Pragmas.print clp + | :? StructDecl<'lang> as s -> TypeDecl.printStructDeclaration s + | :? VarDecl<'lang> as s -> Statements.print false s + | _ -> failwithf "Printer. Unsupported toplevel declaration: %A" d) // |> LayoutOps.sepListL (LayoutOps.wordL "\r\n") // |> Display.layout_to_string FormatOptions.Default |> LayoutOps.aboveListL |> Display.layout_to_string { FormatOptions.Default with PrintWidth = 100 } - diff --git a/src/Brahma.FSharp.OpenCL.Printer/Statements.fs b/src/Brahma.FSharp.OpenCL.Printer/Statements.fs index becf6dd7..2bdcd022 100644 --- a/src/Brahma.FSharp.OpenCL.Printer/Statements.fs +++ b/src/Brahma.FSharp.OpenCL.Printer/Statements.fs @@ -23,11 +23,9 @@ open Microsoft.FSharp.Collections module Statements = let rec private printAssignment (a: Assignment<'lang>) = - [ - Expressions.print a.Name - wordL "=" - Expressions.print a.Value - ] + [ Expressions.print a.Name + wordL "=" + Expressions.print a.Value ] |> spaceListL and private printSpaceModeifier (sm: AddressSpaceQualifier<_>) = @@ -39,18 +37,17 @@ module Statements = | Default -> wordL "__default" and private printVarDecl (vd: VarDecl<'lang>) = - [ - if vd.SpaceModifier.IsSome then yield printSpaceModeifier vd.SpaceModifier.Value - yield Types.print vd.Type - yield wordL vd.Name - if vd.Type :? ArrayType<_> then yield wordL "[" ^^ wordL (string vd.Type.Size) ^^ wordL "]" - if vd.Expr.IsSome && not <| vd.IsLocal() then - yield [ - wordL "=" - Expressions.print vd.Expr.Value - ] - |> spaceListL - ] + [ if vd.SpaceModifier.IsSome then + yield printSpaceModeifier vd.SpaceModifier.Value + yield Types.print vd.Type + yield wordL vd.Name + if vd.Type :? ArrayType<_> then + yield wordL "[" ^^ wordL (string vd.Type.Size) ^^ wordL "]" + if vd.Expr.IsSome && not <| vd.IsLocal() then + yield + [ wordL "=" + Expressions.print vd.Expr.Value ] + |> spaceListL ] |> spaceListL and private printVar (v: Variable<'lang>) = wordL v.Name @@ -71,12 +68,10 @@ module Statements = | Some x -> print true x | None -> wordL "" - [ - yield wordL "if" ++ cond - yield then' - if if'.Else.IsSome then - yield aboveL (wordL "else") else' - ] + [ yield wordL "if" ++ cond + yield then' + if if'.Else.IsSome then + yield aboveL (wordL "else") else' ] |> aboveListL and private printForInteger (for': ForIntegerLoop<_>) = @@ -84,30 +79,28 @@ module Statements = let i = print true for'.Var let cModif = print true for'.CountModifier let body = print true for'.Body - let header = [ i; cond; cModif ] |> sepListL (wordL ";") |> bracketL - [ - yield wordL "for" ++ header - yield body - ] + let header = + [ i + cond + cModif ] + |> sepListL (wordL ";") + |> bracketL + + [ yield wordL "for" ++ header + yield body ] |> aboveListL and printWhileLoop (wl: WhileLoop<_>) = let cond = Expressions.print wl.Condition |> bracketL let body = print true wl.WhileBlock - [ - yield wordL "while" ++ cond - yield body - ] + [ yield wordL "while" ++ cond + yield body ] |> aboveListL and printFunCall (fc: FunCall<_>) = - let args = - fc.Args - |> List.map Expressions.print - |> commaListL - |> bracketL + let args = fc.Args |> List.map Expressions.print |> commaListL |> bracketL wordL fc.Name ++ args @@ -117,20 +110,19 @@ module Statements = | MemFence.Global -> wordL "barrier(CLK_GLOBAL_MEM_FENCE)" | Both -> wordL "barrier(CLK_LOCAL_MEM_FENCE | CLK_GLOBAL_MEM_FENCE)" - and printReturn (r: Return<_>) = wordL "return" ++ Expressions.print r.Expression + and printReturn (r: Return<_>) = + wordL "return" ++ Expressions.print r.Expression and printFieldSet (fs: FieldSet<_>) = let host = Expressions.print fs.Host let fld = wordL fs.Field let val' = Expressions.print fs.Val - [ - host |> bracketL - wordL "." - fld - wordL "=" - val' - ] + [ host |> bracketL + wordL "." + fld + wordL "=" + val' ] |> spaceListL and print isToplevel (stmt: Statement<'lang>) = @@ -150,7 +142,4 @@ module Statements = | :? Expression<'lang> as e -> Expressions.print e | _ -> failwithf $"Printer. Unsupported statement: {stmt}" - if isToplevel then - res - else - res ++ wordL ";" + if isToplevel then res else res ++ wordL ";" diff --git a/src/Brahma.FSharp.OpenCL.Printer/TypeDecl.fs b/src/Brahma.FSharp.OpenCL.Printer/TypeDecl.fs index a0dd07a0..1901c4ec 100644 --- a/src/Brahma.FSharp.OpenCL.Printer/TypeDecl.fs +++ b/src/Brahma.FSharp.OpenCL.Printer/TypeDecl.fs @@ -22,31 +22,23 @@ open Microsoft.FSharp.Text.StructuredFormat.LayoutOps module TypeDecl = let printStructDeclaration (decl: StructDecl<_>) = let header = - [ - wordL "typedef" - wordL "struct" - wordL decl.StructType.Name - ] + [ wordL "typedef" + wordL "struct" + wordL decl.StructType.Name ] |> spaceListL let flds = - [ - for f in decl.StructType.Fields -> - [ - Types.print f.Type - wordL f.Name - wordL ";" - ] - |> spaceListL - ] + [ for f in decl.StructType.Fields -> + [ Types.print f.Type + wordL f.Name + wordL ";" ] + |> spaceListL ] |> aboveListL |> braceL let footer = - [ - wordL decl.StructType.Name - wordL ";" - ] + [ wordL decl.StructType.Name + wordL ";" ] |> spaceListL header ^^ flds ^^ footer diff --git a/src/Brahma.FSharp.OpenCL.Printer/Types.fs b/src/Brahma.FSharp.OpenCL.Printer/Types.fs index 67e39c48..d85cbe97 100644 --- a/src/Brahma.FSharp.OpenCL.Printer/Types.fs +++ b/src/Brahma.FSharp.OpenCL.Printer/Types.fs @@ -54,23 +54,24 @@ module Types = | _ -> failwithf "Printer. Unsupported type: %A" type' and printAggregatingInplaceType keyword typeName fields = - let header = [ wordL keyword; wordL typeName ] |> spaceListL + let header = + [ wordL keyword + wordL typeName ] + |> spaceListL let body = - [ - for field in fields -> - [ - print field.Type - wordL field.Name - wordL ";" - ] - |> spaceListL - ] + [ for field in fields -> + [ print field.Type + wordL field.Name + wordL ";" ] + |> spaceListL ] |> aboveListL |> braceL header ^^ body - and printUnionInplaceType (t: UnionClInplaceType<_>) = printAggregatingInplaceType "union" t.Name t.Fields + and printUnionInplaceType (t: UnionClInplaceType<_>) = + printAggregatingInplaceType "union" t.Name t.Fields - and printStructInplaceType (t: StructInplaceType<_>) = printAggregatingInplaceType "struct" t.Name t.Fields + and printStructInplaceType (t: StructInplaceType<_>) = + printAggregatingInplaceType "struct" t.Name t.Fields diff --git a/src/Brahma.FSharp.OpenCL.Shared/IBuffer.fs b/src/Brahma.FSharp.OpenCL.Shared/IBuffer.fs index 970c37ec..8b4d622d 100644 --- a/src/Brahma.FSharp.OpenCL.Shared/IBuffer.fs +++ b/src/Brahma.FSharp.OpenCL.Shared/IBuffer.fs @@ -4,16 +4,15 @@ open OpenCL.Net open System type IClMem = - abstract member Size : IntPtr - abstract member Data : obj + abstract member Size: IntPtr + abstract member Data: obj type IBuffer<'a> = inherit IClMem inherit IDisposable - abstract Memory : IMem - abstract Length : int - abstract ElementSize : int - abstract Free : unit -> unit - abstract Item : int -> 'a with get, set - + abstract Memory: IMem + abstract Length: int + abstract ElementSize: int + abstract Free: unit -> unit + abstract Item: int -> 'a with get, set diff --git a/src/Brahma.FSharp.OpenCL.Shared/IDevice.fs b/src/Brahma.FSharp.OpenCL.Shared/IDevice.fs index fe4a2818..490a28f1 100644 --- a/src/Brahma.FSharp.OpenCL.Shared/IDevice.fs +++ b/src/Brahma.FSharp.OpenCL.Shared/IDevice.fs @@ -14,7 +14,8 @@ type DeviceType = | GPU | Default -type [] Byte +[] +type Byte type DeviceExtension = | CL_INTEL_ACCELERATOR diff --git a/src/Brahma.FSharp.OpenCL.Shared/KernelLangExtensions.fs b/src/Brahma.FSharp.OpenCL.Shared/KernelLangExtensions.fs index bdeff568..c0ebf53f 100644 --- a/src/Brahma.FSharp.OpenCL.Shared/KernelLangExtensions.fs +++ b/src/Brahma.FSharp.OpenCL.Shared/KernelLangExtensions.fs @@ -34,9 +34,19 @@ module KernelLangExtensions = failIfOutsideKernel () f - let inline inc (p: 'a) = failIfOutsideKernel (); p + LanguagePrimitives.GenericOne<'a> - let inline dec (p: 'a) = failIfOutsideKernel (); p - LanguagePrimitives.GenericOne<'a> + let inline inc (p: 'a) = + failIfOutsideKernel () + p + LanguagePrimitives.GenericOne<'a> + + let inline dec (p: 'a) = + failIfOutsideKernel () + p - LanguagePrimitives.GenericOne<'a> // работает для всех типов - let inline xchg (p: 'a) (value: 'a) = failIfOutsideKernel (); p - let inline cmpxchg (p: 'a) (cmp: 'a) (value: 'a) = failIfOutsideKernel (); if p = cmp then value else p + let inline xchg (p: 'a) (value: 'a) = + failIfOutsideKernel () + p + + let inline cmpxchg (p: 'a) (cmp: 'a) (value: 'a) = + failIfOutsideKernel () + if p = cmp then value else p diff --git a/src/Brahma.FSharp.OpenCL.Translator/Bindings.fs b/src/Brahma.FSharp.OpenCL.Translator/Bindings.fs index b43cdb48..31b39b42 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/Bindings.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/Bindings.fs @@ -4,13 +4,23 @@ open Brahma.FSharp.OpenCL.AST [] module Bindings = - let [] Range1D_ = "range1d" - let [] Range2D_ = "range2d" - let [] Range3D_ = "range3d" + [] + let Range1D_ = "range1d" - let [] ClArray_ = "clarray" - let [] ClCell_ = "clcell" - let [] IBuffer_ = "ibuffer" + [] + let Range2D_ = "range2d" + + [] + let Range3D_ = "range3d" + + [] + let ClArray_ = "clarray" + + [] + let ClCell_ = "clcell" + + [] + let IBuffer_ = "ibuffer" type BoolHostAlias = byte let BoolClAlias = UChar diff --git a/src/Brahma.FSharp.OpenCL.Translator/Body.fs b/src/Brahma.FSharp.OpenCL.Translator/Body.fs index 1d856b3a..21e5b34a 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/Body.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/Body.fs @@ -39,58 +39,24 @@ module private BodyPatterns = | _ when expected.ToLowerInvariant() = str.ToLowerInvariant() -> Some Lower | _ -> None - let (|ForLoopWithStep|_|) = function - | Patterns.Let - ( - VarName "inputSequence", - DerivedPatterns.SpecificCall <@ (.. ..) @> ( - _, - _, - [start; step; finish] - ), - Patterns.Let ( - VarName "enumerator", - _, - Patterns.TryFinally ( - Patterns.WhileLoop ( - _, - Patterns.Let ( - loopVar, - _, - loopBody - ) - ), - _ - ) - ) - ) -> Some (loopVar, (start, step, finish), loopBody) + let (|ForLoopWithStep|_|) = + function + | Patterns.Let(VarName "inputSequence", + DerivedPatterns.SpecificCall <@ (.. ..) @> (_, _, [ start; step; finish ]), + Patterns.Let(VarName "enumerator", + _, + Patterns.TryFinally(Patterns.WhileLoop(_, Patterns.Let(loopVar, _, loopBody)), _))) -> + Some(loopVar, (start, step, finish), loopBody) | _ -> None - let (|ForLoop|_|) = function - | Patterns.Let - ( - VarName "inputSequence", - DerivedPatterns.SpecificCall <@ (..) @> ( - _, - _, - [start; finish] - ), - Patterns.Let ( - VarName "enumerator", - _, - Patterns.TryFinally ( - Patterns.WhileLoop ( - _, - Patterns.Let ( - loopVar, - _, - loopBody - ) - ), - _ - ) - ) - ) -> Some (loopVar, (start, finish), loopBody) + let (|ForLoop|_|) = + function + | Patterns.Let(VarName "inputSequence", + DerivedPatterns.SpecificCall <@ (..) @> (_, _, [ start; finish ]), + Patterns.Let(VarName "enumerator", + _, + Patterns.TryFinally(Patterns.WhileLoop(_, Patterns.Let(loopVar, _, loopBody)), _))) -> + Some(loopVar, (start, finish), loopBody) | _ -> None module rec Body = @@ -98,40 +64,47 @@ module rec Body = let private clearContext (targetContext: TranslationContext<'a, 'b>) = { targetContext with VarDecls = ResizeArray() } - let toStb (s: Node<_>) = translation { - match s with - | :? StatementBlock<_> as s -> - return s - | x -> return StatementBlock <| ResizeArray [x :?> Statement<_>] - } - - let private itemHelper exprs hostVar = translation { - let! idx = translation { - match exprs with - | hd :: _ -> return! translateAsExpr hd - | [] -> return raise <| InvalidKernelException("Array index missed!") + let toStb (s: Node<_>) = + translation { + match s with + | :? StatementBlock<_> as s -> return s + | x -> return StatementBlock <| ResizeArray [ x :?> Statement<_> ] } - return idx, hostVar - } - - let private translateBinding (var: Var) newName (expr: Expr) = translation { - let! body = translateCond (*TranslateAsExpr*) expr - let! varType = translation { - match (body: Expression<_>) with - | :? Const<_> as c -> - return c.Type - | :? ArrayInitializer<_> as ai -> - return! Type.translate var.Type |> State.using (fun ctx -> { ctx with ArrayKind = CArrayDecl ai.Length }) - | _ -> return! Type.translate var.Type + let private itemHelper exprs hostVar = + translation { + let! idx = + translation { + match exprs with + | hd :: _ -> return! translateAsExpr hd + | [] -> return raise <| InvalidKernelException("Array index missed!") + } + + return idx, hostVar } - let varDecl = VarDecl(varType, newName, Some body) - if varType :? RefType then - varDecl.SpaceModifier <- Some AddressSpaceQualifier.Private + let private translateBinding (var: Var) newName (expr: Expr) = + translation { + let! body = translateCond (*TranslateAsExpr*) expr - return varDecl - } + let! varType = + translation { + match (body: Expression<_>) with + | :? Const<_> as c -> return c.Type + | :? ArrayInitializer<_> as ai -> + return! + Type.translate var.Type + |> State.using (fun ctx -> { ctx with ArrayKind = CArrayDecl ai.Length }) + | _ -> return! Type.translate var.Type + } + + let varDecl = VarDecl(varType, newName, Some body) + + if varType :? RefType then + varDecl.SpaceModifier <- Some AddressSpaceQualifier.Private + + return varDecl + } let private translateListOfArgs (args: Expr list) = args @@ -141,252 +114,413 @@ module rec Body = let! state = state let! translated = translateCond arg return translated :: state - } - ) (State.return' []) + }) + (State.return' []) |> State.map List.rev - let private translateCall exprOpt (mInfo: System.Reflection.MethodInfo) args = translation { - let! args = translateListOfArgs args - - match mInfo.Name.ToLowerInvariant() with - | "op_multiply" -> return Binop(Mult, args.[0], args.[1]) :> Statement<_> - | "op_addition" -> return Binop(Plus, args.[0], args.[1]) :> Statement<_> - | "op_division" -> return Binop(Div, args.[0], args.[1]) :> Statement<_> - | "op_lessthan" -> return Binop(Less, args.[0], args.[1]) :> Statement<_> - | "op_lessthanorequal" -> return Binop(LessEQ, args.[0], args.[1]) :> Statement<_> - | "op_greaterthan" -> return Binop(Great, args.[0], args.[1]) :> Statement<_> - | "op_greaterthanorequal" -> return Binop(GreatEQ, args.[0], args.[1]) :> Statement<_> - | "op_equality" -> return Binop(EQ, args.[0], args.[1]) :> Statement<_> - | "op_inequality" -> return Binop(NEQ, args.[0], args.[1]) :> Statement<_> - | "op_subtraction" -> return Binop(Minus, args.[0], args.[1]) :> Statement<_> - | "op_unarynegation" -> return Unop(UOp.Minus, args.[0]) :> Statement<_> - | "op_modulus" -> return Binop(Remainder, args.[0], args.[1]) :> Statement<_> - | "op_bitwiseand" -> return Binop(BitAnd, args.[0], args.[1]) :> Statement<_> - | "op_bitwiseor" -> return Binop(BitOr, args.[0], args.[1]) :> Statement<_> - | "op_exclusiveor" -> return Binop(BitXor, args.[0], args.[1]) :> Statement<_> - | "op_logicalnot" -> return Unop(UOp.BitNegation, args.[0]) :> Statement<_> - | "op_leftshift" -> return Binop(LeftShift, args.[0], args.[1]) :> Statement<_> - | "op_rightshift" -> return Binop(RightShift, args.[0], args.[1]) :> Statement<_> - | "op_booleanand" -> - let! flag = State.gets (fun context -> context.TranslatorOptions.UseNativeBooleanType) - if flag then - return Binop(And, args.[0], args.[1]) :> Statement<_> - else - return Binop(BitAnd, args.[0], args.[1]) :> Statement<_> - | "op_booleanor" -> - let! flag = State.gets (fun context -> context.TranslatorOptions.UseNativeBooleanType) - if flag then - return Binop(Or, args.[0], args.[1]) :> Statement<_> - else - return Binop(BitOr, args.[0], args.[1]) :> Statement<_> - | "not" -> return Unop(UOp.Not, args.[0]) :> Statement<_> - | "atomicadd" -> - do! State.modify (fun context -> context.Flags.Add EnableAtomic |> ignore; context) - return FunCall("atom_add", [args.[0]; args.[1]]) :> Statement<_> - | "atomicsub" -> - do! State.modify (fun context -> context.Flags.Add EnableAtomic |> ignore; context) - return FunCall("atom_sub", [args.[0]; args.[1]]) :> Statement<_> - | "atomicxchg" -> - do! State.modify (fun context -> context.Flags.Add EnableAtomic |> ignore; context) - return FunCall("atom_xchg", [args.[0]; args.[1]]) :> Statement<_> - | "atomicmax" -> - do! State.modify (fun context -> context.Flags.Add EnableAtomic |> ignore; context) - return FunCall("atom_max", [args.[0]; args.[1]]) :> Statement<_> - | "atomicmin" -> - do! State.modify (fun context -> context.Flags.Add EnableAtomic |> ignore; context) - return FunCall("atom_min", [args.[0]; args.[1]]) :> Statement<_> - | "atomicinc" -> - do! State.modify (fun context -> context.Flags.Add EnableAtomic |> ignore; context) - return FunCall("atom_inc", [args.[0]]) :> Statement<_> - | "atomicdec" -> - do! State.modify (fun context -> context.Flags.Add EnableAtomic |> ignore; context) - return FunCall("atom_dec", [args.[0]]) :> Statement<_> - | "atomiccmpxchg" -> - do! State.modify (fun context -> context.Flags.Add EnableAtomic |> ignore; context) - return FunCall("atom_cmpxchg", [args.[0]; args.[1]; args.[2]]) :> Statement<_> - | "atomicand" -> - do! State.modify (fun context -> context.Flags.Add EnableAtomic |> ignore; context) - return FunCall("atom_and", [args.[0]; args.[1]]) :> Statement<_> - | "atomicor" -> - do! State.modify (fun context -> context.Flags.Add EnableAtomic |> ignore; context) - return FunCall("atom_or", [args.[0]; args.[1]]) :> Statement<_> - | "atomicxor" -> - do! State.modify (fun context -> context.Flags.Add EnableAtomic |> ignore; context) - return FunCall("atom_xor", [args.[0]; args.[1]]) :> Statement<_> - | "todouble" -> return Cast(args.[0], PrimitiveType Float) :> Statement<_> - | "toint" -> return Cast(args.[0], PrimitiveType Int) :> Statement<_> - | "toint16" -> return Cast(args.[0], PrimitiveType Short) :> Statement<_> - | "tosingle" -> return Cast(args.[0], PrimitiveType Float) :> Statement<_> - | "tobyte" -> return Cast(args.[0], PrimitiveType UChar) :> Statement<_> - | "touint32" -> return Cast(args.[0], PrimitiveType UInt) :> Statement<_> - | "touint16" -> return Cast(args.[0], PrimitiveType UShort) :> Statement<_> - | "toint64" -> return Cast(args.[0], PrimitiveType Long) :> Statement<_> - | "touint64" -> return Cast(args.[0], PrimitiveType ULong) :> Statement<_> - | "min" - | "max" - | "acos" - | "asin" - | "atan" - | "cos" - | "cosh" - | "exp" - | "floor" - | "log" - | "log10" - | "pow" - | "sin" - | "sinh" - | "sqrt" - | "tan" - | "tanh" as fName -> - if - mInfo.DeclaringType.AssemblyQualifiedName.StartsWith("System.Math") || - mInfo.DeclaringType.AssemblyQualifiedName.StartsWith("Microsoft.FSharp.Core.Operators") - then - return FunCall(fName, args) :> Statement<_> - else - return raise <| InvalidKernelException $"Seems, that you use math function with name %s{fName} not from System.Math or Microsoft.FSharp.Core.Operators" - | "abs" as fName -> - if mInfo.DeclaringType.AssemblyQualifiedName.StartsWith("Microsoft.FSharp.Core.Operators") then - return FunCall("fabs", args) :> Statement<_> - else - return raise <| InvalidKernelException $"Seems, that you use math function with name %s{fName} not from System.Math or Microsoft.FSharp.Core.Operators" - | "powinteger" as fName -> - if mInfo.DeclaringType.AssemblyQualifiedName.StartsWith("Microsoft.FSharp.Core.Operators") then - return FunCall("powr", args) :> Statement<_> - else - return raise <| InvalidKernelException $"Seems, that you use math function with name %s{fName} not from System.Math or Microsoft.FSharp.Core.Operators" - | "ref" -> return Ptr args.[0] :> Statement<_> - | "op_dereference" -> return IndirectionOp args.[0] :> Statement<_> - | "op_colonequals" -> - return Assignment(Property(PropertyType.VarReference(IndirectionOp args.[0])), args.[1]) :> Statement<_> - | "setarray" -> - return Assignment(Property(PropertyType.Item(Item(args.[0], args.[1]))), args.[2]) :> Statement<_> - | "getarray" -> return Item(args.[0], args.[1]) :> Statement<_> - | "barrierlocal" -> return Barrier(MemFence.Local) :> Statement<_> - | "barrierglobal" -> return Barrier(MemFence.Global) :> Statement<_> - | "barrierfull" -> return Barrier(MemFence.Both) :> Statement<_> - | "local" -> return raise <| InvalidKernelException("Calling the local function is allowed only at the top level of the let binding") - | "arraylocal" -> return raise <| InvalidKernelException("Calling the localArray function is allowed only at the top level of the let binding") - | "zerocreate" -> - let length = - match args.[0] with - | :? Const as c -> int c.Val - | other -> raise <| InvalidKernelException $"Calling Array.zeroCreate with a non-const argument: %A{other}" - return ZeroArray length :> Statement<_> - | "fst" -> return FieldGet(args.[0], "_1") :> Statement<_> - | "snd" -> return FieldGet(args.[0], "_2") :> Statement<_> - | other -> return raise <| InvalidKernelException $"Unsupported call: %s{other}" - } - - // TODO: Refactoring: Safe pattern matching by expr type. - let private translateSpecificPropGet expr propName exprs = translation { - let! hostVar = translateAsExpr expr - - match propName with - | "globalid0i" | "globalid0" -> return FunCall("get_global_id", [Const(PrimitiveType Int, "0")]) :> Expression<_> - | "globalid1i" | "globalid1" -> return FunCall("get_global_id", [Const(PrimitiveType Int, "1")]) :> Expression<_> - | "globalid2i" | "globalid2" -> return FunCall("get_global_id", [Const(PrimitiveType Int, "2")]) :> Expression<_> - - | "localid0" -> return FunCall("get_local_id", [Const(PrimitiveType Int, "0")]) :> Expression<_> - | "localid1" -> return FunCall("get_local_id", [Const(PrimitiveType Int, "1")]) :> Expression<_> - | "localid2" -> return FunCall("get_local_id", [Const(PrimitiveType Int, "2")]) :> Expression<_> - - | "item" -> - let! (idx, hVar) = itemHelper exprs hostVar - return Item(hVar, idx) :> Expression<_> - - // TODO rewrite to active pattern - | "value" when - match expr with - | Patterns.Var v -> Some v - | _ -> None - |> Option.exists (fun v -> v.Type.Name.ToLower().StartsWith ClCell_) -> + let private translateCall exprOpt (mInfo: System.Reflection.MethodInfo) args = + translation { + let! args = translateListOfArgs args + + match mInfo.Name.ToLowerInvariant() with + | "op_multiply" -> return Binop(Mult, args.[0], args.[1]) :> Statement<_> + | "op_addition" -> return Binop(Plus, args.[0], args.[1]) :> Statement<_> + | "op_division" -> return Binop(Div, args.[0], args.[1]) :> Statement<_> + | "op_lessthan" -> return Binop(Less, args.[0], args.[1]) :> Statement<_> + | "op_lessthanorequal" -> return Binop(LessEQ, args.[0], args.[1]) :> Statement<_> + | "op_greaterthan" -> return Binop(Great, args.[0], args.[1]) :> Statement<_> + | "op_greaterthanorequal" -> return Binop(GreatEQ, args.[0], args.[1]) :> Statement<_> + | "op_equality" -> return Binop(EQ, args.[0], args.[1]) :> Statement<_> + | "op_inequality" -> return Binop(NEQ, args.[0], args.[1]) :> Statement<_> + | "op_subtraction" -> return Binop(Minus, args.[0], args.[1]) :> Statement<_> + | "op_unarynegation" -> return Unop(UOp.Minus, args.[0]) :> Statement<_> + | "op_modulus" -> return Binop(Remainder, args.[0], args.[1]) :> Statement<_> + | "op_bitwiseand" -> return Binop(BitAnd, args.[0], args.[1]) :> Statement<_> + | "op_bitwiseor" -> return Binop(BitOr, args.[0], args.[1]) :> Statement<_> + | "op_exclusiveor" -> return Binop(BitXor, args.[0], args.[1]) :> Statement<_> + | "op_logicalnot" -> return Unop(UOp.BitNegation, args.[0]) :> Statement<_> + | "op_leftshift" -> return Binop(LeftShift, args.[0], args.[1]) :> Statement<_> + | "op_rightshift" -> return Binop(RightShift, args.[0], args.[1]) :> Statement<_> + | "op_booleanand" -> + let! flag = State.gets (fun context -> context.TranslatorOptions.UseNativeBooleanType) + + if flag then + return Binop(And, args.[0], args.[1]) :> Statement<_> + else + return Binop(BitAnd, args.[0], args.[1]) :> Statement<_> + | "op_booleanor" -> + let! flag = State.gets (fun context -> context.TranslatorOptions.UseNativeBooleanType) - let! (idx, hVar) = itemHelper [Expr.Value 0] hostVar - return Item(hVar, idx) :> Expression<_> + if flag then + return Binop(Or, args.[0], args.[1]) :> Statement<_> + else + return Binop(BitOr, args.[0], args.[1]) :> Statement<_> + | "not" -> return Unop(UOp.Not, args.[0]) :> Statement<_> + | "atomicadd" -> + do! + State.modify (fun context -> + context.Flags.Add EnableAtomic |> ignore + context) + + return + FunCall( + "atom_add", + [ args.[0] + args.[1] ] + ) + :> Statement<_> + | "atomicsub" -> + do! + State.modify (fun context -> + context.Flags.Add EnableAtomic |> ignore + context) + + return + FunCall( + "atom_sub", + [ args.[0] + args.[1] ] + ) + :> Statement<_> + | "atomicxchg" -> + do! + State.modify (fun context -> + context.Flags.Add EnableAtomic |> ignore + context) + + return + FunCall( + "atom_xchg", + [ args.[0] + args.[1] ] + ) + :> Statement<_> + | "atomicmax" -> + do! + State.modify (fun context -> + context.Flags.Add EnableAtomic |> ignore + context) + + return + FunCall( + "atom_max", + [ args.[0] + args.[1] ] + ) + :> Statement<_> + | "atomicmin" -> + do! + State.modify (fun context -> + context.Flags.Add EnableAtomic |> ignore + context) + + return + FunCall( + "atom_min", + [ args.[0] + args.[1] ] + ) + :> Statement<_> + | "atomicinc" -> + do! + State.modify (fun context -> + context.Flags.Add EnableAtomic |> ignore + context) + + return FunCall("atom_inc", [ args.[0] ]) :> Statement<_> + | "atomicdec" -> + do! + State.modify (fun context -> + context.Flags.Add EnableAtomic |> ignore + context) + + return FunCall("atom_dec", [ args.[0] ]) :> Statement<_> + | "atomiccmpxchg" -> + do! + State.modify (fun context -> + context.Flags.Add EnableAtomic |> ignore + context) + + return + FunCall( + "atom_cmpxchg", + [ args.[0] + args.[1] + args.[2] ] + ) + :> Statement<_> + | "atomicand" -> + do! + State.modify (fun context -> + context.Flags.Add EnableAtomic |> ignore + context) + + return + FunCall( + "atom_and", + [ args.[0] + args.[1] ] + ) + :> Statement<_> + | "atomicor" -> + do! + State.modify (fun context -> + context.Flags.Add EnableAtomic |> ignore + context) + + return + FunCall( + "atom_or", + [ args.[0] + args.[1] ] + ) + :> Statement<_> + | "atomicxor" -> + do! + State.modify (fun context -> + context.Flags.Add EnableAtomic |> ignore + context) + + return + FunCall( + "atom_xor", + [ args.[0] + args.[1] ] + ) + :> Statement<_> + | "todouble" -> return Cast(args.[0], PrimitiveType Float) :> Statement<_> + | "toint" -> return Cast(args.[0], PrimitiveType Int) :> Statement<_> + | "toint16" -> return Cast(args.[0], PrimitiveType Short) :> Statement<_> + | "tosingle" -> return Cast(args.[0], PrimitiveType Float) :> Statement<_> + | "tobyte" -> return Cast(args.[0], PrimitiveType UChar) :> Statement<_> + | "touint32" -> return Cast(args.[0], PrimitiveType UInt) :> Statement<_> + | "touint16" -> return Cast(args.[0], PrimitiveType UShort) :> Statement<_> + | "toint64" -> return Cast(args.[0], PrimitiveType Long) :> Statement<_> + | "touint64" -> return Cast(args.[0], PrimitiveType ULong) :> Statement<_> + | "min" + | "max" + | "acos" + | "asin" + | "atan" + | "cos" + | "cosh" + | "exp" + | "floor" + | "log" + | "log10" + | "pow" + | "sin" + | "sinh" + | "sqrt" + | "tan" + | "tanh" as fName -> + if + mInfo.DeclaringType.AssemblyQualifiedName.StartsWith("System.Math") + || mInfo.DeclaringType.AssemblyQualifiedName.StartsWith("Microsoft.FSharp.Core.Operators") + then + return FunCall(fName, args) :> Statement<_> + else + return + raise + <| InvalidKernelException + $"Seems, that you use math function with name %s{fName} not from System.Math or Microsoft.FSharp.Core.Operators" + | "abs" as fName -> + if mInfo.DeclaringType.AssemblyQualifiedName.StartsWith("Microsoft.FSharp.Core.Operators") then + return FunCall("fabs", args) :> Statement<_> + else + return + raise + <| InvalidKernelException + $"Seems, that you use math function with name %s{fName} not from System.Math or Microsoft.FSharp.Core.Operators" + | "powinteger" as fName -> + if mInfo.DeclaringType.AssemblyQualifiedName.StartsWith("Microsoft.FSharp.Core.Operators") then + return FunCall("powr", args) :> Statement<_> + else + return + raise + <| InvalidKernelException + $"Seems, that you use math function with name %s{fName} not from System.Math or Microsoft.FSharp.Core.Operators" + | "ref" -> return Ptr args.[0] :> Statement<_> + | "op_dereference" -> return IndirectionOp args.[0] :> Statement<_> + | "op_colonequals" -> + return Assignment(Property(PropertyType.VarReference(IndirectionOp args.[0])), args.[1]) :> Statement<_> + | "setarray" -> + return Assignment(Property(PropertyType.Item(Item(args.[0], args.[1]))), args.[2]) :> Statement<_> + | "getarray" -> return Item(args.[0], args.[1]) :> Statement<_> + | "barrierlocal" -> return Barrier(MemFence.Local) :> Statement<_> + | "barrierglobal" -> return Barrier(MemFence.Global) :> Statement<_> + | "barrierfull" -> return Barrier(MemFence.Both) :> Statement<_> + | "local" -> + return + raise + <| InvalidKernelException( + "Calling the local function is allowed only at the top level of the let binding" + ) + | "arraylocal" -> + return + raise + <| InvalidKernelException( + "Calling the localArray function is allowed only at the top level of the let binding" + ) + | "zerocreate" -> + let length = + match args.[0] with + | :? Const as c -> int c.Val + | other -> + raise + <| InvalidKernelException $"Calling Array.zeroCreate with a non-const argument: %A{other}" + + return ZeroArray length :> Statement<_> + | "fst" -> return FieldGet(args.[0], "_1") :> Statement<_> + | "snd" -> return FieldGet(args.[0], "_2") :> Statement<_> + | other -> return raise <| InvalidKernelException $"Unsupported call: %s{other}" + } - | _ -> return raise <| InvalidKernelException $"Unsupported property in kernel: %A{propName}" - } + // TODO: Refactoring: Safe pattern matching by expr type. + let private translateSpecificPropGet expr propName exprs = + translation { + let! hostVar = translateAsExpr expr - let private translatePropGet (exprOpt: Expr Option) (propInfo: PropertyInfo) exprs = translation { - let propName = propInfo.Name.ToLowerInvariant() + match propName with + | "globalid0i" + | "globalid0" -> return FunCall("get_global_id", [ Const(PrimitiveType Int, "0") ]) :> Expression<_> + | "globalid1i" + | "globalid1" -> return FunCall("get_global_id", [ Const(PrimitiveType Int, "1") ]) :> Expression<_> + | "globalid2i" + | "globalid2" -> return FunCall("get_global_id", [ Const(PrimitiveType Int, "2") ]) :> Expression<_> + + | "localid0" -> return FunCall("get_local_id", [ Const(PrimitiveType Int, "0") ]) :> Expression<_> + | "localid1" -> return FunCall("get_local_id", [ Const(PrimitiveType Int, "1") ]) :> Expression<_> + | "localid2" -> return FunCall("get_local_id", [ Const(PrimitiveType Int, "2") ]) :> Expression<_> + + | "item" -> + let! (idx, hVar) = itemHelper exprs hostVar + return Item(hVar, idx) :> Expression<_> + + // TODO rewrite to active pattern + | "value" when + match expr with + | Patterns.Var v -> Some v + | _ -> None + |> Option.exists (fun v -> v.Type.Name.ToLower().StartsWith ClCell_) + -> + + let! (idx, hVar) = itemHelper [ Expr.Value 0 ] hostVar + return Item(hVar, idx) :> Expression<_> + + | _ -> return raise <| InvalidKernelException $"Unsupported property in kernel: %A{propName}" + } - match exprOpt with - | Some expr -> - match! State.gets (fun context -> context.CStructDecls.Keys |> Seq.contains expr.Type) with - | true -> - match! State.gets (fun context -> not <| context.CStructDecls.[expr.Type] :? DiscriminatedUnionType<_>) with - | true -> return! translateStructFieldGet expr propInfo.Name - | false -> return! translateUnionFieldGet expr propInfo - | false -> return! translateSpecificPropGet expr propName exprs + let private translatePropGet (exprOpt: Expr Option) (propInfo: PropertyInfo) exprs = + translation { + let propName = propInfo.Name.ToLowerInvariant() - | None -> - match propName with - | Lower (nameof Anchors._localID0) -> return FunCall("get_local_id", [Const(PrimitiveType Int, "0")]) :> Expression<_> + match exprOpt with + | Some expr -> + match! State.gets (fun context -> context.CStructDecls.Keys |> Seq.contains expr.Type) with + | true -> + match! + State.gets (fun context -> not <| context.CStructDecls.[expr.Type] :? DiscriminatedUnionType<_>) + with + | true -> return! translateStructFieldGet expr propInfo.Name + | false -> return! translateUnionFieldGet expr propInfo + | false -> return! translateSpecificPropGet expr propName exprs + + | None -> + match propName with + | Lower(nameof Anchors._localID0) -> + return FunCall("get_local_id", [ Const(PrimitiveType Int, "0") ]) :> Expression<_> + + | Lower(nameof Anchors._globalSize0) -> + return FunCall("get_global_size", [ Const(PrimitiveType Int, "0") ]) :> Expression<_> + | Lower(nameof Anchors._globalSize1) -> + return FunCall("get_global_size", [ Const(PrimitiveType Int, "1") ]) :> Expression<_> + | Lower(nameof Anchors._globalSize2) -> + return FunCall("get_global_size", [ Const(PrimitiveType Int, "2") ]) :> Expression<_> + + | Lower(nameof Anchors._localSize0) -> + return FunCall("get_local_size", [ Const(PrimitiveType Int, "0") ]) :> Expression<_> + | Lower(nameof Anchors._localSize1) -> + return FunCall("get_local_size", [ Const(PrimitiveType Int, "1") ]) :> Expression<_> + | Lower(nameof Anchors._localSize2) -> + return FunCall("get_local_size", [ Const(PrimitiveType Int, "2") ]) :> Expression<_> - | Lower (nameof Anchors._globalSize0) -> return FunCall("get_global_size", [Const(PrimitiveType Int, "0")]) :> Expression<_> - | Lower (nameof Anchors._globalSize1) -> return FunCall("get_global_size", [Const(PrimitiveType Int, "1")]) :> Expression<_> - | Lower (nameof Anchors._globalSize2) -> return FunCall("get_global_size", [Const(PrimitiveType Int, "2")]) :> Expression<_> + | _ -> + return + raise + <| InvalidKernelException $"Unsupported static property get in kernel: %A{propName}" + } - | Lower (nameof Anchors._localSize0) -> return FunCall("get_local_size", [Const(PrimitiveType Int, "0")]) :> Expression<_> - | Lower (nameof Anchors._localSize1) -> return FunCall("get_local_size", [Const(PrimitiveType Int, "1")]) :> Expression<_> - | Lower (nameof Anchors._localSize2) -> return FunCall("get_local_size", [Const(PrimitiveType Int, "2")]) :> Expression<_> + let private translatePropSet exprOpt (propInfo: System.Reflection.PropertyInfo) exprs newVal = + translation { + // TODO: Safe pattern matching (item) by expr type + let propName = propInfo.Name.ToLowerInvariant() - | _ -> return raise <| InvalidKernelException $"Unsupported static property get in kernel: %A{propName}" - } + match exprOpt with + | Some expr -> + let! hostVar = translateAsExpr expr + let! newVal' = translateAsExpr newVal - let private translatePropSet exprOpt (propInfo: System.Reflection.PropertyInfo) exprs newVal = translation { - // TODO: Safe pattern matching (item) by expr type - let propName = propInfo.Name.ToLowerInvariant() + return! + translation { + match propInfo.Name.ToLowerInvariant() with + | "item" -> + let! (idx, hVar) = itemHelper exprs hostVar + let item = Item(hVar, idx) + + return Assignment(Property(PropertyType.Item item), newVal') :> Statement<_> + // TODO rewrite to active pattern + | "value" when + match expr with + | Patterns.Var v -> Some v + | _ -> None + |> Option.exists (fun v -> v.Type.Name.ToLower().StartsWith ClCell_) + -> + + let! (idx, hVar) = itemHelper [ Expr.Value 0 ] hostVar + let item = Item(hVar, idx) + + return Assignment(Property(PropertyType.Item item), newVal') :> Statement<_> + | _ -> + let! translated = translateFieldSet expr propInfo.Name newVal + return translated :> Statement<_> + } + | None -> + return + raise + <| InvalidKernelException $"Unsupported static property set in kernel: %A{propName}" + } - match exprOpt with - | Some expr -> - let! hostVar = translateAsExpr expr - let! newVal' = translateAsExpr newVal - - return! translation { - match propInfo.Name.ToLowerInvariant() with - | "item" -> - let! (idx, hVar) = itemHelper exprs hostVar - let item = Item(hVar, idx) - return Assignment(Property(PropertyType.Item item), newVal') :> Statement<_> - // TODO rewrite to active pattern - | "value" when - match expr with - | Patterns.Var v -> Some v - | _ -> None - |> Option.exists (fun v -> v.Type.Name.ToLower().StartsWith ClCell_) -> + let translateAsExpr expr = + translation { + let! (translated: Node<_>) = translate expr + return translated :?> Expression<_> + } - let! (idx, hVar) = itemHelper [Expr.Value 0] hostVar - let item = Item(hVar, idx) - return Assignment(Property(PropertyType.Item item), newVal') :> Statement<_> - | _ -> - let! translated = translateFieldSet expr propInfo.Name newVal - return translated :> Statement<_> - } - | None -> return raise <| InvalidKernelException $"Unsupported static property set in kernel: %A{propName}" - } - - let translateAsExpr expr = translation { - let! (translated: Node<_>) = translate expr - return translated :?> Expression<_> - } - - let translateVar (var: Var) = translation { - match! State.gets (fun context -> context.Namer.GetCLVarName var.Name) with - | Some varName -> return Variable varName - | None -> - return raise <| InvalidKernelException $"Seems, that you try to use variable with name %A{var.Name}, that declared out of quotation. \ + let translateVar (var: Var) = + translation { + match! State.gets (fun context -> context.Namer.GetCLVarName var.Name) with + | Some varName -> return Variable varName + | None -> + return + raise + <| InvalidKernelException + $"Seems, that you try to use variable with name %A{var.Name}, that declared out of quotation. \ Please, pass it as quoted function's parameter." - } + } let translateValue (value: obj) (sType: System.Type) = translation { match sType.Name.ToLowerInvariant() with | "boolean" -> let! translatedType = Type.translate sType - let stringValue = if value.ToString().ToLowerInvariant() = "false" then "0" else "1" + + let stringValue = + if value.ToString().ToLowerInvariant() = "false" then + "0" + else + "1" + return translatedType, stringValue | typeName when typeName.EndsWith "[]" -> @@ -397,11 +531,11 @@ module rec Body = | "single[]" -> value :?> array |> Array.map string | _ -> raise <| InvalidKernelException $"Unsupported array type: %s{typeName}" - let! translatedType = Type.translate sType |> State.using (fun ctx -> { ctx with ArrayKind = CArrayDecl array.Length }) - let stringValue = - array - |> String.concat ", " - |> fun s -> "{ " + s + "}" + let! translatedType = + Type.translate sType + |> State.using (fun ctx -> { ctx with ArrayKind = CArrayDecl array.Length }) + + let stringValue = array |> String.concat ", " |> (fun s -> "{ " + s + "}") return translatedType, stringValue @@ -413,410 +547,502 @@ module rec Body = } |> State.map (fun (type', value) -> Const(type', value)) - let translateVarSet (var: Var) (expr: Expr) = translation { - let! var = translateVar var - let! expr = translateCond (*TranslateAsExpr*) expr - return Assignment(Property(PropertyType.Var var), expr) - } - - let translateCond (cond: Expr) = translation { - match cond with - | Patterns.IfThenElse (if', then', else') -> - let! l = translateCond if' - let! r = translateCond then' - let! e = translateCond else' - let! isBoolAsBit = State.gets (fun context -> context.TranslatorOptions.BoolAsBit) - let o1 = - match r with - | :? Const as c when c.Val = "1" -> l - | _ -> Binop((if isBoolAsBit then BitAnd else And), l, r) :> Expression<_> - - match e with - | :? Const as c when c.Val = "0" -> - return o1 - | _ -> return Binop((if isBoolAsBit then BitOr else Or), o1, e) :> Expression<_> - - | _ -> return! translateAsExpr cond - } - - let translateIf (cond: Expr) (thenBranch: Expr) (elseBranch: Expr) = translation { - let! if' = translateCond cond - let! then' = translate thenBranch >>= toStb |> State.using clearContext - let! else' = translation { - match elseBranch with - | Patterns.Value (null, sType) -> return None - | _ -> - return! - translate elseBranch >>= toStb - |> State.using clearContext - |> State.map Some + let translateVarSet (var: Var) (expr: Expr) = + translation { + let! var = translateVar var + let! expr = translateCond (*TranslateAsExpr*) expr + return Assignment(Property(PropertyType.Var var), expr) } - return IfThenElse(if', then', else') - } - - // NOTE reversed loops not supported - let translateForLoop (loopVar: Var) (from': Expr) (to': Expr) (step: Expr option) (body: Expr) = translation { - let! loopVarName = State.gets (fun context -> context.Namer.LetStart loopVar.Name) - let loopVarType = loopVar.Type + let translateCond (cond: Expr) = + translation { + match cond with + | Patterns.IfThenElse(if', then', else') -> + let! l = translateCond if' + let! r = translateCond then' + let! e = translateCond else' + let! isBoolAsBit = State.gets (fun context -> context.TranslatorOptions.BoolAsBit) + + let o1 = + match r with + | :? Const as c when c.Val = "1" -> l + | _ -> Binop((if isBoolAsBit then BitAnd else And), l, r) :> Expression<_> + + match e with + | :? Const as c when c.Val = "0" -> return o1 + | _ -> return Binop((if isBoolAsBit then BitOr else Or), o1, e) :> Expression<_> + + | _ -> return! translateAsExpr cond + } - let! loopVarBinding = translateBinding loopVar loopVarName from' + let translateIf (cond: Expr) (thenBranch: Expr) (elseBranch: Expr) = + translation { + let! if' = translateCond cond + let! then' = translate thenBranch >>= toStb |> State.using clearContext - let! condExpr = translateAsExpr to' - let loopCond = Binop(LessEQ, Variable loopVarName, condExpr) + let! else' = + translation { + match elseBranch with + | Patterns.Value(null, sType) -> return None + | _ -> return! translate elseBranch >>= toStb |> State.using clearContext |> State.map Some + } - do! State.modify (fun context -> context.Namer.LetIn loopVar.Name; context) + return IfThenElse(if', then', else') + } - let! loopVarModifier = - match step with - | Some step -> - Expr.VarSet( - loopVar, - Expr.Call( - Utils.makeGenericMethodCall [loopVarType; loopVarType; loopVarType] <@ (+) @>, - [Expr.Var loopVar; step] + // NOTE reversed loops not supported + let translateForLoop (loopVar: Var) (from': Expr) (to': Expr) (step: Expr option) (body: Expr) = + translation { + let! loopVarName = State.gets (fun context -> context.Namer.LetStart loopVar.Name) + let loopVarType = loopVar.Type + + let! loopVarBinding = translateBinding loopVar loopVarName from' + + let! condExpr = translateAsExpr to' + let loopCond = Binop(LessEQ, Variable loopVarName, condExpr) + + do! + State.modify (fun context -> + context.Namer.LetIn loopVar.Name + context) + + let! loopVarModifier = + match step with + | Some step -> + Expr.VarSet( + loopVar, + Expr.Call( + Utils.makeGenericMethodCall + [ loopVarType + loopVarType + loopVarType ] + <@ (+) @>, + [ Expr.Var loopVar + step ] + ) ) - ) - |> translate - |> State.map (fun node -> node :?> Statement<_>) - | None -> translation { return Unop(UOp.Incr, Variable loopVarName) :> Statement<_> } + |> translate + |> State.map (fun node -> node :?> Statement<_>) + | None -> translation { return Unop(UOp.Incr, Variable loopVarName) :> Statement<_> } + + let! loopBody = translate body >>= toStb |> State.using clearContext + + do! + State.modify (fun context -> + context.Namer.LetOut() + context) - let! loopBody = translate body >>= toStb |> State.using clearContext + return ForIntegerLoop(loopVarBinding, loopCond, loopVarModifier, loopBody) + } - do! State.modify (fun context -> context.Namer.LetOut(); context) + let translateWhileLoop condExpr bodyExpr = + translation { + let! nCond = translateCond condExpr + let! nBody = translate bodyExpr >>= toStb + return WhileLoop(nCond, nBody) + } - return ForIntegerLoop(loopVarBinding, loopCond, loopVarModifier, loopBody) - } + let translateSeq expr1 expr2 = + translation { + let linearized = ResizeArray() - let translateWhileLoop condExpr bodyExpr = translation { - let! nCond = translateCond condExpr - let! nBody = translate bodyExpr >>= toStb - return WhileLoop(nCond, nBody) - } + let rec go expr = + match expr with + | Patterns.Sequential(e1, e2) -> + go e1 + go e2 + | _ -> linearized.Add expr - let translateSeq expr1 expr2 = translation { - let linearized = ResizeArray() - let rec go expr = - match expr with - | Patterns.Sequential (e1, e2) -> - go e1 - go e2 - | _ -> linearized.Add expr + go expr1 + go expr2 - go expr1 - go expr2 + let! decls = State.gets (fun context -> ResizeArray(context.VarDecls)) - let! decls = State.gets (fun context -> ResizeArray(context.VarDecls)) - do! State.modify (fun context -> context.VarDecls.Clear(); context) + do! + State.modify (fun context -> + context.VarDecls.Clear() + context) - for expr in linearized do - do! State.modify (fun context -> context.VarDecls.Clear(); context) - match! translate expr with - | :? StatementBlock as s1 -> - decls.AddRange(s1.Statements) - | s1 -> decls.Add(s1 :?> Statement<_>) + for expr in linearized do + do! + State.modify (fun context -> + context.VarDecls.Clear() + context) - return StatementBlock decls - } + match! translate expr with + | :? StatementBlock as s1 -> decls.AddRange(s1.Statements) + | s1 -> decls.Add(s1 :?> Statement<_>) + + return StatementBlock decls + } // TODO change to lambdas and applications without rec - let translateApplication expr1 expr2 = translation { - let rec go expr vals args = - match expr with - | Patterns.Lambda (v, e) -> go e vals (v :: args) - | Patterns.Application (e1, e2) -> go e1 (e2 :: vals) args - | _ -> - if vals.Length = args.Length then - let argsDict = - vals - |> List.zip (List.rev args) - |> dict - - //failwith "Partial evaluation is not supported in kernel function." - expr.Substitute(fun v -> if argsDict.ContainsKey v then Some argsDict.[v] else None), true - else - expr, false + let translateApplication expr1 expr2 = + translation { + let rec go expr vals args = + match expr with + | Patterns.Lambda(v, e) -> go e vals (v :: args) + | Patterns.Application(e1, e2) -> go e1 (e2 :: vals) args + | _ -> + if vals.Length = args.Length then + let argsDict = vals |> List.zip (List.rev args) |> dict + //failwith "Partial evaluation is not supported in kernel function." + expr.Substitute(fun v -> if argsDict.ContainsKey v then Some argsDict.[v] else None), true + else + expr, false - let (body, doing) = go expr1 [expr2] [] - return body, doing - } + + let (body, doing) = go expr1 [ expr2 ] [] + return body, doing + } // TODO change to applications without rec - let translateApplicationFun expr1 expr2 = translation { - let rec go expr vals = translation { - match expr with - | Patterns.Application (e1, e2) -> - let! exp = translateAsExpr e2 - return! go e1 (exp :: vals) - | _ -> - // TODO fix it: return exception rather than expr.ToString() - // NOTE не поддерживается частичное применение - // NOTE не поддерживается композиция функций (или функции высшего порядка) - let funName = + let translateApplicationFun expr1 expr2 = + translation { + let rec go expr vals = + translation { match expr with - | Patterns.ValueWithName (_, _, name) -> name - | _ -> expr.ToString() + | Patterns.Application(e1, e2) -> + let! exp = translateAsExpr e2 + return! go e1 (exp :: vals) + | _ -> + // TODO fix it: return exception rather than expr.ToString() + // NOTE не поддерживается частичное применение + // NOTE не поддерживается композиция функций (или функции высшего порядка) + let funName = + match expr with + | Patterns.ValueWithName(_, _, name) -> name + | _ -> expr.ToString() + + return FunCall(funName, vals) :> Statement<_> + } - return FunCall(funName, vals) :> Statement<_> + let! exp = translateAsExpr expr2 + return! go expr1 [ exp ] } - let! exp = translateAsExpr expr2 - return! go expr1 [exp] - } - - let translateFieldSet host name value = translation { - let! hostE = translateAsExpr host - let! valE = translateAsExpr value - return FieldSet(hostE, name, valE) - } - - let translateStructFieldGet host name = translation { - let! hostE = translateAsExpr host - return FieldGet(hostE, name) :> Expression<_> - } - - let translateUnionFieldGet expr (propInfo: PropertyInfo) = translation { - let! unionType = State.gets (fun context -> context.CStructDecls.[expr.Type]) - let unionType = unionType :?> DiscriminatedUnionType - - let! unionValueExpr = translateAsExpr expr - - // для структур du классы наследники кейсов кстати тоже не создаются :) - let caseName = propInfo.DeclaringType.Name - let unionCaseField = - // для option классы наследники не создаются, поэтому нужно обрабатывать отдельно - if caseName <> "FSharpOption`1" then - unionType.GetCaseByName caseName - else - unionType.GetCaseByName "Some" - - match unionCaseField with - | Some unionCaseField -> - return - FieldGet( - FieldGet( - FieldGet(unionValueExpr, unionType.Data.Name), - unionCaseField.Name - ), - propInfo.Name - ) - :> Expression<_> - | None -> - return raise <| InvalidKernelException $"Union field get translation error: union %A{unionType.Name} doesn't have case %A{caseName}" - } - - let private translateLet (var: Var) expr inExpr = translation { - let! bName = State.gets (fun context -> context.Namer.LetStart var.Name) - - let! vDecl = translation { - match expr with - | DerivedPatterns.SpecificCall <@@ local @@> (_, _, _) -> - let! vType = Type.translate var.Type - return VarDecl(vType, bName, None, spaceModifier = Local) - | DerivedPatterns.SpecificCall <@@ localArray @@> (_, _, [arg]) -> - let! expr = translateCond arg - let arrayLength = - match expr with - | :? Const as c -> int c.Val - | other -> raise <| InvalidKernelException $"Calling localArray with a non-const argument %A{other}" - let! arrayType = Type.translate var.Type |> State.using (fun ctx -> { ctx with ArrayKind = CArrayDecl arrayLength }) - return VarDecl(arrayType, bName, None, spaceModifier = Local) - | Patterns.DefaultValue _ -> - let! vType = Type.translate var.Type - return VarDecl(vType, bName, None) - | _ -> return! translateBinding var bName expr + let translateFieldSet host name value = + translation { + let! hostE = translateAsExpr host + let! valE = translateAsExpr value + return FieldSet(hostE, name, valE) + } + + let translateStructFieldGet host name = + translation { + let! hostE = translateAsExpr host + return FieldGet(hostE, name) :> Expression<_> } - do! State.modify (fun context -> context.VarDecls.Add vDecl; context) - do! State.modify (fun context -> context.Namer.LetIn var.Name; context) + let translateUnionFieldGet expr (propInfo: PropertyInfo) = + translation { + let! unionType = State.gets (fun context -> context.CStructDecls.[expr.Type]) + let unionType = unionType :?> DiscriminatedUnionType - let! res = translate inExpr |> State.using clearContext - let! sb = State.gets (fun context -> context.VarDecls) + let! unionValueExpr = translateAsExpr expr - match res with - | :? StatementBlock as s -> sb.AddRange s.Statements - | _ -> sb.Add(res :?> Statement<_>) + // для структур du классы наследники кейсов кстати тоже не создаются :) + let caseName = propInfo.DeclaringType.Name - do! State.modify (fun context -> context.Namer.LetOut(); context) - do! State.modify clearContext + let unionCaseField = + // для option классы наследники не создаются, поэтому нужно обрабатывать отдельно + if caseName <> "FSharpOption`1" then + unionType.GetCaseByName caseName + else + unionType.GetCaseByName "Some" - return StatementBlock sb :> Node<_> - } + match unionCaseField with + | Some unionCaseField -> + return + FieldGet( + FieldGet(FieldGet(unionValueExpr, unionType.Data.Name), unionCaseField.Name), + propInfo.Name + ) + :> Expression<_> + | None -> + return + raise + <| InvalidKernelException + $"Union field get translation error: union %A{unionType.Name} doesn't have case %A{caseName}" + } - let private translateProvidedCall expr = translation { - let rec traverse expr args = translation { - match expr with - | Patterns.Value (calledName, sType) -> - match sType.Name.ToLowerInvariant() with - | "string" -> return (calledName :?> string), args - | _ -> return raise <| TranslationFailedException $"Failed to parse provided call, expected string call name: {expr}" - | Patterns.Sequential (expr1, expr2) -> - let! updatedArgs = translation { - match expr2 with - | Patterns.Value (null, _) -> return args // the last item in the sequence is null - | _ -> - let! a = translateAsExpr expr2 - return a :: args + let private translateLet (var: Var) expr inExpr = + translation { + let! bName = State.gets (fun context -> context.Namer.LetStart var.Name) + + let! vDecl = + translation { + match expr with + | DerivedPatterns.SpecificCall <@@ local @@> (_, _, _) -> + let! vType = Type.translate var.Type + return VarDecl(vType, bName, None, spaceModifier = Local) + | DerivedPatterns.SpecificCall <@@ localArray @@> (_, _, [ arg ]) -> + let! expr = translateCond arg + + let arrayLength = + match expr with + | :? Const as c -> int c.Val + | other -> + raise + <| InvalidKernelException $"Calling localArray with a non-const argument %A{other}" + + let! arrayType = + Type.translate var.Type + |> State.using (fun ctx -> { ctx with ArrayKind = CArrayDecl arrayLength }) + + return VarDecl(arrayType, bName, None, spaceModifier = Local) + | Patterns.DefaultValue _ -> + let! vType = Type.translate var.Type + return VarDecl(vType, bName, None) + | _ -> return! translateBinding var bName expr } - return! traverse expr1 updatedArgs - | _ -> return raise <| TranslationFailedException $"Failed to parse provided call: {expr}" + + do! + State.modify (fun context -> + context.VarDecls.Add vDecl + context) + + do! + State.modify (fun context -> + context.Namer.LetIn var.Name + context) + + let! res = translate inExpr |> State.using clearContext + let! sb = State.gets (fun context -> context.VarDecls) + + match res with + | :? StatementBlock as s -> sb.AddRange s.Statements + | _ -> sb.Add(res :?> Statement<_>) + + do! + State.modify (fun context -> + context.Namer.LetOut() + context) + + do! State.modify clearContext + + return StatementBlock sb :> Node<_> } - let! m = traverse expr [] - return FunCall m :> Node<_> - } + let private translateProvidedCall expr = + translation { + let rec traverse expr args = + translation { + match expr with + | Patterns.Value(calledName, sType) -> + match sType.Name.ToLowerInvariant() with + | "string" -> return (calledName :?> string), args + | _ -> + return + raise + <| TranslationFailedException + $"Failed to parse provided call, expected string call name: {expr}" + | Patterns.Sequential(expr1, expr2) -> + let! updatedArgs = + translation { + match expr2 with + | Patterns.Value(null, _) -> return args // the last item in the sequence is null + | _ -> + let! a = translateAsExpr expr2 + return a :: args + } + + return! traverse expr1 updatedArgs + | _ -> return raise <| TranslationFailedException $"Failed to parse provided call: {expr}" + } - let translate expr = translation { - let toNode (x: #Node<_>) = translation { - return x :> Node<_> + let! m = traverse expr [] + return FunCall m :> Node<_> } - match expr with - | Patterns.AddressOf expr -> return raise <| InvalidKernelException $"AddressOf is not supported: {expr}" - | Patterns.AddressSet expr -> return raise <| InvalidKernelException $"AddressSet is not supported: {expr}" - - | Patterns.Application (expr1, expr2) -> - let! (e, applying) = translateApplication expr1 expr2 - if applying then - return! translate e - else - return! translateApplicationFun expr1 expr2 >>= toNode - - | DerivedPatterns.SpecificCall <@@ print @@> (_, _, args) -> - match args with - | [ Patterns.ValueWithName (argTypes, _, _); - Patterns.ValueWithName (formatStr, _, _); - Patterns.ValueWithName (argValues, _, _) ] -> - - let formatStrArg = Const(PrimitiveType ConstStringLiteral, formatStr :?> string) :> Expression<_> - let! args' = translateListOfArgs (argValues :?> list) - return FunCall("printf", formatStrArg :: args') :> Node<_> - | _ -> return raise <| TranslationFailedException("printf: something going wrong.") - - | DerivedPatterns.SpecificCall <@ (|>) @> - ( - _, - _, - [expr; Patterns.Lambda(_, DerivedPatterns.SpecificCall <@ ignore @> (_, _, _))] - ) -> - return! translate expr - - | DerivedPatterns.SpecificCall <@ LanguagePrimitives.GenericOne @> (_, [onType], _) -> - let! type' = Type.translate onType - let value = - Expr.Call( - Utils.makeGenericMethodCall [onType] <@ LanguagePrimitives.GenericOne @>, - List.empty - ).EvaluateUntyped().ToString() - - return Const(type', value) :> Node<_> - - | Patterns.Call (exprOpt, mInfo, args) -> return! translateCall exprOpt mInfo args >>= toNode - | Patterns.Coerce (expr, sType) -> return raise <| InvalidKernelException $"Coerce is not supported: {expr}" - | Patterns.DefaultValue sType -> return raise <| InvalidKernelException $"DefaultValue is not supported: {expr}" - - | Patterns.FieldGet (exprOpt, fldInfo) -> - match exprOpt with - | Some expr -> return! translateStructFieldGet expr fldInfo.Name >>= toNode - | None -> return raise <| InvalidKernelException $"FieldGet for empty host is not supported. Field: %A{fldInfo.Name}" + let translate expr = + translation { + let toNode (x: #Node<_>) = translation { return x :> Node<_> } - | Patterns.FieldSet (exprOpt, fldInfo, expr) -> - match exprOpt with - | Some e -> return! translateFieldSet e fldInfo.Name expr >>= toNode - | None -> return raise <| InvalidKernelException $"Field set with empty host is not supported. Field: %A{fldInfo}" - - | ForLoopWithStep (loopVar, (start, step, finish), loopBody) -> return! translateForLoop loopVar start finish (Some step) loopBody >>= toNode - | ForLoop (loopVar, (start, finish), loopBody) -> return! translateForLoop loopVar start finish None loopBody >>= toNode - | Patterns.ForIntegerRangeLoop (loopVar, start, finish, loopBody) -> return! translateForLoop loopVar start finish None loopBody >>= toNode - | Patterns.IfThenElse (cond, thenExpr, elseExpr) -> return! translateIf cond thenExpr elseExpr >>= toNode - - | Patterns.Lambda (var, _expr) -> return raise <| InvalidKernelException $"Lambda is not supported: %A{expr}" - | Patterns.Let (var, expr, inExpr) -> - match var.Name with - | "___providedCallInfo" -> return! translateProvidedCall expr - | _ -> return! translateLet var expr inExpr - - | Patterns.LetRecursive (bindings, expr) -> return raise <| InvalidKernelException $"LetRecursive is not supported: {expr}" - | Patterns.NewArray (sType, exprs) -> return raise <| InvalidKernelException $"NewArray is not supported: {expr}" - | Patterns.NewDelegate (sType, vars, expr) -> return raise <| InvalidKernelException $"NewDelegate is not supported: {expr}" - - | Patterns.NewObject (constrInfo, exprs) -> - let! context = State.get - // let p = constrInfo. GetParameters() - // let p2 = constrInfo.GetMethodBody() - let! structInfo = Type.translate constrInfo.DeclaringType - let cArgs = exprs |> List.map (fun x -> translation { return! translateAsExpr x }) - return NewStruct<_>(structInfo :?> StructType, cArgs |> List.map (State.eval context)) :> Node<_> - - | Patterns.NewRecord (sType, exprs) -> - let! context = State.get - let! structInfo = Type.translate sType - let cArgs = exprs |> List.map (fun x -> translation { return! translateAsExpr x }) - return NewStruct<_>(structInfo :?> StructType, cArgs |> List.map (State.eval context)) :> Node<_> - - | Patterns.NewTuple (exprs) -> - let! context = State.get - let! tupleDecl = Type.translate expr.Type - let cArgs = exprs |> List.map (fun x -> translateAsExpr x) - return NewStruct<_>(tupleDecl :?> StructType, cArgs |> List.map (State.eval context)) :> Node<_> - - | Patterns.NewUnionCase (unionCaseInfo, exprs) -> - let! context = State.get - let! unionInfo = Type.translate unionCaseInfo.DeclaringType - let unionInfo = unionInfo :?> DiscriminatedUnionType - - let tag = Const(unionInfo.Tag.Type, string unionCaseInfo.Tag) :> Expression<_> - let args = - match unionInfo.GetCaseByTag unionCaseInfo.Tag with - | None -> [] - | Some field -> - let structArgs = exprs |> List.map (fun x -> translateAsExpr x) |> List.map (State.eval context) - NewUnion( - unionInfo.Data.Type :?> UnionClInplaceType<_>, - field.Name, - NewStruct(field.Type :?> StructType<_>, structArgs) - ) :> Expression<_> - |> List.singleton - - return NewStruct(unionInfo, tag :: args) :> Node<_> - - | Patterns.PropertyGet (exprOpt, propInfo, exprs) -> return! translatePropGet exprOpt propInfo exprs >>= toNode - | Patterns.PropertySet (exprOpt, propInfo, exprs, expr) -> return! translatePropSet exprOpt propInfo exprs expr >>= toNode - | Patterns.Sequential (expr1, expr2) -> return! translateSeq expr1 expr2 >>= toNode - | Patterns.TryFinally (tryExpr, finallyExpr) -> return raise <| InvalidKernelException $"TryFinally is not supported: {expr}" - | Patterns.TryWith (expr1, var1, expr2, var2, expr3) -> return raise <| InvalidKernelException $"TryWith is not supported: {expr}" - | Patterns.TupleGet (expr, i) -> return! translateStructFieldGet expr $"_{i + 1}" >>= toNode - | Patterns.TypeTest (expr, sType) -> return raise <| InvalidKernelException $"TypeTest is not supported: {expr}" - - | Patterns.UnionCaseTest (expr, unionCaseInfo) -> - let! unionInfo = Type.translate unionCaseInfo.DeclaringType - let unionInfo = unionInfo :?> DiscriminatedUnionType - - let! unionVarExpr = translateAsExpr expr - let unionGetTagExpr = FieldGet(unionVarExpr, unionInfo.Tag.Name) :> Expression<_> - // NOTE Const pog for genericOne - let tagExpr = Const(unionInfo.Tag.Type, string unionCaseInfo.Tag) :> Expression<_> - - return Binop(EQ, unionGetTagExpr, tagExpr) :> Node<_> - - | Patterns.ValueWithName (obj', sType, name) -> - let! context = State.get - // Here is the only use of TranslationContext.InLocal - if sType.ToString().EndsWith "[]" (*&& not context.InLocal*) then - context.Namer.AddVar name - let! res = translateValue obj' sType - context.TopLevelVarsDecls.Add( - VarDecl(res.Type, name, Some(res :> Expression<_>), AddressSpaceQualifier.Constant) - ) - let var = Var(name, sType) - return! translateVar var >>= toNode - else - return! translateValue obj' sType >>= toNode - - | Patterns.Value (obj', sType) -> return! translateValue obj' sType >>= toNode - | Patterns.Var var -> return! translateVar var >>= toNode - | Patterns.VarSet (var, expr) -> return! translateVarSet var expr >>= toNode - | Patterns.WhileLoop (condExpr, bodyExpr) -> return! translateWhileLoop condExpr bodyExpr >>= toNode - | _ -> return raise <| InvalidKernelException $"Following expression inside kernel is not supported:\n{expr}" - } + match expr with + | Patterns.AddressOf expr -> return raise <| InvalidKernelException $"AddressOf is not supported: {expr}" + | Patterns.AddressSet expr -> return raise <| InvalidKernelException $"AddressSet is not supported: {expr}" + + | Patterns.Application(expr1, expr2) -> + let! (e, applying) = translateApplication expr1 expr2 + + if applying then + return! translate e + else + return! translateApplicationFun expr1 expr2 >>= toNode + + | DerivedPatterns.SpecificCall <@@ print @@> (_, _, args) -> + match args with + | [ Patterns.ValueWithName(argTypes, _, _) + Patterns.ValueWithName(formatStr, _, _) + Patterns.ValueWithName(argValues, _, _) ] -> + + let formatStrArg = + Const(PrimitiveType ConstStringLiteral, formatStr :?> string) :> Expression<_> + + let! args' = translateListOfArgs (argValues :?> list) + return FunCall("printf", formatStrArg :: args') :> Node<_> + | _ -> return raise <| TranslationFailedException("printf: something going wrong.") + + | DerivedPatterns.SpecificCall <@ (|>) @> (_, + _, + [ expr + Patterns.Lambda(_, + DerivedPatterns.SpecificCall <@ ignore @> (_, + _, + _)) ]) -> + return! translate expr + + | DerivedPatterns.SpecificCall <@ LanguagePrimitives.GenericOne @> (_, [ onType ], _) -> + let! type' = Type.translate onType + + let value = + Expr + .Call( + Utils.makeGenericMethodCall [ onType ] <@ LanguagePrimitives.GenericOne @>, + List.empty + ) + .EvaluateUntyped() + .ToString() + + return Const(type', value) :> Node<_> + + | Patterns.Call(exprOpt, mInfo, args) -> return! translateCall exprOpt mInfo args >>= toNode + | Patterns.Coerce(expr, sType) -> return raise <| InvalidKernelException $"Coerce is not supported: {expr}" + | Patterns.DefaultValue sType -> + return raise <| InvalidKernelException $"DefaultValue is not supported: {expr}" + + | Patterns.FieldGet(exprOpt, fldInfo) -> + match exprOpt with + | Some expr -> return! translateStructFieldGet expr fldInfo.Name >>= toNode + | None -> + return + raise + <| InvalidKernelException $"FieldGet for empty host is not supported. Field: %A{fldInfo.Name}" + + | Patterns.FieldSet(exprOpt, fldInfo, expr) -> + match exprOpt with + | Some e -> return! translateFieldSet e fldInfo.Name expr >>= toNode + | None -> + return + raise + <| InvalidKernelException $"Field set with empty host is not supported. Field: %A{fldInfo}" + + | ForLoopWithStep(loopVar, (start, step, finish), loopBody) -> + return! translateForLoop loopVar start finish (Some step) loopBody >>= toNode + | ForLoop(loopVar, (start, finish), loopBody) -> + return! translateForLoop loopVar start finish None loopBody >>= toNode + | Patterns.ForIntegerRangeLoop(loopVar, start, finish, loopBody) -> + return! translateForLoop loopVar start finish None loopBody >>= toNode + | Patterns.IfThenElse(cond, thenExpr, elseExpr) -> return! translateIf cond thenExpr elseExpr >>= toNode + + | Patterns.Lambda(var, _expr) -> return raise <| InvalidKernelException $"Lambda is not supported: %A{expr}" + | Patterns.Let(var, expr, inExpr) -> + match var.Name with + | "___providedCallInfo" -> return! translateProvidedCall expr + | _ -> return! translateLet var expr inExpr + + | Patterns.LetRecursive(bindings, expr) -> + return raise <| InvalidKernelException $"LetRecursive is not supported: {expr}" + | Patterns.NewArray(sType, exprs) -> + return raise <| InvalidKernelException $"NewArray is not supported: {expr}" + | Patterns.NewDelegate(sType, vars, expr) -> + return raise <| InvalidKernelException $"NewDelegate is not supported: {expr}" + + | Patterns.NewObject(constrInfo, exprs) -> + let! context = State.get + // let p = constrInfo. GetParameters() + // let p2 = constrInfo.GetMethodBody() + let! structInfo = Type.translate constrInfo.DeclaringType + let cArgs = exprs |> List.map (fun x -> translation { return! translateAsExpr x }) + + return NewStruct<_>(structInfo :?> StructType, cArgs |> List.map (State.eval context)) :> Node<_> + + | Patterns.NewRecord(sType, exprs) -> + let! context = State.get + let! structInfo = Type.translate sType + let cArgs = exprs |> List.map (fun x -> translation { return! translateAsExpr x }) + + return NewStruct<_>(structInfo :?> StructType, cArgs |> List.map (State.eval context)) :> Node<_> + + | Patterns.NewTuple(exprs) -> + let! context = State.get + let! tupleDecl = Type.translate expr.Type + let cArgs = exprs |> List.map (fun x -> translateAsExpr x) + + return NewStruct<_>(tupleDecl :?> StructType, cArgs |> List.map (State.eval context)) :> Node<_> + + | Patterns.NewUnionCase(unionCaseInfo, exprs) -> + let! context = State.get + let! unionInfo = Type.translate unionCaseInfo.DeclaringType + let unionInfo = unionInfo :?> DiscriminatedUnionType + + let tag = Const(unionInfo.Tag.Type, string unionCaseInfo.Tag) :> Expression<_> + + let args = + match unionInfo.GetCaseByTag unionCaseInfo.Tag with + | None -> [] + | Some field -> + let structArgs = + exprs |> List.map (fun x -> translateAsExpr x) |> List.map (State.eval context) + + NewUnion( + unionInfo.Data.Type :?> UnionClInplaceType<_>, + field.Name, + NewStruct(field.Type :?> StructType<_>, structArgs) + ) + :> Expression<_> + |> List.singleton + + return NewStruct(unionInfo, tag :: args) :> Node<_> + + | Patterns.PropertyGet(exprOpt, propInfo, exprs) -> + return! translatePropGet exprOpt propInfo exprs >>= toNode + | Patterns.PropertySet(exprOpt, propInfo, exprs, expr) -> + return! translatePropSet exprOpt propInfo exprs expr >>= toNode + | Patterns.Sequential(expr1, expr2) -> return! translateSeq expr1 expr2 >>= toNode + | Patterns.TryFinally(tryExpr, finallyExpr) -> + return raise <| InvalidKernelException $"TryFinally is not supported: {expr}" + | Patterns.TryWith(expr1, var1, expr2, var2, expr3) -> + return raise <| InvalidKernelException $"TryWith is not supported: {expr}" + | Patterns.TupleGet(expr, i) -> return! translateStructFieldGet expr $"_{i + 1}" >>= toNode + | Patterns.TypeTest(expr, sType) -> + return raise <| InvalidKernelException $"TypeTest is not supported: {expr}" + + | Patterns.UnionCaseTest(expr, unionCaseInfo) -> + let! unionInfo = Type.translate unionCaseInfo.DeclaringType + let unionInfo = unionInfo :?> DiscriminatedUnionType + + let! unionVarExpr = translateAsExpr expr + let unionGetTagExpr = FieldGet(unionVarExpr, unionInfo.Tag.Name) :> Expression<_> + // NOTE Const pog for genericOne + let tagExpr = Const(unionInfo.Tag.Type, string unionCaseInfo.Tag) :> Expression<_> + + return Binop(EQ, unionGetTagExpr, tagExpr) :> Node<_> + + | Patterns.ValueWithName(obj', sType, name) -> + let! context = State.get + // Here is the only use of TranslationContext.InLocal + if sType.ToString().EndsWith "[]" (*&& not context.InLocal*) then + context.Namer.AddVar name + let! res = translateValue obj' sType + + context.TopLevelVarsDecls.Add( + VarDecl(res.Type, name, Some(res :> Expression<_>), AddressSpaceQualifier.Constant) + ) + + let var = Var(name, sType) + return! translateVar var >>= toNode + else + return! translateValue obj' sType >>= toNode + + | Patterns.Value(obj', sType) -> return! translateValue obj' sType >>= toNode + | Patterns.Var var -> return! translateVar var >>= toNode + | Patterns.VarSet(var, expr) -> return! translateVarSet var expr >>= toNode + | Patterns.WhileLoop(condExpr, bodyExpr) -> return! translateWhileLoop condExpr bodyExpr >>= toNode + | _ -> + return + raise + <| InvalidKernelException $"Following expression inside kernel is not supported:\n{expr}" + } diff --git a/src/Brahma.FSharp.OpenCL.Translator/CustomMarshaller.fs b/src/Brahma.FSharp.OpenCL.Translator/CustomMarshaller.fs index 20e8cf53..fc3883ce 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/CustomMarshaller.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/CustomMarshaller.fs @@ -10,11 +10,11 @@ open System.Runtime.Serialization open FSharpx.Collections type StructurePacking = - { - Size: int - Alignment: int - Members: {| Pack: StructurePacking; Offsets: int|} list - } + { Size: int + Alignment: int + Members: + {| Pack: StructurePacking + Offsets: int |} list } type CustomMarshaller() = let typePacking = ConcurrentDictionary() @@ -23,21 +23,20 @@ type CustomMarshaller() = let blittableTypes = ConcurrentDictionary( - dict [ - typeof, false - typeof, true - typeof, true - typeof, true - typeof, true - typeof, true - typeof, true - typeof, true - typeof, true - typeof, true - typeof, true - typeof, true - typeof, true - ] + dict + [ typeof, false + typeof, true + typeof, true + typeof, true + typeof, true + typeof, true + typeof, true + typeof, true + typeof, true + typeof, true + typeof, true + typeof, true + typeof, true ] ) let (|TupleType|RecordType|UnionType|UserDefinedStructureType|PrimitiveType|) (type': Type) = @@ -63,11 +62,9 @@ type CustomMarshaller() = // TODO issues with multithreading member this.GetTypePacking(type': Type) = let getAlignment elems = - elems - |> List.map (fun pack -> pack.Alignment) - |> List.max + elems |> List.map (fun pack -> pack.Alignment) |> List.max - let getSize alignment elems = + let getSize alignment elems = elems |> List.fold (fun state x -> Utils.roundUp x.Alignment state + x.Size) 0 |> Utils.roundUp alignment @@ -86,17 +83,16 @@ type CustomMarshaller() = let rec go (type': Type) = match type' with | TupleType -> - let elems = - FSharpType.GetTupleElements type' - |> Array.map go - |> Array.toList + let elems = FSharpType.GetTupleElements type' |> Array.map go |> Array.toList let alignment = elems |> getAlignment let size = elems |> getSize alignment let offsets = elems |> getOffsets let members = (elems, offsets) ||> getMembers - { Size = size; Alignment = alignment; Members = members } + { Size = size + Alignment = alignment + Members = members } | RecordType -> let elems = @@ -110,22 +106,23 @@ type CustomMarshaller() = let offsets = elems |> getOffsets let members = (elems, offsets) ||> getMembers - { Size = size; Alignment = alignment; Members = members } + { Size = size + Alignment = alignment + Members = members } | UnionType -> let tag = go typeof + let nonEmptyFieldsTypes = FSharpType.GetUnionCases type' - |> Array.map - (fun unionCase -> - unionCase.GetFields() - |> Array.map (fun pi -> pi.PropertyType) - ) + |> Array.map (fun unionCase -> unionCase.GetFields() |> Array.map (fun pi -> pi.PropertyType)) |> Array.filter (fun a -> a.Length <> 0) let unionPacking = if nonEmptyFieldsTypes.Length = 0 then - { Size = 0; Alignment = 1; Members = [] } + { Size = 0 + Alignment = 1 + Members = [] } else let packingList = nonEmptyFieldsTypes @@ -134,25 +131,26 @@ type CustomMarshaller() = |> Array.toList let unionAlignment = - packingList - |> List.map (fun pack -> pack.Alignment) - |> List.max + packingList |> List.map (fun pack -> pack.Alignment) |> List.max - let unionSize = - packingList - |> List.map (fun pack -> pack.Size) - |> List.max + let unionSize = packingList |> List.map (fun pack -> pack.Size) |> List.max - { Size = unionSize; Alignment = unionAlignment; Members = [] } + { Size = unionSize + Alignment = unionAlignment + Members = [] } - let elems = [tag; unionPacking] + let elems = + [ tag + unionPacking ] let alignment = elems |> getAlignment let size = elems |> getSize alignment let offsets = elems |> getOffsets let members = (elems, offsets) ||> getMembers - { Size = size; Alignment = alignment; Members = members } + { Size = size + Alignment = alignment + Members = members } | UserDefinedStructureType -> let elems = @@ -166,16 +164,29 @@ type CustomMarshaller() = let offsets = elems |> getOffsets let members = (elems, offsets) ||> getMembers - { Size = size; Alignment = alignment; Members = members } + { Size = size + Alignment = alignment + Members = members } | PrimitiveType -> - let size = Marshal.SizeOf (if type' = typeof then typeof else type') + let size = + Marshal.SizeOf( + if type' = typeof then + typeof + else + type' + ) + let alignment = size - { Size = size; Alignment = alignment; Members = [] } + + { Size = size + Alignment = alignment + Members = [] } go type' let mutable packing = Unchecked.defaultof + if typePacking.TryGetValue(type', &packing) then packing else @@ -191,26 +202,26 @@ type CustomMarshaller() = for pack in packing.Members do let offset = Utils.roundUp pack.Pack.Alignment size - offsets.Add (offset + start) + offsets.Add(offset + start) size <- offset + pack.Pack.Size offsets |> Seq.toList - let rec loop (packing: StructurePacking) (start: int) = seq { - match packing.Members with - | [] -> start - | _ -> - let packingOffsetPairs = - getFlattenOffsets start packing - |> List.zip packing.Members + let rec loop (packing: StructurePacking) (start: int) = + seq { + match packing.Members with + | [] -> start + | _ -> + let packingOffsetPairs = getFlattenOffsets start packing |> List.zip packing.Members - for (packing, offset) in packingOffsetPairs do - yield! loop packing.Pack offset - } + for (packing, offset) in packingOffsetPairs do + yield! loop packing.Pack offset + } loop packing 0 |> Seq.toArray let mutable offsets = Unchecked.defaultof + if typeOffsets.TryGetValue(type', &offsets) then offsets else @@ -220,6 +231,7 @@ type CustomMarshaller() = member this.IsBlittable(type': Type) = let mutable isBlittable = false + if blittableTypes.TryGetValue(type', &isBlittable) then isBlittable // TODO is array check useful here? @@ -238,9 +250,9 @@ type CustomMarshaller() = blittableTypes.TryAdd(type', isBlittable) |> ignore isBlittable with _ ->*) - isBlittable <- false - blittableTypes.TryAdd(type', isBlittable) |> ignore - isBlittable + isBlittable <- false + blittableTypes.TryAdd(type', isBlittable) |> ignore + isBlittable member this.WriteToUnmanaged(array: 'a[]) = let size = array.Length * this.GetTypePacking(typeof<'a>).Size @@ -250,8 +262,16 @@ type CustomMarshaller() = member this.WriteToUnmanaged(array: 'a[], ptr: IntPtr) = let rec write start (structure: obj) = - let offsets = this.GetTypeOffsets(if isNull structure then typeof else structure.GetType()) + let offsets = + this.GetTypeOffsets( + if isNull structure then + typeof + else + structure.GetType() + ) + let mutable i = 0 + let rec go (str: obj) = match str with | Tuple -> @@ -259,19 +279,20 @@ type CustomMarshaller() = let tupleSize = tuple.Length [ 0 .. tupleSize - 1 ] |> List.iter (fun i -> go tuple.[i]) - | Record -> - FSharpValue.GetRecordFields str - |> Array.iter go + | Record -> FSharpValue.GetRecordFields str |> Array.iter go | Union -> - let (case, data) = FSharpValue.GetUnionFields(str, if isNull str then typeof else str.GetType()) + let (case, data) = + FSharpValue.GetUnionFields(str, (if isNull str then typeof else str.GetType())) + go case.Tag if data.Length <> 0 then FSharpValue.MakeTuple( data, FSharpType.MakeTupleType( - data |> Array.map (fun o -> if isNull o then typeof else o.GetType()) + data + |> Array.map (fun o -> if isNull o then typeof else o.GetType()) ) ) |> write (IntPtr.Add(start, offsets.[i])) @@ -285,21 +306,24 @@ type CustomMarshaller() = | Primitive -> let offset = if isNull structure then 0 else offsets.[i] + let structure = if str.GetType() = typeof then box <| Convert.ToByte str else str + Marshal.StructureToPtr(structure, IntPtr.Add(start, offset), false) i <- i + 1 go structure - Array.Parallel.iteri (fun j item -> - let pack = this.GetTypePacking(typeof<'a>) - let start = IntPtr.Add(ptr, j * pack.Size) - write start item - ) array + Array.Parallel.iteri + (fun j item -> + let pack = this.GetTypePacking(typeof<'a>) + let start = IntPtr.Add(ptr, j * pack.Size) + write start item) + array array.Length * this.GetTypePacking(typeof<'a>).Size @@ -312,6 +336,7 @@ type CustomMarshaller() = let rec read start type' = let offsets = this.GetTypeOffsets(type') let mutable i = 0 + let rec go (type'': Type) = match type'' with | TupleType -> @@ -340,11 +365,13 @@ type CustomMarshaller() = |> read (IntPtr.Add(start, offsets.[i])) |> FSharpValue.GetTupleFields |> fun tupleFields -> FSharpValue.MakeUnion(case, tupleFields) + i <- i + 1 union | UserDefinedStructureType -> let inst = Activator.CreateInstance(type'') + type''.GetFields() |> Array.map (fun fi -> fi, go fi.FieldType) |> Array.iter (fun (fi, value) -> fi.SetValue(inst, value)) @@ -353,22 +380,29 @@ type CustomMarshaller() = | PrimitiveType -> let offset = offsets.[i] + let structure = Marshal.PtrToStructure( IntPtr.Add(start, offset), - if type'' = typeof then typeof else type'' + if type'' = typeof then + typeof + else + type'' ) + let structure = if type'' = typeof then box <| Convert.ToBoolean structure else structure + i <- i + 1 structure go type' - Array.Parallel.iteri (fun j _ -> - let start = IntPtr.Add(ptr, j * this.GetTypePacking(typeof<'a>).Size) - array.[j] <- unbox<'a> <| read start typeof<'a> - ) array + Array.Parallel.iteri + (fun j _ -> + let start = IntPtr.Add(ptr, j * this.GetTypePacking(typeof<'a>).Size) + array.[j] <- unbox<'a> <| read start typeof<'a>) + array diff --git a/src/Brahma.FSharp.OpenCL.Translator/Exceptions.fs b/src/Brahma.FSharp.OpenCL.Translator/Exceptions.fs index 11e36848..438fcb69 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/Exceptions.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/Exceptions.fs @@ -6,14 +6,14 @@ open System type InvalidKernelException = inherit Exception - new() = { inherit Exception() } // + new() = { inherit Exception() } // new(message: string) = { inherit Exception(message) } - new(message: string, inner: Exception) = { inherit Exception(message, inner) } // + new(message: string, inner: Exception) = { inherit Exception(message, inner) } // /// The exception that is thrown when the unexpected error occured during the translation. type TranslationFailedException = inherit Exception - new() = { inherit Exception() } // + new() = { inherit Exception() } // new(message: string) = { inherit Exception(message) } new(message: string, inner: Exception) = { inherit Exception(message, inner) } diff --git a/src/Brahma.FSharp.OpenCL.Translator/Methods.fs b/src/Brahma.FSharp.OpenCL.Translator/Methods.fs index ee0213df..b14ee895 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/Methods.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/Methods.fs @@ -19,189 +19,177 @@ type Method(var: Var, expr: Expr) = sb :> Statement<_> | :? Expression<'lang> as ex -> Return ex :> Statement<_> | :? IfThenElse<'lang> as ite -> - let newThen = - adding ite.Then :?> StatementBlock<_> + let newThen = adding ite.Then :?> StatementBlock<_> let newElse = if Option.isNone ite.Else then None else - Some (adding ite.Else.Value :?> StatementBlock<_>) + Some(adding ite.Else.Value :?> StatementBlock<_>) IfThenElse(ite.Condition, newThen, newElse) :> Statement<_> | _ -> failwithf $"Unsupported statement to add Return: %A{stmt}" adding subAST - abstract TranslateBody : Var list * Expr -> State> - default this.TranslateBody(args, body) = translation { - let! context = State.get + abstract TranslateBody: Var list * Expr -> State> - context.Namer.LetIn() - args |> List.iter (fun v -> context.Namer.AddVar v.Name) + default this.TranslateBody(args, body) = + translation { + let! context = State.get - let! newBody = Body.translate body + context.Namer.LetIn() + args |> List.iter (fun v -> context.Namer.AddVar v.Name) - return - match newBody with - | :? StatementBlock as sb -> sb - | :? Statement as s -> StatementBlock <| ResizeArray [s] - | _ -> failwithf $"Incorrect function body: %A{newBody}" - } + let! newBody = Body.translate body - abstract TranslateArgs : Var list * string list * string list -> State list> + return + match newBody with + | :? StatementBlock as sb -> sb + | :? Statement as s -> StatementBlock <| ResizeArray [ s ] + | _ -> failwithf $"Incorrect function body: %A{newBody}" + } - abstract BuildFunction : FunFormalArg list * StatementBlock -> State> + abstract TranslateArgs: Var list * string list * string list -> State list> - abstract GetTopLevelVarDecls : unit -> State list> - default this.GetTopLevelVarDecls() = translation { - let! context = State.get + abstract BuildFunction: FunFormalArg list * StatementBlock -> State> - return - context.TopLevelVarsDecls - |> Seq.cast<_> - |> List.ofSeq - } + abstract GetTopLevelVarDecls: unit -> State list> - abstract Translate : string list * string list -> State list> - default this.Translate(globalVars, localVars) = translation { - // TODO move it to translator? - do! State.modify (fun context -> context.WithNewLocalContext()) + default this.GetTopLevelVarDecls() = + translation { + let! context = State.get - match expr with - | DerivedPatterns.Lambdas (args, body) -> - let args = List.collect id args - let! translatedArgs = this.TranslateArgs(args, globalVars, localVars) - let! translatedBody = this.TranslateBody(args, body) - let! func = this.BuildFunction(translatedArgs, translatedBody) - let! topLevelVarDecls = this.GetTopLevelVarDecls() + return context.TopLevelVarsDecls |> Seq.cast<_> |> List.ofSeq + } - return topLevelVarDecls @ [func] + abstract Translate: string list * string list -> State list> - | _ -> return failwithf $"Incorrect OpenCL quotation: %A{expr}" - } + default this.Translate(globalVars, localVars) = + translation { + // TODO move it to translator? + do! State.modify (fun context -> context.WithNewLocalContext()) - override this.ToString() = - $"%A{var}\n%A{expr}" + match expr with + | DerivedPatterns.Lambdas(args, body) -> + let args = List.collect id args + let! translatedArgs = this.TranslateArgs(args, globalVars, localVars) + let! translatedBody = this.TranslateBody(args, body) + let! func = this.BuildFunction(translatedArgs, translatedBody) + let! topLevelVarDecls = this.GetTopLevelVarDecls() + + return topLevelVarDecls @ [ func ] + + | _ -> return failwithf $"Incorrect OpenCL quotation: %A{expr}" + } + + override this.ToString() = $"%A{var}\n%A{expr}" type KernelFunc(var: Var, expr: Expr) = inherit Method(var, expr) - override this.TranslateArgs(args, _, _) = translation { - let! context = State.get + override this.TranslateArgs(args, _, _) = + translation { + let! context = State.get - let brahmaDimensionsTypes = [ - Range1D_ - Range2D_ - Range3D_ - ] + let brahmaDimensionsTypes = + [ Range1D_ + Range2D_ + Range3D_ ] - return - args - |> List.filter - (fun (variable: Var) -> + return + args + |> List.filter (fun (variable: Var) -> brahmaDimensionsTypes - |> (not << List.contains (variable.Type.Name.ToLowerInvariant())) - ) - |> List.map - (fun variable -> + |> (not << List.contains (variable.Type.Name.ToLowerInvariant()))) + |> List.map (fun variable -> let vType = Type.translate variable.Type |> State.eval context let declSpecs = DeclSpecifierPack(typeSpecifier = vType) if vType :? RefType<_> then declSpecs.AddressSpaceQualifier <- Global - FunFormalArg(declSpecs, variable.Name) - ) - } + FunFormalArg(declSpecs, variable.Name)) + } - override this.BuildFunction(args, body) = translation { - let retFunType = PrimitiveType Void :> Type<_> - let declSpecs = DeclSpecifierPack(typeSpecifier = retFunType, funQualifier = Kernel) - return FunDecl(declSpecs, var.Name, args, body) :> ITopDef<_> - } + override this.BuildFunction(args, body) = + translation { + let retFunType = PrimitiveType Void :> Type<_> + let declSpecs = DeclSpecifierPack(typeSpecifier = retFunType, funQualifier = Kernel) + return FunDecl(declSpecs, var.Name, args, body) :> ITopDef<_> + } type Function(var: Var, expr: Expr) = inherit Method(var, expr) - override this.TranslateArgs(args, globalVars, localVars) = translation { - let! context = State.get - - return - args - |> List.map (fun variable -> - let vType = Type.translate variable.Type |> State.eval context - let declSpecs = DeclSpecifierPack(typeSpecifier = vType) - - if - vType :? RefType<_> && - globalVars |> List.contains variable.Name - then - declSpecs.AddressSpaceQualifier <- Global - elif - vType :? RefType<_> && - localVars |> List.contains variable.Name - then - declSpecs.AddressSpaceQualifier <- Local - - FunFormalArg(declSpecs, variable.Name) - ) - } - - override this.BuildFunction(args, body) = translation { - let! context = State.get - - let retFunType = Type.translate var.Type |> State.eval context - let declSpecs = DeclSpecifierPack(typeSpecifier = retFunType) - let partAST = - match retFunType with - | :? PrimitiveType as t when t.Type = Void -> body :> Statement<_> - | _ -> this.AddReturn(body) - - return FunDecl(declSpecs, var.Name, args, partAST) :> ITopDef<_> - } + override this.TranslateArgs(args, globalVars, localVars) = + translation { + let! context = State.get + + return + args + |> List.map (fun variable -> + let vType = Type.translate variable.Type |> State.eval context + let declSpecs = DeclSpecifierPack(typeSpecifier = vType) + + if vType :? RefType<_> && globalVars |> List.contains variable.Name then + declSpecs.AddressSpaceQualifier <- Global + elif vType :? RefType<_> && localVars |> List.contains variable.Name then + declSpecs.AddressSpaceQualifier <- Local + + FunFormalArg(declSpecs, variable.Name)) + } + + override this.BuildFunction(args, body) = + translation { + let! context = State.get + + let retFunType = Type.translate var.Type |> State.eval context + let declSpecs = DeclSpecifierPack(typeSpecifier = retFunType) + + let partAST = + match retFunType with + | :? PrimitiveType as t when t.Type = Void -> body :> Statement<_> + | _ -> this.AddReturn(body) + + return FunDecl(declSpecs, var.Name, args, partAST) :> ITopDef<_> + } type AtomicFunc(var: Var, expr: Expr, qual: AddressSpaceQualifier) = inherit Method(var, expr) - override this.TranslateArgs(args, globalVars, localVars) = translation { - let! context = State.get + override this.TranslateArgs(args, globalVars, localVars) = + translation { + let! context = State.get - let firstNonMutexIdx = - args - |> List.tryFindIndex (fun v -> not <| v.Name.EndsWith "Mutex") - |> Option.defaultValue 0 + let firstNonMutexIdx = + args + |> List.tryFindIndex (fun v -> not <| v.Name.EndsWith "Mutex") + |> Option.defaultValue 0 - return - args - |> List.mapi - (fun i variable -> + return + args + |> List.mapi (fun i variable -> let vType = Type.translate variable.Type |> State.eval context let declSpecs = DeclSpecifierPack(typeSpecifier = vType) if i = firstNonMutexIdx then declSpecs.AddressSpaceQualifier <- qual - elif - vType :? RefType<_> && - globalVars |> List.contains variable.Name - then + elif vType :? RefType<_> && globalVars |> List.contains variable.Name then declSpecs.AddressSpaceQualifier <- Global - elif - vType :? RefType<_> && - localVars |> List.contains variable.Name - then + elif vType :? RefType<_> && localVars |> List.contains variable.Name then declSpecs.AddressSpaceQualifier <- Local - FunFormalArg(declSpecs, variable.Name) - ) - } + FunFormalArg(declSpecs, variable.Name)) + } - override this.BuildFunction(args, body) = translation { - let! context = State.get + override this.BuildFunction(args, body) = + translation { + let! context = State.get - let retFunType = Type.translate var.Type |> State.eval context - let declSpecs = DeclSpecifierPack(typeSpecifier = retFunType) - let partAST = this.AddReturn body + let retFunType = Type.translate var.Type |> State.eval context + let declSpecs = DeclSpecifierPack(typeSpecifier = retFunType) + let partAST = this.AddReturn body - return FunDecl(declSpecs, var.Name, args, partAST) :> ITopDef<_> - } + return FunDecl(declSpecs, var.Name, args, partAST) :> ITopDef<_> + } diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/AtomicTransformer.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/AtomicTransformer.fs index 003b0fee..a203a7a0 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/AtomicTransformer.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/AtomicTransformer.fs @@ -31,17 +31,38 @@ module AtomicProcessor = let inline private atomicOr p v = (|||) !p v let inline private atomicXor p v = (^^^) !p v - let private atomicAddInfo = (Utils.getMethodInfoOfCall <@ atomicAdd @>).GetGenericMethodDefinition() - let private atomicSubInfo = (Utils.getMethodInfoOfCall <@ atomicSub @>).GetGenericMethodDefinition() - let private atomicIncInfo = (Utils.getMethodInfoOfCall <@ atomicInc @>).GetGenericMethodDefinition() - let private atomicDecInfo = (Utils.getMethodInfoOfCall <@ atomicDec @>).GetGenericMethodDefinition() - let private atomicXchgInfo = (Utils.getMethodInfoOfCall <@ atomicXchg @>).GetGenericMethodDefinition() - let private atomicCmpxchgInfo = (Utils.getMethodInfoOfCall <@ atomicCmpxchg @>).GetGenericMethodDefinition() - let private atomicMinInfo = (Utils.getMethodInfoOfCall <@ atomicMin @>).GetGenericMethodDefinition() - let private atomicMaxInfo = (Utils.getMethodInfoOfCall <@ atomicMax @>).GetGenericMethodDefinition() - let private atomicAndInfo = (Utils.getMethodInfoOfCall <@ atomicAnd @>).GetGenericMethodDefinition() - let private atomicOrInfo = (Utils.getMethodInfoOfCall <@ atomicOr @>).GetGenericMethodDefinition() - let private atomicXorInfo = (Utils.getMethodInfoOfCall <@ atomicXor @>).GetGenericMethodDefinition() + let private atomicAddInfo = + (Utils.getMethodInfoOfCall <@ atomicAdd @>).GetGenericMethodDefinition() + + let private atomicSubInfo = + (Utils.getMethodInfoOfCall <@ atomicSub @>).GetGenericMethodDefinition() + + let private atomicIncInfo = + (Utils.getMethodInfoOfCall <@ atomicInc @>).GetGenericMethodDefinition() + + let private atomicDecInfo = + (Utils.getMethodInfoOfCall <@ atomicDec @>).GetGenericMethodDefinition() + + let private atomicXchgInfo = + (Utils.getMethodInfoOfCall <@ atomicXchg @>).GetGenericMethodDefinition() + + let private atomicCmpxchgInfo = + (Utils.getMethodInfoOfCall <@ atomicCmpxchg @>).GetGenericMethodDefinition() + + let private atomicMinInfo = + (Utils.getMethodInfoOfCall <@ atomicMin @>).GetGenericMethodDefinition() + + let private atomicMaxInfo = + (Utils.getMethodInfoOfCall <@ atomicMax @>).GetGenericMethodDefinition() + + let private atomicAndInfo = + (Utils.getMethodInfoOfCall <@ atomicAnd @>).GetGenericMethodDefinition() + + let private atomicOrInfo = + (Utils.getMethodInfoOfCall <@ atomicOr @>).GetGenericMethodDefinition() + + let private atomicXorInfo = + (Utils.getMethodInfoOfCall <@ atomicXor @>).GetGenericMethodDefinition() let private modifyFirstOfList f lst = match lst with @@ -50,17 +71,17 @@ module AtomicProcessor = let private modifyFirstOfListList f lst = match lst with - | [x] :: tail -> [f x] :: tail + | [ x ] :: tail -> [ f x ] :: tail | _ -> invalidArg "lst" "List should not be empty" let private getFirstOfListListWith f lst = match lst with - | [x] :: _ -> f x + | [ x ] :: _ -> f x | _ -> invalidArg "lst" "List should not be empty" let grabVariableAddresses (expr: Expr) = match expr with - | DerivedPatterns.Lambdas (args, body) -> + | DerivedPatterns.Lambdas(args, body) -> let kernelArgs = List.collect id args let vars = Dictionary() @@ -71,400 +92,449 @@ module AtomicProcessor = let rec traverse expr = match expr with - | Patterns.Let (var, (DerivedPatterns.SpecificCall <@ local @> _), body) - | Patterns.Let (var, (DerivedPatterns.SpecificCall <@ localArray @> _), body) -> + | Patterns.Let(var, (DerivedPatterns.SpecificCall <@ local @> _), body) + | Patterns.Let(var, (DerivedPatterns.SpecificCall <@ localArray @> _), body) -> vars.Add(var, LocalQ) traverse body | ExprShape.ShapeVar _ -> () - | ExprShape.ShapeLambda (_, lambda) -> traverse lambda - | ExprShape.ShapeCombination (_, exprs) -> List.iter traverse exprs + | ExprShape.ShapeLambda(_, lambda) -> traverse lambda + | ExprShape.ShapeCombination(_, exprs) -> List.iter traverse exprs traverse body vars |> Seq.map (|KeyValue|) |> Map.ofSeq - | _ -> raise <| InvalidKernelException $"Invalid kernel expression. Must be lambda, but given\n{expr}" - - let rec private transformAtomicsAndCollectPointerVars (expr: Expr) nonPrivateVars = atomicProcessing { - match expr with - | DerivedPatterns.Applications - ( - DerivedPatterns.SpecificCall <@ atomic @> - ( - _, - _, - [DerivedPatterns.Lambdas (lambdaArgs, lambdaBody)] - ), - ([Patterns.ValidVolatileArg pointerVar as volatileArg] :: _ as applicationArgs) - ) when nonPrivateVars |> Map.containsKey pointerVar -> // private vars not supported - - let newApplicationArgs = - applicationArgs - |> List.collect id - |> modifyFirstOfList Utils.createRefCall - - // https://www.khronos.org/registry/OpenCL/sdk/1.2/docs/man/xhtml/atomicFunctions.html - match lambdaBody with - | DerivedPatterns.SpecificCall <@ (+) @> (_, onType :: _, [Patterns.Var _; Patterns.Var _]) when - onType = typeof || onType = typeof || - // base - onType = typeof || onType = typeof -> - return Expr.Call(atomicAddInfo.MakeGenericMethod(onType, onType, onType), newApplicationArgs) - - | DerivedPatterns.SpecificCall <@ (-) @> (_, onType :: _, [Patterns.Var _; Patterns.Var _]) when - onType = typeof || onType = typeof || - // base - onType = typeof || onType = typeof -> - return Expr.Call(atomicSubInfo.MakeGenericMethod(onType, onType, onType), newApplicationArgs) - - | DerivedPatterns.SpecificCall <@ inc @> (_, onType :: _, [Patterns.Var _]) when - onType = typeof || onType = typeof || - // base - onType = typeof || onType = typeof -> - return Expr.Call(atomicIncInfo.MakeGenericMethod(onType, onType), newApplicationArgs) - - | DerivedPatterns.SpecificCall <@ dec @> (_, onType :: _, [Patterns.Var _]) when - onType = typeof || onType = typeof || - // base - onType = typeof || onType = typeof -> - return Expr.Call(atomicDecInfo.MakeGenericMethod(onType, onType), newApplicationArgs) - - | DerivedPatterns.SpecificCall <@ xchg @> (_, onType :: _, [Patterns.Var _; Patterns.Var _]) when - onType = typeof || onType = typeof || onType = typeof || - // base - onType = typeof || onType = typeof -> - return Expr.Call(atomicXchgInfo.MakeGenericMethod(onType), newApplicationArgs) - - | DerivedPatterns.SpecificCall <@ cmpxchg @> (_, onType :: _, [Patterns.Var _; Patterns.Var _; Patterns.Var _]) when - onType = typeof || onType = typeof || - // base - onType = typeof || onType = typeof -> - return Expr.Call(atomicCmpxchgInfo.MakeGenericMethod(onType), newApplicationArgs) - - | DerivedPatterns.SpecificCall <@ min @> (_, onType :: _, [Patterns.Var _; Patterns.Var _]) when - onType = typeof || onType = typeof || - // TODO если устройство не поддерживает атомики для этих типов, то вообще работать не будет - // нужно либо забить на расширения, либо учитывать параметры девайса - // extended - onType = typeof || onType = typeof -> - return Expr.Call(atomicMinInfo.MakeGenericMethod(onType), newApplicationArgs) - - | DerivedPatterns.SpecificCall <@ max @> (_, onType :: _, [Patterns.Var _; Patterns.Var _]) when - onType = typeof || onType = typeof || - // extended - onType = typeof || onType = typeof -> - return Expr.Call(atomicMaxInfo.MakeGenericMethod(onType), newApplicationArgs) - - | DerivedPatterns.SpecificCall <@ (&&&) @> (_, onType :: _, [Patterns.Var _; Patterns.Var _]) when - onType = typeof || onType = typeof || - // extended - onType = typeof || onType = typeof -> - return Expr.Call(atomicAndInfo.MakeGenericMethod(onType), newApplicationArgs) - - | DerivedPatterns.SpecificCall <@ (|||) @> (_, onType :: _, [Patterns.Var _; Patterns.Var _]) when - onType = typeof || onType = typeof || - // extended - onType = typeof || onType = typeof -> - return Expr.Call(atomicOrInfo.MakeGenericMethod(onType), newApplicationArgs) - - | DerivedPatterns.SpecificCall <@ (^^^) @> (_, onType :: _, [Patterns.Var _; Patterns.Var _]) when - onType = typeof || onType = typeof || - // extended - onType = typeof || onType = typeof -> - return Expr.Call(atomicXorInfo.MakeGenericMethod(onType), newApplicationArgs) - - | _ -> - let collectedLambdaTypes = - lambdaArgs - |> List.collect id - |> List.map (fun var -> var.Type) - |> fun args -> args @ [lambdaBody.Type] - - (* baseFunc *) - - let baseFuncType = - collectedLambdaTypes - |> Utils.makeLambdaType - - let baseFuncVar = Var("baseFunc", baseFuncType) + | _ -> + raise + <| InvalidKernelException $"Invalid kernel expression. Must be lambda, but given\n{expr}" + + let rec private transformAtomicsAndCollectPointerVars (expr: Expr) nonPrivateVars = + atomicProcessing { + match expr with + | DerivedPatterns.Applications(DerivedPatterns.SpecificCall <@ atomic @> (_, + _, + [ DerivedPatterns.Lambdas(lambdaArgs, + lambdaBody) ]), + ([ Patterns.ValidVolatileArg pointerVar as volatileArg ] :: _ as applicationArgs)) when + nonPrivateVars |> Map.containsKey pointerVar + -> // private vars not supported + + let newApplicationArgs = + applicationArgs |> List.collect id |> modifyFirstOfList Utils.createRefCall + + // https://www.khronos.org/registry/OpenCL/sdk/1.2/docs/man/xhtml/atomicFunctions.html + match lambdaBody with + | DerivedPatterns.SpecificCall <@ (+) @> (_, onType :: _, [ Patterns.Var _; Patterns.Var _ ]) when + onType = typeof + || onType = typeof + || + // base + onType = typeof + || onType = typeof + -> + return Expr.Call(atomicAddInfo.MakeGenericMethod(onType, onType, onType), newApplicationArgs) + + | DerivedPatterns.SpecificCall <@ (-) @> (_, onType :: _, [ Patterns.Var _; Patterns.Var _ ]) when + onType = typeof + || onType = typeof + || + // base + onType = typeof + || onType = typeof + -> + return Expr.Call(atomicSubInfo.MakeGenericMethod(onType, onType, onType), newApplicationArgs) + + | DerivedPatterns.SpecificCall <@ inc @> (_, onType :: _, [ Patterns.Var _ ]) when + onType = typeof + || onType = typeof + || + // base + onType = typeof + || onType = typeof + -> + return Expr.Call(atomicIncInfo.MakeGenericMethod(onType, onType), newApplicationArgs) + + | DerivedPatterns.SpecificCall <@ dec @> (_, onType :: _, [ Patterns.Var _ ]) when + onType = typeof + || onType = typeof + || + // base + onType = typeof + || onType = typeof + -> + return Expr.Call(atomicDecInfo.MakeGenericMethod(onType, onType), newApplicationArgs) + + | DerivedPatterns.SpecificCall <@ xchg @> (_, onType :: _, [ Patterns.Var _; Patterns.Var _ ]) when + onType = typeof + || onType = typeof + || onType = typeof + || + // base + onType = typeof + || onType = typeof + -> + return Expr.Call(atomicXchgInfo.MakeGenericMethod(onType), newApplicationArgs) + + | DerivedPatterns.SpecificCall <@ cmpxchg @> (_, + onType :: _, + [ Patterns.Var _; Patterns.Var _; Patterns.Var _ ]) when + onType = typeof + || onType = typeof + || + // base + onType = typeof + || onType = typeof + -> + return Expr.Call(atomicCmpxchgInfo.MakeGenericMethod(onType), newApplicationArgs) + + | DerivedPatterns.SpecificCall <@ min @> (_, onType :: _, [ Patterns.Var _; Patterns.Var _ ]) when + onType = typeof + || onType = typeof + || + // TODO если устройство не поддерживает атомики для этих типов, то вообще работать не будет + // нужно либо забить на расширения, либо учитывать параметры девайса + // extended + onType = typeof + || onType = typeof + -> + return Expr.Call(atomicMinInfo.MakeGenericMethod(onType), newApplicationArgs) + + | DerivedPatterns.SpecificCall <@ max @> (_, onType :: _, [ Patterns.Var _; Patterns.Var _ ]) when + onType = typeof + || onType = typeof + || + // extended + onType = typeof + || onType = typeof + -> + return Expr.Call(atomicMaxInfo.MakeGenericMethod(onType), newApplicationArgs) + + | DerivedPatterns.SpecificCall <@ (&&&) @> (_, onType :: _, [ Patterns.Var _; Patterns.Var _ ]) when + onType = typeof + || onType = typeof + || + // extended + onType = typeof + || onType = typeof + -> + return Expr.Call(atomicAndInfo.MakeGenericMethod(onType), newApplicationArgs) + + | DerivedPatterns.SpecificCall <@ (|||) @> (_, onType :: _, [ Patterns.Var _; Patterns.Var _ ]) when + onType = typeof + || onType = typeof + || + // extended + onType = typeof + || onType = typeof + -> + return Expr.Call(atomicOrInfo.MakeGenericMethod(onType), newApplicationArgs) + + | DerivedPatterns.SpecificCall <@ (^^^) @> (_, onType :: _, [ Patterns.Var _; Patterns.Var _ ]) when + onType = typeof + || onType = typeof + || + // extended + onType = typeof + || onType = typeof + -> + return Expr.Call(atomicXorInfo.MakeGenericMethod(onType), newApplicationArgs) + + | _ -> + let collectedLambdaTypes = + lambdaArgs + |> List.collect id + |> List.map (fun var -> var.Type) + |> fun args -> args @ [ lambdaBody.Type ] + + (* baseFunc *) + + let baseFuncType = collectedLambdaTypes |> Utils.makeLambdaType + + let baseFuncVar = Var("baseFunc", baseFuncType) + + let baseFuncArgs = lambdaArgs + + let baseFuncBody = + match lambdaBody with + | DerivedPatterns.SpecificCall <@ inc @> (_, onType :: _, [ Patterns.Var p ]) -> + Expr.Call( + Utils.makeGenericMethodCall + [ onType + onType + onType ] + <@ (+) @>, + [ Expr.Var p + Expr.Call(Utils.makeGenericMethodCall [ onType ] <@ GenericOne @>, List.empty) ] + ) - let baseFuncArgs = lambdaArgs + | DerivedPatterns.SpecificCall <@ dec @> (_, onType :: _, [ Patterns.Var p ]) -> + Expr.Call( + Utils.makeGenericMethodCall + [ onType + onType + onType ] + <@ (-) @>, + [ Expr.Var p + Expr.Call(Utils.makeGenericMethodCall [ onType ] <@ GenericOne @>, List.empty) ] + ) - let baseFuncBody = - match lambdaBody with - | DerivedPatterns.SpecificCall <@ inc @> (_, onType :: _, [Patterns.Var p]) -> - Expr.Call( - Utils.makeGenericMethodCall [onType; onType; onType] <@ (+) @>, - [ - Expr.Var p; - Expr.Call( - Utils.makeGenericMethodCall [onType] <@ GenericOne @>, - List.empty - ) - ] - ) + | DerivedPatterns.SpecificCall <@ xchg @> (_, _, [ Patterns.Var p; Patterns.Var value ]) -> + Expr.Var value - | DerivedPatterns.SpecificCall <@ dec @> (_, onType :: _, [Patterns.Var p]) -> - Expr.Call( - Utils.makeGenericMethodCall [onType; onType; onType] <@ (-) @>, - [ - Expr.Var p; + | DerivedPatterns.SpecificCall <@ cmpxchg @> (_, + onType :: _, + [ Patterns.Var p + Patterns.Var cmp + Patterns.Var value ]) -> + Expr.IfThenElse( Expr.Call( - Utils.makeGenericMethodCall [onType] <@ GenericOne @>, - List.empty - ) - ] - ) + Utils.makeGenericMethodCall [ onType ] <@ (=) @>, + [ Expr.Var p + Expr.Var cmp ] + ), + Expr.Var value, + Expr.Var p + ) - | DerivedPatterns.SpecificCall <@ xchg @> (_, _, [Patterns.Var p; Patterns.Var value]) -> - Expr.Var value + | _ -> lambdaBody - | DerivedPatterns.SpecificCall <@ cmpxchg @> (_, onType :: _, [Patterns.Var p; Patterns.Var cmp; Patterns.Var value]) -> - Expr.IfThenElse( - Expr.Call(Utils.makeGenericMethodCall [onType] <@ (=) @>, [Expr.Var p; Expr.Var cmp]), - Expr.Var value, - Expr.Var p - ) + (* atomicFunc*) - | _ -> lambdaBody + let atomicFuncType = + collectedLambdaTypes + |> modifyFirstOfList (fun x -> typeof>.GetGenericTypeDefinition().MakeGenericType(x)) + |> Utils.makeLambdaType - (* atomicFunc*) + let atomicFuncVar = Var("atomicFunc", atomicFuncType) - let atomicFuncType = - collectedLambdaTypes - |> modifyFirstOfList (fun x -> typeof>.GetGenericTypeDefinition().MakeGenericType(x)) - |> Utils.makeLambdaType + let atomicFuncArgs = + baseFuncArgs + |> modifyFirstOfListList (fun x -> + Var(x.Name, typeof>.GetGenericTypeDefinition().MakeGenericType(x.Type), x.IsMutable)) - let atomicFuncVar = Var("atomicFunc", atomicFuncType) + let! state = State.get - let atomicFuncArgs = - baseFuncArgs - |> modifyFirstOfListList - (fun x -> + let mutexVar = + match state |> Map.tryFind pointerVar with + // if mutex var already exists (if 2 or more atomic op on the same data) + | Some mVar -> mVar + | None -> Var( - x.Name, - typeof>.GetGenericTypeDefinition().MakeGenericType(x.Type), - x.IsMutable + pointerVar.Name + "Mutex", + if nonPrivateVars.[pointerVar] = GlobalQ then + typeof> + elif pointerVar.Type.IsArray then + typeof + else + typeof ) - ) - let! state = State.get - - let mutexVar = - match state |> Map.tryFind pointerVar with - // if mutex var already exists (if 2 or more atomic op on the same data) - | Some mVar -> mVar - | None -> - Var( - pointerVar.Name + "Mutex", - if nonPrivateVars.[pointerVar] = GlobalQ then - typeof> - elif pointerVar.Type.IsArray then - typeof - else - typeof - ) + do! State.modify (fun state -> state |> Map.add pointerVar mutexVar) + + let atomicFuncBody = + let mutex = + match volatileArg with + | Patterns.PropertyGet(Some(Patterns.Var v), propInfo, args) when + v.Type.Name.ToLower().StartsWith ClArray_ + && propInfo.Name.ToLower().StartsWith "item" + -> - do! State.modify (fun state -> state |> Map.add pointerVar mutexVar) + Expr.PropertyGet(Expr.Var mutexVar, typeof>.GetProperty ("Item"), args) - let atomicFuncBody = - let mutex = - match volatileArg with - | Patterns.PropertyGet (Some (Patterns.Var v), propInfo, args) when - v.Type.Name.ToLower().StartsWith ClArray_ && - propInfo.Name.ToLower().StartsWith "item" -> + | Patterns.PropertyGet(Some(Patterns.Var v), propInfo, args) when + v.Type.Name.ToLower().StartsWith ClCell_ + && propInfo.Name.ToLower().StartsWith "value" + -> + + Expr.PropertyGet( + Expr.Var mutexVar, + typeof>.GetProperty ("Item"), + [ Expr.Value 0 ] + ) - Expr.PropertyGet(Expr.Var mutexVar, typeof>.GetProperty("Item"), args) + | Patterns.Var _ -> Expr.Var mutexVar - | Patterns.PropertyGet (Some (Patterns.Var v), propInfo, args) when - v.Type.Name.ToLower().StartsWith ClCell_ && - propInfo.Name.ToLower().StartsWith "value" -> + | DerivedPatterns.SpecificCall <@ IntrinsicFunctions.GetArray @> (_, + _, + [ Patterns.Var _; idx ]) -> + Expr.Call( + Utils.getMethodInfoOfCall <@ IntrinsicFunctions.GetArray @>, + [ Expr.Var mutexVar + idx ] + ) - Expr.PropertyGet(Expr.Var mutexVar, typeof>.GetProperty("Item"), [Expr.Value 0]) + | _ -> failwith "Invalid volatile argument. This exception should never occur :)" + |> Utils.createRefCall - | Patterns.Var _ -> Expr.Var mutexVar + let baseFuncApplicaionArgs = + atomicFuncArgs + |> List.map (List.map Expr.Var) + |> modifyFirstOfListList Utils.createDereferenceCall - | DerivedPatterns.SpecificCall <@ IntrinsicFunctions.GetArray @> (_, _, [Patterns.Var _; idx]) -> - Expr.Call( - Utils.getMethodInfoOfCall <@ IntrinsicFunctions.GetArray @>, - [Expr.Var mutexVar; idx] + let oldValueVar = + Var( + "oldValue", + getFirstOfListListWith (fun (x: Var) -> x.Type.GenericTypeArguments.[0]) atomicFuncArgs, + true ) - | _ -> failwith "Invalid volatile argument. This exception should never occur :)" - |> Utils.createRefCall + Expr.Let( + oldValueVar, + Expr.DefaultValue + <| getFirstOfListListWith (fun (x: Var) -> x.Type.GenericTypeArguments.[0]) atomicFuncArgs, + Expr.Sequential( + <@@ + let mutable flip = 0 + let mutable flag = true - let baseFuncApplicaionArgs = - atomicFuncArgs - |> List.map (List.map Expr.Var) - |> modifyFirstOfListList Utils.createDereferenceCall + while flag do + let old = atomicXchg %%mutex (1 - flip) - let oldValueVar = - Var( - "oldValue", - getFirstOfListListWith (fun (x: Var) -> x.Type.GenericTypeArguments.[0]) atomicFuncArgs, - true - ) + if old = flip then + %% Expr.VarSet(oldValueVar, getFirstOfListListWith id baseFuncApplicaionArgs) + + %%(Utils.createReferenceSetCall + <| getFirstOfListListWith Expr.Var atomicFuncArgs + <| Expr.Applications(Expr.Var baseFuncVar, baseFuncApplicaionArgs)) + + flag <- false - Expr.Let( - oldValueVar, - Expr.DefaultValue <| getFirstOfListListWith (fun (x: Var) -> x.Type.GenericTypeArguments.[0]) atomicFuncArgs, - Expr.Sequential( - <@@ - let mutable flip = 0 - let mutable flag = true - while flag do - let old = atomicXchg %%mutex (1 - flip) - if old = flip then - %%Expr.VarSet( - oldValueVar, - getFirstOfListListWith id baseFuncApplicaionArgs - ) - %%( - Utils.createReferenceSetCall - <| getFirstOfListListWith Expr.Var atomicFuncArgs - <| Expr.Applications(Expr.Var baseFuncVar, baseFuncApplicaionArgs) - ) - flag <- false - flip <- 1 - flip - @@>, - Expr.Var oldValueVar + flip <- 1 - flip + @@>, + Expr.Var oldValueVar + ) ) - ) - return - Expr.Let( - baseFuncVar, - Expr.Lambdas(baseFuncArgs, baseFuncBody), + return Expr.Let( - atomicFuncVar, - Expr.Lambdas(atomicFuncArgs, atomicFuncBody), - Expr.Applications( - Expr.Var atomicFuncVar, - newApplicationArgs |> List.map List.singleton + baseFuncVar, + Expr.Lambdas(baseFuncArgs, baseFuncBody), + Expr.Let( + atomicFuncVar, + Expr.Lambdas(atomicFuncArgs, atomicFuncBody), + Expr.Applications(Expr.Var atomicFuncVar, newApplicationArgs |> List.map List.singleton) ) ) - ) - - // if pointer var in private memory - | DerivedPatterns.Applications - ( - DerivedPatterns.SpecificCall <@ atomic @> - ( - _, - _, - [DerivedPatterns.Lambdas (lambdaArgs, lambdaBody)] - ), - ([Patterns.ValidVolatileArg pointerVar] :: _ as applicationArgs) - ) when nonPrivateVars |> Map.containsKey pointerVar |> not -> - return failwithf - $"Invalid address space of {pointerVar} var. \ + + // if pointer var in private memory + | DerivedPatterns.Applications(DerivedPatterns.SpecificCall <@ atomic @> (_, + _, + [ DerivedPatterns.Lambdas(lambdaArgs, + lambdaBody) ]), + ([ Patterns.ValidVolatileArg pointerVar ] :: _ as applicationArgs)) when + nonPrivateVars |> Map.containsKey pointerVar |> not + -> + return + failwithf + $"Invalid address space of {pointerVar} var. \ Atomic operaion cannot be executed on variables in private memmory" - // if volatile arg is invalid - | DerivedPatterns.Applications - ( - DerivedPatterns.SpecificCall <@ atomic @> - ( - _, - _, - [DerivedPatterns.Lambdas _] - ), - [invalidVolatileArg] :: _ - ) -> - return failwithf - $"Invalid volatile arg of atomic function. Must be `var` of `var.[expr]`, \ + // if volatile arg is invalid + | DerivedPatterns.Applications(DerivedPatterns.SpecificCall <@ atomic @> (_, + _, + [ DerivedPatterns.Lambdas _ ]), + [ invalidVolatileArg ] :: _) -> + return + failwithf + $"Invalid volatile arg of atomic function. Must be `var` of `var.[expr]`, \ where `var` is variable in local or global memory, but given\n{invalidVolatileArg}" - | ExprShape.ShapeVar var -> return Expr.Var var - | ExprShape.ShapeLambda (var, lambda) -> - let! transformedLambda = transformAtomicsAndCollectPointerVars lambda nonPrivateVars - return Expr.Lambda(var, transformedLambda) - | ExprShape.ShapeCombination (combo, exprs) -> - let! transformedList = exprs |> List.map (fun e -> transformAtomicsAndCollectPointerVars e nonPrivateVars) |> State.collect - return ExprShape.RebuildShapeCombination(combo, transformedList) - } - - let private insertMutexVars (expr: Expr) = atomicProcessing { - let! pointerVarToMutexVarMap = State.get - match expr with - | DerivedPatterns.Lambdas (args, body) -> - let args = List.collect id args - let newArgs = ResizeArray args - - // Set global args - pointerVarToMutexVarMap - |> Map.iter (fun var mutexVar -> - if args |> List.contains var then - newArgs.Add mutexVar - ) - - // Set local args - let rec go expr = - match expr with - | Patterns.Let (var, (DerivedPatterns.SpecificCall <@ local @> (_, _, args) as letExpr), inExpr) -> - Expr.Let( - var, - letExpr, - match pointerVarToMutexVarMap |> Map.tryFind var with - | Some mutexVar -> - failwith "Atomic local non-array variables is not supported yet" + | ExprShape.ShapeVar var -> return Expr.Var var + | ExprShape.ShapeLambda(var, lambda) -> + let! transformedLambda = transformAtomicsAndCollectPointerVars lambda nonPrivateVars + return Expr.Lambda(var, transformedLambda) + | ExprShape.ShapeCombination(combo, exprs) -> + let! transformedList = + exprs + |> List.map (fun e -> transformAtomicsAndCollectPointerVars e nonPrivateVars) + |> State.collect + + return ExprShape.RebuildShapeCombination(combo, transformedList) + } + + let private insertMutexVars (expr: Expr) = + atomicProcessing { + let! pointerVarToMutexVarMap = State.get + + match expr with + | DerivedPatterns.Lambdas(args, body) -> + let args = List.collect id args + let newArgs = ResizeArray args + + // Set global args + pointerVarToMutexVarMap + |> Map.iter (fun var mutexVar -> + if args |> List.contains var then + newArgs.Add mutexVar) + + // Set local args + let rec go expr = + match expr with + | Patterns.Let(var, (DerivedPatterns.SpecificCall <@ local @> (_, _, args) as letExpr), inExpr) -> + Expr.Let( + var, + letExpr, + match pointerVarToMutexVarMap |> Map.tryFind var with + | Some mutexVar -> failwith "Atomic local non-array variables is not supported yet" // Expr.Let( // mutexVar, // Expr.Call(Utils.getMethodInfoOfLambda <@ local @>, args), // inExpr // ) - | None -> inExpr - ) - | Patterns.Let (var, (DerivedPatterns.SpecificCall <@ localArray @> (_, _, args) as letExpr), inExpr) -> - Expr.Let( - var, - letExpr, - match pointerVarToMutexVarMap |> Map.tryFind var with - | Some mutexVar -> - Expr.Let( - mutexVar, - Expr.Call(Utils.getMethodInfoOfCall <@ localArray @>, args), - Expr.Sequential( - <@@ - if Anchors._localID0 = 0 then - %%( - let i = Var("i", typeof, true) - Expr.ForIntegerRangeLoop( - i, - Expr.Value 0, - <@@ (%%args.[0] : int) - 1 @@>, - Expr.Call( - Utils.getMethodInfoOfCall <@ IntrinsicFunctions.SetArray @>, - [ - Expr.Var mutexVar - Expr.Var i - Expr.Value 0 - ] - ) - ) - ) - barrierLocal () - @@>, - inExpr + | None -> inExpr + ) + | Patterns.Let(var, (DerivedPatterns.SpecificCall <@ localArray @> (_, _, args) as letExpr), inExpr) -> + Expr.Let( + var, + letExpr, + match pointerVarToMutexVarMap |> Map.tryFind var with + | Some mutexVar -> + Expr.Let( + mutexVar, + Expr.Call(Utils.getMethodInfoOfCall <@ localArray @>, args), + Expr.Sequential( + <@@ + if Anchors._localID0 = 0 then + %%(let i = Var("i", typeof, true) + + Expr.ForIntegerRangeLoop( + i, + Expr.Value 0, + <@@ (%%args.[0]: int) - 1 @@>, + Expr.Call( + Utils.getMethodInfoOfCall + <@ IntrinsicFunctions.SetArray @>, + [ Expr.Var mutexVar + Expr.Var i + Expr.Value 0 ] + ) + )) + + barrierLocal () + @@>, + inExpr + ) ) - ) - | None -> inExpr - ) + | None -> inExpr + ) - | ExprShape.ShapeVar var -> Expr.Var var - | ExprShape.ShapeLambda (var, lambda) -> - Expr.Lambda(var, go lambda) - | ExprShape.ShapeCombination (combo, exprs) -> - ExprShape.RebuildShapeCombination(combo, List.map go exprs) + | ExprShape.ShapeVar var -> Expr.Var var + | ExprShape.ShapeLambda(var, lambda) -> Expr.Lambda(var, go lambda) + | ExprShape.ShapeCombination(combo, exprs) -> + ExprShape.RebuildShapeCombination(combo, List.map go exprs) - return Expr.Lambdas(Seq.toList newArgs |> List.map List.singleton, go body) + return Expr.Lambdas(Seq.toList newArgs |> List.map List.singleton, go body) - | _ -> return raise <| InvalidKernelException $"Invalid kernel expression. Must be lambda, but given\n{expr}" - } + | _ -> + return + raise + <| InvalidKernelException $"Invalid kernel expression. Must be lambda, but given\n{expr}" + } let processAtomic (expr: Expr) = let nonPrivateVars = grabVariableAddresses expr + transformAtomicsAndCollectPointerVars expr nonPrivateVars >>= insertMutexVars |> State.eval Map.empty diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/GettingWorkSizeTransformer.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/GettingWorkSizeTransformer.fs index 310b6572..67c3e5e0 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/GettingWorkSizeTransformer.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/GettingWorkSizeTransformer.fs @@ -9,96 +9,85 @@ type WorkSizeQual = module GettingWorkSizeTransformer = let inline (|Name|_|) (str: string) x = - match (^a : (member Name : string) x) with + match (^a: (member Name: string) x) with | name when name = str -> Some x | _ -> None let inline (|TypeName|_|) (str: string) x = - match (^a : (member Type : System.Type) x) with + match (^a: (member Type: System.Type) x) with | type' when type'.Name.ToLowerInvariant().Contains str -> Some x | _ -> None let inline (|WorkSize|_|) x = match x with - | Name "GlobalWorkSize" x -> Some (x, GlobalWS) - | Name "LocalWorkSize" x -> Some (x, LocalWS) + | Name "GlobalWorkSize" x -> Some(x, GlobalWS) + | Name "LocalWorkSize" x -> Some(x, LocalWS) | _ -> None let rec go (expr: Expr) = match expr with - | Patterns.Let - ( - var, - Patterns.PropertyGet (Some (Patterns.Var (TypeName Range1D_ _)), WorkSize (_, q), _), - inExpr - ) -> + | Patterns.Let(var, Patterns.PropertyGet(Some(Patterns.Var(TypeName Range1D_ _)), WorkSize(_, q), _), inExpr) -> Expr.Let( var, - (match q with | GlobalWS -> <@@ Anchors._globalSize0 @@> | LocalWS -> <@@ Anchors._localSize0 @@>), + (match q with + | GlobalWS -> <@@ Anchors._globalSize0 @@> + | LocalWS -> <@@ Anchors._localSize0 @@>), go inExpr ) - | Patterns.LetVar - ( - Name "patternInput" _, - Patterns.PropertyGet (Some (Patterns.Var (TypeName Range2D_ _)), WorkSize (_, q), _), - Patterns.Let ( - varY, - Patterns.TupleGet (Patterns.Var (Name "patternInput" _), 1), - Patterns.Let ( - varX, - Patterns.TupleGet (Patterns.Var (Name "patternInput" _), 0), - inExpr - ) - ) - ) -> + | Patterns.LetVar(Name "patternInput" _, + Patterns.PropertyGet(Some(Patterns.Var(TypeName Range2D_ _)), WorkSize(_, q), _), + Patterns.Let(varY, + Patterns.TupleGet(Patterns.Var(Name "patternInput" _), 1), + Patterns.Let(varX, + Patterns.TupleGet(Patterns.Var(Name "patternInput" _), 0), + inExpr))) -> Expr.Let( varX, - (match q with | GlobalWS -> <@@ Anchors._globalSize0 @@> | LocalWS -> <@@ Anchors._localSize0 @@>), + (match q with + | GlobalWS -> <@@ Anchors._globalSize0 @@> + | LocalWS -> <@@ Anchors._localSize0 @@>), Expr.Let( varY, - (match q with | GlobalWS -> <@@ Anchors._globalSize1 @@> | LocalWS -> <@@ Anchors._localSize1 @@>), + (match q with + | GlobalWS -> <@@ Anchors._globalSize1 @@> + | LocalWS -> <@@ Anchors._localSize1 @@>), go inExpr ) ) - | Patterns.LetVar - ( - Name "patternInput" _, - Patterns.PropertyGet (Some (Patterns.Var (TypeName Range3D_ _)), WorkSize (_, q), _), - Patterns.Let ( - varZ, - Patterns.TupleGet (Patterns.Var (Name "patternInput" _), 2), - Patterns.Let ( - varY, - Patterns.TupleGet (Patterns.Var (Name "patternInput" _), 1), - Patterns.Let ( - varX, - Patterns.TupleGet (Patterns.Var (Name "patternInput" _), 0), - inExpr - ) - ) - ) - ) -> + | Patterns.LetVar(Name "patternInput" _, + Patterns.PropertyGet(Some(Patterns.Var(TypeName Range3D_ _)), WorkSize(_, q), _), + Patterns.Let(varZ, + Patterns.TupleGet(Patterns.Var(Name "patternInput" _), 2), + Patterns.Let(varY, + Patterns.TupleGet(Patterns.Var(Name "patternInput" _), 1), + Patterns.Let(varX, + Patterns.TupleGet(Patterns.Var(Name "patternInput" _), + 0), + inExpr)))) -> Expr.Let( varX, - (match q with | GlobalWS -> <@@ Anchors._globalSize0 @@> | LocalWS -> <@@ Anchors._localSize0 @@>), + (match q with + | GlobalWS -> <@@ Anchors._globalSize0 @@> + | LocalWS -> <@@ Anchors._localSize0 @@>), Expr.Let( varY, - (match q with | GlobalWS -> <@@ Anchors._globalSize1 @@> | LocalWS -> <@@ Anchors._localSize1 @@>), + (match q with + | GlobalWS -> <@@ Anchors._globalSize1 @@> + | LocalWS -> <@@ Anchors._localSize1 @@>), Expr.Let( varZ, - (match q with | GlobalWS -> <@@ Anchors._globalSize2 @@> | LocalWS -> <@@ Anchors._localSize2 @@>), + (match q with + | GlobalWS -> <@@ Anchors._globalSize2 @@> + | LocalWS -> <@@ Anchors._localSize2 @@>), go inExpr ) ) ) | ExprShape.ShapeVar var -> Expr.Var var - | ExprShape.ShapeLambda (var, lambda) -> - Expr.Lambda(var, go lambda) - | ExprShape.ShapeCombination (combo, exprs) -> - ExprShape.RebuildShapeCombination(combo, List.map go exprs) + | ExprShape.ShapeLambda(var, lambda) -> Expr.Lambda(var, go lambda) + | ExprShape.ShapeCombination(combo, exprs) -> ExprShape.RebuildShapeCombination(combo, List.map go exprs) - let __ (expr: Expr) = - go expr + let __ (expr: Expr) = go expr diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/LambdaLiftingTransformer.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/LambdaLiftingTransformer.fs index 8c4f346e..f9d4296b 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/LambdaLiftingTransformer.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/LambdaLiftingTransformer.fs @@ -4,10 +4,9 @@ open Brahma.FSharp.OpenCL.Translator open FSharp.Quotations type Context = - private { - FreeVariables: Map> - Substitution: Map - } + private + { FreeVariables: Map> + Substitution: Map } module Context = /// head: t, args: [x1: t1; x2: t2; x3: t3] @@ -17,6 +16,7 @@ module Context = let newHeadType = Utils.makeFunctionType head.Type argTypes let newHead = Var(head.Name, newHeadType, head.IsMutable) + let application = args |> List.map Expr.Var @@ -24,25 +24,21 @@ module Context = application, newHead - let empty = { FreeVariables = Map.empty; Substitution = Map.empty } + let empty = + { FreeVariables = Map.empty + Substitution = Map.empty } let setFunctionFreeVariables (oldFuncVar: Var) (extendedParams: List) (ctx: Context) = - { - FreeVariables = ctx.FreeVariables.Add(oldFuncVar, extendedParams) - Substitution = ctx.Substitution - } + { FreeVariables = ctx.FreeVariables.Add(oldFuncVar, extendedParams) + Substitution = ctx.Substitution } let setFunctionSubstitution (oldFuncVar: Var) (substitution: Expr) (ctx: Context) = - { - FreeVariables = ctx.FreeVariables - Substitution = ctx.Substitution.Add(oldFuncVar, substitution) - } + { FreeVariables = ctx.FreeVariables + Substitution = ctx.Substitution.Add(oldFuncVar, substitution) } - let getFunctionFreeVariables (oldFuncVar: Var) (ctx: Context) = - ctx.FreeVariables.TryFind oldFuncVar + let getFunctionFreeVariables (oldFuncVar: Var) (ctx: Context) = ctx.FreeVariables.TryFind oldFuncVar - let getFunctionSubstitution (oldFuncVar: Var) (ctx: Context) = - ctx.Substitution.TryFind oldFuncVar + let getFunctionSubstitution (oldFuncVar: Var) (ctx: Context) = ctx.Substitution.TryFind oldFuncVar module VoidArgumentsCleanUp = let private isConsistOfVoidVarOnly (args: list) = @@ -53,27 +49,33 @@ module VoidArgumentsCleanUp = let rec private cleanUpVoidArgumentsImpl (subst: Map) (expr: Expr) = match expr with - | Patterns.LetFuncUncurry (var, args, body, inExpr) -> + | Patterns.LetFuncUncurry(var, args, body, inExpr) -> let args' = - if isConsistOfVoidVarOnly args then args - else List.filter (not << Utils.isTypeOf) args + if isConsistOfVoidVarOnly args then + args + else + List.filter (not << Utils.isTypeOf) args + + let newFuncVarType = + Utils.makeFunctionType body.Type <| List.map (fun (var: Var) -> var.Type) args' - let newFuncVarType = Utils.makeFunctionType body.Type <| List.map (fun (var: Var) -> var.Type) args' let newFuncVar = Var(var.Name, newFuncVarType, var.IsMutable) let body' = cleanUpVoidArgumentsImpl subst body - let subst' = subst.Add (var, newFuncVar) + let subst' = subst.Add(var, newFuncVar) let inExpr' = cleanUpVoidArgumentsImpl subst' inExpr Expr.Let(newFuncVar, Utils.makeLambdaExpr args' body', inExpr') - | Patterns.ApplicationUncurry (head, exprs) -> + | Patterns.ApplicationUncurry(head, exprs) -> match head with | Patterns.Var var -> match subst.TryFind var with | Some var' -> let exprs' = - if isConsistOfVoidExprOnly exprs then exprs - else List.filter (fun (exp: Expr) -> exp.Type <> typeof) exprs + if isConsistOfVoidExprOnly exprs then + exprs + else + List.filter (fun (exp: Expr) -> exp.Type <> typeof) exprs Utils.makeApplicationExpr <| Expr.Var var' @@ -81,8 +83,7 @@ module VoidArgumentsCleanUp = | _ -> expr | _ -> expr - | ExprShape.ShapeLambda (var, body) -> - Expr.Lambda (var, cleanUpVoidArgumentsImpl subst body) + | ExprShape.ShapeLambda(var, body) -> Expr.Lambda(var, cleanUpVoidArgumentsImpl subst body) | ExprShape.ShapeVar var -> match subst.TryFind var with | Some _ -> @@ -91,23 +92,18 @@ module VoidArgumentsCleanUp = | None -> expr | ExprShape.ShapeCombination(shapeComboObject, exprList) -> let exprList' = List.map <| cleanUpVoidArgumentsImpl subst <| exprList - ExprShape.RebuildShapeCombination (shapeComboObject, exprList') + ExprShape.RebuildShapeCombination(shapeComboObject, exprList') - let cleanUpVoidArguments (expr: Expr) = - cleanUpVoidArgumentsImpl Map.empty expr + let cleanUpVoidArguments (expr: Expr) = cleanUpVoidArgumentsImpl Map.empty expr [] module LambdaLifting = let rec parameterLiftExprImpl (ctx: Context) (expr: Expr) = match expr with - | Patterns.LetVar (v, definition, inExpr) -> - Expr.Let( - v, - parameterLiftExprImpl ctx definition, - parameterLiftExprImpl ctx inExpr - ) + | Patterns.LetVar(v, definition, inExpr) -> + Expr.Let(v, parameterLiftExprImpl ctx definition, parameterLiftExprImpl ctx inExpr) - | Patterns.LetFunc (f, definition, inExpr) -> + | Patterns.LetFunc(f, definition, inExpr) -> let localFreeVars = Utils.collectFreeVars definition let freeFunctionVars = Utils.collectFreeFunctionVars definition @@ -116,15 +112,13 @@ module LambdaLifting = |> Option.defaultValue List.empty |> Set.ofList - let extendedFreeVars = - freeFunctionVars - |> Set.map getSetFreeVars - |> Set.unionMany + let extendedFreeVars = freeFunctionVars |> Set.map getSetFreeVars |> Set.unionMany let freeVars = Set.union localFreeVars extendedFreeVars |> Set.toList let (substitution, newFuncVar) = Context.makeApplication f freeVars let newDefinition = parameterLiftExprImpl ctx definition + let extendedCtx = ctx |> Context.setFunctionFreeVariables f freeVars @@ -136,8 +130,7 @@ module LambdaLifting = inExpr |> parameterLiftExprImpl extendedCtx ) - | ExprShape.ShapeLambda (x, body) -> - Expr.Lambda(x, parameterLiftExprImpl ctx body) + | ExprShape.ShapeLambda(x, body) -> Expr.Lambda(x, parameterLiftExprImpl ctx body) | ExprShape.ShapeVar var -> match Context.getFunctionSubstitution var ctx with @@ -147,8 +140,7 @@ module LambdaLifting = | ExprShape.ShapeCombination(shapeComboObject, exprList) -> ExprShape.RebuildShapeCombination(shapeComboObject, List.map (parameterLiftExprImpl ctx) exprList) - let parameterLiftExpr = - parameterLiftExprImpl Context.empty + let parameterLiftExpr = parameterLiftExprImpl Context.empty let rec blockFloating (expr: Expr) = match expr with @@ -157,12 +149,11 @@ module LambdaLifting = let (inExpr', inExprMethods) = blockFloating inExpr inExpr', bodyMethods @ [ (var, body') ] @ inExprMethods - | ExprShape.ShapeLambda (var, body) -> + | ExprShape.ShapeLambda(var, body) -> let (body', methods) = blockFloating body Expr.Lambda(var, body'), methods - | ExprShape.ShapeVar var -> - Expr.Var(var), List.empty + | ExprShape.ShapeVar var -> Expr.Var(var), List.empty | ExprShape.ShapeCombination(shapeComboObject, exprList) -> let (exprList', methods) = exprList |> List.map blockFloating |> List.unzip diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/MutableVarsToRefTransformer.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/MutableVarsToRefTransformer.fs index 1c7044b3..8d59ff08 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/MutableVarsToRefTransformer.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/MutableVarsToRefTransformer.fs @@ -9,32 +9,26 @@ module MutableVarsToRefTransformer = let rec collectMutableVarsInClosure (expr: Expr) = match expr with - | Patterns.LetFunc (_, body, inExpr) -> + | Patterns.LetFunc(_, body, inExpr) -> let mutableFreeVars = body |> Utils.collectFreeVarsWithPredicate isMutableVar - Set.unionMany [ - mutableFreeVars - collectMutableVarsInClosure body - collectMutableVarsInClosure inExpr - ] - | ExprShape.ShapeLambda (_, body) -> - collectMutableVarsInClosure body - | ExprShape.ShapeVar _ -> - Set.empty - | ExprShape.ShapeCombination(_, exprList) -> - exprList - |> List.map collectMutableVarsInClosure - |> Set.unionMany + + Set.unionMany + [ mutableFreeVars + collectMutableVarsInClosure body + collectMutableVarsInClosure inExpr ] + | ExprShape.ShapeLambda(_, body) -> collectMutableVarsInClosure body + | ExprShape.ShapeVar _ -> Set.empty + | ExprShape.ShapeCombination(_, exprList) -> exprList |> List.map collectMutableVarsInClosure |> Set.unionMany let rec varsToRefsWithPredicateImpl (refMap: Map) (predicate: Var -> bool) (expr: Expr) = match expr with - | Patterns.LetVar (var, body, inExpr) -> + | Patterns.LetVar(var, body, inExpr) -> if predicate var then let refName = var.Name + "Ref" - let refType = typedefof>.MakeGenericType(var.Type) + let refType = typedefof>.MakeGenericType (var.Type) let refVar = Var(refName, refType, false) - let newRefMap = - refMap.Add(var, Expr.Var refVar) + let newRefMap = refMap.Add(var, Expr.Var refVar) Expr.Let( var, @@ -52,19 +46,19 @@ module MutableVarsToRefTransformer = varsToRefsWithPredicateImpl refMap predicate inExpr ) - | Patterns.VarSet (var, valueExpr) -> + | Patterns.VarSet(var, valueExpr) -> match refMap.TryFind var with | Some refExpr -> - Utils.createReferenceSetCall refExpr <| varsToRefsWithPredicateImpl refMap predicate valueExpr + Utils.createReferenceSetCall refExpr + <| varsToRefsWithPredicateImpl refMap predicate valueExpr | None -> expr | ExprShape.ShapeVar var -> match refMap.TryFind var with | Some refExpr -> Utils.createDereferenceCall refExpr | None -> expr - | ExprShape.ShapeLambda (var, body) -> - Expr.Lambda (var, varsToRefsWithPredicateImpl refMap predicate body) - | ExprShape.ShapeCombination (shapeComboObject, exprList) -> + | ExprShape.ShapeLambda(var, body) -> Expr.Lambda(var, varsToRefsWithPredicateImpl refMap predicate body) + | ExprShape.ShapeCombination(shapeComboObject, exprList) -> let exprList' = List.map (varsToRefsWithPredicateImpl refMap predicate) exprList ExprShape.RebuildShapeCombination(shapeComboObject, exprList') diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/PrintfTransformer.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/PrintfTransformer.fs index 6879e51f..ea8bede5 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/PrintfTransformer.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/PrintfTransformer.fs @@ -9,13 +9,8 @@ module PrintfReplacer = let rec replacePrintf (expr: Expr) = match expr with - | Patterns.Printf (tpArgs, value, bindArgs) -> - <@@ - print tpArgs value bindArgs - @@> - | ExprShape.ShapeVar _ -> - expr - | ExprShape.ShapeLambda (x, body) -> - Expr.Lambda(x, replacePrintf body) + | Patterns.Printf(tpArgs, value, bindArgs) -> <@@ print tpArgs value bindArgs @@> + | ExprShape.ShapeVar _ -> expr + | ExprShape.ShapeLambda(x, body) -> Expr.Lambda(x, replacePrintf body) | ExprShape.ShapeCombination(combo, exprList) -> ExprShape.RebuildShapeCombination(combo, List.map replacePrintf exprList) diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/UniqueVarNamesTransformer.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/UniqueVarNamesTransformer.fs index 1fc680e9..f3476b37 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/UniqueVarNamesTransformer.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/UniqueVarNamesTransformer.fs @@ -33,12 +33,12 @@ module UniqueVarRenamer = | ExprShape.ShapeVar var -> let newVar = ctx.Add var Expr.Var(newVar) - | ExprShape.ShapeLambda (var, body) -> + | ExprShape.ShapeLambda(var, body) -> let newVar = ctx.Add var Expr.Lambda(newVar, makeVarNamesUniqueImpl ctx body) - | ExprShape.ShapeCombination (shapeComboObj, exprList) -> + | ExprShape.ShapeCombination(shapeComboObj, exprList) -> let exprList' = List.map (makeVarNamesUniqueImpl ctx) exprList - ExprShape.RebuildShapeCombination (shapeComboObj, exprList') + ExprShape.RebuildShapeCombination(shapeComboObj, exprList') let makeVarNameUnique (expr: Expr) = - makeVarNamesUniqueImpl <| RenamingContext () <| expr + makeVarNamesUniqueImpl <| RenamingContext() <| expr diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Patterns.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Patterns.fs index bfc4d73f..fbc803b8 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Patterns.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Patterns.fs @@ -7,18 +7,18 @@ open FSharp.Core.LanguagePrimitives open Brahma.FSharp.OpenCL.Translator module Patterns = - let rec (|HasSubExpr|_|) ((|Pattern|_|) : Expr -> 'a Option) expr = + let rec (|HasSubExpr|_|) ((|Pattern|_|): Expr -> 'a Option) expr = match expr with | Pattern x -> Some x - | ExprShape.ShapeCombination (shapeObj, exprList) -> + | ExprShape.ShapeCombination(shapeObj, exprList) -> exprList |> List.map ((|HasSubExpr|_|) (|Pattern|_|)) |> List.fold (fun x y -> match x with | Some _ -> x - | None -> y - ) None + | None -> y) + None | _ -> None /// An active pattern to recognize any value expression @@ -30,22 +30,23 @@ module Patterns = /// Example: printf "%d %f" -> ([Int, Float], "%d %f") let (|NewPrintfFormat|_|) (expr: Expr) = match expr with - | Call (None, mInfo, args) -> + | Call(None, mInfo, args) -> match mInfo.Name with - | "PrintFormat" | "printfn" -> + | "PrintFormat" + | "printfn" -> let retType = mInfo.ReturnType + let bindTypes = match retType with | _ when retType = typeof -> [] - | _ when FSharpType.IsFunction retType -> - Utils.getFunctionArgTypes <| mInfo.ReturnType + | _ when FSharpType.IsFunction retType -> Utils.getFunctionArgTypes <| mInfo.ReturnType | _ -> failwithf "printf: returned type %A of NewPrintfFormat is not expected" retType match args with - | [HasValueAsSubExpr (s, _)] -> + | [ HasValueAsSubExpr(s, _) ] -> let s' = (s :?> string).Replace("\n", "\\n") let s'' = if mInfo.Name = "printfn" then s' + "\\n" else s' - Some (bindTypes, s'') + Some(bindTypes, s'') | _ -> failwithf "printf: argument %A of NewPrintfFormat call is not expected" args | _ -> None | _ -> None @@ -54,36 +55,32 @@ module Patterns = match expr with | Let(_, value, inExpr) -> match value with - | NewPrintfFormat (tpArgs, value) -> + | NewPrintfFormat(tpArgs, value) -> assert (tpArgs = Utils.getFunctionArgTypes inExpr.Type) - Some (tpArgs, value, []) + Some(tpArgs, value, []) | _ -> None | Application(f, arg) -> match f with - | PartialPrintf(tpArgs, value, bindArgs) -> - Some (tpArgs, value, bindArgs @ [arg]) + | PartialPrintf(tpArgs, value, bindArgs) -> Some(tpArgs, value, bindArgs @ [ arg ]) | _ -> None - | NewPrintfFormat(tpArgs, formatStr) -> - Some (tpArgs, formatStr, []) + | NewPrintfFormat(tpArgs, formatStr) -> Some(tpArgs, formatStr, []) | _ -> None let (|Printf|_|) (expr: Expr) = match expr with | PartialPrintf(tpArgs, value, bindArgs) -> if List.length bindArgs = List.length tpArgs then - Some (tpArgs, value, bindArgs) + Some(tpArgs, value, bindArgs) else None | _ -> None let private letDefinition (predicate: Var -> bool) (expr: Expr) = match expr with - | Let (var, expr, inExpr) -> - if predicate var then Some (var, expr, inExpr) else None + | Let(var, expr, inExpr) -> if predicate var then Some(var, expr, inExpr) else None | _ -> None - let (|LetFunc|_|) (expr: Expr) = - letDefinition Utils.isFunction expr + let (|LetFunc|_|) (expr: Expr) = letDefinition Utils.isFunction expr let (|LetVar|_|) (expr: Expr) = letDefinition (not << Utils.isFunction) expr @@ -91,7 +88,7 @@ module Patterns = // HACK это все можно DerrivedPatterns.Lambdas и DerrivedPatterns.Applications заменить же let rec private uncurryLambda (expr: Expr) = match expr with - | ExprShape.ShapeLambda (var, body) -> + | ExprShape.ShapeLambda(var, body) -> let (args, innerBody) = uncurryLambda body var :: args, innerBody | _ -> [], expr @@ -99,19 +96,18 @@ module Patterns = let private uncurryApplication (expr: Expr) = let rec uncurryApplicationImpl (acc: list) (expr: Expr) = match expr with - | Application (l, r) -> - uncurryApplicationImpl (r :: acc) l - | _ -> - expr, acc + | Application(l, r) -> uncurryApplicationImpl (r :: acc) l + | _ -> expr, acc + uncurryApplicationImpl [] expr /// let f x1 x2 x3 = body in e /// => LetFuncUncurry(f, [x1; x2, x3], body, e) let (|LetFuncUncurry|_|) (expr: Expr) = match expr with - | LetFunc (var, body, inExpr) -> + | LetFunc(var, body, inExpr) -> let args, body' = uncurryLambda body - Some (var, args, body', inExpr) + Some(var, args, body', inExpr) | _ -> None /// e0 e1 e2 e3 @@ -119,22 +115,25 @@ module Patterns = let (|ApplicationUncurry|_|) (expr: Expr) = // TODO: think about partial function, we should to raise exception somewhere match expr with - | Application _ -> - Some <| uncurryApplication expr + | Application _ -> Some <| uncurryApplication expr | _ -> None - let (|GlobalVar|_|) = function - | Patterns.PropertyGet (Some (Patterns.Var v), propInfo, args) when - v.Type.Name.ToLower().StartsWith ClArray_ && - propInfo.Name.ToLower().StartsWith "item" || - v.Type.Name.ToLower().StartsWith ClCell_ && - propInfo.Name.ToLower().StartsWith "value" -> Some v + let (|GlobalVar|_|) = + function + | Patterns.PropertyGet(Some(Patterns.Var v), propInfo, args) when + v.Type.Name.ToLower().StartsWith ClArray_ + && propInfo.Name.ToLower().StartsWith "item" + || v.Type.Name.ToLower().StartsWith ClCell_ + && propInfo.Name.ToLower().StartsWith "value" + -> + Some v | _ -> None - let (|ValidVolatileArg|_|) = function + let (|ValidVolatileArg|_|) = + function // global | GlobalVar v -> Some v // non-global | Patterns.Var var - | DerivedPatterns.SpecificCall <@ IntrinsicFunctions.GetArray @> (_, _, [Patterns.Var var; _]) -> Some var + | DerivedPatterns.SpecificCall <@ IntrinsicFunctions.GetArray @> (_, _, [ Patterns.Var var; _ ]) -> Some var | _ -> None diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Utils.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Utils.fs index 28f1592f..350ecb4a 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Utils.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Utils.fs @@ -8,13 +8,13 @@ open Brahma.FSharp.OpenCL.Translator module Utils = let rec getFunctionArgTypes (funType: System.Type) = let argType, retType = FSharpType.GetFunctionElements(funType) + match retType with - | _ when FSharpType.IsFunction retType -> - argType :: getFunctionArgTypes retType - | _ -> [argType] + | _ when FSharpType.IsFunction retType -> argType :: getFunctionArgTypes retType + | _ -> [ argType ] let makeFunctionType (retType: System.Type) (argTypes: List) = - List.foldBack (fun tp acc -> FSharpType.MakeFunctionType(tp, acc)) argTypes retType + List.foldBack (fun tp acc -> FSharpType.MakeFunctionType(tp, acc)) argTypes retType let makeLambdaType types = List.reduceBack (fun domain range -> FSharpType.MakeFunctionType(domain, range)) types @@ -26,72 +26,77 @@ module Utils = List.fold (fun l r -> Expr.Application(l, r)) head expressions // TODO tail recursion - let rec extractLambdaArguments = function - | Patterns.Lambda (var, body) -> + let rec extractLambdaArguments = + function + | Patterns.Lambda(var, body) -> let vars, body' = extractLambdaArguments body var :: vars, body' | expr -> [], expr - let rec collectLambdaArguments = function - | ExprShape.ShapeLambda (var, body) -> - var :: collectLambdaArguments body + let rec collectLambdaArguments = + function + | ExprShape.ShapeLambda(var, body) -> var :: collectLambdaArguments body | _ -> [] // Это из замыкания переменные? /// Collect free variables of expression that satisfies predicate. let rec collectFreeVarsWithPredicate (predicate: Var -> bool) (expr: Expr) : Set = - expr.GetFreeVars() - |> Seq.filter predicate - |> Set.ofSeq + expr.GetFreeVars() |> Seq.filter predicate |> Set.ofSeq - let isFunction (var: Var) = - FSharpType.IsFunction var.Type + let isFunction (var: Var) = FSharpType.IsFunction var.Type - let collectFreeVars : Expr -> Set = + let collectFreeVars: Expr -> Set = collectFreeVarsWithPredicate (not << isFunction) - let collectFreeFunctionVars : Expr -> Set = + let collectFreeFunctionVars: Expr -> Set = collectFreeVarsWithPredicate isFunction let rec collectLocalVars (expr: Expr) : Var list = match expr with - | Patterns.Let (variable, DerivedPatterns.SpecificCall <@ local @> (_, _, _), cont) - | Patterns.Let (variable, DerivedPatterns.SpecificCall <@ localArray @> (_, _, _), cont) -> + | Patterns.Let(variable, DerivedPatterns.SpecificCall <@ local @> (_, _, _), cont) + | Patterns.Let(variable, DerivedPatterns.SpecificCall <@ localArray @> (_, _, _), cont) -> variable :: collectLocalVars cont | ExprShape.ShapeVar _ -> [] - | ExprShape.ShapeLambda (_, lambda) -> - collectLocalVars lambda - | ExprShape.ShapeCombination (_, expressions) -> - List.collect collectLocalVars expressions + | ExprShape.ShapeLambda(_, lambda) -> collectLocalVars lambda + | ExprShape.ShapeCombination(_, expressions) -> List.collect collectLocalVars expressions - let isTypeOf<'tp> (var: Var) = - var.Type = typeof<'tp> + let isTypeOf<'tp> (var: Var) = var.Type = typeof<'tp> let createRefCall (value: Expr) = match <@@ ref () @@> with | Patterns.Call(obj, methodInfo, _) -> - let newMethodInfo = methodInfo.GetGenericMethodDefinition().MakeGenericMethod([|value.Type|]) + let newMethodInfo = + methodInfo.GetGenericMethodDefinition().MakeGenericMethod([| value.Type |]) + match obj with - | Some obj -> Expr.Call(obj, newMethodInfo, [value]) - | None -> Expr.Call(newMethodInfo, [value]) + | Some obj -> Expr.Call(obj, newMethodInfo, [ value ]) + | None -> Expr.Call(newMethodInfo, [ value ]) | _ -> failwithf "createRefCall: ref () is not more a Call expression" let createDereferenceCall (reference: Expr) = - match <@@ ! (ref ()) @@> with + match <@@ !(ref ()) @@> with | Patterns.Call(None, methodInfo, _) -> let tp = reference.Type.GenericTypeArguments.[0] - let newMethodInfo = methodInfo.GetGenericMethodDefinition().MakeGenericMethod([|tp|]) - Expr.Call (newMethodInfo, [reference]) + + let newMethodInfo = + methodInfo.GetGenericMethodDefinition().MakeGenericMethod([| tp |]) + + Expr.Call(newMethodInfo, [ reference ]) | _ -> failwithf "createDereferenceCall: ! is not more a Call expression" let createReferenceSetCall (reference: Expr) (value: Expr) = match <@@ ref () := () @@> with - | Patterns.Call (None, methodInfo, _) -> + | Patterns.Call(None, methodInfo, _) -> let tp = reference.Type.GenericTypeArguments.[0] let newMethodInfo = methodInfo.GetGenericMethodDefinition().MakeGenericMethod(tp) - Expr.Call (newMethodInfo, [reference; value]) + + Expr.Call( + newMethodInfo, + [ reference + value ] + ) | _ -> failwithf "createReferenceSetCall: (:=) is not more a Call expression" let isGlobal (var: Var) = - var.Type.Name.ToLower().StartsWith ClArray_ || - var.Type.Name.ToLower().StartsWith ClCell_ + var.Type.Name.ToLower().StartsWith ClArray_ + || var.Type.Name.ToLower().StartsWith ClCell_ diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/VarDefsToLambdaTransformer.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/VarDefsToLambdaTransformer.fs index 64c4c9d8..d858474e 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/VarDefsToLambdaTransformer.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/VarDefsToLambdaTransformer.fs @@ -12,16 +12,11 @@ module VarDefsToLambdaTransformer = | Patterns.ValueWithName _ | Patterns.DefaultValue _ | Patterns.Var _ -> true - | Patterns.Call (_, _, args) -> List.forall isPrimitiveExpression args - | Patterns.FieldGet (instance, _) -> - instance - |> Option.map isPrimitiveExpression - |> Option.defaultValue true - | Patterns.PropertyGet (instance, _, args) -> + | Patterns.Call(_, _, args) -> List.forall isPrimitiveExpression args + | Patterns.FieldGet(instance, _) -> instance |> Option.map isPrimitiveExpression |> Option.defaultValue true + | Patterns.PropertyGet(instance, _, args) -> let isPrimitiveInstance = - instance - |> Option.map isPrimitiveExpression - |> Option.defaultValue true + instance |> Option.map isPrimitiveExpression |> Option.defaultValue true let isPrimitiveArgs = List.forall isPrimitiveExpression args isPrimitiveInstance && isPrimitiveArgs @@ -31,7 +26,7 @@ module VarDefsToLambdaTransformer = // let x = expr -> let x = let unit () = expr in unit () let rec transformVarDefsToLambda (expr: Expr) = match expr with - | Patterns.LetVar (var, body, inExpr) -> + | Patterns.LetVar(var, body, inExpr) -> if isPrimitiveExpression body then Expr.Let(var, body, transformVarDefsToLambda inExpr) else @@ -67,7 +62,7 @@ module VarDefsToLambdaTransformer = ) | ExprShape.ShapeVar _ -> expr - | ExprShape.ShapeLambda (var, body) -> Expr.Lambda(var, transformVarDefsToLambda body) - | ExprShape.ShapeCombination (shapeComboObject, exprList) -> + | ExprShape.ShapeLambda(var, body) -> Expr.Lambda(var, transformVarDefsToLambda body) + | ExprShape.ShapeCombination(shapeComboObject, exprList) -> let exprList' = List.map transformVarDefsToLambda exprList ExprShape.RebuildShapeCombination(shapeComboObject, exprList') diff --git a/src/Brahma.FSharp.OpenCL.Translator/TranslationContext.fs b/src/Brahma.FSharp.OpenCL.Translator/TranslationContext.fs index ded3f0a7..66ec8aba 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/TranslationContext.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/TranslationContext.fs @@ -76,43 +76,39 @@ type Namer() = type TranslationContext<'lang, 'vDecl> = { - // translator scope - TranslatorOptions: TranslatorOptions + // translator scope + TranslatorOptions: TranslatorOptions - // kernel scope - CStructDecls: Dictionary> - StructInplaceCounter: Dictionary - TopLevelVarsDecls: ResizeArray<'vDecl> - Flags: HashSet + // kernel scope + CStructDecls: Dictionary> + StructInplaceCounter: Dictionary + TopLevelVarsDecls: ResizeArray<'vDecl> + Flags: HashSet - // function scope - VarDecls: ResizeArray<'vDecl> - Namer: Namer + // function scope + VarDecls: ResizeArray<'vDecl> + Namer: Namer - // specific scope - ArrayKind: ArrayKind - } + // specific scope + ArrayKind: ArrayKind } static member Create(options) = - { - TranslatorOptions = options + { TranslatorOptions = options - CStructDecls = Dictionary>() - StructInplaceCounter = Dictionary() - TopLevelVarsDecls = ResizeArray<'vDecl>() - Flags = HashSet() + CStructDecls = Dictionary>() + StructInplaceCounter = Dictionary() + TopLevelVarsDecls = ResizeArray<'vDecl>() + Flags = HashSet() - VarDecls = ResizeArray<'vDecl>() - Namer = Namer() + VarDecls = ResizeArray<'vDecl>() + Namer = Namer() - ArrayKind = CPointer - } + ArrayKind = CPointer } member this.WithNewLocalContext() = { this with VarDecls = ResizeArray() - Namer = Namer() - } + Namer = Namer() } type TargetContext = TranslationContext> diff --git a/src/Brahma.FSharp.OpenCL.Translator/Translator.fs b/src/Brahma.FSharp.OpenCL.Translator/Translator.fs index 4eff8030..23b11503 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/Translator.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/Translator.fs @@ -29,32 +29,26 @@ type FSQuotationToOpenCLTranslator(device: IDevice, ?translatorOptions: Translat let collectData (expr: Expr) (functions: (Var * Expr) list) = // global var names let kernelArgumentsNames = - expr - |> Utils.collectLambdaArguments - |> List.map (fun var -> var.Name) + expr |> Utils.collectLambdaArguments |> List.map (fun var -> var.Name) let localVarsNames = - expr - |> Utils.collectLocalVars - |> List.map (fun var -> var.Name) + expr |> Utils.collectLocalVars |> List.map (fun var -> var.Name) let atomicApplicationsInfo = let atomicPointerArgQualifiers = Dictionary>() let (|AtomicApplArgs|_|) (args: Expr list list) = match args with - | [mutex] :: _ :: [[DerivedPatterns.SpecificCall <@ ref @> (_, _, [Patterns.ValidVolatileArg var])]] - | [mutex] :: [[DerivedPatterns.SpecificCall <@ ref @> (_, _, [Patterns.ValidVolatileArg var])]] -> Some (mutex, var) + | [ mutex ] :: _ :: [ [ DerivedPatterns.SpecificCall <@ ref @> (_, _, [ Patterns.ValidVolatileArg var ]) ] ] + | [ mutex ] :: [ [ DerivedPatterns.SpecificCall <@ ref @> (_, _, [ Patterns.ValidVolatileArg var ]) ] ] -> + Some(mutex, var) | _ -> None let rec go expr = match expr with - | DerivedPatterns.Applications - ( - Patterns.Var funcVar, - AtomicApplArgs (_, volatileVar) - ) - when funcVar.Name.StartsWith "atomic" -> + | DerivedPatterns.Applications(Patterns.Var funcVar, AtomicApplArgs(_, volatileVar)) when + funcVar.Name.StartsWith "atomic" + -> if kernelArgumentsNames |> List.contains volatileVar.Name then atomicPointerArgQualifiers.Add(funcVar, Global) @@ -64,30 +58,29 @@ type FSQuotationToOpenCLTranslator(device: IDevice, ?translatorOptions: Translat failwith "Atomic pointer argument should be from local or global memory only" | ExprShape.ShapeVar _ -> () - | ExprShape.ShapeLambda (_, lambda) -> go lambda - | ExprShape.ShapeCombination (_, exprs) -> List.iter go exprs + | ExprShape.ShapeLambda(_, lambda) -> go lambda + | ExprShape.ShapeCombination(_, exprs) -> List.iter go exprs - functions - |> List.map snd - |> fun tail -> expr :: tail - |> Seq.iter go + functions |> List.map snd |> (fun tail -> expr :: tail) |> Seq.iter go - atomicPointerArgQualifiers - |> Seq.map (|KeyValue|) - |> Map.ofSeq + atomicPointerArgQualifiers |> Seq.map (|KeyValue|) |> Map.ofSeq kernelArgumentsNames, localVarsNames, atomicApplicationsInfo - let constructMethods (expr: Expr) (functions: (Var * Expr) list) (atomicApplicationsInfo: Map>) = - let kernelFunc = KernelFunc(Var(mainKernelName, expr.Type), expr) :> Method |> List.singleton + let constructMethods + (expr: Expr) + (functions: (Var * Expr) list) + (atomicApplicationsInfo: Map>) + = + let kernelFunc = + KernelFunc(Var(mainKernelName, expr.Type), expr) :> Method |> List.singleton let methods = functions |> List.map (fun (var, expr) -> match atomicApplicationsInfo |> Map.tryFind var with | Some qual -> AtomicFunc(var, expr, qual) :> Method - | None -> Function(var, expr) :> Method - ) + | None -> Function(var, expr) :> Method) methods @ kernelFunc @@ -107,10 +100,14 @@ type FSQuotationToOpenCLTranslator(device: IDevice, ?translatorOptions: Translat // TODO: Extract quotationTransformer to translator let (kernelExpr, functions) = transformQuotation expr - let (globalVars, localVars, atomicApplicationsInfo) = collectData kernelExpr functions + + let (globalVars, localVars, atomicApplicationsInfo) = + collectData kernelExpr functions + let methods = constructMethods kernelExpr functions atomicApplicationsInfo let clFuncs = ResizeArray() + for method in methods do clFuncs.AddRange(method.Translate(globalVars, localVars) |> State.eval context) @@ -123,9 +120,7 @@ type FSQuotationToOpenCLTranslator(device: IDevice, ?translatorOptions: Translat | EnableAtomic -> pragmas.Add(CLPragma CLGlobalInt32BaseAtomics :> ITopDef<_>) pragmas.Add(CLPragma CLLocalInt32BaseAtomics :> ITopDef<_>) - | EnableFP64 -> - pragmas.Add(CLPragma CLFP64) - ) + | EnableFP64 -> pragmas.Add(CLPragma CLFP64)) List.ofSeq pragmas @@ -140,16 +135,14 @@ type FSQuotationToOpenCLTranslator(device: IDevice, ?translatorOptions: Translat |> List.find (fun method -> method :? KernelFunc) |> fun kernel -> kernel.FunExpr - member val Marshaller = CustomMarshaller() with get + member val Marshaller = CustomMarshaller() member this.TranslatorOptions = translatorOptions member this.Translate(qExpr) = - lock lockObject <| fun () -> - translate qExpr + lock lockObject <| fun () -> translate qExpr - member this.TransformQuotation(expr: Expr) = - transformQuotation expr + member this.TransformQuotation(expr: Expr) = transformQuotation expr static member CreateDefault() = let device = @@ -162,7 +155,6 @@ type FSQuotationToOpenCLTranslator(device: IDevice, ?translatorOptions: Translat member this.MaxWorkItemSizes = [| 0 |] member this.DeviceExtensions = [||] member this.LocalMemSize = 0 - member this.GlobalMemSize = 0L - } + member this.GlobalMemSize = 0L } FSQuotationToOpenCLTranslator(device) diff --git a/src/Brahma.FSharp.OpenCL.Translator/Type.fs b/src/Brahma.FSharp.OpenCL.Translator/Type.fs index 02fe0b1d..bd6f6ff3 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/Type.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/Type.fs @@ -37,166 +37,187 @@ module rec Type = | _ -> None // как указатель транслируем только массивы и refType - let rec translate (type': System.Type) = translation { - match type' with - | Name "int" - | Name "int32" -> return PrimitiveType(Int) :> Type - | Name "int16" -> return PrimitiveType(Short) :> Type - | Name "uint16" -> return PrimitiveType(UShort) :> Type - | Name "uint32" -> return PrimitiveType(UInt) :> Type - | Name "float32" - | Name "single" -> return PrimitiveType(Float) :> Type - | Name "byte" -> return PrimitiveType(UChar) :> Type - | Name "sbyte" -> return PrimitiveType(Char) :> Type - | Name "int64" -> return PrimitiveType(Long) :> Type - | Name "uint64" -> return PrimitiveType(ULong) :> Type - | Name "unit" -> return PrimitiveType(Void) :> Type - | Name "float" - | Name "double" -> - do! State.modify (fun ctx -> ctx.Flags.Add EnableFP64 |> ignore; ctx) - return PrimitiveType(Double) :> Type - - | Name "boolean" -> - match! State.gets (fun ctx -> ctx.TranslatorOptions.UseNativeBooleanType) with - | true -> return PrimitiveType(Bool) :> Type - | false -> return PrimitiveType(BoolClAlias) :> Type - - | Name "read_only image2D" -> return Image2DType(true) :> Type - | Name "write_only image2D" -> return Image2DType(false) :> Type - - | StartsWith "fsharpref" -> - let! translatedType = translate type'.GenericTypeArguments.[0] - return RefType(translatedType, []) :> Type - | StartsWith "fsharpfunc" -> - return! translate type'.GenericTypeArguments.[1] - - | EndsWith "[]" -> - let! baseT = translate <| type'.GetElementType() - match! State.gets (fun ctx -> ctx.ArrayKind) with - | CPointer -> return RefType(baseT, []) :> Type - | CArrayDecl size -> return ArrayType(baseT, size) :> Type - - | StartsWith ClArray_ - | StartsWith ClCell_ - | StartsWith IBuffer_ -> - let! baseT = translate type'.GenericTypeArguments.[0] - match! State.gets (fun ctx -> ctx.ArrayKind) with - | CPointer -> return RefType(baseT, []) :> Type - | CArrayDecl size -> return ArrayType(baseT, size) :> Type - - | StartsWith "tuple" - | StartsWith "valuetuple" -> - let! translated = translateTuple type' - return translated :> Type<_> - - | _ when FSharpType.IsUnion type' -> - let! translated = translateUnion type' - return translated :> Type<_> - - // TODO only struct, not non-struct records - | _ when Utils.hasAttribute type' -> - let! translated = translateStruct type' - return translated :> Type<_> - - | other -> return failwithf $"Unsupported kernel type: %A{other}" - } - - let translateStruct (type': System.Type) = translation { - let! context = State.get - - if context.CStructDecls.ContainsKey type' then - return context.CStructDecls.[type'] - else - let! fields = - [ - for f in type'.GetProperties(BindingFlags.Public ||| BindingFlags.Instance) -> - translate f.PropertyType >>= fun type' -> - State.return' { Name = f.Name; Type = type' } - ] - @ - [ - if not <| FSharpType.IsRecord type' then - for f in type'.GetFields(BindingFlags.Public ||| BindingFlags.Instance) -> - translate f.FieldType >>= fun type' -> - State.return' { Name = f.Name; Type = type' } - ] - |> State.collect - - let fields = fields |> List.distinct - - let! index = State.gets (fun ctx -> ctx.CStructDecls.Count) - let structType = StructType( $"struct%i{index}", fields) - do! State.modify (fun context -> context.CStructDecls.Add(type', structType); context) - return structType - } - - let translateTuple (type': System.Type) = translation { - let! context = State.get - - if context.CStructDecls.ContainsKey type' then - return context.CStructDecls.[type'] - else - let genericTypeArguments = FSharpType.GetTupleElements type' |> List.ofArray - - let! elements = - genericTypeArguments - |> List.mapi - (fun i type' -> translation { - let! translatedType = translate type' - return { - Name = $"_%i{i + 1}" - Type = translatedType - } - }) - |> State.collect - - let! index = State.gets (fun ctx -> ctx.CStructDecls.Count) - let tupleDecl = StructType( $"tuple%i{index}", elements) - do! State.modify (fun ctx -> ctx.CStructDecls.Add(type', tupleDecl); ctx) - return tupleDecl - } - - let translateUnion (type': System.Type) = translation { - let! context = State.get - - if context.CStructDecls.ContainsKey type' then - return context.CStructDecls.[type'] - else - let notEmptyCases = - FSharpType.GetUnionCases type' - |> Array.filter (fun case -> case.GetFields().Length <> 0) - - let! fields = - [ - for case in notEmptyCases -> + let rec translate (type': System.Type) = + translation { + match type' with + | Name "int" + | Name "int32" -> return PrimitiveType(Int) :> Type + | Name "int16" -> return PrimitiveType(Short) :> Type + | Name "uint16" -> return PrimitiveType(UShort) :> Type + | Name "uint32" -> return PrimitiveType(UInt) :> Type + | Name "float32" + | Name "single" -> return PrimitiveType(Float) :> Type + | Name "byte" -> return PrimitiveType(UChar) :> Type + | Name "sbyte" -> return PrimitiveType(Char) :> Type + | Name "int64" -> return PrimitiveType(Long) :> Type + | Name "uint64" -> return PrimitiveType(ULong) :> Type + | Name "unit" -> return PrimitiveType(Void) :> Type + | Name "float" + | Name "double" -> + do! + State.modify (fun ctx -> + ctx.Flags.Add EnableFP64 |> ignore + ctx) + + return PrimitiveType(Double) :> Type + + | Name "boolean" -> + match! State.gets (fun ctx -> ctx.TranslatorOptions.UseNativeBooleanType) with + | true -> return PrimitiveType(Bool) :> Type + | false -> return PrimitiveType(BoolClAlias) :> Type + + | Name "read_only image2D" -> return Image2DType(true) :> Type + | Name "write_only image2D" -> return Image2DType(false) :> Type + + | StartsWith "fsharpref" -> + let! translatedType = translate type'.GenericTypeArguments.[0] + return RefType(translatedType, []) :> Type + | StartsWith "fsharpfunc" -> return! translate type'.GenericTypeArguments.[1] + + | EndsWith "[]" -> + let! baseT = translate <| type'.GetElementType() + + match! State.gets (fun ctx -> ctx.ArrayKind) with + | CPointer -> return RefType(baseT, []) :> Type + | CArrayDecl size -> return ArrayType(baseT, size) :> Type + + | StartsWith ClArray_ + | StartsWith ClCell_ + | StartsWith IBuffer_ -> + let! baseT = translate type'.GenericTypeArguments.[0] + + match! State.gets (fun ctx -> ctx.ArrayKind) with + | CPointer -> return RefType(baseT, []) :> Type + | CArrayDecl size -> return ArrayType(baseT, size) :> Type + + | StartsWith "tuple" + | StartsWith "valuetuple" -> + let! translated = translateTuple type' + return translated :> Type<_> + + | _ when FSharpType.IsUnion type' -> + let! translated = translateUnion type' + return translated :> Type<_> + + // TODO only struct, not non-struct records + | _ when Utils.hasAttribute type' -> + let! translated = translateStruct type' + return translated :> Type<_> + + | other -> return failwithf $"Unsupported kernel type: %A{other}" + } + + let translateStruct (type': System.Type) = + translation { + let! context = State.get + + if context.CStructDecls.ContainsKey type' then + return context.CStructDecls.[type'] + else + let! fields = + [ for f in type'.GetProperties(BindingFlags.Public ||| BindingFlags.Instance) -> + translate f.PropertyType + >>= fun type' -> State.return' { Name = f.Name; Type = type' } ] + @ [ if not <| FSharpType.IsRecord type' then + for f in type'.GetFields(BindingFlags.Public ||| BindingFlags.Instance) -> + translate f.FieldType + >>= fun type' -> State.return' { Name = f.Name; Type = type' } ] + |> State.collect + + let fields = fields |> List.distinct + + let! index = State.gets (fun ctx -> ctx.CStructDecls.Count) + let structType = StructType($"struct%i{index}", fields) + + do! + State.modify (fun context -> + context.CStructDecls.Add(type', structType) + context) + + return structType + } + + let translateTuple (type': System.Type) = + translation { + let! context = State.get + + if context.CStructDecls.ContainsKey type' then + return context.CStructDecls.[type'] + else + let genericTypeArguments = FSharpType.GetTupleElements type' |> List.ofArray + + let! elements = + genericTypeArguments + |> List.mapi (fun i type' -> translation { - let structName = case.Name - let tag = case.Tag - let! fields = - [ - for field in case.GetFields() -> - translate field.PropertyType >>= fun type' -> - State.return' { Name = field.Name; Type = type' } - ] - |> State.collect - - let! context = State.get - let conter = - let mutable i = 0 - if context.StructInplaceCounter.TryGetValue($"{structName}Type", &i) then - context.StructInplaceCounter.[$"{structName}Type"] <- i + 1 - i - else - context.StructInplaceCounter.Add($"{structName}Type", 1) - 0 - - return tag, { Name = structName; Type = StructInplaceType($"{structName}Type{conter}", fields) } - } - ] - |> State.collect - - let! index = State.gets (fun ctx -> ctx.CStructDecls.Count) - let duType = DiscriminatedUnionType( $"du%i{index}", fields) - do! State.modify (fun context -> context.CStructDecls.Add(type', duType); context) - return duType :> StructType<_> - } + let! translatedType = translate type' + + return + { Name = $"_%i{i + 1}" + Type = translatedType } + }) + |> State.collect + + let! index = State.gets (fun ctx -> ctx.CStructDecls.Count) + let tupleDecl = StructType($"tuple%i{index}", elements) + + do! + State.modify (fun ctx -> + ctx.CStructDecls.Add(type', tupleDecl) + ctx) + + return tupleDecl + } + + let translateUnion (type': System.Type) = + translation { + let! context = State.get + + if context.CStructDecls.ContainsKey type' then + return context.CStructDecls.[type'] + else + let notEmptyCases = + FSharpType.GetUnionCases type' + |> Array.filter (fun case -> case.GetFields().Length <> 0) + + let! fields = + [ for case in notEmptyCases -> + translation { + let structName = case.Name + let tag = case.Tag + + let! fields = + [ for field in case.GetFields() -> + translate field.PropertyType + >>= fun type' -> State.return' { Name = field.Name; Type = type' } ] + |> State.collect + + let! context = State.get + + let conter = + let mutable i = 0 + + if context.StructInplaceCounter.TryGetValue($"{structName}Type", &i) then + context.StructInplaceCounter.[$"{structName}Type"] <- i + 1 + i + else + context.StructInplaceCounter.Add($"{structName}Type", 1) + 0 + + return + tag, + { Name = structName + Type = StructInplaceType($"{structName}Type{conter}", fields) } + } ] + |> State.collect + + let! index = State.gets (fun ctx -> ctx.CStructDecls.Count) + let duType = DiscriminatedUnionType($"du%i{index}", fields) + + do! + State.modify (fun context -> + context.CStructDecls.Add(type', duType) + context) + + return duType :> StructType<_> + } diff --git a/src/Brahma.FSharp.OpenCL.Translator/Utils/Extensions.fs b/src/Brahma.FSharp.OpenCL.Translator/Utils/Extensions.fs index ffaf6c50..3bf80c43 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/Utils/Extensions.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/Utils/Extensions.fs @@ -6,32 +6,25 @@ open Microsoft.FSharp.Reflection [] module Extensions = type Expr with + /// Builds an expression that represents the lambda static member Lambdas(args: Var list list, body: Expr) = - let mkRLinear mk (vs, body) = List.foldBack (fun v acc -> mk (v, acc)) vs body + let mkRLinear mk (vs, body) = + List.foldBack (fun v acc -> mk (v, acc)) vs body let mkTupledLambda (args, body) = match args with - | [x] -> Expr.Lambda(x, body) + | [ x ] -> Expr.Lambda(x, body) | [] -> Expr.Lambda(Var("unitVar", typeof), body) | _ -> let tupledArg = - Var( - "tupledArg", - FSharpType.MakeTupleType(args |> List.map (fun v -> v.Type) |> List.toArray) - ) + Var("tupledArg", FSharpType.MakeTupleType(args |> List.map (fun v -> v.Type) |> List.toArray)) Expr.Lambda( tupledArg, - (args, [0 .. args.Length - 1], body) - |||> List.foldBack2 - (fun var idxInTuple letExpr -> - Expr.Let( - var, - Expr.TupleGet(Expr.Var tupledArg, idxInTuple), - letExpr - ) - ) + (args, [ 0 .. args.Length - 1 ], body) + |||> List.foldBack2 (fun var idxInTuple letExpr -> + Expr.Let(var, Expr.TupleGet(Expr.Var tupledArg, idxInTuple), letExpr)) ) mkRLinear mkTupledLambda (args, body) diff --git a/src/Brahma.FSharp.OpenCL.Translator/Utils/StateBuilder.fs b/src/Brahma.FSharp.OpenCL.Translator/Utils/StateBuilder.fs index 9718c0cf..8112c446 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/Utils/StateBuilder.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/Utils/StateBuilder.fs @@ -3,50 +3,44 @@ namespace Brahma.FSharp.OpenCL.Translator type State<'state, 'result> = State of ('state -> 'result * 'state) module State = - let inline run state (State f) = - f state + let inline run state (State f) = f state - let exec state (State f) = - snd (f state) + let exec state (State f) = snd (f state) - let eval state (State f) = - fst (f state) + let eval state (State f) = fst (f state) - let inline return' x = State <| fun state -> - (x, state) + let inline return' x = State <| fun state -> (x, state) - let inline (>>=) x f = State <| fun state -> - let (y, state') = run state x - run state' (f y) + let inline (>>=) x f = + State + <| fun state -> + let (y, state') = run state x + run state' (f y) - let get = State (fun s -> s, s) + let get = State(fun s -> s, s) - let put newState = State <| fun _ -> - (), newState + let put newState = State <| fun _ -> (), newState // modify state - let modify f = - get >>= (f >> put) + let modify f = get >>= (f >> put) // apply f to state to produce value - let gets f = - get >>= (f >> return') + let gets f = get >>= (f >> return') - let map f s = State <| fun state -> - let (x, state) = run state s - f x, state + let map f s = + State + <| fun state -> + let (x, state) = run state s + f x, state - let using f x = State <| fun state -> - eval (f state) x, state + let using f x = + State <| fun state -> eval (f state) x, state let collect (list: State<'s, 'a> list) = list |> List.fold - (fun state elem -> - state >>= fun state -> - elem >>= fun elem -> - return' (elem :: state) - ) (return' List.empty) + (fun state elem -> state >>= fun state -> elem >>= fun elem -> return' (elem :: state)) + (return' List.empty) |> fun args -> map List.rev args type StateBuilder<'state>() = @@ -56,7 +50,8 @@ type StateBuilder<'state>() = member inline this.Zero() : State<'state, unit> = State.return' () member inline this.Combine(x1: State<'state, _>, x2: State<'state, _>) = - State <| fun context -> + State + <| fun context -> let (_, context) = State.run context x1 State.run context x2 diff --git a/src/Brahma.FSharp.OpenCL.Translator/Utils/Utils.fs b/src/Brahma.FSharp.OpenCL.Translator/Utils/Utils.fs index 85274535..84cdbf43 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/Utils/Utils.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/Utils/Utils.fs @@ -6,8 +6,8 @@ open System module Utils = let getMethodInfoOfCall (expr: Expr) = match expr with - | Patterns.Call (_, mInfo, _) -> mInfo - | DerivedPatterns.Lambdas (_, Patterns.Call (_, mInfo, _)) -> mInfo + | Patterns.Call(_, mInfo, _) -> mInfo + | DerivedPatterns.Lambdas(_, Patterns.Call(_, mInfo, _)) -> mInfo | _ -> failwithf $"Expression is not kind of call, but {expr}" let makeGenericMethodCall (types: Type list) (expr: Expr) = @@ -20,7 +20,4 @@ module Utils = |> Seq.exists (fun attr -> attr.GetType() = typeof<'attr>) let roundUp n x = - if x % n <> 0 then - (x / n) * n + n - else - x + if x % n <> 0 then (x / n) * n + n else x diff --git a/tests/Brahma.FSharp.Tests/Brahma.FSharp.Tests.fsproj b/tests/Brahma.FSharp.Tests/Brahma.FSharp.Tests.fsproj index dad2b3eb..9a9df832 100644 --- a/tests/Brahma.FSharp.Tests/Brahma.FSharp.Tests.fsproj +++ b/tests/Brahma.FSharp.Tests/Brahma.FSharp.Tests.fsproj @@ -10,100 +10,94 @@ - - + + + + Always + + + + Always - - - - - - - - - - - - - - - - - - + + + Always + - - - - - + + + Always + - - + + + Always + - - - - - - - - - - - - - - - - - - - - - + + + Always + - - + + + Always + - - + + + Always + - - - - - - + + + Always + - + + + Always + - - - - - + + + Always + - - + + + Always + - - - + + + Always + - - - + + + Always + - - - + + + Always + + + + + + + + + Always + diff --git a/tests/Brahma.FSharp.Tests/Common.fs b/tests/Brahma.FSharp.Tests/Common.fs index 1278efc5..eb948fea 100644 --- a/tests/Brahma.FSharp.Tests/Common.fs +++ b/tests/Brahma.FSharp.Tests/Common.fs @@ -9,22 +9,14 @@ module CustomDatatypes = val mutable InnerValue: int new(x) = { InnerValue = x } - static member (+) (x: WrappedInt, y: WrappedInt) = - WrappedInt(x.InnerValue + y.InnerValue) + static member (+)(x: WrappedInt, y: WrappedInt) = WrappedInt(x.InnerValue + y.InnerValue) - static member (-) (x: WrappedInt, y: WrappedInt) = - WrappedInt(x.InnerValue - y.InnerValue) + static member (-)(x: WrappedInt, y: WrappedInt) = WrappedInt(x.InnerValue - y.InnerValue) module Utils = let filesAreEqual file1 file2 = - let all1 = - (File.ReadAllText file1) - .Trim() - .Replace("\r\n", "\n") + let all1 = (File.ReadAllText file1).Trim().Replace("\r\n", "\n") - let all2 = - (File.ReadAllText file2) - .Trim() - .Replace("\r\n", "\n") + let all2 = (File.ReadAllText file2).Trim().Replace("\r\n", "\n") Expect.sequenceEqual all1 all2 "Files should be equals as strings" diff --git a/tests/Brahma.FSharp.Tests/ExecutionTests/AtomicTests.fs b/tests/Brahma.FSharp.Tests/ExecutionTests/AtomicTests.fs index 6f7a10ff..b4a8cc20 100644 --- a/tests/Brahma.FSharp.Tests/ExecutionTests/AtomicTests.fs +++ b/tests/Brahma.FSharp.Tests/ExecutionTests/AtomicTests.fs @@ -18,22 +18,14 @@ module Helpers = Arb.Default.NormalFloat() |> Arb.toGen |> Gen.map float - |> Gen.filter - (fun v -> - v < 100. && - v > -100. - ) + |> Gen.filter (fun v -> v < 100. && v > -100.) |> Gen.arrayOf |> Arb.fromGen static member Float32Type() = Arb.Default.Float32() |> Arb.toGen - |> Gen.filter - (fun v -> - v < 100.f && - v > -100.f - ) + |> Gen.filter (fun v -> v < 100.f && v > -100.f) |> Gen.arrayOf |> Arb.fromGen @@ -45,49 +37,49 @@ module Helpers = { Config.QuickThrowOnFailure with QuietOnSuccess = true MaxTest = 20 - Arbitrary = [typeof] - } - let checkDefault<'a when 'a : equality and 'a : struct> context expected kernel = + Arbitrary = [ typeof ] } + + let checkDefault<'a when 'a: equality and 'a: struct> context expected kernel = let actual = opencl { use! result = ClArray.toDevice <| Array.zeroCreate<'a> 1 - do! runCommand kernel <| fun kernelPrepare -> - kernelPrepare - <| Range1D(Settings.doubledWgSize, Settings.wgSize) - <| result + + do! + runCommand kernel + <| fun kernelPrepare -> kernelPrepare <| Range1D(Settings.doubledWgSize, Settings.wgSize) <| result return! ClArray.toHost result } |> ClTask.runSync context |> fun result -> result.[0] - "Results should be equal" - |> Expect.equal actual expected + "Results should be equal" |> Expect.equal actual expected // TODO add tests in inc dec on supported types (generate spinlock) /// Stress test for unary atomic operations. /// Use global atomics -let stressTest<'a when 'a : equality and 'a : struct> context (f: Expr<'a -> 'a>) size rawF (isEqual: 'a -> 'a -> bool) = +let stressTest<'a when 'a: equality and 'a: struct> context (f: Expr<'a -> 'a>) size rawF (isEqual: 'a -> 'a -> bool) = let kernel = <@ fun (range: Range1D) (result: 'a clarray) -> let gid = range.GlobalID0 + if gid < size then atomic %f result.[0] |> ignore @> let expected = - [0 .. size - 1] + [ 0 .. size - 1 ] |> List.fold (fun state _ -> rawF state) Unchecked.defaultof<'a> let actual = opencl { use! result = ClArray.toDevice <| Array.zeroCreate<'a> 1 - do! runCommand kernel <| fun kernelPrepare -> - kernelPrepare - <| Range1D.CreateValid(size, Settings.wgSize) - <| result + + do! + runCommand kernel + <| fun kernelPrepare -> kernelPrepare <| Range1D.CreateValid(size, Settings.wgSize) <| result return! ClArray.toHost result } @@ -100,140 +92,185 @@ let stressTest<'a when 'a : equality and 'a : struct> context (f: Expr<'a -> 'a> >> setField "exp" expected ) - "Results should be equal" - |> Expect.isTrue (isEqual actual expected) - -let stressTestCases context = [ - let range = [1 .. 10 .. 100] - - // int - yield! range |> List.map (fun size -> - testCase $"Smoke stress test (size %i{size}) on atomic 'inc' on int" <| fun () -> - stressTest context <@ inc @> size (fun x -> x + 1) (=) - ) - yield! range |> List.map (fun size -> - testCase $"Smoke stress test (size %i{size}) on atomic 'dec' on int" <| fun () -> - stressTest context <@ dec @> size (fun x -> x - 1) (=) - ) - - // float32 - yield! range |> List.map (fun size -> - testCase $"Smoke stress test (size %i{size}) on atomic 'inc' on float32" <| fun () -> - stressTest context <@ fun x -> x + 1.f @> size (fun x -> x + 1.f) (fun x y -> float (abs (x - y)) < Accuracy.low.relative) - ) - - // double - yield! range |> List.map (fun size -> - testCase $"Smoke stress test (size %i{size}) on atomic 'inc' on float" <| fun () -> - stressTest context <@ fun x -> x + 1. @> size (fun x -> x + 1.) (fun x y -> abs (x - y) < Accuracy.low.relative) - ) - - // bool - yield! range |> List.map (fun size -> - testCase $"Smoke stress test (size %i{size}) on atomic 'not' on bool" <| fun () -> - stressTest context <@ not @> size not (=) - ) - - // WrappedInt (не работает транляция или типа того) - let wrappedIntInc = <@ fun x -> x + WrappedInt(1) @> - yield! range |> List.map (fun size -> - ptestCase $"Smoke stress test (size %i{size}) on custom atomic 'inc' on WrappedInt" <| fun () -> - stressTest context wrappedIntInc size (fun x -> x + WrappedInt(1)) (=) - ) - - // custom int op - let incx2 = <@ fun x -> x + 2 @> - yield! range |> List.map (fun size -> - testCase $"Smoke stress test (size %i{size}) on atomic unary func on int" <| fun () -> - stressTest context incx2 size (fun x -> x + 2) (=) - ) -] + "Results should be equal" |> Expect.isTrue (isEqual actual expected) + +let stressTestCases context = + [ let range = [ 1..10..100 ] + + // int + yield! + range + |> List.map (fun size -> + testCase $"Smoke stress test (size %i{size}) on atomic 'inc' on int" + <| fun () -> stressTest context <@ inc @> size (fun x -> x + 1) (=)) + + yield! + range + |> List.map (fun size -> + testCase $"Smoke stress test (size %i{size}) on atomic 'dec' on int" + <| fun () -> stressTest context <@ dec @> size (fun x -> x - 1) (=)) + + // float32 + yield! + range + |> List.map (fun size -> + testCase $"Smoke stress test (size %i{size}) on atomic 'inc' on float32" + <| fun () -> + stressTest + context + <@ fun x -> x + 1.f @> + size + (fun x -> x + 1.f) + (fun x y -> float (abs (x - y)) < Accuracy.low.relative)) + + // double + yield! + range + |> List.map (fun size -> + testCase $"Smoke stress test (size %i{size}) on atomic 'inc' on float" + <| fun () -> + stressTest + context + <@ fun x -> x + 1. @> + size + (fun x -> x + 1.) + (fun x y -> abs (x - y) < Accuracy.low.relative)) + + // bool + yield! + range + |> List.map (fun size -> + testCase $"Smoke stress test (size %i{size}) on atomic 'not' on bool" + <| fun () -> stressTest context <@ not @> size not (=)) + + // WrappedInt (не работает транляция или типа того) + let wrappedIntInc = <@ fun x -> x + WrappedInt(1) @> + + yield! + range + |> List.map (fun size -> + ptestCase $"Smoke stress test (size %i{size}) on custom atomic 'inc' on WrappedInt" + <| fun () -> stressTest context wrappedIntInc size (fun x -> x + WrappedInt(1)) (=)) + + // custom int op + let incx2 = <@ fun x -> x + 2 @> + + yield! + range + |> List.map (fun size -> + testCase $"Smoke stress test (size %i{size}) on atomic unary func on int" + <| fun () -> stressTest context incx2 size (fun x -> x + 2) (=)) ] /// Test for add and sub like atomic operations. /// Use local and global atomics, /// use reading from global mem in local atomic -let foldTest<'a when 'a : equality and 'a : struct> context f (isEqual: 'a -> 'a -> bool) = - let (.=.) left right = isEqual left right |@ $"%A{left} = %A{right}" +let foldTest<'a when 'a: equality and 'a: struct> context f (isEqual: 'a -> 'a -> bool) = + let (.=.) left right = + isEqual left right |@ $"%A{left} = %A{right}" - Check.One(Settings.fscheckConfig, fun (array: 'a[]) -> - let arrayLength = array.Length - let kernel zero = - <@ - fun (range: Range1D) (array: 'a clarray) (result: 'a clcell) -> - let lid = range.LocalID0 - let gid = range.GlobalID0 - - let localResult = localArray<'a> 1 - if lid = 0 then - localResult.[0] <- zero - - barrierLocal () - - if gid < arrayLength then - atomic %f localResult.[0] array.[gid] |> ignore - - if lid = 0 then - atomic %f result.Value localResult.[0] |> ignore - @> - - let expected () = - array - |> Array.fold (fun state x -> f.Evaluate() state x) Unchecked.defaultof<'a> - - let actual () = - opencl { - use! result = ClCell.alloc<'a> () - use! array = ClArray.toDevice array - do! runCommand (kernel Unchecked.defaultof<'a>) <| fun kernelPrepare -> - kernelPrepare - <| Range1D.CreateValid(array.Length, Settings.wgSize) - <| array - <| result - - return! ClCell.toHost result - } - |> ClTask.runSync context + Check.One( + Settings.fscheckConfig, + fun (array: 'a[]) -> + let arrayLength = array.Length - array.Length <> 0 - ==> lazy (actual () .=. expected ()) - ) + let kernel zero = + <@ + fun (range: Range1D) (array: 'a clarray) (result: 'a clcell) -> + let lid = range.LocalID0 + let gid = range.GlobalID0 -let foldTestCases context = [ - // int, smoke tests - testCase "Smoke fold test atomic 'add' on int" <| fun () -> foldTest context <@ (+) @> (=) + let localResult = localArray<'a> 1 - // float - testCase "Fold test atomic 'add' on float32" <| fun () -> foldTest context <@ (+) @> (fun x y -> float (abs (x - y)) < Accuracy.low.relative) + if lid = 0 then + localResult.[0] <- zero - // double - testCase "Fold test atomic 'add' on float" <| fun () -> foldTest context <@ (+) @> (fun x y -> abs (x - y) < Accuracy.low.relative) + barrierLocal () - // bool - ptestCase "Fold test atomic '&&' on bool" <| fun () -> foldTest context <@ (&&) @> (=) + if gid < arrayLength then + atomic %f localResult.[0] array.[gid] |> ignore - testCase "Reduce test atomic 'min' on int" <| fun () -> foldTest context <@ min @> (=) - ptestCase "Reduce test atomic 'min' on int64" <| fun () -> foldTest context <@ min @> (=) - testCase "Reduce test atomic 'min' on int16" <| fun () -> foldTest context <@ min @> (=) + if lid = 0 then + atomic %f result.Value localResult.[0] |> ignore + @> - testCase "Reduce test atomic 'max' on int" <| fun () -> foldTest context <@ max @> (=) - ptestCase "Reduce test atomic 'max' on int64" <| fun () -> foldTest context <@ max @> (=) - testCase "Reduce test atomic 'max' on int16" <| fun () -> foldTest context <@ max @> (=) + let expected () = + array + |> Array.fold (fun state x -> f.Evaluate () state x) Unchecked.defaultof<'a> - testCase "Reduce test atomic '&&&' on int" <| fun () -> foldTest context <@ (&&&) @> (=) - ptestCase "Reduce test atomic '&&&' on int64" <| fun () -> foldTest context <@ (&&&) @> (=) + let actual () = + opencl { + use! result = ClCell.alloc<'a> () + use! array = ClArray.toDevice array - testCase "Reduce test atomic '|||' on int" <| fun () -> foldTest context <@ (|||) @> (=) - ptestCase "Reduce test atomic '|||' on int64" <| fun () -> foldTest context <@ (|||) @> (=) + do! + runCommand (kernel Unchecked.defaultof<'a>) + <| fun kernelPrepare -> + kernelPrepare + <| Range1D.CreateValid(array.Length, Settings.wgSize) + <| array + <| result - testCase "Reduce test atomic '^^^' on int" <| fun () -> foldTest context <@ (^^^) @> (=) - ptestCase "Reduce test atomic '^^^' on int64" <| fun () -> foldTest context <@ (^^^) @> (=) + return! ClCell.toHost result + } + |> ClTask.runSync context - // WrappedInt (не работает транляция или типа того) - ptestCase "Fold test atomic 'add' on WrappedInt" <| fun () -> foldTest context <@ (+) @> (=) -] + array.Length <> 0 ==> lazy (actual () .=. expected ()) + ) -let xchgTest<'a when 'a : equality and 'a : struct> context cmp value = +let foldTestCases context = + [ + // int, smoke tests + testCase "Smoke fold test atomic 'add' on int" + <| fun () -> foldTest context <@ (+) @> (=) + + // float + testCase "Fold test atomic 'add' on float32" + <| fun () -> foldTest context <@ (+) @> (fun x y -> float (abs (x - y)) < Accuracy.low.relative) + + // double + testCase "Fold test atomic 'add' on float" + <| fun () -> foldTest context <@ (+) @> (fun x y -> abs (x - y) < Accuracy.low.relative) + + // bool + ptestCase "Fold test atomic '&&' on bool" + <| fun () -> foldTest context <@ (&&) @> (=) + + testCase "Reduce test atomic 'min' on int" + <| fun () -> foldTest context <@ min @> (=) + ptestCase "Reduce test atomic 'min' on int64" + <| fun () -> foldTest context <@ min @> (=) + testCase "Reduce test atomic 'min' on int16" + <| fun () -> foldTest context <@ min @> (=) + + testCase "Reduce test atomic 'max' on int" + <| fun () -> foldTest context <@ max @> (=) + ptestCase "Reduce test atomic 'max' on int64" + <| fun () -> foldTest context <@ max @> (=) + testCase "Reduce test atomic 'max' on int16" + <| fun () -> foldTest context <@ max @> (=) + + testCase "Reduce test atomic '&&&' on int" + <| fun () -> foldTest context <@ (&&&) @> (=) + ptestCase "Reduce test atomic '&&&' on int64" + <| fun () -> foldTest context <@ (&&&) @> (=) + + testCase "Reduce test atomic '|||' on int" + <| fun () -> foldTest context <@ (|||) @> (=) + ptestCase "Reduce test atomic '|||' on int64" + <| fun () -> foldTest context <@ (|||) @> (=) + + testCase "Reduce test atomic '^^^' on int" + <| fun () -> foldTest context <@ (^^^) @> (=) + ptestCase "Reduce test atomic '^^^' on int64" + <| fun () -> foldTest context <@ (^^^) @> (=) + + // WrappedInt (не работает транляция или типа того) + ptestCase "Fold test atomic 'add' on WrappedInt" + <| fun () -> foldTest context <@ (+) @> (=) ] + +let xchgTest<'a when 'a: equality and 'a: struct> context cmp value = let localSize = Settings.wgSize + let kernel = <@ fun (range: Range1D) (array: 'a clarray) -> @@ -248,80 +285,83 @@ let xchgTest<'a when 'a : equality and 'a : struct> context cmp value = let actual = opencl { - use! buffer = ClArray.toDevice [| for i = 0 to localSize - 1 do if i < localSize / 2 then cmp else value |] - do! runCommand kernel <| fun kernelPrepare -> - kernelPrepare - <| Range1D(localSize, localSize) - <| buffer + use! buffer = + ClArray.toDevice + [| for i = 0 to localSize - 1 do + if i < localSize / 2 then cmp else value |] + + do! + runCommand kernel + <| fun kernelPrepare -> kernelPrepare <| Range1D(localSize, localSize) <| buffer return! ClArray.toHost buffer } |> ClTask.runSync context - "Results should be equal" - |> Expect.sequenceEqual actual expected + "Results should be equal" |> Expect.sequenceEqual actual expected -let xchgTestCases context = [ - testCase "Xchg test on int" <| fun () -> xchgTest context 0 256 - testCase "Xchg test on float" <| fun () -> xchgTest context 0. 256. - testCase "Xchg test on bool" <| fun () -> xchgTest context false true - ptestCase "Xchg test on WrappedInt" <| fun () -> xchgTest context (WrappedInt 0) (WrappedInt 256) -] +let xchgTestCases context = + [ testCase "Xchg test on int" <| fun () -> xchgTest context 0 256 + testCase "Xchg test on float" <| fun () -> xchgTest context 0. 256. + testCase "Xchg test on bool" <| fun () -> xchgTest context false true + ptestCase "Xchg test on WrappedInt" + <| fun () -> xchgTest context (WrappedInt 0) (WrappedInt 256) ] // TODO barrier broken -let perfomanceTest context = fun () -> - // use native atomic_inc for int - let kernelUsingNativeInc = - <@ - fun (range: Range1D) (result: int clarray) -> - let localAcc = localArray 1 - if range.LocalID0 = 0 then - localAcc.[0] <- 0 +let perfomanceTest context = + fun () -> + // use native atomic_inc for int + let kernelUsingNativeInc = + <@ + fun (range: Range1D) (result: int clarray) -> + let localAcc = localArray 1 - atomic inc localAcc.[0] |> ignore - barrierLocal () + if range.LocalID0 = 0 then + localAcc.[0] <- 0 - if range.LocalID0 = 0 then - result.[0] <- localAcc.[0] - @> + atomic inc localAcc.[0] |> ignore + barrierLocal () - // generate spinlock - let kernelUsingCustomInc = - let inc = <@ fun x -> x + 1 @> - <@ - fun (range: Range1D) (result: int clarray) -> - let localAcc = localArray 1 - if range.LocalID0 = 0 then - localAcc.[0] <- 0 + if range.LocalID0 = 0 then + result.[0] <- localAcc.[0] + @> - atomic %inc localAcc.[0] |> ignore - barrierLocal () + // generate spinlock + let kernelUsingCustomInc = + let inc = <@ fun x -> x + 1 @> - if range.LocalID0 = 0 then - result.[0] <- localAcc.[0] - @> + <@ + fun (range: Range1D) (result: int clarray) -> + let localAcc = localArray 1 - let prepare kernel () = - opencl { - use! result = ClArray.toDevice <| Array.zeroCreate 1 - do! runCommand kernel <| fun kernelPrepare -> - kernelPrepare - <| Range1D(Settings.wgSize, Settings.wgSize) - <| result + if range.LocalID0 = 0 then + localAcc.[0] <- 0 - return! ClArray.toHost result - } - |> ClTask.runSync context + atomic %inc localAcc.[0] |> ignore + barrierLocal () + + if range.LocalID0 = 0 then + result.[0] <- localAcc.[0] + @> + + let prepare kernel () = + opencl { + use! result = ClArray.toDevice <| Array.zeroCreate 1 - "Kernel wich uses native 'inc' should be faster than with custom one" - |> Expect.isFasterThan (prepare kernelUsingNativeInc) (prepare kernelUsingCustomInc) + do! + runCommand kernel + <| fun kernelPrepare -> kernelPrepare <| Range1D(Settings.wgSize, Settings.wgSize) <| result + + return! ClArray.toHost result + } + |> ClTask.runSync context + + "Kernel wich uses native 'inc' should be faster than with custom one" + |> Expect.isFasterThan (prepare kernelUsingNativeInc) (prepare kernelUsingCustomInc) let tests context = - [ - testList "Stress tests" << stressTestCases - ptestList "Fold tests" << foldTestCases - ptestList "Xchg tests" << xchgTestCases - ptestCase "Perfomance test on 'inc'" << perfomanceTest - ] + [ testList "Stress tests" << stressTestCases + ptestList "Fold tests" << foldTestCases + ptestList "Xchg tests" << xchgTestCases + ptestCase "Perfomance test on 'inc'" << perfomanceTest ] |> List.map (fun testFixture -> testFixture context) - diff --git a/tests/Brahma.FSharp.Tests/ExecutionTests/CompilationTests.fs b/tests/Brahma.FSharp.Tests/ExecutionTests/CompilationTests.fs index 3c1a7a1e..650bbb6c 100644 --- a/tests/Brahma.FSharp.Tests/ExecutionTests/CompilationTests.fs +++ b/tests/Brahma.FSharp.Tests/ExecutionTests/CompilationTests.fs @@ -26,24 +26,25 @@ module Helpers = Utils.filesAreEqual targetPath expectedPath -let simpleTests context = [ - let inline checkCode command outFile expected = checkCode context command outFile expected - testCase "Pointers to private values should be explicitly private" <| fun () -> - let command = - <@ - fun (k: Range1D) (a: int clarray) -> - let x (a: int) = - a + 1 +let simpleTests context = + [ let inline checkCode command outFile expected = + checkCode context command outFile expected - let mutable s = 1 - let mutable s = 2 - let s1 = x s + testCase "Pointers to private values should be explicitly private" + <| fun () -> + let command = + <@ + fun (k: Range1D) (a: int clarray) -> + let x (a: int) = a + 1 - a.[0] <- s1 - @> + let mutable s = 1 + let mutable s = 2 + let s1 = x s - checkCode command "GenericSpace.gen" "GenericSpace.cl" -] + a.[0] <- s1 + @> + + checkCode command "GenericSpace.gen" "GenericSpace.cl" ] type SimpleUnion = | SimpleOne @@ -68,102 +69,105 @@ let unionTests context = testCase name <| fun () -> checkCode context command outFile expectedFile let newUnionTestList = - [ - testGen - testCase - "Test 1: TranslateTest.A" - "Union.Compile.Test1.gen" - "Union.Compile.Test1.cl" - <@ fun (range: Range1D) -> - let x = A(5, 6.0) - let mutable y = 5 - y <- 7 @> - - testGen - testCase - "Test 2: TranslateTest.B" - "Union.Compile.Test2.gen" - "Union.Compile.Test2.cl" - <@ fun (range: Range1D) -> + [ testGen + testCase + "Test 1: TranslateTest.A" + "Union.Compile.Test1.gen" + "Union.Compile.Test1.cl" + <@ + fun (range: Range1D) -> + let x = A(5, 6.0) + let mutable y = 5 + y <- 7 + @> + + testGen + testCase + "Test 2: TranslateTest.B" + "Union.Compile.Test2.gen" + "Union.Compile.Test2.cl" + <@ + fun (range: Range1D) -> let x = B(5.0) let mutable y = 5 - y <- 7 @> - - testGen - testCase - "Test 3: TranslateTest.C" - "Union.Compile.Test3.gen" - "Union.Compile.Test3.cl" - <@ fun (range: Range1D) -> + y <- 7 + @> + + testGen + testCase + "Test 3: TranslateTest.C" + "Union.Compile.Test3.gen" + "Union.Compile.Test3.cl" + <@ + fun (range: Range1D) -> let x = C let mutable y = 5 - y <- 7 @> - - testGen - testCase - "Test 4: OuterUnion.Outer" - "Union.Compile.Test4.gen" - "Union.Compile.Test4.cl" - <@ fun (range: Range1D) -> + y <- 7 + @> + + testGen + testCase + "Test 4: OuterUnion.Outer" + "Union.Compile.Test4.gen" + "Union.Compile.Test4.cl" + <@ + fun (range: Range1D) -> let x = Inner SimpleOne let mutable y = 5 - y <- 7 @> - - testGen - testCase - "Test 5: OuterUnion.Inner" - "Union.Compile.Test5.gen" - "Union.Compile.Test5.cl" - <@ fun (range: Range1D) -> + y <- 7 + @> + + testGen + testCase + "Test 5: OuterUnion.Inner" + "Union.Compile.Test5.gen" + "Union.Compile.Test5.cl" + <@ + fun (range: Range1D) -> let x = Inner(SimpleTwo 29) let mutable y = 5 - y <- 7 @> - ] + y <- 7 + @> ] let testUnionCaseTestLists = - [ - testGen - testCase - "Test 1: simple pattern matching" - "Union.Compile.Test6.gen" - "Union.Compile.Test6.cl" - <@ fun (range: Range1D) -> - let t = Case1 - let mutable x = 5 - - match t with - | Case1 -> x <- 5 - | Case2 (_) -> x <- 6 - | Case3 (_) -> x <- 7 @> - ] + [ testGen + testCase + "Test 1: simple pattern matching" + "Union.Compile.Test6.gen" + "Union.Compile.Test6.cl" + <@ + fun (range: Range1D) -> + let t = Case1 + let mutable x = 5 + + match t with + | Case1 -> x <- 5 + | Case2(_) -> x <- 6 + | Case3(_) -> x <- 7 + @> ] let unionPropertyGetTestLists = - [ - testGen - testCase - "Test 1: simple pattern matching bindings" - "Union.Compile.Test7.gen" - "Union.Compile.Test7.cl" - <@ fun (range: Range1D) -> - let t = Case1 - let mutable m = 5 - - match t with - | Case1 -> m <- 5 - | Case2 (x) -> m <- x - | Case3 (y, z) -> m <- y + z @> - ] - - [ - testList "NewUnion" newUnionTestList - testList "TestUnionCase" testUnionCaseTestLists - testList "UnionPropertyGet" unionPropertyGetTestLists - ] + [ testGen + testCase + "Test 1: simple pattern matching bindings" + "Union.Compile.Test7.gen" + "Union.Compile.Test7.cl" + <@ + fun (range: Range1D) -> + let t = Case1 + let mutable m = 5 + + match t with + | Case1 -> m <- 5 + | Case2(x) -> m <- x + | Case3(y, z) -> m <- y + z + @> ] + + [ testList "NewUnion" newUnionTestList + testList "TestUnionCase" testUnionCaseTestLists + testList "UnionPropertyGet" unionPropertyGetTestLists ] let tests context = - [ - testList "Simple tests" << simpleTests - testList "Union Compile tests" << unionTests - ] + [ testList "Simple tests" << simpleTests + testList "Union Compile tests" << unionTests ] |> List.map (fun testFixture -> testFixture context) - diff --git a/tests/Brahma.FSharp.Tests/ExecutionTests/CompositeTypesTests.fs b/tests/Brahma.FSharp.Tests/ExecutionTests/CompositeTypesTests.fs index e5cfa524..8922c419 100644 --- a/tests/Brahma.FSharp.Tests/ExecutionTests/CompositeTypesTests.fs +++ b/tests/Brahma.FSharp.Tests/ExecutionTests/CompositeTypesTests.fs @@ -10,7 +10,7 @@ open Brahma.FSharp [] module Helpers = - let check<'a when 'a : equality> context (data: 'a[]) (command: int -> Expr ClArray<'a> -> unit>) = + let check<'a when 'a: equality> context (data: 'a[]) (command: int -> Expr ClArray<'a> -> unit>) = let length = data.Length let expected = data @@ -18,40 +18,27 @@ module Helpers = let actual = opencl { use! buffer = ClArray.toDevice data - do! runCommand (command length) <| fun it -> - it - <| Range1D.CreateValid(data.Length, 256) - <| buffer + + do! + runCommand (command length) + <| fun it -> it <| Range1D.CreateValid(data.Length, 256) <| buffer return! ClArray.toHost buffer } |> ClTask.runSync context - "Arrays should be equal" - |> Expect.sequenceEqual actual expected + "Arrays should be equal" |> Expect.sequenceEqual actual expected let message typeName = $"Simple test on `%s{typeName}`" [] -type RecordOfIntInt64 = - { - X: int - Y: int64 - } +type RecordOfIntInt64 = { X: int; Y: int64 } [] -type RecordOfBoolBool = - { - X: bool - Y: bool - } +type RecordOfBoolBool = { X: bool; Y: bool } [] -type GenericRecord<'a, 'b> = - { - mutable X: 'a - mutable Y: 'b - } +type GenericRecord<'a, 'b> = { mutable X: 'a; mutable Y: 'b } [] type StructOfIntInt64 = @@ -65,89 +52,126 @@ type GenericStruct<'a, 'b> = val mutable Y: 'b new(x, y) = { X = x; Y = y } -let tupleTestCases context = [ - let inline check data command = check context data command - - let inline command length = - <@ - fun (gid: int) (buffer: clarray) -> - if gid < length then - let struct(a, b) = buffer.[gid] - buffer.[gid] <- struct(a, b) - @> - - testProperty (message "struct(int * int)") <| fun (data: struct(int * int)[]) -> - if data.Length <> 0 then check data (fun length -> <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @>) - - testProperty (message "struct(int * int64)") <| fun (data: struct(int * int64)[]) -> - if data.Length <> 0 then check data (fun length -> <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @>) - - testProperty (message "struct(bool * bool") <| fun (data: struct(bool * bool)[]) -> - if data.Length <> 0 then check data (fun length -> <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @>) - - testProperty (message "struct((int * int) * (int * int))") <| fun (data: struct((int * int) * (int * int))[]) -> - if data.Length <> 0 then check data (fun length -> <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @>) - - testProperty (message "struct((int * int64) * (bool * bool))") <| fun (data: struct((int * int64) * (bool * bool))[]) -> - if data.Length <> 0 then check data (fun length -> <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @>) - - testProperty (message "struct(RecordOfIntInt64 * RecordOfBoolBool)") <| fun (data: struct(RecordOfIntInt64 * RecordOfBoolBool)[]) -> - if data.Length <> 0 then check data (fun length -> <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @>) - - testProperty (message "struct(GenericRecord * GenericRecord)") <| fun (data: struct(GenericRecord * GenericRecord)[]) -> - if data.Length <> 0 then check data (fun length -> <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @>) - - testProperty (message "struct(int * int64 * bool)") <| fun (data: struct(int * int64 * bool)[]) -> - if data.Length <> 0 then - check data <| fun length -> - <@ fun (range: Range1D) (buffer: ClArray<_>) -> - let gid = range.GlobalID0 - if gid < length then - let struct(a1, a2, a3) = buffer.[gid] - buffer.[gid] <- struct(a1, a2, a3) - @> - - testProperty "Simple test on big tuple (of size 10)" <| fun (data: struct(int * int * int * int * int * int * int * int * int * int)[]) -> - if data.Length <> 0 then - check data <| fun length -> - <@ fun (range: Range1D) (buffer: ClArray<_>) -> - let gid = range.GlobalID0 - if gid < length then - let struct(a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) = buffer.[gid] - buffer.[gid] <- struct(a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) - @> - - testProperty "Test on inner tuples deconstruction" <| fun (data: struct((int * int) * (int * int))[]) -> - if data.Length <> 0 then - check data <| fun length -> - <@ fun (range: Range1D) (buffer: ClArray<_>) -> - let gid = range.GlobalID0 - if gid < length then - let struct((a, b), (c, d)) = buffer.[gid] - buffer.[gid] <- struct((a, b), (c, d)) - @> -] - -let recordTestCases context = [ - let inline check data command = check context data command - - let inline command length = - <@ - fun (gid: int) (buffer: ClArray>) -> - if gid < length then - let { X = x; Y = y } = buffer.[gid] - let mutable innerStruct = { X = x; Y = y } - innerStruct.X <- x - innerStruct.Y <- y - buffer.[gid] <- { X = innerStruct.X; Y = innerStruct.Y } - @> - - testProperty (message "GenericRecord") <| fun (data: GenericRecord[]) -> - if data.Length <> 0 then check data (fun length -> <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @>) - - testProperty (message "GenericRecord<(int * int64), (bool * bool)>") <| fun (data: GenericRecord<(int * int64), (bool * bool)>[]) -> - if data.Length <> 0 then check data (fun length -> <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @>) -] +let tupleTestCases context = + [ let inline check data command = check context data command + + let inline command length = + <@ + fun (gid: int) (buffer: clarray) -> + if gid < length then + let struct (a, b) = buffer.[gid] + buffer.[gid] <- struct (a, b) + @> + + testProperty (message "struct(int * int)") + <| fun (data: struct (int * int)[]) -> + if data.Length <> 0 then + check data (fun length -> + <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @>) + + testProperty (message "struct(int * int64)") + <| fun (data: struct (int * int64)[]) -> + if data.Length <> 0 then + check data (fun length -> + <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @>) + + testProperty (message "struct(bool * bool") + <| fun (data: struct (bool * bool)[]) -> + if data.Length <> 0 then + check data (fun length -> + <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @>) + + testProperty (message "struct((int * int) * (int * int))") + <| fun (data: struct ((int * int) * (int * int))[]) -> + if data.Length <> 0 then + check data (fun length -> + <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @>) + + testProperty (message "struct((int * int64) * (bool * bool))") + <| fun (data: struct ((int * int64) * (bool * bool))[]) -> + if data.Length <> 0 then + check data (fun length -> + <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @>) + + testProperty (message "struct(RecordOfIntInt64 * RecordOfBoolBool)") + <| fun (data: struct (RecordOfIntInt64 * RecordOfBoolBool)[]) -> + if data.Length <> 0 then + check data (fun length -> + <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @>) + + testProperty (message "struct(GenericRecord * GenericRecord)") + <| fun (data: struct (GenericRecord * GenericRecord)[]) -> + if data.Length <> 0 then + check data (fun length -> + <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @>) + + testProperty (message "struct(int * int64 * bool)") + <| fun (data: struct (int * int64 * bool)[]) -> + if data.Length <> 0 then + check data + <| fun length -> + <@ + fun (range: Range1D) (buffer: ClArray<_>) -> + let gid = range.GlobalID0 + + if gid < length then + let struct (a1, a2, a3) = buffer.[gid] + buffer.[gid] <- struct (a1, a2, a3) + @> + + testProperty "Simple test on big tuple (of size 10)" + <| fun (data: struct (int * int * int * int * int * int * int * int * int * int)[]) -> + if data.Length <> 0 then + check data + <| fun length -> + <@ + fun (range: Range1D) (buffer: ClArray<_>) -> + let gid = range.GlobalID0 + + if gid < length then + let struct (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) = buffer.[gid] + buffer.[gid] <- struct (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) + @> + + testProperty "Test on inner tuples deconstruction" + <| fun (data: struct ((int * int) * (int * int))[]) -> + if data.Length <> 0 then + check data + <| fun length -> + <@ + fun (range: Range1D) (buffer: ClArray<_>) -> + let gid = range.GlobalID0 + + if gid < length then + let struct ((a, b), (c, d)) = buffer.[gid] + buffer.[gid] <- struct ((a, b), (c, d)) + @> ] + +let recordTestCases context = + [ let inline check data command = check context data command + + let inline command length = + <@ + fun (gid: int) (buffer: ClArray>) -> + if gid < length then + let { X = x; Y = y } = buffer.[gid] + let mutable innerStruct = { X = x; Y = y } + innerStruct.X <- x + innerStruct.Y <- y + buffer.[gid] <- { X = innerStruct.X; Y = innerStruct.Y } + @> + + testProperty (message "GenericRecord") + <| fun (data: GenericRecord[]) -> + if data.Length <> 0 then + check data (fun length -> + <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @>) + + testProperty (message "GenericRecord<(int * int64), (bool * bool)>") + <| fun (data: GenericRecord<(int * int64), (bool * bool)>[]) -> + if data.Length <> 0 then + check data (fun length -> + <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @>) ] let genGenericStruct<'a, 'b> = gen { @@ -160,81 +184,105 @@ let genGenericStruct<'a, 'b> = type GenericStructGenerator = static member GenericStruct() = Arb.fromGen genGenericStruct -let structTests context = [ - let inline check data command = check context data command - let inline checkResult cmd input expected = RuntimeTests.Helpers.checkResult context cmd input expected - - testCase "Smoke test" <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - if range.GlobalID0 = 0 then - let b = buf.[0] - buf.[0] <- buf.[1] - buf.[1] <- b - @> - - checkResult command [|StructOfIntInt64(1, 2L); StructOfIntInt64(3, 4L)|] - [|StructOfIntInt64(3, 4L); StructOfIntInt64(1, 2L)|] - - testCase "Struct constructor test" <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - buf.[0] <- StructOfIntInt64(5, 6L) - @> - - checkResult command [|StructOfIntInt64(1, 2L); StructOfIntInt64(3, 4L)|] - [|StructOfIntInt64(5, 6L); StructOfIntInt64(3, 4L)|] - - testCase "Struct prop set" <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - let mutable y = buf.[0] - y.X <- 5 - buf.[0] <- y - @> - - checkResult command [|StructOfIntInt64(1, 2L)|] [|StructOfIntInt64(5, 2L)|] - - testCase "Struct prop get" <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - if range.GlobalID0 = 0 then - let mutable y = buf.[0] - y.X <- y.X + 3 - buf.[0] <- y - @> - - checkResult command [|StructOfIntInt64(1, 2L); StructOfIntInt64(3, 4L)|] - [|StructOfIntInt64(4, 2L); StructOfIntInt64(3, 4L)|] - - let inline command length = - <@ - fun (gid: int) (buffer: ClArray>) -> - if gid < length then - let tmp = buffer.[gid] - let x = tmp.X - let y = tmp.Y - let mutable innerStruct = GenericStruct(x, y) - innerStruct.X <- x - innerStruct.Y <- y - buffer.[gid] <- GenericStruct(innerStruct.X, innerStruct.Y) - @> - - let config = { FsCheckConfig.defaultConfig with arbitrary = [typeof] } - - testPropertyWithConfig config (message "GenericStruct") <| fun (data: GenericStruct[]) -> - if data.Length <> 0 then check data (fun length -> <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @>) - - testPropertyWithConfig config (message "GenericStruct<(int * int64), (bool * bool)>") <| fun (data: GenericStruct<(int * int64), (bool * bool)>[]) -> - if data.Length <> 0 then check data (fun length -> <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @>) - - testPropertyWithConfig config (message "GenericStruct") <| fun (data: GenericStruct[]) -> - if data.Length <> 0 then check data (fun length -> <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @>) -] +let structTests context = + [ let inline check data command = check context data command + + let inline checkResult cmd input expected = + RuntimeTests.Helpers.checkResult context cmd input expected + + testCase "Smoke test" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + if range.GlobalID0 = 0 then + let b = buf.[0] + buf.[0] <- buf.[1] + buf.[1] <- b + @> + + checkResult + command + [| StructOfIntInt64(1, 2L) + StructOfIntInt64(3, 4L) |] + [| StructOfIntInt64(3, 4L) + StructOfIntInt64(1, 2L) |] + + testCase "Struct constructor test" + <| fun _ -> + let command = + <@ fun (range: Range1D) (buf: ClArray) -> buf.[0] <- StructOfIntInt64(5, 6L) @> + + checkResult + command + [| StructOfIntInt64(1, 2L) + StructOfIntInt64(3, 4L) |] + [| StructOfIntInt64(5, 6L) + StructOfIntInt64(3, 4L) |] + + testCase "Struct prop set" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + let mutable y = buf.[0] + y.X <- 5 + buf.[0] <- y + @> + + checkResult command [| StructOfIntInt64(1, 2L) |] [| StructOfIntInt64(5, 2L) |] + + testCase "Struct prop get" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + if range.GlobalID0 = 0 then + let mutable y = buf.[0] + y.X <- y.X + 3 + buf.[0] <- y + @> + + checkResult + command + [| StructOfIntInt64(1, 2L) + StructOfIntInt64(3, 4L) |] + [| StructOfIntInt64(4, 2L) + StructOfIntInt64(3, 4L) |] + + let inline command length = + <@ + fun (gid: int) (buffer: ClArray>) -> + if gid < length then + let tmp = buffer.[gid] + let x = tmp.X + let y = tmp.Y + let mutable innerStruct = GenericStruct(x, y) + innerStruct.X <- x + innerStruct.Y <- y + buffer.[gid] <- GenericStruct(innerStruct.X, innerStruct.Y) + @> + + let config = + { FsCheckConfig.defaultConfig with arbitrary = [ typeof ] } + + testPropertyWithConfig config (message "GenericStruct") + <| fun (data: GenericStruct[]) -> + if data.Length <> 0 then + check data (fun length -> + <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @>) + + testPropertyWithConfig config (message "GenericStruct<(int * int64), (bool * bool)>") + <| fun (data: GenericStruct<(int * int64), (bool * bool)>[]) -> + if data.Length <> 0 then + check data (fun length -> + <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @>) + + testPropertyWithConfig config (message "GenericStruct") + <| fun (data: GenericStruct[]) -> + if data.Length <> 0 then + check data (fun length -> + <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @>) ] type SimpleDU = | A @@ -251,113 +299,152 @@ type EnumDU = | B | C -let unionTests context = [ - let inline check data command = check context data command - - testProperty (message "Option>") <| fun (data: Option>[]) -> - if data.Length <> 0 then - check data <| fun length -> - <@ fun (range: Range1D) (buffer: ClArray<_>) -> - let gid = range.GlobalID0 - if gid < length then - buffer.[gid] <- - match buffer.[gid] with - | Some { X = x; Y = y } -> Some { X = x; Y = y } - | None -> None - @> - - testProperty (message "Option>") <| fun (data: Option>[]) -> - if data.Length <> 0 then - check data <| fun length -> - <@ fun (range: Range1D) (buffer: ClArray<_>) -> - let gid = range.GlobalID0 - if gid < length then - buffer.[gid] <- - match buffer.[gid] with - | Some a -> - match a with - | Some { X = x; Y = y } -> Some (Some { X = x; Y = y }) - | None -> Some None - | None -> None - - // TODO didnt work -// | Some (Some { X = x; Y = y }) -> Some (Some { X = x; Y = y }) -// | Some None -> Some None -// | None -> None - @> - - testProperty (message "SimpleDU") <| fun (data: SimpleDU[]) -> - if data.Length <> 0 then - check data <| fun length -> - <@ fun (range: Range1D) (buffer: ClArray<_>) -> - let gid = range.GlobalID0 - if gid < length then - buffer.[gid] <- - match buffer.[gid] with - | SimpleDU.A -> SimpleDU.A - | SimpleDU.B x -> SimpleDU.B x - | SimpleDU.C (x, y) -> SimpleDU.C (x, y) - @> - - ptestProperty (message "GenericDU>") <| fun (data: GenericDU>[]) -> - // TODO test case -// let data = -// [| -// GenericDU.C { -// X = true -// Y = Some true -// } -// |] - - if data.Length <> 0 then - check data <| fun length -> - <@ fun (range: Range1D) (buffer: ClArray<_>) -> - let gid = range.GlobalID0 - if gid < length then - buffer.[gid] <- - match buffer.[gid] with - | GenericDU.A -> GenericDU.A - | GenericDU.B x -> GenericDU.B x - | GenericDU.C { X = x; Y = y } -> - match y with - | Some b -> GenericDU.C { X = x; Y = Some b } - | None -> GenericDU.C { X = x; Y = None } - @> - - testProperty (message "GenericRecord, Option>") <| fun (data: GenericRecord, Option>[]) -> - if data.Length <> 0 then - check data <| fun length -> - <@ fun (range: Range1D) (buffer: ClArray<_>) -> - let gid = range.GlobalID0 - if gid < length then - buffer.[gid] <- - match buffer.[gid] with - | { X = Some x; Y = Some y } -> { X = Some x; Y = Some y } - | { X = Some x; Y = None } -> { X = Some x; Y = None } - | { X = None; Y = Some y } -> { X = None; Y = Some y } - | { X = None; Y = None } -> { X = None; Y = None } - - @> - - testProperty (message "EnumDU") <| fun (data: EnumDU[]) -> - if data.Length <> 0 then - check data <| fun length -> - <@ fun (range: Range1D) (buffer: ClArray<_>) -> - let gid = range.GlobalID0 - if gid < length then - buffer.[gid] <- - match buffer.[gid] with - | EnumDU.A -> EnumDU.A - | EnumDU.B -> EnumDU.B - | EnumDU.C -> EnumDU.C - @> -] +let unionTests context = + [ let inline check data command = check context data command + + testProperty (message "Option>") + <| fun (data: Option>[]) -> + if data.Length <> 0 then + check data + <| fun length -> + <@ + fun (range: Range1D) (buffer: ClArray<_>) -> + let gid = range.GlobalID0 + + if gid < length then + buffer.[gid] <- + match buffer.[gid] with + | Some { X = x; Y = y } -> Some { X = x; Y = y } + | None -> None + @> + + testProperty (message "Option>") + <| fun (data: Option>[]) -> + if data.Length <> 0 then + check data + <| fun length -> + <@ + fun (range: Range1D) (buffer: ClArray<_>) -> + let gid = range.GlobalID0 + + if gid < length then + buffer.[gid] <- + match buffer.[gid] with + | Some a -> + match a with + | Some { X = x; Y = y } -> Some(Some { X = x; Y = y }) + | None -> Some None + | None -> None + + // TODO didnt work + // | Some (Some { X = x; Y = y }) -> Some (Some { X = x; Y = y }) + // | Some None -> Some None + // | None -> None + + + + + + + + + + @> + + testProperty (message "SimpleDU") + <| fun (data: SimpleDU[]) -> + if data.Length <> 0 then + check data + <| fun length -> + <@ + fun (range: Range1D) (buffer: ClArray<_>) -> + let gid = range.GlobalID0 + + if gid < length then + buffer.[gid] <- + match buffer.[gid] with + | SimpleDU.A -> SimpleDU.A + | SimpleDU.B x -> SimpleDU.B x + | SimpleDU.C(x, y) -> SimpleDU.C(x, y) + @> + + ptestProperty (message "GenericDU>") + <| fun (data: GenericDU>[]) -> + // TODO test case + // let data = + // [| + // GenericDU.C { + // X = true + // Y = Some true + // } + // |] + + if data.Length <> 0 then + check data + <| fun length -> + <@ + fun (range: Range1D) (buffer: ClArray<_>) -> + let gid = range.GlobalID0 + + if gid < length then + buffer.[gid] <- + match buffer.[gid] with + | GenericDU.A -> GenericDU.A + | GenericDU.B x -> GenericDU.B x + | GenericDU.C { X = x; Y = y } -> + match y with + | Some b -> GenericDU.C { X = x; Y = Some b } + | None -> GenericDU.C { X = x; Y = None } + @> + + testProperty (message "GenericRecord, Option>") + <| fun (data: GenericRecord, Option>[]) -> + if data.Length <> 0 then + check data + <| fun length -> + <@ + fun (range: Range1D) (buffer: ClArray<_>) -> + let gid = range.GlobalID0 + + if gid < length then + buffer.[gid] <- + match buffer.[gid] with + | { X = Some x; Y = Some y } -> { X = Some x; Y = Some y } + | { X = Some x; Y = None } -> { X = Some x; Y = None } + | { X = None; Y = Some y } -> { X = None; Y = Some y } + | { X = None; Y = None } -> { X = None; Y = None } + + + + + + + + + + + @> + + testProperty (message "EnumDU") + <| fun (data: EnumDU[]) -> + if data.Length <> 0 then + check data + <| fun length -> + <@ + fun (range: Range1D) (buffer: ClArray<_>) -> + let gid = range.GlobalID0 + + if gid < length then + buffer.[gid] <- + match buffer.[gid] with + | EnumDU.A -> EnumDU.A + | EnumDU.B -> EnumDU.B + | EnumDU.C -> EnumDU.C + @> ] let tests context = - [ - testList "Tuple tests" << tupleTestCases - testList "Record tests" << recordTestCases - testList "Struct tests" << structTests - testList "Union tests" << unionTests - ] + [ testList "Tuple tests" << tupleTestCases + testList "Record tests" << recordTestCases + testList "Struct tests" << structTests + testList "Union tests" << unionTests ] |> List.map (fun testFixture -> testFixture context) diff --git a/tests/Brahma.FSharp.Tests/ExecutionTests/ExecutionTests.fs b/tests/Brahma.FSharp.Tests/ExecutionTests/ExecutionTests.fs index c3e81cbd..900d9901 100644 --- a/tests/Brahma.FSharp.Tests/ExecutionTests/ExecutionTests.fs +++ b/tests/Brahma.FSharp.Tests/ExecutionTests/ExecutionTests.fs @@ -8,18 +8,20 @@ open Brahma.FSharp.OpenCL.Shared // TODO make it lazy? let allContexts = ClDevice.GetAvailableDevices() - |> Seq.map - (fun device -> - let translator = FSQuotationToOpenCLTranslator(device) - let clContext = ClContext(device, translator) - RuntimeContext(clContext) - ) -let tests = [ - for context in allContexts do yield! [ - testList $"System tests with running kernels on %A{context}" <| RuntimeTests.tests context - testList $"Compilation tests on %A{context}" <| CompilationTests.tests context - testList $"Tests on 'opencl' computation exression on %A{context}" <| WorkflowBuilderTests.tests context - ptestList $"Tests on atomic functions on %A{context}" <| AtomicTests.tests context - testList $"Tests on composite types on %A{context}" <| CompositeTypesTests.tests context - ] -] + |> Seq.map (fun device -> + let translator = FSQuotationToOpenCLTranslator(device) + let clContext = ClContext(device, translator) + RuntimeContext(clContext)) + +let tests = + [ for context in allContexts do + yield! + [ testList $"System tests with running kernels on %A{context}" + <| RuntimeTests.tests context + testList $"Compilation tests on %A{context}" <| CompilationTests.tests context + testList $"Tests on 'opencl' computation exression on %A{context}" + <| WorkflowBuilderTests.tests context + ptestList $"Tests on atomic functions on %A{context}" + <| AtomicTests.tests context + testList $"Tests on composite types on %A{context}" + <| CompositeTypesTests.tests context ] ] diff --git a/tests/Brahma.FSharp.Tests/ExecutionTests/RuntimeTests.fs b/tests/Brahma.FSharp.Tests/ExecutionTests/RuntimeTests.fs index b27511dd..3c0152e8 100644 --- a/tests/Brahma.FSharp.Tests/ExecutionTests/RuntimeTests.fs +++ b/tests/Brahma.FSharp.Tests/ExecutionTests/RuntimeTests.fs @@ -17,8 +17,7 @@ module Helpers = let actual = opencl { use! inBuf = ClArray.toDevice inArr - do! runCommand command <| fun x -> - x default1D inBuf + do! runCommand command <| fun x -> x default1D inBuf return! ClArray.toHost inBuf } @@ -28,239 +27,353 @@ module Helpers = let logger = Log.create "FullTests" -let smokeTestsOnPrimitiveTypes context = [ - let inline checkResult cmd input expected = checkResult context cmd input expected - - testCase "Array item set" <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - buf.[0] <- 1 - @> - - checkResult command intInArr [|1; 1; 2; 3|] - - testCase "Array item set. Long" <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray<_>) -> - buf.[0] <- 1L - @> - - checkResult command [|0L; 1L; 2L; 3L|] [|1L; 1L; 2L; 3L|] - - testCase "Array item set. ULong" <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - buf.[0] <- 1UL - @> - - checkResult command [|0UL; 1UL; 2UL; 3UL|] [|1UL; 1UL; 2UL; 3UL|] - - testCase "Array item set. Sbyte" <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - buf.[0] <- 1y - @> - - checkResult command [|0y; 1y; 2y; 3y|] [|1y; 1y; 2y; 3y|] - - testCase "Array item set. Sequential operations" <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - buf.[0] <- 2 - buf.[1] <- 4 - @> - - checkResult command intInArr [|2; 4; 2; 3|] - - testCase "Byte type support with overflow" <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - if range.GlobalID0 = 0 then - buf.[0] <- buf.[0] + 1uy - buf.[1] <- buf.[1] + 1uy - buf.[2] <- buf.[2] + 1uy - @> - - checkResult command [|0uy; 255uy; 254uy|] [|1uy; 0uy; 255uy|] -] - -let typeCastingTests context = [ - let inline checkResult cmd input expected = checkResult context cmd input expected - - testCase "uint64 -> int64" <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - buf.[0] <- int64 1UL - @> - - checkResult command [|0L; 1L|] [|1L; 1L|] - - testCase "int64 -> uint64" <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - buf.[0] <- uint64 1L - @> - - checkResult command [|0UL; 1UL|] [|1UL; 1UL|] - - testCase "byte -> float -> byte" <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - if range.GlobalID0 = 0 then - buf.[0] <- byte (float buf.[0]) - buf.[1] <- byte (float buf.[1]) - buf.[2] <- byte (float buf.[2]) - @> - - checkResult command [|0uy; 255uy; 254uy|] [|0uy; 255uy; 254uy|] - - // test fail on Intel platform: - // Actual: [1uy, 255uy, 255uy] - ptestCase "Byte and float 2" <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - if range.GlobalID0 = 0 then - buf.[0] <- byte ((float buf.[0]) + 1.0) - buf.[1] <- byte ((float buf.[1]) + 1.0) - buf.[2] <- byte ((float buf.[2]) + 1.0) - @> - - checkResult command [|0uy; 255uy; 254uy|] [|1uy; 0uy; 255uy|] - - // test failed on Intel platform: - // Actual : [1uy, 1uy, 1uy] - ptestCase "Byte and float in condition" <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - if range.GlobalID0 = 0 then - let x = if true then buf.[0] + 1uy else buf.[0] + 1uy - buf.[0] <- x - let y = if true then buf.[1] + 1uy else buf.[1] + 1uy - buf.[1] <- y - let z = if true then buf.[2] + 1uy else buf.[2] + 1uy - buf.[2] <- z - @> - - checkResult command [|0uy; 255uy; 254uy|] [|1uy; 0uy; 255uy|] - - // test failed on Intel platform due to exception - ptestCase "Byte and float in condition 2" <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - if range.GlobalID0 = 0 - then - let x = - if true - then - let g = 1uy - buf.[0] + g - else buf.[0] + 1uy - buf.[0] <- x - let y = - if true - then - let g = 1uy - buf.[1] + g - else buf.[1] + 1uy - buf.[1] <- y - let z = - if true - then - let g = 1uy - buf.[2] + g - else buf.[2] + 1uy - buf.[2] <- z - @> - - checkResult command [|0uy; 255uy; 254uy|] [|1uy; 0uy; 255uy|] -] - -let bindingTests context = [ - let inline checkResult cmd input expected = checkResult context cmd input expected - - testCase "Bindings. Simple" <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - let x = 1 - buf.[0] <- x - @> - - checkResult command intInArr [|1; 1; 2; 3|] - - testCase "Bindings. Sequential bindings" <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - let x = 1 - let y = x + 1 - buf.[0] <- y - @> - - checkResult command intInArr [|2; 1; 2; 3|] - - testCase "Bindings. Binding in IF" <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - if 2 = 0 then - let x = 1 - buf.[0] <- x - else - let i = 2 - buf.[0] <- i - @> - - checkResult command intInArr [|2; 1; 2; 3|] - - testCase "Bindings. Binding in FOR" <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - for i in 0..3 do - let x = i * i - buf.[i] <- x - @> - - checkResult command intInArr [|0; 1; 4; 9|] - - testCase "Bindings. Binding in WHILE" <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - while buf.[0] < 5 do - let x = buf.[0] + 1 - buf.[0] <- x * x - @> - - checkResult command intInArr [|25; 1; 2; 3|] -] +let smokeTestsOnPrimitiveTypes context = + [ let inline checkResult cmd input expected = checkResult context cmd input expected + + testCase "Array item set" + <| fun _ -> + let command = <@ fun (range: Range1D) (buf: ClArray) -> buf.[0] <- 1 @> + + checkResult + command + intInArr + [| 1 + 1 + 2 + 3 |] + + testCase "Array item set. Long" + <| fun _ -> + let command = <@ fun (range: Range1D) (buf: ClArray<_>) -> buf.[0] <- 1L @> + + checkResult + command + [| 0L + 1L + 2L + 3L |] + [| 1L + 1L + 2L + 3L |] + + testCase "Array item set. ULong" + <| fun _ -> + let command = <@ fun (range: Range1D) (buf: ClArray) -> buf.[0] <- 1UL @> + + checkResult + command + [| 0UL + 1UL + 2UL + 3UL |] + [| 1UL + 1UL + 2UL + 3UL |] + + testCase "Array item set. Sbyte" + <| fun _ -> + let command = <@ fun (range: Range1D) (buf: ClArray) -> buf.[0] <- 1y @> + + checkResult + command + [| 0y + 1y + 2y + 3y |] + [| 1y + 1y + 2y + 3y |] + + testCase "Array item set. Sequential operations" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + buf.[0] <- 2 + buf.[1] <- 4 + @> + + checkResult + command + intInArr + [| 2 + 4 + 2 + 3 |] + + testCase "Byte type support with overflow" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + if range.GlobalID0 = 0 then + buf.[0] <- buf.[0] + 1uy + buf.[1] <- buf.[1] + 1uy + buf.[2] <- buf.[2] + 1uy + @> + + checkResult + command + [| 0uy + 255uy + 254uy |] + [| 1uy + 0uy + 255uy |] ] + +let typeCastingTests context = + [ let inline checkResult cmd input expected = checkResult context cmd input expected + + testCase "uint64 -> int64" + <| fun _ -> + let command = + <@ fun (range: Range1D) (buf: ClArray) -> buf.[0] <- int64 1UL @> + + checkResult + command + [| 0L + 1L |] + [| 1L + 1L |] + + testCase "int64 -> uint64" + <| fun _ -> + let command = + <@ fun (range: Range1D) (buf: ClArray) -> buf.[0] <- uint64 1L @> + + checkResult + command + [| 0UL + 1UL |] + [| 1UL + 1UL |] + + testCase "byte -> float -> byte" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + if range.GlobalID0 = 0 then + buf.[0] <- byte (float buf.[0]) + buf.[1] <- byte (float buf.[1]) + buf.[2] <- byte (float buf.[2]) + @> + + checkResult + command + [| 0uy + 255uy + 254uy |] + [| 0uy + 255uy + 254uy |] + + // test fail on Intel platform: + // Actual: [1uy, 255uy, 255uy] + ptestCase "Byte and float 2" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + if range.GlobalID0 = 0 then + buf.[0] <- byte ((float buf.[0]) + 1.0) + buf.[1] <- byte ((float buf.[1]) + 1.0) + buf.[2] <- byte ((float buf.[2]) + 1.0) + @> + + checkResult + command + [| 0uy + 255uy + 254uy |] + [| 1uy + 0uy + 255uy |] + + // test failed on Intel platform: + // Actual : [1uy, 1uy, 1uy] + ptestCase "Byte and float in condition" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + if range.GlobalID0 = 0 then + let x = if true then buf.[0] + 1uy else buf.[0] + 1uy + buf.[0] <- x + let y = if true then buf.[1] + 1uy else buf.[1] + 1uy + buf.[1] <- y + let z = if true then buf.[2] + 1uy else buf.[2] + 1uy + buf.[2] <- z + @> + + checkResult + command + [| 0uy + 255uy + 254uy |] + [| 1uy + 0uy + 255uy |] + + // test failed on Intel platform due to exception + ptestCase "Byte and float in condition 2" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + if range.GlobalID0 = 0 then + let x = + if true then + let g = 1uy + buf.[0] + g + else + buf.[0] + 1uy + + buf.[0] <- x + + let y = + if true then + let g = 1uy + buf.[1] + g + else + buf.[1] + 1uy + + buf.[1] <- y + + let z = + if true then + let g = 1uy + buf.[2] + g + else + buf.[2] + 1uy + + buf.[2] <- z + @> + + checkResult + command + [| 0uy + 255uy + 254uy |] + [| 1uy + 0uy + 255uy |] ] + +let bindingTests context = + [ let inline checkResult cmd input expected = checkResult context cmd input expected + + testCase "Bindings. Simple" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + let x = 1 + buf.[0] <- x + @> + + checkResult + command + intInArr + [| 1 + 1 + 2 + 3 |] + + testCase "Bindings. Sequential bindings" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + let x = 1 + let y = x + 1 + buf.[0] <- y + @> + + checkResult + command + intInArr + [| 2 + 1 + 2 + 3 |] + + testCase "Bindings. Binding in IF" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + if 2 = 0 then + let x = 1 + buf.[0] <- x + else + let i = 2 + buf.[0] <- i + @> + + checkResult + command + intInArr + [| 2 + 1 + 2 + 3 |] + + testCase "Bindings. Binding in FOR" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + for i in 0..3 do + let x = i * i + buf.[i] <- x + @> + + checkResult + command + intInArr + [| 0 + 1 + 4 + 9 |] + + testCase "Bindings. Binding in WHILE" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + while buf.[0] < 5 do + let x = buf.[0] + 1 + buf.[0] <- x * x + @> + + checkResult + command + intInArr + [| 25 + 1 + 2 + 3 |] ] let operatorsAndMathFunctionsTests context = let inline checkResult cmd input expected = checkResult context cmd input expected - let binaryOpTestGen testCase name + let binaryOpTestGen + testCase + name (binop: Expr<'a -> 'a -> 'a>) (xs: array<'a>) (ys: array<'a>) - (expected: array<'a>) = + (expected: array<'a>) + = - testCase name <| fun () -> + testCase name + <| fun () -> let command = <@ - fun (range: Range1D) (xs: ClArray<'a>) (ys: ClArray<'a>) (zs: ClArray<'a>) -> + fun (range: Range1D) (xs: ClArray<'a>) (ys: ClArray<'a>) (zs: ClArray<'a>) -> let i = range.GlobalID0 zs.[i] <- (%binop) xs.[i] ys.[i] @> @@ -274,8 +387,7 @@ let operatorsAndMathFunctionsTests context = use! inBufYs = ClArray.toDevice ys use! outBuf = ClArray.toDevice zs - do! runCommand command <| fun x -> - x range inBufXs inBufYs outBuf + do! runCommand command <| fun x -> x range inBufXs inBufYs outBuf return! ClArray.toHost outBuf } @@ -283,15 +395,13 @@ let operatorsAndMathFunctionsTests context = Expect.sequenceEqual actual expected ":(" - let unaryOpTestGen testCase name - (unop: Expr<'a -> 'a>) - (xs: array<'a>) - (expected: array<'a>) = + let unaryOpTestGen testCase name (unop: Expr<'a -> 'a>) (xs: array<'a>) (expected: array<'a>) = - testCase name <| fun () -> + testCase name + <| fun () -> let command = <@ - fun (range: Range1D) (xs: ClArray<'a>) (zs: ClArray<'a>) -> + fun (range: Range1D) (xs: ClArray<'a>) (zs: ClArray<'a>) -> let i = range.GlobalID0 zs.[i] <- (%unop) xs.[i] @> @@ -304,8 +414,7 @@ let operatorsAndMathFunctionsTests context = use! inBufXs = ClArray.toDevice xs use! outBuf = ClArray.toDevice zs - do! runCommand command <| fun x -> - x range inBufXs outBuf + do! runCommand command <| fun x -> x range inBufXs outBuf return! ClArray.toHost outBuf } @@ -313,1291 +422,1703 @@ let operatorsAndMathFunctionsTests context = Expect.sequenceEqual actual expected ":(" - [ - binaryOpTestGen testCase "Boolean OR" <@ (||) @> - [|true; false; false; true|] - [|false; true; false; true|] - [|true; true; false; true|] - - binaryOpTestGen testCase "Boolean AND" <@ (&&) @> - [|true; false; false; true|] - [|false; true; false; true|] - [|false; false; false; true|] - - binaryOpTestGen testCase "Bitwise OR on int" <@ (|||) @> - [|1; 0; 0; 1|] - [|0; 1; 0; 1|] - [|1; 1; 0; 1|] - - binaryOpTestGen testCase "Bitwise AND on int" <@ (&&&) @> - [|1; 0; 0; 1|] - [|0; 1; 0; 1|] - [|0; 0; 0; 1|] - - binaryOpTestGen testCase "Bitwise XOR on int" <@ (^^^) @> - [|1; 0; 0; 1|] - [|0; 1; 0; 1|] - [|1; 1; 0; 0|] - - binaryOpTestGen testCase "Arithmetic PLUS on int" <@ (+) @> - [|1; 2; 3; 4|] - [|5; 6; 7; 8|] - [|6; 8; 10; 12|] - - unaryOpTestGen testCase "Bitwise NEGATION on int" <@ (~~~) @> - <|| ( - [|1; 10; 99; 0|] - |> fun array -> array, array |> Array.map (fun x -> - x - 1) - ) - - binaryOpTestGen testCase "MAX on float32" <@ max @> - [|1.f; 2.f; 3.f; 4.f|] - [|5.f; 6.f; 7.f; 8.f|] - [|5.f; 6.f; 7.f; 8.f|] - - binaryOpTestGen testCase "MIN on float32" <@ min @> - [|1.f; 2.f; 3.f; 4.f|] - [|5.f; 6.f; 7.f; 8.f|] - [|1.f; 2.f; 3.f; 4.f|] - - ptestCase "MAX on int16 with const" <| fun () -> - let command = - <@ - fun (range: Range1D) (buf: int16 clarray) -> - let gid = range.GlobalID0 - buf.[gid] <- max buf.[gid] 1s - @> - - let inA = [|0s; 1s; 2s; 3s|] - checkResult command inA (Array.map (max 1s) inA) - - // Failed: due to precision - ptestCase "Math sin" <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - let i = range.GlobalID0 - buf.[i] <- System.Math.Sin (float buf.[i]) - @> - - let inA = [|0.0; 1.0; 2.0; 3.0|] - checkResult command inA (inA |> Array.map System.Math.Sin) //[|0.0; 0.841471; 0.9092974; 0.14112|] - ] - -let controlFlowTests context = [ - let inline checkResult cmd input expected = checkResult context cmd input expected - - testCase "Check 'if then' condition" <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - if 0 = 2 then buf.[0] <- 42 - @> - - checkResult command intInArr [|0; 1; 2; 3|] - - testCase "Check 'if then else' condition" <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - if 0 = 2 then buf.[0] <- 1 else buf.[0] <- 2 - @> - - checkResult command intInArr [|2; 1; 2; 3|] - - testCase "Check 'for' integer loop" <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - if range.GlobalID0 = 0 then - for i in 0 .. 3 do - buf.[i] <- i - @> - - checkResult command intInArr [|0; 1; 2; 3|] - - testCase "Check 'for' integer loop with step" <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - if range.GlobalID0 = 0 then - for i in 0 .. 2 .. 6 do - buf.[i / 2] <- i - @> - - checkResult command intInArr [|0; 2; 4; 6|] - - testCase "Check 'for' non-integer loop" <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - if range.GlobalID0 = 0 then - for i in 0u .. 3u do - buf.[int i] <- i - @> - - checkResult command [|0u; 0u; 0u; 0u|] [|0u; 1u; 2u; 3u|] - - testCase "Check simple 'while' loop" <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - while buf.[0] < 5 do - buf.[0] <- buf.[0] + 1 - @> - - checkResult command intInArr [|5; 1; 2; 3|] - - testCase "Check 'while' loop inside 'for' integer loop" <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - for i in 0 .. 3 do - while buf.[i] < 10 do - buf.[i] <- buf.[i] * buf.[i] + 1 - @> - - checkResult command intInArr [|26; 26; 26; 10|] -] - -let kernelArgumentsTests context = [ - let inline checkResult cmd input expected = checkResult context cmd input expected - - testCase "Simple 1D" <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - let i = range.GlobalID0 - buf.[i] <- i + i - @> - - checkResult command intInArr [|0;2;4;6|] - - testCase "Simple 1D with copy" <| fun _ -> - let command = - <@ - fun (range: Range1D) (inBuf:ClArray) (outBuf:ClArray) -> - let i = range.GlobalID0 - outBuf.[i] <- inBuf.[i] - @> - - let expected = [|0; 1; 2; 3|] - - let actual = - opencl { - use! inBuf = ClArray.toDevice intInArr - use! outBuf = ClArray.toDevice [|0; 0; 0; 0|] - do! runCommand command <| fun x -> - x default1D inBuf outBuf - - return! ClArray.toHost inBuf - } - |> ClTask.runSync context - - Expect.sequenceEqual actual expected "Arrays should be equals" - - testCase "Simple 1D float" <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - let i = range.GlobalID0 - buf.[i] <- buf.[i] * buf.[i] - @> - - checkResult command float32Arr [|0.0f; 1.0f; 4.0f; 9.0f|] - - testCase "Int as arg" <| fun _ -> - let command = - <@ - fun (range: Range1D) x (buf: ClArray) -> - let i = range.GlobalID0 - buf.[i] <- x + x - @> - - let expected = [|4; 4; 4; 4|] - - let actual = - opencl { - use! inBuf = ClArray.toDevice intInArr - do! runCommand command <| fun x -> - x default1D 2 inBuf - - return! ClArray.toHost inBuf - } - |> ClTask.runSync context - - Expect.sequenceEqual actual expected "Arrays should be equals" + [ binaryOpTestGen + testCase + "Boolean OR" + <@ (||) @> + [| true + false + false + true |] + [| false + true + false + true |] + [| true + true + false + true |] + + binaryOpTestGen + testCase + "Boolean AND" + <@ (&&) @> + [| true + false + false + true |] + [| false + true + false + true |] + [| false + false + false + true |] + + binaryOpTestGen + testCase + "Bitwise OR on int" + <@ (|||) @> + [| 1 + 0 + 0 + 1 |] + [| 0 + 1 + 0 + 1 |] + [| 1 + 1 + 0 + 1 |] + + binaryOpTestGen + testCase + "Bitwise AND on int" + <@ (&&&) @> + [| 1 + 0 + 0 + 1 |] + [| 0 + 1 + 0 + 1 |] + [| 0 + 0 + 0 + 1 |] + + binaryOpTestGen + testCase + "Bitwise XOR on int" + <@ (^^^) @> + [| 1 + 0 + 0 + 1 |] + [| 0 + 1 + 0 + 1 |] + [| 1 + 1 + 0 + 0 |] + + binaryOpTestGen + testCase + "Arithmetic PLUS on int" + <@ (+) @> + [| 1 + 2 + 3 + 4 |] + [| 5 + 6 + 7 + 8 |] + [| 6 + 8 + 10 + 12 |] + + unaryOpTestGen testCase "Bitwise NEGATION on int" <@ (~~~) @> + <|| ([| 1 + 10 + 99 + 0 |] + |> fun array -> array, array |> Array.map (fun x -> -x - 1)) + + binaryOpTestGen + testCase + "MAX on float32" + <@ max @> + [| 1.f + 2.f + 3.f + 4.f |] + [| 5.f + 6.f + 7.f + 8.f |] + [| 5.f + 6.f + 7.f + 8.f |] + + binaryOpTestGen + testCase + "MIN on float32" + <@ min @> + [| 1.f + 2.f + 3.f + 4.f |] + [| 5.f + 6.f + 7.f + 8.f |] + [| 1.f + 2.f + 3.f + 4.f |] + + ptestCase "MAX on int16 with const" + <| fun () -> + let command = + <@ + fun (range: Range1D) (buf: int16 clarray) -> + let gid = range.GlobalID0 + buf.[gid] <- max buf.[gid] 1s + @> + + let inA = + [| 0s + 1s + 2s + 3s |] + + checkResult command inA (Array.map (max 1s) inA) + + // Failed: due to precision + ptestCase "Math sin" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + let i = range.GlobalID0 + buf.[i] <- System.Math.Sin(float buf.[i]) + @> + + let inA = + [| 0.0 + 1.0 + 2.0 + 3.0 |] + + checkResult command inA (inA |> Array.map System.Math.Sin) ] //[|0.0; 0.841471; 0.9092974; 0.14112|] + +let controlFlowTests context = + [ let inline checkResult cmd input expected = checkResult context cmd input expected + + testCase "Check 'if then' condition" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + if 0 = 2 then + buf.[0] <- 42 + @> + + checkResult + command + intInArr + [| 0 + 1 + 2 + 3 |] + + testCase "Check 'if then else' condition" + <| fun _ -> + let command = + <@ fun (range: Range1D) (buf: ClArray) -> if 0 = 2 then buf.[0] <- 1 else buf.[0] <- 2 @> + + checkResult + command + intInArr + [| 2 + 1 + 2 + 3 |] + + testCase "Check 'for' integer loop" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + if range.GlobalID0 = 0 then + for i in 0..3 do + buf.[i] <- i + @> + + checkResult + command + intInArr + [| 0 + 1 + 2 + 3 |] + + testCase "Check 'for' integer loop with step" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + if range.GlobalID0 = 0 then + for i in 0..2..6 do + buf.[i / 2] <- i + @> + + checkResult + command + intInArr + [| 0 + 2 + 4 + 6 |] + + testCase "Check 'for' non-integer loop" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + if range.GlobalID0 = 0 then + for i in 0u .. 3u do + buf.[int i] <- i + @> + + checkResult + command + [| 0u + 0u + 0u + 0u |] + [| 0u + 1u + 2u + 3u |] + + testCase "Check simple 'while' loop" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + while buf.[0] < 5 do + buf.[0] <- buf.[0] + 1 + @> + + checkResult + command + intInArr + [| 5 + 1 + 2 + 3 |] + + testCase "Check 'while' loop inside 'for' integer loop" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + for i in 0..3 do + while buf.[i] < 10 do + buf.[i] <- buf.[i] * buf.[i] + 1 + @> + + checkResult + command + intInArr + [| 26 + 26 + 26 + 10 |] ] + +let kernelArgumentsTests context = + [ let inline checkResult cmd input expected = checkResult context cmd input expected + + testCase "Simple 1D" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + let i = range.GlobalID0 + buf.[i] <- i + i + @> + + checkResult + command + intInArr + [| 0 + 2 + 4 + 6 |] + + testCase "Simple 1D with copy" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (inBuf: ClArray) (outBuf: ClArray) -> + let i = range.GlobalID0 + outBuf.[i] <- inBuf.[i] + @> + + let expected = + [| 0 + 1 + 2 + 3 |] + + let actual = + opencl { + use! inBuf = ClArray.toDevice intInArr + + use! outBuf = + ClArray.toDevice + [| 0 + 0 + 0 + 0 |] + + do! runCommand command <| fun x -> x default1D inBuf outBuf + + return! ClArray.toHost inBuf + } + |> ClTask.runSync context + + Expect.sequenceEqual actual expected "Arrays should be equals" + + testCase "Simple 1D float" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + let i = range.GlobalID0 + buf.[i] <- buf.[i] * buf.[i] + @> + + checkResult + command + float32Arr + [| 0.0f + 1.0f + 4.0f + 9.0f |] + + testCase "Int as arg" + <| fun _ -> + let command = + <@ + fun (range: Range1D) x (buf: ClArray) -> + let i = range.GlobalID0 + buf.[i] <- x + x + @> + + let expected = + [| 4 + 4 + 4 + 4 |] + + let actual = + opencl { + use! inBuf = ClArray.toDevice intInArr + do! runCommand command <| fun x -> x default1D 2 inBuf + + return! ClArray.toHost inBuf + } + |> ClTask.runSync context + + Expect.sequenceEqual actual expected "Arrays should be equals" + + testCase "Sequential commands over single buffer" + <| fun _ -> + let command = <@ fun (range: Range1D) i x (buf: ClArray) -> buf.[i] <- x + x @> + + let expected = + [| 4 + 1 + 4 + 3 |] + + let actual = + opencl { + use! inArr = ClArray.toDevice intInArr + + do! runCommand command <| fun it -> it <| default1D <| 0 <| 2 <| inArr + + do! runCommand command <| fun it -> it <| default1D <| 2 <| 2 <| inArr + + return! ClArray.toHost inArr + } + |> ClTask.runSync context + + Expect.sequenceEqual actual expected "Arrays should be equals" + + ptestProperty "Parallel execution of kernel" + <| fun _const -> + let context = context.ClContext + let n = 4 + let l = 256 + + let getAllocator (context: ClContext) = + let kernel = + <@ + fun (r: Range1D) (buffer: ClArray) -> + let i = r.GlobalID0 + buffer.[i] <- _const + @> + + let k = context.Compile kernel + + fun (q: MailboxProcessor<_>) -> + let buf = context.CreateClArray(l, allocationMode = AllocationMode.AllocHostPtr) + let executable = k.GetKernel() + q.Post(Msg.MsgSetArguments(fun () -> executable.KernelFunc (Range1D(l, l)) buf)) + q.Post(Msg.CreateRunMsg<_, _>(executable)) + buf + + let allocator = getAllocator context + + let allocOnGPU (q: MailboxProcessor<_>) allocator = + let b = allocator q + let res = Array.zeroCreate l + q.PostAndReply(fun ch -> Msg.CreateToHostMsg(b, res, ch)) |> ignore + q.Post(Msg.CreateFreeMsg b) + res + + let actual = + Array.init n (fun _ -> context.QueueProvider.CreateQueue()) + |> Array.map (fun q -> async { return allocOnGPU q allocator }) + |> Async.Parallel + |> Async.RunSynchronously + + let expected = Array.init n (fun _ -> Array.create l _const) + + Expect.sequenceEqual actual expected "Arrays should be equals" ] + +let quotationInjectionTests context = + [ let inline checkResult cmd input expected = checkResult context cmd input expected + + testCase "Quotations injections 1" + <| fun _ -> + let myF = <@ fun x -> x * x @> + + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + buf.[0] <- (%myF) 2 + buf.[1] <- (%myF) 4 + @> + + checkResult + command + intInArr + [| 4 + 16 + 2 + 3 |] + + testCase "Quotations injections 2" + <| fun _ -> + let myF = <@ fun x y -> y - x @> + + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + buf.[0] <- (%myF) 2 5 + buf.[1] <- (%myF) 4 9 + @> + + checkResult + command + intInArr + [| 3 + 5 + 2 + 3 |] ] + +let localMemTests context = + [ let inline checkResult cmd input expected = checkResult context cmd input expected + + // TODO: pointers to local data must be local too. + testCase "Local int. Work item counting" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (output: ClArray) -> + let globalID = range.GlobalID0 + let mutable x = local () + + if globalID = 0 then + x <- 0 + + barrierLocal () + + atomic (+) x 1 |> ignore + // fetch local value before read, dont work without barrier + barrierLocal () + + if globalID = 0 then + output.[0] <- x + @> + + let expected = [| 5 |] + + let actual = + opencl { + use! inBuf = ClArray.toDevice [| 0 |] + do! runCommand command <| fun x -> x (Range1D(5, 5)) inBuf + + return! ClArray.toHost inBuf + } + |> ClTask.runSync context + + Expect.sequenceEqual actual expected "Arrays should be equals" + + testCase "Local array. Test 1" + <| fun _ -> + let localWorkSize = 5 + let globalWorkSize = 15 + + let command = + <@ + fun (range: Range1D) (input: ClArray) (output: ClArray) -> + let localBuf = localArray localWorkSize + + localBuf.[range.LocalID0] <- range.LocalID0 + barrierLocal () + output.[range.GlobalID0] <- localBuf.[(range.LocalID0 + 1) % localWorkSize] + @> + + + let expected = + [| for x in 1..localWorkSize -> x % localWorkSize |] + |> Array.replicate (globalWorkSize / localWorkSize) + |> Array.concat + + let actual = + opencl { + use! inBuf = ClArray.toDevice (Array.zeroCreate globalWorkSize) + use! outBuf = ClArray.toDevice (Array.zeroCreate globalWorkSize) + + do! + runCommand command + <| fun x -> x (Range1D(globalWorkSize, localWorkSize)) inBuf outBuf + + return! ClArray.toHost outBuf + } + |> ClTask.runSync context + + Expect.sequenceEqual actual expected "Arrays should be equals" + + ptestCase "Local array. Test 2" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + let localBuf = localArray 42 + atomic xchg localBuf.[0] 1L |> ignore + buf.[0] <- localBuf.[0] + @> + + checkResult + command + [| 0L + 1L + 2L + 3L |] + [| 1L + 1L + 2L + 3L |] ] + +let letTransformationTests context = + [ let inline checkResult cmd input expected = checkResult context cmd input expected + + testCase "Template Let Transformation Test 0" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + let f = 3 + buf.[0] <- f + @> + + checkResult + command + intInArr + [| 3 + 1 + 2 + 3 |] + + testCase "Template Let Transformation Test 1" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + let x = 4 + + let f = + let x = 3 + x + + buf.[0] <- x + f + @> + + checkResult + command + intInArr + [| 7 + 1 + 2 + 3 |] + + testCase "Template Let Transformation Test 1.2" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + let f y = + let x c b = b + c + 4 + y + x 2 3 + + buf.[0] <- f 1 + @> + + checkResult + command + intInArr + [| 10 + 1 + 2 + 3 |] + + testCase "Template Let Transformation Test 2" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + let f = + let x = + let y = 3 + y + + x + + buf.[0] <- f + @> + + checkResult + command + intInArr + [| 3 + 1 + 2 + 3 |] + + testCase "Template Let Transformation Test 3" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + let f = + let f = 5 + f + + buf.[0] <- f + @> + + checkResult + command + intInArr + [| 5 + 1 + 2 + 3 |] + + testCase "Template Let Transformation Test 4" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + let f = + let f = + let f = 5 + f + + f + + buf.[0] <- f + @> + + checkResult + command + intInArr + [| 5 + 1 + 2 + 3 |] + + testCase "Template Let Transformation Test 5" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + let f a b = + let x y z = y + z + x a b + + buf.[0] <- f 1 7 + @> + + checkResult + command + intInArr + [| 8 + 1 + 2 + 3 |] + + testCase "Template Let Transformation Test 6" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + let f x y = + let x = x + x + y + + buf.[0] <- f 7 8 + @> + + checkResult + command + intInArr + [| 15 + 1 + 2 + 3 |] + + testCase "Template Let Transformation Test 7" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + let f y = + let x y = 6 - y + x y + + buf.[0] <- f 7 + @> + + checkResult + command + intInArr + [| -1 + 1 + 2 + 3 |] + + testCase "Template Let Transformation Test 8" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (m: ClArray) -> + let p = m.[0] + + let x n = + let l = m.[3] + let g k = k + m.[0] + m.[1] + + let r = + let y a = + let x = 5 - n + (g 4) + let z t = m.[2] + a - t + z (a + x + l) + + y 6 + + r + m.[3] + + if range.GlobalID0 = 0 then + m.[0] <- x 7 + @> + + checkResult + command + intInArr + [| -1 + 1 + 2 + 3 |] + + testCase "Template Let Transformation Test 9" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + let x n = + let r = 8 + let h = r + n + h + + buf.[0] <- x 9 + @> + + checkResult + command + intInArr + [| 17 + 1 + 2 + 3 |] + + testCase "Template Let Transformation Test 10" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + let p = 9 + + let x n b = + let t = 0 + n + b + t + + buf.[0] <- x 7 9 + @> + + checkResult + command + intInArr + [| 16 + 1 + 2 + 3 |] + + testCase "Template Let Transformation Test 11" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + let p = 1 + + let m = + let r (l: int) = l + r 9 + + let z (k: int) = k + buf.[0] <- m + @> + + checkResult + command + intInArr + [| 9 + 1 + 2 + 3 |] + + testCase "Template Let Transformation Test 12" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + let f x y = + let y = y + let y = y + let g x m = m + x + g x y + + buf.[0] <- f 1 7 + @> + + checkResult + command + intInArr + [| 8 + 1 + 2 + 3 |] + + testCase "Template Let Transformation Test 13" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + let f y = + let y = y + let y = y + let g (m: int) = m + g y + + buf.[0] <- f 7 + @> + + checkResult + command + intInArr + [| 7 + 1 + 2 + 3 |] + + testCase "Template Let Transformation Test 14" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + let f y = + let y = y + let y = y + + let g (m: int) = + let g r t = r + y - t + let n o = o - (g y 2) + n 5 + + g y + + let z y = y - 2 + buf.[0] <- f (z 7) + @> + + checkResult + command + intInArr + [| -3 + 1 + 2 + 3 |] + + testCase "Template Let Transformation Test 15" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + let f y = + let Argi index = if index = 0 then buf.[1] else buf.[2] + Argi y + + buf.[0] <- f 0 + @> + + checkResult + command + intInArr + [| 1 + 1 + 2 + 3 |] + + testCase "Template Let Transformation Test 16" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + let f y = + if y = 0 then + let z (a: int) = a + z 9 + else + buf.[2] + + buf.[0] <- f 0 + @> + + checkResult + command + intInArr + [| 9 + 1 + 2 + 3 |] + + testCase "Template Let Transformation Test 17" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + if range.GlobalID0 = 0 then + let f y = + let g = buf.[1] + 1 + y + g + + for i in 0..3 do + buf.[i] <- f i + @> + + checkResult + command + intInArr + [| 2 + 3 + 6 + 7 |] + + testCase "Template Let Transformation Test 18" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + for i in 0..3 do + let f = + let g = buf.[1] + 1 + i + g + + if range.GlobalID0 = 0 then + buf.[i] <- f + @> + + checkResult + command + intInArr + [| 2 + 3 + 6 + 7 |] + + testCase "Template Let Transformation Test 19" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + if range.GlobalID0 = 0 then + for i in 0..3 do + let f x = + let g = buf.[1] + x + i + g + + buf.[i] <- f 1 + @> + + checkResult + command + intInArr + [| 2 + 3 + 6 + 7 |] + + // TODO: perform range (1D, 2D, 3D) erasure when range is lifted. + ptestCase "Template Let Transformation Test 20" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (m: ClArray) -> + let f x = range.GlobalID0 + x + m.[0] <- f 2 + @> + + checkResult + command + intInArr + [| 2 + 3 + 6 + 7 |] ] + +let letQuotationTransformerSystemTests context = + [ let inline checkResult cmd input expected = checkResult context cmd input expected + + testCase "Test 0" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + let mutable x = 1 + let f y = x <- y + f 10 + buf.[0] <- x + @> + + checkResult + command + intInArr + [| 10 + 1 + 2 + 3 |] + + testCase "Test 1" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + let mutable x = 1 + let f y = x <- x + y + f 10 + buf.[0] <- x + @> + + checkResult + command + intInArr + [| 11 + 1 + 2 + 3 |] + + testCase "Test 2" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (arr: ClArray) -> + let f x = + let g y = y + 1 + g x + + arr.[0] <- f 2 + @> + + checkResult + command + intInArr + [| 3 + 1 + 2 + 3 |] + + testCase "Test 3" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (arr: ClArray) -> + let f x = + let g y = y + x + g (x + 1) + + arr.[0] <- f 2 + @> + + checkResult + command + intInArr + [| 5 + 1 + 2 + 3 |] + + testCase "Test 4" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (arr: ClArray) -> + let gid = range.GlobalID0 + + let x = + let mutable y = 0 + + let addToY x = y <- y + x + + for i in 0..5 do + addToY arr.[gid] + + y + + arr.[gid] <- x + @> + + checkResult + command + intInArr + [| 0 + 6 + 12 + 18 |] + + testCase "Test 5" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (arr: ClArray) -> + let gid = range.GlobalID0 + + let mutable x = if 0 > 1 then 2 else 3 + + let mutable y = + for i in 0..4 do + x <- x + 1 + + x + 1 + + let z = x + y + + let f () = arr.[gid] <- x + y + z + f () + @> + + checkResult + command + intInArr + [| 34 + 34 + 34 + 34 |] ] + +let commonApiTests context = + [ let inline checkResult cmd input expected = checkResult context cmd input expected + + testCase "Check simple '|> ignore'" + <| fun () -> + let command = + <@ + fun (range: Range1D) (buffer: ClArray) -> + let gid = range.GlobalID0 + atomic inc buffer.[gid] |> ignore + @> + + checkResult command intInArr (intInArr |> Array.map ((+) 1)) + + // Lambda is not supported. + ptestCase "Forward pipe" + <| fun _ -> + let command = + <@ fun (range: Range1D) (buf: ClArray) -> buf.[0] <- (1.25f |> int) @> + + checkResult + command + intInArr + [| 1 + 1 + 2 + 3 |] + + // Lambda is not supported. + ptestCase "Backward pipe" + <| fun _ -> + let command = + <@ fun (range: Range1D) (buf: ClArray) -> buf.[0] <- int <| 1.25f + 2.34f @> + + checkResult + command + intInArr + [| 3 + 1 + 2 + 3 |] + + testCase "Getting value of 'int clcell' should be correct" + <| fun () -> + let command = + <@ + fun (range: Range1D) (buffer: int clarray) (cell: int clcell) -> + let gid = range.GlobalID0 + buffer.[gid] <- cell.Value + @> + + let value = 10 + let expected = Array.replicate defaultInArrayLength value + + let actual = + opencl { + use! cell = ClCell.toDevice 10 + use! buffer = ClArray.alloc defaultInArrayLength + do! runCommand command <| fun it -> it <| default1D <| buffer <| cell + + return! ClArray.toHost buffer + } + |> ClTask.runSync context + + "Arrays should be equal" |> Expect.sequenceEqual actual expected + + // TODO test on getting Value property of non-clcell type + // TODO test on getting Item property on non-clarray type + + testCase "Setting value of 'int clcell' should be correct" + <| fun () -> + let value = 10 + let command = <@ fun (range: Range1D) (cell: int clcell) -> cell.Value <- value @> + + let actual = + opencl { + use! cell = ClCell.toDevice value + do! runCommand command <| fun it -> it <| default1D <| cell + + return! ClCell.toHost cell + } + |> ClTask.runSync context + + "Arrays should be equal" |> Expect.equal actual value + + testCase "Using 'int clcell' from inner function should work correctly" + <| fun () -> + let value = 10 + + let command = + <@ + fun (range: Range1D) (cell: int clcell) -> + let f () = + let x = cell.Value + cell.Value <- x + + f () + @> + + let actual = + opencl { + use! cell = ClCell.toDevice value + do! runCommand command <| fun it -> it <| default1D <| cell + + return! ClCell.toHost cell + } + |> ClTask.runSync context + + "Arrays should be equal" |> Expect.equal actual value + + testCase "Using 'int clcell' with native atomic operation should be correct" + <| fun () -> + let value = 10 - testCase "Sequential commands over single buffer" <| fun _ -> - let command = - <@ - fun (range: Range1D) i x (buf: ClArray) -> - buf.[i] <- x + x - @> + let command = + <@ fun (range: Range1D) (cell: int clcell) -> atomic (+) cell.Value value |> ignore @> + + let expected = value * default1D.GlobalWorkSize + + let actual = + opencl { + use! cell = ClCell.toDevice 0 + do! runCommand command <| fun it -> it <| default1D <| cell - let expected = [|4; 1; 4; 3|] + return! ClCell.toHost cell + } + |> ClTask.runSync context - let actual = - opencl { - use! inArr = ClArray.toDevice intInArr - - do! runCommand command <| fun it -> - it - <| default1D - <| 0 - <| 2 - <| inArr - - do! runCommand command <| fun it -> - it - <| default1D - <| 2 - <| 2 - <| inArr - - return! ClArray.toHost inArr - } - |> ClTask.runSync context + "Arrays should be equal" |> Expect.equal actual expected - Expect.sequenceEqual actual expected "Arrays should be equals" + ptestCase "Using 'int clcell' with spinlock atomic operation should be correct" + <| fun () -> + let value = 10 - ptestProperty "Parallel execution of kernel" <| fun _const -> - let context = context.ClContext - let n = 4 - let l = 256 - let getAllocator (context: ClContext) = - let kernel = - <@ - fun (r: Range1D) (buffer: ClArray) -> - let i = r.GlobalID0 - buffer.[i] <- _const - @> - let k = context.Compile kernel - fun (q:MailboxProcessor<_>) -> - let buf = context.CreateClArray(l, allocationMode = AllocationMode.AllocHostPtr) - let executable = k.GetKernel() - q.Post(Msg.MsgSetArguments(fun () -> executable.KernelFunc (Range1D(l, l)) buf)) - q.Post(Msg.CreateRunMsg<_,_>(executable)) - buf - - let allocator = getAllocator context - let allocOnGPU (q:MailboxProcessor<_>) allocator = - let b = allocator q - let res = Array.zeroCreate l - q.PostAndReply (fun ch -> Msg.CreateToHostMsg(b, res, ch)) |> ignore - q.Post (Msg.CreateFreeMsg b) - res + let command = + <@ fun (range: Range1D) (cell: int clcell) -> atomic (fun x -> x + value) cell.Value |> ignore @> - let actual = - Array.init n (fun _ -> context.QueueProvider.CreateQueue()) - |> Array.map (fun q -> async { return allocOnGPU q allocator }) - |> Async.Parallel - |> Async.RunSynchronously + let expected = value * default1D.GlobalWorkSize - let expected = Array.init n (fun _ -> Array.create l _const) + let actual = + opencl { + use! cell = ClCell.toDevice 0 + do! runCommand command <| fun it -> it <| default1D <| cell - Expect.sequenceEqual actual expected "Arrays should be equals" -] + return! ClCell.toHost cell + } + |> ClTask.runSync context -let quotationInjectionTests context = [ - let inline checkResult cmd input expected = checkResult context cmd input expected + "Arrays should be equal" |> Expect.equal actual expected ] - testCase "Quotations injections 1" <| fun _ -> - let myF = <@ fun x -> x * x @> +let booleanTests context = + [ testCase "Executing copy kernel on boolean array should not raise exception" + <| fun () -> + let inputArray = Array.create 100_000 true + let inputArrayLength = inputArray.Length - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - buf.[0] <- (%myF) 2 - buf.[1] <- (%myF) 4 - @> + let copy = + <@ + fun (ndRange: Range1D) (inputArrayBuffer: bool clarray) (outputArrayBuffer: bool clarray) -> - checkResult command intInArr [|4;16;2;3|] + let i = ndRange.GlobalID0 - testCase "Quotations injections 2" <| fun _ -> - let myF = <@ fun x y -> y - x @> + if i < inputArrayLength then + outputArrayBuffer.[i] <- inputArrayBuffer.[i] + @> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - buf.[0] <- (%myF) 2 5 - buf.[1] <- (%myF) 4 9 - @> + let actual = + opencl { + use! input = ClArray.toDevice inputArray + use! output = ClArray.alloc 100_000 - checkResult command intInArr [|3;5;2;3|] -] + do! + runCommand copy + <| fun x -> x <| Range1D.CreateValid(inputArray.Length, 256) <| input <| output -let localMemTests context = [ - let inline checkResult cmd input expected = checkResult context cmd input expected - - // TODO: pointers to local data must be local too. - testCase "Local int. Work item counting" <| fun _ -> - let command = - <@ - fun (range: Range1D) (output: ClArray) -> - let globalID = range.GlobalID0 - let mutable x = local () - - if globalID = 0 then x <- 0 - barrierLocal () - - atomic (+) x 1 |> ignore - // fetch local value before read, dont work without barrier - barrierLocal () - - if globalID = 0 then - output.[0] <- x - @> + return! ClArray.toHost output + } + |> ClTask.runSync context - let expected = [|5|] - - let actual = - opencl { - use! inBuf = ClArray.toDevice [|0|] - do! runCommand command <| fun x -> - x (Range1D(5, 5)) inBuf - - return! ClArray.toHost inBuf - } - |> ClTask.runSync context + "Arrays should be equal" |> Expect.sequenceEqual actual inputArray - Expect.sequenceEqual actual expected "Arrays should be equals" + testProperty "'lor' on boolean type should work correctly" + <| fun (array: bool[]) -> + if array.Length <> 0 then + let reversed = Seq.rev array |> Seq.toArray + let inputArrayLength = array.Length - testCase "Local array. Test 1" <| fun _ -> - let localWorkSize = 5 - let globalWorkSize = 15 + let command = + <@ + fun (ndRange: Range1D) (array: bool clarray) (reversed: bool clarray) -> - let command = - <@ - fun (range: Range1D) (input: ClArray) (output: ClArray) -> - let localBuf = localArray localWorkSize + let i = ndRange.GlobalID0 - localBuf.[range.LocalID0] <- range.LocalID0 - barrierLocal () - output.[range.GlobalID0] <- localBuf.[(range.LocalID0 + 1) % localWorkSize] - @> + if i < inputArrayLength then + array.[i] <- array.[i] || reversed.[i] || false + @> + let expected = (array, reversed) ||> Array.zip |> Array.map (fun (x, y) -> x || y) - let expected = - [| for x in 1..localWorkSize -> x % localWorkSize |] - |> Array.replicate (globalWorkSize / localWorkSize) - |> Array.concat + let actual = + opencl { + use! array' = ClArray.toDevice array + use! reversed' = ClArray.toDevice reversed - let actual = - opencl { - use! inBuf = ClArray.toDevice (Array.zeroCreate globalWorkSize) - use! outBuf = ClArray.toDevice (Array.zeroCreate globalWorkSize) - do! runCommand command <| fun x -> - x (Range1D(globalWorkSize, localWorkSize)) inBuf outBuf + do! + runCommand command + <| fun x -> x <| Range1D.CreateValid(inputArrayLength, 256) <| array' <| reversed' - return! ClArray.toHost outBuf - } - |> ClTask.runSync context + return! ClArray.toHost array' + } + |> ClTask.runSync context - Expect.sequenceEqual actual expected "Arrays should be equals" + "Arrays should be equal" |> Expect.sequenceEqual actual expected - ptestCase "Local array. Test 2" <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: ClArray) -> - let localBuf = localArray 42 - atomic xchg localBuf.[0] 1L |> ignore - buf.[0] <- localBuf.[0] - @> + testProperty "'land' on boolean type should work correctly" + <| fun (array: bool[]) -> + if array.Length <> 0 then + let reversed = Seq.rev array |> Seq.toArray + let inputArrayLength = array.Length - checkResult command [|0L; 1L; 2L; 3L|] [|1L; 1L; 2L; 3L|] -] + let command = + <@ + fun (ndRange: Range1D) (array: bool clarray) (reversed: bool clarray) -> -let letTransformationTests context = [ - let inline checkResult cmd input expected = checkResult context cmd input expected + let i = ndRange.GlobalID0 - testCase "Template Let Transformation Test 0" <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - let f = 3 - buf.[0] <- f - @> - - checkResult command intInArr [|3; 1; 2; 3|] - - testCase "Template Let Transformation Test 1" <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - let x = 4 - let f = - let x = 3 - x - buf.[0] <- x + f - @> - checkResult command intInArr [|7; 1; 2; 3|] - - testCase "Template Let Transformation Test 1.2" <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - let f y = - let x c b = b + c + 4 + y - x 2 3 - buf.[0] <- f 1 - @> - - checkResult command intInArr [|10; 1; 2; 3|] - - testCase "Template Let Transformation Test 2" <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - let f = - let x = - let y = 3 - y - x - buf.[0] <- f - @> - - checkResult command intInArr [|3; 1; 2; 3|] - - testCase "Template Let Transformation Test 3" <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - let f = - let f = 5 - f - buf.[0] <- f - @> - - checkResult command intInArr [|5; 1; 2; 3|] - - testCase "Template Let Transformation Test 4" <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - let f = - let f = - let f = 5 - f - f - buf.[0] <- f - @> - - checkResult command intInArr [|5; 1; 2; 3|] - - testCase "Template Let Transformation Test 5" <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - let f a b = - let x y z = y + z - x a b - buf.[0] <- f 1 7 - @> - - checkResult command intInArr [|8; 1; 2; 3|] - - testCase "Template Let Transformation Test 6" <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - let f x y = - let x = x - x + y - buf.[0] <- f 7 8 - @> - - checkResult command intInArr [|15; 1; 2; 3|] - - testCase "Template Let Transformation Test 7" <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - let f y = - let x y = 6 - y - x y - buf.[0] <- f 7 - @> - - checkResult command intInArr [|-1; 1; 2; 3|] - - testCase "Template Let Transformation Test 8" <| fun _ -> - let command = - <@ - fun (range: Range1D) (m: ClArray) -> - let p = m.[0] - let x n = - let l = m.[3] - let g k = k + m.[0] + m.[1] - let r = - let y a = - let x = 5 - n + (g 4) - let z t = m.[2] + a - t - z (a + x + l) - y 6 - r + m.[3] - if range.GlobalID0 = 0 - then m.[0] <- x 7 - @> - - checkResult command intInArr [|-1; 1; 2; 3|] - - testCase "Template Let Transformation Test 9" <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - let x n = - let r = 8 - let h = r + n - h - buf.[0] <- x 9 - @> - - checkResult command intInArr [|17; 1; 2; 3|] - - testCase "Template Let Transformation Test 10" <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - let p = 9 - let x n b = - let t = 0 - n + b + t - buf.[0] <- x 7 9 - @> - - checkResult command intInArr [|16; 1; 2; 3|] - - testCase "Template Let Transformation Test 11" <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - let p = 1 - let m = - let r (l:int) = l - r 9 - let z (k:int) = k - buf.[0] <- m - @> - - checkResult command intInArr [|9; 1; 2; 3|] - - testCase "Template Let Transformation Test 12" <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - let f x y = - let y = y - let y = y - let g x m = m + x - g x y - buf.[0] <- f 1 7 - @> - - checkResult command intInArr [|8; 1; 2; 3|] - - testCase "Template Let Transformation Test 13" <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - let f y = - let y = y - let y = y - let g (m:int) = m - g y - buf.[0] <- f 7 - @> - - checkResult command intInArr [|7; 1; 2; 3|] - - testCase "Template Let Transformation Test 14" <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - let f y = - let y = y - let y = y - let g (m:int) = - let g r t = r + y - t - let n o = o - (g y 2) - n 5 - g y - let z y = y - 2 - buf.[0] <- f (z 7) - @> - - checkResult command intInArr [|-3; 1; 2; 3|] - - testCase "Template Let Transformation Test 15" <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - let f y = - let Argi index = - if index = 0 - then buf.[1] - else buf.[2] - Argi y - buf.[0] <- f 0 - @> - - checkResult command intInArr [|1; 1; 2; 3|] - - testCase "Template Let Transformation Test 16" <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - let f y = - if y = 0 - then - let z (a:int) = a - z 9 - else buf.[2] - buf.[0] <- f 0 - @> - - checkResult command intInArr [|9; 1; 2; 3|] - - testCase "Template Let Transformation Test 17" <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - if range.GlobalID0 = 0 - then - let f y = - let g = buf.[1] + 1 - y + g - for i in 0..3 do - buf.[i] <- f i - @> - - checkResult command intInArr [|2; 3; 6; 7|] - - testCase "Template Let Transformation Test 18" <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - for i in 0..3 do - let f = - let g = buf.[1] + 1 - i + g - if range.GlobalID0 = 0 - then buf.[i] <- f - @> - - checkResult command intInArr [|2; 3; 6; 7|] - - testCase "Template Let Transformation Test 19" <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - if range.GlobalID0 = 0 - then - for i in 0..3 do - let f x = - let g = buf.[1] + x - i + g - buf.[i] <- f 1 - @> - - checkResult command intInArr [|2; 3; 6; 7|] - - // TODO: perform range (1D, 2D, 3D) erasure when range is lifted. - ptestCase "Template Let Transformation Test 20" <| fun _ -> - let command = - <@ - fun (range: Range1D) (m: ClArray) -> - let f x = - range.GlobalID0 + x - m.[0] <- f 2 - @> - - checkResult command intInArr [|2; 3; 6; 7|] -] - -let letQuotationTransformerSystemTests context = [ - let inline checkResult cmd input expected = checkResult context cmd input expected + if i < inputArrayLength then + array.[i] <- array.[i] && reversed.[i] && true + @> - testCase "Test 0" <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - let mutable x = 1 - let f y = - x <- y - f 10 - buf.[0] <- x - @> - - checkResult command intInArr [|10; 1; 2; 3|] - - testCase "Test 1" <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - let mutable x = 1 - let f y = - x <- x + y - f 10 - buf.[0] <- x - @> - - checkResult command intInArr [|11; 1; 2; 3|] - - testCase "Test 2" <| fun _ -> - let command = - <@ - fun (range: Range1D) (arr: ClArray) -> - let f x = - let g y = y + 1 - g x - arr.[0] <- f 2 - @> - - checkResult command intInArr [|3; 1; 2; 3|] - - testCase "Test 3" <| fun _ -> - let command = - <@ - fun (range: Range1D) (arr: ClArray)-> - let f x = - let g y = - y + x - g (x + 1) - arr.[0] <- f 2 - @> - - checkResult command intInArr [|5; 1; 2; 3|] - - testCase "Test 4" <| fun _ -> - let command = - <@ - fun (range: Range1D) (arr: ClArray) -> - let gid = range.GlobalID0 - let x = - let mutable y = 0 - - let addToY x = - y <- y + x - - for i in 0..5 do - addToY arr.[gid] - y - arr.[gid] <- x - @> - - checkResult command intInArr [|0; 6; 12; 18|] - - testCase "Test 5" <| fun _ -> - let command = - <@ - fun (range: Range1D) (arr: ClArray) -> - let gid = range.GlobalID0 - - let mutable x = - if 0 > 1 then 2 else 3 - - let mutable y = - for i in 0..4 do - x <- x + 1 - x + 1 - - let z = - x + y - - let f () = - arr.[gid] <- x + y + z - f () - @> - - checkResult command intInArr [|34; 34; 34; 34|] -] - -let commonApiTests context = [ - let inline checkResult cmd input expected = checkResult context cmd input expected + let expected = (array, reversed) ||> Array.zip |> Array.map (fun (x, y) -> x && y) - testCase "Check simple '|> ignore'" <| fun () -> - let command = - <@ - fun (range: Range1D) (buffer: ClArray) -> - let gid = range.GlobalID0 - atomic inc buffer.[gid] |> ignore - @> - - checkResult command intInArr (intInArr |> Array.map ((+) 1)) - - // Lambda is not supported. - ptestCase "Forward pipe" <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - buf.[0] <- (1.25f |> int) - @> - checkResult command intInArr [|1; 1; 2; 3|] - - // Lambda is not supported. - ptestCase "Backward pipe" <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - buf.[0] <- int <| 1.25f + 2.34f - @> - checkResult command intInArr [|3; 1; 2; 3|] - - testCase "Getting value of 'int clcell' should be correct" <| fun () -> - let command = - <@ - fun (range: Range1D) (buffer: int clarray) (cell: int clcell) -> - let gid = range.GlobalID0 - buffer.[gid] <- cell.Value - @> - - let value = 10 - let expected = Array.replicate defaultInArrayLength value + let actual = + opencl { + use! array' = ClArray.toDevice array + use! reversed' = ClArray.toDevice reversed - let actual = - opencl { - use! cell = ClCell.toDevice 10 - use! buffer = ClArray.alloc defaultInArrayLength - do! runCommand command <| fun it -> - it - <| default1D - <| buffer - <| cell - - return! ClArray.toHost buffer - } - |> ClTask.runSync context + do! + runCommand command + <| fun x -> x <| Range1D.CreateValid(inputArrayLength, 256) <| array' <| reversed' - "Arrays should be equal" - |> Expect.sequenceEqual actual expected + return! ClArray.toHost array' + } + |> ClTask.runSync context - // TODO test on getting Value property of non-clcell type - // TODO test on getting Item property on non-clarray type + "Arrays should be equal" |> Expect.sequenceEqual actual expected ] - testCase "Setting value of 'int clcell' should be correct" <| fun () -> - let value = 10 - let command = - <@ - fun (range: Range1D) (cell: int clcell) -> - cell.Value <- value - @> +let parallelExecutionTests context = + [ testCase "Running tasks in parallel should not raise exception" + <| fun () -> + let fill = + opencl { + let kernel = + <@ + fun (range: Range1D) (buffer: int clarray) -> + let i = range.GlobalID0 + buffer.[i] <- 1 + @> - let actual = - opencl { - use! cell = ClCell.toDevice value - do! runCommand command <| fun it -> - it - <| default1D - <| cell + use! array = ClArray.alloc 256 + do! runCommand kernel <| fun x -> x <| Range1D.CreateValid(256, 256) <| array - return! ClCell.toHost cell - } - |> ClTask.runSync context + return! ClArray.toHost array + } - "Arrays should be equal" - |> Expect.equal actual value + let expected = Array.replicate 3 (Array.create 256 1) - testCase "Using 'int clcell' from inner function should work correctly" <| fun () -> - let value = 10 - let command = - <@ - fun (range: Range1D) (cell: int clcell) -> - let f () = - let x = cell.Value - cell.Value <- x + let actual = + opencl { return! List.replicate 3 fill |> ClTask.inParallel } + |> ClTask.runSync context - f () - @> + "Arrays should be equal" |> Expect.sequenceEqual actual expected - let actual = - opencl { - use! cell = ClCell.toDevice value - do! runCommand command <| fun it -> - it - <| default1D - <| cell - - return! ClCell.toHost cell - } - |> ClTask.runSync context - - "Arrays should be equal" - |> Expect.equal actual value - - testCase "Using 'int clcell' with native atomic operation should be correct" <| fun () -> - let value = 10 - let command = - <@ - fun (range: Range1D) (cell: int clcell) -> - atomic (+) cell.Value value |> ignore - @> - - let expected = value * default1D.GlobalWorkSize - - let actual = - opencl { - use! cell = ClCell.toDevice 0 - do! runCommand command <| fun it -> - it - <| default1D - <| cell - - return! ClCell.toHost cell - } - |> ClTask.runSync context - - "Arrays should be equal" - |> Expect.equal actual expected - - ptestCase "Using 'int clcell' with spinlock atomic operation should be correct" <| fun () -> - let value = 10 - let command = - <@ - fun (range: Range1D) (cell: int clcell) -> - atomic (fun x -> x + value) cell.Value |> ignore - @> - - let expected = value * default1D.GlobalWorkSize - - let actual = - opencl { - use! cell = ClCell.toDevice 0 - do! runCommand command <| fun it -> - it - <| default1D - <| cell - - return! ClCell.toHost cell - } - |> ClTask.runSync context - - "Arrays should be equal" - |> Expect.equal actual expected -] - -let booleanTests context = [ - testCase "Executing copy kernel on boolean array should not raise exception" <| fun () -> - let inputArray = Array.create 100_000 true - let inputArrayLength = inputArray.Length - let copy = - <@ - fun (ndRange: Range1D) - (inputArrayBuffer: bool clarray) - (outputArrayBuffer: bool clarray) -> - - let i = ndRange.GlobalID0 - if i < inputArrayLength then - outputArrayBuffer.[i] <- inputArrayBuffer.[i] - @> - - let actual = - opencl { - use! input = ClArray.toDevice inputArray - use! output = ClArray.alloc 100_000 - do! runCommand copy <| fun x -> - x - <| Range1D.CreateValid(inputArray.Length, 256) - <| input - <| output - - return! ClArray.toHost output - } - |> ClTask.runSync context - - "Arrays should be equal" - |> Expect.sequenceEqual actual inputArray - - testProperty "'lor' on boolean type should work correctly" <| fun (array: bool[]) -> - if array.Length <> 0 then - let reversed = Seq.rev array |> Seq.toArray - let inputArrayLength = array.Length - let command = - <@ - fun (ndRange: Range1D) - (array: bool clarray) - (reversed: bool clarray) -> - - let i = ndRange.GlobalID0 - if i < inputArrayLength then - array.[i] <- array.[i] || reversed.[i] || false - @> - - let expected = - (array, reversed) - ||> Array.zip - |> Array.map (fun (x, y) -> x || y) - - let actual = - opencl { - use! array' = ClArray.toDevice array - use! reversed' = ClArray.toDevice reversed - do! runCommand command <| fun x -> - x - <| Range1D.CreateValid(inputArrayLength, 256) - <| array' - <| reversed' - - return! ClArray.toHost array' - } - |> ClTask.runSync context - - "Arrays should be equal" - |> Expect.sequenceEqual actual expected - - testProperty "'land' on boolean type should work correctly" <| fun (array: bool[]) -> - if array.Length <> 0 then - let reversed = Seq.rev array |> Seq.toArray - let inputArrayLength = array.Length - let command = - <@ - fun (ndRange: Range1D) - (array: bool clarray) - (reversed: bool clarray) -> - - let i = ndRange.GlobalID0 - if i < inputArrayLength then - array.[i] <- array.[i] && reversed.[i] && true - @> - - let expected = - (array, reversed) - ||> Array.zip - |> Array.map (fun (x, y) -> x && y) - - let actual = - opencl { - use! array' = ClArray.toDevice array - use! reversed' = ClArray.toDevice reversed - do! runCommand command <| fun x -> - x - <| Range1D.CreateValid(inputArrayLength, 256) - <| array' - <| reversed' - - return! ClArray.toHost array' - } - |> ClTask.runSync context - - "Arrays should be equal" - |> Expect.sequenceEqual actual expected -] - -let parallelExecutionTests context = [ - testCase "Running tasks in parallel should not raise exception" <| fun () -> - let fill = opencl { - let kernel = - <@ - fun (range: Range1D) (buffer: int clarray) -> - let i = range.GlobalID0 - buffer.[i] <- 1 - @> - - use! array = ClArray.alloc 256 - do! runCommand kernel <| fun x -> - x - <| Range1D.CreateValid(256, 256) - <| array - - return! ClArray.toHost array - } - - let expected = Array.replicate 3 (Array.create 256 1) - - let actual = - opencl { - return! - List.replicate 3 fill - |> ClTask.inParallel - } - |> ClTask.runSync context - - "Arrays should be equal" - |> Expect.sequenceEqual actual expected - - // TODO check if it really faster -] + // TODO check if it really faster + ] type Option1 = | None1 | Some1 of int -let simpleDUTests context = [ - testCase "Option with F#-native syntax" <| fun () -> - let rnd = System.Random() - let input1 = Array.init 100_000 (fun i -> rnd.Next()) - let input2 = Array.init 100_000 (fun i -> rnd.Next()) - let inputArrayLength = input1.Length - let add (op:Expr -> Option -> Option>) = - <@ - fun (ndRange: Range1D) - (input1: int clarray) - (input2: int clarray) - (output: int clarray) -> - - let i = ndRange.GlobalID0 - if i < inputArrayLength then - let x = if input1.[i] < 0 then None else Some input1.[i] - let y = if input2.[i] < 0 then None else Some input2.[i] - output.[i] <- match (%op) x y with Some x -> x | None -> 0 - @> - - let actual = - opencl { - use! input1 = ClArray.toDevice input1 - use! input2 = ClArray.toDevice input2 - use! output = ClArray.alloc 100_000 - let op = - <@ fun x y -> - match x with - | Some x -> match y with Some y -> Some (x + y) | None -> Some x - | None -> match y with Some y -> Some y | None -> None - @> - - do! runCommand (add op) <| fun x -> - x - <| Range1D.CreateValid(input1.Length, 256) - <| input1 - <| input2 - <| output - - return! ClArray.toHost output - } - |> ClTask.runSync context - - let expected = - (input1, input2) - ||> Array.map2 - (fun x y -> - if x < 0 then - if y < 0 then 0 else y - else - x + y - ) - - "Arrays should be equal" - |> Expect.sequenceEqual actual expected - - testCase "Option with simplified syntax" <| fun () -> - let rnd = System.Random() - let input1 = Array.init 100_000 (fun i -> rnd.Next()) - let input2 = Array.init 100_000 (fun i -> rnd.Next()) - let inputArrayLength = input1.Length - let add (op:Expr -> Option -> Option>) = - <@ - fun (ndRange: Range1D) - (input1: int clarray) - (input2: int clarray) - (output: int clarray) -> - - let i = ndRange.GlobalID0 - if i < inputArrayLength then - let mutable x = None - let mutable y = None - if input1.[i] >= 0 then x <- Some input1.[i] - if input2.[i] >= 0 then y <- Some input2.[i] - match (%op) x y with - | Some x -> output.[i] <- x - | None -> output.[i] <- 0 - @> - - let actual = - opencl { - use! input1 = ClArray.toDevice input1 - use! input2 = ClArray.toDevice input2 - use! output = ClArray.alloc 100_000 - let op = - <@ fun x y -> - match x, y with - | Some x, Some y -> Some (x + y) - | Some x, None -> Some x - | None, Some y -> Some y - | None, None -> None - @> - - do! runCommand (add op) <| fun x -> - x - <| Range1D.CreateValid(input1.Length, 256) - <| input1 - <| input2 - <| output - - return! ClArray.toHost output - } - |> ClTask.runSync context - - let expected = - (input1, input2) - ||> Array.map2 - (fun x y -> - if x < 0 then - if y < 0 then 0 else y - else - x + y - ) - - "Arrays should be equal" - |> Expect.sequenceEqual actual expected - - testCase "Simple custom non-generic DU" <| fun () -> - let rnd = System.Random() - let input1 = Array.init 100_000 (fun i -> rnd.Next()) - let input2 = Array.init 100_000 (fun i -> rnd.Next()) - let inputArrayLength = input1.Length - let add (op:Expr Option1 -> Option1>) = - <@ - fun (ndRange: Range1D) - (input1: int clarray) - (input2: int clarray) - (output: int clarray) -> - - let i = ndRange.GlobalID0 - if i < inputArrayLength then - let mutable x = None1 - let mutable y = None1 - if input1.[i] >= 0 then x <- Some1 input1.[i] - if input2.[i] >= 0 then y <- Some1 input2.[i] - let z = (%op) x y - match z with - | Some1 x -> output.[i] <- x - | None1 -> output.[i] <- 0 - @> - - let actual = - opencl { - use! input1 = ClArray.toDevice input1 - use! input2 = ClArray.toDevice input2 - use! output = ClArray.alloc 100_000 - let op = - <@ fun x y -> - match x with - | Some1 x -> match y with Some1 y -> Some1 (x + y) | None1 -> Some1 x - | None1 -> match y with Some1 y -> Some1 y | None1 -> None1 - @> - - do! runCommand (add op) <| fun x -> - x - <| Range1D.CreateValid(input1.Length, 256) - <| input1 - <| input2 - <| output - - return! ClArray.toHost output - } - |> ClTask.runSync context - - let expected = - (input1, input2) - ||> Array.map2 - (fun x y -> - if x < 0 then - if y < 0 then 0 else y - else - x + y - ) - - "Arrays should be equal" - |> Expect.sequenceEqual actual expected -] +let simpleDUTests context = + [ testCase "Option with F#-native syntax" + <| fun () -> + let rnd = System.Random() + let input1 = Array.init 100_000 (fun i -> rnd.Next()) + let input2 = Array.init 100_000 (fun i -> rnd.Next()) + let inputArrayLength = input1.Length + + let add (op: Expr -> Option -> Option>) = + <@ + fun (ndRange: Range1D) (input1: int clarray) (input2: int clarray) (output: int clarray) -> + + let i = ndRange.GlobalID0 + + if i < inputArrayLength then + let x = if input1.[i] < 0 then None else Some input1.[i] + let y = if input2.[i] < 0 then None else Some input2.[i] + + output.[i] <- + match (%op) x y with + | Some x -> x + | None -> 0 + @> + + let actual = + opencl { + use! input1 = ClArray.toDevice input1 + use! input2 = ClArray.toDevice input2 + use! output = ClArray.alloc 100_000 + + let op = + <@ + fun x y -> + match x with + | Some x -> + match y with + | Some y -> Some(x + y) + | None -> Some x + | None -> + match y with + | Some y -> Some y + | None -> None + @> + + do! + runCommand (add op) + <| fun x -> x <| Range1D.CreateValid(input1.Length, 256) <| input1 <| input2 <| output + + return! ClArray.toHost output + } + |> ClTask.runSync context + + let expected = + (input1, input2) + ||> Array.map2 (fun x y -> + if x < 0 then + if y < 0 then 0 else y + else + x + y) + + "Arrays should be equal" |> Expect.sequenceEqual actual expected + + testCase "Option with simplified syntax" + <| fun () -> + let rnd = System.Random() + let input1 = Array.init 100_000 (fun i -> rnd.Next()) + let input2 = Array.init 100_000 (fun i -> rnd.Next()) + let inputArrayLength = input1.Length + + let add (op: Expr -> Option -> Option>) = + <@ + fun (ndRange: Range1D) (input1: int clarray) (input2: int clarray) (output: int clarray) -> + + let i = ndRange.GlobalID0 + + if i < inputArrayLength then + let mutable x = None + let mutable y = None + + if input1.[i] >= 0 then + x <- Some input1.[i] + + if input2.[i] >= 0 then + y <- Some input2.[i] + + match (%op) x y with + | Some x -> output.[i] <- x + | None -> output.[i] <- 0 + @> + + let actual = + opencl { + use! input1 = ClArray.toDevice input1 + use! input2 = ClArray.toDevice input2 + use! output = ClArray.alloc 100_000 + + let op = + <@ + fun x y -> + match x, y with + | Some x, Some y -> Some(x + y) + | Some x, None -> Some x + | None, Some y -> Some y + | None, None -> None + @> + + do! + runCommand (add op) + <| fun x -> x <| Range1D.CreateValid(input1.Length, 256) <| input1 <| input2 <| output + + return! ClArray.toHost output + } + |> ClTask.runSync context + + let expected = + (input1, input2) + ||> Array.map2 (fun x y -> + if x < 0 then + if y < 0 then 0 else y + else + x + y) + + "Arrays should be equal" |> Expect.sequenceEqual actual expected + + testCase "Simple custom non-generic DU" + <| fun () -> + let rnd = System.Random() + let input1 = Array.init 100_000 (fun i -> rnd.Next()) + let input2 = Array.init 100_000 (fun i -> rnd.Next()) + let inputArrayLength = input1.Length + + let add (op: Expr Option1 -> Option1>) = + <@ + fun (ndRange: Range1D) (input1: int clarray) (input2: int clarray) (output: int clarray) -> + + let i = ndRange.GlobalID0 + + if i < inputArrayLength then + let mutable x = None1 + let mutable y = None1 + + if input1.[i] >= 0 then + x <- Some1 input1.[i] + + if input2.[i] >= 0 then + y <- Some1 input2.[i] + + let z = (%op) x y + + match z with + | Some1 x -> output.[i] <- x + | None1 -> output.[i] <- 0 + @> + + let actual = + opencl { + use! input1 = ClArray.toDevice input1 + use! input2 = ClArray.toDevice input2 + use! output = ClArray.alloc 100_000 + + let op = + <@ + fun x y -> + match x with + | Some1 x -> + match y with + | Some1 y -> Some1(x + y) + | None1 -> Some1 x + | None1 -> + match y with + | Some1 y -> Some1 y + | None1 -> None1 + @> + + do! + runCommand (add op) + <| fun x -> x <| Range1D.CreateValid(input1.Length, 256) <| input1 <| input2 <| output + + return! ClArray.toHost output + } + |> ClTask.runSync context + + let expected = + (input1, input2) + ||> Array.map2 (fun x y -> + if x < 0 then + if y < 0 then 0 else y + else + x + y) + + "Arrays should be equal" |> Expect.sequenceEqual actual expected ] [] type StructWithOverridedConstructors = @@ -1634,20 +2155,19 @@ type StructWithOverridedConstructors = //] let tests context = - [ - testList "Simple tests on primitive types" << smokeTestsOnPrimitiveTypes - testList "Type castings tests" << typeCastingTests - testList "Bindings tests" << bindingTests - testList "Operators and math functions tests" << operatorsAndMathFunctionsTests - testList "Control flow tests" << controlFlowTests - testList "Kernel arguments tests" << kernelArgumentsTests - testList "Quotation injection tests" << quotationInjectionTests - testList "Local memory tests" << localMemTests - testList "Let Transformation Tests" << letTransformationTests - testList "Let Transformation Tests Mutable Vars" << letQuotationTransformerSystemTests - testList "Common Api Tests" << commonApiTests - testList "Boolean Tests" << booleanTests - ptestList "Parallel Execution Tests" << parallelExecutionTests - testList "Simple tests on discriminated unions" << simpleDUTests - ] + [ testList "Simple tests on primitive types" << smokeTestsOnPrimitiveTypes + testList "Type castings tests" << typeCastingTests + testList "Bindings tests" << bindingTests + testList "Operators and math functions tests" << operatorsAndMathFunctionsTests + testList "Control flow tests" << controlFlowTests + testList "Kernel arguments tests" << kernelArgumentsTests + testList "Quotation injection tests" << quotationInjectionTests + testList "Local memory tests" << localMemTests + testList "Let Transformation Tests" << letTransformationTests + testList "Let Transformation Tests Mutable Vars" + << letQuotationTransformerSystemTests + testList "Common Api Tests" << commonApiTests + testList "Boolean Tests" << booleanTests + ptestList "Parallel Execution Tests" << parallelExecutionTests + testList "Simple tests on discriminated unions" << simpleDUTests ] |> List.map (fun testFixture -> testFixture context) diff --git a/tests/Brahma.FSharp.Tests/ExecutionTests/WorkflowBuilderTests.fs b/tests/Brahma.FSharp.Tests/ExecutionTests/WorkflowBuilderTests.fs index 202dca1d..269191bf 100644 --- a/tests/Brahma.FSharp.Tests/ExecutionTests/WorkflowBuilderTests.fs +++ b/tests/Brahma.FSharp.Tests/ExecutionTests/WorkflowBuilderTests.fs @@ -14,166 +14,216 @@ module Helpers = let! res = ClArray.alloc<'b> input.Length let code = - <@ fun (range: Range1D) (input: 'a clarray) (output: 'b clarray) -> - let idx = range.GlobalID0 - output.[idx] <- (%f) input.[idx] @> + <@ + fun (range: Range1D) (input: 'a clarray) (output: 'b clarray) -> + let idx = range.GlobalID0 + output.[idx] <- (%f) input.[idx] + @> - do! runCommand code <| fun x -> - x - <| Range1D input.Length - <| input - <| res + do! runCommand code <| fun x -> x <| Range1D input.Length <| input <| res return res } -let bindTests context = [ - testCase "Test 1" <| fun _ -> - let xs = [| 1; 2; 3; 4 |] - - let workflow = - opencl { - use! xs' = ClArray.toDevice xs - use! ys = gpuMap <@ fun x -> x * x + 10 @> xs' - use! zs = gpuMap <@ fun x -> x + 1 @> ys - return! ClArray.toHost zs - } - - let output = ClTask.runSync context workflow - Expect.equal output [| 12; 15; 20; 27 |] eqMsg - - testCase "'use!' should free resources after all" <| fun () -> - let log = ResizeArray() - - opencl { - use! resource = opencl { - return - { new System.IDisposable with - member this.Dispose() = log.Add "disposed" - } - } - - do! opencl { return log.Add "1" } - return! opencl { log.Add "2" } - } - |> ClTask.runSync context - - "Last value should be 'disposed'" - |> Expect.isTrue (log.[log.Count - 1] = "disposed") -] - -let loopTests context = [ - testCase "While. Test 1. Without evaluation" <| fun _ -> - let mutable log : int list = [] - - let workflow = - opencl { - let mutable i = 0 - log <- i :: log - - while i < 10 do - i <- i + 1 - log <- i :: log - } - - Expect.equal log [] "Delay should prevent any computations before evaluation started" - ClTask.runSync context workflow - Expect.equal log [ 10 .. -1 .. 0 ] eqMsg - - testCase "While. Test 2. Simple evaluation" <| fun _ -> - let mutable xs = [| 1; 2; 3; 4; 5; 6; 7; 8 |] - let iters = 5 - let expected = Array.map (fun x -> pown 2 iters * x) xs - - // TODO change to use copyTo - let workflow = - opencl { - let f = <@ fun x -> x * 2 @> - - let mutable i = 0 - - let! xs' = ClArray.toDevice xs - let mutable tmp = xs' - while i < iters do - let! res = gpuMap f tmp - do! ClArray.close tmp - tmp <- res - i <- i + 1 - - let! res = ClArray.toHost tmp - do! ClArray.close tmp - - return res - } - - let output = ClTask.runSync context workflow - Expect.equal output expected eqMsg - - testCase "While. Test 3. Do inside body of while loop" <| fun _ -> - let gpuMapInplace f (xs: int clarray ref) = - opencl { - let! res = gpuMap f !xs - do! ClArray.close !xs - xs := res - } - - let workflow = - opencl { - let! xs = ClArray.toDevice [| 1; 2; 3; 4 |] - let xs = ref xs - - let mutable i = 0 - - while i < 10 do - do! gpuMapInplace <@ fun x -> x + 1 @> xs - i <- i + 1 - - return! ClArray.toHost !xs - } - - let output = ClTask.runSync context workflow - Expect.equal output [| 11; 12; 13; 14 |] eqMsg - - testCase "For. Test 1. Without evaluation" <| fun _ -> - let log = List() - - let workflow = - opencl { - log.Add(0) - - for x in [ 1 .. 10 ] do - log.Add(x) - } - - Expect.sequenceEqual log - <| List() - <| "Delay should prevent any computations before evaluation started" - - ClTask.runSync context workflow - Expect.sequenceEqual log (List([ 0 .. 10 ])) eqMsg - - testCase "For. Test 2. Simple evaluation" <| fun _ -> - let workflow = - opencl { - let xs = [| 1; 2; 3; 4 |] - let! xs' = ClArray.toDevice xs - let mutable tmp = xs' - - for y in [| 10; 20; 30 |] do - let! res = gpuMap <@ fun x -> x + y @> tmp - do! ClArray.close tmp - tmp <- res - - return! ClArray.toHost tmp - } - - let output = ClTask.runSync context workflow - Expect.equal output [| 61; 62; 63; 64 |] eqMsg -] +let bindTests context = + [ testCase "Test 1" + <| fun _ -> + let xs = + [| 1 + 2 + 3 + 4 |] + + let workflow = + opencl { + use! xs' = ClArray.toDevice xs + use! ys = gpuMap <@ fun x -> x * x + 10 @> xs' + use! zs = gpuMap <@ fun x -> x + 1 @> ys + return! ClArray.toHost zs + } + + let output = ClTask.runSync context workflow + + Expect.equal + output + [| 12 + 15 + 20 + 27 |] + eqMsg + + testCase "'use!' should free resources after all" + <| fun () -> + let log = ResizeArray() + + opencl { + use! resource = + opencl { + return + { new System.IDisposable with + member this.Dispose() = log.Add "disposed" } + } + + do! opencl { return log.Add "1" } + return! opencl { log.Add "2" } + } + |> ClTask.runSync context + + "Last value should be 'disposed'" + |> Expect.isTrue (log.[log.Count - 1] = "disposed") ] + +let loopTests context = + [ testCase "While. Test 1. Without evaluation" + <| fun _ -> + let mutable log: int list = [] + + let workflow = + opencl { + let mutable i = 0 + log <- i :: log + + while i < 10 do + i <- i + 1 + log <- i :: log + } + + Expect.equal log [] "Delay should prevent any computations before evaluation started" + ClTask.runSync context workflow + Expect.equal log [ 10..-1..0 ] eqMsg + + testCase "While. Test 2. Simple evaluation" + <| fun _ -> + let mutable xs = + [| 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 |] + + let iters = 5 + let expected = Array.map (fun x -> pown 2 iters * x) xs + + // TODO change to use copyTo + let workflow = + opencl { + let f = <@ fun x -> x * 2 @> + + let mutable i = 0 + + let! xs' = ClArray.toDevice xs + let mutable tmp = xs' + + while i < iters do + let! res = gpuMap f tmp + do! ClArray.close tmp + tmp <- res + i <- i + 1 + + let! res = ClArray.toHost tmp + do! ClArray.close tmp + + return res + } + + let output = ClTask.runSync context workflow + Expect.equal output expected eqMsg + + testCase "While. Test 3. Do inside body of while loop" + <| fun _ -> + let gpuMapInplace f (xs: int clarray ref) = + opencl { + let! res = gpuMap f !xs + do! ClArray.close !xs + xs := res + } + + let workflow = + opencl { + let! xs = + ClArray.toDevice + [| 1 + 2 + 3 + 4 |] + + let xs = ref xs + + let mutable i = 0 + + while i < 10 do + do! gpuMapInplace <@ fun x -> x + 1 @> xs + i <- i + 1 + + return! ClArray.toHost !xs + } + + let output = ClTask.runSync context workflow + + Expect.equal + output + [| 11 + 12 + 13 + 14 |] + eqMsg + + testCase "For. Test 1. Without evaluation" + <| fun _ -> + let log = List() + + let workflow = + opencl { + log.Add(0) + + for x in [ 1..10 ] do + log.Add(x) + } + + Expect.sequenceEqual log + <| List() + <| "Delay should prevent any computations before evaluation started" + + ClTask.runSync context workflow + Expect.sequenceEqual log (List([ 0..10 ])) eqMsg + + testCase "For. Test 2. Simple evaluation" + <| fun _ -> + let workflow = + opencl { + let xs = + [| 1 + 2 + 3 + 4 |] + + let! xs' = ClArray.toDevice xs + let mutable tmp = xs' + + for y in + [| 10 + 20 + 30 |] do + let! res = gpuMap <@ fun x -> x + y @> tmp + do! ClArray.close tmp + tmp <- res + + return! ClArray.toHost tmp + } + + let output = ClTask.runSync context workflow + + Expect.equal + output + [| 61 + 62 + 63 + 64 |] + eqMsg ] let tests context = - [ - testList "Simple bind tests" << bindTests - testList "Loop tests" << loopTests - ] + [ testList "Simple bind tests" << bindTests + testList "Loop tests" << loopTests ] |> List.map (fun testFixture -> testFixture context) diff --git a/tests/Brahma.FSharp.Tests/Program.fs b/tests/Brahma.FSharp.Tests/Program.fs index d81420a5..558e91d9 100644 --- a/tests/Brahma.FSharp.Tests/Program.fs +++ b/tests/Brahma.FSharp.Tests/Program.fs @@ -1,15 +1,15 @@ open Expecto +open Brahma.FSharp.Tests + [] let allTests = - testList "All tests" [ - testList "Translation tests" TranslationTests.tests - testList "Execution tests" ExecutionTests.tests - ] + testList + "All tests" + [ Translator.All.tests] |> testSequenced +open System.IO [] -let main argv = - allTests - |> runTestsWithCLIArgs [] argv +let main argv = allTests |> runTestsWithCLIArgs [] argv diff --git a/tests/Brahma.FSharp.Tests/TranslationTests.fs b/tests/Brahma.FSharp.Tests/TranslationTests.fs deleted file mode 100644 index 1396355f..00000000 --- a/tests/Brahma.FSharp.Tests/TranslationTests.fs +++ /dev/null @@ -1,8 +0,0 @@ -module TranslationTests - -open Brahma.FSharp.OpenCL.Translator -open Expecto - -let translators = [ - FSQuotationToOpenCLTranslator.CreateDefault() -] diff --git a/tests/Brahma.FSharp.Tests/Translator/All.fs b/tests/Brahma.FSharp.Tests/Translator/All.fs new file mode 100644 index 00000000..bbdef9fb --- /dev/null +++ b/tests/Brahma.FSharp.Tests/Translator/All.fs @@ -0,0 +1,39 @@ +module Brahma.FSharp.Tests.Translator.All + +open Brahma.FSharp.OpenCL.Translator +open Brahma.FSharp.Tests.Translator +open Expecto + +let translator = FSQuotationToOpenCLTranslator.CreateDefault() + +let private common translator = + [ BinOp.tests + ControlFlow.tests + NamesResolving.tests + ConstantArray.tests + LambdaLifting.tests + Carrying.tests + Injection.tests + Printf.tests + + Specific.MergePath.tests ] + |> List.map (fun f -> f translator) + |> testList "Common" + +let private union _ = + [ Union.tests ] + |> testList "Union" + +let private transformation translator = + [ QuatationTransformation.Transformation.tests + QuatationTransformation.LambdaLifting.tests + QuatationTransformation.VarDefsToLambda.tests ] + |> List.map (fun f -> f translator) + |> testList "Transformation" + +let tests = + [ common + union + transformation ] + |> List.map (fun f -> f translator) + |> testList "Translator" diff --git a/tests/Brahma.FSharp.Tests/Translator/BinaryOperations/Expected/Array.Item.Set.cl b/tests/Brahma.FSharp.Tests/Translator/BinOp/Expected/Array.Item.Set.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/Translator/BinaryOperations/Expected/Array.Item.Set.cl rename to tests/Brahma.FSharp.Tests/Translator/BinOp/Expected/Array.Item.Set.cl diff --git a/tests/Brahma.FSharp.Tests/Translator/BinaryOperations/Expected/Binary.Operations.Math.cl b/tests/Brahma.FSharp.Tests/Translator/BinOp/Expected/Binary.Operations.Math.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/Translator/BinaryOperations/Expected/Binary.Operations.Math.cl rename to tests/Brahma.FSharp.Tests/Translator/BinOp/Expected/Binary.Operations.Math.cl diff --git a/tests/Brahma.FSharp.Tests/Translator/BinaryOperations/Expected/Binding.cl b/tests/Brahma.FSharp.Tests/Translator/BinOp/Expected/Binding.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/Translator/BinaryOperations/Expected/Binding.cl rename to tests/Brahma.FSharp.Tests/Translator/BinOp/Expected/Binding.cl diff --git a/tests/Brahma.FSharp.Tests/Translator/BinaryOperations/Expected/Binop.Plus.cl b/tests/Brahma.FSharp.Tests/Translator/BinOp/Expected/Binop.Plus.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/Translator/BinaryOperations/Expected/Binop.Plus.cl rename to tests/Brahma.FSharp.Tests/Translator/BinOp/Expected/Binop.Plus.cl diff --git a/tests/Brahma.FSharp.Tests/Translator/BinaryOperations/Expected/MAX.Transformation.cl b/tests/Brahma.FSharp.Tests/Translator/BinOp/Expected/MAX.Transformation.cl similarity index 100% rename from tests/Brahma.FSharp.Tests/Translator/BinaryOperations/Expected/MAX.Transformation.cl rename to tests/Brahma.FSharp.Tests/Translator/BinOp/Expected/MAX.Transformation.cl diff --git a/tests/Brahma.FSharp.Tests/Translator/BinOp/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/BinOp/Tests.fs new file mode 100644 index 00000000..bcbf26cc --- /dev/null +++ b/tests/Brahma.FSharp.Tests/Translator/BinOp/Tests.fs @@ -0,0 +1,47 @@ +module Brahma.FSharp.Tests.Translator.BinOp + +open Brahma.FSharp +open Brahma.FSharp.Tests.Translator.Common +open System.IO +open Expecto + +let private basePath = Path.Combine("Translator", "BinOp", "Expected") + +let private basicBinOpsTests translator = + [ let inline createTest name = + Helpers.createTest translator basePath name + + <@ fun (range: Range1D) (buf: int clarray) -> buf.[0] <- 0 @> + |> createTest "Array item set" "Array.Item.Set.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + let x = 1 + buf.[0] <- x + @> + |> createTest "Binding" "Binding.cl" + + <@ fun (range: Range1D) (buf: int clarray) -> buf.[0] <- 1 + 2 @> + |> createTest "Binop plus" "Binop.Plus.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + let x = 0 + let y = x + 1 + let z = y * 2 + let a = z - x + let i = a / 2 + buf.[0] <- i + @> + |> createTest "Binary operations. Math." "Binary.Operations.Math.cl" + + <@ + fun (range: Range1D) (buf: float clarray) -> + let tempVarY = 1. + buf.[0] <- max buf.[0] tempVarY + buf.[0] <- max buf.[0] tempVarY + @> + |> createTest "TempVar from MAX transformation should not affect other variables" "MAX.Transformation.cl" ] + +let tests translator = + basicBinOpsTests translator |> testList "BinaryOperations" diff --git a/tests/Brahma.FSharp.Tests/Translator/BinaryOperations/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/BinaryOperations/Tests.fs deleted file mode 100644 index 75080a9d..00000000 --- a/tests/Brahma.FSharp.Tests/Translator/BinaryOperations/Tests.fs +++ /dev/null @@ -1,52 +0,0 @@ -module Brahma.FSharp.Tests.Translator.BinaryOperations.Tests - -open Expecto -open Brahma.FSharp -open Brahma.FSharp.Tests.Translator.Common - -let basicBinOpsTests translator = [ - let checkCode command = Helpers.checkCode translator command - - testCase "Array item set" <| fun _ -> - let command = <@ fun (range: Range1D) (buf: int clarray) -> buf.[0] <- 0 @> - - checkCode command "Array.Item.Set.gen" "Array.Item.Set.cl" - - testCase "Binding" <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let x = 1 - buf.[0] <- x - @> - - checkCode command "Binding.gen" "Binding.cl" - - testCase "Binop plus" <| fun _ -> - let command = <@ fun (range: Range1D) (buf: int clarray) -> buf.[0] <- 1 + 2 @> - - checkCode command "Binop.Plus.gen" "Binop.Plus.cl" - - testCase "Binary operations. Math." <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let x = 0 - let y = x + 1 - let z = y * 2 - let a = z - x - let i = a / 2 - buf.[0] <- i - @> - - checkCode command "Binary.Operations.Math.gen" "Binary.Operations.Math.cl" - - testCase "TempVar from MAX transformation should not affect other variables" <| fun () -> - let command = - <@ - fun (range: Range1D) (buf: float clarray) -> - let tempVarY = 1. - buf.[0] <- max buf.[0] tempVarY - buf.[0] <- max buf.[0] tempVarY - @> - - checkCode command "MAX.Transformation.gen" "MAX.Transformation.cl" -] diff --git a/tests/Brahma.FSharp.Tests/Translator/Carrying/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/Carrying/Tests.fs index 9d4ceaf6..7cfd4ed1 100644 --- a/tests/Brahma.FSharp.Tests/Translator/Carrying/Tests.fs +++ b/tests/Brahma.FSharp.Tests/Translator/Carrying/Tests.fs @@ -1,38 +1,41 @@ -module Brahma.FSharp.Tests.Translator.Carrying.Tests +module Brahma.FSharp.Tests.Translator.Carrying open Brahma.FSharp -open Expecto open Brahma.FSharp.Tests.Translator.Common +open System.IO +open Expecto + +let private basePath = Path.Combine("Translator", "Carrying", "Expected") -let curryingTests translator = [ - let inline checkCode cmd outFile expected = checkCode translator cmd outFile expected +let private curryingTests translator = + [ let inline createTest name = Helpers.createTest translator basePath name - testCase "Nested functions.Carring 1." <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let f x y = x - y - let g = f 2 - buf.[0] <- g 3 - buf.[1] <- g 5 - @> + <@ + fun (range: Range1D) (buf: int clarray) -> + let f x y = x - y + let g = f 2 + buf.[0] <- g 3 + buf.[1] <- g 5 + @> + |> createTest "Nested functions.Carrying 1." "Nested.Function.Carring.cl" - checkCode command "Nested.Function.Carring.gen" "Nested.Function.Carring.cl" + <@ + fun (range: Range1D) (buf: int clarray) -> + let f x y = + let gg = ref 0 - testCase "Nested functions.Currying 2." <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let f x y = - let gg = ref 0 + for i in 1..x do + gg := !gg + y - for i in 1 .. x do - gg := !gg + y + !gg - !gg + let g x = f 2 x + buf.[0] <- g 2 + buf.[1] <- g 3 + @> + |> createTest "Nested functions.Currying 2." "Nested.Function.Carring2.cl" ] - let g x = f 2 x - buf.[0] <- g 2 - buf.[1] <- g 3 - @> +let tests translator = + curryingTests translator + |> testList "Currying" - checkCode command "Nested.Function.Carring2.gen" "Nested.Function.Carring2.cl" -] diff --git a/tests/Brahma.FSharp.Tests/Translator/Common.fs b/tests/Brahma.FSharp.Tests/Translator/Common.fs index 044fc63c..c088b4be 100644 --- a/tests/Brahma.FSharp.Tests/Translator/Common.fs +++ b/tests/Brahma.FSharp.Tests/Translator/Common.fs @@ -1,7 +1,6 @@ module Brahma.FSharp.Tests.Translator.Common open Expecto -open Brahma.FSharp.Tests open System.IO open Brahma.FSharp.OpenCL.Printer open Brahma.FSharp.OpenCL.Translator @@ -9,18 +8,31 @@ open FSharp.Quotations [] module Helpers = - let basePath = "TranslationTests/Expected/" - let openclTranslate (translator: FSQuotationToOpenCLTranslator) (expr: Expr) = - translator.Translate expr - |> fst - |> AST.print + translator.Translate expr |> fst |> AST.print + + let compareCodeAndFile actualCode pathToExpectedCode = + let expectedCode = + (File.ReadAllText pathToExpectedCode).Trim().Replace("\r\n", "\n") + + let actualCode = (actualCode: string).Trim().Replace("\r\n", "\n") + + Expect.equal actualCode expectedCode <| "Code must be the same." + + let checkCode translator quotation pathToExpectedCode = + let actualCode = quotation |> openclTranslate translator + + compareCodeAndFile actualCode pathToExpectedCode - let checkCode translator command outFile expected = - let code = command |> openclTranslate translator + let printfStandard code = + let translator = FSQuotationToOpenCLTranslator.CreateDefault() - let expectedPath = Path.Combine(basePath, expected) - // read from file + openclTranslate translator code + |> fun code -> code.Trim().Replace("\r\n", "\n") + |> printfn "%A" - Utils.filesAreEqual "targetPath" expectedPath + // create tests* + let inline createTest translator basePath name expectedFileName quotation = + test name { checkCode translator quotation <| Path.Combine(basePath, expectedFileName) } + let inline createPTest name = ptest name { () } diff --git a/tests/Brahma.FSharp.Tests/Translator/ConstantArray/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/ConstantArray/Tests.fs index ff9259dc..a57f868f 100644 --- a/tests/Brahma.FSharp.Tests/Translator/ConstantArray/Tests.fs +++ b/tests/Brahma.FSharp.Tests/Translator/ConstantArray/Tests.fs @@ -1,19 +1,32 @@ -module Brahma.FSharp.Tests.Translator.ConstantArray.Tests +module Brahma.FSharp.Tests.Translator.ConstantArray -open Expecto open Brahma.FSharp open Brahma.FSharp.Tests.Translator.Common +open System.IO +open Expecto + +let private basePath = Path.Combine("Translator", "ConstantArray", "Expected") + +let private constantArrayTests translator = + [ let inline createTest name = + Helpers.createTest translator basePath name + + let cArray1 = + [| 1 + 2 + 3 |] + + <@ fun (range: Range1D) (buf: int clarray) -> buf.[0] <- cArray1.[1] @> + |> createTest "Constant array translation. Test 1" "Constant array translation. Test 1.cl" -let constantArrayTests translator = [ - let inline checkCode cmd outFile expected = checkCode translator cmd outFile expected + let cArray1 = + [| 1 + 2 + 3 |] - testCase "Constant array translation. Test 1" <| fun _ -> - let cArray1 = [| 1; 2; 3 |] - let command = <@ fun (range: Range1D) (buf: int clarray) -> buf.[0] <- cArray1.[1] @> - checkCode command "Constant array translation. Test 1.gen" "Constant array translation. Test 1.cl" + <@ fun (range: Range1D) (buf: int clarray) -> buf.[0] <- 1 + cArray1.[1] @> + |> createTest "Constant array translation. Test 2" "Constant array translation. Test 2.cl" ] - testCase "Constant array translation. Test 2" <| fun _ -> - let cArray1 = [| 1; 2; 3 |] - let command = <@ fun (range: Range1D) (buf: int clarray) -> buf.[0] <- 1 + cArray1.[1] @> - checkCode command "Constant array translation. Test 2.gen" "Constant array translation. Test 2.cl" -] +let tests translator = + constantArrayTests translator + |> testList "ConstantArray" diff --git a/tests/Brahma.FSharp.Tests/Translator/ControlFlow/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/ControlFlow/Tests.fs index b24e4add..ac389c7e 100644 --- a/tests/Brahma.FSharp.Tests/Translator/ControlFlow/Tests.fs +++ b/tests/Brahma.FSharp.Tests/Translator/ControlFlow/Tests.fs @@ -1,95 +1,108 @@ -module Brahma.FSharp.Tests.Translator.ControlFlow.Tests +module Brahma.FSharp.Tests.Translator.ControlFlow open Brahma.FSharp -open Expecto open Brahma.FSharp.Tests.Translator.Common +open System.IO +open Expecto +open Brahma.FSharp.OpenCL.Translator + +let private basePath = Path.Combine("Translator", "ControlFlow", "Expected") + +let private controlFlowTests translator = + [ let inline createTest name = Helpers.createTest translator basePath name + + let inline createPTest name _ = Helpers.createPTest name + + <@ + fun (range: Range1D) (buf: int clarray) -> + if 0 = 2 then + buf.[0] <- 1 + @> + |> createTest "If Then" "If.Then.cl" + + <@ fun (range: Range1D) (buf: int clarray) -> if 0 = 2 then buf.[0] <- 1 else buf.[0] <- 2 @> + |> createTest "If Then Else" "If.Then.Else.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + for i in 1..3 do + buf.[0] <- i + @> + |> createTest "For Integer Loop" "For.Integer.Loop.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + let x = 1 + let y = x + 1 + buf.[0] <- y + @> + |> createTest "Sequential bindings" "Sequential.Bindings.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + if 2 = 0 then + let x = 1 + buf.[0] <- x + else + let i = 2 + buf.[0] <- i + @> + |> createTest "Binding in IF." "Binding.In.IF.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + for i in 0..3 do + let x = i * i + buf.[0] <- x + @> + |> createTest "Binding in FOR." "Binding.In.FOR.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + while buf.[0] < 5 do + buf.[0] <- buf.[0] + 1 + @> + |> createTest "Simple WHILE loop." "Simple.WHILE.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + while buf.[0] < 5 do + let x = buf.[0] + 1 + buf.[0] <- x * x + @> + |> createTest "Binding in WHILE." "Binding.In.WHILE.cl" + + // WHILE with single statement in the body and this stetement is assignment of constant. + // This test translates to openCL correctly but breaks openCL compiler on ubuntu 18.04 + <@ + fun (range: Range1D) (buf: int clarray) -> + while true do + buf.[0] <- 1 + @> + |> createPTest "WHILE with single statement." + + <@ + fun (range: Range1D) (buf: int clarray) -> + while buf.[0] < 5 && (buf.[1] < 6 || buf.[2] > 2) do + buf.[0] <- 2 + buf.[0] + @> + |> createTest "WHILE with complex condition" "WHILE.with.complex.condition.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + buf.[0] <- 2 + buf.[1] <- 3 + @> + |> createTest "Simple seq." "Simple.Seq.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + let x = 2 + buf.[0] <- x + let y = 2 + buf.[1] <- y + @> + |> createTest "Seq with bindings." "Seq.With.Bindings.cl" ] -let inline createTest translator name fileName quotation = test name { - Helpers.checkCode translator quotation fileName fileName // TODO(remove out file) -} - -let controlFlowTests translator = [ - let inline createTest name = createTest translator name - - <@ fun (range: Range1D) (buf: int clarray) -> if 0 = 2 then buf.[0] <- 1 @> - |> createTest "If Then" "If.Then.cl" - - <@ fun (range: Range1D) (buf: int clarray) -> - if 0 = 2 then - buf.[0] <- 1 - else - buf.[0] <- 2 - @> - |> createTest "If Then Else" "If.Then.Else.cl" - - <@ fun (range: Range1D) (buf: int clarray) -> - for i in 1 .. 3 do - buf.[0] <- i - @> - |> createTest "For Integer Loop" "For.Integer.Loop.cl" - - <@ fun (range: Range1D) (buf: int clarray) -> - let x = 1 - let y = x + 1 - buf.[0] <- y - @> - |> createTest "Sequential bindings" "Sequential.Bindings.cl" - - <@ fun (range: Range1D) (buf: int clarray) -> - if 2 = 0 then - let x = 1 - buf.[0] <- x - else - let i = 2 - buf.[0] <- i - @> - |> createTest "Binding in IF." "Binding.In.IF.cl" - - <@ fun (range: Range1D) (buf: int clarray) -> - for i in 0 .. 3 do - let x = i * i - buf.[0] <- x - @> - |> createTest "Binding in FOR." "Binding.In.FOR.cl" - - <@ fun (range: Range1D) (buf: int clarray) -> - while buf.[0] < 5 do - buf.[0] <- buf.[0] + 1 - @> - |> createTest "Simple WHILE loop." "Simple.WHILE.cl" - - <@ fun (range: Range1D) (buf: int clarray) -> - while buf.[0] < 5 do - let x = buf.[0] + 1 - buf.[0] <- x * x - @> - |> createTest "Binding in WHILE." "Binding.In.WHILE.cl" - - // WHILE with single statement in the body and this stetement is assignment of constant. - // This test translates to openCL correctly but breaks openCL compiler on ubuntu 18.04 - <@ fun (range: Range1D) (buf: int clarray) -> - while true do - buf.[0] <- 1 - @> - |> createTest "WHILE with single statement." "WHILE.with.complex.condition.cl" - - // TODO(paths in test. Race condition?) - <@ fun (range: Range1D) (buf: int clarray) -> - while buf.[0] < 5 && (buf.[1] < 6 || buf.[2] > 2) do - buf.[0] <- 2 + buf.[0] - @> - |> createTest "WHILE with complex condition" "WHILE.with.complex.condition.cl" - - <@ fun (range: Range1D) (buf: int clarray) -> - buf.[0] <- 2 - buf.[1] <- 3 - @> - |> createTest "Simple seq." "Simple.Seq.cl" - - <@ fun (range: Range1D) (buf: int clarray) -> - let x = 2 - buf.[0] <- x - let y = 2 - buf.[1] <- y - @> - |> createTest "Seq with bindings." "Seq.With.Bindings.cl" ] +let tests translator = + controlFlowTests translator |> testList "ControlFlow" diff --git a/tests/Brahma.FSharp.Tests/Translator/Injection/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/Injection/Tests.fs index 144a7180..fb2026b8 100644 --- a/tests/Brahma.FSharp.Tests/Translator/Injection/Tests.fs +++ b/tests/Brahma.FSharp.Tests/Translator/Injection/Tests.fs @@ -1,32 +1,34 @@ -module Brahma.FSharp.Tests.Translator.Injection.Tests +module Brahma.FSharp.Tests.Translator.Injection -open Expecto open Brahma.FSharp open Brahma.FSharp.Tests.Translator.Common +open System.IO +open Expecto -let quotationsInjectionTests translator = [ - let inline checkCode cmd outFile expected = Helpers.checkCode translator cmd outFile expected - - testCase "Quotations injections 1" <| fun _ -> - let myF = <@ fun x -> x * x @> +let private basePath = Path.Combine("Translator", "Injection", "Expected") - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - buf.[0] <- (%myF) 2 - buf.[1] <- (%myF) 4 - @> +let private quotationsInjectionTests translator = + [ let inline createTest name = + Helpers.createTest translator basePath name - checkCode command "Quotations.Injections.1.gen" "Quotations.Injections.1.cl" + let myF = <@ fun x -> x * x @> - testCase "Quotations injections 2" <| fun _ -> - let myF = <@ fun x y -> x - y @> + <@ + fun (range: Range1D) (buf: int clarray) -> + buf.[0] <- (%myF) 2 + buf.[1] <- (%myF) 4 + @> + |> createTest "Quotations injections 1" "Quotations.Injections.1.cl" - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - buf.[0] <- (%myF) 2 3 - buf.[1] <- (%myF) 4 5 - @> + let myF = <@ fun x y -> x - y @> - checkCode command "Quotations.Injections.2.gen" "Quotations.Injections.2.cl" + <@ + fun (range: Range1D) (buf: int clarray) -> + buf.[0] <- (%myF) 2 3 + buf.[1] <- (%myF) 4 5 + @> + |> createTest "Quotations injections 2" "Quotations.Injections.2.cl" ] -] +let tests translator = + quotationsInjectionTests translator + |> testList "QuotationsInjection" diff --git a/tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Tests.fs index 606b1d3b..bb5deb5a 100644 --- a/tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Tests.fs +++ b/tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Tests.fs @@ -1,298 +1,263 @@ -module Brahma.FSharp.Tests.Translator.LambdaLifting.Tests +module Brahma.FSharp.Tests.Translator.LambdaLifting -open Expecto open Brahma.FSharp open Brahma.FSharp.Tests.Translator.Common +open System.IO +open Expecto -let lambdaLiftingTests translator = [ - let inline checkCode cmd outFile expected = checkCode translator cmd outFile expected - - testCase "Template Let Transformation Test 0" <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let f = 3 - buf.[0] <- f - @> - - checkCode command "Template Test 0.gen" "Template Test 0.cl" - - testCase "Template Let Transformation Test 1" <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let f = - let x = 3 - x - - buf.[0] <- f - @> - - checkCode command "Template Test 1.gen" "Template Test 1.cl" - - testCase "Template Let Transformation Test 2" <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let f = - let x = - let y = 3 - y - - x - - buf.[0] <- f - @> - - checkCode command "Template Test 2.gen" "Template Test 2.cl" - - testCase "Template Let Transformation Test 3" <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let f = - let f = 5 - f - - buf.[0] <- f - @> - - checkCode command "Template Test 3.gen" "Template Test 3.cl" - - testCase "Template Let Transformation Test 4" <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let f = - let f = - let f = 5 - f - - f - - buf.[0] <- f - @> - - checkCode command "Template Test 4.gen" "Template Test 4.cl" - - testCase "Template Let Transformation Test 5" <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let f a b = - let x y z = y + z - x a b - - buf.[0] <- f 1 7 - @> - - checkCode command "Template Test 5.gen" "Template Test 5.cl" - - testCase "Template Let Transformation Test 6" <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let f x y = - let x = x - x + y - - buf.[0] <- f 7 8 - @> - - checkCode command "Template Test 6.gen" "Template Test 6.cl" - - testCase "Template Let Transformation Test 7" <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let f y = - let x y = 6 - y - x y - - buf.[0] <- f 7 - @> - - checkCode command "Template Test 7.gen" "Template Test 7.cl" - - testCase "Template Let Transformation Test 8" <| fun _ -> - let command = - <@ fun (range: Range1D) (m: int clarray) -> - let p = m.[0] - - let x n = - let l = m.[9] - let g k = k + m.[0] + m.[1] - - let r = - let y a = - let x = 5 - n + (g 4) - let z t = m.[2] + a - t - z (a + x + l) - - y 6 - - r + m.[3] - - m.[0] <- x 7 - @> - - checkCode command "Template Test 8.gen" "Template Test 8.cl" - - testCase "Template Let Transformation Test 9" <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let x n = - let r = 8 - let h = r + n - h - - buf.[0] <- x 9 - @> - - checkCode command "Template Test 9.gen" "Template Test 9.cl" - - testCase "Template Let Transformation Test 10" <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let p = 9 - - let x n b = - let t = 0 - n + b + t - - buf.[0] <- x 7 9 - @> - - checkCode command "Template Test 10.gen" "Template Test 10.cl" - - testCase "Template Let Transformation Test 11" <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let p = 1 - - let m = - let r l = l + p - r 9 - - let z k = k + 1 - buf.[0] <- m - @> - - checkCode command "Template Test 11.gen" "Template Test 11.cl" - - testCase "Template Let Transformation Test 12" <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let f x y = - let y = y - let y = y - let g x m = m + x - g x y - - buf.[0] <- f 1 7 - @> - - checkCode command "Template Test 12.gen" "Template Test 12.cl" - - testCase "Template Let Transformation Test 13" <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let f y = - let y = y - let y = y - let g m = m + 1 - g y - - buf.[0] <- f 7 - @> - - checkCode command "Template Test 13.gen" "Template Test 13.cl" - - testCase "Template Let Transformation Test 14" <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let f (y: int) = - let y = y - let y = y - - let g (m: int) = - let g r t = r + y - t - let n o = o - (g y 2) - n 5 - - g y - - let z y = y - 2 - buf.[0] <- f (z 7) - @> - - checkCode command "Template Test 14.gen" "Template Test 14.cl" - - testCase "Template Let Transformation Test 15" <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let f y = - let Argi index = if index = 0 then buf.[1] else buf.[2] - Argi y - - buf.[0] <- f 0 - @> - - checkCode command "Template Test 15.gen" "Template Test 15.cl" - - testCase "Template Let Transformation Test 16" <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let f y = - if y = 0 then - let z a = a + 1 - z 9 - else - buf.[2] - - buf.[0] <- f 0 - @> - - checkCode command "Template Test 16.gen" "Template Test 16.cl" - - testCase "Let renamed" <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let f x = - let g = 1 + x - g - - buf.[0] <- f 1 - @> - - checkCode command "Let renamed.gen" "Let renamed.cl" - - testCase "Let renamed 2" <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let f m k = - let g q w = 1 + q + w - let t p = 7 - p - (g 1 2) - m * k / (t 53) - - buf.[0] <- f 1 4 - @> - - checkCode command "Let renamed 2.gen" "Let renamed 2.cl" - - testCase "Renamer Test" <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let f x y = - let y = y - let y = y - let g x m = m + x - g x y - - buf.[0] <- f 1 7 - @> - - checkCode command "Renamer Test.gen" "Renamer Test.cl" - - testCase "Nested functions" <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let f x y = x - y - buf.[0] <- f 2 3 - buf.[1] <- f 4 5 - @> - - checkCode command "Nested.Function.gen" "Nested.Function.cl" -] +let private basePath = Path.Combine("Translator", "LambdaLifting", "Expected") + +let private lambdaLiftingTests translator = + [ let inline createTest name = + Helpers.createTest translator basePath name + + <@ + fun (range: Range1D) (buf: int clarray) -> + let f = 3 + buf.[0] <- f + @> + |> createTest "Template Let Transformation Test 0" "Template Test 0.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + let f = + let x = 3 + x + + buf.[0] <- f + @> + |> createTest "Template Let Transformation Test 1" "Template Test 1.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + let f = + let x = + let y = 3 + y + + x + + buf.[0] <- f + @> + |> createTest "Template Let Transformation Test 2" "Template Test 2.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + let f = + let f = 5 + f + + buf.[0] <- f + @> + |> createTest "Template Let Transformation Test 3" "Template Test 3.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + let f = + let f = + let f = 5 + f + + f + + buf.[0] <- f + @> + |> createTest "Template Let Transformation Test 4" "Template Test 4.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + let f a b = + let x y z = y + z + x a b + + buf.[0] <- f 1 7 + @> + |> createTest "Template Let Transformation Test 5" "Template Test 5.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + let f x y = + let x = x + x + y + + buf.[0] <- f 7 8 + @> + |> createTest "Template Let Transformation Test 6" "Template Test 6.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + let f y = + let x y = 6 - y + x y + + buf.[0] <- f 7 + @> + |> createTest "Template Let Transformation Test 7" "Template Test 7.cl" + + <@ + fun (range: Range1D) (m: int clarray) -> + let p = m.[0] + + let x n = + let l = m.[9] + let g k = k + m.[0] + m.[1] + + let r = + let y a = + let x = 5 - n + (g 4) + let z t = m.[2] + a - t + z (a + x + l) + + y 6 + + r + m.[3] + + m.[0] <- x 7 + @> + |> createTest "Template Let Transformation Test 8" "Template Test 8.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + let x n = + let r = 8 + let h = r + n + h + + buf.[0] <- x 9 + @> + |> createTest "Template Let Transformation Test 9" "Template Test 9.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + let p = 9 + + let x n b = + let t = 0 + n + b + t + + buf.[0] <- x 7 9 + @> + |> createTest "Template Let Transformation Test 10" "Template Test 10.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + let p = 1 + + let m = + let r l = l + p + r 9 + + let z k = k + 1 + buf.[0] <- m + @> + |> createTest "Template Let Transformation Test 11" "Template Test 11.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + let f x y = + let y = y + let y = y + let g x m = m + x + g x y + + buf.[0] <- f 1 7 + @> + |> createTest "Template Let Transformation Test 12" "Template Test 12.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + let f y = + let y = y + let y = y + let g m = m + 1 + g y + + buf.[0] <- f 7 + @> + |> createTest "Template Let Transformation Test 13" "Template Test 13.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + let f (y: int) = + let y = y + let y = y + + let g (m: int) = + let g r t = r + y - t + let n o = o - (g y 2) + n 5 + + g y + + let z y = y - 2 + buf.[0] <- f (z 7) + @> + |> createTest "Template Let Transformation Test 14" "Template Test 14.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + let f y = + let Argi index = if index = 0 then buf.[1] else buf.[2] + Argi y + + buf.[0] <- f 0 + @> + |> createTest "Template Let Transformation Test 15" "Template Test 15.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + let f y = + if y = 0 then + let z a = a + 1 + z 9 + else + buf.[2] + + buf.[0] <- f 0 + @> + |> createTest "Template Let Transformation Test 16" "Template Test 16.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + let f x = + let g = 1 + x + g + + buf.[0] <- f 1 + @> + |> createTest "Let renamed" "Let renamed.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + let f m k = + let g q w = 1 + q + w + let t p = 7 - p + (g 1 2) - m * k / (t 53) + + buf.[0] <- f 1 4 + @> + |> createTest "Let renamed 2" "Let renamed 2.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + let f x y = + let y = y + let y = y + let g x m = m + x + g x y + + buf.[0] <- f 1 7 + @> + |> createTest "Renamer Test" "Renamer Test.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + let f x y = x - y + buf.[0] <- f 2 3 + buf.[1] <- f 4 5 + @> + |> createTest "Nested functions" "Nested.Function.cl" ] + +let tests translator = + lambdaLiftingTests translator + |> testList "LambdaLifting" diff --git a/tests/Brahma.FSharp.Tests/Translator/LangExtensions/Atomic.fs b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/Atomic.fs index 2add17ba..8dd4f576 100644 --- a/tests/Brahma.FSharp.Tests/Translator/LangExtensions/Atomic.fs +++ b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/Atomic.fs @@ -4,52 +4,54 @@ open Expecto open Brahma.FSharp open Brahma.FSharp.Tests.Translator.Common -let test translator= - - [ testCase "Multiple local values in atomic operations" <| fun () -> - let kernel = - <@ - fun (ndRange: Range1D) (v: int) -> - let mutable firstMaxIndex = local () - let mutable secondMaxIndex = local () - let mutable value = local () - - if ndRange.LocalID0 = 0 then - firstMaxIndex <- 0 - secondMaxIndex <- 0 - value <- v - - barrierLocal () - - atomic (max) firstMaxIndex value |> ignore - atomic (max) secondMaxIndex value |> ignore - @> - - Helpers.openclTranslate translator kernel |> ignore -] - -let commonApiTests translator = [ - // TODO is it correct? - ptestCase "Using atomic in lambda should not raise exception if first parameter passed" <| fun () -> - let command = - <@ - fun (range: Range1D) (buffer: int[]) -> - let g = atomic (fun x y -> x + 1) buffer.[0] - g 5 |> ignore - @> - - command |> Helpers.openclTranslate translator |> ignore - - // TODO is it correct? - ptestCase "Using atomic in lambda should raise exception if first parameter is argument" <| fun () -> - let command = - <@ - fun (range: Range1D) (buffer: int[]) -> - let g x y = atomic (+) x y - g buffer.[0] 6 |> ignore - @> - - Expect.throwsT - <| fun () -> command |> Helpers.openclTranslate translator |> ignore - <| "Exception should be thrown" -] +let test translator = + + [ testCase "Multiple local values in atomic operations" + <| fun () -> + let kernel = + <@ + fun (ndRange: Range1D) (v: int) -> + let mutable firstMaxIndex = local () + let mutable secondMaxIndex = local () + let mutable value = local () + + if ndRange.LocalID0 = 0 then + firstMaxIndex <- 0 + secondMaxIndex <- 0 + value <- v + + barrierLocal () + + atomic (max) firstMaxIndex value |> ignore + atomic (max) secondMaxIndex value |> ignore + @> + + Helpers.openclTranslate translator kernel |> ignore ] + +let commonApiTests translator = + [ + // TODO is it correct? + ptestCase "Using atomic in lambda should not raise exception if first parameter passed" + <| fun () -> + let command = + <@ + fun (range: Range1D) (buffer: int[]) -> + let g = atomic (fun x y -> x + 1) buffer.[0] + g 5 |> ignore + @> + + command |> Helpers.openclTranslate translator |> ignore + + // TODO is it correct? + ptestCase "Using atomic in lambda should raise exception if first parameter is argument" + <| fun () -> + let command = + <@ + fun (range: Range1D) (buffer: int[]) -> + let g x y = atomic (+) x y + g buffer.[0] 6 |> ignore + @> + + Expect.throwsT + <| fun () -> command |> Helpers.openclTranslate translator |> ignore + <| "Exception should be thrown" ] diff --git a/tests/Brahma.FSharp.Tests/Translator/LangExtensions/Barrier/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/Barrier/Tests.fs index a6f3751f..ea29e9bc 100644 --- a/tests/Brahma.FSharp.Tests/Translator/LangExtensions/Barrier/Tests.fs +++ b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/Barrier/Tests.fs @@ -1,21 +1,25 @@ -module Brahma.FSharp.Tests.Translator.Barrier.Tests +module Brahma.FSharp.Tests.Translator.Barrier -open Expecto open Brahma.FSharp open Brahma.FSharp.Tests.Translator.Common +open System.IO +open Expecto + +let private basePath = Path.Combine("Translator", "BinaryOperations", "Expected") + +let private barrierTests translator = + [ let inline createTest name = + Helpers.createTest translator basePath name -let barrierTests translator = [ - let inline checkCode cmd outFile expected = Helpers.checkCode translator cmd outFile expected + <@ fun (range: Range1D) -> barrierLocal () @> + |> createTest "Local barrier translation tests" "Barrier.Local.cl" - testCase "Local barrier translation tests" <| fun () -> - let command = <@ fun (range: Range1D) -> barrierLocal () @> - checkCode command "Barrier.Local.gen" "Barrier.Local.cl" + <@ fun (range: Range1D) -> barrierGlobal () @> + |> createTest "Global barrier translation tests" "Barrier.Global.cl" - testCase "Global barrier translation tests" <| fun () -> - let command = <@ fun (range: Range1D) -> barrierGlobal () @> - checkCode command "Barrier.Global.gen" "Barrier.Global.cl" + <@ fun (range: Range1D) -> barrierFull () @> + |> createTest "Full barrier translation tests" "Barrier.Full.cl" ] - testCase "Full barrier translation tests" <| fun () -> - let command = <@ fun (range: Range1D) -> barrierFull () @> - checkCode command "Barrier.Full.gen" "Barrier.Full.cl" -] +let tests translator = + barrierTests translator + |> testList "Barrier" diff --git a/tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalID/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalID/Tests.fs index ca9e48ae..6eb83fef 100644 --- a/tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalID/Tests.fs +++ b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalID/Tests.fs @@ -1,28 +1,31 @@ -module Brahma.FSharp.Tests.Translator.LocalId.Tests +module Brahma.FSharp.Tests.Translator.LangExtensions.LocalId open Brahma.FSharp -open Expecto open Brahma.FSharp.Tests.Translator.Common +open System.IO +open Expecto -let basicLocalIdTests translator = [ - let inline checkCode cmd outFile expected = Helpers.checkCode translator cmd outFile expected +let private basePath = Path.Combine("Translator", "Local", "Expected") - testCase "LocalID of 1D" <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let id = range.LocalID0 - buf.[id] <- 0 - @> +let private basicLocalIdTests translator = + [ let inline createTest name = + Helpers.createTest translator basePath name - checkCode command "LocalID1D.gen" "LocalID1D.cl" + <@ + fun (range: Range1D) (buf: int clarray) -> + let id = range.LocalID0 + buf.[id] <- 0 + @> + |> createTest "LocalID of 1D" "LocalID1D.cl" - testCase "LocalID of 2D" <| fun _ -> - let command = - <@ fun (range: Range2D) (buf: int clarray) -> - let v = range.LocalID0 - let id = range.LocalID1 - buf.[id] <- v - @> + <@ + fun (range: Range2D) (buf: int clarray) -> + let v = range.LocalID0 + let id = range.LocalID1 + buf.[id] <- v + @> + |> createTest "LocalID of 2D" "LocalID2D.cl" ] - checkCode command "LocalID2D.gen" "LocalID2D.cl" -] +let tests translator = + basicLocalIdTests translator + |> testList "BasicLocalId" diff --git a/tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalMemory/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalMemory/Tests.fs index e1585de7..3b3806f8 100644 --- a/tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalMemory/Tests.fs +++ b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalMemory/Tests.fs @@ -1,36 +1,37 @@ -module Brahma.FSharp.Tests.Translator.LocalMemory.Tests +module Brahma.FSharp.Tests.Translator.LocalMemory -open Expecto open Brahma.FSharp open Brahma.FSharp.Tests.Translator.Common +open System.IO +open Expecto -let localMemoryTests translator = [ - let inline checkCode cmd outFile expected = Helpers.checkCode translator cmd outFile expected - - testCase "Local int" <| fun _ -> - let command = - <@ fun (range: Range1D) -> - let mutable x = local () - x <- 0 - @> - - checkCode command "LocalMemory.int.gen" "LocalMemory.int.cl" - - testCase "Local float" <| fun _ -> - let command = - <@ fun (range: Range1D) -> - let mutable x = local () - x <- 0.0 - @> - - checkCode command "LocalMemory.float.gen" "LocalMemory.float.cl" - - testCase "Local int array" <| fun _ -> - let command = - <@ fun (range: Range1D) -> - let xs = localArray 5 - xs.[range.LocalID0] <- range.LocalID0 - @> - - checkCode command "LocalMemory.int [].gen" "LocalMemory.int [].cl" -] +let private basePath = Path.Combine("Translator", "BinaryOperations", "Expected") + +let private localMemoryTests translator = + [ let inline createTest name = + Helpers.createTest translator basePath name + + <@ + fun (range: Range1D) -> + let mutable x = local () + x <- 0 + @> + |> createTest "Local int" "LocalMemory.int.cl" + + <@ + fun (range: Range1D) -> + let mutable x = local () + x <- 0.0 + @> + |> createTest "Local float" "LocalMemory.float.cl" + + <@ + fun (range: Range1D) -> + let xs = localArray 5 + xs.[range.LocalID0] <- range.LocalID0 + @> + |> createTest "Local int array" "LocalMemory.int [].cl" ] + +let tests translator = + localMemoryTests translator + |> testList "LocalMemory" diff --git a/tests/Brahma.FSharp.Tests/Translator/LangExtensions/WorkSize/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/WorkSize/Tests.fs index 1f5c6eb5..152d5b05 100644 --- a/tests/Brahma.FSharp.Tests/Translator/LangExtensions/WorkSize/Tests.fs +++ b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/WorkSize/Tests.fs @@ -1,42 +1,41 @@ -module Brahma.FSharp.Tests.Translator.WorkSize.Tests +module Brahma.FSharp.Tests.Translator.WorkSize open Brahma.FSharp -open Expecto open Brahma.FSharp.Tests.Translator.Common +open System.IO +open Expecto -let basicWorkSizeTests translator = [ - let inline checkCode cmd outFile expected = Helpers.checkCode translator cmd outFile expected - - testCase "WorkSize of 1D" <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: int clarray) -> - let gSize = range.GlobalWorkSize - let lSize = range.LocalWorkSize - () - @> - - checkCode command "WorkSize1D.gen" "WorkSize1D.cl" - - testCase "WorkSize of 2D" <| fun _ -> - let command = - <@ - fun (range: Range2D) (buf: int clarray) -> - let (gSizeX, gSizeY) = range.GlobalWorkSize - let (lSizeX, lSizeY) = range.LocalWorkSize - () - @> - - checkCode command "WorkSize2D.gen" "WorkSize2D.cl" - - testCase "WorkSize of 3D" <| fun _ -> - let command = - <@ - fun (range: Range3D) (buf: int clarray) -> - let (gSizeX, gSizeY, gSizeZ) = range.GlobalWorkSize - let (lSizeX, lSizeY, lSizeZ) = range.LocalWorkSize - () - @> - - checkCode command "WorkSize3D.gen" "WorkSize3D.cl" -] +let private basePath = Path.Combine("Translator", "BinaryOperations", "Expected") + +let private basicWorkSizeTests translator = + [ let inline createTest name = + Helpers.createTest translator basePath name + + <@ + fun (range: Range1D) (buf: int clarray) -> + let gSize = range.GlobalWorkSize + let lSize = range.LocalWorkSize + () + @> + |> createTest "WorkSize of 1D" "WorkSize1D.cl" + + <@ + fun (range: Range2D) (buf: int clarray) -> + let (gSizeX, gSizeY) = range.GlobalWorkSize + let (lSizeX, lSizeY) = range.LocalWorkSize + () + @> + |> createTest "WorkSize of 2D" "WorkSize2D.cl" + + + <@ + fun (range: Range3D) (buf: int clarray) -> + let (gSizeX, gSizeY, gSizeZ) = range.GlobalWorkSize + let (lSizeX, lSizeY, lSizeZ) = range.LocalWorkSize + () + @> + |> createTest "WorkSize of 3D" "WorkSize3D.cl" ] + +let tests translator = + basicWorkSizeTests translator + |> testList "BasicWorkSize" diff --git a/tests/Brahma.FSharp.Tests/Translator/NamesResolving/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/NamesResolving/Tests.fs index 5d60112a..a044f111 100644 --- a/tests/Brahma.FSharp.Tests/Translator/NamesResolving/Tests.fs +++ b/tests/Brahma.FSharp.Tests/Translator/NamesResolving/Tests.fs @@ -1,63 +1,60 @@ -module Brahma.FSharp.Tests.Translator.NamesResolving.Tests +module Brahma.FSharp.Tests.Translator.NamesResolving open Brahma.FSharp -open Expecto open Brahma.FSharp.Tests.Translator.Common +open System.IO +open Expecto -let namesResolvingTests translator = [ - let inline checkCode cmd outFile expected = checkCode translator cmd outFile expected - - testCase "Bindings with equal names." <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let x = 2 - buf.[0] <- x - let x = 3 - buf.[1] <- x - @> - - checkCode command "Bindings.With.Equal.Names.gen" "Bindings.With.Equal.Names.cl" - - testCase "Binding and FOR counter conflict 1." <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let i = 2 - - for i in 1 .. 2 do - buf.[1] <- i - @> - - checkCode command "Binding.And.FOR.Counter.Conflict.1.gen" "Binding.And.FOR.Counter.Conflict.1.cl" - - testCase "Binding and FOR counter conflict 2." <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - for i in 1 .. 2 do - let i = 2 - buf.[1] <- i - @> - - checkCode command "Binding.And.FOR.Counter.Conflict.2.gen" "Binding.And.FOR.Counter.Conflict.2.cl" - - testCase "Binding and FOR counter conflict 3." <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - for i in 0 .. 1 do - let i = i + 2 - buf.[i] <- 2 - @> - - checkCode command "Binding.And.FOR.Counter.Conflict.3.gen" "Binding.And.FOR.Counter.Conflict.3.cl" - - testCase "Binding and FOR counter conflict 4." <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: int clarray) -> - let i = 1 - - for i in 0 .. i + 1 do - let i = i + 2 - buf.[i] <- 2 - @> - - checkCode command "Binding.And.FOR.Counter.Conflict.4.gen" "Binding.And.FOR.Counter.Conflict.4.cl" -] +let private basePath = Path.Combine("Translator", "NamesResolving", "Expected") + +let private namesResolvingTests translator = + [ let inline createTest name = + Helpers.createTest translator basePath name + + <@ + fun (range: Range1D) (buf: int clarray) -> + let x = 2 + buf.[0] <- x + let x = 3 + buf.[1] <- x + @> + |> createTest "Bindings with equal names." "Bindings.With.Equal.Names.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + let i = 2 + + for i in 1..2 do + buf.[1] <- i + @> + |> createTest "Binding and FOR counter conflict 1." "Binding.And.FOR.Counter.Conflict.1.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + for i in 1..2 do + let i = 2 + buf.[1] <- i + @> + |> createTest "Binding and FOR counter conflict 2." "Binding.And.FOR.Counter.Conflict.2.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + for i in 0..1 do + let i = i + 2 + buf.[i] <- 2 + @> + |> createTest "Binding and FOR counter conflict 3." "Binding.And.FOR.Counter.Conflict.3.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + let i = 1 + + for i in 0 .. i + 1 do + let i = i + 2 + buf.[i] <- 2 + @> + |> createTest "Binding and FOR counter conflict 4." "Binding.And.FOR.Counter.Conflict.4.cl" ] + +let tests translator = + namesResolvingTests translator + |> testList "NamesResolving" diff --git a/tests/Brahma.FSharp.Tests/Translator/Printf/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/Printf/Tests.fs index 7c008f45..3ec8e952 100644 --- a/tests/Brahma.FSharp.Tests/Translator/Printf/Tests.fs +++ b/tests/Brahma.FSharp.Tests/Translator/Printf/Tests.fs @@ -1,49 +1,48 @@ -module Brahma.FSharp.Tests.Translator.Printf.Tests +module Brahma.FSharp.Tests.Translator.Printf -open Expecto open Brahma.FSharp open Brahma.FSharp.Tests.Translator.Common +open System.IO +open Expecto -let printfTests translator = [ - let inline checkCode cmd outFile expected = Helpers.checkCode translator cmd outFile expected +let private basePath = Path.Combine("Translator", "Printf", "Expected") - testCase "Printf test 1" <| fun _ -> - let command = <@ fun (range: Range1D) -> printf "%d %f" 10 15.0 @> - checkCode command "Printf test 1.gen" "Printf test 1.cl" +let private printfTests translator = + [ let inline createTest name = + Helpers.createTest translator basePath name - testCase "Printf test 2" <| fun _ -> - let command = - <@ fun (range: Range1D) (xs: int clarray) -> - let gid = range.GlobalID0 - let x = 10 + <@ fun (range: Range1D) -> printf "%d %f" 10 15.0 @> + |> createTest "Printf test 1" "Printf test 1.cl" - printf "%d %d" x xs.[gid] - @> + <@ + fun (range: Range1D) (xs: int clarray) -> + let gid = range.GlobalID0 + let x = 10 - checkCode command "Printf test 2.gen" "Printf test 2.cl" + printf "%d %d" x xs.[gid] + @> + |> createTest "Printf test 2" "Printf test 2.cl" - testCase "Printf test 3" <| fun _ -> - let command = - <@ fun (range: Range1D) (xs: int clarray) -> - let mutable i = 0 + <@ + fun (range: Range1D) (xs: int clarray) -> + let mutable i = 0 - while i < 10 do - xs.[0] <- i * 2 - printf "i = %d, xs.[0]*10 = %d\n" i (xs.[0] + 10) - i <- i + 1 - @> + while i < 10 do + xs.[0] <- i * 2 + printf "i = %d, xs.[0]*10 = %d\n" i (xs.[0] + 10) + i <- i + 1 + @> + |> createTest "Printf test 3" "Printf test 3.cl" - checkCode command "Printf test 3.gen" "Printf test 3.cl" + <@ fun (range: Range1D) -> printfn "%d %f" 10 15.0 @> + |> createTest "Printf test 4: printfn" "Printf test 4.cl" - testCase "Printf test 4: printfn" <| fun _ -> - let command = <@ fun (range: Range1D) -> printfn "%d %f" 10 15.0 @> - checkCode command "Printf test 4.gen" "Printf test 4.cl" + <@ fun (range: Range1D) -> printf "I am complied" @> + |> createTest "Printf test 5: printf without args" "Printf test 5.cl" - testCase "Printf test 5: printf without args" <| fun _ -> - let command = <@ fun (range: Range1D) -> printf "I am complied" @> - checkCode command "Printf test 5.gen" "Printf test 5.cl" + <@ fun (range: Range1D) -> printfn "I am complied too" @> + |> createTest "Printf test 6: printfn without args" "Printf test 6.cl" ] - testCase "Printf test 6: printfn without args" <| fun _ -> - let command = <@ fun (range: Range1D) -> printfn "I am complied too" @> - checkCode command "Printf test 6.gen" "Printf test 6.cl" -] +let tests translator = + printfTests translator + |> testList "Printf" diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Common.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Common.fs index 53288471..a088789a 100644 --- a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Common.fs +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Common.fs @@ -17,8 +17,8 @@ module Helpers = match expr with | ExprShape.ShapeVar var -> Expr.Var(replaceUnitVar var) - | ExprShape.ShapeLambda (var, body) -> Expr.Lambda(replaceUnitVar var, renameUnitVar body) - | ExprShape.ShapeCombination (shapeComboObj, exprList) -> + | ExprShape.ShapeLambda(var, body) -> Expr.Lambda(replaceUnitVar var, renameUnitVar body) + | ExprShape.ShapeCombination(shapeComboObj, exprList) -> ExprShape.RebuildShapeCombination(shapeComboObj, List.map renameUnitVar exprList) let openclTransformQuotation (translator: FSQuotationToOpenCLTranslator) (expr: Expr) = @@ -28,10 +28,7 @@ module Helpers = let actual' = renameUnitVar actual let expected' = renameUnitVar expected - Expect.equal - <| actual'.ToString() - <| expected'.ToString() - <| msg + Expect.sequenceEqual <| actual'.ToString() <| expected'.ToString() <| msg let assertMethodEqual (actual: Var * Expr) (expected: Var * Expr) = Expect.equal (fst actual).Name (fst expected).Name "Method names should be equal" diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/LambdaLifting.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/LambdaLifting.fs index 879f5499..37e5f2a6 100644 --- a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/LambdaLifting.fs +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/LambdaLifting.fs @@ -3,8 +3,9 @@ module Brahma.FSharp.Tests.Translator.QuatationTransformation.LambdaLifting open Expecto open Brahma.FSharp.OpenCL.Translator.QuotationTransformers open Common +open Expecto -let lambdaLiftingTests = +let private lambdaLiftingTests = let genParameterLiftTest name expr expected = test name { let actual = LambdaLifting.parameterLiftExpr expr @@ -12,86 +13,97 @@ let lambdaLiftingTests = assertExprEqual actual expected equalsMessage } - [ - genParameterLiftTest - "Test 1" - <@ let x = 1 - let addToX y = x + y - addToX 2 - @> - <@ let x = 1 - let addToX x y = x + y - addToX x 2 - @> - - genParameterLiftTest - "Test 2" - <@ let x = 1 - let z = x - - let addToX y = // freeVars: [x, z] - x + y + z - - let f z1 = // freeVars: [], addToX freeVars: [x, z] - 2 + addToX z1 - - f 3 - @> - <@ let x = 1 - let z = x - - let addToX x z y = x + y + z - let f x z z1 = 2 + addToX x z z1 - f x z 3 - @> - - genParameterLiftTest - "Test 3" - <@ let mainX = "global variable" - let mainY = "global variable" - let mainZ = "global variable" - - let foo fooX = - let fooY = "local variable of foo" - let bar barX = mainX + fooY + barX - bar fooX + mainY - - foo mainZ - @> - <@ let mainX = "global variable" - let mainY = "global variable" - let mainZ = "global variable" - - let foo mainX mainY fooX = - let fooY = "local variable of foo" - let bar fooY mainX barX = mainX + fooY + barX - bar fooY mainX fooX + mainY - - foo mainX mainY mainZ - @> - - genParameterLiftTest - "Test 4" - <@ let x0 = 0 - - let f x1 = - let g x2 = - let h x3 = x3 + x0 - h x2 - - g x1 - - f x0 - @> - <@ let x0 = 0 - - let f x0 x1 = - let g x0 x2 = - let h x0 x3 = x3 + x0 - h x0 x2 - - g x0 x1 - - f x0 x0 - @> - ] + [ genParameterLiftTest + "Test 1" + <@ + let x = 1 + let addToX y = x + y + addToX 2 + @> + <@ + let x = 1 + let addToX x y = x + y + addToX x 2 + @> + + genParameterLiftTest + "Test 2" + <@ + let x = 1 + let z = x + + let addToX y = // freeVars: [x, z] + x + y + z + + let f z1 = // freeVars: [], addToX freeVars: [x, z] + 2 + addToX z1 + + f 3 + @> + <@ + let x = 1 + let z = x + + let addToX x z y = x + y + z + let f x z z1 = 2 + addToX x z z1 + f x z 3 + @> + + genParameterLiftTest + "Test 3" + <@ + let mainX = "global variable" + let mainY = "global variable" + let mainZ = "global variable" + + let foo fooX = + let fooY = "local variable of foo" + let bar barX = mainX + fooY + barX + bar fooX + mainY + + foo mainZ + @> + <@ + let mainX = "global variable" + let mainY = "global variable" + let mainZ = "global variable" + + let foo mainX mainY fooX = + let fooY = "local variable of foo" + let bar fooY mainX barX = mainX + fooY + barX + bar fooY mainX fooX + mainY + + foo mainX mainY mainZ + @> + + genParameterLiftTest + "Test 4" + <@ + let x0 = 0 + + let f x1 = + let g x2 = + let h x3 = x3 + x0 + h x2 + + g x1 + + f x0 + @> + <@ + let x0 = 0 + + let f x0 x1 = + let g x0 x2 = + let h x0 x3 = x3 + x0 + h x0 x2 + + g x0 x1 + + f x0 x0 + @> ] + +let tests _ = + lambdaLiftingTests + |> testList "Lambda lifting" + diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Transformation.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Transformation.fs index 398bb39b..3407e9f6 100644 --- a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Transformation.fs +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Transformation.fs @@ -4,18 +4,17 @@ open Expecto open Brahma.FSharp open FSharp.Quotations open Common +open Expecto -let quotationTransformerTest translator = +let private quotationTransformerTest translator = let assertMethodListsEqual (actual: list) (expected: list) = Expect.equal actual.Length expected.Length "List sizes should be equal" - - List.zip actual expected - |> List.iter (fun (x, y) -> assertMethodEqual x y) + List.iter2 assertMethodEqual actual expected let makeMethods (expr: Expr) = let rec go (expr: Expr) = match expr with - | Patterns.Let (var, body, inExpr) -> + | Patterns.Let(var, body, inExpr) -> let methods, kernel = go inExpr (var, body) :: methods, kernel | _ -> [], expr @@ -26,150 +25,165 @@ let quotationTransformerTest translator = let genTest testCase name expr expected = let expectedKernelExpr, expectedMethods = makeMethods expected - testCase name <| fun _ -> - let (actualKernelExpr, actualKernelMethods) = expr |> openclTransformQuotation translator + testCase name + <| fun _ -> + let (actualKernelExpr, actualKernelMethods) = + expr |> openclTransformQuotation translator assertMethodListsEqual actualKernelMethods expectedMethods assertExprEqual actualKernelExpr expectedKernelExpr "kernels not equals" - [ - genTest - testCase - "Test 0" - <@ fun (range: Range1D) (buf: array) -> - let mutable x = 1 - let f y = x <- y - f 10 - buf.[0] <- x - @> - <@ - let f (xRef: _ ref) (y: int) = xRef.Value <- y - - fun (range: Range1D) (buf: array) -> - let mutable x = 1 - let xRef = ref x - - f xRef 10 - buf.[0] <- xRef.Value - @> - - genTest - testCase - "Test 1" - <@ fun (range: Range1D) (buf: array) -> - let mutable x = 1 - let f y = x <- x + y - f 10 - buf.[0] <- x - @> - <@ - let f (xRef: _ ref) (y: int) = xRef.Value <- xRef.Value + y - - fun (range: Range1D) (buf: array) -> - let mutable x = 1 - let xRef = ref x - - f xRef 10 - buf.[0] <- xRef.Value - @> - - genTest - testCase - "Test 2: simple lambda lifting without capturing variables" - <@ fun (range: Range1D) -> - let f x = - let g y = y + 1 - g x - - f 2 @> - <@ let g y = y + 1 - let f x = g x - fun (range: Range1D) -> f 2 @> - - genTest - testCase - "Test 3: simple lambda lifting with capturing variables" - <@ fun (range: Range1D) -> - let f x = - let g y = y + x - g (x + 1) - - f 2 - @> - <@ let g x y = y + x - let f x = g x (x + 1) - fun (range: Range1D) -> f 2 - @> - - genTest - testCase - "Test 4" - <@ fun (range: Range1D) (arr: array) -> - let x = - let mutable y = 0 - - let addToY x = y <- y + x - - for i in 0 .. 10 do - addToY arr.[i] - - y - - x - @> - <@ let addToY (yRef: _ ref) x = yRef.Value <- yRef.Value + x - - let x1UnitFunc (arr: array) = - let y = 0 - let yRef = ref y - - for i in 0 .. 10 do - addToY yRef arr.[i] - - yRef.Value - - fun (range: Range1D) (arr: array) -> - let x1 = x1UnitFunc arr - x1 - @> - - genTest - testCase - "Test 5" - <@ fun (range: Range1D) (arr: array) -> - let mutable x = if 0 > 1 then 2 else 3 - - let mutable y = - for i in 0 .. 10 do - x <- x + 1 - - x + 1 - - let z = x + y - - let f () = arr.[0] <- x + y + z - f () - @> - <@ let xUnitFunc () = if 0 > 1 then 2 else 3 - - let yUnitFunc (xRef: _ ref) = - for i in 0 .. 10 do - xRef.Value <- xRef.Value + 1 - - xRef.Value + 1 - - let f (arr: array) (xRef: _ ref) (yRef: _ ref) z - = arr.[0] <- xRef.Value + yRef.Value + z - - fun (range: Range1D) (arr: array) -> - let mutable x = xUnitFunc () - let xRef = ref x - - let mutable y = yUnitFunc xRef - let yRef = ref y - - let z = xRef.Value + yRef.Value - - f arr xRef yRef z - @> - ] + [ genTest + testCase + "Test 0" + <@ + fun (range: Range1D) (buf: array) -> + let mutable x = 1 + let f y = x <- y + f 10 + buf.[0] <- x + @> + <@ + let f (xRef: _ ref) (y: int) = xRef.Value <- y + + fun (range: Range1D) (buf: array) -> + let mutable x = 1 + let xRef = ref x + + f xRef 10 + buf.[0] <- xRef.Value + @> + + genTest + testCase + "Test 1" + <@ + fun (range: Range1D) (buf: array) -> + let mutable x = 1 + let f y = x <- x + y + f 10 + buf.[0] <- x + @> + <@ + let f (xRef: _ ref) (y: int) = xRef.Value <- xRef.Value + y + + fun (range: Range1D) (buf: array) -> + let mutable x = 1 + let xRef = ref x + + f xRef 10 + buf.[0] <- xRef.Value + @> + + genTest + testCase + "Test 2: simple lambda lifting without capturing variables" + <@ + fun (range: Range1D) -> + let f x = + let g y = y + 1 + g x + + f 2 + @> + <@ + let g y = y + 1 + let f x = g x + fun (range: Range1D) -> f 2 + @> + + genTest + testCase + "Test 3: simple lambda lifting with capturing variables" + <@ + fun (range: Range1D) -> + let f x = + let g y = y + x + g (x + 1) + + f 2 + @> + <@ + let g x y = y + x + let f x = g x (x + 1) + fun (range: Range1D) -> f 2 + @> + + genTest + testCase + "Test 4" + <@ + fun (range: Range1D) (arr: array) -> + let x = + let mutable y = 0 + + let addToY x = y <- y + x + + for i in 0..10 do + addToY arr.[i] + + y + + x + @> + <@ + let addToY (yRef: _ ref) x = yRef.Value <- yRef.Value + x + + let x1UnitFunc (arr: array) = + let y = 0 + let yRef = ref y + + for i in 0..10 do + addToY yRef arr.[i] + + yRef.Value + + fun (range: Range1D) (arr: array) -> + let x1 = x1UnitFunc arr + x1 + @> + + genTest + testCase + "Test 5" + <@ + fun (range: Range1D) (arr: array) -> + let mutable x = if 0 > 1 then 2 else 3 + + let mutable y = + for i in 0..10 do + x <- x + 1 + + x + 1 + + let z = x + y + + let f () = arr.[0] <- x + y + z + f () + @> + <@ + let xUnitFunc () = if 0 > 1 then 2 else 3 + + let yUnitFunc (xRef: _ ref) = + for i in 0..10 do + xRef.Value <- xRef.Value + 1 + + xRef.Value + 1 + + let f (arr: array) (xRef: _ ref) (yRef: _ ref) z = arr.[0] <- xRef.Value + yRef.Value + z + + fun (range: Range1D) (arr: array) -> + let mutable x = xUnitFunc () + let xRef = ref x + + let mutable y = yUnitFunc xRef + let yRef = ref y + + let z = xRef.Value + yRef.Value + + f arr xRef yRef z + @> ] + +let tests translator = + quotationTransformerTest translator + |> testList "QuotationTransformer" diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/VarDefsToLambda.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/VarDefsToLambda.fs index 2ee8b078..ec44f9ea 100644 --- a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/VarDefsToLambda.fs +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/VarDefsToLambda.fs @@ -3,8 +3,9 @@ module Brahma.FSharp.Tests.Translator.QuatationTransformation.VarDefsToLambda open Expecto open Brahma.FSharp.OpenCL.Translator.QuotationTransformers open Common +open Expecto -let varDefsToLambdaTest = +let private varDefsToLambdaTest = let genVarDefToLambdaTest name expr expected = test name { let actual = VarDefsToLambdaTransformer.transformVarDefsToLambda expr @@ -12,76 +13,83 @@ let varDefsToLambdaTest = assertExprEqual actual expected equalsMessage } - [ - genVarDefToLambdaTest - "Test 1" - <@ let x = - let mutable y = 0 + [ genVarDefToLambdaTest + "Test 1" + <@ + let x = + let mutable y = 0 + + for i in 1..10 do + y <- y + i + + y - for i in 1 .. 10 do - y <- y + i + x + @> + <@ + let x = + let xUnitFunc () = + let mutable y = 0 - y + for i in 1..10 do + y <- y + i - x - @> - <@ let x = - let xUnitFunc () = - let mutable y = 0 + y - for i in 1 .. 10 do - y <- y + i + xUnitFunc () - y + x + @> - xUnitFunc () + genVarDefToLambdaTest + "Test 2: we need to go deeper" + <@ + let x = + let mutable y = + if true then + let z = 10 + z + 1 + else + let z = 20 + z + 2 - x - @> + for i in 1..10 do + let z = if false then 10 else 20 + y <- y + i + z - genVarDefToLambdaTest - "Test 2: we need to go deeper" - <@ let x = - let mutable y = - if true then - let z = 10 - z + 1 - else - let z = 20 - z + 2 + y - for i in 1 .. 10 do - let z = if false then 10 else 20 - y <- y + i + z + x + @> + <@ + let x = + let xUnitFunc () = + let mutable y = + let yUnitFunc () = + if true then + let z = 10 + z + 1 + else + let z = 20 + z + 2 - y + yUnitFunc () - x - @> - <@ let x = - let xUnitFunc () = - let mutable y = - let yUnitFunc () = - if true then - let z = 10 - z + 1 - else - let z = 20 - z + 2 + for i in 1..10 do + let z = + let zUnitFunc () = if false then 10 else 20 + zUnitFunc () - yUnitFunc () + y <- y + i + z - for i in 1 .. 10 do - let z = - let zUnitFunc () = if false then 10 else 20 - zUnitFunc () + y - y <- y + i + z + xUnitFunc () - y + x + @> ] - xUnitFunc () +let tests _ = + varDefsToLambdaTest + |> testList "Var -> Lambda" - x - @> - ] diff --git a/tests/Brahma.FSharp.Tests/Translator/Specific/MergePath.fs b/tests/Brahma.FSharp.Tests/Translator/Specific/MergePath.fs index 92e3874e..0e7588b7 100644 --- a/tests/Brahma.FSharp.Tests/Translator/Specific/MergePath.fs +++ b/tests/Brahma.FSharp.Tests/Translator/Specific/MergePath.fs @@ -1,151 +1,154 @@ module Brahma.FSharp.Tests.Translator.Specific.MergePath +open System.IO open Brahma.FSharp.Tests.Translator.Common -open Expecto open Brahma.FSharp open Brahma.FSharp.OpenCL.Translator -let specificTests (translator: FSQuotationToOpenCLTranslator) = [ - let inline checkCode cmd outFile expected = Helpers.checkCode translator cmd outFile expected +let private basePath = Path.Combine("Translator", "MergePath", "Expected") - testCase "Merge kernel" <| fun () -> - let command workGroupSize = - <@ - fun (ndRange: Range1D) - firstSide - secondSide - sumOfSides - (firstRowsBuffer: ClArray) - (firstColumnsBuffer: ClArray) - (firstValuesBuffer: ClArray) - (secondRowsBuffer: ClArray) - (secondColumnsBuffer: ClArray) - (secondValuesBuffer: ClArray) - (allRowsBuffer: ClArray) - (allColumnsBuffer: ClArray) - (allValuesBuffer: ClArray) -> +let tests (translator: FSQuotationToOpenCLTranslator) = + let inline createTest name = + Helpers.createTest translator basePath name - let i = ndRange.GlobalID0 + let workGroupSize = 255 - let mutable beginIdxLocal = local () - let mutable endIdxLocal = local () - let localID = ndRange.LocalID0 + <@ + fun + (ndRange: Range1D) + firstSide + secondSide + sumOfSides + (firstRowsBuffer: ClArray) + (firstColumnsBuffer: ClArray) + (firstValuesBuffer: ClArray) + (secondRowsBuffer: ClArray) + (secondColumnsBuffer: ClArray) + (secondValuesBuffer: ClArray) + (allRowsBuffer: ClArray) + (allColumnsBuffer: ClArray) + (allValuesBuffer: ClArray) -> - if localID < 2 then - let mutable x = localID * (workGroupSize - 1) + i - 1 + let i = ndRange.GlobalID0 - if x >= sumOfSides then - x <- sumOfSides - 1 + let mutable beginIdxLocal = local () + let mutable endIdxLocal = local () + let localID = ndRange.LocalID0 - let diagonalNumber = x + if localID < 2 then + let mutable x = localID * (workGroupSize - 1) + i - 1 - let mutable leftEdge = diagonalNumber + 1 - secondSide - if leftEdge < 0 then leftEdge <- 0 + if x >= sumOfSides then + x <- sumOfSides - 1 - let mutable rightEdge = firstSide - 1 + let diagonalNumber = x - if rightEdge > diagonalNumber then - rightEdge <- diagonalNumber + let mutable leftEdge = diagonalNumber + 1 - secondSide - while leftEdge <= rightEdge do - let middleIdx = (leftEdge + rightEdge) / 2 + if leftEdge < 0 then + leftEdge <- 0 - let firstIndex: uint64 = - ((uint64 firstRowsBuffer.[middleIdx]) <<< 32) - ||| (uint64 firstColumnsBuffer.[middleIdx]) + let mutable rightEdge = firstSide - 1 - let secondIndex: uint64 = - ((uint64 secondRowsBuffer.[diagonalNumber - middleIdx]) - <<< 32) - ||| (uint64 secondColumnsBuffer.[diagonalNumber - middleIdx]) + if rightEdge > diagonalNumber then + rightEdge <- diagonalNumber - if firstIndex < secondIndex then - leftEdge <- middleIdx + 1 - else - rightEdge <- middleIdx - 1 + while leftEdge <= rightEdge do + let middleIdx = (leftEdge + rightEdge) / 2 - // Here localID equals either 0 or 1 - if localID = 0 then - beginIdxLocal <- leftEdge - else - endIdxLocal <- leftEdge + let firstIndex: uint64 = + ((uint64 firstRowsBuffer.[middleIdx]) <<< 32) + ||| (uint64 firstColumnsBuffer.[middleIdx]) - barrierLocal () + let secondIndex: uint64 = + ((uint64 secondRowsBuffer.[diagonalNumber - middleIdx]) <<< 32) + ||| (uint64 secondColumnsBuffer.[diagonalNumber - middleIdx]) - let beginIdx = beginIdxLocal - let endIdx = endIdxLocal - let firstLocalLength = endIdx - beginIdx - let mutable x = workGroupSize - firstLocalLength + if firstIndex < secondIndex then + leftEdge <- middleIdx + 1 + else + rightEdge <- middleIdx - 1 - if endIdx = firstSide then - x <- secondSide - i + localID + beginIdx + // Here localID equals either 0 or 1 + if localID = 0 then + beginIdxLocal <- leftEdge + else + endIdxLocal <- leftEdge - let secondLocalLength = x + barrierLocal () - //First indices are from 0 to firstLocalLength - 1 inclusive - //Second indices are from firstLocalLength to firstLocalLength + secondLocalLength - 1 inclusive - let localIndices = localArray workGroupSize + let beginIdx = beginIdxLocal + let endIdx = endIdxLocal + let firstLocalLength = endIdx - beginIdx + let mutable x = workGroupSize - firstLocalLength - if localID < firstLocalLength then - localIndices.[localID] <- - ((uint64 firstRowsBuffer.[beginIdx + localID]) - <<< 32) - ||| (uint64 firstColumnsBuffer.[beginIdx + localID]) + if endIdx = firstSide then + x <- secondSide - i + localID + beginIdx - if localID < secondLocalLength then - localIndices.[firstLocalLength + localID] <- - ((uint64 secondRowsBuffer.[i - beginIdx]) <<< 32) - ||| (uint64 secondColumnsBuffer.[i - beginIdx]) + let secondLocalLength = x - barrierLocal () + //First indices are from 0 to firstLocalLength - 1 inclusive + //Second indices are from firstLocalLength to firstLocalLength + secondLocalLength - 1 inclusive + let localIndices = localArray workGroupSize - if i < sumOfSides then - let mutable leftEdge = localID + 1 - secondLocalLength - if leftEdge < 0 then leftEdge <- 0 + if localID < firstLocalLength then + localIndices.[localID] <- + ((uint64 firstRowsBuffer.[beginIdx + localID]) <<< 32) + ||| (uint64 firstColumnsBuffer.[beginIdx + localID]) - let mutable rightEdge = firstLocalLength - 1 + if localID < secondLocalLength then + localIndices.[firstLocalLength + localID] <- + ((uint64 secondRowsBuffer.[i - beginIdx]) <<< 32) + ||| (uint64 secondColumnsBuffer.[i - beginIdx]) - if rightEdge > localID then - rightEdge <- localID + barrierLocal () - while leftEdge <= rightEdge do - let middleIdx = (leftEdge + rightEdge) / 2 - let firstIndex = localIndices.[middleIdx] + if i < sumOfSides then + let mutable leftEdge = localID + 1 - secondLocalLength - let secondIndex = - localIndices.[firstLocalLength + localID - middleIdx] + if leftEdge < 0 then + leftEdge <- 0 - if firstIndex < secondIndex then - leftEdge <- middleIdx + 1 - else - rightEdge <- middleIdx - 1 + let mutable rightEdge = firstLocalLength - 1 - let boundaryX = rightEdge - let boundaryY = localID - leftEdge + if rightEdge > localID then + rightEdge <- localID - // boundaryX and boundaryY can't be off the right edge of array (only off the left edge) - let isValidX = boundaryX >= 0 - let isValidY = boundaryY >= 0 + while leftEdge <= rightEdge do + let middleIdx = (leftEdge + rightEdge) / 2 + let firstIndex = localIndices.[middleIdx] - let mutable fstIdx = 0UL + let secondIndex = localIndices.[firstLocalLength + localID - middleIdx] - if isValidX then - fstIdx <- localIndices.[boundaryX] + if firstIndex < secondIndex then + leftEdge <- middleIdx + 1 + else + rightEdge <- middleIdx - 1 - let mutable sndIdx = 0UL + let boundaryX = rightEdge + let boundaryY = localID - leftEdge - if isValidY then - sndIdx <- localIndices.[firstLocalLength + boundaryY] + // boundaryX and boundaryY can't be off the right edge of array (only off the left edge) + let isValidX = boundaryX >= 0 + let isValidY = boundaryY >= 0 - if not isValidX || isValidY && fstIdx < sndIdx then - allRowsBuffer.[i] <- int (sndIdx >>> 32) - allColumnsBuffer.[i] <- int sndIdx - allValuesBuffer.[i] <- secondValuesBuffer.[i - localID - beginIdx + boundaryY] - else - allRowsBuffer.[i] <- int (fstIdx >>> 32) - allColumnsBuffer.[i] <- int fstIdx - allValuesBuffer.[i] <- firstValuesBuffer.[beginIdx + boundaryX] - @> + let mutable fstIdx = 0UL - checkCode (command 256) "MergeKernel.gen" "MergeKernel.cl" - ] + if isValidX then + fstIdx <- localIndices.[boundaryX] + + let mutable sndIdx = 0UL + + if isValidY then + sndIdx <- localIndices.[firstLocalLength + boundaryY] + + if not isValidX || isValidY && fstIdx < sndIdx then + allRowsBuffer.[i] <- int (sndIdx >>> 32) + allColumnsBuffer.[i] <- int sndIdx + allValuesBuffer.[i] <- secondValuesBuffer.[i - localID - beginIdx + boundaryY] + else + allRowsBuffer.[i] <- int (fstIdx >>> 32) + allColumnsBuffer.[i] <- int fstIdx + allValuesBuffer.[i] <- firstValuesBuffer.[beginIdx + boundaryX] + @> + |> createTest "Merge path" "MergeKernel.cl" diff --git a/tests/Brahma.FSharp.Tests/Translator/Union/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/Union/Tests.fs index 36a64b69..f877aadd 100644 --- a/tests/Brahma.FSharp.Tests/Translator/Union/Tests.fs +++ b/tests/Brahma.FSharp.Tests/Translator/Union/Tests.fs @@ -1,4 +1,4 @@ -module Brahma.FSharp.Tests.Translator.Union.Tests +module Brahma.FSharp.Tests.Translator.Union open Expecto open Brahma.FSharp.OpenCL.Translator @@ -7,30 +7,31 @@ open Brahma.FSharp.OpenCL.Printer open System.IO open Brahma.FSharp.Tests.Translator.Common +let private basePath = Path.Combine("Translator", "Union", "Expected") + type TranslateTest = | A of int * float | B of double | C -let unionTests (translator: FSQuotationToOpenCLTranslator) = - let testGen testCase name (types: List) outFile expectedFile = - testCase name <| fun () -> +let private unionTests = + let testGen name (types: List) expectedFile = + test name { let context = TranslationContext.Create(TranslatorOptions()) - for type' in types do Type.translateUnion type' |> State.run context |> ignore - - let unions = context.CStructDecls.Values |> Seq.map StructDecl |> Seq.toList - - let ast = AST <| List.map (fun du -> du :> ITopDef<_>) unions - let code = AST.print ast - File.WriteAllText(outFile, code) // TODO() + types + |> List.iter (fun type' -> Type.translateUnion type' |> State.run context |> ignore) - Utils.filesAreEqual outFile - <| Path.Combine(basePath, expectedFile) + context.CStructDecls.Values + |> Seq.map StructDecl + |> Seq.toList + |> List.map (fun du -> du :> ITopDef<_>) + |> AST + |> AST.print + |> fun code -> Helpers.compareCodeAndFile code <| Path.Combine(basePath, expectedFile) + } - [ - testGen testCase "Test 1" [ typeof ] "Translation.Test1.gen" "Translation.Test1.cl" - ] + [ testGen "Test 1" [ typeof ] "Translation.Test1.cl" ] type SimpleUnion = | SimpleOne @@ -40,30 +41,44 @@ type OuterUnion = | Outer of int | Inner of SimpleUnion -let collectUnionTests (translator: FSQuotationToOpenCLTranslator) = - let testGen testCase name expected command = - testCase name <| fun () -> - let unions = - Body.translate command - |> State.exec (TranslationContext.Create(TranslatorOptions())) - |> fun context -> context.CStructDecls.Keys +let private collectUnionTests = + let testGen name expected command = + test name { + Body.translate command + |> State.exec (TranslationContext.Create(TranslatorOptions())) + |> fun context -> context.CStructDecls.Keys + |> fun unions -> Expect.sequenceEqual unions expected "Should be equal" + } - Expect.sequenceEqual unions expected "Should be equal" + [ testGen + "Simple union" + [| typeof |] + <@ + let x = SimpleOne + let y = SimpleTwo 2 + () + @> - [ - testGen testCase "Simple union" [| typeof |] - <@ let x = SimpleOne - let y = SimpleTwo 2 - () - @> + testGen + "Nested union 1" + [| typeof + typeof |] + <@ + let x = Outer 5 + () + @> - testGen testCase "Nested union 1" [| typeof; typeof |] - <@ let x = Outer 5 - () - @> + testGen + "Nested union 2" + [| typeof + typeof |] + <@ + let x = Inner SimpleOne + () + @> ] - testGen testCase "Nested union 2" [| typeof; typeof |] - <@ let x = Inner SimpleOne - () - @> - ] +let tests = + [ unionTests + collectUnionTests ] + |> List.concat + |> testList "Union" From a87f22a8fe37b4ffcdbdc9beba5f95ac4aa4d682 Mon Sep 17 00:00:00 2001 From: IgorErin Date: Thu, 6 Jul 2023 20:28:59 +0300 Subject: [PATCH 05/22] refactor: translation tests --- .../QuatationTransformation/Common.fs | 2 +- .../QuatationTransformation/Transformation.fs | 25 +++++++++---------- .../Translator/Specific/MergePath.fs | 4 +-- 3 files changed, 15 insertions(+), 16 deletions(-) diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Common.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Common.fs index a088789a..a245edb3 100644 --- a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Common.fs +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Common.fs @@ -28,7 +28,7 @@ module Helpers = let actual' = renameUnitVar actual let expected' = renameUnitVar expected - Expect.sequenceEqual <| actual'.ToString() <| expected'.ToString() <| msg + Expect.equal <| actual'.ToString() <| expected'.ToString() <| msg let assertMethodEqual (actual: Var * Expr) (expected: Var * Expr) = Expect.equal (fst actual).Name (fst expected).Name "Method names should be equal" diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Transformation.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Transformation.fs index 3407e9f6..72dc2826 100644 --- a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Transformation.fs +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Transformation.fs @@ -4,7 +4,6 @@ open Expecto open Brahma.FSharp open FSharp.Quotations open Common -open Expecto let private quotationTransformerTest translator = let assertMethodListsEqual (actual: list) (expected: list) = @@ -44,14 +43,14 @@ let private quotationTransformerTest translator = buf.[0] <- x @> <@ - let f (xRef: _ ref) (y: int) = xRef.Value <- y + let f xRef (y: int) = xRef := y fun (range: Range1D) (buf: array) -> let mutable x = 1 let xRef = ref x f xRef 10 - buf.[0] <- xRef.Value + buf.[0] <- !xRef @> genTest @@ -65,14 +64,14 @@ let private quotationTransformerTest translator = buf.[0] <- x @> <@ - let f (xRef: _ ref) (y: int) = xRef.Value <- xRef.Value + y + let f (xRef: _ ref) (y: int) = xRef := !xRef + y fun (range: Range1D) (buf: array) -> let mutable x = 1 let xRef = ref x f xRef 10 - buf.[0] <- xRef.Value + buf.[0] <- !xRef @> genTest @@ -127,7 +126,7 @@ let private quotationTransformerTest translator = x @> <@ - let addToY (yRef: _ ref) x = yRef.Value <- yRef.Value + x + let addToY (yRef: _ ref) x = yRef := !yRef + x let x1UnitFunc (arr: array) = let y = 0 @@ -136,7 +135,7 @@ let private quotationTransformerTest translator = for i in 0..10 do addToY yRef arr.[i] - yRef.Value + !yRef fun (range: Range1D) (arr: array) -> let x1 = x1UnitFunc arr @@ -164,13 +163,13 @@ let private quotationTransformerTest translator = <@ let xUnitFunc () = if 0 > 1 then 2 else 3 - let yUnitFunc (xRef: _ ref) = + let yUnitFunc xRef = for i in 0..10 do - xRef.Value <- xRef.Value + 1 + xRef := !xRef + 1 - xRef.Value + 1 + !xRef + 1 - let f (arr: array) (xRef: _ ref) (yRef: _ ref) z = arr.[0] <- xRef.Value + yRef.Value + z + let f (arr: array) xRef yRef z = arr.[0] <- !xRef + !yRef + z fun (range: Range1D) (arr: array) -> let mutable x = xUnitFunc () @@ -179,11 +178,11 @@ let private quotationTransformerTest translator = let mutable y = yUnitFunc xRef let yRef = ref y - let z = xRef.Value + yRef.Value + let z = !xRef + !yRef f arr xRef yRef z @> ] let tests translator = quotationTransformerTest translator - |> testList "QuotationTransformer" + |> testList "Transformation" diff --git a/tests/Brahma.FSharp.Tests/Translator/Specific/MergePath.fs b/tests/Brahma.FSharp.Tests/Translator/Specific/MergePath.fs index 0e7588b7..aaf48149 100644 --- a/tests/Brahma.FSharp.Tests/Translator/Specific/MergePath.fs +++ b/tests/Brahma.FSharp.Tests/Translator/Specific/MergePath.fs @@ -5,13 +5,13 @@ open Brahma.FSharp.Tests.Translator.Common open Brahma.FSharp open Brahma.FSharp.OpenCL.Translator -let private basePath = Path.Combine("Translator", "MergePath", "Expected") +let private basePath = Path.Combine("Translator", "Specific", "Expected") let tests (translator: FSQuotationToOpenCLTranslator) = let inline createTest name = Helpers.createTest translator basePath name - let workGroupSize = 255 + let workGroupSize = 256 <@ fun From 739c880506a5a499f57a8b60af56fec8a384ca03 Mon Sep 17 00:00:00 2001 From: IgorErin Date: Thu, 6 Jul 2023 21:26:18 +0300 Subject: [PATCH 06/22] refactor: disable problem tests --- .../ExecutionTests/CompilationTests.fs | 6 +- .../ExecutionTests/CompositeTypesTests.fs | 2 + tests/Brahma.FSharp.Tests/Program.fs | 5 +- tests/Brahma.FSharp.Tests/Translator/All.fs | 4 +- .../Translator/Carrying/Tests.fs | 13 +- .../Translator/ConstantArray/Tests.fs | 3 +- .../Translator/ControlFlow/Tests.fs | 3 +- .../Translator/Injection/Tests.fs | 3 +- .../Translator/LambdaLifting/Tests.fs | 3 +- .../LangExtensions/Barrier/Tests.fs | 3 +- .../LangExtensions/LocalID/Tests.fs | 3 +- .../LangExtensions/LocalMemory/Tests.fs | 3 +- .../LangExtensions/WorkSize/Tests.fs | 3 +- .../Translator/NamesResolving/Tests.fs | 3 +- .../Translator/Printf/Tests.fs | 3 +- .../QuatationTransformation/LambdaLifting.fs | 4 +- .../QuatationTransformation/Transformation.fs | 3 +- .../VarDefsToLambda.fs | 4 +- .../Translator/Specific/MergePath.fs | 212 +++++++++--------- 19 files changed, 135 insertions(+), 148 deletions(-) diff --git a/tests/Brahma.FSharp.Tests/ExecutionTests/CompilationTests.fs b/tests/Brahma.FSharp.Tests/ExecutionTests/CompilationTests.fs index 650bbb6c..d7892cf2 100644 --- a/tests/Brahma.FSharp.Tests/ExecutionTests/CompilationTests.fs +++ b/tests/Brahma.FSharp.Tests/ExecutionTests/CompilationTests.fs @@ -82,7 +82,7 @@ let unionTests context = @> testGen - testCase + ptestCase // TODO(https://github.com/YaccConstructor/Brahma.FSharp/issues/152) "Test 2: TranslateTest.B" "Union.Compile.Test2.gen" "Union.Compile.Test2.cl" @@ -131,7 +131,7 @@ let unionTests context = let testUnionCaseTestLists = [ testGen - testCase + ptestCase // TODO(https://github.com/YaccConstructor/Brahma.FSharp/issues/152) "Test 1: simple pattern matching" "Union.Compile.Test6.gen" "Union.Compile.Test6.cl" @@ -148,7 +148,7 @@ let unionTests context = let unionPropertyGetTestLists = [ testGen - testCase + ptestCase // TODO(https://github.com/YaccConstructor/Brahma.FSharp/issues/152) "Test 1: simple pattern matching bindings" "Union.Compile.Test7.gen" "Union.Compile.Test7.cl" diff --git a/tests/Brahma.FSharp.Tests/ExecutionTests/CompositeTypesTests.fs b/tests/Brahma.FSharp.Tests/ExecutionTests/CompositeTypesTests.fs index 8922c419..610310f5 100644 --- a/tests/Brahma.FSharp.Tests/ExecutionTests/CompositeTypesTests.fs +++ b/tests/Brahma.FSharp.Tests/ExecutionTests/CompositeTypesTests.fs @@ -349,6 +349,7 @@ let unionTests context = + @> testProperty (message "SimpleDU") @@ -423,6 +424,7 @@ let unionTests context = + @> testProperty (message "EnumDU") diff --git a/tests/Brahma.FSharp.Tests/Program.fs b/tests/Brahma.FSharp.Tests/Program.fs index 558e91d9..99baa43a 100644 --- a/tests/Brahma.FSharp.Tests/Program.fs +++ b/tests/Brahma.FSharp.Tests/Program.fs @@ -6,10 +6,9 @@ open Brahma.FSharp.Tests let allTests = testList "All tests" - [ Translator.All.tests] + [ Translator.All.tests + testList "Execution tests" ExecutionTests.tests ] |> testSequenced -open System.IO - [] let main argv = allTests |> runTestsWithCLIArgs [] argv diff --git a/tests/Brahma.FSharp.Tests/Translator/All.fs b/tests/Brahma.FSharp.Tests/Translator/All.fs index bbdef9fb..ba4b4eaf 100644 --- a/tests/Brahma.FSharp.Tests/Translator/All.fs +++ b/tests/Brahma.FSharp.Tests/Translator/All.fs @@ -20,9 +20,7 @@ let private common translator = |> List.map (fun f -> f translator) |> testList "Common" -let private union _ = - [ Union.tests ] - |> testList "Union" +let private union _ = [ Union.tests ] |> testList "Union" let private transformation translator = [ QuatationTransformation.Transformation.tests diff --git a/tests/Brahma.FSharp.Tests/Translator/Carrying/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/Carrying/Tests.fs index 7cfd4ed1..c0ef9bbb 100644 --- a/tests/Brahma.FSharp.Tests/Translator/Carrying/Tests.fs +++ b/tests/Brahma.FSharp.Tests/Translator/Carrying/Tests.fs @@ -8,7 +8,10 @@ open Expecto let private basePath = Path.Combine("Translator", "Carrying", "Expected") let private curryingTests translator = - [ let inline createTest name = Helpers.createTest translator basePath name + [ let inline createTest name = + Helpers.createTest translator basePath name + + let inline createPTest name _ = Helpers.createPTest name <@ fun (range: Range1D) (buf: int clarray) -> @@ -17,7 +20,7 @@ let private curryingTests translator = buf.[0] <- g 3 buf.[1] <- g 5 @> - |> createTest "Nested functions.Carrying 1." "Nested.Function.Carring.cl" + |> createPTest "Nested functions.Carrying 1." // "Nested.Function.Carring.cl" TODO(error: f application) <@ fun (range: Range1D) (buf: int clarray) -> @@ -33,9 +36,7 @@ let private curryingTests translator = buf.[0] <- g 2 buf.[1] <- g 3 @> - |> createTest "Nested functions.Currying 2." "Nested.Function.Carring2.cl" ] + |> createPTest "Nested functions.Currying 2." ] // "Nested.Function.Carring2.cl" TODO(error) let tests translator = - curryingTests translator - |> testList "Currying" - + curryingTests translator |> testList "Currying" diff --git a/tests/Brahma.FSharp.Tests/Translator/ConstantArray/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/ConstantArray/Tests.fs index a57f868f..eedb47ec 100644 --- a/tests/Brahma.FSharp.Tests/Translator/ConstantArray/Tests.fs +++ b/tests/Brahma.FSharp.Tests/Translator/ConstantArray/Tests.fs @@ -28,5 +28,4 @@ let private constantArrayTests translator = |> createTest "Constant array translation. Test 2" "Constant array translation. Test 2.cl" ] let tests translator = - constantArrayTests translator - |> testList "ConstantArray" + constantArrayTests translator |> testList "ConstantArray" diff --git a/tests/Brahma.FSharp.Tests/Translator/ControlFlow/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/ControlFlow/Tests.fs index ac389c7e..08957de0 100644 --- a/tests/Brahma.FSharp.Tests/Translator/ControlFlow/Tests.fs +++ b/tests/Brahma.FSharp.Tests/Translator/ControlFlow/Tests.fs @@ -9,7 +9,8 @@ open Brahma.FSharp.OpenCL.Translator let private basePath = Path.Combine("Translator", "ControlFlow", "Expected") let private controlFlowTests translator = - [ let inline createTest name = Helpers.createTest translator basePath name + [ let inline createTest name = + Helpers.createTest translator basePath name let inline createPTest name _ = Helpers.createPTest name diff --git a/tests/Brahma.FSharp.Tests/Translator/Injection/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/Injection/Tests.fs index fb2026b8..825a8ef2 100644 --- a/tests/Brahma.FSharp.Tests/Translator/Injection/Tests.fs +++ b/tests/Brahma.FSharp.Tests/Translator/Injection/Tests.fs @@ -30,5 +30,4 @@ let private quotationsInjectionTests translator = |> createTest "Quotations injections 2" "Quotations.Injections.2.cl" ] let tests translator = - quotationsInjectionTests translator - |> testList "QuotationsInjection" + quotationsInjectionTests translator |> testList "QuotationsInjection" diff --git a/tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Tests.fs index bb5deb5a..bb6565e7 100644 --- a/tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Tests.fs +++ b/tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Tests.fs @@ -259,5 +259,4 @@ let private lambdaLiftingTests translator = |> createTest "Nested functions" "Nested.Function.cl" ] let tests translator = - lambdaLiftingTests translator - |> testList "LambdaLifting" + lambdaLiftingTests translator |> testList "LambdaLifting" diff --git a/tests/Brahma.FSharp.Tests/Translator/LangExtensions/Barrier/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/Barrier/Tests.fs index ea29e9bc..b2c6d167 100644 --- a/tests/Brahma.FSharp.Tests/Translator/LangExtensions/Barrier/Tests.fs +++ b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/Barrier/Tests.fs @@ -21,5 +21,4 @@ let private barrierTests translator = |> createTest "Full barrier translation tests" "Barrier.Full.cl" ] let tests translator = - barrierTests translator - |> testList "Barrier" + barrierTests translator |> testList "Barrier" diff --git a/tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalID/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalID/Tests.fs index 6eb83fef..68a59bac 100644 --- a/tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalID/Tests.fs +++ b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalID/Tests.fs @@ -27,5 +27,4 @@ let private basicLocalIdTests translator = |> createTest "LocalID of 2D" "LocalID2D.cl" ] let tests translator = - basicLocalIdTests translator - |> testList "BasicLocalId" + basicLocalIdTests translator |> testList "BasicLocalId" diff --git a/tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalMemory/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalMemory/Tests.fs index 3b3806f8..b236dd3e 100644 --- a/tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalMemory/Tests.fs +++ b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalMemory/Tests.fs @@ -33,5 +33,4 @@ let private localMemoryTests translator = |> createTest "Local int array" "LocalMemory.int [].cl" ] let tests translator = - localMemoryTests translator - |> testList "LocalMemory" + localMemoryTests translator |> testList "LocalMemory" diff --git a/tests/Brahma.FSharp.Tests/Translator/LangExtensions/WorkSize/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/WorkSize/Tests.fs index 152d5b05..90290207 100644 --- a/tests/Brahma.FSharp.Tests/Translator/LangExtensions/WorkSize/Tests.fs +++ b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/WorkSize/Tests.fs @@ -37,5 +37,4 @@ let private basicWorkSizeTests translator = |> createTest "WorkSize of 3D" "WorkSize3D.cl" ] let tests translator = - basicWorkSizeTests translator - |> testList "BasicWorkSize" + basicWorkSizeTests translator |> testList "BasicWorkSize" diff --git a/tests/Brahma.FSharp.Tests/Translator/NamesResolving/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/NamesResolving/Tests.fs index a044f111..3edbd067 100644 --- a/tests/Brahma.FSharp.Tests/Translator/NamesResolving/Tests.fs +++ b/tests/Brahma.FSharp.Tests/Translator/NamesResolving/Tests.fs @@ -56,5 +56,4 @@ let private namesResolvingTests translator = |> createTest "Binding and FOR counter conflict 4." "Binding.And.FOR.Counter.Conflict.4.cl" ] let tests translator = - namesResolvingTests translator - |> testList "NamesResolving" + namesResolvingTests translator |> testList "NamesResolving" diff --git a/tests/Brahma.FSharp.Tests/Translator/Printf/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/Printf/Tests.fs index 3ec8e952..be9e8eba 100644 --- a/tests/Brahma.FSharp.Tests/Translator/Printf/Tests.fs +++ b/tests/Brahma.FSharp.Tests/Translator/Printf/Tests.fs @@ -44,5 +44,4 @@ let private printfTests translator = |> createTest "Printf test 6: printfn without args" "Printf test 6.cl" ] let tests translator = - printfTests translator - |> testList "Printf" + printfTests translator |> testList "Printf" diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/LambdaLifting.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/LambdaLifting.fs index 37e5f2a6..4f7f9a27 100644 --- a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/LambdaLifting.fs +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/LambdaLifting.fs @@ -104,6 +104,4 @@ let private lambdaLiftingTests = @> ] let tests _ = - lambdaLiftingTests - |> testList "Lambda lifting" - + lambdaLiftingTests |> testList "Lambda lifting" diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Transformation.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Transformation.fs index 72dc2826..516f0b2e 100644 --- a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Transformation.fs +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Transformation.fs @@ -184,5 +184,4 @@ let private quotationTransformerTest translator = @> ] let tests translator = - quotationTransformerTest translator - |> testList "Transformation" + quotationTransformerTest translator |> testList "Transformation" diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/VarDefsToLambda.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/VarDefsToLambda.fs index ec44f9ea..2c47b31a 100644 --- a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/VarDefsToLambda.fs +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/VarDefsToLambda.fs @@ -90,6 +90,4 @@ let private varDefsToLambdaTest = @> ] let tests _ = - varDefsToLambdaTest - |> testList "Var -> Lambda" - + varDefsToLambdaTest |> testList "Var -> Lambda" diff --git a/tests/Brahma.FSharp.Tests/Translator/Specific/MergePath.fs b/tests/Brahma.FSharp.Tests/Translator/Specific/MergePath.fs index aaf48149..887cf8c5 100644 --- a/tests/Brahma.FSharp.Tests/Translator/Specific/MergePath.fs +++ b/tests/Brahma.FSharp.Tests/Translator/Specific/MergePath.fs @@ -8,147 +8,147 @@ open Brahma.FSharp.OpenCL.Translator let private basePath = Path.Combine("Translator", "Specific", "Expected") let tests (translator: FSQuotationToOpenCLTranslator) = - let inline createTest name = - Helpers.createTest translator basePath name + let inline createTest name = + Helpers.createTest translator basePath name - let workGroupSize = 256 + let workGroupSize = 256 - <@ - fun - (ndRange: Range1D) - firstSide - secondSide - sumOfSides - (firstRowsBuffer: ClArray) - (firstColumnsBuffer: ClArray) - (firstValuesBuffer: ClArray) - (secondRowsBuffer: ClArray) - (secondColumnsBuffer: ClArray) - (secondValuesBuffer: ClArray) - (allRowsBuffer: ClArray) - (allColumnsBuffer: ClArray) - (allValuesBuffer: ClArray) -> + <@ + fun + (ndRange: Range1D) + firstSide + secondSide + sumOfSides + (firstRowsBuffer: ClArray) + (firstColumnsBuffer: ClArray) + (firstValuesBuffer: ClArray) + (secondRowsBuffer: ClArray) + (secondColumnsBuffer: ClArray) + (secondValuesBuffer: ClArray) + (allRowsBuffer: ClArray) + (allColumnsBuffer: ClArray) + (allValuesBuffer: ClArray) -> - let i = ndRange.GlobalID0 + let i = ndRange.GlobalID0 - let mutable beginIdxLocal = local () - let mutable endIdxLocal = local () - let localID = ndRange.LocalID0 + let mutable beginIdxLocal = local () + let mutable endIdxLocal = local () + let localID = ndRange.LocalID0 - if localID < 2 then - let mutable x = localID * (workGroupSize - 1) + i - 1 + if localID < 2 then + let mutable x = localID * (workGroupSize - 1) + i - 1 - if x >= sumOfSides then - x <- sumOfSides - 1 + if x >= sumOfSides then + x <- sumOfSides - 1 - let diagonalNumber = x + let diagonalNumber = x - let mutable leftEdge = diagonalNumber + 1 - secondSide + let mutable leftEdge = diagonalNumber + 1 - secondSide - if leftEdge < 0 then - leftEdge <- 0 + if leftEdge < 0 then + leftEdge <- 0 - let mutable rightEdge = firstSide - 1 + let mutable rightEdge = firstSide - 1 - if rightEdge > diagonalNumber then - rightEdge <- diagonalNumber + if rightEdge > diagonalNumber then + rightEdge <- diagonalNumber - while leftEdge <= rightEdge do - let middleIdx = (leftEdge + rightEdge) / 2 + while leftEdge <= rightEdge do + let middleIdx = (leftEdge + rightEdge) / 2 - let firstIndex: uint64 = - ((uint64 firstRowsBuffer.[middleIdx]) <<< 32) - ||| (uint64 firstColumnsBuffer.[middleIdx]) + let firstIndex: uint64 = + ((uint64 firstRowsBuffer.[middleIdx]) <<< 32) + ||| (uint64 firstColumnsBuffer.[middleIdx]) - let secondIndex: uint64 = - ((uint64 secondRowsBuffer.[diagonalNumber - middleIdx]) <<< 32) - ||| (uint64 secondColumnsBuffer.[diagonalNumber - middleIdx]) + let secondIndex: uint64 = + ((uint64 secondRowsBuffer.[diagonalNumber - middleIdx]) <<< 32) + ||| (uint64 secondColumnsBuffer.[diagonalNumber - middleIdx]) - if firstIndex < secondIndex then - leftEdge <- middleIdx + 1 - else - rightEdge <- middleIdx - 1 + if firstIndex < secondIndex then + leftEdge <- middleIdx + 1 + else + rightEdge <- middleIdx - 1 - // Here localID equals either 0 or 1 - if localID = 0 then - beginIdxLocal <- leftEdge - else - endIdxLocal <- leftEdge + // Here localID equals either 0 or 1 + if localID = 0 then + beginIdxLocal <- leftEdge + else + endIdxLocal <- leftEdge - barrierLocal () + barrierLocal () - let beginIdx = beginIdxLocal - let endIdx = endIdxLocal - let firstLocalLength = endIdx - beginIdx - let mutable x = workGroupSize - firstLocalLength + let beginIdx = beginIdxLocal + let endIdx = endIdxLocal + let firstLocalLength = endIdx - beginIdx + let mutable x = workGroupSize - firstLocalLength - if endIdx = firstSide then - x <- secondSide - i + localID + beginIdx + if endIdx = firstSide then + x <- secondSide - i + localID + beginIdx - let secondLocalLength = x + let secondLocalLength = x - //First indices are from 0 to firstLocalLength - 1 inclusive - //Second indices are from firstLocalLength to firstLocalLength + secondLocalLength - 1 inclusive - let localIndices = localArray workGroupSize + //First indices are from 0 to firstLocalLength - 1 inclusive + //Second indices are from firstLocalLength to firstLocalLength + secondLocalLength - 1 inclusive + let localIndices = localArray workGroupSize - if localID < firstLocalLength then - localIndices.[localID] <- - ((uint64 firstRowsBuffer.[beginIdx + localID]) <<< 32) - ||| (uint64 firstColumnsBuffer.[beginIdx + localID]) + if localID < firstLocalLength then + localIndices.[localID] <- + ((uint64 firstRowsBuffer.[beginIdx + localID]) <<< 32) + ||| (uint64 firstColumnsBuffer.[beginIdx + localID]) - if localID < secondLocalLength then - localIndices.[firstLocalLength + localID] <- - ((uint64 secondRowsBuffer.[i - beginIdx]) <<< 32) - ||| (uint64 secondColumnsBuffer.[i - beginIdx]) + if localID < secondLocalLength then + localIndices.[firstLocalLength + localID] <- + ((uint64 secondRowsBuffer.[i - beginIdx]) <<< 32) + ||| (uint64 secondColumnsBuffer.[i - beginIdx]) - barrierLocal () + barrierLocal () - if i < sumOfSides then - let mutable leftEdge = localID + 1 - secondLocalLength + if i < sumOfSides then + let mutable leftEdge = localID + 1 - secondLocalLength - if leftEdge < 0 then - leftEdge <- 0 + if leftEdge < 0 then + leftEdge <- 0 - let mutable rightEdge = firstLocalLength - 1 + let mutable rightEdge = firstLocalLength - 1 - if rightEdge > localID then - rightEdge <- localID + if rightEdge > localID then + rightEdge <- localID - while leftEdge <= rightEdge do - let middleIdx = (leftEdge + rightEdge) / 2 - let firstIndex = localIndices.[middleIdx] + while leftEdge <= rightEdge do + let middleIdx = (leftEdge + rightEdge) / 2 + let firstIndex = localIndices.[middleIdx] - let secondIndex = localIndices.[firstLocalLength + localID - middleIdx] + let secondIndex = localIndices.[firstLocalLength + localID - middleIdx] - if firstIndex < secondIndex then - leftEdge <- middleIdx + 1 - else - rightEdge <- middleIdx - 1 + if firstIndex < secondIndex then + leftEdge <- middleIdx + 1 + else + rightEdge <- middleIdx - 1 - let boundaryX = rightEdge - let boundaryY = localID - leftEdge + let boundaryX = rightEdge + let boundaryY = localID - leftEdge - // boundaryX and boundaryY can't be off the right edge of array (only off the left edge) - let isValidX = boundaryX >= 0 - let isValidY = boundaryY >= 0 + // boundaryX and boundaryY can't be off the right edge of array (only off the left edge) + let isValidX = boundaryX >= 0 + let isValidY = boundaryY >= 0 - let mutable fstIdx = 0UL + let mutable fstIdx = 0UL - if isValidX then - fstIdx <- localIndices.[boundaryX] + if isValidX then + fstIdx <- localIndices.[boundaryX] - let mutable sndIdx = 0UL + let mutable sndIdx = 0UL - if isValidY then - sndIdx <- localIndices.[firstLocalLength + boundaryY] + if isValidY then + sndIdx <- localIndices.[firstLocalLength + boundaryY] - if not isValidX || isValidY && fstIdx < sndIdx then - allRowsBuffer.[i] <- int (sndIdx >>> 32) - allColumnsBuffer.[i] <- int sndIdx - allValuesBuffer.[i] <- secondValuesBuffer.[i - localID - beginIdx + boundaryY] - else - allRowsBuffer.[i] <- int (fstIdx >>> 32) - allColumnsBuffer.[i] <- int fstIdx - allValuesBuffer.[i] <- firstValuesBuffer.[beginIdx + boundaryX] - @> - |> createTest "Merge path" "MergeKernel.cl" + if not isValidX || isValidY && fstIdx < sndIdx then + allRowsBuffer.[i] <- int (sndIdx >>> 32) + allColumnsBuffer.[i] <- int sndIdx + allValuesBuffer.[i] <- secondValuesBuffer.[i - localID - beginIdx + boundaryY] + else + allRowsBuffer.[i] <- int (fstIdx >>> 32) + allColumnsBuffer.[i] <- int fstIdx + allValuesBuffer.[i] <- firstValuesBuffer.[beginIdx + boundaryX] + @> + |> createTest "Merge path" "MergeKernel.cl" From 74ee6871440de94ea4735201e0218a36ab9c783e Mon Sep 17 00:00:00 2001 From: IgorErin Date: Thu, 6 Jul 2023 23:43:48 +0300 Subject: [PATCH 07/22] refactor: tests, fantomas on --- Brahma.FSharp.sln | 14 ++++++++ build/build.fs | 6 ++-- .../ExecutionTests/CompositeTypesTests.fs | 35 ------------------- 3 files changed, 17 insertions(+), 38 deletions(-) diff --git a/Brahma.FSharp.sln b/Brahma.FSharp.sln index 7d3ba1e5..5f8441ed 100644 --- a/Brahma.FSharp.sln +++ b/Brahma.FSharp.sln @@ -27,6 +27,8 @@ Project("{2150E333-8FDC-42A3-9474-1A3956D46DE8}") = "benchmarks", "benchmarks", EndProject Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "Brahma.FSharp.Benchmarks", "benchmarks\Brahma.FSharp.Benchmarks\Brahma.FSharp.Benchmarks.fsproj", "{3CB90A8F-D372-426E-930A-65833F46E796}" EndProject +Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "build", "build\build.fsproj", "{BB36B500-C0C3-438C-9423-3536BBF1B123}" +EndProject Global GlobalSection(SolutionConfigurationPlatforms) = preSolution Debug|Any CPU = Debug|Any CPU @@ -148,6 +150,18 @@ Global {3CB90A8F-D372-426E-930A-65833F46E796}.Release|x64.Build.0 = Release|Any CPU {3CB90A8F-D372-426E-930A-65833F46E796}.Release|x86.ActiveCfg = Release|Any CPU {3CB90A8F-D372-426E-930A-65833F46E796}.Release|x86.Build.0 = Release|Any CPU + {BB36B500-C0C3-438C-9423-3536BBF1B123}.Debug|Any CPU.ActiveCfg = Debug|Any CPU + {BB36B500-C0C3-438C-9423-3536BBF1B123}.Debug|Any CPU.Build.0 = Debug|Any CPU + {BB36B500-C0C3-438C-9423-3536BBF1B123}.Debug|x64.ActiveCfg = Debug|Any CPU + {BB36B500-C0C3-438C-9423-3536BBF1B123}.Debug|x64.Build.0 = Debug|Any CPU + {BB36B500-C0C3-438C-9423-3536BBF1B123}.Debug|x86.ActiveCfg = Debug|Any CPU + {BB36B500-C0C3-438C-9423-3536BBF1B123}.Debug|x86.Build.0 = Debug|Any CPU + {BB36B500-C0C3-438C-9423-3536BBF1B123}.Release|Any CPU.ActiveCfg = Release|Any CPU + {BB36B500-C0C3-438C-9423-3536BBF1B123}.Release|Any CPU.Build.0 = Release|Any CPU + {BB36B500-C0C3-438C-9423-3536BBF1B123}.Release|x64.ActiveCfg = Release|Any CPU + {BB36B500-C0C3-438C-9423-3536BBF1B123}.Release|x64.Build.0 = Release|Any CPU + {BB36B500-C0C3-438C-9423-3536BBF1B123}.Release|x86.ActiveCfg = Release|Any CPU + {BB36B500-C0C3-438C-9423-3536BBF1B123}.Release|x86.Build.0 = Release|Any CPU EndGlobalSection GlobalSection(NestedProjects) = preSolution {455B3C80-98CD-484A-8AD0-6EB93E504D84} = {569DF79C-F1A0-4AE9-BE73-17628649518C} diff --git a/build/build.fs b/build/build.fs index 3f36a68b..ed77cd8f 100644 --- a/build/build.fs +++ b/build/build.fs @@ -616,7 +616,7 @@ let formatCode _ = |> dotnet.fantomas if not result.OK then - printfn "Errors while formatting all files: %A" result.Messages + printfn $"Code: %i{result.ExitCode} Errors while formatting all files: %A{result.Messages}" let checkFormatCode _ = let result = @@ -636,7 +636,7 @@ let checkFormatCode _ = elif result.ExitCode = 99 then failwith "Some files need formatting, check output for more info" else - Trace.logf "Errors while formatting: %A" result.Errors + Trace.logf $"Code: %i{result.ExitCode} Errors while formatting: %A{result.Errors}" let buildDocs _ = DocsTool.build () @@ -727,7 +727,7 @@ let initTargets () = ==>! "Release" "DotnetRestore" - //==> "CheckFormatCode" + ==> "CheckFormatCode" ==> "DotnetBuild" //==> "FSharpAnalyzers" ==> "DotnetTest" diff --git a/tests/Brahma.FSharp.Tests/ExecutionTests/CompositeTypesTests.fs b/tests/Brahma.FSharp.Tests/ExecutionTests/CompositeTypesTests.fs index 610310f5..e85c1267 100644 --- a/tests/Brahma.FSharp.Tests/ExecutionTests/CompositeTypesTests.fs +++ b/tests/Brahma.FSharp.Tests/ExecutionTests/CompositeTypesTests.fs @@ -335,21 +335,6 @@ let unionTests context = | Some { X = x; Y = y } -> Some(Some { X = x; Y = y }) | None -> Some None | None -> None - - // TODO didnt work - // | Some (Some { X = x; Y = y }) -> Some (Some { X = x; Y = y }) - // | Some None -> Some None - // | None -> None - - - - - - - - - - @> testProperty (message "SimpleDU") @@ -371,15 +356,6 @@ let unionTests context = ptestProperty (message "GenericDU>") <| fun (data: GenericDU>[]) -> - // TODO test case - // let data = - // [| - // GenericDU.C { - // X = true - // Y = Some true - // } - // |] - if data.Length <> 0 then check data <| fun length -> @@ -414,17 +390,6 @@ let unionTests context = | { X = Some x; Y = None } -> { X = Some x; Y = None } | { X = None; Y = Some y } -> { X = None; Y = Some y } | { X = None; Y = None } -> { X = None; Y = None } - - - - - - - - - - - @> testProperty (message "EnumDU") From 5da31afdfb2d2d8dec1cb9bb361bfec0e7a4e7fb Mon Sep 17 00:00:00 2001 From: IgorErin Date: Fri, 7 Jul 2023 13:50:34 +0300 Subject: [PATCH 08/22] refactor: paket update --- paket.lock | 327 +++++++----------- tests/Brahma.FSharp.Tests/Program.fs | 2 +- tests/Brahma.FSharp.Tests/Translator/All.fs | 9 +- .../Translator/BinOp/Tests.fs | 8 +- .../Translator/Carrying/Tests.fs | 10 +- .../Brahma.FSharp.Tests/Translator/Common.fs | 26 +- .../Translator/ConstantArray/Tests.fs | 8 +- .../Translator/ControlFlow/Tests.fs | 8 +- .../Translator/Injection/Tests.fs | 8 +- .../Translator/LambdaLifting/Tests.fs | 8 +- .../Translator/LangExtensions/Atomic.fs | 10 +- .../LangExtensions/Barrier/Tests.fs | 8 +- .../LangExtensions/LocalID/Tests.fs | 8 +- .../LangExtensions/LocalMemory/Tests.fs | 8 +- .../LangExtensions/WorkSize/Tests.fs | 8 +- .../Translator/NamesResolving/Tests.fs | 8 +- .../Translator/Printf/Tests.fs | 8 +- .../QuatationTransformation/LambdaLifting.fs | 3 +- .../QuatationTransformation/Transformation.fs | 8 +- .../VarDefsToLambda.fs | 3 +- .../Translator/Specific/MergePath.fs | 5 +- 21 files changed, 187 insertions(+), 304 deletions(-) diff --git a/paket.lock b/paket.lock index 53799761..6a4feaa9 100644 --- a/paket.lock +++ b/paket.lock @@ -3,8 +3,8 @@ RESTRICTION: == net7.0 NUGET remote: https://www.nuget.org/api/v2 altcover (7.6.812) - BenchmarkDotNet (0.13.3) - BenchmarkDotNet.Annotations (>= 0.13.3) + BenchmarkDotNet (0.13.5) + BenchmarkDotNet.Annotations (>= 0.13.5) CommandLineParser (>= 2.4.3) Gee.External.Capstone (>= 2.3) Iced (>= 1.17) @@ -14,7 +14,7 @@ NUGET Microsoft.DotNet.PlatformAbstractions (>= 3.1.6) Perfolizer (>= 0.2.1) System.Management (>= 6.0) - BenchmarkDotNet.Annotations (0.13.3) + BenchmarkDotNet.Annotations (0.13.5) CommandLineParser (2.9.1) Expecto (9.0.4) FSharp.Core (>= 4.6) @@ -25,8 +25,8 @@ NUGET ExtraConstraints.Fody (1.14) Fody (>= 6.0) NETStandard.Library (>= 1.6.1) - Fody (6.6.4) - FsCheck (2.16.5) + Fody (6.8) + FsCheck (2.16.6) FSharp.Core (>= 4.2.3) FSCL.Compiler (2.0.1) FSCL.Runtime (2.0.1) @@ -39,36 +39,32 @@ NUGET FSharpx.Text.StructuredFormat (3.1) FSharp.Core (>= 4.6.2) Gee.External.Capstone (2.3) - Iced (1.18) + Iced (1.19) ILGPU (1.1) System.Collections.Immutable (>= 6.0) System.Memory (>= 4.5.4) System.Reflection.Metadata (>= 6.0.1) System.Runtime.CompilerServices.Unsafe (>= 6.0) - Microsoft.Bcl.AsyncInterfaces (7.0) Microsoft.Build.Framework (16.10) System.Security.Permissions (>= 4.7) Microsoft.Build.Tasks.Git (1.1.1) - copy_local: true - Microsoft.CodeAnalysis.Analyzers (3.3.3) - Microsoft.CodeAnalysis.Common (4.4) - Microsoft.CodeAnalysis.Analyzers (>= 3.3.3) - System.Collections.Immutable (>= 6.0) - System.Memory (>= 4.5.5) - System.Reflection.Metadata (>= 5.0) + Microsoft.CodeAnalysis.Analyzers (3.3.4) + Microsoft.CodeAnalysis.Common (4.6) + Microsoft.CodeAnalysis.Analyzers (>= 3.3.4) + System.Collections.Immutable (>= 7.0) + System.Reflection.Metadata (>= 7.0) System.Runtime.CompilerServices.Unsafe (>= 6.0) - System.Text.Encoding.CodePages (>= 6.0) - System.Threading.Tasks.Extensions (>= 4.5.4) - Microsoft.CodeAnalysis.CSharp (4.4) - Microsoft.CodeAnalysis.Common (4.4) - Microsoft.CodeCoverage (17.4.1) - Microsoft.Diagnostics.NETCore.Client (0.2.351802) - Microsoft.Bcl.AsyncInterfaces (>= 1.1) - Microsoft.Extensions.Logging (>= 2.1.1) - Microsoft.Diagnostics.Runtime (2.2.343001) + System.Text.Encoding.CodePages (>= 7.0) + Microsoft.CodeAnalysis.CSharp (4.6) + Microsoft.CodeAnalysis.Common (4.6) + Microsoft.CodeCoverage (17.6.3) + Microsoft.Diagnostics.NETCore.Client (0.2.430602) + Microsoft.Extensions.Logging (>= 6.0) + Microsoft.Diagnostics.Runtime (2.4.416101) Microsoft.Diagnostics.NETCore.Client (>= 0.2.251802) System.Collections.Immutable (>= 5.0) System.Runtime.CompilerServices.Unsafe (>= 5.0) - Microsoft.Diagnostics.Tracing.TraceEvent (3.0.6) + Microsoft.Diagnostics.Tracing.TraceEvent (3.1.3) System.Runtime.CompilerServices.Unsafe (>= 5.0) Microsoft.DotNet.PlatformAbstractions (3.1.6) Microsoft.Extensions.DependencyInjection (7.0) @@ -79,47 +75,45 @@ NUGET Microsoft.Extensions.DependencyInjection.Abstractions (>= 7.0) Microsoft.Extensions.Logging.Abstractions (>= 7.0) Microsoft.Extensions.Options (>= 7.0) - Microsoft.Extensions.Logging.Abstractions (7.0) - Microsoft.Extensions.Options (7.0) + Microsoft.Extensions.Logging.Abstractions (7.0.1) + Microsoft.Extensions.Options (7.0.1) Microsoft.Extensions.DependencyInjection.Abstractions (>= 7.0) Microsoft.Extensions.Primitives (>= 7.0) Microsoft.Extensions.Primitives (7.0) Microsoft.NET.Test.Sdk (16.8) Microsoft.CodeCoverage (>= 16.8) Microsoft.TestPlatform.TestHost (>= 16.8) - Microsoft.NETCore.Platforms (7.0) + Microsoft.NETCore.Platforms (7.0.3) Microsoft.SourceLink.Common (1.1.1) - copy_local: true Microsoft.SourceLink.GitHub (1.0) - copy_local: true Microsoft.Build.Tasks.Git (>= 1.0) Microsoft.SourceLink.Common (>= 1.0) - Microsoft.TestPlatform.ObjectModel (17.4.1) - NuGet.Frameworks (>= 5.11) + Microsoft.TestPlatform.ObjectModel (17.6.3) + NuGet.Frameworks (>= 6.5) System.Reflection.Metadata (>= 1.6) - Microsoft.TestPlatform.TestHost (17.4.1) - Microsoft.TestPlatform.ObjectModel (>= 17.4.1) + Microsoft.TestPlatform.TestHost (17.6.3) + Microsoft.TestPlatform.ObjectModel (>= 17.6.3) Newtonsoft.Json (>= 13.0.1) Microsoft.Win32.SystemEvents (7.0) - Mono.Cecil (0.11.4) + Mono.Cecil (0.11.5) NETStandard.Library (2.0.3) Microsoft.NETCore.Platforms (>= 1.1) - Newtonsoft.Json (13.0.2) - NuGet.Frameworks (6.4) - Perfolizer (0.2.1) - System.Memory (>= 4.5.3) + Newtonsoft.Json (13.0.3) + NuGet.Frameworks (6.6.1) + Perfolizer (0.3.4) System.CodeDom (7.0) System.Collections.Immutable (7.0) System.Drawing.Common (7.0) Microsoft.Win32.SystemEvents (>= 7.0) - System.Management (7.0) + System.Management (7.0.2) System.CodeDom (>= 7.0) System.Memory (4.5.5) - System.Reflection.Metadata (7.0) + System.Reflection.Metadata (7.0.2) System.Collections.Immutable (>= 7.0) System.Runtime.CompilerServices.Unsafe (6.0) System.Security.Permissions (7.0) System.Windows.Extensions (>= 7.0) System.Text.Encoding.CodePages (7.0) - System.Threading.Tasks.Extensions (4.5.4) System.Windows.Extensions (7.0) System.Drawing.Common (>= 7.0) YoloDev.Expecto.TestSdk (0.13.3) @@ -145,15 +139,15 @@ NUGET Fake.Core.Environment (>= 6.0.0-beta001) Fake.Core.Trace (>= 6.0.0-beta001) FSharp.Core (>= 6.0.3) - Fake.Core.CommandLineParsing (6.0.0-beta001) + Fake.Core.CommandLineParsing (6.0) FParsec (>= 1.1.1) FSharp.Core (>= 6.0.3) - Fake.Core.Context (6.0.0-beta001) + Fake.Core.Context (6.0) FSharp.Core (>= 6.0.3) Fake.Core.Environment (6.0.0-beta001) FSharp.Core (>= 6.0.3) - Fake.Core.FakeVar (6.0.0-beta001) - Fake.Core.Context (>= 6.0.0-beta001) + Fake.Core.FakeVar (6.0) + Fake.Core.Context (>= 6.0) FSharp.Core (>= 6.0.3) Fake.Core.Process (6.0.0-beta001) Fake.Core.Environment (>= 6.0.0-beta001) @@ -167,9 +161,9 @@ NUGET Fake.Core.SemVer (>= 6.0.0-beta001) Fake.Core.String (>= 6.0.0-beta001) FSharp.Core (>= 6.0.3) - Fake.Core.SemVer (6.0.0-beta001) + Fake.Core.SemVer (6.0) FSharp.Core (>= 6.0.3) - Fake.Core.String (6.0.0-beta001) + Fake.Core.String (6.0) FSharp.Core (>= 6.0.3) Fake.Core.Target (6.0.0-beta001) Fake.Core.CommandLineParsing (>= 6.0.0-beta001) @@ -188,8 +182,8 @@ NUGET Fake.Core.Environment (>= 6.0.0-beta001) Fake.Core.FakeVar (>= 6.0.0-beta001) FSharp.Core (>= 6.0.3) - Fake.Core.Xml (6.0.0-beta001) - Fake.Core.String (>= 6.0.0-beta001) + Fake.Core.Xml (6.0) + Fake.Core.String (>= 6.0) FSharp.Core (>= 6.0.3) Fake.DotNet.AssemblyInfoFile (6.0.0-beta001) Fake.Core.Environment (>= 6.0.0-beta001) @@ -252,74 +246,49 @@ NUGET Fake.Core.Trace (>= 6.0.0-beta001) Fake.IO.FileSystem (>= 6.0.0-beta001) FSharp.Core (>= 6.0.3) - fantomas (5.1.5) + fantomas (6.1.1) FParsec (1.1.1) FSharp.Core (>= 4.3.4) FSharp.Control.Reactive (5.0.5) FSharp.Core (>= 4.7.2) System.Reactive (>= 5.0 < 6.0) - FSharp.Core (7.0) - Microsoft.Build (17.4) - Microsoft.Build.Framework (>= 17.4) - Microsoft.NET.StringTools (>= 17.4) - System.Collections.Immutable (>= 6.0) - System.Configuration.ConfigurationManager (>= 6.0) - System.Reflection.Metadata (>= 6.0) - System.Reflection.MetadataLoadContext (>= 6.0) - System.Security.Principal.Windows (>= 5.0) - System.Text.Encoding.CodePages (>= 6.0) - System.Text.Json (>= 6.0) - System.Threading.Tasks.Dataflow (>= 6.0) - Microsoft.Build.Framework (17.4) - System.Security.Permissions (>= 6.0) - Microsoft.Build.Tasks.Core (17.4) - Microsoft.Build.Framework (>= 17.4) - Microsoft.Build.Utilities.Core (>= 17.4) - Microsoft.NET.StringTools (>= 17.4) - System.CodeDom (>= 6.0) - System.Collections.Immutable (>= 6.0) - System.Reflection.Metadata (>= 6.0) - System.Resources.Extensions (>= 6.0) - System.Security.Cryptography.Pkcs (>= 6.0.1) - System.Security.Cryptography.Xml (>= 6.0) - System.Security.Permissions (>= 6.0) - System.Threading.Tasks.Dataflow (>= 6.0) - Microsoft.Build.Utilities.Core (17.4) - Microsoft.Build.Framework (>= 17.4) - Microsoft.NET.StringTools (>= 17.4) - System.Collections.Immutable (>= 6.0) - System.Configuration.ConfigurationManager (>= 6.0) - Microsoft.NET.StringTools (17.4) - System.Memory (>= 4.5.5) - System.Runtime.CompilerServices.Unsafe (>= 6.0) + FSharp.Core (7.0.300) + Microsoft.Build.Framework (17.6.3) + System.Security.Permissions (>= 7.0) + Microsoft.Build.Utilities.Core (17.6.3) + Microsoft.Build.Framework (>= 17.6.3) + Microsoft.NET.StringTools (>= 17.6.3) + Microsoft.VisualStudio.Setup.Configuration.Interop (>= 3.2.2146) + System.Collections.Immutable (>= 7.0) + System.Configuration.ConfigurationManager (>= 7.0) + System.Security.Permissions (>= 7.0) + Microsoft.NET.StringTools (17.6.3) + Microsoft.VisualStudio.Setup.Configuration.Interop (3.6.2115) Microsoft.Win32.Registry (5.0) System.Security.AccessControl (>= 5.0) System.Security.Principal.Windows (>= 5.0) Microsoft.Win32.SystemEvents (7.0) Mono.Posix.NETStandard (1.0) - MSBuild.StructuredLogger (2.1.758) - Microsoft.Build (>= 16.10) - Microsoft.Build.Framework (>= 16.10) - Microsoft.Build.Tasks.Core (>= 16.10) - Microsoft.Build.Utilities.Core (>= 16.10) - Newtonsoft.Json (13.0.2) - NuGet.Common (6.4) - NuGet.Frameworks (>= 6.4) - NuGet.Configuration (6.4) - NuGet.Common (>= 6.4) + MSBuild.StructuredLogger (2.1.820) + Microsoft.Build.Framework (>= 17.5) + Microsoft.Build.Utilities.Core (>= 17.5) + Newtonsoft.Json (13.0.3) + NuGet.Common (6.6.1) + NuGet.Frameworks (>= 6.6.1) + NuGet.Configuration (6.6.1) + NuGet.Common (>= 6.6.1) System.Security.Cryptography.ProtectedData (>= 4.4) - NuGet.Frameworks (6.4) - NuGet.Packaging (6.4) + NuGet.Frameworks (6.6.1) + NuGet.Packaging (6.6.1) Newtonsoft.Json (>= 13.0.1) - NuGet.Configuration (>= 6.4) - NuGet.Versioning (>= 6.4) + NuGet.Configuration (>= 6.6.1) + NuGet.Versioning (>= 6.6.1) System.Security.Cryptography.Cng (>= 5.0) System.Security.Cryptography.Pkcs (>= 5.0) - NuGet.Protocol (6.4) - NuGet.Packaging (>= 6.4) - NuGet.Versioning (6.4) - Octokit (4.0.3) - System.CodeDom (7.0) + NuGet.Protocol (6.6.1) + NuGet.Packaging (>= 6.6.1) + NuGet.Versioning (6.6.1) + Octokit (7.0.1) System.Collections.Immutable (7.0) System.Configuration.ConfigurationManager (7.0) System.Diagnostics.EventLog (>= 7.0) @@ -329,31 +298,16 @@ NUGET System.Drawing.Common (7.0) Microsoft.Win32.SystemEvents (>= 7.0) System.Formats.Asn1 (7.0) - System.Memory (4.5.5) System.Reactive (5.0) - System.Reflection.Metadata (7.0) - System.Collections.Immutable (>= 7.0) - System.Reflection.MetadataLoadContext (7.0) - System.Collections.Immutable (>= 7.0) - System.Reflection.Metadata (>= 7.0) - System.Resources.Extensions (7.0) - System.Runtime.CompilerServices.Unsafe (6.0) System.Security.AccessControl (6.0) System.Security.Cryptography.Cng (5.0) System.Formats.Asn1 (>= 5.0) - System.Security.Cryptography.Pkcs (7.0) + System.Security.Cryptography.Pkcs (7.0.3) System.Formats.Asn1 (>= 7.0) - System.Security.Cryptography.ProtectedData (7.0) - System.Security.Cryptography.Xml (7.0) - System.Security.Cryptography.Pkcs (>= 7.0) + System.Security.Cryptography.ProtectedData (7.0.1) System.Security.Permissions (7.0) System.Windows.Extensions (>= 7.0) System.Security.Principal.Windows (5.0) - System.Text.Encoding.CodePages (7.0) - System.Text.Encodings.Web (7.0) - System.Text.Json (7.0.1) - System.Text.Encodings.Web (>= 7.0) - System.Threading.Tasks.Dataflow (7.0) System.Windows.Extensions (7.0) System.Drawing.Common (>= 7.0) @@ -368,44 +322,44 @@ NUGET BlackFox.VsWhere (1.1) FSharp.Core (>= 4.2.3) Microsoft.Win32.Registry (>= 4.7) - Fable.Browser.Blob (1.2) + Fable.Browser.Blob (1.3) Fable.Core (>= 3.0) FSharp.Core (>= 4.7.2) - Fable.Browser.Dom (2.10.1) - Fable.Browser.Blob (>= 1.2) + Fable.Browser.Dom (2.14) + Fable.Browser.Blob (>= 1.3) Fable.Browser.Event (>= 1.5) - Fable.Browser.WebStorage (>= 1.1) + Fable.Browser.WebStorage (>= 1.2) Fable.Core (>= 3.2.8) FSharp.Core (>= 4.7.2) Fable.Browser.Event (1.5) Fable.Browser.Gamepad (>= 1.1) Fable.Core (>= 3.0) FSharp.Core (>= 4.7.2) - Fable.Browser.Gamepad (1.1) + Fable.Browser.Gamepad (1.2) Fable.Core (>= 3.0) FSharp.Core (>= 4.7.2) - Fable.Browser.WebStorage (1.1) + Fable.Browser.WebStorage (1.2) Fable.Browser.Event (>= 1.5) Fable.Core (>= 3.0) FSharp.Core (>= 4.7.2) - Fable.Core (3.7.1) - Fable.React (9.1) - Fable.React.Types (>= 18.1) - Fable.ReactDom.Types (>= 18.0) + Fable.Core (4.0) + Fable.React (9.3) + Fable.React.Types (>= 18.3) + Fable.ReactDom.Types (>= 18.2) FSharp.Core (>= 4.7.2) - Fable.React.Types (18.1) + Fable.React.Types (18.3) Fable.Browser.Dom (>= 2.4.4) Fable.Core (>= 3.2.7) FSharp.Core (>= 4.7.2) - Fable.ReactDom.Types (18.0) - Fable.React.Types (>= 18.1) + Fable.ReactDom.Types (18.2) + Fable.React.Types (>= 18.3) FSharp.Core (>= 4.7.2) - Fake.Core.Context (6.0.0-beta001) + Fake.Core.Context (6.0) FSharp.Core (>= 6.0.3) Fake.Core.Environment (6.0.0-beta001) FSharp.Core (>= 6.0.3) - Fake.Core.FakeVar (6.0.0-beta001) - Fake.Core.Context (>= 6.0.0-beta001) + Fake.Core.FakeVar (6.0) + Fake.Core.Context (>= 6.0) FSharp.Core (>= 6.0.3) Fake.Core.Process (6.0.0-beta001) Fake.Core.Environment (>= 6.0.0-beta001) @@ -415,9 +369,9 @@ NUGET Fake.IO.FileSystem (>= 6.0.0-beta001) FSharp.Core (>= 6.0.3) System.Collections.Immutable (>= 6.0) - Fake.Core.SemVer (6.0.0-beta001) + Fake.Core.SemVer (6.0) FSharp.Core (>= 6.0.3) - Fake.Core.String (6.0.0-beta001) + Fake.Core.String (6.0) FSharp.Core (>= 6.0.3) Fake.Core.Tasks (6.0.0-beta001) Fake.Core.Trace (>= 6.0.0-beta001) @@ -426,8 +380,8 @@ NUGET Fake.Core.Environment (>= 6.0.0-beta001) Fake.Core.FakeVar (>= 6.0.0-beta001) FSharp.Core (>= 6.0.3) - Fake.Core.Xml (6.0.0-beta001) - Fake.Core.String (>= 6.0.0-beta001) + Fake.Core.Xml (6.0) + Fake.Core.String (>= 6.0) FSharp.Core (>= 6.0.3) Fake.DotNet.Cli (6.0.0-beta001) Fake.Core.Environment (>= 6.0.0-beta001) @@ -481,47 +435,25 @@ NUGET System.Reflection.TypeExtensions (>= 4.3) System.Runtime.Loader (>= 4.0) System.Security.Cryptography.Algorithms (>= 4.3) - FSharp.Core (7.0) + FSharp.Core (7.0.300) FSharp.Formatting (4.0.0-rc1) FSharp.Compiler.Service (>= 34.1) FSharp.Literate (4.0.0-rc1) FSharp.Compiler.Service (>= 34.1) FSharp.Core (>= 4.7) - Microsoft.Build (17.4) - Microsoft.Build.Framework (>= 17.4) - Microsoft.NET.StringTools (>= 17.4) - System.Collections.Immutable (>= 6.0) - System.Configuration.ConfigurationManager (>= 6.0) - System.Reflection.Metadata (>= 6.0) - System.Reflection.MetadataLoadContext (>= 6.0) - System.Security.Principal.Windows (>= 5.0) - System.Text.Encoding.CodePages (>= 6.0) - System.Text.Json (>= 6.0) - System.Threading.Tasks.Dataflow (>= 6.0) - Microsoft.Build.Framework (17.4) - System.Security.Permissions (>= 6.0) - Microsoft.Build.Tasks.Core (17.4) - Microsoft.Build.Framework (>= 17.4) - Microsoft.Build.Utilities.Core (>= 17.4) - Microsoft.NET.StringTools (>= 17.4) - System.CodeDom (>= 6.0) - System.Collections.Immutable (>= 6.0) - System.Reflection.Metadata (>= 6.0) - System.Resources.Extensions (>= 6.0) - System.Security.Cryptography.Pkcs (>= 6.0.1) - System.Security.Cryptography.Xml (>= 6.0) - System.Security.Permissions (>= 6.0) - System.Threading.Tasks.Dataflow (>= 6.0) - Microsoft.Build.Utilities.Core (17.4) - Microsoft.Build.Framework (>= 17.4) - Microsoft.NET.StringTools (>= 17.4) - System.Collections.Immutable (>= 6.0) - System.Configuration.ConfigurationManager (>= 6.0) - Microsoft.NET.StringTools (17.4) - System.Memory (>= 4.5.5) - System.Runtime.CompilerServices.Unsafe (>= 6.0) - Microsoft.NETCore.Platforms (7.0) + Microsoft.Build.Framework (17.6.3) + System.Security.Permissions (>= 7.0) + Microsoft.Build.Utilities.Core (17.6.3) + Microsoft.Build.Framework (>= 17.6.3) + Microsoft.NET.StringTools (>= 17.6.3) + Microsoft.VisualStudio.Setup.Configuration.Interop (>= 3.2.2146) + System.Collections.Immutable (>= 7.0) + System.Configuration.ConfigurationManager (>= 7.0) + System.Security.Permissions (>= 7.0) + Microsoft.NET.StringTools (17.6.3) + Microsoft.NETCore.Platforms (7.0.3) Microsoft.NETCore.Targets (5.0) + Microsoft.VisualStudio.Setup.Configuration.Interop (3.6.2115) Microsoft.Win32.Primitives (4.3) Microsoft.NETCore.Platforms (>= 1.1) Microsoft.NETCore.Targets (>= 1.1) @@ -531,27 +463,25 @@ NUGET System.Security.Principal.Windows (>= 5.0) Microsoft.Win32.SystemEvents (7.0) Mono.Posix.NETStandard (1.0) - MSBuild.StructuredLogger (2.1.758) - Microsoft.Build (>= 16.10) - Microsoft.Build.Framework (>= 16.10) - Microsoft.Build.Tasks.Core (>= 16.10) - Microsoft.Build.Utilities.Core (>= 16.10) - Newtonsoft.Json (13.0.2) - NuGet.Common (6.4) - NuGet.Frameworks (>= 6.4) - NuGet.Configuration (6.4) - NuGet.Common (>= 6.4) + MSBuild.StructuredLogger (2.1.820) + Microsoft.Build.Framework (>= 17.5) + Microsoft.Build.Utilities.Core (>= 17.5) + Newtonsoft.Json (13.0.3) + NuGet.Common (6.6.1) + NuGet.Frameworks (>= 6.6.1) + NuGet.Configuration (6.6.1) + NuGet.Common (>= 6.6.1) System.Security.Cryptography.ProtectedData (>= 4.4) - NuGet.Frameworks (6.4) - NuGet.Packaging (6.4) + NuGet.Frameworks (6.6.1) + NuGet.Packaging (6.6.1) Newtonsoft.Json (>= 13.0.1) - NuGet.Configuration (>= 6.4) - NuGet.Versioning (>= 6.4) + NuGet.Configuration (>= 6.6.1) + NuGet.Versioning (>= 6.6.1) System.Security.Cryptography.Cng (>= 5.0) System.Security.Cryptography.Pkcs (>= 5.0) - NuGet.Protocol (6.4) - NuGet.Packaging (>= 6.4) - NuGet.Versioning (6.4) + NuGet.Protocol (6.6.1) + NuGet.Packaging (>= 6.6.1) + NuGet.Versioning (6.6.1) runtime.debian.8-x64.runtime.native.System.Security.Cryptography.OpenSsl (4.3.3) runtime.debian.9-x64.runtime.native.System.Security.Cryptography.OpenSsl (4.3.3) runtime.fedora.23-x64.runtime.native.System.Security.Cryptography.OpenSsl (4.3.3) @@ -590,7 +520,6 @@ NUGET runtime.ubuntu.16.10-x64.runtime.native.System.Security.Cryptography.OpenSsl (4.3.3) runtime.ubuntu.18.04-x64.runtime.native.System.Security.Cryptography.OpenSsl (4.3.3) System.Buffers (4.5.1) - System.CodeDom (7.0) System.Collections (4.3) Microsoft.NETCore.Platforms (>= 1.1) Microsoft.NETCore.Targets (>= 1.1) @@ -690,17 +619,13 @@ NUGET System.Reflection.Primitives (>= 4.3) System.Runtime (>= 4.3) System.Reflection.Emit (4.7) - System.Reflection.Metadata (7.0) + System.Reflection.Metadata (7.0.2) System.Collections.Immutable (>= 7.0) - System.Reflection.MetadataLoadContext (7.0) - System.Collections.Immutable (>= 7.0) - System.Reflection.Metadata (>= 7.0) System.Reflection.Primitives (4.3) Microsoft.NETCore.Platforms (>= 1.1) Microsoft.NETCore.Targets (>= 1.1) System.Runtime (>= 4.3) System.Reflection.TypeExtensions (4.7) - System.Resources.Extensions (7.0) System.Resources.ResourceManager (4.3) Microsoft.NETCore.Platforms (>= 1.1) Microsoft.NETCore.Targets (>= 1.1) @@ -710,7 +635,6 @@ NUGET System.Runtime (4.3.1) Microsoft.NETCore.Platforms (>= 1.1.1) Microsoft.NETCore.Targets (>= 1.1.3) - System.Runtime.CompilerServices.Unsafe (6.0) System.Runtime.Extensions (4.3.1) Microsoft.NETCore.Platforms (>= 1.1.1) Microsoft.NETCore.Targets (>= 1.1.3) @@ -766,7 +690,7 @@ NUGET System.Runtime.InteropServices (>= 4.3) System.Security.Cryptography.Primitives (>= 4.3) System.Text.Encoding (>= 4.3) - System.Security.Cryptography.Pkcs (7.0) + System.Security.Cryptography.Pkcs (7.0.3) System.Formats.Asn1 (>= 7.0) System.Security.Cryptography.Primitives (4.3) System.Diagnostics.Debug (>= 4.3) @@ -776,9 +700,7 @@ NUGET System.Runtime (>= 4.3) System.Threading (>= 4.3) System.Threading.Tasks (>= 4.3) - System.Security.Cryptography.ProtectedData (7.0) - System.Security.Cryptography.Xml (7.0) - System.Security.Cryptography.Pkcs (>= 7.0) + System.Security.Cryptography.ProtectedData (7.0.1) System.Security.Permissions (7.0) System.Windows.Extensions (>= 7.0) System.Security.Principal.Windows (5.0) @@ -786,15 +708,11 @@ NUGET Microsoft.NETCore.Platforms (>= 1.1) Microsoft.NETCore.Targets (>= 1.1) System.Runtime (>= 4.3) - System.Text.Encoding.CodePages (7.0) System.Text.Encoding.Extensions (4.3) Microsoft.NETCore.Platforms (>= 1.1) Microsoft.NETCore.Targets (>= 1.1) System.Runtime (>= 4.3) System.Text.Encoding (>= 4.3) - System.Text.Encodings.Web (7.0) - System.Text.Json (7.0.1) - System.Text.Encodings.Web (>= 7.0) System.Threading (4.3) System.Runtime (>= 4.3) System.Threading.Tasks (>= 4.3) @@ -802,7 +720,6 @@ NUGET Microsoft.NETCore.Platforms (>= 1.1) Microsoft.NETCore.Targets (>= 1.1) System.Runtime (>= 4.3) - System.Threading.Tasks.Dataflow (7.0) System.Threading.Thread (4.3) System.Runtime (>= 4.3) System.Threading.ThreadPool (4.3) diff --git a/tests/Brahma.FSharp.Tests/Program.fs b/tests/Brahma.FSharp.Tests/Program.fs index 99baa43a..067c370b 100644 --- a/tests/Brahma.FSharp.Tests/Program.fs +++ b/tests/Brahma.FSharp.Tests/Program.fs @@ -6,7 +6,7 @@ open Brahma.FSharp.Tests let allTests = testList "All tests" - [ Translator.All.tests + [ Brahma.FSharp.Tests.Translator.Carrying.tests testList "Execution tests" ExecutionTests.tests ] |> testSequenced diff --git a/tests/Brahma.FSharp.Tests/Translator/All.fs b/tests/Brahma.FSharp.Tests/Translator/All.fs index ba4b4eaf..8b9f32a4 100644 --- a/tests/Brahma.FSharp.Tests/Translator/All.fs +++ b/tests/Brahma.FSharp.Tests/Translator/All.fs @@ -6,7 +6,7 @@ open Expecto let translator = FSQuotationToOpenCLTranslator.CreateDefault() -let private common translator = +let private common = [ BinOp.tests ControlFlow.tests NamesResolving.tests @@ -17,21 +17,18 @@ let private common translator = Printf.tests Specific.MergePath.tests ] - |> List.map (fun f -> f translator) |> testList "Common" -let private union _ = [ Union.tests ] |> testList "Union" +let private union = [ Union.tests ] |> testList "Union" -let private transformation translator = +let private transformation = [ QuatationTransformation.Transformation.tests QuatationTransformation.LambdaLifting.tests QuatationTransformation.VarDefsToLambda.tests ] - |> List.map (fun f -> f translator) |> testList "Transformation" let tests = [ common union transformation ] - |> List.map (fun f -> f translator) |> testList "Translator" diff --git a/tests/Brahma.FSharp.Tests/Translator/BinOp/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/BinOp/Tests.fs index bcbf26cc..9ddd48d1 100644 --- a/tests/Brahma.FSharp.Tests/Translator/BinOp/Tests.fs +++ b/tests/Brahma.FSharp.Tests/Translator/BinOp/Tests.fs @@ -7,9 +7,8 @@ open Expecto let private basePath = Path.Combine("Translator", "BinOp", "Expected") -let private basicBinOpsTests translator = - [ let inline createTest name = - Helpers.createTest translator basePath name +let private basicBinOpsTests = + [ let inline createTest name = Helpers.createTest basePath name <@ fun (range: Range1D) (buf: int clarray) -> buf.[0] <- 0 @> |> createTest "Array item set" "Array.Item.Set.cl" @@ -43,5 +42,4 @@ let private basicBinOpsTests translator = @> |> createTest "TempVar from MAX transformation should not affect other variables" "MAX.Transformation.cl" ] -let tests translator = - basicBinOpsTests translator |> testList "BinaryOperations" +let tests = basicBinOpsTests |> testList "BinaryOperations" diff --git a/tests/Brahma.FSharp.Tests/Translator/Carrying/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/Carrying/Tests.fs index c0ef9bbb..95f449f1 100644 --- a/tests/Brahma.FSharp.Tests/Translator/Carrying/Tests.fs +++ b/tests/Brahma.FSharp.Tests/Translator/Carrying/Tests.fs @@ -7,9 +7,8 @@ open Expecto let private basePath = Path.Combine("Translator", "Carrying", "Expected") -let private curryingTests translator = - [ let inline createTest name = - Helpers.createTest translator basePath name +let private curryingTests = + [ let inline createTest name = Helpers.createTest basePath name let inline createPTest name _ = Helpers.createPTest name @@ -20,7 +19,7 @@ let private curryingTests translator = buf.[0] <- g 3 buf.[1] <- g 5 @> - |> createPTest "Nested functions.Carrying 1." // "Nested.Function.Carring.cl" TODO(error: f application) + |> createPTest "Nested functions.Carrying 1." // "Nested.Function.Carring.cl" // TODO(error: f application) <@ fun (range: Range1D) (buf: int clarray) -> @@ -38,5 +37,4 @@ let private curryingTests translator = @> |> createPTest "Nested functions.Currying 2." ] // "Nested.Function.Carring2.cl" TODO(error) -let tests translator = - curryingTests translator |> testList "Currying" +let tests = curryingTests |> testList "Currying" diff --git a/tests/Brahma.FSharp.Tests/Translator/Common.fs b/tests/Brahma.FSharp.Tests/Translator/Common.fs index c088b4be..a8819f6c 100644 --- a/tests/Brahma.FSharp.Tests/Translator/Common.fs +++ b/tests/Brahma.FSharp.Tests/Translator/Common.fs @@ -8,31 +8,25 @@ open FSharp.Quotations [] module Helpers = - let openclTranslate (translator: FSQuotationToOpenCLTranslator) (expr: Expr) = - translator.Translate expr |> fst |> AST.print + let openclTranslate (expr: Expr) = + FSQuotationToOpenCLTranslator.CreateDefault().Translate expr |> fst |> AST.print + + let filterText (text: string) = text.Trim().Replace("\r\n", "\n") let compareCodeAndFile actualCode pathToExpectedCode = - let expectedCode = - (File.ReadAllText pathToExpectedCode).Trim().Replace("\r\n", "\n") + let expectedCode = (File.ReadAllText pathToExpectedCode) |> filterText - let actualCode = (actualCode: string).Trim().Replace("\r\n", "\n") + let actualCode = (actualCode: string).Trim().Replace("\r\n", "\n") |> filterText Expect.equal actualCode expectedCode <| "Code must be the same." - let checkCode translator quotation pathToExpectedCode = - let actualCode = quotation |> openclTranslate translator + let checkCode quotation pathToExpectedCode = + let actualCode = quotation |> openclTranslate compareCodeAndFile actualCode pathToExpectedCode - let printfStandard code = - let translator = FSQuotationToOpenCLTranslator.CreateDefault() - - openclTranslate translator code - |> fun code -> code.Trim().Replace("\r\n", "\n") - |> printfn "%A" - // create tests* - let inline createTest translator basePath name expectedFileName quotation = - test name { checkCode translator quotation <| Path.Combine(basePath, expectedFileName) } + let inline createTest basePath name expectedFileName quotation = + test name { checkCode quotation <| Path.Combine(basePath, expectedFileName) } let inline createPTest name = ptest name { () } diff --git a/tests/Brahma.FSharp.Tests/Translator/ConstantArray/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/ConstantArray/Tests.fs index eedb47ec..137fa7fb 100644 --- a/tests/Brahma.FSharp.Tests/Translator/ConstantArray/Tests.fs +++ b/tests/Brahma.FSharp.Tests/Translator/ConstantArray/Tests.fs @@ -7,9 +7,8 @@ open Expecto let private basePath = Path.Combine("Translator", "ConstantArray", "Expected") -let private constantArrayTests translator = - [ let inline createTest name = - Helpers.createTest translator basePath name +let private constantArrayTests = + [ let inline createTest name = Helpers.createTest basePath name let cArray1 = [| 1 @@ -27,5 +26,4 @@ let private constantArrayTests translator = <@ fun (range: Range1D) (buf: int clarray) -> buf.[0] <- 1 + cArray1.[1] @> |> createTest "Constant array translation. Test 2" "Constant array translation. Test 2.cl" ] -let tests translator = - constantArrayTests translator |> testList "ConstantArray" +let tests = constantArrayTests |> testList "ConstantArray" diff --git a/tests/Brahma.FSharp.Tests/Translator/ControlFlow/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/ControlFlow/Tests.fs index 08957de0..5d3d808d 100644 --- a/tests/Brahma.FSharp.Tests/Translator/ControlFlow/Tests.fs +++ b/tests/Brahma.FSharp.Tests/Translator/ControlFlow/Tests.fs @@ -8,9 +8,8 @@ open Brahma.FSharp.OpenCL.Translator let private basePath = Path.Combine("Translator", "ControlFlow", "Expected") -let private controlFlowTests translator = - [ let inline createTest name = - Helpers.createTest translator basePath name +let private controlFlowTests = + [ let inline createTest name = Helpers.createTest basePath name let inline createPTest name _ = Helpers.createPTest name @@ -105,5 +104,4 @@ let private controlFlowTests translator = @> |> createTest "Seq with bindings." "Seq.With.Bindings.cl" ] -let tests translator = - controlFlowTests translator |> testList "ControlFlow" +let tests = controlFlowTests |> testList "ControlFlow" diff --git a/tests/Brahma.FSharp.Tests/Translator/Injection/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/Injection/Tests.fs index 825a8ef2..93227110 100644 --- a/tests/Brahma.FSharp.Tests/Translator/Injection/Tests.fs +++ b/tests/Brahma.FSharp.Tests/Translator/Injection/Tests.fs @@ -7,9 +7,8 @@ open Expecto let private basePath = Path.Combine("Translator", "Injection", "Expected") -let private quotationsInjectionTests translator = - [ let inline createTest name = - Helpers.createTest translator basePath name +let private quotationsInjectionTests = + [ let inline createTest name = Helpers.createTest basePath name let myF = <@ fun x -> x * x @> @@ -29,5 +28,4 @@ let private quotationsInjectionTests translator = @> |> createTest "Quotations injections 2" "Quotations.Injections.2.cl" ] -let tests translator = - quotationsInjectionTests translator |> testList "QuotationsInjection" +let tests = quotationsInjectionTests |> testList "QuotationsInjection" diff --git a/tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Tests.fs index bb6565e7..7c4f1dfb 100644 --- a/tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Tests.fs +++ b/tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Tests.fs @@ -7,9 +7,8 @@ open Expecto let private basePath = Path.Combine("Translator", "LambdaLifting", "Expected") -let private lambdaLiftingTests translator = - [ let inline createTest name = - Helpers.createTest translator basePath name +let private lambdaLiftingTests = + [ let inline createTest name = Helpers.createTest basePath name <@ fun (range: Range1D) (buf: int clarray) -> @@ -258,5 +257,4 @@ let private lambdaLiftingTests translator = @> |> createTest "Nested functions" "Nested.Function.cl" ] -let tests translator = - lambdaLiftingTests translator |> testList "LambdaLifting" +let tests = lambdaLiftingTests |> testList "LambdaLifting" diff --git a/tests/Brahma.FSharp.Tests/Translator/LangExtensions/Atomic.fs b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/Atomic.fs index 8dd4f576..6d73c9ef 100644 --- a/tests/Brahma.FSharp.Tests/Translator/LangExtensions/Atomic.fs +++ b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/Atomic.fs @@ -4,7 +4,7 @@ open Expecto open Brahma.FSharp open Brahma.FSharp.Tests.Translator.Common -let test translator = +let test = [ testCase "Multiple local values in atomic operations" <| fun () -> @@ -26,9 +26,9 @@ let test translator = atomic (max) secondMaxIndex value |> ignore @> - Helpers.openclTranslate translator kernel |> ignore ] + Helpers.openclTranslate kernel |> ignore ] -let commonApiTests translator = +let commonApiTests = [ // TODO is it correct? ptestCase "Using atomic in lambda should not raise exception if first parameter passed" @@ -40,7 +40,7 @@ let commonApiTests translator = g 5 |> ignore @> - command |> Helpers.openclTranslate translator |> ignore + command |> Helpers.openclTranslate |> ignore // TODO is it correct? ptestCase "Using atomic in lambda should raise exception if first parameter is argument" @@ -53,5 +53,5 @@ let commonApiTests translator = @> Expect.throwsT - <| fun () -> command |> Helpers.openclTranslate translator |> ignore + <| fun () -> command |> Helpers.openclTranslate |> ignore <| "Exception should be thrown" ] diff --git a/tests/Brahma.FSharp.Tests/Translator/LangExtensions/Barrier/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/Barrier/Tests.fs index b2c6d167..d22a7bf5 100644 --- a/tests/Brahma.FSharp.Tests/Translator/LangExtensions/Barrier/Tests.fs +++ b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/Barrier/Tests.fs @@ -7,9 +7,8 @@ open Expecto let private basePath = Path.Combine("Translator", "BinaryOperations", "Expected") -let private barrierTests translator = - [ let inline createTest name = - Helpers.createTest translator basePath name +let private barrierTests = + [ let inline createTest name = Helpers.createTest basePath name <@ fun (range: Range1D) -> barrierLocal () @> |> createTest "Local barrier translation tests" "Barrier.Local.cl" @@ -20,5 +19,4 @@ let private barrierTests translator = <@ fun (range: Range1D) -> barrierFull () @> |> createTest "Full barrier translation tests" "Barrier.Full.cl" ] -let tests translator = - barrierTests translator |> testList "Barrier" +let tests = barrierTests |> testList "Barrier" diff --git a/tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalID/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalID/Tests.fs index 68a59bac..104c39cb 100644 --- a/tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalID/Tests.fs +++ b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalID/Tests.fs @@ -7,9 +7,8 @@ open Expecto let private basePath = Path.Combine("Translator", "Local", "Expected") -let private basicLocalIdTests translator = - [ let inline createTest name = - Helpers.createTest translator basePath name +let private basicLocalIdTests = + [ let inline createTest name = Helpers.createTest basePath name <@ fun (range: Range1D) (buf: int clarray) -> @@ -26,5 +25,4 @@ let private basicLocalIdTests translator = @> |> createTest "LocalID of 2D" "LocalID2D.cl" ] -let tests translator = - basicLocalIdTests translator |> testList "BasicLocalId" +let tests = basicLocalIdTests |> testList "BasicLocalId" diff --git a/tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalMemory/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalMemory/Tests.fs index b236dd3e..a4644afc 100644 --- a/tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalMemory/Tests.fs +++ b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalMemory/Tests.fs @@ -7,9 +7,8 @@ open Expecto let private basePath = Path.Combine("Translator", "BinaryOperations", "Expected") -let private localMemoryTests translator = - [ let inline createTest name = - Helpers.createTest translator basePath name +let private localMemoryTests = + [ let inline createTest name = Helpers.createTest basePath name <@ fun (range: Range1D) -> @@ -32,5 +31,4 @@ let private localMemoryTests translator = @> |> createTest "Local int array" "LocalMemory.int [].cl" ] -let tests translator = - localMemoryTests translator |> testList "LocalMemory" +let tests = localMemoryTests |> testList "LocalMemory" diff --git a/tests/Brahma.FSharp.Tests/Translator/LangExtensions/WorkSize/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/WorkSize/Tests.fs index 90290207..df8beeec 100644 --- a/tests/Brahma.FSharp.Tests/Translator/LangExtensions/WorkSize/Tests.fs +++ b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/WorkSize/Tests.fs @@ -7,9 +7,8 @@ open Expecto let private basePath = Path.Combine("Translator", "BinaryOperations", "Expected") -let private basicWorkSizeTests translator = - [ let inline createTest name = - Helpers.createTest translator basePath name +let private basicWorkSizeTests = + [ let inline createTest name = Helpers.createTest basePath name <@ fun (range: Range1D) (buf: int clarray) -> @@ -36,5 +35,4 @@ let private basicWorkSizeTests translator = @> |> createTest "WorkSize of 3D" "WorkSize3D.cl" ] -let tests translator = - basicWorkSizeTests translator |> testList "BasicWorkSize" +let tests = basicWorkSizeTests |> testList "BasicWorkSize" diff --git a/tests/Brahma.FSharp.Tests/Translator/NamesResolving/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/NamesResolving/Tests.fs index 3edbd067..dc5a883c 100644 --- a/tests/Brahma.FSharp.Tests/Translator/NamesResolving/Tests.fs +++ b/tests/Brahma.FSharp.Tests/Translator/NamesResolving/Tests.fs @@ -7,9 +7,8 @@ open Expecto let private basePath = Path.Combine("Translator", "NamesResolving", "Expected") -let private namesResolvingTests translator = - [ let inline createTest name = - Helpers.createTest translator basePath name +let private namesResolvingTests = + [ let inline createTest name = Helpers.createTest basePath name <@ fun (range: Range1D) (buf: int clarray) -> @@ -55,5 +54,4 @@ let private namesResolvingTests translator = @> |> createTest "Binding and FOR counter conflict 4." "Binding.And.FOR.Counter.Conflict.4.cl" ] -let tests translator = - namesResolvingTests translator |> testList "NamesResolving" +let tests = namesResolvingTests |> testList "NamesResolving" diff --git a/tests/Brahma.FSharp.Tests/Translator/Printf/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/Printf/Tests.fs index be9e8eba..6b28a7ad 100644 --- a/tests/Brahma.FSharp.Tests/Translator/Printf/Tests.fs +++ b/tests/Brahma.FSharp.Tests/Translator/Printf/Tests.fs @@ -7,9 +7,8 @@ open Expecto let private basePath = Path.Combine("Translator", "Printf", "Expected") -let private printfTests translator = - [ let inline createTest name = - Helpers.createTest translator basePath name +let private printfTests = + [ let inline createTest name = Helpers.createTest basePath name <@ fun (range: Range1D) -> printf "%d %f" 10 15.0 @> |> createTest "Printf test 1" "Printf test 1.cl" @@ -43,5 +42,4 @@ let private printfTests translator = <@ fun (range: Range1D) -> printfn "I am complied too" @> |> createTest "Printf test 6: printfn without args" "Printf test 6.cl" ] -let tests translator = - printfTests translator |> testList "Printf" +let tests = printfTests |> testList "Printf" diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/LambdaLifting.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/LambdaLifting.fs index 4f7f9a27..6208a52c 100644 --- a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/LambdaLifting.fs +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/LambdaLifting.fs @@ -103,5 +103,4 @@ let private lambdaLiftingTests = f x0 x0 @> ] -let tests _ = - lambdaLiftingTests |> testList "Lambda lifting" +let tests = lambdaLiftingTests |> testList "Lambda lifting" diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Transformation.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Transformation.fs index 516f0b2e..e07ca80b 100644 --- a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Transformation.fs +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Transformation.fs @@ -1,11 +1,14 @@ module Brahma.FSharp.Tests.Translator.QuatationTransformation.Transformation +open Brahma.FSharp.OpenCL.Translator open Expecto open Brahma.FSharp open FSharp.Quotations open Common -let private quotationTransformerTest translator = +let private quotationTransformerTest = + let translator = FSQuotationToOpenCLTranslator.CreateDefault() + let assertMethodListsEqual (actual: list) (expected: list) = Expect.equal actual.Length expected.Length "List sizes should be equal" List.iter2 assertMethodEqual actual expected @@ -183,5 +186,4 @@ let private quotationTransformerTest translator = f arr xRef yRef z @> ] -let tests translator = - quotationTransformerTest translator |> testList "Transformation" +let tests = quotationTransformerTest |> testList "Transformation" diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/VarDefsToLambda.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/VarDefsToLambda.fs index 2c47b31a..04336946 100644 --- a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/VarDefsToLambda.fs +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/VarDefsToLambda.fs @@ -89,5 +89,4 @@ let private varDefsToLambdaTest = x @> ] -let tests _ = - varDefsToLambdaTest |> testList "Var -> Lambda" +let tests = varDefsToLambdaTest |> testList "Var -> Lambda" diff --git a/tests/Brahma.FSharp.Tests/Translator/Specific/MergePath.fs b/tests/Brahma.FSharp.Tests/Translator/Specific/MergePath.fs index 887cf8c5..56e5552e 100644 --- a/tests/Brahma.FSharp.Tests/Translator/Specific/MergePath.fs +++ b/tests/Brahma.FSharp.Tests/Translator/Specific/MergePath.fs @@ -7,9 +7,8 @@ open Brahma.FSharp.OpenCL.Translator let private basePath = Path.Combine("Translator", "Specific", "Expected") -let tests (translator: FSQuotationToOpenCLTranslator) = - let inline createTest name = - Helpers.createTest translator basePath name +let tests = + let inline createTest name = Helpers.createTest basePath name let workGroupSize = 256 From 4ebe4fb68ec7e4c7667b524e52a8c864ebf6bc65 Mon Sep 17 00:00:00 2001 From: IgorErin Date: Mon, 10 Jul 2023 18:52:21 +0300 Subject: [PATCH 09/22] add: Printf replace tests --- src/Brahma.FSharp.OpenCL.Translator/Body.fs | 2 +- .../Brahma.FSharp.OpenCL.Translator.fsproj | 2 +- .../AtomicTransformer.fs | 2 +- .../QuotationTransformers/Print.fs | 77 +++++++++++++++++++ .../PrintfTransformer.fs | 16 ---- .../Utilities/Patterns.fs | 75 +----------------- .../Translator.fs | 17 ++-- .../Brahma.FSharp.Tests.fsproj | 2 + tests/Brahma.FSharp.Tests/Program.fs | 5 +- .../QuatationTransformation/Printf.fs | 62 +++++++++++++++ 10 files changed, 157 insertions(+), 103 deletions(-) create mode 100644 src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Print.fs delete mode 100644 src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/PrintfTransformer.fs create mode 100644 tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Printf.fs diff --git a/src/Brahma.FSharp.OpenCL.Translator/Body.fs b/src/Brahma.FSharp.OpenCL.Translator/Body.fs index 21e5b34a..b467388f 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/Body.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/Body.fs @@ -872,7 +872,7 @@ module rec Body = else return! translateApplicationFun expr1 expr2 >>= toNode - | DerivedPatterns.SpecificCall <@@ print @@> (_, _, args) -> + | DerivedPatterns.SpecificCall <@@ Print.print @@> (_, _, args) -> match args with | [ Patterns.ValueWithName(argTypes, _, _) Patterns.ValueWithName(formatStr, _, _) diff --git a/src/Brahma.FSharp.OpenCL.Translator/Brahma.FSharp.OpenCL.Translator.fsproj b/src/Brahma.FSharp.OpenCL.Translator/Brahma.FSharp.OpenCL.Translator.fsproj index 1cd81881..d191b143 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/Brahma.FSharp.OpenCL.Translator.fsproj +++ b/src/Brahma.FSharp.OpenCL.Translator/Brahma.FSharp.OpenCL.Translator.fsproj @@ -25,9 +25,9 @@ + - diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/AtomicTransformer.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/AtomicTransformer.fs index a203a7a0..b15edf8b 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/AtomicTransformer.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/AtomicTransformer.fs @@ -82,7 +82,7 @@ module AtomicProcessor = let grabVariableAddresses (expr: Expr) = match expr with | DerivedPatterns.Lambdas(args, body) -> - let kernelArgs = List.collect id args + let kernelArgs = List.concat args let vars = Dictionary() diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Print.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Print.fs new file mode 100644 index 00000000..f583d5e0 --- /dev/null +++ b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Print.fs @@ -0,0 +1,77 @@ +namespace Brahma.FSharp.OpenCL.Translator.QuotationTransformers + +open FSharp.Quotations +open FSharp.Quotations.Patterns +open FSharp.Reflection +open Brahma.FSharp.OpenCL.Translator + +module Print = + module Utils = + /// An active pattern to recognize any value expression + /// which is an arbitrary depth subterm of the expression + let rec (|HasValueAsSubExpr|_|) = + function + | Value x -> Some x + | ExprShape.ShapeCombination(_, exprList) -> List.tryPick (|HasValueAsSubExpr|_|) exprList + | _ -> None + + /// An active pattern to recognize lambda expression, + /// that obtained from printf/printfn function. + /// Example: printf "%d %f" -> ([Int, Float], "%d %f") + let (|NewPrintfFormat|_|) = + function + | Call(None, mInfo, args) -> + match mInfo.Name with + | "PrintFormat" + | "printfn" -> + let bindTypes = + match mInfo.ReturnType with + | _ when mInfo.ReturnType = typeof -> [] + | _ when FSharpType.IsFunction mInfo.ReturnType -> Utils.getFunctionArgTypes mInfo.ReturnType + | _ -> failwithf "printf: returned type %A of NewPrintfFormat is not expected" mInfo.ReturnType + + match args with + | [ HasValueAsSubExpr(s, _) ] -> + let s' = (s :?> string).Replace("\n", "\\n") + let s'' = if mInfo.Name = "printfn" then s' + "\\n" else s' + + Some(bindTypes, s'') + | _ -> failwithf "printf: argument %A of NewPrintfFormat call is not expected" args + | _ -> None + | _ -> None + + let rec (|PartialPrintf|_|) = + function + | Let(_, value, inExpr) -> + match value with + | NewPrintfFormat(tpArgs, value) -> + assert (tpArgs = Utils.getFunctionArgTypes inExpr.Type) + + Some(tpArgs, value, []) + | _ -> None + | Application(f, arg) -> + match f with + | PartialPrintf(tpArgs, value, bindArgs) -> Some(tpArgs, value, bindArgs @ [ arg ]) + | _ -> None + | NewPrintfFormat(tpArgs, formatStr) -> Some(tpArgs, formatStr, []) + | _ -> None + + let (|Printf|_|) = + function + | PartialPrintf(tpArgs, value, bindArgs) -> + if List.length bindArgs = List.length tpArgs then + Some(tpArgs, value, bindArgs) + else + None + | _ -> None + + /// Function for replacing printf call + let print (tpArgs: System.Type list) (value: string) (bindArgs: Expr list) = () + + let rec replace = + function + | Utils.Printf(tpArgs, value, bindArgs) -> <@@ print tpArgs value bindArgs @@> + | ExprShape.ShapeVar _ as expr -> expr + | ExprShape.ShapeLambda(x, body) -> Expr.Lambda(x, replace body) + | ExprShape.ShapeCombination(combo, exprList) -> + ExprShape.RebuildShapeCombination(combo, List.map replace exprList) diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/PrintfTransformer.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/PrintfTransformer.fs deleted file mode 100644 index ea8bede5..00000000 --- a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/PrintfTransformer.fs +++ /dev/null @@ -1,16 +0,0 @@ -namespace Brahma.FSharp.OpenCL.Translator.QuotationTransformers - -open FSharp.Quotations - -[] -module PrintfReplacer = - /// Function for replacing printf call - let print (tpArgs: System.Type list) (value: string) (bindArgs: Expr list) = () - - let rec replacePrintf (expr: Expr) = - match expr with - | Patterns.Printf(tpArgs, value, bindArgs) -> <@@ print tpArgs value bindArgs @@> - | ExprShape.ShapeVar _ -> expr - | ExprShape.ShapeLambda(x, body) -> Expr.Lambda(x, replacePrintf body) - | ExprShape.ShapeCombination(combo, exprList) -> - ExprShape.RebuildShapeCombination(combo, List.map replacePrintf exprList) diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Patterns.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Patterns.fs index fbc803b8..0aaffda0 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Patterns.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Patterns.fs @@ -2,85 +2,16 @@ namespace Brahma.FSharp.OpenCL.Translator.QuotationTransformers open FSharp.Quotations open FSharp.Quotations.Patterns -open FSharp.Reflection open FSharp.Core.LanguagePrimitives open Brahma.FSharp.OpenCL.Translator module Patterns = - let rec (|HasSubExpr|_|) ((|Pattern|_|): Expr -> 'a Option) expr = - match expr with - | Pattern x -> Some x - | ExprShape.ShapeCombination(shapeObj, exprList) -> - exprList - |> List.map ((|HasSubExpr|_|) (|Pattern|_|)) - |> List.fold - (fun x y -> - match x with - | Some _ -> x - | None -> y) - None - | _ -> None - - /// An active pattern to recognize any value expression - /// which is an arbitrary depth subterm of the expression - let (|HasValueAsSubExpr|_|) (expr: Expr) = (|HasSubExpr|_|) (|Value|_|) expr - - /// An active pattern to recognize lambda expression, - /// that obtained from printf/printfn function. - /// Example: printf "%d %f" -> ([Int, Float], "%d %f") - let (|NewPrintfFormat|_|) (expr: Expr) = - match expr with - | Call(None, mInfo, args) -> - match mInfo.Name with - | "PrintFormat" - | "printfn" -> - let retType = mInfo.ReturnType - - let bindTypes = - match retType with - | _ when retType = typeof -> [] - | _ when FSharpType.IsFunction retType -> Utils.getFunctionArgTypes <| mInfo.ReturnType - | _ -> failwithf "printf: returned type %A of NewPrintfFormat is not expected" retType - - match args with - | [ HasValueAsSubExpr(s, _) ] -> - let s' = (s :?> string).Replace("\n", "\\n") - let s'' = if mInfo.Name = "printfn" then s' + "\\n" else s' - Some(bindTypes, s'') - | _ -> failwithf "printf: argument %A of NewPrintfFormat call is not expected" args - | _ -> None - | _ -> None - - let rec (|PartialPrintf|_|) (expr: Expr) = - match expr with - | Let(_, value, inExpr) -> - match value with - | NewPrintfFormat(tpArgs, value) -> - assert (tpArgs = Utils.getFunctionArgTypes inExpr.Type) - Some(tpArgs, value, []) - | _ -> None - | Application(f, arg) -> - match f with - | PartialPrintf(tpArgs, value, bindArgs) -> Some(tpArgs, value, bindArgs @ [ arg ]) - | _ -> None - | NewPrintfFormat(tpArgs, formatStr) -> Some(tpArgs, formatStr, []) - | _ -> None - - let (|Printf|_|) (expr: Expr) = - match expr with - | PartialPrintf(tpArgs, value, bindArgs) -> - if List.length bindArgs = List.length tpArgs then - Some(tpArgs, value, bindArgs) - else - None - | _ -> None - - let private letDefinition (predicate: Var -> bool) (expr: Expr) = - match expr with + let private letDefinition (predicate: Var -> bool) = + function | Let(var, expr, inExpr) -> if predicate var then Some(var, expr, inExpr) else None | _ -> None - let (|LetFunc|_|) (expr: Expr) = letDefinition Utils.isFunction expr + let (|LetFunc|_|) = letDefinition Utils.isFunction let (|LetVar|_|) (expr: Expr) = letDefinition (not << Utils.isFunction) expr diff --git a/src/Brahma.FSharp.OpenCL.Translator/Translator.fs b/src/Brahma.FSharp.OpenCL.Translator/Translator.fs index 23b11503..d04ee2ee 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/Translator.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/Translator.fs @@ -84,9 +84,11 @@ type FSQuotationToOpenCLTranslator(device: IDevice, ?translatorOptions: Translat methods @ kernelFunc + // TODO(add logging (via CE state)) + let transformQuotation expr = expr - |> replacePrintf + |> Print.replace |> GettingWorkSizeTransformer.__ |> processAtomic |> makeVarNameUnique @@ -96,20 +98,19 @@ type FSQuotationToOpenCLTranslator(device: IDevice, ?translatorOptions: Translat |> lambdaLifting let translate expr = - let context = TranslationContext.Create(translatorOptions) - // TODO: Extract quotationTransformer to translator - let (kernelExpr, functions) = transformQuotation expr + // what is it? + let kernelExpr, functions = transformQuotation expr - let (globalVars, localVars, atomicApplicationsInfo) = - collectData kernelExpr functions + let globalVars, localVars, atomicApplicationsInfo = collectData kernelExpr functions let methods = constructMethods kernelExpr functions atomicApplicationsInfo + let context = TranslationContext.Create(translatorOptions) let clFuncs = ResizeArray() - for method in methods do - clFuncs.AddRange(method.Translate(globalVars, localVars) |> State.eval context) + methods + |> List.iter (fun method -> clFuncs.AddRange(method.Translate(globalVars, localVars) |> State.eval context)) let pragmas = let pragmas = ResizeArray() diff --git a/tests/Brahma.FSharp.Tests/Brahma.FSharp.Tests.fsproj b/tests/Brahma.FSharp.Tests/Brahma.FSharp.Tests.fsproj index 9a9df832..c0fef866 100644 --- a/tests/Brahma.FSharp.Tests/Brahma.FSharp.Tests.fsproj +++ b/tests/Brahma.FSharp.Tests/Brahma.FSharp.Tests.fsproj @@ -88,6 +88,8 @@ + + diff --git a/tests/Brahma.FSharp.Tests/Program.fs b/tests/Brahma.FSharp.Tests/Program.fs index 067c370b..80eb0644 100644 --- a/tests/Brahma.FSharp.Tests/Program.fs +++ b/tests/Brahma.FSharp.Tests/Program.fs @@ -4,10 +4,7 @@ open Brahma.FSharp.Tests [] let allTests = - testList - "All tests" - [ Brahma.FSharp.Tests.Translator.Carrying.tests - testList "Execution tests" ExecutionTests.tests ] + testList "All tests" [ Brahma.FSharp.Tests.Translator.QuatationTransformation.Printf.tests ] |> testSequenced [] diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Printf.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Printf.fs new file mode 100644 index 00000000..ce8aa659 --- /dev/null +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Printf.fs @@ -0,0 +1,62 @@ +module Brahma.FSharp.Tests.Translator.QuatationTransformation.Printf + +open Expecto +open Brahma.FSharp.OpenCL.Translator.QuotationTransformers + +let private replaceTests = + [ let createTest name source expected = + test name { + let actual = Print.replace source + + Expect.equal actual expected "Result should be the same." + } + + let tpArgs: System.Type list = [] + let value = "" + let bindArgs: Quotations.Expr list = [] + + createTest "1 Test. Empty printf" + <| <@ printf "" @> + <| <@ Print.print tpArgs value bindArgs @> + + let tpArgs: System.Type list = [] + let value = "\\n" + let bindArgs: Quotations.Expr list = [] + + createTest "2 Test. Empty printfn" + <| <@ printfn "" @> + <| <@ Print.print tpArgs value bindArgs @> + + let tpArgs: System.Type list = [] + let value = "Hello, world!" + let bindArgs: Quotations.Expr list = [] + + createTest "3 Test. Hello, world! printf" + <| <@ printf "Hello, world!" @> + <| <@ Print.print tpArgs value bindArgs @> + + let tpArgs: System.Type list = [] + let value = "Hello, world!\\n" + let bindArgs: Quotations.Expr list = [] + + createTest "4 Test. Hello, world! printfn" + <| <@ printfn "Hello, world!" @> + <| <@ Print.print tpArgs value bindArgs @> + + let tpArgs: System.Type list = [] + let value = "He\\nllo, w\\nor\\nld!" + let bindArgs: Quotations.Expr list = [] + + createTest "5 Test. New line. printf" + <| <@ printf "He\nllo, w\nor\nld!" @> + <| <@ Print.print tpArgs value bindArgs @> + + let tpArgs: System.Type list = [] + let value = "He\\nllo, w\\nor\\nld!\\n" + let bindArgs: Quotations.Expr list = [] + + createTest "6 Test. New line. printfn" + <| <@ printfn "He\nllo, w\nor\nld!" @> + <| <@ Print.print tpArgs value bindArgs @> ] + +let tests = replaceTests |> testList "Printf" From 9bb92f8024598d75fd375fd14c46997935813ae6 Mon Sep 17 00:00:00 2001 From: IgorErin Date: Fri, 14 Jul 2023 21:08:16 +0300 Subject: [PATCH 10/22] refactor: QTransformer.WorkSize patterns --- .../Brahma.FSharp.OpenCL.Translator.fsproj | 2 +- .../GettingWorkSizeTransformer.fs | 93 ------------------- .../QuotationTransformers/WorkSize.fs | 85 +++++++++++++++++ .../Translator.fs | 2 +- tests/Brahma.FSharp.Tests/Program.fs | 2 +- .../QuatationTransformation/Printf.fs | 18 +++- 6 files changed, 105 insertions(+), 97 deletions(-) delete mode 100644 src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/GettingWorkSizeTransformer.fs create mode 100644 src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/WorkSize.fs diff --git a/src/Brahma.FSharp.OpenCL.Translator/Brahma.FSharp.OpenCL.Translator.fsproj b/src/Brahma.FSharp.OpenCL.Translator/Brahma.FSharp.OpenCL.Translator.fsproj index d191b143..4e314304 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/Brahma.FSharp.OpenCL.Translator.fsproj +++ b/src/Brahma.FSharp.OpenCL.Translator/Brahma.FSharp.OpenCL.Translator.fsproj @@ -26,7 +26,7 @@ - + diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/GettingWorkSizeTransformer.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/GettingWorkSizeTransformer.fs deleted file mode 100644 index 67c3e5e0..00000000 --- a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/GettingWorkSizeTransformer.fs +++ /dev/null @@ -1,93 +0,0 @@ -namespace Brahma.FSharp.OpenCL.Translator.QuotationTransformers - -open FSharp.Quotations -open Brahma.FSharp.OpenCL.Translator - -type WorkSizeQual = - | GlobalWS - | LocalWS - -module GettingWorkSizeTransformer = - let inline (|Name|_|) (str: string) x = - match (^a: (member Name: string) x) with - | name when name = str -> Some x - | _ -> None - - let inline (|TypeName|_|) (str: string) x = - match (^a: (member Type: System.Type) x) with - | type' when type'.Name.ToLowerInvariant().Contains str -> Some x - | _ -> None - - let inline (|WorkSize|_|) x = - match x with - | Name "GlobalWorkSize" x -> Some(x, GlobalWS) - | Name "LocalWorkSize" x -> Some(x, LocalWS) - | _ -> None - - let rec go (expr: Expr) = - match expr with - | Patterns.Let(var, Patterns.PropertyGet(Some(Patterns.Var(TypeName Range1D_ _)), WorkSize(_, q), _), inExpr) -> - Expr.Let( - var, - (match q with - | GlobalWS -> <@@ Anchors._globalSize0 @@> - | LocalWS -> <@@ Anchors._localSize0 @@>), - go inExpr - ) - - | Patterns.LetVar(Name "patternInput" _, - Patterns.PropertyGet(Some(Patterns.Var(TypeName Range2D_ _)), WorkSize(_, q), _), - Patterns.Let(varY, - Patterns.TupleGet(Patterns.Var(Name "patternInput" _), 1), - Patterns.Let(varX, - Patterns.TupleGet(Patterns.Var(Name "patternInput" _), 0), - inExpr))) -> - Expr.Let( - varX, - (match q with - | GlobalWS -> <@@ Anchors._globalSize0 @@> - | LocalWS -> <@@ Anchors._localSize0 @@>), - Expr.Let( - varY, - (match q with - | GlobalWS -> <@@ Anchors._globalSize1 @@> - | LocalWS -> <@@ Anchors._localSize1 @@>), - go inExpr - ) - ) - - | Patterns.LetVar(Name "patternInput" _, - Patterns.PropertyGet(Some(Patterns.Var(TypeName Range3D_ _)), WorkSize(_, q), _), - Patterns.Let(varZ, - Patterns.TupleGet(Patterns.Var(Name "patternInput" _), 2), - Patterns.Let(varY, - Patterns.TupleGet(Patterns.Var(Name "patternInput" _), 1), - Patterns.Let(varX, - Patterns.TupleGet(Patterns.Var(Name "patternInput" _), - 0), - inExpr)))) -> - Expr.Let( - varX, - (match q with - | GlobalWS -> <@@ Anchors._globalSize0 @@> - | LocalWS -> <@@ Anchors._localSize0 @@>), - Expr.Let( - varY, - (match q with - | GlobalWS -> <@@ Anchors._globalSize1 @@> - | LocalWS -> <@@ Anchors._localSize1 @@>), - Expr.Let( - varZ, - (match q with - | GlobalWS -> <@@ Anchors._globalSize2 @@> - | LocalWS -> <@@ Anchors._localSize2 @@>), - go inExpr - ) - ) - ) - - | ExprShape.ShapeVar var -> Expr.Var var - | ExprShape.ShapeLambda(var, lambda) -> Expr.Lambda(var, go lambda) - | ExprShape.ShapeCombination(combo, exprs) -> ExprShape.RebuildShapeCombination(combo, List.map go exprs) - - let __ (expr: Expr) = go expr diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/WorkSize.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/WorkSize.fs new file mode 100644 index 00000000..f3612736 --- /dev/null +++ b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/WorkSize.fs @@ -0,0 +1,85 @@ +namespace Brahma.FSharp.OpenCL.Translator.QuotationTransformers + +open FSharp.Quotations +open Brahma.FSharp.OpenCL.Translator + +module WorkSize = + type private WorkSizeQual = + | GlobalWS + | LocalWS + + let inline private (|Name|_|) (str: string) x = + match (^a: (member Name: string) x) with + | name when name = str -> Some() + | _ -> None + + let inline private (|WorkSize|_|) x = + match x with + | Name "GlobalWorkSize" -> Some(GlobalWS) + | Name "LocalWorkSize" -> Some(LocalWS) + | _ -> None + + let inline private (|TypeName|_|) (str: string) x = + match (^a: (member Type: System.Type) x) with + | type' when type'.Name.ToLowerInvariant().Contains str -> Some() + | _ -> None + + let inline private (|Qualifier|_|) name = + function + | Patterns.PropertyGet(Some(Patterns.Var(TypeName name)), WorkSize(qualifier), _) -> Some qualifier + | _ -> None + + let inline private (|Equal|_|) str = + function + | line when line = str -> Some() + | _ -> None + + let private (|ReturnSome|_|) = + function + | x -> Some x + + let inline private (|CoordinateBind|_|) number (|InPatter|_|) = + function + | Patterns.Let(var, Patterns.TupleGet(Patterns.Var(Name "patternInput"), Equal number), InPatter inExp) -> + Some(var, inExp) + | _ -> None + + let inline private (|Zero|_|) exp = + (|CoordinateBind|_|) 0 (|ReturnSome|_|) exp + + let inline private (|First|_|) exp = (|CoordinateBind|_|) 1 (|Zero|_|) exp + + let inline private (|Second|_|) exp = (|CoordinateBind|_|) 2 (|First|_|) exp + + let private globalSize0 = + function + | GlobalWS -> <@@ Anchors._globalSize0 @@> + | LocalWS -> <@@ Anchors._localSize0 @@> + + let private globalSize1 = + function + | GlobalWS -> <@@ Anchors._globalSize1 @@> + | LocalWS -> <@@ Anchors._localSize1 @@> + + let private globalSize2 = + function + | GlobalWS -> <@@ Anchors._globalSize2 @@> + | LocalWS -> <@@ Anchors._localSize2 @@> + + let rec go = + function + | Patterns.Let(var, Qualifier Range1D_ qualifier, inExpr) -> Expr.Let(var, (globalSize0 qualifier), go inExpr) + | Patterns.LetVar(Name "patternInput", Qualifier Range2D_ qualifier, First(varY, (varX, inExp))) -> + let inExp = Expr.Let(varY, (globalSize1 qualifier), go inExp) + + Expr.Let(varX, (globalSize0 qualifier), inExp) + | Patterns.LetVar(Name "patternInput", Qualifier Range2D_ qualifier, Second(varZ, (varY, (varX, inExp)))) -> + let inExp = Expr.Let(varZ, (globalSize2 qualifier), go inExp) + let inExp = Expr.Let(varY, (globalSize1 qualifier), inExp) + + Expr.Let(varX, (globalSize0 qualifier), inExp) + | ExprShape.ShapeVar var -> Expr.Var var + | ExprShape.ShapeLambda(var, lambda) -> Expr.Lambda(var, go lambda) + | ExprShape.ShapeCombination(combo, exp) -> ExprShape.RebuildShapeCombination(combo, List.map go exp) + + let get (expr: Expr) = go expr diff --git a/src/Brahma.FSharp.OpenCL.Translator/Translator.fs b/src/Brahma.FSharp.OpenCL.Translator/Translator.fs index d04ee2ee..f0239c26 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/Translator.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/Translator.fs @@ -89,7 +89,7 @@ type FSQuotationToOpenCLTranslator(device: IDevice, ?translatorOptions: Translat let transformQuotation expr = expr |> Print.replace - |> GettingWorkSizeTransformer.__ + |> WorkSize.get |> processAtomic |> makeVarNameUnique |> transformVarDefsToLambda diff --git a/tests/Brahma.FSharp.Tests/Program.fs b/tests/Brahma.FSharp.Tests/Program.fs index 80eb0644..9a7ba27c 100644 --- a/tests/Brahma.FSharp.Tests/Program.fs +++ b/tests/Brahma.FSharp.Tests/Program.fs @@ -4,7 +4,7 @@ open Brahma.FSharp.Tests [] let allTests = - testList "All tests" [ Brahma.FSharp.Tests.Translator.QuatationTransformation.Printf.tests ] + testList "All tests" [ Brahma.FSharp.Tests.Translator.All.tests ] |> testSequenced [] diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Printf.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Printf.fs index ce8aa659..cf0a2898 100644 --- a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Printf.fs +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Printf.fs @@ -57,6 +57,22 @@ let private replaceTests = createTest "6 Test. New line. printfn" <| <@ printfn "He\nllo, w\nor\nld!" @> + <| <@ Print.print tpArgs value bindArgs @> + + let tpArgs: System.Type list = + [ typeof + typeof + typeof ] + + let value = "%d %d %s" + + let bindArgs: Quotations.Expr list = + [ <@@ 1 @@> + <@@ 2 @@> + <@@ "" @@> ] + + createTest "7 Test. %d %d %s. printf" + <| <@ printf "%d %d %s" 1 2 "" @> <| <@ Print.print tpArgs value bindArgs @> ] -let tests = replaceTests |> testList "Printf" +let tests = replaceTests |> testList "Printf" |> testSequenced From 3e0e3048901d75b485a6ce5270d7e7334a1a6d58 Mon Sep 17 00:00:00 2001 From: IgorErin Date: Sat, 15 Jul 2023 23:15:22 +0300 Subject: [PATCH 11/22] add: WorkSize pass tests --- .../AtomicTransformer.fs | 5 +- .../QuotationTransformers/WorkSize.fs | 3 +- .../Translator.fs | 2 +- .../Brahma.FSharp.Tests.fsproj | 17 ++- tests/Brahma.FSharp.Tests/Program.fs | 2 +- tests/Brahma.FSharp.Tests/Translator/All.fs | 24 +++- .../LangExtensions/Barrier/Tests.fs | 5 +- .../LangExtensions/LocalID/Tests.fs | 3 +- .../LangExtensions/LocalMemory/Tests.fs | 5 +- .../LangExtensions/WorkSize/Tests.fs | 6 +- .../{Printf.fs => Print.fs} | 2 +- .../QuatationTransformation/WorkSize.fs | 120 ++++++++++++++++++ 12 files changed, 164 insertions(+), 30 deletions(-) rename tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/{Printf.fs => Print.fs} (99%) create mode 100644 tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/WorkSize.fs diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/AtomicTransformer.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/AtomicTransformer.fs index b15edf8b..360c6c30 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/AtomicTransformer.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/AtomicTransformer.fs @@ -17,8 +17,7 @@ type AddressQual = module AtomicProcessing = let atomicProcessing = StateBuilder>() -[] -module AtomicProcessor = +module Atomic = let inline private atomicAdd p v = (+) !p v let inline private atomicSub p v = (-) !p v let inline private atomicInc p = inc !p @@ -532,7 +531,7 @@ module AtomicProcessor = <| InvalidKernelException $"Invalid kernel expression. Must be lambda, but given\n{expr}" } - let processAtomic (expr: Expr) = + let parse (expr: Expr) = let nonPrivateVars = grabVariableAddresses expr transformAtomicsAndCollectPointerVars expr nonPrivateVars diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/WorkSize.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/WorkSize.fs index f3612736..787dfdf4 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/WorkSize.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/WorkSize.fs @@ -41,6 +41,7 @@ module WorkSize = let inline private (|CoordinateBind|_|) number (|InPatter|_|) = function | Patterns.Let(var, Patterns.TupleGet(Patterns.Var(Name "patternInput"), Equal number), InPatter inExp) -> + Some(var, inExp) | _ -> None @@ -73,7 +74,7 @@ module WorkSize = let inExp = Expr.Let(varY, (globalSize1 qualifier), go inExp) Expr.Let(varX, (globalSize0 qualifier), inExp) - | Patterns.LetVar(Name "patternInput", Qualifier Range2D_ qualifier, Second(varZ, (varY, (varX, inExp)))) -> + | Patterns.LetVar(Name "patternInput", Qualifier Range3D_ qualifier, Second(varZ, (varY, (varX, inExp)))) -> let inExp = Expr.Let(varZ, (globalSize2 qualifier), go inExp) let inExp = Expr.Let(varY, (globalSize1 qualifier), inExp) diff --git a/src/Brahma.FSharp.OpenCL.Translator/Translator.fs b/src/Brahma.FSharp.OpenCL.Translator/Translator.fs index f0239c26..cf851e45 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/Translator.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/Translator.fs @@ -90,7 +90,7 @@ type FSQuotationToOpenCLTranslator(device: IDevice, ?translatorOptions: Translat expr |> Print.replace |> WorkSize.get - |> processAtomic + |> Atomic.parse |> makeVarNameUnique |> transformVarDefsToLambda |> transformMutableVarsToRef diff --git a/tests/Brahma.FSharp.Tests/Brahma.FSharp.Tests.fsproj b/tests/Brahma.FSharp.Tests/Brahma.FSharp.Tests.fsproj index c0fef866..69ef9812 100644 --- a/tests/Brahma.FSharp.Tests/Brahma.FSharp.Tests.fsproj +++ b/tests/Brahma.FSharp.Tests/Brahma.FSharp.Tests.fsproj @@ -62,34 +62,33 @@ - + Always - + Always - + Always - + Always - - - Always - + - + + + diff --git a/tests/Brahma.FSharp.Tests/Program.fs b/tests/Brahma.FSharp.Tests/Program.fs index 9a7ba27c..ca7803ce 100644 --- a/tests/Brahma.FSharp.Tests/Program.fs +++ b/tests/Brahma.FSharp.Tests/Program.fs @@ -4,7 +4,7 @@ open Brahma.FSharp.Tests [] let allTests = - testList "All tests" [ Brahma.FSharp.Tests.Translator.All.tests ] + testList "All tests" [ Brahma.FSharp.Tests.Translator.QuatationTransformation.WorkSize.tests ] |> testSequenced [] diff --git a/tests/Brahma.FSharp.Tests/Translator/All.fs b/tests/Brahma.FSharp.Tests/Translator/All.fs index 8b9f32a4..08086312 100644 --- a/tests/Brahma.FSharp.Tests/Translator/All.fs +++ b/tests/Brahma.FSharp.Tests/Translator/All.fs @@ -1,12 +1,12 @@ module Brahma.FSharp.Tests.Translator.All -open Brahma.FSharp.OpenCL.Translator open Brahma.FSharp.Tests.Translator open Expecto -let translator = FSQuotationToOpenCLTranslator.CreateDefault() +let translator = + Brahma.FSharp.OpenCL.Translator.FSQuotationToOpenCLTranslator.CreateDefault() -let private common = +let common = [ BinOp.tests ControlFlow.tests NamesResolving.tests @@ -14,14 +14,25 @@ let private common = LambdaLifting.tests Carrying.tests Injection.tests - Printf.tests Specific.MergePath.tests ] |> testList "Common" -let private union = [ Union.tests ] |> testList "Union" +let extensions = + [ LangExtensions.Barrier.tests + LangExtensions.LocalId.tests + LangExtensions.LocalMemory.tests + LangExtensions.WorkSize.tests ] + |> testList "LangExtensions" -let private transformation = +let passes = + [ QuatationTransformation.Print.tests + QuatationTransformation.WorkSize.tests ] + |> testList "Passes" + +let union = [ Union.tests ] |> testList "Union" + +let transformation = [ QuatationTransformation.Transformation.tests QuatationTransformation.LambdaLifting.tests QuatationTransformation.VarDefsToLambda.tests ] @@ -29,6 +40,7 @@ let private transformation = let tests = [ common + passes union transformation ] |> testList "Translator" diff --git a/tests/Brahma.FSharp.Tests/Translator/LangExtensions/Barrier/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/Barrier/Tests.fs index d22a7bf5..67e7b1a4 100644 --- a/tests/Brahma.FSharp.Tests/Translator/LangExtensions/Barrier/Tests.fs +++ b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/Barrier/Tests.fs @@ -1,11 +1,12 @@ -module Brahma.FSharp.Tests.Translator.Barrier +module Brahma.FSharp.Tests.Translator.LangExtensions.Barrier open Brahma.FSharp open Brahma.FSharp.Tests.Translator.Common open System.IO open Expecto -let private basePath = Path.Combine("Translator", "BinaryOperations", "Expected") +let private basePath = + Path.Combine("Translator", "LangExtensions", "Barrier", "Expected") let private barrierTests = [ let inline createTest name = Helpers.createTest basePath name diff --git a/tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalID/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalID/Tests.fs index 104c39cb..d1a1d908 100644 --- a/tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalID/Tests.fs +++ b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalID/Tests.fs @@ -5,7 +5,8 @@ open Brahma.FSharp.Tests.Translator.Common open System.IO open Expecto -let private basePath = Path.Combine("Translator", "Local", "Expected") +let private basePath = + Path.Combine("Translator", "LangExtensions", "LocalID", "Expected") let private basicLocalIdTests = [ let inline createTest name = Helpers.createTest basePath name diff --git a/tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalMemory/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalMemory/Tests.fs index a4644afc..e6750668 100644 --- a/tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalMemory/Tests.fs +++ b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalMemory/Tests.fs @@ -1,11 +1,12 @@ -module Brahma.FSharp.Tests.Translator.LocalMemory +module Brahma.FSharp.Tests.Translator.LangExtensions.LocalMemory open Brahma.FSharp open Brahma.FSharp.Tests.Translator.Common open System.IO open Expecto -let private basePath = Path.Combine("Translator", "BinaryOperations", "Expected") +let private basePath = + Path.Combine("Translator", "LangExtensions", "LocalMemory", "Expected") let private localMemoryTests = [ let inline createTest name = Helpers.createTest basePath name diff --git a/tests/Brahma.FSharp.Tests/Translator/LangExtensions/WorkSize/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/WorkSize/Tests.fs index df8beeec..83cb3868 100644 --- a/tests/Brahma.FSharp.Tests/Translator/LangExtensions/WorkSize/Tests.fs +++ b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/WorkSize/Tests.fs @@ -1,11 +1,12 @@ -module Brahma.FSharp.Tests.Translator.WorkSize +module Brahma.FSharp.Tests.Translator.LangExtensions.WorkSize open Brahma.FSharp open Brahma.FSharp.Tests.Translator.Common open System.IO open Expecto -let private basePath = Path.Combine("Translator", "BinaryOperations", "Expected") +let private basePath = + Path.Combine("Translator", "LangExtensions", "WorkSize", "Expected") let private basicWorkSizeTests = [ let inline createTest name = Helpers.createTest basePath name @@ -26,7 +27,6 @@ let private basicWorkSizeTests = @> |> createTest "WorkSize of 2D" "WorkSize2D.cl" - <@ fun (range: Range3D) (buf: int clarray) -> let (gSizeX, gSizeY, gSizeZ) = range.GlobalWorkSize diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Printf.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Print.fs similarity index 99% rename from tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Printf.fs rename to tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Print.fs index cf0a2898..27934e94 100644 --- a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Printf.fs +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Print.fs @@ -1,4 +1,4 @@ -module Brahma.FSharp.Tests.Translator.QuatationTransformation.Printf +module Brahma.FSharp.Tests.Translator.QuatationTransformation.Print open Expecto open Brahma.FSharp.OpenCL.Translator.QuotationTransformers diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/WorkSize.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/WorkSize.fs new file mode 100644 index 00000000..c60164d7 --- /dev/null +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/WorkSize.fs @@ -0,0 +1,120 @@ +module Brahma.FSharp.Tests.Translator.QuatationTransformation.WorkSize + +open Brahma.FSharp +open Brahma.FSharp.OpenCL.Translator.QuotationTransformers +open Expecto + +// Duplicate implementation +module Helpers = + let _localID0 = Unchecked.defaultof + + let _globalSize0 = Unchecked.defaultof + let _globalSize1 = Unchecked.defaultof + let _globalSize2 = Unchecked.defaultof + + let _localSize0 = Unchecked.defaultof + let _localSize1 = Unchecked.defaultof + let _localSize2 = Unchecked.defaultof + +let private workSizeTests = + [ let createTest name source expected = + test name { + let actual = WorkSize.get source + + let actualStr = actual.ToString() + let expectedStr = expected.ToString() + + Expect.equal actualStr expectedStr "Result should be the same." + } + + createTest "Test 1D. Global" + <| <@ + fun (ndRange: Range1D) -> + let fst = ndRange.GlobalWorkSize + + () + @> + <| <@ + fun (ndRange: Range1D) -> + let fst = Helpers._globalSize0 + + () + @> + + createTest "Test 2D. Global" + <| <@ + fun (ndRange: Range2D) -> + let (fst, snd) = ndRange.GlobalWorkSize + + () + @> + <| <@ + fun (ndRange: Range2D) -> + let fst = Helpers._globalSize0 + let snd = Helpers._globalSize1 + + () + @> + + createTest "Test 3D. Global" + <| <@ + fun (ndRange: Range3D) -> + let (fst, snd, thd) = ndRange.GlobalWorkSize + + () + @> + <| <@ + fun (ndRange: Range3D) -> + let fst = Helpers._globalSize0 + let snd = Helpers._globalSize1 + let thd = Helpers._globalSize2 + + () + @> + + createTest "Test 1D. Local" + <| <@ + fun (ndRange: Range1D) -> + let fst = ndRange.LocalWorkSize + + () + @> + <| <@ + fun (ndRange: Range1D) -> + let fst = Helpers._localSize0 + + () + @> + + createTest "Test 2D. Local" + <| <@ + fun (ndRange: Range2D) -> + let (fst, snd) = ndRange.LocalWorkSize + + () + @> + <| <@ + fun (ndRange: Range2D) -> + let fst = Helpers._localSize0 + let snd = Helpers._localSize1 + + () + @> + + createTest "Test 3D. Local" + <| <@ + fun (ndRange: Range3D) -> + let (fst, snd, thd) = ndRange.LocalWorkSize + + () + @> + <| <@ + fun (ndRange: Range3D) -> + let fst = Helpers._localSize0 + let snd = Helpers._localSize1 + let thd = Helpers._localSize2 + + () + @> ] + +let tests = workSizeTests |> testList "WorkSize" |> testSequenced From 085797837c05d4727c48558cabbdbe1b72762371 Mon Sep 17 00:00:00 2001 From: IgorErin Date: Mon, 17 Jul 2023 17:17:33 +0300 Subject: [PATCH 12/22] add: renaming tests --- .../Brahma.FSharp.OpenCL.Translator.fsproj | 6 +- .../{AtomicTransformer.fs => Atomic.fs} | 43 +++---- .../MutableVarsToRefTransformer.fs | 3 +- ...{UniqueVarNamesTransformer.fs => Names.fs} | 20 ++-- ...efsToLambdaTransformer.fs => Variables.fs} | 24 ++-- .../Translator.fs | 8 +- .../Brahma.FSharp.Tests.fsproj | 2 + tests/Brahma.FSharp.Tests/Program.fs | 2 +- tests/Brahma.FSharp.Tests/Translator/All.fs | 3 +- .../QuatationTransformation/Names.fs | 106 ++++++++++++++++++ .../VarDefsToLambda.fs | 2 +- 11 files changed, 166 insertions(+), 53 deletions(-) rename src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/{AtomicTransformer.fs => Atomic.fs} (94%) rename src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/{UniqueVarNamesTransformer.fs => Names.fs} (81%) rename src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/{VarDefsToLambdaTransformer.fs => Variables.fs} (79%) create mode 100644 tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Names.fs diff --git a/src/Brahma.FSharp.OpenCL.Translator/Brahma.FSharp.OpenCL.Translator.fsproj b/src/Brahma.FSharp.OpenCL.Translator/Brahma.FSharp.OpenCL.Translator.fsproj index 4e314304..c8ea5aec 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/Brahma.FSharp.OpenCL.Translator.fsproj +++ b/src/Brahma.FSharp.OpenCL.Translator/Brahma.FSharp.OpenCL.Translator.fsproj @@ -27,10 +27,10 @@ - - + + - + diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/AtomicTransformer.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Atomic.fs similarity index 94% rename from src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/AtomicTransformer.fs rename to src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Atomic.fs index 360c6c30..1986427c 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/AtomicTransformer.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Atomic.fs @@ -18,17 +18,17 @@ module AtomicProcessing = let atomicProcessing = StateBuilder>() module Atomic = - let inline private atomicAdd p v = (+) !p v - let inline private atomicSub p v = (-) !p v - let inline private atomicInc p = inc !p - let inline private atomicDec p = dec !p - let inline private atomicXchg p v = xchg !p v - let inline private atomicCmpxchg p cmp v = cmpxchg !p cmp v - let inline private atomicMin p v = min !p v - let inline private atomicMax p v = max !p v - let inline private atomicAnd p v = (&&&) !p v - let inline private atomicOr p v = (|||) !p v - let inline private atomicXor p v = (^^^) !p v + let inline private atomicAdd (p: _ ref) v = (+) p.Value v + let inline private atomicSub (p: _ ref) v = (-) p.Value v + let inline private atomicInc (p: _ ref) = inc p.Value + let inline private atomicDec (p: _ ref) = dec p.Value + let inline private atomicXchg (p: _ ref) v = xchg p.Value v + let inline private atomicCmpxchg (p: _ ref) cmp v = cmpxchg p.Value cmp v + let inline private atomicMin (p: _ ref) v = min p.Value v + let inline private atomicMax (p: _ ref) v = max p.Value v + let inline private atomicAnd (p: _ ref) v = (&&&) p.Value v + let inline private atomicOr (p: _ ref) v = (|||) p.Value v + let inline private atomicXor (p: _ ref) v = (^^^) p.Value v let private atomicAddInfo = (Utils.getMethodInfoOfCall <@ atomicAdd @>).GetGenericMethodDefinition() @@ -78,8 +78,8 @@ module Atomic = | [ x ] :: _ -> f x | _ -> invalidArg "lst" "List should not be empty" - let grabVariableAddresses (expr: Expr) = - match expr with + // TODO(test) + let grabVariableAddresses = function | DerivedPatterns.Lambdas(args, body) -> let kernelArgs = List.concat args @@ -89,22 +89,22 @@ module Atomic = |> List.filter Utils.isGlobal |> List.iter (fun v -> vars.Add(v, GlobalQ)) - let rec traverse expr = - match expr with - | Patterns.Let(var, (DerivedPatterns.SpecificCall <@ local @> _), body) - | Patterns.Let(var, (DerivedPatterns.SpecificCall <@ localArray @> _), body) -> + let rec traverse = function + // TODO(Note: precomputation in specificCall, make static?) + | Patterns.Let(var, DerivedPatterns.SpecificCall <@ local @> _, body) + | Patterns.Let(var, DerivedPatterns.SpecificCall <@ localArray @> _, body) -> vars.Add(var, LocalQ) traverse body | ExprShape.ShapeVar _ -> () | ExprShape.ShapeLambda(_, lambda) -> traverse lambda - | ExprShape.ShapeCombination(_, exprs) -> List.iter traverse exprs + | ExprShape.ShapeCombination(_, exp) -> List.iter traverse exp traverse body vars |> Seq.map (|KeyValue|) |> Map.ofSeq - | _ -> + | expr -> raise <| InvalidKernelException $"Invalid kernel expression. Must be lambda, but given\n{expr}" @@ -115,12 +115,13 @@ module Atomic = _, [ DerivedPatterns.Lambdas(lambdaArgs, lambdaBody) ]), + // atomic application restriction ([ Patterns.ValidVolatileArg pointerVar as volatileArg ] :: _ as applicationArgs)) when nonPrivateVars |> Map.containsKey pointerVar -> // private vars not supported let newApplicationArgs = - applicationArgs |> List.collect id |> modifyFirstOfList Utils.createRefCall + applicationArgs |> List.concat |> modifyFirstOfList Utils.createRefCall // https://www.khronos.org/registry/OpenCL/sdk/1.2/docs/man/xhtml/atomicFunctions.html match lambdaBody with @@ -239,7 +240,7 @@ module Atomic = -> return Expr.Call(atomicXorInfo.MakeGenericMethod(onType), newApplicationArgs) - | _ -> + | lambdaBody -> let collectedLambdaTypes = lambdaArgs |> List.collect id diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/MutableVarsToRefTransformer.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/MutableVarsToRefTransformer.fs index 8d59ff08..f5a45704 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/MutableVarsToRefTransformer.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/MutableVarsToRefTransformer.fs @@ -7,8 +7,7 @@ module MutableVarsToRefTransformer = let private isMutableVar (var: Var) = var.IsMutable && not (Utils.isFunction var) - let rec collectMutableVarsInClosure (expr: Expr) = - match expr with + let rec collectMutableVarsInClosure = function | Patterns.LetFunc(_, body, inExpr) -> let mutableFreeVars = body |> Utils.collectFreeVarsWithPredicate isMutableVar diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/UniqueVarNamesTransformer.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Names.fs similarity index 81% rename from src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/UniqueVarNamesTransformer.fs rename to src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Names.fs index f3476b37..043c6e62 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/UniqueVarNamesTransformer.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Names.fs @@ -8,10 +8,13 @@ type RenamingContext() = let totalNames = HashSet() let mutable counter = 0 - let makeUniqueVarName (varName: string) = + let rec makeUniqueVarName (varName: string) = if totalNames.Contains varName then counter <- counter + 1 + sprintf "%s%d" varName counter + // if name with this postfix already exists + |> makeUniqueVarName else varName @@ -19,6 +22,7 @@ type RenamingContext() = if not <| varMapper.ContainsKey var then let newName = makeUniqueVarName var.Name let newVar = Var(newName, var.Type, var.IsMutable) + varMapper.Add(var, newVar) totalNames.Add newName |> ignore @@ -26,19 +30,21 @@ type RenamingContext() = member this.Mapper = varMapper -[] -module UniqueVarRenamer = - let rec private makeVarNamesUniqueImpl (ctx: RenamingContext) (expr: Expr) = - match expr with +module Names = + let rec private makeVarNamesUniqueImpl (ctx: RenamingContext) = function | ExprShape.ShapeVar var -> let newVar = ctx.Add var + Expr.Var(newVar) | ExprShape.ShapeLambda(var, body) -> let newVar = ctx.Add var + Expr.Lambda(newVar, makeVarNamesUniqueImpl ctx body) | ExprShape.ShapeCombination(shapeComboObj, exprList) -> - let exprList' = List.map (makeVarNamesUniqueImpl ctx) exprList + let exprList' = + List.map (makeVarNamesUniqueImpl ctx) exprList + ExprShape.RebuildShapeCombination(shapeComboObj, exprList') - let makeVarNameUnique (expr: Expr) = + let makeUnique (expr: Expr) = makeVarNamesUniqueImpl <| RenamingContext() <| expr diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/VarDefsToLambdaTransformer.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Variables.fs similarity index 79% rename from src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/VarDefsToLambdaTransformer.fs rename to src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Variables.fs index d858474e..9e8ae301 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/VarDefsToLambdaTransformer.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Variables.fs @@ -3,11 +3,9 @@ namespace Brahma.FSharp.OpenCL.Translator.QuotationTransformers open FSharp.Quotations open FSharp.Reflection -[] -module VarDefsToLambdaTransformer = +module Variables = // TODO need way to identify expression vs statements (now it is very primitive) - let rec isPrimitiveExpression (expr: Expr) = - match expr with + let rec isPrimitiveExpression = function | Patterns.Value _ | Patterns.ValueWithName _ | Patterns.DefaultValue _ @@ -19,16 +17,16 @@ module VarDefsToLambdaTransformer = instance |> Option.map isPrimitiveExpression |> Option.defaultValue true let isPrimitiveArgs = List.forall isPrimitiveExpression args + isPrimitiveInstance && isPrimitiveArgs | Patterns.NewUnionCase _ -> true | _ -> false // let x = expr -> let x = let unit () = expr in unit () - let rec transformVarDefsToLambda (expr: Expr) = - match expr with + let rec defsToLambda = function | Patterns.LetVar(var, body, inExpr) -> if isPrimitiveExpression body then - Expr.Let(var, body, transformVarDefsToLambda inExpr) + Expr.Let(var, body, defsToLambda inExpr) else let fType = FSharpType.MakeFunctionType(typeof, var.Type) let fVar = Var(var.Name + "UnitFunc", fType) @@ -37,10 +35,10 @@ module VarDefsToLambdaTransformer = var, Expr.Let( fVar, - Expr.Lambda(Var("unitVar", typeof), transformVarDefsToLambda body), + Expr.Lambda(Var("unitVar", typeof), defsToLambda body), Expr.Application(Expr.Var fVar, Expr.Value((), typeof)) ), - transformVarDefsToLambda inExpr + defsToLambda inExpr ) | Patterns.PropertySet(Some o, prop, idxs, value) -> @@ -55,14 +53,14 @@ module VarDefsToLambdaTransformer = prop, Expr.Let( fVar, - Expr.Lambda(Var("unitVar", typeof), transformVarDefsToLambda value), + Expr.Lambda(Var("unitVar", typeof), defsToLambda value), Expr.Application(Expr.Var fVar, Expr.Value((), typeof)) ), idxs ) - | ExprShape.ShapeVar _ -> expr - | ExprShape.ShapeLambda(var, body) -> Expr.Lambda(var, transformVarDefsToLambda body) + | ExprShape.ShapeVar _ as expr -> expr + | ExprShape.ShapeLambda(var, body) -> Expr.Lambda(var, defsToLambda body) | ExprShape.ShapeCombination(shapeComboObject, exprList) -> - let exprList' = List.map transformVarDefsToLambda exprList + let exprList' = List.map defsToLambda exprList ExprShape.RebuildShapeCombination(shapeComboObject, exprList') diff --git a/src/Brahma.FSharp.OpenCL.Translator/Translator.fs b/src/Brahma.FSharp.OpenCL.Translator/Translator.fs index cf851e45..17fa0c5d 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/Translator.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/Translator.fs @@ -90,11 +90,11 @@ type FSQuotationToOpenCLTranslator(device: IDevice, ?translatorOptions: Translat expr |> Print.replace |> WorkSize.get - |> Atomic.parse - |> makeVarNameUnique - |> transformVarDefsToLambda + |> Atomic.parse // TODO(refactor) + |> Names.makeUnique + |> Variables.defsToLambda // TODO(tests) |> transformMutableVarsToRef - |> makeVarNameUnique + |> Names.makeUnique |> lambdaLifting let translate expr = diff --git a/tests/Brahma.FSharp.Tests/Brahma.FSharp.Tests.fsproj b/tests/Brahma.FSharp.Tests/Brahma.FSharp.Tests.fsproj index 69ef9812..3ff64f18 100644 --- a/tests/Brahma.FSharp.Tests/Brahma.FSharp.Tests.fsproj +++ b/tests/Brahma.FSharp.Tests/Brahma.FSharp.Tests.fsproj @@ -89,6 +89,8 @@ + + diff --git a/tests/Brahma.FSharp.Tests/Program.fs b/tests/Brahma.FSharp.Tests/Program.fs index ca7803ce..9a7ba27c 100644 --- a/tests/Brahma.FSharp.Tests/Program.fs +++ b/tests/Brahma.FSharp.Tests/Program.fs @@ -4,7 +4,7 @@ open Brahma.FSharp.Tests [] let allTests = - testList "All tests" [ Brahma.FSharp.Tests.Translator.QuatationTransformation.WorkSize.tests ] + testList "All tests" [ Brahma.FSharp.Tests.Translator.All.tests ] |> testSequenced [] diff --git a/tests/Brahma.FSharp.Tests/Translator/All.fs b/tests/Brahma.FSharp.Tests/Translator/All.fs index 08086312..a7d57c18 100644 --- a/tests/Brahma.FSharp.Tests/Translator/All.fs +++ b/tests/Brahma.FSharp.Tests/Translator/All.fs @@ -27,7 +27,8 @@ let extensions = let passes = [ QuatationTransformation.Print.tests - QuatationTransformation.WorkSize.tests ] + QuatationTransformation.WorkSize.tests + QuatationTransformation.Names.tests ] |> testList "Passes" let union = [ Union.tests ] |> testList "Union" diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Names.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Names.fs new file mode 100644 index 00000000..ffdeb115 --- /dev/null +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Names.fs @@ -0,0 +1,106 @@ +module Brahma.FSharp.Tests.Translator.QuatationTransformation.Names + +open System.Collections.Generic +open Brahma.FSharp.OpenCL.Translator.QuotationTransformers +open Expecto +open FSharp.Quotations + +// collect all vars and get them names +let private getNames expr = + let dict = HashSet() + + let addToDict (var: Var) = + if not <| dict.Contains var then + dict.Add(var) |> ignore + + let rec get = function + | ExprShape.ShapeVar var -> addToDict var + | ExprShape.ShapeLambda(var, body) -> + addToDict var + get body + | ExprShape.ShapeCombination(_, exprList) -> + List.iter get exprList + + get expr + + dict + |> Seq.map (fun var -> var.Name) + +let private uniquesTests = + [ let createTest name source = + test name { + let names = + Names.makeUnique source |> getNames + + let namesWithoutDuplicates = Seq.distinct names + + Expect.sequenceEqual names namesWithoutDuplicates "Result should be the same." + } + + createTest "Test 1." + <| <@ + fun var -> + let var = () + let var = () + let var = () + + () + @> + + createTest "Test 2." + <| <@ fun f -> + let f (x: int) = x + let f (x: int) (y: int) = x + + let f = 4 + () @> + + createTest "Test 3." + <| <@ + fun x y z z10 -> + let mutable x = 4 + let mutable x = () + + let y = 100 + + let f (x: unit) (y: int) (z: int) = x + + let x = f x y 3 + + let x = (fun (x: unit) -> fun (y: unit) -> fun (z: unit) -> y) + + let z = () + let y = () + let z10 = () + + x z y z10 + + () + @> + + createTest "Test 4." + <| <@ + fun x1 y2 z3 z10 -> + let mutable x3 = 4 + let mutable x1 = () + + let y2 = 100 + + let f (x: unit) (y: int) (z: int) = x + + let y3 = 3 + let x1 = f x1 y3 3 + + let x = (fun (x4: unit) -> fun (y2: int) -> fun (z: unit) -> 2) + + let z124 = () + let y32 = () + let z10 = () + let z4 = () + + let z11 = x z4 y2 z10 + + () + @> ] + +let tests = uniquesTests |> testList "Names" |> testSequenced diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/VarDefsToLambda.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/VarDefsToLambda.fs index 04336946..177ca40f 100644 --- a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/VarDefsToLambda.fs +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/VarDefsToLambda.fs @@ -8,7 +8,7 @@ open Expecto let private varDefsToLambdaTest = let genVarDefToLambdaTest name expr expected = test name { - let actual = VarDefsToLambdaTransformer.transformVarDefsToLambda expr + let actual = Variables.defsToLambda expr assertExprEqual actual expected equalsMessage } From f8bba71ef112e731e13da7a60bc0b723ed2ccaa7 Mon Sep 17 00:00:00 2001 From: IgorErin Date: Mon, 17 Jul 2023 23:53:10 +0300 Subject: [PATCH 13/22] refactor: Vardef to unit fun tests --- .../QuotationTransformers/Atomic.fs | 8 +- .../MutableVarsToRefTransformer.fs | 3 +- .../QuotationTransformers/Names.fs | 6 +- .../QuotationTransformers/Variables.fs | 54 ++++++----- .../Brahma.FSharp.Tests.fsproj | 3 +- tests/Brahma.FSharp.Tests/Program.fs | 2 +- tests/Brahma.FSharp.Tests/Translator/All.fs | 6 +- .../QuatationTransformation/Names.fs | 24 ++--- .../VarDefsToLambda.fs | 92 ------------------ .../QuatationTransformation/Variables.fs | 96 +++++++++++++++++++ 10 files changed, 152 insertions(+), 142 deletions(-) delete mode 100644 tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/VarDefsToLambda.fs create mode 100644 tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Variables.fs diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Atomic.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Atomic.fs index 1986427c..88fed9cf 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Atomic.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Atomic.fs @@ -79,7 +79,8 @@ module Atomic = | _ -> invalidArg "lst" "List should not be empty" // TODO(test) - let grabVariableAddresses = function + let grabVariableAddresses = + function | DerivedPatterns.Lambdas(args, body) -> let kernelArgs = List.concat args @@ -89,7 +90,8 @@ module Atomic = |> List.filter Utils.isGlobal |> List.iter (fun v -> vars.Add(v, GlobalQ)) - let rec traverse = function + let rec traverse = + function // TODO(Note: precomputation in specificCall, make static?) | Patterns.Let(var, DerivedPatterns.SpecificCall <@ local @> _, body) | Patterns.Let(var, DerivedPatterns.SpecificCall <@ localArray @> _, body) -> @@ -115,7 +117,7 @@ module Atomic = _, [ DerivedPatterns.Lambdas(lambdaArgs, lambdaBody) ]), - // atomic application restriction + // atomic application restriction ([ Patterns.ValidVolatileArg pointerVar as volatileArg ] :: _ as applicationArgs)) when nonPrivateVars |> Map.containsKey pointerVar -> // private vars not supported diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/MutableVarsToRefTransformer.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/MutableVarsToRefTransformer.fs index f5a45704..f7de0a86 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/MutableVarsToRefTransformer.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/MutableVarsToRefTransformer.fs @@ -7,7 +7,8 @@ module MutableVarsToRefTransformer = let private isMutableVar (var: Var) = var.IsMutable && not (Utils.isFunction var) - let rec collectMutableVarsInClosure = function + let rec collectMutableVarsInClosure = + function | Patterns.LetFunc(_, body, inExpr) -> let mutableFreeVars = body |> Utils.collectFreeVarsWithPredicate isMutableVar diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Names.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Names.fs index 043c6e62..ed6ff603 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Names.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Names.fs @@ -31,7 +31,8 @@ type RenamingContext() = member this.Mapper = varMapper module Names = - let rec private makeVarNamesUniqueImpl (ctx: RenamingContext) = function + let rec private makeVarNamesUniqueImpl (ctx: RenamingContext) = + function | ExprShape.ShapeVar var -> let newVar = ctx.Add var @@ -41,8 +42,7 @@ module Names = Expr.Lambda(newVar, makeVarNamesUniqueImpl ctx body) | ExprShape.ShapeCombination(shapeComboObj, exprList) -> - let exprList' = - List.map (makeVarNamesUniqueImpl ctx) exprList + let exprList' = List.map (makeVarNamesUniqueImpl ctx) exprList ExprShape.RebuildShapeCombination(shapeComboObj, exprList') diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Variables.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Variables.fs index 9e8ae301..ba8bfc53 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Variables.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Variables.fs @@ -5,7 +5,8 @@ open FSharp.Reflection module Variables = // TODO need way to identify expression vs statements (now it is very primitive) - let rec isPrimitiveExpression = function + let rec private isPrimitiveExpression = + function | Patterns.Value _ | Patterns.ValueWithName _ | Patterns.DefaultValue _ @@ -22,45 +23,46 @@ module Variables = | Patterns.NewUnionCase _ -> true | _ -> false + // create: let fVal () = expr in unit () + let private createApplication fVar body = + Expr.Let( + fVar, + Expr.Lambda(Var("unitVar", typeof), body), + Expr.Application(Expr.Var fVar, Expr.Value((), typeof)) + ) + // let x = expr -> let x = let unit () = expr in unit () - let rec defsToLambda = function + let rec defsToLambda = + function | Patterns.LetVar(var, body, inExpr) -> if isPrimitiveExpression body then Expr.Let(var, body, defsToLambda inExpr) else - let fType = FSharpType.MakeFunctionType(typeof, var.Type) - let fVar = Var(var.Name + "UnitFunc", fType) + let funVal = + let fType = FSharpType.MakeFunctionType(typeof, var.Type) + + Var(var.Name + "UnitFunc", fType) - Expr.Let( - var, - Expr.Let( - fVar, - Expr.Lambda(Var("unitVar", typeof), defsToLambda body), - Expr.Application(Expr.Var fVar, Expr.Value((), typeof)) - ), - defsToLambda inExpr - ) + let body = defsToLambda body + let letEvalAndApplication = createApplication funVal body - | Patterns.PropertySet(Some o, prop, idxs, value) -> + let newInExpr = defsToLambda inExpr + + Expr.Let(var, letEvalAndApplication, newInExpr) + | Patterns.PropertySet(Some o, prop, indices, value) -> if isPrimitiveExpression value then - Expr.PropertySet(o, prop, value, idxs) + Expr.PropertySet(o, prop, value, indices) else let fType = FSharpType.MakeFunctionType(typeof, prop.PropertyType) - let fVar = Var(prop.Name + "UnitFunc", fType) + let fVal = Var(prop.Name + "UnitFunc", fType) - Expr.PropertySet( - o, - prop, - Expr.Let( - fVar, - Expr.Lambda(Var("unitVar", typeof), defsToLambda value), - Expr.Application(Expr.Var fVar, Expr.Value((), typeof)) - ), - idxs - ) + let body = defsToLambda value + let letEvalAndApplication = createApplication fVal body + Expr.PropertySet(o, prop, letEvalAndApplication, indices) | ExprShape.ShapeVar _ as expr -> expr | ExprShape.ShapeLambda(var, body) -> Expr.Lambda(var, defsToLambda body) | ExprShape.ShapeCombination(shapeComboObject, exprList) -> let exprList' = List.map defsToLambda exprList + ExprShape.RebuildShapeCombination(shapeComboObject, exprList') diff --git a/tests/Brahma.FSharp.Tests/Brahma.FSharp.Tests.fsproj b/tests/Brahma.FSharp.Tests/Brahma.FSharp.Tests.fsproj index 3ff64f18..ceb47c55 100644 --- a/tests/Brahma.FSharp.Tests/Brahma.FSharp.Tests.fsproj +++ b/tests/Brahma.FSharp.Tests/Brahma.FSharp.Tests.fsproj @@ -91,8 +91,9 @@ + + - diff --git a/tests/Brahma.FSharp.Tests/Program.fs b/tests/Brahma.FSharp.Tests/Program.fs index 9a7ba27c..27f96462 100644 --- a/tests/Brahma.FSharp.Tests/Program.fs +++ b/tests/Brahma.FSharp.Tests/Program.fs @@ -4,7 +4,7 @@ open Brahma.FSharp.Tests [] let allTests = - testList "All tests" [ Brahma.FSharp.Tests.Translator.All.tests ] + testList "All tests" [ Brahma.FSharp.Tests.Translator.QuatationTransformation.Variables.tests ] |> testSequenced [] diff --git a/tests/Brahma.FSharp.Tests/Translator/All.fs b/tests/Brahma.FSharp.Tests/Translator/All.fs index a7d57c18..14808082 100644 --- a/tests/Brahma.FSharp.Tests/Translator/All.fs +++ b/tests/Brahma.FSharp.Tests/Translator/All.fs @@ -28,15 +28,15 @@ let extensions = let passes = [ QuatationTransformation.Print.tests QuatationTransformation.WorkSize.tests - QuatationTransformation.Names.tests ] + QuatationTransformation.Names.tests + QuatationTransformation.Variables.tests ] |> testList "Passes" let union = [ Union.tests ] |> testList "Union" let transformation = [ QuatationTransformation.Transformation.tests - QuatationTransformation.LambdaLifting.tests - QuatationTransformation.VarDefsToLambda.tests ] + QuatationTransformation.LambdaLifting.tests ] |> testList "Transformation" let tests = diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Names.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Names.fs index ffdeb115..4f89562f 100644 --- a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Names.fs +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Names.fs @@ -13,24 +13,22 @@ let private getNames expr = if not <| dict.Contains var then dict.Add(var) |> ignore - let rec get = function + let rec get = + function | ExprShape.ShapeVar var -> addToDict var | ExprShape.ShapeLambda(var, body) -> addToDict var get body - | ExprShape.ShapeCombination(_, exprList) -> - List.iter get exprList + | ExprShape.ShapeCombination(_, exprList) -> List.iter get exprList get expr - dict - |> Seq.map (fun var -> var.Name) + dict |> Seq.map (fun var -> var.Name) let private uniquesTests = [ let createTest name source = test name { - let names = - Names.makeUnique source |> getNames + let names = Names.makeUnique source |> getNames let namesWithoutDuplicates = Seq.distinct names @@ -48,12 +46,14 @@ let private uniquesTests = @> createTest "Test 2." - <| <@ fun f -> - let f (x: int) = x - let f (x: int) (y: int) = x + <| <@ + fun f -> + let f (x: int) = x + let f (x: int) (y: int) = x - let f = 4 - () @> + let f = 4 + () + @> createTest "Test 3." <| <@ diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/VarDefsToLambda.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/VarDefsToLambda.fs deleted file mode 100644 index 177ca40f..00000000 --- a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/VarDefsToLambda.fs +++ /dev/null @@ -1,92 +0,0 @@ -module Brahma.FSharp.Tests.Translator.QuatationTransformation.VarDefsToLambda - -open Expecto -open Brahma.FSharp.OpenCL.Translator.QuotationTransformers -open Common -open Expecto - -let private varDefsToLambdaTest = - let genVarDefToLambdaTest name expr expected = - test name { - let actual = Variables.defsToLambda expr - - assertExprEqual actual expected equalsMessage - } - - [ genVarDefToLambdaTest - "Test 1" - <@ - let x = - let mutable y = 0 - - for i in 1..10 do - y <- y + i - - y - - x - @> - <@ - let x = - let xUnitFunc () = - let mutable y = 0 - - for i in 1..10 do - y <- y + i - - y - - xUnitFunc () - - x - @> - - genVarDefToLambdaTest - "Test 2: we need to go deeper" - <@ - let x = - let mutable y = - if true then - let z = 10 - z + 1 - else - let z = 20 - z + 2 - - for i in 1..10 do - let z = if false then 10 else 20 - y <- y + i + z - - y - - x - @> - <@ - let x = - let xUnitFunc () = - let mutable y = - let yUnitFunc () = - if true then - let z = 10 - z + 1 - else - let z = 20 - z + 2 - - yUnitFunc () - - for i in 1..10 do - let z = - let zUnitFunc () = if false then 10 else 20 - zUnitFunc () - - y <- y + i + z - - y - - xUnitFunc () - - x - @> ] - -let tests = varDefsToLambdaTest |> testList "Var -> Lambda" diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Variables.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Variables.fs new file mode 100644 index 00000000..32dddb28 --- /dev/null +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Variables.fs @@ -0,0 +1,96 @@ +module Brahma.FSharp.Tests.Translator.QuatationTransformation.Variables + +open Brahma.FSharp.OpenCL.Translator.QuotationTransformers +open Expecto + +let private uniquesTests = + [ let createTest name source expected = + test name { + let actual = Variables.defsToLambda source + + let actualStr = actual.ToString() + let expectedStr = expected.ToString() + + Expect.equal actualStr expectedStr "Result should be the same." + } + + createTest "Test 1." <| <@ let x = 1 + 1 in () @> <| <@ let x = 1 + 1 in () @> + + createTest "Test 2." + <| <@ + let x = + let mutable y = 0 + + for i in 1..10 do + y <- y + i + + y + + x + @> + <| <@ + let x = + let xUnitFunc = + fun (unitVar: unit) -> + let mutable y = 0 + + for i in 1..10 do + y <- y + i + + y + + xUnitFunc () + + x + @> + + createTest "Test 3." + <| <@ + let x = + let mutable y = + if true then + let z = 10 + z + 1 + else + let z = 20 + z + 2 + + for i in 1..10 do + let z = if false then 10 else 20 + y <- y + i + z + + y + + x + @> + <| <@ + let x = + let xUnitFunc = + fun (unitVar: unit) -> + let mutable y = + let yUnitFunc = + fun (unitVar: unit) -> + if true then + let z = 10 + z + 1 + else + let z = 20 + z + 2 + + yUnitFunc () + + for i in 1..10 do + let z = + let zUnitFunc = fun (unitVar: unit) -> if false then 10 else 20 + zUnitFunc () + + y <- y + i + z + + y + + xUnitFunc () + + x + @> ] + +let tests = uniquesTests |> testList "Variables" |> testSequenced From c7651d1ead28d79bdaf2b45f22ff67e37c821493 Mon Sep 17 00:00:00 2001 From: IgorErin Date: Tue, 18 Jul 2023 15:32:34 +0300 Subject: [PATCH 14/22] add: VarToRef tests --- .../Brahma.FSharp.OpenCL.Translator.fsproj | 2 +- .../MutableVarsToRefTransformer.fs | 70 ------ .../QuotationTransformers/Utilities/Utils.fs | 13 +- .../QuotationTransformers/VarToRef.fs | 79 +++++++ .../Translator.fs | 4 +- .../Brahma.FSharp.Tests.fsproj | 2 + tests/Brahma.FSharp.Tests/Program.fs | 2 +- tests/Brahma.FSharp.Tests/Translator/All.fs | 3 +- .../QuatationTransformation/VarToRef.fs | 211 ++++++++++++++++++ 9 files changed, 308 insertions(+), 78 deletions(-) delete mode 100644 src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/MutableVarsToRefTransformer.fs create mode 100644 src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/VarToRef.fs create mode 100644 tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/VarToRef.fs diff --git a/src/Brahma.FSharp.OpenCL.Translator/Brahma.FSharp.OpenCL.Translator.fsproj b/src/Brahma.FSharp.OpenCL.Translator/Brahma.FSharp.OpenCL.Translator.fsproj index c8ea5aec..950b6145 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/Brahma.FSharp.OpenCL.Translator.fsproj +++ b/src/Brahma.FSharp.OpenCL.Translator/Brahma.FSharp.OpenCL.Translator.fsproj @@ -29,7 +29,7 @@ - + diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/MutableVarsToRefTransformer.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/MutableVarsToRefTransformer.fs deleted file mode 100644 index f7de0a86..00000000 --- a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/MutableVarsToRefTransformer.fs +++ /dev/null @@ -1,70 +0,0 @@ -namespace Brahma.FSharp.OpenCL.Translator.QuotationTransformers - -open FSharp.Quotations - -[] -module MutableVarsToRefTransformer = - let private isMutableVar (var: Var) = - var.IsMutable && not (Utils.isFunction var) - - let rec collectMutableVarsInClosure = - function - | Patterns.LetFunc(_, body, inExpr) -> - let mutableFreeVars = body |> Utils.collectFreeVarsWithPredicate isMutableVar - - Set.unionMany - [ mutableFreeVars - collectMutableVarsInClosure body - collectMutableVarsInClosure inExpr ] - | ExprShape.ShapeLambda(_, body) -> collectMutableVarsInClosure body - | ExprShape.ShapeVar _ -> Set.empty - | ExprShape.ShapeCombination(_, exprList) -> exprList |> List.map collectMutableVarsInClosure |> Set.unionMany - - let rec varsToRefsWithPredicateImpl (refMap: Map) (predicate: Var -> bool) (expr: Expr) = - match expr with - | Patterns.LetVar(var, body, inExpr) -> - if predicate var then - let refName = var.Name + "Ref" - let refType = typedefof>.MakeGenericType (var.Type) - let refVar = Var(refName, refType, false) - - let newRefMap = refMap.Add(var, Expr.Var refVar) - - Expr.Let( - var, - varsToRefsWithPredicateImpl refMap predicate body, - Expr.Let( - refVar, - Utils.createRefCall <| Expr.Var var, - varsToRefsWithPredicateImpl newRefMap predicate inExpr - ) - ) - else - Expr.Let( - var, - varsToRefsWithPredicateImpl refMap predicate body, - varsToRefsWithPredicateImpl refMap predicate inExpr - ) - - | Patterns.VarSet(var, valueExpr) -> - match refMap.TryFind var with - | Some refExpr -> - Utils.createReferenceSetCall refExpr - <| varsToRefsWithPredicateImpl refMap predicate valueExpr - | None -> expr - - | ExprShape.ShapeVar var -> - match refMap.TryFind var with - | Some refExpr -> Utils.createDereferenceCall refExpr - | None -> expr - | ExprShape.ShapeLambda(var, body) -> Expr.Lambda(var, varsToRefsWithPredicateImpl refMap predicate body) - | ExprShape.ShapeCombination(shapeComboObject, exprList) -> - let exprList' = List.map (varsToRefsWithPredicateImpl refMap predicate) exprList - ExprShape.RebuildShapeCombination(shapeComboObject, exprList') - - let varsToRefsWithPredicate (predicate: Var -> bool) (expr: Expr) = - varsToRefsWithPredicateImpl Map.empty predicate expr - - let transformMutableVarsToRef (expr: Expr) = - let mutableVarsInClosure = collectMutableVarsInClosure expr - varsToRefsWithPredicate mutableVarsInClosure.Contains expr diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Utils.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Utils.fs index 350ecb4a..687709ac 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Utils.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Utils.fs @@ -38,8 +38,6 @@ module Utils = | ExprShape.ShapeLambda(var, body) -> var :: collectLambdaArguments body | _ -> [] - // Это из замыкания переменные? - /// Collect free variables of expression that satisfies predicate. let rec collectFreeVarsWithPredicate (predicate: Var -> bool) (expr: Expr) : Set = expr.GetFreeVars() |> Seq.filter predicate |> Set.ofSeq @@ -62,11 +60,20 @@ module Utils = let isTypeOf<'tp> (var: Var) = var.Type = typeof<'tp> + let createRefVar (var: Var) = + let refName = var.Name + "Ref" + let refType = typedefof>.MakeGenericType var.Type + + Var(refName, refType, false) + + // TODO(make static) let createRefCall (value: Expr) = match <@@ ref () @@> with | Patterns.Call(obj, methodInfo, _) -> let newMethodInfo = - methodInfo.GetGenericMethodDefinition().MakeGenericMethod([| value.Type |]) + methodInfo + .GetGenericMethodDefinition() + .MakeGenericMethod([| value.Type |]) match obj with | Some obj -> Expr.Call(obj, newMethodInfo, [ value ]) diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/VarToRef.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/VarToRef.fs new file mode 100644 index 00000000..96b9d9e7 --- /dev/null +++ b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/VarToRef.fs @@ -0,0 +1,79 @@ +namespace Brahma.FSharp.OpenCL.Translator.QuotationTransformers + +open FSharp.Quotations + +module VarToRef = + let private isMutableVar (var: Var) = + var.IsMutable && not (Utils.isFunction var) + + let rec private collectMutableVarsInClosure = + function + | Patterns.LetFunc(_, body, inExpr) -> + let mutableFreeVars = + body.GetFreeVars() + |> Seq.filter isMutableVar + |> Set.ofSeq + + [ mutableFreeVars + collectMutableVarsInClosure body + collectMutableVarsInClosure inExpr ] + |> Set.unionMany + | ExprShape.ShapeLambda(_, body) -> collectMutableVarsInClosure body + | ExprShape.ShapeVar _ -> Set.empty + | ExprShape.ShapeCombination(_, exprList) -> + exprList + |> List.map collectMutableVarsInClosure + |> Set.unionMany + + let private varsToRefsWithPredicate (predicate: Var -> bool) (expr: Expr) = + let rec parse (refMap: Map) = function + | Patterns.LetVar(var, body, inExpr) -> + if predicate var then + // create refVar, typeof = ref> + let refVar = Utils.createRefVar var + // map var to refVar usage + let newRefMap = refMap.Add(var, Expr.Var refVar) + let refInExpr = parse newRefMap inExpr + + // <@ ref var @> + let refCall = Utils.createRefCall <| Expr.Var var + + // <@ let refVar = ref var in refInExpr @> + let newLetInExpr = Expr.Let(refVar, refCall, refInExpr) + + let newBody = parse refMap body + + // let var = newBody in + // let refVar = ref (var) in + // refInExpr + Expr.Let(var, newBody, newLetInExpr) + else + let body = parse refMap body + let inExp = parse refMap inExpr + + Expr.Let(var, body, inExp) + | Patterns.VarSet(var, valueExpr) as sourceExpr -> + refMap.TryFind var + |> Option.map (fun refExpr -> + let expr = parse refMap valueExpr + Utils.createReferenceSetCall refExpr expr) + |> Option.defaultValue sourceExpr + | ExprShape.ShapeVar var as sourceExpr -> + refMap.TryFind var + |> Option.map Utils.createDereferenceCall + |> Option.defaultValue sourceExpr + | ExprShape.ShapeLambda(var, body) -> + let newBody = parse refMap body + + Expr.Lambda(var, newBody) + | ExprShape.ShapeCombination(shapeComboObject, exprList) -> + let exprList' = List.map (parse refMap) exprList + + ExprShape.RebuildShapeCombination(shapeComboObject, exprList') + + parse Map.empty expr + + let transform (expr: Expr) = + let mutableVarsInClosure = collectMutableVarsInClosure expr + + varsToRefsWithPredicate mutableVarsInClosure.Contains expr diff --git a/src/Brahma.FSharp.OpenCL.Translator/Translator.fs b/src/Brahma.FSharp.OpenCL.Translator/Translator.fs index 17fa0c5d..b9786a8f 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/Translator.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/Translator.fs @@ -92,8 +92,8 @@ type FSQuotationToOpenCLTranslator(device: IDevice, ?translatorOptions: Translat |> WorkSize.get |> Atomic.parse // TODO(refactor) |> Names.makeUnique - |> Variables.defsToLambda // TODO(tests) - |> transformMutableVarsToRef + |> Variables.defsToLambda + |> VarToRef.transform |> Names.makeUnique |> lambdaLifting diff --git a/tests/Brahma.FSharp.Tests/Brahma.FSharp.Tests.fsproj b/tests/Brahma.FSharp.Tests/Brahma.FSharp.Tests.fsproj index ceb47c55..ad90d63c 100644 --- a/tests/Brahma.FSharp.Tests/Brahma.FSharp.Tests.fsproj +++ b/tests/Brahma.FSharp.Tests/Brahma.FSharp.Tests.fsproj @@ -93,6 +93,8 @@ + + diff --git a/tests/Brahma.FSharp.Tests/Program.fs b/tests/Brahma.FSharp.Tests/Program.fs index 27f96462..93d39c97 100644 --- a/tests/Brahma.FSharp.Tests/Program.fs +++ b/tests/Brahma.FSharp.Tests/Program.fs @@ -4,7 +4,7 @@ open Brahma.FSharp.Tests [] let allTests = - testList "All tests" [ Brahma.FSharp.Tests.Translator.QuatationTransformation.Variables.tests ] + testList "All tests" [ Brahma.FSharp.Tests.Translator.QuatationTransformation.VarToRef.tests ] |> testSequenced [] diff --git a/tests/Brahma.FSharp.Tests/Translator/All.fs b/tests/Brahma.FSharp.Tests/Translator/All.fs index 14808082..0397f36c 100644 --- a/tests/Brahma.FSharp.Tests/Translator/All.fs +++ b/tests/Brahma.FSharp.Tests/Translator/All.fs @@ -29,7 +29,8 @@ let passes = [ QuatationTransformation.Print.tests QuatationTransformation.WorkSize.tests QuatationTransformation.Names.tests - QuatationTransformation.Variables.tests ] + QuatationTransformation.Variables.tests + QuatationTransformation.VarToRef.tests ] |> testList "Passes" let union = [ Union.tests ] |> testList "Union" diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/VarToRef.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/VarToRef.fs new file mode 100644 index 00000000..6e30f6dd --- /dev/null +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/VarToRef.fs @@ -0,0 +1,211 @@ +module Brahma.FSharp.Tests.Translator.QuatationTransformation.VarToRef + +open System.Collections.Generic +open Brahma.FSharp.OpenCL.Translator.QuotationTransformers +open Expecto +open FSharp.Quotations + +let private uniquesTests = + [ let createTest name source expected = + test name { + let actual = VarToRef.transform source + + let actualStr = actual.ToString() + let expectedStr = expected.ToString() + + Expect.equal actualStr expectedStr "Result should be the same." + } + + createTest "Test 1" // id (no mutable vars) + <| <@ + let firstVar = () + let secondVar = 2 + + let f () = + firstVar + secondVar + + () @> + <| <@ + let firstVar = () + let secondVar = 2 + + let f () = + firstVar + secondVar + + () @> + + createTest "Test 2" // transform mutable var (unit type) + <| <@ let mutable firstVar = () + let f (x: int) = firstVar + () @> + <| <@ let mutable firstVar = () + let firstVarRef = ref firstVar + let f (x: int) = !firstVarRef // firstVar free in f TODO(_.Value) + () @> + + createTest "Test 3" + <| <@ let mutable firstVar = 1 + let f () = firstVar + () @> + <| <@ let mutable firstVar = 1 + let firstVarRef = ref firstVar + let f () = !firstVarRef + () @> + + createTest "Test 4" + <| <@ let mutable firstVar = 1 + let f () = firstVar <- 1 + () @> + <| <@ let mutable firstVar = 1 + let firstVarRef = ref firstVar + let f () = firstVarRef := 1 + () @> + + createTest "Test 5" + <| <@ let mutable firstVar = 1 + let f () = + firstVar <- 2 + firstVar + ()@> + <| <@ let mutable firstVar = 1 + let firstVarRef = ref firstVar + let f () = + firstVarRef := 2 + !firstVarRef + () @> + + createTest "Test 6" + <| <@ let mutable firstVar = 1 + let mutable secondVar = 0.5 + + let f () = + firstVar <- 3 + secondVar <- 0.25 + + () + () @> + <| <@ let mutable firstVar = 1 + let firstVarRef = ref firstVar + + let secondVar = 0.5 + let secondVarRef = ref secondVar + + let f () = + firstVarRef := 3 + secondVarRef := 0.25 + + () + () @> + + createTest "Test 7" // id (mutable fun) + <| <@ let mutable firstFun = fun () -> 1 + + let f () = + firstFun <- fun () -> 2 + + () + () @> + <| <@ let mutable firstFun = fun () -> 1 + + let f () = + firstFun <- fun () -> 2 + + () + () @> + + createTest "Test 8" + <| <@ let mutable firstVar = + let mutable innerVar = None + + let f (x: int) = innerVar <- Some x + Some 1 + () @> + <| <@ let mutable firstVar = + let mutable innerVar = None + let innerVarRef = ref innerVar + + let f (x: int) = innerVarRef := Some x + Some 1 + () @> + + createTest "Test 9" + <| <@ let mutable firstVar = + let mutable firstInnerVar = + let mutable secondInnerVar = Some 1 + + let f () = secondInnerVar + + None + + let f () = firstInnerVar + + Some () + let f () = firstVar + + () @> + <| <@ let mutable firstVar = + let mutable firstInnerVar = + let mutable secondInnerVar = Some 1 + let secondInnerVarRef = ref secondInnerVar + + let f () = !secondInnerVarRef + + None + let firstInnerVarRef = ref firstInnerVar + + let f () = !firstInnerVarRef + + Some () + + let firstVarRef = ref firstVar + + let f () = !firstVarRef + + () @> + + createTest "Test 10" + <| <@ fun (x: int) (y: int option) -> + let mutable firstVar = Some 2 + + let f = fun () -> + printfn "" + firstVar <- None + printfn "" + firstVar <- Some 0 + firstVar + + () @> + <| <@ fun (x: int) (y: int option) -> + let mutable firstVar = Some 2 + let firstVarRef = ref firstVar + + let f = fun () -> + printfn "" + firstVarRef := None + printfn "" + firstVarRef := Some 0 + !firstVarRef + () @> + + createTest "Test 11" // id + <| <@ let mutable firstVar = () + let mutable secondVar = 2 + + let firstVar = () + let f () = firstVar + let g () = let secondVar = 2 in secondVar + + () + @> + <| <@ let mutable firstVar = () + let mutable secondVar = 2 + + let firstVar = () + let f () = firstVar + let g () = let secondVar = 2 in secondVar + + () @> ] + +let tests = uniquesTests |> testList "VarToRef" |> testSequenced From a80b4f8b286cece1a0ae9d3d1e747d092a62ad9a Mon Sep 17 00:00:00 2001 From: IgorErin Date: Fri, 21 Jul 2023 23:31:40 +0300 Subject: [PATCH 15/22] wip: lambda lifting --- src/Brahma.FSharp.OpenCL.Translator/Body.fs | 19 +- .../Brahma.FSharp.OpenCL.Translator.fsproj | 2 +- .../LambdaLiftingTransformer.fs | 166 ------------------ .../QuotationTransformers/Lifting.fs | 127 ++++++++++++++ .../Utilities/Patterns.fs | 3 +- .../QuotationTransformers/Utilities/Utils.fs | 12 +- .../Translator.fs | 2 +- tests/Brahma.FSharp.Tests/Program.fs | 2 +- .../QuatationTransformation/LambdaLifting.fs | 63 ++++++- 9 files changed, 205 insertions(+), 191 deletions(-) delete mode 100644 src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/LambdaLiftingTransformer.fs create mode 100644 src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Lifting.fs diff --git a/src/Brahma.FSharp.OpenCL.Translator/Body.fs b/src/Brahma.FSharp.OpenCL.Translator/Body.fs index b467388f..52431949 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/Body.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/Body.fs @@ -27,7 +27,6 @@ open Brahma.FSharp // Translations restricts the generic parameter of the AST nodes to the type Lang #nowarn "64" -[] module private BodyPatterns = let (|VarName|_|) (str: string) (var': Var) = match var'.Name with @@ -428,21 +427,21 @@ module rec Body = | None -> match propName with - | Lower(nameof Anchors._localID0) -> + | BodyPatterns.Lower(nameof Anchors._localID0) -> return FunCall("get_local_id", [ Const(PrimitiveType Int, "0") ]) :> Expression<_> - | Lower(nameof Anchors._globalSize0) -> + | BodyPatterns.Lower(nameof Anchors._globalSize0) -> return FunCall("get_global_size", [ Const(PrimitiveType Int, "0") ]) :> Expression<_> - | Lower(nameof Anchors._globalSize1) -> + | BodyPatterns.Lower(nameof Anchors._globalSize1) -> return FunCall("get_global_size", [ Const(PrimitiveType Int, "1") ]) :> Expression<_> - | Lower(nameof Anchors._globalSize2) -> + | BodyPatterns.Lower(nameof Anchors._globalSize2) -> return FunCall("get_global_size", [ Const(PrimitiveType Int, "2") ]) :> Expression<_> - | Lower(nameof Anchors._localSize0) -> + | BodyPatterns.Lower(nameof Anchors._localSize0) -> return FunCall("get_local_size", [ Const(PrimitiveType Int, "0") ]) :> Expression<_> - | Lower(nameof Anchors._localSize1) -> + | BodyPatterns.Lower(nameof Anchors._localSize1) -> return FunCall("get_local_size", [ Const(PrimitiveType Int, "1") ]) :> Expression<_> - | Lower(nameof Anchors._localSize2) -> + | BodyPatterns.Lower(nameof Anchors._localSize2) -> return FunCall("get_local_size", [ Const(PrimitiveType Int, "2") ]) :> Expression<_> | _ -> @@ -929,9 +928,9 @@ module rec Body = raise <| InvalidKernelException $"Field set with empty host is not supported. Field: %A{fldInfo}" - | ForLoopWithStep(loopVar, (start, step, finish), loopBody) -> + | BodyPatterns.ForLoopWithStep(loopVar, (start, step, finish), loopBody) -> return! translateForLoop loopVar start finish (Some step) loopBody >>= toNode - | ForLoop(loopVar, (start, finish), loopBody) -> + | BodyPatterns.ForLoop(loopVar, (start, finish), loopBody) -> return! translateForLoop loopVar start finish None loopBody >>= toNode | Patterns.ForIntegerRangeLoop(loopVar, start, finish, loopBody) -> return! translateForLoop loopVar start finish None loopBody >>= toNode diff --git a/src/Brahma.FSharp.OpenCL.Translator/Brahma.FSharp.OpenCL.Translator.fsproj b/src/Brahma.FSharp.OpenCL.Translator/Brahma.FSharp.OpenCL.Translator.fsproj index 950b6145..bef0d0a7 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/Brahma.FSharp.OpenCL.Translator.fsproj +++ b/src/Brahma.FSharp.OpenCL.Translator/Brahma.FSharp.OpenCL.Translator.fsproj @@ -31,7 +31,7 @@ - + diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/LambdaLiftingTransformer.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/LambdaLiftingTransformer.fs deleted file mode 100644 index f9d4296b..00000000 --- a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/LambdaLiftingTransformer.fs +++ /dev/null @@ -1,166 +0,0 @@ -namespace Brahma.FSharp.OpenCL.Translator.QuotationTransformers - -open Brahma.FSharp.OpenCL.Translator -open FSharp.Quotations - -type Context = - private - { FreeVariables: Map> - Substitution: Map } - -module Context = - /// head: t, args: [x1: t1; x2: t2; x3: t3] - /// result: (newHead: t1 -> t2 -> t3 -> t) x1 x2 x3 - let makeApplication (head: Var) (args: List) = - let argTypes = List.map (fun (x: Var) -> x.Type) args - let newHeadType = Utils.makeFunctionType head.Type argTypes - - let newHead = Var(head.Name, newHeadType, head.IsMutable) - - let application = - args - |> List.map Expr.Var - |> List.fold (fun acc expr -> Expr.Application(acc, expr)) (Expr.Var newHead) - - application, newHead - - let empty = - { FreeVariables = Map.empty - Substitution = Map.empty } - - let setFunctionFreeVariables (oldFuncVar: Var) (extendedParams: List) (ctx: Context) = - { FreeVariables = ctx.FreeVariables.Add(oldFuncVar, extendedParams) - Substitution = ctx.Substitution } - - let setFunctionSubstitution (oldFuncVar: Var) (substitution: Expr) (ctx: Context) = - { FreeVariables = ctx.FreeVariables - Substitution = ctx.Substitution.Add(oldFuncVar, substitution) } - - let getFunctionFreeVariables (oldFuncVar: Var) (ctx: Context) = ctx.FreeVariables.TryFind oldFuncVar - - let getFunctionSubstitution (oldFuncVar: Var) (ctx: Context) = ctx.Substitution.TryFind oldFuncVar - -module VoidArgumentsCleanUp = - let private isConsistOfVoidVarOnly (args: list) = - args.Length = 1 && args.Head.Type = typeof - - let private isConsistOfVoidExprOnly (args: list) = - args.Length = 1 && args.Head.Type = typeof - - let rec private cleanUpVoidArgumentsImpl (subst: Map) (expr: Expr) = - match expr with - | Patterns.LetFuncUncurry(var, args, body, inExpr) -> - let args' = - if isConsistOfVoidVarOnly args then - args - else - List.filter (not << Utils.isTypeOf) args - - let newFuncVarType = - Utils.makeFunctionType body.Type <| List.map (fun (var: Var) -> var.Type) args' - - let newFuncVar = Var(var.Name, newFuncVarType, var.IsMutable) - let body' = cleanUpVoidArgumentsImpl subst body - - let subst' = subst.Add(var, newFuncVar) - let inExpr' = cleanUpVoidArgumentsImpl subst' inExpr - Expr.Let(newFuncVar, Utils.makeLambdaExpr args' body', inExpr') - - | Patterns.ApplicationUncurry(head, exprs) -> - match head with - | Patterns.Var var -> - match subst.TryFind var with - | Some var' -> - let exprs' = - if isConsistOfVoidExprOnly exprs then - exprs - else - List.filter (fun (exp: Expr) -> exp.Type <> typeof) exprs - - Utils.makeApplicationExpr - <| Expr.Var var' - <| List.map (cleanUpVoidArgumentsImpl subst) exprs' - - | _ -> expr - | _ -> expr - | ExprShape.ShapeLambda(var, body) -> Expr.Lambda(var, cleanUpVoidArgumentsImpl subst body) - | ExprShape.ShapeVar var -> - match subst.TryFind var with - | Some _ -> - // TODO: check it in another step. - failwithf "First-Order functions (just like curring) is not supported." - | None -> expr - | ExprShape.ShapeCombination(shapeComboObject, exprList) -> - let exprList' = List.map <| cleanUpVoidArgumentsImpl subst <| exprList - ExprShape.RebuildShapeCombination(shapeComboObject, exprList') - - let cleanUpVoidArguments (expr: Expr) = cleanUpVoidArgumentsImpl Map.empty expr - -[] -module LambdaLifting = - let rec parameterLiftExprImpl (ctx: Context) (expr: Expr) = - match expr with - | Patterns.LetVar(v, definition, inExpr) -> - Expr.Let(v, parameterLiftExprImpl ctx definition, parameterLiftExprImpl ctx inExpr) - - | Patterns.LetFunc(f, definition, inExpr) -> - let localFreeVars = Utils.collectFreeVars definition - let freeFunctionVars = Utils.collectFreeFunctionVars definition - - let getSetFreeVars (fVar: Var) = - Context.getFunctionFreeVariables fVar ctx - |> Option.defaultValue List.empty - |> Set.ofList - - let extendedFreeVars = freeFunctionVars |> Set.map getSetFreeVars |> Set.unionMany - - let freeVars = Set.union localFreeVars extendedFreeVars |> Set.toList - - let (substitution, newFuncVar) = Context.makeApplication f freeVars - let newDefinition = parameterLiftExprImpl ctx definition - - let extendedCtx = - ctx - |> Context.setFunctionFreeVariables f freeVars - |> Context.setFunctionSubstitution f substitution - - Expr.Let( - newFuncVar, - List.foldBack (fun arg body -> Expr.Lambda(arg, body)) freeVars newDefinition, - inExpr |> parameterLiftExprImpl extendedCtx - ) - - | ExprShape.ShapeLambda(x, body) -> Expr.Lambda(x, parameterLiftExprImpl ctx body) - - | ExprShape.ShapeVar var -> - match Context.getFunctionSubstitution var ctx with - | Some subst -> subst - | None -> expr - - | ExprShape.ShapeCombination(shapeComboObject, exprList) -> - ExprShape.RebuildShapeCombination(shapeComboObject, List.map (parameterLiftExprImpl ctx) exprList) - - let parameterLiftExpr = parameterLiftExprImpl Context.empty - - let rec blockFloating (expr: Expr) = - match expr with - | Patterns.LetFunc(var, body, inExpr) -> - let (body', bodyMethods) = blockFloating body - let (inExpr', inExprMethods) = blockFloating inExpr - inExpr', bodyMethods @ [ (var, body') ] @ inExprMethods - - | ExprShape.ShapeLambda(var, body) -> - let (body', methods) = blockFloating body - Expr.Lambda(var, body'), methods - - | ExprShape.ShapeVar var -> Expr.Var(var), List.empty - - | ExprShape.ShapeCombination(shapeComboObject, exprList) -> - let (exprList', methods) = exprList |> List.map blockFloating |> List.unzip - ExprShape.RebuildShapeCombination(shapeComboObject, exprList'), List.concat methods - - let lambdaLifting (expr: Expr) = - expr - |> parameterLiftExpr - |> VoidArgumentsCleanUp.cleanUpVoidArguments - |> blockFloating diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Lifting.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Lifting.fs new file mode 100644 index 00000000..feecdf27 --- /dev/null +++ b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Lifting.fs @@ -0,0 +1,127 @@ +namespace Brahma.FSharp.OpenCL.Translator.QuotationTransformers + +open Brahma.FSharp.OpenCL.Translator +open FSharp.Quotations + +type Context = + { FreeVariables: Map> + Substitution: Map } + + member this.Update(oldFun, newFunVar, freeVars) = + let newApplication = + freeVars + |> List.map Expr.Var + |> Utils.makeApplicationExpr (Expr.Var newFunVar) + + { FreeVariables = this.FreeVariables.Add(oldFun, freeVars) + Substitution = this.Substitution.Add(oldFun, newApplication) } + + static member empty = + { FreeVariables = Map.empty + Substitution = Map.empty } + +module Lift = + module Parameters = + let private collectFreeVars ctx expr = + let localFreeVars = Utils.collectFreeVars expr + + Utils.collectFreeFunctionVars expr + |> Set.map + (ctx.FreeVariables.TryFind >> + Option.defaultValue List.empty >> + Set.ofList) + |> Set.unionMany + |> Set.union localFreeVars + |> Set.toList + + let lift = + let rec run (ctx: Context) = function + | Patterns.LetFunc(f, definition, inExp) -> + let freeVars = collectFreeVars ctx definition + + let definition' = + run ctx definition // body + |> Utils.makeLambdaExpr freeVars + + let f' = Utils.transformToFunctionVar f freeVars + + let inExp' = run (ctx.Update(f, f', freeVars)) inExp + + Expr.Let(f', definition', inExp') + | Patterns.LetVar(v, definition, inExp) -> + let definition' = run ctx definition + let inExp' = run ctx inExp + + Expr.Let(v, definition', inExp') + | ExprShape.ShapeVar var as expr -> + ctx.Substitution.TryFind var + |> Option.defaultValue expr + | ExprShape.ShapeLambda(x, body) -> + Expr.Lambda(x, run ctx body) + | ExprShape.ShapeCombination(o, exprList) -> + ExprShape.RebuildShapeCombination(o, List.map (run ctx) exprList) + + run Context.empty + + module UnitArguments = + let inline private unitExpFilter (args: list<^a> when ^a : (member Type : System.Type)) = + match args with + | [] -> failwith "" // TODO() + | [ _ ] -> args + | _ -> + args |> List.filter (fun arg -> arg.Type <> typeof) + + let cleanUp (expr: Expr) = + let rec parse (subst: Map) = function + | Patterns.LetFuncUncurry(var, args, body, inExpr) -> + let args' = unitExpFilter args + let var' = Utils.transformToFunctionVar var args' + let body' = parse subst body |> Utils.makeLambdaExpr args' + let inExpr' = parse (subst.Add(var, var')) inExpr + + Expr.Let(var', body', inExpr') + | Patterns.ApplicationUncurry(Patterns.Var var, exp) as source -> + subst.TryFind var + |> Option.map (fun var' -> + // TODO(what about exp with unit type???) + let exp' = unitExpFilter exp + + Utils.makeApplicationExpr + <| Expr.Var var' + <| List.map (parse subst) exp') + |> Option.defaultValue source + | ExprShape.ShapeLambda(var, body) -> // map body + Expr.Lambda(var, parse subst body) + | ExprShape.ShapeVar var as source -> + subst.TryFind var + |> Option.bind (fun _ -> + // TODO(make validation pass) + failwithf "First-Order functions (just like curring) is not supported.") + |> Option.defaultValue source + | ExprShape.ShapeCombination(o, exprList) -> + let exprList' = List.map <| parse subst <| exprList + ExprShape.RebuildShapeCombination(o, exprList') + + parse Map.empty expr + + module Lambda = + let rec lift = function + | Patterns.LetFunc(var, body, inExpr) -> + let body', bodyMethods = lift body + let inExpr', inExprMethods = lift inExpr + + inExpr', bodyMethods @ [ (var, body') ] @ inExprMethods + | ExprShape.ShapeLambda(var, body) -> + let body', methods = lift body + + Expr.Lambda(var, body'), methods + | ExprShape.ShapeVar var -> Expr.Var(var), List.empty + | ExprShape.ShapeCombination(o, exprList) -> + let exprList', methods = exprList |> List.map lift |> List.unzip + ExprShape.RebuildShapeCombination(o, exprList'), List.concat methods + + let parse (expr: Expr) = + expr + |> Parameters.lift + |> UnitArguments.cleanUp + |> Lambda.lift diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Patterns.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Patterns.fs index 0aaffda0..fb63636a 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Patterns.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Patterns.fs @@ -25,8 +25,7 @@ module Patterns = | _ -> [], expr let private uncurryApplication (expr: Expr) = - let rec uncurryApplicationImpl (acc: list) (expr: Expr) = - match expr with + let rec uncurryApplicationImpl (acc: list) = function | Application(l, r) -> uncurryApplicationImpl (r :: acc) l | _ -> expr, acc diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Utils.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Utils.fs index 687709ac..7519f2d5 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Utils.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Utils.fs @@ -25,6 +25,14 @@ module Utils = let makeApplicationExpr (head: Expr) (expressions: Expr list) = List.fold (fun l r -> Expr.Application(l, r)) head expressions + /// head: t, args: [x1: t1; x2: t2; x3: t3] + /// newHead: t1 -> t2 -> t3 -> t + let transformToFunctionVar (source: Var) (args: List) = + args + |> List.map (fun x -> x.Type) + |> makeFunctionType source.Type + |> fun t -> Var(source.Name, t, source.IsMutable) + // TODO tail recursion let rec extractLambdaArguments = function @@ -58,8 +66,6 @@ module Utils = | ExprShape.ShapeLambda(_, lambda) -> collectLocalVars lambda | ExprShape.ShapeCombination(_, expressions) -> List.collect collectLocalVars expressions - let isTypeOf<'tp> (var: Var) = var.Type = typeof<'tp> - let createRefVar (var: Var) = let refName = var.Name + "Ref" let refType = typedefof>.MakeGenericType var.Type @@ -107,3 +113,5 @@ module Utils = let isGlobal (var: Var) = var.Type.Name.ToLower().StartsWith ClArray_ || var.Type.Name.ToLower().StartsWith ClCell_ + + diff --git a/src/Brahma.FSharp.OpenCL.Translator/Translator.fs b/src/Brahma.FSharp.OpenCL.Translator/Translator.fs index b9786a8f..91e2d70c 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/Translator.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/Translator.fs @@ -95,7 +95,7 @@ type FSQuotationToOpenCLTranslator(device: IDevice, ?translatorOptions: Translat |> Variables.defsToLambda |> VarToRef.transform |> Names.makeUnique - |> lambdaLifting + |> Lift.parse let translate expr = // TODO: Extract quotationTransformer to translator diff --git a/tests/Brahma.FSharp.Tests/Program.fs b/tests/Brahma.FSharp.Tests/Program.fs index 93d39c97..785cb332 100644 --- a/tests/Brahma.FSharp.Tests/Program.fs +++ b/tests/Brahma.FSharp.Tests/Program.fs @@ -4,7 +4,7 @@ open Brahma.FSharp.Tests [] let allTests = - testList "All tests" [ Brahma.FSharp.Tests.Translator.QuatationTransformation.VarToRef.tests ] + testList "All tests" [ Brahma.FSharp.Tests.Translator.QuatationTransformation.LambdaLifting.unitCleanUpTests ] |> testSequenced [] diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/LambdaLifting.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/LambdaLifting.fs index 6208a52c..622eb1bb 100644 --- a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/LambdaLifting.fs +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/LambdaLifting.fs @@ -5,15 +5,15 @@ open Brahma.FSharp.OpenCL.Translator.QuotationTransformers open Common open Expecto -let private lambdaLiftingTests = - let genParameterLiftTest name expr expected = +let private parameterLiftingTests = + let createTest name expr expected = test name { - let actual = LambdaLifting.parameterLiftExpr expr + let actual = Lift.Parameters.lift expr assertExprEqual actual expected equalsMessage } - [ genParameterLiftTest + [ createTest "Test 1" <@ let x = 1 @@ -26,7 +26,7 @@ let private lambdaLiftingTests = addToX x 2 @> - genParameterLiftTest + createTest "Test 2" <@ let x = 1 @@ -49,7 +49,7 @@ let private lambdaLiftingTests = f x z 3 @> - genParameterLiftTest + createTest "Test 3" <@ let mainX = "global variable" @@ -76,7 +76,7 @@ let private lambdaLiftingTests = foo mainX mainY mainZ @> - genParameterLiftTest + createTest "Test 4" <@ let x0 = 0 @@ -102,5 +102,52 @@ let private lambdaLiftingTests = f x0 x0 @> ] + |> testList "Parameter lifting" -let tests = lambdaLiftingTests |> testList "Lambda lifting" + +let unitCleanUpTests = + let createTest name expr expected = + test name { + let actual = Lift.UnitArguments.cleanUp expr + + assertExprEqual actual expected equalsMessage + } + + [ createTest "Test 1" + <| <@ let f (x: unit) = x in () @> + <| <@ let f (x: unit) = x in () @> + + // createTest "Test 2" + // <| <@ let f (x: unit) (y: int) = x in () @> + // <| (let s = () in <@ let f (y: int) = s in () @>) + // + // createTest "Test 3" + // <| <@ let f (x: unit) (y: unit) = x in () @> + // <| <@ let f (x: unit) = x in () @> + // + // createTest "Test 4" + // <| <@ let f (x: int) = x in () @> + // <| <@ let f (x: int) = x in () @> + // + // createTest "Test 5" + // <| <@ let f (x: int option) = x in () @> + // <| <@ let f (x: int option) = x in () @> + // + // createTest "Test 6" + // <| <@ let f (x: unit option) = x in () @> + // <| <@ let f (x: unit option) = x in () @> + // + // createTest "Test 7" + // <| <@ let f (x: unit) (y: unit) (z: unit) = if x = y then z else z in () @> + // <| <@ let What = () in () @> + // + // createTest "Test 8" + // <| <@ let f (x: unit) (y: unit) (z: unit) = let x = () in y in () @> + // <| <@ () @> + + ] + |> testList "Unit clean up" + + +let tests = [ parameterLiftingTests ] + |> testList "Lambda lifting" From cb88118dff0ec3a34fe9005569195437d120a511 Mon Sep 17 00:00:00 2001 From: IgorErin Date: Sat, 22 Jul 2023 17:47:43 +0300 Subject: [PATCH 16/22] refactor: Unit args cleanup; tests --- .../QuotationTransformers/Lifting.fs | 32 ++++-- .../Utilities/Patterns.fs | 31 +----- .../QuotationTransformers/Utilities/Utils.fs | 8 -- .../QuatationTransformation/Common.fs | 29 +++-- .../QuatationTransformation/LambdaLifting.fs | 101 ++++++++++++------ .../QuatationTransformation/Transformation.fs | 2 +- 6 files changed, 112 insertions(+), 91 deletions(-) diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Lifting.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Lifting.fs index feecdf27..2106c54b 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Lifting.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Lifting.fs @@ -34,6 +34,14 @@ module Lift = |> Set.union localFreeVars |> Set.toList + /// head: t, args: [x1: t1; x2: t2; x3: t3] + /// newHead: t1 -> t2 -> t3 -> t + let private createFunctionVar (source: Var) (args: List) = + args + |> List.map (fun x -> x.Type) + |> Utils.makeFunctionType source.Type + |> fun t -> Var(source.Name, t, source.IsMutable) + let lift = let rec run (ctx: Context) = function | Patterns.LetFunc(f, definition, inExp) -> @@ -43,7 +51,7 @@ module Lift = run ctx definition // body |> Utils.makeLambdaExpr freeVars - let f' = Utils.transformToFunctionVar f freeVars + let f' = createFunctionVar f freeVars let inExp' = run (ctx.Update(f, f', freeVars)) inExp @@ -66,36 +74,44 @@ module Lift = module UnitArguments = let inline private unitExpFilter (args: list<^a> when ^a : (member Type : System.Type)) = match args with - | [] -> failwith "" // TODO() + | [] -> failwith "Arguments cannot be empty" | [ _ ] -> args | _ -> + // if several units ??? args |> List.filter (fun arg -> arg.Type <> typeof) + /// args: [x1: t1; x2: t2; x3: t3], boyd: t4 + /// newVar: t1 -> t2 -> t3 -> t4 + let private createFunctionVar (body: Expr) (args: Var list) (var: Var) = + args + |> List.map (fun var -> var.Type) + |> Utils.makeFunctionType body.Type + |> fun t -> Var(var.Name, t, var.IsMutable) + let cleanUp (expr: Expr) = let rec parse (subst: Map) = function | Patterns.LetFuncUncurry(var, args, body, inExpr) -> let args' = unitExpFilter args - let var' = Utils.transformToFunctionVar var args' + let var' = createFunctionVar body args' var let body' = parse subst body |> Utils.makeLambdaExpr args' let inExpr' = parse (subst.Add(var, var')) inExpr Expr.Let(var', body', inExpr') - | Patterns.ApplicationUncurry(Patterns.Var var, exp) as source -> + | DerivedPatterns.Applications(Patterns.Var var, exps) as source -> subst.TryFind var |> Option.map (fun var' -> // TODO(what about exp with unit type???) - let exp' = unitExpFilter exp + let exps' = unitExpFilter <| List.concat exps Utils.makeApplicationExpr <| Expr.Var var' - <| List.map (parse subst) exp') + <| List.map (parse subst) exps') |> Option.defaultValue source - | ExprShape.ShapeLambda(var, body) -> // map body + | ExprShape.ShapeLambda(var, body) -> Expr.Lambda(var, parse subst body) | ExprShape.ShapeVar var as source -> subst.TryFind var |> Option.bind (fun _ -> - // TODO(make validation pass) failwithf "First-Order functions (just like curring) is not supported.") |> Option.defaultValue source | ExprShape.ShapeCombination(o, exprList) -> diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Patterns.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Patterns.fs index fb63636a..afa0b029 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Patterns.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Patterns.fs @@ -11,41 +11,18 @@ module Patterns = | Let(var, expr, inExpr) -> if predicate var then Some(var, expr, inExpr) else None | _ -> None - let (|LetFunc|_|) = letDefinition Utils.isFunction + let (|LetFunc|_|) exp = letDefinition Utils.isFunction exp let (|LetVar|_|) (expr: Expr) = letDefinition (not << Utils.isFunction) expr - // HACK это все можно DerrivedPatterns.Lambdas и DerrivedPatterns.Applications заменить же - let rec private uncurryLambda (expr: Expr) = - match expr with - | ExprShape.ShapeLambda(var, body) -> - let (args, innerBody) = uncurryLambda body - var :: args, innerBody - | _ -> [], expr - - let private uncurryApplication (expr: Expr) = - let rec uncurryApplicationImpl (acc: list) = function - | Application(l, r) -> uncurryApplicationImpl (r :: acc) l - | _ -> expr, acc - - uncurryApplicationImpl [] expr - /// let f x1 x2 x3 = body in e /// => LetFuncUncurry(f, [x1; x2, x3], body, e) let (|LetFuncUncurry|_|) (expr: Expr) = match expr with - | LetFunc(var, body, inExpr) -> - let args, body' = uncurryLambda body - Some(var, args, body', inExpr) - | _ -> None - - /// e0 e1 e2 e3 - /// => (e0, [e1; e2; e3]) - let (|ApplicationUncurry|_|) (expr: Expr) = - // TODO: think about partial function, we should to raise exception somewhere - match expr with - | Application _ -> Some <| uncurryApplication expr + | Let(var, DerivedPatterns.Lambdas(args, body), inExp) -> + let args = List.concat args + Some(var, args, body, inExp) | _ -> None let (|GlobalVar|_|) = diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Utils.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Utils.fs index 7519f2d5..cb1295b2 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Utils.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Utils.fs @@ -25,14 +25,6 @@ module Utils = let makeApplicationExpr (head: Expr) (expressions: Expr list) = List.fold (fun l r -> Expr.Application(l, r)) head expressions - /// head: t, args: [x1: t1; x2: t2; x3: t3] - /// newHead: t1 -> t2 -> t3 -> t - let transformToFunctionVar (source: Var) (args: List) = - args - |> List.map (fun x -> x.Type) - |> makeFunctionType source.Type - |> fun t -> Var(source.Name, t, source.IsMutable) - // TODO tail recursion let rec extractLambdaArguments = function diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Common.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Common.fs index a245edb3..ce4a1a02 100644 --- a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Common.fs +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Common.fs @@ -9,29 +9,28 @@ module Helpers = let equalsMessage = "Values should be the same." let rec renameUnitVar (expr: Expr) = - let replaceUnitVar (var: Var) = - if var.Type = typeof then + expr.Substitute + <| function + | var when var.Type.IsEquivalentTo(typeof) -> Var("unitVar", var.Type, var.IsMutable) - else - var - - match expr with - | ExprShape.ShapeVar var -> Expr.Var(replaceUnitVar var) - | ExprShape.ShapeLambda(var, body) -> Expr.Lambda(replaceUnitVar var, renameUnitVar body) - | ExprShape.ShapeCombination(shapeComboObj, exprList) -> - ExprShape.RebuildShapeCombination(shapeComboObj, List.map renameUnitVar exprList) + |> Expr.Var + |> Some + | _ -> None let openclTransformQuotation (translator: FSQuotationToOpenCLTranslator) (expr: Expr) = translator.TransformQuotation expr - let assertExprEqual (actual: Expr) (expected: Expr) (msg: string) = - let actual' = renameUnitVar actual - let expected' = renameUnitVar expected + let equalAsStrings (actual: Expr) (expected: Expr) (msg: string) = + Expect.equal <| actual.ToString() <| expected.ToString() <| msg + + let equalToTheExactUnitVars (actual: Expr) (expected: Expr) (msg: string) = + let actual = renameUnitVar actual + let expected = renameUnitVar expected - Expect.equal <| actual'.ToString() <| expected'.ToString() <| msg + equalAsStrings actual expected msg let assertMethodEqual (actual: Var * Expr) (expected: Var * Expr) = Expect.equal (fst actual).Name (fst expected).Name "Method names should be equal" - assertExprEqual (snd actual) (snd expected) + equalAsStrings (snd actual) (snd expected) <| $"Method bodies of %s{(fst actual).Name} is not equal" diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/LambdaLifting.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/LambdaLifting.fs index 622eb1bb..30cfe68a 100644 --- a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/LambdaLifting.fs +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/LambdaLifting.fs @@ -3,14 +3,18 @@ module Brahma.FSharp.Tests.Translator.QuatationTransformation.LambdaLifting open Expecto open Brahma.FSharp.OpenCL.Translator.QuotationTransformers open Common -open Expecto +open Microsoft.FSharp.Quotations +open Brahma.FSharp let private parameterLiftingTests = let createTest name expr expected = test name { let actual = Lift.Parameters.lift expr - assertExprEqual actual expected equalsMessage + let actual = actual.ToString() + let expected = expected.ToString() + + Expect.equal actual expected equalsMessage } [ createTest @@ -104,48 +108,81 @@ let private parameterLiftingTests = @> ] |> testList "Parameter lifting" +let unitVar name = Expr.Cast(Expr.Var(Var(name, typeof))) let unitCleanUpTests = let createTest name expr expected = test name { let actual = Lift.UnitArguments.cleanUp expr - assertExprEqual actual expected equalsMessage + equalAsStrings actual expected equalsMessage } [ createTest "Test 1" <| <@ let f (x: unit) = x in () @> <| <@ let f (x: unit) = x in () @> - // createTest "Test 2" - // <| <@ let f (x: unit) (y: int) = x in () @> - // <| (let s = () in <@ let f (y: int) = s in () @>) - // - // createTest "Test 3" - // <| <@ let f (x: unit) (y: unit) = x in () @> - // <| <@ let f (x: unit) = x in () @> - // - // createTest "Test 4" - // <| <@ let f (x: int) = x in () @> - // <| <@ let f (x: int) = x in () @> - // - // createTest "Test 5" - // <| <@ let f (x: int option) = x in () @> - // <| <@ let f (x: int option) = x in () @> - // - // createTest "Test 6" - // <| <@ let f (x: unit option) = x in () @> - // <| <@ let f (x: unit option) = x in () @> - // - // createTest "Test 7" - // <| <@ let f (x: unit) (y: unit) (z: unit) = if x = y then z else z in () @> - // <| <@ let What = () in () @> - // - // createTest "Test 8" - // <| <@ let f (x: unit) (y: unit) (z: unit) = let x = () in y in () @> - // <| <@ () @> - - ] + createTest "Test 2" + <| <@ let f (x: unit) (y: int) = x in () @> + <| <@ let f (y: int) = (%unitVar "x") in () @> + + createTest "Test 3" + <| <@ let f (x: unit) (y: unit) = x in () @> + <| <@ let f = (%unitVar "x") in () @> + + createTest "Test 4" + <| <@ let f (x: int) = x in () @> + <| <@ let f (x: int) = x in () @> + + createTest "Test 5" + <| <@ let f (x: int option) = x in () @> + <| <@ let f (x: int option) = x in () @> + + createTest "Test 6" + <| <@ let f (x: unit option) = x in () @> + <| <@ let f (x: unit option) = x in () @> + + createTest "Test 7" + <| <@ let f (x: unit) (y: unit) (z: unit) = if x = y then z else y in () @> + <| <@ let f = if (%unitVar "x") = (%unitVar "y") then (%unitVar "z") else (%unitVar "y") in () @> + + createTest "Test 8" + <| <@ let f (x: unit) = let g (y: unit) = Some () in () in () @> + <| <@ let f (x: unit) = let g (y: unit) = Some () in () in () @> + + createTest "Test 9" + <| <@ let f (x: unit) (y: unit) = + let g (z: unit) (c: unit) = x in g y x + in () @> + <| <@ let f = let g = (%unitVar "x") in g in () @> + + createTest "Test 10" + <| <@ let f () = printfn "side effect"; () + let g (x: unit) (y: unit) (z: int) = z + + // side effect in f application + g (f ()) () 0 @> + <| <@ let f () = printfn "side effect"; () + let g (z: int) = z + + // no side effect + g 0 @> + + createTest "Test 11" + <| <@ let f (x: int) = printfn "side effect"; () in + let g (x: unit) (y: int) = y in + + // side effect in f application + g (f 0) 0 @> + <| <@ let f (x: int) = printfn "side effect"; () in + let g (y: int) = y in + + // no side effect + g 0 @> + + createTest "Test 12" // id + <| <@ let f (x: int) = x in f 4 @> + <| <@ let f (x: int) = x in f 4 @> ] |> testList "Unit clean up" diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Transformation.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Transformation.fs index e07ca80b..10530ab6 100644 --- a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Transformation.fs +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Transformation.fs @@ -33,7 +33,7 @@ let private quotationTransformerTest = expr |> openclTransformQuotation translator assertMethodListsEqual actualKernelMethods expectedMethods - assertExprEqual actualKernelExpr expectedKernelExpr "kernels not equals" + equalToTheExactUnitVars actualKernelExpr expectedKernelExpr "kernels not equals" [ genTest testCase From adb579a647351a97fe19ab6083b0a0df07ecad87 Mon Sep 17 00:00:00 2001 From: IgorErin Date: Sun, 23 Jul 2023 00:49:29 +0300 Subject: [PATCH 17/22] add: lambda lifting tests --- tests/Brahma.FSharp.Tests/Program.fs | 2 +- .../QuatationTransformation/Common.fs | 15 ++++ .../QuatationTransformation/LambdaLifting.fs | 81 +++++++++++++++++-- 3 files changed, 90 insertions(+), 8 deletions(-) diff --git a/tests/Brahma.FSharp.Tests/Program.fs b/tests/Brahma.FSharp.Tests/Program.fs index 785cb332..ca1e8339 100644 --- a/tests/Brahma.FSharp.Tests/Program.fs +++ b/tests/Brahma.FSharp.Tests/Program.fs @@ -4,7 +4,7 @@ open Brahma.FSharp.Tests [] let allTests = - testList "All tests" [ Brahma.FSharp.Tests.Translator.QuatationTransformation.LambdaLifting.unitCleanUpTests ] + testList "All tests" [ Brahma.FSharp.Tests.Translator.QuatationTransformation.LambdaLifting.lambdaLiftingTests ] |> testSequenced [] diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Common.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Common.fs index ce4a1a02..1371badb 100644 --- a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Common.fs +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Common.fs @@ -17,12 +17,27 @@ module Helpers = |> Some | _ -> None + let var<'t> name = Var(name, typeof<'t>) + + let expVar<'t> name = Expr.Cast<'t>(Expr.Var(var<'t> name)) + + let varEqual (actual: Var) (expected: Var) = + Expect.equal actual.IsMutable expected.IsMutable "Mutability must be the same" + Expect.isTrue (actual.Type.IsEquivalentTo(expected.Type)) "Type must be the same" + Expect.equal actual.Name expected.Name "Names must be the same" + let openclTransformQuotation (translator: FSQuotationToOpenCLTranslator) (expr: Expr) = translator.TransformQuotation expr let equalAsStrings (actual: Expr) (expected: Expr) (msg: string) = Expect.equal <| actual.ToString() <| expected.ToString() <| msg + let inline typesEqual + (actual: ^a when ^a : (member Type : System.Type)) + (expected: ^b when ^b : (member Type : System.Type)) = + + Expect.isTrue (actual.Type = expected.Type) "Types must be the same" + let equalToTheExactUnitVars (actual: Expr) (expected: Expr) (msg: string) = let actual = renameUnitVar actual let expected = renameUnitVar expected diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/LambdaLifting.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/LambdaLifting.fs index 30cfe68a..cafd4bef 100644 --- a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/LambdaLifting.fs +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/LambdaLifting.fs @@ -3,8 +3,7 @@ module Brahma.FSharp.Tests.Translator.QuatationTransformation.LambdaLifting open Expecto open Brahma.FSharp.OpenCL.Translator.QuotationTransformers open Common -open Microsoft.FSharp.Quotations -open Brahma.FSharp +open FSharp.Quotations let private parameterLiftingTests = let createTest name expr expected = @@ -108,7 +107,7 @@ let private parameterLiftingTests = @> ] |> testList "Parameter lifting" -let unitVar name = Expr.Cast(Expr.Var(Var(name, typeof))) +let unitVar name = expVar name let unitCleanUpTests = let createTest name expr expected = @@ -126,7 +125,7 @@ let unitCleanUpTests = <| <@ let f (x: unit) (y: int) = x in () @> <| <@ let f (y: int) = (%unitVar "x") in () @> - createTest "Test 3" + createTest "Test 3" // TODO(is it correct?) <| <@ let f (x: unit) (y: unit) = x in () @> <| <@ let f = (%unitVar "x") in () @> @@ -161,7 +160,7 @@ let unitCleanUpTests = let g (x: unit) (y: unit) (z: int) = z // side effect in f application - g (f ()) () 0 @> + g (f ()) () 0 @> // TODO(unit expr in application) <| <@ let f () = printfn "side effect"; () let g (z: int) = z @@ -186,5 +185,73 @@ let unitCleanUpTests = |> testList "Unit clean up" -let tests = [ parameterLiftingTests ] - |> testList "Lambda lifting" +let lambdaLiftingTests = + let inline createTest name expr expectedKernel (expectedFunctions: (Var * #Expr) list ) = + test name { + let actualKernel, actualFunctions = Lift.Lambda.lift expr + + typesEqual actualKernel expectedKernel + + (actualFunctions, expectedFunctions) + ||> List.iter2 (fun actual expected -> + varEqual (fst actual) (fst expected) + + let actualFunction = snd actual + let expectedFunction = snd expected + + typesEqual actualFunction expectedFunction + equalAsStrings actualFunction expectedFunction equalsMessage) + + equalAsStrings actualKernel expectedKernel + <| "Kernels should be the same" + } + + [ createTest "Test 1" + <| <@ let f () = () in () @> // source + <| <@ () @> // kernel + <| [ var unit> "f", <@ fun (unitVar0: unit) -> () @> ] // lifted lambdas (var, body) + + createTest "Test 2" + <| <@ let f () = printfn "text" in () @> + <| <@ () @> + <| [ var unit> "f", <@ fun (unitVar0: unit) -> printfn "text" @> ] + + createTest "Test 3" + <| <@ let f (x: int) = () in () @> + <| <@ () @> + <| [ var unit> "f", <@ fun (x: int) -> () @> ] + + createTest "Test 4" + <| <@ let f (x: int) = Some 0 in () @> + <| <@ () @> + <| [ var int option> "f", <@ fun (x: int) -> Some 0 @> ] + + createTest "Test 5" + <| <@ let f () = printfn "first"; printfn "second" in () @> + <| <@ () @> + <| [ var unit> "f", <@ fun (unitVar0: unit) -> printfn "first"; printfn "second" @> ] + + createTest "Test 6" + <| <@ let f () = () in let g () = () in () @> + <| <@ () @> + <| [ var unit> "f", <@ fun (unitVar0: unit) -> () @> + var unit> "g", <@ fun (unitVar0: unit) -> () @> ] + + createTest "Test 7" + <| <@ let f () = let g () = () in () in () @> + <| <@ () @> + <| [ var unit> "g", <@ fun (unitVar0: unit) -> () @> + var unit> "f", <@ fun (unitVar0: unit) -> () @> ] + + createTest "Test 8" + <| <@ let f (x: int) = let g () = x in () in () @> + <| <@ () @> + <| [ var int> "g", <@@ fun (unitVar0: unit) -> (%expVar "x") @@> + var unit> "f", <@@ fun (x: int) -> () @@> ] ] + |> testList "Lambda" + +let tests = + [ parameterLiftingTests + unitCleanUpTests + lambdaLiftingTests ] + |> testList "Lifting" From 1b4583fb1629f44c7235d86f332cb75f4acd7285 Mon Sep 17 00:00:00 2001 From: IgorErin Date: Sun, 23 Jul 2023 13:37:37 +0300 Subject: [PATCH 18/22] refactor: tests --- .../QuotationTransformers/Lifting.fs | 120 +++---- .../QuotationTransformers/Utilities/Utils.fs | 6 +- .../QuotationTransformers/VarToRef.fs | 13 +- .../QuotationTransformers/Variables.fs | 35 +- .../Brahma.FSharp.Tests.fsproj | 2 +- tests/Brahma.FSharp.Tests/Program.fs | 2 +- tests/Brahma.FSharp.Tests/Translator/All.fs | 7 +- .../QuatationTransformation/Common.fs | 21 +- .../{LambdaLifting.fs => Lifting.fs} | 132 ++++--- .../QuatationTransformation/Print.fs | 8 +- .../QuatationTransformation/VarToRef.fs | 323 ++++++++++-------- .../QuatationTransformation/Variables.fs | 74 ++-- .../QuatationTransformation/WorkSize.fs | 11 +- 13 files changed, 402 insertions(+), 352 deletions(-) rename tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/{LambdaLifting.fs => Lifting.fs} (69%) diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Lifting.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Lifting.fs index 2106c54b..195464d5 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Lifting.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Lifting.fs @@ -9,9 +9,7 @@ type Context = member this.Update(oldFun, newFunVar, freeVars) = let newApplication = - freeVars - |> List.map Expr.Var - |> Utils.makeApplicationExpr (Expr.Var newFunVar) + freeVars |> List.map Expr.Var |> Utils.makeApplicationExpr (Expr.Var newFunVar) { FreeVariables = this.FreeVariables.Add(oldFun, freeVars) Substitution = this.Substitution.Add(oldFun, newApplication) } @@ -26,13 +24,10 @@ module Lift = let localFreeVars = Utils.collectFreeVars expr Utils.collectFreeFunctionVars expr - |> Set.map - (ctx.FreeVariables.TryFind >> - Option.defaultValue List.empty >> - Set.ofList) - |> Set.unionMany - |> Set.union localFreeVars - |> Set.toList + |> Set.map (ctx.FreeVariables.TryFind >> Option.defaultValue List.empty >> Set.ofList) + |> Set.unionMany + |> Set.union localFreeVars + |> Set.toList /// head: t, args: [x1: t1; x2: t2; x3: t3] /// newHead: t1 -> t2 -> t3 -> t @@ -40,42 +35,40 @@ module Lift = args |> List.map (fun x -> x.Type) |> Utils.makeFunctionType source.Type - |> fun t -> Var(source.Name, t, source.IsMutable) + |> fun t -> Var(source.Name, t, source.IsMutable) let lift = - let rec run (ctx: Context) = function - | Patterns.LetFunc(f, definition, inExp) -> - let freeVars = collectFreeVars ctx definition + let rec run (ctx: Context) = + function + | Patterns.LetFunc(f, definition, inExp) -> + let freeVars = collectFreeVars ctx definition - let definition' = - run ctx definition // body - |> Utils.makeLambdaExpr freeVars + let definition' = + run ctx definition // body + |> Utils.makeLambdaExpr freeVars - let f' = createFunctionVar f freeVars + let f' = createFunctionVar f freeVars - let inExp' = run (ctx.Update(f, f', freeVars)) inExp + let inExp' = run (ctx.Update(f, f', freeVars)) inExp - Expr.Let(f', definition', inExp') - | Patterns.LetVar(v, definition, inExp) -> - let definition' = run ctx definition - let inExp' = run ctx inExp + Expr.Let(f', definition', inExp') + | Patterns.LetVar(v, definition, inExp) -> + let definition' = run ctx definition + let inExp' = run ctx inExp - Expr.Let(v, definition', inExp') - | ExprShape.ShapeVar var as expr -> - ctx.Substitution.TryFind var - |> Option.defaultValue expr - | ExprShape.ShapeLambda(x, body) -> - Expr.Lambda(x, run ctx body) - | ExprShape.ShapeCombination(o, exprList) -> - ExprShape.RebuildShapeCombination(o, List.map (run ctx) exprList) + Expr.Let(v, definition', inExp') + | ExprShape.ShapeVar var as expr -> ctx.Substitution.TryFind var |> Option.defaultValue expr + | ExprShape.ShapeLambda(x, body) -> Expr.Lambda(x, run ctx body) + | ExprShape.ShapeCombination(o, exprList) -> + ExprShape.RebuildShapeCombination(o, List.map (run ctx) exprList) run Context.empty module UnitArguments = - let inline private unitExpFilter (args: list<^a> when ^a : (member Type : System.Type)) = + let inline private unitExpFilter (args: list< ^a > when ^a: (member Type: System.Type)) = match args with | [] -> failwith "Arguments cannot be empty" - | [ _ ] -> args + | [ _ ] -> args | _ -> // if several units ??? args |> List.filter (fun arg -> arg.Type <> typeof) @@ -89,39 +82,37 @@ module Lift = |> fun t -> Var(var.Name, t, var.IsMutable) let cleanUp (expr: Expr) = - let rec parse (subst: Map) = function - | Patterns.LetFuncUncurry(var, args, body, inExpr) -> - let args' = unitExpFilter args - let var' = createFunctionVar body args' var - let body' = parse subst body |> Utils.makeLambdaExpr args' - let inExpr' = parse (subst.Add(var, var')) inExpr - - Expr.Let(var', body', inExpr') - | DerivedPatterns.Applications(Patterns.Var var, exps) as source -> - subst.TryFind var - |> Option.map (fun var' -> - // TODO(what about exp with unit type???) - let exps' = unitExpFilter <| List.concat exps - - Utils.makeApplicationExpr - <| Expr.Var var' - <| List.map (parse subst) exps') - |> Option.defaultValue source - | ExprShape.ShapeLambda(var, body) -> - Expr.Lambda(var, parse subst body) - | ExprShape.ShapeVar var as source -> - subst.TryFind var - |> Option.bind (fun _ -> - failwithf "First-Order functions (just like curring) is not supported.") - |> Option.defaultValue source - | ExprShape.ShapeCombination(o, exprList) -> - let exprList' = List.map <| parse subst <| exprList - ExprShape.RebuildShapeCombination(o, exprList') + let rec parse (subst: Map) = + function + | Patterns.LetFuncUncurry(var, args, body, inExpr) -> + let args' = unitExpFilter args + let var' = createFunctionVar body args' var + let body' = parse subst body |> Utils.makeLambdaExpr args' + let inExpr' = parse (subst.Add(var, var')) inExpr + + Expr.Let(var', body', inExpr') + | DerivedPatterns.Applications(Patterns.Var var, exps) as source -> + subst.TryFind var + |> Option.map (fun var' -> + // TODO(what about exp with unit type???) + let exps' = unitExpFilter <| List.concat exps + + Utils.makeApplicationExpr <| Expr.Var var' <| List.map (parse subst) exps') + |> Option.defaultValue source + | ExprShape.ShapeLambda(var, body) -> Expr.Lambda(var, parse subst body) + | ExprShape.ShapeVar var as source -> + subst.TryFind var + |> Option.bind (fun _ -> failwithf "First-Order functions (just like curring) is not supported.") + |> Option.defaultValue source + | ExprShape.ShapeCombination(o, exprList) -> + let exprList' = List.map <| parse subst <| exprList + ExprShape.RebuildShapeCombination(o, exprList') parse Map.empty expr module Lambda = - let rec lift = function + let rec lift = + function | Patterns.LetFunc(var, body, inExpr) -> let body', bodyMethods = lift body let inExpr', inExprMethods = lift inExpr @@ -137,7 +128,4 @@ module Lift = ExprShape.RebuildShapeCombination(o, exprList'), List.concat methods let parse (expr: Expr) = - expr - |> Parameters.lift - |> UnitArguments.cleanUp - |> Lambda.lift + expr |> Parameters.lift |> UnitArguments.cleanUp |> Lambda.lift diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Utils.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Utils.fs index cb1295b2..1b85ced4 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Utils.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Utils.fs @@ -69,9 +69,7 @@ module Utils = match <@@ ref () @@> with | Patterns.Call(obj, methodInfo, _) -> let newMethodInfo = - methodInfo - .GetGenericMethodDefinition() - .MakeGenericMethod([| value.Type |]) + methodInfo.GetGenericMethodDefinition().MakeGenericMethod([| value.Type |]) match obj with | Some obj -> Expr.Call(obj, newMethodInfo, [ value ]) @@ -105,5 +103,3 @@ module Utils = let isGlobal (var: Var) = var.Type.Name.ToLower().StartsWith ClArray_ || var.Type.Name.ToLower().StartsWith ClCell_ - - diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/VarToRef.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/VarToRef.fs index 96b9d9e7..6bad44a8 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/VarToRef.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/VarToRef.fs @@ -9,10 +9,7 @@ module VarToRef = let rec private collectMutableVarsInClosure = function | Patterns.LetFunc(_, body, inExpr) -> - let mutableFreeVars = - body.GetFreeVars() - |> Seq.filter isMutableVar - |> Set.ofSeq + let mutableFreeVars = body.GetFreeVars() |> Seq.filter isMutableVar |> Set.ofSeq [ mutableFreeVars collectMutableVarsInClosure body @@ -20,13 +17,11 @@ module VarToRef = |> Set.unionMany | ExprShape.ShapeLambda(_, body) -> collectMutableVarsInClosure body | ExprShape.ShapeVar _ -> Set.empty - | ExprShape.ShapeCombination(_, exprList) -> - exprList - |> List.map collectMutableVarsInClosure - |> Set.unionMany + | ExprShape.ShapeCombination(_, exprList) -> exprList |> List.map collectMutableVarsInClosure |> Set.unionMany let private varsToRefsWithPredicate (predicate: Var -> bool) (expr: Expr) = - let rec parse (refMap: Map) = function + let rec parse (refMap: Map) = + function | Patterns.LetVar(var, body, inExpr) -> if predicate var then // create refVar, typeof = ref> diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Variables.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Variables.fs index ba8bfc53..a644274f 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Variables.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Variables.fs @@ -4,6 +4,8 @@ open FSharp.Quotations open FSharp.Reflection module Variables = + let unitVarName = "unitVar0" + // TODO need way to identify expression vs statements (now it is very primitive) let rec private isPrimitiveExpression = function @@ -23,11 +25,16 @@ module Variables = | Patterns.NewUnionCase _ -> true | _ -> false + let inline private createFunVar sourceName sourceType = + let fType = FSharpType.MakeFunctionType(typeof, sourceType) + + Var(sourceName + "UnitFunc", fType) + // create: let fVal () = expr in unit () - let private createApplication fVar body = + let private createDefinitionAndApplication fVar body = Expr.Let( fVar, - Expr.Lambda(Var("unitVar", typeof), body), + Expr.Lambda(Var(unitVarName, typeof), body), Expr.Application(Expr.Var fVar, Expr.Value((), typeof)) ) @@ -38,28 +45,24 @@ module Variables = if isPrimitiveExpression body then Expr.Let(var, body, defsToLambda inExpr) else - let funVal = - let fType = FSharpType.MakeFunctionType(typeof, var.Type) - - Var(var.Name + "UnitFunc", fType) - - let body = defsToLambda body - let letEvalAndApplication = createApplication funVal body + let letAndApplication = + createDefinitionAndApplication + <| createFunVar var.Name var.Type + <| defsToLambda body let newInExpr = defsToLambda inExpr - Expr.Let(var, letEvalAndApplication, newInExpr) + Expr.Let(var, letAndApplication, newInExpr) | Patterns.PropertySet(Some o, prop, indices, value) -> if isPrimitiveExpression value then Expr.PropertySet(o, prop, value, indices) else - let fType = FSharpType.MakeFunctionType(typeof, prop.PropertyType) - let fVal = Var(prop.Name + "UnitFunc", fType) - - let body = defsToLambda value - let letEvalAndApplication = createApplication fVal body + let letAndApplication = + createDefinitionAndApplication + <|createFunVar prop.Name prop.PropertyType + <| defsToLambda value - Expr.PropertySet(o, prop, letEvalAndApplication, indices) + Expr.PropertySet(o, prop, letAndApplication, indices) | ExprShape.ShapeVar _ as expr -> expr | ExprShape.ShapeLambda(var, body) -> Expr.Lambda(var, defsToLambda body) | ExprShape.ShapeCombination(shapeComboObject, exprList) -> diff --git a/tests/Brahma.FSharp.Tests/Brahma.FSharp.Tests.fsproj b/tests/Brahma.FSharp.Tests/Brahma.FSharp.Tests.fsproj index ad90d63c..bdbcd6f2 100644 --- a/tests/Brahma.FSharp.Tests/Brahma.FSharp.Tests.fsproj +++ b/tests/Brahma.FSharp.Tests/Brahma.FSharp.Tests.fsproj @@ -95,7 +95,7 @@ - + diff --git a/tests/Brahma.FSharp.Tests/Program.fs b/tests/Brahma.FSharp.Tests/Program.fs index ca1e8339..5b06276d 100644 --- a/tests/Brahma.FSharp.Tests/Program.fs +++ b/tests/Brahma.FSharp.Tests/Program.fs @@ -4,7 +4,7 @@ open Brahma.FSharp.Tests [] let allTests = - testList "All tests" [ Brahma.FSharp.Tests.Translator.QuatationTransformation.LambdaLifting.lambdaLiftingTests ] + testList "All tests" [ Translator.QuatationTransformation.Variables.tests ] |> testSequenced [] diff --git a/tests/Brahma.FSharp.Tests/Translator/All.fs b/tests/Brahma.FSharp.Tests/Translator/All.fs index 0397f36c..f0f49add 100644 --- a/tests/Brahma.FSharp.Tests/Translator/All.fs +++ b/tests/Brahma.FSharp.Tests/Translator/All.fs @@ -30,15 +30,14 @@ let passes = QuatationTransformation.WorkSize.tests QuatationTransformation.Names.tests QuatationTransformation.Variables.tests - QuatationTransformation.VarToRef.tests ] + QuatationTransformation.VarToRef.tests + QuatationTransformation.Lifting.tests ] |> testList "Passes" let union = [ Union.tests ] |> testList "Union" let transformation = - [ QuatationTransformation.Transformation.tests - QuatationTransformation.LambdaLifting.tests ] - |> testList "Transformation" + [ QuatationTransformation.Transformation.tests ] |> testList "Transformation" let tests = [ common diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Common.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Common.fs index 1371badb..c0735404 100644 --- a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Common.fs +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Common.fs @@ -12,9 +12,7 @@ module Helpers = expr.Substitute <| function | var when var.Type.IsEquivalentTo(typeof) -> - Var("unitVar", var.Type, var.IsMutable) - |> Expr.Var - |> Some + Var("unitVar", var.Type, var.IsMutable) |> Expr.Var |> Some | _ -> None let var<'t> name = Var(name, typeof<'t>) @@ -33,8 +31,9 @@ module Helpers = Expect.equal <| actual.ToString() <| expected.ToString() <| msg let inline typesEqual - (actual: ^a when ^a : (member Type : System.Type)) - (expected: ^b when ^b : (member Type : System.Type)) = + (actual: ^a when ^a: (member Type: System.Type)) + (expected: ^b when ^b: (member Type: System.Type)) + = Expect.isTrue (actual.Type = expected.Type) "Types must be the same" @@ -44,8 +43,14 @@ module Helpers = equalAsStrings actual expected msg + let exprEqual (actual: Expr) (expected: Expr) = + typesEqual actual expected // TODO(check that all types in exps are equal (vars, ...)) + equalAsStrings actual expected equalsMessage + let assertMethodEqual (actual: Var * Expr) (expected: Var * Expr) = - Expect.equal (fst actual).Name (fst expected).Name "Method names should be equal" + varEqual (fst actual) (fst expected) + exprEqual (snd actual) (snd expected) + + let createMapTestAndCompareAsStrings map name source expected = + test name { exprEqual (map source) expected } - equalAsStrings (snd actual) (snd expected) - <| $"Method bodies of %s{(fst actual).Name} is not equal" diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/LambdaLifting.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Lifting.fs similarity index 69% rename from tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/LambdaLifting.fs rename to tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Lifting.fs index cafd4bef..01a09220 100644 --- a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/LambdaLifting.fs +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Lifting.fs @@ -1,20 +1,13 @@ -module Brahma.FSharp.Tests.Translator.QuatationTransformation.LambdaLifting +module Brahma.FSharp.Tests.Translator.QuatationTransformation.Lifting open Expecto open Brahma.FSharp.OpenCL.Translator.QuotationTransformers open Common open FSharp.Quotations -let private parameterLiftingTests = - let createTest name expr expected = - test name { - let actual = Lift.Parameters.lift expr - - let actual = actual.ToString() - let expected = expected.ToString() - - Expect.equal actual expected equalsMessage - } +let parameterLiftingTests = + let createTest name = + createMapTestAndCompareAsStrings Lift.Parameters.lift name [ createTest "Test 1" @@ -104,18 +97,18 @@ let private parameterLiftingTests = g x0 x1 f x0 x0 - @> ] - |> testList "Parameter lifting" + @> + + createTest "Test 5" // id + <| <@ let f = let x = 4 in x in () @> + <| <@ let f = let x = 4 in x in () @> ] + |> testList "Parameter" let unitVar name = expVar name let unitCleanUpTests = - let createTest name expr expected = - test name { - let actual = Lift.UnitArguments.cleanUp expr - - equalAsStrings actual expected equalsMessage - } + let createTest name = + createMapTestAndCompareAsStrings Lift.UnitArguments.cleanUp name [ createTest "Test 1" <| <@ let f (x: unit) = x in () @> @@ -143,41 +136,65 @@ let unitCleanUpTests = createTest "Test 7" <| <@ let f (x: unit) (y: unit) (z: unit) = if x = y then z else y in () @> - <| <@ let f = if (%unitVar "x") = (%unitVar "y") then (%unitVar "z") else (%unitVar "y") in () @> + <| <@ + let f = + if (%unitVar "x") = (%unitVar "y") then + (%unitVar "z") + else + (%unitVar "y") in () + @> createTest "Test 8" - <| <@ let f (x: unit) = let g (y: unit) = Some () in () in () @> - <| <@ let f (x: unit) = let g (y: unit) = Some () in () in () @> + <| <@ let f (x: unit) = let g (y: unit) = Some() in () in () @> + <| <@ let f (x: unit) = let g (y: unit) = Some() in () in () @> createTest "Test 9" - <| <@ let f (x: unit) (y: unit) = - let g (z: unit) (c: unit) = x in g y x - in () @> + <| <@ let f (x: unit) (y: unit) = let g (z: unit) (c: unit) = x in g y x in () @> <| <@ let f = let g = (%unitVar "x") in g in () @> createTest "Test 10" - <| <@ let f () = printfn "side effect"; () - let g (x: unit) (y: unit) (z: int) = z + <| <@ + let f () = + printfn "side effect" + () + + let g (x: unit) (y: unit) (z: int) = z - // side effect in f application - g (f ()) () 0 @> // TODO(unit expr in application) - <| <@ let f () = printfn "side effect"; () - let g (z: int) = z + // side effect in f application + g (f ()) () 0 + @> // TODO(unit expr in application) + <| <@ + let f () = + printfn "side effect" + () - // no side effect - g 0 @> + let g (z: int) = z + + // no side effect + g 0 + @> createTest "Test 11" - <| <@ let f (x: int) = printfn "side effect"; () in - let g (x: unit) (y: int) = y in + <| <@ + let f (x: int) = + printfn "side effect" + () in + + let g (x: unit) (y: int) = y in - // side effect in f application - g (f 0) 0 @> - <| <@ let f (x: int) = printfn "side effect"; () in - let g (y: int) = y in + // side effect in f application + g (f 0) 0 + @> + <| <@ + let f (x: int) = + printfn "side effect" + () in - // no side effect - g 0 @> + let g (y: int) = y in + + // no side effect + g 0 + @> createTest "Test 12" // id <| <@ let f (x: int) = x in f 4 @> @@ -186,24 +203,16 @@ let unitCleanUpTests = let lambdaLiftingTests = - let inline createTest name expr expectedKernel (expectedFunctions: (Var * #Expr) list ) = + let inline createTest name expr expectedKernel (expectedFunctions: (Var * #Expr) list) = test name { let actualKernel, actualFunctions = Lift.Lambda.lift expr typesEqual actualKernel expectedKernel (actualFunctions, expectedFunctions) - ||> List.iter2 (fun actual expected -> - varEqual (fst actual) (fst expected) - - let actualFunction = snd actual - let expectedFunction = snd expected - - typesEqual actualFunction expectedFunction - equalAsStrings actualFunction expectedFunction equalsMessage) + ||> List.iter2 assertMethodEqual - equalAsStrings actualKernel expectedKernel - <| "Kernels should be the same" + equalAsStrings actualKernel expectedKernel <| "Kernels should be the same" } [ createTest "Test 1" @@ -227,12 +236,25 @@ let lambdaLiftingTests = <| [ var int option> "f", <@ fun (x: int) -> Some 0 @> ] createTest "Test 5" - <| <@ let f () = printfn "first"; printfn "second" in () @> + <| <@ + let f () = + printfn "first" + printfn "second" in () + @> <| <@ () @> - <| [ var unit> "f", <@ fun (unitVar0: unit) -> printfn "first"; printfn "second" @> ] + <| [ var unit> "f", + <@ + fun (unitVar0: unit) -> + printfn "first" + printfn "second" + @> ] createTest "Test 6" - <| <@ let f () = () in let g () = () in () @> + <| <@ + let f () = () in + let g () = () in + () + @> <| <@ () @> <| [ var unit> "f", <@ fun (unitVar0: unit) -> () @> var unit> "g", <@ fun (unitVar0: unit) -> () @> ] diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Print.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Print.fs index 27934e94..2d20eddb 100644 --- a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Print.fs +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Print.fs @@ -4,12 +4,8 @@ open Expecto open Brahma.FSharp.OpenCL.Translator.QuotationTransformers let private replaceTests = - [ let createTest name source expected = - test name { - let actual = Print.replace source - - Expect.equal actual expected "Result should be the same." - } + [ let inline createTest name = + Common.Helpers.createMapTestAndCompareAsStrings Print.replace name let tpArgs: System.Type list = [] let value = "" diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/VarToRef.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/VarToRef.fs index 6e30f6dd..0529a028 100644 --- a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/VarToRef.fs +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/VarToRef.fs @@ -1,20 +1,11 @@ module Brahma.FSharp.Tests.Translator.QuatationTransformation.VarToRef -open System.Collections.Generic open Brahma.FSharp.OpenCL.Translator.QuotationTransformers open Expecto -open FSharp.Quotations let private uniquesTests = - [ let createTest name source expected = - test name { - let actual = VarToRef.transform source - - let actualStr = actual.ToString() - let expectedStr = expected.ToString() - - Expect.equal actualStr expectedStr "Result should be the same." - } + [ let inline createTest name = + Common.Helpers.createMapTestAndCompareAsStrings VarToRef.transform name createTest "Test 1" // id (no mutable vars) <| <@ @@ -25,7 +16,8 @@ let private uniquesTests = firstVar secondVar - () @> + () + @> <| <@ let firstVar = () let secondVar = 2 @@ -34,178 +26,233 @@ let private uniquesTests = firstVar secondVar - () @> + () + @> createTest "Test 2" // transform mutable var (unit type) - <| <@ let mutable firstVar = () - let f (x: int) = firstVar - () @> - <| <@ let mutable firstVar = () - let firstVarRef = ref firstVar - let f (x: int) = !firstVarRef // firstVar free in f TODO(_.Value) - () @> + <| <@ + let mutable firstVar = () + let f (x: int) = firstVar + () + @> + <| <@ + let mutable firstVar = () + let firstVarRef = ref firstVar + let f (x: int) = !firstVarRef // firstVar free in f TODO(_.Value) + () + @> createTest "Test 3" - <| <@ let mutable firstVar = 1 - let f () = firstVar - () @> - <| <@ let mutable firstVar = 1 - let firstVarRef = ref firstVar - let f () = !firstVarRef - () @> + <| <@ + let mutable firstVar = 1 + let f () = firstVar + () + @> + <| <@ + let mutable firstVar = 1 + let firstVarRef = ref firstVar + let f () = !firstVarRef + () + @> createTest "Test 4" - <| <@ let mutable firstVar = 1 - let f () = firstVar <- 1 - () @> - <| <@ let mutable firstVar = 1 - let firstVarRef = ref firstVar - let f () = firstVarRef := 1 - () @> + <| <@ + let mutable firstVar = 1 + let f () = firstVar <- 1 + () + @> + <| <@ + let mutable firstVar = 1 + let firstVarRef = ref firstVar + let f () = firstVarRef := 1 + () + @> createTest "Test 5" - <| <@ let mutable firstVar = 1 - let f () = - firstVar <- 2 - firstVar - ()@> - <| <@ let mutable firstVar = 1 - let firstVarRef = ref firstVar - let f () = - firstVarRef := 2 - !firstVarRef - () @> + <| <@ + let mutable firstVar = 1 + + let f () = + firstVar <- 2 + firstVar + + () + @> + <| <@ + let mutable firstVar = 1 + let firstVarRef = ref firstVar + + let f () = + firstVarRef := 2 + !firstVarRef + + () + @> createTest "Test 6" - <| <@ let mutable firstVar = 1 - let mutable secondVar = 0.5 + <| <@ + let mutable firstVar = 1 + let mutable secondVar = 0.5 - let f () = - firstVar <- 3 - secondVar <- 0.25 + let f () = + firstVar <- 3 + secondVar <- 0.25 + + () - () - () @> - <| <@ let mutable firstVar = 1 - let firstVarRef = ref firstVar + () + @> + <| <@ + let mutable firstVar = 1 + let firstVarRef = ref firstVar - let secondVar = 0.5 - let secondVarRef = ref secondVar + let secondVar = 0.5 + let secondVarRef = ref secondVar + + let f () = + firstVarRef := 3 + secondVarRef := 0.25 - let f () = - firstVarRef := 3 - secondVarRef := 0.25 + () - () - () @> + () + @> createTest "Test 7" // id (mutable fun) - <| <@ let mutable firstFun = fun () -> 1 + <| <@ + let mutable firstFun = fun () -> 1 + + let f () = + firstFun <- fun () -> 2 - let f () = - firstFun <- fun () -> 2 + () - () - () @> - <| <@ let mutable firstFun = fun () -> 1 + () + @> + <| <@ + let mutable firstFun = fun () -> 1 + + let f () = + firstFun <- fun () -> 2 - let f () = - firstFun <- fun () -> 2 + () - () - () @> + () + @> createTest "Test 8" - <| <@ let mutable firstVar = - let mutable innerVar = None + <| <@ + let mutable firstVar = + let mutable innerVar = None + + let f (x: int) = innerVar <- Some x + Some 1 - let f (x: int) = innerVar <- Some x - Some 1 - () @> - <| <@ let mutable firstVar = - let mutable innerVar = None - let innerVarRef = ref innerVar + () + @> + <| <@ + let mutable firstVar = + let mutable innerVar = None + let innerVarRef = ref innerVar - let f (x: int) = innerVarRef := Some x - Some 1 - () @> + let f (x: int) = innerVarRef := Some x + Some 1 + + () + @> createTest "Test 9" - <| <@ let mutable firstVar = - let mutable firstInnerVar = - let mutable secondInnerVar = Some 1 + <| <@ + let mutable firstVar = + let mutable firstInnerVar = + let mutable secondInnerVar = Some 1 - let f () = secondInnerVar + let f () = secondInnerVar - None + None - let f () = firstInnerVar + let f () = firstInnerVar - Some () - let f () = firstVar + Some() - () @> - <| <@ let mutable firstVar = - let mutable firstInnerVar = - let mutable secondInnerVar = Some 1 - let secondInnerVarRef = ref secondInnerVar + let f () = firstVar - let f () = !secondInnerVarRef + () + @> + <| <@ + let mutable firstVar = + let mutable firstInnerVar = + let mutable secondInnerVar = Some 1 + let secondInnerVarRef = ref secondInnerVar + + let f () = !secondInnerVarRef + + None - None - let firstInnerVarRef = ref firstInnerVar + let firstInnerVarRef = ref firstInnerVar - let f () = !firstInnerVarRef + let f () = !firstInnerVarRef - Some () + Some() - let firstVarRef = ref firstVar + let firstVarRef = ref firstVar - let f () = !firstVarRef + let f () = !firstVarRef - () @> + () + @> createTest "Test 10" - <| <@ fun (x: int) (y: int option) -> - let mutable firstVar = Some 2 - - let f = fun () -> - printfn "" - firstVar <- None - printfn "" - firstVar <- Some 0 - firstVar - - () @> - <| <@ fun (x: int) (y: int option) -> - let mutable firstVar = Some 2 - let firstVarRef = ref firstVar - - let f = fun () -> - printfn "" - firstVarRef := None - printfn "" - firstVarRef := Some 0 - !firstVarRef - () @> + <| <@ + fun (x: int) (y: int option) -> + let mutable firstVar = Some 2 + + let f = + fun () -> + printfn "" + firstVar <- None + printfn "" + firstVar <- Some 0 + firstVar + + () + @> + <| <@ + fun (x: int) (y: int option) -> + let mutable firstVar = Some 2 + let firstVarRef = ref firstVar + + let f = + fun () -> + printfn "" + firstVarRef := None + printfn "" + firstVarRef := Some 0 + !firstVarRef + + () + @> createTest "Test 11" // id - <| <@ let mutable firstVar = () - let mutable secondVar = 2 + <| <@ + let mutable firstVar = () + let mutable secondVar = 2 - let firstVar = () - let f () = firstVar - let g () = let secondVar = 2 in secondVar + let firstVar = () + let f () = firstVar + let g () = let secondVar = 2 in secondVar - () - @> - <| <@ let mutable firstVar = () - let mutable secondVar = 2 + () + @> + <| <@ + let mutable firstVar = () + let mutable secondVar = 2 - let firstVar = () - let f () = firstVar - let g () = let secondVar = 2 in secondVar + let firstVar = () + let f () = firstVar + let g () = let secondVar = 2 in secondVar - () @> ] + () + @> ] let tests = uniquesTests |> testList "VarToRef" |> testSequenced diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Variables.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Variables.fs index 32dddb28..abff7fb2 100644 --- a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Variables.fs +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Variables.fs @@ -4,15 +4,8 @@ open Brahma.FSharp.OpenCL.Translator.QuotationTransformers open Expecto let private uniquesTests = - [ let createTest name source expected = - test name { - let actual = Variables.defsToLambda source - - let actualStr = actual.ToString() - let expectedStr = expected.ToString() - - Expect.equal actualStr expectedStr "Result should be the same." - } + [ let createTest name = + Common.Helpers.createMapTestAndCompareAsStrings Variables.defsToLambda name createTest "Test 1." <| <@ let x = 1 + 1 in () @> <| <@ let x = 1 + 1 in () @> @@ -30,14 +23,13 @@ let private uniquesTests = @> <| <@ let x = - let xUnitFunc = - fun (unitVar: unit) -> - let mutable y = 0 + let xUnitFunc () = + let mutable y = 0 - for i in 1..10 do - y <- y + i + for i in 1..10 do + y <- y + i - y + y xUnitFunc () @@ -65,32 +57,46 @@ let private uniquesTests = @> <| <@ let x = - let xUnitFunc = - fun (unitVar: unit) -> - let mutable y = - let yUnitFunc = - fun (unitVar: unit) -> - if true then - let z = 10 - z + 1 - else - let z = 20 - z + 2 + let xUnitFunc () = + let mutable y = + let yUnitFunc () = + if true then + let z = 10 + z + 1 + else + let z = 20 + z + 2 - yUnitFunc () + yUnitFunc () - for i in 1..10 do - let z = - let zUnitFunc = fun (unitVar: unit) -> if false then 10 else 20 - zUnitFunc () + for i in 1..10 do + let z = + let zUnitFunc () = if false then 10 else 20 + zUnitFunc () - y <- y + i + z + y <- y + i + z - y + y xUnitFunc () x - @> ] + @> + + createTest "Test 4" + <| <@ let f = let x = 4 in x in () @> + <| <@ let f = let fUnitFunc () = let x = 4 in x in fUnitFunc () in () @> + + createTest "Test 5" + <| <@ let f = let g = let x = 4 in x in () in () @> + <| <@ let f = + let fUnitFunc () = + let g = + let gUnitFunc () = + let x = 4 in x + gUnitFunc () in + () in + fUnitFunc () in + () @> ] let tests = uniquesTests |> testList "Variables" |> testSequenced diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/WorkSize.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/WorkSize.fs index c60164d7..cabaad45 100644 --- a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/WorkSize.fs +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/WorkSize.fs @@ -17,15 +17,8 @@ module Helpers = let _localSize2 = Unchecked.defaultof let private workSizeTests = - [ let createTest name source expected = - test name { - let actual = WorkSize.get source - - let actualStr = actual.ToString() - let expectedStr = expected.ToString() - - Expect.equal actualStr expectedStr "Result should be the same." - } + [ let createTest name = + Common.Helpers.createMapTestAndCompareAsStrings WorkSize.get name createTest "Test 1D. Global" <| <@ From f046e161f175d90684d2bbad74636afed7407ee9 Mon Sep 17 00:00:00 2001 From: IgorErin Date: Sun, 23 Jul 2023 22:15:29 +0300 Subject: [PATCH 19/22] fix: Lifting.unitCleanUp --- .../QuotationTransformers/Lifting.fs | 13 ++++++++-- .../QuotationTransformers/Variables.fs | 2 +- tests/Brahma.FSharp.Tests/Program.fs | 5 +++- .../QuatationTransformation/Common.fs | 3 +-- .../QuatationTransformation/Lifting.fs | 10 ++++---- .../QuatationTransformation/Print.fs | 2 +- .../QuatationTransformation/VarToRef.fs | 2 +- .../QuatationTransformation/Variables.fs | 24 +++++++++++-------- .../QuatationTransformation/WorkSize.fs | 2 +- 9 files changed, 40 insertions(+), 23 deletions(-) diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Lifting.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Lifting.fs index 195464d5..84e5c8b1 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Lifting.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Lifting.fs @@ -70,7 +70,7 @@ module Lift = | [] -> failwith "Arguments cannot be empty" | [ _ ] -> args | _ -> - // if several units ??? + // TODO() if several units ??? args |> List.filter (fun arg -> arg.Type <> typeof) /// args: [x1: t1; x2: t2; x3: t3], boyd: t4 @@ -81,6 +81,15 @@ module Lift = |> Utils.makeFunctionType body.Type |> fun t -> Var(var.Name, t, var.IsMutable) + // application like <@ f () @> represented as Application(f, Value()); + // Value() in Applications patterns go to [] + // Then i think we should map [] -> [ Value((), typeof) ] in exps + let private mapExpressions = + List.map (function + | [] -> [ Expr.Value((), typeof) ] + | x -> x) + >> List.concat + let cleanUp (expr: Expr) = let rec parse (subst: Map) = function @@ -95,7 +104,7 @@ module Lift = subst.TryFind var |> Option.map (fun var' -> // TODO(what about exp with unit type???) - let exps' = unitExpFilter <| List.concat exps + let exps' = mapExpressions exps |> unitExpFilter Utils.makeApplicationExpr <| Expr.Var var' <| List.map (parse subst) exps') |> Option.defaultValue source diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Variables.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Variables.fs index a644274f..e997d3af 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Variables.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Variables.fs @@ -59,7 +59,7 @@ module Variables = else let letAndApplication = createDefinitionAndApplication - <|createFunVar prop.Name prop.PropertyType + <| createFunVar prop.Name prop.PropertyType <| defsToLambda value Expr.PropertySet(o, prop, letAndApplication, indices) diff --git a/tests/Brahma.FSharp.Tests/Program.fs b/tests/Brahma.FSharp.Tests/Program.fs index 5b06276d..d9076793 100644 --- a/tests/Brahma.FSharp.Tests/Program.fs +++ b/tests/Brahma.FSharp.Tests/Program.fs @@ -4,7 +4,10 @@ open Brahma.FSharp.Tests [] let allTests = - testList "All tests" [ Translator.QuatationTransformation.Variables.tests ] + testList + "All tests" + [ Translator.All.tests + ExecutionTests.tests |> testList "Execution" ] |> testSequenced [] diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Common.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Common.fs index c0735404..22386638 100644 --- a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Common.fs +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Common.fs @@ -51,6 +51,5 @@ module Helpers = varEqual (fst actual) (fst expected) exprEqual (snd actual) (snd expected) - let createMapTestAndCompareAsStrings map name source expected = + let createMapTestAndCompareAsStrings map name source expected = test name { exprEqual (map source) expected } - diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Lifting.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Lifting.fs index 01a09220..f859923d 100644 --- a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Lifting.fs +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Lifting.fs @@ -198,9 +198,12 @@ let unitCleanUpTests = createTest "Test 12" // id <| <@ let f (x: int) = x in f 4 @> - <| <@ let f (x: int) = x in f 4 @> ] - |> testList "Unit clean up" + <| <@ let f (x: int) = x in f 4 @> + createTest "Test 13" + <| <@ let f = let fUnitFunc () = let x = 3 in x in fUnitFunc () in () @> + <| <@ let f = let fUnitFunc () = let x = 3 in x in fUnitFunc () in () @> ] + |> testList "Unit clean up" let lambdaLiftingTests = let inline createTest name expr expectedKernel (expectedFunctions: (Var * #Expr) list) = @@ -209,8 +212,7 @@ let lambdaLiftingTests = typesEqual actualKernel expectedKernel - (actualFunctions, expectedFunctions) - ||> List.iter2 assertMethodEqual + (actualFunctions, expectedFunctions) ||> List.iter2 assertMethodEqual equalAsStrings actualKernel expectedKernel <| "Kernels should be the same" } diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Print.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Print.fs index 2d20eddb..d5e8684f 100644 --- a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Print.fs +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Print.fs @@ -5,7 +5,7 @@ open Brahma.FSharp.OpenCL.Translator.QuotationTransformers let private replaceTests = [ let inline createTest name = - Common.Helpers.createMapTestAndCompareAsStrings Print.replace name + Common.Helpers.createMapTestAndCompareAsStrings Print.replace name let tpArgs: System.Type list = [] let value = "" diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/VarToRef.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/VarToRef.fs index 0529a028..4efc0e05 100644 --- a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/VarToRef.fs +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/VarToRef.fs @@ -5,7 +5,7 @@ open Expecto let private uniquesTests = [ let inline createTest name = - Common.Helpers.createMapTestAndCompareAsStrings VarToRef.transform name + Common.Helpers.createMapTestAndCompareAsStrings VarToRef.transform name createTest "Test 1" // id (no mutable vars) <| <@ diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Variables.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Variables.fs index abff7fb2..c53ad7e1 100644 --- a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Variables.fs +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Variables.fs @@ -4,7 +4,7 @@ open Brahma.FSharp.OpenCL.Translator.QuotationTransformers open Expecto let private uniquesTests = - [ let createTest name = + [ let createTest name = Common.Helpers.createMapTestAndCompareAsStrings Variables.defsToLambda name createTest "Test 1." <| <@ let x = 1 + 1 in () @> <| <@ let x = 1 + 1 in () @> @@ -89,14 +89,18 @@ let private uniquesTests = createTest "Test 5" <| <@ let f = let g = let x = 4 in x in () in () @> - <| <@ let f = - let fUnitFunc () = - let g = - let gUnitFunc () = - let x = 4 in x - gUnitFunc () in - () in - fUnitFunc () in - () @> ] + <| <@ + let f = + let fUnitFunc () = + let g = + let gUnitFunc () = let x = 4 in x + gUnitFunc () + + () + + fUnitFunc () + + () + @> ] let tests = uniquesTests |> testList "Variables" |> testSequenced diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/WorkSize.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/WorkSize.fs index cabaad45..ad889f67 100644 --- a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/WorkSize.fs +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/WorkSize.fs @@ -17,7 +17,7 @@ module Helpers = let _localSize2 = Unchecked.defaultof let private workSizeTests = - [ let createTest name = + [ let createTest name = Common.Helpers.createMapTestAndCompareAsStrings WorkSize.get name createTest "Test 1D. Global" From 4710de203ee98896ab7f2aa7cae56184b8c6f2f5 Mon Sep 17 00:00:00 2001 From: IgorErin Date: Wed, 26 Jul 2023 13:33:40 +0300 Subject: [PATCH 20/22] fix: Lifitng.unitCleanUp --- .../QuotationTransformers/Lifting.fs | 41 +++++++++++++------ .../QuatationTransformation/Lifting.fs | 20 +++++---- 2 files changed, 41 insertions(+), 20 deletions(-) diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Lifting.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Lifting.fs index 84e5c8b1..8098e0ff 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Lifting.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Lifting.fs @@ -65,13 +65,29 @@ module Lift = run Context.empty module UnitArguments = - let inline private unitExpFilter (args: list< ^a > when ^a: (member Type: System.Type)) = - match args with - | [] -> failwith "Arguments cannot be empty" - | [ _ ] -> args + let inline private isUnitType< ^a when ^a: (member Type: System.Type)> (e: ^a) = e.Type = typeof + + let inline private filterUnit< ^a when ^a: (member Type: System.Type)> (pars: ^a list) = + match pars with + | [] -> failwith "Parameters cannot be empty" + | [ _ ] -> pars | _ -> - // TODO() if several units ??? - args |> List.filter (fun arg -> arg.Type <> typeof) + let isExistVarWithAnotherType = pars |> List.exists (not << isUnitType) + + if isExistVarWithAnotherType then + pars |> List.filter (not << isUnitType) + else + pars |> List.distinctBy (fun v -> v.Type) + + // Take out unit type expressions except Vars and Values. + let private takeOutArgs (args: Expr list) app = + args + |> List.filter (fun e -> e.Type = typeof) + |> List.filter (function + | Patterns.Var _ + | Patterns.Value _ -> false + | _ -> true) + |> (fun args -> List.foldBack (fun f s -> Expr.Sequential(f, s)) args app) /// args: [x1: t1; x2: t2; x3: t3], boyd: t4 /// newVar: t1 -> t2 -> t3 -> t4 @@ -81,10 +97,10 @@ module Lift = |> Utils.makeFunctionType body.Type |> fun t -> Var(var.Name, t, var.IsMutable) - // application like <@ f () @> represented as Application(f, Value()); + // Application like <@ f () @> represented as Application(f, Value()); // Value() in Applications patterns go to [] // Then i think we should map [] -> [ Value((), typeof) ] in exps - let private mapExpressions = + let private mapExpsToArgs = List.map (function | [] -> [ Expr.Value((), typeof) ] | x -> x) @@ -94,7 +110,7 @@ module Lift = let rec parse (subst: Map) = function | Patterns.LetFuncUncurry(var, args, body, inExpr) -> - let args' = unitExpFilter args + let args' = filterUnit args let var' = createFunctionVar body args' var let body' = parse subst body |> Utils.makeLambdaExpr args' let inExpr' = parse (subst.Add(var, var')) inExpr @@ -103,10 +119,11 @@ module Lift = | DerivedPatterns.Applications(Patterns.Var var, exps) as source -> subst.TryFind var |> Option.map (fun var' -> - // TODO(what about exp with unit type???) - let exps' = mapExpressions exps |> unitExpFilter + let args = mapExpsToArgs exps + let args' = filterUnit args |> List.map (parse subst) + let app' = Utils.makeApplicationExpr (Expr.Var var') args' - Utils.makeApplicationExpr <| Expr.Var var' <| List.map (parse subst) exps') + takeOutArgs args app') |> Option.defaultValue source | ExprShape.ShapeLambda(var, body) -> Expr.Lambda(var, parse subst body) | ExprShape.ShapeVar var as source -> diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Lifting.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Lifting.fs index f859923d..25c068dc 100644 --- a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Lifting.fs +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Lifting.fs @@ -118,9 +118,13 @@ let unitCleanUpTests = <| <@ let f (x: unit) (y: int) = x in () @> <| <@ let f (y: int) = (%unitVar "x") in () @> - createTest "Test 3" // TODO(is it correct?) + createTest "Test 3" <| <@ let f (x: unit) (y: unit) = x in () @> - <| <@ let f = (%unitVar "x") in () @> + <| <@ let f (x: unit) = x in () @> + + createTest "Test 3.5" + <| <@ let f (x: unit) (y: unit) = y in () @> + <| <@ let f (x: unit) = (%unitVar "y") in () @> createTest "Test 4" <| <@ let f (x: int) = x in () @> @@ -137,8 +141,8 @@ let unitCleanUpTests = createTest "Test 7" <| <@ let f (x: unit) (y: unit) (z: unit) = if x = y then z else y in () @> <| <@ - let f = - if (%unitVar "x") = (%unitVar "y") then + let f (x: unit) = + if x = (%unitVar "y") then (%unitVar "z") else (%unitVar "y") in () @@ -150,7 +154,7 @@ let unitCleanUpTests = createTest "Test 9" <| <@ let f (x: unit) (y: unit) = let g (z: unit) (c: unit) = x in g y x in () @> - <| <@ let f = let g = (%unitVar "x") in g in () @> + <| <@ let f (x: unit) = let g (z: unit) = x in g (%unitVar "y") in () @> createTest "Test 10" <| <@ @@ -162,7 +166,7 @@ let unitCleanUpTests = // side effect in f application g (f ()) () 0 - @> // TODO(unit expr in application) + @> <| <@ let f () = printfn "side effect" @@ -170,7 +174,7 @@ let unitCleanUpTests = let g (z: int) = z - // no side effect + f () // side effect g 0 @> @@ -192,7 +196,7 @@ let unitCleanUpTests = let g (y: int) = y in - // no side effect + f 0 // side effect g 0 @> From d49c0944369c05a319ae789467bb9ceb34c294e4 Mon Sep 17 00:00:00 2001 From: IgorErin Date: Wed, 26 Jul 2023 14:39:36 +0300 Subject: [PATCH 21/22] refactor: fantomas config; disable warn: 1591 (xml commetns) --- .editorconfig | 38 +- docsTool/templates/nav.fs | 6 +- .../Brahma.FSharp.OpenCL.AST.fsproj | 1 + .../DeclSpecifierPack.fs | 3 +- src/Brahma.FSharp.OpenCL.AST/Types.fs | 20 +- .../Brahma.FSharp.OpenCL.Core.fsproj | 1 + src/Brahma.FSharp.OpenCL.Core/ClBuffer.fs | 32 +- .../ClContextExtensions.fs | 32 +- src/Brahma.FSharp.OpenCL.Core/ClDevice.fs | 11 +- src/Brahma.FSharp.OpenCL.Core/ClProgram.fs | 6 +- src/Brahma.FSharp.OpenCL.Core/ClTask.fs | 6 +- .../CommandQueueProvider.fs | 12 +- .../DataStructures/ClArray.fs | 15 +- .../DataStructures/ClCell.fs | 9 +- src/Brahma.FSharp.OpenCL.Core/Messages.fs | 13 +- src/Brahma.FSharp.OpenCL.Core/NDRange.fs | 16 +- .../RuntimeContext.fs | 8 +- .../Brahma.FSharp.OpenCL.Printer.fsproj | 1 + .../Expressions.fs | 41 +- src/Brahma.FSharp.OpenCL.Printer/FunDecl.fs | 34 +- src/Brahma.FSharp.OpenCL.Printer/Pragmas.fs | 4 +- src/Brahma.FSharp.OpenCL.Printer/Printer.fs | 3 +- .../Statements.fs | 61 +- src/Brahma.FSharp.OpenCL.Printer/TypeDecl.fs | 18 +- src/Brahma.FSharp.OpenCL.Printer/Types.fs | 19 +- src/Brahma.FSharp.OpenCL.Translator/Body.fs | 145 +- .../Brahma.FSharp.OpenCL.Translator.fsproj | 1 + .../CustomMarshaller.fs | 108 +- .../Methods.fs | 17 +- .../QuotationTransformers/Atomic.fs | 49 +- .../QuotationTransformers/Lifting.fs | 34 +- .../QuotationTransformers/Names.fs | 3 +- .../Utilities/Patterns.fs | 3 +- .../QuotationTransformers/Utilities/Utils.fs | 9 +- .../QuotationTransformers/VarToRef.fs | 14 +- .../QuotationTransformers/WorkSize.fs | 3 +- .../TranslationContext.fs | 48 +- .../Translator.fs | 12 +- src/Brahma.FSharp.OpenCL.Translator/Type.fs | 95 +- .../Utils/Extensions.fs | 6 +- .../Utils/StateBuilder.fs | 6 +- .../Utils/Utils.fs | 3 +- src/YC.OpenCL.NET/YC.OpenCL.NET.csproj | 1 + .../ExecutionTests/AtomicTests.fs | 270 +- .../ExecutionTests/CompilationTests.fs | 229 +- .../ExecutionTests/CompositeTypesTests.fs | 695 ++-- .../ExecutionTests/ExecutionTests.fs | 29 +- .../ExecutionTests/RuntimeTests.fs | 3499 +++++++---------- .../ExecutionTests/WorkflowBuilderTests.fs | 357 +- tests/Brahma.FSharp.Tests/Program.fs | 5 +- tests/Brahma.FSharp.Tests/Translator/All.fs | 51 +- .../Translator/BinOp/Tests.fs | 68 +- .../Translator/Carrying/Tests.fs | 58 +- .../Translator/ConstantArray/Tests.fs | 22 +- .../Translator/ControlFlow/Tests.fs | 190 +- .../Translator/Injection/Tests.fs | 40 +- .../Translator/LambdaLifting/Tests.fs | 498 +-- .../Translator/LangExtensions/Atomic.fs | 87 +- .../LangExtensions/Barrier/Tests.fs | 16 +- .../LangExtensions/LocalID/Tests.fs | 30 +- .../LangExtensions/LocalMemory/Tests.fs | 40 +- .../LangExtensions/WorkSize/Tests.fs | 46 +- .../Translator/NamesResolving/Tests.fs | 92 +- .../Translator/Printf/Tests.fs | 52 +- .../QuatationTransformation/Common.fs | 3 +- .../QuatationTransformation/Lifting.fs | 512 +-- .../QuatationTransformation/Names.fs | 110 +- .../QuatationTransformation/Print.fs | 95 +- .../QuatationTransformation/Transformation.fs | 302 +- .../QuatationTransformation/VarToRef.fs | 445 +-- .../QuatationTransformation/Variables.fs | 149 +- .../QuatationTransformation/WorkSize.fs | 185 +- .../Translator/Specific/MergePath.fs | 5 +- .../Translator/Union/Tests.fs | 54 +- 74 files changed, 4362 insertions(+), 4839 deletions(-) diff --git a/.editorconfig b/.editorconfig index a95a037d..bca8fa9e 100644 --- a/.editorconfig +++ b/.editorconfig @@ -33,5 +33,41 @@ trim_trailing_whitespace = true indent_size = 2 # fantomas conf + [*.fs] -fsharp_array_or_list_multiline_formatter=number_of_items +fsharp_semicolon_at_end_of_line=false +fsharp_space_before_parameter=true +fsharp_space_before_lowercase_invocation=true +fsharp_space_before_uppercase_invocation=false +fsharp_space_before_class_constructor=false +fsharp_space_before_member=false +fsharp_space_before_colon=false +fsharp_space_after_comma=true +fsharp_space_before_semicolon=false +fsharp_space_after_semicolon=true +fsharp_indent_on_try_with=false +fsharp_space_around_delimiter=true +fsharp_max_if_then_else_short_width=80 +fsharp_max_infix_operator_expression=80 +fsharp_max_record_width=80 +fsharp_max_record_number_of_items=1 +fsharp_record_multiline_formatter=character_width +fsharp_max_array_or_list_width=80 +fsharp_max_array_or_list_number_of_items=1 +fsharp_array_or_list_multiline_formatter=character_width +fsharp_max_value_binding_width=80 +fsharp_max_function_binding_width=80 +fsharp_max_dot_get_expression_width=80 +fsharp_multiline_block_brackets_on_same_column=true +fsharp_newline_between_type_definition_and_members=false +fsharp_keep_if_then_in_same_line=true +fsharp_max_elmish_width=80 +fsharp_single_argument_web_mode=true +fsharp_align_function_signature_to_indentation=false +fsharp_alternative_long_member_definitions=false +fsharp_multi_line_lambda_closing_newline=true +fsharp_disable_elmish_syntax=false +fsharp_keep_indent_in_branch=false +fsharp_blank_lines_around_nested_multiline_expressions=false +fsharp_bar_before_discriminated_union_declaration=false +fsharp_strict_mode=false \ No newline at end of file diff --git a/docsTool/templates/nav.fs b/docsTool/templates/nav.fs index 33d3ba6d..100686b4 100644 --- a/docsTool/templates/nav.fs +++ b/docsTool/templates/nav.fs @@ -48,7 +48,7 @@ let navItemIconOnly link ariaLabel inner = ] let dropDownNavMenu text items = - li [ Class "nav-item dropdown" ][ + li [ Class "nav-item dropdown" ] [ a [ Id (sprintf "navbarDropdown-%s" text) Href "#" @@ -57,8 +57,8 @@ let dropDownNavMenu text items = AriaExpanded false Class "nav-link dropdown-toggle" ] [ normalizeStr text ] - ul [ HTMLAttr.Custom ("aria-labelledby", "dropdownMenu1") - Class "dropdown-menu border-0 shadow" ] items ] + ul [ HTMLAttr.Custom ("aria-labelledby", "dropdownMenu1") + Class "dropdown-menu border-0 shadow" ] items ] let dropDownNavItem text link = li [ diff --git a/src/Brahma.FSharp.OpenCL.AST/Brahma.FSharp.OpenCL.AST.fsproj b/src/Brahma.FSharp.OpenCL.AST/Brahma.FSharp.OpenCL.AST.fsproj index 922ae8ac..2f1f1b16 100644 --- a/src/Brahma.FSharp.OpenCL.AST/Brahma.FSharp.OpenCL.AST.fsproj +++ b/src/Brahma.FSharp.OpenCL.AST/Brahma.FSharp.OpenCL.AST.fsproj @@ -8,6 +8,7 @@ Brahma.FSharp.OpenCL.AST OpenCL C AST. + 1591 true diff --git a/src/Brahma.FSharp.OpenCL.AST/DeclSpecifierPack.fs b/src/Brahma.FSharp.OpenCL.AST/DeclSpecifierPack.fs index 1d42f86c..3d686817 100644 --- a/src/Brahma.FSharp.OpenCL.AST/DeclSpecifierPack.fs +++ b/src/Brahma.FSharp.OpenCL.AST/DeclSpecifierPack.fs @@ -36,8 +36,7 @@ type DeclSpecifierPack<'lang> member val Type = typeSpecifier with get, set member val TypeQualifiers = defaultArg typeQualifiers [] with get, set - member this.AddTypeQual tq = - this.TypeQualifiers <- tq :: this.TypeQualifiers + member this.AddTypeQual tq = this.TypeQualifiers <- tq :: this.TypeQualifiers member this.Matches(other: obj) = match other with diff --git a/src/Brahma.FSharp.OpenCL.AST/Types.fs b/src/Brahma.FSharp.OpenCL.AST/Types.fs index 596cccdf..715b795a 100644 --- a/src/Brahma.FSharp.OpenCL.AST/Types.fs +++ b/src/Brahma.FSharp.OpenCL.AST/Types.fs @@ -114,20 +114,21 @@ type DiscriminatedUnionType<'lang>(name: string, fields: List inherit StructType<'lang>( name, - [ { Name = "tag" - Type = PrimitiveType(Int) } - { Name = "data" - Type = UnionClInplaceType(name + "_Data", List.map snd fields) } ] + [ + { Name = "tag"; Type = PrimitiveType(Int) } + { + Name = "data" + Type = UnionClInplaceType(name + "_Data", List.map snd fields) + } + ] ) member this.Tag = this.Fields.[0] member this.Data = this.Fields.[1] - member this.GetCaseByTag(tag: int) = - List.tryFind (fun (id, _) -> id = tag) fields |> Option.map snd + member this.GetCaseByTag(tag: int) = List.tryFind (fun (id, _) -> id = tag) fields |> Option.map snd - member this.GetCaseByName(case: string) = - List.tryFind (fun (_, f) -> f.Name = case) fields |> Option.map snd + member this.GetCaseByName(case: string) = List.tryFind (fun (_, f) -> f.Name = case) fields |> Option.map snd type TupleType<'lang>(baseStruct: StructType<'lang>) = inherit Type<'lang>() @@ -135,8 +136,7 @@ type TupleType<'lang>(baseStruct: StructType<'lang>) = member this.BaseStruct = baseStruct override this.Size = baseStruct.Size - override this.Matches _ = - failwith "Not implemented: matches for tuples" + override this.Matches _ = failwith "Not implemented: matches for tuples" type RefType<'lang>(baseType: Type<'lang>, typeQuals: TypeQualifier<'lang> list) = inherit Type<'lang>() diff --git a/src/Brahma.FSharp.OpenCL.Core/Brahma.FSharp.OpenCL.Core.fsproj b/src/Brahma.FSharp.OpenCL.Core/Brahma.FSharp.OpenCL.Core.fsproj index c8833a2d..5217c390 100644 --- a/src/Brahma.FSharp.OpenCL.Core/Brahma.FSharp.OpenCL.Core.fsproj +++ b/src/Brahma.FSharp.OpenCL.Core/Brahma.FSharp.OpenCL.Core.fsproj @@ -10,6 +10,7 @@ Brahma.FSharp.OpenCL.Core Core components of Brahma.FSharp. --warnon:3390 + 1591 true diff --git a/src/Brahma.FSharp.OpenCL.Core/ClBuffer.fs b/src/Brahma.FSharp.OpenCL.Core/ClBuffer.fs index 0b0debf4..cabdda50 100644 --- a/src/Brahma.FSharp.OpenCL.Core/ClBuffer.fs +++ b/src/Brahma.FSharp.OpenCL.Core/ClBuffer.fs @@ -32,21 +32,27 @@ type AllocationMode = /// Represents flags to specify allocation and usage information of OpenCL buffer. type ClMemFlags = - { HostAccessMode: HostAccessMode - DeviceAccessMode: DeviceAccessMode - AllocationMode: AllocationMode } + { + HostAccessMode: HostAccessMode + DeviceAccessMode: DeviceAccessMode + AllocationMode: AllocationMode + } /// Represents default flags in case of allocation with copying data. static member DefaultIfData = - { HostAccessMode = HostAccessMode.ReadWrite - DeviceAccessMode = DeviceAccessMode.ReadWrite - AllocationMode = AllocationMode.AllocAndCopyHostPtr } + { + HostAccessMode = HostAccessMode.ReadWrite + DeviceAccessMode = DeviceAccessMode.ReadWrite + AllocationMode = AllocationMode.AllocAndCopyHostPtr + } /// Represents default flags in case of allocation without copying data. static member DefaultIfNoData = - { HostAccessMode = HostAccessMode.ReadWrite - DeviceAccessMode = DeviceAccessMode.ReadWrite - AllocationMode = AllocationMode.AllocHostPtr } + { + HostAccessMode = HostAccessMode.ReadWrite + DeviceAccessMode = DeviceAccessMode.ReadWrite + AllocationMode = AllocationMode.AllocHostPtr + } type BufferInitParam<'a> = | Data of 'a[] @@ -80,9 +86,11 @@ type ClBuffer<'a>(clContext: ClContext, initParam: BufferInitParam<'a>, ?memFlag | DeviceAccessMode.WriteOnly -> flags <- flags ||| MemFlags.WriteOnly let ifDataFlags = - [ AllocationMode.UseHostPtr - AllocationMode.CopyHostPtr - AllocationMode.AllocAndCopyHostPtr ] + [ + AllocationMode.UseHostPtr + AllocationMode.CopyHostPtr + AllocationMode.AllocAndCopyHostPtr + ] match initParam with | Size _ when ifDataFlags |> List.contains memFlags.AllocationMode -> diff --git a/src/Brahma.FSharp.OpenCL.Core/ClContextExtensions.fs b/src/Brahma.FSharp.OpenCL.Core/ClContextExtensions.fs index 4a8bb3d1..520eeb7d 100644 --- a/src/Brahma.FSharp.OpenCL.Core/ClContextExtensions.fs +++ b/src/Brahma.FSharp.OpenCL.Core/ClContextExtensions.fs @@ -19,9 +19,11 @@ module ClContextExtensions = ) = let flags = - { HostAccessMode = defaultArg hostAccessMode ClMemFlags.DefaultIfData.HostAccessMode - DeviceAccessMode = defaultArg deviceAccessMode ClMemFlags.DefaultIfData.DeviceAccessMode - AllocationMode = defaultArg allocationMode ClMemFlags.DefaultIfData.AllocationMode } + { + HostAccessMode = defaultArg hostAccessMode ClMemFlags.DefaultIfData.HostAccessMode + DeviceAccessMode = defaultArg deviceAccessMode ClMemFlags.DefaultIfData.DeviceAccessMode + AllocationMode = defaultArg allocationMode ClMemFlags.DefaultIfData.AllocationMode + } let buffer = new ClBuffer<'a>(this, Data data, flags) new ClArray<_>(buffer) @@ -36,9 +38,11 @@ module ClContextExtensions = ) = let flags = - { HostAccessMode = defaultArg hostAccessMode ClMemFlags.DefaultIfNoData.HostAccessMode - DeviceAccessMode = defaultArg deviceAccessMode ClMemFlags.DefaultIfNoData.DeviceAccessMode - AllocationMode = defaultArg allocationMode ClMemFlags.DefaultIfNoData.AllocationMode } + { + HostAccessMode = defaultArg hostAccessMode ClMemFlags.DefaultIfNoData.HostAccessMode + DeviceAccessMode = defaultArg deviceAccessMode ClMemFlags.DefaultIfNoData.DeviceAccessMode + AllocationMode = defaultArg allocationMode ClMemFlags.DefaultIfNoData.AllocationMode + } let buffer = new ClBuffer<'a>(this, Size size, flags) new ClArray<_>(buffer) @@ -53,9 +57,11 @@ module ClContextExtensions = ) = let flags = - { HostAccessMode = defaultArg hostAccessMode ClMemFlags.DefaultIfData.HostAccessMode - DeviceAccessMode = defaultArg deviceAccessMode ClMemFlags.DefaultIfData.DeviceAccessMode - AllocationMode = defaultArg allocationMode ClMemFlags.DefaultIfData.AllocationMode } + { + HostAccessMode = defaultArg hostAccessMode ClMemFlags.DefaultIfData.HostAccessMode + DeviceAccessMode = defaultArg deviceAccessMode ClMemFlags.DefaultIfData.DeviceAccessMode + AllocationMode = defaultArg allocationMode ClMemFlags.DefaultIfData.AllocationMode + } let buffer = new ClBuffer<'a>(this, Data [| data |], flags) new ClCell<_>(buffer) @@ -69,9 +75,11 @@ module ClContextExtensions = ) = let flags = - { HostAccessMode = defaultArg hostAccessMode ClMemFlags.DefaultIfNoData.HostAccessMode - DeviceAccessMode = defaultArg deviceAccessMode ClMemFlags.DefaultIfNoData.DeviceAccessMode - AllocationMode = defaultArg allocationMode ClMemFlags.DefaultIfNoData.AllocationMode } + { + HostAccessMode = defaultArg hostAccessMode ClMemFlags.DefaultIfNoData.HostAccessMode + DeviceAccessMode = defaultArg deviceAccessMode ClMemFlags.DefaultIfNoData.DeviceAccessMode + AllocationMode = defaultArg allocationMode ClMemFlags.DefaultIfNoData.AllocationMode + } let buffer = new ClBuffer<'a>(this, Size 1, flags) new ClCell<_>(buffer) diff --git a/src/Brahma.FSharp.OpenCL.Core/ClDevice.fs b/src/Brahma.FSharp.OpenCL.Core/ClDevice.fs index d4e6b140..d4f47d8a 100644 --- a/src/Brahma.FSharp.OpenCL.Core/ClDevice.fs +++ b/src/Brahma.FSharp.OpenCL.Core/ClDevice.fs @@ -39,13 +39,9 @@ type ClDevice(device: OpenCL.Net.Device) = let error = ref Unchecked.defaultof let result = f error - if error.Value <> ClErrorCode.Success then - onError - else - result + if error.Value <> ClErrorCode.Success then onError else result - let (|Contains|_|) (substring: string) (str: string) = - if str.Contains substring then Some Contains else None + let (|Contains|_|) (substring: string) (str: string) = if str.Contains substring then Some Contains else None /// Gets internal representation of device specific to OpenCL.Net. member this.Device = device @@ -234,7 +230,8 @@ type ClDevice(device: OpenCL.Net.Device) = Some <| Cl.GetDeviceIDs(platform, DeviceHelpers.convertToDeviceType deviceType, error) else - None) + None + ) |> Seq.concat |> Seq.map ClDevice diff --git a/src/Brahma.FSharp.OpenCL.Core/ClProgram.fs b/src/Brahma.FSharp.OpenCL.Core/ClProgram.fs index a6c44cf9..a8fa02b0 100644 --- a/src/Brahma.FSharp.OpenCL.Core/ClProgram.fs +++ b/src/Brahma.FSharp.OpenCL.Core/ClProgram.fs @@ -96,7 +96,8 @@ type ClProgram<'TRange, 'a when 'TRange :> INDRange>(ctx: ClContext, srcLambda: | _ -> failwithf $"Something went wrong with type of atomic global var. \ - Expected var of type '%s{ClArray_}' or '%s{ClCell_}', but given %s{var.Type.Name}") + Expected var of type '%s{ClArray_}' or '%s{ClCell_}', but given %s{var.Type.Name}" + ) ) let regularArgs = @@ -128,7 +129,8 @@ type ClProgram<'TRange, 'a when 'TRange :> INDRange>(ctx: ClContext, srcLambda: (%%(Expr.Var mutexBuffersVar): ResizeArray>).Add mutexBuffer - box mutexBuffer) + box mutexBuffer + ) @@>, Expr.Let( xVar, diff --git a/src/Brahma.FSharp.OpenCL.Core/ClTask.fs b/src/Brahma.FSharp.OpenCL.Core/ClTask.fs index cb10c4b1..e6f79777 100644 --- a/src/Brahma.FSharp.OpenCL.Core/ClTask.fs +++ b/src/Brahma.FSharp.OpenCL.Core/ClTask.fs @@ -25,8 +25,7 @@ type ClTaskBuilder() = member inline this.Combine(m1, m2) = this.Bind(m1, (fun () -> m2)) - member inline this.Delay(rest) = - this.Bind(this.Zero(), (fun () -> rest ())) + member inline this.Delay(rest) = this.Bind(this.Zero(), (fun () -> rest ())) member inline this.Run(m) = m @@ -121,7 +120,8 @@ module ClTask = ctx.CommandQueue.Post <| syncMsgs.[i] return result } - |> fun task -> async { return runComputation task <| ctx.WithNewCommandQueue() }) + |> fun task -> async { return runComputation task <| ctx.WithNewCommandQueue() } + ) |> Async.Parallel |> Async.RunSynchronously } diff --git a/src/Brahma.FSharp.OpenCL.Core/CommandQueueProvider.fs b/src/Brahma.FSharp.OpenCL.Core/CommandQueueProvider.fs index 1ce4a8e4..180994dc 100644 --- a/src/Brahma.FSharp.OpenCL.Core/CommandQueueProvider.fs +++ b/src/Brahma.FSharp.OpenCL.Core/CommandQueueProvider.fs @@ -15,7 +15,8 @@ type CommandQueueProvider private (device, context, translator: FSQuotationToOpe let handleFree (free: IFreeCrate) = { new IFreeCrateEvaluator with - member this.Eval crate = crate.Source.Dispose() } + member this.Eval crate = crate.Source.Dispose() + } |> free.Apply let handleToGPU queue (toGpu: IToGPUCrate) = @@ -40,7 +41,8 @@ type CommandQueueProvider private (device, context, translator: FSQuotationToOpe ) if error <> ErrorCode.Success then - raise (Cl.Exception error) } + raise (Cl.Exception error) + } |> toGpu.Apply let handleToHost queue (toHost: IToHostCrate) = @@ -91,7 +93,8 @@ type CommandQueueProvider private (device, context, translator: FSQuotationToOpe match crate.ReplyChannel with | Some ch -> ch.Reply crate.Destination - | None -> () } + | None -> () + } |> toHost.Apply let handleRun queue (run: IRunCrate) = @@ -115,7 +118,8 @@ type CommandQueueProvider private (device, context, translator: FSQuotationToOpe ) if error <> ErrorCode.Success then - raise (Cl.Exception error) } + raise (Cl.Exception error) + } |> run.Apply /// diff --git a/src/Brahma.FSharp.OpenCL.Core/DataStructures/ClArray.fs b/src/Brahma.FSharp.OpenCL.Core/DataStructures/ClArray.fs index c20de10e..ee877228 100644 --- a/src/Brahma.FSharp.OpenCL.Core/DataStructures/ClArray.fs +++ b/src/Brahma.FSharp.OpenCL.Core/DataStructures/ClArray.fs @@ -33,8 +33,7 @@ type ClArray<'a> internal (buffer: ClBuffer<'a>) = member this.Dispose() = (this :> IDisposable).Dispose() - override this.ToString() = - $"{(buffer :> IClMem).Data}, %A{(buffer :> IClMem).Size}" + override this.ToString() = $"{(buffer :> IClMem).Data}, %A{(buffer :> IClMem).Size}" // fsharplint:disable-next-line type clarray<'a> = ClArray<'a> @@ -52,8 +51,7 @@ module ClArray = // or allocate with null ptr and write // TODO if array.Length = 0 ... /// Transfers specified array to device with default memory flags. - let toDevice (array: 'a[]) = - toDeviceWithFlags array ClMemFlags.DefaultIfData + let toDevice (array: 'a[]) = toDeviceWithFlags array ClMemFlags.DefaultIfData /// Allocate empty array on device with specified memory flags. let allocWithFlags<'a> (size: int) (memFlags: ClMemFlags) = @@ -65,8 +63,7 @@ module ClArray = } /// Allocate empty array on device with default memory flags. - let alloc<'a> (size: int) = - allocWithFlags<'a> size ClMemFlags.DefaultIfNoData + let alloc<'a> (size: int) = allocWithFlags<'a> size ClMemFlags.DefaultIfNoData /// Transfers specified array from device to host. let toHost (clArray: ClArray<'a>) = @@ -79,12 +76,10 @@ module ClArray = } // TODO impl it using clEnqueCopy - let copy (clArray: ClArray<'a>) = - opencl { failwith "Not implemented yet" } + let copy (clArray: ClArray<'a>) = opencl { failwith "Not implemented yet" } // TODO impl it - let copyTo (destination: ClArray<'a>) (source: ClArray<'a>) = - opencl { failwith "Not implemented yet" } + let copyTo (destination: ClArray<'a>) (source: ClArray<'a>) = opencl { failwith "Not implemented yet" } let close (clArray: ClArray<'a>) = opencl { diff --git a/src/Brahma.FSharp.OpenCL.Core/DataStructures/ClCell.fs b/src/Brahma.FSharp.OpenCL.Core/DataStructures/ClCell.fs index 3995f505..4e90430a 100644 --- a/src/Brahma.FSharp.OpenCL.Core/DataStructures/ClCell.fs +++ b/src/Brahma.FSharp.OpenCL.Core/DataStructures/ClCell.fs @@ -45,8 +45,7 @@ module ClCell = } /// Transfers specified value to device with default memory flags. - let toDevice (value: 'a) = - toDeviceWithFlags value ClMemFlags.DefaultIfData + let toDevice (value: 'a) = toDeviceWithFlags value ClMemFlags.DefaultIfData /// Allocate default value on device with specified memory flags. let allocWithFlags<'a> (memFlags: ClMemFlags) = @@ -58,8 +57,7 @@ module ClCell = } /// Allocate empty array on device with default memory flags. - let alloc<'a> () = - allocWithFlags<'a> ClMemFlags.DefaultIfNoData + let alloc<'a> () = allocWithFlags<'a> ClMemFlags.DefaultIfNoData /// Transfers specified value from device to host. let toHost (clCell: ClCell<'a>) = @@ -72,5 +70,4 @@ module ClCell = } // TODO impl it - let copy (clCell: ClCell<'a>) = - opencl { failwith "Not implemented yet" } + let copy (clCell: ClCell<'a>) = opencl { failwith "Not implemented yet" } diff --git a/src/Brahma.FSharp.OpenCL.Core/Messages.fs b/src/Brahma.FSharp.OpenCL.Core/Messages.fs index f9a702c4..688cb5c1 100644 --- a/src/Brahma.FSharp.OpenCL.Core/Messages.fs +++ b/src/Brahma.FSharp.OpenCL.Core/Messages.fs @@ -68,23 +68,26 @@ type Msg = static member CreateToHostMsg<'a>(src, dst, ?ch) = { new IToHostCrate with - member this.Apply evaluator = - evaluator.Eval <| ToHost<'a>(src, dst, ?replyChannel = ch) } + member this.Apply evaluator = evaluator.Eval <| ToHost<'a>(src, dst, ?replyChannel = ch) + } |> MsgToHost static member CreateToGPUMsg<'a>(src, dst) = { new IToGPUCrate with - member this.Apply evaluator = evaluator.Eval <| ToGPU<'a>(src, dst) } + member this.Apply evaluator = evaluator.Eval <| ToGPU<'a>(src, dst) + } |> MsgToGPU static member CreateFreeMsg<'a>(src) = { new IFreeCrate with - member this.Apply evaluator = evaluator.Eval <| Free(src) } + member this.Apply evaluator = evaluator.Eval <| Free(src) + } |> MsgFree static member CreateRunMsg<'TRange, 'a when 'TRange :> INDRange>(kernel) = { new IRunCrate with - member this.Apply evaluator = evaluator.Eval <| Run(kernel) } + member this.Apply evaluator = evaluator.Eval <| Run(kernel) + } |> MsgRun static member CreateBarrierMessages(numOfQueuesOnBarrier: int) = diff --git a/src/Brahma.FSharp.OpenCL.Core/NDRange.fs b/src/Brahma.FSharp.OpenCL.Core/NDRange.fs index 076ac2d0..ff094df0 100644 --- a/src/Brahma.FSharp.OpenCL.Core/NDRange.fs +++ b/src/Brahma.FSharp.OpenCL.Core/NDRange.fs @@ -87,13 +87,9 @@ type Range2D private (globalWorkSizeX: int, globalWorkSizeY: int, localWorkSizeX member this.LocalWorkSize = (localWorkSizeX, localWorkSizeY) interface INDRange with - member this.GlobalWorkSize = - [| IntPtr globalWorkSizeX - IntPtr globalWorkSizeY |] + member this.GlobalWorkSize = [| IntPtr globalWorkSizeX; IntPtr globalWorkSizeY |] - member this.LocalWorkSize = - [| IntPtr localWorkSizeX - IntPtr localWorkSizeY |] + member this.LocalWorkSize = [| IntPtr localWorkSizeX; IntPtr localWorkSizeY |] member this.Dimensions = 2 @@ -158,13 +154,9 @@ type Range3D interface INDRange with member this.GlobalWorkSize = - [| IntPtr globalWorkSizeX - IntPtr globalWorkSizeY - IntPtr globalWorkSizeZ |] + [| IntPtr globalWorkSizeX; IntPtr globalWorkSizeY; IntPtr globalWorkSizeZ |] member this.LocalWorkSize = - [| IntPtr localWorkSizeX - IntPtr localWorkSizeY - IntPtr globalWorkSizeZ |] + [| IntPtr localWorkSizeX; IntPtr localWorkSizeY; IntPtr globalWorkSizeZ |] member this.Dimensions = 3 diff --git a/src/Brahma.FSharp.OpenCL.Core/RuntimeContext.fs b/src/Brahma.FSharp.OpenCL.Core/RuntimeContext.fs index ab12b1d7..a4206f1c 100644 --- a/src/Brahma.FSharp.OpenCL.Core/RuntimeContext.fs +++ b/src/Brahma.FSharp.OpenCL.Core/RuntimeContext.fs @@ -2,8 +2,9 @@ namespace Brahma.FSharp type RuntimeOptions = { - // TODO if 2D or 3D - WorkgroupSize: int } + // TODO if 2D or 3D + WorkgroupSize: int + } static member Default = { WorkgroupSize = 256 } @@ -25,8 +26,7 @@ type RuntimeContext(clContext: ClContext) = member this.ClContext = clContext - member internal this.WithNewCommandQueue() = - RuntimeContext(clContext, RuntimeOptions = this.RuntimeOptions) + member internal this.WithNewCommandQueue() = RuntimeContext(clContext, RuntimeOptions = this.RuntimeOptions) member internal this.WithRuntimeOptions(runtimeOptions) = RuntimeContext(clContext, RuntimeOptions = runtimeOptions, CommandQueue = this.CommandQueue) diff --git a/src/Brahma.FSharp.OpenCL.Printer/Brahma.FSharp.OpenCL.Printer.fsproj b/src/Brahma.FSharp.OpenCL.Printer/Brahma.FSharp.OpenCL.Printer.fsproj index 779dcc28..34db5bbf 100644 --- a/src/Brahma.FSharp.OpenCL.Printer/Brahma.FSharp.OpenCL.Printer.fsproj +++ b/src/Brahma.FSharp.OpenCL.Printer/Brahma.FSharp.OpenCL.Printer.fsproj @@ -9,6 +9,7 @@ Brahma.FSharp.OpenCL.Printer OpenCL C printer: from AST to text. + 1591 true diff --git a/src/Brahma.FSharp.OpenCL.Printer/Expressions.fs b/src/Brahma.FSharp.OpenCL.Printer/Expressions.fs index f79cb77c..3ee291bd 100644 --- a/src/Brahma.FSharp.OpenCL.Printer/Expressions.fs +++ b/src/Brahma.FSharp.OpenCL.Printer/Expressions.fs @@ -45,11 +45,9 @@ module Expressions = let private printVar (varible: Variable<'lang>) = wordL varible.Name - let rec private printItem (itm: Item<'lang>) = - (print itm.Arr) ++ squareBracketL (print itm.Idx) + let rec private printItem (itm: Item<'lang>) = (print itm.Arr) ++ squareBracketL (print itm.Idx) - and private printIndirectionOp (deref: IndirectionOp<'lang>) = - wordL "*" ++ (print deref.Expr |> bracketL) + and private printIndirectionOp (deref: IndirectionOp<'lang>) = wordL "*" ++ (print deref.Expr |> bracketL) and private printBop (op: BOp<'lang>) = match op with @@ -79,11 +77,7 @@ module Expressions = let r = print binop.Right let op = printBop binop.Op - [ l - op - r ] - |> spaceListL - |> bracketL + [ l; op; r ] |> spaceListL |> bracketL and private printProperty (prop: Property<'lang>) = match prop.Property with @@ -145,38 +139,29 @@ module Expressions = let args = List.map print newStruct.ConstructorArgs |> commaListL match newStruct.Struct with - | :? StructInplaceType<_> -> - [ wordL "{" - args - wordL "}" ] - |> spaceListL + | :? StructInplaceType<_> -> [ wordL "{"; args; wordL "}" ] |> spaceListL | _ -> let t = Types.print newStruct.Struct - [ t |> bracketL - wordL "{" - args - wordL "}" ] - |> spaceListL + [ t |> bracketL; wordL "{"; args; wordL "}" ] |> spaceListL and printNewUnion (newUnion: NewUnion<_>) = let arg = print newUnion.ConstructorArg - [ wordL "{" - wordL <| "." + newUnion.ConstructorArgName - wordL "=" - arg - wordL "}" ] + [ + wordL "{" + wordL <| "." + newUnion.ConstructorArgName + wordL "=" + arg + wordL "}" + ] |> spaceListL and printFfieldGet (fg: FieldGet<_>) = let host = print fg.Host let fld = wordL fg.Field - [ host |> bracketL - wordL "." - fld ] - |> spaceListL + [ host |> bracketL; wordL "."; fld ] |> spaceListL and print (expr: Expression<'lang>) = match expr with diff --git a/src/Brahma.FSharp.OpenCL.Printer/FunDecl.fs b/src/Brahma.FSharp.OpenCL.Printer/FunDecl.fs index 95c70a9d..df35935b 100644 --- a/src/Brahma.FSharp.OpenCL.Printer/FunDecl.fs +++ b/src/Brahma.FSharp.OpenCL.Printer/FunDecl.fs @@ -21,16 +21,18 @@ open Brahma.FSharp.OpenCL.Printer module FunDecl = let private printFunFormalParam (param: FunFormalArg<_>) = - [ match param.DeclSpecs.AddressSpaceQualifier with - | Global -> yield wordL "__global" - | Local -> yield wordL "__local" - | _ -> yield wordL "private" + [ + match param.DeclSpecs.AddressSpaceQualifier with + | Global -> yield wordL "__global" + | Local -> yield wordL "__local" + | _ -> yield wordL "private" - match param.DeclSpecs.Type with - | Some t -> yield Types.print t - | None -> failwith "Could not print a formal arg with undefined type" + match param.DeclSpecs.Type with + | Some t -> yield Types.print t + | None -> failwith "Could not print a formal arg with undefined type" - yield wordL param.Name ] + yield wordL param.Name + ] |> spaceListL let print<'lang> (funDecl: FunDecl<'lang>) = @@ -43,13 +45,15 @@ module FunDecl = | None -> false let header = - [ match funDecl.DeclSpecs.FunQual with - | Some Kernel -> yield wordL "__kernel" - | None -> () - match funDecl.DeclSpecs.Type with - | Some t -> yield Types.print t - | None -> failwith "Could not print a func declaration with undefined return type" - yield wordL funDecl.Name ] + [ + match funDecl.DeclSpecs.FunQual with + | Some Kernel -> yield wordL "__kernel" + | None -> () + match funDecl.DeclSpecs.Type with + | Some t -> yield Types.print t + | None -> failwith "Could not print a func declaration with undefined return type" + yield wordL funDecl.Name + ] |> spaceListL let formalParams = diff --git a/src/Brahma.FSharp.OpenCL.Printer/Pragmas.fs b/src/Brahma.FSharp.OpenCL.Printer/Pragmas.fs index 64e6390a..91c8b8fb 100644 --- a/src/Brahma.FSharp.OpenCL.Printer/Pragmas.fs +++ b/src/Brahma.FSharp.OpenCL.Printer/Pragmas.fs @@ -22,7 +22,9 @@ module Pragmas = let print (clp: CLPragma<_>) = match clp.Type with | CLGlobalInt32BaseAtomics -> - [ "#pragma OPENCL EXTENSION cl_khr_global_int32_base_atomics : enable" |> wordL ] + [ + "#pragma OPENCL EXTENSION cl_khr_global_int32_base_atomics : enable" |> wordL + ] |> aboveListL | CLLocalInt32BaseAtomics -> [ "#pragma OPENCL EXTENSION cl_khr_local_int32_base_atomics : enable" |> wordL ] diff --git a/src/Brahma.FSharp.OpenCL.Printer/Printer.fs b/src/Brahma.FSharp.OpenCL.Printer/Printer.fs index c7ad8d42..ff4531b8 100644 --- a/src/Brahma.FSharp.OpenCL.Printer/Printer.fs +++ b/src/Brahma.FSharp.OpenCL.Printer/Printer.fs @@ -28,7 +28,8 @@ module AST = | :? CLPragma<'lang> as clp -> Pragmas.print clp | :? StructDecl<'lang> as s -> TypeDecl.printStructDeclaration s | :? VarDecl<'lang> as s -> Statements.print false s - | _ -> failwithf "Printer. Unsupported toplevel declaration: %A" d) + | _ -> failwithf "Printer. Unsupported toplevel declaration: %A" d + ) // |> LayoutOps.sepListL (LayoutOps.wordL "\r\n") // |> Display.layout_to_string FormatOptions.Default |> LayoutOps.aboveListL diff --git a/src/Brahma.FSharp.OpenCL.Printer/Statements.fs b/src/Brahma.FSharp.OpenCL.Printer/Statements.fs index 2bdcd022..b46e0cd7 100644 --- a/src/Brahma.FSharp.OpenCL.Printer/Statements.fs +++ b/src/Brahma.FSharp.OpenCL.Printer/Statements.fs @@ -23,10 +23,7 @@ open Microsoft.FSharp.Collections module Statements = let rec private printAssignment (a: Assignment<'lang>) = - [ Expressions.print a.Name - wordL "=" - Expressions.print a.Value ] - |> spaceListL + [ Expressions.print a.Name; wordL "="; Expressions.print a.Value ] |> spaceListL and private printSpaceModeifier (sm: AddressSpaceQualifier<_>) = match sm with @@ -37,17 +34,16 @@ module Statements = | Default -> wordL "__default" and private printVarDecl (vd: VarDecl<'lang>) = - [ if vd.SpaceModifier.IsSome then - yield printSpaceModeifier vd.SpaceModifier.Value - yield Types.print vd.Type - yield wordL vd.Name - if vd.Type :? ArrayType<_> then - yield wordL "[" ^^ wordL (string vd.Type.Size) ^^ wordL "]" - if vd.Expr.IsSome && not <| vd.IsLocal() then - yield - [ wordL "=" - Expressions.print vd.Expr.Value ] - |> spaceListL ] + [ + if vd.SpaceModifier.IsSome then + yield printSpaceModeifier vd.SpaceModifier.Value + yield Types.print vd.Type + yield wordL vd.Name + if vd.Type :? ArrayType<_> then + yield wordL "[" ^^ wordL (string vd.Type.Size) ^^ wordL "]" + if vd.Expr.IsSome && not <| vd.IsLocal() then + yield [ wordL "="; Expressions.print vd.Expr.Value ] |> spaceListL + ] |> spaceListL and private printVar (v: Variable<'lang>) = wordL v.Name @@ -68,10 +64,12 @@ module Statements = | Some x -> print true x | None -> wordL "" - [ yield wordL "if" ++ cond - yield then' - if if'.Else.IsSome then - yield aboveL (wordL "else") else' ] + [ + yield wordL "if" ++ cond + yield then' + if if'.Else.IsSome then + yield aboveL (wordL "else") else' + ] |> aboveListL and private printForInteger (for': ForIntegerLoop<_>) = @@ -80,24 +78,15 @@ module Statements = let cModif = print true for'.CountModifier let body = print true for'.Body - let header = - [ i - cond - cModif ] - |> sepListL (wordL ";") - |> bracketL + let header = [ i; cond; cModif ] |> sepListL (wordL ";") |> bracketL - [ yield wordL "for" ++ header - yield body ] - |> aboveListL + [ yield wordL "for" ++ header; yield body ] |> aboveListL and printWhileLoop (wl: WhileLoop<_>) = let cond = Expressions.print wl.Condition |> bracketL let body = print true wl.WhileBlock - [ yield wordL "while" ++ cond - yield body ] - |> aboveListL + [ yield wordL "while" ++ cond; yield body ] |> aboveListL and printFunCall (fc: FunCall<_>) = let args = fc.Args |> List.map Expressions.print |> commaListL |> bracketL @@ -110,20 +99,14 @@ module Statements = | MemFence.Global -> wordL "barrier(CLK_GLOBAL_MEM_FENCE)" | Both -> wordL "barrier(CLK_LOCAL_MEM_FENCE | CLK_GLOBAL_MEM_FENCE)" - and printReturn (r: Return<_>) = - wordL "return" ++ Expressions.print r.Expression + and printReturn (r: Return<_>) = wordL "return" ++ Expressions.print r.Expression and printFieldSet (fs: FieldSet<_>) = let host = Expressions.print fs.Host let fld = wordL fs.Field let val' = Expressions.print fs.Val - [ host |> bracketL - wordL "." - fld - wordL "=" - val' ] - |> spaceListL + [ host |> bracketL; wordL "."; fld; wordL "="; val' ] |> spaceListL and print isToplevel (stmt: Statement<'lang>) = let res = diff --git a/src/Brahma.FSharp.OpenCL.Printer/TypeDecl.fs b/src/Brahma.FSharp.OpenCL.Printer/TypeDecl.fs index 1901c4ec..b136d7ef 100644 --- a/src/Brahma.FSharp.OpenCL.Printer/TypeDecl.fs +++ b/src/Brahma.FSharp.OpenCL.Printer/TypeDecl.fs @@ -22,23 +22,15 @@ open Microsoft.FSharp.Text.StructuredFormat.LayoutOps module TypeDecl = let printStructDeclaration (decl: StructDecl<_>) = let header = - [ wordL "typedef" - wordL "struct" - wordL decl.StructType.Name ] - |> spaceListL + [ wordL "typedef"; wordL "struct"; wordL decl.StructType.Name ] |> spaceListL let flds = - [ for f in decl.StructType.Fields -> - [ Types.print f.Type - wordL f.Name - wordL ";" ] - |> spaceListL ] + [ + for f in decl.StructType.Fields -> [ Types.print f.Type; wordL f.Name; wordL ";" ] |> spaceListL + ] |> aboveListL |> braceL - let footer = - [ wordL decl.StructType.Name - wordL ";" ] - |> spaceListL + let footer = [ wordL decl.StructType.Name; wordL ";" ] |> spaceListL header ^^ flds ^^ footer diff --git a/src/Brahma.FSharp.OpenCL.Printer/Types.fs b/src/Brahma.FSharp.OpenCL.Printer/Types.fs index d85cbe97..933bee97 100644 --- a/src/Brahma.FSharp.OpenCL.Printer/Types.fs +++ b/src/Brahma.FSharp.OpenCL.Printer/Types.fs @@ -54,24 +54,17 @@ module Types = | _ -> failwithf "Printer. Unsupported type: %A" type' and printAggregatingInplaceType keyword typeName fields = - let header = - [ wordL keyword - wordL typeName ] - |> spaceListL + let header = [ wordL keyword; wordL typeName ] |> spaceListL let body = - [ for field in fields -> - [ print field.Type - wordL field.Name - wordL ";" ] - |> spaceListL ] + [ + for field in fields -> [ print field.Type; wordL field.Name; wordL ";" ] |> spaceListL + ] |> aboveListL |> braceL header ^^ body - and printUnionInplaceType (t: UnionClInplaceType<_>) = - printAggregatingInplaceType "union" t.Name t.Fields + and printUnionInplaceType (t: UnionClInplaceType<_>) = printAggregatingInplaceType "union" t.Name t.Fields - and printStructInplaceType (t: StructInplaceType<_>) = - printAggregatingInplaceType "struct" t.Name t.Fields + and printStructInplaceType (t: StructInplaceType<_>) = printAggregatingInplaceType "struct" t.Name t.Fields diff --git a/src/Brahma.FSharp.OpenCL.Translator/Body.fs b/src/Brahma.FSharp.OpenCL.Translator/Body.fs index 52431949..376a9e4b 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/Body.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/Body.fs @@ -113,7 +113,8 @@ module rec Body = let! state = state let! translated = translateCond arg return translated :: state - }) + } + ) (State.return' []) |> State.map List.rev @@ -159,134 +160,90 @@ module rec Body = do! State.modify (fun context -> context.Flags.Add EnableAtomic |> ignore - context) - - return - FunCall( - "atom_add", - [ args.[0] - args.[1] ] + context ) - :> Statement<_> + + return FunCall("atom_add", [ args.[0]; args.[1] ]) :> Statement<_> | "atomicsub" -> do! State.modify (fun context -> context.Flags.Add EnableAtomic |> ignore - context) - - return - FunCall( - "atom_sub", - [ args.[0] - args.[1] ] + context ) - :> Statement<_> + + return FunCall("atom_sub", [ args.[0]; args.[1] ]) :> Statement<_> | "atomicxchg" -> do! State.modify (fun context -> context.Flags.Add EnableAtomic |> ignore - context) - - return - FunCall( - "atom_xchg", - [ args.[0] - args.[1] ] + context ) - :> Statement<_> + + return FunCall("atom_xchg", [ args.[0]; args.[1] ]) :> Statement<_> | "atomicmax" -> do! State.modify (fun context -> context.Flags.Add EnableAtomic |> ignore - context) - - return - FunCall( - "atom_max", - [ args.[0] - args.[1] ] + context ) - :> Statement<_> + + return FunCall("atom_max", [ args.[0]; args.[1] ]) :> Statement<_> | "atomicmin" -> do! State.modify (fun context -> context.Flags.Add EnableAtomic |> ignore - context) - - return - FunCall( - "atom_min", - [ args.[0] - args.[1] ] + context ) - :> Statement<_> + + return FunCall("atom_min", [ args.[0]; args.[1] ]) :> Statement<_> | "atomicinc" -> do! State.modify (fun context -> context.Flags.Add EnableAtomic |> ignore - context) + context + ) return FunCall("atom_inc", [ args.[0] ]) :> Statement<_> | "atomicdec" -> do! State.modify (fun context -> context.Flags.Add EnableAtomic |> ignore - context) + context + ) return FunCall("atom_dec", [ args.[0] ]) :> Statement<_> | "atomiccmpxchg" -> do! State.modify (fun context -> context.Flags.Add EnableAtomic |> ignore - context) - - return - FunCall( - "atom_cmpxchg", - [ args.[0] - args.[1] - args.[2] ] + context ) - :> Statement<_> + + return FunCall("atom_cmpxchg", [ args.[0]; args.[1]; args.[2] ]) :> Statement<_> | "atomicand" -> do! State.modify (fun context -> context.Flags.Add EnableAtomic |> ignore - context) - - return - FunCall( - "atom_and", - [ args.[0] - args.[1] ] + context ) - :> Statement<_> + + return FunCall("atom_and", [ args.[0]; args.[1] ]) :> Statement<_> | "atomicor" -> do! State.modify (fun context -> context.Flags.Add EnableAtomic |> ignore - context) - - return - FunCall( - "atom_or", - [ args.[0] - args.[1] ] + context ) - :> Statement<_> + + return FunCall("atom_or", [ args.[0]; args.[1] ]) :> Statement<_> | "atomicxor" -> do! State.modify (fun context -> context.Flags.Add EnableAtomic |> ignore - context) - - return - FunCall( - "atom_xor", - [ args.[0] - args.[1] ] + context ) - :> Statement<_> + + return FunCall("atom_xor", [ args.[0]; args.[1] ]) :> Statement<_> | "todouble" -> return Cast(args.[0], PrimitiveType Float) :> Statement<_> | "toint" -> return Cast(args.[0], PrimitiveType Int) :> Statement<_> | "toint16" -> return Cast(args.[0], PrimitiveType Short) :> Statement<_> @@ -514,11 +471,7 @@ module rec Body = | "boolean" -> let! translatedType = Type.translate sType - let stringValue = - if value.ToString().ToLowerInvariant() = "false" then - "0" - else - "1" + let stringValue = if value.ToString().ToLowerInvariant() = "false" then "0" else "1" return translatedType, stringValue @@ -603,7 +556,8 @@ module rec Body = do! State.modify (fun context -> context.Namer.LetIn loopVar.Name - context) + context + ) let! loopVarModifier = match step with @@ -611,13 +565,8 @@ module rec Body = Expr.VarSet( loopVar, Expr.Call( - Utils.makeGenericMethodCall - [ loopVarType - loopVarType - loopVarType ] - <@ (+) @>, - [ Expr.Var loopVar - step ] + Utils.makeGenericMethodCall [ loopVarType; loopVarType; loopVarType ] <@ (+) @>, + [ Expr.Var loopVar; step ] ) ) |> translate @@ -629,7 +578,8 @@ module rec Body = do! State.modify (fun context -> context.Namer.LetOut() - context) + context + ) return ForIntegerLoop(loopVarBinding, loopCond, loopVarModifier, loopBody) } @@ -660,13 +610,15 @@ module rec Body = do! State.modify (fun context -> context.VarDecls.Clear() - context) + context + ) for expr in linearized do do! State.modify (fun context -> context.VarDecls.Clear() - context) + context + ) match! translate expr with | :? StatementBlock as s1 -> decls.AddRange(s1.Statements) @@ -800,12 +752,14 @@ module rec Body = do! State.modify (fun context -> context.VarDecls.Add vDecl - context) + context + ) do! State.modify (fun context -> context.Namer.LetIn var.Name - context) + context + ) let! res = translate inExpr |> State.using clearContext let! sb = State.gets (fun context -> context.VarDecls) @@ -817,7 +771,8 @@ module rec Body = do! State.modify (fun context -> context.Namer.LetOut() - context) + context + ) do! State.modify clearContext diff --git a/src/Brahma.FSharp.OpenCL.Translator/Brahma.FSharp.OpenCL.Translator.fsproj b/src/Brahma.FSharp.OpenCL.Translator/Brahma.FSharp.OpenCL.Translator.fsproj index bef0d0a7..b9718d21 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/Brahma.FSharp.OpenCL.Translator.fsproj +++ b/src/Brahma.FSharp.OpenCL.Translator/Brahma.FSharp.OpenCL.Translator.fsproj @@ -9,6 +9,7 @@ Brahma.FSharp.OpenCL.Translator F# quotations to OpenCL C translator. + 1591 true diff --git a/src/Brahma.FSharp.OpenCL.Translator/CustomMarshaller.fs b/src/Brahma.FSharp.OpenCL.Translator/CustomMarshaller.fs index fc3883ce..dd2371a2 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/CustomMarshaller.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/CustomMarshaller.fs @@ -10,11 +10,11 @@ open System.Runtime.Serialization open FSharpx.Collections type StructurePacking = - { Size: int - Alignment: int - Members: - {| Pack: StructurePacking - Offsets: int |} list } + { + Size: int + Alignment: int + Members: {| Pack: StructurePacking; Offsets: int |} list + } type CustomMarshaller() = let typePacking = ConcurrentDictionary() @@ -24,19 +24,21 @@ type CustomMarshaller() = let blittableTypes = ConcurrentDictionary( dict - [ typeof, false - typeof, true - typeof, true - typeof, true - typeof, true - typeof, true - typeof, true - typeof, true - typeof, true - typeof, true - typeof, true - typeof, true - typeof, true ] + [ + typeof, false + typeof, true + typeof, true + typeof, true + typeof, true + typeof, true + typeof, true + typeof, true + typeof, true + typeof, true + typeof, true + typeof, true + typeof, true + ] ) let (|TupleType|RecordType|UnionType|UserDefinedStructureType|PrimitiveType|) (type': Type) = @@ -61,8 +63,7 @@ type CustomMarshaller() = // TODO issues with multithreading member this.GetTypePacking(type': Type) = - let getAlignment elems = - elems |> List.map (fun pack -> pack.Alignment) |> List.max + let getAlignment elems = elems |> List.map (fun pack -> pack.Alignment) |> List.max let getSize alignment elems = elems @@ -90,9 +91,7 @@ type CustomMarshaller() = let offsets = elems |> getOffsets let members = (elems, offsets) ||> getMembers - { Size = size - Alignment = alignment - Members = members } + { Size = size; Alignment = alignment; Members = members } | RecordType -> let elems = @@ -106,9 +105,7 @@ type CustomMarshaller() = let offsets = elems |> getOffsets let members = (elems, offsets) ||> getMembers - { Size = size - Alignment = alignment - Members = members } + { Size = size; Alignment = alignment; Members = members } | UnionType -> let tag = go typeof @@ -120,9 +117,7 @@ type CustomMarshaller() = let unionPacking = if nonEmptyFieldsTypes.Length = 0 then - { Size = 0 - Alignment = 1 - Members = [] } + { Size = 0; Alignment = 1; Members = [] } else let packingList = nonEmptyFieldsTypes @@ -135,22 +130,16 @@ type CustomMarshaller() = let unionSize = packingList |> List.map (fun pack -> pack.Size) |> List.max - { Size = unionSize - Alignment = unionAlignment - Members = [] } + { Size = unionSize; Alignment = unionAlignment; Members = [] } - let elems = - [ tag - unionPacking ] + let elems = [ tag; unionPacking ] let alignment = elems |> getAlignment let size = elems |> getSize alignment let offsets = elems |> getOffsets let members = (elems, offsets) ||> getMembers - { Size = size - Alignment = alignment - Members = members } + { Size = size; Alignment = alignment; Members = members } | UserDefinedStructureType -> let elems = @@ -164,24 +153,15 @@ type CustomMarshaller() = let offsets = elems |> getOffsets let members = (elems, offsets) ||> getMembers - { Size = size - Alignment = alignment - Members = members } + { Size = size; Alignment = alignment; Members = members } | PrimitiveType -> let size = - Marshal.SizeOf( - if type' = typeof then - typeof - else - type' - ) + Marshal.SizeOf(if type' = typeof then typeof else type') let alignment = size - { Size = size - Alignment = alignment - Members = [] } + { Size = size; Alignment = alignment; Members = [] } go type' @@ -263,12 +243,7 @@ type CustomMarshaller() = member this.WriteToUnmanaged(array: 'a[], ptr: IntPtr) = let rec write start (structure: obj) = let offsets = - this.GetTypeOffsets( - if isNull structure then - typeof - else - structure.GetType() - ) + this.GetTypeOffsets(if isNull structure then typeof else structure.GetType()) let mutable i = 0 @@ -308,10 +283,7 @@ type CustomMarshaller() = let offset = if isNull structure then 0 else offsets.[i] let structure = - if str.GetType() = typeof then - box <| Convert.ToByte str - else - str + if str.GetType() = typeof then box <| Convert.ToByte str else str Marshal.StructureToPtr(structure, IntPtr.Add(start, offset), false) i <- i + 1 @@ -322,7 +294,8 @@ type CustomMarshaller() = (fun j item -> let pack = this.GetTypePacking(typeof<'a>) let start = IntPtr.Add(ptr, j * pack.Size) - write start item) + write start item + ) array array.Length * this.GetTypePacking(typeof<'a>).Size @@ -384,17 +357,11 @@ type CustomMarshaller() = let structure = Marshal.PtrToStructure( IntPtr.Add(start, offset), - if type'' = typeof then - typeof - else - type'' + if type'' = typeof then typeof else type'' ) let structure = - if type'' = typeof then - box <| Convert.ToBoolean structure - else - structure + if type'' = typeof then box <| Convert.ToBoolean structure else structure i <- i + 1 structure @@ -404,5 +371,6 @@ type CustomMarshaller() = Array.Parallel.iteri (fun j _ -> let start = IntPtr.Add(ptr, j * this.GetTypePacking(typeof<'a>).Size) - array.[j] <- unbox<'a> <| read start typeof<'a>) + array.[j] <- unbox<'a> <| read start typeof<'a> + ) array diff --git a/src/Brahma.FSharp.OpenCL.Translator/Methods.fs b/src/Brahma.FSharp.OpenCL.Translator/Methods.fs index b14ee895..c9b70e84 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/Methods.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/Methods.fs @@ -92,16 +92,14 @@ type KernelFunc(var: Var, expr: Expr) = translation { let! context = State.get - let brahmaDimensionsTypes = - [ Range1D_ - Range2D_ - Range3D_ ] + let brahmaDimensionsTypes = [ Range1D_; Range2D_; Range3D_ ] return args |> List.filter (fun (variable: Var) -> brahmaDimensionsTypes - |> (not << List.contains (variable.Type.Name.ToLowerInvariant()))) + |> (not << List.contains (variable.Type.Name.ToLowerInvariant())) + ) |> List.map (fun variable -> let vType = Type.translate variable.Type |> State.eval context let declSpecs = DeclSpecifierPack(typeSpecifier = vType) @@ -109,7 +107,8 @@ type KernelFunc(var: Var, expr: Expr) = if vType :? RefType<_> then declSpecs.AddressSpaceQualifier <- Global - FunFormalArg(declSpecs, variable.Name)) + FunFormalArg(declSpecs, variable.Name) + ) } override this.BuildFunction(args, body) = @@ -137,7 +136,8 @@ type Function(var: Var, expr: Expr) = elif vType :? RefType<_> && localVars |> List.contains variable.Name then declSpecs.AddressSpaceQualifier <- Local - FunFormalArg(declSpecs, variable.Name)) + FunFormalArg(declSpecs, variable.Name) + ) } override this.BuildFunction(args, body) = @@ -180,7 +180,8 @@ type AtomicFunc(var: Var, expr: Expr, qual: AddressSpaceQualifier) = elif vType :? RefType<_> && localVars |> List.contains variable.Name then declSpecs.AddressSpaceQualifier <- Local - FunFormalArg(declSpecs, variable.Name)) + FunFormalArg(declSpecs, variable.Name) + ) } override this.BuildFunction(args, body) = diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Atomic.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Atomic.fs index 88fed9cf..abaa08d8 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Atomic.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Atomic.fs @@ -261,24 +261,20 @@ module Atomic = match lambdaBody with | DerivedPatterns.SpecificCall <@ inc @> (_, onType :: _, [ Patterns.Var p ]) -> Expr.Call( - Utils.makeGenericMethodCall - [ onType - onType - onType ] - <@ (+) @>, - [ Expr.Var p - Expr.Call(Utils.makeGenericMethodCall [ onType ] <@ GenericOne @>, List.empty) ] + Utils.makeGenericMethodCall [ onType; onType; onType ] <@ (+) @>, + [ + Expr.Var p + Expr.Call(Utils.makeGenericMethodCall [ onType ] <@ GenericOne @>, List.empty) + ] ) | DerivedPatterns.SpecificCall <@ dec @> (_, onType :: _, [ Patterns.Var p ]) -> Expr.Call( - Utils.makeGenericMethodCall - [ onType - onType - onType ] - <@ (-) @>, - [ Expr.Var p - Expr.Call(Utils.makeGenericMethodCall [ onType ] <@ GenericOne @>, List.empty) ] + Utils.makeGenericMethodCall [ onType; onType; onType ] <@ (-) @>, + [ + Expr.Var p + Expr.Call(Utils.makeGenericMethodCall [ onType ] <@ GenericOne @>, List.empty) + ] ) | DerivedPatterns.SpecificCall <@ xchg @> (_, _, [ Patterns.Var p; Patterns.Var value ]) -> @@ -292,8 +288,7 @@ module Atomic = Expr.IfThenElse( Expr.Call( Utils.makeGenericMethodCall [ onType ] <@ (=) @>, - [ Expr.Var p - Expr.Var cmp ] + [ Expr.Var p; Expr.Var cmp ] ), Expr.Var value, Expr.Var p @@ -313,7 +308,8 @@ module Atomic = let atomicFuncArgs = baseFuncArgs |> modifyFirstOfListList (fun x -> - Var(x.Name, typeof>.GetGenericTypeDefinition().MakeGenericType(x.Type), x.IsMutable)) + Var(x.Name, typeof>.GetGenericTypeDefinition().MakeGenericType(x.Type), x.IsMutable) + ) let! state = State.get @@ -324,12 +320,9 @@ module Atomic = | None -> Var( pointerVar.Name + "Mutex", - if nonPrivateVars.[pointerVar] = GlobalQ then - typeof> - elif pointerVar.Type.IsArray then - typeof - else - typeof + if nonPrivateVars.[pointerVar] = GlobalQ then typeof> + elif pointerVar.Type.IsArray then typeof + else typeof ) do! State.modify (fun state -> state |> Map.add pointerVar mutexVar) @@ -362,8 +355,7 @@ module Atomic = [ Patterns.Var _; idx ]) -> Expr.Call( Utils.getMethodInfoOfCall <@ IntrinsicFunctions.GetArray @>, - [ Expr.Var mutexVar - idx ] + [ Expr.Var mutexVar; idx ] ) | _ -> failwith "Invalid volatile argument. This exception should never occur :)" @@ -468,7 +460,8 @@ module Atomic = pointerVarToMutexVarMap |> Map.iter (fun var mutexVar -> if args |> List.contains var then - newArgs.Add mutexVar) + newArgs.Add mutexVar + ) // Set local args let rec go expr = @@ -507,9 +500,7 @@ module Atomic = Expr.Call( Utils.getMethodInfoOfCall <@ IntrinsicFunctions.SetArray @>, - [ Expr.Var mutexVar - Expr.Var i - Expr.Value 0 ] + [ Expr.Var mutexVar; Expr.Var i; Expr.Value 0 ] ) )) diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Lifting.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Lifting.fs index 8098e0ff..c3099390 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Lifting.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Lifting.fs @@ -4,19 +4,21 @@ open Brahma.FSharp.OpenCL.Translator open FSharp.Quotations type Context = - { FreeVariables: Map> - Substitution: Map } + { + FreeVariables: Map> + Substitution: Map + } member this.Update(oldFun, newFunVar, freeVars) = let newApplication = freeVars |> List.map Expr.Var |> Utils.makeApplicationExpr (Expr.Var newFunVar) - { FreeVariables = this.FreeVariables.Add(oldFun, freeVars) - Substitution = this.Substitution.Add(oldFun, newApplication) } + { + FreeVariables = this.FreeVariables.Add(oldFun, freeVars) + Substitution = this.Substitution.Add(oldFun, newApplication) + } - static member empty = - { FreeVariables = Map.empty - Substitution = Map.empty } + static member empty = { FreeVariables = Map.empty; Substitution = Map.empty } module Lift = module Parameters = @@ -83,10 +85,12 @@ module Lift = let private takeOutArgs (args: Expr list) app = args |> List.filter (fun e -> e.Type = typeof) - |> List.filter (function + |> List.filter ( + function | Patterns.Var _ | Patterns.Value _ -> false - | _ -> true) + | _ -> true + ) |> (fun args -> List.foldBack (fun f s -> Expr.Sequential(f, s)) args app) /// args: [x1: t1; x2: t2; x3: t3], boyd: t4 @@ -101,9 +105,11 @@ module Lift = // Value() in Applications patterns go to [] // Then i think we should map [] -> [ Value((), typeof) ] in exps let private mapExpsToArgs = - List.map (function + List.map ( + function | [] -> [ Expr.Value((), typeof) ] - | x -> x) + | x -> x + ) >> List.concat let cleanUp (expr: Expr) = @@ -123,7 +129,8 @@ module Lift = let args' = filterUnit args |> List.map (parse subst) let app' = Utils.makeApplicationExpr (Expr.Var var') args' - takeOutArgs args app') + takeOutArgs args app' + ) |> Option.defaultValue source | ExprShape.ShapeLambda(var, body) -> Expr.Lambda(var, parse subst body) | ExprShape.ShapeVar var as source -> @@ -153,5 +160,4 @@ module Lift = let exprList', methods = exprList |> List.map lift |> List.unzip ExprShape.RebuildShapeCombination(o, exprList'), List.concat methods - let parse (expr: Expr) = - expr |> Parameters.lift |> UnitArguments.cleanUp |> Lambda.lift + let parse (expr: Expr) = expr |> Parameters.lift |> UnitArguments.cleanUp |> Lambda.lift diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Names.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Names.fs index ed6ff603..0fea09d8 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Names.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Names.fs @@ -46,5 +46,4 @@ module Names = ExprShape.RebuildShapeCombination(shapeComboObj, exprList') - let makeUnique (expr: Expr) = - makeVarNamesUniqueImpl <| RenamingContext() <| expr + let makeUnique (expr: Expr) = makeVarNamesUniqueImpl <| RenamingContext() <| expr diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Patterns.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Patterns.fs index afa0b029..fce352c0 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Patterns.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Patterns.fs @@ -13,8 +13,7 @@ module Patterns = let (|LetFunc|_|) exp = letDefinition Utils.isFunction exp - let (|LetVar|_|) (expr: Expr) = - letDefinition (not << Utils.isFunction) expr + let (|LetVar|_|) (expr: Expr) = letDefinition (not << Utils.isFunction) expr /// let f x1 x2 x3 = body in e /// => LetFuncUncurry(f, [x1; x2, x3], body, e) diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Utils.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Utils.fs index 1b85ced4..8753ee30 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Utils.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Utils.fs @@ -19,8 +19,7 @@ module Utils = let makeLambdaType types = List.reduceBack (fun domain range -> FSharpType.MakeFunctionType(domain, range)) types - let makeLambdaExpr (args: Var list) (body: Expr) = - List.foldBack (fun var expr -> Expr.Lambda(var, expr)) args body + let makeLambdaExpr (args: Var list) (body: Expr) = List.foldBack (fun var expr -> Expr.Lambda(var, expr)) args body let makeApplicationExpr (head: Expr) (expressions: Expr list) = List.fold (fun l r -> Expr.Application(l, r)) head expressions @@ -93,11 +92,7 @@ module Utils = let tp = reference.Type.GenericTypeArguments.[0] let newMethodInfo = methodInfo.GetGenericMethodDefinition().MakeGenericMethod(tp) - Expr.Call( - newMethodInfo, - [ reference - value ] - ) + Expr.Call(newMethodInfo, [ reference; value ]) | _ -> failwithf "createReferenceSetCall: (:=) is not more a Call expression" let isGlobal (var: Var) = diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/VarToRef.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/VarToRef.fs index 6bad44a8..adc882c0 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/VarToRef.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/VarToRef.fs @@ -3,17 +3,18 @@ namespace Brahma.FSharp.OpenCL.Translator.QuotationTransformers open FSharp.Quotations module VarToRef = - let private isMutableVar (var: Var) = - var.IsMutable && not (Utils.isFunction var) + let private isMutableVar (var: Var) = var.IsMutable && not (Utils.isFunction var) let rec private collectMutableVarsInClosure = function | Patterns.LetFunc(_, body, inExpr) -> let mutableFreeVars = body.GetFreeVars() |> Seq.filter isMutableVar |> Set.ofSeq - [ mutableFreeVars - collectMutableVarsInClosure body - collectMutableVarsInClosure inExpr ] + [ + mutableFreeVars + collectMutableVarsInClosure body + collectMutableVarsInClosure inExpr + ] |> Set.unionMany | ExprShape.ShapeLambda(_, body) -> collectMutableVarsInClosure body | ExprShape.ShapeVar _ -> Set.empty @@ -51,7 +52,8 @@ module VarToRef = refMap.TryFind var |> Option.map (fun refExpr -> let expr = parse refMap valueExpr - Utils.createReferenceSetCall refExpr expr) + Utils.createReferenceSetCall refExpr expr + ) |> Option.defaultValue sourceExpr | ExprShape.ShapeVar var as sourceExpr -> refMap.TryFind var diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/WorkSize.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/WorkSize.fs index 787dfdf4..b9580d81 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/WorkSize.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/WorkSize.fs @@ -45,8 +45,7 @@ module WorkSize = Some(var, inExp) | _ -> None - let inline private (|Zero|_|) exp = - (|CoordinateBind|_|) 0 (|ReturnSome|_|) exp + let inline private (|Zero|_|) exp = (|CoordinateBind|_|) 0 (|ReturnSome|_|) exp let inline private (|First|_|) exp = (|CoordinateBind|_|) 1 (|Zero|_|) exp diff --git a/src/Brahma.FSharp.OpenCL.Translator/TranslationContext.fs b/src/Brahma.FSharp.OpenCL.Translator/TranslationContext.fs index 66ec8aba..d167327d 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/TranslationContext.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/TranslationContext.fs @@ -76,39 +76,39 @@ type Namer() = type TranslationContext<'lang, 'vDecl> = { - // translator scope - TranslatorOptions: TranslatorOptions + // translator scope + TranslatorOptions: TranslatorOptions - // kernel scope - CStructDecls: Dictionary> - StructInplaceCounter: Dictionary - TopLevelVarsDecls: ResizeArray<'vDecl> - Flags: HashSet + // kernel scope + CStructDecls: Dictionary> + StructInplaceCounter: Dictionary + TopLevelVarsDecls: ResizeArray<'vDecl> + Flags: HashSet - // function scope - VarDecls: ResizeArray<'vDecl> - Namer: Namer + // function scope + VarDecls: ResizeArray<'vDecl> + Namer: Namer - // specific scope - ArrayKind: ArrayKind } + // specific scope + ArrayKind: ArrayKind + } static member Create(options) = - { TranslatorOptions = options + { + TranslatorOptions = options - CStructDecls = Dictionary>() - StructInplaceCounter = Dictionary() - TopLevelVarsDecls = ResizeArray<'vDecl>() - Flags = HashSet() + CStructDecls = Dictionary>() + StructInplaceCounter = Dictionary() + TopLevelVarsDecls = ResizeArray<'vDecl>() + Flags = HashSet() - VarDecls = ResizeArray<'vDecl>() - Namer = Namer() + VarDecls = ResizeArray<'vDecl>() + Namer = Namer() - ArrayKind = CPointer } + ArrayKind = CPointer + } - member this.WithNewLocalContext() = - { this with - VarDecls = ResizeArray() - Namer = Namer() } + member this.WithNewLocalContext() = { this with VarDecls = ResizeArray(); Namer = Namer() } type TargetContext = TranslationContext> diff --git a/src/Brahma.FSharp.OpenCL.Translator/Translator.fs b/src/Brahma.FSharp.OpenCL.Translator/Translator.fs index 91e2d70c..4f4ffb70 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/Translator.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/Translator.fs @@ -80,7 +80,8 @@ type FSQuotationToOpenCLTranslator(device: IDevice, ?translatorOptions: Translat |> List.map (fun (var, expr) -> match atomicApplicationsInfo |> Map.tryFind var with | Some qual -> AtomicFunc(var, expr, qual) :> Method - | None -> Function(var, expr) :> Method) + | None -> Function(var, expr) :> Method + ) methods @ kernelFunc @@ -121,7 +122,8 @@ type FSQuotationToOpenCLTranslator(device: IDevice, ?translatorOptions: Translat | EnableAtomic -> pragmas.Add(CLPragma CLGlobalInt32BaseAtomics :> ITopDef<_>) pragmas.Add(CLPragma CLLocalInt32BaseAtomics :> ITopDef<_>) - | EnableFP64 -> pragmas.Add(CLPragma CLFP64)) + | EnableFP64 -> pragmas.Add(CLPragma CLFP64) + ) List.ofSeq pragmas @@ -140,8 +142,7 @@ type FSQuotationToOpenCLTranslator(device: IDevice, ?translatorOptions: Translat member this.TranslatorOptions = translatorOptions - member this.Translate(qExpr) = - lock lockObject <| fun () -> translate qExpr + member this.Translate(qExpr) = lock lockObject <| fun () -> translate qExpr member this.TransformQuotation(expr: Expr) = transformQuotation expr @@ -156,6 +157,7 @@ type FSQuotationToOpenCLTranslator(device: IDevice, ?translatorOptions: Translat member this.MaxWorkItemSizes = [| 0 |] member this.DeviceExtensions = [||] member this.LocalMemSize = 0 - member this.GlobalMemSize = 0L } + member this.GlobalMemSize = 0L + } FSQuotationToOpenCLTranslator(device) diff --git a/src/Brahma.FSharp.OpenCL.Translator/Type.fs b/src/Brahma.FSharp.OpenCL.Translator/Type.fs index bd6f6ff3..34f34bd1 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/Type.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/Type.fs @@ -57,7 +57,8 @@ module rec Type = do! State.modify (fun ctx -> ctx.Flags.Add EnableFP64 |> ignore - ctx) + ctx + ) return PrimitiveType(Double) :> Type @@ -115,13 +116,17 @@ module rec Type = return context.CStructDecls.[type'] else let! fields = - [ for f in type'.GetProperties(BindingFlags.Public ||| BindingFlags.Instance) -> - translate f.PropertyType - >>= fun type' -> State.return' { Name = f.Name; Type = type' } ] - @ [ if not <| FSharpType.IsRecord type' then + [ + for f in type'.GetProperties(BindingFlags.Public ||| BindingFlags.Instance) -> + translate f.PropertyType + >>= fun type' -> State.return' { Name = f.Name; Type = type' } + ] + @ [ + if not <| FSharpType.IsRecord type' then for f in type'.GetFields(BindingFlags.Public ||| BindingFlags.Instance) -> translate f.FieldType - >>= fun type' -> State.return' { Name = f.Name; Type = type' } ] + >>= fun type' -> State.return' { Name = f.Name; Type = type' } + ] |> State.collect let fields = fields |> List.distinct @@ -132,7 +137,8 @@ module rec Type = do! State.modify (fun context -> context.CStructDecls.Add(type', structType) - context) + context + ) return structType } @@ -152,10 +158,9 @@ module rec Type = translation { let! translatedType = translate type' - return - { Name = $"_%i{i + 1}" - Type = translatedType } - }) + return { Name = $"_%i{i + 1}"; Type = translatedType } + } + ) |> State.collect let! index = State.gets (fun ctx -> ctx.CStructDecls.Count) @@ -164,7 +169,8 @@ module rec Type = do! State.modify (fun ctx -> ctx.CStructDecls.Add(type', tupleDecl) - ctx) + ctx + ) return tupleDecl } @@ -181,34 +187,40 @@ module rec Type = |> Array.filter (fun case -> case.GetFields().Length <> 0) let! fields = - [ for case in notEmptyCases -> - translation { - let structName = case.Name - let tag = case.Tag - - let! fields = - [ for field in case.GetFields() -> - translate field.PropertyType - >>= fun type' -> State.return' { Name = field.Name; Type = type' } ] - |> State.collect - - let! context = State.get - - let conter = - let mutable i = 0 - - if context.StructInplaceCounter.TryGetValue($"{structName}Type", &i) then - context.StructInplaceCounter.[$"{structName}Type"] <- i + 1 - i - else - context.StructInplaceCounter.Add($"{structName}Type", 1) - 0 - - return - tag, - { Name = structName - Type = StructInplaceType($"{structName}Type{conter}", fields) } - } ] + [ + for case in notEmptyCases -> + translation { + let structName = case.Name + let tag = case.Tag + + let! fields = + [ + for field in case.GetFields() -> + translate field.PropertyType + >>= fun type' -> State.return' { Name = field.Name; Type = type' } + ] + |> State.collect + + let! context = State.get + + let conter = + let mutable i = 0 + + if context.StructInplaceCounter.TryGetValue($"{structName}Type", &i) then + context.StructInplaceCounter.[$"{structName}Type"] <- i + 1 + i + else + context.StructInplaceCounter.Add($"{structName}Type", 1) + 0 + + return + tag, + { + Name = structName + Type = StructInplaceType($"{structName}Type{conter}", fields) + } + } + ] |> State.collect let! index = State.gets (fun ctx -> ctx.CStructDecls.Count) @@ -217,7 +229,8 @@ module rec Type = do! State.modify (fun context -> context.CStructDecls.Add(type', duType) - context) + context + ) return duType :> StructType<_> } diff --git a/src/Brahma.FSharp.OpenCL.Translator/Utils/Extensions.fs b/src/Brahma.FSharp.OpenCL.Translator/Utils/Extensions.fs index 3bf80c43..a0b10d7c 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/Utils/Extensions.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/Utils/Extensions.fs @@ -9,8 +9,7 @@ module Extensions = /// Builds an expression that represents the lambda static member Lambdas(args: Var list list, body: Expr) = - let mkRLinear mk (vs, body) = - List.foldBack (fun v acc -> mk (v, acc)) vs body + let mkRLinear mk (vs, body) = List.foldBack (fun v acc -> mk (v, acc)) vs body let mkTupledLambda (args, body) = match args with @@ -24,7 +23,8 @@ module Extensions = tupledArg, (args, [ 0 .. args.Length - 1 ], body) |||> List.foldBack2 (fun var idxInTuple letExpr -> - Expr.Let(var, Expr.TupleGet(Expr.Var tupledArg, idxInTuple), letExpr)) + Expr.Let(var, Expr.TupleGet(Expr.Var tupledArg, idxInTuple), letExpr) + ) ) mkRLinear mkTupledLambda (args, body) diff --git a/src/Brahma.FSharp.OpenCL.Translator/Utils/StateBuilder.fs b/src/Brahma.FSharp.OpenCL.Translator/Utils/StateBuilder.fs index 8112c446..c749dd90 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/Utils/StateBuilder.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/Utils/StateBuilder.fs @@ -33,8 +33,7 @@ module State = let (x, state) = run state s f x, state - let using f x = - State <| fun state -> eval (f state) x, state + let using f x = State <| fun state -> eval (f state) x, state let collect (list: State<'s, 'a> list) = list @@ -55,8 +54,7 @@ type StateBuilder<'state>() = let (_, context) = State.run context x1 State.run context x2 - member inline this.Delay(rest) = - this.Bind(this.Zero(), (fun () -> rest ())) + member inline this.Delay(rest) = this.Bind(this.Zero(), (fun () -> rest ())) member inline this.Run(m) = m diff --git a/src/Brahma.FSharp.OpenCL.Translator/Utils/Utils.fs b/src/Brahma.FSharp.OpenCL.Translator/Utils/Utils.fs index 84cdbf43..b8c47cb3 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/Utils/Utils.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/Utils/Utils.fs @@ -19,5 +19,4 @@ module Utils = tp.GetCustomAttributes(false) |> Seq.exists (fun attr -> attr.GetType() = typeof<'attr>) - let roundUp n x = - if x % n <> 0 then (x / n) * n + n else x + let roundUp n x = if x % n <> 0 then (x / n) * n + n else x diff --git a/src/YC.OpenCL.NET/YC.OpenCL.NET.csproj b/src/YC.OpenCL.NET/YC.OpenCL.NET.csproj index fc5a47a7..b1292775 100644 --- a/src/YC.OpenCL.NET/YC.OpenCL.NET.csproj +++ b/src/YC.OpenCL.NET/YC.OpenCL.NET.csproj @@ -9,6 +9,7 @@ OpenCL.NET true true + 1591 diff --git a/tests/Brahma.FSharp.Tests/ExecutionTests/AtomicTests.fs b/tests/Brahma.FSharp.Tests/ExecutionTests/AtomicTests.fs index b4a8cc20..4cf4eb0d 100644 --- a/tests/Brahma.FSharp.Tests/ExecutionTests/AtomicTests.fs +++ b/tests/Brahma.FSharp.Tests/ExecutionTests/AtomicTests.fs @@ -37,7 +37,8 @@ module Helpers = { Config.QuickThrowOnFailure with QuietOnSuccess = true MaxTest = 20 - Arbitrary = [ typeof ] } + Arbitrary = [ typeof ] + } let checkDefault<'a when 'a: equality and 'a: struct> context expected kernel = let actual = @@ -95,78 +96,86 @@ let stressTest<'a when 'a: equality and 'a: struct> context (f: Expr<'a -> 'a>) "Results should be equal" |> Expect.isTrue (isEqual actual expected) let stressTestCases context = - [ let range = [ 1..10..100 ] - - // int - yield! - range - |> List.map (fun size -> - testCase $"Smoke stress test (size %i{size}) on atomic 'inc' on int" - <| fun () -> stressTest context <@ inc @> size (fun x -> x + 1) (=)) - - yield! - range - |> List.map (fun size -> - testCase $"Smoke stress test (size %i{size}) on atomic 'dec' on int" - <| fun () -> stressTest context <@ dec @> size (fun x -> x - 1) (=)) - - // float32 - yield! - range - |> List.map (fun size -> - testCase $"Smoke stress test (size %i{size}) on atomic 'inc' on float32" - <| fun () -> - stressTest - context - <@ fun x -> x + 1.f @> - size - (fun x -> x + 1.f) - (fun x y -> float (abs (x - y)) < Accuracy.low.relative)) - - // double - yield! - range - |> List.map (fun size -> - testCase $"Smoke stress test (size %i{size}) on atomic 'inc' on float" - <| fun () -> - stressTest - context - <@ fun x -> x + 1. @> - size - (fun x -> x + 1.) - (fun x y -> abs (x - y) < Accuracy.low.relative)) - - // bool - yield! - range - |> List.map (fun size -> - testCase $"Smoke stress test (size %i{size}) on atomic 'not' on bool" - <| fun () -> stressTest context <@ not @> size not (=)) - - // WrappedInt (не работает транляция или типа того) - let wrappedIntInc = <@ fun x -> x + WrappedInt(1) @> - - yield! - range - |> List.map (fun size -> - ptestCase $"Smoke stress test (size %i{size}) on custom atomic 'inc' on WrappedInt" - <| fun () -> stressTest context wrappedIntInc size (fun x -> x + WrappedInt(1)) (=)) - - // custom int op - let incx2 = <@ fun x -> x + 2 @> - - yield! - range - |> List.map (fun size -> - testCase $"Smoke stress test (size %i{size}) on atomic unary func on int" - <| fun () -> stressTest context incx2 size (fun x -> x + 2) (=)) ] + [ + let range = [ 1..10..100 ] + + // int + yield! + range + |> List.map (fun size -> + testCase $"Smoke stress test (size %i{size}) on atomic 'inc' on int" + <| fun () -> stressTest context <@ inc @> size (fun x -> x + 1) (=) + ) + + yield! + range + |> List.map (fun size -> + testCase $"Smoke stress test (size %i{size}) on atomic 'dec' on int" + <| fun () -> stressTest context <@ dec @> size (fun x -> x - 1) (=) + ) + + // float32 + yield! + range + |> List.map (fun size -> + testCase $"Smoke stress test (size %i{size}) on atomic 'inc' on float32" + <| fun () -> + stressTest + context + <@ fun x -> x + 1.f @> + size + (fun x -> x + 1.f) + (fun x y -> float (abs (x - y)) < Accuracy.low.relative) + ) + + // double + yield! + range + |> List.map (fun size -> + testCase $"Smoke stress test (size %i{size}) on atomic 'inc' on float" + <| fun () -> + stressTest + context + <@ fun x -> x + 1. @> + size + (fun x -> x + 1.) + (fun x y -> abs (x - y) < Accuracy.low.relative) + ) + + // bool + yield! + range + |> List.map (fun size -> + testCase $"Smoke stress test (size %i{size}) on atomic 'not' on bool" + <| fun () -> stressTest context <@ not @> size not (=) + ) + + // WrappedInt (не работает транляция или типа того) + let wrappedIntInc = <@ fun x -> x + WrappedInt(1) @> + + yield! + range + |> List.map (fun size -> + ptestCase $"Smoke stress test (size %i{size}) on custom atomic 'inc' on WrappedInt" + <| fun () -> stressTest context wrappedIntInc size (fun x -> x + WrappedInt(1)) (=) + ) + + // custom int op + let incx2 = <@ fun x -> x + 2 @> + + yield! + range + |> List.map (fun size -> + testCase $"Smoke stress test (size %i{size}) on atomic unary func on int" + <| fun () -> stressTest context incx2 size (fun x -> x + 2) (=) + ) + ] /// Test for add and sub like atomic operations. /// Use local and global atomics, /// use reading from global mem in local atomic let foldTest<'a when 'a: equality and 'a: struct> context f (isEqual: 'a -> 'a -> bool) = - let (.=.) left right = - isEqual left right |@ $"%A{left} = %A{right}" + let (.=.) left right = isEqual left right |@ $"%A{left} = %A{right}" Check.One( Settings.fscheckConfig, @@ -219,54 +228,55 @@ let foldTest<'a when 'a: equality and 'a: struct> context f (isEqual: 'a -> 'a - let foldTestCases context = [ - // int, smoke tests - testCase "Smoke fold test atomic 'add' on int" - <| fun () -> foldTest context <@ (+) @> (=) - - // float - testCase "Fold test atomic 'add' on float32" - <| fun () -> foldTest context <@ (+) @> (fun x y -> float (abs (x - y)) < Accuracy.low.relative) - - // double - testCase "Fold test atomic 'add' on float" - <| fun () -> foldTest context <@ (+) @> (fun x y -> abs (x - y) < Accuracy.low.relative) - - // bool - ptestCase "Fold test atomic '&&' on bool" - <| fun () -> foldTest context <@ (&&) @> (=) - - testCase "Reduce test atomic 'min' on int" - <| fun () -> foldTest context <@ min @> (=) - ptestCase "Reduce test atomic 'min' on int64" - <| fun () -> foldTest context <@ min @> (=) - testCase "Reduce test atomic 'min' on int16" - <| fun () -> foldTest context <@ min @> (=) - - testCase "Reduce test atomic 'max' on int" - <| fun () -> foldTest context <@ max @> (=) - ptestCase "Reduce test atomic 'max' on int64" - <| fun () -> foldTest context <@ max @> (=) - testCase "Reduce test atomic 'max' on int16" - <| fun () -> foldTest context <@ max @> (=) - - testCase "Reduce test atomic '&&&' on int" - <| fun () -> foldTest context <@ (&&&) @> (=) - ptestCase "Reduce test atomic '&&&' on int64" - <| fun () -> foldTest context <@ (&&&) @> (=) - - testCase "Reduce test atomic '|||' on int" - <| fun () -> foldTest context <@ (|||) @> (=) - ptestCase "Reduce test atomic '|||' on int64" - <| fun () -> foldTest context <@ (|||) @> (=) - - testCase "Reduce test atomic '^^^' on int" - <| fun () -> foldTest context <@ (^^^) @> (=) - ptestCase "Reduce test atomic '^^^' on int64" - <| fun () -> foldTest context <@ (^^^) @> (=) - - // WrappedInt (не работает транляция или типа того) - ptestCase "Fold test atomic 'add' on WrappedInt" - <| fun () -> foldTest context <@ (+) @> (=) ] + // int, smoke tests + testCase "Smoke fold test atomic 'add' on int" + <| fun () -> foldTest context <@ (+) @> (=) + + // float + testCase "Fold test atomic 'add' on float32" + <| fun () -> foldTest context <@ (+) @> (fun x y -> float (abs (x - y)) < Accuracy.low.relative) + + // double + testCase "Fold test atomic 'add' on float" + <| fun () -> foldTest context <@ (+) @> (fun x y -> abs (x - y) < Accuracy.low.relative) + + // bool + ptestCase "Fold test atomic '&&' on bool" + <| fun () -> foldTest context <@ (&&) @> (=) + + testCase "Reduce test atomic 'min' on int" + <| fun () -> foldTest context <@ min @> (=) + ptestCase "Reduce test atomic 'min' on int64" + <| fun () -> foldTest context <@ min @> (=) + testCase "Reduce test atomic 'min' on int16" + <| fun () -> foldTest context <@ min @> (=) + + testCase "Reduce test atomic 'max' on int" + <| fun () -> foldTest context <@ max @> (=) + ptestCase "Reduce test atomic 'max' on int64" + <| fun () -> foldTest context <@ max @> (=) + testCase "Reduce test atomic 'max' on int16" + <| fun () -> foldTest context <@ max @> (=) + + testCase "Reduce test atomic '&&&' on int" + <| fun () -> foldTest context <@ (&&&) @> (=) + ptestCase "Reduce test atomic '&&&' on int64" + <| fun () -> foldTest context <@ (&&&) @> (=) + + testCase "Reduce test atomic '|||' on int" + <| fun () -> foldTest context <@ (|||) @> (=) + ptestCase "Reduce test atomic '|||' on int64" + <| fun () -> foldTest context <@ (|||) @> (=) + + testCase "Reduce test atomic '^^^' on int" + <| fun () -> foldTest context <@ (^^^) @> (=) + ptestCase "Reduce test atomic '^^^' on int64" + <| fun () -> foldTest context <@ (^^^) @> (=) + + // WrappedInt (не работает транляция или типа того) + ptestCase "Fold test atomic 'add' on WrappedInt" + <| fun () -> foldTest context <@ (+) @> (=) + ] let xchgTest<'a when 'a: equality and 'a: struct> context cmp value = let localSize = Settings.wgSize @@ -287,8 +297,10 @@ let xchgTest<'a when 'a: equality and 'a: struct> context cmp value = opencl { use! buffer = ClArray.toDevice - [| for i = 0 to localSize - 1 do - if i < localSize / 2 then cmp else value |] + [| + for i = 0 to localSize - 1 do + if i < localSize / 2 then cmp else value + |] do! runCommand kernel @@ -301,11 +313,13 @@ let xchgTest<'a when 'a: equality and 'a: struct> context cmp value = "Results should be equal" |> Expect.sequenceEqual actual expected let xchgTestCases context = - [ testCase "Xchg test on int" <| fun () -> xchgTest context 0 256 - testCase "Xchg test on float" <| fun () -> xchgTest context 0. 256. - testCase "Xchg test on bool" <| fun () -> xchgTest context false true - ptestCase "Xchg test on WrappedInt" - <| fun () -> xchgTest context (WrappedInt 0) (WrappedInt 256) ] + [ + testCase "Xchg test on int" <| fun () -> xchgTest context 0 256 + testCase "Xchg test on float" <| fun () -> xchgTest context 0. 256. + testCase "Xchg test on bool" <| fun () -> xchgTest context false true + ptestCase "Xchg test on WrappedInt" + <| fun () -> xchgTest context (WrappedInt 0) (WrappedInt 256) + ] // TODO barrier broken let perfomanceTest context = @@ -360,8 +374,10 @@ let perfomanceTest context = |> Expect.isFasterThan (prepare kernelUsingNativeInc) (prepare kernelUsingCustomInc) let tests context = - [ testList "Stress tests" << stressTestCases - ptestList "Fold tests" << foldTestCases - ptestList "Xchg tests" << xchgTestCases - ptestCase "Perfomance test on 'inc'" << perfomanceTest ] + [ + testList "Stress tests" << stressTestCases + ptestList "Fold tests" << foldTestCases + ptestList "Xchg tests" << xchgTestCases + ptestCase "Perfomance test on 'inc'" << perfomanceTest + ] |> List.map (fun testFixture -> testFixture context) diff --git a/tests/Brahma.FSharp.Tests/ExecutionTests/CompilationTests.fs b/tests/Brahma.FSharp.Tests/ExecutionTests/CompilationTests.fs index d7892cf2..12182842 100644 --- a/tests/Brahma.FSharp.Tests/ExecutionTests/CompilationTests.fs +++ b/tests/Brahma.FSharp.Tests/ExecutionTests/CompilationTests.fs @@ -27,24 +27,25 @@ module Helpers = Utils.filesAreEqual targetPath expectedPath let simpleTests context = - [ let inline checkCode command outFile expected = - checkCode context command outFile expected + [ + let inline checkCode command outFile expected = checkCode context command outFile expected - testCase "Pointers to private values should be explicitly private" - <| fun () -> - let command = - <@ - fun (k: Range1D) (a: int clarray) -> - let x (a: int) = a + 1 + testCase "Pointers to private values should be explicitly private" + <| fun () -> + let command = + <@ + fun (k: Range1D) (a: int clarray) -> + let x (a: int) = a + 1 - let mutable s = 1 - let mutable s = 2 - let s1 = x s + let mutable s = 1 + let mutable s = 2 + let s1 = x s - a.[0] <- s1 - @> + a.[0] <- s1 + @> - checkCode command "GenericSpace.gen" "GenericSpace.cl" ] + checkCode command "GenericSpace.gen" "GenericSpace.cl" + ] type SimpleUnion = | SimpleOne @@ -69,105 +70,115 @@ let unionTests context = testCase name <| fun () -> checkCode context command outFile expectedFile let newUnionTestList = - [ testGen - testCase - "Test 1: TranslateTest.A" - "Union.Compile.Test1.gen" - "Union.Compile.Test1.cl" - <@ - fun (range: Range1D) -> - let x = A(5, 6.0) - let mutable y = 5 - y <- 7 - @> - - testGen - ptestCase // TODO(https://github.com/YaccConstructor/Brahma.FSharp/issues/152) - "Test 2: TranslateTest.B" - "Union.Compile.Test2.gen" - "Union.Compile.Test2.cl" - <@ - fun (range: Range1D) -> - let x = B(5.0) - let mutable y = 5 - y <- 7 - @> - - testGen - testCase - "Test 3: TranslateTest.C" - "Union.Compile.Test3.gen" - "Union.Compile.Test3.cl" - <@ - fun (range: Range1D) -> - let x = C - let mutable y = 5 - y <- 7 - @> - - testGen - testCase - "Test 4: OuterUnion.Outer" - "Union.Compile.Test4.gen" - "Union.Compile.Test4.cl" - <@ - fun (range: Range1D) -> - let x = Inner SimpleOne - let mutable y = 5 - y <- 7 - @> - - testGen - testCase - "Test 5: OuterUnion.Inner" - "Union.Compile.Test5.gen" - "Union.Compile.Test5.cl" - <@ - fun (range: Range1D) -> - let x = Inner(SimpleTwo 29) - let mutable y = 5 - y <- 7 - @> ] + [ + testGen + testCase + "Test 1: TranslateTest.A" + "Union.Compile.Test1.gen" + "Union.Compile.Test1.cl" + <@ + fun (range: Range1D) -> + let x = A(5, 6.0) + let mutable y = 5 + y <- 7 + @> + + testGen + ptestCase // TODO(https://github.com/YaccConstructor/Brahma.FSharp/issues/152) + "Test 2: TranslateTest.B" + "Union.Compile.Test2.gen" + "Union.Compile.Test2.cl" + <@ + fun (range: Range1D) -> + let x = B(5.0) + let mutable y = 5 + y <- 7 + @> + + testGen + testCase + "Test 3: TranslateTest.C" + "Union.Compile.Test3.gen" + "Union.Compile.Test3.cl" + <@ + fun (range: Range1D) -> + let x = C + let mutable y = 5 + y <- 7 + @> + + testGen + testCase + "Test 4: OuterUnion.Outer" + "Union.Compile.Test4.gen" + "Union.Compile.Test4.cl" + <@ + fun (range: Range1D) -> + let x = Inner SimpleOne + let mutable y = 5 + y <- 7 + @> + + testGen + testCase + "Test 5: OuterUnion.Inner" + "Union.Compile.Test5.gen" + "Union.Compile.Test5.cl" + <@ + fun (range: Range1D) -> + let x = Inner(SimpleTwo 29) + let mutable y = 5 + y <- 7 + @> + ] let testUnionCaseTestLists = - [ testGen - ptestCase // TODO(https://github.com/YaccConstructor/Brahma.FSharp/issues/152) - "Test 1: simple pattern matching" - "Union.Compile.Test6.gen" - "Union.Compile.Test6.cl" - <@ - fun (range: Range1D) -> - let t = Case1 - let mutable x = 5 - - match t with - | Case1 -> x <- 5 - | Case2(_) -> x <- 6 - | Case3(_) -> x <- 7 - @> ] + [ + testGen + ptestCase // TODO(https://github.com/YaccConstructor/Brahma.FSharp/issues/152) + "Test 1: simple pattern matching" + "Union.Compile.Test6.gen" + "Union.Compile.Test6.cl" + <@ + fun (range: Range1D) -> + let t = Case1 + let mutable x = 5 + + match t with + | Case1 -> x <- 5 + | Case2(_) -> x <- 6 + | Case3(_) -> x <- 7 + @> + ] let unionPropertyGetTestLists = - [ testGen - ptestCase // TODO(https://github.com/YaccConstructor/Brahma.FSharp/issues/152) - "Test 1: simple pattern matching bindings" - "Union.Compile.Test7.gen" - "Union.Compile.Test7.cl" - <@ - fun (range: Range1D) -> - let t = Case1 - let mutable m = 5 - - match t with - | Case1 -> m <- 5 - | Case2(x) -> m <- x - | Case3(y, z) -> m <- y + z - @> ] - - [ testList "NewUnion" newUnionTestList - testList "TestUnionCase" testUnionCaseTestLists - testList "UnionPropertyGet" unionPropertyGetTestLists ] + [ + testGen + ptestCase // TODO(https://github.com/YaccConstructor/Brahma.FSharp/issues/152) + "Test 1: simple pattern matching bindings" + "Union.Compile.Test7.gen" + "Union.Compile.Test7.cl" + <@ + fun (range: Range1D) -> + let t = Case1 + let mutable m = 5 + + match t with + | Case1 -> m <- 5 + | Case2(x) -> m <- x + | Case3(y, z) -> m <- y + z + @> + ] + + [ + testList "NewUnion" newUnionTestList + testList "TestUnionCase" testUnionCaseTestLists + testList "UnionPropertyGet" unionPropertyGetTestLists + ] let tests context = - [ testList "Simple tests" << simpleTests - testList "Union Compile tests" << unionTests ] + [ + testList "Simple tests" << simpleTests + testList "Union Compile tests" << unionTests + ] |> List.map (fun testFixture -> testFixture context) diff --git a/tests/Brahma.FSharp.Tests/ExecutionTests/CompositeTypesTests.fs b/tests/Brahma.FSharp.Tests/ExecutionTests/CompositeTypesTests.fs index e85c1267..1ae7e05e 100644 --- a/tests/Brahma.FSharp.Tests/ExecutionTests/CompositeTypesTests.fs +++ b/tests/Brahma.FSharp.Tests/ExecutionTests/CompositeTypesTests.fs @@ -53,125 +53,156 @@ type GenericStruct<'a, 'b> = new(x, y) = { X = x; Y = y } let tupleTestCases context = - [ let inline check data command = check context data command - - let inline command length = - <@ - fun (gid: int) (buffer: clarray) -> - if gid < length then - let struct (a, b) = buffer.[gid] - buffer.[gid] <- struct (a, b) - @> - - testProperty (message "struct(int * int)") - <| fun (data: struct (int * int)[]) -> - if data.Length <> 0 then - check data (fun length -> - <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @>) - - testProperty (message "struct(int * int64)") - <| fun (data: struct (int * int64)[]) -> - if data.Length <> 0 then - check data (fun length -> - <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @>) - - testProperty (message "struct(bool * bool") - <| fun (data: struct (bool * bool)[]) -> - if data.Length <> 0 then - check data (fun length -> - <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @>) - - testProperty (message "struct((int * int) * (int * int))") - <| fun (data: struct ((int * int) * (int * int))[]) -> - if data.Length <> 0 then - check data (fun length -> - <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @>) - - testProperty (message "struct((int * int64) * (bool * bool))") - <| fun (data: struct ((int * int64) * (bool * bool))[]) -> - if data.Length <> 0 then - check data (fun length -> - <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @>) - - testProperty (message "struct(RecordOfIntInt64 * RecordOfBoolBool)") - <| fun (data: struct (RecordOfIntInt64 * RecordOfBoolBool)[]) -> - if data.Length <> 0 then - check data (fun length -> - <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @>) - - testProperty (message "struct(GenericRecord * GenericRecord)") - <| fun (data: struct (GenericRecord * GenericRecord)[]) -> - if data.Length <> 0 then - check data (fun length -> - <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @>) - - testProperty (message "struct(int * int64 * bool)") - <| fun (data: struct (int * int64 * bool)[]) -> - if data.Length <> 0 then - check data - <| fun length -> - <@ - fun (range: Range1D) (buffer: ClArray<_>) -> - let gid = range.GlobalID0 - - if gid < length then - let struct (a1, a2, a3) = buffer.[gid] - buffer.[gid] <- struct (a1, a2, a3) - @> - - testProperty "Simple test on big tuple (of size 10)" - <| fun (data: struct (int * int * int * int * int * int * int * int * int * int)[]) -> - if data.Length <> 0 then - check data - <| fun length -> - <@ - fun (range: Range1D) (buffer: ClArray<_>) -> - let gid = range.GlobalID0 - - if gid < length then - let struct (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) = buffer.[gid] - buffer.[gid] <- struct (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) - @> - - testProperty "Test on inner tuples deconstruction" - <| fun (data: struct ((int * int) * (int * int))[]) -> - if data.Length <> 0 then - check data - <| fun length -> - <@ - fun (range: Range1D) (buffer: ClArray<_>) -> - let gid = range.GlobalID0 - - if gid < length then - let struct ((a, b), (c, d)) = buffer.[gid] - buffer.[gid] <- struct ((a, b), (c, d)) - @> ] + [ + let inline check data command = check context data command + + let inline command length = + <@ + fun (gid: int) (buffer: clarray) -> + if gid < length then + let struct (a, b) = buffer.[gid] + buffer.[gid] <- struct (a, b) + @> + + testProperty (message "struct(int * int)") + <| fun (data: struct (int * int)[]) -> + if data.Length <> 0 then + check + data + (fun length -> + <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @> + ) + + testProperty (message "struct(int * int64)") + <| fun (data: struct (int * int64)[]) -> + if data.Length <> 0 then + check + data + (fun length -> + <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @> + ) + + testProperty (message "struct(bool * bool") + <| fun (data: struct (bool * bool)[]) -> + if data.Length <> 0 then + check + data + (fun length -> + <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @> + ) + + testProperty (message "struct((int * int) * (int * int))") + <| fun (data: struct ((int * int) * (int * int))[]) -> + if data.Length <> 0 then + check + data + (fun length -> + <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @> + ) + + testProperty (message "struct((int * int64) * (bool * bool))") + <| fun (data: struct ((int * int64) * (bool * bool))[]) -> + if data.Length <> 0 then + check + data + (fun length -> + <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @> + ) + + testProperty (message "struct(RecordOfIntInt64 * RecordOfBoolBool)") + <| fun (data: struct (RecordOfIntInt64 * RecordOfBoolBool)[]) -> + if data.Length <> 0 then + check + data + (fun length -> + <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @> + ) + + testProperty (message "struct(GenericRecord * GenericRecord)") + <| fun (data: struct (GenericRecord * GenericRecord)[]) -> + if data.Length <> 0 then + check + data + (fun length -> + <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @> + ) + + testProperty (message "struct(int * int64 * bool)") + <| fun (data: struct (int * int64 * bool)[]) -> + if data.Length <> 0 then + check data + <| fun length -> + <@ + fun (range: Range1D) (buffer: ClArray<_>) -> + let gid = range.GlobalID0 + + if gid < length then + let struct (a1, a2, a3) = buffer.[gid] + buffer.[gid] <- struct (a1, a2, a3) + @> + + testProperty "Simple test on big tuple (of size 10)" + <| fun (data: struct (int * int * int * int * int * int * int * int * int * int)[]) -> + if data.Length <> 0 then + check data + <| fun length -> + <@ + fun (range: Range1D) (buffer: ClArray<_>) -> + let gid = range.GlobalID0 + + if gid < length then + let struct (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) = buffer.[gid] + buffer.[gid] <- struct (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) + @> + + testProperty "Test on inner tuples deconstruction" + <| fun (data: struct ((int * int) * (int * int))[]) -> + if data.Length <> 0 then + check data + <| fun length -> + <@ + fun (range: Range1D) (buffer: ClArray<_>) -> + let gid = range.GlobalID0 + + if gid < length then + let struct ((a, b), (c, d)) = buffer.[gid] + buffer.[gid] <- struct ((a, b), (c, d)) + @> + ] let recordTestCases context = - [ let inline check data command = check context data command - - let inline command length = - <@ - fun (gid: int) (buffer: ClArray>) -> - if gid < length then - let { X = x; Y = y } = buffer.[gid] - let mutable innerStruct = { X = x; Y = y } - innerStruct.X <- x - innerStruct.Y <- y - buffer.[gid] <- { X = innerStruct.X; Y = innerStruct.Y } - @> - - testProperty (message "GenericRecord") - <| fun (data: GenericRecord[]) -> - if data.Length <> 0 then - check data (fun length -> - <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @>) - - testProperty (message "GenericRecord<(int * int64), (bool * bool)>") - <| fun (data: GenericRecord<(int * int64), (bool * bool)>[]) -> - if data.Length <> 0 then - check data (fun length -> - <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @>) ] + [ + let inline check data command = check context data command + + let inline command length = + <@ + fun (gid: int) (buffer: ClArray>) -> + if gid < length then + let { X = x; Y = y } = buffer.[gid] + let mutable innerStruct = { X = x; Y = y } + innerStruct.X <- x + innerStruct.Y <- y + buffer.[gid] <- { X = innerStruct.X; Y = innerStruct.Y } + @> + + testProperty (message "GenericRecord") + <| fun (data: GenericRecord[]) -> + if data.Length <> 0 then + check + data + (fun length -> + <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @> + ) + + testProperty (message "GenericRecord<(int * int64), (bool * bool)>") + <| fun (data: GenericRecord<(int * int64), (bool * bool)>[]) -> + if data.Length <> 0 then + check + data + (fun length -> + <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @> + ) + ] let genGenericStruct<'a, 'b> = gen { @@ -185,104 +216,110 @@ type GenericStructGenerator = static member GenericStruct() = Arb.fromGen genGenericStruct let structTests context = - [ let inline check data command = check context data command - - let inline checkResult cmd input expected = - RuntimeTests.Helpers.checkResult context cmd input expected - - testCase "Smoke test" - <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - if range.GlobalID0 = 0 then - let b = buf.[0] - buf.[0] <- buf.[1] - buf.[1] <- b - @> - - checkResult - command - [| StructOfIntInt64(1, 2L) - StructOfIntInt64(3, 4L) |] - [| StructOfIntInt64(3, 4L) - StructOfIntInt64(1, 2L) |] - - testCase "Struct constructor test" - <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: ClArray) -> buf.[0] <- StructOfIntInt64(5, 6L) @> - - checkResult - command - [| StructOfIntInt64(1, 2L) - StructOfIntInt64(3, 4L) |] - [| StructOfIntInt64(5, 6L) - StructOfIntInt64(3, 4L) |] - - testCase "Struct prop set" - <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - let mutable y = buf.[0] - y.X <- 5 - buf.[0] <- y - @> - - checkResult command [| StructOfIntInt64(1, 2L) |] [| StructOfIntInt64(5, 2L) |] - - testCase "Struct prop get" - <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - if range.GlobalID0 = 0 then - let mutable y = buf.[0] - y.X <- y.X + 3 - buf.[0] <- y - @> - - checkResult - command - [| StructOfIntInt64(1, 2L) - StructOfIntInt64(3, 4L) |] - [| StructOfIntInt64(4, 2L) - StructOfIntInt64(3, 4L) |] - - let inline command length = - <@ - fun (gid: int) (buffer: ClArray>) -> - if gid < length then - let tmp = buffer.[gid] - let x = tmp.X - let y = tmp.Y - let mutable innerStruct = GenericStruct(x, y) - innerStruct.X <- x - innerStruct.Y <- y - buffer.[gid] <- GenericStruct(innerStruct.X, innerStruct.Y) - @> - - let config = - { FsCheckConfig.defaultConfig with arbitrary = [ typeof ] } - - testPropertyWithConfig config (message "GenericStruct") - <| fun (data: GenericStruct[]) -> - if data.Length <> 0 then - check data (fun length -> - <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @>) - - testPropertyWithConfig config (message "GenericStruct<(int * int64), (bool * bool)>") - <| fun (data: GenericStruct<(int * int64), (bool * bool)>[]) -> - if data.Length <> 0 then - check data (fun length -> - <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @>) - - testPropertyWithConfig config (message "GenericStruct") - <| fun (data: GenericStruct[]) -> - if data.Length <> 0 then - check data (fun length -> - <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @>) ] + [ + let inline check data command = check context data command + + let inline checkResult cmd input expected = RuntimeTests.Helpers.checkResult context cmd input expected + + testCase "Smoke test" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + if range.GlobalID0 = 0 then + let b = buf.[0] + buf.[0] <- buf.[1] + buf.[1] <- b + @> + + checkResult + command + [| StructOfIntInt64(1, 2L); StructOfIntInt64(3, 4L) |] + [| StructOfIntInt64(3, 4L); StructOfIntInt64(1, 2L) |] + + testCase "Struct constructor test" + <| fun _ -> + let command = + <@ fun (range: Range1D) (buf: ClArray) -> buf.[0] <- StructOfIntInt64(5, 6L) @> + + checkResult + command + [| StructOfIntInt64(1, 2L); StructOfIntInt64(3, 4L) |] + [| StructOfIntInt64(5, 6L); StructOfIntInt64(3, 4L) |] + + testCase "Struct prop set" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + let mutable y = buf.[0] + y.X <- 5 + buf.[0] <- y + @> + + checkResult command [| StructOfIntInt64(1, 2L) |] [| StructOfIntInt64(5, 2L) |] + + testCase "Struct prop get" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + if range.GlobalID0 = 0 then + let mutable y = buf.[0] + y.X <- y.X + 3 + buf.[0] <- y + @> + + checkResult + command + [| StructOfIntInt64(1, 2L); StructOfIntInt64(3, 4L) |] + [| StructOfIntInt64(4, 2L); StructOfIntInt64(3, 4L) |] + + let inline command length = + <@ + fun (gid: int) (buffer: ClArray>) -> + if gid < length then + let tmp = buffer.[gid] + let x = tmp.X + let y = tmp.Y + let mutable innerStruct = GenericStruct(x, y) + innerStruct.X <- x + innerStruct.Y <- y + buffer.[gid] <- GenericStruct(innerStruct.X, innerStruct.Y) + @> + + let config = + { FsCheckConfig.defaultConfig with + arbitrary = [ typeof ] + } + + testPropertyWithConfig config (message "GenericStruct") + <| fun (data: GenericStruct[]) -> + if data.Length <> 0 then + check + data + (fun length -> + <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @> + ) + + testPropertyWithConfig config (message "GenericStruct<(int * int64), (bool * bool)>") + <| fun (data: GenericStruct<(int * int64), (bool * bool)>[]) -> + if data.Length <> 0 then + check + data + (fun length -> + <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @> + ) + + testPropertyWithConfig config (message "GenericStruct") + <| fun (data: GenericStruct[]) -> + if data.Length <> 0 then + check + data + (fun length -> + <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @> + ) + ] type SimpleDU = | A @@ -300,118 +337,122 @@ type EnumDU = | C let unionTests context = - [ let inline check data command = check context data command - - testProperty (message "Option>") - <| fun (data: Option>[]) -> - if data.Length <> 0 then - check data - <| fun length -> - <@ - fun (range: Range1D) (buffer: ClArray<_>) -> - let gid = range.GlobalID0 - - if gid < length then - buffer.[gid] <- - match buffer.[gid] with - | Some { X = x; Y = y } -> Some { X = x; Y = y } - | None -> None - @> - - testProperty (message "Option>") - <| fun (data: Option>[]) -> - if data.Length <> 0 then - check data - <| fun length -> - <@ - fun (range: Range1D) (buffer: ClArray<_>) -> - let gid = range.GlobalID0 - - if gid < length then - buffer.[gid] <- - match buffer.[gid] with - | Some a -> - match a with - | Some { X = x; Y = y } -> Some(Some { X = x; Y = y }) - | None -> Some None - | None -> None - @> - - testProperty (message "SimpleDU") - <| fun (data: SimpleDU[]) -> - if data.Length <> 0 then - check data - <| fun length -> - <@ - fun (range: Range1D) (buffer: ClArray<_>) -> - let gid = range.GlobalID0 - - if gid < length then - buffer.[gid] <- - match buffer.[gid] with - | SimpleDU.A -> SimpleDU.A - | SimpleDU.B x -> SimpleDU.B x - | SimpleDU.C(x, y) -> SimpleDU.C(x, y) - @> - - ptestProperty (message "GenericDU>") - <| fun (data: GenericDU>[]) -> - if data.Length <> 0 then - check data - <| fun length -> - <@ - fun (range: Range1D) (buffer: ClArray<_>) -> - let gid = range.GlobalID0 - - if gid < length then - buffer.[gid] <- - match buffer.[gid] with - | GenericDU.A -> GenericDU.A - | GenericDU.B x -> GenericDU.B x - | GenericDU.C { X = x; Y = y } -> - match y with - | Some b -> GenericDU.C { X = x; Y = Some b } - | None -> GenericDU.C { X = x; Y = None } - @> - - testProperty (message "GenericRecord, Option>") - <| fun (data: GenericRecord, Option>[]) -> - if data.Length <> 0 then - check data - <| fun length -> - <@ - fun (range: Range1D) (buffer: ClArray<_>) -> - let gid = range.GlobalID0 - - if gid < length then - buffer.[gid] <- - match buffer.[gid] with - | { X = Some x; Y = Some y } -> { X = Some x; Y = Some y } - | { X = Some x; Y = None } -> { X = Some x; Y = None } - | { X = None; Y = Some y } -> { X = None; Y = Some y } - | { X = None; Y = None } -> { X = None; Y = None } - @> - - testProperty (message "EnumDU") - <| fun (data: EnumDU[]) -> - if data.Length <> 0 then - check data - <| fun length -> - <@ - fun (range: Range1D) (buffer: ClArray<_>) -> - let gid = range.GlobalID0 - - if gid < length then - buffer.[gid] <- - match buffer.[gid] with - | EnumDU.A -> EnumDU.A - | EnumDU.B -> EnumDU.B - | EnumDU.C -> EnumDU.C - @> ] + [ + let inline check data command = check context data command + + testProperty (message "Option>") + <| fun (data: Option>[]) -> + if data.Length <> 0 then + check data + <| fun length -> + <@ + fun (range: Range1D) (buffer: ClArray<_>) -> + let gid = range.GlobalID0 + + if gid < length then + buffer.[gid] <- + match buffer.[gid] with + | Some { X = x; Y = y } -> Some { X = x; Y = y } + | None -> None + @> + + testProperty (message "Option>") + <| fun (data: Option>[]) -> + if data.Length <> 0 then + check data + <| fun length -> + <@ + fun (range: Range1D) (buffer: ClArray<_>) -> + let gid = range.GlobalID0 + + if gid < length then + buffer.[gid] <- + match buffer.[gid] with + | Some a -> + match a with + | Some { X = x; Y = y } -> Some(Some { X = x; Y = y }) + | None -> Some None + | None -> None + @> + + testProperty (message "SimpleDU") + <| fun (data: SimpleDU[]) -> + if data.Length <> 0 then + check data + <| fun length -> + <@ + fun (range: Range1D) (buffer: ClArray<_>) -> + let gid = range.GlobalID0 + + if gid < length then + buffer.[gid] <- + match buffer.[gid] with + | SimpleDU.A -> SimpleDU.A + | SimpleDU.B x -> SimpleDU.B x + | SimpleDU.C(x, y) -> SimpleDU.C(x, y) + @> + + ptestProperty (message "GenericDU>") + <| fun (data: GenericDU>[]) -> + if data.Length <> 0 then + check data + <| fun length -> + <@ + fun (range: Range1D) (buffer: ClArray<_>) -> + let gid = range.GlobalID0 + + if gid < length then + buffer.[gid] <- + match buffer.[gid] with + | GenericDU.A -> GenericDU.A + | GenericDU.B x -> GenericDU.B x + | GenericDU.C { X = x; Y = y } -> + match y with + | Some b -> GenericDU.C { X = x; Y = Some b } + | None -> GenericDU.C { X = x; Y = None } + @> + + testProperty (message "GenericRecord, Option>") + <| fun (data: GenericRecord, Option>[]) -> + if data.Length <> 0 then + check data + <| fun length -> + <@ + fun (range: Range1D) (buffer: ClArray<_>) -> + let gid = range.GlobalID0 + + if gid < length then + buffer.[gid] <- + match buffer.[gid] with + | { X = Some x; Y = Some y } -> { X = Some x; Y = Some y } + | { X = Some x; Y = None } -> { X = Some x; Y = None } + | { X = None; Y = Some y } -> { X = None; Y = Some y } + | { X = None; Y = None } -> { X = None; Y = None } + @> + + testProperty (message "EnumDU") + <| fun (data: EnumDU[]) -> + if data.Length <> 0 then + check data + <| fun length -> + <@ + fun (range: Range1D) (buffer: ClArray<_>) -> + let gid = range.GlobalID0 + + if gid < length then + buffer.[gid] <- + match buffer.[gid] with + | EnumDU.A -> EnumDU.A + | EnumDU.B -> EnumDU.B + | EnumDU.C -> EnumDU.C + @> + ] let tests context = - [ testList "Tuple tests" << tupleTestCases - testList "Record tests" << recordTestCases - testList "Struct tests" << structTests - testList "Union tests" << unionTests ] + [ + testList "Tuple tests" << tupleTestCases + testList "Record tests" << recordTestCases + testList "Struct tests" << structTests + testList "Union tests" << unionTests + ] |> List.map (fun testFixture -> testFixture context) diff --git a/tests/Brahma.FSharp.Tests/ExecutionTests/ExecutionTests.fs b/tests/Brahma.FSharp.Tests/ExecutionTests/ExecutionTests.fs index 900d9901..835b60e4 100644 --- a/tests/Brahma.FSharp.Tests/ExecutionTests/ExecutionTests.fs +++ b/tests/Brahma.FSharp.Tests/ExecutionTests/ExecutionTests.fs @@ -11,17 +11,22 @@ let allContexts = |> Seq.map (fun device -> let translator = FSQuotationToOpenCLTranslator(device) let clContext = ClContext(device, translator) - RuntimeContext(clContext)) + RuntimeContext(clContext) + ) let tests = - [ for context in allContexts do - yield! - [ testList $"System tests with running kernels on %A{context}" - <| RuntimeTests.tests context - testList $"Compilation tests on %A{context}" <| CompilationTests.tests context - testList $"Tests on 'opencl' computation exression on %A{context}" - <| WorkflowBuilderTests.tests context - ptestList $"Tests on atomic functions on %A{context}" - <| AtomicTests.tests context - testList $"Tests on composite types on %A{context}" - <| CompositeTypesTests.tests context ] ] + [ + for context in allContexts do + yield! + [ + testList $"System tests with running kernels on %A{context}" + <| RuntimeTests.tests context + testList $"Compilation tests on %A{context}" <| CompilationTests.tests context + testList $"Tests on 'opencl' computation exression on %A{context}" + <| WorkflowBuilderTests.tests context + ptestList $"Tests on atomic functions on %A{context}" + <| AtomicTests.tests context + testList $"Tests on composite types on %A{context}" + <| CompositeTypesTests.tests context + ] + ] diff --git a/tests/Brahma.FSharp.Tests/ExecutionTests/RuntimeTests.fs b/tests/Brahma.FSharp.Tests/ExecutionTests/RuntimeTests.fs index 3c0152e8..ece9cec7 100644 --- a/tests/Brahma.FSharp.Tests/ExecutionTests/RuntimeTests.fs +++ b/tests/Brahma.FSharp.Tests/ExecutionTests/RuntimeTests.fs @@ -28,334 +28,226 @@ module Helpers = let logger = Log.create "FullTests" let smokeTestsOnPrimitiveTypes context = - [ let inline checkResult cmd input expected = checkResult context cmd input expected - - testCase "Array item set" - <| fun _ -> - let command = <@ fun (range: Range1D) (buf: ClArray) -> buf.[0] <- 1 @> - - checkResult - command - intInArr - [| 1 - 1 - 2 - 3 |] - - testCase "Array item set. Long" - <| fun _ -> - let command = <@ fun (range: Range1D) (buf: ClArray<_>) -> buf.[0] <- 1L @> - - checkResult - command - [| 0L - 1L - 2L - 3L |] - [| 1L - 1L - 2L - 3L |] - - testCase "Array item set. ULong" - <| fun _ -> - let command = <@ fun (range: Range1D) (buf: ClArray) -> buf.[0] <- 1UL @> - - checkResult - command - [| 0UL - 1UL - 2UL - 3UL |] - [| 1UL - 1UL - 2UL - 3UL |] - - testCase "Array item set. Sbyte" - <| fun _ -> - let command = <@ fun (range: Range1D) (buf: ClArray) -> buf.[0] <- 1y @> - - checkResult - command - [| 0y - 1y - 2y - 3y |] - [| 1y - 1y - 2y - 3y |] - - testCase "Array item set. Sequential operations" - <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - buf.[0] <- 2 - buf.[1] <- 4 - @> - - checkResult - command - intInArr - [| 2 - 4 - 2 - 3 |] - - testCase "Byte type support with overflow" - <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - if range.GlobalID0 = 0 then - buf.[0] <- buf.[0] + 1uy - buf.[1] <- buf.[1] + 1uy - buf.[2] <- buf.[2] + 1uy - @> - - checkResult - command - [| 0uy - 255uy - 254uy |] - [| 1uy - 0uy - 255uy |] ] + [ + let inline checkResult cmd input expected = checkResult context cmd input expected + + testCase "Array item set" + <| fun _ -> + let command = <@ fun (range: Range1D) (buf: ClArray) -> buf.[0] <- 1 @> + + checkResult command intInArr [| 1; 1; 2; 3 |] + + testCase "Array item set. Long" + <| fun _ -> + let command = <@ fun (range: Range1D) (buf: ClArray<_>) -> buf.[0] <- 1L @> + + checkResult command [| 0L; 1L; 2L; 3L |] [| 1L; 1L; 2L; 3L |] + + testCase "Array item set. ULong" + <| fun _ -> + let command = <@ fun (range: Range1D) (buf: ClArray) -> buf.[0] <- 1UL @> + + checkResult command [| 0UL; 1UL; 2UL; 3UL |] [| 1UL; 1UL; 2UL; 3UL |] + + testCase "Array item set. Sbyte" + <| fun _ -> + let command = <@ fun (range: Range1D) (buf: ClArray) -> buf.[0] <- 1y @> + + checkResult command [| 0y; 1y; 2y; 3y |] [| 1y; 1y; 2y; 3y |] + + testCase "Array item set. Sequential operations" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + buf.[0] <- 2 + buf.[1] <- 4 + @> + + checkResult command intInArr [| 2; 4; 2; 3 |] + + testCase "Byte type support with overflow" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + if range.GlobalID0 = 0 then + buf.[0] <- buf.[0] + 1uy + buf.[1] <- buf.[1] + 1uy + buf.[2] <- buf.[2] + 1uy + @> + + checkResult command [| 0uy; 255uy; 254uy |] [| 1uy; 0uy; 255uy |] + ] let typeCastingTests context = - [ let inline checkResult cmd input expected = checkResult context cmd input expected - - testCase "uint64 -> int64" - <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: ClArray) -> buf.[0] <- int64 1UL @> - - checkResult - command - [| 0L - 1L |] - [| 1L - 1L |] - - testCase "int64 -> uint64" - <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: ClArray) -> buf.[0] <- uint64 1L @> - - checkResult - command - [| 0UL - 1UL |] - [| 1UL - 1UL |] - - testCase "byte -> float -> byte" - <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - if range.GlobalID0 = 0 then - buf.[0] <- byte (float buf.[0]) - buf.[1] <- byte (float buf.[1]) - buf.[2] <- byte (float buf.[2]) - @> - - checkResult - command - [| 0uy - 255uy - 254uy |] - [| 0uy - 255uy - 254uy |] - - // test fail on Intel platform: - // Actual: [1uy, 255uy, 255uy] - ptestCase "Byte and float 2" - <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - if range.GlobalID0 = 0 then - buf.[0] <- byte ((float buf.[0]) + 1.0) - buf.[1] <- byte ((float buf.[1]) + 1.0) - buf.[2] <- byte ((float buf.[2]) + 1.0) - @> - - checkResult - command - [| 0uy - 255uy - 254uy |] - [| 1uy - 0uy - 255uy |] - - // test failed on Intel platform: - // Actual : [1uy, 1uy, 1uy] - ptestCase "Byte and float in condition" - <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - if range.GlobalID0 = 0 then - let x = if true then buf.[0] + 1uy else buf.[0] + 1uy - buf.[0] <- x - let y = if true then buf.[1] + 1uy else buf.[1] + 1uy - buf.[1] <- y - let z = if true then buf.[2] + 1uy else buf.[2] + 1uy - buf.[2] <- z - @> - - checkResult - command - [| 0uy - 255uy - 254uy |] - [| 1uy - 0uy - 255uy |] - - // test failed on Intel platform due to exception - ptestCase "Byte and float in condition 2" - <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - if range.GlobalID0 = 0 then - let x = - if true then - let g = 1uy - buf.[0] + g - else - buf.[0] + 1uy - - buf.[0] <- x - - let y = - if true then - let g = 1uy - buf.[1] + g - else - buf.[1] + 1uy - - buf.[1] <- y - - let z = - if true then - let g = 1uy - buf.[2] + g - else - buf.[2] + 1uy - - buf.[2] <- z - @> - - checkResult - command - [| 0uy - 255uy - 254uy |] - [| 1uy - 0uy - 255uy |] ] + [ + let inline checkResult cmd input expected = checkResult context cmd input expected + + testCase "uint64 -> int64" + <| fun _ -> + let command = + <@ fun (range: Range1D) (buf: ClArray) -> buf.[0] <- int64 1UL @> + + checkResult command [| 0L; 1L |] [| 1L; 1L |] + + testCase "int64 -> uint64" + <| fun _ -> + let command = + <@ fun (range: Range1D) (buf: ClArray) -> buf.[0] <- uint64 1L @> + + checkResult command [| 0UL; 1UL |] [| 1UL; 1UL |] + + testCase "byte -> float -> byte" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + if range.GlobalID0 = 0 then + buf.[0] <- byte (float buf.[0]) + buf.[1] <- byte (float buf.[1]) + buf.[2] <- byte (float buf.[2]) + @> + + checkResult command [| 0uy; 255uy; 254uy |] [| 0uy; 255uy; 254uy |] + + // test fail on Intel platform: + // Actual: [1uy, 255uy, 255uy] + ptestCase "Byte and float 2" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + if range.GlobalID0 = 0 then + buf.[0] <- byte ((float buf.[0]) + 1.0) + buf.[1] <- byte ((float buf.[1]) + 1.0) + buf.[2] <- byte ((float buf.[2]) + 1.0) + @> + + checkResult command [| 0uy; 255uy; 254uy |] [| 1uy; 0uy; 255uy |] + + // test failed on Intel platform: + // Actual : [1uy, 1uy, 1uy] + ptestCase "Byte and float in condition" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + if range.GlobalID0 = 0 then + let x = if true then buf.[0] + 1uy else buf.[0] + 1uy + buf.[0] <- x + let y = if true then buf.[1] + 1uy else buf.[1] + 1uy + buf.[1] <- y + let z = if true then buf.[2] + 1uy else buf.[2] + 1uy + buf.[2] <- z + @> + + checkResult command [| 0uy; 255uy; 254uy |] [| 1uy; 0uy; 255uy |] + + // test failed on Intel platform due to exception + ptestCase "Byte and float in condition 2" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + if range.GlobalID0 = 0 then + let x = + if true then + let g = 1uy + buf.[0] + g + else + buf.[0] + 1uy + + buf.[0] <- x + + let y = + if true then + let g = 1uy + buf.[1] + g + else + buf.[1] + 1uy + + buf.[1] <- y + + let z = + if true then + let g = 1uy + buf.[2] + g + else + buf.[2] + 1uy + + buf.[2] <- z + @> + + checkResult command [| 0uy; 255uy; 254uy |] [| 1uy; 0uy; 255uy |] + ] let bindingTests context = - [ let inline checkResult cmd input expected = checkResult context cmd input expected - - testCase "Bindings. Simple" - <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - let x = 1 - buf.[0] <- x - @> - - checkResult - command - intInArr - [| 1 - 1 - 2 - 3 |] - - testCase "Bindings. Sequential bindings" - <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - let x = 1 - let y = x + 1 - buf.[0] <- y - @> - - checkResult - command - intInArr - [| 2 - 1 - 2 - 3 |] - - testCase "Bindings. Binding in IF" - <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - if 2 = 0 then - let x = 1 - buf.[0] <- x - else - let i = 2 - buf.[0] <- i - @> - - checkResult - command - intInArr - [| 2 - 1 - 2 - 3 |] - - testCase "Bindings. Binding in FOR" - <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - for i in 0..3 do - let x = i * i - buf.[i] <- x - @> - - checkResult - command - intInArr - [| 0 - 1 - 4 - 9 |] - - testCase "Bindings. Binding in WHILE" - <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - while buf.[0] < 5 do - let x = buf.[0] + 1 - buf.[0] <- x * x - @> - - checkResult - command - intInArr - [| 25 - 1 - 2 - 3 |] ] + [ + let inline checkResult cmd input expected = checkResult context cmd input expected + + testCase "Bindings. Simple" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + let x = 1 + buf.[0] <- x + @> + + checkResult command intInArr [| 1; 1; 2; 3 |] + + testCase "Bindings. Sequential bindings" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + let x = 1 + let y = x + 1 + buf.[0] <- y + @> + + checkResult command intInArr [| 2; 1; 2; 3 |] + + testCase "Bindings. Binding in IF" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + if 2 = 0 then + let x = 1 + buf.[0] <- x + else + let i = 2 + buf.[0] <- i + @> + + checkResult command intInArr [| 2; 1; 2; 3 |] + + testCase "Bindings. Binding in FOR" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + for i in 0..3 do + let x = i * i + buf.[i] <- x + @> + + checkResult command intInArr [| 0; 1; 4; 9 |] + + testCase "Bindings. Binding in WHILE" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + while buf.[0] < 5 do + let x = buf.[0] + 1 + buf.[0] <- x * x + @> + + checkResult command intInArr [| 25; 1; 2; 3 |] + ] let operatorsAndMathFunctionsTests context = let inline checkResult cmd input expected = checkResult context cmd input expected @@ -422,1703 +314,1344 @@ let operatorsAndMathFunctionsTests context = Expect.sequenceEqual actual expected ":(" - [ binaryOpTestGen - testCase - "Boolean OR" - <@ (||) @> - [| true - false - false - true |] - [| false - true - false - true |] - [| true - true - false - true |] - - binaryOpTestGen - testCase - "Boolean AND" - <@ (&&) @> - [| true - false - false - true |] - [| false - true - false - true |] - [| false - false - false - true |] - - binaryOpTestGen - testCase - "Bitwise OR on int" - <@ (|||) @> - [| 1 - 0 - 0 - 1 |] - [| 0 - 1 - 0 - 1 |] - [| 1 - 1 - 0 - 1 |] - - binaryOpTestGen - testCase - "Bitwise AND on int" - <@ (&&&) @> - [| 1 - 0 - 0 - 1 |] - [| 0 - 1 - 0 - 1 |] - [| 0 - 0 - 0 - 1 |] - - binaryOpTestGen - testCase - "Bitwise XOR on int" - <@ (^^^) @> - [| 1 - 0 - 0 - 1 |] - [| 0 - 1 - 0 - 1 |] - [| 1 - 1 - 0 - 0 |] - - binaryOpTestGen - testCase - "Arithmetic PLUS on int" - <@ (+) @> - [| 1 - 2 - 3 - 4 |] - [| 5 - 6 - 7 - 8 |] - [| 6 - 8 - 10 - 12 |] - - unaryOpTestGen testCase "Bitwise NEGATION on int" <@ (~~~) @> - <|| ([| 1 - 10 - 99 - 0 |] - |> fun array -> array, array |> Array.map (fun x -> -x - 1)) - - binaryOpTestGen - testCase - "MAX on float32" - <@ max @> - [| 1.f - 2.f - 3.f - 4.f |] - [| 5.f - 6.f - 7.f - 8.f |] - [| 5.f - 6.f - 7.f - 8.f |] - - binaryOpTestGen - testCase - "MIN on float32" - <@ min @> - [| 1.f - 2.f - 3.f - 4.f |] - [| 5.f - 6.f - 7.f - 8.f |] - [| 1.f - 2.f - 3.f - 4.f |] - - ptestCase "MAX on int16 with const" - <| fun () -> - let command = - <@ - fun (range: Range1D) (buf: int16 clarray) -> - let gid = range.GlobalID0 - buf.[gid] <- max buf.[gid] 1s - @> - - let inA = - [| 0s - 1s - 2s - 3s |] - - checkResult command inA (Array.map (max 1s) inA) - - // Failed: due to precision - ptestCase "Math sin" - <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - let i = range.GlobalID0 - buf.[i] <- System.Math.Sin(float buf.[i]) - @> - - let inA = - [| 0.0 - 1.0 - 2.0 - 3.0 |] - - checkResult command inA (inA |> Array.map System.Math.Sin) ] //[|0.0; 0.841471; 0.9092974; 0.14112|] + [ + binaryOpTestGen + testCase + "Boolean OR" + <@ (||) @> + [| true; false; false; true |] + [| false; true; false; true |] + [| true; true; false; true |] + + binaryOpTestGen + testCase + "Boolean AND" + <@ (&&) @> + [| true; false; false; true |] + [| false; true; false; true |] + [| false; false; false; true |] + + binaryOpTestGen testCase "Bitwise OR on int" <@ (|||) @> [| 1; 0; 0; 1 |] [| 0; 1; 0; 1 |] [| 1; 1; 0; 1 |] + + binaryOpTestGen testCase "Bitwise AND on int" <@ (&&&) @> [| 1; 0; 0; 1 |] [| 0; 1; 0; 1 |] [| 0; 0; 0; 1 |] + + binaryOpTestGen testCase "Bitwise XOR on int" <@ (^^^) @> [| 1; 0; 0; 1 |] [| 0; 1; 0; 1 |] [| 1; 1; 0; 0 |] + + binaryOpTestGen testCase "Arithmetic PLUS on int" <@ (+) @> [| 1; 2; 3; 4 |] [| 5; 6; 7; 8 |] [| 6; 8; 10; 12 |] + + unaryOpTestGen testCase "Bitwise NEGATION on int" <@ (~~~) @> + <|| ([| 1; 10; 99; 0 |] |> fun array -> array, array |> Array.map (fun x -> -x - 1)) + + binaryOpTestGen + testCase + "MAX on float32" + <@ max @> + [| 1.f; 2.f; 3.f; 4.f |] + [| 5.f; 6.f; 7.f; 8.f |] + [| 5.f; 6.f; 7.f; 8.f |] + + binaryOpTestGen + testCase + "MIN on float32" + <@ min @> + [| 1.f; 2.f; 3.f; 4.f |] + [| 5.f; 6.f; 7.f; 8.f |] + [| 1.f; 2.f; 3.f; 4.f |] + + ptestCase "MAX on int16 with const" + <| fun () -> + let command = + <@ + fun (range: Range1D) (buf: int16 clarray) -> + let gid = range.GlobalID0 + buf.[gid] <- max buf.[gid] 1s + @> + + let inA = [| 0s; 1s; 2s; 3s |] + + checkResult command inA (Array.map (max 1s) inA) + + // Failed: due to precision + ptestCase "Math sin" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + let i = range.GlobalID0 + buf.[i] <- System.Math.Sin(float buf.[i]) + @> + + let inA = [| 0.0; 1.0; 2.0; 3.0 |] + + checkResult command inA (inA |> Array.map System.Math.Sin) + ] //[|0.0; 0.841471; 0.9092974; 0.14112|] let controlFlowTests context = - [ let inline checkResult cmd input expected = checkResult context cmd input expected - - testCase "Check 'if then' condition" - <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - if 0 = 2 then - buf.[0] <- 42 - @> - - checkResult - command - intInArr - [| 0 - 1 - 2 - 3 |] - - testCase "Check 'if then else' condition" - <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: ClArray) -> if 0 = 2 then buf.[0] <- 1 else buf.[0] <- 2 @> - - checkResult - command - intInArr - [| 2 - 1 - 2 - 3 |] - - testCase "Check 'for' integer loop" - <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - if range.GlobalID0 = 0 then - for i in 0..3 do - buf.[i] <- i - @> - - checkResult - command - intInArr - [| 0 - 1 - 2 - 3 |] - - testCase "Check 'for' integer loop with step" - <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - if range.GlobalID0 = 0 then - for i in 0..2..6 do - buf.[i / 2] <- i - @> - - checkResult - command - intInArr - [| 0 - 2 - 4 - 6 |] - - testCase "Check 'for' non-integer loop" - <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - if range.GlobalID0 = 0 then - for i in 0u .. 3u do - buf.[int i] <- i - @> - - checkResult - command - [| 0u - 0u - 0u - 0u |] - [| 0u - 1u - 2u - 3u |] - - testCase "Check simple 'while' loop" - <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - while buf.[0] < 5 do - buf.[0] <- buf.[0] + 1 - @> - - checkResult - command - intInArr - [| 5 - 1 - 2 - 3 |] - - testCase "Check 'while' loop inside 'for' integer loop" - <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - for i in 0..3 do - while buf.[i] < 10 do - buf.[i] <- buf.[i] * buf.[i] + 1 - @> - - checkResult - command - intInArr - [| 26 - 26 - 26 - 10 |] ] + [ + let inline checkResult cmd input expected = checkResult context cmd input expected + + testCase "Check 'if then' condition" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + if 0 = 2 then + buf.[0] <- 42 + @> + + checkResult command intInArr [| 0; 1; 2; 3 |] + + testCase "Check 'if then else' condition" + <| fun _ -> + let command = + <@ fun (range: Range1D) (buf: ClArray) -> if 0 = 2 then buf.[0] <- 1 else buf.[0] <- 2 @> + + checkResult command intInArr [| 2; 1; 2; 3 |] + + testCase "Check 'for' integer loop" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + if range.GlobalID0 = 0 then + for i in 0..3 do + buf.[i] <- i + @> + + checkResult command intInArr [| 0; 1; 2; 3 |] + + testCase "Check 'for' integer loop with step" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + if range.GlobalID0 = 0 then + for i in 0..2..6 do + buf.[i / 2] <- i + @> + + checkResult command intInArr [| 0; 2; 4; 6 |] + + testCase "Check 'for' non-integer loop" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + if range.GlobalID0 = 0 then + for i in 0u .. 3u do + buf.[int i] <- i + @> + + checkResult command [| 0u; 0u; 0u; 0u |] [| 0u; 1u; 2u; 3u |] + + testCase "Check simple 'while' loop" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + while buf.[0] < 5 do + buf.[0] <- buf.[0] + 1 + @> + + checkResult command intInArr [| 5; 1; 2; 3 |] + + testCase "Check 'while' loop inside 'for' integer loop" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + for i in 0..3 do + while buf.[i] < 10 do + buf.[i] <- buf.[i] * buf.[i] + 1 + @> + + checkResult command intInArr [| 26; 26; 26; 10 |] + ] let kernelArgumentsTests context = - [ let inline checkResult cmd input expected = checkResult context cmd input expected - - testCase "Simple 1D" - <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - let i = range.GlobalID0 - buf.[i] <- i + i - @> - - checkResult - command - intInArr - [| 0 - 2 - 4 - 6 |] - - testCase "Simple 1D with copy" - <| fun _ -> - let command = - <@ - fun (range: Range1D) (inBuf: ClArray) (outBuf: ClArray) -> - let i = range.GlobalID0 - outBuf.[i] <- inBuf.[i] - @> - - let expected = - [| 0 - 1 - 2 - 3 |] - - let actual = - opencl { - use! inBuf = ClArray.toDevice intInArr - - use! outBuf = - ClArray.toDevice - [| 0 - 0 - 0 - 0 |] - - do! runCommand command <| fun x -> x default1D inBuf outBuf - - return! ClArray.toHost inBuf - } - |> ClTask.runSync context - - Expect.sequenceEqual actual expected "Arrays should be equals" - - testCase "Simple 1D float" - <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - let i = range.GlobalID0 - buf.[i] <- buf.[i] * buf.[i] - @> - - checkResult - command - float32Arr - [| 0.0f - 1.0f - 4.0f - 9.0f |] - - testCase "Int as arg" - <| fun _ -> - let command = - <@ - fun (range: Range1D) x (buf: ClArray) -> - let i = range.GlobalID0 - buf.[i] <- x + x - @> - - let expected = - [| 4 - 4 - 4 - 4 |] - - let actual = - opencl { - use! inBuf = ClArray.toDevice intInArr - do! runCommand command <| fun x -> x default1D 2 inBuf - - return! ClArray.toHost inBuf - } - |> ClTask.runSync context - - Expect.sequenceEqual actual expected "Arrays should be equals" - - testCase "Sequential commands over single buffer" - <| fun _ -> - let command = <@ fun (range: Range1D) i x (buf: ClArray) -> buf.[i] <- x + x @> - - let expected = - [| 4 - 1 - 4 - 3 |] - - let actual = - opencl { - use! inArr = ClArray.toDevice intInArr - - do! runCommand command <| fun it -> it <| default1D <| 0 <| 2 <| inArr - - do! runCommand command <| fun it -> it <| default1D <| 2 <| 2 <| inArr - - return! ClArray.toHost inArr - } - |> ClTask.runSync context - - Expect.sequenceEqual actual expected "Arrays should be equals" - - ptestProperty "Parallel execution of kernel" - <| fun _const -> - let context = context.ClContext - let n = 4 - let l = 256 - - let getAllocator (context: ClContext) = - let kernel = - <@ - fun (r: Range1D) (buffer: ClArray) -> - let i = r.GlobalID0 - buffer.[i] <- _const - @> - - let k = context.Compile kernel - - fun (q: MailboxProcessor<_>) -> - let buf = context.CreateClArray(l, allocationMode = AllocationMode.AllocHostPtr) - let executable = k.GetKernel() - q.Post(Msg.MsgSetArguments(fun () -> executable.KernelFunc (Range1D(l, l)) buf)) - q.Post(Msg.CreateRunMsg<_, _>(executable)) - buf - - let allocator = getAllocator context - - let allocOnGPU (q: MailboxProcessor<_>) allocator = - let b = allocator q - let res = Array.zeroCreate l - q.PostAndReply(fun ch -> Msg.CreateToHostMsg(b, res, ch)) |> ignore - q.Post(Msg.CreateFreeMsg b) - res - - let actual = - Array.init n (fun _ -> context.QueueProvider.CreateQueue()) - |> Array.map (fun q -> async { return allocOnGPU q allocator }) - |> Async.Parallel - |> Async.RunSynchronously - - let expected = Array.init n (fun _ -> Array.create l _const) - - Expect.sequenceEqual actual expected "Arrays should be equals" ] + [ + let inline checkResult cmd input expected = checkResult context cmd input expected + + testCase "Simple 1D" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + let i = range.GlobalID0 + buf.[i] <- i + i + @> + + checkResult command intInArr [| 0; 2; 4; 6 |] + + testCase "Simple 1D with copy" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (inBuf: ClArray) (outBuf: ClArray) -> + let i = range.GlobalID0 + outBuf.[i] <- inBuf.[i] + @> + + let expected = [| 0; 1; 2; 3 |] + + let actual = + opencl { + use! inBuf = ClArray.toDevice intInArr + + use! outBuf = ClArray.toDevice [| 0; 0; 0; 0 |] + + do! runCommand command <| fun x -> x default1D inBuf outBuf + + return! ClArray.toHost inBuf + } + |> ClTask.runSync context + + Expect.sequenceEqual actual expected "Arrays should be equals" + + testCase "Simple 1D float" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + let i = range.GlobalID0 + buf.[i] <- buf.[i] * buf.[i] + @> + + checkResult command float32Arr [| 0.0f; 1.0f; 4.0f; 9.0f |] + + testCase "Int as arg" + <| fun _ -> + let command = + <@ + fun (range: Range1D) x (buf: ClArray) -> + let i = range.GlobalID0 + buf.[i] <- x + x + @> + + let expected = [| 4; 4; 4; 4 |] + + let actual = + opencl { + use! inBuf = ClArray.toDevice intInArr + do! runCommand command <| fun x -> x default1D 2 inBuf + + return! ClArray.toHost inBuf + } + |> ClTask.runSync context + + Expect.sequenceEqual actual expected "Arrays should be equals" + + testCase "Sequential commands over single buffer" + <| fun _ -> + let command = <@ fun (range: Range1D) i x (buf: ClArray) -> buf.[i] <- x + x @> + + let expected = [| 4; 1; 4; 3 |] + + let actual = + opencl { + use! inArr = ClArray.toDevice intInArr + + do! runCommand command <| fun it -> it <| default1D <| 0 <| 2 <| inArr + + do! runCommand command <| fun it -> it <| default1D <| 2 <| 2 <| inArr + + return! ClArray.toHost inArr + } + |> ClTask.runSync context + + Expect.sequenceEqual actual expected "Arrays should be equals" + + ptestProperty "Parallel execution of kernel" + <| fun _const -> + let context = context.ClContext + let n = 4 + let l = 256 + + let getAllocator (context: ClContext) = + let kernel = + <@ + fun (r: Range1D) (buffer: ClArray) -> + let i = r.GlobalID0 + buffer.[i] <- _const + @> + + let k = context.Compile kernel + + fun (q: MailboxProcessor<_>) -> + let buf = context.CreateClArray(l, allocationMode = AllocationMode.AllocHostPtr) + let executable = k.GetKernel() + q.Post(Msg.MsgSetArguments(fun () -> executable.KernelFunc (Range1D(l, l)) buf)) + q.Post(Msg.CreateRunMsg<_, _>(executable)) + buf + + let allocator = getAllocator context + + let allocOnGPU (q: MailboxProcessor<_>) allocator = + let b = allocator q + let res = Array.zeroCreate l + q.PostAndReply(fun ch -> Msg.CreateToHostMsg(b, res, ch)) |> ignore + q.Post(Msg.CreateFreeMsg b) + res + + let actual = + Array.init n (fun _ -> context.QueueProvider.CreateQueue()) + |> Array.map (fun q -> async { return allocOnGPU q allocator }) + |> Async.Parallel + |> Async.RunSynchronously + + let expected = Array.init n (fun _ -> Array.create l _const) + + Expect.sequenceEqual actual expected "Arrays should be equals" + ] let quotationInjectionTests context = - [ let inline checkResult cmd input expected = checkResult context cmd input expected - - testCase "Quotations injections 1" - <| fun _ -> - let myF = <@ fun x -> x * x @> - - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - buf.[0] <- (%myF) 2 - buf.[1] <- (%myF) 4 - @> - - checkResult - command - intInArr - [| 4 - 16 - 2 - 3 |] - - testCase "Quotations injections 2" - <| fun _ -> - let myF = <@ fun x y -> y - x @> - - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - buf.[0] <- (%myF) 2 5 - buf.[1] <- (%myF) 4 9 - @> - - checkResult - command - intInArr - [| 3 - 5 - 2 - 3 |] ] + [ + let inline checkResult cmd input expected = checkResult context cmd input expected + + testCase "Quotations injections 1" + <| fun _ -> + let myF = <@ fun x -> x * x @> + + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + buf.[0] <- (%myF) 2 + buf.[1] <- (%myF) 4 + @> + + checkResult command intInArr [| 4; 16; 2; 3 |] + + testCase "Quotations injections 2" + <| fun _ -> + let myF = <@ fun x y -> y - x @> + + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + buf.[0] <- (%myF) 2 5 + buf.[1] <- (%myF) 4 9 + @> + + checkResult command intInArr [| 3; 5; 2; 3 |] + ] let localMemTests context = - [ let inline checkResult cmd input expected = checkResult context cmd input expected - - // TODO: pointers to local data must be local too. - testCase "Local int. Work item counting" - <| fun _ -> - let command = - <@ - fun (range: Range1D) (output: ClArray) -> - let globalID = range.GlobalID0 - let mutable x = local () - - if globalID = 0 then - x <- 0 - - barrierLocal () - - atomic (+) x 1 |> ignore - // fetch local value before read, dont work without barrier - barrierLocal () - - if globalID = 0 then - output.[0] <- x - @> - - let expected = [| 5 |] - - let actual = - opencl { - use! inBuf = ClArray.toDevice [| 0 |] - do! runCommand command <| fun x -> x (Range1D(5, 5)) inBuf - - return! ClArray.toHost inBuf - } - |> ClTask.runSync context - - Expect.sequenceEqual actual expected "Arrays should be equals" - - testCase "Local array. Test 1" - <| fun _ -> - let localWorkSize = 5 - let globalWorkSize = 15 - - let command = - <@ - fun (range: Range1D) (input: ClArray) (output: ClArray) -> - let localBuf = localArray localWorkSize - - localBuf.[range.LocalID0] <- range.LocalID0 - barrierLocal () - output.[range.GlobalID0] <- localBuf.[(range.LocalID0 + 1) % localWorkSize] - @> - - - let expected = - [| for x in 1..localWorkSize -> x % localWorkSize |] - |> Array.replicate (globalWorkSize / localWorkSize) - |> Array.concat - - let actual = - opencl { - use! inBuf = ClArray.toDevice (Array.zeroCreate globalWorkSize) - use! outBuf = ClArray.toDevice (Array.zeroCreate globalWorkSize) - - do! - runCommand command - <| fun x -> x (Range1D(globalWorkSize, localWorkSize)) inBuf outBuf - - return! ClArray.toHost outBuf - } - |> ClTask.runSync context - - Expect.sequenceEqual actual expected "Arrays should be equals" - - ptestCase "Local array. Test 2" - <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - let localBuf = localArray 42 - atomic xchg localBuf.[0] 1L |> ignore - buf.[0] <- localBuf.[0] - @> - - checkResult - command - [| 0L - 1L - 2L - 3L |] - [| 1L - 1L - 2L - 3L |] ] + [ + let inline checkResult cmd input expected = checkResult context cmd input expected -let letTransformationTests context = - [ let inline checkResult cmd input expected = checkResult context cmd input expected - - testCase "Template Let Transformation Test 0" - <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - let f = 3 - buf.[0] <- f - @> - - checkResult - command - intInArr - [| 3 - 1 - 2 - 3 |] - - testCase "Template Let Transformation Test 1" - <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - let x = 4 - - let f = - let x = 3 - x - - buf.[0] <- x + f - @> - - checkResult - command - intInArr - [| 7 - 1 - 2 - 3 |] - - testCase "Template Let Transformation Test 1.2" - <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - let f y = - let x c b = b + c + 4 + y - x 2 3 - - buf.[0] <- f 1 - @> - - checkResult - command - intInArr - [| 10 - 1 - 2 - 3 |] - - testCase "Template Let Transformation Test 2" - <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - let f = - let x = - let y = 3 - y - - x - - buf.[0] <- f - @> - - checkResult - command - intInArr - [| 3 - 1 - 2 - 3 |] - - testCase "Template Let Transformation Test 3" - <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - let f = - let f = 5 - f - - buf.[0] <- f - @> - - checkResult - command - intInArr - [| 5 - 1 - 2 - 3 |] - - testCase "Template Let Transformation Test 4" - <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - let f = - let f = - let f = 5 - f - - f - - buf.[0] <- f - @> - - checkResult - command - intInArr - [| 5 - 1 - 2 - 3 |] - - testCase "Template Let Transformation Test 5" - <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - let f a b = - let x y z = y + z - x a b - - buf.[0] <- f 1 7 - @> - - checkResult - command - intInArr - [| 8 - 1 - 2 - 3 |] - - testCase "Template Let Transformation Test 6" - <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - let f x y = - let x = x - x + y - - buf.[0] <- f 7 8 - @> - - checkResult - command - intInArr - [| 15 - 1 - 2 - 3 |] - - testCase "Template Let Transformation Test 7" - <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - let f y = - let x y = 6 - y - x y - - buf.[0] <- f 7 - @> - - checkResult - command - intInArr - [| -1 - 1 - 2 - 3 |] - - testCase "Template Let Transformation Test 8" - <| fun _ -> - let command = - <@ - fun (range: Range1D) (m: ClArray) -> - let p = m.[0] - - let x n = - let l = m.[3] - let g k = k + m.[0] + m.[1] - - let r = - let y a = - let x = 5 - n + (g 4) - let z t = m.[2] + a - t - z (a + x + l) - - y 6 - - r + m.[3] - - if range.GlobalID0 = 0 then - m.[0] <- x 7 - @> - - checkResult - command - intInArr - [| -1 - 1 - 2 - 3 |] - - testCase "Template Let Transformation Test 9" - <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - let x n = - let r = 8 - let h = r + n - h - - buf.[0] <- x 9 - @> - - checkResult - command - intInArr - [| 17 - 1 - 2 - 3 |] - - testCase "Template Let Transformation Test 10" - <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - let p = 9 - - let x n b = - let t = 0 - n + b + t - - buf.[0] <- x 7 9 - @> - - checkResult - command - intInArr - [| 16 - 1 - 2 - 3 |] - - testCase "Template Let Transformation Test 11" - <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - let p = 1 - - let m = - let r (l: int) = l - r 9 - - let z (k: int) = k - buf.[0] <- m - @> - - checkResult - command - intInArr - [| 9 - 1 - 2 - 3 |] - - testCase "Template Let Transformation Test 12" - <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - let f x y = - let y = y - let y = y - let g x m = m + x - g x y - - buf.[0] <- f 1 7 - @> - - checkResult - command - intInArr - [| 8 - 1 - 2 - 3 |] - - testCase "Template Let Transformation Test 13" - <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - let f y = - let y = y - let y = y - let g (m: int) = m - g y - - buf.[0] <- f 7 - @> - - checkResult - command - intInArr - [| 7 - 1 - 2 - 3 |] - - testCase "Template Let Transformation Test 14" - <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - let f y = - let y = y - let y = y - - let g (m: int) = - let g r t = r + y - t - let n o = o - (g y 2) - n 5 - - g y - - let z y = y - 2 - buf.[0] <- f (z 7) - @> - - checkResult - command - intInArr - [| -3 - 1 - 2 - 3 |] - - testCase "Template Let Transformation Test 15" - <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - let f y = - let Argi index = if index = 0 then buf.[1] else buf.[2] - Argi y - - buf.[0] <- f 0 - @> - - checkResult - command - intInArr - [| 1 - 1 - 2 - 3 |] - - testCase "Template Let Transformation Test 16" - <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - let f y = - if y = 0 then - let z (a: int) = a - z 9 - else - buf.[2] - - buf.[0] <- f 0 - @> - - checkResult - command - intInArr - [| 9 - 1 - 2 - 3 |] - - testCase "Template Let Transformation Test 17" - <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - if range.GlobalID0 = 0 then - let f y = - let g = buf.[1] + 1 - y + g - - for i in 0..3 do - buf.[i] <- f i - @> - - checkResult - command - intInArr - [| 2 - 3 - 6 - 7 |] - - testCase "Template Let Transformation Test 18" - <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - for i in 0..3 do - let f = - let g = buf.[1] + 1 - i + g - - if range.GlobalID0 = 0 then - buf.[i] <- f - @> - - checkResult - command - intInArr - [| 2 - 3 - 6 - 7 |] - - testCase "Template Let Transformation Test 19" - <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - if range.GlobalID0 = 0 then - for i in 0..3 do - let f x = - let g = buf.[1] + x - i + g - - buf.[i] <- f 1 - @> - - checkResult - command - intInArr - [| 2 - 3 - 6 - 7 |] - - // TODO: perform range (1D, 2D, 3D) erasure when range is lifted. - ptestCase "Template Let Transformation Test 20" - <| fun _ -> - let command = - <@ - fun (range: Range1D) (m: ClArray) -> - let f x = range.GlobalID0 + x - m.[0] <- f 2 - @> - - checkResult - command - intInArr - [| 2 - 3 - 6 - 7 |] ] + // TODO: pointers to local data must be local too. + testCase "Local int. Work item counting" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (output: ClArray) -> + let globalID = range.GlobalID0 + let mutable x = local () -let letQuotationTransformerSystemTests context = - [ let inline checkResult cmd input expected = checkResult context cmd input expected - - testCase "Test 0" - <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - let mutable x = 1 - let f y = x <- y - f 10 - buf.[0] <- x - @> - - checkResult - command - intInArr - [| 10 - 1 - 2 - 3 |] - - testCase "Test 1" - <| fun _ -> - let command = - <@ - fun (range: Range1D) (buf: ClArray) -> - let mutable x = 1 - let f y = x <- x + y - f 10 - buf.[0] <- x - @> - - checkResult - command - intInArr - [| 11 - 1 - 2 - 3 |] - - testCase "Test 2" - <| fun _ -> - let command = - <@ - fun (range: Range1D) (arr: ClArray) -> - let f x = - let g y = y + 1 - g x - - arr.[0] <- f 2 - @> - - checkResult - command - intInArr - [| 3 - 1 - 2 - 3 |] - - testCase "Test 3" - <| fun _ -> - let command = - <@ - fun (range: Range1D) (arr: ClArray) -> - let f x = - let g y = y + x - g (x + 1) - - arr.[0] <- f 2 - @> - - checkResult - command - intInArr - [| 5 - 1 - 2 - 3 |] - - testCase "Test 4" - <| fun _ -> - let command = - <@ - fun (range: Range1D) (arr: ClArray) -> - let gid = range.GlobalID0 - - let x = - let mutable y = 0 - - let addToY x = y <- y + x - - for i in 0..5 do - addToY arr.[gid] - - y - - arr.[gid] <- x - @> - - checkResult - command - intInArr - [| 0 - 6 - 12 - 18 |] - - testCase "Test 5" - <| fun _ -> - let command = - <@ - fun (range: Range1D) (arr: ClArray) -> - let gid = range.GlobalID0 - - let mutable x = if 0 > 1 then 2 else 3 - - let mutable y = - for i in 0..4 do - x <- x + 1 - - x + 1 - - let z = x + y - - let f () = arr.[gid] <- x + y + z - f () - @> - - checkResult - command - intInArr - [| 34 - 34 - 34 - 34 |] ] + if globalID = 0 then + x <- 0 -let commonApiTests context = - [ let inline checkResult cmd input expected = checkResult context cmd input expected - - testCase "Check simple '|> ignore'" - <| fun () -> - let command = - <@ - fun (range: Range1D) (buffer: ClArray) -> - let gid = range.GlobalID0 - atomic inc buffer.[gid] |> ignore - @> - - checkResult command intInArr (intInArr |> Array.map ((+) 1)) - - // Lambda is not supported. - ptestCase "Forward pipe" - <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: ClArray) -> buf.[0] <- (1.25f |> int) @> - - checkResult - command - intInArr - [| 1 - 1 - 2 - 3 |] - - // Lambda is not supported. - ptestCase "Backward pipe" - <| fun _ -> - let command = - <@ fun (range: Range1D) (buf: ClArray) -> buf.[0] <- int <| 1.25f + 2.34f @> - - checkResult - command - intInArr - [| 3 - 1 - 2 - 3 |] - - testCase "Getting value of 'int clcell' should be correct" - <| fun () -> - let command = - <@ - fun (range: Range1D) (buffer: int clarray) (cell: int clcell) -> - let gid = range.GlobalID0 - buffer.[gid] <- cell.Value - @> - - let value = 10 - let expected = Array.replicate defaultInArrayLength value - - let actual = - opencl { - use! cell = ClCell.toDevice 10 - use! buffer = ClArray.alloc defaultInArrayLength - do! runCommand command <| fun it -> it <| default1D <| buffer <| cell - - return! ClArray.toHost buffer - } - |> ClTask.runSync context - - "Arrays should be equal" |> Expect.sequenceEqual actual expected - - // TODO test on getting Value property of non-clcell type - // TODO test on getting Item property on non-clarray type - - testCase "Setting value of 'int clcell' should be correct" - <| fun () -> - let value = 10 - let command = <@ fun (range: Range1D) (cell: int clcell) -> cell.Value <- value @> - - let actual = - opencl { - use! cell = ClCell.toDevice value - do! runCommand command <| fun it -> it <| default1D <| cell - - return! ClCell.toHost cell - } - |> ClTask.runSync context - - "Arrays should be equal" |> Expect.equal actual value - - testCase "Using 'int clcell' from inner function should work correctly" - <| fun () -> - let value = 10 - - let command = - <@ - fun (range: Range1D) (cell: int clcell) -> - let f () = - let x = cell.Value - cell.Value <- x - - f () - @> - - let actual = - opencl { - use! cell = ClCell.toDevice value - do! runCommand command <| fun it -> it <| default1D <| cell - - return! ClCell.toHost cell - } - |> ClTask.runSync context - - "Arrays should be equal" |> Expect.equal actual value - - testCase "Using 'int clcell' with native atomic operation should be correct" - <| fun () -> - let value = 10 - - let command = - <@ fun (range: Range1D) (cell: int clcell) -> atomic (+) cell.Value value |> ignore @> - - let expected = value * default1D.GlobalWorkSize - - let actual = - opencl { - use! cell = ClCell.toDevice 0 - do! runCommand command <| fun it -> it <| default1D <| cell + barrierLocal () + + atomic (+) x 1 |> ignore + // fetch local value before read, dont work without barrier + barrierLocal () + + if globalID = 0 then + output.[0] <- x + @> + + let expected = [| 5 |] + + let actual = + opencl { + use! inBuf = ClArray.toDevice [| 0 |] + do! runCommand command <| fun x -> x (Range1D(5, 5)) inBuf - return! ClCell.toHost cell - } - |> ClTask.runSync context + return! ClArray.toHost inBuf + } + |> ClTask.runSync context - "Arrays should be equal" |> Expect.equal actual expected + Expect.sequenceEqual actual expected "Arrays should be equals" - ptestCase "Using 'int clcell' with spinlock atomic operation should be correct" - <| fun () -> - let value = 10 + testCase "Local array. Test 1" + <| fun _ -> + let localWorkSize = 5 + let globalWorkSize = 15 - let command = - <@ fun (range: Range1D) (cell: int clcell) -> atomic (fun x -> x + value) cell.Value |> ignore @> + let command = + <@ + fun (range: Range1D) (input: ClArray) (output: ClArray) -> + let localBuf = localArray localWorkSize - let expected = value * default1D.GlobalWorkSize + localBuf.[range.LocalID0] <- range.LocalID0 + barrierLocal () + output.[range.GlobalID0] <- localBuf.[(range.LocalID0 + 1) % localWorkSize] + @> - let actual = - opencl { - use! cell = ClCell.toDevice 0 - do! runCommand command <| fun it -> it <| default1D <| cell - return! ClCell.toHost cell - } - |> ClTask.runSync context + let expected = + [| for x in 1..localWorkSize -> x % localWorkSize |] + |> Array.replicate (globalWorkSize / localWorkSize) + |> Array.concat - "Arrays should be equal" |> Expect.equal actual expected ] + let actual = + opencl { + use! inBuf = ClArray.toDevice (Array.zeroCreate globalWorkSize) + use! outBuf = ClArray.toDevice (Array.zeroCreate globalWorkSize) -let booleanTests context = - [ testCase "Executing copy kernel on boolean array should not raise exception" - <| fun () -> - let inputArray = Array.create 100_000 true - let inputArrayLength = inputArray.Length + do! + runCommand command + <| fun x -> x (Range1D(globalWorkSize, localWorkSize)) inBuf outBuf + + return! ClArray.toHost outBuf + } + |> ClTask.runSync context + + Expect.sequenceEqual actual expected "Arrays should be equals" + + ptestCase "Local array. Test 2" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + let localBuf = localArray 42 + atomic xchg localBuf.[0] 1L |> ignore + buf.[0] <- localBuf.[0] + @> + + checkResult command [| 0L; 1L; 2L; 3L |] [| 1L; 1L; 2L; 3L |] + ] + +let letTransformationTests context = + [ + let inline checkResult cmd input expected = checkResult context cmd input expected + + testCase "Template Let Transformation Test 0" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + let f = 3 + buf.[0] <- f + @> - let copy = - <@ - fun (ndRange: Range1D) (inputArrayBuffer: bool clarray) (outputArrayBuffer: bool clarray) -> + checkResult command intInArr [| 3; 1; 2; 3 |] - let i = ndRange.GlobalID0 + testCase "Template Let Transformation Test 1" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + let x = 4 - if i < inputArrayLength then - outputArrayBuffer.[i] <- inputArrayBuffer.[i] - @> + let f = + let x = 3 + x - let actual = - opencl { - use! input = ClArray.toDevice inputArray - use! output = ClArray.alloc 100_000 + buf.[0] <- x + f + @> - do! - runCommand copy - <| fun x -> x <| Range1D.CreateValid(inputArray.Length, 256) <| input <| output + checkResult command intInArr [| 7; 1; 2; 3 |] - return! ClArray.toHost output - } - |> ClTask.runSync context + testCase "Template Let Transformation Test 1.2" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + let f y = + let x c b = b + c + 4 + y + x 2 3 - "Arrays should be equal" |> Expect.sequenceEqual actual inputArray + buf.[0] <- f 1 + @> - testProperty "'lor' on boolean type should work correctly" - <| fun (array: bool[]) -> - if array.Length <> 0 then - let reversed = Seq.rev array |> Seq.toArray - let inputArrayLength = array.Length + checkResult command intInArr [| 10; 1; 2; 3 |] - let command = - <@ - fun (ndRange: Range1D) (array: bool clarray) (reversed: bool clarray) -> + testCase "Template Let Transformation Test 2" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + let f = + let x = + let y = 3 + y - let i = ndRange.GlobalID0 + x - if i < inputArrayLength then - array.[i] <- array.[i] || reversed.[i] || false - @> + buf.[0] <- f + @> - let expected = (array, reversed) ||> Array.zip |> Array.map (fun (x, y) -> x || y) + checkResult command intInArr [| 3; 1; 2; 3 |] - let actual = - opencl { - use! array' = ClArray.toDevice array - use! reversed' = ClArray.toDevice reversed + testCase "Template Let Transformation Test 3" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + let f = + let f = 5 + f - do! - runCommand command - <| fun x -> x <| Range1D.CreateValid(inputArrayLength, 256) <| array' <| reversed' + buf.[0] <- f + @> - return! ClArray.toHost array' - } - |> ClTask.runSync context + checkResult command intInArr [| 5; 1; 2; 3 |] - "Arrays should be equal" |> Expect.sequenceEqual actual expected + testCase "Template Let Transformation Test 4" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + let f = + let f = + let f = 5 + f - testProperty "'land' on boolean type should work correctly" - <| fun (array: bool[]) -> - if array.Length <> 0 then - let reversed = Seq.rev array |> Seq.toArray - let inputArrayLength = array.Length + f - let command = - <@ - fun (ndRange: Range1D) (array: bool clarray) (reversed: bool clarray) -> + buf.[0] <- f + @> - let i = ndRange.GlobalID0 + checkResult command intInArr [| 5; 1; 2; 3 |] - if i < inputArrayLength then - array.[i] <- array.[i] && reversed.[i] && true - @> + testCase "Template Let Transformation Test 5" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + let f a b = + let x y z = y + z + x a b - let expected = (array, reversed) ||> Array.zip |> Array.map (fun (x, y) -> x && y) + buf.[0] <- f 1 7 + @> - let actual = - opencl { - use! array' = ClArray.toDevice array - use! reversed' = ClArray.toDevice reversed + checkResult command intInArr [| 8; 1; 2; 3 |] - do! - runCommand command - <| fun x -> x <| Range1D.CreateValid(inputArrayLength, 256) <| array' <| reversed' + testCase "Template Let Transformation Test 6" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + let f x y = + let x = x + x + y - return! ClArray.toHost array' - } - |> ClTask.runSync context + buf.[0] <- f 7 8 + @> - "Arrays should be equal" |> Expect.sequenceEqual actual expected ] + checkResult command intInArr [| 15; 1; 2; 3 |] -let parallelExecutionTests context = - [ testCase "Running tasks in parallel should not raise exception" - <| fun () -> - let fill = - opencl { - let kernel = - <@ - fun (range: Range1D) (buffer: int clarray) -> - let i = range.GlobalID0 - buffer.[i] <- 1 - @> + testCase "Template Let Transformation Test 7" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + let f y = + let x y = 6 - y + x y - use! array = ClArray.alloc 256 - do! runCommand kernel <| fun x -> x <| Range1D.CreateValid(256, 256) <| array + buf.[0] <- f 7 + @> - return! ClArray.toHost array - } + checkResult command intInArr [| -1; 1; 2; 3 |] - let expected = Array.replicate 3 (Array.create 256 1) + testCase "Template Let Transformation Test 8" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (m: ClArray) -> + let p = m.[0] - let actual = - opencl { return! List.replicate 3 fill |> ClTask.inParallel } - |> ClTask.runSync context + let x n = + let l = m.[3] + let g k = k + m.[0] + m.[1] - "Arrays should be equal" |> Expect.sequenceEqual actual expected + let r = + let y a = + let x = 5 - n + (g 4) + let z t = m.[2] + a - t + z (a + x + l) - // TODO check if it really faster - ] + y 6 -type Option1 = - | None1 - | Some1 of int + r + m.[3] -let simpleDUTests context = - [ testCase "Option with F#-native syntax" - <| fun () -> - let rnd = System.Random() - let input1 = Array.init 100_000 (fun i -> rnd.Next()) - let input2 = Array.init 100_000 (fun i -> rnd.Next()) - let inputArrayLength = input1.Length - - let add (op: Expr -> Option -> Option>) = - <@ - fun (ndRange: Range1D) (input1: int clarray) (input2: int clarray) (output: int clarray) -> - - let i = ndRange.GlobalID0 - - if i < inputArrayLength then - let x = if input1.[i] < 0 then None else Some input1.[i] - let y = if input2.[i] < 0 then None else Some input2.[i] - - output.[i] <- - match (%op) x y with - | Some x -> x - | None -> 0 - @> - - let actual = - opencl { - use! input1 = ClArray.toDevice input1 - use! input2 = ClArray.toDevice input2 - use! output = ClArray.alloc 100_000 - - let op = - <@ - fun x y -> - match x with - | Some x -> - match y with - | Some y -> Some(x + y) - | None -> Some x - | None -> - match y with - | Some y -> Some y - | None -> None - @> - - do! - runCommand (add op) - <| fun x -> x <| Range1D.CreateValid(input1.Length, 256) <| input1 <| input2 <| output - - return! ClArray.toHost output - } - |> ClTask.runSync context - - let expected = - (input1, input2) - ||> Array.map2 (fun x y -> - if x < 0 then - if y < 0 then 0 else y - else - x + y) - - "Arrays should be equal" |> Expect.sequenceEqual actual expected - - testCase "Option with simplified syntax" - <| fun () -> - let rnd = System.Random() - let input1 = Array.init 100_000 (fun i -> rnd.Next()) - let input2 = Array.init 100_000 (fun i -> rnd.Next()) - let inputArrayLength = input1.Length - - let add (op: Expr -> Option -> Option>) = - <@ - fun (ndRange: Range1D) (input1: int clarray) (input2: int clarray) (output: int clarray) -> - - let i = ndRange.GlobalID0 - - if i < inputArrayLength then - let mutable x = None - let mutable y = None - - if input1.[i] >= 0 then - x <- Some input1.[i] - - if input2.[i] >= 0 then - y <- Some input2.[i] - - match (%op) x y with - | Some x -> output.[i] <- x - | None -> output.[i] <- 0 - @> - - let actual = - opencl { - use! input1 = ClArray.toDevice input1 - use! input2 = ClArray.toDevice input2 - use! output = ClArray.alloc 100_000 - - let op = - <@ - fun x y -> - match x, y with - | Some x, Some y -> Some(x + y) - | Some x, None -> Some x - | None, Some y -> Some y - | None, None -> None - @> - - do! - runCommand (add op) - <| fun x -> x <| Range1D.CreateValid(input1.Length, 256) <| input1 <| input2 <| output - - return! ClArray.toHost output - } - |> ClTask.runSync context - - let expected = - (input1, input2) - ||> Array.map2 (fun x y -> - if x < 0 then - if y < 0 then 0 else y - else - x + y) - - "Arrays should be equal" |> Expect.sequenceEqual actual expected - - testCase "Simple custom non-generic DU" - <| fun () -> - let rnd = System.Random() - let input1 = Array.init 100_000 (fun i -> rnd.Next()) - let input2 = Array.init 100_000 (fun i -> rnd.Next()) - let inputArrayLength = input1.Length - - let add (op: Expr Option1 -> Option1>) = - <@ - fun (ndRange: Range1D) (input1: int clarray) (input2: int clarray) (output: int clarray) -> - - let i = ndRange.GlobalID0 - - if i < inputArrayLength then - let mutable x = None1 - let mutable y = None1 - - if input1.[i] >= 0 then - x <- Some1 input1.[i] - - if input2.[i] >= 0 then - y <- Some1 input2.[i] - - let z = (%op) x y - - match z with - | Some1 x -> output.[i] <- x - | None1 -> output.[i] <- 0 - @> - - let actual = - opencl { - use! input1 = ClArray.toDevice input1 - use! input2 = ClArray.toDevice input2 - use! output = ClArray.alloc 100_000 - - let op = - <@ - fun x y -> - match x with - | Some1 x -> - match y with - | Some1 y -> Some1(x + y) - | None1 -> Some1 x - | None1 -> - match y with - | Some1 y -> Some1 y - | None1 -> None1 - @> - - do! - runCommand (add op) - <| fun x -> x <| Range1D.CreateValid(input1.Length, 256) <| input1 <| input2 <| output - - return! ClArray.toHost output - } - |> ClTask.runSync context - - let expected = - (input1, input2) - ||> Array.map2 (fun x y -> - if x < 0 then - if y < 0 then 0 else y - else - x + y) - - "Arrays should be equal" |> Expect.sequenceEqual actual expected ] + if range.GlobalID0 = 0 then + m.[0] <- x 7 + @> + + checkResult command intInArr [| -1; 1; 2; 3 |] + + testCase "Template Let Transformation Test 9" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + let x n = + let r = 8 + let h = r + n + h + + buf.[0] <- x 9 + @> + + checkResult command intInArr [| 17; 1; 2; 3 |] + + testCase "Template Let Transformation Test 10" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + let p = 9 + + let x n b = + let t = 0 + n + b + t + + buf.[0] <- x 7 9 + @> + + checkResult command intInArr [| 16; 1; 2; 3 |] + + testCase "Template Let Transformation Test 11" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + let p = 1 + + let m = + let r (l: int) = l + r 9 + + let z (k: int) = k + buf.[0] <- m + @> + + checkResult command intInArr [| 9; 1; 2; 3 |] + + testCase "Template Let Transformation Test 12" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + let f x y = + let y = y + let y = y + let g x m = m + x + g x y + + buf.[0] <- f 1 7 + @> + + checkResult command intInArr [| 8; 1; 2; 3 |] + + testCase "Template Let Transformation Test 13" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + let f y = + let y = y + let y = y + let g (m: int) = m + g y + + buf.[0] <- f 7 + @> + + checkResult command intInArr [| 7; 1; 2; 3 |] + + testCase "Template Let Transformation Test 14" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + let f y = + let y = y + let y = y + + let g (m: int) = + let g r t = r + y - t + let n o = o - (g y 2) + n 5 + + g y + + let z y = y - 2 + buf.[0] <- f (z 7) + @> + + checkResult command intInArr [| -3; 1; 2; 3 |] + + testCase "Template Let Transformation Test 15" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + let f y = + let Argi index = if index = 0 then buf.[1] else buf.[2] + Argi y + + buf.[0] <- f 0 + @> + + checkResult command intInArr [| 1; 1; 2; 3 |] + + testCase "Template Let Transformation Test 16" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + let f y = + if y = 0 then + let z (a: int) = a + z 9 + else + buf.[2] + + buf.[0] <- f 0 + @> + + checkResult command intInArr [| 9; 1; 2; 3 |] + + testCase "Template Let Transformation Test 17" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + if range.GlobalID0 = 0 then + let f y = + let g = buf.[1] + 1 + y + g + + for i in 0..3 do + buf.[i] <- f i + @> + + checkResult command intInArr [| 2; 3; 6; 7 |] + + testCase "Template Let Transformation Test 18" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + for i in 0..3 do + let f = + let g = buf.[1] + 1 + i + g + + if range.GlobalID0 = 0 then + buf.[i] <- f + @> + + checkResult command intInArr [| 2; 3; 6; 7 |] + + testCase "Template Let Transformation Test 19" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + if range.GlobalID0 = 0 then + for i in 0..3 do + let f x = + let g = buf.[1] + x + i + g + + buf.[i] <- f 1 + @> + + checkResult command intInArr [| 2; 3; 6; 7 |] + + // TODO: perform range (1D, 2D, 3D) erasure when range is lifted. + ptestCase "Template Let Transformation Test 20" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (m: ClArray) -> + let f x = range.GlobalID0 + x + m.[0] <- f 2 + @> + + checkResult command intInArr [| 2; 3; 6; 7 |] + ] + +let letQuotationTransformerSystemTests context = + [ + let inline checkResult cmd input expected = checkResult context cmd input expected + + testCase "Test 0" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + let mutable x = 1 + let f y = x <- y + f 10 + buf.[0] <- x + @> + + checkResult command intInArr [| 10; 1; 2; 3 |] + + testCase "Test 1" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (buf: ClArray) -> + let mutable x = 1 + let f y = x <- x + y + f 10 + buf.[0] <- x + @> + + checkResult command intInArr [| 11; 1; 2; 3 |] + + testCase "Test 2" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (arr: ClArray) -> + let f x = + let g y = y + 1 + g x + + arr.[0] <- f 2 + @> + + checkResult command intInArr [| 3; 1; 2; 3 |] + + testCase "Test 3" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (arr: ClArray) -> + let f x = + let g y = y + x + g (x + 1) + + arr.[0] <- f 2 + @> + + checkResult command intInArr [| 5; 1; 2; 3 |] + + testCase "Test 4" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (arr: ClArray) -> + let gid = range.GlobalID0 + + let x = + let mutable y = 0 + + let addToY x = y <- y + x + + for i in 0..5 do + addToY arr.[gid] + + y + + arr.[gid] <- x + @> + + checkResult command intInArr [| 0; 6; 12; 18 |] + + testCase "Test 5" + <| fun _ -> + let command = + <@ + fun (range: Range1D) (arr: ClArray) -> + let gid = range.GlobalID0 + + let mutable x = if 0 > 1 then 2 else 3 + + let mutable y = + for i in 0..4 do + x <- x + 1 + + x + 1 + + let z = x + y + + let f () = arr.[gid] <- x + y + z + f () + @> + + checkResult command intInArr [| 34; 34; 34; 34 |] + ] + +let commonApiTests context = + [ + let inline checkResult cmd input expected = checkResult context cmd input expected + + testCase "Check simple '|> ignore'" + <| fun () -> + let command = + <@ + fun (range: Range1D) (buffer: ClArray) -> + let gid = range.GlobalID0 + atomic inc buffer.[gid] |> ignore + @> + + checkResult command intInArr (intInArr |> Array.map ((+) 1)) + + // Lambda is not supported. + ptestCase "Forward pipe" + <| fun _ -> + let command = + <@ fun (range: Range1D) (buf: ClArray) -> buf.[0] <- (1.25f |> int) @> + + checkResult command intInArr [| 1; 1; 2; 3 |] + + // Lambda is not supported. + ptestCase "Backward pipe" + <| fun _ -> + let command = + <@ fun (range: Range1D) (buf: ClArray) -> buf.[0] <- int <| 1.25f + 2.34f @> + + checkResult command intInArr [| 3; 1; 2; 3 |] + + testCase "Getting value of 'int clcell' should be correct" + <| fun () -> + let command = + <@ + fun (range: Range1D) (buffer: int clarray) (cell: int clcell) -> + let gid = range.GlobalID0 + buffer.[gid] <- cell.Value + @> + + let value = 10 + let expected = Array.replicate defaultInArrayLength value + + let actual = + opencl { + use! cell = ClCell.toDevice 10 + use! buffer = ClArray.alloc defaultInArrayLength + do! runCommand command <| fun it -> it <| default1D <| buffer <| cell + + return! ClArray.toHost buffer + } + |> ClTask.runSync context + + "Arrays should be equal" |> Expect.sequenceEqual actual expected + + // TODO test on getting Value property of non-clcell type + // TODO test on getting Item property on non-clarray type + + testCase "Setting value of 'int clcell' should be correct" + <| fun () -> + let value = 10 + let command = <@ fun (range: Range1D) (cell: int clcell) -> cell.Value <- value @> + + let actual = + opencl { + use! cell = ClCell.toDevice value + do! runCommand command <| fun it -> it <| default1D <| cell + + return! ClCell.toHost cell + } + |> ClTask.runSync context + + "Arrays should be equal" |> Expect.equal actual value + + testCase "Using 'int clcell' from inner function should work correctly" + <| fun () -> + let value = 10 + + let command = + <@ + fun (range: Range1D) (cell: int clcell) -> + let f () = + let x = cell.Value + cell.Value <- x + + f () + @> + + let actual = + opencl { + use! cell = ClCell.toDevice value + do! runCommand command <| fun it -> it <| default1D <| cell + + return! ClCell.toHost cell + } + |> ClTask.runSync context + + "Arrays should be equal" |> Expect.equal actual value + + testCase "Using 'int clcell' with native atomic operation should be correct" + <| fun () -> + let value = 10 + + let command = + <@ fun (range: Range1D) (cell: int clcell) -> atomic (+) cell.Value value |> ignore @> + + let expected = value * default1D.GlobalWorkSize + + let actual = + opencl { + use! cell = ClCell.toDevice 0 + do! runCommand command <| fun it -> it <| default1D <| cell + + return! ClCell.toHost cell + } + |> ClTask.runSync context + + "Arrays should be equal" |> Expect.equal actual expected + + ptestCase "Using 'int clcell' with spinlock atomic operation should be correct" + <| fun () -> + let value = 10 + + let command = + <@ fun (range: Range1D) (cell: int clcell) -> atomic (fun x -> x + value) cell.Value |> ignore @> + + let expected = value * default1D.GlobalWorkSize + + let actual = + opencl { + use! cell = ClCell.toDevice 0 + do! runCommand command <| fun it -> it <| default1D <| cell + + return! ClCell.toHost cell + } + |> ClTask.runSync context + + "Arrays should be equal" |> Expect.equal actual expected + ] + +let booleanTests context = + [ + testCase "Executing copy kernel on boolean array should not raise exception" + <| fun () -> + let inputArray = Array.create 100_000 true + let inputArrayLength = inputArray.Length + + let copy = + <@ + fun (ndRange: Range1D) (inputArrayBuffer: bool clarray) (outputArrayBuffer: bool clarray) -> + + let i = ndRange.GlobalID0 + + if i < inputArrayLength then + outputArrayBuffer.[i] <- inputArrayBuffer.[i] + @> + + let actual = + opencl { + use! input = ClArray.toDevice inputArray + use! output = ClArray.alloc 100_000 + + do! + runCommand copy + <| fun x -> x <| Range1D.CreateValid(inputArray.Length, 256) <| input <| output + + return! ClArray.toHost output + } + |> ClTask.runSync context + + "Arrays should be equal" |> Expect.sequenceEqual actual inputArray + + testProperty "'lor' on boolean type should work correctly" + <| fun (array: bool[]) -> + if array.Length <> 0 then + let reversed = Seq.rev array |> Seq.toArray + let inputArrayLength = array.Length + + let command = + <@ + fun (ndRange: Range1D) (array: bool clarray) (reversed: bool clarray) -> + + let i = ndRange.GlobalID0 + + if i < inputArrayLength then + array.[i] <- array.[i] || reversed.[i] || false + @> + + let expected = (array, reversed) ||> Array.zip |> Array.map (fun (x, y) -> x || y) + + let actual = + opencl { + use! array' = ClArray.toDevice array + use! reversed' = ClArray.toDevice reversed + + do! + runCommand command + <| fun x -> x <| Range1D.CreateValid(inputArrayLength, 256) <| array' <| reversed' + + return! ClArray.toHost array' + } + |> ClTask.runSync context + + "Arrays should be equal" |> Expect.sequenceEqual actual expected + + testProperty "'land' on boolean type should work correctly" + <| fun (array: bool[]) -> + if array.Length <> 0 then + let reversed = Seq.rev array |> Seq.toArray + let inputArrayLength = array.Length + + let command = + <@ + fun (ndRange: Range1D) (array: bool clarray) (reversed: bool clarray) -> + + let i = ndRange.GlobalID0 + + if i < inputArrayLength then + array.[i] <- array.[i] && reversed.[i] && true + @> + + let expected = (array, reversed) ||> Array.zip |> Array.map (fun (x, y) -> x && y) + + let actual = + opencl { + use! array' = ClArray.toDevice array + use! reversed' = ClArray.toDevice reversed + + do! + runCommand command + <| fun x -> x <| Range1D.CreateValid(inputArrayLength, 256) <| array' <| reversed' + + return! ClArray.toHost array' + } + |> ClTask.runSync context + + "Arrays should be equal" |> Expect.sequenceEqual actual expected + ] + +let parallelExecutionTests context = + [ + testCase "Running tasks in parallel should not raise exception" + <| fun () -> + let fill = + opencl { + let kernel = + <@ + fun (range: Range1D) (buffer: int clarray) -> + let i = range.GlobalID0 + buffer.[i] <- 1 + @> + + use! array = ClArray.alloc 256 + do! runCommand kernel <| fun x -> x <| Range1D.CreateValid(256, 256) <| array + + return! ClArray.toHost array + } + + let expected = Array.replicate 3 (Array.create 256 1) + + let actual = + opencl { return! List.replicate 3 fill |> ClTask.inParallel } + |> ClTask.runSync context + + "Arrays should be equal" |> Expect.sequenceEqual actual expected + + // TODO check if it really faster + ] + +type Option1 = + | None1 + | Some1 of int + +let simpleDUTests context = + [ + testCase "Option with F#-native syntax" + <| fun () -> + let rnd = System.Random() + let input1 = Array.init 100_000 (fun i -> rnd.Next()) + let input2 = Array.init 100_000 (fun i -> rnd.Next()) + let inputArrayLength = input1.Length + + let add (op: Expr -> Option -> Option>) = + <@ + fun (ndRange: Range1D) (input1: int clarray) (input2: int clarray) (output: int clarray) -> + + let i = ndRange.GlobalID0 + + if i < inputArrayLength then + let x = if input1.[i] < 0 then None else Some input1.[i] + let y = if input2.[i] < 0 then None else Some input2.[i] + + output.[i] <- + match (%op) x y with + | Some x -> x + | None -> 0 + @> + + let actual = + opencl { + use! input1 = ClArray.toDevice input1 + use! input2 = ClArray.toDevice input2 + use! output = ClArray.alloc 100_000 + + let op = + <@ + fun x y -> + match x with + | Some x -> + match y with + | Some y -> Some(x + y) + | None -> Some x + | None -> + match y with + | Some y -> Some y + | None -> None + @> + + do! + runCommand (add op) + <| fun x -> x <| Range1D.CreateValid(input1.Length, 256) <| input1 <| input2 <| output + + return! ClArray.toHost output + } + |> ClTask.runSync context + + let expected = + (input1, input2) + ||> Array.map2 (fun x y -> + if x < 0 then + if y < 0 then 0 else y + else + x + y + ) + + "Arrays should be equal" |> Expect.sequenceEqual actual expected + + testCase "Option with simplified syntax" + <| fun () -> + let rnd = System.Random() + let input1 = Array.init 100_000 (fun i -> rnd.Next()) + let input2 = Array.init 100_000 (fun i -> rnd.Next()) + let inputArrayLength = input1.Length + + let add (op: Expr -> Option -> Option>) = + <@ + fun (ndRange: Range1D) (input1: int clarray) (input2: int clarray) (output: int clarray) -> + + let i = ndRange.GlobalID0 + + if i < inputArrayLength then + let mutable x = None + let mutable y = None + + if input1.[i] >= 0 then + x <- Some input1.[i] + + if input2.[i] >= 0 then + y <- Some input2.[i] + + match (%op) x y with + | Some x -> output.[i] <- x + | None -> output.[i] <- 0 + @> + + let actual = + opencl { + use! input1 = ClArray.toDevice input1 + use! input2 = ClArray.toDevice input2 + use! output = ClArray.alloc 100_000 + + let op = + <@ + fun x y -> + match x, y with + | Some x, Some y -> Some(x + y) + | Some x, None -> Some x + | None, Some y -> Some y + | None, None -> None + @> + + do! + runCommand (add op) + <| fun x -> x <| Range1D.CreateValid(input1.Length, 256) <| input1 <| input2 <| output + + return! ClArray.toHost output + } + |> ClTask.runSync context + + let expected = + (input1, input2) + ||> Array.map2 (fun x y -> + if x < 0 then + if y < 0 then 0 else y + else + x + y + ) + + "Arrays should be equal" |> Expect.sequenceEqual actual expected + + testCase "Simple custom non-generic DU" + <| fun () -> + let rnd = System.Random() + let input1 = Array.init 100_000 (fun i -> rnd.Next()) + let input2 = Array.init 100_000 (fun i -> rnd.Next()) + let inputArrayLength = input1.Length + + let add (op: Expr Option1 -> Option1>) = + <@ + fun (ndRange: Range1D) (input1: int clarray) (input2: int clarray) (output: int clarray) -> + + let i = ndRange.GlobalID0 + + if i < inputArrayLength then + let mutable x = None1 + let mutable y = None1 + + if input1.[i] >= 0 then + x <- Some1 input1.[i] + + if input2.[i] >= 0 then + y <- Some1 input2.[i] + + let z = (%op) x y + + match z with + | Some1 x -> output.[i] <- x + | None1 -> output.[i] <- 0 + @> + + let actual = + opencl { + use! input1 = ClArray.toDevice input1 + use! input2 = ClArray.toDevice input2 + use! output = ClArray.alloc 100_000 + + let op = + <@ + fun x y -> + match x with + | Some1 x -> + match y with + | Some1 y -> Some1(x + y) + | None1 -> Some1 x + | None1 -> + match y with + | Some1 y -> Some1 y + | None1 -> None1 + @> + + do! + runCommand (add op) + <| fun x -> x <| Range1D.CreateValid(input1.Length, 256) <| input1 <| input2 <| output + + return! ClArray.toHost output + } + |> ClTask.runSync context + + let expected = + (input1, input2) + ||> Array.map2 (fun x y -> + if x < 0 then + if y < 0 then 0 else y + else + x + y + ) + + "Arrays should be equal" |> Expect.sequenceEqual actual expected + ] [] type StructWithOverridedConstructors = @@ -2155,19 +1688,21 @@ type StructWithOverridedConstructors = //] let tests context = - [ testList "Simple tests on primitive types" << smokeTestsOnPrimitiveTypes - testList "Type castings tests" << typeCastingTests - testList "Bindings tests" << bindingTests - testList "Operators and math functions tests" << operatorsAndMathFunctionsTests - testList "Control flow tests" << controlFlowTests - testList "Kernel arguments tests" << kernelArgumentsTests - testList "Quotation injection tests" << quotationInjectionTests - testList "Local memory tests" << localMemTests - testList "Let Transformation Tests" << letTransformationTests - testList "Let Transformation Tests Mutable Vars" - << letQuotationTransformerSystemTests - testList "Common Api Tests" << commonApiTests - testList "Boolean Tests" << booleanTests - ptestList "Parallel Execution Tests" << parallelExecutionTests - testList "Simple tests on discriminated unions" << simpleDUTests ] + [ + testList "Simple tests on primitive types" << smokeTestsOnPrimitiveTypes + testList "Type castings tests" << typeCastingTests + testList "Bindings tests" << bindingTests + testList "Operators and math functions tests" << operatorsAndMathFunctionsTests + testList "Control flow tests" << controlFlowTests + testList "Kernel arguments tests" << kernelArgumentsTests + testList "Quotation injection tests" << quotationInjectionTests + testList "Local memory tests" << localMemTests + testList "Let Transformation Tests" << letTransformationTests + testList "Let Transformation Tests Mutable Vars" + << letQuotationTransformerSystemTests + testList "Common Api Tests" << commonApiTests + testList "Boolean Tests" << booleanTests + ptestList "Parallel Execution Tests" << parallelExecutionTests + testList "Simple tests on discriminated unions" << simpleDUTests + ] |> List.map (fun testFixture -> testFixture context) diff --git a/tests/Brahma.FSharp.Tests/ExecutionTests/WorkflowBuilderTests.fs b/tests/Brahma.FSharp.Tests/ExecutionTests/WorkflowBuilderTests.fs index 269191bf..e6f55487 100644 --- a/tests/Brahma.FSharp.Tests/ExecutionTests/WorkflowBuilderTests.fs +++ b/tests/Brahma.FSharp.Tests/ExecutionTests/WorkflowBuilderTests.fs @@ -26,204 +26,169 @@ module Helpers = } let bindTests context = - [ testCase "Test 1" - <| fun _ -> - let xs = - [| 1 - 2 - 3 - 4 |] - - let workflow = - opencl { - use! xs' = ClArray.toDevice xs - use! ys = gpuMap <@ fun x -> x * x + 10 @> xs' - use! zs = gpuMap <@ fun x -> x + 1 @> ys - return! ClArray.toHost zs - } - - let output = ClTask.runSync context workflow - - Expect.equal - output - [| 12 - 15 - 20 - 27 |] - eqMsg - - testCase "'use!' should free resources after all" - <| fun () -> - let log = ResizeArray() - - opencl { - use! resource = - opencl { - return - { new System.IDisposable with - member this.Dispose() = log.Add "disposed" } - } - - do! opencl { return log.Add "1" } - return! opencl { log.Add "2" } - } - |> ClTask.runSync context - - "Last value should be 'disposed'" - |> Expect.isTrue (log.[log.Count - 1] = "disposed") ] + [ + testCase "Test 1" + <| fun _ -> + let xs = [| 1; 2; 3; 4 |] + + let workflow = + opencl { + use! xs' = ClArray.toDevice xs + use! ys = gpuMap <@ fun x -> x * x + 10 @> xs' + use! zs = gpuMap <@ fun x -> x + 1 @> ys + return! ClArray.toHost zs + } + + let output = ClTask.runSync context workflow + + Expect.equal output [| 12; 15; 20; 27 |] eqMsg + + testCase "'use!' should free resources after all" + <| fun () -> + let log = ResizeArray() + + opencl { + use! resource = + opencl { + return + { new System.IDisposable with + member this.Dispose() = log.Add "disposed" + } + } + + do! opencl { return log.Add "1" } + return! opencl { log.Add "2" } + } + |> ClTask.runSync context + + "Last value should be 'disposed'" + |> Expect.isTrue (log.[log.Count - 1] = "disposed") + ] let loopTests context = - [ testCase "While. Test 1. Without evaluation" - <| fun _ -> - let mutable log: int list = [] - - let workflow = - opencl { - let mutable i = 0 - log <- i :: log - - while i < 10 do - i <- i + 1 - log <- i :: log - } - - Expect.equal log [] "Delay should prevent any computations before evaluation started" - ClTask.runSync context workflow - Expect.equal log [ 10..-1..0 ] eqMsg - - testCase "While. Test 2. Simple evaluation" - <| fun _ -> - let mutable xs = - [| 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 |] - - let iters = 5 - let expected = Array.map (fun x -> pown 2 iters * x) xs - - // TODO change to use copyTo - let workflow = - opencl { - let f = <@ fun x -> x * 2 @> - - let mutable i = 0 - - let! xs' = ClArray.toDevice xs - let mutable tmp = xs' - - while i < iters do - let! res = gpuMap f tmp - do! ClArray.close tmp - tmp <- res - i <- i + 1 - - let! res = ClArray.toHost tmp - do! ClArray.close tmp - - return res - } - - let output = ClTask.runSync context workflow - Expect.equal output expected eqMsg - - testCase "While. Test 3. Do inside body of while loop" - <| fun _ -> - let gpuMapInplace f (xs: int clarray ref) = - opencl { - let! res = gpuMap f !xs - do! ClArray.close !xs - xs := res - } - - let workflow = - opencl { - let! xs = - ClArray.toDevice - [| 1 - 2 - 3 - 4 |] - - let xs = ref xs - - let mutable i = 0 - - while i < 10 do - do! gpuMapInplace <@ fun x -> x + 1 @> xs - i <- i + 1 - - return! ClArray.toHost !xs - } - - let output = ClTask.runSync context workflow - - Expect.equal - output - [| 11 - 12 - 13 - 14 |] - eqMsg - - testCase "For. Test 1. Without evaluation" - <| fun _ -> - let log = List() - - let workflow = - opencl { - log.Add(0) - - for x in [ 1..10 ] do - log.Add(x) - } - - Expect.sequenceEqual log - <| List() - <| "Delay should prevent any computations before evaluation started" - - ClTask.runSync context workflow - Expect.sequenceEqual log (List([ 0..10 ])) eqMsg - - testCase "For. Test 2. Simple evaluation" - <| fun _ -> - let workflow = - opencl { - let xs = - [| 1 - 2 - 3 - 4 |] - - let! xs' = ClArray.toDevice xs - let mutable tmp = xs' - - for y in - [| 10 - 20 - 30 |] do - let! res = gpuMap <@ fun x -> x + y @> tmp - do! ClArray.close tmp - tmp <- res - - return! ClArray.toHost tmp - } - - let output = ClTask.runSync context workflow - - Expect.equal - output - [| 61 - 62 - 63 - 64 |] - eqMsg ] + [ + testCase "While. Test 1. Without evaluation" + <| fun _ -> + let mutable log: int list = [] + + let workflow = + opencl { + let mutable i = 0 + log <- i :: log + + while i < 10 do + i <- i + 1 + log <- i :: log + } + + Expect.equal log [] "Delay should prevent any computations before evaluation started" + ClTask.runSync context workflow + Expect.equal log [ 10..-1..0 ] eqMsg + + testCase "While. Test 2. Simple evaluation" + <| fun _ -> + let mutable xs = [| 1; 2; 3; 4; 5; 6; 7; 8 |] + + let iters = 5 + let expected = Array.map (fun x -> pown 2 iters * x) xs + + // TODO change to use copyTo + let workflow = + opencl { + let f = <@ fun x -> x * 2 @> + + let mutable i = 0 + + let! xs' = ClArray.toDevice xs + let mutable tmp = xs' + + while i < iters do + let! res = gpuMap f tmp + do! ClArray.close tmp + tmp <- res + i <- i + 1 + + let! res = ClArray.toHost tmp + do! ClArray.close tmp + + return res + } + + let output = ClTask.runSync context workflow + Expect.equal output expected eqMsg + + testCase "While. Test 3. Do inside body of while loop" + <| fun _ -> + let gpuMapInplace f (xs: int clarray ref) = + opencl { + let! res = gpuMap f !xs + do! ClArray.close !xs + xs := res + } + + let workflow = + opencl { + let! xs = ClArray.toDevice [| 1; 2; 3; 4 |] + + let xs = ref xs + + let mutable i = 0 + + while i < 10 do + do! gpuMapInplace <@ fun x -> x + 1 @> xs + i <- i + 1 + + return! ClArray.toHost !xs + } + + let output = ClTask.runSync context workflow + + Expect.equal output [| 11; 12; 13; 14 |] eqMsg + + testCase "For. Test 1. Without evaluation" + <| fun _ -> + let log = List() + + let workflow = + opencl { + log.Add(0) + + for x in [ 1..10 ] do + log.Add(x) + } + + Expect.sequenceEqual log + <| List() + <| "Delay should prevent any computations before evaluation started" + + ClTask.runSync context workflow + Expect.sequenceEqual log (List([ 0..10 ])) eqMsg + + testCase "For. Test 2. Simple evaluation" + <| fun _ -> + let workflow = + opencl { + let xs = [| 1; 2; 3; 4 |] + + let! xs' = ClArray.toDevice xs + let mutable tmp = xs' + + for y in [| 10; 20; 30 |] do + let! res = gpuMap <@ fun x -> x + y @> tmp + do! ClArray.close tmp + tmp <- res + + return! ClArray.toHost tmp + } + + let output = ClTask.runSync context workflow + + Expect.equal output [| 61; 62; 63; 64 |] eqMsg + ] let tests context = - [ testList "Simple bind tests" << bindTests - testList "Loop tests" << loopTests ] + [ + testList "Simple bind tests" << bindTests + testList "Loop tests" << loopTests + ] |> List.map (fun testFixture -> testFixture context) diff --git a/tests/Brahma.FSharp.Tests/Program.fs b/tests/Brahma.FSharp.Tests/Program.fs index d9076793..1c9299af 100644 --- a/tests/Brahma.FSharp.Tests/Program.fs +++ b/tests/Brahma.FSharp.Tests/Program.fs @@ -4,10 +4,7 @@ open Brahma.FSharp.Tests [] let allTests = - testList - "All tests" - [ Translator.All.tests - ExecutionTests.tests |> testList "Execution" ] + testList "All tests" [ Translator.All.tests; ExecutionTests.tests |> testList "Execution" ] |> testSequenced [] diff --git a/tests/Brahma.FSharp.Tests/Translator/All.fs b/tests/Brahma.FSharp.Tests/Translator/All.fs index f0f49add..abe2cae2 100644 --- a/tests/Brahma.FSharp.Tests/Translator/All.fs +++ b/tests/Brahma.FSharp.Tests/Translator/All.fs @@ -7,31 +7,37 @@ let translator = Brahma.FSharp.OpenCL.Translator.FSQuotationToOpenCLTranslator.CreateDefault() let common = - [ BinOp.tests - ControlFlow.tests - NamesResolving.tests - ConstantArray.tests - LambdaLifting.tests - Carrying.tests - Injection.tests - - Specific.MergePath.tests ] + [ + BinOp.tests + ControlFlow.tests + NamesResolving.tests + ConstantArray.tests + LambdaLifting.tests + Carrying.tests + Injection.tests + + Specific.MergePath.tests + ] |> testList "Common" let extensions = - [ LangExtensions.Barrier.tests - LangExtensions.LocalId.tests - LangExtensions.LocalMemory.tests - LangExtensions.WorkSize.tests ] + [ + LangExtensions.Barrier.tests + LangExtensions.LocalId.tests + LangExtensions.LocalMemory.tests + LangExtensions.WorkSize.tests + ] |> testList "LangExtensions" let passes = - [ QuatationTransformation.Print.tests - QuatationTransformation.WorkSize.tests - QuatationTransformation.Names.tests - QuatationTransformation.Variables.tests - QuatationTransformation.VarToRef.tests - QuatationTransformation.Lifting.tests ] + [ + QuatationTransformation.Print.tests + QuatationTransformation.WorkSize.tests + QuatationTransformation.Names.tests + QuatationTransformation.Variables.tests + QuatationTransformation.VarToRef.tests + QuatationTransformation.Lifting.tests + ] |> testList "Passes" let union = [ Union.tests ] |> testList "Union" @@ -39,9 +45,4 @@ let union = [ Union.tests ] |> testList "Union" let transformation = [ QuatationTransformation.Transformation.tests ] |> testList "Transformation" -let tests = - [ common - passes - union - transformation ] - |> testList "Translator" +let tests = [ common; passes; union; transformation ] |> testList "Translator" diff --git a/tests/Brahma.FSharp.Tests/Translator/BinOp/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/BinOp/Tests.fs index 9ddd48d1..bba66f8b 100644 --- a/tests/Brahma.FSharp.Tests/Translator/BinOp/Tests.fs +++ b/tests/Brahma.FSharp.Tests/Translator/BinOp/Tests.fs @@ -8,38 +8,40 @@ open Expecto let private basePath = Path.Combine("Translator", "BinOp", "Expected") let private basicBinOpsTests = - [ let inline createTest name = Helpers.createTest basePath name - - <@ fun (range: Range1D) (buf: int clarray) -> buf.[0] <- 0 @> - |> createTest "Array item set" "Array.Item.Set.cl" - - <@ - fun (range: Range1D) (buf: int clarray) -> - let x = 1 - buf.[0] <- x - @> - |> createTest "Binding" "Binding.cl" - - <@ fun (range: Range1D) (buf: int clarray) -> buf.[0] <- 1 + 2 @> - |> createTest "Binop plus" "Binop.Plus.cl" - - <@ - fun (range: Range1D) (buf: int clarray) -> - let x = 0 - let y = x + 1 - let z = y * 2 - let a = z - x - let i = a / 2 - buf.[0] <- i - @> - |> createTest "Binary operations. Math." "Binary.Operations.Math.cl" - - <@ - fun (range: Range1D) (buf: float clarray) -> - let tempVarY = 1. - buf.[0] <- max buf.[0] tempVarY - buf.[0] <- max buf.[0] tempVarY - @> - |> createTest "TempVar from MAX transformation should not affect other variables" "MAX.Transformation.cl" ] + [ + let inline createTest name = Helpers.createTest basePath name + + <@ fun (range: Range1D) (buf: int clarray) -> buf.[0] <- 0 @> + |> createTest "Array item set" "Array.Item.Set.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + let x = 1 + buf.[0] <- x + @> + |> createTest "Binding" "Binding.cl" + + <@ fun (range: Range1D) (buf: int clarray) -> buf.[0] <- 1 + 2 @> + |> createTest "Binop plus" "Binop.Plus.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + let x = 0 + let y = x + 1 + let z = y * 2 + let a = z - x + let i = a / 2 + buf.[0] <- i + @> + |> createTest "Binary operations. Math." "Binary.Operations.Math.cl" + + <@ + fun (range: Range1D) (buf: float clarray) -> + let tempVarY = 1. + buf.[0] <- max buf.[0] tempVarY + buf.[0] <- max buf.[0] tempVarY + @> + |> createTest "TempVar from MAX transformation should not affect other variables" "MAX.Transformation.cl" + ] let tests = basicBinOpsTests |> testList "BinaryOperations" diff --git a/tests/Brahma.FSharp.Tests/Translator/Carrying/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/Carrying/Tests.fs index 95f449f1..1864df82 100644 --- a/tests/Brahma.FSharp.Tests/Translator/Carrying/Tests.fs +++ b/tests/Brahma.FSharp.Tests/Translator/Carrying/Tests.fs @@ -8,33 +8,35 @@ open Expecto let private basePath = Path.Combine("Translator", "Carrying", "Expected") let private curryingTests = - [ let inline createTest name = Helpers.createTest basePath name - - let inline createPTest name _ = Helpers.createPTest name - - <@ - fun (range: Range1D) (buf: int clarray) -> - let f x y = x - y - let g = f 2 - buf.[0] <- g 3 - buf.[1] <- g 5 - @> - |> createPTest "Nested functions.Carrying 1." // "Nested.Function.Carring.cl" // TODO(error: f application) - - <@ - fun (range: Range1D) (buf: int clarray) -> - let f x y = - let gg = ref 0 - - for i in 1..x do - gg := !gg + y - - !gg - - let g x = f 2 x - buf.[0] <- g 2 - buf.[1] <- g 3 - @> - |> createPTest "Nested functions.Currying 2." ] // "Nested.Function.Carring2.cl" TODO(error) + [ + let inline createTest name = Helpers.createTest basePath name + + let inline createPTest name _ = Helpers.createPTest name + + <@ + fun (range: Range1D) (buf: int clarray) -> + let f x y = x - y + let g = f 2 + buf.[0] <- g 3 + buf.[1] <- g 5 + @> + |> createPTest "Nested functions.Carrying 1." // "Nested.Function.Carring.cl" // TODO(error: f application) + + <@ + fun (range: Range1D) (buf: int clarray) -> + let f x y = + let gg = ref 0 + + for i in 1..x do + gg := !gg + y + + !gg + + let g x = f 2 x + buf.[0] <- g 2 + buf.[1] <- g 3 + @> + |> createPTest "Nested functions.Currying 2." + ] // "Nested.Function.Carring2.cl" TODO(error) let tests = curryingTests |> testList "Currying" diff --git a/tests/Brahma.FSharp.Tests/Translator/ConstantArray/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/ConstantArray/Tests.fs index 137fa7fb..3edba6d9 100644 --- a/tests/Brahma.FSharp.Tests/Translator/ConstantArray/Tests.fs +++ b/tests/Brahma.FSharp.Tests/Translator/ConstantArray/Tests.fs @@ -8,22 +8,18 @@ open Expecto let private basePath = Path.Combine("Translator", "ConstantArray", "Expected") let private constantArrayTests = - [ let inline createTest name = Helpers.createTest basePath name + [ + let inline createTest name = Helpers.createTest basePath name - let cArray1 = - [| 1 - 2 - 3 |] + let cArray1 = [| 1; 2; 3 |] - <@ fun (range: Range1D) (buf: int clarray) -> buf.[0] <- cArray1.[1] @> - |> createTest "Constant array translation. Test 1" "Constant array translation. Test 1.cl" + <@ fun (range: Range1D) (buf: int clarray) -> buf.[0] <- cArray1.[1] @> + |> createTest "Constant array translation. Test 1" "Constant array translation. Test 1.cl" - let cArray1 = - [| 1 - 2 - 3 |] + let cArray1 = [| 1; 2; 3 |] - <@ fun (range: Range1D) (buf: int clarray) -> buf.[0] <- 1 + cArray1.[1] @> - |> createTest "Constant array translation. Test 2" "Constant array translation. Test 2.cl" ] + <@ fun (range: Range1D) (buf: int clarray) -> buf.[0] <- 1 + cArray1.[1] @> + |> createTest "Constant array translation. Test 2" "Constant array translation. Test 2.cl" + ] let tests = constantArrayTests |> testList "ConstantArray" diff --git a/tests/Brahma.FSharp.Tests/Translator/ControlFlow/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/ControlFlow/Tests.fs index 5d3d808d..a63ebb54 100644 --- a/tests/Brahma.FSharp.Tests/Translator/ControlFlow/Tests.fs +++ b/tests/Brahma.FSharp.Tests/Translator/ControlFlow/Tests.fs @@ -9,99 +9,101 @@ open Brahma.FSharp.OpenCL.Translator let private basePath = Path.Combine("Translator", "ControlFlow", "Expected") let private controlFlowTests = - [ let inline createTest name = Helpers.createTest basePath name - - let inline createPTest name _ = Helpers.createPTest name - - <@ - fun (range: Range1D) (buf: int clarray) -> - if 0 = 2 then - buf.[0] <- 1 - @> - |> createTest "If Then" "If.Then.cl" - - <@ fun (range: Range1D) (buf: int clarray) -> if 0 = 2 then buf.[0] <- 1 else buf.[0] <- 2 @> - |> createTest "If Then Else" "If.Then.Else.cl" - - <@ - fun (range: Range1D) (buf: int clarray) -> - for i in 1..3 do - buf.[0] <- i - @> - |> createTest "For Integer Loop" "For.Integer.Loop.cl" - - <@ - fun (range: Range1D) (buf: int clarray) -> - let x = 1 - let y = x + 1 - buf.[0] <- y - @> - |> createTest "Sequential bindings" "Sequential.Bindings.cl" - - <@ - fun (range: Range1D) (buf: int clarray) -> - if 2 = 0 then - let x = 1 - buf.[0] <- x - else - let i = 2 - buf.[0] <- i - @> - |> createTest "Binding in IF." "Binding.In.IF.cl" - - <@ - fun (range: Range1D) (buf: int clarray) -> - for i in 0..3 do - let x = i * i - buf.[0] <- x - @> - |> createTest "Binding in FOR." "Binding.In.FOR.cl" - - <@ - fun (range: Range1D) (buf: int clarray) -> - while buf.[0] < 5 do - buf.[0] <- buf.[0] + 1 - @> - |> createTest "Simple WHILE loop." "Simple.WHILE.cl" - - <@ - fun (range: Range1D) (buf: int clarray) -> - while buf.[0] < 5 do - let x = buf.[0] + 1 - buf.[0] <- x * x - @> - |> createTest "Binding in WHILE." "Binding.In.WHILE.cl" - - // WHILE with single statement in the body and this stetement is assignment of constant. - // This test translates to openCL correctly but breaks openCL compiler on ubuntu 18.04 - <@ - fun (range: Range1D) (buf: int clarray) -> - while true do - buf.[0] <- 1 - @> - |> createPTest "WHILE with single statement." - - <@ - fun (range: Range1D) (buf: int clarray) -> - while buf.[0] < 5 && (buf.[1] < 6 || buf.[2] > 2) do - buf.[0] <- 2 + buf.[0] - @> - |> createTest "WHILE with complex condition" "WHILE.with.complex.condition.cl" - - <@ - fun (range: Range1D) (buf: int clarray) -> - buf.[0] <- 2 - buf.[1] <- 3 - @> - |> createTest "Simple seq." "Simple.Seq.cl" - - <@ - fun (range: Range1D) (buf: int clarray) -> - let x = 2 - buf.[0] <- x - let y = 2 - buf.[1] <- y - @> - |> createTest "Seq with bindings." "Seq.With.Bindings.cl" ] + [ + let inline createTest name = Helpers.createTest basePath name + + let inline createPTest name _ = Helpers.createPTest name + + <@ + fun (range: Range1D) (buf: int clarray) -> + if 0 = 2 then + buf.[0] <- 1 + @> + |> createTest "If Then" "If.Then.cl" + + <@ fun (range: Range1D) (buf: int clarray) -> if 0 = 2 then buf.[0] <- 1 else buf.[0] <- 2 @> + |> createTest "If Then Else" "If.Then.Else.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + for i in 1..3 do + buf.[0] <- i + @> + |> createTest "For Integer Loop" "For.Integer.Loop.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + let x = 1 + let y = x + 1 + buf.[0] <- y + @> + |> createTest "Sequential bindings" "Sequential.Bindings.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + if 2 = 0 then + let x = 1 + buf.[0] <- x + else + let i = 2 + buf.[0] <- i + @> + |> createTest "Binding in IF." "Binding.In.IF.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + for i in 0..3 do + let x = i * i + buf.[0] <- x + @> + |> createTest "Binding in FOR." "Binding.In.FOR.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + while buf.[0] < 5 do + buf.[0] <- buf.[0] + 1 + @> + |> createTest "Simple WHILE loop." "Simple.WHILE.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + while buf.[0] < 5 do + let x = buf.[0] + 1 + buf.[0] <- x * x + @> + |> createTest "Binding in WHILE." "Binding.In.WHILE.cl" + + // WHILE with single statement in the body and this stetement is assignment of constant. + // This test translates to openCL correctly but breaks openCL compiler on ubuntu 18.04 + <@ + fun (range: Range1D) (buf: int clarray) -> + while true do + buf.[0] <- 1 + @> + |> createPTest "WHILE with single statement." + + <@ + fun (range: Range1D) (buf: int clarray) -> + while buf.[0] < 5 && (buf.[1] < 6 || buf.[2] > 2) do + buf.[0] <- 2 + buf.[0] + @> + |> createTest "WHILE with complex condition" "WHILE.with.complex.condition.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + buf.[0] <- 2 + buf.[1] <- 3 + @> + |> createTest "Simple seq." "Simple.Seq.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + let x = 2 + buf.[0] <- x + let y = 2 + buf.[1] <- y + @> + |> createTest "Seq with bindings." "Seq.With.Bindings.cl" + ] let tests = controlFlowTests |> testList "ControlFlow" diff --git a/tests/Brahma.FSharp.Tests/Translator/Injection/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/Injection/Tests.fs index 93227110..29da9f41 100644 --- a/tests/Brahma.FSharp.Tests/Translator/Injection/Tests.fs +++ b/tests/Brahma.FSharp.Tests/Translator/Injection/Tests.fs @@ -8,24 +8,26 @@ open Expecto let private basePath = Path.Combine("Translator", "Injection", "Expected") let private quotationsInjectionTests = - [ let inline createTest name = Helpers.createTest basePath name - - let myF = <@ fun x -> x * x @> - - <@ - fun (range: Range1D) (buf: int clarray) -> - buf.[0] <- (%myF) 2 - buf.[1] <- (%myF) 4 - @> - |> createTest "Quotations injections 1" "Quotations.Injections.1.cl" - - let myF = <@ fun x y -> x - y @> - - <@ - fun (range: Range1D) (buf: int clarray) -> - buf.[0] <- (%myF) 2 3 - buf.[1] <- (%myF) 4 5 - @> - |> createTest "Quotations injections 2" "Quotations.Injections.2.cl" ] + [ + let inline createTest name = Helpers.createTest basePath name + + let myF = <@ fun x -> x * x @> + + <@ + fun (range: Range1D) (buf: int clarray) -> + buf.[0] <- (%myF) 2 + buf.[1] <- (%myF) 4 + @> + |> createTest "Quotations injections 1" "Quotations.Injections.1.cl" + + let myF = <@ fun x y -> x - y @> + + <@ + fun (range: Range1D) (buf: int clarray) -> + buf.[0] <- (%myF) 2 3 + buf.[1] <- (%myF) 4 5 + @> + |> createTest "Quotations injections 2" "Quotations.Injections.2.cl" + ] let tests = quotationsInjectionTests |> testList "QuotationsInjection" diff --git a/tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Tests.fs index 7c4f1dfb..3a053c90 100644 --- a/tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Tests.fs +++ b/tests/Brahma.FSharp.Tests/Translator/LambdaLifting/Tests.fs @@ -8,253 +8,255 @@ open Expecto let private basePath = Path.Combine("Translator", "LambdaLifting", "Expected") let private lambdaLiftingTests = - [ let inline createTest name = Helpers.createTest basePath name - - <@ - fun (range: Range1D) (buf: int clarray) -> - let f = 3 - buf.[0] <- f - @> - |> createTest "Template Let Transformation Test 0" "Template Test 0.cl" - - <@ - fun (range: Range1D) (buf: int clarray) -> - let f = - let x = 3 - x - - buf.[0] <- f - @> - |> createTest "Template Let Transformation Test 1" "Template Test 1.cl" - - <@ - fun (range: Range1D) (buf: int clarray) -> - let f = - let x = - let y = 3 - y - - x - - buf.[0] <- f - @> - |> createTest "Template Let Transformation Test 2" "Template Test 2.cl" - - <@ - fun (range: Range1D) (buf: int clarray) -> - let f = - let f = 5 - f - - buf.[0] <- f - @> - |> createTest "Template Let Transformation Test 3" "Template Test 3.cl" - - <@ - fun (range: Range1D) (buf: int clarray) -> - let f = - let f = - let f = 5 - f - - f - - buf.[0] <- f - @> - |> createTest "Template Let Transformation Test 4" "Template Test 4.cl" - - <@ - fun (range: Range1D) (buf: int clarray) -> - let f a b = - let x y z = y + z - x a b - - buf.[0] <- f 1 7 - @> - |> createTest "Template Let Transformation Test 5" "Template Test 5.cl" - - <@ - fun (range: Range1D) (buf: int clarray) -> - let f x y = - let x = x - x + y - - buf.[0] <- f 7 8 - @> - |> createTest "Template Let Transformation Test 6" "Template Test 6.cl" - - <@ - fun (range: Range1D) (buf: int clarray) -> - let f y = - let x y = 6 - y - x y - - buf.[0] <- f 7 - @> - |> createTest "Template Let Transformation Test 7" "Template Test 7.cl" - - <@ - fun (range: Range1D) (m: int clarray) -> - let p = m.[0] - - let x n = - let l = m.[9] - let g k = k + m.[0] + m.[1] - - let r = - let y a = - let x = 5 - n + (g 4) - let z t = m.[2] + a - t - z (a + x + l) - - y 6 - - r + m.[3] - - m.[0] <- x 7 - @> - |> createTest "Template Let Transformation Test 8" "Template Test 8.cl" - - <@ - fun (range: Range1D) (buf: int clarray) -> - let x n = - let r = 8 - let h = r + n - h - - buf.[0] <- x 9 - @> - |> createTest "Template Let Transformation Test 9" "Template Test 9.cl" - - <@ - fun (range: Range1D) (buf: int clarray) -> - let p = 9 - - let x n b = - let t = 0 - n + b + t - - buf.[0] <- x 7 9 - @> - |> createTest "Template Let Transformation Test 10" "Template Test 10.cl" - - <@ - fun (range: Range1D) (buf: int clarray) -> - let p = 1 - - let m = - let r l = l + p - r 9 - - let z k = k + 1 - buf.[0] <- m - @> - |> createTest "Template Let Transformation Test 11" "Template Test 11.cl" - - <@ - fun (range: Range1D) (buf: int clarray) -> - let f x y = - let y = y - let y = y - let g x m = m + x - g x y - - buf.[0] <- f 1 7 - @> - |> createTest "Template Let Transformation Test 12" "Template Test 12.cl" - - <@ - fun (range: Range1D) (buf: int clarray) -> - let f y = - let y = y - let y = y - let g m = m + 1 - g y - - buf.[0] <- f 7 - @> - |> createTest "Template Let Transformation Test 13" "Template Test 13.cl" - - <@ - fun (range: Range1D) (buf: int clarray) -> - let f (y: int) = - let y = y - let y = y - - let g (m: int) = - let g r t = r + y - t - let n o = o - (g y 2) - n 5 - - g y - - let z y = y - 2 - buf.[0] <- f (z 7) - @> - |> createTest "Template Let Transformation Test 14" "Template Test 14.cl" - - <@ - fun (range: Range1D) (buf: int clarray) -> - let f y = - let Argi index = if index = 0 then buf.[1] else buf.[2] - Argi y - - buf.[0] <- f 0 - @> - |> createTest "Template Let Transformation Test 15" "Template Test 15.cl" - - <@ - fun (range: Range1D) (buf: int clarray) -> - let f y = - if y = 0 then - let z a = a + 1 - z 9 - else - buf.[2] - - buf.[0] <- f 0 - @> - |> createTest "Template Let Transformation Test 16" "Template Test 16.cl" - - <@ - fun (range: Range1D) (buf: int clarray) -> - let f x = - let g = 1 + x - g - - buf.[0] <- f 1 - @> - |> createTest "Let renamed" "Let renamed.cl" - - <@ - fun (range: Range1D) (buf: int clarray) -> - let f m k = - let g q w = 1 + q + w - let t p = 7 - p - (g 1 2) - m * k / (t 53) - - buf.[0] <- f 1 4 - @> - |> createTest "Let renamed 2" "Let renamed 2.cl" - - <@ - fun (range: Range1D) (buf: int clarray) -> - let f x y = - let y = y - let y = y - let g x m = m + x - g x y - - buf.[0] <- f 1 7 - @> - |> createTest "Renamer Test" "Renamer Test.cl" - - <@ - fun (range: Range1D) (buf: int clarray) -> - let f x y = x - y - buf.[0] <- f 2 3 - buf.[1] <- f 4 5 - @> - |> createTest "Nested functions" "Nested.Function.cl" ] + [ + let inline createTest name = Helpers.createTest basePath name + + <@ + fun (range: Range1D) (buf: int clarray) -> + let f = 3 + buf.[0] <- f + @> + |> createTest "Template Let Transformation Test 0" "Template Test 0.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + let f = + let x = 3 + x + + buf.[0] <- f + @> + |> createTest "Template Let Transformation Test 1" "Template Test 1.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + let f = + let x = + let y = 3 + y + + x + + buf.[0] <- f + @> + |> createTest "Template Let Transformation Test 2" "Template Test 2.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + let f = + let f = 5 + f + + buf.[0] <- f + @> + |> createTest "Template Let Transformation Test 3" "Template Test 3.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + let f = + let f = + let f = 5 + f + + f + + buf.[0] <- f + @> + |> createTest "Template Let Transformation Test 4" "Template Test 4.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + let f a b = + let x y z = y + z + x a b + + buf.[0] <- f 1 7 + @> + |> createTest "Template Let Transformation Test 5" "Template Test 5.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + let f x y = + let x = x + x + y + + buf.[0] <- f 7 8 + @> + |> createTest "Template Let Transformation Test 6" "Template Test 6.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + let f y = + let x y = 6 - y + x y + + buf.[0] <- f 7 + @> + |> createTest "Template Let Transformation Test 7" "Template Test 7.cl" + + <@ + fun (range: Range1D) (m: int clarray) -> + let p = m.[0] + + let x n = + let l = m.[9] + let g k = k + m.[0] + m.[1] + + let r = + let y a = + let x = 5 - n + (g 4) + let z t = m.[2] + a - t + z (a + x + l) + + y 6 + + r + m.[3] + + m.[0] <- x 7 + @> + |> createTest "Template Let Transformation Test 8" "Template Test 8.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + let x n = + let r = 8 + let h = r + n + h + + buf.[0] <- x 9 + @> + |> createTest "Template Let Transformation Test 9" "Template Test 9.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + let p = 9 + + let x n b = + let t = 0 + n + b + t + + buf.[0] <- x 7 9 + @> + |> createTest "Template Let Transformation Test 10" "Template Test 10.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + let p = 1 + + let m = + let r l = l + p + r 9 + + let z k = k + 1 + buf.[0] <- m + @> + |> createTest "Template Let Transformation Test 11" "Template Test 11.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + let f x y = + let y = y + let y = y + let g x m = m + x + g x y + + buf.[0] <- f 1 7 + @> + |> createTest "Template Let Transformation Test 12" "Template Test 12.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + let f y = + let y = y + let y = y + let g m = m + 1 + g y + + buf.[0] <- f 7 + @> + |> createTest "Template Let Transformation Test 13" "Template Test 13.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + let f (y: int) = + let y = y + let y = y + + let g (m: int) = + let g r t = r + y - t + let n o = o - (g y 2) + n 5 + + g y + + let z y = y - 2 + buf.[0] <- f (z 7) + @> + |> createTest "Template Let Transformation Test 14" "Template Test 14.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + let f y = + let Argi index = if index = 0 then buf.[1] else buf.[2] + Argi y + + buf.[0] <- f 0 + @> + |> createTest "Template Let Transformation Test 15" "Template Test 15.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + let f y = + if y = 0 then + let z a = a + 1 + z 9 + else + buf.[2] + + buf.[0] <- f 0 + @> + |> createTest "Template Let Transformation Test 16" "Template Test 16.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + let f x = + let g = 1 + x + g + + buf.[0] <- f 1 + @> + |> createTest "Let renamed" "Let renamed.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + let f m k = + let g q w = 1 + q + w + let t p = 7 - p + (g 1 2) - m * k / (t 53) + + buf.[0] <- f 1 4 + @> + |> createTest "Let renamed 2" "Let renamed 2.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + let f x y = + let y = y + let y = y + let g x m = m + x + g x y + + buf.[0] <- f 1 7 + @> + |> createTest "Renamer Test" "Renamer Test.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + let f x y = x - y + buf.[0] <- f 2 3 + buf.[1] <- f 4 5 + @> + |> createTest "Nested functions" "Nested.Function.cl" + ] let tests = lambdaLiftingTests |> testList "LambdaLifting" diff --git a/tests/Brahma.FSharp.Tests/Translator/LangExtensions/Atomic.fs b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/Atomic.fs index 6d73c9ef..e423521a 100644 --- a/tests/Brahma.FSharp.Tests/Translator/LangExtensions/Atomic.fs +++ b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/Atomic.fs @@ -6,52 +6,55 @@ open Brahma.FSharp.Tests.Translator.Common let test = - [ testCase "Multiple local values in atomic operations" - <| fun () -> - let kernel = - <@ - fun (ndRange: Range1D) (v: int) -> - let mutable firstMaxIndex = local () - let mutable secondMaxIndex = local () - let mutable value = local () + [ + testCase "Multiple local values in atomic operations" + <| fun () -> + let kernel = + <@ + fun (ndRange: Range1D) (v: int) -> + let mutable firstMaxIndex = local () + let mutable secondMaxIndex = local () + let mutable value = local () - if ndRange.LocalID0 = 0 then - firstMaxIndex <- 0 - secondMaxIndex <- 0 - value <- v + if ndRange.LocalID0 = 0 then + firstMaxIndex <- 0 + secondMaxIndex <- 0 + value <- v - barrierLocal () + barrierLocal () - atomic (max) firstMaxIndex value |> ignore - atomic (max) secondMaxIndex value |> ignore - @> + atomic (max) firstMaxIndex value |> ignore + atomic (max) secondMaxIndex value |> ignore + @> - Helpers.openclTranslate kernel |> ignore ] + Helpers.openclTranslate kernel |> ignore + ] let commonApiTests = [ - // TODO is it correct? - ptestCase "Using atomic in lambda should not raise exception if first parameter passed" - <| fun () -> - let command = - <@ - fun (range: Range1D) (buffer: int[]) -> - let g = atomic (fun x y -> x + 1) buffer.[0] - g 5 |> ignore - @> - - command |> Helpers.openclTranslate |> ignore - - // TODO is it correct? - ptestCase "Using atomic in lambda should raise exception if first parameter is argument" - <| fun () -> - let command = - <@ - fun (range: Range1D) (buffer: int[]) -> - let g x y = atomic (+) x y - g buffer.[0] 6 |> ignore - @> - - Expect.throwsT - <| fun () -> command |> Helpers.openclTranslate |> ignore - <| "Exception should be thrown" ] + // TODO is it correct? + ptestCase "Using atomic in lambda should not raise exception if first parameter passed" + <| fun () -> + let command = + <@ + fun (range: Range1D) (buffer: int[]) -> + let g = atomic (fun x y -> x + 1) buffer.[0] + g 5 |> ignore + @> + + command |> Helpers.openclTranslate |> ignore + + // TODO is it correct? + ptestCase "Using atomic in lambda should raise exception if first parameter is argument" + <| fun () -> + let command = + <@ + fun (range: Range1D) (buffer: int[]) -> + let g x y = atomic (+) x y + g buffer.[0] 6 |> ignore + @> + + Expect.throwsT + <| fun () -> command |> Helpers.openclTranslate |> ignore + <| "Exception should be thrown" + ] diff --git a/tests/Brahma.FSharp.Tests/Translator/LangExtensions/Barrier/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/Barrier/Tests.fs index 67e7b1a4..fea38a42 100644 --- a/tests/Brahma.FSharp.Tests/Translator/LangExtensions/Barrier/Tests.fs +++ b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/Barrier/Tests.fs @@ -9,15 +9,17 @@ let private basePath = Path.Combine("Translator", "LangExtensions", "Barrier", "Expected") let private barrierTests = - [ let inline createTest name = Helpers.createTest basePath name + [ + let inline createTest name = Helpers.createTest basePath name - <@ fun (range: Range1D) -> barrierLocal () @> - |> createTest "Local barrier translation tests" "Barrier.Local.cl" + <@ fun (range: Range1D) -> barrierLocal () @> + |> createTest "Local barrier translation tests" "Barrier.Local.cl" - <@ fun (range: Range1D) -> barrierGlobal () @> - |> createTest "Global barrier translation tests" "Barrier.Global.cl" + <@ fun (range: Range1D) -> barrierGlobal () @> + |> createTest "Global barrier translation tests" "Barrier.Global.cl" - <@ fun (range: Range1D) -> barrierFull () @> - |> createTest "Full barrier translation tests" "Barrier.Full.cl" ] + <@ fun (range: Range1D) -> barrierFull () @> + |> createTest "Full barrier translation tests" "Barrier.Full.cl" + ] let tests = barrierTests |> testList "Barrier" diff --git a/tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalID/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalID/Tests.fs index d1a1d908..9f632712 100644 --- a/tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalID/Tests.fs +++ b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalID/Tests.fs @@ -9,21 +9,23 @@ let private basePath = Path.Combine("Translator", "LangExtensions", "LocalID", "Expected") let private basicLocalIdTests = - [ let inline createTest name = Helpers.createTest basePath name + [ + let inline createTest name = Helpers.createTest basePath name - <@ - fun (range: Range1D) (buf: int clarray) -> - let id = range.LocalID0 - buf.[id] <- 0 - @> - |> createTest "LocalID of 1D" "LocalID1D.cl" + <@ + fun (range: Range1D) (buf: int clarray) -> + let id = range.LocalID0 + buf.[id] <- 0 + @> + |> createTest "LocalID of 1D" "LocalID1D.cl" - <@ - fun (range: Range2D) (buf: int clarray) -> - let v = range.LocalID0 - let id = range.LocalID1 - buf.[id] <- v - @> - |> createTest "LocalID of 2D" "LocalID2D.cl" ] + <@ + fun (range: Range2D) (buf: int clarray) -> + let v = range.LocalID0 + let id = range.LocalID1 + buf.[id] <- v + @> + |> createTest "LocalID of 2D" "LocalID2D.cl" + ] let tests = basicLocalIdTests |> testList "BasicLocalId" diff --git a/tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalMemory/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalMemory/Tests.fs index e6750668..dc544e3d 100644 --- a/tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalMemory/Tests.fs +++ b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/LocalMemory/Tests.fs @@ -9,27 +9,29 @@ let private basePath = Path.Combine("Translator", "LangExtensions", "LocalMemory", "Expected") let private localMemoryTests = - [ let inline createTest name = Helpers.createTest basePath name + [ + let inline createTest name = Helpers.createTest basePath name - <@ - fun (range: Range1D) -> - let mutable x = local () - x <- 0 - @> - |> createTest "Local int" "LocalMemory.int.cl" + <@ + fun (range: Range1D) -> + let mutable x = local () + x <- 0 + @> + |> createTest "Local int" "LocalMemory.int.cl" - <@ - fun (range: Range1D) -> - let mutable x = local () - x <- 0.0 - @> - |> createTest "Local float" "LocalMemory.float.cl" + <@ + fun (range: Range1D) -> + let mutable x = local () + x <- 0.0 + @> + |> createTest "Local float" "LocalMemory.float.cl" - <@ - fun (range: Range1D) -> - let xs = localArray 5 - xs.[range.LocalID0] <- range.LocalID0 - @> - |> createTest "Local int array" "LocalMemory.int [].cl" ] + <@ + fun (range: Range1D) -> + let xs = localArray 5 + xs.[range.LocalID0] <- range.LocalID0 + @> + |> createTest "Local int array" "LocalMemory.int [].cl" + ] let tests = localMemoryTests |> testList "LocalMemory" diff --git a/tests/Brahma.FSharp.Tests/Translator/LangExtensions/WorkSize/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/WorkSize/Tests.fs index 83cb3868..197e32c4 100644 --- a/tests/Brahma.FSharp.Tests/Translator/LangExtensions/WorkSize/Tests.fs +++ b/tests/Brahma.FSharp.Tests/Translator/LangExtensions/WorkSize/Tests.fs @@ -9,30 +9,32 @@ let private basePath = Path.Combine("Translator", "LangExtensions", "WorkSize", "Expected") let private basicWorkSizeTests = - [ let inline createTest name = Helpers.createTest basePath name + [ + let inline createTest name = Helpers.createTest basePath name - <@ - fun (range: Range1D) (buf: int clarray) -> - let gSize = range.GlobalWorkSize - let lSize = range.LocalWorkSize - () - @> - |> createTest "WorkSize of 1D" "WorkSize1D.cl" + <@ + fun (range: Range1D) (buf: int clarray) -> + let gSize = range.GlobalWorkSize + let lSize = range.LocalWorkSize + () + @> + |> createTest "WorkSize of 1D" "WorkSize1D.cl" - <@ - fun (range: Range2D) (buf: int clarray) -> - let (gSizeX, gSizeY) = range.GlobalWorkSize - let (lSizeX, lSizeY) = range.LocalWorkSize - () - @> - |> createTest "WorkSize of 2D" "WorkSize2D.cl" + <@ + fun (range: Range2D) (buf: int clarray) -> + let (gSizeX, gSizeY) = range.GlobalWorkSize + let (lSizeX, lSizeY) = range.LocalWorkSize + () + @> + |> createTest "WorkSize of 2D" "WorkSize2D.cl" - <@ - fun (range: Range3D) (buf: int clarray) -> - let (gSizeX, gSizeY, gSizeZ) = range.GlobalWorkSize - let (lSizeX, lSizeY, lSizeZ) = range.LocalWorkSize - () - @> - |> createTest "WorkSize of 3D" "WorkSize3D.cl" ] + <@ + fun (range: Range3D) (buf: int clarray) -> + let (gSizeX, gSizeY, gSizeZ) = range.GlobalWorkSize + let (lSizeX, lSizeY, lSizeZ) = range.LocalWorkSize + () + @> + |> createTest "WorkSize of 3D" "WorkSize3D.cl" + ] let tests = basicWorkSizeTests |> testList "BasicWorkSize" diff --git a/tests/Brahma.FSharp.Tests/Translator/NamesResolving/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/NamesResolving/Tests.fs index dc5a883c..67eb37fd 100644 --- a/tests/Brahma.FSharp.Tests/Translator/NamesResolving/Tests.fs +++ b/tests/Brahma.FSharp.Tests/Translator/NamesResolving/Tests.fs @@ -8,50 +8,52 @@ open Expecto let private basePath = Path.Combine("Translator", "NamesResolving", "Expected") let private namesResolvingTests = - [ let inline createTest name = Helpers.createTest basePath name - - <@ - fun (range: Range1D) (buf: int clarray) -> - let x = 2 - buf.[0] <- x - let x = 3 - buf.[1] <- x - @> - |> createTest "Bindings with equal names." "Bindings.With.Equal.Names.cl" - - <@ - fun (range: Range1D) (buf: int clarray) -> - let i = 2 - - for i in 1..2 do - buf.[1] <- i - @> - |> createTest "Binding and FOR counter conflict 1." "Binding.And.FOR.Counter.Conflict.1.cl" - - <@ - fun (range: Range1D) (buf: int clarray) -> - for i in 1..2 do - let i = 2 - buf.[1] <- i - @> - |> createTest "Binding and FOR counter conflict 2." "Binding.And.FOR.Counter.Conflict.2.cl" - - <@ - fun (range: Range1D) (buf: int clarray) -> - for i in 0..1 do - let i = i + 2 - buf.[i] <- 2 - @> - |> createTest "Binding and FOR counter conflict 3." "Binding.And.FOR.Counter.Conflict.3.cl" - - <@ - fun (range: Range1D) (buf: int clarray) -> - let i = 1 - - for i in 0 .. i + 1 do - let i = i + 2 - buf.[i] <- 2 - @> - |> createTest "Binding and FOR counter conflict 4." "Binding.And.FOR.Counter.Conflict.4.cl" ] + [ + let inline createTest name = Helpers.createTest basePath name + + <@ + fun (range: Range1D) (buf: int clarray) -> + let x = 2 + buf.[0] <- x + let x = 3 + buf.[1] <- x + @> + |> createTest "Bindings with equal names." "Bindings.With.Equal.Names.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + let i = 2 + + for i in 1..2 do + buf.[1] <- i + @> + |> createTest "Binding and FOR counter conflict 1." "Binding.And.FOR.Counter.Conflict.1.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + for i in 1..2 do + let i = 2 + buf.[1] <- i + @> + |> createTest "Binding and FOR counter conflict 2." "Binding.And.FOR.Counter.Conflict.2.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + for i in 0..1 do + let i = i + 2 + buf.[i] <- 2 + @> + |> createTest "Binding and FOR counter conflict 3." "Binding.And.FOR.Counter.Conflict.3.cl" + + <@ + fun (range: Range1D) (buf: int clarray) -> + let i = 1 + + for i in 0 .. i + 1 do + let i = i + 2 + buf.[i] <- 2 + @> + |> createTest "Binding and FOR counter conflict 4." "Binding.And.FOR.Counter.Conflict.4.cl" + ] let tests = namesResolvingTests |> testList "NamesResolving" diff --git a/tests/Brahma.FSharp.Tests/Translator/Printf/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/Printf/Tests.fs index 6b28a7ad..7fb7bcea 100644 --- a/tests/Brahma.FSharp.Tests/Translator/Printf/Tests.fs +++ b/tests/Brahma.FSharp.Tests/Translator/Printf/Tests.fs @@ -8,38 +8,40 @@ open Expecto let private basePath = Path.Combine("Translator", "Printf", "Expected") let private printfTests = - [ let inline createTest name = Helpers.createTest basePath name + [ + let inline createTest name = Helpers.createTest basePath name - <@ fun (range: Range1D) -> printf "%d %f" 10 15.0 @> - |> createTest "Printf test 1" "Printf test 1.cl" + <@ fun (range: Range1D) -> printf "%d %f" 10 15.0 @> + |> createTest "Printf test 1" "Printf test 1.cl" - <@ - fun (range: Range1D) (xs: int clarray) -> - let gid = range.GlobalID0 - let x = 10 + <@ + fun (range: Range1D) (xs: int clarray) -> + let gid = range.GlobalID0 + let x = 10 - printf "%d %d" x xs.[gid] - @> - |> createTest "Printf test 2" "Printf test 2.cl" + printf "%d %d" x xs.[gid] + @> + |> createTest "Printf test 2" "Printf test 2.cl" - <@ - fun (range: Range1D) (xs: int clarray) -> - let mutable i = 0 + <@ + fun (range: Range1D) (xs: int clarray) -> + let mutable i = 0 - while i < 10 do - xs.[0] <- i * 2 - printf "i = %d, xs.[0]*10 = %d\n" i (xs.[0] + 10) - i <- i + 1 - @> - |> createTest "Printf test 3" "Printf test 3.cl" + while i < 10 do + xs.[0] <- i * 2 + printf "i = %d, xs.[0]*10 = %d\n" i (xs.[0] + 10) + i <- i + 1 + @> + |> createTest "Printf test 3" "Printf test 3.cl" - <@ fun (range: Range1D) -> printfn "%d %f" 10 15.0 @> - |> createTest "Printf test 4: printfn" "Printf test 4.cl" + <@ fun (range: Range1D) -> printfn "%d %f" 10 15.0 @> + |> createTest "Printf test 4: printfn" "Printf test 4.cl" - <@ fun (range: Range1D) -> printf "I am complied" @> - |> createTest "Printf test 5: printf without args" "Printf test 5.cl" + <@ fun (range: Range1D) -> printf "I am complied" @> + |> createTest "Printf test 5: printf without args" "Printf test 5.cl" - <@ fun (range: Range1D) -> printfn "I am complied too" @> - |> createTest "Printf test 6: printfn without args" "Printf test 6.cl" ] + <@ fun (range: Range1D) -> printfn "I am complied too" @> + |> createTest "Printf test 6: printfn without args" "Printf test 6.cl" + ] let tests = printfTests |> testList "Printf" diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Common.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Common.fs index 22386638..153109b6 100644 --- a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Common.fs +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Common.fs @@ -51,5 +51,4 @@ module Helpers = varEqual (fst actual) (fst expected) exprEqual (snd actual) (snd expected) - let createMapTestAndCompareAsStrings map name source expected = - test name { exprEqual (map source) expected } + let createMapTestAndCompareAsStrings map name source expected = test name { exprEqual (map source) expected } diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Lifting.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Lifting.fs index 25c068dc..e84d7e99 100644 --- a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Lifting.fs +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Lifting.fs @@ -6,207 +6,203 @@ open Common open FSharp.Quotations let parameterLiftingTests = - let createTest name = - createMapTestAndCompareAsStrings Lift.Parameters.lift name - - [ createTest - "Test 1" - <@ - let x = 1 - let addToX y = x + y - addToX 2 - @> - <@ - let x = 1 - let addToX x y = x + y - addToX x 2 - @> - - createTest - "Test 2" - <@ - let x = 1 - let z = x - - let addToX y = // freeVars: [x, z] - x + y + z - - let f z1 = // freeVars: [], addToX freeVars: [x, z] - 2 + addToX z1 - - f 3 - @> - <@ - let x = 1 - let z = x - - let addToX x z y = x + y + z - let f x z z1 = 2 + addToX x z z1 - f x z 3 - @> - - createTest - "Test 3" - <@ - let mainX = "global variable" - let mainY = "global variable" - let mainZ = "global variable" - - let foo fooX = - let fooY = "local variable of foo" - let bar barX = mainX + fooY + barX - bar fooX + mainY - - foo mainZ - @> - <@ - let mainX = "global variable" - let mainY = "global variable" - let mainZ = "global variable" - - let foo mainX mainY fooX = - let fooY = "local variable of foo" - let bar fooY mainX barX = mainX + fooY + barX - bar fooY mainX fooX + mainY - - foo mainX mainY mainZ - @> - - createTest - "Test 4" - <@ - let x0 = 0 - - let f x1 = - let g x2 = - let h x3 = x3 + x0 - h x2 - - g x1 - - f x0 - @> - <@ - let x0 = 0 - - let f x0 x1 = - let g x0 x2 = - let h x0 x3 = x3 + x0 - h x0 x2 - - g x0 x1 - - f x0 x0 - @> - - createTest "Test 5" // id - <| <@ let f = let x = 4 in x in () @> - <| <@ let f = let x = 4 in x in () @> ] + let createTest name = createMapTestAndCompareAsStrings Lift.Parameters.lift name + + [ + createTest + "Test 1" + <@ + let x = 1 + let addToX y = x + y + addToX 2 + @> + <@ + let x = 1 + let addToX x y = x + y + addToX x 2 + @> + + createTest + "Test 2" + <@ + let x = 1 + let z = x + + let addToX y = // freeVars: [x, z] + x + y + z + + let f z1 = // freeVars: [], addToX freeVars: [x, z] + 2 + addToX z1 + + f 3 + @> + <@ + let x = 1 + let z = x + + let addToX x z y = x + y + z + let f x z z1 = 2 + addToX x z z1 + f x z 3 + @> + + createTest + "Test 3" + <@ + let mainX = "global variable" + let mainY = "global variable" + let mainZ = "global variable" + + let foo fooX = + let fooY = "local variable of foo" + let bar barX = mainX + fooY + barX + bar fooX + mainY + + foo mainZ + @> + <@ + let mainX = "global variable" + let mainY = "global variable" + let mainZ = "global variable" + + let foo mainX mainY fooX = + let fooY = "local variable of foo" + let bar fooY mainX barX = mainX + fooY + barX + bar fooY mainX fooX + mainY + + foo mainX mainY mainZ + @> + + createTest + "Test 4" + <@ + let x0 = 0 + + let f x1 = + let g x2 = + let h x3 = x3 + x0 + h x2 + + g x1 + + f x0 + @> + <@ + let x0 = 0 + + let f x0 x1 = + let g x0 x2 = + let h x0 x3 = x3 + x0 + h x0 x2 + + g x0 x1 + + f x0 x0 + @> + + createTest "Test 5" // id + <| <@ let f = let x = 4 in x in () @> + <| <@ let f = let x = 4 in x in () @> + ] |> testList "Parameter" let unitVar name = expVar name let unitCleanUpTests = - let createTest name = - createMapTestAndCompareAsStrings Lift.UnitArguments.cleanUp name - - [ createTest "Test 1" - <| <@ let f (x: unit) = x in () @> - <| <@ let f (x: unit) = x in () @> - - createTest "Test 2" - <| <@ let f (x: unit) (y: int) = x in () @> - <| <@ let f (y: int) = (%unitVar "x") in () @> - - createTest "Test 3" - <| <@ let f (x: unit) (y: unit) = x in () @> - <| <@ let f (x: unit) = x in () @> - - createTest "Test 3.5" - <| <@ let f (x: unit) (y: unit) = y in () @> - <| <@ let f (x: unit) = (%unitVar "y") in () @> - - createTest "Test 4" - <| <@ let f (x: int) = x in () @> - <| <@ let f (x: int) = x in () @> - - createTest "Test 5" - <| <@ let f (x: int option) = x in () @> - <| <@ let f (x: int option) = x in () @> - - createTest "Test 6" - <| <@ let f (x: unit option) = x in () @> - <| <@ let f (x: unit option) = x in () @> - - createTest "Test 7" - <| <@ let f (x: unit) (y: unit) (z: unit) = if x = y then z else y in () @> - <| <@ - let f (x: unit) = - if x = (%unitVar "y") then - (%unitVar "z") - else - (%unitVar "y") in () - @> - - createTest "Test 8" - <| <@ let f (x: unit) = let g (y: unit) = Some() in () in () @> - <| <@ let f (x: unit) = let g (y: unit) = Some() in () in () @> - - createTest "Test 9" - <| <@ let f (x: unit) (y: unit) = let g (z: unit) (c: unit) = x in g y x in () @> - <| <@ let f (x: unit) = let g (z: unit) = x in g (%unitVar "y") in () @> - - createTest "Test 10" - <| <@ - let f () = - printfn "side effect" - () - - let g (x: unit) (y: unit) (z: int) = z - - // side effect in f application - g (f ()) () 0 - @> - <| <@ - let f () = - printfn "side effect" - () - - let g (z: int) = z - - f () // side effect - g 0 - @> - - createTest "Test 11" - <| <@ - let f (x: int) = - printfn "side effect" - () in - - let g (x: unit) (y: int) = y in - - // side effect in f application - g (f 0) 0 - @> - <| <@ - let f (x: int) = - printfn "side effect" - () in - - let g (y: int) = y in - - f 0 // side effect - g 0 - @> - - createTest "Test 12" // id - <| <@ let f (x: int) = x in f 4 @> - <| <@ let f (x: int) = x in f 4 @> - - createTest "Test 13" - <| <@ let f = let fUnitFunc () = let x = 3 in x in fUnitFunc () in () @> - <| <@ let f = let fUnitFunc () = let x = 3 in x in fUnitFunc () in () @> ] + let createTest name = createMapTestAndCompareAsStrings Lift.UnitArguments.cleanUp name + + [ + createTest "Test 1" + <| <@ let f (x: unit) = x in () @> + <| <@ let f (x: unit) = x in () @> + + createTest "Test 2" + <| <@ let f (x: unit) (y: int) = x in () @> + <| <@ let f (y: int) = (%unitVar "x") in () @> + + createTest "Test 3" + <| <@ let f (x: unit) (y: unit) = x in () @> + <| <@ let f (x: unit) = x in () @> + + createTest "Test 3.5" + <| <@ let f (x: unit) (y: unit) = y in () @> + <| <@ let f (x: unit) = (%unitVar "y") in () @> + + createTest "Test 4" + <| <@ let f (x: int) = x in () @> + <| <@ let f (x: int) = x in () @> + + createTest "Test 5" + <| <@ let f (x: int option) = x in () @> + <| <@ let f (x: int option) = x in () @> + + createTest "Test 6" + <| <@ let f (x: unit option) = x in () @> + <| <@ let f (x: unit option) = x in () @> + + createTest "Test 7" + <| <@ let f (x: unit) (y: unit) (z: unit) = if x = y then z else y in () @> + <| <@ let f (x: unit) = if x = (%unitVar "y") then (%unitVar "z") else (%unitVar "y") in () @> + + createTest "Test 8" + <| <@ let f (x: unit) = let g (y: unit) = Some() in () in () @> + <| <@ let f (x: unit) = let g (y: unit) = Some() in () in () @> + + createTest "Test 9" + <| <@ let f (x: unit) (y: unit) = let g (z: unit) (c: unit) = x in g y x in () @> + <| <@ let f (x: unit) = let g (z: unit) = x in g (%unitVar "y") in () @> + + createTest "Test 10" + <| <@ + let f () = + printfn "side effect" + () + + let g (x: unit) (y: unit) (z: int) = z + + // side effect in f application + g (f ()) () 0 + @> + <| <@ + let f () = + printfn "side effect" + () + + let g (z: int) = z + + f () // side effect + g 0 + @> + + createTest "Test 11" + <| <@ + let f (x: int) = + printfn "side effect" + () in + + let g (x: unit) (y: int) = y in + + // side effect in f application + g (f 0) 0 + @> + <| <@ + let f (x: int) = + printfn "side effect" + () in + + let g (y: int) = y in + + f 0 // side effect + g 0 + @> + + createTest "Test 12" // id + <| <@ let f (x: int) = x in f 4 @> + <| <@ let f (x: int) = x in f 4 @> + + createTest "Test 13" + <| <@ let f = let fUnitFunc () = let x = 3 in x in fUnitFunc () in () @> + <| <@ let f = let fUnitFunc () = let x = 3 in x in fUnitFunc () in () @> + ] |> testList "Unit clean up" let lambdaLiftingTests = @@ -221,65 +217,73 @@ let lambdaLiftingTests = equalAsStrings actualKernel expectedKernel <| "Kernels should be the same" } - [ createTest "Test 1" - <| <@ let f () = () in () @> // source - <| <@ () @> // kernel - <| [ var unit> "f", <@ fun (unitVar0: unit) -> () @> ] // lifted lambdas (var, body) - - createTest "Test 2" - <| <@ let f () = printfn "text" in () @> - <| <@ () @> - <| [ var unit> "f", <@ fun (unitVar0: unit) -> printfn "text" @> ] - - createTest "Test 3" - <| <@ let f (x: int) = () in () @> - <| <@ () @> - <| [ var unit> "f", <@ fun (x: int) -> () @> ] - - createTest "Test 4" - <| <@ let f (x: int) = Some 0 in () @> - <| <@ () @> - <| [ var int option> "f", <@ fun (x: int) -> Some 0 @> ] - - createTest "Test 5" - <| <@ - let f () = - printfn "first" - printfn "second" in () - @> - <| <@ () @> - <| [ var unit> "f", - <@ - fun (unitVar0: unit) -> - printfn "first" - printfn "second" - @> ] - - createTest "Test 6" - <| <@ - let f () = () in - let g () = () in - () - @> - <| <@ () @> - <| [ var unit> "f", <@ fun (unitVar0: unit) -> () @> - var unit> "g", <@ fun (unitVar0: unit) -> () @> ] - - createTest "Test 7" - <| <@ let f () = let g () = () in () in () @> - <| <@ () @> - <| [ var unit> "g", <@ fun (unitVar0: unit) -> () @> - var unit> "f", <@ fun (unitVar0: unit) -> () @> ] - - createTest "Test 8" - <| <@ let f (x: int) = let g () = x in () in () @> - <| <@ () @> - <| [ var int> "g", <@@ fun (unitVar0: unit) -> (%expVar "x") @@> - var unit> "f", <@@ fun (x: int) -> () @@> ] ] + [ + createTest "Test 1" + <| <@ let f () = () in () @> // source + <| <@ () @> // kernel + <| [ var unit> "f", <@ fun (unitVar0: unit) -> () @> ] // lifted lambdas (var, body) + + createTest "Test 2" + <| <@ let f () = printfn "text" in () @> + <| <@ () @> + <| [ var unit> "f", <@ fun (unitVar0: unit) -> printfn "text" @> ] + + createTest "Test 3" + <| <@ let f (x: int) = () in () @> + <| <@ () @> + <| [ var unit> "f", <@ fun (x: int) -> () @> ] + + createTest "Test 4" + <| <@ let f (x: int) = Some 0 in () @> + <| <@ () @> + <| [ var int option> "f", <@ fun (x: int) -> Some 0 @> ] + + createTest "Test 5" + <| <@ + let f () = + printfn "first" + printfn "second" in () + @> + <| <@ () @> + <| [ + var unit> "f", + <@ + fun (unitVar0: unit) -> + printfn "first" + printfn "second" + @> + ] + + createTest "Test 6" + <| <@ + let f () = () in + let g () = () in + () + @> + <| <@ () @> + <| [ + var unit> "f", <@ fun (unitVar0: unit) -> () @> + var unit> "g", <@ fun (unitVar0: unit) -> () @> + ] + + createTest "Test 7" + <| <@ let f () = let g () = () in () in () @> + <| <@ () @> + <| [ + var unit> "g", <@ fun (unitVar0: unit) -> () @> + var unit> "f", <@ fun (unitVar0: unit) -> () @> + ] + + createTest "Test 8" + <| <@ let f (x: int) = let g () = x in () in () @> + <| <@ () @> + <| [ + var int> "g", <@@ fun (unitVar0: unit) -> (%expVar "x") @@> + var unit> "f", <@@ fun (x: int) -> () @@> + ] + ] |> testList "Lambda" let tests = - [ parameterLiftingTests - unitCleanUpTests - lambdaLiftingTests ] + [ parameterLiftingTests; unitCleanUpTests; lambdaLiftingTests ] |> testList "Lifting" diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Names.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Names.fs index 4f89562f..bedb44de 100644 --- a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Names.fs +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Names.fs @@ -26,81 +26,83 @@ let private getNames expr = dict |> Seq.map (fun var -> var.Name) let private uniquesTests = - [ let createTest name source = - test name { - let names = Names.makeUnique source |> getNames + [ + let createTest name source = + test name { + let names = Names.makeUnique source |> getNames - let namesWithoutDuplicates = Seq.distinct names + let namesWithoutDuplicates = Seq.distinct names - Expect.sequenceEqual names namesWithoutDuplicates "Result should be the same." - } + Expect.sequenceEqual names namesWithoutDuplicates "Result should be the same." + } - createTest "Test 1." - <| <@ - fun var -> - let var = () - let var = () - let var = () + createTest "Test 1." + <| <@ + fun var -> + let var = () + let var = () + let var = () - () - @> + () + @> - createTest "Test 2." - <| <@ - fun f -> - let f (x: int) = x - let f (x: int) (y: int) = x + createTest "Test 2." + <| <@ + fun f -> + let f (x: int) = x + let f (x: int) (y: int) = x - let f = 4 - () - @> + let f = 4 + () + @> - createTest "Test 3." - <| <@ - fun x y z z10 -> - let mutable x = 4 - let mutable x = () + createTest "Test 3." + <| <@ + fun x y z z10 -> + let mutable x = 4 + let mutable x = () - let y = 100 + let y = 100 - let f (x: unit) (y: int) (z: int) = x + let f (x: unit) (y: int) (z: int) = x - let x = f x y 3 + let x = f x y 3 - let x = (fun (x: unit) -> fun (y: unit) -> fun (z: unit) -> y) + let x = (fun (x: unit) -> fun (y: unit) -> fun (z: unit) -> y) - let z = () - let y = () - let z10 = () + let z = () + let y = () + let z10 = () - x z y z10 + x z y z10 - () - @> + () + @> - createTest "Test 4." - <| <@ - fun x1 y2 z3 z10 -> - let mutable x3 = 4 - let mutable x1 = () + createTest "Test 4." + <| <@ + fun x1 y2 z3 z10 -> + let mutable x3 = 4 + let mutable x1 = () - let y2 = 100 + let y2 = 100 - let f (x: unit) (y: int) (z: int) = x + let f (x: unit) (y: int) (z: int) = x - let y3 = 3 - let x1 = f x1 y3 3 + let y3 = 3 + let x1 = f x1 y3 3 - let x = (fun (x4: unit) -> fun (y2: int) -> fun (z: unit) -> 2) + let x = (fun (x4: unit) -> fun (y2: int) -> fun (z: unit) -> 2) - let z124 = () - let y32 = () - let z10 = () - let z4 = () + let z124 = () + let y32 = () + let z10 = () + let z4 = () - let z11 = x z4 y2 z10 + let z11 = x z4 y2 z10 - () - @> ] + () + @> + ] let tests = uniquesTests |> testList "Names" |> testSequenced diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Print.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Print.fs index d5e8684f..b74dda87 100644 --- a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Print.fs +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Print.fs @@ -4,71 +4,66 @@ open Expecto open Brahma.FSharp.OpenCL.Translator.QuotationTransformers let private replaceTests = - [ let inline createTest name = - Common.Helpers.createMapTestAndCompareAsStrings Print.replace name + [ + let inline createTest name = Common.Helpers.createMapTestAndCompareAsStrings Print.replace name - let tpArgs: System.Type list = [] - let value = "" - let bindArgs: Quotations.Expr list = [] + let tpArgs: System.Type list = [] + let value = "" + let bindArgs: Quotations.Expr list = [] - createTest "1 Test. Empty printf" - <| <@ printf "" @> - <| <@ Print.print tpArgs value bindArgs @> + createTest "1 Test. Empty printf" + <| <@ printf "" @> + <| <@ Print.print tpArgs value bindArgs @> - let tpArgs: System.Type list = [] - let value = "\\n" - let bindArgs: Quotations.Expr list = [] + let tpArgs: System.Type list = [] + let value = "\\n" + let bindArgs: Quotations.Expr list = [] - createTest "2 Test. Empty printfn" - <| <@ printfn "" @> - <| <@ Print.print tpArgs value bindArgs @> + createTest "2 Test. Empty printfn" + <| <@ printfn "" @> + <| <@ Print.print tpArgs value bindArgs @> - let tpArgs: System.Type list = [] - let value = "Hello, world!" - let bindArgs: Quotations.Expr list = [] + let tpArgs: System.Type list = [] + let value = "Hello, world!" + let bindArgs: Quotations.Expr list = [] - createTest "3 Test. Hello, world! printf" - <| <@ printf "Hello, world!" @> - <| <@ Print.print tpArgs value bindArgs @> + createTest "3 Test. Hello, world! printf" + <| <@ printf "Hello, world!" @> + <| <@ Print.print tpArgs value bindArgs @> - let tpArgs: System.Type list = [] - let value = "Hello, world!\\n" - let bindArgs: Quotations.Expr list = [] + let tpArgs: System.Type list = [] + let value = "Hello, world!\\n" + let bindArgs: Quotations.Expr list = [] - createTest "4 Test. Hello, world! printfn" - <| <@ printfn "Hello, world!" @> - <| <@ Print.print tpArgs value bindArgs @> + createTest "4 Test. Hello, world! printfn" + <| <@ printfn "Hello, world!" @> + <| <@ Print.print tpArgs value bindArgs @> - let tpArgs: System.Type list = [] - let value = "He\\nllo, w\\nor\\nld!" - let bindArgs: Quotations.Expr list = [] + let tpArgs: System.Type list = [] + let value = "He\\nllo, w\\nor\\nld!" + let bindArgs: Quotations.Expr list = [] - createTest "5 Test. New line. printf" - <| <@ printf "He\nllo, w\nor\nld!" @> - <| <@ Print.print tpArgs value bindArgs @> + createTest "5 Test. New line. printf" + <| <@ printf "He\nllo, w\nor\nld!" @> + <| <@ Print.print tpArgs value bindArgs @> - let tpArgs: System.Type list = [] - let value = "He\\nllo, w\\nor\\nld!\\n" - let bindArgs: Quotations.Expr list = [] + let tpArgs: System.Type list = [] + let value = "He\\nllo, w\\nor\\nld!\\n" + let bindArgs: Quotations.Expr list = [] - createTest "6 Test. New line. printfn" - <| <@ printfn "He\nllo, w\nor\nld!" @> - <| <@ Print.print tpArgs value bindArgs @> + createTest "6 Test. New line. printfn" + <| <@ printfn "He\nllo, w\nor\nld!" @> + <| <@ Print.print tpArgs value bindArgs @> - let tpArgs: System.Type list = - [ typeof - typeof - typeof ] + let tpArgs: System.Type list = [ typeof; typeof; typeof ] - let value = "%d %d %s" + let value = "%d %d %s" - let bindArgs: Quotations.Expr list = - [ <@@ 1 @@> - <@@ 2 @@> - <@@ "" @@> ] + let bindArgs: Quotations.Expr list = [ <@@ 1 @@>; <@@ 2 @@>; <@@ "" @@> ] - createTest "7 Test. %d %d %s. printf" - <| <@ printf "%d %d %s" 1 2 "" @> - <| <@ Print.print tpArgs value bindArgs @> ] + createTest "7 Test. %d %d %s. printf" + <| <@ printf "%d %d %s" 1 2 "" @> + <| <@ Print.print tpArgs value bindArgs @> + ] let tests = replaceTests |> testList "Printf" |> testSequenced diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Transformation.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Transformation.fs index 10530ab6..b2ee11ff 100644 --- a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Transformation.fs +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Transformation.fs @@ -35,155 +35,157 @@ let private quotationTransformerTest = assertMethodListsEqual actualKernelMethods expectedMethods equalToTheExactUnitVars actualKernelExpr expectedKernelExpr "kernels not equals" - [ genTest - testCase - "Test 0" - <@ - fun (range: Range1D) (buf: array) -> - let mutable x = 1 - let f y = x <- y - f 10 - buf.[0] <- x - @> - <@ - let f xRef (y: int) = xRef := y - - fun (range: Range1D) (buf: array) -> - let mutable x = 1 - let xRef = ref x - - f xRef 10 - buf.[0] <- !xRef - @> - - genTest - testCase - "Test 1" - <@ - fun (range: Range1D) (buf: array) -> - let mutable x = 1 - let f y = x <- x + y - f 10 - buf.[0] <- x - @> - <@ - let f (xRef: _ ref) (y: int) = xRef := !xRef + y - - fun (range: Range1D) (buf: array) -> - let mutable x = 1 - let xRef = ref x - - f xRef 10 - buf.[0] <- !xRef - @> - - genTest - testCase - "Test 2: simple lambda lifting without capturing variables" - <@ - fun (range: Range1D) -> - let f x = - let g y = y + 1 - g x - - f 2 - @> - <@ - let g y = y + 1 - let f x = g x - fun (range: Range1D) -> f 2 - @> - - genTest - testCase - "Test 3: simple lambda lifting with capturing variables" - <@ - fun (range: Range1D) -> - let f x = - let g y = y + x - g (x + 1) - - f 2 - @> - <@ - let g x y = y + x - let f x = g x (x + 1) - fun (range: Range1D) -> f 2 - @> - - genTest - testCase - "Test 4" - <@ - fun (range: Range1D) (arr: array) -> - let x = - let mutable y = 0 - - let addToY x = y <- y + x - - for i in 0..10 do - addToY arr.[i] - - y - - x - @> - <@ - let addToY (yRef: _ ref) x = yRef := !yRef + x - - let x1UnitFunc (arr: array) = - let y = 0 - let yRef = ref y - - for i in 0..10 do - addToY yRef arr.[i] - - !yRef - - fun (range: Range1D) (arr: array) -> - let x1 = x1UnitFunc arr - x1 - @> - - genTest - testCase - "Test 5" - <@ - fun (range: Range1D) (arr: array) -> - let mutable x = if 0 > 1 then 2 else 3 - - let mutable y = - for i in 0..10 do - x <- x + 1 - - x + 1 - - let z = x + y - - let f () = arr.[0] <- x + y + z - f () - @> - <@ - let xUnitFunc () = if 0 > 1 then 2 else 3 - - let yUnitFunc xRef = - for i in 0..10 do - xRef := !xRef + 1 - - !xRef + 1 - - let f (arr: array) xRef yRef z = arr.[0] <- !xRef + !yRef + z - - fun (range: Range1D) (arr: array) -> - let mutable x = xUnitFunc () - let xRef = ref x - - let mutable y = yUnitFunc xRef - let yRef = ref y - - let z = !xRef + !yRef - - f arr xRef yRef z - @> ] + [ + genTest + testCase + "Test 0" + <@ + fun (range: Range1D) (buf: array) -> + let mutable x = 1 + let f y = x <- y + f 10 + buf.[0] <- x + @> + <@ + let f xRef (y: int) = xRef := y + + fun (range: Range1D) (buf: array) -> + let mutable x = 1 + let xRef = ref x + + f xRef 10 + buf.[0] <- !xRef + @> + + genTest + testCase + "Test 1" + <@ + fun (range: Range1D) (buf: array) -> + let mutable x = 1 + let f y = x <- x + y + f 10 + buf.[0] <- x + @> + <@ + let f (xRef: _ ref) (y: int) = xRef := !xRef + y + + fun (range: Range1D) (buf: array) -> + let mutable x = 1 + let xRef = ref x + + f xRef 10 + buf.[0] <- !xRef + @> + + genTest + testCase + "Test 2: simple lambda lifting without capturing variables" + <@ + fun (range: Range1D) -> + let f x = + let g y = y + 1 + g x + + f 2 + @> + <@ + let g y = y + 1 + let f x = g x + fun (range: Range1D) -> f 2 + @> + + genTest + testCase + "Test 3: simple lambda lifting with capturing variables" + <@ + fun (range: Range1D) -> + let f x = + let g y = y + x + g (x + 1) + + f 2 + @> + <@ + let g x y = y + x + let f x = g x (x + 1) + fun (range: Range1D) -> f 2 + @> + + genTest + testCase + "Test 4" + <@ + fun (range: Range1D) (arr: array) -> + let x = + let mutable y = 0 + + let addToY x = y <- y + x + + for i in 0..10 do + addToY arr.[i] + + y + + x + @> + <@ + let addToY (yRef: _ ref) x = yRef := !yRef + x + + let x1UnitFunc (arr: array) = + let y = 0 + let yRef = ref y + + for i in 0..10 do + addToY yRef arr.[i] + + !yRef + + fun (range: Range1D) (arr: array) -> + let x1 = x1UnitFunc arr + x1 + @> + + genTest + testCase + "Test 5" + <@ + fun (range: Range1D) (arr: array) -> + let mutable x = if 0 > 1 then 2 else 3 + + let mutable y = + for i in 0..10 do + x <- x + 1 + + x + 1 + + let z = x + y + + let f () = arr.[0] <- x + y + z + f () + @> + <@ + let xUnitFunc () = if 0 > 1 then 2 else 3 + + let yUnitFunc xRef = + for i in 0..10 do + xRef := !xRef + 1 + + !xRef + 1 + + let f (arr: array) xRef yRef z = arr.[0] <- !xRef + !yRef + z + + fun (range: Range1D) (arr: array) -> + let mutable x = xUnitFunc () + let xRef = ref x + + let mutable y = yUnitFunc xRef + let yRef = ref y + + let z = !xRef + !yRef + + f arr xRef yRef z + @> + ] let tests = quotationTransformerTest |> testList "Transformation" diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/VarToRef.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/VarToRef.fs index 4efc0e05..8b6559d2 100644 --- a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/VarToRef.fs +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/VarToRef.fs @@ -4,255 +4,256 @@ open Brahma.FSharp.OpenCL.Translator.QuotationTransformers open Expecto let private uniquesTests = - [ let inline createTest name = - Common.Helpers.createMapTestAndCompareAsStrings VarToRef.transform name - - createTest "Test 1" // id (no mutable vars) - <| <@ - let firstVar = () - let secondVar = 2 - - let f () = - firstVar - secondVar - - () - @> - <| <@ - let firstVar = () - let secondVar = 2 - - let f () = - firstVar - secondVar - - () - @> - - createTest "Test 2" // transform mutable var (unit type) - <| <@ - let mutable firstVar = () - let f (x: int) = firstVar - () - @> - <| <@ - let mutable firstVar = () - let firstVarRef = ref firstVar - let f (x: int) = !firstVarRef // firstVar free in f TODO(_.Value) - () - @> - - createTest "Test 3" - <| <@ - let mutable firstVar = 1 - let f () = firstVar - () - @> - <| <@ - let mutable firstVar = 1 - let firstVarRef = ref firstVar - let f () = !firstVarRef - () - @> - - createTest "Test 4" - <| <@ - let mutable firstVar = 1 - let f () = firstVar <- 1 - () - @> - <| <@ - let mutable firstVar = 1 - let firstVarRef = ref firstVar - let f () = firstVarRef := 1 - () - @> - - createTest "Test 5" - <| <@ - let mutable firstVar = 1 - - let f () = - firstVar <- 2 - firstVar - - () - @> - <| <@ - let mutable firstVar = 1 - let firstVarRef = ref firstVar - - let f () = - firstVarRef := 2 - !firstVarRef - - () - @> - - createTest "Test 6" - <| <@ - let mutable firstVar = 1 - let mutable secondVar = 0.5 - - let f () = - firstVar <- 3 - secondVar <- 0.25 - - () - - () - @> - <| <@ - let mutable firstVar = 1 - let firstVarRef = ref firstVar - - let secondVar = 0.5 - let secondVarRef = ref secondVar - - let f () = - firstVarRef := 3 - secondVarRef := 0.25 - - () - - () - @> - - createTest "Test 7" // id (mutable fun) - <| <@ - let mutable firstFun = fun () -> 1 - - let f () = - firstFun <- fun () -> 2 - - () - - () - @> - <| <@ - let mutable firstFun = fun () -> 1 - - let f () = - firstFun <- fun () -> 2 - - () - - () - @> - - createTest "Test 8" - <| <@ - let mutable firstVar = - let mutable innerVar = None - - let f (x: int) = innerVar <- Some x - Some 1 + [ + let inline createTest name = Common.Helpers.createMapTestAndCompareAsStrings VarToRef.transform name + + createTest "Test 1" // id (no mutable vars) + <| <@ + let firstVar = () + let secondVar = 2 + + let f () = + firstVar + secondVar + + () + @> + <| <@ + let firstVar = () + let secondVar = 2 + + let f () = + firstVar + secondVar + + () + @> + + createTest "Test 2" // transform mutable var (unit type) + <| <@ + let mutable firstVar = () + let f (x: int) = firstVar + () + @> + <| <@ + let mutable firstVar = () + let firstVarRef = ref firstVar + let f (x: int) = !firstVarRef // firstVar free in f TODO(_.Value) + () + @> + + createTest "Test 3" + <| <@ + let mutable firstVar = 1 + let f () = firstVar + () + @> + <| <@ + let mutable firstVar = 1 + let firstVarRef = ref firstVar + let f () = !firstVarRef + () + @> + + createTest "Test 4" + <| <@ + let mutable firstVar = 1 + let f () = firstVar <- 1 + () + @> + <| <@ + let mutable firstVar = 1 + let firstVarRef = ref firstVar + let f () = firstVarRef := 1 + () + @> + + createTest "Test 5" + <| <@ + let mutable firstVar = 1 + + let f () = + firstVar <- 2 + firstVar + + () + @> + <| <@ + let mutable firstVar = 1 + let firstVarRef = ref firstVar + + let f () = + firstVarRef := 2 + !firstVarRef + + () + @> + + createTest "Test 6" + <| <@ + let mutable firstVar = 1 + let mutable secondVar = 0.5 + + let f () = + firstVar <- 3 + secondVar <- 0.25 + + () + + () + @> + <| <@ + let mutable firstVar = 1 + let firstVarRef = ref firstVar + + let secondVar = 0.5 + let secondVarRef = ref secondVar + + let f () = + firstVarRef := 3 + secondVarRef := 0.25 + + () + + () + @> + + createTest "Test 7" // id (mutable fun) + <| <@ + let mutable firstFun = fun () -> 1 + + let f () = + firstFun <- fun () -> 2 + + () + + () + @> + <| <@ + let mutable firstFun = fun () -> 1 + + let f () = + firstFun <- fun () -> 2 + + () + + () + @> + + createTest "Test 8" + <| <@ + let mutable firstVar = + let mutable innerVar = None + + let f (x: int) = innerVar <- Some x + Some 1 - () - @> - <| <@ - let mutable firstVar = - let mutable innerVar = None - let innerVarRef = ref innerVar + () + @> + <| <@ + let mutable firstVar = + let mutable innerVar = None + let innerVarRef = ref innerVar - let f (x: int) = innerVarRef := Some x - Some 1 + let f (x: int) = innerVarRef := Some x + Some 1 - () - @> + () + @> - createTest "Test 9" - <| <@ - let mutable firstVar = - let mutable firstInnerVar = - let mutable secondInnerVar = Some 1 + createTest "Test 9" + <| <@ + let mutable firstVar = + let mutable firstInnerVar = + let mutable secondInnerVar = Some 1 - let f () = secondInnerVar + let f () = secondInnerVar - None + None - let f () = firstInnerVar + let f () = firstInnerVar - Some() + Some() - let f () = firstVar + let f () = firstVar - () - @> - <| <@ - let mutable firstVar = - let mutable firstInnerVar = - let mutable secondInnerVar = Some 1 - let secondInnerVarRef = ref secondInnerVar + () + @> + <| <@ + let mutable firstVar = + let mutable firstInnerVar = + let mutable secondInnerVar = Some 1 + let secondInnerVarRef = ref secondInnerVar - let f () = !secondInnerVarRef + let f () = !secondInnerVarRef - None + None - let firstInnerVarRef = ref firstInnerVar + let firstInnerVarRef = ref firstInnerVar - let f () = !firstInnerVarRef + let f () = !firstInnerVarRef - Some() + Some() - let firstVarRef = ref firstVar + let firstVarRef = ref firstVar - let f () = !firstVarRef + let f () = !firstVarRef - () - @> + () + @> - createTest "Test 10" - <| <@ - fun (x: int) (y: int option) -> - let mutable firstVar = Some 2 + createTest "Test 10" + <| <@ + fun (x: int) (y: int option) -> + let mutable firstVar = Some 2 - let f = - fun () -> - printfn "" - firstVar <- None - printfn "" - firstVar <- Some 0 - firstVar + let f = + fun () -> + printfn "" + firstVar <- None + printfn "" + firstVar <- Some 0 + firstVar - () - @> - <| <@ - fun (x: int) (y: int option) -> - let mutable firstVar = Some 2 - let firstVarRef = ref firstVar + () + @> + <| <@ + fun (x: int) (y: int option) -> + let mutable firstVar = Some 2 + let firstVarRef = ref firstVar - let f = - fun () -> - printfn "" - firstVarRef := None - printfn "" - firstVarRef := Some 0 - !firstVarRef + let f = + fun () -> + printfn "" + firstVarRef := None + printfn "" + firstVarRef := Some 0 + !firstVarRef - () - @> + () + @> - createTest "Test 11" // id - <| <@ - let mutable firstVar = () - let mutable secondVar = 2 + createTest "Test 11" // id + <| <@ + let mutable firstVar = () + let mutable secondVar = 2 - let firstVar = () - let f () = firstVar - let g () = let secondVar = 2 in secondVar + let firstVar = () + let f () = firstVar + let g () = let secondVar = 2 in secondVar - () - @> - <| <@ - let mutable firstVar = () - let mutable secondVar = 2 + () + @> + <| <@ + let mutable firstVar = () + let mutable secondVar = 2 - let firstVar = () - let f () = firstVar - let g () = let secondVar = 2 in secondVar + let firstVar = () + let f () = firstVar + let g () = let secondVar = 2 in secondVar - () - @> ] + () + @> + ] let tests = uniquesTests |> testList "VarToRef" |> testSequenced diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Variables.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Variables.fs index c53ad7e1..fe451d6e 100644 --- a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Variables.fs +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Variables.fs @@ -4,103 +4,104 @@ open Brahma.FSharp.OpenCL.Translator.QuotationTransformers open Expecto let private uniquesTests = - [ let createTest name = - Common.Helpers.createMapTestAndCompareAsStrings Variables.defsToLambda name + [ + let createTest name = Common.Helpers.createMapTestAndCompareAsStrings Variables.defsToLambda name - createTest "Test 1." <| <@ let x = 1 + 1 in () @> <| <@ let x = 1 + 1 in () @> + createTest "Test 1." <| <@ let x = 1 + 1 in () @> <| <@ let x = 1 + 1 in () @> - createTest "Test 2." - <| <@ - let x = - let mutable y = 0 + createTest "Test 2." + <| <@ + let x = + let mutable y = 0 - for i in 1..10 do - y <- y + i + for i in 1..10 do + y <- y + i - y + y - x - @> - <| <@ - let x = - let xUnitFunc () = - let mutable y = 0 + x + @> + <| <@ + let x = + let xUnitFunc () = + let mutable y = 0 - for i in 1..10 do - y <- y + i + for i in 1..10 do + y <- y + i - y + y - xUnitFunc () + xUnitFunc () - x - @> + x + @> - createTest "Test 3." - <| <@ - let x = - let mutable y = - if true then - let z = 10 - z + 1 - else - let z = 20 - z + 2 + createTest "Test 3." + <| <@ + let x = + let mutable y = + if true then + let z = 10 + z + 1 + else + let z = 20 + z + 2 - for i in 1..10 do - let z = if false then 10 else 20 - y <- y + i + z + for i in 1..10 do + let z = if false then 10 else 20 + y <- y + i + z - y + y - x - @> - <| <@ - let x = - let xUnitFunc () = - let mutable y = - let yUnitFunc () = - if true then - let z = 10 - z + 1 - else - let z = 20 - z + 2 + x + @> + <| <@ + let x = + let xUnitFunc () = + let mutable y = + let yUnitFunc () = + if true then + let z = 10 + z + 1 + else + let z = 20 + z + 2 - yUnitFunc () + yUnitFunc () - for i in 1..10 do - let z = - let zUnitFunc () = if false then 10 else 20 - zUnitFunc () + for i in 1..10 do + let z = + let zUnitFunc () = if false then 10 else 20 + zUnitFunc () - y <- y + i + z + y <- y + i + z - y + y - xUnitFunc () + xUnitFunc () - x - @> + x + @> - createTest "Test 4" - <| <@ let f = let x = 4 in x in () @> - <| <@ let f = let fUnitFunc () = let x = 4 in x in fUnitFunc () in () @> + createTest "Test 4" + <| <@ let f = let x = 4 in x in () @> + <| <@ let f = let fUnitFunc () = let x = 4 in x in fUnitFunc () in () @> - createTest "Test 5" - <| <@ let f = let g = let x = 4 in x in () in () @> - <| <@ - let f = - let fUnitFunc () = - let g = - let gUnitFunc () = let x = 4 in x - gUnitFunc () + createTest "Test 5" + <| <@ let f = let g = let x = 4 in x in () in () @> + <| <@ + let f = + let fUnitFunc () = + let g = + let gUnitFunc () = let x = 4 in x + gUnitFunc () - () + () - fUnitFunc () + fUnitFunc () - () - @> ] + () + @> + ] let tests = uniquesTests |> testList "Variables" |> testSequenced diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/WorkSize.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/WorkSize.fs index ad889f67..7dde9626 100644 --- a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/WorkSize.fs +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/WorkSize.fs @@ -17,97 +17,98 @@ module Helpers = let _localSize2 = Unchecked.defaultof let private workSizeTests = - [ let createTest name = - Common.Helpers.createMapTestAndCompareAsStrings WorkSize.get name - - createTest "Test 1D. Global" - <| <@ - fun (ndRange: Range1D) -> - let fst = ndRange.GlobalWorkSize - - () - @> - <| <@ - fun (ndRange: Range1D) -> - let fst = Helpers._globalSize0 - - () - @> - - createTest "Test 2D. Global" - <| <@ - fun (ndRange: Range2D) -> - let (fst, snd) = ndRange.GlobalWorkSize - - () - @> - <| <@ - fun (ndRange: Range2D) -> - let fst = Helpers._globalSize0 - let snd = Helpers._globalSize1 - - () - @> - - createTest "Test 3D. Global" - <| <@ - fun (ndRange: Range3D) -> - let (fst, snd, thd) = ndRange.GlobalWorkSize - - () - @> - <| <@ - fun (ndRange: Range3D) -> - let fst = Helpers._globalSize0 - let snd = Helpers._globalSize1 - let thd = Helpers._globalSize2 - - () - @> - - createTest "Test 1D. Local" - <| <@ - fun (ndRange: Range1D) -> - let fst = ndRange.LocalWorkSize - - () - @> - <| <@ - fun (ndRange: Range1D) -> - let fst = Helpers._localSize0 - - () - @> - - createTest "Test 2D. Local" - <| <@ - fun (ndRange: Range2D) -> - let (fst, snd) = ndRange.LocalWorkSize - - () - @> - <| <@ - fun (ndRange: Range2D) -> - let fst = Helpers._localSize0 - let snd = Helpers._localSize1 - - () - @> - - createTest "Test 3D. Local" - <| <@ - fun (ndRange: Range3D) -> - let (fst, snd, thd) = ndRange.LocalWorkSize - - () - @> - <| <@ - fun (ndRange: Range3D) -> - let fst = Helpers._localSize0 - let snd = Helpers._localSize1 - let thd = Helpers._localSize2 - - () - @> ] + [ + let createTest name = Common.Helpers.createMapTestAndCompareAsStrings WorkSize.get name + + createTest "Test 1D. Global" + <| <@ + fun (ndRange: Range1D) -> + let fst = ndRange.GlobalWorkSize + + () + @> + <| <@ + fun (ndRange: Range1D) -> + let fst = Helpers._globalSize0 + + () + @> + + createTest "Test 2D. Global" + <| <@ + fun (ndRange: Range2D) -> + let (fst, snd) = ndRange.GlobalWorkSize + + () + @> + <| <@ + fun (ndRange: Range2D) -> + let fst = Helpers._globalSize0 + let snd = Helpers._globalSize1 + + () + @> + + createTest "Test 3D. Global" + <| <@ + fun (ndRange: Range3D) -> + let (fst, snd, thd) = ndRange.GlobalWorkSize + + () + @> + <| <@ + fun (ndRange: Range3D) -> + let fst = Helpers._globalSize0 + let snd = Helpers._globalSize1 + let thd = Helpers._globalSize2 + + () + @> + + createTest "Test 1D. Local" + <| <@ + fun (ndRange: Range1D) -> + let fst = ndRange.LocalWorkSize + + () + @> + <| <@ + fun (ndRange: Range1D) -> + let fst = Helpers._localSize0 + + () + @> + + createTest "Test 2D. Local" + <| <@ + fun (ndRange: Range2D) -> + let (fst, snd) = ndRange.LocalWorkSize + + () + @> + <| <@ + fun (ndRange: Range2D) -> + let fst = Helpers._localSize0 + let snd = Helpers._localSize1 + + () + @> + + createTest "Test 3D. Local" + <| <@ + fun (ndRange: Range3D) -> + let (fst, snd, thd) = ndRange.LocalWorkSize + + () + @> + <| <@ + fun (ndRange: Range3D) -> + let fst = Helpers._localSize0 + let snd = Helpers._localSize1 + let thd = Helpers._localSize2 + + () + @> + ] let tests = workSizeTests |> testList "WorkSize" |> testSequenced diff --git a/tests/Brahma.FSharp.Tests/Translator/Specific/MergePath.fs b/tests/Brahma.FSharp.Tests/Translator/Specific/MergePath.fs index 56e5552e..c04b1c69 100644 --- a/tests/Brahma.FSharp.Tests/Translator/Specific/MergePath.fs +++ b/tests/Brahma.FSharp.Tests/Translator/Specific/MergePath.fs @@ -69,10 +69,7 @@ let tests = rightEdge <- middleIdx - 1 // Here localID equals either 0 or 1 - if localID = 0 then - beginIdxLocal <- leftEdge - else - endIdxLocal <- leftEdge + if localID = 0 then beginIdxLocal <- leftEdge else endIdxLocal <- leftEdge barrierLocal () diff --git a/tests/Brahma.FSharp.Tests/Translator/Union/Tests.fs b/tests/Brahma.FSharp.Tests/Translator/Union/Tests.fs index f877aadd..26e837ae 100644 --- a/tests/Brahma.FSharp.Tests/Translator/Union/Tests.fs +++ b/tests/Brahma.FSharp.Tests/Translator/Union/Tests.fs @@ -50,35 +50,31 @@ let private collectUnionTests = |> fun unions -> Expect.sequenceEqual unions expected "Should be equal" } - [ testGen - "Simple union" - [| typeof |] - <@ - let x = SimpleOne - let y = SimpleTwo 2 - () - @> + [ + testGen + "Simple union" + [| typeof |] + <@ + let x = SimpleOne + let y = SimpleTwo 2 + () + @> - testGen - "Nested union 1" - [| typeof - typeof |] - <@ - let x = Outer 5 - () - @> + testGen + "Nested union 1" + [| typeof; typeof |] + <@ + let x = Outer 5 + () + @> - testGen - "Nested union 2" - [| typeof - typeof |] - <@ - let x = Inner SimpleOne - () - @> ] + testGen + "Nested union 2" + [| typeof; typeof |] + <@ + let x = Inner SimpleOne + () + @> + ] -let tests = - [ unionTests - collectUnionTests ] - |> List.concat - |> testList "Union" +let tests = [ unionTests; collectUnionTests ] |> List.concat |> testList "Union" From 12238c9e5458f4081432571e11dc21532af78175 Mon Sep 17 00:00:00 2001 From: IgorErin Date: Wed, 26 Jul 2023 18:22:47 +0300 Subject: [PATCH 22/22] refactor: formatting --- .editorconfig | 39 +---- .../DeclSpecifierPack.fs | 3 +- src/Brahma.FSharp.OpenCL.AST/FunDecl.fs | 8 +- src/Brahma.FSharp.OpenCL.AST/Statements.fs | 23 +-- src/Brahma.FSharp.OpenCL.AST/Types.fs | 14 +- .../ClContextExtensions.fs | 7 +- src/Brahma.FSharp.OpenCL.Core/ClDevice.fs | 11 +- src/Brahma.FSharp.OpenCL.Core/ClException.fs | 5 +- src/Brahma.FSharp.OpenCL.Core/ClProgram.fs | 18 +- src/Brahma.FSharp.OpenCL.Core/ClTask.fs | 11 +- .../CommandQueueProvider.fs | 3 +- .../DataStructures/ClArray.fs | 15 +- .../DataStructures/ClCell.fs | 9 +- src/Brahma.FSharp.OpenCL.Core/Messages.fs | 3 +- src/Brahma.FSharp.OpenCL.Core/NDRange.fs | 10 +- .../RuntimeContext.fs | 3 +- .../Expressions.fs | 6 +- src/Brahma.FSharp.OpenCL.Printer/Printer.fs | 8 +- .../Statements.fs | 3 +- src/Brahma.FSharp.OpenCL.Printer/Types.fs | 6 +- src/Brahma.FSharp.OpenCL.Translator/Body.fs | 156 +++++++----------- .../CustomMarshaller.fs | 86 ++++++++-- .../Methods.fs | 12 +- .../QuotationTransformers/Atomic.fs | 68 +++----- .../QuotationTransformers/Lifting.fs | 27 ++- .../QuotationTransformers/Names.fs | 3 +- .../QuotationTransformers/Print.fs | 3 +- .../Utilities/Patterns.fs | 3 +- .../QuotationTransformers/Utilities/Utils.fs | 6 +- .../QuotationTransformers/VarToRef.fs | 6 +- .../QuotationTransformers/Variables.fs | 6 +- .../QuotationTransformers/WorkSize.fs | 3 +- .../TranslationContext.fs | 6 +- .../Translator.fs | 22 +-- src/Brahma.FSharp.OpenCL.Translator/Type.fs | 21 ++- .../Utils/Extensions.fs | 6 +- .../Utils/StateBuilder.fs | 15 +- .../Utils/Utils.fs | 3 +- .../ExecutionTests/AtomicTests.fs | 29 +--- .../ExecutionTests/CompilationTests.fs | 3 +- .../ExecutionTests/CompositeTypesTests.fs | 75 ++------- .../ExecutionTests/ExecutionTests.fs | 3 +- .../ExecutionTests/RuntimeTests.fs | 35 +--- .../QuatationTransformation/Common.fs | 14 +- .../QuatationTransformation/Lifting.fs | 14 +- .../QuatationTransformation/Print.fs | 3 +- .../QuatationTransformation/VarToRef.fs | 3 +- .../QuatationTransformation/Variables.fs | 3 +- .../QuatationTransformation/WorkSize.fs | 3 +- .../Translator/Specific/MergePath.fs | 5 +- 50 files changed, 354 insertions(+), 493 deletions(-) diff --git a/.editorconfig b/.editorconfig index bca8fa9e..4dafd2d5 100644 --- a/.editorconfig +++ b/.editorconfig @@ -35,39 +35,14 @@ indent_size = 2 # fantomas conf [*.fs] -fsharp_semicolon_at_end_of_line=false -fsharp_space_before_parameter=true -fsharp_space_before_lowercase_invocation=true -fsharp_space_before_uppercase_invocation=false -fsharp_space_before_class_constructor=false -fsharp_space_before_member=false -fsharp_space_before_colon=false -fsharp_space_after_comma=true -fsharp_space_before_semicolon=false -fsharp_space_after_semicolon=true -fsharp_indent_on_try_with=false -fsharp_space_around_delimiter=true -fsharp_max_if_then_else_short_width=80 +[*.{fs,fsx}] +max_line_length=140 +fsharp_newline_between_type_definition_and_members=true +fsharp_max_function_binding_width=40 +fsharp_max_if_then_else_short_width=60 fsharp_max_infix_operator_expression=80 -fsharp_max_record_width=80 -fsharp_max_record_number_of_items=1 -fsharp_record_multiline_formatter=character_width fsharp_max_array_or_list_width=80 -fsharp_max_array_or_list_number_of_items=1 -fsharp_array_or_list_multiline_formatter=character_width -fsharp_max_value_binding_width=80 -fsharp_max_function_binding_width=80 +fsharp_max_array_or_list_number_of_items=5 fsharp_max_dot_get_expression_width=80 fsharp_multiline_block_brackets_on_same_column=true -fsharp_newline_between_type_definition_and_members=false -fsharp_keep_if_then_in_same_line=true -fsharp_max_elmish_width=80 -fsharp_single_argument_web_mode=true -fsharp_align_function_signature_to_indentation=false -fsharp_alternative_long_member_definitions=false -fsharp_multi_line_lambda_closing_newline=true -fsharp_disable_elmish_syntax=false -fsharp_keep_indent_in_branch=false -fsharp_blank_lines_around_nested_multiline_expressions=false -fsharp_bar_before_discriminated_union_declaration=false -fsharp_strict_mode=false \ No newline at end of file +fsharp_keep_max_number_of_blank_lines=1 \ No newline at end of file diff --git a/src/Brahma.FSharp.OpenCL.AST/DeclSpecifierPack.fs b/src/Brahma.FSharp.OpenCL.AST/DeclSpecifierPack.fs index 3d686817..1d42f86c 100644 --- a/src/Brahma.FSharp.OpenCL.AST/DeclSpecifierPack.fs +++ b/src/Brahma.FSharp.OpenCL.AST/DeclSpecifierPack.fs @@ -36,7 +36,8 @@ type DeclSpecifierPack<'lang> member val Type = typeSpecifier with get, set member val TypeQualifiers = defaultArg typeQualifiers [] with get, set - member this.AddTypeQual tq = this.TypeQualifiers <- tq :: this.TypeQualifiers + member this.AddTypeQual tq = + this.TypeQualifiers <- tq :: this.TypeQualifiers member this.Matches(other: obj) = match other with diff --git a/src/Brahma.FSharp.OpenCL.AST/FunDecl.fs b/src/Brahma.FSharp.OpenCL.AST/FunDecl.fs index 376821f6..fec633b1 100644 --- a/src/Brahma.FSharp.OpenCL.AST/FunDecl.fs +++ b/src/Brahma.FSharp.OpenCL.AST/FunDecl.fs @@ -26,13 +26,7 @@ type FunFormalArg<'lang>(declSpecs: DeclSpecifierPack<'lang>, name: string) = | :? FunFormalArg<'lang> as o -> this.DeclSpecs.Matches(o.DeclSpecs) && this.Name.Equals(o.Name) | _ -> false -type FunDecl<'lang> - ( - declSpecs: DeclSpecifierPack<'lang>, - name: string, - args: List>, - body: Statement<'lang> - ) = +type FunDecl<'lang>(declSpecs: DeclSpecifierPack<'lang>, name: string, args: List>, body: Statement<'lang>) = inherit Node<'lang>() interface ITopDef<'lang> diff --git a/src/Brahma.FSharp.OpenCL.AST/Statements.fs b/src/Brahma.FSharp.OpenCL.AST/Statements.fs index 640da988..e48fec38 100644 --- a/src/Brahma.FSharp.OpenCL.AST/Statements.fs +++ b/src/Brahma.FSharp.OpenCL.AST/Statements.fs @@ -15,13 +15,7 @@ namespace Brahma.FSharp.OpenCL.AST -type VarDecl<'lang> - ( - vType: Type<'lang>, - name: string, - expr: Option>, - ?spaceModifier: AddressSpaceQualifier<'lang> - ) = +type VarDecl<'lang>(vType: Type<'lang>, name: string, expr: Option>, ?spaceModifier: AddressSpaceQualifier<'lang>) = inherit Statement<'lang>() let mutable spaceModifier = spaceModifier @@ -60,12 +54,7 @@ type Return<'lang>(expression: Expression<'lang>) = override this.Children = [] member this.Expression = expression -type IfThenElse<'lang> - ( - cond: Expression<'lang>, - thenBranch: StatementBlock<'lang>, - elseBranch: Option> - ) = +type IfThenElse<'lang>(cond: Expression<'lang>, thenBranch: StatementBlock<'lang>, elseBranch: Option>) = inherit Statement<'lang>() override this.Children = [] @@ -73,13 +62,7 @@ type IfThenElse<'lang> member this.Then = thenBranch member this.Else = elseBranch -type ForIntegerLoop<'lang> - ( - var: VarDecl<'lang>, - cond: Expression<'lang>, - countModifier: Statement<'lang>, - body: StatementBlock<'lang> - ) = +type ForIntegerLoop<'lang>(var: VarDecl<'lang>, cond: Expression<'lang>, countModifier: Statement<'lang>, body: StatementBlock<'lang>) = inherit Statement<'lang>() override this.Children = [] diff --git a/src/Brahma.FSharp.OpenCL.AST/Types.fs b/src/Brahma.FSharp.OpenCL.AST/Types.fs index 715b795a..d1523a49 100644 --- a/src/Brahma.FSharp.OpenCL.AST/Types.fs +++ b/src/Brahma.FSharp.OpenCL.AST/Types.fs @@ -115,7 +115,10 @@ type DiscriminatedUnionType<'lang>(name: string, fields: List StructType<'lang>( name, [ - { Name = "tag"; Type = PrimitiveType(Int) } + { + Name = "tag" + Type = PrimitiveType(Int) + } { Name = "data" Type = UnionClInplaceType(name + "_Data", List.map snd fields) @@ -126,9 +129,11 @@ type DiscriminatedUnionType<'lang>(name: string, fields: List member this.Tag = this.Fields.[0] member this.Data = this.Fields.[1] - member this.GetCaseByTag(tag: int) = List.tryFind (fun (id, _) -> id = tag) fields |> Option.map snd + member this.GetCaseByTag(tag: int) = + List.tryFind (fun (id, _) -> id = tag) fields |> Option.map snd - member this.GetCaseByName(case: string) = List.tryFind (fun (_, f) -> f.Name = case) fields |> Option.map snd + member this.GetCaseByName(case: string) = + List.tryFind (fun (_, f) -> f.Name = case) fields |> Option.map snd type TupleType<'lang>(baseStruct: StructType<'lang>) = inherit Type<'lang>() @@ -136,7 +141,8 @@ type TupleType<'lang>(baseStruct: StructType<'lang>) = member this.BaseStruct = baseStruct override this.Size = baseStruct.Size - override this.Matches _ = failwith "Not implemented: matches for tuples" + override this.Matches _ = + failwith "Not implemented: matches for tuples" type RefType<'lang>(baseType: Type<'lang>, typeQuals: TypeQualifier<'lang> list) = inherit Type<'lang>() diff --git a/src/Brahma.FSharp.OpenCL.Core/ClContextExtensions.fs b/src/Brahma.FSharp.OpenCL.Core/ClContextExtensions.fs index 520eeb7d..038ae1e4 100644 --- a/src/Brahma.FSharp.OpenCL.Core/ClContextExtensions.fs +++ b/src/Brahma.FSharp.OpenCL.Core/ClContextExtensions.fs @@ -67,12 +67,7 @@ module ClContextExtensions = new ClCell<_>(buffer) /// Creates OpenCL default value with specified memory flags. - member this.CreateClCell - ( - ?hostAccessMode: HostAccessMode, - ?deviceAccessMode: DeviceAccessMode, - ?allocationMode: AllocationMode - ) = + member this.CreateClCell(?hostAccessMode: HostAccessMode, ?deviceAccessMode: DeviceAccessMode, ?allocationMode: AllocationMode) = let flags = { diff --git a/src/Brahma.FSharp.OpenCL.Core/ClDevice.fs b/src/Brahma.FSharp.OpenCL.Core/ClDevice.fs index d4f47d8a..d4e6b140 100644 --- a/src/Brahma.FSharp.OpenCL.Core/ClDevice.fs +++ b/src/Brahma.FSharp.OpenCL.Core/ClDevice.fs @@ -39,9 +39,13 @@ type ClDevice(device: OpenCL.Net.Device) = let error = ref Unchecked.defaultof let result = f error - if error.Value <> ClErrorCode.Success then onError else result + if error.Value <> ClErrorCode.Success then + onError + else + result - let (|Contains|_|) (substring: string) (str: string) = if str.Contains substring then Some Contains else None + let (|Contains|_|) (substring: string) (str: string) = + if str.Contains substring then Some Contains else None /// Gets internal representation of device specific to OpenCL.Net. member this.Device = device @@ -230,8 +234,7 @@ type ClDevice(device: OpenCL.Net.Device) = Some <| Cl.GetDeviceIDs(platform, DeviceHelpers.convertToDeviceType deviceType, error) else - None - ) + None) |> Seq.concat |> Seq.map ClDevice diff --git a/src/Brahma.FSharp.OpenCL.Core/ClException.fs b/src/Brahma.FSharp.OpenCL.Core/ClException.fs index e148e3e7..293fabf2 100644 --- a/src/Brahma.FSharp.OpenCL.Core/ClException.fs +++ b/src/Brahma.FSharp.OpenCL.Core/ClException.fs @@ -11,6 +11,9 @@ type CLException = new(error: ErrorCode) = { inherit Exception(error.ToString()) } - new(error: ErrorCode, inner: Exception) = { inherit Exception(error.ToString(), inner) } + new(error: ErrorCode, inner: Exception) = + { + inherit Exception(error.ToString(), inner) + } new(info: SerializationInfo, context: StreamingContext) = { inherit Exception(info, context) } diff --git a/src/Brahma.FSharp.OpenCL.Core/ClProgram.fs b/src/Brahma.FSharp.OpenCL.Core/ClProgram.fs index a8fa02b0..3fb63273 100644 --- a/src/Brahma.FSharp.OpenCL.Core/ClProgram.fs +++ b/src/Brahma.FSharp.OpenCL.Core/ClProgram.fs @@ -96,15 +96,11 @@ type ClProgram<'TRange, 'a when 'TRange :> INDRange>(ctx: ClContext, srcLambda: | _ -> failwithf $"Something went wrong with type of atomic global var. \ - Expected var of type '%s{ClArray_}' or '%s{ClCell_}', but given %s{var.Type.Name}" - ) + Expected var of type '%s{ClArray_}' or '%s{ClCell_}', but given %s{var.Type.Name}") ) let regularArgs = - Expr.NewArray( - typeof, - argsWithoutMutexes |> List.map (fun v -> Expr.Coerce(Expr.Var v, typeof)) - ) + Expr.NewArray(typeof, argsWithoutMutexes |> List.map (fun v -> Expr.Coerce(Expr.Var v, typeof))) let argsList = argsWithoutMutexes |> List.map List.singleton @@ -117,8 +113,7 @@ type ClProgram<'TRange, 'a when 'TRange :> INDRange>(ctx: ClContext, srcLambda: let xVar = Var("x", typeof) Expr.Lambdas( - [ [ kernelVar ] ] - @ [ [ rangeVar ] ] @ [ [ argsVar ] ] @ [ [ mutexBuffersVar ] ] @ argsList, + [ [ kernelVar ]; [ rangeVar ]; [ argsVar ]; [ mutexBuffersVar ] ] @ argsList, Expr.Let( mutexArgsVar, <@@ @@ -129,16 +124,13 @@ type ClProgram<'TRange, 'a when 'TRange :> INDRange>(ctx: ClContext, srcLambda: (%%(Expr.Var mutexBuffersVar): ResizeArray>).Add mutexBuffer - box mutexBuffer - ) + box mutexBuffer) @@>, Expr.Let( xVar, <@@ %%regularArgs |> List.ofArray @@>, <@@ - %%Utils.createReferenceSetCall - (Expr.Var rangeVar) - <@@ unbox<'TRange> (%%Expr.Var xVar: obj list).Head @@> + %%Utils.createReferenceSetCall (Expr.Var rangeVar) <@@ unbox<'TRange> (%%Expr.Var xVar: obj list).Head @@> %%Utils.createReferenceSetCall (Expr.Var argsVar) diff --git a/src/Brahma.FSharp.OpenCL.Core/ClTask.fs b/src/Brahma.FSharp.OpenCL.Core/ClTask.fs index e6f79777..6c9a0c1d 100644 --- a/src/Brahma.FSharp.OpenCL.Core/ClTask.fs +++ b/src/Brahma.FSharp.OpenCL.Core/ClTask.fs @@ -25,7 +25,8 @@ type ClTaskBuilder() = member inline this.Combine(m1, m2) = this.Bind(m1, (fun () -> m2)) - member inline this.Delay(rest) = this.Bind(this.Zero(), (fun () -> rest ())) + member inline this.Delay(rest) = + this.Bind(this.Zero(), (fun () -> rest ())) member inline this.Run(m) = m @@ -61,10 +62,7 @@ type ClTaskBuilder() = this.Combine(this.Run(body), this.Delay(fun () -> this.While(cond, body))) member this.For(xs: seq<'T>, f) = - this.Bind( - this.Return(xs.GetEnumerator()), - fun en -> this.While((fun () -> en.MoveNext()), this.Delay(fun () -> f en.Current)) - ) + this.Bind(this.Return(xs.GetEnumerator()), (fun en -> this.While((fun () -> en.MoveNext()), this.Delay(fun () -> f en.Current)))) [] module ClTaskImpl = @@ -120,8 +118,7 @@ module ClTask = ctx.CommandQueue.Post <| syncMsgs.[i] return result } - |> fun task -> async { return runComputation task <| ctx.WithNewCommandQueue() } - ) + |> fun task -> async { return runComputation task <| ctx.WithNewCommandQueue() }) |> Async.Parallel |> Async.RunSynchronously } diff --git a/src/Brahma.FSharp.OpenCL.Core/CommandQueueProvider.fs b/src/Brahma.FSharp.OpenCL.Core/CommandQueueProvider.fs index 180994dc..75966e39 100644 --- a/src/Brahma.FSharp.OpenCL.Core/CommandQueueProvider.fs +++ b/src/Brahma.FSharp.OpenCL.Core/CommandQueueProvider.fs @@ -125,8 +125,7 @@ type CommandQueueProvider private (device, context, translator: FSQuotationToOpe /// /// Initializes a new instance of the class with specified device, context and translator. /// - new(device: Device, context: Context, translator: FSQuotationToOpenCLTranslator) = - CommandQueueProvider(device, context, translator, ()) + new(device: Device, context: Context, translator: FSQuotationToOpenCLTranslator) = CommandQueueProvider(device, context, translator, ()) /// /// Creates new command queue capable of handling messages of type . diff --git a/src/Brahma.FSharp.OpenCL.Core/DataStructures/ClArray.fs b/src/Brahma.FSharp.OpenCL.Core/DataStructures/ClArray.fs index ee877228..c20de10e 100644 --- a/src/Brahma.FSharp.OpenCL.Core/DataStructures/ClArray.fs +++ b/src/Brahma.FSharp.OpenCL.Core/DataStructures/ClArray.fs @@ -33,7 +33,8 @@ type ClArray<'a> internal (buffer: ClBuffer<'a>) = member this.Dispose() = (this :> IDisposable).Dispose() - override this.ToString() = $"{(buffer :> IClMem).Data}, %A{(buffer :> IClMem).Size}" + override this.ToString() = + $"{(buffer :> IClMem).Data}, %A{(buffer :> IClMem).Size}" // fsharplint:disable-next-line type clarray<'a> = ClArray<'a> @@ -51,7 +52,8 @@ module ClArray = // or allocate with null ptr and write // TODO if array.Length = 0 ... /// Transfers specified array to device with default memory flags. - let toDevice (array: 'a[]) = toDeviceWithFlags array ClMemFlags.DefaultIfData + let toDevice (array: 'a[]) = + toDeviceWithFlags array ClMemFlags.DefaultIfData /// Allocate empty array on device with specified memory flags. let allocWithFlags<'a> (size: int) (memFlags: ClMemFlags) = @@ -63,7 +65,8 @@ module ClArray = } /// Allocate empty array on device with default memory flags. - let alloc<'a> (size: int) = allocWithFlags<'a> size ClMemFlags.DefaultIfNoData + let alloc<'a> (size: int) = + allocWithFlags<'a> size ClMemFlags.DefaultIfNoData /// Transfers specified array from device to host. let toHost (clArray: ClArray<'a>) = @@ -76,10 +79,12 @@ module ClArray = } // TODO impl it using clEnqueCopy - let copy (clArray: ClArray<'a>) = opencl { failwith "Not implemented yet" } + let copy (clArray: ClArray<'a>) = + opencl { failwith "Not implemented yet" } // TODO impl it - let copyTo (destination: ClArray<'a>) (source: ClArray<'a>) = opencl { failwith "Not implemented yet" } + let copyTo (destination: ClArray<'a>) (source: ClArray<'a>) = + opencl { failwith "Not implemented yet" } let close (clArray: ClArray<'a>) = opencl { diff --git a/src/Brahma.FSharp.OpenCL.Core/DataStructures/ClCell.fs b/src/Brahma.FSharp.OpenCL.Core/DataStructures/ClCell.fs index 4e90430a..3995f505 100644 --- a/src/Brahma.FSharp.OpenCL.Core/DataStructures/ClCell.fs +++ b/src/Brahma.FSharp.OpenCL.Core/DataStructures/ClCell.fs @@ -45,7 +45,8 @@ module ClCell = } /// Transfers specified value to device with default memory flags. - let toDevice (value: 'a) = toDeviceWithFlags value ClMemFlags.DefaultIfData + let toDevice (value: 'a) = + toDeviceWithFlags value ClMemFlags.DefaultIfData /// Allocate default value on device with specified memory flags. let allocWithFlags<'a> (memFlags: ClMemFlags) = @@ -57,7 +58,8 @@ module ClCell = } /// Allocate empty array on device with default memory flags. - let alloc<'a> () = allocWithFlags<'a> ClMemFlags.DefaultIfNoData + let alloc<'a> () = + allocWithFlags<'a> ClMemFlags.DefaultIfNoData /// Transfers specified value from device to host. let toHost (clCell: ClCell<'a>) = @@ -70,4 +72,5 @@ module ClCell = } // TODO impl it - let copy (clCell: ClCell<'a>) = opencl { failwith "Not implemented yet" } + let copy (clCell: ClCell<'a>) = + opencl { failwith "Not implemented yet" } diff --git a/src/Brahma.FSharp.OpenCL.Core/Messages.fs b/src/Brahma.FSharp.OpenCL.Core/Messages.fs index 688cb5c1..68169534 100644 --- a/src/Brahma.FSharp.OpenCL.Core/Messages.fs +++ b/src/Brahma.FSharp.OpenCL.Core/Messages.fs @@ -68,7 +68,8 @@ type Msg = static member CreateToHostMsg<'a>(src, dst, ?ch) = { new IToHostCrate with - member this.Apply evaluator = evaluator.Eval <| ToHost<'a>(src, dst, ?replyChannel = ch) + member this.Apply evaluator = + evaluator.Eval <| ToHost<'a>(src, dst, ?replyChannel = ch) } |> MsgToHost diff --git a/src/Brahma.FSharp.OpenCL.Core/NDRange.fs b/src/Brahma.FSharp.OpenCL.Core/NDRange.fs index ff094df0..2e3072d5 100644 --- a/src/Brahma.FSharp.OpenCL.Core/NDRange.fs +++ b/src/Brahma.FSharp.OpenCL.Core/NDRange.fs @@ -114,12 +114,7 @@ type Range3D /// Local work size for dimension 0 to use. /// Local work size for dimension 1 to use. /// Local work size for dimension 2 to use. - new(globalWorkSizeX: int, - globalWorkSizeY: int, - globalWorkSizeZ: int, - localWorkSizeX: int, - localWorkSizeY: int, - localWorkSizeZ: int) = + new(globalWorkSizeX: int, globalWorkSizeY: int, globalWorkSizeZ: int, localWorkSizeX: int, localWorkSizeY: int, localWorkSizeZ: int) = Range3D(globalWorkSizeX, globalWorkSizeY, globalWorkSizeZ, localWorkSizeX, localWorkSizeY, localWorkSizeZ) /// @@ -128,8 +123,7 @@ type Range3D /// Global work size for dimension 0 to use. /// Global work size for dimension 1 to use. /// Global work size for dimension 2 to use. - new(globalWorkSizeX, globalWorkSizeY, globalWorkSizeZ) = - Range3D(globalWorkSizeX, globalWorkSizeY, globalWorkSizeZ, 1, 1, 1) + new(globalWorkSizeX, globalWorkSizeY, globalWorkSizeZ) = Range3D(globalWorkSizeX, globalWorkSizeY, globalWorkSizeZ, 1, 1, 1) /// Gets the unique global work-item ID for dimension 0. member this.GlobalID0: int = FailIfOutsideKernel() diff --git a/src/Brahma.FSharp.OpenCL.Core/RuntimeContext.fs b/src/Brahma.FSharp.OpenCL.Core/RuntimeContext.fs index a4206f1c..b96e0eb9 100644 --- a/src/Brahma.FSharp.OpenCL.Core/RuntimeContext.fs +++ b/src/Brahma.FSharp.OpenCL.Core/RuntimeContext.fs @@ -26,7 +26,8 @@ type RuntimeContext(clContext: ClContext) = member this.ClContext = clContext - member internal this.WithNewCommandQueue() = RuntimeContext(clContext, RuntimeOptions = this.RuntimeOptions) + member internal this.WithNewCommandQueue() = + RuntimeContext(clContext, RuntimeOptions = this.RuntimeOptions) member internal this.WithRuntimeOptions(runtimeOptions) = RuntimeContext(clContext, RuntimeOptions = runtimeOptions, CommandQueue = this.CommandQueue) diff --git a/src/Brahma.FSharp.OpenCL.Printer/Expressions.fs b/src/Brahma.FSharp.OpenCL.Printer/Expressions.fs index 3ee291bd..fc43e5de 100644 --- a/src/Brahma.FSharp.OpenCL.Printer/Expressions.fs +++ b/src/Brahma.FSharp.OpenCL.Printer/Expressions.fs @@ -45,9 +45,11 @@ module Expressions = let private printVar (varible: Variable<'lang>) = wordL varible.Name - let rec private printItem (itm: Item<'lang>) = (print itm.Arr) ++ squareBracketL (print itm.Idx) + let rec private printItem (itm: Item<'lang>) = + (print itm.Arr) ++ squareBracketL (print itm.Idx) - and private printIndirectionOp (deref: IndirectionOp<'lang>) = wordL "*" ++ (print deref.Expr |> bracketL) + and private printIndirectionOp (deref: IndirectionOp<'lang>) = + wordL "*" ++ (print deref.Expr |> bracketL) and private printBop (op: BOp<'lang>) = match op with diff --git a/src/Brahma.FSharp.OpenCL.Printer/Printer.fs b/src/Brahma.FSharp.OpenCL.Printer/Printer.fs index ff4531b8..35a144ec 100644 --- a/src/Brahma.FSharp.OpenCL.Printer/Printer.fs +++ b/src/Brahma.FSharp.OpenCL.Printer/Printer.fs @@ -28,9 +28,11 @@ module AST = | :? CLPragma<'lang> as clp -> Pragmas.print clp | :? StructDecl<'lang> as s -> TypeDecl.printStructDeclaration s | :? VarDecl<'lang> as s -> Statements.print false s - | _ -> failwithf "Printer. Unsupported toplevel declaration: %A" d - ) + | _ -> failwithf "Printer. Unsupported toplevel declaration: %A" d) // |> LayoutOps.sepListL (LayoutOps.wordL "\r\n") // |> Display.layout_to_string FormatOptions.Default |> LayoutOps.aboveListL - |> Display.layout_to_string { FormatOptions.Default with PrintWidth = 100 } + |> Display.layout_to_string + { FormatOptions.Default with + PrintWidth = 100 + } diff --git a/src/Brahma.FSharp.OpenCL.Printer/Statements.fs b/src/Brahma.FSharp.OpenCL.Printer/Statements.fs index b46e0cd7..daa0b133 100644 --- a/src/Brahma.FSharp.OpenCL.Printer/Statements.fs +++ b/src/Brahma.FSharp.OpenCL.Printer/Statements.fs @@ -99,7 +99,8 @@ module Statements = | MemFence.Global -> wordL "barrier(CLK_GLOBAL_MEM_FENCE)" | Both -> wordL "barrier(CLK_LOCAL_MEM_FENCE | CLK_GLOBAL_MEM_FENCE)" - and printReturn (r: Return<_>) = wordL "return" ++ Expressions.print r.Expression + and printReturn (r: Return<_>) = + wordL "return" ++ Expressions.print r.Expression and printFieldSet (fs: FieldSet<_>) = let host = Expressions.print fs.Host diff --git a/src/Brahma.FSharp.OpenCL.Printer/Types.fs b/src/Brahma.FSharp.OpenCL.Printer/Types.fs index 933bee97..7d5d017c 100644 --- a/src/Brahma.FSharp.OpenCL.Printer/Types.fs +++ b/src/Brahma.FSharp.OpenCL.Printer/Types.fs @@ -65,6 +65,8 @@ module Types = header ^^ body - and printUnionInplaceType (t: UnionClInplaceType<_>) = printAggregatingInplaceType "union" t.Name t.Fields + and printUnionInplaceType (t: UnionClInplaceType<_>) = + printAggregatingInplaceType "union" t.Name t.Fields - and printStructInplaceType (t: StructInplaceType<_>) = printAggregatingInplaceType "struct" t.Name t.Fields + and printStructInplaceType (t: StructInplaceType<_>) = + printAggregatingInplaceType "struct" t.Name t.Fields diff --git a/src/Brahma.FSharp.OpenCL.Translator/Body.fs b/src/Brahma.FSharp.OpenCL.Translator/Body.fs index 376a9e4b..06c1a3da 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/Body.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/Body.fs @@ -61,7 +61,9 @@ module private BodyPatterns = module rec Body = // new var scope let private clearContext (targetContext: TranslationContext<'a, 'b>) = - { targetContext with VarDecls = ResizeArray() } + { targetContext with + VarDecls = ResizeArray() + } let toStb (s: Node<_>) = translation { @@ -93,7 +95,10 @@ module rec Body = | :? ArrayInitializer<_> as ai -> return! Type.translate var.Type - |> State.using (fun ctx -> { ctx with ArrayKind = CArrayDecl ai.Length }) + |> State.using (fun ctx -> + { ctx with + ArrayKind = CArrayDecl ai.Length + }) | _ -> return! Type.translate var.Type } @@ -113,8 +118,7 @@ module rec Body = let! state = state let! translated = translateCond arg return translated :: state - } - ) + }) (State.return' []) |> State.map List.rev @@ -160,88 +164,77 @@ module rec Body = do! State.modify (fun context -> context.Flags.Add EnableAtomic |> ignore - context - ) + context) return FunCall("atom_add", [ args.[0]; args.[1] ]) :> Statement<_> | "atomicsub" -> do! State.modify (fun context -> context.Flags.Add EnableAtomic |> ignore - context - ) + context) return FunCall("atom_sub", [ args.[0]; args.[1] ]) :> Statement<_> | "atomicxchg" -> do! State.modify (fun context -> context.Flags.Add EnableAtomic |> ignore - context - ) + context) return FunCall("atom_xchg", [ args.[0]; args.[1] ]) :> Statement<_> | "atomicmax" -> do! State.modify (fun context -> context.Flags.Add EnableAtomic |> ignore - context - ) + context) return FunCall("atom_max", [ args.[0]; args.[1] ]) :> Statement<_> | "atomicmin" -> do! State.modify (fun context -> context.Flags.Add EnableAtomic |> ignore - context - ) + context) return FunCall("atom_min", [ args.[0]; args.[1] ]) :> Statement<_> | "atomicinc" -> do! State.modify (fun context -> context.Flags.Add EnableAtomic |> ignore - context - ) + context) return FunCall("atom_inc", [ args.[0] ]) :> Statement<_> | "atomicdec" -> do! State.modify (fun context -> context.Flags.Add EnableAtomic |> ignore - context - ) + context) return FunCall("atom_dec", [ args.[0] ]) :> Statement<_> | "atomiccmpxchg" -> do! State.modify (fun context -> context.Flags.Add EnableAtomic |> ignore - context - ) + context) return FunCall("atom_cmpxchg", [ args.[0]; args.[1]; args.[2] ]) :> Statement<_> | "atomicand" -> do! State.modify (fun context -> context.Flags.Add EnableAtomic |> ignore - context - ) + context) return FunCall("atom_and", [ args.[0]; args.[1] ]) :> Statement<_> | "atomicor" -> do! State.modify (fun context -> context.Flags.Add EnableAtomic |> ignore - context - ) + context) return FunCall("atom_or", [ args.[0]; args.[1] ]) :> Statement<_> | "atomicxor" -> do! State.modify (fun context -> context.Flags.Add EnableAtomic |> ignore - context - ) + context) return FunCall("atom_xor", [ args.[0]; args.[1] ]) :> Statement<_> | "todouble" -> return Cast(args.[0], PrimitiveType Float) :> Statement<_> @@ -298,10 +291,8 @@ module rec Body = $"Seems, that you use math function with name %s{fName} not from System.Math or Microsoft.FSharp.Core.Operators" | "ref" -> return Ptr args.[0] :> Statement<_> | "op_dereference" -> return IndirectionOp args.[0] :> Statement<_> - | "op_colonequals" -> - return Assignment(Property(PropertyType.VarReference(IndirectionOp args.[0])), args.[1]) :> Statement<_> - | "setarray" -> - return Assignment(Property(PropertyType.Item(Item(args.[0], args.[1]))), args.[2]) :> Statement<_> + | "op_colonequals" -> return Assignment(Property(PropertyType.VarReference(IndirectionOp args.[0])), args.[1]) :> Statement<_> + | "setarray" -> return Assignment(Property(PropertyType.Item(Item(args.[0], args.[1]))), args.[2]) :> Statement<_> | "getarray" -> return Item(args.[0], args.[1]) :> Statement<_> | "barrierlocal" -> return Barrier(MemFence.Local) :> Statement<_> | "barrierglobal" -> return Barrier(MemFence.Global) :> Statement<_> @@ -309,15 +300,11 @@ module rec Body = | "local" -> return raise - <| InvalidKernelException( - "Calling the local function is allowed only at the top level of the let binding" - ) + <| InvalidKernelException("Calling the local function is allowed only at the top level of the let binding") | "arraylocal" -> return raise - <| InvalidKernelException( - "Calling the localArray function is allowed only at the top level of the let binding" - ) + <| InvalidKernelException("Calling the localArray function is allowed only at the top level of the let binding") | "zerocreate" -> let length = match args.[0] with @@ -375,9 +362,7 @@ module rec Body = | Some expr -> match! State.gets (fun context -> context.CStructDecls.Keys |> Seq.contains expr.Type) with | true -> - match! - State.gets (fun context -> not <| context.CStructDecls.[expr.Type] :? DiscriminatedUnionType<_>) - with + match! State.gets (fun context -> not <| context.CStructDecls.[expr.Type] :? DiscriminatedUnionType<_>) with | true -> return! translateStructFieldGet expr propInfo.Name | false -> return! translateUnionFieldGet expr propInfo | false -> return! translateSpecificPropGet expr propName exprs @@ -471,7 +456,11 @@ module rec Body = | "boolean" -> let! translatedType = Type.translate sType - let stringValue = if value.ToString().ToLowerInvariant() = "false" then "0" else "1" + let stringValue = + if value.ToString().ToLowerInvariant() = "false" then + "0" + else + "1" return translatedType, stringValue @@ -485,7 +474,10 @@ module rec Body = let! translatedType = Type.translate sType - |> State.using (fun ctx -> { ctx with ArrayKind = CArrayDecl array.Length }) + |> State.using (fun ctx -> + { ctx with + ArrayKind = CArrayDecl array.Length + }) let stringValue = array |> String.concat ", " |> (fun s -> "{ " + s + "}") @@ -556,8 +548,7 @@ module rec Body = do! State.modify (fun context -> context.Namer.LetIn loopVar.Name - context - ) + context) let! loopVarModifier = match step with @@ -578,8 +569,7 @@ module rec Body = do! State.modify (fun context -> context.Namer.LetOut() - context - ) + context) return ForIntegerLoop(loopVarBinding, loopCond, loopVarModifier, loopBody) } @@ -610,15 +600,13 @@ module rec Body = do! State.modify (fun context -> context.VarDecls.Clear() - context - ) + context) for expr in linearized do do! State.modify (fun context -> context.VarDecls.Clear() - context - ) + context) match! translate expr with | :? StatementBlock as s1 -> decls.AddRange(s1.Statements) @@ -643,7 +631,6 @@ module rec Body = else expr, false - let (body, doing) = go expr1 [ expr2 ] [] return body, doing } @@ -706,16 +693,11 @@ module rec Body = match unionCaseField with | Some unionCaseField -> return - FieldGet( - FieldGet(FieldGet(unionValueExpr, unionType.Data.Name), unionCaseField.Name), - propInfo.Name - ) - :> Expression<_> + FieldGet(FieldGet(FieldGet(unionValueExpr, unionType.Data.Name), unionCaseField.Name), propInfo.Name) :> Expression<_> | None -> return raise - <| InvalidKernelException - $"Union field get translation error: union %A{unionType.Name} doesn't have case %A{caseName}" + <| InvalidKernelException $"Union field get translation error: union %A{unionType.Name} doesn't have case %A{caseName}" } let private translateLet (var: Var) expr inExpr = @@ -740,7 +722,10 @@ module rec Body = let! arrayType = Type.translate var.Type - |> State.using (fun ctx -> { ctx with ArrayKind = CArrayDecl arrayLength }) + |> State.using (fun ctx -> + { ctx with + ArrayKind = CArrayDecl arrayLength + }) return VarDecl(arrayType, bName, None, spaceModifier = Local) | Patterns.DefaultValue _ -> @@ -752,14 +737,12 @@ module rec Body = do! State.modify (fun context -> context.VarDecls.Add vDecl - context - ) + context) do! State.modify (fun context -> context.Namer.LetIn var.Name - context - ) + context) let! res = translate inExpr |> State.using clearContext let! sb = State.gets (fun context -> context.VarDecls) @@ -771,8 +754,7 @@ module rec Body = do! State.modify (fun context -> context.Namer.LetOut() - context - ) + context) do! State.modify clearContext @@ -790,8 +772,7 @@ module rec Body = | _ -> return raise - <| TranslationFailedException - $"Failed to parse provided call, expected string call name: {expr}" + <| TranslationFailedException $"Failed to parse provided call, expected string call name: {expr}" | Patterns.Sequential(expr1, expr2) -> let! updatedArgs = translation { @@ -828,9 +809,7 @@ module rec Body = | DerivedPatterns.SpecificCall <@@ Print.print @@> (_, _, args) -> match args with - | [ Patterns.ValueWithName(argTypes, _, _) - Patterns.ValueWithName(formatStr, _, _) - Patterns.ValueWithName(argValues, _, _) ] -> + | [ Patterns.ValueWithName(argTypes, _, _); Patterns.ValueWithName(formatStr, _, _); Patterns.ValueWithName(argValues, _, _) ] -> let formatStrArg = Const(PrimitiveType ConstStringLiteral, formatStr :?> string) :> Expression<_> @@ -841,11 +820,7 @@ module rec Body = | DerivedPatterns.SpecificCall <@ (|>) @> (_, _, - [ expr - Patterns.Lambda(_, - DerivedPatterns.SpecificCall <@ ignore @> (_, - _, - _)) ]) -> + [ expr; Patterns.Lambda(_, DerivedPatterns.SpecificCall <@ ignore @> (_, _, _)) ]) -> return! translate expr | DerivedPatterns.SpecificCall <@ LanguagePrimitives.GenericOne @> (_, [ onType ], _) -> @@ -853,10 +828,7 @@ module rec Body = let value = Expr - .Call( - Utils.makeGenericMethodCall [ onType ] <@ LanguagePrimitives.GenericOne @>, - List.empty - ) + .Call(Utils.makeGenericMethodCall [ onType ] <@ LanguagePrimitives.GenericOne @>, List.empty) .EvaluateUntyped() .ToString() @@ -864,8 +836,7 @@ module rec Body = | Patterns.Call(exprOpt, mInfo, args) -> return! translateCall exprOpt mInfo args >>= toNode | Patterns.Coerce(expr, sType) -> return raise <| InvalidKernelException $"Coerce is not supported: {expr}" - | Patterns.DefaultValue sType -> - return raise <| InvalidKernelException $"DefaultValue is not supported: {expr}" + | Patterns.DefaultValue sType -> return raise <| InvalidKernelException $"DefaultValue is not supported: {expr}" | Patterns.FieldGet(exprOpt, fldInfo) -> match exprOpt with @@ -897,12 +868,9 @@ module rec Body = | "___providedCallInfo" -> return! translateProvidedCall expr | _ -> return! translateLet var expr inExpr - | Patterns.LetRecursive(bindings, expr) -> - return raise <| InvalidKernelException $"LetRecursive is not supported: {expr}" - | Patterns.NewArray(sType, exprs) -> - return raise <| InvalidKernelException $"NewArray is not supported: {expr}" - | Patterns.NewDelegate(sType, vars, expr) -> - return raise <| InvalidKernelException $"NewDelegate is not supported: {expr}" + | Patterns.LetRecursive(bindings, expr) -> return raise <| InvalidKernelException $"LetRecursive is not supported: {expr}" + | Patterns.NewArray(sType, exprs) -> return raise <| InvalidKernelException $"NewArray is not supported: {expr}" + | Patterns.NewDelegate(sType, vars, expr) -> return raise <| InvalidKernelException $"NewDelegate is not supported: {expr}" | Patterns.NewObject(constrInfo, exprs) -> let! context = State.get @@ -951,18 +919,14 @@ module rec Body = return NewStruct(unionInfo, tag :: args) :> Node<_> - | Patterns.PropertyGet(exprOpt, propInfo, exprs) -> - return! translatePropGet exprOpt propInfo exprs >>= toNode - | Patterns.PropertySet(exprOpt, propInfo, exprs, expr) -> - return! translatePropSet exprOpt propInfo exprs expr >>= toNode + | Patterns.PropertyGet(exprOpt, propInfo, exprs) -> return! translatePropGet exprOpt propInfo exprs >>= toNode + | Patterns.PropertySet(exprOpt, propInfo, exprs, expr) -> return! translatePropSet exprOpt propInfo exprs expr >>= toNode | Patterns.Sequential(expr1, expr2) -> return! translateSeq expr1 expr2 >>= toNode - | Patterns.TryFinally(tryExpr, finallyExpr) -> - return raise <| InvalidKernelException $"TryFinally is not supported: {expr}" + | Patterns.TryFinally(tryExpr, finallyExpr) -> return raise <| InvalidKernelException $"TryFinally is not supported: {expr}" | Patterns.TryWith(expr1, var1, expr2, var2, expr3) -> return raise <| InvalidKernelException $"TryWith is not supported: {expr}" | Patterns.TupleGet(expr, i) -> return! translateStructFieldGet expr $"_{i + 1}" >>= toNode - | Patterns.TypeTest(expr, sType) -> - return raise <| InvalidKernelException $"TypeTest is not supported: {expr}" + | Patterns.TypeTest(expr, sType) -> return raise <| InvalidKernelException $"TypeTest is not supported: {expr}" | Patterns.UnionCaseTest(expr, unionCaseInfo) -> let! unionInfo = Type.translate unionCaseInfo.DeclaringType @@ -982,9 +946,7 @@ module rec Body = context.Namer.AddVar name let! res = translateValue obj' sType - context.TopLevelVarsDecls.Add( - VarDecl(res.Type, name, Some(res :> Expression<_>), AddressSpaceQualifier.Constant) - ) + context.TopLevelVarsDecls.Add(VarDecl(res.Type, name, Some(res :> Expression<_>), AddressSpaceQualifier.Constant)) let var = Var(name, sType) return! translateVar var >>= toNode diff --git a/src/Brahma.FSharp.OpenCL.Translator/CustomMarshaller.fs b/src/Brahma.FSharp.OpenCL.Translator/CustomMarshaller.fs index dd2371a2..4b712cbe 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/CustomMarshaller.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/CustomMarshaller.fs @@ -13,7 +13,11 @@ type StructurePacking = { Size: int Alignment: int - Members: {| Pack: StructurePacking; Offsets: int |} list + Members: + {| + Pack: StructurePacking + Offsets: int + |} list } type CustomMarshaller() = @@ -63,7 +67,8 @@ type CustomMarshaller() = // TODO issues with multithreading member this.GetTypePacking(type': Type) = - let getAlignment elems = elems |> List.map (fun pack -> pack.Alignment) |> List.max + let getAlignment elems = + elems |> List.map (fun pack -> pack.Alignment) |> List.max let getSize alignment elems = elems @@ -91,7 +96,11 @@ type CustomMarshaller() = let offsets = elems |> getOffsets let members = (elems, offsets) ||> getMembers - { Size = size; Alignment = alignment; Members = members } + { + Size = size + Alignment = alignment + Members = members + } | RecordType -> let elems = @@ -105,7 +114,11 @@ type CustomMarshaller() = let offsets = elems |> getOffsets let members = (elems, offsets) ||> getMembers - { Size = size; Alignment = alignment; Members = members } + { + Size = size + Alignment = alignment + Members = members + } | UnionType -> let tag = go typeof @@ -117,7 +130,11 @@ type CustomMarshaller() = let unionPacking = if nonEmptyFieldsTypes.Length = 0 then - { Size = 0; Alignment = 1; Members = [] } + { + Size = 0 + Alignment = 1 + Members = [] + } else let packingList = nonEmptyFieldsTypes @@ -130,7 +147,11 @@ type CustomMarshaller() = let unionSize = packingList |> List.map (fun pack -> pack.Size) |> List.max - { Size = unionSize; Alignment = unionAlignment; Members = [] } + { + Size = unionSize + Alignment = unionAlignment + Members = [] + } let elems = [ tag; unionPacking ] @@ -139,7 +160,11 @@ type CustomMarshaller() = let offsets = elems |> getOffsets let members = (elems, offsets) ||> getMembers - { Size = size; Alignment = alignment; Members = members } + { + Size = size + Alignment = alignment + Members = members + } | UserDefinedStructureType -> let elems = @@ -153,15 +178,28 @@ type CustomMarshaller() = let offsets = elems |> getOffsets let members = (elems, offsets) ||> getMembers - { Size = size; Alignment = alignment; Members = members } + { + Size = size + Alignment = alignment + Members = members + } | PrimitiveType -> let size = - Marshal.SizeOf(if type' = typeof then typeof else type') + Marshal.SizeOf( + if type' = typeof then + typeof + else + type' + ) let alignment = size - { Size = size; Alignment = alignment; Members = [] } + { + Size = size + Alignment = alignment + Members = [] + } go type' @@ -243,7 +281,12 @@ type CustomMarshaller() = member this.WriteToUnmanaged(array: 'a[], ptr: IntPtr) = let rec write start (structure: obj) = let offsets = - this.GetTypeOffsets(if isNull structure then typeof else structure.GetType()) + this.GetTypeOffsets( + if isNull structure then + typeof + else + structure.GetType() + ) let mutable i = 0 @@ -283,7 +326,10 @@ type CustomMarshaller() = let offset = if isNull structure then 0 else offsets.[i] let structure = - if str.GetType() = typeof then box <| Convert.ToByte str else str + if str.GetType() = typeof then + box <| Convert.ToByte str + else + str Marshal.StructureToPtr(structure, IntPtr.Add(start, offset), false) i <- i + 1 @@ -294,8 +340,7 @@ type CustomMarshaller() = (fun j item -> let pack = this.GetTypePacking(typeof<'a>) let start = IntPtr.Add(ptr, j * pack.Size) - write start item - ) + write start item) array array.Length * this.GetTypePacking(typeof<'a>).Size @@ -357,11 +402,17 @@ type CustomMarshaller() = let structure = Marshal.PtrToStructure( IntPtr.Add(start, offset), - if type'' = typeof then typeof else type'' + if type'' = typeof then + typeof + else + type'' ) let structure = - if type'' = typeof then box <| Convert.ToBoolean structure else structure + if type'' = typeof then + box <| Convert.ToBoolean structure + else + structure i <- i + 1 structure @@ -371,6 +422,5 @@ type CustomMarshaller() = Array.Parallel.iteri (fun j _ -> let start = IntPtr.Add(ptr, j * this.GetTypePacking(typeof<'a>).Size) - array.[j] <- unbox<'a> <| read start typeof<'a> - ) + array.[j] <- unbox<'a> <| read start typeof<'a>) array diff --git a/src/Brahma.FSharp.OpenCL.Translator/Methods.fs b/src/Brahma.FSharp.OpenCL.Translator/Methods.fs index c9b70e84..b069627a 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/Methods.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/Methods.fs @@ -98,8 +98,7 @@ type KernelFunc(var: Var, expr: Expr) = args |> List.filter (fun (variable: Var) -> brahmaDimensionsTypes - |> (not << List.contains (variable.Type.Name.ToLowerInvariant())) - ) + |> (not << List.contains (variable.Type.Name.ToLowerInvariant()))) |> List.map (fun variable -> let vType = Type.translate variable.Type |> State.eval context let declSpecs = DeclSpecifierPack(typeSpecifier = vType) @@ -107,8 +106,7 @@ type KernelFunc(var: Var, expr: Expr) = if vType :? RefType<_> then declSpecs.AddressSpaceQualifier <- Global - FunFormalArg(declSpecs, variable.Name) - ) + FunFormalArg(declSpecs, variable.Name)) } override this.BuildFunction(args, body) = @@ -136,8 +134,7 @@ type Function(var: Var, expr: Expr) = elif vType :? RefType<_> && localVars |> List.contains variable.Name then declSpecs.AddressSpaceQualifier <- Local - FunFormalArg(declSpecs, variable.Name) - ) + FunFormalArg(declSpecs, variable.Name)) } override this.BuildFunction(args, body) = @@ -180,8 +177,7 @@ type AtomicFunc(var: Var, expr: Expr, qual: AddressSpaceQualifier) = elif vType :? RefType<_> && localVars |> List.contains variable.Name then declSpecs.AddressSpaceQualifier <- Local - FunFormalArg(declSpecs, variable.Name) - ) + FunFormalArg(declSpecs, variable.Name)) } override this.BuildFunction(args, body) = diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Atomic.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Atomic.fs index abaa08d8..58bba898 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Atomic.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Atomic.fs @@ -115,8 +115,7 @@ module Atomic = match expr with | DerivedPatterns.Applications(DerivedPatterns.SpecificCall <@ atomic @> (_, _, - [ DerivedPatterns.Lambdas(lambdaArgs, - lambdaBody) ]), + [ DerivedPatterns.Lambdas(lambdaArgs, lambdaBody) ]), // atomic application restriction ([ Patterns.ValidVolatileArg pointerVar as volatileArg ] :: _ as applicationArgs)) when nonPrivateVars |> Map.containsKey pointerVar @@ -178,9 +177,7 @@ module Atomic = -> return Expr.Call(atomicXchgInfo.MakeGenericMethod(onType), newApplicationArgs) - | DerivedPatterns.SpecificCall <@ cmpxchg @> (_, - onType :: _, - [ Patterns.Var _; Patterns.Var _; Patterns.Var _ ]) when + | DerivedPatterns.SpecificCall <@ cmpxchg @> (_, onType :: _, [ Patterns.Var _; Patterns.Var _; Patterns.Var _ ]) when onType = typeof || onType = typeof || @@ -277,19 +274,13 @@ module Atomic = ] ) - | DerivedPatterns.SpecificCall <@ xchg @> (_, _, [ Patterns.Var p; Patterns.Var value ]) -> - Expr.Var value + | DerivedPatterns.SpecificCall <@ xchg @> (_, _, [ Patterns.Var p; Patterns.Var value ]) -> Expr.Var value | DerivedPatterns.SpecificCall <@ cmpxchg @> (_, onType :: _, - [ Patterns.Var p - Patterns.Var cmp - Patterns.Var value ]) -> + [ Patterns.Var p; Patterns.Var cmp; Patterns.Var value ]) -> Expr.IfThenElse( - Expr.Call( - Utils.makeGenericMethodCall [ onType ] <@ (=) @>, - [ Expr.Var p; Expr.Var cmp ] - ), + Expr.Call(Utils.makeGenericMethodCall [ onType ] <@ (=) @>, [ Expr.Var p; Expr.Var cmp ]), Expr.Var value, Expr.Var p ) @@ -308,8 +299,7 @@ module Atomic = let atomicFuncArgs = baseFuncArgs |> modifyFirstOfListList (fun x -> - Var(x.Name, typeof>.GetGenericTypeDefinition().MakeGenericType(x.Type), x.IsMutable) - ) + Var(x.Name, typeof>.GetGenericTypeDefinition().MakeGenericType(x.Type), x.IsMutable)) let! state = State.get @@ -320,9 +310,12 @@ module Atomic = | None -> Var( pointerVar.Name + "Mutex", - if nonPrivateVars.[pointerVar] = GlobalQ then typeof> - elif pointerVar.Type.IsArray then typeof - else typeof + if nonPrivateVars.[pointerVar] = GlobalQ then + typeof> + elif pointerVar.Type.IsArray then + typeof + else + typeof ) do! State.modify (fun state -> state |> Map.add pointerVar mutexVar) @@ -342,21 +335,12 @@ module Atomic = && propInfo.Name.ToLower().StartsWith "value" -> - Expr.PropertyGet( - Expr.Var mutexVar, - typeof>.GetProperty ("Item"), - [ Expr.Value 0 ] - ) + Expr.PropertyGet(Expr.Var mutexVar, typeof>.GetProperty ("Item"), [ Expr.Value 0 ]) | Patterns.Var _ -> Expr.Var mutexVar - | DerivedPatterns.SpecificCall <@ IntrinsicFunctions.GetArray @> (_, - _, - [ Patterns.Var _; idx ]) -> - Expr.Call( - Utils.getMethodInfoOfCall <@ IntrinsicFunctions.GetArray @>, - [ Expr.Var mutexVar; idx ] - ) + | DerivedPatterns.SpecificCall <@ IntrinsicFunctions.GetArray @> (_, _, [ Patterns.Var _; idx ]) -> + Expr.Call(Utils.getMethodInfoOfCall <@ IntrinsicFunctions.GetArray @>, [ Expr.Var mutexVar; idx ]) | _ -> failwith "Invalid volatile argument. This exception should never occur :)" |> Utils.createRefCall @@ -367,11 +351,7 @@ module Atomic = |> modifyFirstOfListList Utils.createDereferenceCall let oldValueVar = - Var( - "oldValue", - getFirstOfListListWith (fun (x: Var) -> x.Type.GenericTypeArguments.[0]) atomicFuncArgs, - true - ) + Var("oldValue", getFirstOfListListWith (fun (x: Var) -> x.Type.GenericTypeArguments.[0]) atomicFuncArgs, true) Expr.Let( oldValueVar, @@ -414,8 +394,7 @@ module Atomic = // if pointer var in private memory | DerivedPatterns.Applications(DerivedPatterns.SpecificCall <@ atomic @> (_, _, - [ DerivedPatterns.Lambdas(lambdaArgs, - lambdaBody) ]), + [ DerivedPatterns.Lambdas(lambdaArgs, lambdaBody) ]), ([ Patterns.ValidVolatileArg pointerVar ] :: _ as applicationArgs)) when nonPrivateVars |> Map.containsKey pointerVar |> not -> @@ -425,9 +404,7 @@ module Atomic = Atomic operaion cannot be executed on variables in private memmory" // if volatile arg is invalid - | DerivedPatterns.Applications(DerivedPatterns.SpecificCall <@ atomic @> (_, - _, - [ DerivedPatterns.Lambdas _ ]), + | DerivedPatterns.Applications(DerivedPatterns.SpecificCall <@ atomic @> (_, _, [ DerivedPatterns.Lambdas _ ]), [ invalidVolatileArg ] :: _) -> return failwithf @@ -460,8 +437,7 @@ module Atomic = pointerVarToMutexVarMap |> Map.iter (fun var mutexVar -> if args |> List.contains var then - newArgs.Add mutexVar - ) + newArgs.Add mutexVar) // Set local args let rec go expr = @@ -498,8 +474,7 @@ module Atomic = Expr.Value 0, <@@ (%%args.[0]: int) - 1 @@>, Expr.Call( - Utils.getMethodInfoOfCall - <@ IntrinsicFunctions.SetArray @>, + Utils.getMethodInfoOfCall <@ IntrinsicFunctions.SetArray @>, [ Expr.Var mutexVar; Expr.Var i; Expr.Value 0 ] ) )) @@ -514,8 +489,7 @@ module Atomic = | ExprShape.ShapeVar var -> Expr.Var var | ExprShape.ShapeLambda(var, lambda) -> Expr.Lambda(var, go lambda) - | ExprShape.ShapeCombination(combo, exprs) -> - ExprShape.RebuildShapeCombination(combo, List.map go exprs) + | ExprShape.ShapeCombination(combo, exprs) -> ExprShape.RebuildShapeCombination(combo, List.map go exprs) return Expr.Lambdas(Seq.toList newArgs |> List.map List.singleton, go body) diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Lifting.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Lifting.fs index c3099390..d6f479fe 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Lifting.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Lifting.fs @@ -18,7 +18,11 @@ type Context = Substitution = this.Substitution.Add(oldFun, newApplication) } - static member empty = { FreeVariables = Map.empty; Substitution = Map.empty } + static member empty = + { + FreeVariables = Map.empty + Substitution = Map.empty + } module Lift = module Parameters = @@ -61,8 +65,7 @@ module Lift = Expr.Let(v, definition', inExp') | ExprShape.ShapeVar var as expr -> ctx.Substitution.TryFind var |> Option.defaultValue expr | ExprShape.ShapeLambda(x, body) -> Expr.Lambda(x, run ctx body) - | ExprShape.ShapeCombination(o, exprList) -> - ExprShape.RebuildShapeCombination(o, List.map (run ctx) exprList) + | ExprShape.ShapeCombination(o, exprList) -> ExprShape.RebuildShapeCombination(o, List.map (run ctx) exprList) run Context.empty @@ -85,12 +88,10 @@ module Lift = let private takeOutArgs (args: Expr list) app = args |> List.filter (fun e -> e.Type = typeof) - |> List.filter ( - function + |> List.filter (function | Patterns.Var _ | Patterns.Value _ -> false - | _ -> true - ) + | _ -> true) |> (fun args -> List.foldBack (fun f s -> Expr.Sequential(f, s)) args app) /// args: [x1: t1; x2: t2; x3: t3], boyd: t4 @@ -105,11 +106,9 @@ module Lift = // Value() in Applications patterns go to [] // Then i think we should map [] -> [ Value((), typeof) ] in exps let private mapExpsToArgs = - List.map ( - function + List.map (function | [] -> [ Expr.Value((), typeof) ] - | x -> x - ) + | x -> x) >> List.concat let cleanUp (expr: Expr) = @@ -129,8 +128,7 @@ module Lift = let args' = filterUnit args |> List.map (parse subst) let app' = Utils.makeApplicationExpr (Expr.Var var') args' - takeOutArgs args app' - ) + takeOutArgs args app') |> Option.defaultValue source | ExprShape.ShapeLambda(var, body) -> Expr.Lambda(var, parse subst body) | ExprShape.ShapeVar var as source -> @@ -160,4 +158,5 @@ module Lift = let exprList', methods = exprList |> List.map lift |> List.unzip ExprShape.RebuildShapeCombination(o, exprList'), List.concat methods - let parse (expr: Expr) = expr |> Parameters.lift |> UnitArguments.cleanUp |> Lambda.lift + let parse (expr: Expr) = + expr |> Parameters.lift |> UnitArguments.cleanUp |> Lambda.lift diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Names.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Names.fs index 0fea09d8..ed6ff603 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Names.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Names.fs @@ -46,4 +46,5 @@ module Names = ExprShape.RebuildShapeCombination(shapeComboObj, exprList') - let makeUnique (expr: Expr) = makeVarNamesUniqueImpl <| RenamingContext() <| expr + let makeUnique (expr: Expr) = + makeVarNamesUniqueImpl <| RenamingContext() <| expr diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Print.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Print.fs index f583d5e0..dfb638b4 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Print.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Print.fs @@ -73,5 +73,4 @@ module Print = | Utils.Printf(tpArgs, value, bindArgs) -> <@@ print tpArgs value bindArgs @@> | ExprShape.ShapeVar _ as expr -> expr | ExprShape.ShapeLambda(x, body) -> Expr.Lambda(x, replace body) - | ExprShape.ShapeCombination(combo, exprList) -> - ExprShape.RebuildShapeCombination(combo, List.map replace exprList) + | ExprShape.ShapeCombination(combo, exprList) -> ExprShape.RebuildShapeCombination(combo, List.map replace exprList) diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Patterns.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Patterns.fs index fce352c0..afa0b029 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Patterns.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Patterns.fs @@ -13,7 +13,8 @@ module Patterns = let (|LetFunc|_|) exp = letDefinition Utils.isFunction exp - let (|LetVar|_|) (expr: Expr) = letDefinition (not << Utils.isFunction) expr + let (|LetVar|_|) (expr: Expr) = + letDefinition (not << Utils.isFunction) expr /// let f x1 x2 x3 = body in e /// => LetFuncUncurry(f, [x1; x2, x3], body, e) diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Utils.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Utils.fs index 8753ee30..cc1863e7 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Utils.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Utilities/Utils.fs @@ -19,7 +19,8 @@ module Utils = let makeLambdaType types = List.reduceBack (fun domain range -> FSharpType.MakeFunctionType(domain, range)) types - let makeLambdaExpr (args: Var list) (body: Expr) = List.foldBack (fun var expr -> Expr.Lambda(var, expr)) args body + let makeLambdaExpr (args: Var list) (body: Expr) = + List.foldBack (fun var expr -> Expr.Lambda(var, expr)) args body let makeApplicationExpr (head: Expr) (expressions: Expr list) = List.fold (fun l r -> Expr.Application(l, r)) head expressions @@ -51,8 +52,7 @@ module Utils = let rec collectLocalVars (expr: Expr) : Var list = match expr with | Patterns.Let(variable, DerivedPatterns.SpecificCall <@ local @> (_, _, _), cont) - | Patterns.Let(variable, DerivedPatterns.SpecificCall <@ localArray @> (_, _, _), cont) -> - variable :: collectLocalVars cont + | Patterns.Let(variable, DerivedPatterns.SpecificCall <@ localArray @> (_, _, _), cont) -> variable :: collectLocalVars cont | ExprShape.ShapeVar _ -> [] | ExprShape.ShapeLambda(_, lambda) -> collectLocalVars lambda | ExprShape.ShapeCombination(_, expressions) -> List.collect collectLocalVars expressions diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/VarToRef.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/VarToRef.fs index adc882c0..c2639249 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/VarToRef.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/VarToRef.fs @@ -3,7 +3,8 @@ namespace Brahma.FSharp.OpenCL.Translator.QuotationTransformers open FSharp.Quotations module VarToRef = - let private isMutableVar (var: Var) = var.IsMutable && not (Utils.isFunction var) + let private isMutableVar (var: Var) = + var.IsMutable && not (Utils.isFunction var) let rec private collectMutableVarsInClosure = function @@ -52,8 +53,7 @@ module VarToRef = refMap.TryFind var |> Option.map (fun refExpr -> let expr = parse refMap valueExpr - Utils.createReferenceSetCall refExpr expr - ) + Utils.createReferenceSetCall refExpr expr) |> Option.defaultValue sourceExpr | ExprShape.ShapeVar var as sourceExpr -> refMap.TryFind var diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Variables.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Variables.fs index e997d3af..9e2cd318 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Variables.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/Variables.fs @@ -32,11 +32,7 @@ module Variables = // create: let fVal () = expr in unit () let private createDefinitionAndApplication fVar body = - Expr.Let( - fVar, - Expr.Lambda(Var(unitVarName, typeof), body), - Expr.Application(Expr.Var fVar, Expr.Value((), typeof)) - ) + Expr.Let(fVar, Expr.Lambda(Var(unitVarName, typeof), body), Expr.Application(Expr.Var fVar, Expr.Value((), typeof))) // let x = expr -> let x = let unit () = expr in unit () let rec defsToLambda = diff --git a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/WorkSize.fs b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/WorkSize.fs index b9580d81..787dfdf4 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/WorkSize.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/QuotationTransformers/WorkSize.fs @@ -45,7 +45,8 @@ module WorkSize = Some(var, inExp) | _ -> None - let inline private (|Zero|_|) exp = (|CoordinateBind|_|) 0 (|ReturnSome|_|) exp + let inline private (|Zero|_|) exp = + (|CoordinateBind|_|) 0 (|ReturnSome|_|) exp let inline private (|First|_|) exp = (|CoordinateBind|_|) 1 (|Zero|_|) exp diff --git a/src/Brahma.FSharp.OpenCL.Translator/TranslationContext.fs b/src/Brahma.FSharp.OpenCL.Translator/TranslationContext.fs index d167327d..ded3f0a7 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/TranslationContext.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/TranslationContext.fs @@ -108,7 +108,11 @@ type TranslationContext<'lang, 'vDecl> = ArrayKind = CPointer } - member this.WithNewLocalContext() = { this with VarDecls = ResizeArray(); Namer = Namer() } + member this.WithNewLocalContext() = + { this with + VarDecls = ResizeArray() + Namer = Namer() + } type TargetContext = TranslationContext> diff --git a/src/Brahma.FSharp.OpenCL.Translator/Translator.fs b/src/Brahma.FSharp.OpenCL.Translator/Translator.fs index 4f4ffb70..352ced5d 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/Translator.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/Translator.fs @@ -40,15 +40,12 @@ type FSQuotationToOpenCLTranslator(device: IDevice, ?translatorOptions: Translat let (|AtomicApplArgs|_|) (args: Expr list list) = match args with | [ mutex ] :: _ :: [ [ DerivedPatterns.SpecificCall <@ ref @> (_, _, [ Patterns.ValidVolatileArg var ]) ] ] - | [ mutex ] :: [ [ DerivedPatterns.SpecificCall <@ ref @> (_, _, [ Patterns.ValidVolatileArg var ]) ] ] -> - Some(mutex, var) + | [ mutex ] :: [ [ DerivedPatterns.SpecificCall <@ ref @> (_, _, [ Patterns.ValidVolatileArg var ]) ] ] -> Some(mutex, var) | _ -> None let rec go expr = match expr with - | DerivedPatterns.Applications(Patterns.Var funcVar, AtomicApplArgs(_, volatileVar)) when - funcVar.Name.StartsWith "atomic" - -> + | DerivedPatterns.Applications(Patterns.Var funcVar, AtomicApplArgs(_, volatileVar)) when funcVar.Name.StartsWith "atomic" -> if kernelArgumentsNames |> List.contains volatileVar.Name then atomicPointerArgQualifiers.Add(funcVar, Global) @@ -67,11 +64,7 @@ type FSQuotationToOpenCLTranslator(device: IDevice, ?translatorOptions: Translat kernelArgumentsNames, localVarsNames, atomicApplicationsInfo - let constructMethods - (expr: Expr) - (functions: (Var * Expr) list) - (atomicApplicationsInfo: Map>) - = + let constructMethods (expr: Expr) (functions: (Var * Expr) list) (atomicApplicationsInfo: Map>) = let kernelFunc = KernelFunc(Var(mainKernelName, expr.Type), expr) :> Method |> List.singleton @@ -80,8 +73,7 @@ type FSQuotationToOpenCLTranslator(device: IDevice, ?translatorOptions: Translat |> List.map (fun (var, expr) -> match atomicApplicationsInfo |> Map.tryFind var with | Some qual -> AtomicFunc(var, expr, qual) :> Method - | None -> Function(var, expr) :> Method - ) + | None -> Function(var, expr) :> Method) methods @ kernelFunc @@ -122,8 +114,7 @@ type FSQuotationToOpenCLTranslator(device: IDevice, ?translatorOptions: Translat | EnableAtomic -> pragmas.Add(CLPragma CLGlobalInt32BaseAtomics :> ITopDef<_>) pragmas.Add(CLPragma CLLocalInt32BaseAtomics :> ITopDef<_>) - | EnableFP64 -> pragmas.Add(CLPragma CLFP64) - ) + | EnableFP64 -> pragmas.Add(CLPragma CLFP64)) List.ofSeq pragmas @@ -142,7 +133,8 @@ type FSQuotationToOpenCLTranslator(device: IDevice, ?translatorOptions: Translat member this.TranslatorOptions = translatorOptions - member this.Translate(qExpr) = lock lockObject <| fun () -> translate qExpr + member this.Translate(qExpr) = + lock lockObject <| fun () -> translate qExpr member this.TransformQuotation(expr: Expr) = transformQuotation expr diff --git a/src/Brahma.FSharp.OpenCL.Translator/Type.fs b/src/Brahma.FSharp.OpenCL.Translator/Type.fs index 34f34bd1..065b9603 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/Type.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/Type.fs @@ -57,8 +57,7 @@ module rec Type = do! State.modify (fun ctx -> ctx.Flags.Add EnableFP64 |> ignore - ctx - ) + ctx) return PrimitiveType(Double) :> Type @@ -137,8 +136,7 @@ module rec Type = do! State.modify (fun context -> context.CStructDecls.Add(type', structType) - context - ) + context) return structType } @@ -158,9 +156,12 @@ module rec Type = translation { let! translatedType = translate type' - return { Name = $"_%i{i + 1}"; Type = translatedType } - } - ) + return + { + Name = $"_%i{i + 1}" + Type = translatedType + } + }) |> State.collect let! index = State.gets (fun ctx -> ctx.CStructDecls.Count) @@ -169,8 +170,7 @@ module rec Type = do! State.modify (fun ctx -> ctx.CStructDecls.Add(type', tupleDecl) - ctx - ) + ctx) return tupleDecl } @@ -229,8 +229,7 @@ module rec Type = do! State.modify (fun context -> context.CStructDecls.Add(type', duType) - context - ) + context) return duType :> StructType<_> } diff --git a/src/Brahma.FSharp.OpenCL.Translator/Utils/Extensions.fs b/src/Brahma.FSharp.OpenCL.Translator/Utils/Extensions.fs index a0b10d7c..3bf80c43 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/Utils/Extensions.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/Utils/Extensions.fs @@ -9,7 +9,8 @@ module Extensions = /// Builds an expression that represents the lambda static member Lambdas(args: Var list list, body: Expr) = - let mkRLinear mk (vs, body) = List.foldBack (fun v acc -> mk (v, acc)) vs body + let mkRLinear mk (vs, body) = + List.foldBack (fun v acc -> mk (v, acc)) vs body let mkTupledLambda (args, body) = match args with @@ -23,8 +24,7 @@ module Extensions = tupledArg, (args, [ 0 .. args.Length - 1 ], body) |||> List.foldBack2 (fun var idxInTuple letExpr -> - Expr.Let(var, Expr.TupleGet(Expr.Var tupledArg, idxInTuple), letExpr) - ) + Expr.Let(var, Expr.TupleGet(Expr.Var tupledArg, idxInTuple), letExpr)) ) mkRLinear mkTupledLambda (args, body) diff --git a/src/Brahma.FSharp.OpenCL.Translator/Utils/StateBuilder.fs b/src/Brahma.FSharp.OpenCL.Translator/Utils/StateBuilder.fs index c749dd90..c10dd575 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/Utils/StateBuilder.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/Utils/StateBuilder.fs @@ -33,13 +33,12 @@ module State = let (x, state) = run state s f x, state - let using f x = State <| fun state -> eval (f state) x, state + let using f x = + State <| fun state -> eval (f state) x, state let collect (list: State<'s, 'a> list) = list - |> List.fold - (fun state elem -> state >>= fun state -> elem >>= fun elem -> return' (elem :: state)) - (return' List.empty) + |> List.fold (fun state elem -> state >>= fun state -> elem >>= fun elem -> return' (elem :: state)) (return' List.empty) |> fun args -> map List.rev args type StateBuilder<'state>() = @@ -54,15 +53,13 @@ type StateBuilder<'state>() = let (_, context) = State.run context x1 State.run context x2 - member inline this.Delay(rest) = this.Bind(this.Zero(), (fun () -> rest ())) + member inline this.Delay(rest) = + this.Bind(this.Zero(), (fun () -> rest ())) member inline this.Run(m) = m member this.For(seq: seq<'a>, f) = - this.Bind( - this.Return(seq.GetEnumerator()), - fun en -> this.While((fun () -> en.MoveNext()), this.Delay(fun () -> f en.Current)) - ) + this.Bind(this.Return(seq.GetEnumerator()), (fun en -> this.While((fun () -> en.MoveNext()), this.Delay(fun () -> f en.Current)))) member this.While(cond, body) = if not (cond ()) then diff --git a/src/Brahma.FSharp.OpenCL.Translator/Utils/Utils.fs b/src/Brahma.FSharp.OpenCL.Translator/Utils/Utils.fs index b8c47cb3..84cdbf43 100644 --- a/src/Brahma.FSharp.OpenCL.Translator/Utils/Utils.fs +++ b/src/Brahma.FSharp.OpenCL.Translator/Utils/Utils.fs @@ -19,4 +19,5 @@ module Utils = tp.GetCustomAttributes(false) |> Seq.exists (fun attr -> attr.GetType() = typeof<'attr>) - let roundUp n x = if x % n <> 0 then (x / n) * n + n else x + let roundUp n x = + if x % n <> 0 then (x / n) * n + n else x diff --git a/tests/Brahma.FSharp.Tests/ExecutionTests/AtomicTests.fs b/tests/Brahma.FSharp.Tests/ExecutionTests/AtomicTests.fs index 4cf4eb0d..24d3a45f 100644 --- a/tests/Brahma.FSharp.Tests/ExecutionTests/AtomicTests.fs +++ b/tests/Brahma.FSharp.Tests/ExecutionTests/AtomicTests.fs @@ -104,15 +104,13 @@ let stressTestCases context = range |> List.map (fun size -> testCase $"Smoke stress test (size %i{size}) on atomic 'inc' on int" - <| fun () -> stressTest context <@ inc @> size (fun x -> x + 1) (=) - ) + <| fun () -> stressTest context <@ inc @> size (fun x -> x + 1) (=)) yield! range |> List.map (fun size -> testCase $"Smoke stress test (size %i{size}) on atomic 'dec' on int" - <| fun () -> stressTest context <@ dec @> size (fun x -> x - 1) (=) - ) + <| fun () -> stressTest context <@ dec @> size (fun x -> x - 1) (=)) // float32 yield! @@ -125,8 +123,7 @@ let stressTestCases context = <@ fun x -> x + 1.f @> size (fun x -> x + 1.f) - (fun x y -> float (abs (x - y)) < Accuracy.low.relative) - ) + (fun x y -> float (abs (x - y)) < Accuracy.low.relative)) // double yield! @@ -134,21 +131,14 @@ let stressTestCases context = |> List.map (fun size -> testCase $"Smoke stress test (size %i{size}) on atomic 'inc' on float" <| fun () -> - stressTest - context - <@ fun x -> x + 1. @> - size - (fun x -> x + 1.) - (fun x y -> abs (x - y) < Accuracy.low.relative) - ) + stressTest context <@ fun x -> x + 1. @> size (fun x -> x + 1.) (fun x y -> abs (x - y) < Accuracy.low.relative)) // bool yield! range |> List.map (fun size -> testCase $"Smoke stress test (size %i{size}) on atomic 'not' on bool" - <| fun () -> stressTest context <@ not @> size not (=) - ) + <| fun () -> stressTest context <@ not @> size not (=)) // WrappedInt (не работает транляция или типа того) let wrappedIntInc = <@ fun x -> x + WrappedInt(1) @> @@ -157,8 +147,7 @@ let stressTestCases context = range |> List.map (fun size -> ptestCase $"Smoke stress test (size %i{size}) on custom atomic 'inc' on WrappedInt" - <| fun () -> stressTest context wrappedIntInc size (fun x -> x + WrappedInt(1)) (=) - ) + <| fun () -> stressTest context wrappedIntInc size (fun x -> x + WrappedInt(1)) (=)) // custom int op let incx2 = <@ fun x -> x + 2 @> @@ -167,15 +156,15 @@ let stressTestCases context = range |> List.map (fun size -> testCase $"Smoke stress test (size %i{size}) on atomic unary func on int" - <| fun () -> stressTest context incx2 size (fun x -> x + 2) (=) - ) + <| fun () -> stressTest context incx2 size (fun x -> x + 2) (=)) ] /// Test for add and sub like atomic operations. /// Use local and global atomics, /// use reading from global mem in local atomic let foldTest<'a when 'a: equality and 'a: struct> context f (isEqual: 'a -> 'a -> bool) = - let (.=.) left right = isEqual left right |@ $"%A{left} = %A{right}" + let (.=.) left right = + isEqual left right |@ $"%A{left} = %A{right}" Check.One( Settings.fscheckConfig, diff --git a/tests/Brahma.FSharp.Tests/ExecutionTests/CompilationTests.fs b/tests/Brahma.FSharp.Tests/ExecutionTests/CompilationTests.fs index 12182842..720f5f09 100644 --- a/tests/Brahma.FSharp.Tests/ExecutionTests/CompilationTests.fs +++ b/tests/Brahma.FSharp.Tests/ExecutionTests/CompilationTests.fs @@ -28,7 +28,8 @@ module Helpers = let simpleTests context = [ - let inline checkCode command outFile expected = checkCode context command outFile expected + let inline checkCode command outFile expected = + checkCode context command outFile expected testCase "Pointers to private values should be explicitly private" <| fun () -> diff --git a/tests/Brahma.FSharp.Tests/ExecutionTests/CompositeTypesTests.fs b/tests/Brahma.FSharp.Tests/ExecutionTests/CompositeTypesTests.fs index 1ae7e05e..d2a85536 100644 --- a/tests/Brahma.FSharp.Tests/ExecutionTests/CompositeTypesTests.fs +++ b/tests/Brahma.FSharp.Tests/ExecutionTests/CompositeTypesTests.fs @@ -67,65 +67,37 @@ let tupleTestCases context = testProperty (message "struct(int * int)") <| fun (data: struct (int * int)[]) -> if data.Length <> 0 then - check - data - (fun length -> - <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @> - ) + check data (fun length -> <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @>) testProperty (message "struct(int * int64)") <| fun (data: struct (int * int64)[]) -> if data.Length <> 0 then - check - data - (fun length -> - <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @> - ) + check data (fun length -> <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @>) testProperty (message "struct(bool * bool") <| fun (data: struct (bool * bool)[]) -> if data.Length <> 0 then - check - data - (fun length -> - <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @> - ) + check data (fun length -> <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @>) testProperty (message "struct((int * int) * (int * int))") <| fun (data: struct ((int * int) * (int * int))[]) -> if data.Length <> 0 then - check - data - (fun length -> - <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @> - ) + check data (fun length -> <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @>) testProperty (message "struct((int * int64) * (bool * bool))") <| fun (data: struct ((int * int64) * (bool * bool))[]) -> if data.Length <> 0 then - check - data - (fun length -> - <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @> - ) + check data (fun length -> <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @>) testProperty (message "struct(RecordOfIntInt64 * RecordOfBoolBool)") <| fun (data: struct (RecordOfIntInt64 * RecordOfBoolBool)[]) -> if data.Length <> 0 then - check - data - (fun length -> - <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @> - ) + check data (fun length -> <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @>) testProperty (message "struct(GenericRecord * GenericRecord)") <| fun (data: struct (GenericRecord * GenericRecord)[]) -> if data.Length <> 0 then - check - data - (fun length -> - <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @> - ) + check data (fun length -> <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @>) testProperty (message "struct(int * int64 * bool)") <| fun (data: struct (int * int64 * bool)[]) -> @@ -188,20 +160,12 @@ let recordTestCases context = testProperty (message "GenericRecord") <| fun (data: GenericRecord[]) -> if data.Length <> 0 then - check - data - (fun length -> - <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @> - ) + check data (fun length -> <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @>) testProperty (message "GenericRecord<(int * int64), (bool * bool)>") <| fun (data: GenericRecord<(int * int64), (bool * bool)>[]) -> if data.Length <> 0 then - check - data - (fun length -> - <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @> - ) + check data (fun length -> <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @>) ] let genGenericStruct<'a, 'b> = @@ -219,7 +183,8 @@ let structTests context = [ let inline check data command = check context data command - let inline checkResult cmd input expected = RuntimeTests.Helpers.checkResult context cmd input expected + let inline checkResult cmd input expected = + RuntimeTests.Helpers.checkResult context cmd input expected testCase "Smoke test" <| fun _ -> @@ -296,29 +261,17 @@ let structTests context = testPropertyWithConfig config (message "GenericStruct") <| fun (data: GenericStruct[]) -> if data.Length <> 0 then - check - data - (fun length -> - <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @> - ) + check data (fun length -> <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @>) testPropertyWithConfig config (message "GenericStruct<(int * int64), (bool * bool)>") <| fun (data: GenericStruct<(int * int64), (bool * bool)>[]) -> if data.Length <> 0 then - check - data - (fun length -> - <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @> - ) + check data (fun length -> <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @>) testPropertyWithConfig config (message "GenericStruct") <| fun (data: GenericStruct[]) -> if data.Length <> 0 then - check - data - (fun length -> - <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @> - ) + check data (fun length -> <@ fun (range: Range1D) (buffer: ClArray<_>) -> (%command length) range.GlobalID0 buffer @>) ] type SimpleDU = diff --git a/tests/Brahma.FSharp.Tests/ExecutionTests/ExecutionTests.fs b/tests/Brahma.FSharp.Tests/ExecutionTests/ExecutionTests.fs index 835b60e4..6f73a1c3 100644 --- a/tests/Brahma.FSharp.Tests/ExecutionTests/ExecutionTests.fs +++ b/tests/Brahma.FSharp.Tests/ExecutionTests/ExecutionTests.fs @@ -11,8 +11,7 @@ let allContexts = |> Seq.map (fun device -> let translator = FSQuotationToOpenCLTranslator(device) let clContext = ClContext(device, translator) - RuntimeContext(clContext) - ) + RuntimeContext(clContext)) let tests = [ diff --git a/tests/Brahma.FSharp.Tests/ExecutionTests/RuntimeTests.fs b/tests/Brahma.FSharp.Tests/ExecutionTests/RuntimeTests.fs index ece9cec7..14064697 100644 --- a/tests/Brahma.FSharp.Tests/ExecutionTests/RuntimeTests.fs +++ b/tests/Brahma.FSharp.Tests/ExecutionTests/RuntimeTests.fs @@ -252,14 +252,7 @@ let bindingTests context = let operatorsAndMathFunctionsTests context = let inline checkResult cmd input expected = checkResult context cmd input expected - let binaryOpTestGen - testCase - name - (binop: Expr<'a -> 'a -> 'a>) - (xs: array<'a>) - (ys: array<'a>) - (expected: array<'a>) - = + let binaryOpTestGen testCase name (binop: Expr<'a -> 'a -> 'a>) (xs: array<'a>) (ys: array<'a>) (expected: array<'a>) = testCase name <| fun () -> @@ -342,21 +335,9 @@ let operatorsAndMathFunctionsTests context = unaryOpTestGen testCase "Bitwise NEGATION on int" <@ (~~~) @> <|| ([| 1; 10; 99; 0 |] |> fun array -> array, array |> Array.map (fun x -> -x - 1)) - binaryOpTestGen - testCase - "MAX on float32" - <@ max @> - [| 1.f; 2.f; 3.f; 4.f |] - [| 5.f; 6.f; 7.f; 8.f |] - [| 5.f; 6.f; 7.f; 8.f |] + binaryOpTestGen testCase "MAX on float32" <@ max @> [| 1.f; 2.f; 3.f; 4.f |] [| 5.f; 6.f; 7.f; 8.f |] [| 5.f; 6.f; 7.f; 8.f |] - binaryOpTestGen - testCase - "MIN on float32" - <@ min @> - [| 1.f; 2.f; 3.f; 4.f |] - [| 5.f; 6.f; 7.f; 8.f |] - [| 1.f; 2.f; 3.f; 4.f |] + binaryOpTestGen testCase "MIN on float32" <@ min @> [| 1.f; 2.f; 3.f; 4.f |] [| 5.f; 6.f; 7.f; 8.f |] [| 1.f; 2.f; 3.f; 4.f |] ptestCase "MAX on int16 with const" <| fun () -> @@ -689,7 +670,6 @@ let localMemTests context = output.[range.GlobalID0] <- localBuf.[(range.LocalID0 + 1) % localWorkSize] @> - let expected = [| for x in 1..localWorkSize -> x % localWorkSize |] |> Array.replicate (globalWorkSize / localWorkSize) @@ -1515,8 +1495,7 @@ let simpleDUTests context = if x < 0 then if y < 0 then 0 else y else - x + y - ) + x + y) "Arrays should be equal" |> Expect.sequenceEqual actual expected @@ -1578,8 +1557,7 @@ let simpleDUTests context = if x < 0 then if y < 0 then 0 else y else - x + y - ) + x + y) "Arrays should be equal" |> Expect.sequenceEqual actual expected @@ -1647,8 +1625,7 @@ let simpleDUTests context = if x < 0 then if y < 0 then 0 else y else - x + y - ) + x + y) "Arrays should be equal" |> Expect.sequenceEqual actual expected ] diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Common.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Common.fs index 153109b6..12c910d5 100644 --- a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Common.fs +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Common.fs @@ -11,8 +11,7 @@ module Helpers = let rec renameUnitVar (expr: Expr) = expr.Substitute <| function - | var when var.Type.IsEquivalentTo(typeof) -> - Var("unitVar", var.Type, var.IsMutable) |> Expr.Var |> Some + | var when var.Type.IsEquivalentTo(typeof) -> Var("unitVar", var.Type, var.IsMutable) |> Expr.Var |> Some | _ -> None let var<'t> name = Var(name, typeof<'t>) @@ -24,16 +23,12 @@ module Helpers = Expect.isTrue (actual.Type.IsEquivalentTo(expected.Type)) "Type must be the same" Expect.equal actual.Name expected.Name "Names must be the same" - let openclTransformQuotation (translator: FSQuotationToOpenCLTranslator) (expr: Expr) = - translator.TransformQuotation expr + let openclTransformQuotation (translator: FSQuotationToOpenCLTranslator) (expr: Expr) = translator.TransformQuotation expr let equalAsStrings (actual: Expr) (expected: Expr) (msg: string) = Expect.equal <| actual.ToString() <| expected.ToString() <| msg - let inline typesEqual - (actual: ^a when ^a: (member Type: System.Type)) - (expected: ^b when ^b: (member Type: System.Type)) - = + let inline typesEqual (actual: ^a when ^a: (member Type: System.Type)) (expected: ^b when ^b: (member Type: System.Type)) = Expect.isTrue (actual.Type = expected.Type) "Types must be the same" @@ -51,4 +46,5 @@ module Helpers = varEqual (fst actual) (fst expected) exprEqual (snd actual) (snd expected) - let createMapTestAndCompareAsStrings map name source expected = test name { exprEqual (map source) expected } + let createMapTestAndCompareAsStrings map name source expected = + test name { exprEqual (map source) expected } diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Lifting.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Lifting.fs index e84d7e99..a8ada22f 100644 --- a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Lifting.fs +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Lifting.fs @@ -6,7 +6,8 @@ open Common open FSharp.Quotations let parameterLiftingTests = - let createTest name = createMapTestAndCompareAsStrings Lift.Parameters.lift name + let createTest name = + createMapTestAndCompareAsStrings Lift.Parameters.lift name [ createTest @@ -108,7 +109,8 @@ let parameterLiftingTests = let unitVar name = expVar name let unitCleanUpTests = - let createTest name = createMapTestAndCompareAsStrings Lift.UnitArguments.cleanUp name + let createTest name = + createMapTestAndCompareAsStrings Lift.UnitArguments.cleanUp name [ createTest "Test 1" @@ -141,7 +143,13 @@ let unitCleanUpTests = createTest "Test 7" <| <@ let f (x: unit) (y: unit) (z: unit) = if x = y then z else y in () @> - <| <@ let f (x: unit) = if x = (%unitVar "y") then (%unitVar "z") else (%unitVar "y") in () @> + <| <@ + let f (x: unit) = + if x = (%unitVar "y") then + (%unitVar "z") + else + (%unitVar "y") in () + @> createTest "Test 8" <| <@ let f (x: unit) = let g (y: unit) = Some() in () in () @> diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Print.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Print.fs index b74dda87..96b25776 100644 --- a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Print.fs +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Print.fs @@ -5,7 +5,8 @@ open Brahma.FSharp.OpenCL.Translator.QuotationTransformers let private replaceTests = [ - let inline createTest name = Common.Helpers.createMapTestAndCompareAsStrings Print.replace name + let inline createTest name = + Common.Helpers.createMapTestAndCompareAsStrings Print.replace name let tpArgs: System.Type list = [] let value = "" diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/VarToRef.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/VarToRef.fs index 8b6559d2..e6f54f0e 100644 --- a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/VarToRef.fs +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/VarToRef.fs @@ -5,7 +5,8 @@ open Expecto let private uniquesTests = [ - let inline createTest name = Common.Helpers.createMapTestAndCompareAsStrings VarToRef.transform name + let inline createTest name = + Common.Helpers.createMapTestAndCompareAsStrings VarToRef.transform name createTest "Test 1" // id (no mutable vars) <| <@ diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Variables.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Variables.fs index fe451d6e..e32df0bc 100644 --- a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Variables.fs +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/Variables.fs @@ -5,7 +5,8 @@ open Expecto let private uniquesTests = [ - let createTest name = Common.Helpers.createMapTestAndCompareAsStrings Variables.defsToLambda name + let createTest name = + Common.Helpers.createMapTestAndCompareAsStrings Variables.defsToLambda name createTest "Test 1." <| <@ let x = 1 + 1 in () @> <| <@ let x = 1 + 1 in () @> diff --git a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/WorkSize.fs b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/WorkSize.fs index 7dde9626..64fdf194 100644 --- a/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/WorkSize.fs +++ b/tests/Brahma.FSharp.Tests/Translator/QuatationTransformation/WorkSize.fs @@ -18,7 +18,8 @@ module Helpers = let private workSizeTests = [ - let createTest name = Common.Helpers.createMapTestAndCompareAsStrings WorkSize.get name + let createTest name = + Common.Helpers.createMapTestAndCompareAsStrings WorkSize.get name createTest "Test 1D. Global" <| <@ diff --git a/tests/Brahma.FSharp.Tests/Translator/Specific/MergePath.fs b/tests/Brahma.FSharp.Tests/Translator/Specific/MergePath.fs index c04b1c69..56e5552e 100644 --- a/tests/Brahma.FSharp.Tests/Translator/Specific/MergePath.fs +++ b/tests/Brahma.FSharp.Tests/Translator/Specific/MergePath.fs @@ -69,7 +69,10 @@ let tests = rightEdge <- middleIdx - 1 // Here localID equals either 0 or 1 - if localID = 0 then beginIdxLocal <- leftEdge else endIdxLocal <- leftEdge + if localID = 0 then + beginIdxLocal <- leftEdge + else + endIdxLocal <- leftEdge barrierLocal ()